perl5.000/ 775 203 12 0 5650575761 5357 perl5.000/Artistic 644 203 12 13740 5501156503 7154 The "Artistic License" Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder as specified below. "Copyright Holder" is whoever is named in the copyright or copyrights for the package. "You" is you, if you're thinking about copying or distributing this Package. "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as uunet.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) give non-standard executables non-standard names, and clearly document the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End perl5.000/Changes 664 203 12 16764 5642611037 6761 New things ---------- The -w switch is much more informative. References. See t/op/ref.t for examples. All entities in Perl 5 are reference counted so that it knows when each item should be destroyed. Objects. See t/op/ref.t for examples. => is now a synonym for comma. This is useful as documentation for arguments that come in pairs, such as initializers for associative arrays, or named arguments to a subroutine. All functions have been turned into list operators or unary operators, meaning the parens are optional. Even subroutines may be called as list operators if they've already been declared. More embeddible. See main.c and embed_h.SH. Multiple interpreters in the same process are supported (though not with interleaved execution yet). The interpreter is now flattened out. Compare Perl 4's eval.c with the perl 5's pp.c. Compare Perl 4's 900 line interpreter loop in cmd.c with Perl 5's 1 line interpreter loop in run.c. Eventually we'll make everything non-blocking so we can interface nicely with a scheduler. eval is now treated more like a subroutine call. Among other things, this means you can return from it. Format value lists may be spread over multiple lines by enclosing in a do {} block. You may now define BEGIN and END subroutines for each package. The BEGIN subroutine executes the moment it's parsed. The END subroutine executes just before exiting. Flags on the #! line are interpreted even if the script wasn't executed directly. (And even if the script was located by "perl -x"!) The ?: operator is now legal as an lvalue. List context now propagates to the right side of && and ||, as well as the 2nd and 3rd arguments to ?:. The "defined" function can now take a general expression. Lexical scoping available via "my". eval can see the current lexical variables. The preferred package delimiter is now :: rather than '. tie/untie are now preferred to dbmopen/dbmclose. Multiple DBM implementations are allowed in the same executable, so you can write scripts to interchange data among different formats. New "and" and "or" operators work just like && and || but with a precedence lower than comma, so they work better with list operators. New functions include: abs(), chr(), uc(), ucfirst(), lc(), lcfirst(), chomp(), glob() require with a number checks to see that the version of Perl that is currently running is at least that number. Dynamic loading of external modules is now supported. There is a new quote form qw//, which is equivalent to split(' ', q//). Assignment of a reference to a glob value now just replaces the single element of the glob corresponding to the reference type: *foo = \$bar, *foo = \&bletch; Filehandle methods are now supported: output_autoflush STDOUT 1; There is now an "English" module that provides human readable translations for cryptic variable names. Autoload stubs can now call the replacement subroutine with goto &realsub. Subroutines can be defined lazily in any package by declaring an AUTOLOAD routine, which will be called if a non-existent subroutine is called in that package. Several previously added features have been subsumed under the new keywords "use" and "no". Saying "use Module LIST" is short for BEGIN { require Module; import Module LIST; } The "no" keyword is identical except that it calls "unimport" instead. The earlier pragma mechanism now uses this mechanism, and two new modules have been added to the library to implement "use integer" and variations of "use strict vars, refs, subs". Variables may now be interpolated literally into a pattern by prefixing them with \Q, which works just like \U, but backwhacks non-alphanumerics instead. There is also a corresponding quotemeta function. Any quantifier in a regular expression may now be followed by a ? to indicate that the pattern is supposed to match as little as possible. Pattern matches may now be followed by an m or s modifier to explicitly request multiline or singleline semantics. An s modifier makes . match newline. Patterns may now contain \A to match only at the beginning of the string, and \Z to match only at the end. These differ from ^ and $ in that they ignore multiline semantics. In addition, \G matches where the last interation of m//g or s///g left off. Non-backreference-producing parens of various sorts may now be indicated by placing a ? directly after the opening parenthesis, followed by a character that indicates the purpose of the parens. An :, for instance, indicates simple grouping. (?:a|b|c) will match any of a, b or c without producing a backreference. It does "eat" the input. There are also assertions which do not eat the input but do lookahead for you. (?=stuff) indicates that the next thing must be "stuff". (?!nonsense) indicates that the next thing must not be "nonsense". The negation operator now treats non-numeric strings specially. A -"text" is turned into "-text", so that -bareword is the same as "-bareword". If the string already begins with a + or -, it is flipped to the other sign. Incompatibilities ----------------- @ now always interpolates an array in double-quotish strings. Some programs may now need to use backslash to protect any @ that shouldn't interpolate. Ordinary variables starting with underscore are no longer forced into package main. s'$lhs'$rhs' now does no interpolation on either side. It used to interplolate $lhs but not $rhs. The second and third arguments of splice are now evaluated in scalar context (like the book says) rather than list context. Saying "shift @foo + 20" is now a semantic error because of precedence. "open FOO || die" is now incorrect. You need parens around the filehandle. The elements of argument lists for formats are now evaluated in list context. This means you can interpolate list values now. You can't do a goto into a block that is optimized away. Darn. It is no longer syntactically legal to use whitespace as the name of a variable, or as a delimiter for any kind of quote construct. Some error messages will be different. The caller function now returns a false value in a scalar context if there is no caller. This lets library files determine if they're being required. m//g now attaches its state to the searched string rather than the regular expression. "reverse" is no longer allowed as the name of a sort subroutine. taintperl is no longer a separate executable. There is now a -T switch to turn on tainting when it isn't turned on automatically. Symbols starting with _ are no longer forced into package main, except for $_ itself (and @_, etc.). Double-quoted strings may no longer end with an unescaped $ or @. Negative array subscripts now count from the end of the array. The comma operator in a scalar context is now guaranteed to give a scalar context to its arguments. The ** operator now binds more tightly than unary minus. Setting $#array lower now discards array elements so that destructors work reasonably. delete is not guaranteed to return the old value for tied arrays, since this capability may be onerous for some modules to implement. Attempts to set $1 through $9 now result in a run-time error. perl5.000/Configure 775 203 12 500066 5647030615 7350 #! /bin/sh # # If these # comments don't work, trim them. Don't worry about any other # shell scripts, Configure will trim # comments from them for you. # # (If you are trying to port this package to a machine without sh, # I would suggest you have a look at the prototypical config_h.SH file # and edit it to reflect your system. Some packages may include samples # of config.h for certain machines, so you might look for one of those.) # # Yes, you may rip this off to use in other distribution packages. This # script belongs to the public domain and cannot be copyrighted. # # (Note: this Configure script was generated automatically. Rather than # working with this copy of Configure, you may wish to get metaconfig. # The dist-3.0 package (which contains metaconfig) was posted in # comp.sources.misc so you may fetch it yourself from your nearest # archive site. Check with Archie if you don't know where that can be.) # # $Id: Head.U,v 3.0.1.5 1994/08/29 16:03:44 ram Exp $ # # Generated on Tue Oct 11 22:49:31 EDT 1994 [metaconfig 3.0 PL35] cat >/tmp/c1$$ </tmp/c2$$ </dev/null` test "$me" || me=$0 ;; esac : Proper PATH setting paths='/bin /usr/bin /usr/local/bin /usr/ucb /usr/local /usr/lbin' paths=$paths:'/usr/5bin /etc /usr/gnu/bin /usr/new /usr/new/bin /usr/nbin' paths=$paths:'/sys5.3/bin /sys5.3/usr/bin /bsd4.3/bin /bsd4.3/usr/ucb' paths=$paths:'/bsd4.3/usr/bin /usr/bsd /bsd43/bin /usr/ccs/bin' paths=$paths:'/etc /usr/lib /usr/ucblib /lib /usr/ccs/lib' paths=$paths:'/sbin /usr/sbin /usr/libexec' for p in $paths do case ":$PATH:" in *:$p:*) ;; *) test -d $p && PATH=$PATH:$p ;; esac done PATH=.:$PATH export PATH : Sanity checks if test ! -t 0; then echo "Say 'sh $me', not 'sh <$me'" exit 1 fi : On HP-UX, large Configure scripts may exercise a bug in /bin/sh if test -f /hp-ux -a -f /bin/ksh; then if (PATH=.; alias -x) >/dev/null 2>&1; then : already under /bin/ksh else cat <<'EOM' (Feeding myself to ksh to avoid nasty sh bug in "here document" expansion.) EOM exec /bin/ksh $0 "$@" fi else : Warn them if they use ksh on other systems (PATH=.; alias -x) >/dev/null 2>&1 && \ cat <extract <<'EOS' CONFIG=true echo "Doing variable substitutions on .SH files..." if test -f MANIFEST; then shlist=`awk '{print $1}' options.awk <<'EOF' BEGIN { optstr = "deEf:hrsSD:U:V"; # getopt-style specification len = length(optstr); for (i = 1; i <= len; i++) { c = substr(optstr, i, 1); if (i < len) a = substr(optstr, i + 1, 1); else a = ""; if (a == ":") { arg[c] = 1; i++; } opt[c] = 1; } } { expect = 0; str = $0; if (substr(str, 1, 1) != "-") { printf("'%s'\n", str); next; } len = length($0); for (i = 2; i <= len; i++) { c = substr(str, i, 1); if (!opt[c]) { printf("-%s\n", substr(str, i)); next; } printf("-%s\n", c); if (arg[c]) { if (i < len) printf("'%s'\n", substr(str, i + 1)); else expect = 1; next; } } } END { if (expect) print "?"; } EOF : process the command line options set X `for arg in "$@"; do echo $arg; done | awk -f options.awk` eval "set $*" shift rm -f options.awk : set up default values fastread='' reuseval=false config_sh='' alldone='' error='' silent='' extractsh='' optdef='optdef.sh' : option parsing while test $# -gt 0; do case "$1" in -d) shift; fastread=yes;; -e) shift; alldone=cont;; -f) shift cd .. if test -r "$1"; then config_sh="$1" else echo "$me: cannot read config file $1." >&2 error=true fi cd UU shift;; -h) shift; error=true;; -r) shift; reuseval=true;; -s) shift; silent=true;; -E) shift; alldone=exit;; -S) shift; extractsh=true;; -D) shift case "$1" in *=) echo "$me: use '-U symbol=', not '-D symbol='." >&2 echo "$me: ignoring -D $1" >&2 ;; *=*) echo "$1" >> $optdef;; *) echo "$1='define'" >> $optdef;; esac shift ;; -U) shift case "$1" in *=) echo "$1" >> $optdef;; *=*) echo "$me: use '-D symbol=val', not '-U symbol=val'." >&2 echo "$me: ignoring -U $1" >&2 ;; *) echo "$1='undef'" >> $optdef;; esac shift ;; -V) echo "$me generated by metaconfig 3.0 PL35." >&2 exit 0;; --) break;; -*) echo "$me: unknown option $1" >&2; shift; error=true;; *) break;; esac done case "$error" in true) cat >&2 <&1 case "$silent" in true) exec 1>/dev/null;; esac : run the defines and the undefines, if any touch $optdef . ./$optdef rm -f $optdef case "$extractsh" in true) case "$config_sh" in '') config_sh='config.sh'; config='./config.sh';; /*) config="$config_sh";; *) config="./$config_sh";; esac echo " " echo "Fetching answers from $config_sh..." cd .. . $config echo " " . ./UU/extract rm -rf UU echo "Done." exit 0 ;; esac : set package name package=perl5 : Eunice requires " " instead of "", can you believe it echo " " : Here we go... echo "Beginning of configuration questions for $package." define='define' undef='undef' smallmach='pdp11 i8086 z8000 i80286 iAPX286' rmlist='' trap 'echo " "; rm -rf $rmlist; exit 1' 1 2 3 15 : We must find out about Eunice early eunicefix=':' if test -f /etc/unixtovms; then eunicefix=/etc/unixtovms fi if test -f /etc/unixtovms.exe; then eunicefix=/etc/unixtovms.exe fi : list of known cpp symbols al="AMIX BIT_MSF BSD BSD4_3 BSD_NET2 CRAY DGUX DOLPHIN DPX2" al="$al GO32 HP700 I386 I80960 I960 Lynx M68000 M68K MACH" al="$al MIPSEB MIPSEL MSDOS MTXINU MVS" al="$al M_COFF M_I186 M_I286 M_I386 M_I8086 M_I86 M_I86SM" al="$al M_SYS3 M_SYS5 M_SYSIII M_SYSV M_UNIX M_XENIX" al="$al NeXT OCS88 OSF1 PARISC PC532 PORTAR POSIX" al="$al PWB R3000 SVR3 SVR4" al="$al SYSTYPE_BSD SYSTYPE_SVR4 SYSTYPE_SYSV" al="$al UTEK UTS UTek UnicomPBB UnicomPBD Utek VMS" al="$al _AIX _AIX32 _AM29000 _COFF _CRAY _EPI _IBMR2" al="$al _MIPSEB _MIPSEL _M_COFF _M_I86 _M_I86SM _M_SYS3" al="$al _M_SYS5 _M_SYSIII _M_SYSV _M_UNIX _M_XENIX _R3000" al="$al _SYSTYPE_BSD _SYSTYPE_BSD43 _SYSTYPE_SVR4" al="$al _SYSTYPE_SYSV _SYSV3 _UNICOS" al="$al __386BSD__ __BIG_ENDIAN __BIG_ENDIAN__ __BSD_4_4__" al="$al __DGUX__ __DPX2__ __H3050R __H3050RX" al="$al __LITTLE_ENDIAN __LITTLE_ENDIAN__ __MACH__" al="$al __MIPSEB __MIPSEB__ __MIPSEL __MIPSEL__" al="$al __Next__ __OSF1__ __PARAGON__ __PWB __STDC__" al="$al ____386BSD____ __alpha __alpha__ __amiga" al="$al __bsd4_2 __bsd4_2__ __bsdi__ __convex__" al="$al __host_mips__" al="$al __hp9000s200 __hp9000s300 __hp9000s400 __hp9000s500" al="$al __hp9000s500 __hp9000s700 __hp9000s800" al="$al __hppa __hpux __i286 __i286__ __i386 __i386__" al="$al __i486 __i486__ __i860 __i860__" al="$al __m68k __m68k__ __m88100__ __m88k __m88k__" al="$al __mc68000 __mc68000__ __mc68020 __mc68020__" al="$al __mc68030 __mc68030__ __mc68040 __mc68040__" al="$al __mc88100 __mc88100__ __mips __mips__" al="$al __motorola__ __osf__ __pa_risc __sparc__ __stdc__" al="$al __sun __sun__ __svr3__ __svr4__ __ultrix __ultrix__" al="$al __unix __unix__ __vax __vax__" al="$al _host_mips _mips _unix" al="$al a29k aegis alliant am29000 amiga ansi" al="$al bsd bsd43 bsd4_2 bsd4_3 bsd4_4 bull" al="$al convex cray ctix encore gcos gimpel" al="$al hcx host_mips hp200 hp300 hp700 hp800" al="$al hp9000 hp9000s300 hp9000s400 hp9000s500" al="$al hp9000s700 hp9000s800 hp9k8 hpux" al="$al i186 i286 i386 i486 i8086" al="$al i80960 i860 iAPX286 ibm interdata is68k" al="$al linux luna luna88k m68k m88100 m88k" al="$al mc300 mc500 mc68000 mc68010 mc68020 mc68030" al="$al mc68040 mc68060 mc68k mc68k32 mc700" al="$al mc88000 mc88100 merlin mert mips mvs n16" al="$al ncl_el ncl_mr" al="$al news1500 news1700 news1800 news1900 news3700" al="$al news700 news800 news900 ns16000 ns32000" al="$al ns32016 ns32332 ns32k nsc32000 os osf" al="$al parisc pc532 pdp11 plexus posix pyr" al="$al riscix riscos sequent sgi sinix sony sony_news" al="$al sonyrisc sparc sparclite spectrum stratos" al="$al sun sun3 sun386 svr4 sysV68 sysV88" al="$al tower tower32 tower32_200 tower32_600 tower32_700" al="$al tower32_800 tower32_850 tss u3b u3b2 u3b20 u3b200" al="$al u3b5 ultrix unix unixpc unos vax venix vms" al="$al xenix z8000" i_whoami='' : change the next line if compiling for Xenix/286 on Xenix/386 xlibpth='/usr/lib/386 /lib/386' : general looking path for locating libraries glibpth="/lib/pa1.1 /usr/lib/large /lib /usr/lib $xlibpth" glibpth="$glibpth /lib/large /usr/lib/small /lib/small" glibpth="$glibpth /usr/ccs/lib /usr/ucblib /usr/local/lib /usr/shlib" : Private path used by Configure to find libraries. Its value : is prepended to libpth. This variable takes care of special : machines, like the mips. Usually, it should be empty. plibpth='' : full support for void wanted by default defvoidused=15 : set useposix=false in your hint file to disable the POSIX extension. useposix=true gccversion='' : no include file wanted by default inclwanted='' groupstype='' : default library list libswanted='' : List of libraries we want. libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl' libswanted="$libswanted dld ld sun m c cposix posix ndir dir crypt" libswanted="$libswanted ucb bsd BSD PW x" : We want to search /usr/shlib before most other libraries. : This is only used by ext/util/extliblist glibpth=`echo " $glibpth " | sed -e 's! /usr/shlib ! !'` glibpth="/usr/shlib $glibpth" : Do not use vfork unless overridden by a hint file. usevfork=false : We can look for titanos too. al="$al ardent titan" : Some greps do not return status, grrr. echo "grimblepritz" >grimble if grep blurfldyick grimble >/dev/null 2>&1 ; then contains=contains elif grep grimblepritz grimble >/dev/null 2>&1 ; then contains=grep else contains=contains fi rm -f grimble : the following should work in any shell case "$contains" in contains*) echo " " echo "AGH! Grep doesn't return a status. Attempting remedial action." cat >contains <<'EOSS' grep "$1" "$2" >.greptmp && cat .greptmp && test -s .greptmp EOSS chmod +x contains esac : first determine how to suppress newline on echo command echo " " echo "Checking echo to see how to suppress newlines..." (echo "hi there\c" ; echo " ") >.echotmp if $contains c .echotmp >/dev/null 2>&1 ; then echo "...using -n." n='-n' c='' else cat <<'EOM' ...using \c EOM n='' c='\c' fi echo $n "The star should be here-->$c" echo '*' rm -f .echotmp : Now test for existence of everything in MANIFEST echo " " if test -f ../MANIFEST; then echo "First let's make sure your kit is complete. Checking..." >&4 awk '$1 !~ /PACK[A-Z]+/ {print $1}' ../MANIFEST | split -50 rm -f missing for filelist in x??; do (cd ..; ls `cat UU/$filelist` >/dev/null 2>>UU/missing) done if test -s missing; then cat missing >&4 cat >&4 <<'EOM' THIS PACKAGE SEEMS TO BE INCOMPLETE. You have the option of continuing the configuration process, despite the distinct possibility that your kit is damaged, by typing 'y'es. If you do, don't blame me if something goes wrong. I advise you to type 'n'o and contact the author (lwall@netlabs.com). EOM echo $n "Continue? [n] $c" >&4 read ans case "$ans" in y*) echo "Continuing..." >&4 rm -f missing ;; *) echo "ABORTING..." >&4 kill $$ ;; esac else echo "Looks good..." >&4 fi else echo "There is no MANIFEST file. I hope your kit is complete !" fi rm -f missing x?? : compute the number of columns on the terminal for proper question formatting case "$COLUMNS" in '') COLUMNS='80';; esac : set up the echo used in my read myecho="case \"\$xxxm\" in '') echo $n \"\$rp $c\" >&4;; *) case \"\$rp\" in '') echo $n \"[\$xxxm] $c\";; *) if test \`echo \"\$rp [\$xxxm] \" | wc -c\` -ge $COLUMNS; then echo \"\$rp\" >&4 echo $n \"[\$xxxm] $c\" >&4 else echo $n \"\$rp [\$xxxm] $c\" >&4 fi ;; esac;; esac" : now set up to do reads with possible shell escape and default assignment cat <myread xxxm=\$dflt $myecho ans='!' case "\$fastread" in yes) case "\$dflt" in '') ;; *) ans=''; case "\$silent-\$rp" in true-) ;; *) echo " " >&4;; esac;; esac;; *) case "\$silent" in true) case "\$rp" in '') ans='';; esac;; esac;; esac while expr "X\$ans" : "X!" >/dev/null; do read answ set x \$xxxm shift aok=''; eval "ans=\"\$answ\"" && aok=y case "\$answ" in "\$ans") case "\$ans" in "!") sh 1>&4 echo " " $myecho ;; !*) set x \`expr "X\$ans" : "X!\(.*\)\$"\` shift sh 1>&4 -c "\$*" echo " " $myecho ;; esac;; *) case "\$aok" in y) echo "*** Substitution done -- please confirm." xxxm="\$ans" ans=\`echo $n "\$ans$c" | tr '\012' ' '\` xxxm="\$ans" ans=! ;; *) echo "*** Error -- try again." ans=! ;; esac $myecho ;; esac case "\$ans\$xxxm\$nostick" in '') ans=! $myecho ;; esac done case "\$ans" in '') ans="\$xxxm";; esac EOSC : create .config dir to save info across Configure sessions test -d ../.config || mkdir ../.config cat >../.config/README </dev/null || whoami) 2>&1` if $contains "^$user\$" ../.config/instruct >/dev/null 2>&1; then firsttime=false echo " " rp='Would you like to see the instructions?' dflt=n . ./myread case "$ans" in [yY]*) ;; *) needman=false;; esac fi if $needman; then cat <>../.config/instruct;; esac fi : see if sh knows # comments echo " " echo "Checking your sh to see if it knows about # comments..." >&4 if sh -c '#' >/dev/null 2>&1 ; then echo "Your sh handles # comments correctly." shsharp=true spitshell=cat echo " " echo "Okay, let's see if #! works on this system..." xcat=/bin/cat test -r $xcat || xcat=/usr/bin/cat echo "#!$xcat" >try $eunicefix try chmod +x try ./try > today if test -s today; then echo "It does." sharpbang='#!' else echo "#! $xcat" > try $eunicefix try chmod +x try ./try > today if test -s today; then echo "It does." sharpbang='#! ' else echo "It's just a comment." sharpbang=': use ' fi fi else echo "Your sh doesn't grok # comments--I will strip them later on." shsharp=false cd .. echo "exec grep -v '^[ ]*#'" >spitshell chmod +x spitshell $eunicefix spitshell spitshell=`pwd`/spitshell cd UU echo "I presume that if # doesn't work, #! won't work either!" sharpbang=': use ' fi rm -f try today : figure out how to guarantee sh startup echo " " echo "Checking out how to guarantee sh startup..." >&4 case "$SYSTYPE" in *bsd*|sys5*) startsh=$sharpbang"/$SYSTYPE/bin/sh";; *) startsh=$sharpbang'/bin/sh';; esac echo "Let's see if '$startsh' works..." cat >try <&4 cat <loc $startsh case \$# in 0) exit 1;; esac thing=\$1 shift dflt=\$1 shift for dir in \$*; do case "\$thing" in .) if test -d \$dir/\$thing; then echo \$dir exit 0 fi ;; *) for thisthing in \$dir/\$thing; do : Just loop through to pick last element done if test -f \$thisthing; then echo \$thisthing exit 0 elif test -f \$dir/\$thing.exe; then : on Eunice apparently echo \$dir/\$thing exit 0 fi ;; esac done echo \$dflt exit 1 EOSC chmod +x loc $eunicefix loc loclist=" awk cat cp echo expr find grep ln ls mkdir rm sed sort touch tr uniq " trylist=" Mcc bison byacc cpp csh date egrep line nroff perl test uname " pth=`echo $PATH | sed -e 's/:/ /g'` pth="$pth /lib /usr/lib" for file in $loclist; do xxx=`./loc $file $file $pth` eval $file=$xxx eval _$file=$xxx case "$xxx" in /*) echo $file is in $xxx. ;; *) echo "I don't know where $file is. I hope it's in everyone's PATH." ;; esac done echo " " echo "Don't worry if any of the following aren't found..." say=offhand for file in $trylist; do xxx=`./loc $file $file $pth` eval $file=$xxx eval _$file=$xxx case "$xxx" in /*) echo $file is in $xxx. ;; *) echo "I don't see $file out there, $say." say=either ;; esac done case "$egrep" in egrep) echo "Substituting grep for egrep." egrep=$grep ;; esac case "$test" in test) echo "Hopefully test is built into your sh." ;; *) if sh -c "PATH= test true" >/dev/null 2>&1; then echo "Using the test built into your sh." test=test _test=test fi ;; esac case "$echo" in echo) echo "Hopefully echo is built into your sh." ;; '') ;; *) echo " " echo "Checking compatibility between $echo and builtin echo (if any)..." >&4 $echo $n "hi there$c" >foo1 echo $n "hi there$c" >foo2 if cmp foo1 foo2 >/dev/null 2>&1; then echo "They are compatible. In fact, they may be identical." else case "$n" in '-n') n='' c='\c';; *) n='-n' c='';; esac cat <$c" $echo "*" fi $rm -f foo1 foo2 ;; esac : determine whether symbolic links are supported echo " " $touch blurfl if $ln -s blurfl sym > /dev/null 2>&1 ; then echo "Symbolic links are supported." >&4 lns="$ln -s" else echo "Symbolic links are NOT supported." >&4 lns="$ln" fi $rm -f blurfl sym : Try to determine whether config.sh was made on this system case "$config_sh" in '') myuname=`( ($uname -a) 2>/dev/null || hostname) 2>&1` myuname=`echo $myuname | $sed -e 's/^[^=]*=//' -e 's/\///g' | \ tr '[A-Z]' '[a-z]' | tr '\012' ' '` dflt=n if test -f ../config.sh; then oldmyuname='' if $contains myuname= ../config.sh >/dev/null 2>&1; then eval "old`grep myuname= ../config.sh`" fi if test "X$myuname" = "X$oldmyuname"; then dflt=y fi fi : Get old answers from old config file if Configure was run on the : same system, otherwise use the hints. hint=default cd .. if test -f config.sh; then echo " " rp="I see a config.sh file. Shall I use it to set the defaults?" . UU/myread case "$ans" in n*|N*) echo "OK, I'll ignore it."; mv config.sh config.sh.old;; *) echo "Fetching default answers from your old config.sh file..." >&4 tmp="$n" tans="$c" . ./config.sh cp config.sh UU n="$tmp" c="$tans" hint=previous ;; esac fi if test ! -f config.sh; then $cat <&4 dflt='' : Half the following guesses are probably wrong... If you have better : tests or hints, please send them to lwall@netlabs.com : The metaconfig authors would also appreciate a copy... $test -f /irix && osname=irix $test -f /xenix && osname=sco_xenix $test -f /dynix && osname=dynix $test -f /dnix && osname=dnix $test -f /unicos && osname=unicos && osvers=`$uname -r` $test -f /bin/mips && /bin/mips && osname=mips $test -d /NextApps && set X `hostinfo | grep 'NeXT Mach.*:' | sed -e 's/://' -e 's/\./_/'` && osname=next && osvers=$4 $test -d /usr/apollo/bin && osname=apollo $test -f /etc/saf/_sactab && osname=svr4 $test -d /usr/include/minix && osname=minix if $test -f $uname; then set X $myuname shift case "$5" in fps*) osname=fps ;; mips*) case "$4" in umips) osname=umips ;; *) osname=mips ;; esac;; [23]100) osname=mips ;; next*) osname=next ;; news*) osname=news ;; i386*) if $test -f /etc/kconfig; then osname=isc if test "$lns" = "ln -s"; then osvers=4 elif $contains _SYSV3 /usr/include/stdio.h > /dev/null 2>&1 ; then osvers=3 elif $contains _POSIX_SOURCE /usr/include/stdio.h > /dev/null 2>&1 ; then osvers=2 fi fi ;; esac case "$1" in aix) osname=aix tmp=`( (oslevel) 2>/dev/null || echo "not found") 2>&1` case "$tmp" in 'not found') osvers=3.2.0 ;; '<3240'|'<>3240') osvers=3.2.0 ;; '=3240'|'>3240'|'<3250'|'<>3250') osvers=3.2.4 ;; '=3250'|'>3250') osvers=3.2.5 ;; *) osvers='' ;; esac ;; dnix) osname=dnix osvers="$3" ;; domainos) osname=apollo osvers="$3" ;; dgux) osname=dgux osvers="$3" ;; freebsd) osname=freebsd osvers="$3" ;; genix) osname=genix ;; hp*) osname=hpux case "$3" in *.08.*) osvers=9 ;; *.09.*) osvers=9 ;; *.10.*) osvers=10 ;; esac ;; irix) osname=irix case "$3" in 4*) osvers=4 ;; 5*) osvers=5 ;; esac ;; linux) osname=linux case "$3" in 1*) osvers=1 ;; *) osvers="$3" ;; esac ;; netbsd*) osname=netbsd osvers="$3" ;; bsd386) osname=bsd386 osvers=`$uname -r` ;; next*) osname=next ;; solaris) osname=solaris case "$3" in 5*) osvers=`echo $3 | $sed 's/^5/2/g'` ;; esac ;; sunos) osname=sunos case "$3" in 5*) osname=solaris osvers=`echo $3 | $sed 's/^5/2/g'` ;; *) osvers="$3" ;; esac ;; titanos) osname=titanos case "$3" in 1*) osvers=1 ;; 2*) osvers=2 ;; 3*) osvers=3 ;; 4*) osvers=4 ;; esac ;; ultrix) osname=ultrix case "$3" in 1*) osvers=1 ;; 2*) osvers=2 ;; 3*) osvers=3 ;; 4*) osvers=4 ;; esac ;; osf1) case "$5" in alpha) osname=dec_osf case "$3" in [vt]1\.*) osvers=1 ;; [vt]2\.*) osvers=2 ;; [vt]3\.*) osvers=3 ;; esac ;; hp*) osname=hp_osf1 ;; # TR mips) osname=mips_osf1 ;; # TR # TR = Technology Releases: unsupported esac ;; uts) osname=uts osvers="$3" ;; $2) case "$osname" in *isc*) ;; *freebsd*) ;; svr*) : svr4.x or possibly later case "svr$3" in ${osname}*) osname=svr$3 osvers=$4 ;; esac case "$osname" in svr4.0) : Check for ESIX if test -f /stand/boot ; then eval `grep '^INITPROG=[a-z/0-9]*$' /stand/boot` if test -n $INITPROG -a -f $INITPROG; then isesix=`strings -a $INITPROG|grep 'ESIX SYSTEM V/386 Release 4.0'` if test -n $isesix; then osname=esix4 fi fi fi ;; esac ;; *) if test -f /etc/systemid; then osname=sco set `echo $3 | $sed 's/\./ /g'` $4 if $test -f sco_$1_$2_$3.sh; then osvers=$1.$2.$3 elif $test -f sco_$1_$2.sh; then osvers=$1.$2 elif $test -f sco_$1.sh; then osvers=$1 fi else case "$osname" in '') : Still unknown. Probably a generic Sys V. osname="sysv" osvers="$3" ;; esac fi ;; esac ;; *) case "$osname" in '') : Still unknown. Probably a generic BSD. osname="$1" osvers="$3" ;; esac ;; esac else if test -f /vmunix -a -f news_os.sh; then (what /vmunix | tr '[A-Z]' '[a-z]') > ../UU/kernel.what 2>&1 if $contains news-os ../UU/kernel.what >/dev/null 2>&1; then osname=news_os fi $rm -f ../UU/kernel.what fi fi : Now look for a hint file osname_osvers, unless one has been : specified already. case "$hintfile" in ''|' ') file=`echo "${osname}_${osvers}" | sed -e 's@\.@_@g' -e 's@_$@@'` : Also try without trailing minor version numbers. xfile=`echo $file | sed -e 's@_[^_]*$@@'` xxfile=`echo $xfile | sed -e 's@_[^_]*$@@'` xxxfile=`echo $xxfile | sed -e 's@_[^_]*$@@'` xxxxfile=`echo $xxxfile | sed -e 's@_[^_]*$@@'` case "$file" in '') dflt=none ;; *) case "$osvers" in '') dflt=$file ;; *) if $test -f $file.sh ; then dflt=$file elif $test -f $xfile.sh ; then dflt=$xfile elif $test -f $xxfile.sh ; then dflt=$xxfile elif $test -f $xxxfile.sh ; then dflt=$xxxfile elif $test -f $xxxxfile.sh ; then dflt=$xxxxfile elif $test -f "${osname}.sh" ; then dflt="${osname}" else dflt=none fi ;; esac ;; esac ;; *) dflt=`echo $hintfile | sed 's/\.sh$//'` ;; esac $cat <> ../UU/config.sh elif $test X$tans = X -o X$tans = Xnone ; then : nothing else : Give one chance to correct a possible typo. echo "$file.sh does not exist" dflt=$file rp="hint to use instead?" . ../UU/myread for file in $ans; do if $test -f "$file.sh"; then . ./$file.sh $cat $file.sh >> ../UU/config.sh elif $test X$ans = X -o X$ans = Xnone ; then : nothing else echo "$file.sh does not exist -- ignored." fi done fi done hint=recommended : Remember our hint file for later. if $test -f "$file.sh" ; then hintfile="$file" else hintfile='' fi cd .. fi cd UU ;; *) echo " " echo "Fetching default answers from $config_sh..." >&4 tmp="$n" tans="$c" cd .. cp $config_sh config.sh 2>/dev/null . ./config.sh cd UU cp ../config.sh . n="$tmp" c="$tans" hint=previous ;; esac : Restore computed paths for file in $loclist $trylist; do eval $file="\$_$file" done cat << EOM Configure uses the operating system name and version to set some defaults. Say "none" to leave it blank. EOM case "$osname" in ''|' ') case "$hintfile" in ''|' '|none) dflt=none ;; *) dflt=`echo $hintfile | sed -e 's/\.sh$//' -e 's/_.*$//'` ;; esac ;; *) dflt="$osname" ;; esac rp="Operating system name?" . ./myread case "$ans" in none) osname='' ;; *) osname="$ans" ;; esac : who configured the system cf_time=`$date 2>&1` (logname > .temp) >/dev/null 2>&1 $test -s .temp || (whoami > .temp) >/dev/null 2>&1 $test -s .temp || echo unknown > .temp cf_by=`$cat .temp` $rm -f .temp : determine where manual pages are on this system echo " " case "$sysman" in '') syspath='/usr/man/man1 /usr/man/mann /usr/man/manl /usr/man/local/man1' syspath="$syspath /usr/man/u_man/man1 /usr/share/man/man1" syspath="$syspath /usr/catman/u_man/man1 /usr/man/l_man/man1" syspath="$syspath /usr/local/man/u_man/man1 /usr/local/man/l_man/man1" syspath="$syspath /usr/man/man.L /local/man/man1 /usr/local/man/man1" sysman=`./loc . /usr/man/man1 $syspath` ;; esac if $test -d "$sysman"; then echo "System manual is in $sysman." >&4 else echo "Could not find manual pages in source form." >&4 fi : see what memory models we can support case "$models" in '') $cat >pdp11.c <<'EOP' main() { #ifdef pdp11 exit(0); #else exit(1); #endif } EOP cc -o pdp11 pdp11.c >/dev/null 2>&1 if ./pdp11 2>/dev/null; then dflt='unsplit split' else tans=`./loc . X /lib/small /lib/large /usr/lib/small /usr/lib/large /lib/medium /usr/lib/medium /lib/huge` case "$tans" in X) dflt='none';; *) if $test -d /lib/small || $test -d /usr/lib/small; then dflt='small' else dflt='' fi if $test -d /lib/medium || $test -d /usr/lib/medium; then dflt="$dflt medium" fi if $test -d /lib/large || $test -d /usr/lib/large; then dflt="$dflt large" fi if $test -d /lib/huge || $test -d /usr/lib/huge; then dflt="$dflt huge" fi esac fi;; *) dflt="$models";; esac $cat </dev/null 2>&1 || \ $contains '\-i' $sysman/cc.1 >/dev/null 2>&1; then dflt='-i' else dflt='none' fi;; *) dflt="$split";; esac rp="What flag indicates separate I and D space?" . ./myread tans="$ans" case "$tans" in none) tans='';; esac split="$tans" unsplit='';; *large*|*small*|*medium*|*huge*) case "$models" in *large*) case "$large" in '') dflt='-Ml';; *) dflt="$large";; esac rp="What flag indicates large model?" . ./myread tans="$ans" case "$tans" in none) tans=''; esac large="$tans";; *) large='';; esac case "$models" in *huge*) case "$huge" in '') dflt='-Mh';; *) dflt="$huge";; esac rp="What flag indicates huge model?" . ./myread tans="$ans" case "$tans" in none) tans=''; esac huge="$tans";; *) huge="$large";; esac case "$models" in *medium*) case "$medium" in '') dflt='-Mm';; *) dflt="$medium";; esac rp="What flag indicates medium model?" . ./myread tans="$ans" case "$tans" in none) tans=''; esac medium="$tans";; *) medium="$large";; esac case "$models" in *small*) case "$small" in '') dflt='none';; *) dflt="$small";; esac rp="What flag indicates small model?" . ./myread tans="$ans" case "$tans" in none) tans=''; esac small="$tans";; *) small='';; esac ;; *) echo "Unrecognized memory models--you may have to edit Makefile.SH" >&4 ;; esac : make some quick guesses about what we are up against echo " " $echo $n "Hmm... $c" echo exit 1 >bsd echo exit 1 >usg echo exit 1 >v7 echo exit 1 >osf1 echo exit 1 >eunice echo exit 1 >xenix echo exit 1 >venix $cat /usr/include/signal.h /usr/include/sys/signal.h >foo 2>/dev/null if test -f /osf_boot || $contains 'OSF/1' /usr/include/ctype.h >/dev/null 2>&1 then echo "Looks kind of like an OSF/1 system, but we'll see..." echo exit 0 >osf1 elif test `echo abc | tr a-z A-Z` = Abc ; then xxx=`./loc addbib blurfl $pth` if $test -f $xxx; then echo "Looks kind of like a USG system with BSD features, but we'll see..." echo exit 0 >bsd echo exit 0 >usg else if $contains SIGTSTP foo >/dev/null 2>&1 ; then echo "Looks kind of like an extended USG system, but we'll see..." else echo "Looks kind of like a USG system, but we'll see..." fi echo exit 0 >usg fi elif $contains SIGTSTP foo >/dev/null 2>&1 ; then echo "Looks kind of like a BSD system, but we'll see..." echo exit 0 >bsd else echo "Looks kind of like a Version 7 system, but we'll see..." echo exit 0 >v7 fi case "$eunicefix" in *unixtovms*) $cat <<'EOI' There is, however, a strange, musty smell in the air that reminds me of something...hmm...yes...I've got it...there's a VMS nearby, or I'm a Blit. EOI echo exit 0 >eunice d_eunice="$define" : it so happens the Eunice I know will not run shell scripts in Unix format ;; *) echo " " echo "Congratulations. You aren't running Eunice." d_eunice="$undef" ;; esac if test -f /xenix; then echo "Actually, this looks more like a XENIX system..." echo exit 0 >xenix d_xenix="$define" else echo " " echo "It's not Xenix..." d_xenix="$undef" fi chmod +x xenix $eunicefix xenix if test -f /venix; then echo "Actually, this looks more like a VENIX system..." echo exit 0 >venix else echo " " if xenix; then : null else echo "Nor is it Venix..." fi fi chmod +x bsd usg v7 osf1 eunice xenix venix $eunicefix bsd usg v7 osf1 eunice xenix venix $rm -f foo : see if we need a special compiler echo " " if usg; then case "$cc" in '') case "$Mcc" in /*) dflt='Mcc';; *) case "$large" in -M*) dflt='cc';; *) if $contains '\-M' $sysman/cc.1 >/dev/null 2>&1 ; then if $contains '\-M' $sysman/cpp.1 >/dev/null 2>&1; then dflt='cc' else dflt='cc -M' fi else dflt='cc' fi;; esac;; esac;; *) dflt="$cc";; esac $cat <<'EOM' On some systems the default C compiler will not resolve multiple global references that happen to have the same name. On some such systems the "Mcc" command may be used to force these to be resolved. On other systems a "cc -M" command is required. (Note that the -M flag on other systems indicates a memory model to use!) If you have the Gnu C compiler, you might wish to use that instead. EOM rp="What command will force resolution on this system?" . ./myread cc="$ans" else case "$cc" in '') dflt=cc;; *) dflt="$cc";; esac rp="Use which C compiler?" . ./myread cc="$ans" fi echo "Checking if you are using GNU cc ..." >&4 $cat >gccvers.c < int main() { #ifdef __GNUC__ #ifdef __VERSION__ printf("%s\n", __VERSION__); #else printf("%s\n", "1"); #endif #endif return 0; } EOM if $cc -o gccvers gccvers.c >/dev/null 2>&1; then gccversion=`./gccvers` case "$gccversion" in '') echo "You are not using GNU cc." ;; *) echo "You are using GNU cc $gccversion." ;; esac else echo "I can't compile the test program. I'll assume it's not GNU cc." fi $rm -f gccvers* case "$gccversion" in 1*) cpp=`./loc gcc-cpp $cpp $pth` ;; esac : decide how portable to be case "$d_portable" in "$define") dflt=y;; *) dflt=n;; esac $cat <<'EOH' I can set things up so that your shell scripts and binaries are more portable, at what may be a noticable cost in performance. In particular, if you ask to be portable, the following happens: 1) Shell scripts will rely on the PATH variable rather than using the paths derived above. 2) ~username interpretations will be done at run time rather than by Configure. EOH rp="Do you expect to run these scripts and binaries on multiple machines?" . ./myread case "$ans" in y*) d_portable="$define" for file in $loclist $trylist; do eval $file="\$file" done ;; *) d_portable="$undef" ;; esac : set up shell script to do ~ expansion cat >filexp <&2 exit 1 fi case "\$1" in */*) echo \$dir/\`$expr x\$1 : '..[^/]*/\(.*\)'\` ;; *) echo \$dir ;; esac fi ;; *) echo \$1 ;; esac EOSS chmod +x filexp $eunicefix filexp : now set up to get a file name cat <<'EOSC' >getfile tilde='' fullpath='' already='' skip='' none_ok='' exp_file='' nopath_ok='' orig_rp="$rp" orig_dflt="$dflt" case "$fn" in *:*) loc_file=`expr $fn : '.*:\(.*\)'` fn=`expr $fn : '\(.*\):.*'` ;; esac case "$fn" in *~*) tilde=true;; esac case "$fn" in */*) fullpath=true;; esac case "$fn" in *+*) skip=true;; esac case "$fn" in *n*) none_ok=true;; esac case "$fn" in *e*) exp_file=true;; esac case "$fn" in *p*) nopath_ok=true;; esac case "$fn" in *f*) type='File';; *d*) type='Directory';; *l*) type='Locate';; esac what="$type" case "$what" in Locate) what='File';; esac case "$exp_file" in '') case "$d_portable" in "$define") ;; *) exp_file=true;; esac ;; esac cd .. while test "$type"; do redo='' rp="$orig_rp" dflt="$orig_dflt" case "$tilde" in true) rp="$rp (~name ok)";; esac . UU/myread case "$ans" in none) value='' ansexp='' case "$none_ok" in true) type='';; esac ;; *) case "$tilde" in '') value="$ans" ansexp="$ans";; *) value=`UU/filexp $ans` case $? in 0) if test "$ans" != "$value"; then echo "(That is $value on this particular system.)" fi ;; *) value="$ans";; esac ansexp="$value" case "$exp_file" in '') value="$ans";; esac ;; esac case "$fullpath" in true) case "$ansexp" in /*) value="$ansexp" ;; *) redo=true case "$already" in true) echo "I shall only accept a full path name, as in /bin/ls." >&4 echo "Use a ! shell escape if you wish to check pathnames." >&4 ;; *) echo "Please give a full path name, starting with slash." >&4 case "$tilde" in true) echo "Note that using ~name is ok provided it expands well." >&4 already=true ;; esac esac ;; esac ;; esac case "$redo" in '') case "$type" in File) if test -f "$ansexp"; then type='' elif test -r "$ansexp" || (test -h "$ansexp") >/dev/null 2>&1 then echo "($value is not a plain file, but that's ok.)" type='' fi ;; Directory) if test -d "$ansexp"; then type='' fi ;; Locate) if test -d "$value"; then echo "(Looking for $loc_file in directory $value.)" value="$value/$loc_file" fi if test -f "$value"; then type='' fi case "$nopath_ok" in true) case "$value" in */*) ;; *) echo "Assuming $value will be in people's path." type='' ;; esac ;; esac ;; esac case "$skip" in true) type=''; esac case "$type" in '') ;; *) if test "$fastread" = yes; then dflt=y else dflt=n fi rp="$what $value doesn't exist. Use that name anyway?" . UU/myread dflt='' case "$ans" in y*) type='';; *) echo " ";; esac ;; esac ;; esac ;; esac done cd UU ans="$value" rp="$orig_rp" dflt="$orig_dflt" EOSC : What should the include directory be ? echo " " $echo $n "Hmm... $c" dflt='/usr/include' incpath='' mips_type='' if $test -f /bin/mips && /bin/mips; then echo "Looks like a MIPS system..." $cat >usr.c <<'EOCP' #ifdef SYSTYPE_BSD43 /bsd43 #endif EOCP 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' else mips_type='System V' fi $rm -f usr.c usr.out echo "and you're compiling with the $mips_type compiler and libraries." else echo "Doesn't look like a MIPS system." echo "exit 1" >mips chmod +x mips $eunicefix mips fi echo " " case "$usrinc" in '') ;; *) dflt="$usrinc";; esac fn=d/ rp='Where are the include files you want to use?' . ./getfile usrinc="$ans" : 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 .. echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin 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") ;; *) $rm -f $wrapper;; esac $rm -f testcpp.c testcpp.out : determine optimize, if desired, or use for debug flag also case "$optimize" in ' ') dflt='none';; '') dflt='-O';; *) dflt="$optimize";; esac $cat </dev/null 2>&1 then dflt="$dflt -posix" fi ;; esac ;; esac case "$mips_type" in *BSD*) ;; '') ;; *) inclwanted="$inclwanted $usrinc/bsd";; esac for thisincl in $inclwanted; do if $test -d $thisincl; then if $test x$thisincl != x$usrinc; then case "$dflt" in *$thisincl*);; *) dflt="$dflt -I$thisincl";; esac fi fi done inctest='if $contains $2 $usrinc/$1 >/dev/null 2>&1; then xxx=true; elif $contains $2 $usrinc/sys/$1 >/dev/null 2>&1; then xxx=true; else xxx=false; fi; if $xxx; then case "$dflt" in *$2*);; *) dflt="$dflt -D$2";; esac; fi' if ./osf1; then set signal.h __LANGUAGE_C__; eval $inctest else set signal.h LANGUAGE_C; eval $inctest fi set signal.h NO_PROTOTYPE; eval $inctest set signal.h _NO_PROTO; eval $inctest case "$dflt" in '') dflt=none;; esac case "$ccflags" in '') ;; *) dflt="$ccflags";; esac $cat <&4 set X $cppflags shift cppflags='' $cat >cpp.c <<'EOM' #define BLURFL foo BLURFL xx LFRULB EOM previous='' for flag in $* do case "$flag" in -*) ftry="$flag";; *) ftry="$previous $flag";; esac if $cppstdin -DLFRULB=bar $ftry $cppminus cpp1.out 2>/dev/null && \ $cpprun -DLFRULB=bar $ftry $cpplast cpp2.out 2>/dev/null && \ $contains 'foo.*xx.*bar' cpp1.out >/dev/null 2>&1 && \ $contains 'foo.*xx.*bar' cpp2.out >/dev/null 2>&1 then cppflags="$cppflags $ftry" previous='' else previous="$flag" fi done set X $cppflags shift cppflags=${1+"$@"} case "$cppflags" in *-*) echo "They appear to be: $cppflags";; esac $rm -f cpp.c cpp?.out ;; esac : flags used in final linking phase case "$ldflags" in '') if venix; then dflt='-i -z' else dflt='' fi case "$ccflags" in *-posix*) dflt="$dflt -posix" ;; esac case "$dflt" in '') dflt='none' ;; esac ;; *) dflt="$ldflags";; esac echo " " rp="Any additional ld flags (NOT including libraries)?" . ./myread case "$ans" in none) ldflags='';; *) ldflags="$ans";; esac rmlist="$rmlist pdp11" : Set private lib path case "$plibpth" in '') if mips; then plibpth="$incpath/usr/lib /usr/local/lib /usr/ccs/lib" fi;; esac case "$libpth" in ' ') dlist='';; '') dlist="$plibpth $glibpth";; *) dlist="$libpth";; esac : Now check and see which directories actually exist, avoiding duplicates libpth='' for xxx in $dlist do if $test -d $xxx; then case " $libpth " in *" $xxx "*) ;; *) libpth="$libpth $xxx";; esac fi done $cat <<'EOM' Some systems have incompatible or broken versions of libraries. Among the directories listed in the question below, please remove any you know not to be holding relevant libraries, and add any that are needed. Say "none" for none. EOM case "$libpth" in '') dflt='none';; *) set X $libpth shift dflt=${1+"$@"} ;; esac rp="Directories to use for library searches?" . ./myread case "$ans" in none) libpth=' ';; *) libpth="$ans";; esac : compute shared library extension case "$so" in '') if xxx=`./loc libc.sl X $libpth`; $test -f "$xxx"; then dflt='sl' else dflt='so' fi ;; *) dflt="$so";; esac $cat << EOM On some systems, shared libraries may be available. Answer 'none' if you want to suppress searching of shared libraries. EOM rp='What is the file extension used for shared libraries?' . ./myread so="$ans" : Looking for optional libraries echo " " echo "Checking for optional libraries..." >&4 case "$libs" in ' '|'') dflt='';; *) dflt="$libs";; esac case "$libswanted" in '') libswanted='c_s';; esac for thislib in $libswanted; do if xxx=`./loc lib$thislib.$so.[0-9]'*' X $libpth`; $test -f "$xxx"; then echo "Found -l$thislib (shared)." case " $dflt " in *"-l$thislib "*);; *) dflt="$dflt -l$thislib";; esac elif xxx=`./loc lib$thislib.$so X $libpth` ; $test -f "$xxx"; then echo "Found -l$thislib (shared)." case " $dflt " in *"-l$thislib "*);; *) dflt="$dflt -l$thislib";; esac elif xxx=`./loc lib$thislib.a X $libpth`; $test -f "$xxx"; then echo "Found -l$thislib." case " $dflt " in *"-l$thislib "*);; *) dflt="$dflt -l$thislib";; esac elif xxx=`./loc lib${thislib}_s.a X $libpth`; $test -f "$xxx"; then echo "Found -l${thislib}_s." case " $dflt " in *"-l$thislib "*);; *) dflt="$dflt -l${thislib}_s";; esac elif xxx=`./loc Slib$thislib.a X $xlibpth`; $test -f "$xxx"; then echo "Found -l$thislib." case " $dflt " in *"-l$thislib "*);; *) dflt="$dflt -l$thislib";; esac else echo "No -l$thislib." fi done set X $dflt shift dflt="$*" case "$libs" in '') dflt="$dflt";; *) dflt="$libs";; esac case "$dflt" in ' '|'') dflt='none';; esac $cat </dev/null` if $test $dflt -gt 20; then dflt=y else dflt=n fi ;; *) case "$usenm" in true) dflt=y;; *) dflt=n;; esac ;; esac $cat </dev/null 2>&1; then echo "Your C library seems to be in $libc, as you said before." elif $test -r $incpath/usr/lib/libc.a; then libc=$incpath/usr/lib/libc.a; echo "Your C library seems to be in $libc. That's fine." elif $test -r /lib/libc.a; then libc=/lib/libc.a; echo "Your C library seems to be in $libc. You're normal." else if tans=`./loc libc.a blurfl/dyick $libpth`; $test -r "$tans"; then : elif tans=`./loc libc blurfl/dyick $libpth`; $test -r "$tans"; then libnames="$libnames "`./loc clib blurfl/dyick $libpth` elif tans=`./loc clib blurfl/dyick $libpth`; $test -r "$tans"; then : elif tans=`./loc Slibc.a blurfl/dyick $xlibpth`; $test -r "$tans"; then : elif tans=`./loc Mlibc.a blurfl/dyick $xlibpth`; $test -r "$tans"; then : else tans=`./loc Llibc.a blurfl/dyick $xlibpth` fi if $test -r "$tans"; then echo "Your C library seems to be in $tans, of all places." libc=$tans else libc='blurfl' fi fi if $test $xxx = apollo -o -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then dflt="$libc" cat < libpath cat >&4 < libnames set X `cat libnames` shift xxx=files case $# in 1) xxx=file; esac echo "Extracting names from the following $xxx for later perusal:" >&4 echo " " $sed 's/^/ /' libnames >&4 echo " " $echo $n "This may take a while...$c" >&4 nm $nm_opt $* 2>/dev/null >libc.tmp $echo $n ".$c" $grep fprintf libc.tmp > libc.ptf xscan='eval "libc.list"; $echo $n ".$c" >&4' xrun='eval "libc.list"; echo "done" >&4' if com="$sed -n -e 's/^.* [ADTSI] *_[_.]*//p' -e 's/^.* [ADTSI] //p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e 's/^__*//' -e 's/^\([a-zA-Z_0-9$]*\).*xtern.*/\1/p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e '/|UNDEF/d' -e '/FUNC..GL/s/^.*|__*//p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e 's/^.* D __*//p' -e 's/^.* D //p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e 's/^_//' -e 's/^\([a-zA-Z_0-9]*\).*xtern.*text.*/\1/p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$grep '|' | $sed -n -e '/|COMMON/d' -e '/|DATA/d' \ -e '/ file/d' -e 's/^\([^ ]*\).*/\1/p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p' -e 's/^.*|FUNC |WEAK .*|//p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e 's/^__//' -e '/|Undef/d' -e '/|Proc/s/ .*//p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun elif com="$sed -n -e '/Def. Text/s/.* \([^ ]*\)\$/\1/p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun else nm -p $* 2>/dev/null >libc.tmp com="$sed -n -e 's/^.* [ADTS] *_[_.]*//p' -e 's/^.* [ADTS] //p'";\ eval "libc.list" if $contains '^fprintf$' libc.list >/dev/null 2>&1; then nm_opt='-p' echo "done" >&4 else echo " " echo "nm didn't seem to work right. Trying ar instead..." >&4 com='' if ar t $libc > libc.tmp; then for thisname in $libnames; do ar t $thisname >>libc.tmp done $sed -e 's/\.o$//' < libc.tmp > libc.list echo "Ok." >&4 else echo "ar didn't seem to work right." >&4 echo "Maybe this is a Cray...trying bld instead..." >&4 if bld t $libc | $sed -e 's/.*\///' -e 's/\.o:.*$//' > libc.list; then for thisname in $libnames; do bld t $libnames | \ $sed -e 's/.*\///' -e 's/\.o:.*$//' >>libc.list ar t $thisname >>libc.tmp done echo "Ok." >&4 else echo "That didn't work either. Giving up." >&4 exit 1 fi fi fi fi nm_extract="$com" if $test -f /lib/syscalls.exp; then echo " " echo "Also extracting names from /lib/syscalls.exp for good ole AIX..." >&4 $sed -n 's/^\([^ ]*\)[ ]*syscall$/\1/p' /lib/syscalls.exp >>libc.list fi ;; esac $rm -f libnames libpath : is a C symbol defined? csym='tlook=$1; case "$3" in -v) tf=libc.tmp; tc=""; tdc="";; -a) tf=libc.tmp; tc="[0]"; tdc=[];; *) tlook="^$1\$"; tf=libc.list; tc="()"; tdc="()";; esac; tx=yes; case "$reuseval-$4" in true-) ;; true-*) tx=no; eval "tval=\$$4"; case "$tval" in "") tx=yes;; esac;; esac; case "$tx" in yes) case "$runnm" in true) if $contains $tlook $tf >/dev/null 2>&1; then tval=true; else tval=false; fi;; *) echo "main() { extern int $1$tdc; printf(\"%d\", $1$tc); }" > t.c; if $cc $ccflags -o t t.c $ldflags $libs >/dev/null 2>&1; then tval=true; else tval=false; fi; $rm -f t t.c;; esac;; *) case "$tval" in $define) tval=true;; *) tval=false;; esac;; esac; eval "$2=$tval"' : set up the script used to warn in case of inconsistency cat <<'EOSC' >whoa dflt=y echo " " echo "*** WHOA THERE!!! ***" >&4 echo " The $hint value for \$$var on this machine was \"$was\"!" >&4 rp=" Keep the $hint value?" . ./myread case "$ans" in y) td=$was; tu=$was;; esac EOSC : define an is-in-libc? function inlibc='echo " "; td=$define; tu=$undef; sym=$1; var=$2; eval "was=\$$2"; tx=yes; case "$reuseval$was" in true) ;; true*) tx=no;; esac; case "$tx" in yes) set $sym tres -f; eval $csym; case "$tres" in true) echo "$sym() found." >&4; case "$was" in $undef) . whoa; esac; eval "$var=\$td";; *) echo "$sym() NOT found." >&4; case "$was" in $define) . whoa; esac; eval "$var=\$tu";; esac;; *) case "$was" in $define) echo "$sym() found." >&4;; *) echo "$sym() NOT found." >&4;; esac;; esac' : see if gconvert exists set gconvert d_gconvert eval $inlibc case "$d_gconvert" in $define) d_Gconvert="gconvert((x),(n),(t),(b))" ;; *) : Maybe we can emulate it with gcvt. set gcvt d_gcvt eval $inlibc case "$d_gcvt" in $define) : Test whether gcvt drops a trailing decimal point cat >try.c <<'EOP' main() { char buf[64]; gcvt(1.0, 8, buf); if (buf[0] != '1' || buf[1] != '\0') return 1; gcvt(0.0, 8, buf); if (buf[0] != '0' || buf[1] != '\0') return 1; gcvt(-1.0, 8, buf); if (buf[0] != '-' || buf[1] != '1' || buf[2] != '\0') return 1; return 0; } EOP if $cc $ccflags $ldflags -o try try.c $libs > /dev/null 2>&1; then if ./try; then echo "Good, your gcvt() drops a trailing decimal point." d_Gconvert="gcvt((x),(n),(b))" else echo "But your gcvt() keeps a trailing decimal point". d_Gconvert='' fi else echo "Hmm. I can't compile the gcvt test program." d_Gconvert='' fi $rm -f try.c try ;; esac case "$d_Gconvert" in '') echo "I'll use sprintf instead." >&4 d_Gconvert='sprintf((b),"%.*g",(n),(x))' ;; esac esac : Initialize h_fcntl h_fcntl=false : Initialize h_sysfile h_sysfile=false : determine filename position in cpp output echo " " echo "Computing filename position in cpp output for #include directives..." >&4 echo '#include ' > foo.c $cat >fieldn </dev/null | \ $grep '^[ ]*#.*stdio\.h' | \ while read cline; do pos=1 set \$cline while $test \$# -gt 0; do if $test -r \`echo \$1 | $tr -d '"'\`; then echo "\$pos" exit 0 fi shift pos=\`expr \$pos + 1\` done done EOF chmod +x fieldn fieldn=`./fieldn` $rm -f foo.c fieldn case $fieldn in '') pos='???';; 1) pos=first;; 2) pos=second;; 3) pos=third;; *) pos="${fieldn}th";; esac echo "Your cpp writes the filename in the $pos field of the line." : locate header file $cat >findhdr <" > foo\$\$.c $cppstdin $cppminus $cppflags < foo\$\$.c 2>/dev/null | \ $grep "^[ ]*#.*\$wanted" | \ while read cline; do name=\`echo \$cline | $awk "\$awkprg" | $tr -d '"'\` case "\$name" in */\$wanted) echo "\$name"; exit 0;; *) name='';; esac; done; $rm -f foo\$\$.c; case "\$name" in '') exit 1;; esac EOF chmod +x findhdr : access call always available on UNIX set access d_access eval $inlibc : locate the flags for 'access()' case "$d_access" in "$define") echo " " $cat >access.c <<'EOCP' #include #ifdef I_FCNTL #include #endif #ifdef I_SYS_FILE #include #endif #ifdef I_UNISTD #include #endif main() { exit(R_OK); } EOCP : check sys/file.h first, no particular reason here if $test `./findhdr sys/file.h` && \ $cc $cppflags -DI_SYS_FILE access.c -o access >/dev/null 2>&1 ; then h_sysfile=true; echo " defines the *_OK access constants." >&4 elif $test `./findhdr fcntl.h` && \ $cc $cppflags -DI_FCNTL access.c -o access >/dev/null 2>&1 ; then h_fcntl=true; echo " defines the *_OK access constants." >&4 elif $test `./findhdr unistd.h` && \ $cc $cppflags -DI_UNISTD access.c -o access >/dev/null 2>&1 ; then echo " defines the *_OK access constants." >&4 else echo "I can't find the four *_OK access constants--I'll use mine." >&4 fi ;; esac $rm -f access* : see if alarm exists set alarm d_alarm eval $inlibc : is AFS running? echo " " if test -d /afs; then echo "AFS may be running... I'll be extra cautious then..." >&4 afs=true else echo "AFS does not seem to be running..." >&4 afs=false fi : determine root of directory hierarchy where package will be installed. case "$prefix" in '') dflt=`./loc . /usr/local /usr/local /local /opt /usr` ;; *) dflt="$prefix" ;; esac $cat <&4 $cat >attrib.c <<'EOCP' void croak (char* pat,...) __attribute__((format(printf,1,2),noreturn)); EOCP if $cc $ccflags -c attrib.c >attrib.out 2>&1 ; then if $contains 'warning' attrib.out >/dev/null 2>&1; then echo "Your C compiler doesn't fully support __attribute__. ." val="$undef" else echo "Your C compiler supports __attribute__. ." val="$define" fi else echo "Your C compiler doesn't seem to understand __attribute__. ." val="$undef" fi set d_attrib eval $setvar $rm -f attrib* : see if bcmp exists set bcmp d_bcmp eval $inlibc : see if bcopy exists set bcopy d_bcopy eval $inlibc : see if setpgrp exists set setpgrp d_setpgrp eval $inlibc : see which flavor of setpgrp is in use case "$d_setpgrp" in "$define") echo " " $cat >set.c </dev/null 2>&1; then ./set 2>/dev/null case $? in 0) echo "You have to use setpgrp() instead of setpgrp(pid, pgrp)." >&4 val="$undef";; *) echo "You have to use setpgrp(pid, pgrp) instead of setpgrp()." >&4 val="$define";; esac else if usg; then xxx="USG one, i.e. you use setpgrp()." val="$undef" else xxx="BSD one, i.e. you use setpgrp(pid, pgrp)." val="$define" fi echo "Assuming your setpgrp is a $xxx" >&4 fi ;; *) val="$undef";; esac set d_bsdpgrp eval $setvar $rm -f set set.c : see if bzero exists set bzero d_bzero eval $inlibc : check for length of integer echo " " case "$intsize" in '') echo "Checking to see how big your integers are..." >&4 $cat >try.c <<'EOCP' #include main() { printf("%d\n", sizeof(int)); } EOCP if $cc $ccflags try.c -o try >/dev/null 2>&1 ; then dflt=`./try` else dflt='4' echo "(I can't seem to compile the test program. Guessing...)" fi ;; *) dflt="$intsize" ;; esac rp="What is the size of an integer (in bytes)?" . ./myread intsize="$ans" $rm -f try.c try : check for ability to cast large floats to 32-bit ints. echo " " echo 'Checking whether your C compiler can cast large floats to int32.' >&4 if $test "$intsize" -eq 4; then xxx=int else xxx=long fi $cat >try.c < #include blech() { exit(3); } main() { $xxx i32; double f; int result = 0; signal(SIGFPE, blech); f = (double) 0x7fffffff; f = 10 * f; i32 = ($xxx) f; if (i32 != ($xxx) f) result |= 1; exit(result); } EOCP if $cc -o try $ccflags try.c >/dev/null 2>&1; then ./try yyy=$? else echo "(I can't seem to compile the test program--assuming it can't)" yyy=1 fi case "$yyy" in 0) val="$define" echo "Yup, it can." ;; *) val="$undef" echo "Nope, it can't." ;; esac set d_casti32 eval $setvar $rm -f try try.* : check for ability to cast negative floats to unsigned echo " " echo 'Checking whether your C compiler can cast negative float to unsigned.' >&4 $cat >try.c <<'EOCP' #include blech() { exit(3); } main() { double f = -123; unsigned long along; unsigned int aint; unsigned short ashort; int result = 0; signal(SIGFPE, blech); along = (unsigned long)f; aint = (unsigned int)f; ashort = (unsigned short)f; if (along != (unsigned long)-123) result |= 1; if (aint != (unsigned int)-123) result |= 1; if (ashort != (unsigned short)-123) result |= 1; f = (double)0x40000000; f = f + f; along = 0; along = (unsigned long)f; if (along != 0x80000000) result |= 2; f -= 1.; along = 0; along = (unsigned long)f; if (along != 0x7fffffff) result |= 1; f += 2.; along = 0; along = (unsigned long)f; if (along != 0x80000001) result |= 2; exit(result); } EOCP if $cc -o try $ccflags try.c >/dev/null 2>&1; then ./try castflags=$? else castflags=3 fi case "$castflags" in 0) val="$define" echo "Yup, it can." ;; *) val="$undef" echo "Nope, it can't." ;; esac set d_castneg eval $setvar $rm -f try.* : see if sprintf is declared as int or pointer to char echo " " $cat >ucbsprf.c <<'EOF' main() { int sprintf(); char buf[10]; exit((unsigned long)sprintf(buf,"%s","foo") > 10L); } EOF if $cc ucbsprf.c -o ucbsprf >/dev/null 2>&1 && ./ucbsprf; then echo "Your sprintf() returns (int)." >&4 val="$undef" else echo "Your sprintf() returns (char*)." >&4 val="$define" fi set d_charsprf eval $setvar $rm -f ucbsprf* : see if vprintf exists echo " " if set vprintf val -f d_vprintf; eval $csym; $val; then echo 'vprintf() found.' >&4 val="$define" $cat >vprintf.c <<'EOF' #include main() { xxx("foo"); } xxx(va_alist) va_dcl { va_list args; char buf[10]; va_start(args); exit((unsigned long)vsprintf(buf,"%s",args) > 10L); } EOF if $cc $ccflags vprintf.c -o vprintf >/dev/null 2>&1 && ./vprintf; then echo "Your vsprintf() returns (int)." >&4 val2="$undef" else echo "Your vsprintf() returns (char*)." >&4 val2="$define" fi else echo 'vprintf() NOT found.' >&4 val="$undef" val2="$undef" fi set d_vprintf eval $setvar val=$val2 set d_charvspr eval $setvar : see if chown exists set chown d_chown eval $inlibc : see if chroot exists set chroot d_chroot eval $inlibc : see if chsize exists set chsize d_chsize eval $inlibc : check for const keyword echo " " echo 'Checking to see if your C compiler knows about "const"...' >&4 $cat >const.c <<'EOCP' typedef struct spug { int drokk; } spug; main() { const char *foo; const spug y; } EOCP if $cc -c $ccflags const.c >/dev/null 2>&1 ; then val="$define" echo "Yup, it does." else val="$undef" echo "Nope, it doesn't." fi set d_const eval $setvar : see if crypt exists echo " " if set crypt val -f d_crypt; eval $csym; $val; then echo 'crypt() found.' >&4 val="$define" cryptlib='' else cryptlib=`./loc Slibcrypt.a "" $xlibpth` if $test -z "$cryptlib"; then cryptlib=`./loc Mlibcrypt.a "" $xlibpth` else cryptlib=-lcrypt fi if $test -z "$cryptlib"; then cryptlib=`./loc Llibcrypt.a "" $xlibpth` else cryptlib=-lcrypt fi if $test -z "$cryptlib"; then cryptlib=`./loc libcrypt.a "" $libpth` else cryptlib=-lcrypt fi if $test -z "$cryptlib"; then echo 'crypt() NOT found.' >&4 val="$undef" else val="$define" fi fi set d_crypt eval $setvar : get csh whereabouts case "$csh" in 'csh') val="$undef" ;; *) val="$define" ;; esac set d_csh eval $setvar : see if cuserid exists set cuserid d_cuserid eval $inlibc : define an alternate in-header-list? function inhdr='echo " "; td=$define; tu=$undef; yyy=$@; cont=true; xxf="echo \"<\$1> found.\" >&4"; case $# in 2) xxnf="echo \"<\$1> NOT found.\" >&4";; *) xxnf="echo \"<\$1> NOT found, ...\" >&4";; esac; case $# in 4) instead=instead;; *) instead="at last";; esac; while $test "$cont"; do xxx=`./findhdr $1` var=$2; eval "was=\$$2"; if $test "$xxx" && $test -r "$xxx"; then eval $xxf; eval "case \"\$$var\" in $undef) . whoa; esac"; eval "$var=\$td"; cont=""; else eval $xxnf; eval "case \"\$$var\" in $define) . whoa; esac"; eval "$var=\$tu"; fi; set $yyy; shift; shift; yyy=$@; case $# in 0) cont="";; 2) xxf="echo \"but I found <\$1> $instead.\" >&4"; xxnf="echo \"and I did not find <\$1> either.\" >&4";; *) xxf="echo \"but I found <\$1\> instead.\" >&4"; xxnf="echo \"there is no <\$1>, ...\" >&4";; esac; done; while $test "$yyy"; do set $yyy; var=$2; eval "was=\$$2"; eval "case \"\$$var\" in $define) . whoa; esac"; eval "$var=\$tu"; set $yyy; shift; shift; yyy=$@; done' : see if this is a limits.h system set limits.h i_limits eval $inhdr : see if this is a float.h system set float.h i_float eval $inhdr : See if number of significant digits in a double precision number is known echo " " $cat >dbl_dig.c < #endif #ifdef I_FLOAT #include #endif #ifdef DBL_DIG printf("Contains DBL_DIG"); #endif EOM $cppstdin $cppflags $cppminus < dbl_dig.c >dbl_dig.E 2>/dev/null if $contains 'DBL_DIG' dbl_dig.E >/dev/null 2>&1; then echo "DBL_DIG found." >&4 val="$define" else echo "DBL_DIG NOT found." >&4 val="$undef" fi $rm -f dbl_dig.? set d_dbl_dig eval $setvar : see if difftime exists set difftime d_difftime eval $inlibc : see if this is a dirent system echo " " if xinc=`./findhdr dirent.h`; $test "$xinc"; then val="$define" echo " found." >&4 else val="$undef" if xinc=`./findhdr sys/dir.h`; $test "$xinc"; then echo " found." >&4 echo " " else xinc=`./findhdr sys/ndir.h` fi echo " NOT found." >&4 fi set i_dirent eval $setvar : Look for type of directory structure. echo " " $cppstdin $cppflags $cppminus < "$xinc" > try.c case "$direntrytype" in ''|' ') case "$i_dirent" in $define) guess1='struct dirent' ;; *) guess1='struct direct' ;; esac ;; *) guess1="$direntrytype" ;; esac case "$guess1" in 'struct dirent') guess2='struct direct' ;; *) guess2='struct dirent' ;; esac if $contains "$guess1" try.c >/dev/null 2>&1; then direntrytype="$guess1" echo "Your directory entries are $direntrytype." >&4 elif $contains "$guess2" try.c >/dev/null 2>&1; then direntrytype="$guess2" echo "Your directory entries seem to be $direntrytype." >&4 else echo "I don't recognize your system's directory entries." >&4 rp="What type is used for directory entries on this system?" dflt="$guess1" . ./myread direntrytype="$ans" fi $rm -f try.c : see if the directory entry stores field length echo " " if $contains 'd_namlen' $xinc >/dev/null 2>&1; then echo "Good, your directory entry keeps length information in d_namlen." >&4 val="$define" else echo "Your directory entry does not know about the d_namlen field." >&4 val="$undef" fi set d_dirnamlen eval $setvar : see if dlerror exists set dlerror d_dlerror eval $inlibc : see if dld is available set dld.h i_dld eval $inhdr : see if dlopen exists set dlopen d_dlopen eval $inlibc : determine which dynamic loading, if any, to compile in echo " " dldir="ext/DynaLoader" case "$usedl" in $define|y|true) dflt='y' usedl="$define" ;; $undef|n|false) dflt='n' usedl="$undef" ;; *) dflt='n' case "$d_dlopen" in define) dflt='y' ;; esac case "$i_dld" in define) dflt='y' ;; esac : Does a dl_xxx.xs file exist for this operating system $test -f ../$dldir/dl_${osname}.xs && dflt='y' ;; esac rp="Do you wish to use dynamic loading?" . ./myread usedl="$ans" case "$ans" in y*) usedl="$define" case "$dlsrc" in '') if $test -f ../$dldir/dl_${osname}.xs ; then dflt="$dldir/dl_${osname}.xs" elif $test "$d_dlopen" = "$define" ; then dflt="$dldir/dl_dlopen.xs" elif $test "$i_dld" = "$define" ; then dflt="$dldir/dl_dld.xs" else dflt='' fi ;; *) dflt="$dldir/$dlsrc" ;; esac echo "The following dynamic loading files are available:" : Can not go over to $dldir because getfile has path hard-coded in. cd ..; ls -C $dldir/dl*.xs; cd UU rp="Source file to use for dynamic loading" fn="fne~" . ./getfile usedl="$define" : emulate basename dlsrc=`echo $ans | $sed -e 's@.*/\([^/]*\)$@\1@'` $cat << EOM Some systems may require passing special flags to $cc -c to compile modules that will be used to create a shared library. To use no flags, say "none". EOM case "$cccdlflags" in ''|' ') case "$osname" in hpux) dflt='+z' ;; next) dflt='none' ;; sunos) case "$cc" in *gcc*) dflt='-fpic' ;; *) dflt='-pic' ;; esac ;; solaris) case "$cc" in *gcc*) dflt='-fpic' ;; *) dflt='-K pic' ;; esac ;; *) dflt='none' ;; esac ;; *) dflt="$cccdlflags" ;; esac rp="Any special flags to pass to $cc -c to compile shared library modules?" . ./myread case "$ans" in none) cccdlflags='' ;; *) cccdlflags="$ans" ;; esac cat << 'EOM' Some systems may require passing special flags to ld to create a shared library. If your ld flags include -L/local/path options to locate libraries outside your loader's normal search path, you may need to specify those -L options here as well. To use no flags, say "none". EOM case "$lddlflags" in ''|' ') case "$osname" in hpux) dflt='-b' ;; next) dflt='none' ;; solaris) dflt='-G' ;; sunos) dflt='none' ;; *) dflt='none' ;; esac ;; *) dflt="$lddlflags" ;; esac rp="Any special flags to pass to ld to create a shared library?" . ./myread case "$ans" in none) lddlflags='' ;; *) lddlflags="$ans" ;; esac cat <&4 $cat >dyna.c <<'EOM' fred () { } EOM $cat >fred.c< #$i_dlfcn I_DLFCN #ifdef I_DLFCN #include /* the dynamic linker include file for Sunos/Solaris */ #else #include #include #include #endif extern int fred() ; main() { void * handle ; void * symbol ; #ifndef RTLD_LAZY int mode = 1 ; #else int mode = RTLD_LAZY ; #endif handle = dlopen("./dyna.$dlext", mode) ; if (handle == NULL) { printf ("1\n") ; exit(0); } symbol = dlsym(handle, "fred") ; if (symbol == NULL) { /* try putting a leading underscore */ symbol = dlsym(handle, "_fred") ; if (symbol == NULL) { printf ("2\n") ; exit(0); } printf ("3\n") ; } else printf ("4\n") ; exit(0); } EOM if $cc $ccflags $cccdlflags -c dyna.c > /dev/null 2>&1 && ld $lddlflags -o dyna.$dlext dyna.o > /dev/null 2>&1 && $cc $ccflags $ldflags $cccdlflags $ccdlflags fred.c -o fred $libs > /dev/null 2>&1; then xxx=`./fred` case $xxx in 1) echo "Test program failed using dlopen." >&4 echo "Perhaps you should not use dynamic loading." >&4;; 2) echo "Test program failed using dlsym." >&4 echo "Perhaps you should not use dynamic loading." >&4;; 3) echo "dlsym needs a leading underscore" >&4 val="$define" ;; 4) echo "dlsym doesn't need a leading underscore." >&4;; esac else echo "I can't compile and run the test program." >&4 fi ;; esac $rm -f fred fred.? dyna.$dlext dyna.? set d_dlsymun eval $setvar : see if setuid scripts can be secure cat <reflect chmod +x,u+s reflect ./reflect >flect 2>&1 if $contains "/dev/fd" flect >/dev/null; then echo "Congratulations, your kernel has secure setuid scripts!" >&4 val="$define" else $cat <&4 dflt=n;; "$undef") echo "Well, the $hint value is *not* secure." >&4 dflt=n;; *) echo "Well, the $hint value *is* secure." >&4 dflt=y;; esac ;; *) $rm -f reflect flect echo "#!$ls" >reflect chmod +x,u+s reflect echo >flect chmod a+w flect echo '"su" will (probably) prompt you for '"$ans's password." su $ans -c './reflect >flect' if $contains "/dev/fd" flect >/dev/null; then echo "Okay, it looks like setuid scripts are secure." >&4 dflt=y else echo "I don't think setuid scripts are secure." >&4 dflt=n fi ;; esac rp='Does your kernel have *secure* setuid scripts?' . ./myread case "$ans" in [yY]*) val="$define";; *) val="$undef";; esac fi else echo "I don't think setuid scripts are secure (no /dev/fd directory)." >&4 val="$undef" fi set d_suidsafe eval $setvar $rm -f reflect flect : now see if they want to do setuid emulation cat <& 4 ;; *) case "$d_dosuid" in "$define") dflt=y ;; *) dflt=n ;; esac rp="Do you want to do setuid/setgid emulation?" . ./myread case "$ans" in [yY]*) val="$define";; *) val="$undef";; esac ;; esac set d_dosuid eval $setvar : see if drem exists set drem d_drem eval $inlibc : see if dup2 exists set dup2 d_dup2 eval $inlibc : see if fchmod exists set fchmod d_fchmod eval $inlibc : see if fchown exists set fchown d_fchown eval $inlibc : see if this is an fcntl system set fcntl d_fcntl eval $inlibc : see if fgetpos exists set fgetpos d_fgetpos eval $inlibc : see if we can have long filenames echo " " rmlist="$rmlist /tmp/cf$$" $test -d /tmp/cf$$ || mkdir /tmp/cf$$ first=123456789abcdef second=/tmp/cf$$/$first $rm -f $first $second if (echo hi >$first) 2>/dev/null; then if $test -f 123456789abcde; then echo 'You cannot have filenames longer than 14 characters. Sigh.' >&4 val="$undef" else if (echo hi >$second) 2>/dev/null; then if $test -f /tmp/cf$$/123456789abcde; then $cat <<'EOM' That's peculiar... You can have filenames longer than 14 characters, but only on some of the filesystems. Maybe you are using NFS. Anyway, to avoid problems I shall consider your system cannot support long filenames at all. EOM val="$undef" else echo 'You can have filenames longer than 14 characters.' >&4 val="$define" fi else $cat <<'EOM' How confusing! Some of your filesystems are sane enough to allow filenames longer than 14 characters but some others like /tmp can't even think about them. So, for now on, I shall assume your kernel does not allow them at all. EOM val="$undef" fi fi else $cat <<'EOM' You can't have filenames longer than 14 chars. You can't even think about them! EOM val="$undef" fi set d_flexfnam eval $setvar $rm -rf /tmp/cf$$ 123456789abcde* : see if flock exists set flock d_flock eval $inlibc : see if fmod exists set fmod d_fmod eval $inlibc : see if fork exists set fork d_fork eval $inlibc : see if pathconf exists set pathconf d_pathconf eval $inlibc : see if fpathconf exists set fpathconf d_fpathconf eval $inlibc : see if fsetpos exists set fsetpos d_fsetpos eval $inlibc : see if gethostent exists set gethostent d_gethent eval $inlibc : see if getlogin exists set getlogin d_getlogin eval $inlibc : see if getpgrp exists set getpgrp d_getpgrp eval $inlibc : see if getpgrp2 exists set getpgrp2 d_getpgrp2 eval $inlibc : see if getppid exists set getppid d_getppid eval $inlibc : see if getpriority exists set getpriority d_getprior eval $inlibc : see if group exists set group d_group eval $inlibc : see if this is a netinet/in.h or sys/in.h system set netinet/in.h i_niin sys/in.h i_sysin eval $inhdr : see if htonl --and friends-- exists val='' set htonl val eval $inlibc : Maybe they are macros. case "$val" in $undef) $cat >htonl.c < #include #$i_niin I_NETINET_IN #$i_sysin I_SYS_IN #ifdef I_NETINET_IN #include #endif #ifdef I_SYS_IN #include #endif #ifdef htonl printf("Defined as a macro."); #endif EOM $cppstdin $cppflags $cppminus < htonl.c >htonl.E 2>/dev/null if $contains 'Defined as a macro' htonl.E >/dev/null 2>&1; then val="$define" echo "But it seems to be defined as a macro." >&4 fi $rm -f htonl.? ;; esac set d_htonl eval $setvar : see which of string.h or strings.h is needed echo " " strings=`./findhdr string.h` if $test "$strings" && $test -r "$strings"; then echo "Using instead of ." >&4 val="$define" else val="$undef" strings=`./findhdr strings.h` if $test "$strings" && $test -r "$strings"; then echo "Using instead of ." >&4 else echo "No string header found -- You'll surely have problems." >&4 fi fi set i_string eval $setvar case "$i_string" in "$undef") strings=`./findhdr strings.h`;; *) strings=`./findhdr string.h`;; esac : index or strchr echo " " if set index val -f; eval $csym; $val; then if set strchr val -f d_strchr; eval $csym; $val; then if $contains strchr "$strings" >/dev/null 2>&1 ; then val="$define" vali="$undef" echo "strchr() found." >&4 else val="$undef" vali="$define" echo "index() found." >&4 fi else val="$undef" vali="$define" echo "index() found." >&4 fi else if set strchr val -f d_strchr; eval $csym; $val; then val="$define" vali="$undef" echo "strchr() found." >&4 else echo "No index() or strchr() found!" >&4 val="$undef" vali="$undef" fi fi set d_strchr; eval $setvar val="$vali" set d_index; eval $setvar : Look for isascii echo " " $cat >isascii.c <<'EOCP' #include #include main() { int c = 'A'; if (isascii(c)) exit(0); else exit(1); } EOCP if $cc $ccflags $ldflags -o isascii isascii.c $libs >/dev/null 2>&1 ; then echo "isascii() found." >&4 val="$define" else echo "isascii() NOT found." >&4 val="$undef" fi set d_isascii eval $setvar $rm -f isascii* : see if killpg exists set killpg d_killpg eval $inlibc : see if link exists set link d_link eval $inlibc : see if stdio is really std echo " " xxx=`./findhdr stdio.h` if $contains 'char.*_ptr;' "$xxx" >/dev/null 2>&1 ; then if $contains '_cnt;' "$xxx" >/dev/null 2>&1 ; then echo "Your stdio is pretty std." >&4 val="$define" else echo "Your stdio isn't very std." >&4 val="$undef" fi else echo "Your stdio isn't very std." >&4 val="$undef" fi set d_stdstdio eval $setvar : see if stdio is like that in linux case "$d_stdstdio" in "$undef") echo " " xxx=`./findhdr stdio.h` $cppstdin $cppflags $cppminus < "$xxx" > stdio.E if $contains 'char.*_IO_read_base' stdio.E >/dev/null 2>&1 && \ $contains '_IO_read_ptr' stdio.E >/dev/null 2>&1 && \ $contains '_IO_read_end' stdio.E >/dev/null 2>&1 ; then echo "Your stdio looks like linux." >&4 val="$define" else echo "You don't have linux stdio, either." >&4 val="$undef" fi $rm -f stdio.E ;; *) val="$undef" ;; esac set d_linuxstd eval $setvar : see if localeconv exists set localeconv d_locconv eval $inlibc : see if lockf exists set lockf d_lockf eval $inlibc : see if lstat exists set lstat d_lstat eval $inlibc : see if mblen exists set mblen d_mblen eval $inlibc : see if mbstowcs exists set mbstowcs d_mbstowcs eval $inlibc : see if mbtowc exists set mbtowc d_mbtowc eval $inlibc : see if memcmp exists set memcmp d_memcmp eval $inlibc : see if memcpy exists set memcpy d_memcpy eval $inlibc : see if memmove exists set memmove d_memmove eval $inlibc : see if memset exists set memset d_memset eval $inlibc : see if mkdir exists set mkdir d_mkdir eval $inlibc : see if mkfifo exists set mkfifo d_mkfifo eval $inlibc : see if mktime exists set mktime d_mktime eval $inlibc : see if msgctl exists set msgctl d_msgctl eval $inlibc : see if msgget exists set msgget d_msgget eval $inlibc : see if msgsnd exists set msgsnd d_msgsnd eval $inlibc : see if msgrcv exists set msgrcv d_msgrcv eval $inlibc : see how much of the 'msg*(2)' library is present. h_msg=true echo " " case "$d_msgctl$d_msgget$d_msgsnd$d_msgrcv" in *"$undef"*) h_msg=false;; esac : we could also check for sys/ipc.h ... if $h_msg && $test `./findhdr sys/msg.h`; then echo "You have the full msg*(2) library." >&4 val="$define" else echo "You don't have the full msg*(2) library." >&4 val="$undef" fi set d_msg eval $setvar : see if this is a malloc.h system set malloc.h i_malloc eval $inhdr : determine which malloc to compile in echo " " case "$usemymalloc" in ''|y*|true) dflt='y' ;; n*|false) dflt='n' ;; *) dflt="$usemymalloc" ;; esac rp="Do you wish to attempt to use the malloc that comes with $package?" . ./myread usemymalloc="$ans" case "$ans" in y*|true) usemymalloc='y' mallocsrc='malloc.c' mallocobj='malloc.o' d_mymalloc="$define" case "$libs" in *-lmalloc*) : Remove malloc from list of libraries to use echo "Removing unneeded -lmalloc from library list" >&4 set `echo X $libs | $sed -e 's/-lmalloc / /' -e 's/-lmalloc$//'` shift libs="$*" echo "libs = $libs" >&4 ;; esac ;; *) usemymalloc='n' mallocsrc='' mallocobj='' d_mymalloc="$undef" ;; esac : compute the type returned by malloc echo " " case "$malloctype" in '') $cat >malloc.c < #include #ifdef I_MALLOC #include #endif void *malloc(); END if $cc $ccflags -c malloc.c >/dev/null 2>&1; then malloctype='void *' else malloctype='char *' fi $rm -f malloc.[co] ;; esac echo "Your system wants malloc to return '$malloctype', it would seem." >&4 : see if nice exists set nice d_nice eval $inlibc : Locate the flags for 'open()' echo " " $cat >open3.c <<'EOCP' #include #ifdef I_FCNTL #include #endif #ifdef I_SYS_FILE #include #endif main() { if(O_RDONLY); #ifdef O_TRUNC exit(0); #else exit(1); #endif } EOCP : check sys/file.h first to get FREAD on Sun if $test `./findhdr sys/file.h` && \ $cc $cppflags "-DI_SYS_FILE" open3.c -o open3 >/dev/null 2>&1 ; then h_sysfile=true; echo " defines the O_* constants..." >&4 if ./open3; then echo "and you have the 3 argument form of open()." >&4 val="$define" else echo "but not the 3 argument form of open(). Oh, well." >&4 val="$undef" fi elif $test `./findhdr fcntl.h` && \ $cc "-DI_FCNTL" open3.c -o open3 >/dev/null 2>&1 ; then h_fcntl=true; echo " defines the O_* constants..." >&4 if ./open3; then echo "and you have the 3 argument form of open()." >&4 val="$define" else echo "but not the 3 argument form of open(). Oh, well." >&4 val="$undef" fi else val="$undef" echo "I can't find the O_* constant definitions! You got problems." >&4 fi set d_open3 eval $setvar $rm -f open3* : see if passwd exists set passwd d_passwd eval $inlibc : see if pause exists set pause d_pause eval $inlibc : see if pipe exists set pipe d_pipe eval $inlibc : see if this is a pwd system echo " " xxx=`./findhdr pwd.h` if $test "$xxx"; then i_pwd="$define" echo " found." >&4 $cppstdin $cppflags $cppminus < $xxx >$$.h if $contains 'pw_quota' $$.h >/dev/null 2>&1; then d_pwquota="$define" else d_pwquota="$undef" fi if $contains 'pw_age' $$.h >/dev/null 2>&1; then d_pwage="$define" else d_pwage="$undef" fi if $contains 'pw_change' $$.h >/dev/null 2>&1; then d_pwchange="$define" else d_pwchange="$undef" fi if $contains 'pw_class' $$.h >/dev/null 2>&1; then d_pwclass="$define" else d_pwclass="$undef" fi if $contains 'pw_expire' $$.h >/dev/null 2>&1; then d_pwexpire="$define" else d_pwexpire="$undef" fi if $contains 'pw_comment' $$.h >/dev/null 2>&1; then d_pwcomment="$define" else d_pwcomment="$undef" fi $rm -f $$.h else i_pwd="$undef" d_pwquota="$undef" d_pwage="$undef" d_pwchange="$undef" d_pwclass="$undef" d_pwexpire="$undef" d_pwcomment="$undef" echo " NOT found." >&4 fi : see if readdir and friends exist set readdir d_readdir eval $inlibc set seekdir d_seekdir eval $inlibc set telldir d_telldir eval $inlibc set rewinddir d_rewinddir eval $inlibc : see if readlink exists set readlink d_readlink eval $inlibc : see if rename exists set rename d_rename eval $inlibc : see if rmdir exists set rmdir d_rmdir eval $inlibc : can bcopy handle overlapping blocks? val="$undef" case "$d_bcopy" in "$define") echo " " echo "Checking to see if your bcopy() can do overlapping copies..." >&4 $cat >foo.c <<'EOCP' main() { char buf[128], abc[128]; char *b; int len; int off; int align; bcopy("abcdefghijklmnopqrstuvwxyz0123456789", abc, 36); for (align = 7; align >= 0; align--) { for (len = 36; len; len--) { b = buf+align; bcopy(abc, b, len); for (off = 1; off <= len; off++) { bcopy(b, b+off, len); bcopy(b+off, b, len); if (bcmp(b, abc, len)) exit(1); } } } exit(0); } EOCP if $cc foo.c -o safebcpy $ccflags $ldflags $libs >/dev/null 2>&1 ; then if ./safebcpy 2>/dev/null; then echo "Yes, it can." val="$define" else echo "It can't, sorry." fi else echo "(I can't compile the test program, so we'll assume not...)" fi ;; esac $rm -f foo.* safebcpy core set d_safebcpy eval $setvar : can memcpy handle overlapping blocks? val="$undef" case "$d_memcpy" in "$define") echo " " echo "Checking to see if your memcpy() can do overlapping copies..." >&4 $cat >foo.c <<'EOCP' main() { char buf[128], abc[128]; char *b; int len; int off; int align; memcpy(abc, "abcdefghijklmnopqrstuvwxyz0123456789", 36); for (align = 7; align >= 0; align--) { for (len = 36; len; len--) { b = buf+align; memcpy(abc, b, len); for (off = 1; off <= len; off++) { memcpy(b, b+off, len); memcpy(b+off, b, len); if (memcmp(b, abc, len)) exit(1); } } } exit(0); } EOCP if $cc foo.c -o safemcpy $ccflags $ldflags $libs >/dev/null 2>&1 ; then if ./safemcpy 2>/dev/null; then echo "Yes, it can." val="$define" else echo "It can't, sorry." fi else echo "(I can't compile the test program, so we'll assume not...)" fi ;; esac $rm -f foo.* safemcpy core set d_safemcpy eval $setvar : see if select exists set select d_select eval $inlibc : see if semctl exists set semctl d_semctl eval $inlibc : see if semget exists set semget d_semget eval $inlibc : see if semop exists set semop d_semop eval $inlibc : see how much of the 'sem*(2)' library is present. h_sem=true echo " " case "$d_semctl$d_semget$d_semop" in *"$undef"*) h_sem=false;; esac : we could also check for sys/ipc.h ... if $h_sem && $test `./findhdr sys/sem.h`; then echo "You have the full sem*(2) library." >&4 val="$define" else echo "You don't have the full sem*(2) library." >&4 val="$undef" fi set d_sem eval $setvar : see if setegid exists set setegid d_setegid eval $inlibc : see if seteuid exists set seteuid d_seteuid eval $inlibc : see if setlinebuf exists set setlinebuf d_setlinebuf eval $inlibc : see if setlocale exists set setlocale d_setlocale eval $inlibc : see if setpgid exists set setpgid d_setpgid eval $inlibc : see if setpgrp2 exists set setpgrp2 d_setpgrp2 eval $inlibc : see if setpriority exists set setpriority d_setprior eval $inlibc : see if setregid exists set setregid d_setregid eval $inlibc set setresgid d_setresgid eval $inlibc : see if setreuid exists set setreuid d_setreuid eval $inlibc set setresuid d_setresuid eval $inlibc : see if setrgid exists set setrgid d_setrgid eval $inlibc : see if setruid exists set setruid d_setruid eval $inlibc : see if setsid exists set setsid d_setsid eval $inlibc : see if shmctl exists set shmctl d_shmctl eval $inlibc : see if shmget exists set shmget d_shmget eval $inlibc : see if shmat exists set shmat d_shmat eval $inlibc : see what shmat returns case "$d_shmat" in "$define") $cat >shmat.c <<'END' #include void *shmat(); END if $cc $ccflags -c shmat.c >/dev/null 2>&1; then shmattype='void *' else shmattype='char *' fi echo "and it returns ($shmattype)." >&4 : see if a prototype for shmat is available $cppstdin $cppflags $cppminus < $usrinc/sys/shm.h > shmat.c 2>/dev/null if $contains 'shmat.*(' shmat.c >/dev/null 2>&1; then val="$define" else val="$undef" fi $rm -f shmat.[co] ;; *) val="$undef" ;; esac set d_shmatprototype eval $setvar : see if shmdt exists set shmdt d_shmdt eval $inlibc : see how much of the 'shm*(2)' library is present. h_shm=true echo " " case "$d_shmctl$d_shmget$d_shmat$d_shmdt" in *"$undef"*) h_shm=false;; esac : we could also check for sys/ipc.h ... if $h_shm && $test `./findhdr sys/shm.h`; then echo "You have the full shm*(2) library." >&4 val="$define" else echo "You don't have the full shm*(2) library." >&4 val="$undef" fi set d_shm eval $setvar socketlib='' sockethdr='' : see whether socket exists echo " " $echo $n "Hmm... $c" >&4 if set socket val -f d_socket; eval $csym; $val; then echo "Looks like you have Berkeley networking support." >&4 d_socket="$define" if set setsockopt val -f; eval $csym; $val; then d_oldsock="$undef" else echo "...but it uses the old 4.1c interface, rather than 4.2" >&4 d_oldsock="$define" fi else if $contains socklib libc.list >/dev/null 2>&1; then echo "Looks like you have Berkeley networking support." >&4 d_socket="$define" : we will have to assume that it supports the 4.2 BSD interface d_oldsock="$undef" else echo "You don't have Berkeley networking in libc.a..." >&4 if test -f /usr/lib/libnet.a; then ( (nm $nm_opt /usr/lib/libnet.a | eval $nm_extract) || \ ar t /usr/lib/libnet.a) 2>/dev/null >> libc.list if $contains socket libc.list >/dev/null 2>&1; then echo "...but the Wollongong group seems to have hacked it in." >&4 socketlib="-lnet" sockethdr="-I/usr/netinclude" d_socket="$define" if $contains setsockopt libc.list >/dev/null 2>&1; then d_oldsock="$undef" else echo "...using the old 4.1c interface, rather than 4.2" >&4 d_oldsock="$define" fi else echo "or even in libnet.a, which is peculiar." >&4 d_socket="$undef" d_oldsock="$undef" fi else echo "or anywhere else I see." >&4 d_socket="$undef" d_oldsock="$undef" fi fi fi : see if socketpair exists set socketpair d_sockpair eval $inlibc : see if stat knows about block sizes echo " " xxx=`./findhdr sys/stat.h` if $contains 'st_blocks;' "$xxx" >/dev/null 2>&1 ; then if $contains 'st_blksize;' "$xxx" >/dev/null 2>&1 ; then echo "Your stat() knows about block sizes." >&4 val="$define" else echo "Your stat() doesn't know about block sizes." >&4 val="$undef" fi else echo "Your stat() doesn't know about block sizes." >&4 val="$undef" fi set d_statblks eval $setvar : see if strcoll exists set strcoll d_strcoll eval $inlibc : check for structure copying echo " " echo "Checking to see if your C compiler can copy structs..." >&4 $cat >try.c <<'EOCP' main() { struct blurfl { int dyick; } foo, bar; foo = bar; } EOCP if $cc -c try.c >/dev/null 2>&1 ; then val="$define" echo "Yup, it can." else val="$undef" echo "Nope, it can't." fi set d_strctcpy eval $setvar $rm -f try.* : see if strerror and/or sys_errlist[] exist echo " " if set strerror val -f d_strerror; eval $csym; $val; then echo 'strerror() found.' >&4 d_strerror="$define" d_strerrm='strerror(e)' if set sys_errlist val -a d_syserrlst; eval $csym; $val; then echo "(You also have sys_errlist[], so we could roll our own strerror.)" d_syserrlst="$define" else echo "(Since you don't have sys_errlist[], sterror() is welcome.)" d_syserrlst="$undef" fi elif xxx=`./findhdr string.h`; test "$xxx" || xxx=`./findhdr strings.h`; \ $contains '#[ ]*define.*strerror' "$xxx" >/dev/null 2>&1; then echo 'strerror() found in string header.' >&4 d_strerror="$define" d_strerrm='strerror(e)' if set sys_errlist val -a d_syserrlst; eval $csym; $val; then echo "(Most probably, strerror() uses sys_errlist[] for descriptions.)" d_syserrlst="$define" else echo "(You don't appear to have any sys_errlist[], how can this be?)" d_syserrlst="$undef" fi elif set sys_errlist val -a d_syserrlst; eval $csym; $val; then echo "strerror() not found, but you have sys_errlist[] so we'll use that." >&4 d_strerror="$undef" d_syserrlst="$define" d_strerrm='((e)<0||(e)>=sys_nerr?"unknown":sys_errlist[e])' else echo 'strerror() and sys_errlist[] NOT found.' >&4 d_strerror="$undef" d_syserrlst="$undef" d_strerrm='"unknown"' fi : see if strxfrm exists set strxfrm d_strxfrm eval $inlibc : see if symlink exists set symlink d_symlink eval $inlibc : see if syscall exists set syscall d_syscall eval $inlibc : see if sysconf exists set sysconf d_sysconf eval $inlibc : see if system exists set system d_system eval $inlibc : see if tcgetpgrp exists set tcgetpgrp d_tcgetpgrp eval $inlibc : see if tcsetpgrp exists set tcsetpgrp d_tcsetpgrp eval $inlibc : define an is-a-typedef? function typedef='type=$1; var=$2; def=$3; shift; shift; shift; inclist=$@; case "$inclist" in "") inclist="sys/types.h";; esac; eval "val=\$$var"; case "$val" in "") $rm -f temp.c; for inc in $inclist; do echo "#include <$inc>" >>temp.c; done; $cppstdin $cppflags $cppminus < temp.c >temp.E 2>/dev/null; if $contains $type temp.E >/dev/null 2>&1; then eval "$var=$type"; else eval "$var=$def"; fi; $rm -f temp.?;; *) eval "$var=$val";; esac' : see if this is a sys/times.h system set sys/times.h i_systimes eval $inhdr : see if times exists echo " " if set times val -f d_times; eval $csym; $val; then echo 'times() found.' >&4 d_times="$define" inc='' case "$i_systimes" in "$define") inc='sys/times.h';; esac set clock_t clocktype long stdio.h sys/types.h $inc eval $typedef dflt="$clocktype" echo " " rp="What type is returned by times() on this sytem?" . ./myread clocktype="$ans" else echo 'times() NOT found, hope that will do.' >&4 d_times="$undef" clocktype='int' fi : see if truncate exists set truncate d_truncate eval $inlibc : see if tzname[] exists echo " " if set tzname val -a d_tzname; eval $csym; $val; then val="$define" echo 'tzname[] found.' >&4 else val="$undef" echo 'tzname[] NOT found.' >&4 fi set d_tzname eval $setvar : see if umask exists set umask d_umask eval $inlibc : see if we have to deal with yellow pages, now NIS. if $test -d /usr/etc/yp || $test -d /etc/yp; then if $test -f /usr/etc/nibindd; then echo " " echo "I'm fairly confident you're on a NeXT." echo " " rp='Do you get the hosts file via NetInfo?' dflt=y case "$hostcat" in nidump*) ;; '') ;; *) dflt=n;; esac . ./myread case "$ans" in y*) hostcat='nidump hosts .';; *) hostcat='cat /etc/hosts';; esac fi case "$hostcat" in nidump*) ;; *) case "$hostcat" in *ypcat*) dflt=y;; '') if $contains '^\+' /etc/passwd >/dev/null 2>&1; then dflt=y else dflt=n fi;; *) dflt=n;; esac echo " " rp='Are you getting the hosts file via yellow pages?' . ./myread case "$ans" in y*) hostcat='ypcat hosts';; *) hostcat='cat /etc/hosts';; esac ;; esac fi : now get the host name echo " " echo "Figuring out host name..." >&4 case "$myhostname" in '') cont=true echo 'Maybe "hostname" will work...' if tans=`sh -c hostname 2>&1` ; then myhostname=$tans phostname=hostname cont='' fi ;; *) cont='';; esac if $test "$cont"; then if xenix; then echo 'Oh, dear. Maybe "/etc/systemid" is the key...' if tans=`cat /etc/systemid 2>&1` ; then myhostname=$tans phostname='cat /etc/systemid' echo "Whadyaknow. Xenix always was a bit strange..." cont='' fi elif $test -r /etc/systemid; then echo "(What is a non-Xenix system doing with /etc/systemid?)" fi fi if $test "$cont"; then echo 'No, maybe "uuname -l" will work...' if tans=`sh -c 'uuname -l' 2>&1` ; then myhostname=$tans phostname='uuname -l' else echo 'Strange. Maybe "uname -n" will work...' if tans=`sh -c 'uname -n' 2>&1` ; then myhostname=$tans phostname='uname -n' else echo 'Oh well, maybe I can mine it out of whoami.h...' if tans=`sh -c $contains' sysname $usrinc/whoami.h' 2>&1` ; then myhostname=`echo "$tans" | $sed 's/^.*"\(.*\)"/\1/'` phostname="sed -n -e '"'/sysname/s/^.*\"\\(.*\\)\"/\1/{'"' -e p -e q -e '}' <$usrinc/whoami.h" else case "$myhostname" in '') echo "Does this machine have an identity crisis or something?" phostname='';; *) echo "Well, you said $myhostname before..." phostname='echo $myhostname';; esac fi fi fi fi : you do not want to know about this set $myhostname myhostname=$1 : translate upper to lower if necessary case "$myhostname" in *[A-Z]*) echo "(Normalizing case in your host name)" myhostname=`echo $myhostname | tr '[A-Z]' '[a-z]'` ;; esac : verify guess if $test "$myhostname" ; then dflt=y rp='Your host name appears to be "'$myhostname'".'" Right?" . ./myread case "$ans" in y*) ;; *) myhostname='';; esac fi : bad guess or no guess while $test "X$myhostname" = X ; do dflt='' rp="Please type the (one word) name of your host:" . ./myread myhostname="$ans" done : a little sanity check here case "$phostname" in '') ;; *) case `$phostname | tr '[A-Z]' '[a-z]'` in $myhostname$mydomain|$myhostname) ;; *) case "$phostname" in sed*) echo "(That doesn't agree with your whoami.h file, by the way.)" ;; *) echo "(That doesn't agree with your $phostname command, by the way.)" ;; esac ;; esac ;; esac : see how we will look up host name echo " " if false; then : dummy stub to allow use of elif elif set uname val -f d_uname; eval $csym; $val; then if xenix; then $cat <<'EOM' uname() was found, but you're running xenix, and older versions of xenix have a broken uname(). If you don't really know whether your xenix is old enough to have a broken system call, use the default answer. EOM dflt=y case "$d_uname" in "$define") dflt=n;; esac rp='Is your uname() broken?' . ./myread case "$ans" in n*) d_uname="$define"; call=uname;; esac else echo 'uname() found.' >&4 d_uname="$define" call=uname fi fi case "$d_gethname" in '') d_gethname="$undef";; esac case "$d_uname" in '') d_uname="$undef";; esac case "$d_phostname" in '') d_phostname="$undef";; esac : backward compatibility for d_hvfork if test X$d_hvfork != X; then d_vfork="$d_hvfork" d_hvfork='' fi : see if there is a vfork val='' set vfork val eval $inlibc : Ok, but do we want to use it. vfork is reportedly unreliable in : perl on Solaris 2.x, and probably elsewhere. case "$val" in $define) echo " " case "$usevfork" in false) dflt='n';; *) dflt='y';; esac rp="Some systems have problems with vfork(). Do you want to use it?" . ./myread case "$ans" in y|Y) ;; *) echo "Ok, we won't use vfork()." val="$undef" ;; esac ;; esac set d_vfork eval $setvar case "$d_vfork" in $define) usevfork='true';; *) usevfork='false';; esac : see if this is an sysdir system set sys/dir.h i_sysdir eval $inhdr : see if this is an sysndir system set sys/ndir.h i_sysndir eval $inhdr : see if closedir exists set closedir d_closedir eval $inlibc case "$d_closedir" in "$define") echo " " echo "Checking whether closedir() returns a status..." >&4 cat > closedir.c < #if defined(NeXT) && defined(I_SYS_DIR) /* NeXT needs dirent + sys/dir.h */ #include #endif #else #ifdef I_SYS_NDIR #include #else #ifdef I_SYS_DIR #ifdef hp9000s500 #include /* may be wrong in the future */ #else #include #endif #endif #endif #endif int main() { return closedir(opendir(".")); } EOM if $cc $ccflags $ldflags -o closedir closedir.c $libs > /dev/null 2>&1; then if ./closedir > /dev/null 2>&1 ; then echo "Yes, it does." val="$undef" else echo "No, it doesn't." val="$define" fi else echo "(I can't seem to compile the test program--assuming it doesn't)" val="$define" fi ;; *) val="$undef"; ;; esac set d_void_closedir eval $setvar $rm -f closedir* : see if signal is declared as pointer to function returning int or void echo " " xxx=`./findhdr signal.h` $test "$xxx" && $cppstdin $cppminus $cppflags < $xxx >$$.tmp 2>/dev/null if $contains 'int.*\*[ ]*signal' $$.tmp >/dev/null 2>&1 ; then echo "You have int (*signal())() instead of void." >&4 val="$undef" elif $contains 'void.*\*[ ]*signal' $$.tmp >/dev/null 2>&1 ; then echo "You have void (*signal())() instead of int." >&4 val="$define" elif $contains 'extern[ ]*[(\*]*signal' $$.tmp >/dev/null 2>&1 ; then echo "You have int (*signal())() instead of void." >&4 val="$undef" else case "$d_voidsig" in '') echo "I can't determine whether signal handler returns void or int..." >&4 dflt=void rp="What type does your signal handler return?" . ./myread case "$ans" in v*) val="$define";; *) val="$undef";; esac;; "$define") echo "As you already told me, signal handler returns void." >&4;; *) echo "As you already told me, signal handler returns int." >&4;; esac fi set d_voidsig eval $setvar case "$d_voidsig" in "$define") signal_t="void";; *) signal_t="int";; esac $rm -f $$.tmp : check for volatile keyword echo " " echo 'Checking to see if your C compiler knows about "volatile"...' >&4 $cat >try.c <<'EOCP' main() { typedef struct _goo_struct goo_struct; goo_struct * volatile goo = ((goo_struct *)0); struct _goo_struct { long long_int; int reg_int; char char_var; }; typedef unsigned short foo_t; char *volatile foo; volatile int bar; volatile foo_t blech; foo = foo; } EOCP if $cc -c $ccflags try.c >/dev/null 2>&1 ; then val="$define" echo "Yup, it does." else val="$undef" echo "Nope, it doesn't." fi set d_volatile eval $setvar $rm -f try.* : see if there is a wait4 set wait4 d_wait4 eval $inlibc : see if waitpid exists set waitpid d_waitpid eval $inlibc : see if wcstombs exists set wcstombs d_wcstombs eval $inlibc : see if wctomb exists set wctomb d_wctomb eval $inlibc : preserve RCS keywords in files with variable substitution, grrr Date='$Date' Id='$Id' Log='$Log' RCSfile='$RCSfile' Revision='$Revision' : check for alignment requirements echo " " case "$alignbytes" in '') echo "Checking alignment constraints..." >&4 $cat >try.c <<'EOCP' struct foobar { char foo; double bar; } try; main() { printf("%d\n", (char *)&try.bar - (char *)&try.foo); } EOCP if $cc $ccflags try.c -o try >/dev/null 2>&1; then dflt=`./try` else dflt='8' echo"(I can't seem to compile the test program...)" fi ;; *) dflt="$alignbytes" ;; esac rp="Doubles must be aligned on a how-many-byte boundary?" . ./myread alignbytes="$ans" $rm -f try.c try : determine where public executables go echo " " case "$bin" in '') dflt="$prefix/bin" ;; *) dflt="$bin" ;; esac fn=d~ rp='Pathname where the public executables will reside?' . ./getfile bin="$ans" binexp="$ansexp" if $afs; then $cat <try.c <<'EOCP' #include main() { int i; union { unsigned long l; char c[sizeof(long)]; } u; if (sizeof(long) > 4) u.l = (0x08070605L << 32) | 0x04030201L; else u.l = 0x04030201L; for (i = 0; i < sizeof(long); i++) printf("%c", u.c[i]+'0'); printf("\n"); } EOCP if $cc $ccflags try.c -o try >/dev/null 2>&1 ; then dflt=`./try` case "$dflt" in ????|????????) echo "(The test program ran ok.)";; *) echo "(The test program didn't run right for some reason.)";; esac else dflt='4321' cat <<'EOM' (I can't seem to compile the test program. Guessing big-endian...) EOM fi ;; *) echo " " dflt="$byteorder" ;; esac rp="What is the order of bytes in a long?" . ./myread byteorder="$ans" $rm -f try.c try : how do we catenate cpp tokens here? echo " " echo "Checking to see how your cpp does stuff like catenate tokens..." >&4 $cat >cpp_stuff.c <<'EOCP' #define RCAT(a,b)a/**/b #define ACAT(a,b)a ## b RCAT(Rei,ser) ACAT(Cir,cus) EOCP $cppstdin $cppflags $cppminus < cpp_stuff.c >cpp_stuff.out 2>&1 if $contains 'Circus' cpp_stuff.out >/dev/null 2>&1; then echo "Oh! Smells like ANSI's been here." echo "We can catify or stringify, separately or together!" cpp_stuff=42 elif $contains 'Reiser' cpp_stuff.out >/dev/null 2>&1; then echo "Ah, yes! The good old days!" echo "However, in the good old days we don't know how to stringify and" echo "catify at the same time." cpp_stuff=1 else $cat >&4 <&4 <try.c <<'EOCP' #if TRY & 1 void main() { #else main() { #endif extern void moo(); /* function returning void */ void (*goo)(); /* ptr to func returning void */ #if TRY & 8 void *hue; /* generic ptr */ #endif #if TRY & 2 void (*foo[10])(); #endif #if TRY & 4 if(goo == moo) { exit(0); } #endif exit(0); } EOCP if $cc -c -DTRY=$defvoidused try.c >.out 2>&1 ; then voidflags=$defvoidused echo "It appears to support void to the level $package wants ($defvoidused)." if $contains warning .out >/dev/null 2>&1; then echo "However, you might get some warnings that look like this:" $cat .out fi else echo "Hmm, your compiler has some difficulty with void. Checking further..." >&4 if $cc -c -DTRY=1 try.c >/dev/null 2>&1 ; then echo "It supports 1..." if $cc -c -DTRY=3 try.c >/dev/null 2>&1 ; then echo "It also supports 2..." if $cc -c -DTRY=7 try.c >/dev/null 2>&1 ; then voidflags=7 echo "And it supports 4 but not 8 definitely." else echo "It doesn't support 4..." if $cc -c -DTRY=11 try.c >/dev/null 2>&1 ; then voidflags=11 echo "But it supports 8." else voidflags=3 echo "Neither does it support 8." fi fi else echo "It does not support 2..." if $cc -c -DTRY=13 try.c >/dev/null 2>&1 ; then voidflags=13 echo "But it supports 4 and 8." else if $cc -c -DTRY=5 try.c >/dev/null 2>&1 ; then voidflags=5 echo "And it supports 4 but has not heard about 8." else echo "However it supports 8 but not 4." fi fi fi else echo "There is no support at all for void." voidflags=0 fi fi esac dflt="$voidflags"; rp="Your void support flags add up to what?" . ./myread voidflags="$ans" $rm -f try.* .out : see if this is a db.h system set db.h i_db eval $inhdr : see if we have the old dbm set dbm.h i_dbm eval $inhdr : see if ndbm.h is available set ndbm.h i_ndbm eval $inhdr : see if gdbm.h is available set gdbm.h i_gdbm eval $inhdr echo " " echo "Looking for extensions..." >&4 cd ../ext known_extensions='' for xxx in * ; do if $test -f $xxx/$xxx.xs; then known_extensions="$known_extensions $xxx" fi done set X $known_extensions shift known_extensions="$*" cd ../UU : Now see which are supported on this system. avail_ext='' for xxx in $known_extensions ; do case "$xxx" in DB_File) case "$i_db" in $define) avail_ext="$avail_ext $xxx" ;; esac ;; GDBM_File) case "$i_gdbm" in $define) avail_ext="$avail_ext $xxx" ;; esac ;; NDBM_File) case "$i_ndbm" in $define) avail_ext="$avail_ext $xxx" ;; esac ;; ODBM_File) case "$i_dbm" in $define) avail_ext="$avail_ext $xxx" ;; esac ;; POSIX) case "$useposix" in true|define|y) avail_ext="$avail_ext $xxx" ;; esac ;; Socket) case "$d_socket" in $define) avail_ext="$avail_ext $xxx" ;; esac ;; *) avail_ext="$avail_ext $xxx" ;; esac done set X $avail_ext shift avail_ext="$*" case $usedl in $define) $cat </dev/null` unsigned short case $1 in unsigned) dflt="$1 $2" ;; *) dflt="$1" ;; esac ;; *) dflt="$gidtype";; esac echo " " rp="What is the type for group ids returned by getgid()?" . ./myread gidtype="$ans" : see if getgroups exists set getgroups d_getgrps eval $inlibc : Find type of 2nd arg to getgroups echo " " case "$d_getgrps" in 'define') case "$groupstype" in '') dflt="$gidtype" ;; *) dflt="$groupstype" ;; esac $cat <&4 $cat >prototype.c <<'EOCP' main(int argc, char *argv[]) { exit(0);} EOCP if $cc $ccflags -c prototype.c >prototype.out 2>&1 ; then echo "Your C compiler appears to support function prototypes." val="$define" else echo "Your C compiler doesn't seem to understand function prototypes." val="$undef" fi set prototype eval $setvar $rm -f prototype* : check for size of random number generator echo " " case "$randbits" in '') echo "Checking to see how many bits your rand function produces..." >&4 $cat >try.c <<'EOCP' #include main() { register int i; register unsigned long tmp; register unsigned long max = 0L; for (i = 1000; i; i--) { tmp = (unsigned long)rand(); if (tmp > max) max = tmp; } for (i = 0; max; i++) max /= 2; printf("%d\n",i); } EOCP if $cc try.c -o try >/dev/null 2>&1 ; then dflt=`try` else dflt='?' echo "(I can't seem to compile the test program...)" fi ;; *) dflt="$randbits" ;; esac rp='How many bits does your rand() function produce?' . ./myread randbits="$ans" $rm -f try.c try : see if ar generates random libraries by itself echo " " echo "Checking how to generate random libraries on your machine..." >&4 echo 'int bar1() { return bar2(); }' > bar1.c echo 'int bar2() { return 2; }' > bar2.c $cat > foo.c <<'EOP' main() { printf("%d\n", bar1()); exit(0); } EOP $cc $ccflags -c bar1.c >/dev/null 2>&1 $cc $ccflags -c bar2.c >/dev/null 2>&1 $cc $ccflags -c foo.c >/dev/null 2>&1 ar rc bar.a bar2.o bar1.o >/dev/null 2>&1 if $cc $ccflags $ldflags -o foobar foo.o bar.a $libs > /dev/null 2>&1 && ./foobar >/dev/null 2>&1; then echo "ar appears to generate random libraries itself." orderlib=false ranlib=":" elif ar ts bar.a >/dev/null 2>&1 && $cc $ccflags $ldflags -o foobar foo.o bar.a $libs > /dev/null 2>&1 && ./foobar >/dev/null 2>&1; then echo "a table of contents needs to be added with 'ar ts'." orderlib=false ranlib="ar ts" else if $test -f /usr/bin/ranlib; then ranlib=/usr/bin/ranlib elif $test -f /bin/ranlib; then ranlib=/bin/ranlib elif $test -f /usr/local/bin/ranlib; then ranlib=/usr/local/bin/ranlib fi if $test -n "$ranlib"; then echo "your system has $ranlib; we'll use that." orderlib=false else echo "your system doesn't seem to support random libraries" echo "so we'll use lorder and tsort to order the libraries." orderlib=true ranlib=":" fi fi $rm -f foo* bar* : determine where public executable scripts go case "$scriptdir" in '') dflt="$bin" : guess some guesses $test -d /usr/share/scripts && dflt=/usr/share/scripts $test -d /usr/share/bin && dflt=/usr/share/bin $test -d /usr/local/script && dflt=/usr/local/script $test -d $prefix/script && dflt=$prefix/script ;; *) dflt="$scriptdir" ;; esac $cat <, or both." >&4 $echo $n "I'm now running the test program...$c" $cat >try.c <<'EOCP' #include #ifdef I_TIME #include #endif #ifdef I_SYSTIME #ifdef SYSTIMEKERNEL #define KERNEL #endif #include #endif #ifdef I_SYSSELECT #include #endif main() { struct tm foo; #ifdef S_TIMEVAL struct timeval bar; #endif #ifdef S_TIMEZONE struct timezone tzp; #endif if (foo.tm_sec == foo.tm_sec) exit(0); #ifdef S_TIMEVAL if (bar.tv_sec == bar.tv_sec) exit(0); #endif exit(1); } EOCP flags='' s_timezone='' sysselect='' for s_timeval in '-DS_TIMEVAL' ''; do for i_systimek in '' '-DSYSTIMEKERNEL'; do for i_time in '' '-DI_TIME'; do for i_systime in '-DI_SYSTIME' ''; do case "$flags" in '') $echo $n ".$c" if $cc $ccflags \ $i_time $i_systime $i_systimek $sysselect $s_timeval $s_timezone \ try.c -o try >/dev/null 2>&1 ; then set X $i_time $i_systime $i_systimek $sysselect $s_timeval shift flags="$*" echo " " $echo $n "Succeeded with $flags$c" fi ;; esac done done done done timeincl='' echo " " case "$flags" in *SYSTIMEKERNEL*) i_systimek="$define" timeincl=`./findhdr sys/time.h` echo "We'll include with KERNEL defined." >&4;; *) i_systimek="$undef";; esac case "$flags" in *I_TIME*) i_time="$define" timeincl=`./findhdr time.h`" $timeincl" echo "We'll include ." >&4;; *) i_time="$undef";; esac case "$flags" in *I_SYSTIME*) i_systime="$define" timeincl=`./findhdr sys/time.h`" $timeincl" echo "We'll include ." >&4;; *) i_systime="$undef";; esac $rm -f try.c try : check for fd_set items $cat <fd_set.c < #ifdef HAS_SOCKET #include /* Might include */ #endif #ifdef I_SYS_TIME #include #else #ifdef I_SYS_SELECT #include #endif #endif main() { fd_set fds; #ifdef TRYBITS if(fds.fds_bits); #endif #if defined(FD_SET) && defined(FD_CLR) && defined(FD_ISSET) && defined(FD_ZERO) exit(0); #else exit(1); #endif } EOCP if $cc $ccflags -DTRYBITS fd_set.c -o fd_set >fd_set.out 2>&1 ; then d_fds_bits="$define" d_fd_set="$define" echo "Well, your system knows about the normal fd_set typedef..." >&4 if ./fd_set; then echo "and you have the normal fd_set macros (just as I'd expect)." >&4 d_fd_macros="$define" else $cat >&4 <<'EOM' but not the normal fd_set macros! Gaaack! I'll have to cover for you. EOM d_fd_macros="$undef" fi else $cat <<'EOM' Hmm, your compiler has some difficulty with fd_set. Checking further... EOM if $cc $ccflags fd_set.c -o fd_set >fd_set.out 2>&1 ; then d_fds_bits="$undef" d_fd_set="$define" echo "Well, your system has some sort of fd_set available..." >&4 if ./fd_set; then echo "and you have the normal fd_set macros." >&4 d_fd_macros="$define" else $cat <<'EOM' but not the normal fd_set macros! Gross! More work for me... EOM d_fd_macros="$undef" fi else echo "Well, you got zip. That's OK, I can roll my own fd_set stuff." >&4 d_fd_set="$undef" d_fds_bits="$undef" d_fd_macros="$undef" fi fi $rm -f fd_set* : check for type of arguments to select. This will only really : work if the system supports prototypes and provides one for : select. case "$d_select" in $define) : Make initial guess case "$selecttype" in ''|' ') case "$d_fd_set" in $define) xxx='fd_set *' ;; *) xxx='int *' ;; esac ;; *) xxx="$selecttype" ;; esac : backup guess case "$xxx" in 'fd_set *') yyy='int *' ;; 'int *') yyy='fd_set *' ;; esac $cat <try.c < #ifdef HAS_SOCKET #include /* Might include */ #endif #ifdef I_SYS_TIME #include #else #ifdef I_SYS_SELECT #include #endif #endif main() { int width; Select_fd_set_t readfds; Select_fd_set_t writefds; Select_fd_set_t exceptfds; struct timeval timeout; select(width, readfds, writefds, exceptfds, &timeout); exit(0); } EOCP if $cc $ccflags -c -DSelect_fd_set_t="$xxx" try.c >/dev/null 2>&1 ; then selecttype="$xxx" echo "Your system uses $xxx for the arguments to select." >&4 elif $cc $ccflags -c -DSelect_fd_set_t="$yyy" try.c >/dev/null 2>&1 ; then selecttype="$yyy" echo "Your system uses $yyy for the arguments to select." >&4 else rp='What is the type for the 2nd, 3rd, and 4th arguments to select?' dflt="$xxx" . ./myread selecttype="$ans" fi $rm -f try.[co] ;; *) selecttype = 'int *' ;; esac : generate list of signal names echo " " case "$sig_name" in '') echo "Generating a list of signal names..." >&4 xxx=`./findhdr signal.h`" "`./findhdr sys/signal.h` set X `cat $xxx 2>&1 | $awk ' $1 ~ /^#define$/ && $2 ~ /^SIG[A-Z0-9]*$/ && $3 ~ /^[1-9][0-9]*$/ { sig[$3] = substr($2,4,20) if (max < $3 && $3 < 60) { max = $3 } } END { for (i = 1; i <= max; i++) { if (sig[i] == "") printf "%d", i else printf "%s", sig[i] if (i < max) printf " " } printf "\n" } '` shift case $# in 0) echo 'kill -l' >/tmp/foo$$ set X `csh -f 70) { printf "\n" linelen = length(name) } printf "%s", name } }' echo " " : see what type is used for size_t set size_t sizetype 'unsigned int' stdio.h sys/types.h eval $typedef dflt="$sizetype" echo " " rp="What type is used for the length parameter for string functions?" . ./myread sizetype="$ans" : see what type is used for signed size_t set ssize_t ssizetype int stdio.h sys/types.h eval $typedef dflt="$ssizetype" $cat > ssize.c < #include #define Size_t $sizetype #define SSize_t $dflt main() { if (sizeof(Size_t) == sizeof(SSize_t)) printf("$dflt\n"); else if (sizeof(Size_t) == sizeof(int)) printf("int\n"); else printf("long\n"); } EOM echo " " if $cc $ccflags $ldflags -o ssize ssize.c $libs > /dev/null 2>&1 ; then ssizetype=`./ssize` echo "I'll be using $ssizetype for functions returning a byte count." >&4 else echo "(I can't compile the test program--please enlighten me!)" $cat </dev/null 2>&1 ; then echo "Your stdio uses unsigned chars." >&4 stdchar="unsigned char" else echo "Your stdio uses signed chars." >&4 stdchar="char" fi : see if time exists echo " " if set time tval -f d_time; eval $csym; $tval; then echo 'time() found.' >&4 tval="$define" set time_t timetype long stdio.h sys/types.h eval $typedef dflt="$timetype" echo " " rp="What type is returned by time() on this sytem?" . ./myread timetype="$ans" else echo 'time() not found, hope that will do.' >&4 tval="$undef" timetype='int'; fi val=$tval set d_time eval $setvar : see what type uids are declared as in the kernel set uid_t uidtype xxx stdio.h sys/types.h eval $typedef case "$uidtype" in xxx) xxx=`./findhdr sys/user.h` set `grep '_ruid;' "$xxx" 2>/dev/null` unsigned short case $1 in unsigned) dflt="$1 $2" ;; *) dflt="$1" ;; esac ;; *) dflt="$uidtype";; esac echo " " rp="What is the type for user ids returned by getuid()?" . ./myread uidtype="$ans" : determine compiler compiler case "$yacc" in '') dflt=yacc;; *) dflt="$yacc";; esac echo " " comp='yacc' if $test -f "$byacc"; then dflt="$byacc" comp="byacc or $comp" fi if $test -f "$bison"; then comp="$comp or bison -y" fi rp="Which compiler compiler ($comp) shall I use?" . ./myread yacc="$ans" case "$yacc" in *bis*) case "$yacc" in *-y*) ;; *) yacc="$yacc -y" echo "(Adding -y option to bison to get yacc-compatible behaviour.)" ;; esac ;; esac : see if this is a sys/file.h system val='' set sys/file.h val eval $inhdr : do we need to #include ? case "$val" in "$define") echo " " if $h_sysfile; then val="$define" echo "We'll be including ." >&4 else val="$undef" echo "We won't be including ." >&4 fi ;; *) h_sysfile=false ;; esac set i_sysfile eval $setvar : see if fcntl.h is there val='' set fcntl.h val eval $inhdr : see if we can include fcntl.h case "$val" in "$define") echo " " if $h_fcntl; then val="$define" echo "We'll be including ." >&4 else val="$undef" if $h_sysfile; then echo "We don't need to include if we include ." >&4 else echo "We won't be including ." >&4 fi fi ;; *) h_fcntl=false val="$undef" ;; esac set i_fcntl eval $setvar : see if this is an grp system set grp.h i_grp eval $inhdr : see if this is a math.h system set math.h i_math eval $inhdr : see if memory.h is available. val='' set memory.h val eval $inhdr : See if it conflicts with string.h case "$val" in $define) case "$strings" in '') ;; *) $cppstdin $cppflags $cppminus < $strings > mem.h if $contains 'memcpy' mem.h >/dev/null 2>&1; then echo " " echo "We won't be including ." val="$undef" fi $rm -f mem.h ;; esac esac set i_memory eval $setvar : see if net/errno.h is available val='' set net/errno.h val eval $inhdr : Unfortunately, it causes problems on some systems. Arrgh. case "$val" in $define) cat > try.c <<'EOM' #include #include #include int func() { return ENOTSOCK; } EOM if $cc $ccflags -c try.c >/dev/null 2>&1; then echo "We'll be including ." >&4 else echo "We won't be including ." >&4 val="$undef" fi $rm -f try.* try ;; esac set i_neterrno eval $setvar : get C preprocessor symbols handy echo " " echo $al | $tr ' ' '\012' >Cppsym.know $cat <Cppsym $startsh case "\$1" in -l) list=true shift ;; esac unknown='' case "\$list\$#" in 1|2) for sym do if $contains "^\$1$" Cppsym.true >/dev/null 2>&1; then exit 0 elif $contains "^\$1$" Cppsym.know >/dev/null 2>&1; then : else unknown="\$unknown \$sym" fi done set X \$unknown shift ;; esac case \$# in 0) exit 1;; esac echo \$* | $tr ' ' '\012' | $sed -e 's/\(.*\)/\\ #ifdef \1\\ exit 0; _ _ _ _\1\\ \1\\ #endif\\ /' >Cppsym\$\$ echo "exit 1; _ _ _" >>Cppsym\$\$ $cppstdin $cppminus Cppsym2\$\$ case "\$list" in true) $awk 'NF > 5 {print substr(\$6,2,100)}' Cppsym.true $cat Cppsym.true : see if this is a termio system val="$undef" val2="$undef" val3="$undef" if $test `./findhdr termios.h`; then set tcsetattr i_termios eval $inlibc val3="$i_termios" fi echo " " case "$val3" in "$define") echo "You have POSIX termios.h... good!" >&4;; *) if Cppsym pyr; then case "`/bin/universe`" in ucb) if $test `./findhdr sgtty.h`; then val2="$define" echo " found." >&4 else echo "System is pyramid with BSD universe." echo " not found--you could have problems." >&4 fi;; *) if $test `./findhdr termio.h`; then val="$define" echo " found." >&4 else echo "System is pyramid with USG universe." echo " not found--you could have problems." >&4 fi;; esac elif usg; then if $test `./findhdr termio.h`; then echo " found." >&4 val="$define" elif $test `./findhdr sgtty.h`; then echo " found." >&4 val2="$define" else echo "Neither nor found--you could have problems." >&4 fi else if $test `./findhdr sgtty.h`; then echo " found." >&4 val2="$define" elif $test `./findhdr termio.h`; then echo " found." >&4 val="$define" else echo "Neither nor found--you could have problems." >&4 fi fi;; esac set i_termio; eval $setvar val=$val2; set i_sgtty; eval $setvar val=$val3; set i_termios; eval $setvar : see if stdarg is available echo " " if $test `./findhdr stdarg.h`; then echo " found." >&4 valstd="$define" else echo " NOT found." >&4 valstd="$undef" fi : see if varags is available echo " " if $test `./findhdr varargs.h`; then echo " found." >&4 else echo " NOT found, but that's ok (I hope)." >&4 fi : set up the varargs testing programs $cat > varargs.c < #endif #ifdef I_VARARGS #include #endif #ifdef I_STDARG int f(char *p, ...) #else int f(va_alist) va_dcl #endif { va_list ap; #ifndef I_STDARG char *p; #endif #ifdef I_STDARG va_start(ap,p); #else va_start(ap); p = va_arg(ap, char *); #endif va_end(ap); } EOP $cat > varargs </dev/null 2>&1; then echo "true" else echo "false" fi $rm -f varargs.o EOP chmod +x varargs : now check which varargs header should be included echo " " i_varhdr='' case "$valstd" in "$define") if `./varargs I_STDARG`; then val='stdarg.h' elif `./varargs I_VARARGS`; then val='varargs.h' fi ;; *) if `./varargs I_VARARGS`; then val='varargs.h' fi ;; esac case "$val" in '') echo "I could not find the definition for va_dcl... You have problems..." >&4 val="$undef"; set i_stdarg; eval $setvar val="$undef"; set i_varargs; eval $setvar ;; *) set i_varhdr eval $setvar case "$i_varhdr" in stdarg.h) val="$define"; set i_stdarg; eval $setvar val="$undef"; set i_varargs; eval $setvar ;; varargs.h) val="$undef"; set i_stdarg; eval $setvar val="$define"; set i_varargs; eval $setvar ;; esac echo "We'll include <$i_varhdr> to get va_dcl definition." >&4;; esac $rm -f varargs* : see if stddef is available set stddef.h i_stddef eval $inhdr : see if stdlib is available set stdlib.h i_stdlib eval $inhdr : see if ioctl defs are in sgtty, termio, sys/filio or sys/ioctl set sys/filio.h i_sysfilio eval $inhdr echo " " if $test `./findhdr sys/ioctl.h`; then val="$define" echo ' found.' >&4 else val="$undef" if $test $i_sysfilio = "$define"; then echo ' NOT found.' >&4 else $test $i_sgtty = "$define" && xxx="sgtty.h" $test $i_termio = "$define" && xxx="termio.h" $test $i_termios = "$define" && xxx="termios.h" echo "No found, assuming ioctl args are defined in <$xxx>." >&4 fi fi set i_sysioctl eval $setvar : see if this is a sys/param system set sys/param.h i_sysparam eval $inhdr : see if this is a unistd.h system set unistd.h i_unistd eval $inhdr : see if this is an utime system set utime.h i_utime eval $inhdr : see if this is a vfork system case "$d_vfork" in "$define") set vfork.h i_vfork eval $inhdr ;; *) i_vfork="$undef" ;; esac : end of configuration questions echo " " echo "End of configuration questions." echo " " : back to where it started if test -d ../UU; then cd .. fi : configuration may be patched via a 'config.over' file if $test -f config.over; then echo " " dflt=y rp='I see a config.over file. Do you wish to load it?' . UU/myread case "$ans" in n*) echo "OK, I'll ignore it.";; *) . ./config.over echo "Configuration override changes have been loaded." ;; esac fi : create config.sh file echo " " echo "Creating config.sh..." >&4 $spitshell <config.sh $startsh # # This file was produced by running the Configure script. It holds all the # definitions figured out by Configure. Should you modify one of these values, # do not forget to propagate your changes by running "Configure -der". You may # instead choose to run each of the .SH files by yourself, or "Configure -S". # # Configuration time: $cf_time # Configured by: $cf_by # Target system: $myuname dynamic_ext='$dynamic_ext' extensions='$extensions' known_extensions='$known_extensions' static_ext='$static_ext' useposix='$useposix' d_eunice='$d_eunice' d_xenix='$d_xenix' eunicefix='$eunicefix' Mcc='$Mcc' awk='$awk' bash='$bash' bison='$bison' byacc='$byacc' cat='$cat' chgrp='$chgrp' chmod='$chmod' chown='$chown' compress='$compress' cp='$cp' cpio='$cpio' cpp='$cpp' csh='$csh' date='$date' echo='$echo' egrep='$egrep' emacs='$emacs' expr='$expr' find='$find' flex='$flex' gcc='$gcc' grep='$grep' inews='$inews' ksh='$ksh' less='$less' line='$line' lint='$lint' ln='$ln' lp='$lp' lpr='$lpr' ls='$ls' mail='$mail' mailx='$mailx' make='$make' mkdir='$mkdir' more='$more' mv='$mv' nroff='$nroff' perl='$perl' pg='$pg' pmake='$pmake' pr='$pr' rm='$rm' rmail='$rmail' sed='$sed' sendmail='$sendmail' sh='$sh' shar='$shar' sleep='$sleep' smail='$smail' sort='$sort' submit='$submit' tail='$tail' tar='$tar' tbl='$tbl' test='$test' touch='$touch' tr='$tr' troff='$troff' uname='$uname' uniq='$uniq' uuname='$uuname' vi='$vi' zcat='$zcat' libswanted='$libswanted' hint='$hint' myuname='$myuname' osname='$osname' osvers='$osvers' Author='$Author' Date='$Date' Header='$Header' Id='$Id' Locker='$Locker' Log='$Log' RCSfile='$RCSfile' Revision='$Revision' Source='$Source' State='$State' afs='$afs' alignbytes='$alignbytes' archlib='$archlib' archlibexp='$archlibexp' archname='$archname' d_archlib='$d_archlib' installarchlib='$installarchlib' bin='$bin' binexp='$binexp' installbin='$installbin' byteorder='$byteorder' cc='$cc' gccversion='$gccversion' ccflags='$ccflags' cppflags='$cppflags' ldflags='$ldflags' lkflags='$lkflags' optimize='$optimize' cf_by='$cf_by' cf_time='$cf_time' contains='$contains' cpp_stuff='$cpp_stuff' cpplast='$cpplast' cppminus='$cppminus' cpprun='$cpprun' cppstdin='$cppstdin' d_access='$d_access' d_alarm='$d_alarm' d_attrib='$d_attrib' d_bcmp='$d_bcmp' d_bcopy='$d_bcopy' d_bzero='$d_bzero' d_casti32='$d_casti32' castflags='$castflags' d_castneg='$d_castneg' d_charsprf='$d_charsprf' d_chown='$d_chown' d_chroot='$d_chroot' d_chsize='$d_chsize' d_closedir='$d_closedir' d_void_closedir='$d_void_closedir' d_const='$d_const' cryptlib='$cryptlib' d_crypt='$d_crypt' d_csh='$d_csh' d_cuserid='$d_cuserid' d_dbl_dig='$d_dbl_dig' d_difftime='$d_difftime' d_dlerror='$d_dlerror' d_dlopen='$d_dlopen' d_dlsymun='$d_dlsymun' d_dosuid='$d_dosuid' d_suidsafe='$d_suidsafe' d_drem='$d_drem' d_dup2='$d_dup2' d_fchmod='$d_fchmod' d_fchown='$d_fchown' d_fcntl='$d_fcntl' d_fd_macros='$d_fd_macros' d_fd_set='$d_fd_set' d_fds_bits='$d_fds_bits' d_fgetpos='$d_fgetpos' d_flexfnam='$d_flexfnam' d_flock='$d_flock' d_fmod='$d_fmod' d_fork='$d_fork' d_fsetpos='$d_fsetpos' d_Gconvert='$d_Gconvert' d_getgrps='$d_getgrps' d_gethent='$d_gethent' aphostname='$aphostname' d_gethname='$d_gethname' d_phostname='$d_phostname' d_uname='$d_uname' d_getlogin='$d_getlogin' d_getpgrp2='$d_getpgrp2' d_getpgrp='$d_getpgrp' d_getppid='$d_getppid' d_getprior='$d_getprior' d_group='$d_group' d_htonl='$d_htonl' d_isascii='$d_isascii' d_killpg='$d_killpg' d_link='$d_link' d_linuxstd='$d_linuxstd' d_locconv='$d_locconv' d_lockf='$d_lockf' d_lstat='$d_lstat' d_mblen='$d_mblen' d_mbstowcs='$d_mbstowcs' d_mbtowc='$d_mbtowc' d_memcmp='$d_memcmp' d_memcpy='$d_memcpy' d_memmove='$d_memmove' d_memset='$d_memset' d_mkdir='$d_mkdir' d_mkfifo='$d_mkfifo' d_mktime='$d_mktime' d_msg='$d_msg' d_msgctl='$d_msgctl' d_msgget='$d_msgget' d_msgrcv='$d_msgrcv' d_msgsnd='$d_msgsnd' d_nice='$d_nice' d_open3='$d_open3' d_passwd='$d_passwd' d_fpathconf='$d_fpathconf' d_pathconf='$d_pathconf' d_pause='$d_pause' d_pipe='$d_pipe' d_portable='$d_portable' d_readdir='$d_readdir' d_rewinddir='$d_rewinddir' d_seekdir='$d_seekdir' d_telldir='$d_telldir' d_readlink='$d_readlink' d_rename='$d_rename' d_rmdir='$d_rmdir' d_safebcpy='$d_safebcpy' d_safemcpy='$d_safemcpy' d_select='$d_select' d_sem='$d_sem' d_semctl='$d_semctl' d_semget='$d_semget' d_semop='$d_semop' d_setegid='$d_setegid' d_seteuid='$d_seteuid' d_setlinebuf='$d_setlinebuf' d_setlocale='$d_setlocale' d_setpgid='$d_setpgid' d_setpgrp2='$d_setpgrp2' d_bsdpgrp='$d_bsdpgrp' d_setpgrp='$d_setpgrp' d_setprior='$d_setprior' d_setregid='$d_setregid' d_setresgid='$d_setresgid' d_setresuid='$d_setresuid' d_setreuid='$d_setreuid' d_setrgid='$d_setrgid' d_setruid='$d_setruid' d_setsid='$d_setsid' d_shm='$d_shm' d_shmat='$d_shmat' d_shmatprototype='$d_shmatprototype' shmattype='$shmattype' d_shmctl='$d_shmctl' d_shmdt='$d_shmdt' d_shmget='$d_shmget' d_oldsock='$d_oldsock' d_socket='$d_socket' d_sockpair='$d_sockpair' sockethdr='$sockethdr' socketlib='$socketlib' d_statblks='$d_statblks' d_stdstdio='$d_stdstdio' d_index='$d_index' d_strchr='$d_strchr' d_strcoll='$d_strcoll' d_strctcpy='$d_strctcpy' d_strerrm='$d_strerrm' d_strerror='$d_strerror' d_sysernlst='$d_sysernlst' d_syserrlst='$d_syserrlst' d_strxfrm='$d_strxfrm' d_symlink='$d_symlink' d_syscall='$d_syscall' d_sysconf='$d_sysconf' d_system='$d_system' d_tcgetpgrp='$d_tcgetpgrp' d_tcsetpgrp='$d_tcsetpgrp' d_time='$d_time' timetype='$timetype' clocktype='$clocktype' d_times='$d_times' d_truncate='$d_truncate' d_tzname='$d_tzname' d_umask='$d_umask' d_vfork='$d_vfork' usevfork='$usevfork' d_voidsig='$d_voidsig' signal_t='$signal_t' d_volatile='$d_volatile' d_charvspr='$d_charvspr' d_vprintf='$d_vprintf' d_wait4='$d_wait4' d_waitpid='$d_waitpid' d_wcstombs='$d_wcstombs' d_wctomb='$d_wctomb' dlext='$dlext' cccdlflags='$cccdlflags' ccdlflags='$ccdlflags' dlsrc='$dlsrc' lddlflags='$lddlflags' usedl='$usedl' fpostype='$fpostype' gidtype='$gidtype' groupstype='$groupstype' h_fcntl='$h_fcntl' h_sysfile='$h_sysfile' i_db='$i_db' i_dbm='$i_dbm' d_dirnamlen='$d_dirnamlen' direntrytype='$direntrytype' i_dirent='$i_dirent' i_dld='$i_dld' i_dlfcn='$i_dlfcn' i_fcntl='$i_fcntl' i_float='$i_float' i_gdbm='$i_gdbm' i_grp='$i_grp' i_limits='$i_limits' i_malloc='$i_malloc' i_math='$i_math' i_memory='$i_memory' i_ndbm='$i_ndbm' i_neterrno='$i_neterrno' i_niin='$i_niin' i_sysin='$i_sysin' d_pwage='$d_pwage' d_pwchange='$d_pwchange' d_pwclass='$d_pwclass' d_pwcomment='$d_pwcomment' d_pwexpire='$d_pwexpire' d_pwquota='$d_pwquota' i_pwd='$i_pwd' i_stddef='$i_stddef' i_stdlib='$i_stdlib' i_string='$i_string' strings='$strings' i_sysdir='$i_sysdir' i_sysfile='$i_sysfile' d_voidtty='$d_voidtty' i_bsdioctl='$i_bsdioctl' i_sysfilio='$i_sysfilio' i_sysioctl='$i_sysioctl' i_syssockio='$i_syssockio' i_sysndir='$i_sysndir' i_sysparam='$i_sysparam' i_sysselct='$i_sysselct' i_systimes='$i_systimes' i_sgtty='$i_sgtty' i_termio='$i_termio' i_termios='$i_termios' i_systime='$i_systime' i_systimek='$i_systimek' i_time='$i_time' timeincl='$timeincl' i_unistd='$i_unistd' i_utime='$i_utime' i_stdarg='$i_stdarg' i_varargs='$i_varargs' i_varhdr='$i_varhdr' i_vfork='$i_vfork' intsize='$intsize' libc='$libc' glibpth='$glibpth' libpth='$libpth' plibpth='$plibpth' xlibpth='$xlibpth' libs='$libs' lns='$lns' lseektype='$lseektype' d_mymalloc='$d_mymalloc' mallocobj='$mallocobj' mallocsrc='$mallocsrc' malloctype='$malloctype' usemymalloc='$usemymalloc' installmansrc='$installmansrc' manext='$manext' mansrc='$mansrc' mansrcexp='$mansrcexp' huge='$huge' large='$large' medium='$medium' models='$models' small='$small' split='$split' modetype='$modetype' mydomain='$mydomain' myhostname='$myhostname' phostname='$phostname' c='$c' n='$n' groupcat='$groupcat' hostcat='$hostcat' passcat='$passcat' orderlib='$orderlib' ranlib='$ranlib' package='$package' spackage='$spackage' prefix='$prefix' installprivlib='$installprivlib' privlib='$privlib' privlibexp='$privlibexp' prototype='$prototype' randbits='$randbits' installscript='$installscript' scriptdir='$scriptdir' scriptdirexp='$scriptdirexp' selecttype='$selecttype' sig_name='$sig_name' sizetype='$sizetype' so='$so' sharpbang='$sharpbang' shsharp='$shsharp' spitshell='$spitshell' ssizetype='$ssizetype' startsh='$startsh' stdchar='$stdchar' sysman='$sysman' uidtype='$uidtype' nm_opt='$nm_opt' runnm='$runnm' usenm='$usenm' incpath='$incpath' mips='$mips' mips_type='$mips_type' usrinc='$usrinc' defvoidused='$defvoidused' voidflags='$voidflags' yacc='$yacc' yaccflags='$yaccflags' EOT : add special variables $test -f patchlevel.h && \ awk '/^#define/ {printf "%s=%s\n",$2,$3}' patchlevel.h >>config.sh echo "CONFIG=true" >>config.sh : propagate old symbols if $test -f UU/config.sh; then UU/oldconfig.sh sed -n 's/^\([a-zA-Z_0-9]*\)=.*/\1/p' config.sh config.sh UU/oldconfig.sh |\ sort | uniq -u >UU/oldsyms set X `cat UU/oldsyms` shift case $# in 0) ;; *) cat <>config.sh for sym in `cat UU/oldsyms`; do echo " Propagating $hint variable "'$'"$sym..." eval 'tmp="$'"${sym}"'"' echo "$tmp" | \ sed -e "s/'/'\"'\"'/g" -e "s/^/$sym='/" -e "s/$/'/" >>config.sh done ;; esac fi : Finish up by extracting the .SH files case "$alldone" in exit) $rm -rf UU echo "Done." exit 0 ;; cont) ;; '') echo " " dflt='' nostick=true echo "If you didn't make any mistakes, then just type a carriage return here." rp="If you need to edit config.sh, do it as a shell escape here:" . UU/myread nostick='' case "$ans" in '') ;; *) : in case they cannot read sh 1>&4 -c "$ans";; esac ;; esac : if this fails, just run all the .SH files by hand . ./config.sh echo " " exec 1>&4 . ./UU/extract if $contains '^depend:' [Mm]akefile >/dev/null 2>&1; then dflt=y case "$silent" in true) ;; *) $cat < makedepend.out &" It can take a while, so you might not want to run it right now. EOM ;; esac rp="Run make depend now?" . UU/myread case "$ans" in y*) make depend && echo "Now you must run a make." ;; *) echo "You must run 'make depend' then 'make'." ;; esac elif test -f [Mm]akefile; then echo " " echo "Now you must run a make." else echo "Done." fi $rm -f kit*isdone ark*isdone $rm -rf UU : End of Configure castflags='$castflags' d_castneg='$d_castneg' d_charsprf='$d_charsprf' d_chown='$d_chown' d_chroot='$d_chroot' d_chsize='$d_chsize' d_closedir='$d_closedir' d_void_closedir='$d_void_closedir' d_const='$d_const' cryptlib='$cryptlib' d_crypt='$d_crypt' d_csh='$d_csh' d_cuserid='$d_cuserid' d_dbl_dig='$d_dbl_dig' d_difftime='$d_difftime' d_dlerror='$d_dlerror' d_dlopen='$d_dlopen' d_dlsymun='$d_dlsymun' d_dosuid='$d_dosuid' d_suidsafe='$d_suidsafe' d_drem='perl5.000/Copying 664 203 12 30307 5217227513 7006 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! tion of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable forperl5.000/Doc/ 775 203 12 0 5650575646 6066 perl5.000/Doc/perl5-notes 664 203 12 25240 5561232240 10253 #!/usr/local/bin/perl5 # perl5 -x notes 2> expected > actual ; diff expected actual open(EVAL, "| perl5 -x") || die "Can't pipe to perl5\n"; while () { m/prints ``(.*)''$/ && print STDERR $1,"\n"; print EVAL $_; } __END__ #!/usr/local/bin/perl5 # # Perl5a6 notes: Patchlevel 3 # # This document is in the public domain. # # Written by Tony Sanders # # Quick examples of the new Perl5 features as of alpha6. Look in the # file Changes, the man page, and in the test suite (esp t/op/ref.t) # for more information. There are also a number of files in the alpha6 # release (e.g., tie*) that show how to use various features. Also, there # are a number of package modules in lib/*.pm that are of interest. # # Thanks to the following for their input: # Johan.Vromans@NL.net # Daniel Faken # Tom Christiansen # Dean Roehrich # Larry Wall # Lionel Cons # # BEGIN { } # executed at load time print "doody\n"; BEGIN { print "howdy\n"; } # prints ``howdy'' # then prints ``doody'' # END { } # executed at exit time in reverse order of definition END { print "blue sky\n"; } # will print ``blue sky'' END { print "goodbye\n"; } # will print ``goodbye'' # (expr?lval:lval) = value; # The (?:) operator can be used as an lvalue. $a = 1; $b = 2; (defined $b ? $a : $b) = 10; print "$a:$b\n"; # prints ``10:2'' # new functions: abs, chr, uc, ucfirst, lc, lcfirst print abs(-10), "\n"; # prints ``10'' print chr(64), "\n"; # prints ``@'' print uc("the"), "\n"; # prints ``THE'' print ucfirst("the"), "\n"; # prints ``The'' print lc("THE"), "\n"; # prints ``the'' print lcfirst("THE"), "\n"; # prints ``tHE'' # references # references $thing1 = "testing"; $ref = \$thing1; # \ creates a reference print $$ref,"\n" if ${$ref} eq $$ref; # deref, prints ``testing'' # symbolic references sub bat { "baz"; } sub baz { print "foobar\n" }; &{&bat}; # prints ``foobar'' # symbol table assignment: *foo = \&func; # replaces an item in the symbol table (function, scalar, array, hash) # *foo = \$bar replaces the scalar # *foo = \%bar replaces the hash table # *foo = \@bar replaces the array # *foo = \&bar replaces the function # *foo = *bar all of the above (including FILEHANDLE!) # XXX: can't do just filehandles (yet) # # This can be used to import and rename a symbol from another package: # *myfunc = \&otherpack::otherfunc; # AUTOLOAD { ...; } # called if method not found, passed function name in $AUTOLOAD # @_ are the arguments to the function. # goto &func; # goto's a function, used by AUTOLOAD to jump to the function # qw/arg list/; qw(arg list); # quoted words, yields a list; works like split(' ', 'arg list') # not a function, more like q//; { package AutoLoader; AUTOLOAD { eval "sub $AUTOLOAD" . '{ print "@_\n"}'; goto &$AUTOLOAD } package JAPH; @ISA = (AutoLoader); sub foo2 { &bar } foo2 qw(Just another Perl hacker,); # prints ``Just another Perl hacker,'' } # Larry notes: # You might point out that there's a canned Autoloader base class in the # library. Another subtlety is that $AUTOLOAD is always in the same # package as the AUTOLOAD routine, so if you call another package's # AUTOLOAD explicitly you have to set $AUTOLOAD in that package first. # my # lexical scoping sub samp1 { print $z,"\n" } sub samp2 { my($z) = "world"; &samp1 } $z = "hello"; &samp2; # prints ``hello'' # package; # empty package; for catching non-local variable references sub samp3 { my $x = shift; # local() would work also package; # empty package $main::count += $x; # this is ok. # $y = 1; # would be a compile time error } # => # works like comma (,); use for key/value pairs # sometimes used to disambiguate the final expression in a block # might someday supply warnings if you get out of sync %foo = ( abc => foo ); print $foo{abc},"\n"; # prints ``foo'' # :: # works like tick (') (use of ' is deprecated in perl5) print $main::foo{abc},"\n"; # prints ``foo'' # bless ref; # Bless takes a reference and returns an "object" $oref = bless \$scalar; # -> # dereferences an "object" $x = { def => bar }; # $x is ref to anonymous hash print $x->{def},"\n"; # prints ``bar'' # method derefs must be bless'ed { # initial cap is encouraged to avoid naming conflicts package Sample; sub samp4 { my($this) = shift; print $this->{def},"\n"; } sub samp5 { print "samp5: ", $_[1], "\n"; } $main::y = bless $main::x; # $x is ref, $y is "object" } $y->samp4(); # prints ``bar'' # indirect object calls (same as $y->samp5(arglist)) samp5 $y arglist; # prints ``samp5: arglist'' # static method calls (often used for constructors, see below) samp5 Sample arglist; # prints ``samp5: arglist'' # function calls without & sub samp6 { print "look ma\n"; } samp6; # prints ``look ma'' # "forward" decl sub samp7; samp7; # prints ``look pa'' sub samp7 { print "look pa\n"; } # no decl requires ()'s or initial & &samp8; # prints ``look da'' samp8(); # prints ``look da'' sub samp8 { print "look da\n"; } # ref # returns "object" type { package OBJ1; $x = bless \$y; # returns "object" $x in "class" OBJ1 print ref $x,"\n"; # prints ``OBJ1'' } # and non-references return undef. $z = 1; print "non-ref\n" unless ref $z; # prints ``non-ref'' # ref's to "builtins" return type print ref \$ascalar,"\n"; # prints ``SCALAR'' print ref \@array,"\n"; # prints ``ARRAY'' print ref \%hash,"\n"; # prints ``HASH'' sub func { print shift,"\n"; } print ref \&func,"\n"; # prints ``CODE'' print ref \\$scalar,"\n"; # prints ``REF'' # tie # bind a variable to a package with magic functions: # new, DESTROY, fetch, store, delete, firstkey, nextkey # The exact function list varies with the variable type, # see the man page and tie* for more details. # Usage: tie variable, PackageName, ARGLIST { package TIEPACK; sub new { print "NEW: @_\n"; local($x) = $_[1]; bless \$x } sub fetch { print "fetch ", ref $_[0], "\n"; ${$_[0]} } sub store { print "store $_[1]\n"; ${$_[0]} = $_[1] } DESTROY { print "DESTROY ", ref $_[0], "\n" } } tie $h, TIEPACK, "black_tie"; # prints ``NEW: TIEPACK black_tie'' print $h, "\n"; # prints ``fetch TIEPACK'' # prints ``black_tie'' $h = 'bar'; # prints ``store bar'' untie $h; # prints ``DESTROY SCALAR'' # References $sref = \$scalar; # $$sref is scalar $aref = \@array; # @$aref is array $href = \%hash; # %$href is hash table $fref = \&func; # &$fref is function $refref = \$fref; # ref to ref to function &$$refref("call the function"); # prints ``call the function'' # Anonymous data-structures %hash = ( abc => foo ); # hash in perl4 (works in perl5 also) print $hash{abc},"\n"; # prints ``foo'' $ref = { abc => bar }; # reference to anon hash print $ref->{abc},"\n"; # prints ``bar'' @ary = ( 0, 1, 2 ); # array in perl4 (works in perl5 also) print $ary[1],"\n"; # prints ``1'' $ref = [ 3, 4, 5 ]; # reference to anon array print $ref->[1],"\n"; # prints ``4'' # Nested data-structures @foo = ( 0, { name => foobar }, 2, 3 ); # $#foo == 3 $aref = [ 0, { name => foobar }, 2, 3 ]; # ref to anon array $href = { # ref to hash of arrays John => [ Mary, Pat, Blanch ], Paul => [ Sally, Jill, Jane ], Mark => [ Ann, Bob, Dawn ], }; print $href->{Paul}->[0], "\n"; # prints ``Sally'' print $href->{Paul}[0],"\n"; # shorthand version, prints ``Sally'' print @{$href->{Mark}},"\n"; # prints ``AnnBobDawn'' # @ISA # Multiple Inheritance (get rich quick) { package OBJ2; sub abc { print "abc\n"; } package OBJ3; sub def { print "def\n"; } package OBJ4; @ISA = ("OBJ2", "OBJ3"); $x = bless { foo => bar }; $x->abc; # prints ``abc'' $x->def; # prints ``def'' } # Packages, Classes, Objects, Methods, Constructors, Destructors, etc. # XXX: need more explinations and samples { package OBJ5; sub new { print "NEW: @_\n"; my($x) = "empty"; bless \$x } sub output { my($this) = shift; print "value = $$this\n"; } DESTROY { print "OBJ5 DESTROY\n" } } # Constructors are often written as static method calls: $x = new OBJ5; # prints ``NEW: OBJ5'' $x->output; # prints ``value = empty'' # The destructor is responsible for calling any base class destructors. undef $x; # prints ``OBJ5 DESTROY'' # require Package; # same as: BEGIN { require 'Package.pm'; } # require ; # checks against the perl version number require 5.000; # requires perl 5.0 or better # Package Modules # =============== # Yes, these are all very sketchy. See the .pm file for details. # DynamicLoader (builtin) # Public: &bootstrap # Load a shared library package on systems that support it # This incomplete example was extracted from lib/POSIX.pm # # package POSIX; # requires Exporter; require AutoLoader; # @ISA = (Exporter, AutoLoader, DynamicLoader); # @EXPORT = qw(closedir, opendir, [..., lots of functions]); # bootstrap POSIX; # Larry notes: # The gist of it is that DynamicLoader::bootstrap is only called if main.c # didn't already define MYPACKAGE::bootstrap. So the .pm file doesn't know # (or care) whether the module is statically or dynamically loaded. # AutoLoader.pm # Public: &AUTOLOAD # Causes functions from .../lib/perl/auto/PACKAGE/*.al to autoload # when used but not defined. # Config.pm # Exports: %Config # The data from the Configure script for perl programs (yeah) # English.pm # Exports: (lots of verbose variables) # The "english" versions of things like $_ $| $= # Exporter.pm # Public: &import # import PACKAGE [@symbols] # requires PACKAGE to define @EXPORT { package FOOBAR; require Exporter; @ISA = (Exporter); @EXPORT = (foo, bar); sub foo { print "FOO\n" }; sub bar { print "BAR\n" }; 1; package BAT; # require FOOBAR; # not in this example import FOOBAR; @ISA = (); &foo; # prints ``FOO'' } # FileHandle.pm # Exports: (lots of filehandle functions) # English versions of various filehandle operations # Hostname.pm # Exports: &hostname # Routine to get hostname # { # require Hostname; import Hostname; # print &hostname,"\n"; # prints your hostname # } # POSIX.pm # Exports: (posix functions and defines) # POSIX.1 bindings # SDBM_File.pm # SDBM interfaces (use with `tie') # Other DBM interfaces work the same way # when the script exits the END section gets executed and prints ``goodbye'' # ENDs are executed in reverse order of definition. prints ``blue sky'' __END__ unc; # goto's a function, used by AUTOLOAD to jump to the function # qw/arg list/; qw(arg list); # quoted words, yields a list; works like split(' ', 'arg list') # not a function, more like q//; { package AutoLoader; AUTOLOAD { eval "sub $AUTOLOAD" . '{ print "@_\n"}'; goto &$AUTOLOAD } package JAPH; @ISA = (AutoLoader);perl5.000/EXTERN.h 644 203 12 443 5650572633 6574 /* EXTERN.h * * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ #undef EXT #define EXT extern #undef INIT #define INIT(x) #undef DOINIT l8¿ cflags.SH8¿€8Àconfig.H8À”8Á config_h.SH¨8Âconfigpm8¸8Ãcop.h¸È8Äcv.hÈØ8Ådeb.cØè8ÆdoSHè8Çdoio.c8Èdoop.c$8Éperl5.000/INTERN.h 644 203 12 441 5650572633 6564 /* INTERN.h * * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ #undef EXT #define EXT #undef INIT #define INIT(x) = x #define DOINIT €8Àconfig.H8¿”8Á config_h.SH¨8ÂconfigpmSH¸8Ãcop.hpmÈ8Äcv.hop.Ø8Ådeb.c.hè8ÆdoSHeb.8Çdoio.cH8Èdoop.co$8Édosish.hc48Êperl5.000/MANIFEST 644 203 12 54750 5650575220 6614 Artistic The "Artistic License" Changes Differences between Perl 4 and Perl 5 Configure Portability tool Copying The GNU General Public License Doc/perl5-notes Samples of new functionality EXTERN.h Included before foreign .h files INTERN.h Included before domestic .h files MANIFEST This list of files Makefile.SH A script that generates Makefile README The Instructions README.vms Notes about VMS Todo The Wishlist XSUB.h Include file for extension subroutines autosplit Splits up autoloader functions av.c Array value code av.h Array value header c2ph.SH program to translate dbx stabs to perl c2ph.doc documentation for c2ph cflags.SH A script that emits C compilation flags per file config.H Sample config.h config_h.SH Produces config.h configpm Produces lib/Config.pm cop.h Control operator header cv.h Code value header deb.c Debugging routines doSH Script to run all the *.SH files doio.c I/O operations doop.c Support code for various operations dosish.h Some defines for MS/DOSish machines dump.c Debugging output eg/ADB An adb wrapper to put in your crash dir eg/README Intro to example perl scripts eg/changes A program to list recently changed files eg/client A sample client eg/down A program to do things to subdirectories eg/dus A program to do du -s on non-mounted dirs eg/findcp A find wrapper that implements a -cp switch eg/findtar A find wrapper that pumps out a tar file eg/g/gcp A program to do a global rcp eg/g/gcp.man Manual page for gcp eg/g/ged A program to do a global edit eg/g/ghosts A sample /etc/ghosts file eg/g/gsh A program to do a global rsh eg/g/gsh.man Manual page for gsh eg/muck A program to find missing make dependencies eg/muck.man Manual page for muck eg/myrup A program to find lightly loaded machines eg/nih Script to insert #! workaround eg/relink A program to change symbolic links eg/rename A program to rename files eg/rmfrom A program to feed doomed filenames to eg/scan/scan_df Scan for filesystem anomalies eg/scan/scan_last Scan for login anomalies eg/scan/scan_messages Scan for console message anomalies eg/scan/scan_passwd Scan for passwd file anomalies eg/scan/scan_ps Scan for process anomalies eg/scan/scan_sudo Scan for sudo anomalies eg/scan/scan_suid Scan for setuid anomalies eg/scan/scanner An anomaly reporter eg/server A sample server eg/shmkill A program to remove unused shared memory eg/sysvipc/README Intro to Sys V IPC examples eg/sysvipc/ipcmsg Example of SYS V IPC message queues eg/sysvipc/ipcsem Example of Sys V IPC semaphores eg/sysvipc/ipcshm Example of Sys V IPC shared memory eg/travesty A program to print travesties of its input text eg/unuc Un-uppercases an all-uppercase text eg/uudecode A version of uudecode eg/van/empty A program to empty the trashcan eg/van/unvanish A program to undo what vanish does eg/van/vanexp A program to expire vanished files eg/van/vanish A program to put files in a trashcan eg/who A sample who program eg/wrapsuid A setuid script wrapper generator emacs/cperl-mode An alternate perl-mode emacs/emacs19 Notes about emacs 19 emacs/perl-mode.el Emacs major mode for perl emacs/perldb.el Emacs debugging emacs/perldb.pl Emacs debugging emacs/tedstuff Some optional patches embed.h Maps symbols to safer names embed_h.SH Produces embed.h ext/DB_File/DB_File.pm Berkeley DB extension Perl module ext/DB_File/DB_File.xs Berkeley DB extension external subroutines ext/DB_File/DB_File_BS Berkeley DB extension mkbootstrap fodder ext/DB_File/Makefile.SH Berkeley DB extension makefile writer ext/DB_File/typemap Berkeley DB extension interface types ext/DynaLoader/DynaLoader.doc Dynamic Loader specification ext/DynaLoader/DynaLoader.pm Dynamic Loader perl module ext/DynaLoader/Makefile.SH Dynamic Loader makefile writer ext/DynaLoader/README Dynamic Loader notes and intro ext/DynaLoader/dl_aix.xs AIX implementation ext/DynaLoader/dl_dld.xs GNU dld style implementation ext/DynaLoader/dl_dlopen.xs BSD/SunOS4&5 dlopen() style implementation ext/DynaLoader/dl_hpux.xs HP-UX implementation ext/DynaLoader/dl_next.xs Next implementation ext/DynaLoader/dl_none.xs Stub implementation ext/DynaLoader/dl_vms.xs VMS implementation ext/DynaLoader/dlutils.c Dynamic loader utilities for dl_*.xs files ext/Fcntl/Fcntl.pm Fcntl extension Perl module ext/Fcntl/Fcntl.xs Fcntl extension external subroutines ext/Fcntl/MANIFEST Fcntl extension file list ext/Fcntl/Makefile.SH Fcntl extension makefile writer ext/GDBM_File/GDBM_File.pm GDBM extension Perl module ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines ext/GDBM_File/Makefile.SH GDBM extension makefile writer ext/GDBM_File/typemap GDBM extension interface types ext/NDBM_File/Makefile.SH NDBM extension makefile writer ext/NDBM_File/NDBM_File.pm NDBM extension Perl module ext/NDBM_File/NDBM_File.xs NDBM extension external subroutines ext/NDBM_File/typemap NDBM extension interface types ext/ODBM_File/Makefile.SH ODBM extension makefile writer ext/ODBM_File/ODBM_File.pm ODBM extension Perl module ext/ODBM_File/ODBM_File.xs ODBM extension external subroutines ext/ODBM_File/typemap ODBM extension interface types ext/POSIX/Makefile.SH POSIX extension makefile writer ext/POSIX/POSIX.pm POSIX extension Perl module ext/POSIX/POSIX.xs POSIX extension external subroutines ext/POSIX/typemap POSIX extension interface types ext/SDBM_File/Makefile.SH SDBM extension makefile writer ext/SDBM_File/SDBM_File.pm SDBM extension Perl module ext/SDBM_File/SDBM_File.xs SDBM extension external subroutines ext/SDBM_File/sdbm/CHANGES SDBM kit ext/SDBM_File/sdbm/COMPARE SDBM kit ext/SDBM_File/sdbm/Makefile.SH SDBM kit ext/SDBM_File/sdbm/README SDBM kit ext/SDBM_File/sdbm/README.too SDBM kit ext/SDBM_File/sdbm/biblio SDBM kit ext/SDBM_File/sdbm/dba.c SDBM kit ext/SDBM_File/sdbm/dbd.c SDBM kit ext/SDBM_File/sdbm/dbe.1 SDBM kit ext/SDBM_File/sdbm/dbe.c SDBM kit ext/SDBM_File/sdbm/dbm.c SDBM kit ext/SDBM_File/sdbm/dbm.h SDBM kit ext/SDBM_File/sdbm/dbu.c SDBM kit ext/SDBM_File/sdbm/grind SDBM kit ext/SDBM_File/sdbm/hash.c SDBM kit ext/SDBM_File/sdbm/linux.patches SDBM kit ext/SDBM_File/sdbm/makefile.sdbm SDBM kit ext/SDBM_File/sdbm/pair.c SDBM kit ext/SDBM_File/sdbm/pair.h SDBM kit ext/SDBM_File/sdbm/readme.ms SDBM kit ext/SDBM_File/sdbm/readme.ps SDBM kit ext/SDBM_File/sdbm/sdbm.3 SDBM kit ext/SDBM_File/sdbm/sdbm.c SDBM kit ext/SDBM_File/sdbm/sdbm.h SDBM kit ext/SDBM_File/sdbm/tune.h SDBM kit ext/SDBM_File/sdbm/util.c SDBM kit ext/SDBM_File/typemap SDBM extension interface types ext/Socket/Makefile.SH Socket extension makefile writer ext/Socket/Socket.pm Socket extension Perl module ext/Socket/Socket.xs Socket extension external subroutines ext/typemap Extension interface types ext/util/extliblist Used by extension Makefile.SH to make lib lists ext/util/make_ext Used by Makefile to execute extension Makefiles ext/util/mkbootstrap Turns ext/*/*_BS into bootstrap info ext/xsubpp External subroutine preprocessor form.h Public declarations for the above global.sym Symbols that need hiding when embedded gv.c Glob value code gv.h Glob value header h2ph.SH A thing to turn C .h files into perl .ph files h2pl/README How to turn .ph files into .pl files h2pl/cbreak.pl cbreak routines using .ph h2pl/cbreak2.pl cbreak routines using .pl h2pl/eg/sizeof.ph Sample sizeof array initialization h2pl/eg/sys/errno.pl Sample translated errno.pl h2pl/eg/sys/ioctl.pl Sample translated ioctl.pl h2pl/eg/sysexits.pl Sample translated sysexits.pl h2pl/getioctlsizes Program to extract types from ioctl.h h2pl/mksizes Program to make %sizeof array h2pl/mkvars Program to make .pl from .ph files h2pl/tcbreak cbreak test routine using .ph h2pl/tcbreak2 cbreak test routine using .pl h2xs Program to make .xs files from C header files handy.h Handy definitions hints/3b1.sh Hints for named architecture hints/3b1cc Hints for named architecture hints/README.hints Hints for named architecture hints/aix.sh Hints for named architecture hints/altos486.sh Hints for named architecture hints/apollo.sh Hints for named architecture hints/aux.sh Hints for named architecture hints/bsd386.sh Hints for named architecture hints/dec_osf.sh Hints for named architecture hints/dgux.sh Hints for named architecture hints/dnix.sh Hints for named architecture hints/dynix.sh Hints for named architecture hints/esix4.sh Hints for named architecture hints/fps.sh Hints for named architecture hints/freebsd.sh Hints for named architecture hints/genix.sh Hints for named architecture hints/greenhills.sh Hints for named architecture hints/hpux_9.sh Hints for named architecture hints/i386.sh Hints for named architecture hints/irix_4.sh Hints for named architecture hints/irix_5.sh Hints for named architecture hints/isc.sh Hints for named architecture hints/isc_2.sh Hints for named architecture hints/linux.sh Hints for named architecture hints/mips.sh Hints for named architecture hints/mpc.sh Hints for named architecture hints/ncr_tower.sh Hints for named architecture hints/netbsd.sh Hints for named architecture hints/next_3_2.sh Hints for named architecture hints/opus.sh Hints for named architecture hints/sco_2_3_0.sh Hints for named architecture hints/sco_2_3_1.sh Hints for named architecture hints/sco_2_3_2.sh Hints for named architecture hints/sco_2_3_3.sh Hints for named architecture hints/sco_2_3_4.sh Hints for named architecture hints/sco_3.sh Hints for named architecture hints/solaris_2.sh Hints for named architecture hints/stellar.sh Hints for named architecture hints/sunos_4_0.sh Hints for named architecture hints/sunos_4_1.sh Hints for named architecture hints/svr4.sh Hints for named architecture hints/ti1500.sh Hints for named architecture hints/titanos.sh Hints for named architecture hints/ultrix_4.sh Hints for named architecture hints/unicos.sh Hints for named architecture hints/unisysdynix.sh Hints for named architecture hints/utekv.sh Hints for named architecture hints/uts.sh Hints for named architecture hv.c Hash value code hv.h Hash value header installperl Perl script to do "make install" dirty work interp.sym Interpreter specific symbols to hide in a struct ioctl.pl Sample ioctl.pl keywords.h The keyword numbers keywords.pl Program to write keywords.h lib/AnyDBM_File.pm Perl module to emulate dbmopen lib/AutoLoader.pm Autoloader base class lib/AutoSplit.pm A module to split up autoload functions lib/Benchmark.pm A module to time pieces of code and such lib/Carp.pm Error message base class lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir) lib/English.pm Readable aliases for short variables lib/Env.pm Map environment into ordinary variables lib/Exporter.pm Exporter base class lib/ExtUtils/MakeMaker.pm Write Makefiles for extensions lib/File/Basename.pm A module to emulate the basename program lib/File/CheckTree.pm Perl module supporting wholesale file mode validation lib/File/Find.pm Routines to do a find lib/FileHandle.pm FileHandle methods lib/Shell.pm A module to make AUTOLOADEed system() calls lib/Getopt/Long.pm A module to fetch command options (GetOptions) lib/Getopt/Std.pm A module to fetch command options (getopt, getopts) lib/I18N/Collate.pm Routines to do strxfrm-based collation lib/IPC/Open2.pm Open a two-ended pipe lib/IPC/Open3.pm Open a three-ended pipe! lib/Math/BigInt.pm An arbitrary precision integer arithmetic package lib/Math/BigFloat.pm An arbitrary precision floating-point arithmetic package lib/Math/Complex.pm A Complex package lib/Net/Ping.pm Ping methods lib/Search/Dict.pm A module to do binary search on dictionaries lib/Sys/Hostname.pm Hostname methods lib/Sys/Syslog.pm Perl module supporting syslogging lib/Term/Cap.pm Perl module supporting termcap usage lib/Term/Complete.pm A command completion subroutine lib/Test/Harness.pm A test harness lib/Text/Abbrev.pm An abbreviation table builder lib/Text/ParseWords.pm Perl module to split words on arbitrary delimiter lib/Text/Soundex.pm Perl module to implement Soundex lib/Text/Tabs.pm Do expand and unexpand lib/TieHash.pm Base class for tied hashes lib/Time/Local.pm Reverse translation of localtime, gmtime lib/abbrev.pl An abbreviation table builder lib/assert.pl assertion and panic with stack trace lib/bigfloat.pl An arbitrary precision floating point package lib/bigint.pl An arbitrary precision integer arithmetic package lib/bigrat.pl An arbitrary precision rational arithmetic package lib/cacheout.pl Manages output filehandles when you need too many lib/chat2.inter A chat2 with interaction lib/chat2.pl Randal's famous expect-ish routines lib/complete.pl A command completion subroutine lib/ctime.pl A ctime workalike lib/dotsh.pl Code to "dot" in a shell script lib/dumpvar.pl A variable dumper lib/exceptions.pl catch and throw routines lib/fastcwd.pl a faster but more dangerous getcwd lib/find.pl A find emulator--used by find2perl lib/finddepth.pl A depth-first find emulator--used by find2perl lib/flush.pl Routines to do single flush lib/ftp.pl FTP code lib/getcwd.pl A getcwd() emulator lib/getopt.pl Perl library supporting option parsing lib/getopts.pl Perl library supporting option parsing lib/hostname.pl Old hostname code lib/importenv.pl Perl routine to get environment into variables lib/integer.pm For "use integer" lib/less.pm For "use less" lib/look.pl A "look" equivalent lib/newgetopt.pl A perl library supporting long option parsing lib/open2.pl Open a two-ended pipe lib/open3.pl Open a three-ended pipe lib/perl5db.pl Perl debugging routines lib/pwd.pl Routines to keep track of PWD environment variable lib/shellwords.pl Perl library to split into words with shell quoting lib/sigtrap.pm For trapping an abort and giving traceback lib/stat.pl Perl library supporting stat function lib/strict.pm For "use strict" lib/subs.pm Declare overriding subs lib/syslog.pl Perl library supporting syslogging lib/tainted.pl Old code for tainting lib/termcap.pl Perl library supporting termcap usage lib/timelocal.pl Perl library supporting inverse of localtime, gmtime lib/validate.pl Perl library supporting wholesale file mode validation makedepend.SH Precursor to makedepend makedir.SH Precursor to makedir malloc.c A version of malloc you might not want mg.c Magic code mg.h Magic header miniperlmain.c Basic perl w/o dynamic loading or extensions mv-if-diff Script to mv a file if it changed myconfig Prints summary of the current configuration op.c Opcode syntax tree code op.h Opcode syntax tree header opcode.h Automatically generated opcode header opcode.pl Opcode header generatore patchlevel.h The current patch level of perl perl.c main() perl.h Global declarations perl_exp.SH Creates list of exported symbols for AIX. perlsh A poor man's perl shell perly.c A byacc'ed perly.y perly.c.diff Fixup perly.c to allow recursion perly.fixer A program to remove yacc stack limitations perly.h The header file for perly.c perly.y Yacc grammar for perl pl2pm A pl to pm translator pod/Makefile Make pods into something else pod/modpods/Abbrev.pod Doc for Abbrev.pm pod/modpods/AnyDBMFile.pod Doc for AnyDBMFile.pm pod/modpods/AutoLoader.pod Doc for AutoLoader.pm pod/modpods/AutoSplit.pod Doc for AutoSplit.pm pod/modpods/Basename.pod Doc for Basename.pm pod/modpods/Benchmark.pod Doc for Benchmark.pm pod/modpods/Carp.pod Doc for Carp.pm pod/modpods/CheckTree.pod Doc for CheckTree.pm pod/modpods/Collate.pod Doc for Collate.pm pod/modpods/Config.pod Doc for Config.pm pod/modpods/Cwd.pod Doc for Cwd.pm pod/modpods/DB_File.pod Doc for File.pm pod/modpods/Dynaloader.pod Doc for Dynaloader.pm pod/modpods/English.pod Doc for English.pm pod/modpods/Env.pod Doc for Env.pm pod/modpods/Exporter.pod Doc for Exporter.pm pod/modpods/Fcntl.pod Doc for Fcntl.pm pod/modpods/FileHandle.pod Doc for FileHandle.pm pod/modpods/Find.pod Doc for Find.pm pod/modpods/Finddepth.pod Doc for Finddepth.pm pod/modpods/GetOptions.pod Doc for GetOptions.pm pod/modpods/Getopt.pod Doc for Getopt.pm pod/modpods/MakeMaker.pod Doc for MakeMaker.pm pod/modpods/Open2.pod Doc for Open2.pm pod/modpods/Open3.pod Doc for Open3.pm pod/modpods/POSIX.pod Doc for POSIX.pm pod/modpods/Ping.pod Doc for Ping.pm pod/modpods/Socket.pod Doc for Socket.pm pod/modpods/integer.pod Doc for integer.pm pod/modpods/less.pod Doc for less.pm pod/modpods/sigtrap.pod Doc for sigtrap.pm pod/modpods/strict.pod Doc for strict.pm pod/modpods/subs.pod Doc for subs.pm pod/perl.pod Top level perl man page pod/perlapi.pod XS api info pod/perlbook.pod Book info pod/perlbot.pod Object-oriented Bag o' Tricks pod/perlcall.pod Callback info pod/perldata.pod Data structure info pod/perldebug.pod Debugger info pod/perldiag.pod Diagnostic info pod/perlembed.pod Embedding info pod/perlform.pod Format info pod/perlfunc.pod Function info pod/perlguts.pod Internals info pod/perlipc.pod IPC info pod/perlmod.pod Module info pod/perlobj.pod Object info pod/perlop.pod Operator info pod/perlovl.pod Overloading info pod/perlpod.pod Pod info pod/perlre.pod Regular expression info pod/perlref.pod References info pod/perlrun.pod Execution info pod/perlsec.pod Security info pod/perlstyle.pod Style info pod/perlsub.pod Subroutine info pod/perlsyn.pod Syntax info pod/perltrap.pod Trap info pod/perlvar.pod Variable info pod/pod2html Translator to turn pod into HTML pod/pod2man Translator to turn pod into manpage pod/splitman Splits perlfunc into multiple man pages pp.c Push/Pop code pp.h Push/Pop code defs pp_ctl.c Push/Pop code for control flow pp_hot.c Push/Pop code for heavily used opcodes pp_sys.c Push/Pop code for system interaction proto.h Prototypes regcomp.c Regular expression compiler regcomp.h Private declarations for above regexec.c Regular expression evaluator regexp.h Public declarations for the above run.c The interpreter loop scope.c Scope entry and exit code scope.h Scope entry and exit header sv.c Scalar value code sv.h Scalar value header t/README Instructions for regression tests t/TEST The regression tester t/base/cond.t See if conditionals work t/base/if.t See if if works t/base/lex.t See if lexical items work t/base/pat.t See if pattern matching works t/base/term.t See if various terms work t/cmd/elsif.t See if else-if works t/cmd/for.t See if for loops work t/cmd/mod.t See if statement modifiers work t/cmd/subval.t See if subroutine values work t/cmd/switch.t See if switch optimizations work t/cmd/while.t See if while loops work t/comp/cmdopt.t See if command optimization works t/comp/cpp.t See if C preprocessor works t/comp/decl.t See if declarations work t/comp/multiline.t See if multiline strings work t/comp/package.t See if packages work t/comp/script.t See if script invokation works t/comp/term.t See if more terms work t/io/argv.t See if ARGV stuff works t/io/dup.t See if >& works right t/io/fs.t See if directory manipulations work t/io/inplace.t See if inplace editing works t/io/pipe.t See if secure pipes work t/io/print.t See if print commands work t/io/tell.t See if file seeking works t/lib/anydbm.t See if AnyDBM_File works t/lib/bigint.t See if bigint.pl works t/lib/db-btree.t See if DB_File works t/lib/db-hash.t See if DB_File works t/lib/db-recno.t See if DB_File works t/lib/english.t See if English works t/lib/gdbm.t See if GDBM_File works t/lib/ndbm.t See if NDBM_File works t/lib/odbm.t See if ODBM_File works t/lib/posix.t See if POSIX works t/lib/sdbm.t See if SDBM_File works t/lib/soundex.t See if Soundex works t/op/append.t See if . works t/op/array.t See if array operations work t/op/auto.t See if autoincrement et all work t/op/chop.t See if chop works t/op/cond.t See if conditional expressions work t/op/delete.t See if delete works t/op/do.t See if subroutines work t/op/each.t See if associative iterators work t/op/eval.t See if eval operator works t/op/exec.t See if exec and system work t/op/exp.t See if math functions work t/op/flip.t See if range operator works t/op/fork.t See if fork works t/op/glob.t See if <*> works t/op/goto.t See if goto works t/op/groups.t See if $( works t/op/index.t See if index works t/op/int.t See if int works t/op/join.t See if join works t/op/list.t See if array lists work t/op/local.t See if local works t/op/magic.t See if magic variables work t/op/misc.t See if miscellaneous bugs have been fixed t/op/mkdir.t See if mkdir works t/op/my.t See if lexical scoping works t/op/oct.t See if oct and hex work t/op/ord.t See if ord works t/op/pack.t See if pack and unpack work t/op/pat.t See if esoteric patterns work t/op/push.t See if push and pop work t/op/quotemeta.t See if quotemeta works t/op/rand.t See if rand works t/op/range.t See if .. works t/op/re_tests Input file for op.regexp t/op/read.t See if read() works t/op/readdir.t See if readdir() works t/op/ref.t See if refs and objects work t/op/regexp.t See if regular expressions work t/op/repeat.t See if x operator works t/op/sleep.t See if sleep works t/op/sort.t See if sort works t/op/split.t See if split works t/op/sprintf.t See if sprintf works t/op/stat.t See if stat works t/op/study.t See if study works t/op/subst.t See if substitution works t/op/substr.t See if substr works t/op/time.t See if time functions work t/op/undef.t See if undef works t/op/unshift.t See if unshift works t/op/vec.t See if vectors work t/op/write.t See if write works t/re_tests Regular expressions for regexp.t taint.c Tainting code toke.c The tokener unixish.h Defines that are assumed on Unix util.c Utility routines util.h Public declarations for the above vms/config.vms VMS port vms/descrip.mms VMS port vms/genconfig.pl VMS port vms/genopt.com VMS port vms/gen_shrfls.pl VMS port vms/makefile. VMS port vms/mms2make.pl VMS port vms/perlshr.c VMS port vms/perlvms.pod VMS port vms/sockadapt.c VMS port vms/sockadapt.h VMS port vms/test.com VMS port vms/vms.c VMS port vms/vmsish.h VMS port vms/writemain.pl VMS port writemain.SH Generate perlmain.c from miniperlmain.c+extensions x2p/EXTERN.h Same as above x2p/INTERN.h Same as above x2p/Makefile.SH Precursor to Makefile x2p/a2p.h Global declarations x2p/a2p.man Manual page for awk to perl translator x2p/a2p.y A yacc grammer for awk x2p/a2py.c Awk compiler, sort of x2p/cflags.SH A script that emits C compilation flags per file x2p/find2perl.SH A find to perl translator x2p/handy.h Handy definitions x2p/hash.c Associative arrays again x2p/hash.h Public declarations for the above x2p/malloc.c Malloc code x2p/s2p.SH Sed to perl translator x2p/s2p.man Manual page for sed to perl translator x2p/str.c String handling package x2p/str.h Public declarations for the above x2p/util.c Utility routines x2p/util.h Public declarations for the above x2p/walk.c Parse tree walker xf A script to translate Perl 4 symbols to Perl 5 or AIX. perlsh A poor perl5.000/Makefile.SH 664 203 12 24101 5650574236 7427 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=../../../..; else echo "Can't find config.sh."; exit 1 fi . $TOP/config.sh ;; esac : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac case "$d_dosuid" in *define*) suidperl='suidperl' ;; *) suidperl='';; esac : Configure sets byacc=byacc if byacc is not found. We reset it to '' case "$byacc" in ''|'byacc') byacc='';; esac : Prepare dependency lists for Makefile. dynamic_list=' ' for f in $dynamic_ext; do : the dependency named here will never exist dynamic_list="$dynamic_list $f.$dlext" done static_list=' ' static_ai_list=' ' for f in $static_ext; do base=`echo "$f" | sed 's/.*\///'` static_list="$static_list ext/$f/$base.a" if test -f ext/$f/AutoInit.c; then static_ai_list="$static_ai_list ext/$f/AutoInit.c" fi if test -f ext/$f/AutoInit.pl; then static_ai_list="$static_ai_list ext/$f/AutoInit.pl" fi done echo "Extracting Makefile (with variable substitutions)" $spitshell >Makefile <<'!NO!SUBS!' # Makefile.SH # This file is derived from Makefile.SH. Any changes made here will # be lost the next time you run Configure. # Makefile is used to generate makefile. The only difference # is that makefile has the dependencies filled in at the end. # # !NO!SUBS! $spitshell >>Makefile <>Makefile <<'!NO!SUBS!' CCCMD = `sh $(shellflags) cflags $(perllib) $@` private = scripts = manpages = perl.man util = sh = Makefile.SH cflags.SH embed_h.SH makedepend.SH makedir.SH writemain.SH h1 = EXTERN.h INTERN.h XSUB.h av.h config.h cop.h cv.h dosish.h h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h h3 = opcode.h patchlevel.h perl.h perly.h pp.h proto.h regcomp.h h4 = regexp.h scope.h sv.h unixish.h util.h h = $(h1) $(h2) $(h3) $(h4) c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c c2 = perl.c perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c c3 = gv.c sv.c taint.c toke.c util.c deb.c run.c c = $(c1) $(c2) $(c3) miniperlmain.c perlmain.c obj1 = $(mallocobj) gv.o toke.o perly.o op.o regcomp.o dump.o util.o mg.o obj2 = hv.o av.o run.o pp_hot.o sv.o pp.o scope.o pp_ctl.o pp_sys.o obj3 = doop.o doio.o regexec.o taint.o deb.o obj = $(obj1) $(obj2) $(obj3) # Once perl has been Configure'd and built ok you build different # perl variants (Debugging, Embedded, Multiplicity etc) by saying: # make clean; make perllib=libperl.a # where is some combination of 'd' and(or) 'e' or 'm'. # See cflags to understand how this works. # # Eventually some form of 'make-a-perl' script will automate this # together with linking a perl executable with any desired # static modules. perllib = libperl.a lintflags = -hbvxac addedbyconf = UU # grrr SHELL = /bin/sh .c.o: $(CCCMD) $*.c all: makefile miniperl preplibrary $(public) $(dynamic_ext) @echo " "; echo " Making x2p stuff"; cd x2p; $(MAKE) all @echo " "; echo " Making docs"; cd pod; $(MAKE) all; # Phony target to force checking subdirectories. FORCE: !NO!SUBS! : Now on to the rest of the Makefile. $spitshell >>Makefile <<'!NO!SUBS!' # The $& notation tells Sequent machines that it can do a parallel make, # and is harmless otherwise. miniperl: $& miniperlmain.o $(perllib) $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain.o $(perllib) $(libs) perlmain.c: miniperlmain.c config.sh makefile $(static_ext_autoinit) sh writemain $(DYNALOADER) $(static_ext) > tmp sh mv-if-diff tmp perlmain.c perlmain.o: perlmain.c # The file ext.libs is a list of libraries that must be linked in # for static extensions, e.g. -lm -lgdbm, etc. The individual # static extension Makefile's add to it. ext.libs: $(static_ext) -@test -f ext.libs || touch ext.libs perl: $& perlmain.o $(perllib) $(DYNALOADER) $(static_ext) ext.libs $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain.o $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) pureperl: $& perlmain.o $(perllib) $(DYNALOADER) $(static_ext) ext.libs purify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain.o $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) quantperl: $& perlmain.o $(perllib) $(DYNALOADER) $(static_ext) ext.libs quantify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain.o $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) $(perllib): $& perl.o $(obj) ar rcu $(perllib) perl.o $(obj) @$(ranlib) $(perllib) # This version, if specified in Configure, does ONLY those scripts which need # set-id emulation. Suidperl must be setuid root. It contains the "taint" # checks as well as the special code to validate that the script in question # has been invoked correctly. suidperl: $& sperl.o perlmain.o $(perllib) $(DYNALOADER) $(static_ext) ext.libs $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o suidperl perlmain.o sperl.o $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) sperl.o: perl.c perly.h patchlevel.h $(h) $(RMS) sperl.c $(LNS) perl.c sperl.c $(CCCMD) -DIAMSUID sperl.c $(RMS) sperl.c opcode.h: opcode.pl - perl opcode.pl embed.h: embed_h.SH global.sym interp.sym sh embed_h.SH preplibrary: miniperl lib/Config.pm @test -d lib/auto || mkdir lib/auto @echo " AutoSplitting perl library" @./miniperl -Ilib -e 'use AutoSplit; \ autosplit_lib_modules(@ARGV)' lib/*.pm lib/*/*.pm lib/Config.pm: config.sh miniperl ./miniperl configpm install: all ./perl installperl !NO!SUBS! : Only print out the rules for running byacc if the user _has_ byacc. : Otherwise, comment them out. Users who really know what they are : doing can uncomment them and run yacc or bison or whatever. : Configure sets byacc=byacc if byacc is not found. case "$byacc" in ''|'byacc') comment1='#' comment2='' ;; *) comment1='' comment2='#' ;; esac $spitshell >>Makefile <>perly.h # This version is used only if you do not have byacc. ${comment2}perly.c: perly.y ${comment2} touch perly.c !GROK!THIS! $spitshell >>Makefile <<'!NO!SUBS!' # Extensions: # Names added to $(dynamic_ext) or $(static_ext) will automatically # get built. There should ordinarily be no need to change any of # this part of makefile. # # The dummy dependency is a place holder in case $(dynamic_ext) or # $(static_ext) is empty. # # DynaLoader may be needed for extensions that use Makefile.PL. $(DYNALOADER): miniperl preplibrary FORCE @sh ext/util/make_ext static $@ d_dummy $(dynamic_ext): miniperl preplibrary $(DYNALOADER) FORCE @sh ext/util/make_ext dynamic $@ s_dummy $(static_ext): miniperl preplibrary $(DYNALOADER) FORCE @sh ext/util/make_ext static $@ clean: rm -f *.o *.a all perl suidperl miniperl rm -f perlmain.c rm -f perl.exp ext.libs ext/util/extlibist -cd x2p; $(MAKE) clean -cd pod; $(MAKE) clean -@for x in ext/* ; do \ if test -f $$x/Makefile; then \ echo " Making clean in $$x"; \ cd $$x; $(MAKE) clean ; cd ../.. ; \ fi ; \ done realclean: clean -cd x2p; $(MAKE) realclean -@for x in ext/* ; do \ if test -f $$x/Makefile; then \ echo " Making realclean in $$x"; \ cd $$x; $(MAKE) realclean ; cd ../.. ; \ fi ; \ done rm -f *.orig */*.orig *~ */*~ core t/core rm -rf $(addedbyconf) rm -f Makefile cflags makedepend makedir writemain rm -f config.h t/perl makefile makefile.old rm -f x2p/Makefile x2p/makefile x2p/makefile.old x2p/cflags rm -f lib/Config.pm rm -rf lib/auto rm -f h2ph h2ph.man c2ph pstruct rm -rf .config # The following lint has practically everything turned on. Unfortunately, # you have to wade through a lot of mumbo jumbo that can't be suppressed. # If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message # for that spot. lint: perly.c $(c) lint $(lintflags) $(defs) perly.c $(c) > perl.fuzz makefile: Makefile make depend # When done, touch perlmain.c so that it doesn't get remade each time. depend: makedepend - test -f perly.h || cp /dev/null perly.h ./makedepend - test -s perly.h || /bin/rm -f perly.h - test -s perlmain.c && touch perlmain.c cd x2p; $(MAKE) depend test: miniperl perl preplibrary $(dynamic_ext) - cd t && chmod +x TEST */*.t - cd t && (rm -f perl; $(LNS) ../perl perl) && ./perl TEST .clist hlist: $(h) echo $(h) | tr ' ' '\012' >.hlist shlist: $(sh) echo $(sh) | tr ' ' '\012' >.shlist # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE # If this runs make out of memory, delete /usr/include lines. !NO!SUBS! $eunicefix Makefile case `pwd` in *SH) $rm -f ../Makefile ln Makefile ../Makefile ;; esac rm -f makefile n $(DYNALOADER) $(static_ext) > tmp sh mv-if-diff tmp perlmain.c perlmain.o: perlmain.c # The file ext.libs is a list of libraries that must be linked in # for static extensions, e.g. -lm -lgdbm, etc. The individual # static extension Makefile's add to it. ext.libs: $(static_ext) -@test -f ext.libs || touch ext.libs perl: $& perlmain.o $(perllib) $(DYNALOADER) $(static_ext) ext.libs $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmaperl5.000/README 644 203 12 23056 5650407610 6333 [This is an unsupported, pre-release version of Perl 5.0.] Perl Kit, Version 5.0 Copyright (c) 1989,1990,1991,1992,1993,1994 Larry Wall All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" which comes with this Kit. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the Artistic License for more details. You should have received a copy of the Artistic License with this 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., 675 Mass Ave, Cambridge, MA 02139, USA. 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 script falls under the terms of the GPL unless you explicitly put said script under the terms of the GPL yourself. Furthermore, any object code linked with uperl.o does not automatically fall under the terms of the GPL, provided such object code only adds definitions of subroutines and variables, and does not otherwise impair the resulting interpreter from executing any standard Perl script. I consider linking in C subroutines in this manner to be the moral equivalent of defining subroutines in the Perl language itself. You may sell such an object file as proprietary provided that you provide or offer to provide the Perl source, as specified by the GNU General Public License. (This is merely an alternate way of specifying input to the program.) You may also sell a binary produced by the dumping of a running Perl script that belongs to you, provided that you provide or offer to provide the Perl source as specified by the GPL. (The fact that a Perl interpreter and your code are in the same binary file is, in this case, a form of mere aggregation.) This is my interpretation of the GPL. If you still have concerns or difficulties understanding my intent, feel free to contact me. Of course, the Artistic License spells all this out for your protection, so you may prefer to use that. -------------------------------------------------------------------------- Perl is a language that combines some of the features of C, sed, awk and shell. See the manual page for more hype. There are also two Nutshell Handbooks published by O'Reilly & Assoc. See pod/perlbook.pod for more information. Please read all the directions below before you proceed any further, and then follow them carefully. After you have unpacked your kit, you should have all the files listed in MANIFEST. Installation 1) Run Configure. This will figure out various things about your system. Some things Configure will figure out for itself, other things it will ask you about. It will then proceed to make config.h, config.sh, and Makefile. You may have to explicitly say sh Configure to ensure that Configure is run under sh. If you're a hotshot, run Configure -d to take all the defaults and then edit config.sh to patch up any flaws. Configure supports a number of useful options. Run Configure -h to get a listing. To compile with gcc, for example, you can run Configure -Dcc=gcc, or answer 'gcc' at the cc prompt. By default, perl will be installed in /usr/local/{bin, lib, man}. You can specify a different prefix for the default installation directory, when Configure prompts you or by using something like Configure -Dprefix=/whatever. You can also supply a file config.over to over-ride Configure's guesses. It will get loaded up at the very end, just before config.sh is created. You might possibly have to trim # comments from the front of Configure if your sh doesn't handle them, but all other # comments will be taken care of. (If you don't have sh, you'll have to copy the sample file config.H to config.h and edit the config.h to reflect your system's peculiarities.) 2) Glance through config.h to make sure system dependencies are correct. Most of them should have been taken care of by running the Configure script. If you have any additional changes to make to the C definitions, they can be done in cflags.SH. For instance, to turn off the optimizer on toke.c, find the line in the switch structure for toke.c and put the command optimize='-g' before the ;;. To change the C flags for all the files, edit config.sh and change either $ccflags or $optimize. 3) make depend This will look for all the includes and modify Makefile accordingly. Configure will offer to do this for you. 4) make This will attempt to make perl in the current directory. If you can't compile successfully, try adding a -DCRIPPLED_CC flag. (Just because you get no errors doesn't mean it compiled right!) This simplifies some complicated expressions for compilers that get indigestion easily. If that has no effect, try turning off optimization. If you have missing routines, you probably need to add some library or other, or you need to undefine some feature that Configure thought was there but is defective or incomplete. Some compilers will not compile or optimize the larger files without some extra switches to use larger jump offsets or allocate larger internal tables. You can customize the switches for each file in cflags.SH. It's okay to insert rules for specific files into Makefile.SH, since a default rule only takes effect in the absence of a specific rule. Many of the following hints are now done automatically by Configure. Some of the hints here were for Perl 4, and are probably obsolete. They're left here for the moment just to give you some ideas for what to try if you're having trouble. AIX/RT may need a -a switch and -DCRIPPLED_CC. Ultrix 3.[01] on MIPS needs to undefine WAITPID--the system call is busted. MIPS machines may need to undef d_volatile. MIPS machines may need to turn off -O on some files. Some MIPS machines may need to undefine CASTNEGFLOAT. Xenix 386 may need -UM_I86. See also README.xenix. Genix may need to use libc rather than libc_s, or #undef VARARGS. NCR Tower 32 (OS 2.01.01) may need -W2,-Sl,2000 and #undef MKDIR. A/UX may appear to work with -O -B/usr/lib/big/ optimizer flags. A/UX may need -lposix to find rewinddir. A/UX may need -ZP -DPOSIX, and -g if big cc is used. UTS may need one or more of -DCRIPPLED_CC, -K or -g, and undef LSTAT. If you get syntax errors on '(', try -DCRIPPLED_CC. Machines with half-implemented dbm routines will need to #undef I_ODBM SCO prior to 3.2.4 may be missing dbmclose(). An upgrade to 3.2.4 that includes libdbm.nfs (which includes dbmclose()) may be available. If you get duplicates upon linking for malloc et al, say -DHIDEMYMALLOC. If you get duplicate function definitions (a perl function has the same name as another function on your system) try -DEMBED. 5) make test This will run the regression tests on the perl you just made. If it doesn't say "All tests successful" then something went wrong. See the README in the t subdirectory. Note that you can't run it in background if this disables opening of /dev/tty. If "make test" bombs out, just cd to the t directory and run TEST by hand to see if it makes any difference. If individual tests bomb, you can run them by hand, e.g., ./perl op/groups.t 6) make install This will put perl into a public directory (such as /usr/local/bin). It will also try to put the man pages in a reasonable place. It will not nroff the man page, however. You may need to be root to do this. If you are not root, you must own the directories in question and you should ignore any messages about chown not working. Most of the documentation in the pod/ directory is also available in HTML format. Type cd pod; make html; cd .. to generate the html versions. 7) Read the manual entries before running perl. 8) IMPORTANT! Help save the world! Communicate any problems and suggested patches to me, lwall@netlabs.com (Larry Wall), so we can keep the world in sync. If you have a problem, there's someone else out there who either has had or will have the same problem. If possible, send in patches such that the patch program will apply them. Context diffs are the best, then normal diffs. Don't send ed scripts-- I've probably changed my copy since the version you have. It's also helpful if you send the output of "uname -a". Watch for perl patches in comp.lang.perl. Patches will generally be in a form usable by the patch program. If you are just now bringing up perl and aren't sure how many patches there are, write to me and I'll send any you don't have. Your current patch level is shown in patchlevel.h. Just a personal note: I want you to know that I create nice things like this because it pleases the Author of my story. If this bothers you, then your notion of Authorship needs some revision. But you can use perl anyway. :-) The author. ec.t See if exec and system work t/op/exp.t See if math functions work t/op/flip.t See if range operator works t/op/fork.t See if fork works t/op/glob.t See if <*> works t/op/goto.t See if goto works t/op/groups.t See if $( works t/op/index.t See if index works t/op/int.t See if int works t/op/join.t See if join works t/op/list.t See if array lists work t/op/local.t See if local works t/op/magic.t See if magic variables work t/op/misc.t See if miscperl5.000/README.vms 664 203 12 31550 5650421443 7137 Last revised: 09-Oct-1994 by Charles Bailey bailey@genetics.upenn.edu The VMS port of perl5 is still under development. At this time, the perl binaries built under VMS handle internal operations properly, for the most part, as well as most of the system calls which have close equivalents under VMS. There are still some incompatibilities in process handling (e.g the fork/exec model for creating subprocesses doesn't do what you might expect under Unix), and there remain some file handling differences from Unix. There is a VMS implementation of the DynaLoader, but it hasn't been tested much, so it may still have some bugs in it. Over the longer term, we'll try to get many of the useful VMS system services integrated as well, depending on time and people available. Of course, if you'd like to add something yourself, or join the porting team, we'd love to have you! The current sources and build procedures have been tested on a VAX using VAXC and on an AXP using DECC. IF you run into problems with other compilers, please let us know. * Other software required At the moment, in addition to basic VMS, you'll need two things: - a C compiler: VAXC, DECC, or gcc for the VAX; DECC for the AXP - a make tool: DEC's MMS or the free analog MMK (available from ftp.spc.edu) or a standard make utility (e.g. GNU make, also available from ftp.spc.edu). In addition, you may include socket support if you have a IP stack running on your system. See the topic "Socket support" for more information. * Socket support Perl5 includes a number of IP socket routines among its builtin functions, which are available if you choose to compile perl with socket support. Since IP networking is an optional addition to VMS, there are several different IP stacks available, it's difficult to automate the process of building perl5 with socket support in a way which will work on all systems. By default, perl5 is built without IP socket support. If you define the macro SOCKET when invoking MMS, however, socket support will be included. As distributed, perl5 for VMS includes support for the SOCKETSHR socket library, which is layered on MadGoat software's vendor-independent NETLIB interface. This provides support for all socket calls used by perl5 except the [g|s]et*ent() routines, which are replaced for the moment by stubs which generate a fatal error if a perl script attempts to call one of these routines. If you'd like to link perl directly to your IP stack to take advantage of these routines or to eliminate the intermediate NETLIB, then make the following changes: - In Descrip.MMS, locate the section beginning with .ifdef SOCKET, and change the SOCKLIB macro so that it translates to the filespec of your IP stack's socket library. This will be added to the RTL options file. - Edit the file SockAdapt.H in the [.VMS] subdirectory so that it includes the In.H, NetDb.H, and, if necessary, Errno.H header files for your IP stack, or so that it declares the standard TCP/IP data structures appropriately (see the distributed copy of SockAdapt.H for a collection of the structures needed by perl.) You should also define any logical names necessary to find these files before invoking MMS to build perl. - Edit the file SockAdapt.C in the [.VMS] subdirectory so that it contains routines which substitute for any IP library routines required by perl which your IP stack does not provide. This may require a little trial and error; we'll try to compile a complete list soon of socket routines required by perl5. * Building perl under VMS Since you're reading this, presumable you've unpacked the perl distribution into its directory tree, in which you will find a [.vms] subdirectory below the directory in which this file is found. If this isn't the case, then you'll need to unpack the distribution properly, or manually edit Descrip.MMS or the VMS Makefile. to alter directory paths as necessary. (I'd advise using the `normal' directory tree, at least for the first time through.) This subdirectory contains several files, among which are the following: Config.VMS - A template C header file set up for VMS. Descrip.MMS - The MMS/MMK dependency file for building perl GenConfig.Pl - A perl script to generate Config.SH retrospectively from Config.VMS, since the Configure shell script which normally generates Config.SH doesn't run under VMS. GenOpt.Com - A little DCL procedure used to write some linker options files, since not all make utilities can do this easily. Gen_ShrFls.Pl - A perl script which generates linker options files and MACRO declarations for PerlShr.Exe. Makefile. - The make dependency file for building perl MMS2Make.Pl - A perl script used to generate Makefile. from Descrip.MMS VMSish.H - C header file containing VMS-specific definitions VMS.C - C source code for VMS-specific routines WriteMain.Pl - A perl script used to generate perlmain.c during the build. There may also be other files pertaining to features under development; for the most part, you can ignore them. Config.VMS and Decrip.MMS/Makefile. are set up to build a version of perl which includes all features known to work when this release was assembled. If you have code at your site which would support additional features (e.g. emulation of Unix system calls), feel free to make the appropriate changes to these files. (Note: Do not use or edit config.h in the main perl source directory; it is superseded by the current Config.VMS during the build.) You may also wish to make site-specific changes to Descrip.MMS or Makefile. to reflect local conventions for naming of files, etc. At the moment, system-specific information which becomes part of the perl5 Config extension is hard-coded into the file genconfig.pl in the vms subdirectory. Before you build perl, you should make any changes to the list at the end of this file necessary to reflect your system (e.g your hostname and VMS version). Examine the information at the beginning of Descrip.MMS for information about specifying alternate C compilers or building a version of perl with debugging support. For instance, if you want to use DECC, you'll need to include the /macro="decc=1" qualifier to MMS (If you're using make, these options are not supported.) If you're on an AXP system, define the macro __AXP__ (MMK does this for you), and DECC will automatically be selected. To start the build, set default to the main source directory. Then, if you are using MMS or MMK, issue the command $ MMS/Descrip=[.VMS] ! or MMK If you are using make, issue the command $ Make -f [.VMS]Makefile. Note that the Makefile. doesn't support conditional compilation, and is set up to use VAXC on a VAX, and does not include socket support. You can either edit the Makefile. by hand, using Descrip.MMS as a guide, or use the Makefile. to build Miniperl.Exe, and then run the Perl script MMS@Make.pl, found in the [.VMS] subdirectory, to generate a new Makefile with the options appropriate to your site. Note for sites using early versions of DECC: A bug in some versions of the DECC RTL causes newlines to be lost when writing to a pipe. This causes Gen_ShrFls.pl to fail, since it can't read the preprocessor output to identify global variables and routines. You can work around this problem by defining the macro DECC_PIPES_BROKEN when you invoke MMS or MMK. This will build the following files: Miniperl.Exe - a stand-alone version of without any extensions. Miniperl has all the intrinsic capabilities of perl, but cannot make use of the DynaLoader or any extensions which use XS code. PerlShr.Exe - a shareable image containing most of perl's internal routines and global variables. Perl.Exe is linked to this image, as are all dynamic extensions, so everyone's using the same set of global variables and routines. Perl.Exe - the main perl executable image. It's contains the main() routine, plus code for any statically linked extensions. PerlShr_Attr.Opt - A linker options file which specifies psect attributes matching those in PerlShr.Exe. It should be used when linking images against PerlShr.Exe [.Lib]Config.pm - the perl extension which saves configuration information about perl and your system. [.lib]DynaLoader.pm - The perl extension which performs dynamic linking of shareable images for extensions. There are, of course, a number of other files created for use during the build. Once you've got the binaries built, you may wish to `build' the `tidy' or `clean' targets to remove extra files. * Installing perl once it's built Once the build is complete, you'll need to do the following: - Put PerlShr.Exe in a common directory, and make it world-readable. If you place it in a location other than Sys$Share, you'll need to define the logical name PerlShr to point to the image. - Put Perl.Exe in a common directory, and make it world executable - Define a foreign command to invoke perl, using a statement like $ Perl == "$dev:[dir]Perl.Exe" - Create a world-readable directory tree for perl library modules, scripts, and what-have-you, and define PERL_ROOT as a rooted logical name pointing to the top of this tree (i.e. if your perl files were going to live in DKA1:[Perl5...], then you should $ Define/Translation=Concealed Perl_Root DKA1:[Perl5.] - Define the logical name PERLSHR as the full file specification of PERLSHR.EXE, so executable images linked to it can find it. Alternatively, you can justput PERLSHR.EXE int SYS$SHARE. - Place the files from the [.lib] subdirectory in the distribution package into a [.lib] subdirectory off the root directory described above. - Most of the perl5 documentation lives in the [.pod] subdirectory, and is written in a simple markup format which can be easily read. In this directory as well are pod2man and pod2html translators to reformat the docs for common display engines; a pod2hlp translator is under development. Information on perl5 can also be gleaned from the files in the [.doc] subdirectory (internals documents and summaries of changes), and from the test scripts in the [.t...] subdirectories. For now, that's it. * For more information If you're interested in more information on perl in general, consult the Usenet newsgroup comp.lang.perl. The FAQ for that group provides pointers to other online sources of information, as well as books describing perl in depth. If you're interested in up-to-date information on perl5 development and internals, you might want to subscribe to the perl5-porters mailing list. You can do this by sending a message to perl5-porters-request@isi.edu, containing the single line subscribe perl5-porters Your Name Here This is a moderately high-volume list at the moment (25-50 messages/day). Finally, if you're interested in ongoing information about the VMS port, you can subscribe to the VMSperl mailing list by sending a request to bailey@genetics.upenn.edu (it's to a human, not a list server - this is a small operation at the moment). And, as always, we welcome any help or code you'd like to offer - you can send mail to bailey@genetics.upenn.edu or directly to the VMSperl list at vmsperl@genetics.upenn.edu. Good luck using perl. Please let us know how it works for you - we can't guarantee that we'll be able to fix bugs quickly, but we'll try, and we'd certainly like to know they're out there. * Acknowledgements There are, of course, far too many people involved in the porting and testing of perl5 to mention everyone who deserves it, so please forgive us if we've missed someone. That said, special thanks are due to the following: David Denholm for extensive testing and provision of pipe and SocketShr code, Mark Pizzolato for the getredirection() code Rich Salz for readdir() and related routines Denis Haskin for work on a pod-to-hlp translator for the perl5 documentation Richard Dyson and Kent Covert for additional testing on the AXP. and to the entire VMSperl group for useful advice and suggestions. In addition the perl5-porters, especially Andy Dougherty and Tim Bunce , deserve credit for their creativity and willingness to work with the VMS newcomers. Finally, the greatest debt of gratitude is due to Larry Wall , for having the ideas which have made our sleepless nights possible. Thanks, The VMSperl group MS-specific definitions VMS.C - C source code for VMS-specific routines WriteMain.Pl - A perl script used to generate perlmain.c during tperl5.000/Todo 775 203 12 3750 5646555325 6303 Modules needed X/Motif/Tk etc. Curses Tie Modules VecArray Implement array using vec() SubstrArray Implement array using substr() VirtualArray Implement array using a file ShiftSplice Defines shift et al in terms of splice method Would be nice to have Profiler pack "(stuff)*" Contiguous bitfields in pack/unpack lexperl Bundled perl preprocessor Use posix calls internally where possible const variables gettimeofday bytecompiler format BOTTOM $obj->can("method") to probe method inheritance -iprefix. -i rename file only when successfully changed All ARGV input should act like <> Multiple levels of warning .= shouldn't complain about undefined under -w report HANDLE [formats]. tie(FILEHANDLE, ...) __DATA__ support in perlmain to rerun debugger make 'r' print return value like gdb 'fini' Possible pragmas debugger optimize (use less memory, CPU) Optimizations constant function cache switch structures foreach(@array) foreach (1..1000000) foreach(reverse...) Set KEEP on constant split Cache eval tree (unless lexical outer scope used (mark in &compiling?)) rcatmaybe Shrink opcode tables via multiple implementations selected in peep Cache hash value? (Not a win, according to Guido) Optimize away @_ where possible sfio? "one pass" global destruction Optimize sort by { $a <=> $b } Rewrite regexp parser for better integrated optimization Vague possibilities ref function in list context Populate %SIG at startup if appropriate sub mysplice(@, $, $, ...) data prettyprint function? (or is it, as I suspect, a lib routine?) Nested destructors make tr/// return histogram in list context? undef wantarray in void context Loop control on do{} et al Explicit switch statements perl to C translator multi-thread scheduling built-in globbing compile to real threaded code structured types paren counting in tokener to queue remote expectations autocroak? Modifiable $1 et al substr EXPR,OFFSET,LENGTH,STRING locally capture warnings into an array rl5 documentation lives perl5.000/XSUB.h 664 203 12 1101 5650572634 6363 #define ST(off) stack_base[ax + off] #ifdef CAN_PROTOTYPE #define XS(name) void name(CV* cv) #else #define XS(name) void name(cv) CV* cv; #endif #define dXSARGS \ dSP; dMARK; \ I32 ax = mark - stack_base + 1; \ I32 items = sp - mark #define XSANY CvXSUBANY(cv) #define dXSI32 I32 ix = XSANY.any_i32 #define XSRETURN(off) stack_sp = stack_base + ax + ((off) - 1); return #define XSRETURNNO ST(0)=sv_mortalcopy(&sv_no); XSRETURN(1) #define XSRETURNYES ST(0)=sv_mortalcopy(&sv_yes); XSRETURN(1) #define XSRETURNUNDEF ST(0)=sv_mortalcopy(&sv_undef); XSRETURN(1) h2ph.SHä}¨h2plSHô8Òh2xs2ph8Óhandy.hŠhintsh$8Ôhv.cnd48Õhv.hintH8Ö installperl\8× interp.sym\p8Øioctl.plp„9 keywords.h„˜9 keywords.pl¤ðAlib¼9  makedepend.SH9 Ð9! makedir.SHÐä9"malloc.cäô9#mg.cHÐÂCpod9$mg.hod(9%miniperlmain.c%<9& mv-if-diperl5.000/autosplit 775 203 12 130 5633716430 7357 #!./miniperl BEGIN { unshift @INC, "lib" } use AutoSplit; autosplit_lib_modules(@ARGV); 8¾c2ph.docXl8¿ cflags.SHl€8Àconfig.H€”8Á config_h.SH¨8Âconfigpm¨¸8Ãcop.h¨È8Äcv.hHØ8Ådeb.cpmè8ÆdoSHp.8Çdoio.ch8Èdoop.c.$8Édosish.h$48Êdump.c$@ÎgegpP(emacsp`8Ëembed.ht8Ì embed_h.SHt€=…ext8Íform.h¤8Î global.sym¤´perl5.000/av.c 664 203 12 16746 5650573130 6240 /* av.c * * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * "...for the Entwives desired order, and plenty, and peace (by which they * meant that things should remain where they had set them)." --Treebeard */ #include "EXTERN.h" #include "perl.h" static void av_reify _((AV* av)); static void av_reify(av) AV* av; { I32 key; SV* sv; key = AvMAX(av) + 1; while (key > AvFILL(av) + 1) AvARRAY(av)[--key] = &sv_undef; while (key) { sv = AvARRAY(av)[--key]; assert(sv); if (sv != &sv_undef) (void)SvREFCNT_inc(sv); } AvREAL_on(av); } void av_extend(av,key) AV *av; I32 key; { if (key > AvMAX(av)) { SV** ary; I32 tmp; I32 newmax; if (AvALLOC(av) != AvARRAY(av)) { ary = AvALLOC(av) + AvFILL(av) + 1; tmp = AvARRAY(av) - AvALLOC(av); Move(AvARRAY(av), AvALLOC(av), AvFILL(av)+1, SV*); AvMAX(av) += tmp; SvPVX(av) = (char*)AvALLOC(av); if (AvREAL(av)) { while (tmp) ary[--tmp] = &sv_undef; } if (key > AvMAX(av) - 10) { newmax = key + AvMAX(av); goto resize; } } else { if (AvALLOC(av)) { newmax = key + AvMAX(av) / 5; resize: Renew(AvALLOC(av),newmax+1, SV*); ary = AvALLOC(av) + AvMAX(av) + 1; tmp = newmax - AvMAX(av); if (av == stack) { /* Oops, grew stack (via av_store()?) */ stack_sp = AvALLOC(av) + (stack_sp - stack_base); stack_base = AvALLOC(av); stack_max = stack_base + newmax; } } else { newmax = key < 4 ? 4 : key; New(2,AvALLOC(av), newmax+1, SV*); ary = AvALLOC(av) + 1; tmp = newmax; AvALLOC(av)[0] = &sv_undef; /* For the stacks */ } if (AvREAL(av)) { while (tmp) ary[--tmp] = &sv_undef; } SvPVX(av) = (char*)AvALLOC(av); AvMAX(av) = newmax; } } } SV** av_fetch(av,key,lval) register AV *av; I32 key; I32 lval; { SV *sv; if (!av) return 0; if (SvRMAGICAL(av)) { if (mg_find((SV*)av,'P')) { sv = sv_newmortal(); mg_copy((SV*)av, sv, 0, key); Sv = sv; return &Sv; } } if (key < 0) { key += AvFILL(av) + 1; if (key < 0) return 0; } else if (key > AvFILL(av)) { if (!lval) return 0; if (AvREALISH(av)) sv = NEWSV(5,0); else sv = sv_newmortal(); return av_store(av,key,sv); } if (AvARRAY(av)[key] == &sv_undef) { if (lval) { sv = NEWSV(6,0); return av_store(av,key,sv); } return 0; } return &AvARRAY(av)[key]; } SV** av_store(av,key,val) register AV *av; I32 key; SV *val; { SV** ary; if (!av) return 0; if (SvRMAGICAL(av)) { if (mg_find((SV*)av,'P')) { mg_copy((SV*)av, val, 0, key); return 0; } } if (key < 0) { key += AvFILL(av) + 1; if (key < 0) return 0; } if (!val) val = &sv_undef; if (key > AvMAX(av)) av_extend(av,key); if (AvREIFY(av)) av_reify(av); ary = AvARRAY(av); if (AvFILL(av) < key) { if (!AvREAL(av)) { if (av == stack && key > stack_sp - stack_base) stack_sp = stack_base + key; /* XPUSH in disguise */ do ary[++AvFILL(av)] = &sv_undef; while (AvFILL(av) < key); } AvFILL(av) = key; } else if (AvREAL(av)) SvREFCNT_dec(ary[key]); ary[key] = val; if (SvSMAGICAL(av)) { if (val != &sv_undef) { MAGIC* mg = SvMAGIC(av); sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key); } mg_set((SV*)av); } return &ary[key]; } AV * newAV() { register AV *av; av = (AV*)NEWSV(3,0); sv_upgrade((SV *)av, SVt_PVAV); AvREAL_on(av); AvALLOC(av) = 0; SvPVX(av) = 0; AvMAX(av) = AvFILL(av) = -1; return av; } AV * av_make(size,strp) register I32 size; register SV **strp; { register AV *av; register I32 i; register SV** ary; av = (AV*)NEWSV(8,0); sv_upgrade((SV *) av,SVt_PVAV); New(4,ary,size+1,SV*); AvALLOC(av) = ary; AvFLAGS(av) = AVf_REAL; SvPVX(av) = (char*)ary; AvFILL(av) = size - 1; AvMAX(av) = size - 1; for (i = 0; i < size; i++) { assert (*strp); ary[i] = NEWSV(7,0); sv_setsv(ary[i], *strp); strp++; } return av; } AV * av_fake(size,strp) register I32 size; register SV **strp; { register AV *av; register SV** ary; av = (AV*)NEWSV(9,0); sv_upgrade((SV *)av, SVt_PVAV); New(4,ary,size+1,SV*); AvALLOC(av) = ary; Copy(strp,ary,size,SV*); AvFLAGS(av) = AVf_REIFY; SvPVX(av) = (char*)ary; AvFILL(av) = size - 1; AvMAX(av) = size - 1; while (size--) { assert (*strp); SvTEMP_off(*strp); strp++; } return av; } void av_clear(av) register AV *av; { register I32 key; SV** ary; if (!av || AvMAX(av) < 0) return; /*SUPPRESS 560*/ if (AvREAL(av)) { ary = AvARRAY(av); key = AvFILL(av) + 1; while (key) { SvREFCNT_dec(ary[--key]); ary[key] = &sv_undef; } } if (key = AvARRAY(av) - AvALLOC(av)) { AvMAX(av) += key; SvPVX(av) = (char*)AvALLOC(av); } AvFILL(av) = -1; } void av_undef(av) register AV *av; { register I32 key; if (!av) return; /*SUPPRESS 560*/ if (AvREAL(av)) { key = AvFILL(av) + 1; while (key) SvREFCNT_dec(AvARRAY(av)[--key]); } if (key = AvARRAY(av) - AvALLOC(av)) { AvMAX(av) += key; SvPVX(av) = (char*)AvALLOC(av); } Safefree(AvALLOC(av)); AvALLOC(av) = 0; SvPVX(av) = 0; AvMAX(av) = AvFILL(av) = -1; } void av_push(av,val) register AV *av; SV *val; { if (!av) return; av_store(av,AvFILL(av)+1,val); } SV * av_pop(av) register AV *av; { SV *retval; if (!av || AvFILL(av) < 0) return &sv_undef; retval = AvARRAY(av)[AvFILL(av)]; AvARRAY(av)[AvFILL(av)--] = &sv_undef; if (SvSMAGICAL(av)) mg_set((SV*)av); return retval; } void av_unshift(av,num) register AV *av; register I32 num; { register I32 i; register SV **sstr,**dstr; if (!av || num <= 0) return; if (!AvREAL(av)) { if (AvREIFY(av)) av_reify(av); else croak("Can't unshift"); } i = AvARRAY(av) - AvALLOC(av); if (i) { if (i > num) i = num; num -= i; AvMAX(av) += i; AvFILL(av) += i; SvPVX(av) = (char*)(AvARRAY(av) - i); } if (num) { av_extend(av,AvFILL(av)+num); AvFILL(av) += num; dstr = AvARRAY(av) + AvFILL(av); sstr = dstr - num; #ifdef BUGGY_MSC5 # pragma loop_opt(off) /* don't loop-optimize the following code */ #endif /* BUGGY_MSC5 */ for (i = AvFILL(av) - num; i >= 0; --i) { *dstr-- = *sstr--; #ifdef BUGGY_MSC5 # pragma loop_opt() /* loop-optimization back to command-line setting */ #endif /* BUGGY_MSC5 */ } while (num) AvARRAY(av)[--num] = &sv_undef; } } SV * av_shift(av) register AV *av; { SV *retval; if (!av || AvFILL(av) < 0) return &sv_undef; retval = *AvARRAY(av); if (AvREAL(av)) *AvARRAY(av) = &sv_undef; SvPVX(av) = (char*)(AvARRAY(av) + 1); AvMAX(av)--; AvFILL(av)--; if (SvSMAGICAL(av)) mg_set((SV*)av); return retval; } I32 av_len(av) register AV *av; { return AvFILL(av); } void av_fill(av, fill) register AV *av; I32 fill; { if (!av) croak("panic: null array"); if (fill < 0) fill = -1; if (fill <= AvMAX(av)) { I32 key = AvFILL(av); SV** ary = AvARRAY(av); if (AvREAL(av)) { while (key > fill) { SvREFCNT_dec(ary[key]); ary[key--] = &sv_undef; } } else { while (key < fill) ary[++key] = &sv_undef; } AvFILL(av) = fill; if (SvSMAGICAL(av)) mg_set((SV*)av); } else (void)av_store(av,fill,&sv_undef); } sv; if (!av) return perl5.000/av.h 644 203 12 2535 5650573136 6220 /* av.h * * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ struct xpvav { char* xav_array; /* pointer to malloced string */ SSize_t xav_fill; SSize_t xav_max; IV xof_off; /* ptr is incremented by offset */ double xnv_nv; /* numeric value, if any */ MAGIC* xmg_magic; /* magic for scalar array */ HV* xmg_stash; /* class package */ SV** xav_alloc; SV* xav_arylen; U8 xav_flags; }; #define AVf_REAL 1 /* free old entries */ #define AVf_REIFY 2 /* can become real */ #define Nullav Null(AV*) #define AvARRAY(av) ((SV**)((XPVAV*) SvANY(av))->xav_array) #define AvALLOC(av) ((XPVAV*) SvANY(av))->xav_alloc #define AvMAX(av) ((XPVAV*) SvANY(av))->xav_max #define AvFILL(av) ((XPVAV*) SvANY(av))->xav_fill #define AvARYLEN(av) ((XPVAV*) SvANY(av))->xav_arylen #define AvFLAGS(av) ((XPVAV*) SvANY(av))->xav_flags #define AvREAL(av) (AvFLAGS(av) & AVf_REAL) #define AvREAL_on(av) (AvFLAGS(av) |= AVf_REAL) #define AvREAL_off(av) (AvFLAGS(av) &= ~AVf_REAL) #define AvREIFY(av) (AvFLAGS(av) & AVf_REIFY) #define AvREIFY_on(av) (AvFLAGS(av) |= AVf_REIFY) #define AvREIFY_off(av) (AvFLAGS(av) &= ~AVf_REIFY) #define AvREALISH(av) AvFLAGS(av) /* REAL or REIFY -- shortcut */ p_ctl.c”¨9@pp_hot.c¨¼9App_sys.c¼Ì9Bproto.hà9C regcomp.càô9D regcomp.hôÑQtp.9E regexec.perl5.000/c2ph.SH 755 203 12 63645 5650572654 6571 case $CONFIG in '') if test ! -f config.sh; then ln ../config.sh . || \ ln ../../config.sh . || \ ln ../../../config.sh . || \ (echo "Can't find config.sh."; exit 1) fi . config.sh ;; esac : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac echo "Extracting c2ph (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted : by putting a backslash in front. You may delete these comments. rm -f c2ph $spitshell >c2ph <>c2ph <<'!NO!SUBS!' # # c2ph (aka pstruct) # Tom Christiansen, # # As pstruct, dump C structures as generated from 'cc -g -S' stabs. # As c2ph, do this PLUS generate perl code for getting at the structures. # # See the usage message for more. If this isn't enough, read the code. # $RCSID = 'c2ph.SH'; ###################################################################### # some handy data definitions. many of these can be reset later. $bitorder = 'b'; # ascending; set to B for descending bit fields %intrinsics = %template = ( 'char', 'c', 'unsigned char', 'C', 'short', 's', 'short int', 's', 'unsigned short', 'S', 'unsigned short int', 'S', 'short unsigned int', 'S', 'int', 'i', 'unsigned int', 'I', 'long', 'l', 'long int', 'l', 'unsigned long', 'L', 'unsigned long', 'L', 'long unsigned int', 'L', 'unsigned long int', 'L', 'long long', 'q', 'long long int', 'q', 'unsigned long long', 'Q', 'unsigned long long int', 'Q', 'float', 'f', 'double', 'd', 'pointer', 'p', 'null', 'x', 'neganull', 'X', 'bit', $bitorder, ); &buildscrunchlist; delete $intrinsics{'neganull'}; delete $intrinsics{'bit'}; delete $intrinsics{'null'}; # use -s to recompute sizes %sizeof = ( 'char', '1', 'unsigned char', '1', 'short', '2', 'short int', '2', 'unsigned short', '2', 'unsigned short int', '2', 'short unsigned int', '2', 'int', '4', 'unsigned int', '4', 'long', '4', 'long int', '4', 'unsigned long', '4', 'unsigned long int', '4', 'long unsigned int', '4', 'long long', '8', 'long long int', '8', 'unsigned long long', '8', 'unsigned long long int', '8', 'float', '4', 'double', '8', 'pointer', '4', ); ($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5); ($offset_fmt, $size_fmt) = ('d', 'd'); $indent = 2; $CC = 'cc'; $CFLAGS = '-g -S'; $DEFINES = ''; $perl++ if $0 =~ m#/?c2ph$#; require 'getopts.pl'; eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; &Getopts('aixdpvtnws:') || &usage(0); $opt_d && $debug++; $opt_t && $trace++; $opt_p && $perl++; $opt_v && $verbose++; $opt_n && ($perl = 0); if ($opt_w) { ($type_width, $member_width, $offset_width) = (45, 35, 8); } if ($opt_x) { ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 ); } eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; sub PLUMBER { select(STDERR); print "oops, apperent pager foulup\n"; $isatty++; &usage(1); } sub usage { local($oops) = @_; unless (-t STDOUT) { select(STDERR); } elsif (!$oops) { $isatty++; $| = 1; print "hit for further explanation: "; ; open (PIPE, "|". ($ENV{PAGER} || 'more')); $SIG{PIPE} = PLUMBER; select(PIPE); } print "usage: $0 [-dpnP] [var=val] [files ...]\n"; exit unless $isatty; print < 1) { warn "Only one *.s file allowed!\n"; &usage; } } elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) { local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#; $chdir = "cd $dir; " if $dir; &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1; $ARGV[0] =~ s/\.c$/.s/; } else { $TMP = "/tmp/c2ph.$$.c"; &system("cat @ARGV > $TMP") && exit 1; &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1; unlink $TMP; $TMP =~ s/\.c$/.s/; @ARGV = ($TMP); } } if ($opt_s) { for (split(/[\s,]+/, $opt_s)) { $interested{$_}++; } } $| = 1 if $debug; main: { if ($trace) { if (-t && !@ARGV) { print STDERR "reading from your keyboard: "; } else { print STDERR "reading from " . (@ARGV ? "@ARGV" : "").": "; } } STAB: while (<>) { if ($trace && !($. % 10)) { $lineno = $..''; print STDERR $lineno, "\b" x length($lineno); } next unless /^\s*\.stabs\s+/; $line = $_; s/^\s*\.stabs\s+//; &stab; } print STDERR "$.\n" if $trace; unlink $TMP if $TMP; &compute_intrinsics if $perl && !$opt_i; print STDERR "resolving types\n" if $trace; &resolve_types; &adjust_start_addrs; $sum = 2 + $type_width + $member_width; $pmask1 = "%-${type_width}s %-${member_width}s"; $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s"; if ($perl) { # resolve template -- should be in stab define order, but even this isn't enough. print STDERR "\nbuilding type templates: " if $trace; for $i (reverse 0..$#type) { next unless defined($name = $type[$i]); next unless defined $struct{$name}; $build_recursed = 0; &build_template($name) unless defined $template{&psou($name)} || $opt_s && !$interested{$name}; } print STDERR "\n\n" if $trace; } print STDERR "dumping structs: " if $trace; foreach $name (sort keys %struct) { next if $opt_s && !$interested{$name}; print STDERR "$name " if $trace; undef @sizeof; undef @typedef; undef @offsetof; undef @indices; undef @typeof; $mname = &munge($name); $fname = &psou($name); print "# " if $perl && $verbose; $pcode = ''; print "$fname {\n" if !$perl || $verbose; $template{$fname} = &scrunch($template{$fname}) if $perl; &pstruct($name,$name,0); print "# " if $perl && $verbose; print "}\n" if !$perl || $verbose; print "\n" if $perl && $verbose; if ($perl) { print "$pcode"; printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name}); print < $sizeof{$b}; } foreach $name (sort keys %intrinsics) { print '$',&munge($name),"'typedef = '", $template{$name}, "';\n"; } print "\n1;\n"; exit; } ######################################################################################## sub stab { next unless /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun s/"// || next; s/",([x\d]+),([x\d]+),([x\d]+),.*// || next; next if /^\s*$/; $size = $3 if $3; $line = $_; if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) { print "$name is a typedef for some funky pointers: $pdecl\n" if $debug; &pdecl($pdecl); next; } if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) { local($ident) = $2; push(@intrinsics, $ident); $typeno = &typeno($3); $type[$typeno] = $ident; print STDERR "intrinsic $ident in new type $typeno\n" if $debug; next; } if (($name, $typeordef, $typeno, $extra, $struct, $_) = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/) { $typeno = &typeno($typeno); # sun foolery } elsif (/^[\$\w]+:/) { next; # variable } else { warn "can't grok stab: <$_> in: $line " if $_; next; } #warn "got size $size for $name\n"; $sizeof{$name} = $size if $size; s/;[-\d]*;[-\d]*;$//; # we don't care about ranges $typenos{$name} = $typeno; unless (defined $type[$typeno]) { &panic("type 0??") unless $typeno; $type[$typeno] = $name unless defined $type[$typeno]; printf "new type $typeno is $name" if $debug; if ($extra =~ /\*/ && defined $type[$struct]) { print ", a typedef for a pointer to " , $type[$struct] if $debug; } } else { printf "%s is type %d", $name, $typeno if $debug; print ", a typedef for " , $type[$typeno] if $debug; } print "\n" if $debug; #next unless $extra =~ /[su*]/; #$type[$struct] = $name; if ($extra =~ /[us*]/) { &sou($name, $extra); $_ = &sdecl($name, $_, 0); } elsif (/^=ar/) { print "it's a bare array typedef -- that's pretty sick\n" if $debug; $_ = "$typeno$_"; $scripts = ''; $_ = &adecl($_,1); } elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc push(@intrinsics, $2); $typeno = &typeno($3); $type[$typeno] = $2; print STDERR "intrinsic $2 in new type $typeno\n" if $debug; } elsif (s/^=e//) { # blessed by thy compiler; mine won't do this &edecl; } else { warn "Funny remainder for $name on line $_ left in $line " if $_; } } sub typeno { # sun thinks types are (0,27) instead of just 27 local($_) = @_; s/\(\d+,(\d+)\)/$1/; $_; } sub pstruct { local($what,$prefix,$base) = @_; local($field, $fieldname, $typeno, $count, $offset, $entry); local($fieldtype); local($type, $tname); local($mytype, $mycount, $entry2); local($struct_count) = 0; local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt); local($bits,$bytes); local($template); local($mname) = &munge($name); sub munge { local($_) = @_; s/[\s\$\.]/_/g; $_; } local($sname) = &psou($what); $nesting++; for $field (split(/;/, $struct{$what})) { $pad = $prepad = 0; $entry = ''; ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field); $type = $type[$typeno]; $type =~ /([^[]*)(\[.*\])?/; $mytype = $1; $count .= $2; $fieldtype = &psou($mytype); local($fname) = &psou($name); if ($build_templates) { $pad = ($offset - ($lastoffset + $lastlength))/8 if defined $lastoffset; if (! $finished_template{$sname}) { if ($isaunion{$what}) { $template{$sname} .= 'X' x $revpad . ' ' if $revpad; } else { $template{$sname} .= 'x' x $pad . ' ' if $pad; } } $template = &fetch_template($type) x ($count ? &scripts2count($count) : 1); if (! $finished_template{$sname}) { $template{$sname} .= $template; } $revpad = $length/8 if $isaunion{$what}; ($lastoffset, $lastlength) = ($offset, $length); } else { print '# ' if $perl && $verbose; $entry = sprintf($pmask1, ' ' x ($nesting * $indent) . $fieldtype, "$prefix.$fieldname" . $count); $entry =~ s/(\*+)( )/$2$1/; printf $pmask2, $entry, ($base+$offset)/8, ($bits = ($base+$offset)%8) ? ".$bits" : " ", $length/8, ($bits = $length % 8) ? ".$bits": "" if !$perl || $verbose; if ($perl && $nesting == 1) { $template = &scrunch(&fetch_template($type) x ($count ? &scripts2count($count) : 1)); push(@sizeof, int($length/8) .",\t# $fieldname"); push(@offsetof, int($offset/8) .",\t# $fieldname"); push(@typedef, "'$template', \t# $fieldname"); $type =~ s/(struct|union) //; push(@typeof, "'$type" . ($count ? $count : '') . "',\t# $fieldname"); } print ' ', ' ' x $indent x $nesting, $template if $perl && $verbose; print "\n" if !$perl || $verbose; } if ($perl) { local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1; $mycount *= &scripts2count($count) if $count; if ($nesting==1 && !$build_templates) { $pcode .= sprintf("sub %-32s { %4d; }\n", "${mname}'${fieldname}", $struct_count); push(@indices, $struct_count); } $struct_count += $mycount; } &pstruct($type, "$prefix.$fieldname", $base+$offset) if $recurse && defined $struct{$type}; } $countof{$what} = $struct_count unless defined $countof{$whati}; $template{$sname} .= '$' if $build_templates; $finished_template{$sname}++; if ($build_templates && !defined $sizeof{$name}) { local($fmt) = &scrunch($template{$sname}); print STDERR "no size for $name, punting with $fmt..." if $debug; eval '$sizeof{$name} = length(pack($fmt, ()))'; if ($@) { chop $@; warn "couldn't get size for \$name: $@"; } else { print STDERR $sizeof{$name}, "\n" if $debUg; } } --$nesting; } sub psize { local($me) = @_; local($amstruct) = $struct{$me} ? 'struct ' : ''; print '$sizeof{\'', $amstruct, $me, '\'} = '; printf "%d;\n", $sizeof{$me}; } sub pdecl { local($pdecl) = @_; local(@pdecls); local($tname); warn "pdecl: $pdecl\n" if $debug; $pdecl =~ s/\(\d+,(\d+)\)/$1/g; $pdecl =~ s/\*//g; @pdecls = split(/=/, $pdecl); $typeno = $pdecls[0]; $tname = pop @pdecls; if ($tname =~ s/^f//) { $tname = "$tname&"; } #else { $tname = "$tname*"; } for (reverse @pdecls) { $tname .= s/^f// ? "&" : "*"; #$tname =~ s/^f(.*)/$1&/; print "type[$_] is $tname\n" if $debug; $type[$_] = $tname unless defined $type[$_]; } } sub adecl { ($arraytype, $unknown, $lower, $upper) = (); #local($typeno); # global $typeno, @type local($_, $typedef) = @_; while (s/^((\d+)=)?ar(\d+);//) { ($arraytype, $unknown) = ($2, $3); if (s/^(\d+);(\d+);//) { ($lower, $upper) = ($1, $2); $scripts .= '[' . ($upper+1) . ']'; } else { warn "can't find array bounds: $_"; } } if (s/^([\d*f=]*),(\d+),(\d+);//) { ($start, $length) = ($2, $3); local($whatis) = $1; if ($whatis =~ /^(\d+)=/) { $typeno = $1; &pdecl($whatis); } else { $typeno = $whatis; } } elsif (s/^(\d+)(=[*suf]\d*)//) { local($whatis) = $2; if ($whatis =~ /[f*]/) { &pdecl($whatis); } elsif ($whatis =~ /[su]/) { # print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n" if $debug; #$type[$typeno] = $name unless defined $type[$typeno]; ##printf "new type $typeno is $name" if $debug; $typeno = $1; $type[$typeno] = "$prefix.$fieldname"; local($name) = $type[$typeno]; &sou($name, $whatis); $_ = &sdecl($name, $_, $start+$offset); 1; $start = $start{$name}; $offset = $sizeof{$name}; $length = $offset; } else { warn "what's this? $whatis in $line "; } } elsif (/^\d+$/) { $typeno = $_; } else { warn "bad array stab: $_ in $line "; next STAB; } #local($wasdef) = defined($type[$typeno]) && $debug; #if ($typedef) { #print "redefining $type[$typeno] to " if $wasdef; #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno]; #print "$type[$typeno]\n" if $wasdef; #} else { #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype]; #} $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno]; print "type[$arraytype] is $type[$arraytype]\n" if $debug; print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug; $_; } sub sdecl { local($prefix, $_, $offset) = @_; local($fieldname, $scripts, $type, $arraytype, $unknown, $whatis, $pdecl, $upper,$lower, $start,$length) = (); local($typeno,$sou); SFIELD: while (/^([^;]+);/) { $scripts = ''; warn "sdecl $_\n" if $debug; if (s/^([\$\w]+)://) { $fieldname = $1; } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # $typeno = &typeno($1); $type[$typeno] = "$prefix.$fieldname"; local($name) = "$prefix.$fieldname"; &sou($name,$2); $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); $start = $start{$name}; $offset += $sizeof{$name}; #print "done with anon, start is $start, offset is $offset\n"; #next SFIELD; } else { warn "weird field $_ of $line" if $debug; next STAB; #$fieldname = &gensym; #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); } if (/^\d+=ar/) { $_ = &adecl($_); } elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) { ($start, $length) = ($2, $3); &panic("no length?") unless $length; $typeno = &typeno($1) if $1; } elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) { ($pdecl, $start, $length) = ($1,$5,$6); &pdecl($pdecl); } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct ($typeno, $sou) = ($1, $2); $typeno = &typeno($typeno); if (defined($type[$typeno])) { warn "now how did we get type $1 in $fieldname of $line?"; } else { print "anon type $typeno is $prefix.$fieldname\n" if $debug; $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno]; }; local($name) = "$prefix.$fieldname"; &sou($name,$sou); print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug; $type[$typeno] = "$prefix.$fieldname"; $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); $start = $start{$name}; $length = $sizeof{$name}; } else { warn "can't grok stab for $name ($_) in line $line "; next STAB; } &panic("no length for $prefix.$fieldname") unless $length; $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';'; } if (s/;\d*,(\d+),(\d+);//) { local($start, $size) = ($1, $2); $sizeof{$prefix} = $size; print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug; $start{$prefix} = $start; } $_; } sub edecl { s/;$//; $enum{$name} = $_; $_ = ''; } sub resolve_types { local($sou); for $i (0 .. $#type) { next unless defined $type[$i]; $_ = $type[$i]; unless (/\d/) { print "type[$i] $type[$i]\n" if $debug; next; } print "type[$i] $_ ==> " if $debug; s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e; s/^(\d+)\&/&type($1)/e; s/^(\d+)/&type($1)/e; s/(\*+)([^*]+)(\*+)/$1$3$2/; s/\((\*+)(\w+)(\*+)\)/$3($1$2)/; s/^(\d+)([\*\[].*)/&type($1).$2/e; #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge; $type[$i] = $_; print "$_\n" if $debug; } } sub type { &psou($type[$_[0]] || ""); } sub adjust_start_addrs { for (sort keys %start) { ($basename = $_) =~ s/\.[^.]+$//; $start{$_} += $start{$basename}; print "start: $_ @ $start{$_}\n" if $debug; } } sub sou { local($what, $_) = @_; /u/ && $isaunion{$what}++; /s/ && $isastruct{$what}++; } sub psou { local($what) = @_; local($prefix) = ''; if ($isaunion{$what}) { $prefix = 'union '; } elsif ($isastruct{$what}) { $prefix = 'struct '; } $prefix . $what; } sub scrunch { local($_) = @_; study; s/\$//g; s/ / /g; 1 while s/(\w) \1/$1$1/g; # i wanna say this, but perl resists my efforts: # s/(\w)(\1+)/$2 . length($1)/ge; &quick_scrunch; s/ $//; $_; } sub buildscrunchlist { $scrunch_code = "sub quick_scrunch {\n"; for (values %intrinsics) { $scrunch_code .= "\ts/($_{2,})/'$_' . length(\$1)/ge;\n"; } $scrunch_code .= "}\n"; print "$scrunch_code" if $debug; eval $scrunch_code; &panic("can't eval scrunch_code $@ \nscrunch_code") if $@; } sub fetch_template { local($mytype) = @_; local($fmt); local($count) = 1; &panic("why do you care?") unless $perl; if ($mytype =~ s/(\[\d+\])+$//) { $count .= $1; } if ($mytype =~ /\*/) { $fmt = $template{'pointer'}; } elsif (defined $template{$mytype}) { $fmt = $template{$mytype}; } elsif (defined $struct{$mytype}) { if (!defined $template{&psou($mytype)}) { &build_template($mytype) unless $mytype eq $name; } elsif ($template{&psou($mytype)} !~ /\$$/) { #warn "incomplete template for $mytype\n"; } $fmt = $template{&psou($mytype)} || '?'; } else { warn "unknown fmt for $mytype\n"; $fmt = '?'; } $fmt x $count . ' '; } sub compute_intrinsics { local($TMP) = "/tmp/c2ph-i.$$.c"; open (TMP, ">$TMP") || die "can't open $TMP: $!"; select(TMP); print STDERR "computing intrinsic sizes: " if $trace; undef %intrinsics; print <<'EOF'; main() { char *mask = "%d %s\n"; EOF for $type (@intrinsics) { next if $type eq 'void'; print <<"EOF"; printf(mask,sizeof($type), "$type"); EOF } print <<'EOF'; printf(mask,sizeof(char *), "pointer"); exit(0); } EOF close TMP; select(STDOUT); open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|"); while () { chop; split(' ',$_,2);; print "intrinsic $_[1] is size $_[0]\n" if $debug; $sizeof{$_[1]} = $_[0]; $intrinsics{$_[1]} = $template{$_[0]}; } close(PIPE) || die "couldn't read intrinsics!"; unlink($TMP, '/tmp/a.out'); print STDERR "done\n" if $trace; } sub scripts2count { local($_) = @_; s/^\[//; s/\]$//; s/\]\[/*/g; $_ = eval; &panic("$_: $@") if $@; $_; } sub system { print STDERR "@_\n" if $trace; system @_; } sub build_template { local($name) = @_; &panic("already got a template for $name") if defined $template{$name}; local($build_templates) = 1; local($lparen) = '(' x $build_recursed; local($rparen) = ')' x $build_recursed; print STDERR "$lparen$name$rparen " if $trace; $build_recursed++; &pstruct($name,$name,0); print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug; --$build_recursed; } sub panic { select(STDERR); print "\npanic: @_\n"; exit 1 if $] <= 4.003; # caller broken local($i,$_); local($p,$f,$l,$s,$h,$a,@a,@sub); for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { @a = @DB'args; for (@a) { if (/^StB\000/ && length($_) == length($_main{'_main'})) { $_ = sprintf("%s",$_); } else { s/'/\\'/g; s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; } } $w = $w ? '@ = ' : '$ = '; $a = $h ? '(' . join(', ', @a) . ')' : ''; push(@sub, "$w&$s$a from file $f line $l\n"); last if $signal; } for ($i=0; $i <= $#sub; $i++) { last if $signal; print $sub[$i]; } exit 1; } sub squishseq { local($num); local($last) = -1e8; local($string); local($seq) = '..'; while (defined($num = shift)) { if ($num == ($last + 1)) { $string .= $seq unless $inseq++; $last = $num; next; } elsif ($inseq) { $string .= $last unless $last == -1e8; } $string .= ',' if defined $string; $string .= $num; $last = $num; $inseq = 0; } $string .= $last if $inseq && $last != -e18; $string; } !NO!SUBS! $eunicefix c2ph rm -f pstruct ln c2ph pstruct #print "redefining $type[$typeno] to " if $wasdef; #$type[$typeno] = "$whatis$scripts";perl5.000/c2ph.doc 644 203 12 21333 5240611335 6766 Article 484 of comp.lang.perl: Xref: netlabs comp.lang.perl:484 comp.lang.c:983 alt.sources:134 Path: netlabs!psinntp!iggy.GW.Vitalink.COM!lll-winken!sun-barr!cronkite.Central.Sun.COM!spdev!texsun!convex!tchrist From: tchrist@convex.com (Tom Christiansen) Newsgroups: comp.lang.perl,comp.lang.c,alt.sources Subject: pstruct -- a C structure formatter; AKA c2ph, a C to perl header translator Keywords: C perl tranlator Message-ID: <1991Jul25.081021.8104@convex.com> Date: 25 Jul 91 08:10:21 GMT Sender: usenet@convex.com (news access account) Followup-To: comp.lang.perl Organization: CONVEX Computer Corporation, Richardson, Tx., USA Lines: 1208 Nntp-Posting-Host: pixel.convex.com Once upon a time, I wrote a program called pstruct. It was a perl program that tried to parse out C structures and display their member offsets for you. This was especially useful for people looking at binary dumps or poking around the kernel. Pstruct was not a pretty program. Neither was it particularly robust. The problem, you see, was that the C compiler was much better at parsing C than I could ever hope to be. So I got smart: I decided to be lazy and let the C compiler parse the C, which would spit out debugger stabs for me to read. These were much easier to parse. It's still not a pretty program, but at least it's more robust. Pstruct takes any .c or .h files, or preferably .s ones, since that's the format it is going to massage them into anyway, and spits out listings like this: struct tty { int tty.t_locker 000 4 int tty.t_mutex_index 004 4 struct tty * tty.t_tp_virt 008 4 struct clist tty.t_rawq 00c 20 int tty.t_rawq.c_cc 00c 4 int tty.t_rawq.c_cmax 010 4 int tty.t_rawq.c_cfx 014 4 int tty.t_rawq.c_clx 018 4 struct tty * tty.t_rawq.c_tp_cpu 01c 4 struct tty * tty.t_rawq.c_tp_iop 020 4 unsigned char * tty.t_rawq.c_buf_cpu 024 4 unsigned char * tty.t_rawq.c_buf_iop 028 4 struct clist tty.t_canq 02c 20 int tty.t_canq.c_cc 02c 4 int tty.t_canq.c_cmax 030 4 int tty.t_canq.c_cfx 034 4 int tty.t_canq.c_clx 038 4 struct tty * tty.t_canq.c_tp_cpu 03c 4 struct tty * tty.t_canq.c_tp_iop 040 4 unsigned char * tty.t_canq.c_buf_cpu 044 4 unsigned char * tty.t_canq.c_buf_iop 048 4 struct clist tty.t_outq 04c 20 int tty.t_outq.c_cc 04c 4 int tty.t_outq.c_cmax 050 4 int tty.t_outq.c_cfx 054 4 int tty.t_outq.c_clx 058 4 struct tty * tty.t_outq.c_tp_cpu 05c 4 struct tty * tty.t_outq.c_tp_iop 060 4 unsigned char * tty.t_outq.c_buf_cpu 064 4 unsigned char * tty.t_outq.c_buf_iop 068 4 (*int)() tty.t_oproc_cpu 06c 4 (*int)() tty.t_oproc_iop 070 4 (*int)() tty.t_stopproc_cpu 074 4 (*int)() tty.t_stopproc_iop 078 4 struct thread * tty.t_rsel 07c 4 etc. Actually, this was generated by a particular set of options. You can control the formatting of each column, whether you prefer wide or fat, hex or decimal, leading zeroes or whatever. All you need to be able to use this is a C compiler than generates BSD/GCC-style stabs. The -g option on native BSD compilers and GCC should get this for you. To learn more, just type a bogus option, like -\?, and a long usage message will be provided. There are a fair number of possibilities. If you're only a C programmer, than this is the end of the message for you. You can quit right now, and if you care to, save off the source and run it when you feel like it. Or not. But if you're a perl programmer, then for you I have something much more wondrous than just a structure offset printer. You see, if you call pstruct by its other incybernation, c2ph, you have a code generator that translates C code into perl code! Well, structure and union declarations at least, but that's quite a bit. Prior to this point, anyone programming in perl who wanted to interact with C programs, like the kernel, was forced to guess the layouts of the C strutures, and then hardwire these into his program. Of course, when you took your wonderfully to a system where the sgtty structure was laid out differently, you program broke. Which is a shame. We've had Larry's h2ph translator, which helped, but that only works on cpp symbols, not real C, which was also very much needed. What I offer you is a symbolic way of getting at all the C structures. I've couched them in terms of packages and functions. Consider the following program: #!/usr/local/bin/perl require 'syscall.ph'; require 'sys/time.ph'; require 'sys/resource.ph'; $ru = "\0" x &rusage'sizeof(); syscall(&SYS_getrusage, &RUSAGE_SELF, $ru) && die "getrusage: $!"; @ru = unpack($t = &rusage'typedef(), $ru); $utime = $ru[ &rusage'ru_utime + &timeval'tv_sec ] + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6; $stime = $ru[ &rusage'ru_stime + &timeval'tv_sec ] + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6; printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime; As you see, the name of the package is the name of the structure. Regular fields are just their own names. Plus the follwoing accessor functions are provided for your convenience: struct This takes no arguments, and is merely the number of first-level elements in the structure. You would use this for indexing into arrays of structures, perhaps like this $usec = $u[ &user'u_utimer + (&ITIMER_VIRTUAL * &itimerval'struct) + &itimerval'it_value + &timeval'tv_usec ]; sizeof Returns the bytes in the structure, or the member if you pass it an argument, such as &rusage'sizeof(&rusage'ru_utime) typedef This is the perl format definition for passing to pack and unpack. If you ask for the typedef of a nothing, you get the whole structure, otherwise you get that of the member you ask for. Padding is taken care of, as is the magic to guarantee that a union is unpacked into all its aliases. Bitfields are not quite yet supported however. offsetof This function is the byte offset into the array of that member. You may wish to use this for indexing directly into the packed structure with vec() if you're too lazy to unpack it. typeof Not to be confused with the typedef accessor function, this one returns the C type of that field. This would allow you to print out a nice structured pretty print of some structure without knoning anything about it beforehand. No args to this one is a noop. Someday I'll post such a thing to dump out your u structure for you. The way I see this being used is like basically this: % h2ph /usr/lib/perl/tmp.ph % c2ph some_include_file.h >> /usr/lib/perl/tmp.ph % install It's a little tricker with c2ph because you have to get the includes right. I can't know this for your system, but it's not usually too terribly difficult. The code isn't pretty as I mentioned -- I never thought it would be a 1000- line program when I started, or I might not have begun. :-) But I would have been less cavalier in how the parts of the program communicated with each other, etc. It might also have helped if I didn't have to divine the makeup of the stabs on the fly, and then account for micro differences between my compiler and gcc. Anyway, here it is. Should run on perl v4 or greater. Maybe less. --tom eldname", $_, $start+$offset); } if (/^\d+=ar/) { $_ = &adecl($_); } elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) { ($start, $length) = ($2, $3); &panic("no length?") unless $length; $typeno = &typeno($1) if $1; } elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)perl5.000/cflags.SH 755 203 12 5646 5650572654 7151 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=../../../..; else echo "Can't find config.sh."; exit 1 fi . $TOP/config.sh ;; esac : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac echo "Extracting cflags (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted : by putting a backslash in front. You may delete these comments. $spitshell >cflags <>cflags <<'!NO!SUBS!' 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=../../../..; else echo "Can't find config.sh."; exit 1 fi . $TOP/config.sh ;; esac perltype='' optdebug='' # ensure -g used if building a -DDEBUGGING libperl case $# in 2) case $1 in *perl.*) perltype='';; *perld.*) perltype='-DDEBUGGING'; optdebug='-g' ;; *perle.*) perltype='-DEMBED';; *perlde.*) perltype='-DDEBUGGING -DEMBED'; optdebug='-g' ;; *perlm.*) perltype='-DEMBED -DMULTIPLICITY';; *perldm.*) perltype='-DDEBUGGING -DEMBED -DMULTIPLICITY'; optdebug='-g' ;; esac shift ;; esac also=': ' case $# in 1) also='echo 1>&2 " CCCMD = "' esac case $# in 0) set *.c; echo "The current C flags are:" ;; esac set `echo "$* " | sed 's/\.[oc] / /g'` for file do case "$#" in 1) ;; *) echo $n " $file.c $c" ;; esac : allow variables like toke_cflags to be evaluated eval 'eval ${'"${file}_cflags"'-""}' : or customize here case "$file" in DB_File) ;; GDBM_File) ;; NDBM_File) ;; ODBM_File) ;; POSIX) ;; SDBM_File) ;; av) ;; deb) ;; dl) ;; doio) ;; doop) ;; dump) ;; gv) ;; hv) ;; main) ;; malloc) ;; mg) ;; miniperlmain) ;; op) ;; perl) ;; perlmain) ;; perly) ;; pp) ;; pp_ctl) ;; pp_hot) ;; pp_sys) ;; regcomp) ;; regexec) ;; run) ;; scope) ;; sv) ;; taint) ;; toke) ;; usersub) ;; util) ;; *) ;; esac if test "X$optdebug" != "X"; then optimize="$optdebug" fi echo "$cc -c $ccflags $optimize $perltype $large $split" eval "$also "'"$cc -c $ccflags $optimize $perltype $large $split"' . $TOP/config.sh done !NO!SUBS! chmod 755 cflags $eunicefix cflags 070 4 (*int)() tty.t_stopproc_cpu perl5.000/config.H 644 203 12 121554 5645376761 7073 /* This file (config.H) is a sample config.h file. If you are unable to successfully run Configure, copy this file to config.h and edit it to suit your system. */ /* * This file was produced by running the config_h.SH script, which * 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. * * $Id: Config_h.U,v 3.0.1.2 1993/08/24 12:13:20 ram Exp $ */ /* Configuration time: Thu Oct 6 18:27:36 EDT 1994 * Configured by: andy * Target system: crystal crystal 3.2 2 i386 */ #ifndef _config_h_ #define _config_h_ /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double. Usual values are 2, 4 and 8. */ #define MEM_ALIGNBYTES 4 /**/ /* BIN: * This symbol holds the path of the bin directory where the package will * be installed. Program must be prepared to deal with ~name substitution. */ #define BIN "/usr/local/bin" /**/ /* BYTEORDER: * This symbol hold the hexadecimal constant defined in byteorder, * i.e. 0x1234 or 0x4321, etc... */ #define BYTEORDER 0x1234 /* large digits for MSB */ /* CPPSTDIN: * This symbol contains the first part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. Typical value of "cc -E" or "/lib/cpp", but it can also * call a wrapper. See CPPRUN. */ /* CPPMINUS: * This symbol contains the second part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. This symbol will have the value "-" if CPPSTDIN needs a minus * to specify standard input, otherwise the value is "". */ #define CPPSTDIN "gcc -E" #define CPPMINUS "-" /* HAS_ALARM: * This symbol, if defined, indicates that the alarm routine is * available. */ #define HAS_ALARM /**/ /* HAS_BCMP: * This symbol is defined if the bcmp() routine is available to * compare blocks of memory. */ #define HAS_BCMP /**/ /* HAS_BCOPY: * This symbol is defined if the bcopy() routine is available to * copy blocks of memory. */ #define HAS_BCOPY /**/ /* HAS_BZERO: * This symbol is defined if the bzero() routine is available to * set a memory block to 0. */ #define HAS_BZERO /**/ /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. */ /*#define CASTI32 /**/ /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative * numbers to unsigned longs, ints and shorts. */ /* CASTFLAGS: * This symbol contains flags that say what difficulties the compiler * has casting odd floating values to unsigned long: * 0 = ok * 1 = couldn't cast < 0 * 2 = couldn't cast >= 0x80000000 */ #define CASTNEGFLOAT /**/ #define CASTFLAGS 0 /**/ /* CHARSPRINTF: * This symbol is defined if this system declares "char *sprintf()" in * stdio.h. The trend seems to be to declare it as "int sprintf()". It * is up to the package author to declare sprintf correctly based on the * symbol. */ /*#define CHARSPRINTF /**/ /* HAS_CHOWN: * This symbol, if defined, indicates that the chown routine is * available. */ #define HAS_CHOWN /**/ /* HAS_CHROOT: * This symbol, if defined, indicates that the chroot routine is * available. */ #define HAS_CHROOT /**/ /* HAS_CHSIZE: * This symbol, if defined, indicates that the chsize routine is available * to truncate files. You might need a -lx to get this routine. */ #define HAS_CHSIZE /**/ /* HASCONST: * This symbol, if defined, indicates that this C compiler knows about * the const type. There is no need to actually test for that symbol * within your programs. The mere use of the "const" keyword will * trigger the necessary tests. */ #define HASCONST /**/ #ifndef HASCONST #define const #endif /* HAS_CRYPT: * This symbol, if defined, indicates that the crypt routine is available * to encrypt passwords and the like. */ #define HAS_CRYPT /**/ /* CSH: * This symbol, if defined, indicates that the C-shell exists. * If defined, contains the full pathname of csh. */ #define CSH "/bin/csh" /**/ /* HAS_CUSERID: * This symbol, if defined, indicates that the cuserid routine is * available to get character login names. */ #define HAS_CUSERID /**/ /* HAS_DBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol DBL_DIG, which is the number * of significant digits in a double precision number. If this * symbol is not defined, a guess of 15 is usually pretty good. */ #define HAS_DBL_DIG /* */ /* HAS_DIFFTIME: * This symbol, if defined, indicates that the difftime routine is * available. */ #define HAS_DIFFTIME /**/ /* HAS_DUP2: * This symbol, if defined, indicates that the dup2 routine is * available to duplicate file descriptors. */ #define HAS_DUP2 /**/ /* HAS_FCHMOD: * This symbol, if defined, indicates that the fchmod routine is available * to change mode of opened files. If unavailable, use chmod(). */ /*#define HAS_FCHMOD /**/ /* HAS_FCHOWN: * This symbol, if defined, indicates that the fchown routine is available * to change ownership of opened files. If unavailable, use chown(). */ /*#define HAS_FCHOWN /**/ /* HAS_FCNTL: * This symbol, if defined, indicates to the C program that * the fcntl() function exists. */ #define HAS_FCNTL /**/ /* HAS_FGETPOS: * This symbol, if defined, indicates that the fgetpos routine is * available to get the file position indicator, similar to ftell(). */ /*#define HAS_FGETPOS /**/ /* FLEXFILENAMES: * This symbol, if defined, indicates that the system supports filenames * longer than 14 characters. */ /*#define FLEXFILENAMES /**/ /* HAS_FLOCK: * This symbol, if defined, indicates that the flock routine is * available to do file locking. */ /*#define HAS_FLOCK /**/ /* HAS_FORK: * This symbol, if defined, indicates that the fork routine is * available. */ #define HAS_FORK /**/ /* HAS_FSETPOS: * This symbol, if defined, indicates that the fsetpos routine is * available to set the file position indicator, similar to fseek(). */ /*#define HAS_FSETPOS /**/ /* HAS_GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple * groups are probably not supported. */ #define HAS_GETGROUPS /**/ /* HAS_GETHOSTENT: * This symbol, if defined, indicates that the gethostent routine is * available to lookup host names in some data base or other. */ /*#define HAS_GETHOSTENT /**/ /* HAS_UNAME: * This symbol, if defined, indicates that the C program may use the * uname() routine to derive the host name. See also HAS_GETHOSTNAME * and PHOSTNAME. */ #define HAS_UNAME /**/ /* HAS_GETLOGIN: * This symbol, if defined, indicates that the getlogin routine is * available to get the login name. */ #define HAS_GETLOGIN /**/ /* HAS_GETPGRP: * This symbol, if defined, indicates that the getpgrp routine is * available to get the current process group. */ #define HAS_GETPGRP /**/ /* HAS_GETPGRP2: * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) * routine is available to get the current process group. */ /*#define HAS_GETPGRP2 /**/ /* HAS_GETPPID: * This symbol, if defined, indicates that the getppid routine is * available to get the parent process ID. */ #define HAS_GETPPID /**/ /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is * available to get a process's priority. */ /*#define HAS_GETPRIORITY /**/ /* HAS_GROUP: * This symbol, if defined, indicates that the group routine is * available. */ /*#define HAS_GROUP /**/ /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and * friends htons() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_HTONS: * This symbol, if defined, indicates that the htons() routine (and * friends htonl() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHL: * This symbol, if defined, indicates that the ntohl() routine (and * friends htonl() htons() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHS: * This symbol, if defined, indicates that the ntohs() routine (and * friends htonl() htons() ntohl()) are available to do network * order byte swapping. */ #define HAS_HTONL /**/ #define HAS_HTONS /**/ #define HAS_NTOHL /**/ #define HAS_NTOHS /**/ /* HAS_KILLPG: * This symbol, if defined, indicates that the killpg routine is available * to kill process groups. If unavailable, you probably should use kill * with a negative process number. */ /*#define HAS_KILLPG /**/ /* HAS_LINK: * This symbol, if defined, indicates that the link routine is * available to create hard links. */ #define HAS_LINK /**/ /* HAS_LOCKF: * This symbol, if defined, indicates that the lockf routine is * available to do file locking. */ #define HAS_LOCKF /**/ /* HAS_LSTAT: * This symbol, if defined, indicates that the lstat routine is * available to do file stats on symbolic links. */ #define HAS_LSTAT /**/ /* HAS_MBLEN: * This symbol, if defined, indicates that the mblen routine is available * to find the number of bytes in a multibye character. */ /*#define HAS_MBLEN /**/ /* HAS_MBSTOWCS: * This symbol, if defined, indicates that the mbstowcs routine is * available to covert a multibyte string into a wide character string. */ /*#define HAS_MBSTOWCS /**/ /* HAS_MBTOWC: * This symbol, if defined, indicates that the mbtowc routine is available * to covert a multibyte to a wide character. */ /*#define HAS_MBTOWC /**/ /* HAS_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * to compare blocks of memory. */ #define HAS_MEMCMP /**/ /* HAS_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy blocks of memory. */ #define HAS_MEMCPY /**/ /* HAS_MEMMOVE: * This symbol, if defined, indicates that the memmove routine is available * to copy potentially overlapping blocks of memory. This should be used * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your * own version. */ /*#define HAS_MEMMOVE /**/ /* HAS_MEMSET: * This symbol, if defined, indicates that the memset routine is available * to set blocks of memory. */ #define HAS_MEMSET /**/ /* HAS_MKDIR: * This symbol, if defined, indicates that the mkdir routine is available * to create directories. Otherwise you should fork off a new process to * exec /bin/mkdir. */ #define HAS_MKDIR /**/ /* HAS_MKTIME: * This symbol, if defined, indicates that the mktime routine is * available. */ #define HAS_MKTIME /**/ /* HAS_MSG: * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). */ #define HAS_MSG /**/ /* HAS_NICE: * This symbol, if defined, indicates that the nice routine is * available. */ #define HAS_NICE /**/ /* HAS_OPEN3: * This manifest constant lets the C program know that the three * argument form of open(2) is available. */ #define HAS_OPEN3 /**/ /* HAS_PASSWD: * This symbol, if defined, indicates that the passwd routine is * available. */ /*#define HAS_PASSWD /**/ /* HAS_PAUSE: * This symbol, if defined, indicates that the pause routine is * available to suspend a process until a signal is received. */ #define HAS_PAUSE /**/ /* HAS_PIPE: * This symbol, if defined, indicates that the pipe routine is * available to create an inter-process channel. */ #define HAS_PIPE /**/ /* HAS_READDIR: * This symbol, if defined, indicates that the readdir routine is * available to read directory entries. You may have to include * . See I_DIRENT. */ #define HAS_READDIR /**/ /* HAS_SEEKDIR: * This symbol, if defined, indicates that the seekdir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_SEEKDIR /**/ /* HAS_TELLDIR: * This symbol, if defined, indicates that the telldir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_TELLDIR /**/ /* HAS_REWINDDIR: * This symbol, if defined, indicates that the rewinddir routine is * available. You may have to include . See I_DIRENT. */ #define HAS_REWINDDIR /**/ /* HAS_READLINK: * This symbol, if defined, indicates that the readlink routine is * available to read the value of a symbolic link. */ #define HAS_READLINK /**/ /* HAS_RENAME: * This symbol, if defined, indicates that the rename routine is available * to rename files. Otherwise you should do the unlink(), link(), unlink() * trick. */ #define HAS_RENAME /**/ /* HAS_RMDIR: * This symbol, if defined, indicates that the rmdir routine is * available to remove directories. Otherwise you should fork off a * new process to exec /bin/rmdir. */ #define HAS_RMDIR /**/ /* HAS_SELECT: * This symbol, if defined, indicates that the select routine is * available to select active file descriptors. If the timeout field * is used, may need to be included. */ #define HAS_SELECT /**/ /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. */ #define HAS_SEM /**/ /* HAS_SETEGID: * This symbol, if defined, indicates that the setegid routine is available * to change the effective gid of the current program. */ #define HAS_SETEGID /**/ /* HAS_SETEUID: * This symbol, if defined, indicates that the seteuid routine is available * to change the effective uid of the current program. */ #define HAS_SETEUID /**/ /* HAS_SETLINEBUF: * This symbol, if defined, indicates that the setlinebuf routine is * available to change stderr or stdout from block-buffered or unbuffered * to a line-buffered mode. */ /*#define HAS_SETLINEBUF /**/ /* HAS_SETLOCALE: * This symbol, if defined, indicates that the setlocale routine is * available to handle locale-specific ctype implementations. */ #define HAS_SETLOCALE /**/ /* HAS_SETPGID: * This symbol, if defined, indicates that the setpgid routine is * available to set process group ID. */ #define HAS_SETPGID /**/ /* HAS_SETPGRP: * This symbol, if defined, indicates that the setpgrp routine is * available to set the current process group. */ #define HAS_SETPGRP /**/ /* HAS_SETPGRP2: * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) * routine is available to set the current process group. */ /*#define HAS_SETPGRP2 /**/ /* HAS_SETPRIORITY: * This symbol, if defined, indicates that the setpriority routine is * available to set a process's priority. */ /*#define HAS_SETPRIORITY /**/ /* HAS_SETREGID: * This symbol, if defined, indicates that the setregid routine is * available to change the real and effective gid of the current * process. */ /* HAS_SETRESGID: * This symbol, if defined, indicates that the setresgid routine is * available to change the real, effective and saved gid of the current * process. */ #define HAS_SETREGID /**/ /*#define HAS_SETRESGID /**/ /* HAS_SETREUID: * This symbol, if defined, indicates that the setreuid routine is * available to change the real and effective uid of the current * process. */ /* HAS_SETRESUID: * This symbol, if defined, indicates that the setresuid routine is * available to change the real, effective and saved uid of the current * process. */ #define HAS_SETREUID /**/ /*#define HAS_SETRESUID /**/ /* HAS_SETRGID: * This symbol, if defined, indicates that the setrgid routine is available * to change the real gid of the current program. */ /*#define HAS_SETRGID /**/ /* HAS_SETRUID: * This symbol, if defined, indicates that the setruid routine is available * to change the real uid of the current program. */ /*#define HAS_SETRUID /**/ /* HAS_SETSID: * This symbol, if defined, indicates that the setsid routine is * available to set the process group ID. */ #define HAS_SETSID /**/ /* HAS_SHM: * This symbol, if defined, indicates that the entire shm*(2) library is * supported. */ #define HAS_SHM /**/ /* Shmat_t: * This symbol holds the return type of the shmat() system call. * Usually set to 'void *' or 'char *'. */ /* HAS_SHMAT_PROTOTYPE: * This symbol, if defined, indicates that the sys/shm.h includes * a prototype for shmat(). Otherwise, it is up to the program to * guess one. Shmat_t shmat _((int, Shmat_t, int)) is a good guess, * but not always right so it should be emitted by the program only * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. */ #define Shmat_t char * /**/ /*#define HAS_SHMAT_PROTOTYPE /**/ /* HAS_SOCKET: * This symbol, if defined, indicates that the BSD socket interface is * supported. */ /* HAS_SOCKETPAIR: * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ #define HAS_SOCKET /**/ /*#define HAS_SOCKETPAIR /**/ /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. */ /*#define USE_STAT_BLOCKS /**/ /* USE_STD_STDIO: * This symbol is defined if this system has a FILE structure declaring * _ptr and _cnt in stdio.h. */ #define USE_STD_STDIO /**/ /* HAS_STRCHR: * This symbol is defined to indicate that the strchr()/strrchr() * functions are available for string searching. If not, try the * index()/rindex() pair. */ /* HAS_INDEX: * This symbol is defined to indicate that the index()/rindex() * functions are available for string searching. */ #define HAS_STRCHR /**/ /*#define HAS_INDEX /**/ /* HAS_STRCOLL: * This symbol, if defined, indicates that the strcoll routine is * available to compare strings using collating information. */ #define HAS_STRCOLL /**/ /* USE_STRUCT_COPY: * This symbol, if defined, indicates that this C compiler knows how * to copy structures. If undefined, you'll need to use a block copy * routine of some sort instead. */ #define USE_STRUCT_COPY /**/ /* HAS_STRERROR: * This symbol, if defined, indicates that the strerror routine is * available to translate error numbers to strings. See the writeup * of Strerror() in this file before you try to define your own. */ /* HAS_SYS_ERRLIST: * This symbol, if defined, indicates that the sys_errlist array is * available to translate error numbers to strings. The extern int * sys_nerr gives the size of that table. */ /* Strerror: * This preprocessor symbol is defined as a macro if strerror() is * not available to translate error numbers to strings but sys_errlist[] * array is there. */ #define HAS_STRERROR /**/ #define HAS_SYS_ERRLIST /**/ #define Strerror(e) strerror(e) /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. */ #define HAS_STRXFRM /**/ /* HAS_SYMLINK: * This symbol, if defined, indicates that the symlink routine is available * to create symbolic links. */ #define HAS_SYMLINK /**/ /* HAS_SYSCALL: * This symbol, if defined, indicates that the syscall routine is * available to call arbitrary system calls. If undefined, that's tough. */ #define HAS_SYSCALL /**/ /* HAS_SYSTEM: * This symbol, if defined, indicates that the system routine is * available to issue a shell command. */ #define HAS_SYSTEM /**/ /* HAS_TCGETPGRP: * This symbol, if defined, indicates that the tcgetpgrp routine is * available to get foreground process group ID. */ #define HAS_TCGETPGRP /**/ /* HAS_TCSETPGRP: * This symbol, if defined, indicates that the tcsetpgrp routine is * available to set foreground process group ID. */ #define HAS_TCSETPGRP /**/ /* HAS_TIMES: * This symbol, if defined, indicates that the times() routine exists. * Note that this became obsolete on some systems (SUNOS), which now * use getrusage(). It may be necessary to include . */ #define HAS_TIMES /**/ /* HAS_TRUNCATE: * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ /*#define HAS_TRUNCATE /**/ /* HAS_TZNAME: * This symbol, if defined, indicates that the tzname[] array is * available to access timezone names. */ #define HAS_TZNAME /**/ /* HAS_UMASK: * This symbol, if defined, indicates that the umask routine is * available to set and get the value of the file creation mask. */ #define HAS_UMASK /**/ /* HAS_VFORK: * This symbol, if defined, indicates that vfork() exists. */ /*#define HAS_VFORK /**/ /* VOIDSIG: * This symbol is defined if this system declares "void (*signal(...))()" in * signal.h. The old way was to declare it as "int (*signal(...))()". It * is up to the package author to declare things correctly based on the * symbol. */ #define VOIDSIG /**/ /* HASVOLATILE: * This symbol, if defined, indicates that this C compiler knows about * the volatile declaration. */ #define HASVOLATILE /**/ #ifndef HASVOLATILE #define volatile #endif /* HAS_VPRINTF: * This symbol, if defined, indicates that the vprintf routine is available * to printf with a pointer to an argument list. If unavailable, you * may need to write your own, probably in terms of _doprnt(). */ /* USE_CHAR_VSPRINTF: * This symbol is defined if this system has vsprintf() returning type * (char*). The trend seems to be to declare it as "int vsprintf()". It * is up to the package author to declare vsprintf correctly based on the * symbol. */ #define HAS_VPRINTF /**/ /*#define USE_CHAR_VSPRINTF /**/ /* HAS_WAIT4: * This symbol, if defined, indicates that wait4() exists. */ /*#define HAS_WAIT4 /**/ /* HAS_WAITPID: * This symbol, if defined, indicates that the waitpid routine is * available to wait for child process. */ #define HAS_WAITPID /**/ /* HAS_WCSTOMBS: * This symbol, if defined, indicates that the wcstombs routine is * available to convert wide character strings to multibyte strings. */ /*#define HAS_WCSTOMBS /**/ /* HAS_WCTOMB: * This symbol, if defined, indicates that the wctomb routine is available * to covert a wide character to a multibyte. */ /*#define HAS_WCTOMB /**/ /* Fpos_t: * This symbol holds the type used to declare file positions in libc. * It can be fpos_t, long, uint, etc... It may be necessary to include * to get any typedef'ed information. */ #define Fpos_t fpos_t /* File position type */ /* Gid_t: * This symbol holds the return type of getgid() and the type of * argument to setrgid() and related functions. Typically, * it is the type of group ids in the kernel. It can be int, ushort, * uid_t, etc... It may be necessary to include to get * any typedef'ed information. */ #define Gid_t gid_t /* Type for getgid(), etc... */ /* I_DIRENT: * This symbol, if defined, indicates to the C program that it should * include . Using this symbol also triggers the definition * of the Direntry_t define which ends up being 'struct dirent' or * 'struct direct' depending on the availability of . */ /* DIRNAMLEN: * This symbol, if defined, indicates to the C program that the length * of directory entry names is provided by a d_namlen field. Otherwise * you need to do strlen() on the d_name field. */ /* Direntry_t: * This symbol is set to 'struct direct' or 'struct dirent' depending on * whether dirent is available or not. You should use this pseudo type to * portably declare your directory entries. */ #define I_DIRENT /**/ /*#define DIRNAMLEN /**/ #define Direntry_t struct dirent /* I_DLFCN: * This symbol, if defined, indicates that exists and should * be included. */ /*#define I_DLFCN /**/ /* I_FCNTL: * This manifest constant tells the C program to include . */ #define I_FCNTL /**/ /* I_FLOAT: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like DBL_MAX or * DBL_MIN, i.e. machine dependent floating point values. */ #define I_FLOAT /**/ /* I_GRP: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_GRP /**/ /* I_LIMITS: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like WORD_BIT or * LONG_MAX, i.e. machine dependant limitations. */ #define I_LIMITS /**/ /* I_MATH: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_MATH /**/ /* I_MEMORY: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_MEMORY /**/ /* I_NDBM: * This symbol, if defined, indicates that ndbm.h exists and should * be included. */ #define I_NDBM /**/ /* I_NETINET_IN: * This symbol, if defined, indicates to the C program that it should * include . Otherwise, you may try . */ #define I_NETINET_IN /**/ /* I_PWD: * This symbol, if defined, indicates to the C program that it should * include . */ /* PWQUOTA: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_quota. */ /* PWAGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_age. */ /* PWCHANGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_change. */ /* PWCLASS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_class. */ /* PWEXPIRE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_expire. */ /* PWCOMMENT: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_comment. */ #define I_PWD /**/ /*#define PWQUOTA /**/ #define PWAGE /**/ /*#define PWCHANGE /**/ /*#define PWCLASS /**/ /*#define PWEXPIRE /**/ #define PWCOMMENT /**/ /* I_STDDEF: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDDEF /**/ /* I_STDLIB: * This symbol, if defined, indicates that exists and should * be included. */ #define I_STDLIB /**/ /* I_STRING: * This symbol, if defined, indicates to the C program that it should * include (USG systems) instead of (BSD systems). */ #define I_STRING /**/ /* I_SYS_DIR: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_DIR /**/ /* I_SYS_FILE: * This symbol, if defined, indicates to the C program that it should * include to get definition of R_OK and friends. */ /*#define I_SYS_FILE /**/ /* I_SYS_IOCTL: * This symbol, if defined, indicates that exists and should * be included. Otherwise, include or . */ #define I_SYS_IOCTL /**/ /* I_SYS_NDIR: * This symbol, if defined, indicates to the C program that it should * include . */ /*#define I_SYS_NDIR /**/ /* I_SYS_PARAM: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_PARAM /**/ /* I_SYS_SELECT: * This symbol, if defined, indicates to the C program that it should * include in order to get definition of struct timeval. */ /*#define I_SYS_SELECT /**/ /* I_SYS_TIMES: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_SYS_TIMES /**/ /* I_TERMIO: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /* I_TERMIOS: * This symbol, if defined, indicates that the program should include * the POSIX termios.h rather than sgtty.h or termio.h. * There are also differences in the ioctl() calls that depend on the * value of this symbol. */ /* I_SGTTY: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /*#define I_TERMIO /**/ #define I_TERMIOS /**/ /*#define I_SGTTY /**/ /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME_KERNEL: * This symbol, if defined, indicates to the C program that it should * include with KERNEL defined. */ /*#define I_TIME /**/ #define I_SYS_TIME /**/ /*#define I_SYS_TIME_KERNEL /**/ /* I_UNISTD: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_UNISTD /**/ /* I_UTIME: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_UTIME /**/ /* I_STDARG: * This symbol, if defined, indicates that exists and should * be included. */ /* I_VARARGS: * This symbol, if defined, indicates to the C program that it should * include . */ #define I_STDARG /**/ /*#define I_VARARGS /**/ /* I_VFORK: * This symbol, if defined, indicates to the C program that it should * include vfork.h. */ /*#define I_VFORK /**/ /* INTSIZE: * This symbol contains the size of an int, so that the C preprocessor * can make decisions based on it. */ #define INTSIZE 4 /**/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. * It can be int, long, off_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Off_t off_t /* type */ /* PRIVLIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. */ #define PRIVLIB "/usr/local/lib/perl5" /**/ /* CAN_PROTOTYPE: * If defined, this macro indicates that the C compiler can handle * function prototypes. */ /* _: * This macro is used to declare function parameters for folks who want * to make declarations with prototypes using a different style than * the above macros. Use double parentheses. For example: * * int main _((int argc, char *argv[])); */ #define CAN_PROTOTYPE /**/ #ifdef CAN_PROTOTYPE #define _(args) args #else #define _(args) () #endif /* RANDBITS: * This symbol contains the number of bits of random number the rand() * function produces. Usual values are 15, 16, and 31. */ #define RANDBITS 15 /**/ /* SCRIPTDIR: * This symbol holds the name of the directory in which the user wants * to put publicly executable scripts for the package in question. It * is often a directory that is mounted across diverse architectures. * Programs must be prepared to deal with ~name expansion. */ #define SCRIPTDIR "/usr/local/bin" /**/ /* Select_fd_set_t: * This symbol holds the type used for the 2nd, 3rd, and 4th * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET * is defined, and 'int *' otherwise. This is only useful if you * have select(), of course. */ #define Select_fd_set_t fd_set * /**/ /* SIG_NAME: * This symbol contains a list of signal names in order. This is intended * to be used as a static array initialization, like this: * char *sig_name[] = { SIG_NAME }; * The signals in the list are separated with commas, and each signal * is surrounded by double quotes. There is no leading SIG in the signal * name, i.e. SIGQUIT is known as "QUIT". */ #define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","ABRT","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","USR1","USR2","CLD","PWR","WINCH","21","POLL","CONT","STOP","TSTP","TTIN","TTOU" /**/ /* Size_t: * This symbol holds the type used to declare length parameters * for string functions. It is usually size_t, but may be * unsigned long, int, etc. It may be necessary to include * to get any typedef'ed information. */ #define Size_t size_t /* length paramater for string functions */ /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". */ #define STDCHAR unsigned char /**/ /* Uid_t: * This symbol holds the type used to declare user ids in the kernel. * It can be int, ushort, uid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Uid_t uid_t /* UID type */ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this * compiler. What various bits mean: * * 1 = supports declaration of void * 2 = supports arrays of pointers to functions returning void * 4 = supports comparisons between pointers to void functions and * addresses of void functions * 8 = suports declaration of generic void pointers * * The package designer should define VOIDUSED to indicate the requirements * of the package. This can be done either by #defining VOIDUSED before * including config.h, or by defining defvoidused in Myinit.U. If the * latter approach is taken, only those flags will be tested. If the * level of void support necessary is not present, defines void to int. */ #ifndef VOIDUSED #define VOIDUSED 15 #endif #define VOIDFLAGS 15 #if (VOIDFLAGS & VOIDUSED) != VOIDUSED #define void int /* is void to be avoided? */ #define M_VOID /* Xenix strikes again */ #endif /* EUNICE: * This symbol, if defined, indicates that the program is being compiled * under the EUNICE package under VMS. The program will need to handle * things like files that don't go away the first time you unlink them, * due to version numbering. It will also need to compensate for lack * of a respectable link() command. */ /* VMS: * This symbol, if defined, indicates that the program is running under * VMS. It is currently only set in conjunction with the EUNICE symbol. */ /*#define EUNICE /**/ /*#define VMS /**/ /* LOC_SED: * This symbol holds the complete pathname to the sed program. */ #define LOC_SED "/bin/sed" /**/ /* ARCHLIB: * This variable, if defined, holds the name of the directory in * which the user wants to put architecture-dependent public * library files for perl5. It is most often a local directory * such as /usr/local/lib. Programs using this variable must be * prepared to deal with filename expansion. If ARCHLIB is the * same as PRIVLIB, it is not defined, since presumably the * program already searches PRIVLIB. */ #define ARCHLIB "/usr/local/lib/perl5/isc" /**/ /* CAT2: * This macro catenates 2 tokens together. */ #if 42 == 1 #define CAT2(a,b)a/**/b #define CAT3(a,b,c)a/**/b/**/c #define CAT4(a,b,c,d)a/**/b/**/c/**/d #define CAT5(a,b,c,d,e)a/**/b/**/c/**/d/**/e #define STRINGIFY(a)"a" /* If you can get stringification with catify, tell me how! */ #endif #if 42 == 42 #define CAT2(a,b)a ## b #define CAT3(a,b,c)a ## b ## c #define CAT4(a,b,c,d)a ## b ## c ## d #define CAT5(a,b,c,d,e)a ## b ## c ## d ## e #define StGiFy(a)# a #define STRINGIFY(a)StGiFy(a) #define SCAT2(a,b)StGiFy(a) StGiFy(b) #define SCAT3(a,b,c)StGiFy(a) StGiFy(b) StGiFy(c) #define SCAT4(a,b,c,d)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) #define SCAT5(a,b,c,d,e)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) StGiFy(e) #endif #ifndef CAT2 #include "Bletch: How does this C preprocessor catenate tokens?" #endif /* GNUC_ATTRIBUTE_CHECK: * This symbol indicates the C compiler can check for function attributes, * such as printf formats. */ #define GNUC_ATTRIBUTE_CHECK /* */ /* VOID_CLOSEDIR: * This symbol, if defined, indicates that the closedir() routine * does not return a value. */ /*#define VOID_CLOSEDIR /**/ /* HAS_DLERROR: * This symbol, if defined, indicates that the dlerror routine is * available. */ /*#define HAS_DLERROR /**/ /* DLSYM_NEEDS_UNDERSCORE: * This symbol, if defined, indicates that we need to prepend an * underscore to the symbol name before calling dlsym(). This only * makes sense if you *have* dlsym, which we will presume is the * case if you're using dl_dlopen.xs. */ /*#define DLSYM_NEEDS_UNDERSCORE /* */ /* SETUID_SCRIPTS_ARE_SECURE_NOW: * This symbol, if defined, indicates that the bug that prevents * setuid scripts from being secure is not present in this kernel. */ /* DOSUID: * This symbol, if defined, indicates that the C program should * check the script that it is executing for setuid/setgid bits, and * attempt to emulate setuid/setgid on systems that have disabled * setuid #! scripts because the kernel can't do it securely. * It is up to the package designer to make sure that this emulation * is done securely. Among other things, it should do an fstat on * the script it just opened to make sure it really is a setuid/setgid * script, it should make sure the arguments passed correspond exactly * to the argument on the #! line, and it should not trust any * subprocesses to which it must pass the filename rather than the * file descriptor of the script to be executed. */ /*#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/ /*#define DOSUID /**/ /* HAS_DREM: * This symbol, if defined, indicates that the drem routine is * available. This is a Pyramid routine that is the same as * fmod. */ /*#define HAS_DREM /**/ /* HAS_FMOD: * This symbol, if defined, indicates that the fmod routine is * available. */ #define HAS_FMOD /**/ /* Gconvert: * This preprocessor macro is defined to convert a floating point * number to a string without a trailing decimal point. This * emulates the behavior of sprintf("%g"), but is sometimes much more * efficient. If gconvert() is not available, but gcvt() drops the * trailing decimal point, then gcvt() is used. If all else fails, * a macro using sprintf("%g") is used. */ #define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x)) /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. */ #define HAS_ISASCII /**/ /* USE_LINUX_STDIO: * This symbol is defined if this system has a FILE structure declaring * _IO_read_base, _IO_read_ptr, and _IO_read_end in stdio.h. */ /*#define USE_LINUX_STDIO /**/ /* HAS_LOCALECONV: * This symbol, if defined, indicates that the localeconv routine is * available for numeric and monetary formatting conventions. */ #define HAS_LOCALECONV /**/ /* HAS_MKFIFO: * This symbol, if defined, indicates that the mkfifo routine is * available. */ #define HAS_MKFIFO /**/ /* HAS_PATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given filename. */ /* HAS_FPATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given open file descriptor. */ #define HAS_PATHCONF /**/ #define HAS_FPATHCONF /**/ /* HAS_SAFE_BCOPY: * This symbol, if defined, indicates that the bcopy routine is available * to copy potentially overlapping memory blocks. Otherwise you should * probably use memmove() or memcpy(). If neither is defined, roll your * own version. */ #define HAS_SAFE_BCOPY /**/ /* HAS_SAFE_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy potentially overlapping memory blocks. Otherwise you should * probably use memmove() or memcpy(). If neither is defined, roll your * own version. */ #define HAS_SAFE_MEMCPY /**/ /* HAS_SYSCONF: * This symbol, if defined, indicates that sysconf() is available * to determine system related limits and options. */ #define HAS_SYSCONF /**/ /* Time_t: * This symbol holds the type returned by time(). It can be long, * or time_t on BSD sites (in which case should be * included). */ #define Time_t time_t /* Time type */ /* USE_DYNAMIC_LOADING: * This symbol, if defined, indicates that dynamic loading of * some sort is available. */ /*#define USE_DYNAMIC_LOADING /**/ /* Groups_t: * This symbol holds the type used for the second argument to * getgroups(). Usually, this is the same of gidtype, but * sometimes it isn't. It can be int, ushort, uid_t, etc... * It may be necessary to include to get any * typedef'ed information. This is only required if you have * getgroups(). */ #ifdef HAS_GETGROUPS #define Groups_t gid_t /* Type for 2nd arg to getgroups() */ #endif /* I_NET_ERRNO: * This symbol, if defined, indicates that exists and * should be included. */ #define I_NET_ERRNO /**/ /* Malloc_t: * This symbol is the type of pointer returned by malloc and realloc. */ #define Malloc_t void * /**/ /* MYMALLOC: * This symbol, if defined, indicates that we're using our own malloc. */ #define MYMALLOC /**/ /* Mode_t: * This symbol holds the type used to declare file modes * for systems calls. It is usually mode_t, but may be * int or unsigned short. It may be necessary to include * to get any typedef'ed information. */ #define Mode_t mode_t /* file mode parameter for system calls*/ /* SSize_t: * This symbol holds the type used by functions that return * a count of bytes or an error condition. It must be a signed type. * It is usually ssize_t, but may be long or int, etc. * It may be necessary to include or * to get any typedef'ed information. * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). */ #define SSize_t int /* signed count of bytes */ #endif ine void int /* is void to be avoided? */ #define M_VOID /* Xenix strikes again */ #endif /* EUNICE: * This symbol, if defined, indicates that perl5.000/config_h.SH 755 203 12 123474 5650574272 7524 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=../../../..; else echo "Can't find config.sh."; exit 1 fi . $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!' -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 * 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. * * Config_h.U */ /* Configuration time: $cf_time * Configured by: $cf_by * Target system: $myuname */ #ifndef _config_h_ #define _config_h_ /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double. Usual values are 2, 4 and 8. */ #define MEM_ALIGNBYTES $alignbytes /**/ /* BIN: * This symbol holds the path of the bin directory where the package will * be installed. Program must be prepared to deal with ~name substitution. */ #define BIN "$bin" /**/ /* BYTEORDER: * This symbol hold the hexadecimal constant defined in byteorder, * i.e. 0x1234 or 0x4321, etc... */ #define BYTEORDER 0x$byteorder /* large digits for MSB */ /* CPPSTDIN: * This symbol contains the first part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. Typical value of "cc -E" or "/lib/cpp", but it can also * call a wrapper. See CPPRUN. */ /* CPPMINUS: * This symbol contains the second part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. This symbol will have the value "-" if CPPSTDIN needs a minus * to specify standard input, otherwise the value is "". */ #define CPPSTDIN "$cppstdin" #define CPPMINUS "$cppminus" /* HAS_ALARM: * This symbol, if defined, indicates that the alarm routine is * available. */ #$d_alarm HAS_ALARM /**/ /* HAS_BCMP: * This symbol is defined if the bcmp() routine is available to * compare blocks of memory. */ #$d_bcmp HAS_BCMP /**/ /* HAS_BCOPY: * This symbol is defined if the bcopy() routine is available to * copy blocks of memory. */ #$d_bcopy HAS_BCOPY /**/ /* HAS_BZERO: * This symbol is defined if the bzero() routine is available to * set a memory block to 0. */ #$d_bzero HAS_BZERO /**/ /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. */ #$d_casti32 CASTI32 /**/ /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative * numbers to unsigned longs, ints and shorts. */ /* CASTFLAGS: * This symbol contains flags that say what difficulties the compiler * has casting odd floating values to unsigned long: * 0 = ok * 1 = couldn't cast < 0 * 2 = couldn't cast >= 0x80000000 */ #$d_castneg CASTNEGFLOAT /**/ #define CASTFLAGS $castflags /**/ /* CHARSPRINTF: * This symbol is defined if this system declares "char *sprintf()" in * stdio.h. The trend seems to be to declare it as "int sprintf()". It * is up to the package author to declare sprintf correctly based on the * symbol. */ #$d_charsprf CHARSPRINTF /**/ /* HAS_CHOWN: * This symbol, if defined, indicates that the chown routine is * available. */ #$d_chown HAS_CHOWN /**/ /* HAS_CHROOT: * This symbol, if defined, indicates that the chroot routine is * available. */ #$d_chroot HAS_CHROOT /**/ /* HAS_CHSIZE: * This symbol, if defined, indicates that the chsize routine is available * to truncate files. You might need a -lx to get this routine. */ #$d_chsize HAS_CHSIZE /**/ /* HASCONST: * This symbol, if defined, indicates that this C compiler knows about * the const type. There is no need to actually test for that symbol * within your programs. The mere use of the "const" keyword will * trigger the necessary tests. */ #$d_const HASCONST /**/ #ifndef HASCONST #define const #endif /* HAS_CRYPT: * This symbol, if defined, indicates that the crypt routine is available * to encrypt passwords and the like. */ #$d_crypt HAS_CRYPT /**/ /* CSH: * This symbol, if defined, indicates that the C-shell exists. * If defined, contains the full pathname of csh. */ #$d_csh CSH "$csh" /**/ /* HAS_CUSERID: * This symbol, if defined, indicates that the cuserid routine is * available to get character login names. */ #$d_cuserid HAS_CUSERID /**/ /* HAS_DBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol DBL_DIG, which is the number * of significant digits in a double precision number. If this * symbol is not defined, a guess of 15 is usually pretty good. */ #$d_dbl_dig HAS_DBL_DIG /* */ /* HAS_DIFFTIME: * This symbol, if defined, indicates that the difftime routine is * available. */ #$d_difftime HAS_DIFFTIME /**/ /* HAS_DUP2: * This symbol, if defined, indicates that the dup2 routine is * available to duplicate file descriptors. */ #$d_dup2 HAS_DUP2 /**/ /* HAS_FCHMOD: * This symbol, if defined, indicates that the fchmod routine is available * to change mode of opened files. If unavailable, use chmod(). */ #$d_fchmod HAS_FCHMOD /**/ /* HAS_FCHOWN: * This symbol, if defined, indicates that the fchown routine is available * to change ownership of opened files. If unavailable, use chown(). */ #$d_fchown HAS_FCHOWN /**/ /* HAS_FCNTL: * This symbol, if defined, indicates to the C program that * the fcntl() function exists. */ #$d_fcntl HAS_FCNTL /**/ /* HAS_FGETPOS: * This symbol, if defined, indicates that the fgetpos routine is * available to get the file position indicator, similar to ftell(). */ #$d_fgetpos HAS_FGETPOS /**/ /* FLEXFILENAMES: * This symbol, if defined, indicates that the system supports filenames * longer than 14 characters. */ #$d_flexfnam FLEXFILENAMES /**/ /* HAS_FLOCK: * This symbol, if defined, indicates that the flock routine is * available to do file locking. */ #$d_flock HAS_FLOCK /**/ /* HAS_FORK: * This symbol, if defined, indicates that the fork routine is * available. */ #$d_fork HAS_FORK /**/ /* HAS_FSETPOS: * This symbol, if defined, indicates that the fsetpos routine is * available to set the file position indicator, similar to fseek(). */ #$d_fsetpos HAS_FSETPOS /**/ /* HAS_GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple * groups are probably not supported. */ #$d_getgrps HAS_GETGROUPS /**/ /* HAS_GETHOSTENT: * This symbol, if defined, indicates that the gethostent routine is * available to lookup host names in some data base or other. */ #$d_gethent HAS_GETHOSTENT /**/ /* HAS_UNAME: * This symbol, if defined, indicates that the C program may use the * uname() routine to derive the host name. See also HAS_GETHOSTNAME * and PHOSTNAME. */ #$d_uname HAS_UNAME /**/ /* HAS_GETLOGIN: * This symbol, if defined, indicates that the getlogin routine is * available to get the login name. */ #$d_getlogin HAS_GETLOGIN /**/ /* HAS_GETPGRP: * This symbol, if defined, indicates that the getpgrp routine is * available to get the current process group. */ #$d_getpgrp HAS_GETPGRP /**/ /* HAS_GETPGRP2: * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) * routine is available to get the current process group. */ #$d_getpgrp2 HAS_GETPGRP2 /**/ /* HAS_GETPPID: * This symbol, if defined, indicates that the getppid routine is * available to get the parent process ID. */ #$d_getppid HAS_GETPPID /**/ /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is * available to get a process's priority. */ #$d_getprior HAS_GETPRIORITY /**/ /* HAS_GROUP: * This symbol, if defined, indicates that the group routine is * available. */ #$d_group HAS_GROUP /**/ /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and * friends htons() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_HTONS: * This symbol, if defined, indicates that the htons() routine (and * friends htonl() ntohl() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHL: * This symbol, if defined, indicates that the ntohl() routine (and * friends htonl() htons() ntohs()) are available to do network * order byte swapping. */ /* HAS_NTOHS: * This symbol, if defined, indicates that the ntohs() routine (and * friends htonl() htons() ntohl()) are available to do network * order byte swapping. */ #$d_htonl HAS_HTONL /**/ #$d_htonl HAS_HTONS /**/ #$d_htonl HAS_NTOHL /**/ #$d_htonl HAS_NTOHS /**/ /* HAS_KILLPG: * This symbol, if defined, indicates that the killpg routine is available * to kill process groups. If unavailable, you probably should use kill * with a negative process number. */ #$d_killpg HAS_KILLPG /**/ /* HAS_LINK: * This symbol, if defined, indicates that the link routine is * available to create hard links. */ #$d_link HAS_LINK /**/ /* HAS_LOCKF: * This symbol, if defined, indicates that the lockf routine is * available to do file locking. */ #$d_lockf HAS_LOCKF /**/ /* HAS_LSTAT: * This symbol, if defined, indicates that the lstat routine is * available to do file stats on symbolic links. */ #$d_lstat HAS_LSTAT /**/ /* HAS_MBLEN: * This symbol, if defined, indicates that the mblen routine is available * to find the number of bytes in a multibye character. */ #$d_mblen HAS_MBLEN /**/ /* HAS_MBSTOWCS: * This symbol, if defined, indicates that the mbstowcs routine is * available to covert a multibyte string into a wide character string. */ #$d_mbstowcs HAS_MBSTOWCS /**/ /* HAS_MBTOWC: * This symbol, if defined, indicates that the mbtowc routine is available * to covert a multibyte to a wide character. */ #$d_mbtowc HAS_MBTOWC /**/ /* HAS_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * to compare blocks of memory. */ #$d_memcmp HAS_MEMCMP /**/ /* HAS_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy blocks of memory. */ #$d_memcpy HAS_MEMCPY /**/ /* HAS_MEMMOVE: * This symbol, if defined, indicates that the memmove routine is available * to copy potentially overlapping blocks of memory. This should be used * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your * own version. */ #$d_memmove HAS_MEMMOVE /**/ /* HAS_MEMSET: * This symbol, if defined, indicates that the memset routine is available * to set blocks of memory. */ #$d_memset HAS_MEMSET /**/ /* HAS_MKDIR: * This symbol, if defined, indicates that the mkdir routine is available * to create directories. Otherwise you should fork off a new process to * exec /bin/mkdir. */ #$d_mkdir HAS_MKDIR /**/ /* HAS_MKTIME: * This symbol, if defined, indicates that the mktime routine is * available. */ #$d_mktime HAS_MKTIME /**/ /* HAS_MSG: * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). */ #$d_msg HAS_MSG /**/ /* HAS_NICE: * This symbol, if defined, indicates that the nice routine is * available. */ #$d_nice HAS_NICE /**/ /* HAS_OPEN3: * This manifest constant lets the C program know that the three * argument form of open(2) is available. */ #$d_open3 HAS_OPEN3 /**/ /* HAS_PASSWD: * This symbol, if defined, indicates that the passwd routine is * available. */ #$d_passwd HAS_PASSWD /**/ /* HAS_PAUSE: * This symbol, if defined, indicates that the pause routine is * available to suspend a process until a signal is received. */ #$d_pause HAS_PAUSE /**/ /* HAS_PIPE: * This symbol, if defined, indicates that the pipe routine is * available to create an inter-process channel. */ #$d_pipe HAS_PIPE /**/ /* HAS_READDIR: * This symbol, if defined, indicates that the readdir routine is * available to read directory entries. You may have to include * . See I_DIRENT. */ #$d_readdir HAS_READDIR /**/ /* HAS_SEEKDIR: * This symbol, if defined, indicates that the seekdir routine is * available. You may have to include . See I_DIRENT. */ #$d_seekdir HAS_SEEKDIR /**/ /* HAS_TELLDIR: * This symbol, if defined, indicates that the telldir routine is * available. You may have to include . See I_DIRENT. */ #$d_telldir HAS_TELLDIR /**/ /* HAS_REWINDDIR: * This symbol, if defined, indicates that the rewinddir routine is * available. You may have to include . See I_DIRENT. */ #$d_rewinddir HAS_REWINDDIR /**/ /* HAS_READLINK: * This symbol, if defined, indicates that the readlink routine is * available to read the value of a symbolic link. */ #$d_readlink HAS_READLINK /**/ /* HAS_RENAME: * This symbol, if defined, indicates that the rename routine is available * to rename files. Otherwise you should do the unlink(), link(), unlink() * trick. */ #$d_rename HAS_RENAME /**/ /* HAS_RMDIR: * This symbol, if defined, indicates that the rmdir routine is * available to remove directories. Otherwise you should fork off a * new process to exec /bin/rmdir. */ #$d_rmdir HAS_RMDIR /**/ /* HAS_SELECT: * This symbol, if defined, indicates that the select routine is * available to select active file descriptors. If the timeout field * is used, may need to be included. */ #$d_select HAS_SELECT /**/ /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. */ #$d_sem HAS_SEM /**/ /* HAS_SETEGID: * This symbol, if defined, indicates that the setegid routine is available * to change the effective gid of the current program. */ #$d_setegid HAS_SETEGID /**/ /* HAS_SETEUID: * This symbol, if defined, indicates that the seteuid routine is available * to change the effective uid of the current program. */ #$d_seteuid HAS_SETEUID /**/ /* HAS_SETLINEBUF: * This symbol, if defined, indicates that the setlinebuf routine is * available to change stderr or stdout from block-buffered or unbuffered * to a line-buffered mode. */ #$d_setlinebuf HAS_SETLINEBUF /**/ /* HAS_SETLOCALE: * This symbol, if defined, indicates that the setlocale routine is * available to handle locale-specific ctype implementations. */ #$d_setlocale HAS_SETLOCALE /**/ /* HAS_SETPGID: * This symbol, if defined, indicates that the setpgid routine is * available to set process group ID. */ #$d_setpgid HAS_SETPGID /**/ /* HAS_SETPGRP2: * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) * routine is available to set the current process group. */ #$d_setpgrp2 HAS_SETPGRP2 /**/ /* HAS_SETPRIORITY: * This symbol, if defined, indicates that the setpriority routine is * available to set a process's priority. */ #$d_setprior HAS_SETPRIORITY /**/ /* HAS_SETREGID: * This symbol, if defined, indicates that the setregid routine is * available to change the real and effective gid of the current * process. */ /* HAS_SETRESGID: * This symbol, if defined, indicates that the setresgid routine is * available to change the real, effective and saved gid of the current * process. */ #$d_setregid HAS_SETREGID /**/ #$d_setresgid HAS_SETRESGID /**/ /* HAS_SETREUID: * This symbol, if defined, indicates that the setreuid routine is * available to change the real and effective uid of the current * process. */ /* HAS_SETRESUID: * This symbol, if defined, indicates that the setresuid routine is * available to change the real, effective and saved uid of the current * process. */ #$d_setreuid HAS_SETREUID /**/ #$d_setresuid HAS_SETRESUID /**/ /* HAS_SETRGID: * This symbol, if defined, indicates that the setrgid routine is available * to change the real gid of the current program. */ #$d_setrgid HAS_SETRGID /**/ /* HAS_SETRUID: * This symbol, if defined, indicates that the setruid routine is available * to change the real uid of the current program. */ #$d_setruid HAS_SETRUID /**/ /* HAS_SETSID: * This symbol, if defined, indicates that the setsid routine is * available to set the process group ID. */ #$d_setsid HAS_SETSID /**/ /* HAS_SHM: * This symbol, if defined, indicates that the entire shm*(2) library is * supported. */ #$d_shm HAS_SHM /**/ /* Shmat_t: * This symbol holds the return type of the shmat() system call. * Usually set to 'void *' or 'char *'. */ /* HAS_SHMAT_PROTOTYPE: * This symbol, if defined, indicates that the sys/shm.h includes * a prototype for shmat(). Otherwise, it is up to the program to * guess one. Shmat_t shmat _((int, Shmat_t, int)) is a good guess, * but not always right so it should be emitted by the program only * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. */ #define Shmat_t $shmattype /**/ #$d_shmatprototype HAS_SHMAT_PROTOTYPE /**/ /* HAS_SOCKET: * This symbol, if defined, indicates that the BSD socket interface is * supported. */ /* HAS_SOCKETPAIR: * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ #$d_socket HAS_SOCKET /**/ #$d_sockpair HAS_SOCKETPAIR /**/ /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. */ #$d_statblks USE_STAT_BLOCKS /**/ /* USE_STD_STDIO: * This symbol is defined if this system has a FILE structure declaring * _ptr and _cnt in stdio.h. */ #$d_stdstdio USE_STD_STDIO /**/ /* HAS_STRCHR: * This symbol is defined to indicate that the strchr()/strrchr() * functions are available for string searching. If not, try the * index()/rindex() pair. */ /* HAS_INDEX: * This symbol is defined to indicate that the index()/rindex() * functions are available for string searching. */ #$d_strchr HAS_STRCHR /**/ #$d_index HAS_INDEX /**/ /* HAS_STRCOLL: * This symbol, if defined, indicates that the strcoll routine is * available to compare strings using collating information. */ #$d_strcoll HAS_STRCOLL /**/ /* USE_STRUCT_COPY: * This symbol, if defined, indicates that this C compiler knows how * to copy structures. If undefined, you'll need to use a block copy * routine of some sort instead. */ #$d_strctcpy USE_STRUCT_COPY /**/ /* HAS_STRERROR: * This symbol, if defined, indicates that the strerror routine is * available to translate error numbers to strings. See the writeup * of Strerror() in this file before you try to define your own. */ /* HAS_SYS_ERRLIST: * This symbol, if defined, indicates that the sys_errlist array is * available to translate error numbers to strings. The extern int * sys_nerr gives the size of that table. */ /* Strerror: * This preprocessor symbol is defined as a macro if strerror() is * not available to translate error numbers to strings but sys_errlist[] * array is there. */ #$d_strerror HAS_STRERROR /**/ #$d_syserrlst HAS_SYS_ERRLIST /**/ #define Strerror(e) $d_strerrm /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. */ #$d_strxfrm HAS_STRXFRM /**/ /* HAS_SYMLINK: * This symbol, if defined, indicates that the symlink routine is available * to create symbolic links. */ #$d_symlink HAS_SYMLINK /**/ /* HAS_SYSCALL: * This symbol, if defined, indicates that the syscall routine is * available to call arbitrary system calls. If undefined, that's tough. */ #$d_syscall HAS_SYSCALL /**/ /* HAS_SYSTEM: * This symbol, if defined, indicates that the system routine is * available to issue a shell command. */ #$d_system HAS_SYSTEM /**/ /* HAS_TCGETPGRP: * This symbol, if defined, indicates that the tcgetpgrp routine is * available to get foreground process group ID. */ #$d_tcgetpgrp HAS_TCGETPGRP /**/ /* HAS_TCSETPGRP: * This symbol, if defined, indicates that the tcsetpgrp routine is * available to set foreground process group ID. */ #$d_tcsetpgrp HAS_TCSETPGRP /**/ /* HAS_TIMES: * This symbol, if defined, indicates that the times() routine exists. * Note that this became obsolete on some systems (SUNOS), which now * use getrusage(). It may be necessary to include . */ #$d_times HAS_TIMES /**/ /* HAS_TRUNCATE: * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ #$d_truncate HAS_TRUNCATE /**/ /* HAS_TZNAME: * This symbol, if defined, indicates that the tzname[] array is * available to access timezone names. */ #$d_tzname HAS_TZNAME /**/ /* HAS_UMASK: * This symbol, if defined, indicates that the umask routine is * available to set and get the value of the file creation mask. */ #$d_umask HAS_UMASK /**/ /* HAS_VFORK: * This symbol, if defined, indicates that vfork() exists. */ #$d_vfork HAS_VFORK /**/ /* VOIDSIG: * This symbol is defined if this system declares "void (*signal(...))()" in * signal.h. The old way was to declare it as "int (*signal(...))()". It * is up to the package author to declare things correctly based on the * symbol. */ #$d_voidsig VOIDSIG /**/ /* HASVOLATILE: * This symbol, if defined, indicates that this C compiler knows about * the volatile declaration. */ #$d_volatile HASVOLATILE /**/ #ifndef HASVOLATILE #define volatile #endif /* HAS_VPRINTF: * This symbol, if defined, indicates that the vprintf routine is available * to printf with a pointer to an argument list. If unavailable, you * may need to write your own, probably in terms of _doprnt(). */ /* USE_CHAR_VSPRINTF: * This symbol is defined if this system has vsprintf() returning type * (char*). The trend seems to be to declare it as "int vsprintf()". It * is up to the package author to declare vsprintf correctly based on the * symbol. */ #$d_vprintf HAS_VPRINTF /**/ #$d_charvspr USE_CHAR_VSPRINTF /**/ /* HAS_WAIT4: * This symbol, if defined, indicates that wait4() exists. */ #$d_wait4 HAS_WAIT4 /**/ /* HAS_WAITPID: * This symbol, if defined, indicates that the waitpid routine is * available to wait for child process. */ #$d_waitpid HAS_WAITPID /**/ /* HAS_WCSTOMBS: * This symbol, if defined, indicates that the wcstombs routine is * available to convert wide character strings to multibyte strings. */ #$d_wcstombs HAS_WCSTOMBS /**/ /* HAS_WCTOMB: * This symbol, if defined, indicates that the wctomb routine is available * to covert a wide character to a multibyte. */ #$d_wctomb HAS_WCTOMB /**/ /* Fpos_t: * This symbol holds the type used to declare file positions in libc. * It can be fpos_t, long, uint, etc... It may be necessary to include * to get any typedef'ed information. */ #define Fpos_t $fpostype /* File position type */ /* Gid_t: * This symbol holds the return type of getgid() and the type of * argument to setrgid() and related functions. Typically, * it is the type of group ids in the kernel. It can be int, ushort, * uid_t, etc... It may be necessary to include to get * any typedef'ed information. */ #define Gid_t $gidtype /* Type for getgid(), etc... */ /* I_DIRENT: * This symbol, if defined, indicates to the C program that it should * include . Using this symbol also triggers the definition * of the Direntry_t define which ends up being 'struct dirent' or * 'struct direct' depending on the availability of . */ /* DIRNAMLEN: * This symbol, if defined, indicates to the C program that the length * of directory entry names is provided by a d_namlen field. Otherwise * you need to do strlen() on the d_name field. */ /* Direntry_t: * This symbol is set to 'struct direct' or 'struct dirent' depending on * whether dirent is available or not. You should use this pseudo type to * portably declare your directory entries. */ #$i_dirent I_DIRENT /**/ #$d_dirnamlen DIRNAMLEN /**/ #define Direntry_t $direntrytype /* I_DLFCN: * This symbol, if defined, indicates that exists and should * be included. */ #$i_dlfcn I_DLFCN /**/ /* I_FCNTL: * This manifest constant tells the C program to include . */ #$i_fcntl I_FCNTL /**/ /* I_FLOAT: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like DBL_MAX or * DBL_MIN, i.e. machine dependent floating point values. */ #$i_float I_FLOAT /**/ /* I_GRP: * This symbol, if defined, indicates to the C program that it should * include . */ #$i_grp I_GRP /**/ /* I_LIMITS: * This symbol, if defined, indicates to the C program that it should * include to get definition of symbols like WORD_BIT or * LONG_MAX, i.e. machine dependant limitations. */ #$i_limits I_LIMITS /**/ /* I_MATH: * This symbol, if defined, indicates to the C program that it should * include . */ #$i_math I_MATH /**/ /* I_MEMORY: * This symbol, if defined, indicates to the C program that it should * include . */ #$i_memory I_MEMORY /**/ /* I_NDBM: * This symbol, if defined, indicates that ndbm.h exists and should * be included. */ #$i_ndbm I_NDBM /**/ /* I_NETINET_IN: * This symbol, if defined, indicates to the C program that it should * include . Otherwise, you may try . */ #$i_niin I_NETINET_IN /**/ /* I_PWD: * This symbol, if defined, indicates to the C program that it should * include . */ /* PWQUOTA: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_quota. */ /* PWAGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_age. */ /* PWCHANGE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_change. */ /* PWCLASS: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_class. */ /* PWEXPIRE: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_expire. */ /* PWCOMMENT: * This symbol, if defined, indicates to the C program that struct passwd * contains pw_comment. */ #$i_pwd I_PWD /**/ #$d_pwquota PWQUOTA /**/ #$d_pwage PWAGE /**/ #$d_pwchange PWCHANGE /**/ #$d_pwclass PWCLASS /**/ #$d_pwexpire PWEXPIRE /**/ #$d_pwcomment PWCOMMENT /**/ /* I_STDDEF: * This symbol, if defined, indicates that exists and should * be included. */ #$i_stddef I_STDDEF /**/ /* I_STDLIB: * This symbol, if defined, indicates that exists and should * be included. */ #$i_stdlib I_STDLIB /**/ /* I_STRING: * This symbol, if defined, indicates to the C program that it should * include (USG systems) instead of (BSD systems). */ #$i_string I_STRING /**/ /* I_SYS_DIR: * This symbol, if defined, indicates to the C program that it should * include . */ #$i_sysdir I_SYS_DIR /**/ /* I_SYS_FILE: * This symbol, if defined, indicates to the C program that it should * include to get definition of R_OK and friends. */ #$i_sysfile I_SYS_FILE /**/ /* I_SYS_IOCTL: * This symbol, if defined, indicates that exists and should * be included. Otherwise, include or . */ #$i_sysioctl I_SYS_IOCTL /**/ /* I_SYS_NDIR: * This symbol, if defined, indicates to the C program that it should * include . */ #$i_sysndir I_SYS_NDIR /**/ /* I_SYS_PARAM: * This symbol, if defined, indicates to the C program that it should * include . */ #$i_sysparam I_SYS_PARAM /**/ /* I_SYS_SELECT: * This symbol, if defined, indicates to the C program that it should * include in order to get definition of struct timeval. */ #$i_sysselct I_SYS_SELECT /**/ /* I_SYS_TIMES: * This symbol, if defined, indicates to the C program that it should * include . */ #$i_systimes I_SYS_TIMES /**/ /* I_TERMIO: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ /* I_TERMIOS: * This symbol, if defined, indicates that the program should include * the POSIX termios.h rather than sgtty.h or termio.h. * There are also differences in the ioctl() calls that depend on the * value of this symbol. */ /* I_SGTTY: * This symbol, if defined, indicates that the program should include * rather than . There are also differences in * the ioctl() calls that depend on the value of this symbol. */ #$i_termio I_TERMIO /**/ #$i_termios I_TERMIOS /**/ #$i_sgtty I_SGTTY /**/ /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME: * This symbol, if defined, indicates to the C program that it should * include . */ /* I_SYS_TIME_KERNEL: * This symbol, if defined, indicates to the C program that it should * include with KERNEL defined. */ #$i_time I_TIME /**/ #$i_systime I_SYS_TIME /**/ #$i_systimek I_SYS_TIME_KERNEL /**/ /* I_UNISTD: * This symbol, if defined, indicates to the C program that it should * include . */ #$i_unistd I_UNISTD /**/ /* I_UTIME: * This symbol, if defined, indicates to the C program that it should * include . */ #$i_utime I_UTIME /**/ /* I_STDARG: * This symbol, if defined, indicates that exists and should * be included. */ /* I_VARARGS: * This symbol, if defined, indicates to the C program that it should * include . */ #$i_stdarg I_STDARG /**/ #$i_varargs I_VARARGS /**/ /* I_VFORK: * This symbol, if defined, indicates to the C program that it should * include vfork.h. */ #$i_vfork I_VFORK /**/ /* INTSIZE: * This symbol contains the size of an int, so that the C preprocessor * can make decisions based on it. */ #define INTSIZE $intsize /**/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. * It can be int, long, off_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Off_t $lseektype /* type */ /* PRIVLIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. */ #define PRIVLIB "$privlib" /**/ /* CAN_PROTOTYPE: * If defined, this macro indicates that the C compiler can handle * function prototypes. */ /* _: * This macro is used to declare function parameters for folks who want * to make declarations with prototypes using a different style than * the above macros. Use double parentheses. For example: * * int main _((int argc, char *argv[])); */ #$prototype CAN_PROTOTYPE /**/ #ifdef CAN_PROTOTYPE #define _(args) args #else #define _(args) () #endif /* RANDBITS: * This symbol contains the number of bits of random number the rand() * function produces. Usual values are 15, 16, and 31. */ #define RANDBITS $randbits /**/ /* SCRIPTDIR: * This symbol holds the name of the directory in which the user wants * to put publicly executable scripts for the package in question. It * is often a directory that is mounted across diverse architectures. * Programs must be prepared to deal with ~name expansion. */ #define SCRIPTDIR "$scriptdir" /**/ /* Select_fd_set_t: * This symbol holds the type used for the 2nd, 3rd, and 4th * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET * is defined, and 'int *' otherwise. This is only useful if you * have select(), of course. */ #define Select_fd_set_t $selecttype /**/ /* SIG_NAME: * This symbol contains a list of signal names in order. This is intended * to be used as a static array initialization, like this: * char *sig_name[] = { SIG_NAME }; * The signals in the list are separated with commas, and each signal * is surrounded by double quotes. There is no leading SIG in the signal * name, i.e. SIGQUIT is known as "QUIT". */ #define SIG_NAME "`echo $sig_name | sed 's/ /","/g'`" /**/ /* Size_t: * This symbol holds the type used to declare length parameters * for string functions. It is usually size_t, but may be * unsigned long, int, etc. It may be necessary to include * to get any typedef'ed information. */ #define Size_t $sizetype /* length paramater for string functions */ /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". */ #define STDCHAR $stdchar /**/ /* Uid_t: * This symbol holds the type used to declare user ids in the kernel. * It can be int, ushort, uid_t, etc... It may be necessary to include * to get any typedef'ed information. */ #define Uid_t $uidtype /* UID type */ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this * compiler. What various bits mean: * * 1 = supports declaration of void * 2 = supports arrays of pointers to functions returning void * 4 = supports comparisons between pointers to void functions and * addresses of void functions * 8 = suports declaration of generic void pointers * * The package designer should define VOIDUSED to indicate the requirements * of the package. This can be done either by #defining VOIDUSED before * including config.h, or by defining defvoidused in Myinit.U. If the * latter approach is taken, only those flags will be tested. If the * level of void support necessary is not present, defines void to int. */ #ifndef VOIDUSED #define VOIDUSED $defvoidused #endif #define VOIDFLAGS $voidflags #if (VOIDFLAGS & VOIDUSED) != VOIDUSED #define void int /* is void to be avoided? */ #define M_VOID /* Xenix strikes again */ #endif /* EUNICE: * This symbol, if defined, indicates that the program is being compiled * under the EUNICE package under VMS. The program will need to handle * things like files that don't go away the first time you unlink them, * due to version numbering. It will also need to compensate for lack * of a respectable link() command. */ /* VMS: * This symbol, if defined, indicates that the program is running under * VMS. It is currently only set in conjunction with the EUNICE symbol. */ #$d_eunice EUNICE /**/ #$d_eunice VMS /**/ /* LOC_SED: * This symbol holds the complete pathname to the sed program. */ #define LOC_SED "$sed" /**/ /* ARCHLIB: * This variable, if defined, holds the name of the directory in * which the user wants to put architecture-dependent public * library files for $package. It is most often a local directory * such as /usr/local/lib. Programs using this variable must be * prepared to deal with filename expansion. If ARCHLIB is the * same as PRIVLIB, it is not defined, since presumably the * program already searches PRIVLIB. */ #$d_archlib ARCHLIB "$archlib" /**/ /* CAT2: * This macro catenates 2 tokens together. */ /* STRINGIFY: * This macro surrounds its token with double quotes. */ #if $cpp_stuff == 1 #define CAT2(a,b)a/**/b #define CAT3(a,b,c)a/**/b/**/c #define CAT4(a,b,c,d)a/**/b/**/c/**/d #define CAT5(a,b,c,d,e)a/**/b/**/c/**/d/**/e #define STRINGIFY(a)"a" /* If you can get stringification with catify, tell me how! */ #endif #if $cpp_stuff == 42 #define CAT2(a,b)a ## b #define CAT3(a,b,c)a ## b ## c #define CAT4(a,b,c,d)a ## b ## c ## d #define CAT5(a,b,c,d,e)a ## b ## c ## d ## e #define StGiFy(a)# a #define STRINGIFY(a)StGiFy(a) #define SCAT2(a,b)StGiFy(a) StGiFy(b) #define SCAT3(a,b,c)StGiFy(a) StGiFy(b) StGiFy(c) #define SCAT4(a,b,c,d)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) #define SCAT5(a,b,c,d,e)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) StGiFy(e) #endif #ifndef CAT2 #include "Bletch: How does this C preprocessor catenate tokens?" #endif /* GNUC_ATTRIBUTE_CHECK: * This symbol indicates the C compiler can check for function attributes, * such as printf formats. */ #$d_attrib GNUC_ATTRIBUTE_CHECK /* */ /* VOID_CLOSEDIR: * This symbol, if defined, indicates that the closedir() routine * does not return a value. */ #$d_void_closedir VOID_CLOSEDIR /**/ /* HAS_DLERROR: * This symbol, if defined, indicates that the dlerror routine is * available. */ #$d_dlerror HAS_DLERROR /**/ /* DLSYM_NEEDS_UNDERSCORE: * This symbol, if defined, indicates that we need to prepend an * underscore to the symbol name before calling dlsym(). This only * makes sense if you *have* dlsym, which we will presume is the * case if you're using dl_dlopen.xs. */ #$d_dlsymun DLSYM_NEEDS_UNDERSCORE /* */ /* SETUID_SCRIPTS_ARE_SECURE_NOW: * This symbol, if defined, indicates that the bug that prevents * setuid scripts from being secure is not present in this kernel. */ /* DOSUID: * This symbol, if defined, indicates that the C program should * check the script that it is executing for setuid/setgid bits, and * attempt to emulate setuid/setgid on systems that have disabled * setuid #! scripts because the kernel can't do it securely. * It is up to the package designer to make sure that this emulation * is done securely. Among other things, it should do an fstat on * the script it just opened to make sure it really is a setuid/setgid * script, it should make sure the arguments passed correspond exactly * to the argument on the #! line, and it should not trust any * subprocesses to which it must pass the filename rather than the * file descriptor of the script to be executed. */ #$d_suidsafe SETUID_SCRIPTS_ARE_SECURE_NOW /**/ #$d_dosuid DOSUID /**/ /* HAS_DREM: * This symbol, if defined, indicates that the drem routine is * available. This is a Pyramid routine that is the same as * fmod. */ #$d_drem HAS_DREM /**/ /* HAS_FMOD: * This symbol, if defined, indicates that the fmod routine is * available. */ #$d_fmod HAS_FMOD /**/ /* Gconvert: * This preprocessor macro is defined to convert a floating point * number to a string without a trailing decimal point. This * emulates the behavior of sprintf("%g"), but is sometimes much more * efficient. If gconvert() is not available, but gcvt() drops the * trailing decimal point, then gcvt() is used. If all else fails, * a macro using sprintf("%g") is used. */ #define Gconvert(x,n,t,b) $d_Gconvert /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. */ #$d_isascii HAS_ISASCII /**/ /* USE_LINUX_STDIO: * This symbol is defined if this system has a FILE structure declaring * _IO_read_base, _IO_read_ptr, and _IO_read_end in stdio.h. */ #$d_linuxstd USE_LINUX_STDIO /**/ /* HAS_LOCALECONV: * This symbol, if defined, indicates that the localeconv routine is * available for numeric and monetary formatting conventions. */ #$d_locconv HAS_LOCALECONV /**/ /* HAS_MKFIFO: * This symbol, if defined, indicates that the mkfifo routine is * available. */ #$d_mkfifo HAS_MKFIFO /**/ /* HAS_PATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given filename. */ /* HAS_FPATHCONF: * This symbol, if defined, indicates that pathconf() is available * to determine file-system related limits and options associated * with a given open file descriptor. */ #$d_pathconf HAS_PATHCONF /**/ #$d_fpathconf HAS_FPATHCONF /**/ /* HAS_SAFE_BCOPY: * This symbol, if defined, indicates that the bcopy routine is available * to copy potentially overlapping memory blocks. Otherwise you should * probably use memmove() or memcpy(). If neither is defined, roll your * own version. */ #$d_safebcpy HAS_SAFE_BCOPY /**/ /* HAS_SAFE_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy potentially overlapping memory blocks. Otherwise you should * probably use memmove() or memcpy(). If neither is defined, roll your * own version. */ #$d_safemcpy HAS_SAFE_MEMCPY /**/ /* HAS_SETPGRP: * This symbol, if defined, indicates that the setpgrp routine is * available to set the current process group. */ /* USE_BSDPGRP: * This symbol, if defined, indicates that the BSD notion of process * group is to be used. For instance, you have to say setpgrp(pid, pgrp) * instead of the USG setpgrp(). */ #$d_setpgrp HAS_SETPGRP /**/ #$d_bsdpgrp USE_BSDPGRP /**/ /* HAS_SYSCONF: * This symbol, if defined, indicates that sysconf() is available * to determine system related limits and options. */ #$d_sysconf HAS_SYSCONF /**/ /* Time_t: * This symbol holds the type returned by time(). It can be long, * or time_t on BSD sites (in which case should be * included). */ #define Time_t $timetype /* Time type */ /* USE_DYNAMIC_LOADING: * This symbol, if defined, indicates that dynamic loading of * some sort is available. */ #$usedl USE_DYNAMIC_LOADING /**/ /* Groups_t: * This symbol holds the type used for the second argument to * getgroups(). Usually, this is the same of gidtype, but * sometimes it isn't. It can be int, ushort, uid_t, etc... * It may be necessary to include to get any * typedef'ed information. This is only required if you have * getgroups(). */ #ifdef HAS_GETGROUPS #define Groups_t $groupstype /* Type for 2nd arg to getgroups() */ #endif /* I_NET_ERRNO: * This symbol, if defined, indicates that exists and * should be included. */ #$i_neterrno I_NET_ERRNO /**/ /* Malloc_t: * This symbol is the type of pointer returned by malloc and realloc. */ #define Malloc_t $malloctype /**/ /* MYMALLOC: * This symbol, if defined, indicates that we're using our own malloc. */ #$d_mymalloc MYMALLOC /**/ /* Mode_t: * This symbol holds the type used to declare file modes * for systems calls. It is usually mode_t, but may be * int or unsigned short. It may be necessary to include * to get any typedef'ed information. */ #define Mode_t $modetype /* file mode parameter for system calls*/ /* SSize_t: * This symbol holds the type used by functions that return * a count of bytes or an error condition. It must be a signed type. * It is usually ssize_t, but may be long or int, etc. * It may be necessary to include or * to get any typedef'ed information. * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). */ #define SSize_t $ssizetype /* signed count of bytes */ #endif !GROK!THIS! njunction with the EUNICE symbol. */ #$d_eunice EUNICE /**/ #$d_eunice VMS /**/ /* LOC_SED: * This symbol holds the complete pathname to the sed program. */ #define LOC_SED "$sed" /**/ /* perl5.000/configpm 775 203 12 5322 5645376140 7170 #!./miniperl -w @ARGV = "./config.sh"; $config_pm = 'lib/Config.pm'; # list names to put first (and hence lookup fastest) @fast = qw(osname osvers so libpth archlib sharpbang startsh shsharp dynamic_ext static_ext extensions dl_src sig_name ccflags cppflags intsize); open CONFIG, ">$config_pm" or die "Can't open $config_pm: $!\n"; $myver = sprintf("%.3f", $]); print CONFIG <<"ENDOFBEG"; package Config; require Exporter; \@ISA = (Exporter); \@EXPORT = qw(%Config); \$] == $myver or die sprintf "Perl lib version ($myver) doesn't match executable version (%.3f)\\n", \$]; # This file was created by configpm when Perl was built. Any changes # made to this file will be lost the next time perl is built. ENDOFBEG @fast{@fast} = @fast; @non_v=(); @v_fast=(); @v_others=(); while (<>) { next if m:^#!/bin/sh:; # Catch CONFIG=true and PATCHLEVEL=n line from Configure. s/^(\w+)=(true|\d+)\s*$/$1='$2'\n/; unless (m/^(\w+)='(.*)'\s*$/){ push(@non_v, "#$_"); # not a name='value' line next; } if (!$fast{$1}){ push(@v_others, $_); next; } push(@v_fast,$_); } foreach(@non_v){ print CONFIG $_ } print CONFIG "\n", "\$config_sh=<<'!END!OF!CONFIG!';\n", join("", @v_fast, sort @v_others), "!END!OF!CONFIG!\n\n"; print CONFIG <<'ENDOFEND'; tie %Config, Config; sub TIEHASH { bless {} } sub FETCH { # check for cached value (which maybe undef so we use exists not defined) return $_[0]->{$_[1]} if (exists $_[0]->{$_[1]}); my($value); # search for the item in the big $config_sh string return undef unless (($value) = $config_sh =~ m/^$_[1]='(.*)'\s*$/m); $value = undef if $value eq 'undef'; # So we can say "if $Config{'foo'}". $_[0]->{$_[1]} = $value; # cache it return $value; } sub FIRSTKEY { $prevpos = 0; my $key; ($key) = $config_sh =~ m/^(.*)=/; $key; } sub NEXTKEY { my ($pos, $len); $pos = $prevpos; $pos = index( $config_sh, "\n", $pos) + 1; $prevpos = $pos; $len = index( $config_sh, "=", $pos) - $pos; $len > 0 ? substr( $config_sh, $pos, $len) : undef; } sub EXISTS{ exists($_[0]->{$_[1]}) or $config_sh =~ m/^$_[1]=/m; } sub readonly { die "\%Config::Config is read-only\n" } sub STORE { &readonly } sub DELETE{ &readonly } sub CLEAR { &readonly } 1; ENDOFEND close(CONFIG); # Now do some simple tests on the Config.pm file we have created unshift(@INC,'lib'); require $config_pm; import Config; die "$0: $config_pm not valid" unless $Config{'CONFIG'} eq 'true'; die "$0: error processing $config_pm" if defined($Config{'an impossible name'}) or $Config{'CONFIG'} ne 'true' # test cache ; die "$0: error processing $config_pm" if eval '$Config{"cc"} = 1' or eval 'delete $Config{"cc"}' ; exit 0; m HAS_DREM /**/ /* HAS_FMOD: * This symbol, if defined, indicates that the fmod routine is * available. */ #$d_fmod HAS_FMOD /**/ /* Gconvert: * This preprocessor macro is defined to convert a floating point * number to a string without a trailing decimal point. This * emulates the behaviorperl5.000/cop.h 644 203 12 15051 5650573152 6406 /* cop.h * * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ struct cop { BASEOP char * cop_label; /* label for this construct */ HV * cop_stash; /* package line was compiled in */ GV * cop_filegv; /* file the following line # is from */ U32 cop_seq; /* parse sequence number */ I32 cop_arybase; /* array base this line was compiled with */ line_t cop_line; /* line # of this command */ }; #define Nullcop Null(COP*) /* * Here we have some enormously heavy (or at least ponderous) wizardry. */ /* subroutine context */ struct block_sub { CV * cv; GV * gv; GV * dfoutgv; AV * savearray; AV * argarray; U16 olddepth; U8 hasargs; }; #define PUSHSUB(cx) \ cx->blk_sub.cv = cv; \ cx->blk_sub.olddepth = CvDEPTH(cv); \ cx->blk_sub.hasargs = hasargs; #define PUSHFORMAT(cx) \ cx->blk_sub.cv = cv; \ cx->blk_sub.gv = gv; \ cx->blk_sub.dfoutgv = defoutgv; \ cx->blk_sub.hasargs = 0; #define POPSUB(cx) \ if (cx->blk_sub.hasargs) { /* put back old @_ */ \ GvAV(defgv) = cx->blk_sub.savearray; \ } \ if (cx->blk_sub.cv) { \ if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) { \ SvREFCNT_dec((SV*)cx->blk_sub.cv); \ } \ } #define POPFORMAT(cx) \ defoutgv = cx->blk_sub.dfoutgv; /* eval context */ struct block_eval { I32 old_in_eval; I32 old_op_type; char * old_name; OP * old_eval_root; }; #define PUSHEVAL(cx,n,fgv) \ cx->blk_eval.old_in_eval = in_eval; \ cx->blk_eval.old_op_type = op->op_type; \ cx->blk_eval.old_name = n; \ cx->blk_eval.old_eval_root = eval_root; #define POPEVAL(cx) \ in_eval = cx->blk_eval.old_in_eval; \ optype = cx->blk_eval.old_op_type; \ eval_root = cx->blk_eval.old_eval_root; /* loop context */ struct block_loop { char * label; I32 resetsp; OP * redo_op; OP * next_op; OP * last_op; SV ** itervar; SV * itersave; AV * iterary; I32 iterix; }; #define PUSHLOOP(cx, ivar, s) \ cx->blk_loop.label = curcop->cop_label; \ cx->blk_loop.resetsp = s - stack_base; \ cx->blk_loop.redo_op = cLOOP->op_redoop; \ cx->blk_loop.next_op = cLOOP->op_nextop; \ cx->blk_loop.last_op = cLOOP->op_lastop; \ cx->blk_loop.itervar = ivar; \ if (ivar) \ cx->blk_loop.itersave = *cx->blk_loop.itervar; #define POPLOOP(cx) \ newsp = stack_base + cx->blk_loop.resetsp; \ if (cx->blk_loop.itervar) \ *cx->blk_loop.itervar = cx->blk_loop.itersave; /* context common to subroutines, evals and loops */ struct block { I32 blku_oldsp; /* stack pointer to copy stuff down to */ COP * blku_oldcop; /* old curcop pointer */ I32 blku_oldretsp; /* return stack index */ I32 blku_oldmarksp; /* mark stack index */ I32 blku_oldscopesp; /* scope stack index */ PMOP * blku_oldpm; /* values of pattern match vars */ U8 blku_gimme; /* is this block running in list context? */ union { struct block_sub blku_sub; struct block_eval blku_eval; struct block_loop blku_loop; } blk_u; }; #define blk_oldsp cx_u.cx_blk.blku_oldsp #define blk_oldcop cx_u.cx_blk.blku_oldcop #define blk_oldretsp cx_u.cx_blk.blku_oldretsp #define blk_oldmarksp cx_u.cx_blk.blku_oldmarksp #define blk_oldscopesp cx_u.cx_blk.blku_oldscopesp #define blk_oldpm cx_u.cx_blk.blku_oldpm #define blk_gimme cx_u.cx_blk.blku_gimme #define blk_sub cx_u.cx_blk.blk_u.blku_sub #define blk_eval cx_u.cx_blk.blk_u.blku_eval #define blk_loop cx_u.cx_blk.blk_u.blku_loop /* Enter a block. */ #define PUSHBLOCK(cx,t,sp) CXINC, cx = &cxstack[cxstack_ix], \ cx->cx_type = t, \ cx->blk_oldsp = sp - stack_base, \ cx->blk_oldcop = curcop, \ cx->blk_oldmarksp = markstack_ptr - markstack, \ cx->blk_oldscopesp = scopestack_ix, \ cx->blk_oldretsp = retstack_ix, \ cx->blk_oldpm = curpm, \ cx->blk_gimme = gimme; \ DEBUG_l( fprintf(stderr,"Entering block %ld, type %s\n", \ (long)cxstack_ix, block_type[t]); ) /* Exit a block (RETURN and LAST). */ #define POPBLOCK(cx,pm) cx = &cxstack[cxstack_ix--], \ newsp = stack_base + cx->blk_oldsp, \ curcop = cx->blk_oldcop, \ markstack_ptr = markstack + cx->blk_oldmarksp, \ scopestack_ix = cx->blk_oldscopesp, \ retstack_ix = cx->blk_oldretsp, \ pm = cx->blk_oldpm, \ gimme = cx->blk_gimme; \ DEBUG_l( fprintf(stderr,"Leaving block %ld, type %s\n", \ (long)cxstack_ix+1,block_type[cx->cx_type]); ) /* Continue a block elsewhere (NEXT and REDO). */ #define TOPBLOCK(cx) cx = &cxstack[cxstack_ix], \ stack_sp = stack_base + cx->blk_oldsp, \ markstack_ptr = markstack + cx->blk_oldmarksp, \ scopestack_ix = cx->blk_oldscopesp, \ retstack_ix = cx->blk_oldretsp /* substitution context */ struct subst { I32 sbu_iters; I32 sbu_maxiters; I32 sbu_safebase; I32 sbu_once; char * sbu_orig; SV * sbu_dstr; SV * sbu_targ; char * sbu_s; char * sbu_m; char * sbu_strend; char * sbu_subbase; }; #define sb_iters cx_u.cx_subst.sbu_iters #define sb_maxiters cx_u.cx_subst.sbu_maxiters #define sb_safebase cx_u.cx_subst.sbu_safebase #define sb_once cx_u.cx_subst.sbu_once #define sb_orig cx_u.cx_subst.sbu_orig #define sb_dstr cx_u.cx_subst.sbu_dstr #define sb_targ cx_u.cx_subst.sbu_targ #define sb_s cx_u.cx_subst.sbu_s #define sb_m cx_u.cx_subst.sbu_m #define sb_strend cx_u.cx_subst.sbu_strend #define sb_subbase cx_u.cx_subst.sbu_subbase #define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix], \ cx->sb_iters = iters, \ cx->sb_maxiters = maxiters, \ cx->sb_safebase = safebase, \ cx->sb_once = once, \ cx->sb_orig = orig, \ cx->sb_dstr = dstr, \ cx->sb_targ = targ, \ cx->sb_s = s, \ cx->sb_m = m, \ cx->sb_strend = strend, \ cx->cx_type = CXt_SUBST #define POPSUBST(cx) cxstack_ix-- struct context { I32 cx_type; /* what kind of context this is */ union { struct block cx_blk; struct subst cx_subst; } cx_u; }; #define CXt_NULL 0 #define CXt_SUB 1 #define CXt_EVAL 2 #define CXt_LOOP 3 #define CXt_SUBST 4 #define CXt_BLOCK 5 #define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc())) /* "gimme" values */ #define G_SCALAR 0 #define G_ARRAY 1 /* extra flags for perl_call_* routines */ #define G_DISCARD 2 /* Call FREETMPS. */ #define G_EVAL 4 /* Assume eval {} around subroutine call. */ #define G_NOARGS 8 /* Don't construct a @_ array. */ * next_op; OP * last_op; SV ** itervar; SV * itersave; AV * iterary; I32 iterix; }; #define PUSHLOOP(cx, ivar, s) \ cx->blk_loop.label = curcop->cop_label; \ cx->blk_loop.resetsp = s - stack_base; \ cx->blk_loop.redo_op = cLOOP->op_redoop; \ cx->blk_loop.next_op = cLOOP->op_nextop; \ cx->blk_loop.last_op = cLOOP->op_lastop; \ cx->blk_loop.itervar = ivar; \ if (ivar) \ cx->blk_loop.itersave = *cx->blk_loop.iperl5.000/cv.h 664 203 12 2515 5650572634 6224 /* cv.h * * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ struct xpvcv { char * xpv_pv; /* pointer to malloced string */ STRLEN xpv_cur; /* length of xp_pv as a C string */ STRLEN xpv_len; /* allocated size */ IV xof_off; /* integer value */ double xnv_nv; /* numeric value, if any */ MAGIC* xmg_magic; /* magic for scalar array */ HV* xmg_stash; /* class package */ HV * xcv_stash; OP * xcv_start; OP * xcv_root; void (*xcv_xsub) _((CV*)); ANY xcv_xsubany; GV * xcv_gv; GV * xcv_filegv; long xcv_depth; /* >= 2 indicates recursive call */ AV * xcv_padlist; bool xcv_oldstyle; }; #define Nullcv Null(CV*) #define CvSTASH(sv) ((XPVCV*)SvANY(sv))->xcv_stash #define CvSTART(sv) ((XPVCV*)SvANY(sv))->xcv_start #define CvROOT(sv) ((XPVCV*)SvANY(sv))->xcv_root #define CvXSUB(sv) ((XPVCV*)SvANY(sv))->xcv_xsub #define CvXSUBANY(sv) ((XPVCV*)SvANY(sv))->xcv_xsubany #define CvGV(sv) ((XPVCV*)SvANY(sv))->xcv_gv #define CvFILEGV(sv) ((XPVCV*)SvANY(sv))->xcv_filegv #define CvDEPTH(sv) ((XPVCV*)SvANY(sv))->xcv_depth #define CvPADLIST(sv) ((XPVCV*)SvANY(sv))->xcv_padlist #define CvOLDSTYLE(sv) ((XPVCV*)SvANY(sv))->xcv_oldstyle (9Fregexp.h(89Grun.cgcH9Hscope.cX9Iscope.hh9Jsv.c.hx9Ksv.hcopˆ9Ytaint.c˜9Ztoke.c¬9[ perl5.000/deb.c 664 203 12 5427 5650573174 6346 /* deb.c * * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * "Didst thou think that the eyes of the White Tower were blind? Nay, I * have seen more than thou knowest, Gray Fool." --Denethor */ #include "EXTERN.h" #include "perl.h" #ifdef DEBUGGING #if !defined(I_STDARG) && !defined(I_VARARGS) /* * Fallback on the old hackers way of doing varargs */ /*VARARGS1*/ void deb(pat,a1,a2,a3,a4,a5,a6,a7,a8) char *pat; { register I32 i; GV* gv = curcop->cop_filegv; fprintf(stderr,"(%s:%ld)\t", SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "", (long)curcop->cop_line); for (i=0; icop_filegv; fprintf(stderr,"(%s:%ld)\t", SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "", (long)curcop->cop_line); for (i=0; i= i) break; fprintf(stderr, i ? " => ... " : " => "); if (stack_base[0] != &sv_undef || stack_sp < stack_base) fprintf(stderr, " [STACK UNDERFLOW!!!]\n"); do { ++i; if (markscan <= markstack_ptr && *markscan < i) { do { ++markscan; putc('*', stderr); } while (markscan <= markstack_ptr && *markscan < i); fprintf(stderr, " "); } if (i > top) break; fprintf(stderr, "%-4s ", SvPEEK(stack_base[i])); } while (1); fprintf(stderr, "\n"); return 0; } #else static int dummy; /* avoid totally empty deb.o file */ #endif /* DEBUGGING */ copy stuff down to */ COP * blku_oldcop; /* old curcop pointer */ I32 blku_oldretsp; /* return stack index */ I32 blku_oldmarksp; /* mark stack index */ I32 blku_oldscopesp; /* scope stack index */ PMOP * blkuperl5.000/doSH 755 203 12 537 5557314625 6206 : doSH is obsolete. Just use Configure -S : if test -f Configure ; then TOP=.; elif test -f ../Configure ; then TOP=..; elif test -f ../../Configure ; then TOP=../..; elif test -f ../../../Configure ; then TOP=../../..; elif test -f ../../../../Configure ; then TOP=../../../..; else echo "Can't find Configure" ; exit 1 fi sh $TOP/Configure -S Óhandy.hŠhintsam$8Ôhv.cs i48Õhv.hONFH8Ö installperl\8× interp.sym:p8Øioctl.plntf„9 keywperl5.000/doio.c 644 203 12 72220 5650572635 6560 /* doio.c * * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * "Far below them they saw the white waters pour into a foaming bowl, and * then swirl darkly about a deep oval basin in the rocks, until they found * their way out again through a narrow gate, and flowed away, fuming and * chattering, into calmer and more level reaches." */ #include "EXTERN.h" #include "perl.h" #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) #include #ifdef HAS_MSG #include #endif #ifdef HAS_SEM #include #endif #ifdef HAS_SHM #include # ifndef HAS_SHMAT_PROTOTYPE extern Shmat_t shmat _((int, char *, int)); # endif #endif #endif #ifdef I_UTIME #include #endif #ifdef I_FCNTL #include #endif #ifdef I_SYS_FILE #include #endif /* Omit -- it causes too much grief on mixed systems. #ifdef I_UNISTD #include #endif */ bool do_open(gv,name,len,supplied_fp) GV *gv; register char *name; I32 len; FILE *supplied_fp; { FILE *fp; register IO *io = GvIOn(gv); char *myname = savepv(name); int result; int fd; int writing = 0; int dodup; char mode[3]; /* stdio file mode ("r\0" or "r+\0") */ FILE *saveifp = Nullfp; FILE *saveofp = Nullfp; char savetype = ' '; SAVEFREEPV(myname); mode[0] = mode[1] = mode[2] = '\0'; name = myname; forkprocess = 1; /* assume true if no fork */ while (len && isSPACE(name[len-1])) name[--len] = '\0'; if (IoIFP(io)) { fd = fileno(IoIFP(io)); if (IoTYPE(io) == '-') result = 0; else if (fd <= maxsysfd) { saveifp = IoIFP(io); saveofp = IoOFP(io); savetype = IoTYPE(io); result = 0; } else if (IoTYPE(io) == '|') result = my_pclose(IoIFP(io)); else if (IoIFP(io) != IoOFP(io)) { if (IoOFP(io)) { result = fclose(IoOFP(io)); fclose(IoIFP(io)); /* clear stdio, fd already closed */ } else result = fclose(IoIFP(io)); } else result = fclose(IoIFP(io)); if (result == EOF && fd > maxsysfd) fprintf(stderr,"Warning: unable to close filehandle %s properly.\n", GvENAME(gv)); IoOFP(io) = IoIFP(io) = Nullfp; } if (*name == '+' && len > 1 && name[len-1] != '|') { /* scary */ mode[1] = *name++; mode[2] = '\0'; --len; writing = 1; } else { mode[1] = '\0'; } IoTYPE(io) = *name; if (*name == '|') { /*SUPPRESS 530*/ for (name++; isSPACE(*name); name++) ; if (strNE(name,"-")) TAINT_ENV(); TAINT_PROPER("piped open"); if (dowarn && name[strlen(name)-1] == '|') warn("Can't do bidirectional pipe"); fp = my_popen(name,"w"); writing = 1; } else if (*name == '>') { TAINT_PROPER("open"); name++; if (*name == '>') { mode[0] = IoTYPE(io) = 'a'; name++; } else mode[0] = 'w'; writing = 1; if (*name == '&') { duplicity: dodup = 1; name++; if (*name == '=') { dodup = 0; name++; } if (!*name && supplied_fp) fp = supplied_fp; else { while (isSPACE(*name)) name++; if (isDIGIT(*name)) fd = atoi(name); else { IO* thatio; gv = gv_fetchpv(name,FALSE,SVt_PVIO); thatio = GvIO(gv); if (!thatio) { #ifdef EINVAL errno = EINVAL; #endif goto say_false; } if (IoIFP(thatio)) { fd = fileno(IoIFP(thatio)); if (IoTYPE(thatio) == 's') IoTYPE(io) = 's'; } else fd = -1; } if (dodup) fd = dup(fd); if (!(fp = fdopen(fd,mode))) close(fd); } } else { while (isSPACE(*name)) name++; if (strEQ(name,"-")) { fp = stdout; IoTYPE(io) = '-'; } else { fp = fopen(name,mode); } } } else { if (*name == '<') { mode[0] = 'r'; name++; while (isSPACE(*name)) name++; if (*name == '&') goto duplicity; if (strEQ(name,"-")) { fp = stdin; IoTYPE(io) = '-'; } else fp = fopen(name,mode); } else if (name[len-1] == '|') { name[--len] = '\0'; while (len && isSPACE(name[len-1])) name[--len] = '\0'; /*SUPPRESS 530*/ for (; isSPACE(*name); name++) ; if (strNE(name,"-")) TAINT_ENV(); TAINT_PROPER("piped open"); fp = my_popen(name,"r"); IoTYPE(io) = '|'; } else { IoTYPE(io) = '<'; /*SUPPRESS 530*/ for (; isSPACE(*name); name++) ; if (strEQ(name,"-")) { fp = stdin; IoTYPE(io) = '-'; } else fp = fopen(name,"r"); } } if (!fp) { if (dowarn && IoTYPE(io) == '<' && strchr(name, '\n')) warn(warn_nl, "open"); goto say_false; } if (IoTYPE(io) && IoTYPE(io) != '|' && IoTYPE(io) != '-') { if (Fstat(fileno(fp),&statbuf) < 0) { (void)fclose(fp); goto say_false; } if (S_ISSOCK(statbuf.st_mode)) IoTYPE(io) = 's'; /* in case a socket was passed in to us */ #ifdef HAS_SOCKET else if ( #ifdef S_IFMT !(statbuf.st_mode & S_IFMT) #else !statbuf.st_mode #endif ) { int buflen = sizeof tokenbuf; if (getsockname(fileno(fp), (struct sockaddr *)tokenbuf, &buflen) >= 0 || errno != ENOTSOCK) IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */ /* but some return 0 for streams too, sigh */ } #endif } if (saveifp) { /* must use old fp? */ fd = fileno(saveifp); if (saveofp) { fflush(saveofp); /* emulate fclose() */ if (saveofp != saveifp) { /* was a socket? */ fclose(saveofp); if (fd > 2) Safefree(saveofp); } } if (fd != fileno(fp)) { int pid; SV *sv; dup2(fileno(fp), fd); sv = *av_fetch(fdpid,fileno(fp),TRUE); (void)SvUPGRADE(sv, SVt_IV); pid = SvIVX(sv); SvIVX(sv) = 0; sv = *av_fetch(fdpid,fd,TRUE); (void)SvUPGRADE(sv, SVt_IV); SvIVX(sv) = pid; fclose(fp); } fp = saveifp; clearerr(fp); } #if defined(HAS_FCNTL) && defined(F_SETFD) fd = fileno(fp); fcntl(fd,F_SETFD,fd > maxsysfd); #endif IoIFP(io) = fp; if (writing) { if (IoTYPE(io) == 's' || (IoTYPE(io) == '>' && S_ISCHR(statbuf.st_mode)) ) { if (!(IoOFP(io) = fdopen(fileno(fp),"w"))) { fclose(fp); IoIFP(io) = Nullfp; goto say_false; } } else IoOFP(io) = fp; } return TRUE; say_false: IoIFP(io) = saveifp; IoOFP(io) = saveofp; IoTYPE(io) = savetype; return FALSE; } FILE * nextargv(gv) register GV *gv; { register SV *sv; #ifndef FLEXFILENAMES int filedev; int fileino; #endif int fileuid; int filegid; if (!argvoutgv) argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO); if (filemode & (S_ISUID|S_ISGID)) { fflush(IoIFP(GvIOn(argvoutgv))); /* chmod must follow last write */ #ifdef HAS_FCHMOD (void)fchmod(lastfd,filemode); #else (void)chmod(oldname,filemode); #endif } filemode = 0; while (av_len(GvAV(gv)) >= 0) { STRLEN len; sv = av_shift(GvAV(gv)); SAVEFREESV(sv); sv_setsv(GvSV(gv),sv); SvSETMAGIC(GvSV(gv)); oldname = SvPVx(GvSV(gv), len); if (do_open(gv,oldname,len,Nullfp)) { if (inplace) { TAINT_PROPER("inplace open"); if (strEQ(oldname,"-")) { defoutgv = gv_fetchpv("STDOUT",TRUE,SVt_PVIO); return IoIFP(GvIOp(gv)); } #ifndef FLEXFILENAMES filedev = statbuf.st_dev; fileino = statbuf.st_ino; #endif filemode = statbuf.st_mode; fileuid = statbuf.st_uid; filegid = statbuf.st_gid; if (!S_ISREG(filemode)) { warn("Can't do inplace edit: %s is not a regular file", oldname ); do_close(gv,FALSE); continue; } if (*inplace) { #ifdef SUFFIX add_suffix(sv,inplace); #else sv_catpv(sv,inplace); #endif #ifndef FLEXFILENAMES if (Stat(SvPVX(sv),&statbuf) >= 0 && statbuf.st_dev == filedev && statbuf.st_ino == fileino ) { warn("Can't do inplace edit: %s > 14 characters", SvPVX(sv) ); do_close(gv,FALSE); continue; } #endif #ifdef HAS_RENAME #ifndef DOSISH if (rename(oldname,SvPVX(sv)) < 0) { warn("Can't rename %s to %s: %s, skipping file", oldname, SvPVX(sv), Strerror(errno) ); do_close(gv,FALSE); continue; } #else do_close(gv,FALSE); (void)unlink(SvPVX(sv)); (void)rename(oldname,SvPVX(sv)); do_open(gv,SvPVX(sv),SvCUR(GvSV(gv)),Nullfp); #endif /* MSDOS */ #else (void)UNLINK(SvPVX(sv)); if (link(oldname,SvPVX(sv)) < 0) { warn("Can't rename %s to %s: %s, skipping file", oldname, SvPVX(sv), Strerror(errno) ); do_close(gv,FALSE); continue; } (void)UNLINK(oldname); #endif } else { #ifndef DOSISH if (UNLINK(oldname) < 0) { warn("Can't rename %s to %s: %s, skipping file", oldname, SvPVX(sv), Strerror(errno) ); do_close(gv,FALSE); continue; } #else croak("Can't do inplace edit without backup"); #endif } sv_setpvn(sv,">",1); sv_catpv(sv,oldname); errno = 0; /* in case sprintf set errno */ if (!do_open(argvoutgv,SvPVX(sv),SvCUR(sv),Nullfp)) { warn("Can't do inplace edit on %s: %s", oldname, Strerror(errno) ); do_close(gv,FALSE); continue; } defoutgv = argvoutgv; lastfd = fileno(IoIFP(GvIOp(argvoutgv))); (void)Fstat(lastfd,&statbuf); #ifdef HAS_FCHMOD (void)fchmod(lastfd,filemode); #else (void)chmod(oldname,filemode); #endif if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) { #ifdef HAS_FCHOWN (void)fchown(lastfd,fileuid,filegid); #else #ifdef HAS_CHOWN (void)chown(oldname,fileuid,filegid); #endif #endif } } return IoIFP(GvIOp(gv)); } else fprintf(stderr,"Can't open %s: %s\n",SvPV(sv, na), Strerror(errno)); } if (inplace) { (void)do_close(argvoutgv,FALSE); defoutgv = gv_fetchpv("STDOUT",TRUE,SVt_PVIO); } return Nullfp; } #ifdef HAS_PIPE void do_pipe(sv, rgv, wgv) SV *sv; GV *rgv; GV *wgv; { register IO *rstio; register IO *wstio; int fd[2]; if (!rgv) goto badexit; if (!wgv) goto badexit; rstio = GvIOn(rgv); wstio = GvIOn(wgv); if (IoIFP(rstio)) do_close(rgv,FALSE); if (IoIFP(wstio)) do_close(wgv,FALSE); if (pipe(fd) < 0) goto badexit; IoIFP(rstio) = fdopen(fd[0], "r"); IoOFP(wstio) = fdopen(fd[1], "w"); IoIFP(wstio) = IoOFP(wstio); IoTYPE(rstio) = '<'; IoTYPE(wstio) = '>'; if (!IoIFP(rstio) || !IoOFP(wstio)) { if (IoIFP(rstio)) fclose(IoIFP(rstio)); else close(fd[0]); if (IoOFP(wstio)) fclose(IoOFP(wstio)); else close(fd[1]); goto badexit; } sv_setsv(sv,&sv_yes); return; badexit: sv_setsv(sv,&sv_undef); return; } #endif bool #ifndef CAN_PROTOTYPE do_close(gv,explicit) GV *gv; bool explicit; #else do_close(GV *gv, bool explicit) #endif /* CAN_PROTOTYPE */ { bool retval = FALSE; register IO *io; int status; if (!gv) gv = argvgv; if (!gv || SvTYPE(gv) != SVt_PVGV) { errno = EBADF; return FALSE; } io = GvIO(gv); if (!io) { /* never opened */ if (dowarn && explicit) warn("Close on unopened file <%s>",GvENAME(gv)); return FALSE; } if (IoIFP(io)) { if (IoTYPE(io) == '|') { status = my_pclose(IoIFP(io)); retval = (status == 0); statusvalue = (unsigned short)status & 0xffff; } else if (IoTYPE(io) == '-') retval = TRUE; else { if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */ retval = (fclose(IoOFP(io)) != EOF); fclose(IoIFP(io)); /* clear stdio, fd already closed */ } else retval = (fclose(IoIFP(io)) != EOF); } IoOFP(io) = IoIFP(io) = Nullfp; } if (explicit) { IoLINES(io) = 0; IoPAGE(io) = 0; IoLINES_LEFT(io) = IoPAGE_LEN(io); } IoTYPE(io) = ' '; return retval; } bool do_eof(gv) GV *gv; { register IO *io; int ch; io = GvIO(gv); if (!io) return TRUE; while (IoIFP(io)) { #ifdef USE_STD_STDIO /* (the code works without this) */ if (IoIFP(io)->_cnt > 0) /* cheat a little, since */ return FALSE; /* this is the most usual case */ #endif ch = getc(IoIFP(io)); if (ch != EOF) { (void)ungetc(ch, IoIFP(io)); return FALSE; } #ifdef USE_STD_STDIO if (IoIFP(io)->_cnt < -1) IoIFP(io)->_cnt = -1; #endif if (op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */ if (!nextargv(argvgv)) /* get another fp handy */ return TRUE; } else return TRUE; /* normal fp, definitely end of file */ } return TRUE; } long do_tell(gv) GV *gv; { register IO *io; if (!gv) goto phooey; io = GvIO(gv); if (!io || !IoIFP(io)) goto phooey; #ifdef ULTRIX_STDIO_BOTCH if (feof(IoIFP(io))) (void)fseek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */ #endif return ftell(IoIFP(io)); phooey: if (dowarn) warn("tell() on unopened file"); errno = EBADF; return -1L; } bool do_seek(gv, pos, whence) GV *gv; long pos; int whence; { register IO *io; if (!gv) goto nuts; io = GvIO(gv); if (!io || !IoIFP(io)) goto nuts; #ifdef ULTRIX_STDIO_BOTCH if (feof(IoIFP(io))) (void)fseek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */ #endif return fseek(IoIFP(io), pos, whence) >= 0; nuts: if (dowarn) warn("seek() on unopened file"); errno = EBADF; return FALSE; } #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) /* code courtesy of William Kucharski */ #define HAS_CHSIZE I32 chsize(fd, length) I32 fd; /* file descriptor */ Off_t length; /* length to set file to */ { extern long lseek(); struct flock fl; struct stat filebuf; if (Fstat(fd, &filebuf) < 0) return -1; if (filebuf.st_size < length) { /* extend file length */ if ((lseek(fd, (length - 1), 0)) < 0) return -1; /* write a "0" byte */ if ((write(fd, "", 1)) != 1) return -1; } else { /* truncate length */ fl.l_whence = 0; fl.l_len = 0; fl.l_start = length; fl.l_type = F_WRLCK; /* write lock on file space */ /* * This relies on the UNDOCUMENTED F_FREESP argument to * fcntl(2), which truncates the file so that it ends at the * position indicated by fl.l_start. * * Will minor miracles never cease? */ if (fcntl(fd, F_FREESP, &fl) < 0) return -1; } return 0; } #endif /* F_FREESP */ I32 looks_like_number(sv) SV *sv; { register char *s; register char *send; if (!SvPOK(sv)) { STRLEN len; if (!SvPOKp(sv)) return TRUE; s = SvPV(sv, len); send = s + len; } else { s = SvPVX(sv); send = s + SvCUR(sv); } while (isSPACE(*s)) s++; if (s >= send) return FALSE; if (*s == '+' || *s == '-') s++; while (isDIGIT(*s)) s++; if (s == send) return TRUE; if (*s == '.') s++; else if (s == SvPVX(sv)) return FALSE; while (isDIGIT(*s)) s++; if (s == send) return TRUE; if (*s == 'e' || *s == 'E') { s++; if (*s == '+' || *s == '-') s++; while (isDIGIT(*s)) s++; } while (isSPACE(*s)) s++; if (s >= send) return TRUE; return FALSE; } bool do_print(sv,fp) register SV *sv; FILE *fp; { register char *tmps; STRLEN len; /* assuming fp is checked earlier */ if (!sv) return TRUE; if (ofmt) { if (SvGMAGICAL(sv)) mg_get(sv); if (SvIOK(sv) && SvIVX(sv) != 0) { fprintf(fp, ofmt, (double)SvIVX(sv)); return !ferror(fp); } if ( (SvNOK(sv) && SvNVX(sv) != 0.0) || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) { fprintf(fp, ofmt, SvNVX(sv)); return !ferror(fp); } } switch (SvTYPE(sv)) { case SVt_NULL: if (dowarn) warn(warn_uninit); return TRUE; case SVt_IV: if (SvIOK(sv)) { if (SvGMAGICAL(sv)) mg_get(sv); fprintf(fp, "%ld", (long)SvIVX(sv)); return !ferror(fp); } /* FALL THROUGH */ default: tmps = SvPV(sv, len); break; } if (len && (fwrite1(tmps,1,len,fp) == 0 || ferror(fp))) return FALSE; return TRUE; } I32 my_stat(ARGS) dARGS { dSP; IO *io; if (op->op_flags & OPf_REF) { EXTEND(sp,1); io = GvIO(cGVOP->op_gv); if (io && IoIFP(io)) { statgv = cGVOP->op_gv; sv_setpv(statname,""); laststype = OP_STAT; return (laststatval = Fstat(fileno(IoIFP(io)), &statcache)); } else { if (cGVOP->op_gv == defgv) return laststatval; if (dowarn) warn("Stat on unopened file <%s>", GvENAME(cGVOP->op_gv)); statgv = Nullgv; sv_setpv(statname,""); return (laststatval = -1); } } else { dPOPss; PUTBACK; statgv = Nullgv; sv_setpv(statname,SvPV(sv, na)); laststype = OP_STAT; laststatval = Stat(SvPV(sv, na),&statcache); if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n')) warn(warn_nl, "stat"); return laststatval; } } I32 my_lstat(ARGS) dARGS { dSP; SV *sv; if (op->op_flags & OPf_REF) { EXTEND(sp,1); if (cGVOP->op_gv == defgv) { if (laststype != OP_LSTAT) croak("The stat preceding -l _ wasn't an lstat"); return laststatval; } croak("You can't use -l on a filehandle"); } laststype = OP_LSTAT; statgv = Nullgv; sv = POPs; PUTBACK; sv_setpv(statname,SvPV(sv, na)); #ifdef HAS_LSTAT laststatval = lstat(SvPV(sv, na),&statcache); #else laststatval = Stat(SvPV(sv, na),&statcache); #endif if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n')) warn(warn_nl, "lstat"); return laststatval; } bool do_aexec(really,mark,sp) SV *really; register SV **mark; register SV **sp; { register char **a; char *tmps; if (sp > mark) { New(401,Argv, sp - mark + 1, char*); a = Argv; while (++mark <= sp) { if (*mark) *a++ = SvPVx(*mark, na); else *a++ = ""; } *a = Nullch; if (*Argv[0] != '/') /* will execvp use PATH? */ TAINT_ENV(); /* testing IFS here is overkill, probably */ if (really && *(tmps = SvPV(really, na))) execvp(tmps,Argv); else execvp(Argv[0],Argv); if (dowarn) warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno)); } do_execfree(); return FALSE; } void do_execfree() { if (Argv) { Safefree(Argv); Argv = Null(char **); } if (Cmd) { Safefree(Cmd); Cmd = Nullch; } } bool do_exec(cmd) char *cmd; { register char **a; register char *s; char flags[10]; /* save an extra exec if possible */ #ifdef CSH if (strnEQ(cmd,cshname,cshlen) && strnEQ(cmd+cshlen," -c",3)) { strcpy(flags,"-c"); s = cmd+cshlen+3; if (*s == 'f') { s++; strcat(flags,"f"); } if (*s == ' ') s++; if (*s++ == '\'') { char *ncmd = s; while (*s) s++; if (s[-1] == '\n') *--s = '\0'; if (s[-1] == '\'') { *--s = '\0'; execl(cshname,"csh", flags,ncmd,(char*)0); *s = '\''; return FALSE; } } } #endif /* CSH */ /* see if there are shell metacharacters in it */ /*SUPPRESS 530*/ for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */ if (*s == '=') goto doshell; for (s = cmd; *s; s++) { if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { if (*s == '\n' && !s[1]) { *s = '\0'; break; } doshell: execl("/bin/sh","sh","-c",cmd,(char*)0); return FALSE; } } New(402,Argv, (s - cmd) / 2 + 2, char*); Cmd = savepvn(cmd, s-cmd); a = Argv; for (s = Cmd; *s;) { while (*s && isSPACE(*s)) s++; if (*s) *(a++) = s; while (*s && !isSPACE(*s)) s++; if (*s) *s++ = '\0'; } *a = Nullch; if (Argv[0]) { execvp(Argv[0],Argv); if (errno == ENOEXEC) { /* for system V NIH syndrome */ do_execfree(); goto doshell; } if (dowarn) warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno)); } do_execfree(); return FALSE; } I32 apply(type,mark,sp) I32 type; register SV **mark; register SV **sp; { register I32 val; register I32 val2; register I32 tot = 0; char *s; SV **oldmark = mark; if (tainting) { while (++mark <= sp) { if (SvMAGICAL(*mark) && mg_find(*mark, 't')) tainted = TRUE; } mark = oldmark; } switch (type) { case OP_CHMOD: TAINT_PROPER("chmod"); if (++mark <= sp) { tot = sp - mark; val = SvIVx(*mark); while (++mark <= sp) { if (chmod(SvPVx(*mark, na),val)) tot--; } } break; #ifdef HAS_CHOWN case OP_CHOWN: TAINT_PROPER("chown"); if (sp - mark > 2) { val = SvIVx(*++mark); val2 = SvIVx(*++mark); tot = sp - mark; while (++mark <= sp) { if (chown(SvPVx(*mark, na),val,val2)) tot--; } } break; #endif #ifdef HAS_KILL case OP_KILL: TAINT_PROPER("kill"); s = SvPVx(*++mark, na); tot = sp - mark; if (isUPPER(*s)) { if (*s == 'S' && s[1] == 'I' && s[2] == 'G') s += 3; if (!(val = whichsig(s))) croak("Unrecognized signal name \"%s\"",s); } else val = SvIVx(*mark); if (val < 0) { val = -val; while (++mark <= sp) { I32 proc = SvIVx(*mark); #ifdef HAS_KILLPG if (killpg(proc,val)) /* BSD */ #else if (kill(-proc,val)) /* SYSV */ #endif tot--; } } else { while (++mark <= sp) { if (kill(SvIVx(*mark),val)) tot--; } } break; #endif case OP_UNLINK: TAINT_PROPER("unlink"); tot = sp - mark; while (++mark <= sp) { s = SvPVx(*mark, na); if (euid || unsafe) { if (UNLINK(s)) tot--; } else { /* don't let root wipe out directories without -U */ #ifdef HAS_LSTAT if (lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode)) #else if (Stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode)) #endif tot--; else { if (UNLINK(s)) tot--; } } } break; #ifdef HAS_UTIME case OP_UTIME: TAINT_PROPER("utime"); if (sp - mark > 2) { #ifdef I_UTIME struct utimbuf utbuf; #else struct { long actime; long modtime; } utbuf; #endif Zero(&utbuf, sizeof utbuf, char); utbuf.actime = SvIVx(*++mark); /* time accessed */ utbuf.modtime = SvIVx(*++mark); /* time modified */ tot = sp - mark; while (++mark <= sp) { if (utime(SvPVx(*mark, na),&utbuf)) tot--; } } else tot = 0; break; #endif } return tot; } /* Do the permissions allow some operation? Assumes statcache already set. */ #ifndef VMS /* VMS' cando is in vms.c */ I32 cando(bit, effective, statbufp) I32 bit; I32 effective; register struct stat *statbufp; { #ifdef DOSISH /* [Comments and code from Len Reed] * MS-DOS "user" is similar to UNIX's "superuser," but can't write * to write-protected files. The execute permission bit is set * by the Miscrosoft C library stat() function for the following: * .exe files * .com files * .bat files * directories * All files and directories are readable. * Directories and special files, e.g. "CON", cannot be * write-protected. * [Comment by Tom Dinger -- a directory can have the write-protect * bit set in the file system, but DOS permits changes to * the directory anyway. In addition, all bets are off * here for networked software, such as Novell and * Sun's PC-NFS.] */ /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat * too so it will actually look into the files for magic numbers */ return (bit & statbufp->st_mode) ? TRUE : FALSE; #else /* ! MSDOS */ if ((effective ? euid : uid) == 0) { /* root is special */ if (bit == S_IXUSR) { if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode)) return TRUE; } else return TRUE; /* root reads and writes anything */ return FALSE; } if (statbufp->st_uid == (effective ? euid : uid) ) { if (statbufp->st_mode & bit) return TRUE; /* ok as "user" */ } else if (ingroup((I32)statbufp->st_gid,effective)) { if (statbufp->st_mode & bit >> 3) return TRUE; /* ok as "group" */ } else if (statbufp->st_mode & bit >> 6) return TRUE; /* ok as "other" */ return FALSE; #endif /* ! MSDOS */ } #endif /* ! VMS */ I32 ingroup(testgid,effective) I32 testgid; I32 effective; { if (testgid == (effective ? egid : gid)) return TRUE; #ifdef HAS_GETGROUPS #ifndef NGROUPS #define NGROUPS 32 #endif { Groups_t gary[NGROUPS]; I32 anum; anum = getgroups(NGROUPS,gary); while (--anum >= 0) if (gary[anum] == testgid) return TRUE; } #endif return FALSE; } #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) I32 do_ipcget(optype, mark, sp) I32 optype; SV **mark; SV **sp; { key_t key; I32 n, flags; key = (key_t)SvNVx(*++mark); n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark); flags = SvIVx(*++mark); errno = 0; switch (optype) { #ifdef HAS_MSG case OP_MSGGET: return msgget(key, flags); #endif #ifdef HAS_SEM case OP_SEMGET: return semget(key, n, flags); #endif #ifdef HAS_SHM case OP_SHMGET: return shmget(key, n, flags); #endif #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) default: croak("%s not implemented", op_name[optype]); #endif } return -1; /* should never happen */ } I32 do_ipcctl(optype, mark, sp) I32 optype; SV **mark; SV **sp; { SV *astr; char *a; I32 id, n, cmd, infosize, getinfo; I32 ret = -1; id = SvIVx(*++mark); n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0; cmd = SvIVx(*++mark); astr = *++mark; infosize = 0; getinfo = (cmd == IPC_STAT); switch (optype) { #ifdef HAS_MSG case OP_MSGCTL: if (cmd == IPC_STAT || cmd == IPC_SET) infosize = sizeof(struct msqid_ds); break; #endif #ifdef HAS_SHM case OP_SHMCTL: if (cmd == IPC_STAT || cmd == IPC_SET) infosize = sizeof(struct shmid_ds); break; #endif #ifdef HAS_SEM case OP_SEMCTL: if (cmd == IPC_STAT || cmd == IPC_SET) infosize = sizeof(struct semid_ds); else if (cmd == GETALL || cmd == SETALL) { struct semid_ds semds; if (semctl(id, 0, IPC_STAT, &semds) == -1) return -1; getinfo = (cmd == GETALL); infosize = semds.sem_nsems * sizeof(short); /* "short" is technically wrong but much more portable than guessing about u_?short(_t)? */ } break; #endif #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) default: croak("%s not implemented", op_name[optype]); #endif } if (infosize) { STRLEN len; if (getinfo) { SvPV_force(astr, len); a = SvGROW(astr, infosize+1); } else { a = SvPV(astr, len); if (len != infosize) croak("Bad arg length for %s, is %d, should be %d", op_name[optype], len, infosize); } } else { I32 i = SvIV(astr); a = (char *)i; /* ouch */ } errno = 0; switch (optype) { #ifdef HAS_MSG case OP_MSGCTL: ret = msgctl(id, cmd, (struct msqid_ds *)a); break; #endif #ifdef HAS_SEM case OP_SEMCTL: ret = semctl(id, n, cmd, (struct semid_ds *)a); break; #endif #ifdef HAS_SHM case OP_SHMCTL: ret = shmctl(id, cmd, (struct shmid_ds *)a); break; #endif } if (getinfo && ret >= 0) { SvCUR_set(astr, infosize); *SvEND(astr) = '\0'; SvSETMAGIC(astr); } return ret; } I32 do_msgsnd(mark, sp) SV **mark; SV **sp; { #ifdef HAS_MSG SV *mstr; char *mbuf; I32 id, msize, flags; STRLEN len; id = SvIVx(*++mark); mstr = *++mark; flags = SvIVx(*++mark); mbuf = SvPV(mstr, len); if ((msize = len - sizeof(long)) < 0) croak("Arg too short for msgsnd"); errno = 0; return msgsnd(id, (struct msgbuf *)mbuf, msize, flags); #else croak("msgsnd not implemented"); #endif } I32 do_msgrcv(mark, sp) SV **mark; SV **sp; { #ifdef HAS_MSG SV *mstr; char *mbuf; long mtype; I32 id, msize, flags, ret; STRLEN len; id = SvIVx(*++mark); mstr = *++mark; msize = SvIVx(*++mark); mtype = (long)SvIVx(*++mark); flags = SvIVx(*++mark); if (SvTHINKFIRST(mstr)) { if (SvREADONLY(mstr)) croak("Can't msgrcv to readonly var"); if (SvROK(mstr)) sv_unref(mstr); } SvPV_force(mstr, len); mbuf = SvGROW(mstr, sizeof(long)+msize+1); errno = 0; ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags); if (ret >= 0) { SvCUR_set(mstr, sizeof(long)+ret); *SvEND(mstr) = '\0'; } return ret; #else croak("msgrcv not implemented"); #endif } I32 do_semop(mark, sp) SV **mark; SV **sp; { #ifdef HAS_SEM SV *opstr; char *opbuf; I32 id; STRLEN opsize; id = SvIVx(*++mark); opstr = *++mark; opbuf = SvPV(opstr, opsize); if (opsize < sizeof(struct sembuf) || (opsize % sizeof(struct sembuf)) != 0) { errno = EINVAL; return -1; } errno = 0; return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf)); #else croak("semop not implemented"); #endif } I32 do_shmio(optype, mark, sp) I32 optype; SV **mark; SV **sp; { #ifdef HAS_SHM SV *mstr; char *mbuf, *shm; I32 id, mpos, msize; STRLEN len; struct shmid_ds shmds; id = SvIVx(*++mark); mstr = *++mark; mpos = SvIVx(*++mark); msize = SvIVx(*++mark); errno = 0; if (shmctl(id, IPC_STAT, &shmds) == -1) return -1; if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) { errno = EFAULT; /* can't do as caller requested */ return -1; } shm = (Shmat_t)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0); if (shm == (char *)-1) /* I hate System V IPC, I really do */ return -1; if (optype == OP_SHMREAD) { SvPV_force(mstr, len); mbuf = SvGROW(mstr, msize+1); Copy(shm + mpos, mbuf, msize, char); SvCUR_set(mstr, msize); *SvEND(mstr) = '\0'; SvSETMAGIC(mstr); } else { I32 n; mbuf = SvPV(mstr, len); if ((n = len) > msize) n = msize; Copy(mbuf, shm + mpos, n, char); if (n < msize) memzero(shm + mpos + n, msize - n); } return shmdt(shm); #else croak("shm I/O not implemented"); #endif } #endif /* SYSV IPC */ ark > 2) { #ifdef I_UTIME struct utimbuf utbuf; #else struct { long actime; long modtime; } utbuf; #endif Zero(&utbuf, sizeof utbuf, char); utbuf.actime = SvIVx(*++mark); /* time accessed */ utbuf.modtime = SvIVx(*++mark); /* time modified */ tot = sp - mark; while (++mark <= sp) { if (utime(SvPVx(*mark, na),&uperl5.000/doop.c 644 203 12 31336 5650573210 6560 /* doop.c * * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * "'So that was the job I felt I had to do when I started,' thought Sam." */ #include "EXTERN.h" #include "perl.h" #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) #include #endif #ifdef BUGGY_MSC #pragma function(memcmp) #endif /* BUGGY_MSC */ #ifdef BUGGY_MSC #pragma intrinsic(memcmp) #endif /* BUGGY_MSC */ I32 do_trans(sv,arg) SV *sv; OP *arg; { register short *tbl; register char *s; register I32 matches = 0; register I32 ch; register char *send; register char *d; register I32 squash = op->op_private & OPpTRANS_SQUASH; STRLEN len; if (SvREADONLY(sv)) croak(no_modify); tbl = (short*) cPVOP->op_pv; s = SvPV(sv, len); if (!len) return 0; if (!SvPOKp(sv)) s = SvPV_force(sv, len); (void)SvPOK_only(sv); send = s + len; if (!tbl || !s) croak("panic: do_trans"); DEBUG_t( deb("2.TBL\n")); if (!op->op_private) { while (s < send) { if ((ch = tbl[*s & 0377]) >= 0) { matches++; *s = ch; } s++; } } else { d = s; while (s < send) { if ((ch = tbl[*s & 0377]) >= 0) { *d = ch; if (matches++ && squash) { if (d[-1] == *d) matches--; else d++; } else d++; } else if (ch == -1) /* -1 is unmapped character */ *d++ = *s; /* -2 is delete character */ s++; } matches += send - d; /* account for disappeared chars */ *d = '\0'; SvCUR_set(sv, d - SvPVX(sv)); } SvSETMAGIC(sv); return matches; } void do_join(sv,del,mark,sp) register SV *sv; SV *del; register SV **mark; register SV **sp; { SV **oldmark = mark; register I32 items = sp - mark; register STRLEN len; STRLEN delimlen; register char *delim = SvPV(del, delimlen); STRLEN tmplen; mark++; len = (items > 0 ? (delimlen * (items - 1) ) : 0); if (SvTYPE(sv) < SVt_PV) sv_upgrade(sv, SVt_PV); if (SvLEN(sv) < len + items) { /* current length is way too short */ while (items-- > 0) { if (*mark) { SvPV(*mark, tmplen); len += tmplen; } mark++; } SvGROW(sv, len + 1); /* so try to pre-extend */ mark = oldmark; items = sp - mark;; ++mark; } if (items-- > 0) { char *s; if (*mark) { s = SvPV(*mark, tmplen); sv_setpvn(sv, s, tmplen); } else sv_setpv(sv, ""); mark++; } else sv_setpv(sv,""); len = delimlen; if (len) { for (; items > 0; items--,mark++) { sv_catpvn(sv,delim,len); sv_catsv(sv,*mark); } } else { for (; items > 0; items--,mark++) sv_catsv(sv,*mark); } SvSETMAGIC(sv); } void do_sprintf(sv,len,sarg) register SV *sv; register I32 len; register SV **sarg; { register char *s; register char *t; register char *f; bool dolong; #ifdef QUAD bool doquad; #endif /* QUAD */ char ch; register char *send; register SV *arg; char *xs; I32 xlen; I32 pre; I32 post; double value; STRLEN arglen; sv_setpv(sv,""); len--; /* don't count pattern string */ t = s = SvPV(*sarg, arglen); /* XXX Don't know t is writeable */ send = s + arglen; sarg++; for ( ; ; len--) { /*SUPPRESS 560*/ if (len <= 0 || !(arg = *sarg++)) arg = &sv_no; /*SUPPRESS 530*/ for ( ; t < send && *t != '%'; t++) ; if (t >= send) break; /* end of run_format string, ignore extra args */ f = t; *buf = '\0'; xs = buf; #ifdef QUAD doquad = #endif /* QUAD */ dolong = FALSE; pre = post = 0; for (t++; t < send; t++) { switch (*t) { default: ch = *(++t); *t = '\0'; (void)sprintf(xs,f); len++, sarg--; xlen = strlen(xs); break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '.': case '#': case '-': case '+': case ' ': continue; case 'l': #ifdef QUAD if (dolong) { dolong = FALSE; doquad = TRUE; } else #endif dolong = TRUE; continue; case 'c': ch = *(++t); *t = '\0'; xlen = SvIV(arg); if (strEQ(f,"%c")) { /* some printfs fail on null chars */ *xs = xlen; xs[1] = '\0'; xlen = 1; } else { (void)sprintf(xs,f,xlen); xlen = strlen(xs); } break; case 'D': dolong = TRUE; /* FALL THROUGH */ case 'd': ch = *(++t); *t = '\0'; #ifdef QUAD if (doquad) (void)sprintf(buf,s,(quad)SvNV(arg)); else #endif if (dolong) (void)sprintf(xs,f,(long)SvNV(arg)); else (void)sprintf(xs,f,SvIV(arg)); xlen = strlen(xs); break; case 'X': case 'O': dolong = TRUE; /* FALL THROUGH */ case 'x': case 'o': case 'u': ch = *(++t); *t = '\0'; value = SvNV(arg); #ifdef QUAD if (doquad) (void)sprintf(buf,s,(unsigned quad)value); else #endif if (dolong) (void)sprintf(xs,f,U_L(value)); else (void)sprintf(xs,f,U_I(value)); xlen = strlen(xs); break; case 'E': case 'e': case 'f': case 'G': case 'g': ch = *(++t); *t = '\0'; (void)sprintf(xs,f,SvNV(arg)); xlen = strlen(xs); break; case 's': ch = *(++t); *t = '\0'; xs = SvPV(arg, arglen); xlen = (I32)arglen; if (strEQ(f,"%s")) { /* some printfs fail on >128 chars */ break; /* so handle simple cases */ } else if (f[1] == '-') { char *mp = strchr(f, '.'); I32 min = atoi(f+2); if (mp) { I32 max = atoi(mp+1); if (xlen > max) xlen = max; } if (xlen < min) post = min - xlen; break; } else if (isDIGIT(f[1])) { char *mp = strchr(f, '.'); I32 min = atoi(f+1); if (mp) { I32 max = atoi(mp+1); if (xlen > max) xlen = max; } if (xlen < min) pre = min - xlen; break; } strcpy(tokenbuf+64,f); /* sprintf($s,...$s...) */ *t = ch; (void)sprintf(buf,tokenbuf+64,xs); xs = buf; xlen = strlen(xs); break; } /* end of switch, copy results */ *t = ch; SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post); sv_catpvn(sv, s, f - s); if (pre) { repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, pre); SvCUR(sv) += pre; } sv_catpvn(sv, xs, xlen); if (post) { repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, post); SvCUR(sv) += post; } s = t; break; /* break from for loop */ } } sv_catpvn(sv, s, t - s); SvSETMAGIC(sv); } void do_vecset(sv) SV *sv; { SV *targ = LvTARG(sv); register I32 offset; register I32 size; register unsigned char *s; register unsigned long lval; I32 mask; STRLEN targlen; STRLEN len; if (!targ) return; s = (unsigned char*)SvPV_force(targ, targlen); lval = U_L(SvNV(sv)); offset = LvTARGOFF(sv); size = LvTARGLEN(sv); len = (offset + size + 7) / 8; if (len > targlen) { s = (unsigned char*)SvGROW(targ, len + 1); (void)memzero(s + targlen, len - targlen + 1); SvCUR_set(targ, len); } if (size < 8) { mask = (1 << size) - 1; size = offset & 7; lval &= mask; offset >>= 3; s[offset] &= ~(mask << size); s[offset] |= lval << size; } else { offset >>= 3; if (size == 8) s[offset] = lval & 255; else if (size == 16) { s[offset] = (lval >> 8) & 255; s[offset+1] = lval & 255; } else if (size == 32) { s[offset] = (lval >> 24) & 255; s[offset+1] = (lval >> 16) & 255; s[offset+2] = (lval >> 8) & 255; s[offset+3] = lval & 255; } } } void do_chop(astr,sv) register SV *astr; register SV *sv; { STRLEN len; char *s; if (SvTYPE(sv) == SVt_PVAV) { register I32 i; I32 max; AV* av = (AV*)sv; max = AvFILL(av); for (i = 0; i <= max; i++) { sv = (SV*)av_fetch(av, i, FALSE); if (sv && ((sv = *(SV**)sv), sv != &sv_undef)) do_chop(astr, sv); } return; } if (SvTYPE(sv) == SVt_PVHV) { HV* hv = (HV*)sv; HE* entry; (void)hv_iterinit(hv); /*SUPPRESS 560*/ while (entry = hv_iternext(hv)) do_chop(astr,hv_iterval(hv,entry)); return; } s = SvPV(sv, len); if (len && !SvPOKp(sv)) s = SvPV_force(sv, len); if (s && len) { s += --len; sv_setpvn(astr, s, 1); *s = '\0'; SvCUR_set(sv, len); SvNIOK_off(sv); } else sv_setpvn(astr, "", 0); SvSETMAGIC(sv); } I32 do_chomp(sv) register SV *sv; { register I32 count = 0; STRLEN len; char *s; if (SvTYPE(sv) == SVt_PVAV) { register I32 i; I32 max; AV* av = (AV*)sv; max = AvFILL(av); for (i = 0; i <= max; i++) { sv = (SV*)av_fetch(av, i, FALSE); if (sv && ((sv = *(SV**)sv), sv != &sv_undef)) count += do_chomp(sv); } return count; } if (SvTYPE(sv) == SVt_PVHV) { HV* hv = (HV*)sv; HE* entry; (void)hv_iterinit(hv); /*SUPPRESS 560*/ while (entry = hv_iternext(hv)) count += do_chomp(hv_iterval(hv,entry)); return count; } s = SvPV(sv, len); if (len && !SvPOKp(sv)) s = SvPV_force(sv, len); if (s && len) { s += --len; if (rspara) { if (*s != '\n') goto nope; ++count; while (len && s[-1] == '\n') { --len; --s; ++count; } } else if (rslen == 1) { if (*s != rschar) goto nope; ++count; } else { if (len < rslen - 1) goto nope; len -= rslen - 1; s -= rslen - 1; if (bcmp(s, rs, rslen)) goto nope; count += rslen; } *s = '\0'; SvCUR_set(sv, len); SvNIOK_off(sv); } nope: SvSETMAGIC(sv); return count; } void do_vop(optype,sv,left,right) I32 optype; SV *sv; SV *left; SV *right; { #ifdef LIBERAL register long *dl; register long *ll; register long *rl; #endif register char *dc; STRLEN leftlen; STRLEN rightlen; register char *lc = SvPV(left, leftlen); register char *rc = SvPV(right, rightlen); register I32 len; I32 lensave; dc = SvPV_force(sv,na); len = leftlen < rightlen ? leftlen : rightlen; lensave = len; if (SvCUR(sv) < len) { dc = SvGROW(sv,len + 1); (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1); } SvCUR_set(sv, len); (void)SvPOK_only(sv); #ifdef LIBERAL if (len >= sizeof(long)*4 && !((long)dc % sizeof(long)) && !((long)lc % sizeof(long)) && !((long)rc % sizeof(long))) /* It's almost always aligned... */ { I32 remainder = len % (sizeof(long)*4); len /= (sizeof(long)*4); dl = (long*)dc; ll = (long*)lc; rl = (long*)rc; switch (optype) { case OP_BIT_AND: while (len--) { *dl++ = *ll++ & *rl++; *dl++ = *ll++ & *rl++; *dl++ = *ll++ & *rl++; *dl++ = *ll++ & *rl++; } break; case OP_BIT_XOR: while (len--) { *dl++ = *ll++ ^ *rl++; *dl++ = *ll++ ^ *rl++; *dl++ = *ll++ ^ *rl++; *dl++ = *ll++ ^ *rl++; } break; case OP_BIT_OR: while (len--) { *dl++ = *ll++ | *rl++; *dl++ = *ll++ | *rl++; *dl++ = *ll++ | *rl++; *dl++ = *ll++ | *rl++; } } dc = (char*)dl; lc = (char*)ll; rc = (char*)rl; len = remainder; } #endif { char *lsave = lc; char *rsave = rc; switch (optype) { case OP_BIT_AND: while (len--) *dc++ = *lc++ & *rc++; break; case OP_BIT_XOR: while (len--) *dc++ = *lc++ ^ *rc++; goto mop_up; case OP_BIT_OR: while (len--) *dc++ = *lc++ | *rc++; mop_up: len = lensave; if (rightlen > len) sv_catpvn(sv, rsave + len, rightlen - len); else if (leftlen > len) sv_catpvn(sv, lsave + len, leftlen - len); break; } } } OP * do_kv(ARGS) dARGS { dSP; HV *hv = (HV*)POPs; I32 i; register HE *entry; char *tmps; SV *tmpstr; I32 dokeys = (op->op_type == OP_KEYS); I32 dovalues = (op->op_type == OP_VALUES); if (op->op_type == OP_RV2HV || op->op_type == OP_PADHV) dokeys = dovalues = TRUE; if (!hv) RETURN; if (GIMME != G_ARRAY) { dTARGET; if (!SvRMAGICAL(hv) || !mg_find((SV*)hv,'P')) i = HvKEYS(hv); else { i = 0; (void)hv_iterinit(hv); /*SUPPRESS 560*/ while (entry = hv_iternext(hv)) { i++; } } PUSHi( i ); RETURN; } /* Guess how much room we need. hv_max may be a few too many. Oh well. */ EXTEND(sp, HvMAX(hv) * (dokeys + dovalues)); (void)hv_iterinit(hv); PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */ while (entry = hv_iternext(hv)) { SPAGAIN; if (dokeys) { tmps = hv_iterkey(entry,&i); /* won't clobber stack_sp */ if (!i) tmps = ""; XPUSHs(sv_2mortal(newSVpv(tmps,i))); } if (dovalues) { tmpstr = NEWSV(45,0); PUTBACK; sv_setsv(tmpstr,hv_iterval(hv,entry)); SPAGAIN; DEBUG_H( { sprintf(buf,"%d%%%d=%d\n",entry->hent_hash, HvMAX(hv)+1,entry->hent_hash & HvMAX(hv)); sv_setpv(tmpstr,buf); } ) XPUSHs(sv_2mortal(tmpstr)); } PUTBACK; } return NORMAL; } = *(++t); *t = '\0'; value = SvNV(arg); #ifdef QUAD if (doquad) (void)sprintf(buf,s,(unsigned quad)value); else #endif if (dolong) (void)sprintf(xs,f,U_L(value)); else (void)sprintf(xs,f,U_I(value)); xlen = strlen(xs); break; case 'E': case 'e': case perl5.000/dosish.h 644 203 12 717 5650572636 7067 #define ABORT() abort(); /* * fwrite1() should be a routine with the same calling sequence as fwrite(), * but which outputs all of the bytes requested as a single stream (unlike * fwrite() itself, which on some systems outputs several distinct records * if the number_of_items parameter is >1). */ #define fwrite1 fwrite #define Stat(fname,bufptr) stat((fname),(bufptr)) #define Fstat(fd,bufptr) fstat((fd),(bufptr)) #define my_getenv(var) getenv(var) ˜9 keywords.pl¤ðAlib¼9  perl5.000/dump.c 644 203 12 20541 5650572636 6573 /* dump.c * * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * "'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and * it has not been hard for me to read your mind and memory.'" */ #include "EXTERN.h" #include "perl.h" #ifndef DEBUGGING void dump_all() { } #else /* Rest of file is for DEBUGGING */ static void dump(); void dump_all() { #ifdef HAS_SETLINEBUF setlinebuf(stderr); #else setvbuf(stderr, Nullch, _IOLBF, 0); #endif if (main_root) dump_op(main_root); dump_packsubs(defstash); } void dump_packsubs(stash) HV* stash; { I32 i; HE *entry; if (!HvARRAY(stash)) return; for (i = 0; i <= (I32) HvMAX(stash); i++) { for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) { GV *gv = (GV*)entry->hent_val; HV *hv; if (GvCV(gv)) dump_sub(gv); if (GvFORM(gv)) dump_form(gv); if (entry->hent_key[entry->hent_klen-1] == ':' && (hv = GvHV(gv)) && HvNAME(hv) && hv != defstash) dump_packsubs(hv); /* nested package */ } } } void dump_sub(gv) GV* gv; { SV *sv = sv_newmortal(); gv_fullname(sv,gv); dump("\nSUB %s = ", SvPVX(sv)); if (CvXSUB(GvCV(gv))) dump("(xsub 0x%x %d)\n", (long)CvXSUB(GvCV(gv)), CvXSUBANY(GvCV(gv)).any_i32); else if (CvROOT(GvCV(gv))) dump_op(CvROOT(GvCV(gv))); else dump("\n"); } void dump_form(gv) GV* gv; { SV *sv = sv_newmortal(); gv_fullname(sv,gv); dump("\nFORMAT %s = ", SvPVX(sv)); if (CvROOT(GvFORM(gv))) dump_op(CvROOT(GvFORM(gv))); else dump("\n"); } void dump_eval() { dump_op(eval_root); } void dump_op(op) register OP *op; { SV *tmpsv; dump("{\n"); if (op->op_seq) fprintf(stderr, "%-4d", op->op_seq); else fprintf(stderr, " "); dump("TYPE = %s ===> ", op_name[op->op_type]); if (op->op_next) { if (op->op_seq) fprintf(stderr, "%d\n", op->op_next->op_seq); else fprintf(stderr, "(%d)\n", op->op_next->op_seq); } else fprintf(stderr, "DONE\n"); dumplvl++; if (op->op_targ) { if (op->op_type == OP_NULL) dump(" (was %s)\n", op_name[op->op_targ]); else dump("TARG = %d\n", op->op_targ); } #ifdef NOTDEF dump("ADDR = 0x%lx => 0x%lx\n",op, op->op_next); #endif if (op->op_flags) { *buf = '\0'; if (op->op_flags & OPf_KNOW) { if (op->op_flags & OPf_LIST) (void)strcat(buf,"LIST,"); else (void)strcat(buf,"SCALAR,"); } else (void)strcat(buf,"UNKNOWN,"); if (op->op_flags & OPf_KIDS) (void)strcat(buf,"KIDS,"); if (op->op_flags & OPf_PARENS) (void)strcat(buf,"PARENS,"); if (op->op_flags & OPf_STACKED) (void)strcat(buf,"STACKED,"); if (op->op_flags & OPf_REF) (void)strcat(buf,"REF,"); if (op->op_flags & OPf_MOD) (void)strcat(buf,"MOD,"); if (op->op_flags & OPf_SPECIAL) (void)strcat(buf,"SPECIAL,"); if (*buf) buf[strlen(buf)-1] = '\0'; dump("FLAGS = (%s)\n",buf); } if (op->op_private) { *buf = '\0'; if (op->op_type == OP_AASSIGN) { if (op->op_private & OPpASSIGN_COMMON) (void)strcat(buf,"COMMON,"); } else if (op->op_type == OP_SASSIGN) { if (op->op_private & OPpASSIGN_BACKWARDS) (void)strcat(buf,"BACKWARDS,"); } else if (op->op_type == OP_TRANS) { if (op->op_private & OPpTRANS_SQUASH) (void)strcat(buf,"SQUASH,"); if (op->op_private & OPpTRANS_DELETE) (void)strcat(buf,"DELETE,"); if (op->op_private & OPpTRANS_COMPLEMENT) (void)strcat(buf,"COMPLEMENT,"); } else if (op->op_type == OP_REPEAT) { if (op->op_private & OPpREPEAT_DOLIST) (void)strcat(buf,"DOLIST,"); } else if (op->op_type == OP_ENTERSUB || op->op_type == OP_RV2SV || op->op_type == OP_RV2AV || op->op_type == OP_RV2HV || op->op_type == OP_RV2GV || op->op_type == OP_AELEM || op->op_type == OP_HELEM ) { if (op->op_private & OPpDEREF_DB) (void)strcat(buf,"DB,"); if (op->op_private & OPpDEREF_AV) (void)strcat(buf,"AV,"); if (op->op_private & OPpDEREF_HV) (void)strcat(buf,"HV,"); if (op->op_private & HINT_STRICT_REFS) (void)strcat(buf,"STRICT_REFS,"); } else if (op->op_type == OP_CONST) { if (op->op_private & OPpCONST_BARE) (void)strcat(buf,"BARE,"); } else if (op->op_type == OP_FLIP) { if (op->op_private & OPpFLIP_LINENUM) (void)strcat(buf,"LINENUM,"); } else if (op->op_type == OP_FLOP) { if (op->op_private & OPpFLIP_LINENUM) (void)strcat(buf,"LINENUM,"); } if (op->op_flags & OPf_MOD && op->op_private & OPpLVAL_INTRO) (void)strcat(buf,"INTRO,"); if (*buf) { buf[strlen(buf)-1] = '\0'; dump("PRIVATE = (%s)\n",buf); } } switch (op->op_type) { case OP_GVSV: case OP_GV: if (cGVOP->op_gv) { ENTER; tmpsv = NEWSV(0,0); SAVEFREESV(tmpsv); gv_fullname(tmpsv,cGVOP->op_gv); dump("GV = %s\n", SvPV(tmpsv, na)); LEAVE; } else dump("GV = NULL\n"); break; case OP_CONST: dump("SV = %s\n", SvPEEK(cSVOP->op_sv)); break; case OP_NEXTSTATE: case OP_DBSTATE: if (cCOP->cop_line) dump("LINE = %d\n",cCOP->cop_line); if (cCOP->cop_label) dump("LABEL = \"%s\"\n",cCOP->cop_label); break; case OP_ENTERLOOP: dump("REDO ===> "); if (cLOOP->op_redoop) fprintf(stderr, "%d\n", cLOOP->op_redoop->op_seq); else fprintf(stderr, "DONE\n"); dump("NEXT ===> "); if (cLOOP->op_nextop) fprintf(stderr, "%d\n", cLOOP->op_nextop->op_seq); else fprintf(stderr, "DONE\n"); dump("LAST ===> "); if (cLOOP->op_lastop) fprintf(stderr, "%d\n", cLOOP->op_lastop->op_seq); else fprintf(stderr, "DONE\n"); break; case OP_COND_EXPR: dump("TRUE ===> "); if (cCONDOP->op_true) fprintf(stderr, "%d\n", cCONDOP->op_true->op_seq); else fprintf(stderr, "DONE\n"); dump("FALSE ===> "); if (cCONDOP->op_false) fprintf(stderr, "%d\n", cCONDOP->op_false->op_seq); else fprintf(stderr, "DONE\n"); break; case OP_MAPWHILE: case OP_GREPWHILE: case OP_OR: case OP_AND: dump("OTHER ===> "); if (cLOGOP->op_other) fprintf(stderr, "%d\n", cLOGOP->op_other->op_seq); else fprintf(stderr, "DONE\n"); break; case OP_PUSHRE: case OP_MATCH: case OP_SUBST: dump_pm((PMOP*)op); break; default: break; } if (op->op_flags & OPf_KIDS) { OP *kid; for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) dump_op(kid); } dumplvl--; dump("}\n"); } void dump_gv(gv) register GV *gv; { SV *sv; if (!gv) { fprintf(stderr,"{}\n"); return; } sv = sv_newmortal(); dumplvl++; fprintf(stderr,"{\n"); gv_fullname(sv,gv); dump("GV_NAME = %s", SvPVX(sv)); if (gv != GvEGV(gv)) { gv_efullname(sv,GvEGV(gv)); dump("-> %s", SvPVX(sv)); } dump("\n"); dumplvl--; dump("}\n"); } void dump_pm(pm) register PMOP *pm; { char ch; if (!pm) { dump("{}\n"); return; } dump("{\n"); dumplvl++; if (pm->op_pmflags & PMf_ONCE) ch = '?'; else ch = '/'; if (pm->op_pmregexp) dump("PMf_PRE %c%s%c\n",ch,pm->op_pmregexp->precomp,ch); if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) { dump("PMf_REPL = "); dump_op(pm->op_pmreplroot); } if (pm->op_pmshort) { dump("PMf_SHORT = %s\n",SvPEEK(pm->op_pmshort)); } if (pm->op_pmflags) { *buf = '\0'; if (pm->op_pmflags & PMf_USED) (void)strcat(buf,"USED,"); if (pm->op_pmflags & PMf_ONCE) (void)strcat(buf,"ONCE,"); if (pm->op_pmflags & PMf_SCANFIRST) (void)strcat(buf,"SCANFIRST,"); if (pm->op_pmflags & PMf_ALL) (void)strcat(buf,"ALL,"); if (pm->op_pmflags & PMf_SKIPWHITE) (void)strcat(buf,"SKIPWHITE,"); if (pm->op_pmflags & PMf_FOLD) (void)strcat(buf,"FOLD,"); if (pm->op_pmflags & PMf_CONST) (void)strcat(buf,"CONST,"); if (pm->op_pmflags & PMf_KEEP) (void)strcat(buf,"KEEP,"); if (pm->op_pmflags & PMf_GLOBAL) (void)strcat(buf,"GLOBAL,"); if (pm->op_pmflags & PMf_RUNTIME) (void)strcat(buf,"RUNTIME,"); if (pm->op_pmflags & PMf_EVAL) (void)strcat(buf,"EVAL,"); if (*buf) buf[strlen(buf)-1] = '\0'; dump("PMFLAGS = (%s)\n",buf); } dumplvl--; dump("}\n"); } /* VARARGS1 */ static void dump(arg1,arg2,arg3,arg4,arg5) char *arg1; long arg2, arg3, arg4, arg5; { I32 i; for (i = dumplvl*4; i; i--) (void)putc(' ',stderr); fprintf(stderr,arg1, arg2, arg3, arg4, arg5); } #endif 1); (void)memzero(s + targlen, len - targlen + 1); SvCUR_set(targ, len); } if (size < 8) { mask = (1 << size) - 1; size = offset & 7; lval &perl5.000/eg/ 775 203 12 0 5650575657 5756 perl5.000/eg/ADB 644 203 12 317 5240611422 6303 #!/usr/bin/perl # $RCSfile: ADB,v $$Revision: 4.1 $$Date: 92/08/07 17:20:06 $ # This script is only useful when used in your crash directory. $num = shift; exec 'adb', '-k', "vmunix.$num", "vmcore.$num"; pmuckSHÀÎqmuck.manÐÎrmyrupÜÎsnihìÎurelinkdüÎvrenamet Îxrmfromp‰0scannte,Îyserver<ÎzshmkillLž sysvipc`Î{travesty¤pÎ|unuc9 „Î}uudecodeÐvanœÎ~perl5.000/eg/README 644 203 12 1674 5240620357 6710 Although supplied with the perl package, the perl scripts in this eg directory and its subdirectories are placed in the public domain, and you may do anything with them that you wish. This stuff is supplied on an as-is basis--little attempt has been made to make any of it portable. It's mostly here to give you an idea of what perl code looks like, and what tricks and idioms are used. System administrators responsible for many computers will enjoy the items down in the g directory very much. The scan directory contains the beginnings of a system to check on and report various kinds of anomalies. If you machine doesn't support #!, the first thing you'll want to do is replace the #! with a couple of lines that look like this: eval "exec /usr/bin/perl -S $0 $*" if $running_under_some_shell; being sure to include any flags that were on the #! line. A supplied script called "nih" will translate perl scripts in place for you: nih g/g?? P9;perly.y`9<pl2pmyp9=pp.crl€9>perl5.000/eg/changes 644 203 12 1600 5240611424 7343 #!/usr/bin/perl -P # $RCSfile: changes,v $$Revision: 4.1 $$Date: 92/08/07 17:20:08 $ ($dir, $days) = @ARGV; $dir = '/' if $dir eq ''; $days = '14' if $days eq ''; # Masscomps do things differently from Suns #if defined(mc300) || defined(mc500) || defined(mc700) open(Find, "find $dir -mtime -$days -print |") || die "changes: can't run find"; #else open(Find, "find $dir \\( -fstype nfs -prune \\) -o -mtime -$days -ls |") || die "changes: can't run find"; #endif while () { #if defined(mc300) || defined(mc500) || defined(mc700) $x = `/bin/ls -ild $_`; $_ = $x; ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) = split(' '); #else ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) = split(' '); #endif printf("%10s%3s %-8s %-8s%9s %3s %2s %s\n", $perm,$links,$owner,$group,$size,$month,$day,$name); } " will translate perl scripts in place for you: nih g/g?? P9;perly.y`9<pl2pmyp9=pp.crl€9>perl5.000/eg/client 755 203 12 1132 5240620345 7216 #!./perl $pat = 'S n C4 x8'; $inet = 2; $echo = 7; $smtp = 25; $nntp = 119; $test = 2345; $SIG{'INT'} = 'dokill'; $this = pack($pat,$inet,0, 128,149,13,43); $that = pack($pat,$inet,$test,127,0,0,1); if (socket(S,2,1,6)) { print "socket ok\n"; } else { die $!; } if (bind(S,$this)) { print "bind ok\n"; } else { die $!; } if (connect(S,$that)) { print "connect ok\n"; } else { die $!; } select(S); $| = 1; select(stdout); if ($child = fork) { while () { print S; } sleep 3; do dokill(); } else { while () { print; } } sub dokill { kill 9,$child if $child; } ,$links,$owner,$group,$size,$month,$day,$time,$name) = split(' '); #else ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) = split(' '); #endif printf("%10s%3s %-8s %-8s%9s %3s %2s %s\n", $perm,$links,$owner,$group,$size,$month,$day,$name); } " will translate perl scripts in place for you: nih g/g?? P9;perly.y`9<pl2pmyp9=pp.crl€9>perl5.000/eg/down 755 203 12 730 5240620366 6675 #!/usr/bin/perl $| = 1; if ($#ARGV >= 0) { $cmd = join(' ',@ARGV); } else { print "Command: "; $cmd = ; chop($cmd); while ($cmd =~ s/\\$//) { print "+ "; $cmd .= ; chop($cmd); } } $cwd = `pwd`; chop($cwd); open(FIND,'find . -type d -print|') || die "Can't run find"; while () { chop; unless (chdir $_) { print stderr "Can't cd to $_\n"; next; } print "\t--> ",$_,"\n"; system $cmd; chdir $cwd; } print S; } sleep 3; do dokiperl5.000/eg/dus 644 203 12 1065 5240611427 6536 #!/usr/bin/perl # $RCSfile: dus,v $$Revision: 4.1 $$Date: 92/08/07 17:20:11 $ # This script does a du -s on any directories in the current directory that # are not mount points for another filesystem. ($mydev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('.'); open(ls,'ls -F1|'); while () { chop; next unless s|/$||; ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($_); next unless $dev == $mydev; push(@ary,$_); } exec 'du', '-s', @ary; dokill { kill 9,$child if $child; } ,$links,$owner,$group,$size,$month,$day,$time,$name) = split(' '); #else ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) = split(' '); #endif printf("%10s%3s %-8s %-8s%9s %3s %2s %s\n", $perm,$links,$owner,$group,$size,$month,$day,$name); } " will translate perl scripts in place for you: nih g/g?? P9;perly.y`9<pl2pmyp9=pp.crl€9>perl5.000/eg/findcp 644 203 12 2265 5240611430 7203 #!/usr/bin/perl # $RCSfile: findcp,v $$Revision: 4.1 $$Date: 92/08/07 17:20:12 $ # This is a wrapper around the find command that pretends find has a switch # of the form -cp host:destination. It presumes your find implements -ls. # It uses tar to do the actual copy. If your tar knows about the I switch # you may prefer to use findtar, since this one has to do the tar in batches. sub copy { `tar cf - $list | rsh $desthost cd $destdir '&&' tar xBpf -`; } $sourcedir = $ARGV[0]; if ($sourcedir =~ /^\//) { $ARGV[0] = '.'; unless (chdir($sourcedir)) { die "Can't find directory $sourcedir: $!"; } } $args = join(' ',@ARGV); if ($args =~ s/-cp *([^ ]+)/-ls/) { $dest = $1; if ($dest =~ /(.*):(.*)/) { $desthost = $1; $destdir = $2; } else { die "Malformed destination--should be host:directory"; } } else { die("No destination specified"); } open(find,"find $args |") || die "Can't run find for you: $!"; while () { @x = split(' '); if ($x[2] =~ /^d/) { next;} chop($filename = $x[10]); if (length($list) > 5000) { do copy(); $list = ''; } else { $list .= ' '; } $list .= $filename; } if ($list) { do copy(); } $blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) = split(' '); #endif printf("%10s%3s %-8s %-8s%9s %3s %2s %s\n", $perm,$links,$owner,$group,$size,$month,$day,$name); } " will translate perl scripts in place for you: nih g/g?? P9;perly.y`9<pl2pmyp9=pp.crl€9>perl5.000/eg/findtar 644 203 12 771 5240611432 7351 #!/usr/bin/perl # $RCSfile: findtar,v $$Revision: 4.1 $$Date: 92/08/07 17:20:13 $ # findtar takes find-style arguments and spits out a tarfile on stdout. # It won't work unless your find supports -ls and your tar the I flag. $args = join(' ',@ARGV); open(find,"/usr/bin/find $args -ls |") || die "Can't run find for you."; open(tar,"| /bin/tar cIf - -") || die "Can't run tar for you: $!"; while () { @x = split(' '); if ($x[2] =~ /^d/) { print tar '-d ';} print tar $x[10],"\n"; } ext;} perl5.000/eg/g/ 775 203 12 0 5650575653 6200 perl5.000/eg/g/gcp 644 203 12 4574 5240611434 6750 #!/usr/bin/perl # $RCSfile: gcp,v $$Revision: 4.1 $$Date: 92/08/07 17:20:15 $ # Here is a script to do global rcps. See man page. $#ARGV >= 1 || die "Not enough arguments.\n"; if ($ARGV[0] eq '-r') { $rcp = 'rcp -r'; shift; } else { $rcp = 'rcp'; } $args = $rcp; $dest = $ARGV[$#ARGV]; $SIG{'QUIT'} = 'CLEANUP'; $SIG{'INT'} = 'CONT'; while ($arg = shift) { if ($arg =~ /^([-a-zA-Z0-9_+]+):/) { if ($systype && $systype ne $1) { die "Can't mix system type specifers ($systype vs $1).\n"; } $#ARGV < 0 || $arg !~ /:$/ || die "No source file specified.\n"; $systype = $1; $args .= " $arg"; } else { if ($#ARGV >= 0) { if ($arg =~ /^[\/~]/) { $arg =~ /^(.*)\// && ($dir = $1); } else { if (!$pwd) { chop($pwd = `pwd`); } $dir = $pwd; } } if ($olddir && $dir ne $olddir && $dest =~ /:$/) { $args .= " $dest$olddir; $rcp"; } $olddir = $dir; $args .= " $arg"; } } die "No system type specified.\n" unless $systype; $args =~ s/:$/:$olddir/; chop($thishost = `hostname`); $one_of_these = ":$systype:"; if ($systype =~ s/\+/[+]/g) { $one_of_these =~ s/\+/:/g; } $one_of_these =~ s/-/:-/g; @ARGV = (); push(@ARGV,'.grem') if -f '.grem'; push(@ARGV,'.ghosts') if -f '.ghosts'; push(@ARGV,'/etc/ghosts'); $remainder = ''; line: while (<>) { s/[ \t]*\n//; if (!$_ || /^#/) { next line; } if (/^([a-zA-Z_0-9]+)=(.+)/) { $name = $1; $repl = $2; $repl =~ s/\+/:/g; $repl =~ s/-/:-/g; $one_of_these =~ s/:$name:/:$repl:/; $repl =~ s/:/:-/g; $one_of_these =~ s/:-$name:/:-$repl:/g; next line; } @gh = split(' '); $host = $gh[0]; next line if $host eq $thishost; # should handle aliases too $wanted = 0; foreach $class (@gh) { $wanted++ if index($one_of_these,":$class:") >= 0; $wanted = -9999 if index($one_of_these,":-$class:") >= 0; } if ($wanted > 0) { ($cmd = $args) =~ s/[ \t]$systype:/ $host:/g; print "$cmd\n"; $result = `$cmd 2>&1`; $remainder .= "$host+" if $result =~ /Connection timed out|Permission denied/; print $result; } } if ($remainder) { chop($remainder); open(grem,">.grem") || (printf stderr "Can't create .grem: $!\n"); print grem 'rem=', $remainder, "\n"; close(grem); print 'rem=', $remainder, "\n"; } sub CLEANUP { exit; } sub CONT { print "Continuing...\n"; # Just ignore the signal that kills rcp $remainder .= "$host+"; } uf,"LINENUM,"); } else if (op->op_type == OP_FLOP) { if (op->op_private & OPpFLIP_LINENUM) (void)strcat(buf,"LINENUM,"); }perl5.000/eg/g/gcp.man 644 203 12 3661 5240611435 7517 .\" $RCSfile: gcp.man,v $$Revision: 4.1 $$Date: 92/08/07 17:20:17 $ .TH GCP 1C "13 May 1988" .SH NAME gcp \- global file copy .SH SYNOPSIS .B gcp file1 file2 .br .B gcp [ .B \-r ] file ... directory .SH DESCRIPTION .I gcp works just like rcp(1C) except that you may specify a set of hosts to copy files from or to. The host sets are defined in the file /etc/ghosts. (An individual host name can be used as a set containing one member.) You can give a command like gcp /etc/motd sun: to copy your /etc/motd file to /etc/motd on all the Suns. If, on the other hand, you say gcp /a/foo /b/bar sun:/tmp then your files will be copied to /tmp on all the Suns. The general rule is that if you don't specify the destination directory, files go to the same directory they are in currently. .P You may specify the union of two or more sets by using + as follows: gcp /a/foo /b/bar 750+mc: which will copy /a/foo to /a/foo on all 750's and Masscomps, and then copy /b/bar to /b/bar on all 750's and Masscomps. .P Commonly used sets should be defined in /etc/ghosts. For example, you could add a line that says pep=manny+moe+jack Another way to do that would be to add the word "pep" after each of the host entries: manny sun3 pep .br moe sun3 pep .br jack sun3 pep Hosts and sets of host can also be excluded: foo=sun-sun2 Any host so excluded will never be included, even if a subsequent set on the line includes it: foo=abc+def .br bar=xyz-abc+foo comes out to xyz+def. You can define private host sets by creating .ghosts in your current directory with entries just like /etc/ghosts. Also, if there is a file .grem, it defines "rem" to be the remaining hosts from the last gsh or gcp that didn't succeed everywhere. .PP Interrupting with a SIGINT will cause the rcp to the current host to be skipped and execution resumed with the next host. To stop completely, send a SIGQUIT. .SH SEE ALSO rcp(1C) .SH BUGS All the bugs of rcp, since it calls rcp. 1`; $remainder .= "$host+" if $result =~ /Connection timed out|Permissionperl5.000/eg/g/ged 644 203 12 653 5240611437 6713 #!/usr/bin/perl # $RCSfile: ged,v $$Revision: 4.1 $$Date: 92/08/07 17:20:18 $ # Does inplace edits on a set of files on a set of machines. # # Typical invokation: # # ged vax+sun /etc/passwd # s/Freddy/Freddie/; # ^D # $class = shift; $files = join(' ',@ARGV); die "Usage: ged class files /tmp/gsh$$`; # get input into a handy place $dist = " ) { # for each line of ghosts s/[ \t]*\n//; # trim trailing whitespace if (!$_ || /^#/) { # skip blank line or comment next line; } if (/^(\w+)=(.+)/) { # a macro line? $name = $1; $repl = $2; $repl =~ s/\+/:/g; $repl =~ s/-/:-/g; $one_of_these =~ s/:$name:/:$repl:/; # do expansion in "wanted" list $repl =~ s/:/:-/g; $one_of_these =~ s/:-$name:/:-$repl:/; next line; } # we have a normal line @attr = split(' '); # a list of attributes to match against # which we put into an array $host = $attr[0]; # the first attribute is the host name if ($showhost) { $showhost = "$host:\t"; } $wanted = 0; foreach $attr (@attr) { # iterate over attribute array $wanted++ if index($one_of_these,":$attr:") >= 0; $wanted = -9999 if index($one_of_these,":-$attr:") >= 0; } if ($wanted > 0) { print "rsh $host$l$n '$cmd'\n" unless $silent; $SIG{'INT'} = 'DEFAULT'; if (open(PIPE,"rsh $host$l$n '$cmd'$dist 2>&1|")) { # start an rsh $SIG{'INT'} = 'cont'; for ($iter=0; ; $iter++) { unless ($iter) { $remainder .= "$host+" if /Connection timed out|Permission denied/; } print $showhost,$_; } close(PIPE); } else { print "(Can't execute rsh: $!)\n"; $SIG{'INT'} = 'cont'; } } } unlink "/tmp/gsh$$" if $dodist; if ($remainder) { chop($remainder); open(grem,">.grem") || (printf stderr "Can't make a .grem file: $!\n"); print grem 'rem=', $remainder, "\n"; close(grem); print 'rem=', $remainder, "\n"; } # here are a couple of subroutines that serve as signal handlers sub cont { print "\rContinuing...\n"; $remainder .= "$host+"; } sub quit { $| = 1; print "\r"; $SIG{'INT'} = ''; kill 2, $$; } if (cCOP->cop_line) dump("LINE = %d\n",cCOP->cop_line); if (cCOP->cop_label) dump("LABEL = \"%s\"\n",cCOP->cop_label); break; case OP_ENTERLOOP: dump("REDO ===> "); if (cLOOP->op_redoop) fprintf(stderr, "%d\n", cLOOP->op_redoop->op_seq); else fprintf(stderr, "DONE\n"); dump("NEXT ===> "); if (cLOOP->op_nextop) fprintf(stderr, "%d\n", cLOOP->op_nextop->op_seq); else fprintf(stderr, "DONE\n"); dump("LAperl5.000/eg/g/gsh.man 644 203 12 3766 5240611442 7533 .\" $RCSfile: gsh.man,v $$Revision: 4.1 $$Date: 92/08/07 17:20:22 $ .TH GSH 8 "13 May 1988" .SH NAME gsh \- global shell .SH SYNOPSIS .B gsh [options] .I host [options] .I command .SH DESCRIPTION .I gsh works just like rsh(1C) except that you may specify a set of hosts to execute the command on. The host sets are defined in the file /etc/ghosts. (An individual host name can be used as a set containing one member.) You can give a command like gsh sun /etc/mungmotd to run /etc/mungmotd on all your Suns. .P You may specify the union of two or more sets by using + as follows: gsh 750+mc /etc/mungmotd which will run mungmotd on all 750's and Masscomps. .P Commonly used sets should be defined in /etc/ghosts. For example, you could add a line that says pep=manny+moe+jack Another way to do that would be to add the word "pep" after each of the host entries: manny sun3 pep .br moe sun3 pep .br jack sun3 pep Hosts and sets of host can also be excluded: foo=sun-sun2 Any host so excluded will never be included, even if a subsequent set on the line includes it: foo=abc+def bar=xyz-abc+foo comes out to xyz+def. You can define private host sets by creating .ghosts in your current directory with entries just like /etc/ghosts. Also, if there is a file .grem, it defines "rem" to be the remaining hosts from the last gsh or gcp that didn't succeed everywhere. Options include all those defined by rsh, as well as .IP "\-d" 8 Causes gsh to collect input till end of file, and then distribute that input to each invokation of rsh. .IP "\-h" 8 Rather than print out the command followed by the output, merely prepends the host name to each line of output. .IP "\-s" 8 Do work silently. .PP Interrupting with a SIGINT will cause the rsh to the current host to be skipped and execution resumed with the next host. To stop completely, send a SIGQUIT. .SH SEE ALSO rsh(1C) .SH BUGS All the bugs of rsh, since it calls rsh. Also, will not properly return data from the remote execution that contains null characters. never be perl5.000/eg/muck 644 203 12 5501 5240620377 6705 #!../perl $M = '-M'; $M = '-m' if -d '/usr/uts' && -f '/etc/master'; do 'getopt.pl'; do Getopt('f'); if ($opt_f) { $makefile = $opt_f; } elsif (-f 'makefile') { $makefile = 'makefile'; } elsif (-f 'Makefile') { $makefile = 'Makefile'; } else { die "No makefile\n"; } $MF = 'mf00'; while(($key,$val) = each(ENV)) { $mac{$key} = $val; } do scan($makefile); $co = $action{'.c.o'}; $co = ' ' unless $co; $missing = "Missing dependencies:\n"; foreach $key (sort keys(o)) { if ($oc{$key}) { $src = $oc{$key}; $action = $action{$key}; } else { $action = ''; } if (!$action) { if ($co && ($c = $key) =~ s/\.o$/.c/ && -f $c) { $src = $c; $action = $co; } else { print "No source found for $key $c\n"; next; } } $I = ''; $D = ''; $I .= $1 while $action =~ s/(-I\S+\s*)//; $D .= $1 . ' ' while $action =~ s/(-D\w+)//; if ($opt_v) { $cmd = "Checking $key: cc $M $D $I $src"; $cmd =~ s/\s\s+/ /g; print stderr $cmd,"\n"; } open(CPP,"cc $M $D $I $src|") || die "Can't run C preprocessor: $!"; while () { ($name,$dep) = split; $dep =~ s|^\./||; (print $missing,"$key: $dep\n"),($missing='') unless ($dep{"$key: $dep"} += 2) > 2; } } $extra = "\nExtraneous dependencies:\n"; foreach $key (sort keys(dep)) { if ($key =~ /\.o: .*\.h$/ && $dep{$key} == 1) { print $extra,$key,"\n"; $extra = ''; } } sub scan { local($makefile) = @_; local($MF) = $MF; print stderr "Analyzing $makefile.\n" if $opt_v; $MF++; open($MF,$makefile) || die "Can't open $makefile: $!"; while (<$MF>) { chop; chop($_ = $_ . <$MF>) while s/\\$//; next if /^#/; next if /^$/; s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg; s/\$\((\w+)\)/$mac{$1}/eg; $mac{$1} = $2, next if /^(\w+)\s*=\s*(.*)/; if (/^include\s+(.*)/) { do scan($1); print stderr "Continuing $makefile.\n" if $opt_v; next; } if (/^([^:]+):\s*(.*)/) { $left = $1; $right = $2; if ($right =~ /^([^;]*);(.*)/) { $right = $1; $action = $2; } else { $action = ''; } while (<$MF>) { last unless /^\t/; chop; chop($_ = $_ . <$MF>) while s/\\$//; next if /^#/; last if /^$/; s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg; s/\$\((\w+)\)/$mac{$1}/eg; $action .= $_; } foreach $targ (split(' ',$left)) { $targ =~ s|^\./||; foreach $src (split(' ',$right)) { $src =~ s|^\./||; $deplist{$targ} .= ' ' . $src; $dep{"$targ: $src"} = 1; $o{$src} = 1 if $src =~ /\.o$/; $oc{$targ} = $src if $targ =~ /\.o$/ && $src =~ /\.[yc]$/; } $action{$targ} .= $action; } redo if $_; } } close($MF); } sub subst { local($foo,$from,$to) = @_; $foo = $mac{$foo}; $from =~ s/\./[.]/; y/a/a/; $foo =~ s/\b$from\b/$to/g; $foo; } print 'rem=', $remainder, "\n"; } # here are a couple of subroutines that serve as signal handlers sub cont { print "\rContinuing...\n"; $remainder .= "$host+"; } sub quit { perl5.000/eg/muck.man 644 203 12 1114 5240611444 7446 .\" $RCSfile: muck.man,v $$Revision: 4.1 $$Date: 92/08/07 17:20:23 $ .TH MUCK 1 "10 Jan 1989" .SH NAME muck \- make usage checker .SH SYNOPSIS .B muck [options] .SH DESCRIPTION .I muck looks at your current makefile and complains if you've left out any dependencies between .o and .h files. It also complains about extraneous dependencies. .PP You can use the -f FILENAME option to specify an alternate name for your makefile. The -v option is a little more verbose about what muck is mucking around with at the moment. .SH SEE ALSO make(1) .SH BUGS Only knows about .h, .c and .o files. = ''; } if (!$action) { if ($co && ($c = $key) =~ s/\.o$/.c/ && -f $c) { $src = $c; $action = $co; } else { print "No source found for $key $c\n"; next; } } $I = ''; $D = ''; $I .= $1 while $action =~ s/(-I\S+\s*)//; $D .= $1 . ' ' while $action =~ s/(-D\w+)//; if ($opt_v) { $cmd = "Checking $key: cc $M $D $I $src"; $cmd =~ s/\s\s+/ /g; print stderr $cmd,"\n"; } openperl5.000/eg/myrup 644 203 12 1573 5240611446 7124 #!/usr/bin/perl # $RCSfile: myrup,v $$Revision: 4.1 $$Date: 92/08/07 17:20:26 $ # This was a customization of ruptime requested by someone here who wanted # to be able to find the least loaded machine easily. It uses the # /etc/ghosts file that's defined for gsh and gcp to prune down the # number of entries to those hosts we have administrative control over. print "node load (u)\n------- --------\n"; open(ghosts,'/etc/ghosts') || die "Can't open /etc/ghosts: $!"; line: while () { next line if /^#/; next line if /^$/; next line if /=/; ($host) = split; $wanted{$host} = 1; } open(ruptime,'ruptime|') || die "Can't run ruptime: $!"; open(sort,'|sort +1n'); while () { ($host,$upness,$foo,$users,$foo,$foo,$load) = split(/[\s,]+/); if ($wanted{$host} && $upness eq 'up') { printf sort "%s\t%s (%d)\n", $host, $load, $users; } } (-D\w+)//; if ($opt_v) { $cmd = "Checking $key: cc $M $D $I $src"; $cmd =~ s/\s\s+/ /g; print stderr $cmd,"\n"; } openperl5.000/eg/nih 644 203 12 571 5240611450 6476 eval "exec /usr/bin/perl -Spi.bak $0 $*" if $running_under_some_shell; # $RCSfile: nih,v $$Revision: 4.1 $$Date: 92/08/07 17:20:27 $ # This script makes #! scripts directly executable on machines that don't # support #!. It edits in place any scripts mentioned on the command line. s|^#!(.*)|#!$1\neval "exec $1 -S \$0 \$*"\n\tif \$running_under_some_shell;| if $. == 1; load (u)\n------- --------\n"; open(ghosts,'/etc/ghosts') || die "Can't open /etc/ghosts: $!"; line: while () { next liperl5.000/eg/relink 644 203 12 4143 5576233232 7235 #!/usr/bin/perl 'di'; 'ig00'; # # $RCSfile: relink,v $$Revision: 4.1 $$Date: 92/08/07 17:20:29 $ # # $Log: relink,v $ ($op = shift) || die "Usage: relink perlexpr [filenames]\n"; if (!@ARGV) { @ARGV = ; chop(@ARGV); } for (@ARGV) { next unless -l; # symbolic link? $name = $_; $_ = readlink($_); $was = $_; eval $op; die $@ if $@; if ($was ne $_) { unlink($name); symlink($_, $name); } } ############################################################################## # These next few lines are legal in both Perl and nroff. .00; # finish .ig 'di \" finish diversion--previous line must be blank .nr nl 0-1 \" fake up transition to first page again .nr % 0 \" start at page 1 ';<<'.ex'; #__END__ ############# From here on it's a standard manual page ############ .TH RELINK 1 "July 30, 1990" .AT 3 .SH LINK relink \- relinks multiple symbolic links .SH SYNOPSIS .B relink perlexpr [symlinknames] .SH DESCRIPTION .I Relink relinks the symbolic links given according to the rule specified as the first argument. The argument is a Perl expression which is expected to modify the $_ string in Perl for at least some of the names specified. For each symbolic link named on the command line, the Perl expression will be executed on the contents of the symbolic link with that name. If a given symbolic link's contents is not modified by the expression, it will not be changed. If a name given on the command line is not a symbolic link, it will be ignored. If no names are given on the command line, names will be read via standard input. .PP For example, to relink all symbolic links in the current directory pointing to somewhere in X11R3 so that they point to X11R4, you might say .nf relink 's/X11R3/X11R4/' * .fi To change all occurences of links in the system from /usr/spool to /var/spool, you'd say .nf find / -type l -print | relink 's#/usr/spool#/var/spool#' .fi .SH ENVIRONMENT No environment variables are used. .SH FILES .SH AUTHOR Larry Wall .SH "SEE ALSO" ln(1) .br perl(1) .SH DIAGNOSTICS If you give an invalid Perl expression you'll get a syntax error. .SH BUGS .ex t unless /^\t/; chop; chop($_ = $_ . <$MF>) while s/\\$//; next if /^#/; last if /^$/; s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg; s/\$\((\w+)\)/$mac{$1}/eg; $action .= $_; } foreach $targ (split(' ',$left)) { $targ =~ s|^\./||; foreach $src (split(' ',$right)) { $src =~ s|^\./||; $deplist{$targ} .= ' ' . $src; $dep{"$targ: $src"} = 1; $o{$srcperl5.000/eg/rename 755 203 12 3332 5576233237 7227 #!/usr/bin/perl 'di'; 'ig00'; # # $RCSfile: rename,v $$Revision: 4.1 $$Date: 92/08/07 17:20:30 $ # # $Log: rename,v $ ($op = shift) || die "Usage: rename perlexpr [filenames]\n"; if (!@ARGV) { @ARGV = ; chop(@ARGV); } for (@ARGV) { $was = $_; eval $op; die $@ if $@; rename($was,$_) unless $was eq $_; } ############################################################################## # These next few lines are legal in both Perl and nroff. .00; # finish .ig 'di \" finish diversion--previous line must be blank .nr nl 0-1 \" fake up transition to first page again .nr % 0 \" start at page 1 ';<<'.ex'; #__END__ ############# From here on it's a standard manual page ############ .TH RENAME 1 "July 30, 1990" .AT 3 .SH NAME rename \- renames multiple files .SH SYNOPSIS .B rename perlexpr [files] .SH DESCRIPTION .I Rename renames the filenames supplied according to the rule specified as the first argument. The argument is a Perl expression which is expected to modify the $_ string in Perl for at least some of the filenames specified. If a given filename is not modified by the expression, it will not be renamed. If no filenames are given on the command line, filenames will be read via standard input. .PP For example, to rename all files matching *.bak to strip the extension, you might say .nf rename 's/\e.bak$//' *.bak .fi To translate uppercase names to lower, you'd use .nf rename 'y/A-Z/a-z/' * .fi .SH ENVIRONMENT No environment variables are used. .SH FILES .SH AUTHOR Larry Wall .SH "SEE ALSO" mv(1) .br perl(1) .SH DIAGNOSTICS If you give an invalid Perl expression you'll get a syntax error. .SH BUGS .I Rename does not check for the existence of target filenames, so use with care. .ex 's/X11R3/X11R4/' * .fi To change all occurences of links in the system from /usr/spool to /var/spool, you'd say .nf find / -type l -print | relink 's#/usr/spool#/var/spool#' .fi .SH ENVIRONMENT No environment variables are used. .SH FILES .SH AUTHOR Larry Wall .SH "SEE ALSO" ln(1) .br perlperl5.000/eg/rmfrom 644 203 12 246 5240611454 7225 #!/usr/bin/perl -n # $RCSfile: rmfrom,v $$Revision: 4.1 $$Date: 92/08/07 17:20:31 $ # A handy (but dangerous) script to put after a find ... -print. chop; unlink; „vanœÎ~whoÎwrapsuid@ARGV); } for (@ARGV) { $was = $_; eval $op; die $@ if $@; rename($was,$_) unless $was eq $_; } ############################################################################## # These next few lines are legal in both Perl and nroff. .00; # finish .ig 'di \" finishperl5.000/eg/scan/ 775 203 12 0 5650575655 6700 perl5.000/eg/scan/scan_df 644 203 12 2477 5240611456 10276 #!/usr/bin/perl -P # $RCSfile: scan_df,v $$Revision: 4.1 $$Date: 92/08/07 17:20:33 $ # This report points out filesystems that are in danger of overflowing. (chdir '/usr/adm/private/memories') || die "Can't cd to memories: $!\n"; `df >newdf`; open(Df, 'olddf'); while () { ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split; next if $fs =~ /:/; next if $fs eq ''; $oldused{$fs} = $used; } open(Df, 'newdf') || die "scan_df: can't open newdf"; while () { ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split; next if $fs =~ /:/; next if $fs eq ''; $oldused = $oldused{$fs}; next if ($oldused == $used && $capacity < 99); # inactive filesystem if ($capacity >= 90) { #if defined(mc300) || defined(mc500) || defined(mc700) $_ = substr($_,0,13) . ' ' . substr($_,13,1000); $kbytes /= 2; # translate blocks to K $used /= 2; $oldused /= 2; $avail /= 2; #endif $diff = int($used - $oldused); if ($avail < $diff * 2) { # mark specially if in danger $mounted_on .= ' *'; } next if $diff < 50 && $mounted_on eq '/'; $fs =~ s|/dev/||; if ($diff >= 0) { $diff = '(+' . $diff . ')'; } else { $diff = '(' . $diff . ')'; } printf "%-8s%8d%8d %-8s%8d%7s %s\n", $fs,$kbytes,$used,$diff,$avail,$capacity,$mounted_on; } } rename('newdf','olddf'); f rename 's/\e.bak$//' *.bak .fi To translate uppercase names to lower, you'd use .nf rename 'y/A-Z/a-z/' * .fi .SH ENVIRONMENT No environment variables are used. .SH FILES .SH AUTHOR Larperl5.000/eg/scan/scan_last 644 203 12 2433 5240611460 10633 #!/usr/bin/perl -P # $RCSfile: scan_last,v $$Revision: 4.1 $$Date: 92/08/07 17:20:35 $ # This reports who was logged on at weird hours ($dy, $mo, $lastdt) = split(/ +/,`date`); open(Last, 'exec last 2>&1 |') || die "scan_last: can't run last"; while () { #if defined(mc300) || defined(mc500) || defined(mc700) $_ = substr($_,0,19) . substr($_,23,100); #endif next if /^$/; (print),next if m|^/|; $login = substr($_,0,8); $tty = substr($_,10,7); $from = substr($_,19,15); $day = substr($_,36,3); $mo = substr($_,40,3); $dt = substr($_,44,2); $hr = substr($_,47,2); $min = substr($_,50,2); $dash = substr($_,53,1); $tohr = substr($_,55,2); $tomin = substr($_,58,2); $durhr = substr($_,63,2); $durmin = substr($_,66,2); next unless $hr; next if $login eq 'reboot '; next if $login eq 'shutdown'; if ($dt != $lastdt) { if ($lastdt < $dt) { $seen += $dt - $lastdt; } else { $seen++; } $lastdt = $dt; } $inat = $hr + $min / 60; if ($tohr =~ /^[a-z]/) { $outat = 12; # something innocuous } else { $outat = $tohr + $tomin / 60; } last if $seen + ($inat < 8) > 1; if ($inat < 5 || $inat > 21 || $outat < 6 || $outat > 23) { print; } } ; } } rename('newdf','olddf'); f rename 's/\e.bak$//' *.bak .fi To translate uppercase names to lower, you'd use .nf rename 'y/A-Z/a-z/' * .fi .SH ENVIRONMENT No environment variables are used. .SH FILES .SH AUTHOR Larperl5.000/eg/scan/scan_messages 644 203 12 11727 5240611461 11526 #!/usr/bin/perl -P # $RCSfile: scan_messages,v $$Revision: 4.1 $$Date: 92/08/07 17:20:37 $ # This prints out extraordinary console messages. You'll need to customize. chdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n"; $maxpos = `cat oldmsgs 2>&1`; #if defined(mc300) || defined(mc500) || defined(mc700) open(Msgs, '/dev/null') || die "scan_messages: can't open messages"; #else open(Msgs, '/usr/adm/messages') || die "scan_messages: can't open messages"; #endif ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat(Msgs); if ($size < $maxpos) { # Did somebody truncate messages file? $maxpos = 0; } seek(Msgs,$maxpos,0); # Start where we left off last time. while () { s/\[(\d+)\]/#/ && s/$1/#/g; #ifdef vax $_ =~ s/[A-Z][a-z][a-z] +\w+ +[0-9:]+ +\w+ +//; next if /root@.*:/; next if /^vmunix: 4.3 BSD UNIX/; next if /^vmunix: Copyright/; next if /^vmunix: avail mem =/; next if /^vmunix: SBIA0 at /; next if /^vmunix: disk ra81 is/; next if /^vmunix: dmf. at uba/; next if /^vmunix: dmf.:.*asynch/; next if /^vmunix: ex. at uba/; next if /^vmunix: ex.: HW/; next if /^vmunix: il. at uba/; next if /^vmunix: il.: hardware/; next if /^vmunix: ra. at uba/; next if /^vmunix: ra.: media/; next if /^vmunix: real mem/; next if /^vmunix: syncing disks/; next if /^vmunix: tms/; next if /^vmunix: tmscp. at uba/; next if /^vmunix: uba. at /; next if /^vmunix: uda. at /; next if /^vmunix: uda.: unit . ONLIN/; next if /^vmunix: .*buffers containing/; next if /^syslogd: .*newslog/; #endif next if /unknown service/; next if /^\.\.\.$/; if (/^[A-Z][a-z][a-z] [ 0-9][0-9] [ 0-9][0-9]:[0-9][0-9]/) { $pfx = ''; next; } next if /^[ \t]*$/; next if /^[ 0-9]*done$/; if (/^A/) { next if /^Accounting [sr]/; } elsif (/^C/) { next if /^Called from/; next if /^Copyright/; } elsif (/^E/) { next if /^End traceback/; next if /^Ethernet address =/; } elsif (/^K/) { next if /^KERNEL MODE/; } elsif (/^R/) { next if /^Rebooting Unix/; } elsif (/^S/) { next if /^Sun UNIX 4\.2 Release/; } elsif (/^W/) { next if /^WARNING: clock gained/; } elsif (/^a/) { next if /^arg /; next if /^avail mem =/; } elsif (/^b/) { next if /^bwtwo[0-9] at /; } elsif (/^c/) { next if /^cgone[0-9] at /; next if /^cdp[0-9] at /; next if /^csr /; } elsif (/^d/) { next if /^dcpa: init/; next if /^done$/; next if /^dts/; next if /^dump i\/o error/; next if /^dumping to dev/; next if /^dump succeeded/; $pfx = '*' if /^dev = /; } elsif (/^e/) { next if /^end \*\*/; next if /^error in copy/; } elsif (/^f/) { next if /^found /; } elsif (/^i/) { next if /^ib[0-9] at /; next if /^ie[0-9] at /; } elsif (/^l/) { next if /^le[0-9] at /; } elsif (/^m/) { next if /^mem = /; next if /^mt[0-9] at /; next if /^mti[0-9] at /; $pfx = '*' if /^mode = /; } elsif (/^n/) { next if /^not found /; } elsif (/^p/) { next if /^page map /; next if /^pi[0-9] at /; $pfx = '*' if /^panic/; } elsif (/^q/) { next if /^qqq /; } elsif (/^r/) { next if /^read /; next if /^revarp: Requesting/; next if /^root [od]/; } elsif (/^s/) { next if /^sc[0-9] at /; next if /^sd[0-9] at /; next if /^sd[0-9]: oldmsgs.tmp') || die "Can't create tmp file: $!\n"; while ($_ = pop(@seen)) { print tmp $_; } close(tmp); open(tmp,'oldmsgs.tmp') || die "Can't reopen tmp file: $!\n"; while () { if (/^nd:/) { next if $seen{$_} < 20; } if (/NFS/) { next if $seen{$_} < 20; } if (/no carrier/) { next if $seen{$_} < 20; } if (/silo overflow/) { next if $seen{$_} < 20; } print $seen{$_},":\t",$_; } print `rm -f oldmsgs.tmp 2>&1; echo $max > oldmsgs 2>&1`; next if /^vmunix: SBIA0 at /; next perl5.000/eg/scan/scan_passwd 644 203 12 1323 5240611463 11171 #!/usr/bin/perl # $RCSfile: scan_passwd,v $$Revision: 4.1 $$Date: 92/08/07 17:20:38 $ # This scans passwd file for security holes. open(Pass,'/etc/passwd') || die "Can't open passwd file: $!\n"; # $dotriv = (`date` =~ /^Mon/); $dotriv = 1; while () { ($login,$pass,$uid,$gid,$gcos,$home,$shell) = split(/:/); if ($shell eq '') { print "Short: $_"; } next if /^[+]/; if ($pass eq '') { if (index(":sync:lpq:+:", ":$login:") < 0) { print "No pass: $login\t$gcos\n"; } } elsif ($dotriv && crypt($login,substr($pass,0,2)) eq $pass) { print "Trivial: $login\t$gcos\n"; } if ($uid == 0) { if ($login !~ /^.?root$/ && $pass ne '*') { print "Extra root: $_"; } } } ; } if (/NFS/) { next if $seen{$_} < 20; } if (/no carrier/) { next if $seen{$_} < 20; } if (/silo overflow/) { next if $seen{$_} < 20; } print $seen{$_},":\t",$_; } print `rm -f oldmsgs.tmp 2>&1; echo $max > oldmsgs 2>&1`; next if /^vmunix: SBIA0 at /; next perl5.000/eg/scan/scan_ps 644 203 12 1364 5240611465 10321 #!/usr/bin/perl -P # $RCSfile: scan_ps,v $$Revision: 4.1 $$Date: 92/08/07 17:20:40 $ # This looks for looping processes. #if defined(mc300) || defined(mc500) || defined(mc700) open(Ps, '/bin/ps -el|') || die "scan_ps: can't run ps"; while () { next if /rwhod/; print if index(' T', substr($_,62,1)) < 0; } #else open(Ps, '/bin/ps auxww|') || die "scan_ps: can't run ps"; while () { next if /dataserver/; next if /nfsd/; next if /update/; next if /ypserv/; next if /rwhod/; next if /routed/; next if /pagedaemon/; #ifdef vax ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$start,$time) = split; #else ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$time) = split; #endif print if length($time) > 4; } #endif $seen{$_} < 20; } if (/no carrier/) { next if $seen{$_} < 20; } if (/silo overflow/) { next if $seen{$_} < 20; } print $seen{$_},":\t",$_; } print `rm -f oldmsgs.tmp 2>&1; echo $max > oldmsgs 2>&1`; next if /^vmunix: SBIA0 at /; next perl5.000/eg/scan/scan_sudo 644 203 12 2114 5240611466 10644 #!/usr/bin/perl -P # $RCSfile: scan_sudo,v $$Revision: 4.1 $$Date: 92/08/07 17:20:42 $ # Analyze the sudo log. chdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n"; if (open(Oldsudo,'oldsudo')) { $maxpos = ; close Oldsudo; } else { $maxpos = 0; `echo 0 >oldsudo`; } unless (open(Sudo, '/usr/adm/sudo.log')) { print "Somebody removed sudo.log!!!\n" if $maxpos; exit 0; } ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat(Sudo); if ($size < $maxpos) { $maxpos = 0; print "Somebody reset sudo.log!!!\n"; } seek(Sudo,$maxpos,0); while () { s/^.* :[ \t]+//; s/ipcrm.*/ipcrm/; s/kill.*/kill/; unless ($seen{$_}++) { push(@seen,$_); } $last = $_; } $max = tell(Sudo); open(tmp,'|sort >oldsudo.tmp') || die "Can't create tmp file: $!\n"; while ($_ = pop(@seen)) { print tmp $_; } close(tmp); open(tmp,'oldsudo.tmp') || die "Can't reopen tmp file: $!\n"; while () { print $seen{$_},":\t",$_; } print `(rm -f oldsudo.tmp; echo $max > oldsudo) 2>&1`; /^vmunix: dmf.:.*asynch/; next if /^vmunix: ex. at uba/; next if /^vmunix: ex.: HW/; next if /^vmunix: il. at uba/; next if /^vmunix: il.: hardware/; next if /^vmunix: ra. at uba/; next if /^vmunix: ra.: media/; next if /^vmunix: real mem/; next if /^vmunix: syncing disks/; next if /^vmunix: tms/; next if /^vmunix: tmscp. at uba/; next if /^vmunix: uba. at /; next if /^vmunix: uda. at perl5.000/eg/scan/scan_suid 644 203 12 4242 5240611467 10643 #!/usr/bin/perl -P # $RCSfile: scan_suid,v $$Revision: 4.1 $$Date: 92/08/07 17:20:43 $ # Look for new setuid root files. chdir '/usr/adm/private/memories' || die "Can't cd to memories: $!\n"; ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('oldsuid'); if ($nlink) { $lasttime = $mtime; $tmp = $ctime - $atime; if ($tmp <= 0 || $tmp >= 10) { print "WARNING: somebody has read oldsuid!\n"; } $tmp = $ctime - $mtime; if ($tmp <= 0 || $tmp >= 10) { print "WARNING: somebody has modified oldsuid!!!\n"; } } else { $lasttime = time - 60 * 60 * 24; # one day ago } $thistime = time; #if defined(mc300) || defined(mc500) || defined(mc700) open(Find, 'find / -perm -04000 -print |') || die "scan_find: can't run find"; #else open(Find, 'find / \( -fstype nfs -prune \) -o -perm -04000 -ls |') || die "scan_find: can't run find"; #endif open(suid, '>newsuid.tmp'); while () { #if defined(mc300) || defined(mc500) || defined(mc700) $x = `/bin/ls -il $_`; $_ = $x; s/^ *//; ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) = split; #else s/^ *//; ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) = split; #endif if ($perm =~ /[sS]/ && $owner eq 'root') { ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($name); $foo = sprintf("%10s%3s %-8s %-8s%9s %3s %2s %s %s\n", $perm,$links,$owner,$group,$size,$month,$day,$name,$inode); print suid $foo; if ($ctime > $lasttime) { if ($ctime > $thistime) { print "Future file: $foo"; } else { $ct .= $foo; } } } } close(suid); print `sort +7 -8 newsuid.tmp >newsuid 2>&1`; $foo = `/bin/diff oldsuid newsuid 2>&1`; print "Differences in suid info:\n",$foo if $foo; print `mv oldsuid oldoldsuid 2>&1; mv newsuid oldsuid 2>&1`; print `touch oldsuid 2>&1;sleep 2 2>&1;chmod o+w oldsuid 2>&1`; print `rm -f newsuid.tmp 2>&1`; @ct = split(/\n/,$ct); $ct = ''; $* = 1; while ($#ct >= 0) { $tmp = shift(@ct); unless ($foo =~ "^>.*$tmp\n") { $ct .= "$tmp\n"; } } print "Inode changed since last time:\n",$ct if $ct; (mc300) || defined(mc500) || defined(mc700) open(Find, 'find / -perm -04000 -print |') || die "scan_find: can't run find"; #else open(Find, 'find / \( -fstype nfs -prune \) -o -perm -04000 -ls |') || die "scan_find: can't run find"; #endif open(suid, '>newsuid.tmp'); while () { #if defined(mc300) || defined(mc500) || defined(mc700) $perl5.000/eg/scan/scanner 644 203 12 4060 5240611470 10314 #!/usr/bin/perl # $RCSfile: scanner,v $$Revision: 4.1 $$Date: 92/08/07 17:20:44 $ # This runs all the scan_* routines on all the machines in /etc/ghosts. # We run this every morning at about 6 am: # !/bin/sh # cd /usr/adm/private # decrypt scanner | perl >scan.out 2>&1 # mail admin = 0) { @scanlist = @ARGV; } else { @scanlist = split(/[ \t\n]+/,`echo scan_*`); } scan: while ($scan = shift(@scanlist)) { print "\n********** $scan **********\n"; $showhost++; $systype = 'all'; open(ghosts, '/etc/ghosts') || die 'No /etc/ghosts file'; $one_of_these = ":$systype:"; if ($systype =~ s/\+/[+]/g) { $one_of_these =~ s/\+/:/g; } line: while () { s/[ \t]*\n//; if (!$_ || /^#/) { next line; } if (/^([a-zA-Z_0-9]+)=(.+)/) { $name = $1; $repl = $2; $repl =~ s/\+/:/g; $one_of_these =~ s/:$name:/:$repl:/; next line; } @gh = split; $host = $gh[0]; if ($showhost) { $showhost = "$host:\t"; } class: while ($class = pop(gh)) { if (index($one_of_these,":$class:") >=0) { $iter = 0; `exec crypt -inquire <$scan >.x 2>/dev/null`; unless (open(scan,'.x')) { print "Can't run $scan: $!\n"; next scan; } $cmd = ; unless ($cmd =~ s/#!(.*)\n/$1/) { $cmd = '/usr/bin/perl'; } close(scan); if (open(PIPE,"exec rsh $host '$cmd' <.x|")) { sleep(5); unlink '.x'; while () { last if $iter++ > 1000; # must be looping next if /^[0-9.]+u [0-9.]+s/; print $showhost,$_; } close(PIPE); } else { print "(Can't execute rsh: $!)\n"; } last class; } } } } ext if /^KERNEL MODE/; } elsif (/^R/) { next if /^Rebooting Unix/; } elsif (/^S/) { next if /^Sun UNIX 4\.2 Release/; } elsif (/^W/) { next if /^WARNING: clock gained/; } elsif (/^a/) { next if /^arg /; next if /^avail mem =/; } elsif (/^b/) { next if /^bwtwo[0-9] at /; } elsif (/^c/) { next if /^cgone[0-9] at /; next if /^cdp[0-9] at /; next if /^csr /; } elsif (/^d/) { next if /^dcpa: init/; perl5.000/eg/server 755 203 12 1073 5240621251 7247 #!./perl $pat = 'S n C4 x8'; $inet = 2; $echo = 7; $smtp = 25; $nntp = 119; $this = pack($pat,$inet,2345, 0,0,0,0); select(NS); $| = 1; select(stdout); if (socket(S,2,1,6)) { print "socket ok\n"; } else { die $!; } if (bind(S,$this)) { print "bind ok\n"; } else { die $!; } if (listen(S,5)) { print "listen ok\n"; } else { die $!; } for (;;) { print "Listening again\n"; if ($addr = accept(NS,S)) { print "accept ok\n"; } else { die $!; } @ary = unpack($pat,$addr); $, = ' '; print @ary; print "\n"; while () { print; print NS; } } usr/ucb:.'; $| = 1; # command buffering on stdout print "Subject: bizarre happenings\n\n"; (chdir '/usr/adm/private') || die "Can't cd to /usr/adm/private: $!\n"; if ($#ARGV >= 0) { @scanlist = @ARGV; } else { @scanlist = split(/[ \t\n]+/,`echo scan_*`); } scan: while ($scan = shift(@scanlist)) { print "\n********** $scan **********\n"; $showhost++; $systype = 'all'; open(ghosts, '/etc/ghosts') || die 'No /etc/ghosts perl5.000/eg/shmkill 644 203 12 1116 5240611471 7402 #!/usr/bin/perl # $RCSfile: shmkill,v $$Revision: 4.1 $$Date: 92/08/07 17:20:45 $ # A script to call from crontab periodically when people are leaving shared # memory sitting around unattached. open(ipcs,'ipcs -m -o|') || die "Can't run ipcs: $!"; while () { $tmp = index($_,'NATTCH'); $pos = $tmp if $tmp >= 0; if (/^m/) { ($m,$id,$key,$mode,$owner,$group,$attach) = split; if ($attach != substr($_,$pos,6)) { die "Different ipcs format--can't parse!\n"; } if ($attach == 0) { push(@goners,'-m',$id); } } } exec 'ipcrm', @goners if $#goners >= 0; ; # command buffering on stdout print "Subject: bizarre happenings\n\n"; (chdir '/usr/adm/private') || die "Can't cd to /usr/adm/private: $!\n"; if ($#ARGV >= 0) { @scanlist = @ARGV; } else { @scanlist = split(/[ \t\n]+/,`echo scan_*`); } scan: while ($scan = shift(@scanlist)) { print "\n********** $scan **********\n"; $showhost++; $systype = 'all'; open(ghosts, '/etc/ghosts') || die 'No /etc/ghosts perl5.000/eg/sysvipc/ 775 203 12 0 5650575656 7455 perl5.000/eg/sysvipc/README 644 203 12 475 5240620407 10362 FYEnjoyment, here are the test scripts I used while implementing SysV IPC in Perl. Each of them must be run with the parameter "s" for "send" or "r" for "receive"; in each case, the receiver is the server and the sender is the client. -- Chip Salzenberg at ComDev/TCT , f $tmp >= 0; if (/^m/) { ($m,$id,$key,$mode,$owner,$group,$attach) = split; if ($attach != substr($_,$pos,6)) { die "Different ipcs format--can't parse!\n"; } if ($attach == 0) { perl5.000/eg/sysvipc/ipcmsg 644 203 12 1560 5240620415 10722 #!/usr/bin/perl eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' if 0; require 'sys/ipc.ph'; require 'sys/msg.ph'; $| = 1; $mode = shift; die "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/; $send = ($mode eq "s"); $id = msgget(0x1234, ($send ? 0 : &IPC_CREAT) | 0644); die "Can't get message queue: $!\n" unless defined($id); print "message queue id: $id\n"; if ($send) { while () { chop; unless (msgsnd($id, pack("LA*", $., $_), 0)) { die "Can't send message: $!\n"; } } } else { $SIG{'INT'} = $SIG{'QUIT'} = "leave"; for (;;) { unless (msgrcv($id, $_, 512, 0, 0)) { die "Can't receive message: $!\n"; } ($type, $message) = unpack("La*", $_); printf "[%d] %s\n", $type, $message; } } &leave; sub leave { if (!$send) { $x = msgctl($id, &IPC_RMID, 0); if (!defined($x) || $x < 0) { die "Can't remove message queue: $!\n"; } } exit; } { print "\n********** $scan **********\n"; $showhost++; $systype = 'all'; open(ghosts, '/etc/ghosts') || die 'No /etc/ghosts perl5.000/eg/sysvipc/ipcsem 644 203 12 1532 5240620426 10721 #!/usr/bin/perl eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' if 0; require 'sys/ipc.ph'; require 'sys/msg.ph'; $| = 1; $mode = shift; die "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/; $signal = ($mode eq "s"); $id = semget(0x1234, 1, ($signal ? 0 : &IPC_CREAT) | 0644); die "Can't get semaphore: $!\n" unless defined($id); print "semaphore id: $id\n"; if ($signal) { while () { print "Signalling\n"; unless (semop($id, 0, pack("sss", 0, 1, 0))) { die "Can't signal semaphore: $!\n"; } } } else { $SIG{'INT'} = $SIG{'QUIT'} = "leave"; for (;;) { unless (semop($id, 0, pack("sss", 0, -1, 0))) { die "Can't wait for semaphore: $!\n"; } print "Unblocked\n"; } } &leave; sub leave { if (!$signal) { $x = semctl($id, 0, &IPC_RMID, 0); if (!defined($x) || $x < 0) { die "Can't remove semaphore: $!\n"; } } exit; } !\n"; } } exit; } { print "\n********** $scan **********\n"; $showhost++; $systype = 'all'; open(ghosts, '/etc/ghosts') || die 'No /etc/ghosts perl5.000/eg/sysvipc/ipcshm 644 203 12 1725 5240620433 10726 #!/usr/bin/perl eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' if 0; require 'sys/ipc.ph'; require 'sys/shm.ph'; $| = 1; $mode = shift; die "usage: ipcshm {r|s}\n" unless $mode =~ /^[rs]$/; $send = ($mode eq "s"); $SIZE = 32; $id = shmget(0x1234, $SIZE, ($send ? 0 : &IPC_CREAT) | 0644); die "Can't get shared memory: $!\n" unless defined($id); print "shared memory id: $id\n"; if ($send) { while () { chop; unless (shmwrite($id, pack("La*", length($_), $_), 0, $SIZE)) { die "Can't write to shared memory: $!\n"; } } } else { $SIG{'INT'} = $SIG{'QUIT'} = "leave"; for (;;) { $_ = ; unless (shmread($id, $_, 0, $SIZE)) { die "Can't read shared memory: $!\n"; } $len = unpack("L", $_); $message = substr($_, length(pack("L",0)), $len); printf "[%d] %s\n", $len, $message; } } &leave; sub leave { if (!$send) { $x = shmctl($id, &IPC_RMID, 0); if (!defined($x) || $x < 0) { die "Can't remove shared memory: $!\n"; } } exit; } sts, '/etc/ghosts') || die 'No /etc/ghosts perl5.000/eg/travesty 644 203 12 1403 5240620435 7617 #!/usr/bin/perl while (<>) { next if /^\./; next if /^From / .. /^$/; next if /^Path: / .. /^$/; s/^\W+//; push(@ary,split(' ')); while ($#ary > 1) { $a = $p; $p = $n; $w = shift(@ary); $n = $num{$w}; if ($n eq '') { push(@word,$w); $n = pack('S',$#word); $num{$w} = $n; } $lookup{$a . $p} .= $n; } } for (;;) { $n = $lookup{$a . $p}; ($foo,$n) = each(lookup) if $n eq ''; $n = substr($n,int(rand(length($n))) & 0177776,2); $a = $p; $p = $n; ($w) = unpack('S',$n); $w = $word[$w]; $col += length($w) + 1; if ($col >= 65) { $col = 0; print "\n"; } else { print ' '; } print $w; if ($w =~ /\.$/) { if (rand() < .1) { print "\n"; $col = 80; } } } en); printf "[%d] %s\n", $len, $message; } } &leave; sub leave { if (!$send) { $x = shmctl($id, &IPC_RMID, 0); if (!defined($x) || $x < 0) { die "Can't remove shared memory: $!\n"; } } exit; } sts, '/etc/ghosts') || die 'No /etc/ghosts perl5.000/eg/unuc 775 203 12 5447 5365037726 6746 #!/usr/bin/perl print STDERR "Loading proper nouns...\n"; open(DICT,"/usr/dict/words") || die "Can't find /usr/dict/words: $!\n"; while () { if (/^[A-Z]/) { chop; ($lower = $_) =~ y/A-Z/a-z/; $proper{$lower} = $_; } } close DICT; print STDERR "Loading exceptions...\n"; $prog = <<'EOT'; while (<>) { next if /[a-z]/; y/A-Z/a-z/; s/(\w+)/$proper{$1} ? $proper{$1} : $1/eg; s/^(\s*)([a-z])/$1 . (($tmp = $2) =~ y:a-z:A-Z:,$tmp)/e; s/([-.?!]["']?(\n\s*| \s*)["']?)([a-z])/$1 . (($tmp = $3) =~ y:a-z:A-Z:,$tmp)/eg; s/\b([b-df-hj-np-tv-xz]+)\b/(($tmp = $1) =~ y:a-z:A-Z:,$tmp)/eg; s/([a-z])'([SDT])\b/$1 . "'" . (($tmp = $2) =~ y:A-Z:a-z:,$tmp)/eg; EOT while () { chop; next if /^$/; next if /^#/; if (! /;$/) { $foo = $_; $foo =~ y/A-Z/a-z/; print STDERR "Dup $_\n" if $proper{$foo}; $foo =~ s/([^\w ])/\\$1/g; $foo =~ s/ /(\\s+)/g; $foo = "\\b" . $foo if $foo =~ /^\w/; # XXX till patch 9 $foo .= "\\b" if $foo =~ /\w$/; $i = 0; ($bar = $_) =~ s/ /'$' . ++$i/eg; $_ = "s/$foo/$bar/gi;"; } $prog .= ' ' . $_ . "\n"; } $prog .= "}\ncontinue {\n print;\n}\n"; $/ = ''; #print $prog; eval $prog; die $@ if $@; __END__ A.M. Air Force Air Force Base Air Force Station American Apr. Ariane Aug. August Bureau of Labor Statistics CIT Caltech Cape Canaveral Challenger China Corporation Crippen Daily News in Brief Daniel Quayle Dec. Discovery Edwards Endeavour Feb. Ford Aerospace Fri. General Dynamics George Bush Headline News HOTOL I II III IV IX Institute of Technology JPL Jan. Jul. Jun. Kennedy Space Center LDEF Long Duration Exposure Facility Long March Mar. March Martin Martin Marietta Mercury Mon. in May s/\bmay (\d)/May $1/g; s/\boffice of (\w)/'Office of ' . (($tmp = $1) =~ y:a-z:A-Z:,$tmp)/eg; National Science Foundation NASA Select New Mexico Nov. OMB Oct. Office of Management and Budget President President Bush Richard Truly Rocketdyne Russian Russians Sat. Sep. Soviet Soviet Union Soviets Space Shuttle Sun. Thu. Tue. U.S. Union of Soviet Socialist Republics United States VI VII VIII Vice President Vice President Quayle Wed. White Sands Kaman Aerospace Aerospace Daily Aviation Week Space Technology Washington Post Los Angeles Times New York Times Aerospace Industries Association president of Johnson Space Center Space Services Inc. Co. Hughes Aircraft Company Orbital Sciences Swedish Space Arnauld Nicogosian Magellan Galileo Mir Jet Propulsion Laboratory University Department of Defense Orbital Science OMS United Press International United Press UPI Associated Press AP Cable News Network Cape York Zenit SYNCOM Eastern Western Test Range Jcsat Japanese Satellite Communications Defence Ministry Defense Ministry Skynet Fixed Service Structure Launch Processing System Asiasat Launch Control Center Earth CNES Glavkosmos Pacific Atlantic p(5); unlink '.x'; while () { last if $iter++ > 1000; # must be looping next if /^[0-9.]+u [0-9.]+s/; print $showhost,$_; } close(PIPE); } else { print "(Can't execute rperl5.000/eg/uudecode 664 203 12 640 5452070536 7525 #!/usr/bin/perl while (<>) { next unless ($mode,$file) = /^begin\s*(\d*)\s*(\S*)/; open(OUT,"> $file") || die "Can't create $file: $!\n"; while (<>) { last if /^end/; next if /[a-z]/; next unless int((((ord() - 32) & 077) + 2) / 3) == int(length() / 4); print OUT unpack("u", $_); } chmod oct($mode), $file; eof() && die "Missing end: $file may be truncated.\n"; } vour Feb. Ford Aerospace Fri. General Dynamics George Bush Headline News HOTOL I II III IV IX Inperl5.000/eg/van/ 775 203 12 0 5650575656 6541 perl5.000/eg/van/empty 644 203 12 1431 5240611477 7667 #!/usr/bin/perl # $RCSfile: empty,v $$Revision: 4.1 $$Date: 92/08/07 17:20:50 $ # This script empties a trashcan. $recursive = shift if $ARGV[0] eq '-r'; @ARGV = '.' if $#ARGV < 0; chop($pwd = `pwd`); dir: foreach $dir (@ARGV) { unless (chdir $dir) { print stderr "Can't find directory $dir: $!\n"; next dir; } if ($recursive) { do cmd('find . -name .deleted -exec /bin/rm -rf {} ;'); } else { if (-d '.deleted') { do cmd('rm -rf .deleted'); } else { if ($dir eq '.' && $pwd =~ m|/\.deleted$|) { chdir '..'; do cmd('rm -rf .deleted'); } else { print stderr "No trashcan found in directory $dir\n"; } } } } continue { chdir $pwd; } # force direct execution with no shell sub cmd { system split(' ',join(' ',@_)); } tion NASA Select New Mexico Nov. OMB Oct. Office of Management and Budget President President Bush Richard Truly Rocketdyne Russian Russians Sat. Sep. Soviet Soviet Union Soviets Space Shuttle Sun. Thu. Tue. U.S. Union of Soviet Soperl5.000/eg/van/unvanish 644 203 12 2531 5240611500 10351 #!/usr/bin/perl # $RCSfile: unvanish,v $$Revision: 4.1 $$Date: 92/08/07 17:20:52 $ sub it { if ($olddir ne '.') { chop($pwd = `pwd`) if $pwd eq ''; (chdir $olddir) || die "Directory $olddir is not accesible"; } unless ($olddir eq '.deleted') { if (-d '.deleted') { chdir '.deleted' || die "Directory .deleted is not accesible"; } else { chop($pwd = `pwd`) if $pwd eq ''; die "Directory .deleted does not exist" unless $pwd =~ /\.deleted$/; } } print `mv $startfiles$filelist..$force`; if ($olddir ne '.') { (chdir $pwd) || die "Can't get back to original directory $pwd: $!\n"; } } if ($#ARGV < 0) { open(lastcmd,'.deleted/.lastcmd') || open(lastcmd,'.lastcmd') || die "No previous vanish in this dir"; $ARGV = ; close(lastcmd); @ARGV = split(/[\n ]+/,$ARGV); } while ($ARGV[0] =~ /^-/) { $_ = shift; /^-f/ && ($force = ' >/dev/null 2>&1'); /^-i/ && ($interactive = 1); if (/^-+$/) { $startfiles = '- '; last; } } while ($file = shift) { if ($file =~ s|^(.*)/||) { $dir = $1; } else { $dir = '.'; } if ($dir ne $olddir) { do it() if $olddir; $olddir = $dir; } if ($interactive) { print "unvanish: restore $dir/$file? "; next unless =~ /^y/i; } $filelist .= $file; $filelist .= ' '; } do it() if $olddir; dish Space Arnauld Nicogosian Magellan Galileo Mir Jet Propulsion Laboratory University Department of Defense Orbital Science OMS United Press International United Preperl5.000/eg/van/vanexp 644 203 12 703 5240611501 7777 #!/usr/bin/perl # $RCSfile: vanexp,v $$Revision: 4.1 $$Date: 92/08/07 17:20:53 $ # This is for running from a find at night to expire old .deleteds $can = $ARGV[0]; exit 1 unless $can =~ /.deleted$/; ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($can); exit 0 unless $size; if (time - $mtime > 2 * 24 * 60 * 60) { `/bin/rm -rf $can`; } else { `find $can -ctime +2 -exec rm -f {} \;`; } $pwd =~ /\.deleted$/; } } print `mv $startfiles$filperl5.000/eg/van/vanish 644 203 12 2502 5240611502 10006 #!/usr/bin/perl # $RCSfile: vanish,v $$Revision: 4.1 $$Date: 92/08/07 17:20:54 $ sub it { if ($olddir ne '.') { chop($pwd = `pwd`) if $pwd eq ''; (chdir $olddir) || die "Directory $olddir is not accesible"; } if (!-d .deleted) { print `mkdir .deleted; chmod 775 .deleted`; die "You can't remove files from $olddir" if $?; } $filelist =~ s/ $//; $filelist =~ s/#/\\#/g; if ($filelist !~ /^[ \t]*$/) { open(lastcmd,'>.deleted/.lastcmd'); print lastcmd $filelist,"\n"; close(lastcmd); print `/bin/mv $startfiles$filelist .deleted$force`; } if ($olddir ne '.') { (chdir $pwd) || die "Can't get back to original directory $pwd: $!\n"; } } while ($ARGV[0] =~ /^-/) { $_ = shift; /^-f/ && ($force = ' >/dev/null 2>&1'); /^-i/ && ($interactive = 1); if (/^-+$/) { $startfiles = '- '; last; } } chop($pwd = `pwd`); while ($file = shift) { if ($file =~ s|^(.*)/||) { $dir = $1; } else { $dir = '.'; } if ($interactive) { print "vanish: remove $dir/$file? "; next unless =~ /^y/i; } if ($file eq '.deleted') { print stderr "To delete .deleted (the trashcan) use the 'empty' command.\n"; next; } if ($dir ne $olddir) { do it() if $olddir; $olddir = $dir; } $filelist .= $file; $filelist .= ' '; } do it() if $olddir; } do it() if $olddir; dish Space Arnauld Nicogosian Magellan Galileo Mir Jet Propulsion Laboratory University Department of Defense Orbital Science OMS United Press International United Preperl5.000/eg/who 644 203 12 670 5240611503 6514 #!/usr/bin/perl # This assumes your /etc/utmp file looks like ours open(UTMP,'/etc/utmp'); @mo = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec); while (read(UTMP,$utmp,36)) { ($line,$name,$host,$time) = unpack('A8A8A16l',$utmp); if ($name) { $host = "($host)" if ord($host); ($sec,$min,$hour,$mday,$mon) = localtime($time); printf "%-9s%-8s%s %2d %02d:%02d %s\n", $name,$line,$mo[$mon],$mday,$hour,$min,$host; } } lastcmd,'>.deleted/.lastcmd'); print lastcmd $filelist,"\n"; close(lasperl5.000/eg/wrapsuid 775 203 12 5304 5644042724 7614 #!/usr/bin/perl 'di'; 'ig00'; # # $Header: wrapsuid,v 1.1 90/08/11 13:51:29 lwall Locked $ # # $Log: wrapsuid,v $ # Revision 1.1 90/08/11 13:51:29 lwall # Initial revision # $xdev = '-xdev' unless -d '/dev/iop'; if ($#ARGV >= 0) { @list = @ARGV; foreach $name (@ARGV) { die "You must use absolute pathnames.\n" unless $name =~ m|^/|; } } else { open(DF,"/etc/mount|") || die "Can't run /etc/mount"; while () { chop; $_ .= if length($_) < 50; @ary = split; push(@list,$ary[2]) if ($ary[0] =~ m|^/dev|); } } $fslist = join(' ',@list); die "Can't find local filesystems" unless $fslist; open(FIND, "find $fslist $xdev -type f \\( -perm -04000 -o -perm -02000 \\) -print|"); while () { chop; next unless -T; print "Fixing ", $_, "\n"; ($dir,$file) = m|(.*)/(.*)|; chdir $dir || die "Can't chdir to $dir"; ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($file); die "Can't stat $_" unless $ino; chmod $mode & 01777, $file; # wipe out set[ug]id bits rename($file,".$file"); open(C,">.tmp$$.c") || die "Can't write C program for $_"; $real = "$dir/.$file"; print C ' main(argc,argv) int argc; char **argv; { execv("' . $real . '",argv); } '; close C; system '/bin/cc', ".tmp$$.c", '-o', $file; die "Can't compile new $_" if $?; chmod $mode, $file; chown $uid, $gid, $file; unlink ".tmp$$.c"; chdir '/'; } ############################################################################## # These next few lines are legal in both Perl and nroff. .00; # finish .ig 'di \" finish diversion--previous line must be blank .nr nl 0-1 \" fake up transition to first page again .nr % 0 \" start at page 1 '; __END__ ############# From here on it's a standard manual page ############ .TH SUIDSCRIPT 1 "July 30, 1990" .AT 3 .SH NAME wrapsuid \- puts a compiled C wrapper around a setuid or setgid script .SH SYNOPSIS .B wrapsuid [dirlist] .SH DESCRIPTION .I Wrapsuid creates a small C program to execute a script with setuid or setgid privileges without having to set the setuid or setgid bit on the script, which is a security problem on many machines. Specify the list of directories or files that you wish to process. The names must be absolute pathnames. With no arguments it will attempt to process all the local directories for this machine. The scripts to be processed must have the setuid or setgid bit set. The wrapsuid program will delete the bits and set them on the wrapper. .PP Non-superusers may only process their own files. .SH ENVIRONMENT No environment variables are used. .SH FILES None. .SH AUTHOR Larry Wall .SH "SEE ALSO" .SH DIAGNOSTICS .SH BUGS .ex xt if /^error in copy/; } elsif (/^f/) { next if /^found /; } elsif (/^i/) { next if /^ib[0-9] at /; next if /^ie[0-9] at /; } elsif (/^l/) { next if /^le[0-9] at /; } elsif (/^m/) { next if /^mem = /; next if /^mt[0-9] at /; next if /^mti[0-9] at /; $pfx = '*' if /^mode = /;perl5.000/emacs/ 775 203 12 0 5650575660 6445 perl5.000/emacs/cperl-mode 664 203 12 64121 5461704261 10517 Article 15212 of comp.lang.perl: Path: netlabs!news.cerf.net!usc!howland.reston.ans.net!spool.mu.edu!umn.edu!news-feed-2.peachnet.edu!concert!duke!khera From: khera@cs.duke.edu (Vivek Khera) Newsgroups: comp.lang.perl Subject: cperl-mode.el Message-ID: Date: 21 Oct 93 18:08:51 GMT Sender: news@duke.cs.duke.edu Organization: Duke University CS Dept., Durham, NC Lines: 694 Nntp-Posting-Host: thneed.cs.duke.edu X-Md4-Signature: 40dd9bccfb99794a9da2ee891b5bf557 X-Md5-Signature: e4baa8cf00c94092ebf9712514e4696b Since I've received requests to do so, I'm posting the cperl-mode.el file. This allows Emacs (both version 18 and 19) to do nice things when editing Perl code. Indentation works well, and it doesn't get confused like the perl-mode.el that comes with Emacs 19. Install this file as cperl-mode.el, and add the following to your .emacs file: (autoload 'perl-mode "cperl-mode" "alternate mode for editing Perl programs" t) This cperl-mode.el is not exactly the same as when it was originally posted here. I made the following changes: perl-mode is an alias for cperl-mode, and the major mode name is perl-mode, not cperl-mode. This is so it is easier to use with Emacs 19. I suppose one could install this as perl-mode.el and then not have to put the autoload line in (for Emacs 19). Anyway, I'm not maintaining this, so don't send me bugs. --cut here-- ;;; From: olson@mcs.anl.gov (Bob Olson) ;;; Newsgroups: comp.lang.perl ;;; Subject: cperl-mode: Another perl mode for Gnuemacs ;;; Date: 14 Aug 91 15:20:01 GMT ;; Perl code editing commands for Emacs ;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY. No author or distributor ;; accepts responsibility to anyone for the consequences of using it ;; or for whether it serves any particular purpose or works at all, ;; unless he says so in writing. Refer to the GNU Emacs General Public ;; License for full details. ;; Everyone is granted permission to copy, modify and redistribute ;; GNU Emacs, but only under the conditions described in the ;; GNU Emacs General Public License. A copy of this license is ;; supposed to have been given to you along with GNU Emacs so you ;; can know your rights and responsibilities. It should be in a ;; file named COPYING. Among other things, the copyright notice ;; and this notice must be preserved on all copies. (defvar cperl-mode-abbrev-table nil "Abbrev table in use in Cperl-mode buffers.") (define-abbrev-table 'cperl-mode-abbrev-table ()) (defvar cperl-mode-map () "Keymap used in C mode.") (if cperl-mode-map () (setq cperl-mode-map (make-sparse-keymap)) (define-key cperl-mode-map "{" 'electric-cperl-brace) (define-key cperl-mode-map "}" 'electric-cperl-brace) (define-key cperl-mode-map ";" 'electric-cperl-semi) (define-key cperl-mode-map ":" 'electric-cperl-terminator) (define-key cperl-mode-map "\e\C-h" 'mark-cperl-function) (define-key cperl-mode-map "\e\C-q" 'indent-cperl-exp) (define-key cperl-mode-map "\177" 'backward-delete-char-untabify) (define-key cperl-mode-map "\t" 'cperl-indent-command)) (autoload 'cperl-macro-expand "cmacexp" "Display the result of expanding all C macros occurring in the region. The expansion is entirely correct because it uses the C preprocessor." t) (defvar cperl-mode-syntax-table nil "Syntax table in use in Cperl-mode buffers.") (if cperl-mode-syntax-table () (setq cperl-mode-syntax-table (make-syntax-table)) (modify-syntax-entry ?\\ "\\" cperl-mode-syntax-table) (modify-syntax-entry ?/ ". 14" cperl-mode-syntax-table) (modify-syntax-entry ?* ". 23" cperl-mode-syntax-table) (modify-syntax-entry ?+ "." cperl-mode-syntax-table) (modify-syntax-entry ?- "." cperl-mode-syntax-table) (modify-syntax-entry ?= "." cperl-mode-syntax-table) (modify-syntax-entry ?% "." cperl-mode-syntax-table) (modify-syntax-entry ?< "." cperl-mode-syntax-table) (modify-syntax-entry ?> "." cperl-mode-syntax-table) (modify-syntax-entry ?& "." cperl-mode-syntax-table) (modify-syntax-entry ?| "." cperl-mode-syntax-table)) (defvar cperl-indent-level 2 "*Indentation of C statements with respect to containing block.") (defvar cperl-brace-imaginary-offset 0 "*Imagined indentation of a C open brace that actually follows a statement.") (defvar cperl-brace-offset 0 "*Extra indentation for braces, compared with other text in same context.") (defvar cperl-argdecl-indent 5 "*Indentation level of declarations of C function arguments.") (defvar cperl-label-offset -2 "*Offset of C label lines and case statements relative to usual indentation.") (defvar cperl-continued-statement-offset 2 "*Extra indent for lines not starting new statements.") (defvar cperl-continued-brace-offset 0 "*Extra indent for substatements that start with open-braces. This is in addition to cperl-continued-statement-offset.") (defvar cperl-auto-newline nil "*Non-nil means automatically newline before and after braces, and after colons and semicolons, inserted in C code.") (defvar cperl-tab-always-indent t "*Non-nil means TAB in C mode should always reindent the current line, regardless of where in the line point is when the TAB command is used.") ;; provide an alias for working with emacs 19. the perl-mode that comes ;; with it is really bad, and this lets us seamlessly replace it. (fset 'perl-mode 'cperl-mode) (defun cperl-mode () "Major mode for editing C code. Expression and list commands understand all C brackets. Tab indents for C code. Comments are delimited with /* ... */. Paragraphs are separated by blank lines only. Delete converts tabs to spaces as it moves back. \\{cperl-mode-map} Variables controlling indentation style: cperl-tab-always-indent Non-nil means TAB in C mode should always reindent the current line, regardless of where in the line point is when the TAB command is used. cperl-auto-newline Non-nil means automatically newline before and after braces, and after colons and semicolons, inserted in C code. cperl-indent-level Indentation of C statements within surrounding block. The surrounding block's indentation is the indentation of the line on which the open-brace appears. cperl-continued-statement-offset Extra indentation given to a substatement, such as the then-clause of an if or body of a while. cperl-continued-brace-offset Extra indentation given to a brace that starts a substatement. This is in addition to cperl-continued-statement-offset. cperl-brace-offset Extra indentation for line if it starts with an open brace. cperl-brace-imaginary-offset An open brace following other text is treated as if it were this far to the right of the start of its line. cperl-argdecl-indent Indentation level of declarations of C function arguments. cperl-label-offset Extra indentation for line that is a label, or case or default. Settings for K&R and BSD indentation styles are cperl-indent-level 5 8 cperl-continued-statement-offset 5 8 cperl-brace-offset -5 -8 cperl-argdecl-indent 0 8 cperl-label-offset -5 -8 Turning on C mode calls the value of the variable cperl-mode-hook with no args, if that value is non-nil." (interactive) (kill-all-local-variables) (use-local-map cperl-mode-map) (setq major-mode 'perl-mode) (setq mode-name "CPerl") (setq local-abbrev-table cperl-mode-abbrev-table) (set-syntax-table cperl-mode-syntax-table) (make-local-variable 'paragraph-start) (setq paragraph-start (concat "^$\\|" page-delimiter)) (make-local-variable 'paragraph-separate) (setq paragraph-separate paragraph-start) (make-local-variable 'paragraph-ignore-fill-prefix) (setq paragraph-ignore-fill-prefix t) (make-local-variable 'indent-line-function) (setq indent-line-function 'cperl-indent-line) (make-local-variable 'require-final-newline) (setq require-final-newline t) (make-local-variable 'comment-start) (setq comment-start "# ") (make-local-variable 'comment-end) (setq comment-end "") (make-local-variable 'comment-column) (setq comment-column 32) (make-local-variable 'comment-start-skip) (setq comment-start-skip "# *") (make-local-variable 'comment-indent-hook) (setq comment-indent-hook 'cperl-comment-indent) (make-local-variable 'parse-sexp-ignore-comments) (setq parse-sexp-ignore-comments t) (run-hooks 'cperl-mode-hook)) ;; This is used by indent-for-comment ;; to decide how much to indent a comment in C code ;; based on its context. (defun cperl-comment-indent () (if (looking-at "^#") 0 ;Existing comment at bol stays there. (save-excursion (skip-chars-backward " \t") (max (1+ (current-column)) ;Else indent at comment column comment-column)))) ; except leave at least one space. (defun electric-cperl-brace (arg) "Insert character and correct line's indentation." (interactive "P") (let (insertpos) (if (and (not arg) (eolp) (or (save-excursion (skip-chars-backward " \t") (bolp)) (if cperl-auto-newline (progn (cperl-indent-line) (newline) t) nil))) (progn (insert last-command-char) (cperl-indent-line) (if cperl-auto-newline (progn (newline) ;; (newline) may have done auto-fill (setq insertpos (- (point) 2)) (cperl-indent-line))) (save-excursion (if insertpos (goto-char (1+ insertpos))) (delete-char -1)))) (if insertpos (save-excursion (goto-char insertpos) (self-insert-command (prefix-numeric-value arg))) (self-insert-command (prefix-numeric-value arg))))) (defun electric-cperl-semi (arg) "Insert character and correct line's indentation." (interactive "P") (if cperl-auto-newline (electric-cperl-terminator arg) (self-insert-command (prefix-numeric-value arg)))) (defun electric-cperl-terminator (arg) "Insert character and correct line's indentation." (interactive "P") (let (insertpos (end (point))) (if (and (not arg) (eolp) (not (save-excursion (beginning-of-line) (skip-chars-forward " \t") (or (= (following-char) ?#) ;; Colon is special only after a label, or case .... ;; So quickly rule out most other uses of colon ;; and do no indentation for them. (and (eq last-command-char ?:) (not (looking-at "case[ \t]")) (save-excursion (forward-word 1) (skip-chars-forward " \t") (< (point) end))) (progn (beginning-of-defun) (let ((pps (parse-partial-sexp (point) end))) (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))))) (progn (insert last-command-char) (cperl-indent-line) (and cperl-auto-newline (not (cperl-inside-parens-p)) (progn (newline) (setq insertpos (- (point) 2)) (cperl-indent-line))) (save-excursion (if insertpos (goto-char (1+ insertpos))) (delete-char -1)))) (if insertpos (save-excursion (goto-char insertpos) (self-insert-command (prefix-numeric-value arg))) (self-insert-command (prefix-numeric-value arg))))) (defun cperl-inside-parens-p () (condition-case () (save-excursion (save-restriction (narrow-to-region (point) (progn (beginning-of-defun) (point))) (goto-char (point-max)) (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) (error nil))) (defun cperl-indent-command (&optional whole-exp) (interactive "P") "Indent current line as C code, or in some cases insert a tab character. If cperl-tab-always-indent is non-nil (the default), always indent current line. Otherwise, indent the current line only if point is at the left margin or in the line's indentation; otherwise insert a tab. A numeric argument, regardless of its value, means indent rigidly all the lines of the expression starting after point so that this line becomes properly indented. The relative indentation among the lines of the expression are preserved." (if whole-exp ;; If arg, always indent this line as C ;; and shift remaining lines of expression the same amount. (let ((shift-amt (cperl-indent-line)) beg end) (save-excursion (if cperl-tab-always-indent (beginning-of-line)) (setq beg (point)) (forward-sexp 1) (setq end (point)) (goto-char beg) (forward-line 1) (setq beg (point))) (if (> end beg) (indent-code-rigidly beg end shift-amt "#"))) (if (and (not cperl-tab-always-indent) (save-excursion (skip-chars-backward " \t") (not (bolp)))) (insert-tab) (cperl-indent-line)))) (defun cperl-indent-line () "Indent current line as C code. Return the amount the indentation changed by." (let ((indent (calculate-cperl-indent nil)) beg shift-amt (case-fold-search nil) (pos (- (point-max) (point)))) (beginning-of-line) (setq beg (point)) (cond ((eq indent nil) (setq indent (current-indentation))) ((eq indent t) (setq indent (calculate-cperl-indent-within-comment))) ((looking-at "[ \t]*#") (setq indent 0)) (t (skip-chars-forward " \t") (if (listp indent) (setq indent (car indent))) (cond ((or (looking-at "case[ \t]") (and (looking-at "[A-Za-z]") (save-excursion (forward-sexp 1) (looking-at ":")))) (setq indent (max 1 (+ indent cperl-label-offset)))) ((and (looking-at "else\\b") (not (looking-at "else\\s_"))) (setq indent (save-excursion (cperl-backward-to-start-of-if) (current-indentation)))) ((= (following-char) ?}) (setq indent (- indent cperl-indent-level))) ((= (following-char) ?{) (setq indent (+ indent cperl-brace-offset)))))) (skip-chars-forward " \t") (setq shift-amt (- indent (current-column))) (if (zerop shift-amt) (if (> (- (point-max) pos) (point)) (goto-char (- (point-max) pos))) (delete-region beg (point)) (indent-to indent) ;; If initial point was within line's indentation, ;; position after the indentation. Else stay at same point in text. (if (> (- (point-max) pos) (point)) (goto-char (- (point-max) pos)))) shift-amt)) (defun calculate-cperl-indent (&optional parse-start) "Return appropriate indentation for current line as C code. In usual case returns an integer: the column to indent to. Returns nil if line starts inside a string, t if in a comment." (save-excursion (beginning-of-line) (let ((indent-point (point)) (case-fold-search nil) state containing-sexp) (if parse-start (goto-char parse-start) (beginning-of-defun)) (while (< (point) indent-point) (setq parse-start (point)) (setq state (parse-partial-sexp (point) indent-point 0)) (setq containing-sexp (car (cdr state)))) (cond ((or (nth 3 state) (nth 4 state)) ;; return nil or t if should not change this line (nth 4 state)) ((null containing-sexp) ;; Line is at top level. May be data or function definition, ;; or may be function argument declaration. ;; Indent like the previous top level line ;; unless that ends in a closeparen without semicolon, ;; in which case this line is the first argument decl. (goto-char indent-point) (skip-chars-forward " \t") (if (= (following-char) ?{) 0 ; Unless it starts a function body (cperl-backward-to-noncomment (or parse-start (point-min))) ;; Look at previous line that's at column 0 ;; to determine whether we are in top-level decls ;; or function's arg decls. Set basic-indent accordinglu. (let ((basic-indent (save-excursion (re-search-backward "^[^ \^L\t\n#]" nil 'move) (if (and (looking-at "\\sw\\|\\s_") (looking-at ".*(") (progn (goto-char (1- (match-end 0))) (forward-sexp 1) (and (< (point) indent-point) (not (memq (following-char) '(?\, ?\;)))))) cperl-argdecl-indent 0)))) ;; Now add a little if this is a continuation line. (+ basic-indent (if (or (bobp) (memq (preceding-char) '(?\) ?\; ?\}))) 0 cperl-continued-statement-offset))))) ((/= (char-after containing-sexp) ?{) ;; line is expression, not statement: ;; indent to just after the surrounding open. (goto-char (1+ containing-sexp)) (current-column)) (t ;; Statement level. Is it a continuation or a new statement? ;; Find previous non-comment character. (goto-char indent-point) (cperl-backward-to-noncomment containing-sexp) ;; Back up over label lines, since they don't ;; affect whether our line is a continuation. (while (or (eq (preceding-char) ?\,) (and (eq (preceding-char) ?:) (or (eq (char-after (- (point) 2)) ?\') (memq (char-syntax (char-after (- (point) 2))) '(?w ?_))))) (if (eq (preceding-char) ?\,) (cperl-backward-to-start-of-continued-exp containing-sexp)) (beginning-of-line) (cperl-backward-to-noncomment containing-sexp)) ;; Now we get the answer. (if (not (memq (preceding-char) '(nil ?\, ?\; ?\} ?\{))) ;; This line is continuation of preceding line's statement; ;; indent cperl-continued-statement-offset more than the ;; previous line of the statement. (progn (cperl-backward-to-start-of-continued-exp containing-sexp) (+ cperl-continued-statement-offset (current-column) (if (save-excursion (goto-char indent-point) (skip-chars-forward " \t") (eq (following-char) ?{)) cperl-continued-brace-offset 0))) ;; This line starts a new statement. ;; Position following last unclosed open. (goto-char containing-sexp) ;; Is line first statement after an open-brace? (or ;; If no, find that first statement and indent like it. (save-excursion (forward-char 1) (let ((colon-line-end 0)) (while (progn (skip-chars-forward " \t\n") (looking-at "#\\|/\\*\\|case[ \t\n].*:\\|[a-zA-Z0-9_$]*:")) ;; Skip over comments and labels following openbrace. (cond ((= (following-char) ?\#) (forward-line 1)) ((= (following-char) ?\/) (forward-char 2) (search-forward "*/" nil 'move)) ;; case or label: (t (save-excursion (end-of-line) (setq colon-line-end (point))) (search-forward ":")))) ;; The first following code counts ;; if it is before the line we want to indent. (and (< (point) indent-point) (if (> colon-line-end (point)) (- (current-indentation) cperl-label-offset) (current-column))))) ;; If no previous statement, ;; indent it relative to line brace is on. ;; For open brace in column zero, don't let statement ;; start there too. If cperl-indent-level is zero, ;; use cperl-brace-offset + cperl-continued-statement-offset instead. ;; For open-braces not the first thing in a line, ;; add in cperl-brace-imaginary-offset. (+ (if (and (bolp) (zerop cperl-indent-level)) (+ cperl-brace-offset cperl-continued-statement-offset) cperl-indent-level) ;; Move back over whitespace before the openbrace. ;; If openbrace is not first nonwhite thing on the line, ;; add the cperl-brace-imaginary-offset. (progn (skip-chars-backward " \t") (if (bolp) 0 cperl-brace-imaginary-offset)) ;; If the openbrace is preceded by a parenthesized exp, ;; move to the beginning of that; ;; possibly a different line (progn (if (eq (preceding-char) ?\)) (forward-sexp -1)) ;; Get initial indentation of the line we are on. (current-indentation)))))))))) (defun calculate-cperl-indent-within-comment () "Return the indentation amount for line, assuming that the current line is to be regarded as part of a block comment." (let (end star-start) (save-excursion (beginning-of-line) (skip-chars-forward " \t") (setq star-start (= (following-char) ?\*)) (skip-chars-backward " \t\n") (setq end (point)) (beginning-of-line) (skip-chars-forward " \t") (and (re-search-forward "/\\*[ \t]*" end t) star-start (goto-char (1+ (match-beginning 0)))) (current-column)))) (defun cperl-backward-to-noncomment (lim) (let (opoint stop) (while (not stop) (skip-chars-backward " \t\n\f" lim) (setq opoint (point)) (if (and (>= (point) (+ 2 lim)) (save-excursion (forward-char -2) (looking-at "\\*/"))) (search-backward "/*" lim 'move) (beginning-of-line) (skip-chars-forward " \t") (setq stop (or (not (looking-at "#")) (<= (point) lim))) (if stop (goto-char opoint) (beginning-of-line)))))) (defun cperl-backward-to-start-of-continued-exp (lim) (if (= (preceding-char) ?\)) (forward-sexp -1)) (beginning-of-line) (if (<= (point) lim) (goto-char (1+ lim))) (skip-chars-forward " \t")) (defun cperl-backward-to-start-of-if (&optional limit) "Move to the start of the last ``unbalanced'' if." (or limit (setq limit (save-excursion (beginning-of-defun) (point)))) (let ((if-level 1) (case-fold-search nil)) (while (not (zerop if-level)) (backward-sexp 1) (cond ((looking-at "else\\b") (setq if-level (1+ if-level))) ((looking-at "if\\b") (setq if-level (1- if-level))) ((< (point) limit) (setq if-level 0) (goto-char limit)))))) (defun mark-cperl-function () "Put mark at end of C function, point at beginning." (interactive) (push-mark (point)) (end-of-defun) (push-mark (point)) (beginning-of-defun) (backward-paragraph)) (defun indent-cperl-exp () "Indent each line of the C grouping following point." (interactive) (let ((indent-stack (list nil)) (contain-stack (list (point))) (case-fold-search nil) restart outer-loop-done inner-loop-done state ostate this-indent last-sexp at-else at-brace (opoint (point)) (next-depth 0)) (save-excursion (forward-sexp 1)) (save-excursion (setq outer-loop-done nil) (while (and (not (eobp)) (not outer-loop-done)) (setq last-depth next-depth) ;; Compute how depth changes over this line ;; plus enough other lines to get to one that ;; does not end inside a comment or string. ;; Meanwhile, do appropriate indentation on comment lines. (setq innerloop-done nil) (while (and (not innerloop-done) (not (and (eobp) (setq outer-loop-done t)))) (setq ostate state) (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) nil nil state)) (setq next-depth (car state)) (if (and (car (cdr (cdr state))) (>= (car (cdr (cdr state))) 0)) (setq last-sexp (car (cdr (cdr state))))) (if (or (nth 4 ostate)) (cperl-indent-line)) (if (or (nth 3 state)) (forward-line 1) (setq innerloop-done t))) (if (<= next-depth 0) (setq outer-loop-done t)) (if outer-loop-done nil ;; If this line had ..))) (((.. in it, pop out of the levels ;; that ended anywhere in this line, even if the final depth ;; doesn't indicate that they ended. (while (> last-depth (nth 6 state)) (setq indent-stack (cdr indent-stack) contain-stack (cdr contain-stack) last-depth (1- last-depth))) (if (/= last-depth next-depth) (setq last-sexp nil)) ;; Add levels for any parens that were started in this line. (while (< last-depth next-depth) (setq indent-stack (cons nil indent-stack) contain-stack (cons nil contain-stack) last-depth (1+ last-depth))) (if (null (car contain-stack)) (setcar contain-stack (or (car (cdr state)) (save-excursion (forward-sexp -1) (point))))) (forward-line 1) (skip-chars-forward " \t") (if (eolp) nil (if (and (car indent-stack) (>= (car indent-stack) 0)) ;; Line is on an existing nesting level. ;; Lines inside parens are handled specially. (if (/= (char-after (car contain-stack)) ?{) (setq this-indent (car indent-stack)) ;; Line is at statement level. ;; Is it a new statement? Is it an else? ;; Find last non-comment character before this line (save-excursion (setq at-else (looking-at "else\\W")) (setq at-brace (= (following-char) ?{)) (cperl-backward-to-noncomment opoint) (if (not (memq (preceding-char) '(nil ?\, ?\; ?} ?: ?{))) ;; Preceding line did not end in comma or semi; ;; indent this line cperl-continued-statement-offset ;; more than previous. (progn (cperl-backward-to-start-of-continued-exp (car contain-stack)) (setq this-indent (+ cperl-continued-statement-offset (current-column) (if at-brace cperl-continued-brace-offset 0)))) ;; Preceding line ended in comma or semi; ;; use the standard indent for this level. (if at-else (progn (cperl-backward-to-start-of-if opoint) (setq this-indent (current-indentation))) (setq this-indent (car indent-stack)))))) ;; Just started a new nesting level. ;; Compute the standard indent for this level. (let ((val (calculate-cperl-indent (if (car indent-stack) (- (car indent-stack)))))) (setcar indent-stack (setq this-indent val)))) ;; Adjust line indentation according to its contents (if (or (looking-at "case[ \t]") (and (looking-at "[A-Za-z]") (save-excursion (forward-sexp 1) (looking-at ":")))) (setq this-indent (max 1 (+ this-indent cperl-label-offset)))) (if (= (following-char) ?}) (setq this-indent (- this-indent cperl-indent-level))) (if (= (following-char) ?{) (setq this-indent (+ this-indent cperl-brace-offset))) ;; Put chosen indentation into effect. (or (= (current-column) this-indent) (= (following-char) ?\#) (progn (delete-region (point) (progn (beginning-of-line) (point))) (indent-to this-indent))) ;; Indent any comment following the text. (or (looking-at comment-start-skip) (if (re-search-forward comment-start-skip (save-excursion (end-of-line) (point)) t) (progn (indent-for-comment) (beginning-of-line))))))))) ; (message "Indenting C expression...done") ) --cut here-- -- =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= Vivek Khera, Gradual Student/Systems Guy Department of Computer Science Internet: khera@cs.duke.edu Box 90129 RIPEM/PGP/MIME spoken here Durham, NC 27708-0129 (919)660-6528 (setq colon-line-end (point))) (search-forward ":")))) ;; The first following code counts ;; if it is before the line we want to indent. (and (< (point) indent-point) (if (> colon-line-end (point)) (- (current-indentation) cperl-label-offset) (current-column))))) ;; If no previous statement, ;; indent it relative to line brace is on. ;; For open brace in column zero, perl5.000/emacs/emacs19 664 203 12 27312 5460543455 7740 Article 15041 of comp.lang.perl: Path: netlabs!news.cerf.net!usc!sol.ctr.columbia.edu!news.kei.com!bloom-beacon.mit.edu!paperboy.osf.org!meissner From: meissner@osf.org (Michael Meissner) Newsgroups: comp.lang.perl Subject: Re: question on using perldb.el with emacs Date: 17 Oct 1993 21:10:21 GMT Organization: Open Software Foundation Lines: 297 Message-ID: References: NNTP-Posting-Host: pasta.osf.org In-reply-to: bshaw@bobasun.spdc.ti.com's message of Sun, 17 Oct 1993 19:35:24 GMT In article bshaw@bobasun.spdc.ti.com (Bob Shaw) writes: | Hi folks | | Say, I'm trying to use perldb with emacs. I can invoke perldb | within emacs ok and get the window *perldb-foo* but when it asks | for "additional command line arguments" , no matter what I give it | I get the error message Symbol's function definition is void: make- | shell. | | The debugger , by itself, works fine but wanted to try out perldb in | emacs. This is a symptom of using Emacs 19.xx with perldb.el which was originally made for emacs version 18.xx. You can either install the emacs19 replacement for perldb that hooks it in with GUD (grand unified debugger), or apply the patches that I picked off of the net (I use the perldb replacement that uses GUD myself): #!/bin/sh # This is a shell archive (produced by shar 3.49) # To extract the files from this archive, save it to a file, remove # everything above the "!/bin/sh" line above, and type "sh file_name". # # made 10/17/1993 21:07 UTC by meissner@pasta.osf.org # Source directory /usr/users/meissner/elisp # # existing files will NOT be overwritten unless -c is specified # # This shar contains: # length mode name # ------ ---------- ------------------------------------------ # 4761 -rw-r--r-- emacs19-perldb.el # 3845 -rw-rw-r-- emacs19-perldb.patches # # ============= emacs19-perldb.el ============== if test -f 'emacs19-perldb.el' -a X"$1" != X"-c"; then echo 'x - skipping emacs19-perldb.el (File already exists)' else echo 'x - extracting emacs19-perldb.el (Text)' sed 's/^X//' << 'SHAR_EOF' > 'emacs19-perldb.el' && X;; Author : Stephane Boucher X;; Note : This is an add on for gud (Part of GNU Emacs 19). It is X;; derived from the gdb section that is part of gud. X X;; Copyright (C) 1993 Stephane Boucher. X X;; Perldb is free software; you can redistribute it and/or modify X;; it under the terms of the GNU General Public License as published by X;; the Free Software Foundation; either version 2, or (at your option) X;; any later version. X X;; Perldb Emacs is distributed in the hope that it will be useful, X;; but WITHOUT ANY WARRANTY; without even the implied warranty of X;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the X;; GNU General Public License for more details. X X;; You should have received a copy of the GNU General Public License X;; along with GNU Emacs; see the file COPYING. If not, write to X;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. X X(require 'gud) X X;; ====================================================================== X;; perldb functions X X;;; History of argument lists passed to perldb. X(defvar gud-perldb-history nil) X X(defun gud-perldb-massage-args (file args) X (cons "-d" (cons file (cons "-emacs" args)))) X X;; There's no guarantee that Emacs will hand the filter the entire X;; marker at once; it could be broken up across several strings. We X;; might even receive a big chunk with several markers in it. If we X;; receive a chunk of text which looks like it might contain the X;; beginning of a marker, we save it here between calls to the X;; filter. X(defvar gud-perldb-marker-acc "") X X(defun gud-perldb-marker-filter (string) X (save-match-data X (setq gud-perldb-marker-acc (concat gud-perldb-marker-acc string)) X (let ((output "")) X X ;; Process all the complete markers in this chunk. X (while (string-match "^\032\032\\([^:\n]*\\):\\([0-9]*\\):.*\n" X gud-perldb-marker-acc) X (setq X X ;; Extract the frame position from the marker. X gud-last-frame X (cons (substring gud-perldb-marker-acc (match-beginning 1) (match-end 1)) X (string-to-int (substring gud-perldb-marker-acc X (match-beginning 2) X (match-end 2)))) X X ;; Append any text before the marker to the output we're going X ;; to return - we don't include the marker in this text. X output (concat output X (substring gud-perldb-marker-acc 0 (match-beginning 0))) X X ;; Set the accumulator to the remaining text. X gud-perldb-marker-acc (substring gud-perldb-marker-acc (match-end 0)))) X X ;; Does the remaining text look like it might end with the X ;; beginning of another marker? If it does, then keep it in X ;; gud-perldb-marker-acc until we receive the rest of it. Since we X ;; know the full marker regexp above failed, it's pretty simple to X ;; test for marker starts. X (if (string-match "^\032.*\\'" gud-perldb-marker-acc) X (progn X ;; Everything before the potential marker start can be output. X (setq output (concat output (substring gud-perldb-marker-acc X 0 (match-beginning 0)))) X X ;; Everything after, we save, to combine with later input. X (setq gud-perldb-marker-acc X (substring gud-perldb-marker-acc (match-beginning 0)))) X X (setq output (concat output gud-perldb-marker-acc) X gud-perldb-marker-acc "")) X X output))) X X(defun gud-perldb-find-file (f) X (find-file-noselect f)) X X;;;###autoload X(defun perldb (command-line) X "Run perldb on program FILE in buffer *gud-FILE*. XThe directory containing FILE becomes the initial working directory Xand source-file directory for your debugger." X (interactive X (list (read-from-minibuffer "Run perldb (like this): " X (if (consp gud-perldb-history) X (car gud-perldb-history) X "perl ") X nil nil X '(gud-perldb-history . 1)))) X (gud-overload-functions '((gud-massage-args . gud-perldb-massage-args) X (gud-marker-filter . gud-perldb-marker-filter) X (gud-find-file . gud-perldb-find-file) X )) X X (gud-common-init command-line) X X (gud-def gud-break "b %l" "\C-b" "Set breakpoint at current line.") X (gud-def gud-remove "d %l" "\C-d" "Remove breakpoint at current line") X (gud-def gud-step "s" "\C-s" "Step one source line with display.") X (gud-def gud-next "n" "\C-n" "Step one line (skip functions).") X (gud-def gud-cont "c" "\C-r" "Continue with display.") X; (gud-def gud-finish "finish" "\C-f" "Finish executing current function.") X; (gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).") X; (gud-def gud-down "down %p" ">" "Down N stack frames (numeric arg).") X (gud-def gud-print "%e" "\C-p" "Evaluate perl expression at point.") X X (setq comint-prompt-regexp "^ DB<[0-9]+> ") X (run-hooks 'perldb-mode-hook) X ) SHAR_EOF chmod 0644 emacs19-perldb.el || echo 'restore of emacs19-perldb.el failed' Wc_c="`wc -c < 'emacs19-perldb.el'`" test 4761 -eq "$Wc_c" || echo 'emacs19-perldb.el: original size 4761, current size' "$Wc_c" fi # ============= emacs19-perldb.patches ============== if test -f 'emacs19-perldb.patches' -a X"$1" != X"-c"; then echo 'x - skipping emacs19-perldb.patches (File already exists)' else echo 'x - extracting emacs19-perldb.patches (Text)' sed 's/^X//' << 'SHAR_EOF' > 'emacs19-perldb.patches' && XFrom dmm0t@rincewind.mech.virginia.edu Fri Jul 16 23:17:10 1993 XPath: paperboy.osf.org!bloom-beacon.mit.edu!biosci!uwm.edu!ux1.cso.uiuc.edu!howland.reston.ans.net!darwin.sura.net!news-feed-2.peachnet.edu!concert!uvaarpa!murdoch!rincewind.mech.virginia.edu!dmm0t XFrom: dmm0t@rincewind.mech.virginia.edu (David Meyer) XNewsgroups: gnu.emacs.sources XSubject: patches to perldb.el for emacs-19 XMessage-ID: XDate: 15 Jul 93 17:18:07 GMT XSender: usenet@murdoch.acc.Virginia.EDU XOrganization: University of Virginia XLines: 97 X X XHere are my patches to perldb.el (the perl debugger mode that comes Xwith perl 4.0xx). Basically, all I've done is to hack perldb.el to Xuse comint.el stuff rather than the old shell.el stuff (i.e. change Xshell-mode-map to comint-mode-map). X XI've been using my patched version without problem, but if anyone sees Xsomething I've missed, please post or send e-mail. X X Thanks, X Dave X X X*** /Users/dmm0t/perldb.el Thu Jul 15 13:06:59 1993 X--- perldb.el Tue Jul 6 22:24:41 1993 X*************** X*** 65,71 **** X X (if perldb-mode-map X nil X! (setq perldb-mode-map (copy-keymap shell-mode-map)) X (define-key perldb-mode-map "\C-l" 'perldb-refresh)) X X (define-key ctl-x-map " " 'perldb-break) X--- 65,71 ---- X X (if perldb-mode-map X nil X! (setq perldb-mode-map (copy-keymap comint-mode-map)) X (define-key perldb-mode-map "\C-l" 'perldb-refresh)) X X (define-key ctl-x-map " " 'perldb-break) X*************** X*** 122,131 **** X (setq mode-name "Inferior Perl") X (setq mode-line-process '(": %s")) X (use-local-map perldb-mode-map) X! (make-local-variable 'last-input-start) X! (setq last-input-start (make-marker)) X! (make-local-variable 'last-input-end) X! (setq last-input-end (make-marker)) X (make-local-variable 'perldb-last-frame) X (setq perldb-last-frame nil) X (make-local-variable 'perldb-last-frame-displayed-p) X--- 122,131 ---- X (setq mode-name "Inferior Perl") X (setq mode-line-process '(": %s")) X (use-local-map perldb-mode-map) X! (make-local-variable 'comint-last-input-start) X! (setq comint-last-input-start (make-marker)) X! (make-local-variable 'comint-last-input-end) X! (setq comint-last-input-end (make-marker)) X (make-local-variable 'perldb-last-frame) X (setq perldb-last-frame nil) X (make-local-variable 'perldb-last-frame-displayed-p) X*************** X*** 134,142 **** X (setq perldb-delete-prompt-marker nil) X (make-local-variable 'perldb-filter-accumulator) X (setq perldb-filter-accumulator nil) X! (make-local-variable 'shell-prompt-pattern) X! (setq shell-prompt-pattern perldb-prompt-pattern) X! (run-hooks 'shell-mode-hook 'perldb-mode-hook)) X X (defvar current-perldb-buffer nil) X X--- 134,142 ---- X (setq perldb-delete-prompt-marker nil) X (make-local-variable 'perldb-filter-accumulator) X (setq perldb-filter-accumulator nil) X! (make-local-variable 'comint-prompt-regexp) X! (setq comint-prompt-regexp perldb-prompt-pattern) X! (run-hooks 'comint-mode-hook 'perldb-mode-hook)) X X (defvar current-perldb-buffer nil) X X*************** X*** 189,195 **** X (setq default-directory dir) X (or (bolp) (newline)) X (insert "Current directory is " default-directory "\n") X! (apply 'make-shell X (concat "perldb-" file) perldb-command-name nil "-d" path "-emacs" X (parse-args args)) X (perldb-mode) X--- 189,195 ---- X (setq default-directory dir) X (or (bolp) (newline)) X (insert "Current directory is " default-directory "\n") X! (apply 'make-comint X (concat "perldb-" file) perldb-command-name nil "-d" path "-emacs" X (parse-args args)) X (perldb-mode) X-- XDavid M. Meyer Mechanical & Aerospace Engineering Xdmm0t@rincewind.mech.virginia.edu University of Virginia XNeXTmail ok X SHAR_EOF chmod 0664 emacs19-perldb.patches || echo 'restore of emacs19-perldb.patches failed' Wc_c="`wc -c < 'emacs19-perldb.patches'`" test 3845 -eq "$Wc_c" || echo 'emacs19-perldb.patches: original size 3845, current size' "$Wc_c" fi exit 0 -- Michael Meissner email: meissner@osf.org phone: 617-621-8861 Open Software Foundation, 11 Cambridge Center, Cambridge, MA, 02142 Old hackers never die, their bugs just increase. anywhere in this line, even if the final depth ;; doesn't indicate that they ended. (while (> last-depth (nth 6 state)) (setq indent-stack (cdr indent-stack) contain-stack (cdr contain-stack) last-depth (1- last-depth))) (if (/= last-depth next-depth) (setq last-sexp nil)) ;; perl5.000/emacs/perl-mode.el 644 203 12 62312 5240611505 10742 ;; Perl code editing commands for GNU Emacs ;; Copyright (C) 1990 William F. Mann ;; Adapted from C code editing commands 'c-mode.el', Copyright 1987 by the ;; Free Software Foundation, under terms of its General Public License. ;; This file may be made part of GNU Emacs at the option of the FSF, or ;; of the perl distribution at the option of Larry Wall. ;; This code is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY. No author or distributor ;; accepts responsibility to anyone for the consequences of using it ;; or for whether it serves any particular purpose or works at all, ;; unless he says so in writing. Refer to the GNU Emacs General Public ;; License for full details. ;; Everyone is granted permission to copy, modify and redistribute ;; this code, but only under the conditions described in the ;; GNU Emacs General Public License. A copy of this license is ;; supposed to have been given to you along with GNU Emacs so you ;; can know your rights and responsibilities. It should be in a ;; file named COPYING. Among other things, the copyright notice ;; and this notice must be preserved on all copies. ;; To enter perl-mode automatically, add (autoload 'perl-mode "perl-mode") ;; to your .emacs file and change the first line of your perl script to: ;; #!/usr/bin/perl -- # -*-Perl-*- ;; With argments to perl: ;; #!/usr/bin/perl -P- # -*-Perl-*- ;; To handle files included with do 'filename.pl';, add something like ;; (setq auto-mode-alist (append (list (cons "\\.pl$" 'perl-mode)) ;; auto-mode-alist)) ;; to your .emacs file; otherwise the .pl suffix defaults to prolog-mode. ;; This code is based on the 18.53 version c-mode.el, with extensive ;; rewriting. Most of the features of c-mode survived intact. ;; I added a new feature which adds functionality to TAB; it is controlled ;; by the variable perl-tab-to-comment. With it enabled, TAB does the ;; first thing it can from the following list: change the indentation; ;; move past leading white space; delete an empty comment; reindent a ;; comment; move to end of line; create an empty comment; tell you that ;; the line ends in a quoted string, or has a # which should be a \#. ;; If your machine is slow, you may want to remove some of the bindings ;; to electric-perl-terminator. I changed the indenting defaults to be ;; what Larry Wall uses in perl/lib, but left in all the options. ;; I also tuned a few things: comments and labels starting in column ;; zero are left there by indent-perl-exp; perl-beginning-of-function ;; goes back to the first open brace/paren in column zero, the open brace ;; in 'sub ... {', or the equal sign in 'format ... ='; indent-perl-exp ;; (meta-^q) indents from the current line through the close of the next ;; brace/paren, so you don't need to start exactly at a brace or paren. ;; It may be good style to put a set of redundant braces around your ;; main program. This will let you reindent it with meta-^q. ;; Known problems (these are all caused by limitations in the elisp ;; parsing routine (parse-partial-sexp), which was not designed for such ;; a rich language; writing a more suitable parser would be a big job): ;; 1) Regular expression delimitors do not act as quotes, so special ;; characters such as `'"#:;[](){} may need to be backslashed ;; in regular expressions and in both parts of s/// and tr///. ;; 2) The globbing syntax is not recognized, so special ;; characters in the pattern string must be backslashed. ;; 3) The q, qq, and << quoting operators are not recognized; see below. ;; 4) \ (backslash) always quotes the next character, so '\' is ;; treated as the start of a string. Use "\\" as a work-around. ;; 5) To make variables such a $' and $#array work, perl-mode treats ;; $ just like backslash, so '$' is the same as problem 5. ;; 6) Unfortunately, treating $ like \ makes ${var} be treated as an ;; unmatched }. See below. ;; 7) When ' (quote) is used as a package name separator, perl-mode ;; doesn't understand, and thinks it is seeing a quoted string. ;; Here are some ugly tricks to bypass some of these problems: the perl ;; expression /`/ (that's a back-tick) usually evaluates harmlessly, ;; but will trick perl-mode into starting a quoted string, which ;; can be ended with another /`/. Assuming you have no embedded ;; back-ticks, this can used to help solve problem 3: ;; ;; /`/; $ugly = q?"'$?; /`/; ;; ;; To solve problem 6, add a /{/; before each use of ${var}: ;; /{/; while (<${glob_me}>) ... ;; ;; Problem 7 is even worse, but this 'fix' does work :-( ;; $DB'stop#' ;; [$DB'line#' ;; ] =~ s/;9$//; (defvar perl-mode-abbrev-table nil "Abbrev table in use in perl-mode buffers.") (define-abbrev-table 'perl-mode-abbrev-table ()) (defvar perl-mode-map () "Keymap used in Perl mode.") (if perl-mode-map () (setq perl-mode-map (make-sparse-keymap)) (define-key perl-mode-map "{" 'electric-perl-terminator) (define-key perl-mode-map "}" 'electric-perl-terminator) (define-key perl-mode-map ";" 'electric-perl-terminator) (define-key perl-mode-map ":" 'electric-perl-terminator) (define-key perl-mode-map "\e\C-a" 'perl-beginning-of-function) (define-key perl-mode-map "\e\C-e" 'perl-end-of-function) (define-key perl-mode-map "\e\C-h" 'mark-perl-function) (define-key perl-mode-map "\e\C-q" 'indent-perl-exp) (define-key perl-mode-map "\177" 'backward-delete-char-untabify) (define-key perl-mode-map "\t" 'perl-indent-command)) (autoload 'c-macro-expand "cmacexp" "Display the result of expanding all C macros occurring in the region. The expansion is entirely correct because it uses the C preprocessor." t) (defvar perl-mode-syntax-table nil "Syntax table in use in perl-mode buffers.") (if perl-mode-syntax-table () (setq perl-mode-syntax-table (make-syntax-table (standard-syntax-table))) (modify-syntax-entry ?\n ">" perl-mode-syntax-table) (modify-syntax-entry ?# "<" perl-mode-syntax-table) (modify-syntax-entry ?$ "/" perl-mode-syntax-table) (modify-syntax-entry ?% "." perl-mode-syntax-table) (modify-syntax-entry ?& "." perl-mode-syntax-table) (modify-syntax-entry ?\' "\"" perl-mode-syntax-table) (modify-syntax-entry ?* "." perl-mode-syntax-table) (modify-syntax-entry ?+ "." perl-mode-syntax-table) (modify-syntax-entry ?- "." perl-mode-syntax-table) (modify-syntax-entry ?/ "." perl-mode-syntax-table) (modify-syntax-entry ?< "." perl-mode-syntax-table) (modify-syntax-entry ?= "." perl-mode-syntax-table) (modify-syntax-entry ?> "." perl-mode-syntax-table) (modify-syntax-entry ?\\ "\\" perl-mode-syntax-table) (modify-syntax-entry ?` "\"" perl-mode-syntax-table) (modify-syntax-entry ?| "." perl-mode-syntax-table) ) (defconst perl-indent-level 4 "*Indentation of Perl statements with respect to containing block.") (defconst perl-continued-statement-offset 4 "*Extra indent for lines not starting new statements.") (defconst perl-continued-brace-offset -4 "*Extra indent for substatements that start with open-braces. This is in addition to perl-continued-statement-offset.") (defconst perl-brace-offset 0 "*Extra indentation for braces, compared with other text in same context.") (defconst perl-brace-imaginary-offset 0 "*Imagined indentation of an open brace that actually follows a statement.") (defconst perl-label-offset -2 "*Offset of Perl label lines relative to usual indentation.") (defconst perl-tab-always-indent t "*Non-nil means TAB in Perl mode should always indent the current line, regardless of where in the line point is when the TAB command is used.") (defconst perl-tab-to-comment t "*Non-nil means that for lines which don't need indenting, TAB will either indent an existing comment, move to end-of-line, or if at end-of-line already, create a new comment.") (defconst perl-nochange ";?#\\|\f\\|\\s(\\|\\(\\w\\|\\s_\\)+:" "*Lines starting with this regular expression will not be auto-indented.") (defun perl-mode () "Major mode for editing Perl code. Expression and list commands understand all Perl brackets. Tab indents for Perl code. Comments are delimited with # ... \\n. Paragraphs are separated by blank lines only. Delete converts tabs to spaces as it moves back. \\{perl-mode-map} Variables controlling indentation style: perl-tab-always-indent Non-nil means TAB in Perl mode should always indent the current line, regardless of where in the line point is when the TAB command is used. perl-tab-to-comment Non-nil means that for lines which don't need indenting, TAB will either delete an empty comment, indent an existing comment, move to end-of-line, or if at end-of-line already, create a new comment. perl-nochange Lines starting with this regular expression will not be auto-indented. perl-indent-level Indentation of Perl statements within surrounding block. The surrounding block's indentation is the indentation of the line on which the open-brace appears. perl-continued-statement-offset Extra indentation given to a substatement, such as the then-clause of an if or body of a while. perl-continued-brace-offset Extra indentation given to a brace that starts a substatement. This is in addition to perl-continued-statement-offset. perl-brace-offset Extra indentation for line if it starts with an open brace. perl-brace-imaginary-offset An open brace following other text is treated as if it were this far to the right of the start of its line. perl-label-offset Extra indentation for line that is a label. Various indentation styles: K&R BSD BLK GNU LW perl-indent-level 5 8 0 2 4 perl-continued-statement-offset 5 8 4 2 4 perl-continued-brace-offset 0 0 0 0 -4 perl-brace-offset -5 -8 0 0 0 perl-brace-imaginary-offset 0 0 4 0 0 perl-label-offset -5 -8 -2 -2 -2 Turning on Perl mode calls the value of the variable perl-mode-hook with no args, if that value is non-nil." (interactive) (kill-all-local-variables) (use-local-map perl-mode-map) (setq major-mode 'perl-mode) (setq mode-name "Perl") (setq local-abbrev-table perl-mode-abbrev-table) (set-syntax-table perl-mode-syntax-table) (make-local-variable 'paragraph-start) (setq paragraph-start (concat "^$\\|" page-delimiter)) (make-local-variable 'paragraph-separate) (setq paragraph-separate paragraph-start) (make-local-variable 'paragraph-ignore-fill-prefix) (setq paragraph-ignore-fill-prefix t) (make-local-variable 'indent-line-function) (setq indent-line-function 'perl-indent-line) (make-local-variable 'require-final-newline) (setq require-final-newline t) (make-local-variable 'comment-start) (setq comment-start "# ") (make-local-variable 'comment-end) (setq comment-end "") (make-local-variable 'comment-column) (setq comment-column 32) (make-local-variable 'comment-start-skip) (setq comment-start-skip "\\(^\\|\\s-\\);?#+ *") (make-local-variable 'comment-indent-hook) (setq comment-indent-hook 'perl-comment-indent) (make-local-variable 'parse-sexp-ignore-comments) (setq parse-sexp-ignore-comments nil) (run-hooks 'perl-mode-hook)) ;; This is used by indent-for-comment ;; to decide how much to indent a comment in Perl code ;; based on its context. (defun perl-comment-indent () (if (and (bolp) (not (eolp))) 0 ;Existing comment at bol stays there. (save-excursion (skip-chars-backward " \t") (max (1+ (current-column)) ;Else indent at comment column comment-column)))) ; except leave at least one space. (defun electric-perl-terminator (arg) "Insert character. If at end-of-line, and not in a comment or a quote, correct the line's indentation." (interactive "P") (let ((insertpos (point))) (and (not arg) ; decide whether to indent (eolp) (save-excursion (beginning-of-line) (and (not ; eliminate comments quickly (re-search-forward comment-start-skip insertpos t)) (or (/= last-command-char ?:) ;; Colon is special only after a label .... (looking-at "\\s-*\\(\\w\\|\\s_\\)+$")) (let ((pps (parse-partial-sexp (perl-beginning-of-function) insertpos))) (not (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))) (progn ; must insert, indent, delete (insert-char last-command-char 1) (perl-indent-line) (delete-char -1)))) (self-insert-command (prefix-numeric-value arg))) ;; not used anymore, but may be useful someday: ;;(defun perl-inside-parens-p () ;; (condition-case () ;; (save-excursion ;; (save-restriction ;; (narrow-to-region (point) ;; (perl-beginning-of-function)) ;; (goto-char (point-max)) ;; (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) ;; (error nil))) (defun perl-indent-command (&optional arg) "Indent current line as Perl code, or optionally, insert a tab character. With an argument, indent the current line, regardless of other options. If perl-tab-always-indent is nil and point is not in the indentation area at the beginning of the line, simply insert a tab. Otherwise, indent the current line. If point was within the indentation area it is moved to the end of the indentation area. If the line was already indented properly and point was not within the indentation area, and if perl-tab-to-comment is non-nil (the default), then do the first possible action from the following list: 1) delete an empty comment 2) move forward to start of comment, indenting if necessary 3) move forward to end of line 4) create an empty comment 5) move backward to start of comment, indenting if necessary." (interactive "P") (if arg ; If arg, just indent this line (perl-indent-line "\f") (if (and (not perl-tab-always-indent) (<= (current-column) (current-indentation))) (insert-tab) (let (bof lsexp delta (oldpnt (point))) (beginning-of-line) (setq lsexp (point)) (setq bof (perl-beginning-of-function)) (goto-char oldpnt) (setq delta (perl-indent-line "\f\\|;?#" bof)) (and perl-tab-to-comment (= oldpnt (point)) ; done if point moved (if (listp delta) ; if line starts in a quoted string (setq lsexp (or (nth 2 delta) bof)) (= delta 0)) ; done if indenting occurred (let (eol state) (end-of-line) (setq eol (point)) (if (= (char-after bof) ?=) (if (= oldpnt eol) (message "In a format statement")) (setq state (parse-partial-sexp lsexp eol)) (if (nth 3 state) (if (= oldpnt eol) ; already at eol in a string (message "In a string which starts with a %c." (nth 3 state))) (if (not (nth 4 state)) (if (= oldpnt eol) ; no comment, create one? (indent-for-comment)) (beginning-of-line) (if (re-search-forward comment-start-skip eol 'move) (if (eolp) (progn ; kill existing comment (goto-char (match-beginning 0)) (skip-chars-backward " \t") (kill-region (point) eol)) (if (or (< oldpnt (point)) (= oldpnt eol)) (indent-for-comment) ; indent existing comment (end-of-line))) (if (/= oldpnt eol) (end-of-line) (message "Use backslash to quote # characters.") (ding t)))))))))))) (defun perl-indent-line (&optional nochange parse-start) "Indent current line as Perl code. Return the amount the indentation changed by, or (parse-state) if line starts in a quoted string." (let ((case-fold-search nil) (pos (- (point-max) (point))) (bof (or parse-start (save-excursion (perl-beginning-of-function)))) beg indent shift-amt) (beginning-of-line) (setq beg (point)) (setq shift-amt (cond ((= (char-after bof) ?=) 0) ((listp (setq indent (calculate-perl-indent bof))) indent) ((looking-at (or nochange perl-nochange)) 0) (t (skip-chars-forward " \t\f") (cond ((looking-at "\\(\\w\\|\\s_\\)+:") (setq indent (max 1 (+ indent perl-label-offset)))) ((= (following-char) ?}) (setq indent (- indent perl-indent-level))) ((= (following-char) ?{) (setq indent (+ indent perl-brace-offset)))) (- indent (current-column))))) (skip-chars-forward " \t\f") (if (and (numberp shift-amt) (/= 0 shift-amt)) (progn (delete-region beg (point)) (indent-to indent))) ;; If initial point was within line's indentation, ;; position after the indentation. Else stay at same point in text. (if (> (- (point-max) pos) (point)) (goto-char (- (point-max) pos))) shift-amt)) (defun calculate-perl-indent (&optional parse-start) "Return appropriate indentation for current line as Perl code. In usual case returns an integer: the column to indent to. Returns (parse-state) if line starts inside a string." (save-excursion (beginning-of-line) (let ((indent-point (point)) (case-fold-search nil) (colon-line-end 0) state containing-sexp) (if parse-start ;used to avoid searching (goto-char parse-start) (perl-beginning-of-function)) (while (< (point) indent-point) ;repeat until right sexp (setq parse-start (point)) (setq state (parse-partial-sexp (point) indent-point 0)) ; state = (depth_in_parens innermost_containing_list last_complete_sexp ; string_terminator_or_nil inside_commentp following_quotep ; minimum_paren-depth_this_scan) ; Parsing stops if depth in parentheses becomes equal to third arg. (setq containing-sexp (nth 1 state))) (cond ((nth 3 state) state) ; In a quoted string? ((null containing-sexp) ; Line is at top level. (skip-chars-forward " \t\f") (if (= (following-char) ?{) 0 ; move to beginning of line if it starts a function body ;; indent a little if this is a continuation line (perl-backward-to-noncomment) (if (or (bobp) (memq (preceding-char) '(?\; ?\}))) 0 perl-continued-statement-offset))) ((/= (char-after containing-sexp) ?{) ;; line is expression, not statement: ;; indent to just after the surrounding open. (goto-char (1+ containing-sexp)) (current-column)) (t ;; Statement level. Is it a continuation or a new statement? ;; Find previous non-comment character. (perl-backward-to-noncomment) ;; Back up over label lines, since they don't ;; affect whether our line is a continuation. (while (or (eq (preceding-char) ?\,) (and (eq (preceding-char) ?:) (memq (char-syntax (char-after (- (point) 2))) '(?w ?_)))) (if (eq (preceding-char) ?\,) (perl-backward-to-start-of-continued-exp containing-sexp)) (beginning-of-line) (perl-backward-to-noncomment)) ;; Now we get the answer. (if (not (memq (preceding-char) '(?\; ?\} ?\{))) ;; This line is continuation of preceding line's statement; ;; indent perl-continued-statement-offset more than the ;; previous line of the statement. (progn (perl-backward-to-start-of-continued-exp containing-sexp) (+ perl-continued-statement-offset (current-column) (if (save-excursion (goto-char indent-point) (looking-at "[ \t]*{")) perl-continued-brace-offset 0))) ;; This line starts a new statement. ;; Position at last unclosed open. (goto-char containing-sexp) (or ;; If open paren is in col 0, close brace is special (and (bolp) (save-excursion (goto-char indent-point) (looking-at "[ \t]*}")) perl-indent-level) ;; Is line first statement after an open-brace? ;; If no, find that first statement and indent like it. (save-excursion (forward-char 1) ;; Skip over comments and labels following openbrace. (while (progn (skip-chars-forward " \t\f\n") (cond ((looking-at ";?#") (forward-line 1) t) ((looking-at "\\(\\w\\|\\s_\\)+:") (save-excursion (end-of-line) (setq colon-line-end (point))) (search-forward ":"))))) ;; The first following code counts ;; if it is before the line we want to indent. (and (< (point) indent-point) (if (> colon-line-end (point)) (- (current-indentation) perl-label-offset) (current-column)))) ;; If no previous statement, ;; indent it relative to line brace is on. ;; For open paren in column zero, don't let statement ;; start there too. If perl-indent-level is zero, ;; use perl-brace-offset + perl-continued-statement-offset ;; For open-braces not the first thing in a line, ;; add in perl-brace-imaginary-offset. (+ (if (and (bolp) (zerop perl-indent-level)) (+ perl-brace-offset perl-continued-statement-offset) perl-indent-level) ;; Move back over whitespace before the openbrace. ;; If openbrace is not first nonwhite thing on the line, ;; add the perl-brace-imaginary-offset. (progn (skip-chars-backward " \t") (if (bolp) 0 perl-brace-imaginary-offset)) ;; If the openbrace is preceded by a parenthesized exp, ;; move to the beginning of that; ;; possibly a different line (progn (if (eq (preceding-char) ?\)) (forward-sexp -1)) ;; Get initial indentation of the line we are on. (current-indentation)))))))))) (defun perl-backward-to-noncomment () "Move point backward to after the first non-white-space, skipping comments." (interactive) (let (opoint stop) (while (not stop) (setq opoint (point)) (beginning-of-line) (if (re-search-forward comment-start-skip opoint 'move 1) (progn (goto-char (match-end 1)) (skip-chars-forward ";"))) (skip-chars-backward " \t\f") (setq stop (or (bobp) (not (bolp)) (forward-char -1)))))) (defun perl-backward-to-start-of-continued-exp (lim) (if (= (preceding-char) ?\)) (forward-sexp -1)) (beginning-of-line) (if (<= (point) lim) (goto-char (1+ lim))) (skip-chars-forward " \t\f")) ;; note: this may be slower than the c-mode version, but I can understand it. (defun indent-perl-exp () "Indent each line of the Perl grouping following point." (interactive) (let* ((case-fold-search nil) (oldpnt (point-marker)) (bof-mark (save-excursion (end-of-line 2) (perl-beginning-of-function) (point-marker))) eol last-mark lsexp-mark delta) (if (= (char-after (marker-position bof-mark)) ?=) (message "Can't indent a format statement") (message "Indenting Perl expression...") (save-excursion (end-of-line) (setq eol (point))) (save-excursion ; locate matching close paren (while (and (not (eobp)) (<= (point) eol)) (parse-partial-sexp (point) (point-max) 0)) (setq last-mark (point-marker))) (setq lsexp-mark bof-mark) (beginning-of-line) (while (< (point) (marker-position last-mark)) (setq delta (perl-indent-line nil (marker-position bof-mark))) (if (numberp delta) ; unquoted start-of-line? (progn (if (eolp) (delete-horizontal-space)) (setq lsexp-mark (point-marker)))) (end-of-line) (setq eol (point)) (if (nth 4 (parse-partial-sexp (marker-position lsexp-mark) eol)) (progn ; line ends in a comment (beginning-of-line) (if (or (not (looking-at "\\s-*;?#")) (listp delta) (and (/= 0 delta) (= (- (current-indentation) delta) comment-column))) (if (re-search-forward comment-start-skip eol t) (indent-for-comment))))) ; indent existing comment (forward-line 1)) (goto-char (marker-position oldpnt)) (message "Indenting Perl expression...done")))) (defun perl-beginning-of-function (&optional arg) "Move backward to next beginning-of-function, or as far as possible. With argument, repeat that many times; negative args move forward. Returns new value of point in all cases." (interactive "p") (or arg (setq arg 1)) (if (< arg 0) (forward-char 1)) (and (/= arg 0) (re-search-backward "^\\s(\\|^\\s-*sub\\b[^{]+{\\|^\\s-*format\\b[^=]*=\\|^\\." nil 'move arg) (goto-char (1- (match-end 0)))) (point)) ;; note: this routine is adapted directly from emacs lisp.el, end-of-defun; ;; no bugs have been removed :-) (defun perl-end-of-function (&optional arg) "Move forward to next end-of-function. The end of a function is found by moving forward from the beginning of one. With argument, repeat that many times; negative args move backward." (interactive "p") (or arg (setq arg 1)) (let ((first t)) (while (and (> arg 0) (< (point) (point-max))) (let ((pos (point)) npos) (while (progn (if (and first (progn (forward-char 1) (perl-beginning-of-function 1) (not (bobp)))) nil (or (bobp) (forward-char -1)) (perl-beginning-of-function -1)) (setq first nil) (forward-list 1) (skip-chars-forward " \t") (if (looking-at "[#\n]") (forward-line 1)) (<= (point) pos)))) (setq arg (1- arg))) (while (< arg 0) (let ((pos (point))) (perl-beginning-of-function 1) (forward-sexp 1) (forward-line 1) (if (>= (point) pos) (if (progn (perl-beginning-of-function 2) (not (bobp))) (progn (forward-list 1) (skip-chars-forward " \t") (if (looking-at "[#\n]") (forward-line 1))) (goto-char (point-min))))) (setq arg (1+ arg))))) (defun mark-perl-function () "Put mark at end of Perl function, point at beginning." (interactive) (push-mark (point)) (perl-end-of-function) (push-mark (point)) (perl-beginning-of-function) (backward-paragraph)) ;;;;;;;; That's all, folks! ;;;;;;;;; l to third arg. (setq containing-sexp (nth 1 state))) (cond ((nth 3 state) state) ; In a quoted string? ((null containing-sexp) ; Line is at top level. (skip-chars-forward " \t\f") (if (= (following-char) ?{) 0 ; move to beginning of line if it starts a function body ;; inperl5.000/emacs/perldb.el 644 203 12 36516 5240620446 10341 ;; Run perl -d under Emacs ;; Based on gdb.el, as written by W. Schelter, and modified by rms. ;; Modified for Perl by Ray Lischner (uunet!mntgfx!lisch), Nov 1990. ;; This file is part of GNU Emacs. ;; Copyright (C) 1988,1990 Free Software Foundation, Inc. ;; GNU Emacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY. No author or distributor accepts responsibility ;; to anyone for the consequences of using it or for whether it serves ;; any particular purpose or works at all, unless he says so in writing. ;; Refer to the GNU Emacs General Public License for full details. ;; Everyone is granted permission to copy, modify and redistribute GNU ;; Emacs, but only under the conditions described in the GNU Emacs ;; General Public License. A copy of this license is supposed to have ;; been given to you along with GNU Emacs so you can know your rights and ;; responsibilities. It should be in a file named COPYING. Among other ;; things, the copyright notice and this notice must be preserved on all ;; copies. ;; Description of perl -d interface: ;; A facility is provided for the simultaneous display of the source code ;; in one window, while using perldb to step through a function in the ;; other. A small arrow in the source window, indicates the current ;; line. ;; Starting up: ;; In order to use this facility, invoke the command PERLDB to obtain a ;; shell window with the appropriate command bindings. You will be asked ;; for the name of a file to run and additional command line arguments. ;; Perldb will be invoked on this file, in a window named *perldb-foo* ;; if the file is foo. ;; M-s steps by one line, and redisplays the source file and line. ;; You may easily create additional commands and bindings to interact ;; with the display. For example to put the perl debugger command n on \M-n ;; (def-perldb n "\M-n") ;; This causes the emacs command perldb-next to be defined, and runs ;; perldb-display-frame after the command. ;; perldb-display-frame is the basic display function. It tries to display ;; in the other window, the file and line corresponding to the current ;; position in the perldb window. For example after a perldb-step, it would ;; display the line corresponding to the position for the last step. Or ;; if you have done a backtrace in the perldb buffer, and move the cursor ;; into one of the frames, it would display the position corresponding to ;; that frame. ;; perldb-display-frame is invoked automatically when a filename-and-line-number ;; appears in the output. (require 'shell) (defvar perldb-prompt-pattern "^ DB<[0-9]+> " "A regexp to recognize the prompt for perldb.") (defvar perldb-mode-map nil "Keymap for perldb-mode.") (if perldb-mode-map nil (setq perldb-mode-map (copy-keymap shell-mode-map)) (define-key perldb-mode-map "\C-l" 'perldb-refresh)) (define-key ctl-x-map " " 'perldb-break) (define-key ctl-x-map "&" 'send-perldb-command) ;;Of course you may use `def-perldb' with any other perldb command, including ;;user defined ones. (defmacro def-perldb (name key &optional doc) (let* ((fun (intern (concat "perldb-" name)))) (` (progn (defun (, fun) (arg) (, (or doc "")) (interactive "p") (perldb-call (if (not (= 1 arg)) (concat (, name) arg) (, name)))) (define-key perldb-mode-map (, key) (quote (, fun))))))) (def-perldb "s" "\M-s" "Step one source line with display") (def-perldb "n" "\M-n" "Step one source line (skip functions)") (def-perldb "c" "\M-c" "Continue with display") (def-perldb "r" "\C-c\C-r" "Return from current subroutine") (def-perldb "A" "\C-c\C-a" "Delete all actions") (defun perldb-mode () "Major mode for interacting with an inferior Perl debugger process. The following commands are available: \\{perldb-mode-map} \\[perldb-display-frame] displays in the other window the last line referred to in the perldb buffer. \\[perldb-s],\\[perldb-n], and \\[perldb-n] in the perldb window, call perldb to step, next or continue and then update the other window with the current file and position. If you are in a source file, you may select a point to break at, by doing \\[perldb-break]. Commands: Many commands are inherited from shell mode. Additionally we have: \\[perldb-display-frame] display frames file in other window \\[perldb-s] advance one line in program \\[perldb-n] advance one line in program (skip over calls). \\[send-perldb-command] used for special printing of an arg at the current point. C-x SPACE sets break point at current line." (interactive) (kill-all-local-variables) (setq major-mode 'perldb-mode) (setq mode-name "Inferior Perl") (setq mode-line-process '(": %s")) (use-local-map perldb-mode-map) (make-local-variable 'last-input-start) (setq last-input-start (make-marker)) (make-local-variable 'last-input-end) (setq last-input-end (make-marker)) (make-local-variable 'perldb-last-frame) (setq perldb-last-frame nil) (make-local-variable 'perldb-last-frame-displayed-p) (setq perldb-last-frame-displayed-p t) (make-local-variable 'perldb-delete-prompt-marker) (setq perldb-delete-prompt-marker nil) (make-local-variable 'perldb-filter-accumulator) (setq perldb-filter-accumulator nil) (make-local-variable 'shell-prompt-pattern) (setq shell-prompt-pattern perldb-prompt-pattern) (run-hooks 'shell-mode-hook 'perldb-mode-hook)) (defvar current-perldb-buffer nil) (defvar perldb-command-name "perl" "Pathname for executing perl -d.") (defun end-of-quoted-arg (argstr start end) (let* ((chr (substring argstr start (1+ start))) (idx (string-match (concat "[^\\]" chr) argstr (1+ start)))) (and idx (1+ idx)) ) ) (defun parse-args-helper (arglist argstr start end) (while (and (< start end) (string-match "[ \t\n\f\r\b]" (substring argstr start (1+ start)))) (setq start (1+ start))) (cond ((= start end) arglist) ((string-match "[\"']" (substring argstr start (1+ start))) (let ((next (end-of-quoted-arg argstr start end))) (parse-args-helper (cons (substring argstr (1+ start) next) arglist) argstr (1+ next) end))) (t (let ((next (string-match "[ \t\n\f\b\r]" argstr start))) (if next (parse-args-helper (cons (substring argstr start next) arglist) argstr (1+ next) end) (cons (substring argstr start) arglist)))) ) ) (defun parse-args (args) "Extract arguments from a string ARGS. White space separates arguments, with single or double quotes used to protect spaces. A list of strings is returned, e.g., (parse-args \"foo bar 'two args'\") => (\"foo\" \"bar\" \"two args\")." (nreverse (parse-args-helper '() args 0 (length args))) ) (defun perldb (path args) "Run perldb on program FILE in buffer *perldb-FILE*. The default directory for the current buffer becomes the initial working directory, by analogy with gdb . If you wish to change this, use the Perl command `chdir(DIR)'." (interactive "FRun perl -d on file: \nsCommand line arguments: ") (setq path (expand-file-name path)) (let ((file (file-name-nondirectory path)) (dir default-directory)) (switch-to-buffer (concat "*perldb-" file "*")) (setq default-directory dir) (or (bolp) (newline)) (insert "Current directory is " default-directory "\n") (apply 'make-shell (concat "perldb-" file) perldb-command-name nil "-d" path "-emacs" (parse-args args)) (perldb-mode) (set-process-filter (get-buffer-process (current-buffer)) 'perldb-filter) (set-process-sentinel (get-buffer-process (current-buffer)) 'perldb-sentinel) (perldb-set-buffer))) (defun perldb-set-buffer () (cond ((eq major-mode 'perldb-mode) (setq current-perldb-buffer (current-buffer))))) ;; This function is responsible for inserting output from Perl ;; into the buffer. ;; Aside from inserting the text, it notices and deletes ;; each filename-and-line-number; ;; that Perl prints to identify the selected frame. ;; It records the filename and line number, and maybe displays that file. (defun perldb-filter (proc string) (let ((inhibit-quit t)) (if perldb-filter-accumulator (perldb-filter-accumulate-marker proc (concat perldb-filter-accumulator string)) (perldb-filter-scan-input proc string)))) (defun perldb-filter-accumulate-marker (proc string) (setq perldb-filter-accumulator nil) (if (> (length string) 1) (if (= (aref string 1) ?\032) (let ((end (string-match "\n" string))) (if end (progn (let* ((first-colon (string-match ":" string 2)) (second-colon (string-match ":" string (1+ first-colon)))) (setq perldb-last-frame (cons (substring string 2 first-colon) (string-to-int (substring string (1+ first-colon) second-colon))))) (setq perldb-last-frame-displayed-p nil) (perldb-filter-scan-input proc (substring string (1+ end)))) (setq perldb-filter-accumulator string))) (perldb-filter-insert proc "\032") (perldb-filter-scan-input proc (substring string 1))) (setq perldb-filter-accumulator string))) (defun perldb-filter-scan-input (proc string) (if (equal string "") (setq perldb-filter-accumulator nil) (let ((start (string-match "\032" string))) (if start (progn (perldb-filter-insert proc (substring string 0 start)) (perldb-filter-accumulate-marker proc (substring string start))) (perldb-filter-insert proc string))))) (defun perldb-filter-insert (proc string) (let ((moving (= (point) (process-mark proc))) (output-after-point (< (point) (process-mark proc))) (old-buffer (current-buffer)) start) (set-buffer (process-buffer proc)) (unwind-protect (save-excursion ;; Insert the text, moving the process-marker. (goto-char (process-mark proc)) (setq start (point)) (insert string) (set-marker (process-mark proc) (point)) (perldb-maybe-delete-prompt) ;; Check for a filename-and-line number. (perldb-display-frame ;; Don't display the specified file ;; unless (1) point is at or after the position where output appears ;; and (2) this buffer is on the screen. (or output-after-point (not (get-buffer-window (current-buffer)))) ;; Display a file only when a new filename-and-line-number appears. t)) (set-buffer old-buffer)) (if moving (goto-char (process-mark proc))))) (defun perldb-sentinel (proc msg) (cond ((null (buffer-name (process-buffer proc))) ;; buffer killed ;; Stop displaying an arrow in a source file. (setq overlay-arrow-position nil) (set-process-buffer proc nil)) ((memq (process-status proc) '(signal exit)) ;; Stop displaying an arrow in a source file. (setq overlay-arrow-position nil) ;; Fix the mode line. (setq mode-line-process (concat ": " (symbol-name (process-status proc)))) (let* ((obuf (current-buffer))) ;; save-excursion isn't the right thing if ;; process-buffer is current-buffer (unwind-protect (progn ;; Write something in *compilation* and hack its mode line, (set-buffer (process-buffer proc)) ;; Force mode line redisplay soon (set-buffer-modified-p (buffer-modified-p)) (if (eobp) (insert ?\n mode-name " " msg) (save-excursion (goto-char (point-max)) (insert ?\n mode-name " " msg))) ;; If buffer and mode line will show that the process ;; is dead, we can delete it now. Otherwise it ;; will stay around until M-x list-processes. (delete-process proc)) ;; Restore old buffer, but don't restore old point ;; if obuf is the perldb buffer. (set-buffer obuf)))))) (defun perldb-refresh () "Fix up a possibly garbled display, and redraw the arrow." (interactive) (redraw-display) (perldb-display-frame)) (defun perldb-display-frame (&optional nodisplay noauto) "Find, obey and delete the last filename-and-line marker from PERLDB. The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n. Obeying it means displaying in another window the specified file and line." (interactive) (perldb-set-buffer) (and perldb-last-frame (not nodisplay) (or (not perldb-last-frame-displayed-p) (not noauto)) (progn (perldb-display-line (car perldb-last-frame) (cdr perldb-last-frame)) (setq perldb-last-frame-displayed-p t)))) ;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen ;; and that its line LINE is visible. ;; Put the overlay-arrow on the line LINE in that buffer. (defun perldb-display-line (true-file line) (let* ((buffer (find-file-noselect true-file)) (window (display-buffer buffer t)) (pos)) (save-excursion (set-buffer buffer) (save-restriction (widen) (goto-line line) (setq pos (point)) (setq overlay-arrow-string "=>") (or overlay-arrow-position (setq overlay-arrow-position (make-marker))) (set-marker overlay-arrow-position (point) (current-buffer))) (cond ((or (< pos (point-min)) (> pos (point-max))) (widen) (goto-char pos)))) (set-window-point window overlay-arrow-position))) (defun perldb-call (command) "Invoke perldb COMMAND displaying source in other window." (interactive) (goto-char (point-max)) (setq perldb-delete-prompt-marker (point-marker)) (perldb-set-buffer) (send-string (get-buffer-process current-perldb-buffer) (concat command "\n"))) (defun perldb-maybe-delete-prompt () (if (and perldb-delete-prompt-marker (> (point-max) (marker-position perldb-delete-prompt-marker))) (let (start) (goto-char perldb-delete-prompt-marker) (setq start (point)) (beginning-of-line) (delete-region (point) start) (setq perldb-delete-prompt-marker nil)))) (defun perldb-break () "Set PERLDB breakpoint at this source line." (interactive) (let ((line (save-restriction (widen) (1+ (count-lines 1 (point)))))) (send-string (get-buffer-process current-perldb-buffer) (concat "b " line "\n")))) (defun perldb-read-token() "Return a string containing the token found in the buffer at point. A token can be a number or an identifier. If the token is a name prefaced by `$', `@', or `%', the leading character is included in the token." (save-excursion (let (begin) (or (looking-at "[$@%]") (re-search-backward "[^a-zA-Z_0-9]" (point-min) 'move)) (setq begin (point)) (or (looking-at "[$@%]") (setq begin (+ begin 1))) (forward-char 1) (buffer-substring begin (if (re-search-forward "[^a-zA-Z_0-9]" (point-max) 'move) (- (point) 1) (point))) ))) (defvar perldb-commands nil "List of strings or functions used by send-perldb-command. It is for customization by the user.") (defun send-perldb-command (arg) "Issue a Perl debugger command selected by the prefix arg. A numeric arg selects the ARG'th member COMMAND of the list perldb-commands. The token under the cursor is passed to the command. If COMMAND is a string, (format COMMAND TOKEN) is inserted at the end of the perldb buffer, otherwise (funcall COMMAND TOKEN) is inserted. If there is no such COMMAND, then the token itself is inserted. For example, \"p %s\" is a possible string to be a member of perldb-commands, or \"p $ENV{%s}\"." (interactive "P") (let (comm token) (if arg (setq comm (nth arg perldb-commands))) (setq token (perldb-read-token)) (if (eq (current-buffer) current-perldb-buffer) (set-mark (point))) (cond (comm (setq comm (if (stringp comm) (format comm token) (funcall comm token)))) (t (setq comm token))) (switch-to-buffer-other-window current-perldb-buffer) (goto-char (dot-max)) (insert-string comm))) s (current-buffer)) 'perldb-filter) (set-process-sentinel (get-buffer-process (current-buffer)) 'perldb-sentinel) (perldb-set-buffer))) (defun perldb-set-buffer () (coperl5.000/emacs/perldb.pl 644 203 12 32734 5576233260 10360 package DB; # modified Perl debugger, to be run from Emacs in perldb-mode # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 $header = '$RCSfile: perldb.pl,v $$Revision: 4.1 $$Date: 92/08/07 17:20:59 $'; # # This file is automatically included if you do perl -d. # It's probably not useful to include this yourself. # # Perl supplies the values for @line and %sub. It effectively inserts # a do DB'DB(); in front of every place that can # have a breakpoint. It also inserts a do 'perldb.pl' before the first line. # # $Log: perldb.pl,v $ open(IN, "/dev/tty") || open(OUT, ">&STDOUT"); # so we don't dongle stdout select(OUT); $| = 1; # for DB'OUT select(STDOUT); $| = 1; # for real STDOUT $sub = ''; # Is Perl being run from Emacs? $emacs = $main'ARGV[$[] eq '-emacs'; shift(@main'ARGV) if $emacs; $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; print OUT "\nLoading DB routines from $header\n\nEnter h for help.\n\n"; sub DB { &save; ($package, $filename, $line) = caller; $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' . "package $package;"; # this won't let them modify, alas local(*dbline) = "_<$filename"; $max = $#dbline; if (($stop,$action) = split(/\0/,$dbline{$line})) { if ($stop eq '1') { $signal |= 1; } else { $evalarg = "\$DB'signal |= do {$stop;}"; &eval; $dbline{$line} =~ s/;9($|\0)/$1/; } } if ($single || $trace || $signal) { if ($emacs) { print OUT "\032\032$filename:$line:0\n"; } else { print OUT "$package'" unless $sub =~ /'/; print OUT "$sub($filename:$line):\t",$dbline[$line]; for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { last if $dbline[$i] =~ /^\s*(}|#|\n)/; print OUT "$sub($filename:$i):\t",$dbline[$i]; } } } $evalarg = $action, &eval if $action; if ($single || $signal) { $evalarg = $pre, &eval if $pre; print OUT $#stack . " levels deep in subroutine calls!\n" if $single & 4; $start = $line; while ((print OUT " DB<", $#hist+1, "> "), $cmd=&gets) { $single = 0; $signal = 0; $cmd eq '' && exit 0; chop($cmd); $cmd =~ s/\\$// && do { print OUT " cont: "; $cmd .= &gets; redo; }; $cmd =~ /^q$/ && exit 0; $cmd =~ /^$/ && ($cmd = $laststep); push(@hist,$cmd) if length($cmd) > 1; ($i) = split(/\s+/,$cmd); eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i}; $cmd =~ /^h$/ && do { print OUT " T Stack trace. s Single step. n Next, steps over subroutine calls. r Return from current subroutine. c [line] Continue; optionally inserts a one-time-only breakpoint at the specified line. Repeat last n or s. l min+incr List incr+1 lines starting at min. l min-max List lines. l line List line; l List next window. - List previous window. w line List window around line. l subname List subroutine. f filename Switch to filename. /pattern/ Search forwards for pattern; final / is optional. ?pattern? Search backwards for pattern. L List breakpoints and actions. S List subroutine names. t Toggle trace mode. b [line] [condition] Set breakpoint; line defaults to the current execution line; condition breaks if it evaluates to true, defaults to \'1\'. b subname [condition] Set breakpoint at first line of subroutine. d [line] Delete breakpoint. D Delete all breakpoints. a [line] command Set an action to be done before the line is executed. Sequence is: check for breakpoint, print line if necessary, do action, prompt user if breakpoint or step, evaluate line. A Delete all actions. V [pkg [vars]] List some (default all) variables in package (default current). X [vars] Same as \"V currentpackage [vars]\". < command Define command before prompt. | command Define command after prompt. ! number Redo command (default previous command). ! -number Redo number\'th to last command. H -number Display last number commands (default all). q or ^D Quit. p expr Same as \"print DB'OUT expr\" in current package. = [alias value] Define a command alias, or list current aliases. command Execute as a perl statement in current package. "; next; }; $cmd =~ /^t$/ && do { $trace = !$trace; print OUT "Trace = ".($trace?"on":"off")."\n"; next; }; $cmd =~ /^S$/ && do { foreach $subname (sort(keys %sub)) { print OUT $subname,"\n"; } next; }; $cmd =~ s/^X\b/V $package/; $cmd =~ /^V$/ && do { $cmd = 'V $package'; }; $cmd =~ /^V\s*(\S+)\s*(.*)/ && do { $packname = $1; @vars = split(' ',$2); do 'dumpvar.pl' unless defined &main'dumpvar; if (defined &main'dumpvar) { &main'dumpvar($packname,@vars); } else { print DB'OUT "dumpvar.pl not available.\n"; } next; }; $cmd =~ /^f\s*(.*)/ && do { $file = $1; if (!$file) { print OUT "The old f command is now the r command.\n"; print OUT "The new f command switches filenames.\n"; next; } if (!defined $_main{'_<' . $file}) { if (($try) = grep(m#^_<.*$file#, keys %_main)) { $file = substr($try,2); print "\n$file:\n"; } } if (!defined $_main{'_<' . $file}) { print OUT "There's no code here anything matching $file.\n"; next; } elsif ($file ne $filename) { *dbline = "_<$file"; $max = $#dbline; $filename = $file; $start = 1; $cmd = "l"; } }; $cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do { $subname = $1; $subname = "main'" . $subname unless $subname =~ /'/; $subname = "main" . $subname if substr($subname,0,1) eq "'"; ($file,$subrange) = split(/:/,$sub{$subname}); if ($file ne $filename) { *dbline = "_<$file"; $max = $#dbline; $filename = $file; } if ($subrange) { if (eval($subrange) < -$window) { $subrange =~ s/-.*/+/; } $cmd = "l $subrange"; } else { print OUT "Subroutine $1 not found.\n"; next; } }; $cmd =~ /^w\s*(\d*)$/ && do { $incr = $window - 1; $start = $1 if $1; $start -= $preview; $cmd = 'l ' . $start . '-' . ($start + $incr); }; $cmd =~ /^-$/ && do { $incr = $window - 1; $cmd = 'l ' . ($start-$window*2) . '+'; }; $cmd =~ /^l$/ && do { $incr = $window - 1; $cmd = 'l ' . $start . '-' . ($start + $incr); }; $cmd =~ /^l\s*(\d*)\+(\d*)$/ && do { $start = $1 if $1; $incr = $2; $incr = $window - 1 unless $incr; $cmd = 'l ' . $start . '-' . ($start + $incr); }; $cmd =~ /^l\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do { $end = (!$2) ? $max : ($4 ? $4 : $2); $end = $max if $end > $max; $i = $2; $i = $line if $i eq '.'; $i = 1 if $i < 1; if ($emacs) { print OUT "\032\032$filename:$i:0\n"; $i = $end; } else { for (; $i <= $end; $i++) { print OUT "$i:\t", $dbline[$i]; last if $signal; } } $start = $i; # remember in case they want more $start = $max if $start > $max; next; }; $cmd =~ /^D$/ && do { print OUT "Deleting all breakpoints...\n"; for ($i = 1; $i <= $max ; $i++) { if (defined $dbline{$i}) { $dbline{$i} =~ s/^[^\0]+//; if ($dbline{$i} =~ s/^\0?$//) { delete $dbline{$i}; } } } next; }; $cmd =~ /^L$/ && do { for ($i = 1; $i <= $max; $i++) { if (defined $dbline{$i}) { print OUT "$i:\t", $dbline[$i]; ($stop,$action) = split(/\0/, $dbline{$i}); print OUT " break if (", $stop, ")\n" if $stop; print OUT " action: ", $action, "\n" if $action; last if $signal; } } next; }; $cmd =~ /^b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do { $subname = $1; $cond = $2 || '1'; $subname = "$package'" . $subname unless $subname =~ /'/; $subname = "main" . $subname if substr($subname,0,1) eq "'"; ($filename,$i) = split(/[:-]/, $sub{$subname}); if ($i) { *dbline = "_<$filename"; ++$i while $dbline[$i] == 0 && $i < $#dbline; $dbline{$i} =~ s/^[^\0]*/$cond/; } else { print OUT "Subroutine $subname not found.\n"; } next; }; $cmd =~ /^b\s*(\d*)\s*(.*)/ && do { $i = ($1?$1:$line); $cond = $2 || '1'; if ($dbline[$i] == 0) { print OUT "Line $i not breakable.\n"; } else { $dbline{$i} =~ s/^[^\0]*/$cond/; } next; }; $cmd =~ /^d\s*(\d+)?/ && do { $i = ($1?$1:$line); $dbline{$i} =~ s/^[^\0]*//; delete $dbline{$i} if $dbline{$i} eq ''; next; }; $cmd =~ /^A$/ && do { for ($i = 1; $i <= $max ; $i++) { if (defined $dbline{$i}) { $dbline{$i} =~ s/\0[^\0]*//; delete $dbline{$i} if $dbline{$i} eq ''; } } next; }; $cmd =~ /^<\s*(.*)/ && do { $pre = do action($1); next; }; $cmd =~ /^>\s*(.*)/ && do { $post = do action($1); next; }; $cmd =~ /^a\s*(\d+)(\s+(.*))?/ && do { $i = $1; if ($dbline[$i] == 0) { print OUT "Line $i may not have an action.\n"; } else { $dbline{$i} =~ s/\0[^\0]*//; $dbline{$i} .= "\0" . do action($3); } next; }; $cmd =~ /^n$/ && do { $single = 2; $laststep = $cmd; last; }; $cmd =~ /^s$/ && do { $single = 1; $laststep = $cmd; last; }; $cmd =~ /^c\s*(\d*)\s*$/ && do { $i = $1; if ($i) { if ($dbline[$i] == 0) { print OUT "Line $i not breakable.\n"; next; } $dbline{$i} =~ s/(\0|$)/;9$1/; # add one-time-only b.p. } for ($i=0; $i <= $#stack; ) { $stack[$i++] &= ~1; } last; }; $cmd =~ /^r$/ && do { $stack[$#stack] |= 2; last; }; $cmd =~ /^T$/ && do { local($p,$f,$l,$s,$h,$a,@a,@sub); for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { @a = @args; for (@a) { if (/^StB\000/ && length($_) == length($_main{'_main'})) { $_ = sprintf("%s",$_); } else { s/'/\\'/g; s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; } } $w = $w ? '@ = ' : '$ = '; $a = $h ? '(' . join(', ', @a) . ')' : ''; push(@sub, "$w&$s$a from file $f line $l\n"); last if $signal; } for ($i=0; $i <= $#sub; $i++) { last if $signal; print OUT $sub[$i]; } next; }; $cmd =~ /^\/(.*)$/ && do { $inpat = $1; $inpat =~ s:([^\\])/$:$1:; if ($inpat ne "") { eval '$inpat =~ m'."\n$inpat\n"; if ($@ ne "") { print OUT "$@"; next; } $pat = $inpat; } $end = $start; eval ' for (;;) { ++$start; $start = 1 if ($start > $max); last if ($start == $end); if ($dbline[$start] =~ m'."\n$pat\n".'i) { if ($emacs) { print OUT "\032\032$filename:$start:0\n"; } else { print OUT "$start:\t", $dbline[$start], "\n"; } last; } } '; print OUT "/$pat/: not found\n" if ($start == $end); next; }; $cmd =~ /^\?(.*)$/ && do { $inpat = $1; $inpat =~ s:([^\\])\?$:$1:; if ($inpat ne "") { eval '$inpat =~ m'."\n$inpat\n"; if ($@ ne "") { print OUT "$@"; next; } $pat = $inpat; } $end = $start; eval ' for (;;) { --$start; $start = $max if ($start <= 0); last if ($start == $end); if ($dbline[$start] =~ m'."\n$pat\n".'i) { if ($emacs) { print OUT "\032\032$filename:$start:0\n"; } else { print OUT "$start:\t", $dbline[$start], "\n"; } last; } } '; print OUT "?$pat?: not found\n" if ($start == $end); next; }; $cmd =~ /^!+\s*(-)?(\d+)?$/ && do { pop(@hist) if length($cmd) > 1; $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist)); $cmd = $hist[$i] . "\n"; print OUT $cmd; redo; }; $cmd =~ /^!(.+)$/ && do { $pat = "^$1"; pop(@hist) if length($cmd) > 1; for ($i = $#hist; $i; --$i) { last if $hist[$i] =~ $pat; } if (!$i) { print OUT "No such command!\n\n"; next; } $cmd = $hist[$i] . "\n"; print OUT $cmd; redo; }; $cmd =~ /^H\s*(-(\d+))?/ && do { $end = $2?($#hist-$2):0; $hist = 0 if $hist < 0; for ($i=$#hist; $i>$end; $i--) { print OUT "$i: ",$hist[$i],"\n" unless $hist[$i] =~ /^.?$/; }; next; }; $cmd =~ s/^p( .*)?$/print DB'OUT$1/; $cmd =~ /^=/ && do { if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) { $alias{$k}="s~$k~$v~"; print OUT "$k = $v\n"; } elsif ($cmd =~ /^=\s*$/) { foreach $k (sort keys(%alias)) { if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) { print OUT "$k = $v\n"; } else { print OUT "$k\t$alias{$k}\n"; }; }; }; next; }; $evalarg = $cmd; &eval; print OUT "\n"; } if ($post) { $evalarg = $post; &eval; } } ($@, $!, $[, $,, $/, $\) = @saved; } sub save { @saved = ($@, $!, $[, $,, $/, $\); $[ = 0; $, = ""; $/ = "\n"; $\ = ""; } # The following takes its argument via $evalarg to preserve current @_ sub eval { eval "$usercontext $evalarg; &DB'save"; print OUT $@; } sub action { local($action) = @_; while ($action =~ s/\\$//) { print OUT "+ "; $action .= &gets; } $action; } sub gets { local($.); ; } sub catch { $signal = 1; } sub sub { push(@stack, $single); $single &= 1; $single |= 4 if $#stack == $deep; if (wantarray) { @i = &$sub; $single |= pop(@stack); @i; } else { $i = &$sub; $single |= pop(@stack); $i; } } $single = 1; # so it stops on first executable statement @hist = ('?'); $SIG{'INT'} = "DB'catch"; $deep = 100; # warning if stack gets this deep $window = 10; $preview = 3; @stack = (0); @ARGS = @ARGV; for (@args) { s/'/\\'/g; s/(.*)/'$1'/ unless /^-?[\d.]+$/; } if (-f '.perldb') { do './.perldb'; } elsif (-f "$ENV{'LOGDIR'}/.perldb") { do "$ENV{'LOGDIR'}/.perldb"; } elsif (-f "$ENV{'HOME'}/.perldb") { do "$ENV{'HOME'}/.perldb"; } 1; = $line if $i eq '.'; $i = 1 if $perl5.000/emacs/tedstuff 644 203 12 27420 5240620452 10305 Article 4417 of comp.lang.perl: Path: jpl-devvax!elroy.jpl.nasa.gov!decwrl!mcnc!uvaarpa!mmdf From: ted@evi.com (Ted Stefanik) Newsgroups: comp.lang.perl Subject: Correction to Perl fatal error marking in GNU Emacs Message-ID: <1991Feb27.065853.15801@uvaarpa.Virginia.EDU> Date: 27 Feb 91 06:58:53 GMT Sender: mmdf@uvaarpa.Virginia.EDU (Uvaarpa Mail System) Reply-To: ted@evi.com (Ted Stefanik) Organization: The Internet Lines: 282 Reading my own message, it occurred to me that I didn't quite satisfy the request of stef@zweig.sun (Stephane Payrard): | Does anyone has extended perdb/perdb.el to position the | point to the first syntax error? It would be cool. What I posted is a way to use the "M-x compile" command to test perl scripts. (Needless to say, the script cannot be not interactive; you can't provide input to a *compilation* buffer). When creating new Perl programs, I use "M-x compile" until I'm sure that they are syntatically correct; if syntax errors occur, C-x` takes me to each in sequence. After I'm sure the syntax is correct, I start worrying about semantics, and switch to "M-x perldb" if necessary. Therefore, the stuff I posted works great with "M-x compile", but not at all with "M-x perldb". Next, let me update what I posted. I found that perl's die() command doesn't print the same format error message as perl does when it dies with a syntax error. If you put the following in your ".emacs" file, it causes C-x` to recognize both kinds of errors: (load-library "compile") (setq compilation-error-regexp "\\([^ :\n]+\\(: *\\|, line \\|(\\)[0-9]+\\)\\|\\([0-9]+ *of *[^ \n]+\\|[^ \n]+ \\(at \\)*line [0-9]+\\)") Last, so I don't look like a total fool, let me propose a way to satisfy Stephane Payrard's original request (repeated again): | Does anyone has extended perdb/perdb.el to position the | point to the first syntax error? It would be cool. I'm not satisfied with just the "first syntax error". Perl's parser is better than most about not getting out of sync; therefore, if it reports multiple errors, you can usually be assured they are all real errors. So... I hacked in the "next-error" function from "compile.el" to form "perldb-next-error". You can apply the patches at the end of this message to add "perldb-next-error" to your "perldb.el". Notes: 1) The patch binds "perldb-next-error" to C-x~ (because ~ is the shift of ` on my keyboard, and C-x~ is not yet taken in my version of EMACS). 2) "next-error" is meant to work on a single *compilation* buffer; any new "M-x compile" or "M-x grep" command will clear the old *compilation* buffer and reset the compilation-error parser to start at the top of the *compilation* buffer. "perldb-next-error", on the other hand, has to deal with multiple *perldb-* buffers, each of which keep growing. "perldb-next-error" correctly handles the constantly growing *perldb-* buffers by keeping track of the last reported error in the "current-perldb-buffer". Sadly however, when you invoke a new "M-x perldb" on a different Perl script, "perldb-next-error" will start parsing the new *perldb-* buffer at the top (even if it was previously parsed), and will completely lose the marker of the last reported error in *perldb-*. 3) "perldb-next-error" still uses "compilation-error-regexp" to find fatal errors. Therefore, both the "M-x compile"/C-x` scheme and the "M-x perldb"/C-x~ scheme can be used to find fatal errors that match the common "compilation-error-regexp". You *will* want to install that "compilation-error-regexp" stuff into your .emacs file. 4) The patch was developed and tested with GNU Emacs 18.55. 5) Since the patch was ripped off from compile.el, the code is (of course) subject to the GNU copyleft. *** perldb.el.orig Wed Feb 27 00:44:27 1991 --- perldb.el Wed Feb 27 00:44:30 1991 *************** *** 199,205 **** (defun perldb-set-buffer () (cond ((eq major-mode 'perldb-mode) ! (setq current-perldb-buffer (current-buffer))))) ;; This function is responsible for inserting output from Perl ;; into the buffer. --- 199,211 ---- (defun perldb-set-buffer () (cond ((eq major-mode 'perldb-mode) ! (cond ((not (eq current-perldb-buffer (current-buffer))) ! (perldb-forget-errors) ! (setq perldb-parsing-end 2)) ;; 2 to defeat grep defeater ! (t ! (if (> perldb-parsing-end (point-max)) ! (setq perldb-parsing-end (max (point-max) 2))))) ! (setq current-perldb-buffer (current-buffer))))) ;; This function is responsible for inserting output from Perl ;; into the buffer. *************** *** 291,297 **** ;; process-buffer is current-buffer (unwind-protect (progn ! ;; Write something in *compilation* and hack its mode line, (set-buffer (process-buffer proc)) ;; Force mode line redisplay soon (set-buffer-modified-p (buffer-modified-p)) --- 297,303 ---- ;; process-buffer is current-buffer (unwind-protect (progn ! ;; Write something in *perldb-* and hack its mode line, (set-buffer (process-buffer proc)) ;; Force mode line redisplay soon (set-buffer-modified-p (buffer-modified-p)) *************** *** 421,423 **** --- 427,593 ---- (switch-to-buffer-other-window current-perldb-buffer) (goto-char (dot-max)) (insert-string comm))) + + (defvar perldb-error-list nil + "List of error message descriptors for visiting erring functions. + Each error descriptor is a list of length two. + Its car is a marker pointing to an error message. + Its cadr is a marker pointing to the text of the line the message is about, + or nil if that is not interesting. + The value may be t instead of a list; + this means that the buffer of error messages should be reparsed + the next time the list of errors is wanted.") + + (defvar perldb-parsing-end nil + "Position of end of buffer when last error messages parsed.") + + (defvar perldb-error-message "No more fatal Perl errors" + "Message to print when no more matches for compilation-error-regexp are found") + + (defun perldb-next-error (&optional argp) + "Visit next perldb error message and corresponding source code. + This operates on the output from the \\[perldb] command. + If all preparsed error messages have been processed, + the error message buffer is checked for new ones. + A non-nil argument (prefix arg, if interactive) + means reparse the error message buffer and start at the first error." + (interactive "P") + (if (or (eq perldb-error-list t) + argp) + (progn (perldb-forget-errors) + (setq perldb-parsing-end 2))) ;; 2 to defeat grep defeater + (if perldb-error-list + nil + (save-excursion + (switch-to-buffer current-perldb-buffer) + (perldb-parse-errors))) + (let ((next-error (car perldb-error-list))) + (if (null next-error) + (error (concat perldb-error-message + (if (and (get-buffer-process current-perldb-buffer) + (eq (process-status + (get-buffer-process + current-perldb-buffer)) + 'run)) + " yet" "")))) + (setq perldb-error-list (cdr perldb-error-list)) + (if (null (car (cdr next-error))) + nil + (switch-to-buffer (marker-buffer (car (cdr next-error)))) + (goto-char (car (cdr next-error))) + (set-marker (car (cdr next-error)) nil)) + (let* ((pop-up-windows t) + (w (display-buffer (marker-buffer (car next-error))))) + (set-window-point w (car next-error)) + (set-window-start w (car next-error))) + (set-marker (car next-error) nil))) + + ;; Set perldb-error-list to nil, and + ;; unchain the markers that point to the error messages and their text, + ;; so that they no longer slow down gap motion. + ;; This would happen anyway at the next garbage collection, + ;; but it is better to do it right away. + (defun perldb-forget-errors () + (if (eq perldb-error-list t) + (setq perldb-error-list nil)) + (while perldb-error-list + (let ((next-error (car perldb-error-list))) + (set-marker (car next-error) nil) + (if (car (cdr next-error)) + (set-marker (car (cdr next-error)) nil))) + (setq perldb-error-list (cdr perldb-error-list)))) + + (defun perldb-parse-errors () + "Parse the current buffer as error messages. + This makes a list of error descriptors, perldb-error-list. + For each source-file, line-number pair in the buffer, + the source file is read in, and the text location is saved in perldb-error-list. + The function next-error, assigned to \\[next-error], takes the next error off the list + and visits its location." + (setq perldb-error-list nil) + (message "Parsing error messages...") + (let (text-buffer + last-filename last-linenum) + ;; Don't reparse messages already seen at last parse. + (goto-char perldb-parsing-end) + ;; Don't parse the first two lines as error messages. + ;; This matters for grep. + (if (bobp) + (forward-line 2)) + (while (re-search-forward compilation-error-regexp nil t) + (let (linenum filename + error-marker text-marker) + ;; Extract file name and line number from error message. + (save-restriction + (narrow-to-region (match-beginning 0) (match-end 0)) + (goto-char (point-max)) + (skip-chars-backward "[0-9]") + ;; If it's a lint message, use the last file(linenum) on the line. + ;; Normally we use the first on the line. + (if (= (preceding-char) ?\() + (progn + (narrow-to-region (point-min) (1+ (buffer-size))) + (end-of-line) + (re-search-backward compilation-error-regexp) + (skip-chars-backward "^ \t\n") + (narrow-to-region (point) (match-end 0)) + (goto-char (point-max)) + (skip-chars-backward "[0-9]"))) + ;; Are we looking at a "filename-first" or "line-number-first" form? + (if (looking-at "[0-9]") + (progn + (setq linenum (read (current-buffer))) + (goto-char (point-min))) + ;; Line number at start, file name at end. + (progn + (goto-char (point-min)) + (setq linenum (read (current-buffer))) + (goto-char (point-max)) + (skip-chars-backward "^ \t\n"))) + (setq filename (perldb-grab-filename))) + ;; Locate the erring file and line. + (if (and (equal filename last-filename) + (= linenum last-linenum)) + nil + (beginning-of-line 1) + (setq error-marker (point-marker)) + ;; text-buffer gets the buffer containing this error's file. + (if (not (equal filename last-filename)) + (setq text-buffer + (and (file-exists-p (setq last-filename filename)) + (find-file-noselect filename)) + last-linenum 0)) + (if text-buffer + ;; Go to that buffer and find the erring line. + (save-excursion + (set-buffer text-buffer) + (if (zerop last-linenum) + (progn + (goto-char 1) + (setq last-linenum 1))) + (forward-line (- linenum last-linenum)) + (setq last-linenum linenum) + (setq text-marker (point-marker)) + (setq perldb-error-list + (cons (list error-marker text-marker) + perldb-error-list))))) + (forward-line 1))) + (setq perldb-parsing-end (point-max))) + (message "Parsing error messages...done") + (setq perldb-error-list (nreverse perldb-error-list))) + + (defun perldb-grab-filename () + "Return a string which is a filename, starting at point. + Ignore quotes and parentheses around it, as well as trailing colons." + (if (eq (following-char) ?\") + (save-restriction + (narrow-to-region (point) + (progn (forward-sexp 1) (point))) + (goto-char (point-min)) + (read (current-buffer))) + (buffer-substring (point) + (progn + (skip-chars-forward "^ :,\n\t(") + (point))))) + + (define-key ctl-x-map "~" 'perldb-next-error) GNU copyleft. *** perldb.el.orig Wed Feb 27 00:44:27 1991 --- perldb.el Wed Feb 27 00:44:30 1991 *************** *** 199,205 **** (defun perldb-set-buffer () (cond ((eq major-mode 'perldb-mode) ! (setq current-perldb-buffer (curperl5.000/embed.h 664 203 12 122021 5650572636 6725 /* This file is derived from global.sym and interp.sym */ /* (Doing namespace management portably in C is really gross.) */ #ifdef EMBED /* globals we need to hide from the world */ #define AMG_names Perl_AMG_names #define No Perl_No #define Sv Perl_Sv #define Xpv Perl_Xpv #define Yes Perl_Yes #define abs_amg Perl_abs_amg #define add_amg Perl_add_amg #define add_ass_amg Perl_add_ass_amg #define additem Perl_additem #define amagic_generation Perl_amagic_generation #define an Perl_an #define atan2_amg Perl_atan2_amg #define autoboot_preamble Perl_autoboot_preamble #define band_amg Perl_band_amg #define bool__amg Perl_bool__amg #define bor_amg Perl_bor_amg #define buf Perl_buf #define bufend Perl_bufend #define bufptr Perl_bufptr #define bxor_amg Perl_bxor_amg #define check Perl_check #define coeff Perl_coeff #define compiling Perl_compiling #define compl_amg Perl_compl_amg #define comppad Perl_comppad #define comppad_name Perl_comppad_name #define comppad_name_fill Perl_comppad_name_fill #define concat_amg Perl_concat_amg #define concat_ass_amg Perl_concat_ass_amg #define cop_seqmax Perl_cop_seqmax #define cos_amg Perl_cos_amg #define cryptseen Perl_cryptseen #define cryptswitch_add Perl_cryptswitch_add #define cshlen Perl_cshlen #define cshname Perl_cshname #define curcop Perl_curcop #define curinterp Perl_curinterp #define curpad Perl_curpad #define dc Perl_dc #define dec_amg Perl_dec_amg #define di Perl_di #define div_amg Perl_div_amg #define div_ass_amg Perl_div_ass_amg #define ds Perl_ds #define egid Perl_egid #define envgv Perl_envgv #define eq_amg Perl_eq_amg #define error_count Perl_error_count #define euid Perl_euid #define evalseq Perl_evalseq #define exp_amg Perl_exp_amg #define expect Perl_expect #define expectterm Perl_expectterm #define fallback_amg Perl_fallback_amg #define fold Perl_fold #define freq Perl_freq #define ge_amg Perl_ge_amg #define gid Perl_gid #define gt_amg Perl_gt_amg #define hexdigit Perl_hexdigit #define hints Perl_hints #define in_my Perl_in_my #define inc_amg Perl_inc_amg #define know_next Perl_know_next #define last_lop Perl_last_lop #define last_lop_op Perl_last_lop_op #define last_uni Perl_last_uni #define le_amg Perl_le_amg #define lex_state Perl_lex_state #define lex_defer Perl_lex_defer #define lex_expect Perl_lex_expect #define lex_brackets Perl_lex_brackets #define lex_formbrack Perl_lex_formbrack #define lex_fakebrack Perl_lex_fakebrack #define lex_casemods Perl_lex_casemods #define lex_dojoin Perl_lex_dojoin #define lex_starts Perl_lex_starts #define lex_stuff Perl_lex_stuff #define lex_repl Perl_lex_repl #define lex_op Perl_lex_op #define lex_inpat Perl_lex_inpat #define lex_inwhat Perl_lex_inwhat #define lex_brackstack Perl_lex_brackstack #define lex_casestack Perl_lex_casestack #define linestr Perl_linestr #define log_amg Perl_log_amg #define lshift_amg Perl_lshift_amg #define lshift_ass_amg Perl_lshift_ass_amg #define lt_amg Perl_lt_amg #define markstack Perl_markstack #define markstack_max Perl_markstack_max #define markstack_ptr Perl_markstack_ptr #define max_intro_pending Perl_max_intro_pending #define min_intro_pending Perl_min_intro_pending #define mod_amg Perl_mod_amg #define mod_ass_amg Perl_mod_ass_amg #define mult_amg Perl_mult_amg #define mult_ass_amg Perl_mult_ass_amg #define multi_close Perl_multi_close #define multi_end Perl_multi_end #define multi_open Perl_multi_open #define multi_start Perl_multi_start #define na Perl_na #define ncmp_amg Perl_ncmp_amg #define nextval Perl_nextval #define nexttype Perl_nexttype #define nexttoke Perl_nexttoke #define ne_amg Perl_ne_amg #define neg_amg Perl_neg_amg #define nexttype Perl_nexttype #define nextval Perl_nextval #define no_aelem Perl_no_aelem #define no_dir_func Perl_no_dir_func #define no_func Perl_no_func #define no_helem Perl_no_helem #define no_mem Perl_no_mem #define no_modify Perl_no_modify #define no_security Perl_no_security #define no_sock_func Perl_no_sock_func #define no_usym Perl_no_usym #define nointrp Perl_nointrp #define nomem Perl_nomem #define nomemok Perl_nomemok #define nomethod_amg Perl_nomethod_amg #define not_amg Perl_not_amg #define numer_amg Perl_numer_amg #define oldbufptr Perl_oldbufptr #define oldoldbufptr Perl_oldoldbufptr #define op Perl_op #define op_name Perl_op_name #define op_seqmax Perl_op_seqmax #define opargs Perl_opargs #define origalen Perl_origalen #define origenviron Perl_origenviron #define padix Perl_padix #define patleave Perl_patleave #define pow_amg Perl_pow_amg #define pow_ass_amg Perl_pow_ass_amg #define ppaddr Perl_ppaddr #define profiledata Perl_profiledata #define qrt_amg Perl_qrt_amg #define rcsid Perl_rcsid #define reall_srchlen Perl_reall_srchlen #define regarglen Perl_regarglen #define regbol Perl_regbol #define regcode Perl_regcode #define regdummy Perl_regdummy #define regendp Perl_regendp #define regeol Perl_regeol #define regfold Perl_regfold #define reginput Perl_reginput #define reglastparen Perl_reglastparen #define regmyendp Perl_regmyendp #define regmyp_size Perl_regmyp_size #define regmystartp Perl_regmystartp #define regnarrate Perl_regnarrate #define regnaughty Perl_regnaughty #define regnpar Perl_regnpar #define regparse Perl_regparse #define regprecomp Perl_regprecomp #define regprev Perl_regprev #define regsawback Perl_regsawback #define regsize Perl_regsize #define regstartp Perl_regstartp #define regtill Perl_regtill #define regxend Perl_regxend #define repeat_amg Perl_repeat_amg #define repeat_ass_amg Perl_repeat_ass_amg #define retstack Perl_retstack #define retstack_ix Perl_retstack_ix #define retstack_max Perl_retstack_max #define rsfp Perl_rsfp #define rshift_amg Perl_rshift_amg #define rshift_ass_amg Perl_rshift_ass_amg #define savestack Perl_savestack #define savestack_ix Perl_savestack_ix #define savestack_max Perl_savestack_max #define saw_return Perl_saw_return #define scmp_amg Perl_scmp_amg #define scopestack Perl_scopestack #define scopestack_ix Perl_scopestack_ix #define scopestack_max Perl_scopestack_max #define scrgv Perl_scrgv #define seq_amg Perl_seq_amg #define sge_amg Perl_sge_amg #define sgt_amg Perl_sgt_amg #define sig_name Perl_sig_name #define siggv Perl_siggv #define sighandler Perl_sighandler #define simple Perl_simple #define sin_amg Perl_sin_amg #define sle_amg Perl_sle_amg #define slt_amg Perl_slt_amg #define sne_amg Perl_sne_amg #define stack Perl_stack #define stack_base Perl_stack_base #define stack_max Perl_stack_max #define stack_sp Perl_stack_sp #define statbuf Perl_statbuf #define string_amg Perl_string_amg #define sub_generation Perl_sub_generation #define subline Perl_subline #define subname Perl_subname #define subtr_amg Perl_subtr_amg #define subtr_ass_amg Perl_subtr_ass_amg #define sv_no Perl_sv_no #define sv_undef Perl_sv_undef #define sv_yes Perl_sv_yes #define tainting Perl_tainting #define thisexpr Perl_thisexpr #define timesbuf Perl_timesbuf #define tokenbuf Perl_tokenbuf #define uid Perl_uid #define varies Perl_varies #define vert Perl_vert #define vtbl_amagic Perl_vtbl_amagic #define vtbl_amagicelem Perl_vtbl_amagicelem #define vtbl_arylen Perl_vtbl_arylen #define vtbl_bm Perl_vtbl_bm #define vtbl_dbline Perl_vtbl_dbline #define vtbl_env Perl_vtbl_env #define vtbl_envelem Perl_vtbl_envelem #define vtbl_glob Perl_vtbl_glob #define vtbl_isa Perl_vtbl_isa #define vtbl_isaelem Perl_vtbl_isaelem #define vtbl_mglob Perl_vtbl_mglob #define vtbl_pack Perl_vtbl_pack #define vtbl_packelem Perl_vtbl_packelem #define vtbl_pos Perl_vtbl_pos #define vtbl_sig Perl_vtbl_sig #define vtbl_sigelem Perl_vtbl_sigelem #define vtbl_substr Perl_vtbl_substr #define vtbl_sv Perl_vtbl_sv #define vtbl_taint Perl_vtbl_taint #define vtbl_uvar Perl_vtbl_uvar #define vtbl_vec Perl_vtbl_vec #define warn_nl Perl_warn_nl #define warn_nosemi Perl_warn_nosemi #define warn_reserved Perl_warn_reserved #define watchaddr Perl_watchaddr #define watchok Perl_watchok #define yychar Perl_yychar #define yycheck Perl_yycheck #define yydebug Perl_yydebug #define yydefred Perl_yydefred #define yydgoto Perl_yydgoto #define yyerrflag Perl_yyerrflag #define yygindex Perl_yygindex #define yylen Perl_yylen #define yylhs Perl_yylhs #define yylval Perl_yylval #define yyname Perl_yyname #define yynerrs Perl_yynerrs #define yyrindex Perl_yyrindex #define yyrule Perl_yyrule #define yysindex Perl_yysindex #define yytable Perl_yytable #define yyval Perl_yyval #define append_elem Perl_append_elem #define append_list Perl_append_list #define apply Perl_apply #define av_clear Perl_av_clear #define av_fake Perl_av_fake #define av_fetch Perl_av_fetch #define av_fill Perl_av_fill #define av_len Perl_av_len #define av_make Perl_av_make #define av_pop Perl_av_pop #define av_push Perl_av_push #define av_shift Perl_av_shift #define av_store Perl_av_store #define av_undef Perl_av_undef #define av_unshift Perl_av_unshift #define bind_match Perl_bind_match #define block_end Perl_block_end #define block_start Perl_block_start #define calllist Perl_calllist #define cando Perl_cando #define check_uni Perl_check_uni #define checkcomma Perl_checkcomma #define ck_aelem Perl_ck_aelem #define ck_concat Perl_ck_concat #define ck_eof Perl_ck_eof #define ck_eval Perl_ck_eval #define ck_exec Perl_ck_exec #define ck_formline Perl_ck_formline #define ck_ftst Perl_ck_ftst #define ck_fun Perl_ck_fun #define ck_glob Perl_ck_glob #define ck_grep Perl_ck_grep #define ck_gvconst Perl_ck_gvconst #define ck_index Perl_ck_index #define ck_lengthconst Perl_ck_lengthconst #define ck_lfun Perl_ck_lfun #define ck_listiob Perl_ck_listiob #define ck_match Perl_ck_match #define ck_null Perl_ck_null #define ck_repeat Perl_ck_repeat #define ck_retarget Perl_ck_retarget #define ck_rvconst Perl_ck_rvconst #define ck_select Perl_ck_select #define ck_shift Perl_ck_shift #define ck_sort Perl_ck_sort #define ck_spair Perl_ck_spair #define ck_split Perl_ck_split #define ck_subr Perl_ck_subr #define ck_trunc Perl_ck_trunc #define convert Perl_convert #define cpytill Perl_cpytill #define croak Perl_croak #define cv_undef Perl_cv_undef #define cxinc Perl_cxinc #define deb Perl_deb #define deb_growlevel Perl_deb_growlevel #define debop Perl_debop #define debstack Perl_debstack #define debstackptrs Perl_debstackptrs #define deprecate Perl_deprecate #define die Perl_die #define die_where Perl_die_where #define do_aexec Perl_do_aexec #define do_chop Perl_do_chop #define do_close Perl_do_close #define do_eof Perl_do_eof #define do_exec Perl_do_exec #define do_execfree Perl_do_execfree #define do_ipcctl Perl_do_ipcctl #define do_ipcget Perl_do_ipcget #define do_join Perl_do_join #define do_kv Perl_do_kv #define do_msgrcv Perl_do_msgrcv #define do_msgsnd Perl_do_msgsnd #define do_open Perl_do_open #define do_pipe Perl_do_pipe #define do_print Perl_do_print #define do_readline Perl_do_readline #define do_chomp Perl_do_chomp #define do_seek Perl_do_seek #define do_semop Perl_do_semop #define do_shmio Perl_do_shmio #define do_sprintf Perl_do_sprintf #define do_tell Perl_do_tell #define do_trans Perl_do_trans #define do_vecset Perl_do_vecset #define do_vop Perl_do_vop #define doeval Perl_doeval #define dofindlabel Perl_dofindlabel #define dopoptoeval Perl_dopoptoeval #define dump_all Perl_dump_all #define dump_eval Perl_dump_eval #define dump_gv Perl_dump_gv #define dump_op Perl_dump_op #define dump_packsubs Perl_dump_packsubs #define dump_pm Perl_dump_pm #define dump_sub Perl_dump_sub #define fbm_compile Perl_fbm_compile #define fbm_instr Perl_fbm_instr #define fetch_gv Perl_fetch_gv #define fetch_io Perl_fetch_io #define fold_constants Perl_fold_constants #define force_ident Perl_force_ident #define force_next Perl_force_next #define force_word Perl_force_word #define free_tmps Perl_free_tmps #define gen_constant_list Perl_gen_constant_list #define gp_free Perl_gp_free #define gp_ref Perl_gp_ref #define gv_AVadd Perl_gv_AVadd #define gv_HVadd Perl_gv_HVadd #define gv_check Perl_gv_check #define gv_efullname Perl_gv_efullname #define gv_fetchfile Perl_gv_fetchfile #define gv_fetchmeth Perl_gv_fetchmeth #define gv_fetchmethod Perl_gv_fetchmethod #define gv_fetchpv Perl_gv_fetchpv #define gv_fullname Perl_gv_fullname #define gv_init Perl_gv_init #define gv_stashpv Perl_gv_stashpv #define gv_stashsv Perl_gv_stashsv #define he_delayfree Perl_he_delayfree #define he_free Perl_he_free #define hoistmust Perl_hoistmust #define hv_clear Perl_hv_clear #define hv_delete Perl_hv_delete #define hv_exists Perl_hv_exists #define hv_fetch Perl_hv_fetch #define hv_stashpv Perl_hv_stashpv #define hv_iterinit Perl_hv_iterinit #define hv_iterkey Perl_hv_iterkey #define hv_iternext Perl_hv_iternext #define hv_iterval Perl_hv_iterval #define hv_magic Perl_hv_magic #define hv_store Perl_hv_store #define hv_undef Perl_hv_undef #define ibcmp Perl_ibcmp #define ingroup Perl_ingroup #define instr Perl_instr #define intuit_more Perl_intuit_more #define invert Perl_invert #define jmaybe Perl_jmaybe #define keyword Perl_keyword #define leave_scope Perl_leave_scope #define lex_end Perl_lex_end #define lex_start Perl_lex_start #define linklist Perl_linklist #define list Perl_list #define listkids Perl_listkids #define localize Perl_localize #define looks_like_number Perl_looks_like_number #define magic_clearpack Perl_magic_clearpack #define magic_get Perl_magic_get #define magic_getarylen Perl_magic_getarylen #define magic_getglob Perl_magic_getglob #define magic_getpack Perl_magic_getpack #define magic_getpos Perl_magic_getpos #define magic_gettaint Perl_magic_gettaint #define magic_getuvar Perl_magic_getuvar #define magic_len Perl_magic_len #define magic_nextpack Perl_magic_nextpack #define magic_set Perl_magic_set #define magic_setamagic Perl_magic_setamagic #define magic_setarylen Perl_magic_setarylen #define magic_setbm Perl_magic_setbm #define magic_setdbline Perl_magic_setdbline #define magic_setenv Perl_magic_setenv #define magic_setglob Perl_magic_setglob #define magic_setisa Perl_magic_setisa #define magic_setmglob Perl_magic_setmglob #define magic_setpack Perl_magic_setpack #define magic_setpos Perl_magic_setpos #define magic_setsig Perl_magic_setsig #define magic_setsubstr Perl_magic_setsubstr #define magic_settaint Perl_magic_settaint #define magic_setuvar Perl_magic_setuvar #define magic_setvec Perl_magic_setvec #define magic_wipepack Perl_magic_wipepack #define magicname Perl_magicname #define markstack_grow Perl_markstack_grow #define mess Perl_mess #define mg_clear Perl_mg_clear #define mg_copy Perl_mg_copy #define mg_find Perl_mg_find #define mg_free Perl_mg_free #define mg_get Perl_mg_get #define mg_len Perl_mg_len #define mg_magical Perl_mg_magical #define mg_set Perl_mg_set #define mod Perl_mod #define modkids Perl_modkids #define moreswitches Perl_moreswitches #define my Perl_my #define my_exit Perl_my_exit #define my_lstat Perl_my_lstat #define my_pclose Perl_my_pclose #define my_popen Perl_my_popen #define my_setenv Perl_my_setenv #define my_stat Perl_my_stat #define my_unexec Perl_my_unexec #define newANONHASH Perl_newANONHASH #define newANONLIST Perl_newANONLIST #define newASSIGNOP Perl_newASSIGNOP #define newAV Perl_newAV #define newAVREF Perl_newAVREF #define newBINOP Perl_newBINOP #define newCONDOP Perl_newCONDOP #define newCVOP Perl_newCVOP #define newCVREF Perl_newCVREF #define newFORM Perl_newFORM #define newFOROP Perl_newFOROP #define newGVOP Perl_newGVOP #define newGVREF Perl_newGVREF #define newGVgen Perl_newGVgen #define newHV Perl_newHV #define newHVREF Perl_newHVREF #define newIO Perl_newIO #define newLISTOP Perl_newLISTOP #define newLOGOP Perl_newLOGOP #define newLOOPEX Perl_newLOOPEX #define newLOOPOP Perl_newLOOPOP #define newMETHOD Perl_newMETHOD #define newNULLLIST Perl_newNULLLIST #define newOP Perl_newOP #define newPROG Perl_newPROG #define newPMOP Perl_newPMOP #define newPVOP Perl_newPVOP #define newRANGE Perl_newRANGE #define newRV Perl_newRV #define newSLICEOP Perl_newSLICEOP #define newSTATEOP Perl_newSTATEOP #define newSUB Perl_newSUB #define newSV Perl_newSV #define newSVOP Perl_newSVOP #define newSVREF Perl_newSVREF #define newSViv Perl_newSViv #define newSVnv Perl_newSVnv #define newSVpv Perl_newSVpv #define newSVsv Perl_newSVsv #define newUNOP Perl_newUNOP #define newWHILEOP Perl_newWHILEOP #define newXSUB Perl_newXSUB #define newXS Perl_newXS #define nextargv Perl_nextargv #define ninstr Perl_ninstr #define no_fh_allowed Perl_no_fh_allowed #define no_op Perl_no_op #define oopsAV Perl_oopsAV #define oopsCV Perl_oopsCV #define oopsHV Perl_oopsHV #define op_free Perl_op_free #define package Perl_package #define pad_alloc Perl_pad_alloc #define pad_allocmy Perl_pad_allocmy #define pad_findmy Perl_pad_findmy #define pad_free Perl_pad_free #define pad_leavemy Perl_pad_leavemy #define pad_reset Perl_pad_reset #define pad_sv Perl_pad_sv #define pad_swipe Perl_pad_swipe #define peep Perl_peep #define pidgone Perl_pidgone #define pmruntime Perl_pmruntime #define pmtrans Perl_pmtrans #define pop_return Perl_pop_return #define pop_scope Perl_pop_scope #define pp_aassign Perl_pp_aassign #define pp_accept Perl_pp_accept #define pp_add Perl_pp_add #define pp_aelem Perl_pp_aelem #define pp_aelemfast Perl_pp_aelemfast #define pp_alarm Perl_pp_alarm #define pp_and Perl_pp_and #define pp_andassign Perl_pp_andassign #define pp_anonhash Perl_pp_anonhash #define pp_anonlist Perl_pp_anonlist #define pp_aslice Perl_pp_aslice #define pp_atan2 Perl_pp_atan2 #define pp_av2arylen Perl_pp_av2arylen #define pp_backtick Perl_pp_backtick #define pp_bind Perl_pp_bind #define pp_binmode Perl_pp_binmode #define pp_bit_and Perl_pp_bit_and #define pp_bit_or Perl_pp_bit_or #define pp_bless Perl_pp_bless #define pp_caller Perl_pp_caller #define pp_chdir Perl_pp_chdir #define pp_chmod Perl_pp_chmod #define pp_chop Perl_pp_chop #define pp_chown Perl_pp_chown #define pp_chroot Perl_pp_chroot #define pp_close Perl_pp_close #define pp_closedir Perl_pp_closedir #define pp_complement Perl_pp_complement #define pp_concat Perl_pp_concat #define pp_cond_expr Perl_pp_cond_expr #define pp_connect Perl_pp_connect #define pp_const Perl_pp_const #define pp_cos Perl_pp_cos #define pp_crypt Perl_pp_crypt #define pp_cswitch Perl_pp_cswitch #define pp_dbmclose Perl_pp_dbmclose #define pp_dbmopen Perl_pp_dbmopen #define pp_dbstate Perl_pp_dbstate #define pp_defined Perl_pp_defined #define pp_delete Perl_pp_delete #define pp_die Perl_pp_die #define pp_divide Perl_pp_divide #define pp_dofile Perl_pp_dofile #define pp_dump Perl_pp_dump #define pp_each Perl_pp_each #define pp_egrent Perl_pp_egrent #define pp_ehostent Perl_pp_ehostent #define pp_enetent Perl_pp_enetent #define pp_enter Perl_pp_enter #define pp_entereval Perl_pp_entereval #define pp_enteriter Perl_pp_enteriter #define pp_enterloop Perl_pp_enterloop #define pp_entersub Perl_pp_entersub #define pp_entersubr Perl_pp_entersubr #define pp_entertry Perl_pp_entertry #define pp_enterwrite Perl_pp_enterwrite #define pp_eof Perl_pp_eof #define pp_eprotoent Perl_pp_eprotoent #define pp_epwent Perl_pp_epwent #define pp_eq Perl_pp_eq #define pp_eservent Perl_pp_eservent #define pp_evalonce Perl_pp_evalonce #define pp_exec Perl_pp_exec #define pp_exists Perl_pp_exists #define pp_exit Perl_pp_exit #define pp_exp Perl_pp_exp #define pp_fcntl Perl_pp_fcntl #define pp_fileno Perl_pp_fileno #define pp_flip Perl_pp_flip #define pp_flock Perl_pp_flock #define pp_flop Perl_pp_flop #define pp_fork Perl_pp_fork #define pp_formline Perl_pp_formline #define pp_ftatime Perl_pp_ftatime #define pp_ftbinary Perl_pp_ftbinary #define pp_ftblk Perl_pp_ftblk #define pp_ftchr Perl_pp_ftchr #define pp_ftctime Perl_pp_ftctime #define pp_ftdir Perl_pp_ftdir #define pp_fteexec Perl_pp_fteexec #define pp_fteowned Perl_pp_fteowned #define pp_fteread Perl_pp_fteread #define pp_ftewrite Perl_pp_ftewrite #define pp_ftfile Perl_pp_ftfile #define pp_ftis Perl_pp_ftis #define pp_ftlink Perl_pp_ftlink #define pp_ftmtime Perl_pp_ftmtime #define pp_ftpipe Perl_pp_ftpipe #define pp_ftrexec Perl_pp_ftrexec #define pp_ftrowned Perl_pp_ftrowned #define pp_ftrread Perl_pp_ftrread #define pp_ftrwrite Perl_pp_ftrwrite #define pp_ftsgid Perl_pp_ftsgid #define pp_ftsize Perl_pp_ftsize #define pp_ftsock Perl_pp_ftsock #define pp_ftsuid Perl_pp_ftsuid #define pp_ftsvtx Perl_pp_ftsvtx #define pp_fttext Perl_pp_fttext #define pp_fttty Perl_pp_fttty #define pp_ftzero Perl_pp_ftzero #define pp_ge Perl_pp_ge #define pp_getc Perl_pp_getc #define pp_getlogin Perl_pp_getlogin #define pp_getpeername Perl_pp_getpeername #define pp_getpgrp Perl_pp_getpgrp #define pp_getppid Perl_pp_getppid #define pp_getpriority Perl_pp_getpriority #define pp_getsockname Perl_pp_getsockname #define pp_ggrent Perl_pp_ggrent #define pp_ggrgid Perl_pp_ggrgid #define pp_ggrnam Perl_pp_ggrnam #define pp_ghbyaddr Perl_pp_ghbyaddr #define pp_ghbyname Perl_pp_ghbyname #define pp_ghostent Perl_pp_ghostent #define pp_glob Perl_pp_glob #define pp_gmtime Perl_pp_gmtime #define pp_gnbyaddr Perl_pp_gnbyaddr #define pp_gnbyname Perl_pp_gnbyname #define pp_gnetent Perl_pp_gnetent #define pp_goto Perl_pp_goto #define pp_gpbyname Perl_pp_gpbyname #define pp_gpbynumber Perl_pp_gpbynumber #define pp_gprotoent Perl_pp_gprotoent #define pp_gpwent Perl_pp_gpwent #define pp_gpwnam Perl_pp_gpwnam #define pp_gpwuid Perl_pp_gpwuid #define pp_grepstart Perl_pp_grepstart #define pp_grepwhile Perl_pp_grepwhile #define pp_gsbyname Perl_pp_gsbyname #define pp_gsbyport Perl_pp_gsbyport #define pp_gservent Perl_pp_gservent #define pp_gsockopt Perl_pp_gsockopt #define pp_gt Perl_pp_gt #define pp_gv Perl_pp_gv #define pp_gvsv Perl_pp_gvsv #define pp_helem Perl_pp_helem #define pp_hex Perl_pp_hex #define pp_hslice Perl_pp_hslice #define pp_index Perl_pp_index #define pp_indread Perl_pp_indread #define pp_int Perl_pp_int #define pp_interp Perl_pp_interp #define pp_ioctl Perl_pp_ioctl #define pp_iter Perl_pp_iter #define pp_join Perl_pp_join #define pp_keys Perl_pp_keys #define pp_kill Perl_pp_kill #define pp_last Perl_pp_last #define pp_lc Perl_pp_lc #define pp_lcfirst Perl_pp_lcfirst #define pp_le Perl_pp_le #define pp_leave Perl_pp_leave #define pp_leaveeval Perl_pp_leaveeval #define pp_leaveloop Perl_pp_leaveloop #define pp_leavesub Perl_pp_leavesub #define pp_leavetry Perl_pp_leavetry #define pp_leavewrite Perl_pp_leavewrite #define pp_left_shift Perl_pp_left_shift #define pp_length Perl_pp_length #define pp_lineseq Perl_pp_lineseq #define pp_link Perl_pp_link #define pp_list Perl_pp_list #define pp_listen Perl_pp_listen #define pp_localtime Perl_pp_localtime #define pp_log Perl_pp_log #define pp_lslice Perl_pp_lslice #define pp_lstat Perl_pp_lstat #define pp_lt Perl_pp_lt #define pp_map Perl_pp_map #define pp_match Perl_pp_match #define pp_method Perl_pp_method #define pp_mkdir Perl_pp_mkdir #define pp_modulo Perl_pp_modulo #define pp_msgctl Perl_pp_msgctl #define pp_msgget Perl_pp_msgget #define pp_msgrcv Perl_pp_msgrcv #define pp_msgsnd Perl_pp_msgsnd #define pp_multiply Perl_pp_multiply #define pp_ncmp Perl_pp_ncmp #define pp_ne Perl_pp_ne #define pp_negate Perl_pp_negate #define pp_next Perl_pp_next #define pp_nextstate Perl_pp_nextstate #define pp_not Perl_pp_not #define pp_nswitch Perl_pp_nswitch #define pp_null Perl_pp_null #define pp_oct Perl_pp_oct #define pp_open Perl_pp_open #define pp_open_dir Perl_pp_open_dir #define pp_or Perl_pp_or #define pp_orassign Perl_pp_orassign #define pp_ord Perl_pp_ord #define pp_pack Perl_pp_pack #define pp_padav Perl_pp_padav #define pp_padhv Perl_pp_padhv #define pp_padsv Perl_pp_padsv #define pp_pipe_op Perl_pp_pipe_op #define pp_pop Perl_pp_pop #define pp_pos Perl_pp_pos #define pp_postdec Perl_pp_postdec #define pp_postinc Perl_pp_postinc #define pp_pow Perl_pp_pow #define pp_predec Perl_pp_predec #define pp_preinc Perl_pp_preinc #define pp_print Perl_pp_print #define pp_prtf Perl_pp_prtf #define pp_push Perl_pp_push #define pp_pushmark Perl_pp_pushmark #define pp_pushre Perl_pp_pushre #define pp_rand Perl_pp_rand #define pp_range Perl_pp_range #define pp_rcatline Perl_pp_rcatline #define pp_read Perl_pp_read #define pp_readdir Perl_pp_readdir #define pp_readline Perl_pp_readline #define pp_readlink Perl_pp_readlink #define pp_recv Perl_pp_recv #define pp_redo Perl_pp_redo #define pp_ref Perl_pp_ref #define pp_refgen Perl_pp_refgen #define pp_regcmaybe Perl_pp_regcmaybe #define pp_regcomp Perl_pp_regcomp #define pp_rename Perl_pp_rename #define pp_repeat Perl_pp_repeat #define pp_require Perl_pp_require #define pp_reset Perl_pp_reset #define pp_return Perl_pp_return #define pp_reverse Perl_pp_reverse #define pp_rewinddir Perl_pp_rewinddir #define pp_right_shift Perl_pp_right_shift #define pp_rindex Perl_pp_rindex #define pp_rmdir Perl_pp_rmdir #define pp_rv2av Perl_pp_rv2av #define pp_rv2cv Perl_pp_rv2cv #define pp_rv2gv Perl_pp_rv2gv #define pp_rv2hv Perl_pp_rv2hv #define pp_rv2sv Perl_pp_rv2sv #define pp_chomp Perl_pp_chomp #define pp_sassign Perl_pp_sassign #define pp_scalar Perl_pp_scalar #define pp_schop Perl_pp_schop #define pp_scmp Perl_pp_scmp #define pp_scope Perl_pp_scope #define pp_seek Perl_pp_seek #define pp_seekdir Perl_pp_seekdir #define pp_select Perl_pp_select #define pp_semctl Perl_pp_semctl #define pp_semget Perl_pp_semget #define pp_semop Perl_pp_semop #define pp_send Perl_pp_send #define pp_seq Perl_pp_seq #define pp_setpgrp Perl_pp_setpgrp #define pp_setpriority Perl_pp_setpriority #define pp_sge Perl_pp_sge #define pp_sgrent Perl_pp_sgrent #define pp_sgt Perl_pp_sgt #define pp_shift Perl_pp_shift #define pp_shmctl Perl_pp_shmctl #define pp_shmget Perl_pp_shmget #define pp_shmread Perl_pp_shmread #define pp_shmwrite Perl_pp_shmwrite #define pp_shostent Perl_pp_shostent #define pp_shutdown Perl_pp_shutdown #define pp_sin Perl_pp_sin #define pp_sle Perl_pp_sle #define pp_sleep Perl_pp_sleep #define pp_slt Perl_pp_slt #define pp_sne Perl_pp_sne #define pp_snetent Perl_pp_snetent #define pp_socket Perl_pp_socket #define pp_sockpair Perl_pp_sockpair #define pp_sort Perl_pp_sort #define pp_splice Perl_pp_splice #define pp_split Perl_pp_split #define pp_sprintf Perl_pp_sprintf #define pp_sprotoent Perl_pp_sprotoent #define pp_spwent Perl_pp_spwent #define pp_sqrt Perl_pp_sqrt #define pp_srand Perl_pp_srand #define pp_srefgen Perl_pp_srefgen #define pp_schomp Perl_pp_schomp #define pp_sselect Perl_pp_sselect #define pp_sservent Perl_pp_sservent #define pp_ssockopt Perl_pp_ssockopt #define pp_stat Perl_pp_stat #define pp_stub Perl_pp_stub #define pp_study Perl_pp_study #define pp_subst Perl_pp_subst #define pp_substcont Perl_pp_substcont #define pp_substr Perl_pp_substr #define pp_subtract Perl_pp_subtract #define pp_sv2len Perl_pp_sv2len #define pp_symlink Perl_pp_symlink #define pp_syscall Perl_pp_syscall #define pp_sysread Perl_pp_sysread #define pp_system Perl_pp_system #define pp_syswrite Perl_pp_syswrite #define pp_tell Perl_pp_tell #define pp_telldir Perl_pp_telldir #define pp_tie Perl_pp_tie #define pp_time Perl_pp_time #define pp_tms Perl_pp_tms #define pp_trans Perl_pp_trans #define pp_truncate Perl_pp_truncate #define pp_uc Perl_pp_uc #define pp_ucfirst Perl_pp_ucfirst #define pp_umask Perl_pp_umask #define pp_undef Perl_pp_undef #define pp_unlink Perl_pp_unlink #define pp_unpack Perl_pp_unpack #define pp_unshift Perl_pp_unshift #define pp_unstack Perl_pp_unstack #define pp_untie Perl_pp_untie #define pp_utime Perl_pp_utime #define pp_values Perl_pp_values #define pp_vec Perl_pp_vec #define pp_wait Perl_pp_wait #define pp_waitpid Perl_pp_waitpid #define pp_wantarray Perl_pp_wantarray #define pp_warn Perl_pp_warn #define pp_xor Perl_pp_xor #define prepend_elem Perl_prepend_elem #define push_return Perl_push_return #define push_scope Perl_push_scope #define q Perl_q #define ref Perl_ref #define refkids Perl_refkids #define regcomp Perl_regcomp #define regdump Perl_regdump #define regexec Perl_regexec #define regfree Perl_regfree #define regnext Perl_regnext #define regprop Perl_regprop #define repeatcpy Perl_repeatcpy #define rninstr Perl_rninstr #define run Perl_run #define savepv Perl_savepv #define savepvn Perl_savepvn #define save_I32 Perl_save_I32 #define save_aptr Perl_save_aptr #define save_ary Perl_save_ary #define save_clearsv Perl_save_clearsv #define save_delete Perl_save_delete #define save_freeop Perl_save_freeop #define save_freepv Perl_save_freepv #define save_freesv Perl_save_freesv #define save_hash Perl_save_hash #define save_hptr Perl_save_hptr #define save_int Perl_save_int #define save_item Perl_save_item #define save_list Perl_save_list #define save_nogv Perl_save_nogv #define save_scalar Perl_save_scalar #define save_sptr Perl_save_sptr #define save_svref Perl_save_svref #define savestack_grow Perl_savestack_grow #define sawparens Perl_sawparens #define scalar Perl_scalar #define scalarkids Perl_scalarkids #define scalarseq Perl_scalarseq #define scalarvoid Perl_scalarvoid #define scan_const Perl_scan_const #define scan_formline Perl_scan_formline #define scan_heredoc Perl_scan_heredoc #define scan_hex Perl_scan_hex #define scan_ident Perl_scan_ident #define scan_inputsymbol Perl_scan_inputsymbol #define scan_num Perl_scan_num #define scan_oct Perl_scan_oct #define scan_pat Perl_scan_pat #define scan_prefix Perl_scan_prefix #define scan_str Perl_scan_str #define scan_subst Perl_scan_subst #define scan_trans Perl_scan_trans #define scan_word Perl_scan_word #define scope Perl_scope #define screaminstr Perl_screaminstr #define setenv_getix Perl_setenv_getix #define skipspace Perl_skipspace #define stack_grow Perl_stack_grow #define start_subparse Perl_start_subparse #define sublex_done Perl_sublex_done #define sublex_start Perl_sublex_start #define sv_2bool Perl_sv_2bool #define sv_2cv Perl_sv_2cv #define sv_2io Perl_sv_2io #define sv_2iv Perl_sv_2iv #define sv_2mortal Perl_sv_2mortal #define sv_2nv Perl_sv_2nv #define sv_2pv Perl_sv_2pv #define sv_backoff Perl_sv_backoff #define sv_bless Perl_sv_bless #define sv_catpv Perl_sv_catpv #define sv_catpvn Perl_sv_catpvn #define sv_catsv Perl_sv_catsv #define sv_chop Perl_sv_chop #define sv_clean_all Perl_sv_clean_all #define sv_clean_objs Perl_sv_clean_objs #define sv_clear Perl_sv_clear #define sv_cmp Perl_sv_cmp #define sv_dec Perl_sv_dec #define sv_dump Perl_sv_dump #define sv_eq Perl_sv_eq #define sv_free Perl_sv_free #define sv_gets Perl_sv_gets #define sv_grow Perl_sv_grow #define sv_inc Perl_sv_inc #define sv_insert Perl_sv_insert #define sv_isa Perl_sv_isa #define sv_len Perl_sv_len #define sv_magic Perl_sv_magic #define sv_mortalcopy Perl_sv_mortalcopy #define sv_newmortal Perl_sv_newmortal #define sv_peek Perl_sv_peek #define sv_ref Perl_sv_ref #define sv_replace Perl_sv_replace #define sv_report_used Perl_sv_report_used #define sv_reset Perl_sv_reset #define sv_setiv Perl_sv_setiv #define sv_setnv Perl_sv_setnv #define sv_setptrobj Perl_sv_setptrobj #define sv_setpv Perl_sv_setpv #define sv_setpvn Perl_sv_setpvn #define sv_setref_iv Perl_sv_setref_iv #define sv_setref_pv Perl_sv_setref_pv #define sv_setsv Perl_sv_setsv #define sv_unmagic Perl_sv_unmagic #define sv_upgrade Perl_sv_upgrade #define sv_usepvn Perl_sv_usepvn #define taint_env Perl_taint_env #define taint_not Perl_taint_not #define taint_proper Perl_taint_proper #define too_few_arguments Perl_too_few_arguments #define too_many_arguments Perl_too_many_arguments #define wait4pid Perl_wait4pid #define warn Perl_warn #define watch Perl_watch #define whichsig Perl_whichsig #define xiv_arenaroot Perl_xiv_arenaroot #define xiv_root Perl_xiv_root #define xnv_root Perl_xnv_root #define xpv_root Perl_xpv_root #define xrv_root Perl_xrv_root #define yyerror Perl_yyerror #define yyerror Perl_yyerror #define yylex Perl_yylex #define yyparse Perl_yyparse #define yywarn Perl_yywarn #endif /* EMBED */ /* Put interpreter specific symbols into a struct? */ #ifdef MULTIPLICITY #define Argv (curinterp->IArgv) #define Cmd (curinterp->ICmd) #define DBgv (curinterp->IDBgv) #define DBline (curinterp->IDBline) #define DBsignal (curinterp->IDBsignal) #define DBsingle (curinterp->IDBsingle) #define DBsub (curinterp->IDBsub) #define DBtrace (curinterp->IDBtrace) #define allgvs (curinterp->Iallgvs) #define ampergv (curinterp->Iampergv) #define argvgv (curinterp->Iargvgv) #define argvoutgv (curinterp->Iargvoutgv) #define basetime (curinterp->Ibasetime) #define beginav (curinterp->Ibeginav) #define bodytarget (curinterp->Ibodytarget) #define cddir (curinterp->Icddir) #define chopset (curinterp->Ichopset) #define copline (curinterp->Icopline) #define curblock (curinterp->Icurblock) #define curcop (curinterp->Icurcop) #define curcsv (curinterp->Icurcsv) #define curpm (curinterp->Icurpm) #define curstash (curinterp->Icurstash) #define curstname (curinterp->Icurstname) #define cxstack (curinterp->Icxstack) #define cxstack_ix (curinterp->Icxstack_ix) #define cxstack_max (curinterp->Icxstack_max) #define dbargs (curinterp->Idbargs) #define debdelim (curinterp->Idebdelim) #define debname (curinterp->Idebname) #define debstash (curinterp->Idebstash) #define debug (curinterp->Idebug) #define defgv (curinterp->Idefgv) #define defoutgv (curinterp->Idefoutgv) #define defstash (curinterp->Idefstash) #define delaymagic (curinterp->Idelaymagic) #define dirty (curinterp->Idirty) #define dlevel (curinterp->Idlevel) #define dlmax (curinterp->Idlmax) #define do_undump (curinterp->Ido_undump) #define doextract (curinterp->Idoextract) #define doswitches (curinterp->Idoswitches) #define dowarn (curinterp->Idowarn) #define dumplvl (curinterp->Idumplvl) #define e_fp (curinterp->Ie_fp) #define e_tmpname (curinterp->Ie_tmpname) #define endav (curinterp->Iendav) #define envgv (curinterp->Ienvgv) #define eval_root (curinterp->Ieval_root) #define eval_start (curinterp->Ieval_start) #define fdpid (curinterp->Ifdpid) #define filemode (curinterp->Ifilemode) #define firstgv (curinterp->Ifirstgv) #define forkprocess (curinterp->Iforkprocess) #define formfeed (curinterp->Iformfeed) #define formtarget (curinterp->Iformtarget) #define gensym (curinterp->Igensym) #define in_eval (curinterp->Iin_eval) #define incgv (curinterp->Iincgv) #define inplace (curinterp->Iinplace) #define last_in_gv (curinterp->Ilast_in_gv) #define lastfd (curinterp->Ilastfd) #define lastretstr (curinterp->Ilastretstr) #define lastscream (curinterp->Ilastscream) #define lastsize (curinterp->Ilastsize) #define lastspbase (curinterp->Ilastspbase) #define laststatval (curinterp->Ilaststatval) #define laststype (curinterp->Ilaststype) #define leftgv (curinterp->Ileftgv) #define lineary (curinterp->Ilineary) #define localizing (curinterp->Ilocalizing) #define main_root (curinterp->Imain_root) #define main_start (curinterp->Imain_start) #define mainstack (curinterp->Imainstack) #define maxscream (curinterp->Imaxscream) #define maxsysfd (curinterp->Imaxsysfd) #define minus_F (curinterp->Iminus_F) #define minus_a (curinterp->Iminus_a) #define minus_c (curinterp->Iminus_c) #define minus_l (curinterp->Iminus_l) #define minus_n (curinterp->Iminus_n) #define minus_p (curinterp->Iminus_p) #define multiline (curinterp->Imultiline) #define mystack_base (curinterp->Imystack_base) #define mystack_mark (curinterp->Imystack_mark) #define mystack_max (curinterp->Imystack_max) #define mystack_sp (curinterp->Imystack_sp) #define mystrk (curinterp->Imystrk) #define nrs (curinterp->Inrs) #define nrschar (curinterp->Inrschar) #define nrslen (curinterp->Inrslen) #define ofmt (curinterp->Iofmt) #define ofs (curinterp->Iofs) #define ofslen (curinterp->Iofslen) #define oldlastpm (curinterp->Ioldlastpm) #define oldname (curinterp->Ioldname) #define origargc (curinterp->Iorigargc) #define origargv (curinterp->Iorigargv) #define origfilename (curinterp->Iorigfilename) #define ors (curinterp->Iors) #define orslen (curinterp->Iorslen) #define pad (curinterp->Ipad) #define padname (curinterp->Ipadname) #define patchlevel (curinterp->Ipatchlevel) #define perldb (curinterp->Iperldb) #define pidstatus (curinterp->Ipidstatus) #define preambled (curinterp->Ipreambled) #define preprocess (curinterp->Ipreprocess) #define restartop (curinterp->Irestartop) #define rightgv (curinterp->Irightgv) #define rs (curinterp->Irs) #define rschar (curinterp->Irschar) #define rslen (curinterp->Irslen) #define rspara (curinterp->Irspara) #define runlevel (curinterp->Irunlevel) #define sawampersand (curinterp->Isawampersand) #define sawi (curinterp->Isawi) #define sawstudy (curinterp->Isawstudy) #define sawvec (curinterp->Isawvec) #define screamfirst (curinterp->Iscreamfirst) #define screamnext (curinterp->Iscreamnext) #define secondgv (curinterp->Isecondgv) #define siggv (curinterp->Isiggv) #define signalstack (curinterp->Isignalstack) #define sortcop (curinterp->Isortcop) #define sortstack (curinterp->Isortstack) #define sortstash (curinterp->Isortstash) #define splitstr (curinterp->Isplitstr) #define stack (curinterp->Istack) #define statcache (curinterp->Istatcache) #define statgv (curinterp->Istatgv) #define statname (curinterp->Istatname) #define statusvalue (curinterp->Istatusvalue) #define stdingv (curinterp->Istdingv) #define strchop (curinterp->Istrchop) #define sv_count (curinterp->Isv_count) #define sv_objcount (curinterp->Isv_objcount) #define sv_root (curinterp->Isv_root) #define sv_arenaroot (curinterp->Isv_arenaroot) #define tainted (curinterp->Itainted) #define tainting (curinterp->Itainting) #define tmps_floor (curinterp->Itmps_floor) #define tmps_ix (curinterp->Itmps_ix) #define tmps_max (curinterp->Itmps_max) #define tmps_stack (curinterp->Itmps_stack) #define top_env (curinterp->Itop_env) #define toptarget (curinterp->Itoptarget) #define unsafe (curinterp->Iunsafe) #else /* not multiple, so translate interpreter symbols the other way... */ #define IArgv Argv #define ICmd Cmd #define IDBgv DBgv #define IDBline DBline #define IDBsignal DBsignal #define IDBsingle DBsingle #define IDBsub DBsub #define IDBtrace DBtrace #define Iallgvs allgvs #define Iampergv ampergv #define Iargvgv argvgv #define Iargvoutgv argvoutgv #define Ibasetime basetime #define Ibeginav beginav #define Ibodytarget bodytarget #define Icddir cddir #define Ichopset chopset #define Icopline copline #define Icurblock curblock #define Icurcop curcop #define Icurcsv curcsv #define Icurpm curpm #define Icurstash curstash #define Icurstname curstname #define Icxstack cxstack #define Icxstack_ix cxstack_ix #define Icxstack_max cxstack_max #define Idbargs dbargs #define Idebdelim debdelim #define Idebname debname #define Idebstash debstash #define Idebug debug #define Idefgv defgv #define Idefoutgv defoutgv #define Idefstash defstash #define Idelaymagic delaymagic #define Idirty dirty #define Idlevel dlevel #define Idlmax dlmax #define Ido_undump do_undump #define Idoextract doextract #define Idoswitches doswitches #define Idowarn dowarn #define Idumplvl dumplvl #define Ie_fp e_fp #define Ie_tmpname e_tmpname #define Iendav endav #define Ienvgv envgv #define Ieval_root eval_root #define Ieval_start eval_start #define Ifdpid fdpid #define Ifilemode filemode #define Ifirstgv firstgv #define Iforkprocess forkprocess #define Iformfeed formfeed #define Iformtarget formtarget #define Igensym gensym #define Iin_eval in_eval #define Iincgv incgv #define Iinplace inplace #define Ilast_in_gv last_in_gv #define Ilastfd lastfd #define Ilastretstr lastretstr #define Ilastscream lastscream #define Ilastsize lastsize #define Ilastspbase lastspbase #define Ilaststatval laststatval #define Ilaststype laststype #define Ileftgv leftgv #define Ilineary lineary #define Ilocalizing localizing #define Imain_root main_root #define Imain_start main_start #define Imainstack mainstack #define Imaxscream maxscream #define Imaxsysfd maxsysfd #define Iminus_F minus_F #define Iminus_a minus_a #define Iminus_c minus_c #define Iminus_l minus_l #define Iminus_n minus_n #define Iminus_p minus_p #define Imultiline multiline #define Imystack_base mystack_base #define Imystack_mark mystack_mark #define Imystack_max mystack_max #define Imystack_sp mystack_sp #define Imystrk mystrk #define Inrs nrs #define Inrschar nrschar #define Inrslen nrslen #define Iofmt ofmt #define Iofs ofs #define Iofslen ofslen #define Ioldlastpm oldlastpm #define Ioldname oldname #define Iorigargc origargc #define Iorigargv origargv #define Iorigfilename origfilename #define Iors ors #define Iorslen orslen #define Ipad pad #define Ipadname padname #define Ipatchlevel patchlevel #define Iperldb perldb #define Ipidstatus pidstatus #define Ipreambled preambled #define Ipreprocess preprocess #define Irestartop restartop #define Irightgv rightgv #define Irs rs #define Irschar rschar #define Irslen rslen #define Irspara rspara #define Irunlevel runlevel #define Isawampersand sawampersand #define Isawi sawi #define Isawstudy sawstudy #define Isawvec sawvec #define Iscreamfirst screamfirst #define Iscreamnext screamnext #define Isecondgv secondgv #define Isiggv siggv #define Isignalstack signalstack #define Isortcop sortcop #define Isortstack sortstack #define Isortstash sortstash #define Isplitstr splitstr #define Istack stack #define Istatcache statcache #define Istatgv statgv #define Istatname statname #define Istatusvalue statusvalue #define Istdingv stdingv #define Istrchop strchop #define Isv_count sv_count #define Isv_objcount sv_objcount #define Isv_root sv_root #define Isv_arenaroot sv_arenaroot #define Itainted tainted #define Itainting tainting #define Itmps_floor tmps_floor #define Itmps_ix tmps_ix #define Itmps_max tmps_max #define Itmps_stack tmps_stack #define Itop_env top_env #define Itoptarget toptarget #define Iunsafe unsafe #endif /* MULTIPLICITY */ Idumplvl) #define e_fp (curinterp->Ie_fp) #define e_tmpname (curinterp->Ie_tmpname) #define endav (curinterp->Iendav) #define envgv (curinterp->Ienvgv) #define eval_root (curinterp->Ieval_root) #define eval_start (curinterp->Ieval_start) #define fdpid (curinterp->Ifdpid) #define filemode (curinterp->Ifilemode) #define firstgv (curinterp->Ifirstgv) #define forkprocess (curinterp->Iforkprocess) #define formfeed (curinterp->Iformfeed) #define formtarget (curinterp->Iformtarget) #define geperl5.000/embed_h.SH 755 203 12 1733 5650572654 7266 #!/bin/sh cat <<'END' >embed.h /* This file is derived from global.sym and interp.sym */ /* (Doing namespace management portably in C is really gross.) */ #ifdef EMBED /* globals we need to hide from the world */ END sed >embed.h \ -e 's/[ ]*#.*//' \ -e '/^[ ]*$/d' \ -e 's/\(.*\)/#define \1 Perl_\1/' \ -e 's/\(................ \) /\1/' cat <<'END' >> embed.h #endif /* EMBED */ /* Put interpreter specific symbols into a struct? */ #ifdef MULTIPLICITY END sed >embed.h \ -e 's/[ ]*#.*//' \ -e '/^[ ]*$/d' \ -e 's/\(.*\)/#define \1 (curinterp->I\1)/' \ -e 's/\(................ \) /\1/' cat <<'END' >> embed.h #else /* not multiple, so translate interpreter symbols the other way... */ END sed >embed.h \ -e 's/[ ]*#.*//' \ -e '/^[ ]*$/d' \ -e 's/\(.*\)/#define I\1 \1/' \ -e 's/\(................ \) /\1/' cat <<'END' >> embed.h #endif /* MULTIPLICITY */ END ?pp_ctl.cl #¨9@pp_hot.cperl5.000/ext/ 775 203 12 0 5650575673 6161 perl5.000/ext/DB_File/ 775 203 12 0 5650575661 7402 perl5.000/ext/DB_File/DB_File.pm 664 203 12 11727 5637466673 11310 # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (pmarquess@bfsec.bt.co.uk) # last modified 23rd June 1994 # version 0.1 package DB_File::HASHINFO ; use Carp; sub TIEHASH { bless {} ; } %elements = ( 'bsize' => 0, 'ffactor' => 0, 'nelem' => 0, 'cachesize' => 0, 'hash' => 0, 'lorder' => 0 ) ; sub FETCH { return $_[0]{$_[1]} if defined $elements{$_[1]} ; croak "DB_File::HASHINFO::FETCH - Unknown element '$_[1]'" ; } sub STORE { if ( defined $elements{$_[1]} ) { $_[0]{$_[1]} = $_[2] ; return ; } croak "DB_File::HASHINFO::STORE - Unknown element '$_[1]'" ; } sub DELETE { if ( defined $elements{$_[1]} ) { delete ${$_[0]}{$_[1]} ; return ; } croak "DB_File::HASHINFO::DELETE - Unknown element '$_[1]'" ; } sub DESTROY {undef %{$_[0]} } sub FIRSTKEY { croak "DB_File::HASHINFO::FIRSTKEY is not implemented" } sub NEXTKEY { croak "DB_File::HASHINFO::NEXTKEY is not implemented" } sub EXISTS { croak "DB_File::HASHINFO::EXISTS is not implemented" } sub CLEAR { croak "DB_File::HASHINFO::CLEAR is not implemented" } package DB_File::BTREEINFO ; use Carp; sub TIEHASH { bless {} ; } %elements = ( 'flags' => 0, 'cachesize' => 0, 'maxkeypage' => 0, 'minkeypage' => 0, 'psize' => 0, 'compare' => 0, 'prefix' => 0, 'lorder' => 0 ) ; sub FETCH { return $_[0]{$_[1]} if defined $elements{$_[1]} ; croak "DB_File::BTREEINFO::FETCH - Unknown element '$_[1]'" ; } sub STORE { if ( defined $elements{$_[1]} ) { $_[0]{$_[1]} = $_[2] ; return ; } croak "DB_File::BTREEINFO::STORE - Unknown element '$_[1]'" ; } sub DELETE { if ( defined $elements{$_[1]} ) { delete ${$_[0]}{$_[1]} ; return ; } croak "DB_File::BTREEINFO::DELETE - Unknown element '$_[1]'" ; } sub DESTROY {undef %{$_[0]} } sub FIRSTKEY { croak "DB_File::BTREEINFO::FIRSTKEY is not implemented" } sub NEXTKEY { croak "DB_File::BTREEINFO::NEXTKEY is not implemented" } sub EXISTS { croak "DB_File::BTREEINFO::EXISTS is not implemented" } sub CLEAR { croak "DB_File::BTREEINFO::CLEAR is not implemented" } package DB_File::RECNOINFO ; use Carp; sub TIEHASH { bless {} ; } %elements = ( 'bval' => 0, 'cachesize' => 0, 'psize' => 0, 'flags' => 0, 'lorder' => 0, 'reclen' => 0, 'bfname' => 0 ) ; sub FETCH { return $_[0]{$_[1]} if defined $elements{$_[1]} ; croak "DB_File::RECNOINFO::FETCH - Unknown element '$_[1]'" ; } sub STORE { if ( defined $elements{$_[1]} ) { $_[0]{$_[1]} = $_[2] ; return ; } croak "DB_File::RECNOINFO::STORE - Unknown element '$_[1]'" ; } sub DELETE { if ( defined $elements{$_[1]} ) { delete ${$_[0]}{$_[1]} ; return ; } croak "DB_File::RECNOINFO::DELETE - Unknown element '$_[1]'" ; } sub DESTROY {undef %{$_[0]} } sub FIRSTKEY { croak "DB_File::RECNOINFO::FIRSTKEY is not implemented" } sub NEXTKEY { croak "DB_File::RECNOINFO::NEXTKEY is not implemented" } sub EXISTS { croak "DB_File::BTREEINFO::EXISTS is not implemented" } sub CLEAR { croak "DB_File::BTREEINFO::CLEAR is not implemented" } package DB_File ; use Carp; #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; $DB_BTREE = TIEHASH DB_File::BTREEINFO ; $DB_HASH = TIEHASH DB_File::HASHINFO ; $DB_RECNO = TIEHASH DB_File::RECNOINFO ; require TieHash; require Exporter; require AutoLoader; require DynaLoader; @ISA = (TieHash, Exporter, AutoLoader, DynaLoader); @EXPORT = qw( $DB_BTREE $DB_HASH $DB_RECNO BTREEMAGIC BTREEVERSION DB_LOCK DB_SHMEM DB_TXN HASHMAGIC HASHVERSION MAX_PAGE_NUMBER MAX_PAGE_OFFSET MAX_REC_NUMBER RET_ERROR RET_SPECIAL RET_SUCCESS R_CURSOR R_DUP R_FIRST R_FIXEDLEN R_IAFTER R_IBEFORE R_LAST R_NEXT R_NOKEY R_NOOVERWRITE R_PREV R_RECNOSYNC R_SETCURSOR R_SNAPSHOT __R_UNUSED ); sub AUTOLOAD { if (@_ > 1) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } local($constname); ($constname = $AUTOLOAD) =~ s/.*:://; $val = constant($constname, @_ ? $_[0] : 0); if ($! != 0) { if ($! =~ /Invalid/) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } else { ($pack,$file,$line) = caller; croak "Your vendor has not defined DB macro $constname, used at $file line $line. "; } } eval "sub $AUTOLOAD { $val }"; goto &$AUTOLOAD; } @liblist = (); @liblist = split ' ', $Config::Config{"DB_File_loadlibs"} if defined $Config::Config{"DB_File_loadlibs"}; bootstrap DB_File @liblist; # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. 1; __END__ arget (curinterp->Iformtarget) #define geperl5.000/ext/DB_File/DB_File.xs 664 203 12 45225 5647030623 11305 /* DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess (pmarquess@bfsec.bt.co.uk) last modified 23rd June 1994 version 0.1 All comments/suggestions/problems are welcome */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include #include #ifndef DBXS_HASH_TYPE #define DBXS_HASH_TYPE u_int32_t #endif #ifndef DBXS_PREFIX_TYPE #define DBXS_PREFIX_TYPE size_t #endif typedef DB * DB_File; typedef DBT DBTKEY ; union INFO { HASHINFO hash ; RECNOINFO recno ; BTREEINFO btree ; } ; typedef struct { SV * sub ; } CallBackInfo ; /* #define TRACE */ #define db_DESTROY(db) (db->close)(db) #define db_DELETE(db, key, flags) (db->del)(db, &key, flags) #define db_STORE(db, key, value, flags) (db->put)(db, &key, &value, flags) #define db_FETCH(db, key, flags) (db->get)(db, &key, &value, flags) #define db_close(db) (db->close)(db) #define db_del(db, key, flags) (db->del)(db, &key, flags) #define db_fd(db) (db->fd)(db) #define db_put(db, key, value, flags) (db->put)(db, &key, &value, flags) #define db_get(db, key, value, flags) (db->get)(db, &key, &value, flags) #define db_seq(db, key, value, flags) (db->seq)(db, &key, &value, flags) #define db_sync(db, flags) (db->sync)(db, flags) #define OutputValue(arg, name) \ { if (RETVAL == 0) sv_setpvn(arg, name.data, name.size) ; } #define OutputKey(arg, name) \ { if (RETVAL == 0) \ { \ if (db->close != DB_recno_close) \ sv_setpvn(arg, name.data, name.size); \ else \ sv_setiv(arg, (I32)*(I32*)name.data - 1); \ } \ } /* Internal Global Data */ static recno_t Value ; static int (*DB_recno_close)() = NULL ; static CallBackInfo hash_callback = { 0 } ; static CallBackInfo compare_callback = { 0 } ; static CallBackInfo prefix_callback = { 0 } ; static int btree_compare(key1, key2) const DBT * key1 ; const DBT * key2 ; { dSP ; void * data1, * data2 ; int retval ; int count ; data1 = key1->data ; data2 = key2->data ; /* As newSVpv will assume that the data pointer is a null terminated C string if the size parameter is 0, make sure that data points to an empty string if the length is 0 */ if (key1->size == 0) data1 = "" ; if (key2->size == 0) data2 = "" ; ENTER ; SAVETMPS; PUSHMARK(sp) ; EXTEND(sp,2) ; PUSHs(sv_2mortal(newSVpv(data1,key1->size))); PUSHs(sv_2mortal(newSVpv(data2,key2->size))); PUTBACK ; count = perl_call_sv(compare_callback.sub, G_SCALAR); SPAGAIN ; if (count != 1) croak ("DB_File btree_compare: expected 1 return value from %s, got %d\n", count) ; retval = POPi ; PUTBACK ; FREETMPS ; LEAVE ; return (retval) ; } static DBXS_PREFIX_TYPE btree_prefix(key1, key2) const DBT * key1 ; const DBT * key2 ; { dSP ; void * data1, * data2 ; int retval ; int count ; data1 = key1->data ; data2 = key2->data ; /* As newSVpv will assume that the data pointer is a null terminated C string if the size parameter is 0, make sure that data points to an empty string if the length is 0 */ if (key1->size == 0) data1 = "" ; if (key2->size == 0) data2 = "" ; ENTER ; SAVETMPS; PUSHMARK(sp) ; EXTEND(sp,2) ; PUSHs(sv_2mortal(newSVpv(data1,key1->size))); PUSHs(sv_2mortal(newSVpv(data2,key2->size))); PUTBACK ; count = perl_call_sv(prefix_callback.sub, G_SCALAR); SPAGAIN ; if (count != 1) croak ("DB_File btree_prefix: expected 1 return value from %s, got %d\n", count) ; retval = POPi ; PUTBACK ; FREETMPS ; LEAVE ; return (retval) ; } static DBXS_HASH_TYPE hash_cb(data, size) const void * data ; size_t size ; { dSP ; int retval ; int count ; if (size == 0) data = "" ; PUSHMARK(sp) ; XPUSHs(sv_2mortal(newSVpv((char*)data,size))); PUTBACK ; count = perl_call_sv(hash_callback.sub, G_SCALAR); SPAGAIN ; if (count != 1) croak ("DB_File hash_cb: expected 1 return value from %s, got %d\n", count) ; retval = POPi ; PUTBACK ; FREETMPS ; LEAVE ; return (retval) ; } #ifdef TRACE static void PrintHash(hash) HASHINFO hash ; { printf ("HASH Info\n") ; printf (" hash = %s\n", (hash.hash != NULL ? "redefined" : "default")) ; printf (" bsize = %d\n", hash.bsize) ; printf (" ffactor = %d\n", hash.ffactor) ; printf (" nelem = %d\n", hash.nelem) ; printf (" cachesize = %d\n", hash.cachesize) ; printf (" lorder = %d\n", hash.lorder) ; } static void PrintRecno(recno) RECNOINFO recno ; { printf ("RECNO Info\n") ; printf (" flags = %d\n", recno.flags) ; printf (" cachesize = %d\n", recno.cachesize) ; printf (" psize = %d\n", recno.psize) ; printf (" lorder = %d\n", recno.lorder) ; printf (" reclen = %d\n", recno.reclen) ; printf (" bval = %d\n", recno.bval) ; printf (" bfname = %s\n", recno.bfname) ; } PrintBtree(btree) BTREEINFO btree ; { printf ("BTREE Info\n") ; printf (" compare = %s\n", (btree.compare ? "redefined" : "default")) ; printf (" prefix = %s\n", (btree.prefix ? "redefined" : "default")) ; printf (" flags = %d\n", btree.flags) ; printf (" cachesize = %d\n", btree.cachesize) ; printf (" psize = %d\n", btree.psize) ; printf (" maxkeypage = %d\n", btree.maxkeypage) ; printf (" minkeypage = %d\n", btree.minkeypage) ; printf (" lorder = %d\n", btree.lorder) ; } #else #define PrintRecno(recno) #define PrintHash(hash) #define PrintBtree(btree) #endif /* TRACE */ static I32 GetArrayLength(db) DB_File db ; { DBT key ; DBT value ; int RETVAL ; RETVAL = (db->seq)(db, &key, &value, R_LAST) ; if (RETVAL == 0) RETVAL = *(I32 *)key.data ; else if (RETVAL == 1) /* No key means empty file */ RETVAL = 0 ; return (RETVAL) ; } static DB_File ParseOpenInfo(name, flags, mode, sv, string) char * name ; int flags ; int mode ; SV * sv ; char * string ; { SV ** svp; HV * action ; union INFO info ; DB_File RETVAL ; void * openinfo = NULL ; DBTYPE type = DB_HASH ; if (sv) { if (! SvROK(sv) ) croak ("type parameter is not a reference") ; action = (HV*)SvRV(sv); if (sv_isa(sv, "DB_File::HASHINFO")) { type = DB_HASH ; openinfo = (void*)&info ; svp = hv_fetch(action, "hash", 4, FALSE); if (svp && SvOK(*svp)) { info.hash.hash = hash_cb ; hash_callback.sub = *svp ; } else info.hash.hash = NULL ; svp = hv_fetch(action, "bsize", 5, FALSE); info.hash.bsize = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "ffactor", 7, FALSE); info.hash.ffactor = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "nelem", 5, FALSE); info.hash.nelem = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "cachesize", 9, FALSE); info.hash.cachesize = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "lorder", 6, FALSE); info.hash.lorder = svp ? SvIV(*svp) : 0; PrintHash(info) ; } else if (sv_isa(sv, "DB_File::BTREEINFO")) { type = DB_BTREE ; openinfo = (void*)&info ; svp = hv_fetch(action, "compare", 7, FALSE); if (svp && SvOK(*svp)) { info.btree.compare = btree_compare ; compare_callback.sub = *svp ; } else info.btree.compare = NULL ; svp = hv_fetch(action, "prefix", 6, FALSE); if (svp && SvOK(*svp)) { info.btree.prefix = btree_prefix ; prefix_callback.sub = *svp ; } else info.btree.prefix = NULL ; svp = hv_fetch(action, "flags", 5, FALSE); info.btree.flags = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "cachesize", 9, FALSE); info.btree.cachesize = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "minkeypage", 10, FALSE); info.btree.minkeypage = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "maxkeypage", 10, FALSE); info.btree.maxkeypage = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "psize", 5, FALSE); info.btree.psize = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "lorder", 6, FALSE); info.btree.lorder = svp ? SvIV(*svp) : 0; PrintBtree(info) ; } else if (sv_isa(sv, "DB_File::RECNOINFO")) { type = DB_RECNO ; openinfo = (void *)&info ; svp = hv_fetch(action, "flags", 5, FALSE); info.recno.flags = (u_long) svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "cachesize", 9, FALSE); info.recno.cachesize = (u_int) svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "psize", 5, FALSE); info.recno.psize = (int) svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "lorder", 6, FALSE); info.recno.lorder = (int) svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "reclen", 6, FALSE); info.recno.reclen = (size_t) svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "bval", 4, FALSE); if (svp && SvOK(*svp)) { if (SvPOK(*svp)) info.recno.bval = (u_char)*SvPV(*svp, na) ; else info.recno.bval = (u_char)(unsigned long) SvIV(*svp) ; } else { if (info.recno.flags & R_FIXEDLEN) info.recno.bval = (u_char) ' ' ; else info.recno.bval = (u_char) '\n' ; } svp = hv_fetch(action, "bfname", 6, FALSE); info.recno.bfname = (char *) svp ? SvPV(*svp,na) : 0; PrintRecno(info) ; } else croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); } RETVAL = dbopen(name, flags, mode, type, openinfo) ; if (RETVAL == 0) croak("DB_File::%s failed, reason: %s", string, Strerror(errno)) ; /* kludge mode on: RETVAL->type for DB_RECNO is set to DB_BTREE so remember a DB_RECNO by saving the address of one of it's internal routines */ if (type == DB_RECNO) DB_recno_close = RETVAL->close ; return (RETVAL) ; } static int not_here(s) char *s; { croak("DB_File::%s not implemented on this architecture", s); return -1; } static double constant(name, arg) char *name; int arg; { errno = 0; switch (*name) { case 'A': break; case 'B': if (strEQ(name, "BTREEMAGIC")) #ifdef BTREEMAGIC return BTREEMAGIC; #else goto not_there; #endif if (strEQ(name, "BTREEVERSION")) #ifdef BTREEVERSION return BTREEVERSION; #else goto not_there; #endif break; case 'C': break; case 'D': if (strEQ(name, "DB_LOCK")) #ifdef DB_LOCK return DB_LOCK; #else goto not_there; #endif if (strEQ(name, "DB_SHMEM")) #ifdef DB_SHMEM return DB_SHMEM; #else goto not_there; #endif if (strEQ(name, "DB_TXN")) #ifdef DB_TXN return (U32)DB_TXN; #else goto not_there; #endif break; case 'E': break; case 'F': break; case 'G': break; case 'H': if (strEQ(name, "HASHMAGIC")) #ifdef HASHMAGIC return HASHMAGIC; #else goto not_there; #endif if (strEQ(name, "HASHVERSION")) #ifdef HASHVERSION return HASHVERSION; #else goto not_there; #endif break; case 'I': break; case 'J': break; case 'K': break; case 'L': break; case 'M': if (strEQ(name, "MAX_PAGE_NUMBER")) #ifdef MAX_PAGE_NUMBER return (U32)MAX_PAGE_NUMBER; #else goto not_there; #endif if (strEQ(name, "MAX_PAGE_OFFSET")) #ifdef MAX_PAGE_OFFSET return MAX_PAGE_OFFSET; #else goto not_there; #endif if (strEQ(name, "MAX_REC_NUMBER")) #ifdef MAX_REC_NUMBER return (U32)MAX_REC_NUMBER; #else goto not_there; #endif break; case 'N': break; case 'O': break; case 'P': break; case 'Q': break; case 'R': if (strEQ(name, "RET_ERROR")) #ifdef RET_ERROR return RET_ERROR; #else goto not_there; #endif if (strEQ(name, "RET_SPECIAL")) #ifdef RET_SPECIAL return RET_SPECIAL; #else goto not_there; #endif if (strEQ(name, "RET_SUCCESS")) #ifdef RET_SUCCESS return RET_SUCCESS; #else goto not_there; #endif if (strEQ(name, "R_CURSOR")) #ifdef R_CURSOR return R_CURSOR; #else goto not_there; #endif if (strEQ(name, "R_DUP")) #ifdef R_DUP return R_DUP; #else goto not_there; #endif if (strEQ(name, "R_FIRST")) #ifdef R_FIRST return R_FIRST; #else goto not_there; #endif if (strEQ(name, "R_FIXEDLEN")) #ifdef R_FIXEDLEN return R_FIXEDLEN; #else goto not_there; #endif if (strEQ(name, "R_IAFTER")) #ifdef R_IAFTER return R_IAFTER; #else goto not_there; #endif if (strEQ(name, "R_IBEFORE")) #ifdef R_IBEFORE return R_IBEFORE; #else goto not_there; #endif if (strEQ(name, "R_LAST")) #ifdef R_LAST return R_LAST; #else goto not_there; #endif if (strEQ(name, "R_NEXT")) #ifdef R_NEXT return R_NEXT; #else goto not_there; #endif if (strEQ(name, "R_NOKEY")) #ifdef R_NOKEY return R_NOKEY; #else goto not_there; #endif if (strEQ(name, "R_NOOVERWRITE")) #ifdef R_NOOVERWRITE return R_NOOVERWRITE; #else goto not_there; #endif if (strEQ(name, "R_PREV")) #ifdef R_PREV return R_PREV; #else goto not_there; #endif if (strEQ(name, "R_RECNOSYNC")) #ifdef R_RECNOSYNC return R_RECNOSYNC; #else goto not_there; #endif if (strEQ(name, "R_SETCURSOR")) #ifdef R_SETCURSOR return R_SETCURSOR; #else goto not_there; #endif if (strEQ(name, "R_SNAPSHOT")) #ifdef R_SNAPSHOT return R_SNAPSHOT; #else goto not_there; #endif break; case 'S': break; case 'T': break; case 'U': break; case 'V': break; case 'W': break; case 'X': break; case 'Y': break; case 'Z': break; case '_': if (strEQ(name, "__R_UNUSED")) #ifdef __R_UNUSED return __R_UNUSED; #else goto not_there; #endif break; } errno = EINVAL; return 0; not_there: errno = ENOENT; return 0; } MODULE = DB_File PACKAGE = DB_File PREFIX = db_ double constant(name,arg) char * name int arg DB_File db_TIEHASH(dbtype, name=undef, flags=O_RDWR, mode=0640, type=DB_HASH) char * dbtype int flags int mode CODE: { char * name = (char *) NULL ; SV * sv = (SV *) NULL ; if (items >= 2 && SvOK(ST(1))) name = (char*) SvPV(ST(1), na) ; if (items == 5) sv = ST(4) ; RETVAL = ParseOpenInfo(name, flags, mode, sv, "new") ; } OUTPUT: RETVAL BOOT: newXS("DB_File::TIEARRAY", XS_DB_File_db_TIEHASH, file); int db_DESTROY(db) DB_File db int db_DELETE(db, key, flags=0) DB_File db DBTKEY key u_int flags int db_FETCH(db, key, flags=0) DB_File db DBTKEY key u_int flags CODE: { DBT value ; RETVAL = (db->get)(db, &key, &value, flags) ; ST(0) = sv_newmortal(); if (RETVAL == 0) sv_setpvn(ST(0), value.data, value.size); } int db_STORE(db, key, value, flags=0) DB_File db DBTKEY key DBT value u_int flags int db_FIRSTKEY(db) DB_File db CODE: { DBTKEY key ; DBT value ; RETVAL = (db->seq)(db, &key, &value, R_FIRST) ; ST(0) = sv_newmortal(); if (RETVAL == 0) { if (db->type != DB_RECNO) sv_setpvn(ST(0), key.data, key.size); else sv_setiv(ST(0), (I32)*(I32*)key.data - 1); } } int db_NEXTKEY(db, key) DB_File db DBTKEY key CODE: { DBT value ; RETVAL = (db->seq)(db, &key, &value, R_NEXT) ; ST(0) = sv_newmortal(); if (RETVAL == 0) { if (db->type != DB_RECNO) sv_setpvn(ST(0), key.data, key.size); else sv_setiv(ST(0), (I32)*(I32*)key.data - 1); } } # # These would be nice for RECNO # int unshift(db, ...) DB_File db CODE: { DBTKEY key ; DBT value ; int i ; int One ; RETVAL = -1 ; for (i = items-1 ; i > 0 ; --i) { value.data = SvPV(ST(i), na) ; value.size = na ; One = 1 ; key.data = &One ; key.size = sizeof(int) ; RETVAL = (db->put)(db, &key, &value, R_IBEFORE) ; if (RETVAL != 0) break; } } OUTPUT: RETVAL I32 pop(db) DB_File db CODE: { DBTKEY key ; DBT value ; /* First get the final value */ RETVAL = (db->seq)(db, &key, &value, R_LAST) ; ST(0) = sv_newmortal(); /* Now delete it */ if (RETVAL == 0) { RETVAL = (db->del)(db, &key, R_CURSOR) ; if (RETVAL == 0) sv_setpvn(ST(0), value.data, value.size); } } I32 shift(db) DB_File db CODE: { DBTKEY key ; DBT value ; /* get the first value */ RETVAL = (db->seq)(db, &key, &value, R_FIRST) ; ST(0) = sv_newmortal(); /* Now delete it */ if (RETVAL == 0) { RETVAL = (db->del)(db, &key, R_CURSOR) ; if (RETVAL == 0) sv_setpvn(ST(0), value.data, value.size); } } I32 push(db, ...) DB_File db CODE: { DBTKEY key ; DBT value ; int i ; /* Set the Cursor to the Last element */ RETVAL = (db->seq)(db, &key, &value, R_LAST) ; if (RETVAL == 0) { /* for (i = 1 ; i < items ; ++i) */ for (i = items - 1 ; i > 0 ; --i) { value.data = SvPV(ST(i), na) ; value.size = na ; RETVAL = (db->put)(db, &key, &value, R_IAFTER) ; if (RETVAL != 0) break; } } } OUTPUT: RETVAL I32 length(db) DB_File db CODE: RETVAL = GetArrayLength(db) ; OUTPUT: RETVAL # # Now provide an interface to the rest of the DB functionality # int db_del(db, key, flags=0) DB_File db DBTKEY key u_int flags int db_get(db, key, value, flags=0) DB_File db DBTKEY key DBT value u_int flags OUTPUT: value int db_put(db, key, value, flags=0) DB_File db DBTKEY key DBT value u_int flags OUTPUT: key if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key); int db_fd(db) DB_File db int db_sync(db, flags=0) DB_File db u_int flags int db_seq(db, key, value, flags) DB_File db DBTKEY key DBT value u_int flags OUTPUT: key value DB_recno_close = RETVAL->close ; return (RETVAL) ; } static int not_here(s) char *s; { croak("DB_File::%s not implemented on this architecture", s); return -1; } static double constant(name, arg) char *name; int arg; { errno = 0; switch (*name) { case 'A': break; case 'B': if (strEQ(name, "BTREEMAGIC")) #ifdef BTREEMperl5.000/ext/DB_File/DB_File_BS 664 203 12 244 5645376141 11176 # NeXT needs /usr/lib/libposix.a to load along with DB_File.so if ( $dlsrc eq "dl_next.xs" ) { @DynaLoader::dl_resolve_using = ( '/usr/lib/libposix.a' ); } 1; no_close = RETVAL->close ; return (RETVAL) ; } static int not_here(s) char *s; { croak("DB_File::%s not implemented on this architecture", s); return -1; } static double constant(name, arg) char *name; int arg; { errno = 0; switch (*name) { case 'A': break; case 'B': if (strEQ(name, "BTREEMAGIC")) #ifdef BTREEMperl5.000/ext/DB_File/Makefile.SH 664 203 12 12327 5650410572 11452 : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac 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 fi : Find absolute path name for TOP. This is needed when we cd to TOP : to run perl on autosplit. oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd case $CONFIG in '') . $TOP/config.sh ;; esac : Find out directory name. This is also the extension name. ext=`pwd | $sed -e 's@.*/@@'` : This extension might have its own typemap if test -f typemap; then exttypemap='typemap' else exttypemap='' fi : This extension might need additional libraries. potential_libs="-ldb " . $TOP/ext/util/extliblist : This extension might need bootstrap support if test -f ${ext}_BS; then bootdep=${ext}_BS else bootdep='' fi case "$dlsrc" in dl_aix*) echo "#!" > $ext.exp echo "boot_$ext" >> $ext.exp ;; esac echo "Extracting ext/$ext/Makefile (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted : by putting a backslash in front. You may delete these comments. $spitshell >Makefile << !GROK!THIS! # # This Makefile is for the $ext extension to perl. # CC = $cc RANLIB = $ranlib TOP = $TOP ABSTOP = $ABSTOP LDFLAGS = $ldflags CLDFLAGS = $ldflags SMALL = $small LARGE = $large $split # To use an alternate make, set \$altmake in config.sh. MAKE = ${altmake-make} EXT = $ext # $ext might have its own typemap EXTTYPEMAP = $exttypemap # $ext might have its own bootstrap support BOOTDEP = $bootdep BOOTSTRAP = $ext.bs # The following are used to build and install shared libraries for # dynamic loading. LDDLFLAGS = $lddlflags CCDLFLAGS = $ccdlflags CCCDLFLAGS = $cccdlflags SO = $so DLEXT = $dlext # $ext might need to be linked with some extra libraries. # EXTRALIBS = full list of libraries needed for static linking. # Only those libraries that actually exist are included. # DYNLOADLIBS = list of those libraries that are needed but can be # linked in dynamically on this platform. On SunOS, for # example, this would be .so* libraries, but not archive # libraries. The bootstrap file is installed only if # this list is not empty. # STATLOADLIBS = list of those libraries which must be statically # linked into the shared library. On SunOS 4.1.3, # for example, I have only an archive version of # -lm, and it must be linked in statically. EXTRALIBS = $extralibs DYNALOADLIBS = $dynaloadlibs STATLOADLIBS = $statloadlibs !GROK!THIS! $spitshell >>Makefile <<'!NO!SUBS!' # Where to put things: AUTO = $(TOP)/lib/auto INSTALLBOOT = $(AUTO)/$(EXT)/$(EXT).bs INSTALLDYNAMIC = $(AUTO)/$(EXT)/$(EXT).$(DLEXT) INSTALLSTATIC = $(EXT).a INSTALLPM = $(TOP)/lib/$(EXT).pm PERL = $(ABSTOP)/miniperl XSUBPP = $(TOP)/ext/xsubpp SHELL = /bin/sh CCCMD = `sh $(shellflags) $(TOP)/cflags $@` .c.o: $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c all: dynamic # Phony target to force checking subdirectories. FORCE: config: # Target for Dynamic Loading: dynamic: $(INSTALLDYNAMIC) $(INSTALLPM) $(INSTALLBOOT) $(INSTALLDYNAMIC): $(EXT).o @test -d $(AUTO) || mkdir $(AUTO) @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) ld $(LDDLFLAGS) -o $@ $(EXT).o $(STATLOADLIBS) $(BOOTSTRAP): Makefile $(BOOTDEP) $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) touch $(BOOTSTRAP) $(INSTALLBOOT): $(BOOTSTRAP) @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ # Target for Static Loading: static: $(INSTALLSTATIC) $(INSTALLPM) $(INSTALLSTATIC): $(EXT).o ar cr $@ $(EXT).o $(RANLIB) $@ echo $(EXTRALIBS) >> $(TOP)/ext.libs $(EXT).c: $(EXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile $(PERL) $(XSUBPP) $(EXT).xs >tmp mv tmp $@ $(INSTALLPM): $(EXT).pm rm -f $@ cp $(EXT).pm $@ cd $(TOP); $(PERL) autosplit $(EXT) clean: rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp realclean: clean rm -f makefile Makefile rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) rm -rf $(AUTO)/$(EXT) purge: realclean $(EXT).o : $(TOP)/EXTERN.h $(EXT).o : $(TOP)/perl.h $(EXT).o : $(TOP)/embed.h $(EXT).o : $(TOP)/config.h $(EXT).o : $(TOP)/unixish.h $(EXT).o : $(TOP)/handy.h $(EXT).o : $(TOP)/regexp.h $(EXT).o : $(TOP)/sv.h $(EXT).o : $(TOP)/util.h $(EXT).o : $(TOP)/form.h $(EXT).o : $(TOP)/gv.h $(EXT).o : $(TOP)/cv.h $(EXT).o : $(TOP)/opcode.h $(EXT).o : $(TOP)/op.h $(EXT).o : $(TOP)/cop.h $(EXT).o : $(TOP)/av.h $(EXT).o : $(TOP)/hv.h $(EXT).o : $(TOP)/mg.h $(EXT).o : $(TOP)/scope.h $(EXT).o : $(TOP)/pp.h $(EXT).o : $(TOP)/proto.h $(EXT).o : $(TOP)/XSUB.h Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH $(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH $(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH $(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH !NO!SUBS! chmod 644 Makefile $eunicefix Makefile { if (db->type != DB_RECNO) sv_setpvn(ST(0), key.data, key.size); else sv_setiv(ST(0), (I32)*(I32*)key.data - 1); } } int db_NEXTKEY(db, key) DB_File db DBTKEY key CODE: { DBT value ; RETVAL = (db->seq)(db, &key, &value, R_NEXTperl5.000/ext/DB_File/typemap 664 203 12 1231 5604656562 11065 # typemap for Perl 5 interface to Berkeley DB # # written by Paul Marquess (pmarquess@bfsec.bt.co.uk) # last modified 23rd June 1994 # version 0.1 # #################################### DB SECTION # # u_int T_U_INT DB_File T_PTROBJ DBT T_dbtdatum DBTKEY T_dbtkeydatum INPUT T_dbtkeydatum if (db->close != DB_recno_close) { $var.data = SvPV($arg, na); $var.size = (int)na; } else { Value = SvIV($arg) ; ++ Value ; $var.data = & Value; $var.size = (int)sizeof(recno_t); } T_dbtdatum $var.data = SvPV($arg, na); $var.size = (int)na; OUTPUT T_dbtkeydatum OutputKey($arg, $var) T_dbtdatum OutputValue($arg, $var) ac : Find out directory name. This is also the extension name. ext=`pwd | $sed -e 's@.*/@@'` : This extension might have its own typemap if test -f typemap; then exttypemap='typemap' else exttypemap='' fi : This extension might need additional libraries. potential_libs="-ldb " . $TOP/ext/util/extliblist : This extension might need bootstrap support iperl5.000/ext/DynaLoader/ 775 203 12 0 5650575663 10202 perl5.000/ext/DynaLoader/DynaLoader.doc 664 203 12 24540 5633716433 13016 ======================================================================= Specification for the Generic Dynamic Linking 'DynaLoader' Module This specification defines a standard generic interface to the dynamic linking mechanisms available on many platforms. Its primary purpose is to implement automatic dynamic loading of perl modules. The DynaLoader is designed to be a very simple high-level interface that is sufficiently general to cover the requirements of SunOS, HP-UX, NeXT, Linux, VMS and other platforms. It is also hoped that the interface will cover the needs of OS/2, NT etc and allow pseudo-dynamic linking (using ld -A at runtime). This document serves as both a specification for anyone wishing to implement the DynaLoader for a new platform and as a guide for anyone wishing to use the DynaLoader directly in an application. It must be stressed that the DynaLoader, by itself, is practically useless for accessing non-perl libraries because it provides almost no perl-to-C 'glue'. There is, for example, no mechanism for calling a C library function or supplying arguments. It is anticipated that any glue that may be developed in the future will be implemented in a seperate dynamically loaded module. This interface is based on the work and comments of (in no particular order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno Siegel, Thomas Neumann, Paul Marquess, Charles Bailey and others. Larry Wall designed the elegant inherited bootstrap mechanism and implemented the first perl 5 dynamic loader using it. Tim Bunce 11th August 1994 ---------------------------------------------------------------------- DynaLoader Interface Summary @dl_library_path @dl_resolve_using @dl_require_symbols $dl_debug Implemented in: bootstrap($modulename) Perl @filepaths = dl_findfile(@names) Perl $libref = dl_load_file($filename) C $symref = dl_find_symbol($libref, $symbol) C @symbols = dl_undef_symbols() C dl_install_xsub($name, $symref [, $filename]) C $message = dl_error C ---------------------------------------------------------------------- @dl_library_path The standard/default list of directories in which dl_findfile() will search for libraries etc. Directories are searched in order: $dl_library_path[0], [1], ... etc @dl_library_path is initialised to hold the list of 'normal' directories (/usr/lib etc) determined by Configure ($Config{'libpth'}). This should ensure portability across a wide range of platforms. @dl_library_path should also be initialised with any other directories that can be determined from the environment at runtime (such as LD_LIBRARY_PATH for SunOS). After initialisation @dl_library_path can be manipulated by an application using push and unshift before calling dl_findfile(). Unshift can be used to add directories to the front of the search order either to save search time or to override libraries with the same name in the 'normal' directories. The load function that dl_load_file() calls may require an absolute pathname. The dl_findfile() function and @dl_library_path can be used to search for and return the absolute pathname for the library/object that you wish to load. ---------------------------------------------------------------------- @dl_resolve_using A list of additional libraries or other shared objects which can be used to resolve any undefined symbols that might be generated by a later call to load_file(). This is only required on some platforms which do not handle dependent libraries automatically. For example the Socket perl extension library (auto/Socket/Socket.so) contains references to many socket functions which need to be resolved when it's loaded. Most platforms will automatically know where to find the 'dependent' library (e.g., /usr/lib/libsocket.so). A few platforms need to to be told the location of the dependent library explicitly. Use @dl_resolve_using for this. Example usage: @dl_resolve_using = dl_findfile('-lsocket'); ---------------------------------------------------------------------- @dl_require_symbols A list of one or more symbol names that are in the library/object file to be dynamically loaded. This is only required on some platforms. ---------------------------------------------------------------------- $message = dl_error Error message text from the last failed DynaLoader function. Note that, similar to errno in unix, a successful function call does not reset this message. Implementations should detect the error as soon as it occurs in any of the other functions and save the corresponding message for later retrieval. This will avoid problems on some platforms (such as SunOS) where the error message is very temporary (e.g., dlerror()). ---------------------------------------------------------------------- $dl_debug Internal debugging messages are enabled when $dl_debug is set true. Currently setting $dl_debug only affects the perl side of the DynaLoader. These messages should help an application developer to resolve any DynaLoader usage problems. $dl_debug is set to $ENV{'PERL_DL_DEBUG'} if defined. For the DynaLoader developer/porter there is a similar debugging variable added to the C code (see dlutils.c) and enabled if perl is compiled with the -DDEBUGGING flag. This can also be set via the PERL_DL_DEBUG environment variable. Set to 1 for minimal information or higher for more. ---------------------------------------------------------------------- @filepaths = dl_findfile(@names) Determine the full paths (including file suffix) of one or more loadable files given their generic names and optionally one or more directories. Searches directories in @dl_library_path by default and returns an empty list if no files were found. Names can be specified in a variety of platform independent forms. Any names in the form '-lname' are converted into 'libname.*', where .* is an appropriate suffix for the platform. If a name does not already have a suitable prefix and/or suffix then the corresponding file will be searched for by trying combinations of prefix and suffix appropriate to the platform: "$name.o", "lib$name.*" and "$name". If any directories are included in @names they are searched before @dl_library_path. Directories may be specified as -Ldir. Any other names are treated as filenames to be searched for. Using arguments of the form -Ldir and -lname is recommended. Example: @dl_resolve_using = dl_findfile(qw(-L/usr/5lib -lposix)); ---------------------------------------------------------------------- $filepath = dl_expandspec($spec) Some unusual systems, such as VMS, require special filename handling in order to deal with symbolic names for files (i.e., VMS's Logical Names). To support these systems a dl_expandspec function can be implemented either in the dl_*.xs file or code can be added to the autoloadable dl_expandspec function in DynaLoader.pm. See DynaLoader.pm for more information. ---------------------------------------------------------------------- $libref = dl_load_file($filename) Dynamically load $filename, which must be the path to a shared object or library. An opaque 'library reference' is returned as a handle for the loaded object. Returns undef on error. (On systems that provide a handle for the loaded object such as SunOS and HPUX, $libref will be that handle. On other systems $libref will typically be $filename or a pointer to a buffer containing $filename. The application should not examine or alter $libref in any way.) This is function that does the real work. It should use the current values of @dl_require_symbols and @dl_resolve_using if required. SunOS: dlopen($filename) HP-UX: shl_load($filename) Linux: dld_create_reference(@dl_require_symbols); dld_link($filename) NeXT: rld_load($filename, @dl_resolve_using) VMS: lib$find_image_symbol($filename,$dl_require_symbols[0]) ---------------------------------------------------------------------- $symref = dl_find_symbol($libref, $symbol) Return the address of the symbol $symbol or undef if not found. If the target system has separate functions to search for symbols of different types then dl_find_symbol should search for function symbols first and then other types. The exact manner in which the address is returned in $symref is not currently defined. The only initial requirement is that $symref can be passed to, and understood by, dl_install_xsub(). SunOS: dlsym($libref, $symbol) HP-UX: shl_findsym($libref, $symbol) Linux: dld_get_func($symbol) and/or dld_get_symbol($symbol) NeXT: rld_lookup("_$symbol") VMS: lib$find_image_symbol($libref,$symbol) ---------------------------------------------------------------------- @symbols = dl_undef_symbols() Return a list of symbol names which remain undefined after load_file(). Returns () if not known. Don't worry if your platform does not provide a mechanism for this. Most do not need it and hence do not provide it. ---------------------------------------------------------------------- dl_install_xsub($perl_name, $symref [, $filename]) Create a new Perl external subroutine named $perl_name using $symref as a pointer to the function which implements the routine. This is simply a direct call to newXSUB(). Returns a reference to the installed function. The $filename parameter is used by Perl to identify the source file for the function if required by die(), caller() or the debugger. If $filename is not defined then "DynaLoader" will be used. ---------------------------------------------------------------------- bootstrap($module) This is the normal entry point for automatic dynamic loading in Perl. It performs the following actions: 1. locates an auto/$module directory by searching @INC 2. uses dl_findfile() to determine the filename to load 3. sets @dl_require_symbols to ("boot_$module") 4. executes an auto/$module/$^R/$module.bs file if it exists (typically used to add to @dl_resolve_using any files which are required to load the module on the current platform) 5. calls dl_load_file() to load the file 6. calls dl_undef_symbols() and warns if any symbols are undefined 7. calls dl_find_symbol() for "boot_$module" 8. calls dl_install_xsub() to install it as "${module}::bootstrap" 9. calls &{"${module}::bootstrap"} to bootstrap the module ====================================================================== End. --------------------------------- $message = dl_error Error message text from the last failed DynaLoader function. Note that, similar to errno in unix, a succeperl5.000/ext/DynaLoader/DynaLoader.pm 664 203 12 20502 5650421416 12650 package DynaLoader; # # And Gandalf said: 'Many folk like to know beforehand what is to # be set on the table; but those who have laboured to prepare the # feast like to keep their secret; for wonder makes the words of # praise louder.' # # Quote from Tolkien sugested by Anno Siegel. # # Read ext/DynaLoader/README and DynaLoader.doc for # detailed information. # # Tim.Bunce@ig.co.uk, August 1994 use Config; use Carp; use AutoLoader; @ISA=(AutoLoader); # enable messages from DynaLoader perl code $dl_debug = 0 unless $dl_debug; $dl_debug = $ENV{'PERL_DL_DEBUG'} if $ENV{'PERL_DL_DEBUG'}; $dl_so = $dl_dlext = ""; # avoid typo warnings $dl_so = $Config{'so'}; # suffix for shared libraries $dl_dlext = $Config{'dlext'}; # suffix for dynamic modules # Some systems need special handling to expand file specifications # (VMS support by Charles Bailey ) # See dl_expandspec() for more details. Should be harmless but # inefficient to define on systems that don't need it. $do_expand = ($Config{'osname'} eq 'VMS'); @dl_require_symbols = (); # names of symbols we need @dl_resolve_using = (); # names of files to link with @dl_library_path = (); # path to look for files # This is a fix to support DLD's unfortunate desire to relink -lc @dl_resolve_using = dl_findfile('-lc') if $Config{'dlsrc'} eq "dl_dld.xs"; # Initialise @dl_library_path with the 'standard' library path # for this platform as determined by Configure push(@dl_library_path, split(' ',$Config{'libpth'})); # Add to @dl_library_path any extra directories we can gather from # environment variables. So far LD_LIBRARY_PATH is the only known # variable used for this purpose. Others may be added later. push(@dl_library_path, split(/:/, $ENV{'LD_LIBRARY_PATH'})) if $ENV{'LD_LIBRARY_PATH'}; # No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. &boot_DynaLoader if defined &boot_DynaLoader; print STDERR "DynaLoader.pm loaded (@dl_library_path)\n" if ($dl_debug >= 2); # Temporary interface checks for recent changes (Aug 1994) if (defined(&dl_load_file)){ die "dl_error not defined" unless defined (&dl_error); die "dl_undef_symbols not defined" unless defined (&dl_undef_symbols); } 1; # End of main code # The bootstrap function cannot be autoloaded (without complications) # so we define it here: sub bootstrap { # use local vars to enable $module.bs script to edit values local(@args) = @_; local($module) = $args[0]; local(@dirs, $file); croak "Usage: DynaLoader::bootstrap(module)" unless ($module); croak "Can't load module $module, DynaLoader not linked into this perl" unless defined(&dl_load_file); print STDERR "DynaLoader::bootstrap($module)\n" if $dl_debug; my(@modparts) = split(/::/,$module); my($modfname) = $modparts[-1]; my($modpname) = join('/',@modparts); foreach (@INC) { my $dir = "$_/auto/$modpname"; next unless -d $dir; # skip over uninteresting directories # check for common cases to avoid autoload of dl_findfile last if ($file=_check_file("$dir/$modfname.$dl_dlext")); # no luck here, save dir for possible later dl_findfile search push(@dirs, "-L$dir"); } # last resort, let dl_findfile have a go in all known locations $file = dl_findfile(@dirs, map("-L$_",@INC), $modfname) unless $file; croak "Can't find loadable object for module $module in \@INC" unless $file; my($bootname) = "boot_$module"; $bootname =~ s/\W/_/g; @dl_require_symbols = ($bootname); # Execute optional '.bootstrap' perl script for this module. # The .bs file can be used to configure @dl_resolve_using etc to # match the needs of the individual module on this architecture. my $bs = $file; $bs =~ s/\.$dl_dlext$/\.bs/o; # look for .bs 'beside' the library if (-f $bs) { local($osname, $dlsrc) = @Config{'osname','dlsrc'}; print STDERR "$bs ($osname, $dlsrc)\n" if $dl_debug; $@ = ""; do $bs; warn "$bs: $@\n" if $@; } my $libref = DynaLoader::dl_load_file($file) or croak "Can't load '$file' for module $module: ".&dl_error."\n"; my(@unresolved) = dl_undef_symbols(); carp "Undefined symbols present after loading $file: @unresolved\n" if (@unresolved); my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or croak "Can't find '$bootname' symbol in $file\n"; dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); &{"${module}::bootstrap"}(@args); } sub _check_file{ # private utility to handle dl_expandspec vs -f tests my($file) = @_; return $file if (!$do_expand && -f $file); # the common case return $file if ( $do_expand && ($file=dl_expandspec($file))); return undef; } # Let autosplit and the autoloader deal with these functions: __END__ sub dl_findfile { # Read ext/DynaLoader/DynaLoader.doc for detailed information. # This function does not automatically consider the architecture # or the perl library auto directories. my (@args) = @_; my (@dirs, $dir); # which directories to search my (@found); # full paths to real files we have found my ($vms) = ($Config{'osname'} eq 'VMS'); print STDERR "dl_findfile(@args)\n" if $dl_debug; # accumulate directories but process files as they appear arg: foreach(@args) { # Special fast case: full filepath requires no search if (m:/: && -f $_ && !$do_expand){ push(@found,$_); last arg unless wantarray; next; } # Deal with directories first: # Using a -L prefix is the preferred option (faster and more robust) if (m:^-L:){ s/^-L//; push(@dirs, $_); next; } # Otherwise we try to try to spot directories by a heuristic # (this is a more complicated issue than it first appears) if (m:/: && -d $_){ push(@dirs, $_); next; } # VMS: we may be using native VMS directry syntax instead of # Unix emulation, so check this as well if ($vms && /[:>\]]/ && -d $_){ push(@dirs, $_); next; } # Only files should get this far... my(@names, $name); # what filenames to look for if (m:-l: ){ # convert -lname to appropriate library name s/-l//; push(@names,"lib$_.$dl_so"); push(@names,"lib$_.a"); }else{ # Umm, a bare name. Try various alternatives: # these should be ordered with the most likely first push(@names,"$_.$dl_so") unless m/\.$dl_so$/o; push(@names,"lib$_.$dl_so") unless m:/:; push(@names,"$_.o") unless m/\.(o|$dl_so)$/o; push(@names,"$_.a") unless m/\.a$/; push(@names, $_); } foreach $dir (@dirs, @dl_library_path) { next unless -d $dir; foreach $name (@names) { my($file) = "$dir/$name"; print STDERR " checking in $dir for $name\n" if $dl_debug; $file = _check_file($file); if ($file){ push(@found, $file); next arg; # no need to look any further } } } } if ($dl_debug) { foreach(@dirs) { print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_; } print STDERR "dl_findfile found: @found\n"; } return $found[0] unless wantarray; @found; } sub dl_expandspec{ my($spec) = @_; # Optional function invoked if DynaLoader.pm sets $do_expand. # Most systems do not require or use this function. # Some systems may implement it in the dl_*.xs file in which case # this autoload version will not be called but is harmless. # This function is designed to deal with systems which treat some # 'filenames' in a special way. For example VMS 'Logical Names' # (something like unix environment variables - but different). # This function should recognise such names and expand them into # full file paths. # Must return undef if $spec is invalid or file does not exist. my($file) = $spec; # default output to input my($osname) = $Config{'osname'}; if ($osname eq 'VMS'){ # dl_expandspec should be defined in dl_vms.xs croak "dl_expandspec: should be defined in XS file!\n"; }else{ return undef unless -f $file; } print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug; $file; } with the -DDEBUGGING flag. This can also be set via the PERL_DL_DEBUG environment variable. Set to 1 for minimal information or higher for more. -----------------------------------------perl5.000/ext/DynaLoader/Makefile.SH 664 203 12 11352 5650410572 12245 : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac 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 fi : Find absolute path name for TOP. This is needed when we cd to TOP : to run perl on autosplit. oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd case $CONFIG in '') . $TOP/config.sh ;; esac : Find out directory name. This is also the extension name. ext=`pwd | $sed -e 's@.*/@@'` : This extension might have its own typemap if test -f typemap; then exttypemap='typemap' else exttypemap='' fi : This extension might need additional libraries. potential_libs="" . $TOP/ext/util/extliblist echo "Extracting ext/$ext/Makefile (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted : by putting a backslash in front. You may delete these comments. $spitshell >Makefile << !GROK!THIS! # # This Makefile is for the $ext extension to perl. # DLSRC = $dlsrc CC = $cc RANLIB = $ranlib TOP = $TOP ABSTOP = $ABSTOP LDFLAGS = $ldflags CLDFLAGS = $ldflags SMALL = $small LARGE = $large $split # To use an alternate make, set \$altmake in config.sh. MAKE = ${altmake-make} EXT = $ext # $ext might have its own typemap EXTTYPEMAP = $exttypemap # The following are used to build and install shared libraries for # dynamic loading. LDDLFLAGS = $lddlflags CCDLFLAGS = $ccdlflags CCCDLFLAGS = $cccdlflags SO = $so DLEXT = $dlext # $ext might need to be linked with some extra libraries. # EXTRALIBS = full list of libraries needed for static linking. # Only those libraries that actually exist are included. # DYNLOADLIBS = list of those libraries that are needed but can be # linked in dynamically on this platform. On SunOS, for # example, this would be .so* libraries, but not archive # libraries. The bootstrap file is installed only if # this list is not empty. # STATLOADLIBS = list of those libraries which must be statically # linked into the shared library. On SunOS 4.1.3, # for example, I have only an archive version of # -lm, and it must be linked in statically. EXTRALIBS = $extralibs DYNALOADLIBS = $dynaloadlibs STATLOADLIBS = $statloadlibs !GROK!THIS! $spitshell >>Makefile <<'!NO!SUBS!' # Where to put things: AUTO = $(TOP)/lib/auto INSTALLSTATIC = $(EXT).a INSTALLPM = $(TOP)/lib/$(EXT).pm PERL = $(ABSTOP)/miniperl XSUBPP = $(TOP)/ext/xsubpp SHELL = /bin/sh CCCMD = `sh $(shellflags) $(TOP)/cflags $@` .c.o: $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c all: static # Phony target to force checking subdirectories. FORCE: config: # Target for Dynamic Loading: # If we hit here, there's a mistake somewhere. dynamic: static @echo "The DynaLoader extension must be built for static linking" false # Target for Static Loading: static: $(INSTALLSTATIC) $(INSTALLPM) $(INSTALLSTATIC): $(EXT).o ar cr $@ $(EXT).o $(RANLIB) $@ echo $(EXTRALIBS) >> $(TOP)/ext.libs $(EXT).c: $(DLSRC) dlutils.c $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile $(PERL) $(XSUBPP) $(DLSRC) >tmp mv tmp $@ $(INSTALLPM): $(EXT).pm rm -f $@ cp $(EXT).pm $@ cd $(TOP); $(PERL) autosplit $(EXT) # Perform very simple tests just to check for major gaffs. # We can't do much more for platforms we are not executing on. test-xs: for i in dl_*xs; do $(PERL) $(XSUBPP) $$i > /dev/null; done clean: rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) realclean: clean rm -f makefile Makefile rm -f $(INSTALLPM) $(INSTALLSTATIC) rm -rf $(AUTO)/$(EXT) purge: realclean $(EXT).o : $(TOP)/EXTERN.h $(EXT).o : $(TOP)/perl.h $(EXT).o : $(TOP)/embed.h $(EXT).o : $(TOP)/config.h $(EXT).o : $(TOP)/unixish.h $(EXT).o : $(TOP)/handy.h $(EXT).o : $(TOP)/regexp.h $(EXT).o : $(TOP)/sv.h $(EXT).o : $(TOP)/util.h $(EXT).o : $(TOP)/form.h $(EXT).o : $(TOP)/gv.h $(EXT).o : $(TOP)/cv.h $(EXT).o : $(TOP)/opcode.h $(EXT).o : $(TOP)/op.h $(EXT).o : $(TOP)/cop.h $(EXT).o : $(TOP)/av.h $(EXT).o : $(TOP)/hv.h $(EXT).o : $(TOP)/mg.h $(EXT).o : $(TOP)/scope.h $(EXT).o : $(TOP)/pp.h $(EXT).o : $(TOP)/proto.h $(EXT).o : $(TOP)/XSUB.h Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH $(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH $(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH $(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH !NO!SUBS! chmod 644 Makefile $eunicefix Makefile sue than it first appears) if (m:/: && -d $_){ push(@dirs, $_); next; } # VMS: we may be using native VMS directry syntax instead of # Unix emulation, so check this as well if ($vms && /[:>\]]/ && -d $_){ push(@dirs, $_); next; } # perl5.000/ext/DynaLoader/README 664 203 12 4127 5633716435 11146 Perl 5 DynaLoader See DynaLoader.doc for detailed specification. This module is very similar to the other Perl 5 modules except that Configure selects which dl_*.xs file to use. After Configure has been run the Makefile.SH will generate a Makefile which will run xsubpp on a specific dl_*.xs file and write the output to DynaLoader.c After that the processing is the same as any other module. Note that, to be effective, the DynaLoader module must be _statically_ linked into perl! Configure should arrange this. This interface is based on the work and comments of (in no particular order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno Siegel, Thomas Neumann, Paul Marquess, Charles Bailey and others. The dl_*.xs files should either be named after the dynamic linking operating system interface used if that interface is available on more than one type of system, e.g.: dlopen for dlopen()/dlsym() type functions (SunOS, BSD) dld for the GNU dld library functions (linux, ?) or else the osname, e.g., hpux, next, vms etc. Both are determined by Configure and so only those specific names that Configure knows/uses will work. If porting the DynaLoader to a platform that has a core dynamic linking interface similar to an existing generic type, e.g., dlopen or dld, please try to port the corresponding dl_*.xs file (using #ifdef's if required). Otherwise, or if that proves too messy, create a new dl_*.xs file named after your osname. Configure will give preference to a dl_$osname.xs file if one exists. The file dl_dlopen.xs is a reference implementation by Paul Marquess which is a good place to start if porting from scratch. For more complex platforms take a look at dl_dld.xs. The dlutils.c file holds some common definitions that are #included into the dl_*.xs files. After the initial implementation of a new DynaLoader dl_*.xs file you may need to edit or create ext/MODULE/MODULE.bs files to reflect the needs of your platform and linking software. Refer to DynaLoader.doc, ext/utils/mkbootstrap and any existing ext/MODULE/MODULE.bs files for more information. Tim Bunce. August 1994 : $(TOP)/sv.h $(EXT).o : $(TOP)/util.h $(EXT).o : $(TOP)/form.h $(EXT).o : $(TOP)/gv.h $(EXT).o : $(TOP)/cv.h $(EXT).o : $(TOP)/opcode.h $(EXT).o : $(TOP)/op.h $(EXT).o : $(TOP)/cop.h $(EXT).o : $(TOP)/av.h $(EXT).o : $(TOP)/hv.h $(EXT).o : $(TOP)/mg.h $(EXT).o : $(TOP)/scope.h $(EXT).o : $(TOP)/pp.h $(EXT).o : $(TOP)/proto.h $(EXT).o : $(TOP)/XSUB.h Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH $(TOP)/coperl5.000/ext/DynaLoader/dl_aix.xs 664 203 12 31375 5645376765 12142 /* dl_aix.xs * * Written: 8/31/94 by Wayne Scott (wscott@ichips.intel.com) * * All I did was take Jens-Uwe Mager's libdl emulation library for * AIX and merged it with the dl_dlopen.xs file to create a dynamic library * package that works for AIX. * * I did change all malloc's, free's, strdup's, calloc's to use the perl * equilvant. I also removed some stuff we will not need. Call fini() * on statup... It can probably be trimmed more. */ /* * @(#)dlfcn.c 1.5 revision of 93/02/14 20:14:17 * This is an unpublished work copyright (c) 1992 Helios Software GmbH * 3000 Hannover 1, Germany */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include #include #include #include #include #include #include #include /* * We simulate dlopen() et al. through a call to load. Because AIX has * no call to find an exported symbol we read the loader section of the * loaded module and build a list of exported symbols and their virtual * address. */ typedef struct { char *name; /* the symbols's name */ void *addr; /* its relocated virtual address */ } Export, *ExportPtr; /* * The void * handle returned from dlopen is actually a ModulePtr. */ typedef struct Module { struct Module *next; char *name; /* module name for refcounting */ int refCnt; /* the number of references */ void *entry; /* entry point from load */ int nExports; /* the number of exports found */ ExportPtr exports; /* the array of exports */ } Module, *ModulePtr; /* * We keep a list of all loaded modules to be able to call the fini * handlers at atexit() time. */ static ModulePtr modList; /* * The last error from one of the dl* routines is kept in static * variables here. Each error is returned only once to the caller. */ static char errbuf[BUFSIZ]; static int errvalid; static void caterr(char *); static int readExports(ModulePtr); static void terminate(void); static void *findMain(void); /* ARGSUSED */ void *dlopen(char *path, int mode) { register ModulePtr mp; static void *mainModule; /* * Upon the first call register a terminate handler that will * close all libraries. Also get a reference to the main module * for use with loadbind. */ if (!mainModule) { if ((mainModule = findMain()) == NULL) return NULL; atexit(terminate); } /* * Scan the list of modules if have the module already loaded. */ for (mp = modList; mp; mp = mp->next) if (strcmp(mp->name, path) == 0) { mp->refCnt++; return mp; } Newz(1000,mp,1,Module); if (mp == NULL) { errvalid++; strcpy(errbuf, "Newz: "); strcat(errbuf, strerror(errno)); return NULL; } if ((mp->name = savepv(path)) == NULL) { errvalid++; strcpy(errbuf, "savepv: "); strcat(errbuf, strerror(errno)); safefree(mp); return NULL; } /* * load should be declared load(const char *...). Thus we * cast the path to a normal char *. Ugly. */ if ((mp->entry = (void *)load((char *)path, L_NOAUTODEFER, NULL)) == NULL) { safefree(mp->name); safefree(mp); errvalid++; strcpy(errbuf, "dlopen: "); strcat(errbuf, path); strcat(errbuf, ": "); /* * If AIX says the file is not executable, the error * can be further described by querying the loader about * the last error. */ if (errno == ENOEXEC) { char *tmp[BUFSIZ/sizeof(char *)]; if (loadquery(L_GETMESSAGES, tmp, sizeof(tmp)) == -1) strcpy(errbuf, strerror(errno)); else { char **p; for (p = tmp; *p; p++) caterr(*p); } } else strcat(errbuf, strerror(errno)); return NULL; } mp->refCnt = 1; mp->next = modList; modList = mp; if (loadbind(0, mainModule, mp->entry) == -1) { dlclose(mp); errvalid++; strcpy(errbuf, "loadbind: "); strcat(errbuf, strerror(errno)); return NULL; } if (readExports(mp) == -1) { dlclose(mp); return NULL; } return mp; } /* * Attempt to decipher an AIX loader error message and append it * to our static error message buffer. */ static void caterr(char *s) { register char *p = s; while (*p >= '0' && *p <= '9') p++; switch(atoi(s)) { case L_ERROR_TOOMANY: strcat(errbuf, "to many errors"); break; case L_ERROR_NOLIB: strcat(errbuf, "can't load library"); strcat(errbuf, p); break; case L_ERROR_UNDEF: strcat(errbuf, "can't find symbol"); strcat(errbuf, p); break; case L_ERROR_RLDBAD: strcat(errbuf, "bad RLD"); strcat(errbuf, p); break; case L_ERROR_FORMAT: strcat(errbuf, "bad exec format in"); strcat(errbuf, p); break; case L_ERROR_ERRNO: strcat(errbuf, strerror(atoi(++p))); break; default: strcat(errbuf, s); break; } } void *dlsym(void *handle, const char *symbol) { register ModulePtr mp = (ModulePtr)handle; register ExportPtr ep; register int i; /* * Could speed up search, but I assume that one assigns * the result to function pointers anyways. */ for (ep = mp->exports, i = mp->nExports; i; i--, ep++) if (strcmp(ep->name, symbol) == 0) return ep->addr; errvalid++; strcpy(errbuf, "dlsym: undefined symbol "); strcat(errbuf, symbol); return NULL; } char *dlerror(void) { if (errvalid) { errvalid = 0; return errbuf; } return NULL; } int dlclose(void *handle) { register ModulePtr mp = (ModulePtr)handle; int result; register ModulePtr mp1; if (--mp->refCnt > 0) return 0; result = unload(mp->entry); if (result == -1) { errvalid++; strcpy(errbuf, strerror(errno)); } if (mp->exports) { register ExportPtr ep; register int i; for (ep = mp->exports, i = mp->nExports; i; i--, ep++) if (ep->name) safefree(ep->name); safefree(mp->exports); } if (mp == modList) modList = mp->next; else { for (mp1 = modList; mp1; mp1 = mp1->next) if (mp1->next == mp) { mp1->next = mp->next; break; } } safefree(mp->name); safefree(mp); return result; } static void terminate(void) { while (modList) dlclose(modList); } /* Added by Wayne Scott * This is needed because the ldopen system call calls * calloc to allocated a block of date. The ldclose call calls free. * Without this we get this system calloc and perl's free, resulting * in a "Bad free" message. This way we always use perl's malloc. */ void *calloc(size_t ne, size_t sz) { void *out; out = (void *) safemalloc(ne*sz); memzero(out, ne*sz); return(out); } /* * Build the export table from the XCOFF .loader section. */ static int readExports(ModulePtr mp) { LDFILE *ldp = NULL; SCNHDR sh; LDHDR *lhp; char *ldbuf; LDSYM *ls; int i; ExportPtr ep; if ((ldp = ldopen(mp->name, ldp)) == NULL) { struct ld_info *lp; char *buf; int size = 4*1024; if (errno != ENOENT) { errvalid++; strcpy(errbuf, "readExports: "); strcat(errbuf, strerror(errno)); return -1; } /* * The module might be loaded due to the LIBPATH * environment variable. Search for the loaded * module using L_GETINFO. */ if ((buf = safemalloc(size)) == NULL) { errvalid++; strcpy(errbuf, "readExports: "); strcat(errbuf, strerror(errno)); return -1; } while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { safefree(buf); size += 4*1024; if ((buf = safemalloc(size)) == NULL) { errvalid++; strcpy(errbuf, "readExports: "); strcat(errbuf, strerror(errno)); return -1; } } if (i == -1) { errvalid++; strcpy(errbuf, "readExports: "); strcat(errbuf, strerror(errno)); safefree(buf); return -1; } /* * Traverse the list of loaded modules. The entry point * returned by load() does actually point to the data * segment origin. */ lp = (struct ld_info *)buf; while (lp) { if (lp->ldinfo_dataorg == mp->entry) { ldp = ldopen(lp->ldinfo_filename, ldp); break; } if (lp->ldinfo_next == 0) lp = NULL; else lp = (struct ld_info *)((char *)lp + lp->ldinfo_next); } safefree(buf); if (!ldp) { errvalid++; strcpy(errbuf, "readExports: "); strcat(errbuf, strerror(errno)); return -1; } } if (TYPE(ldp) != U802TOCMAGIC) { errvalid++; strcpy(errbuf, "readExports: bad magic"); while(ldclose(ldp) == FAILURE) ; return -1; } if (ldnshread(ldp, _LOADER, &sh) != SUCCESS) { errvalid++; strcpy(errbuf, "readExports: cannot read loader section header"); while(ldclose(ldp) == FAILURE) ; return -1; } /* * We read the complete loader section in one chunk, this makes * finding long symbol names residing in the string table easier. */ if ((ldbuf = (char *)safemalloc(sh.s_size)) == NULL) { errvalid++; strcpy(errbuf, "readExports: "); strcat(errbuf, strerror(errno)); while(ldclose(ldp) == FAILURE) ; return -1; } if (FSEEK(ldp, sh.s_scnptr, BEGINNING) != OKFSEEK) { errvalid++; strcpy(errbuf, "readExports: cannot seek to loader section"); safefree(ldbuf); while(ldclose(ldp) == FAILURE) ; return -1; } if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) { errvalid++; strcpy(errbuf, "readExports: cannot read loader section"); safefree(ldbuf); while(ldclose(ldp) == FAILURE) ; return -1; } lhp = (LDHDR *)ldbuf; ls = (LDSYM *)(ldbuf+LDHDRSZ); /* * Count the number of exports to include in our export table. */ for (i = lhp->l_nsyms; i; i--, ls++) { if (!LDR_EXPORT(*ls)) continue; mp->nExports++; } Newz(1001, mp->exports, mp->nExports, Export); if (mp->exports == NULL) { errvalid++; strcpy(errbuf, "readExports: "); strcat(errbuf, strerror(errno)); safefree(ldbuf); while(ldclose(ldp) == FAILURE) ; return -1; } /* * Fill in the export table. All entries are relative to * the entry point we got from load. */ ep = mp->exports; ls = (LDSYM *)(ldbuf+LDHDRSZ); for (i = lhp->l_nsyms; i; i--, ls++) { char *symname; if (!LDR_EXPORT(*ls)) continue; if (ls->l_zeroes == 0) symname = ls->l_offset+lhp->l_stoff+ldbuf; else symname = ls->l_name; ep->name = savepv(symname); ep->addr = (void *)((unsigned long)mp->entry + ls->l_value); ep++; } safefree(ldbuf); while(ldclose(ldp) == FAILURE) ; return 0; } /* * Find the main modules entry point. This is used as export pointer * for loadbind() to be able to resolve references to the main part. */ static void * findMain(void) { struct ld_info *lp; char *buf; int size = 4*1024; int i; void *ret; if ((buf = safemalloc(size)) == NULL) { errvalid++; strcpy(errbuf, "findMain: "); strcat(errbuf, strerror(errno)); return NULL; } while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { safefree(buf); size += 4*1024; if ((buf = safemalloc(size)) == NULL) { errvalid++; strcpy(errbuf, "findMain: "); strcat(errbuf, strerror(errno)); return NULL; } } if (i == -1) { errvalid++; strcpy(errbuf, "findMain: "); strcat(errbuf, strerror(errno)); safefree(buf); return NULL; } /* * The first entry is the main module. The entry point * returned by load() does actually point to the data * segment origin. */ lp = (struct ld_info *)buf; ret = lp->ldinfo_dataorg; safefree(buf); return ret; } /* dl_dlopen.xs * * Platform: SunOS/Solaris, possibly others which use dlopen. * Author: Paul Marquess (pmarquess@bfsec.bt.co.uk) * Created: 10th July 1994 * * Modified: * 15th July 1994 - Added code to explicitly save any error messages. * 3rd August 1994 - Upgraded to v3 spec. * 9th August 1994 - Changed to use IV * 10th August 1994 - Tim Bunce: Added RTLD_LAZY, switchable debugging, * basic FreeBSD support, removed ClearError * */ /* Porting notes: see dl_dlopen.xs */ #include "dlutils.c" /* SaveError() etc */ static void dl_private_init() { (void)dl_generic_private_init(); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: (void)dl_private_init(); void * dl_load_file(filename) char * filename CODE: DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); RETVAL = dlopen(filename, 1) ; DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; else sv_setiv( ST(0), (IV)RETVAL); void * dl_find_symbol(libhandle, symbolname) void * libhandle char * symbolname CODE: DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; 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. assume that one assigns * the result to function pointers anyways. */ for (ep = mp->exports, i = mp->nExports; i; i--, ep++) if (strcmp(ep->name, symbol) == 0) return ep->addr; errvalid++; strcpy(errbuf, "dlsym: undefined symbol "); strcat(errbufperl5.000/ext/DynaLoader/dl_dld.xs 664 203 12 10443 5645374672 12110 /* * Written 3/1/94, Robert Sanders * * based upon the file "dl.c", which is * Copyright (c) 1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * * $Date: 1994/03/07 00:21:43 $ * $Source: /home/rsanders/src/perl5alpha6/RCS/dld_dl.c,v $ * $Revision: 1.4 $ * $State: Exp $ * * $Log: dld_dl.c,v $ * Removed implicit link against libc. 1994/09/14 William Setzer. * * Integrated other DynaLoader changes. 1994/06/08 Tim Bunce. * * rewrote dl_load_file, misc updates. 1994/09/03 William Setzer. * * Revision 1.4 1994/03/07 00:21:43 rsanders * added min symbol count for load_libs and switched order so system libs * are loaded after app-specified libs. * * Revision 1.3 1994/03/05 01:17:26 rsanders * added path searching. * * Revision 1.2 1994/03/05 00:52:39 rsanders * added package-specified libraries. * * Revision 1.1 1994/03/05 00:33:40 rsanders * Initial revision * * */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include /* GNU DLD header file */ #include #include "dlutils.c" /* for SaveError() etc */ static void dl_private_init() { int dlderr; dl_generic_private_init(); #ifdef __linux__ dlderr = dld_init("/proc/self/exe"); if (dlderr) { #endif dlderr = dld_init(dld_find_executable(origargv[0])); if (dlderr) { char *msg = dld_strerror(dlderr); SaveError("dld_init(%s) failed: %s", origargv[0], msg); DLDEBUG(1,fprintf(stderr,"%s", LastError)); } #ifdef __linux__ } #endif } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: (void)dl_private_init(); char * dl_load_file(filename) char * filename CODE: int dlderr,x,max; GV *gv; AV *av; RETVAL = filename; DLDEBUG(1,fprintf(stderr,"dl_load_file(%s)\n", filename)); gv = gv_fetchpv("DynaLoader::dl_require_symbols", FALSE, SVt_PVAV); if (gv) { av = GvAV(gv); max = AvFILL(av); for (x = 0; x <= max; x++) { char *sym = SvPVX(*av_fetch(av, x, 0)); DLDEBUG(1,fprintf(stderr, "dld_create_ref(%s)\n", sym)); if (dlderr = dld_create_reference(sym)) { SaveError("dld_create_reference(%s): %s", sym, dld_strerror(dlderr)); goto haverror; } } } DLDEBUG(1,fprintf(stderr, "dld_link(%s)\n", filename)); if (dlderr = dld_link(filename)) { SaveError("dld_link(%s): %s", filename, dld_strerror(dlderr)); goto haverror; } gv = gv_fetchpv("DynaLoader::dl_resolve_using", FALSE, SVt_PVAV); if (gv) { av = GvAV(gv); max = AvFILL(av); for (x = 0; x <= max; x++) { char *sym = SvPVX(*av_fetch(av, x, 0)); DLDEBUG(1,fprintf(stderr, "dld_link(%s)\n", sym)); if (dlderr = dld_link(sym)) { SaveError("dld_link(%s): %s", sym, dld_strerror(dlderr)); goto haverror; } } } DLDEBUG(2,fprintf(stderr,"libref=%s\n", RETVAL)); haverror: ST(0) = sv_newmortal() ; if (dlderr == 0) sv_setiv(ST(0), (IV)RETVAL); void * dl_find_symbol(libhandle, symbolname) void * libhandle char * symbolname CODE: DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = (void *)dld_get_func(symbolname); /* if RETVAL==NULL we should try looking for a non-function symbol */ DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("dl_find_symbol: Unable to find '%s' symbol", symbolname) ; else sv_setiv(ST(0), (IV)RETVAL); void dl_undef_symbols() PPCODE: if (dld_undefined_sym_count) { int x; char **undef_syms = dld_list_undefined_sym(); EXTEND(sp, dld_undefined_sym_count); for (x=0; x < dld_undefined_sym_count; x++) PUSHs(sv_2mortal(newSVpv(undef_syms[x]+1, 0))); free(undef_syms); } # 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. ile. * * $Date: 1994/03/07 00:21:43 $ * $Source: /home/rsanders/src/perl5alpha6/RCS/dld_dl.c,v $ * $Revision: 1.4 $ * $State: Exp $ * * $Log: dld_dl.c,v $ * Removed implicit link against libc. 1994/09/14 William perl5.000/ext/DynaLoader/dl_dlopen.xs 664 203 12 13046 5633716436 12623 /* dl_dlopen.xs * * Platform: SunOS/Solaris, possibly others which use dlopen. * Author: Paul Marquess (pmarquess@bfsec.bt.co.uk) * Created: 10th July 1994 * * Modified: * 15th July 1994 - Added code to explicitly save any error messages. * 3rd August 1994 - Upgraded to v3 spec. * 9th August 1994 - Changed to use IV * 10th August 1994 - Tim Bunce: Added RTLD_LAZY, switchable debugging, * basic FreeBSD support, removed ClearError * */ /* Porting notes: Definition of Sunos dynamic Linking functions ============================================= In order to make this implementation easier to understand here is a quick definition of the SunOS Dynamic Linking functions which are used here. dlopen ------ void * dlopen(path, mode) char * path; int mode; This function takes the name of a dynamic object file and returns a descriptor which can be used by dlsym later. It returns NULL on error. The mode parameter must be set to 1 for Solaris 1 and to RTLD_LAZY on Solaris 2. dlsym ------ void * dlsym(handle, symbol) void * handle; char * symbol; Takes the handle returned from dlopen and the name of a symbol to get the address of. If the symbol was found a pointer is returned. It returns NULL on error. If DL_PREPEND_UNDERSCORE is defined an underscore will be added to the start of symbol. This is required on some platforms (freebsd). dlerror ------ char * dlerror() Returns a null-terminated string which describes the last error that occurred with either dlopen or dlsym. After each call to dlerror the error message will be reset to a null pointer. The SaveError function is used to save the error as soo as it happens. Return Types ============ In this implementation the two functions, dl_load_file & dl_find_symbol, return void *. This is because the underlying SunOS dynamic linker calls also return void *. This is not necessarily the case for all architectures. For example, some implementation will want to return a char * for dl_load_file. If void * is not appropriate for your architecture, you will have to change the void * to whatever you require. If you are not certain of how Perl handles C data types, I suggest you start by consulting Dean Roerich's Perl 5 API document. Also, have a look in the typemap file (in the ext directory) for a fairly comprehensive list of types that are already supported. If you are completely stuck, I suggest you post a message to perl5-porters, comp.lang.perl or if you are really desperate to me. Remember when you are making any changes that the return value from dl_load_file is used as a parameter in the dl_find_symbol function. Also the return value from find_symbol is used as a parameter to install_xsub. Dealing with Error Messages ============================ In order to make the handling of dynamic linking errors as generic as possible you should store any error messages associated with your implementation with the StoreError function. In the case of SunOS the function dlerror returns the error message associated with the last dynamic link error. As the SunOS dynamic linker functions dlopen & dlsym both return NULL on error every call to a SunOS dynamic link routine is coded like this RETVAL = dlopen(filename, 1) ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; Note that SaveError() takes a printf format string. Use a "%s" as the first parameter if the error may contain and % characters. */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef I_DLFCN #include /* the dynamic linker include file for Sunos/Solaris */ #else #include #include #endif #ifndef HAS_DLERROR #define dlerror() "Unknown error - dlerror() not implemented" #endif #include "dlutils.c" /* SaveError() etc */ static void dl_private_init() { (void)dl_generic_private_init(); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: (void)dl_private_init(); void * dl_load_file(filename) char * filename CODE: int mode = 1; /* Solaris 1 */ #ifdef RTLD_LAZY mode = RTLD_LAZY; /* Solaris 2 */ #endif DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); RETVAL = dlopen(filename, mode) ; DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; else sv_setiv( ST(0), (IV)RETVAL); void * dl_find_symbol(libhandle, symbolname) void * libhandle char * symbolname CODE: #ifdef DLSYM_NEEDS_UNDERSCORE char symbolname_buf[1024]; symbolname = dl_add_underscore(symbolname, symbolname_buf); #endif DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; 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. += 4*1024; if ((buf = safemalloc(size)) == NULL) { errvalid++; strcpy(errbuf, "readExports: "); strcat(errbuf, strerror(errno)); return -1; } } if (i == -1) { errvalid++; strcpy(errbuf, "readExports: "); strcat(errbuf, strerror(errno)); safefree(buf); return -1; } /* * Traverse the list of loaded modules. The entry point * returned by load() does actually point to the data * segment origin. */ lp = (struct ld_iperl5.000/ext/DynaLoader/dl_hpux.xs 664 203 12 4043 5633716437 12304 /* * Author: Jeff Okamoto (okamoto@corp.hp.com) */ #ifdef __hp9000s300 #define magic hpux_magic #define MAGIC HPUX_MAGIC #endif #include #ifdef __hp9000s300 #undef magic #undef MAGIC #endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "dlutils.c" /* for SaveError() etc */ static void dl_private_init() { (void)dl_generic_private_init(); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: (void)dl_private_init(); void * dl_load_file(filename) char * filename CODE: shl_t obj = NULL; DLDEBUG(1,fprintf(stderr,"dl_load_file(%s): ", filename)); obj = shl_load(filename, BIND_IMMEDIATE | BIND_NONFATAL | BIND_NOSTART | BIND_VERBOSE, 0L); DLDEBUG(2,fprintf(stderr," libref=%x\n", obj)); ST(0) = sv_newmortal() ; if (obj == NULL) SaveError("%s",Strerror(errno)) ; else sv_setiv( ST(0), (IV)obj); void * dl_find_symbol(libhandle, symbolname) void * libhandle char * symbolname CODE: shl_t obj = (shl_t) libhandle; void *symaddr = NULL; int status; #ifdef __hp9000s300 char symbolname_buf[MAXPATHLEN]; symbolname = dl_add_underscore(symbolname, symbolname_buf); #endif DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); status = shl_findsym(&obj, symbolname, TYPE_PROCEDURE, &symaddr); DLDEBUG(2,fprintf(stderr," symbolref = %x\n", symaddr)); ST(0) = sv_newmortal() ; if (status == -1) SaveError("%s",(errno) ? Strerror(errno) : "Symbol not found") ; else sv_setiv( ST(0), (IV)symaddr); int 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. ull-terminated string which describes the last error that occurred with either dlopen or dlsym. After each call to dlerror the error message will be reset to a null pointer. The SaveError function is used to save the error as soo as it happens. Return Types ============ In this implementation the two functions, dl_load_file & dl_find_symbol, return void *. This is because the underlying SunOS dynamic linker calls also return void *. This isperl5.000/ext/DynaLoader/dl_next.xs 664 203 12 10176 5633716437 12322 /* dl_next.xs * * Platform: NeXT NS 3.2 * Author: Anno Siegel (siegel@zrz.TU-Berlin.DE) * Based on: dl_dlopen.xs by Paul Marquess * Created: Aug 15th, 1994 * */ /* And Gandalf said: 'Many folk like to know beforehand what is to be set on the table; but those who have laboured to prepare the feast like to keep their secret; for wonder makes the words of praise louder.' */ /* Porting notes: dl_next.xs is itself a port from dl_dlopen.xs by Paul Marquess. It should not be used as a base for further ports though it may be used as an example for how dl_dlopen.xs can be ported to other platforms. The method used here is just to supply the sun style dlopen etc. functions in terms of NeXTs rld_*. The xs code proper is unchanged from Paul's original. The port could use some streamlining. For one, error handling could be simplified. Anno Siegel */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "dlutils.c" /* SaveError() etc */ #include #include static char * dl_last_error = (char *) 0; NXStream * OpenError() { return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY); } void TransferError( s) NXStream *s; { char *buffer; int len, maxlen; if ( dl_last_error ) { safefree(dl_last_error); } NXGetMemoryBuffer(s, &buffer, &len, &maxlen); dl_last_error = safemalloc(len); strcpy(dl_last_error, buffer); } void CloseError( s) NXStream *s; { if ( s ) { NXCloseMemory( s, NX_FREEBUFFER); } } char *dlerror() { return dl_last_error; } char * dlopen(path, mode) char * path; int mode; /* mode is ignored */ { int rld_success; NXStream *nxerr = OpenError(); AV * av_resolve; I32 i, psize; char *result; char **p; av_resolve = GvAVn(gv_fetchpv( "DynaLoader::dl_resolve_using", FALSE, SVt_PVAV)); psize = AvFILL(av_resolve) + 3; p = (char **) safemalloc(psize * sizeof(char*)); p[0] = path; for(i=1; i #include #include #include #include typedef unsigned long int vmssts; struct libref { struct dsc$descriptor_s name; struct dsc$descriptor_s defspec; }; /* Static data for dl_expand_filespec() - This is static to save * initialization on each call; if you need context-independence, * just make these auto variables in dl_expandspec() and dl_load_file() */ static char dlesa[NAM$C_MAXRSS], dlrsa[NAM$C_MAXRSS]; static struct FAB dlfab; static struct NAM dlnam; /* $PutMsg action routine - records error message in LastError */ static vmssts copy_errmsg(msg,unused) struct dsc$descriptor_s * msg; vmssts unused; { if (*(msg->dsc$a_pointer) = '%') { /* first line */ if (LastError) strncpy((LastError = saferealloc(LastError,msg->dsc$w_length)), msg->dsc$a_pointer, msg->dsc$w_length); else strncpy((LastError = safemalloc(msg->dsc$w_length)), msg->dsc$a_pointer, msg->dsc$w_length); return 0; } else { /* continuation line */ int errlen = strlen(LastError); LastError = saferealloc(LastError, errlen + msg->dsc$w_length + 1); LastError[errlen] = '\n'; LastError[errlen+1] = '\0'; strncat(LastError, msg->dsc$a_pointer, msg->dsc$w_length); } } /* Use $PutMsg to retrieve error message for failure status code */ static void dl_set_error(sts,stv) vmssts sts; vmssts stv; { vmssts vec[3],pmsts; vec[0] = stv ? 2 : 1; vec[1] = sts; vec[2] = stv; if (!(pmsts = sys$putmsg(vec,copy_errmsg,0,0)) & 1) croak("Fatal $PUTMSG error: %d",pmsts); } static void dl_private_init() { dl_generic_private_init(); /* Set up the static control blocks for dl_expand_filespec() */ dlfab = cc$rms_fab; dlnam = cc$rms_nam; dlfab.fab$l_nam = &dlnam; dlnam.nam$l_esa = dlesa; dlnam.nam$b_ess = sizeof dlesa; dlnam.nam$l_rsa = dlrsa; dlnam.nam$b_rss = sizeof dlrsa; } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: (void)dl_private_init(); SV * dl_expandspec(filespec) char * filespec CODE: char vmsspec[NAM$C_MAXRSS], defspec[NAM$C_MAXRSS]; size_t deflen; vmssts sts; tovmsspec(filespec,vmsspec); dlfab.fab$l_fna = vmsspec; dlfab.fab$b_fns = strlen(vmsspec); dlfab.fab$l_dna = 0; dlfab.fab$b_dns = 0; DLDEBUG(1,fprintf(stderr,"dl_expand_filespec(%s):\n",vmsspec)); /* On the first pass, just parse the specification string */ dlnam.nam$b_nop = NAM$M_SYNCHK; sts = sys$parse(&dlfab); DLDEBUG(2,fprintf(stderr,"\tSYNCHK sys$parse = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &sv_undef; } else { /* Now set up a default spec - everything but the name */ deflen = dlnam.nam$l_type - dlesa; memcpy(defspec,dlesa,deflen); memcpy(defspec+deflen,dlnam.nam$l_type, dlnam.nam$b_type + dlnam.nam$b_ver); deflen += dlnam.nam$b_type + dlnam.nam$b_ver; memcpy(vmsspec,dlnam.nam$l_name,dlnam.nam$b_name); DLDEBUG(2,fprintf(stderr,"\tsplit filespec: name = %.*s, default = %.*s\n", dlnam.nam$b_name,vmsspec,defspec,deflen)); /* . . . and go back to expand it */ dlnam.nam$b_nop = 0; dlfab.fab$l_dna = defspec; dlfab.fab$b_dns = deflen; dlfab.fab$b_fns = dlnam.nam$b_name; sts = sys$parse(&dlfab); DLDEBUG(2,fprintf(stderr,"\tname/default sys$parse = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &sv_undef; } else { /* Now find the actual file */ sts = sys$search(&dlfab); DLDEBUG(2,fprintf(stderr,"\tsys$search = %d\n",sts)); if (!(sts & 1) && sts != RMS$_FNF) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &sv_undef; } else { ST(0) = sv_2mortal(newSVpv(dlnam.nam$l_rsa,dlnam.nam$b_rsl)); DLDEBUG(1,fprintf(stderr,"\tresult = \\%.*s\\\n", dlnam.nam$b_rsl,dlnam.nam$l_rsa)); } } } void * dl_load_file(filespec) char * filespec CODE: char vmsspec[NAM$C_MAXRSS]; AV *reqAV; SV *reqSV, **reqSVhndl; STRLEN deflen; struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}, symdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; struct fscnlst { unsigned short int len; unsigned short int code; char *string; } namlst[2] = {0,FSCN$_NAME,0, 0,0,0}; struct libref *dlptr; vmssts sts, failed = 0; void *entry; DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n",filespec)); specdsc.dsc$a_pointer = tovmsspec(filespec,vmsspec); specdsc.dsc$w_length = strlen(specdsc.dsc$a_pointer); DLDEBUG(2,fprintf(stderr,"\tVMS-ified filespec is %s\n", specdsc.dsc$a_pointer)); dlptr = safemalloc(sizeof(struct libref)); dlptr->name.dsc$b_dtype = dlptr->defspec.dsc$b_dtype = DSC$K_DTYPE_T; dlptr->name.dsc$b_class = dlptr->defspec.dsc$b_class = DSC$K_CLASS_S; sts = sys$filescan(&specdsc,namlst,0); DLDEBUG(2,fprintf(stderr,"\tsys$filescan: returns %d, name is %.*s\n", sts,namlst[0].len,namlst[0].string)); if (!(sts & 1)) { failed = 1; dl_set_error(sts,0); } else { dlptr->name.dsc$w_length = namlst[0].len; dlptr->name.dsc$a_pointer = savepvn(namlst[0].string,namlst[0].len); dlptr->defspec.dsc$w_length = specdsc.dsc$w_length - namlst[0].len; dlptr->defspec.dsc$a_pointer = safemalloc(dlptr->defspec.dsc$w_length + 1); deflen = namlst[0].string - specdsc.dsc$a_pointer; memcpy(dlptr->defspec.dsc$a_pointer,specdsc.dsc$a_pointer,deflen); memcpy(dlptr->defspec.dsc$a_pointer + deflen, namlst[0].string + namlst[0].len, dlptr->defspec.dsc$w_length - deflen); DLDEBUG(2,fprintf(stderr,"\tlibref = name: %s, defspec: %.*s\n", dlptr->name.dsc$a_pointer, dlptr->defspec.dsc$w_length, dlptr->defspec.dsc$a_pointer)); if (!(reqAV = GvAV(gv_fetchpv("DynaLoader::dl_require_symbols", FALSE,SVt_PVAV))) || !(reqSVhndl = av_fetch(reqAV,0,FALSE)) || !(reqSV = *reqSVhndl)) { DLDEBUG(2,fprintf(stderr,"\t@dl_require_symbols empty, returning untested libref\n")); } else { symdsc.dsc$w_length = SvCUR(reqSV); symdsc.dsc$a_pointer = SvPVX(reqSV); DLDEBUG(2,fprintf(stderr,"\t$dl_require_symbols[0] = %.*s\n", symdsc.dsc$w_length, symdsc.dsc$a_pointer)); sts = lib$find_image_symbol(&(dlptr->name),&symdsc, &entry,&(dlptr->defspec)); DLDEBUG(2,fprintf(stderr,"\tlib$find_image_symbol returns %d\n",sts)); if (!(sts&1)) { failed = 1; dl_set_error(sts,0); } } } if (failed) { Safefree(dlptr->name.dsc$a_pointer); Safefree(dlptr->defspec.dsc$a_pointer); Safefree(dlptr); ST(0) = &sv_undef; } else { ST(0) = sv_2mortal(newSViv(dlptr)); } void * dl_find_symbol(librefptr,symname) void * librefptr SV * symname CODE: struct libref thislib = *((struct libref *)librefptr); struct dsc$descriptor_s symdsc = {SvCUR(symname),DSC$K_DTYPE_T,DSC$K_CLASS_S,SvPVX(symname)}; void (*entry)(); vmssts sts; DLDEBUG(1,fprintf(stderr,"dl_find_dymbol(%.*s,%.*s):\n", thislib.name.dsc$w_length, thislib.name.dsc$a_pointer, symdsc.dsc$w_length,symdsc.dsc$a_pointer)); sts = lib$find_image_symbol(&(thislib.name),&symdsc, &entry,&(thislib.defspec)); DLDEBUG(2,fprintf(stderr,"\tlib$find_image_symbol returns %d\n",sts)); DLDEBUG(2,fprintf(stderr,"\tentry point is %d\n", (unsigned long int) entry)); if (!(sts & 1)) { dl_set_error(sts,0); ST(0) = &sv_undef; } else ST(0) = sv_2mortal(newSViv(entry)); 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. return 0; } else { /* continuation line */ int errlen = strlen(LastError); LastError = saferealloc(LastError, errlen + msg->dsc$w_length + 1); LastError[errlen] perl5.000/ext/DynaLoader/dlutils.c 664 203 12 3505 5633716441 12106 /* dlutils.c - handy functions and definitions for dl_*.xs files * * Currently this file is simply #included into dl_*.xs/.c files. * It should really be split into a dlutils.h and dlutils.c * */ /* pointer to allocated memory for last error message */ static char *LastError = (char*)NULL; #ifdef DEBUGGING /* currently not connected to $DynaLoader::dl_error but should be */ static int dl_debug = 0; #define DLDEBUG(level,code) if(dl_debug>=level){ code; } #else #define DLDEBUG(level,code) #endif static void dl_generic_private_init() /* called by dl_*.xs dl_private_init() */ { #ifdef DEBUGGING char *perl_dl_debug = getenv("PERL_DL_DEBUG"); if (perl_dl_debug) dl_debug = atoi(perl_dl_debug); #endif } /* SaveError() takes printf style args and saves the result in LastError */ #ifdef STANDARD_C static void SaveError(char* pat, ...) #else /*VARARGS0*/ static void SaveError(pat, va_alist) char *pat; va_dcl #endif { va_list args; char *message; int len; /* This code is based on croak/warn but I'm not sure where mess() */ /* gets its buffer space from! */ #ifdef I_STDARG va_start(args, pat); #else va_start(args); #endif message = mess(pat, &args); va_end(args); len = strlen(message) + 1 ; /* include terminating null char */ /* Allocate some memory for the error message */ if (LastError) LastError = (char*)saferealloc(LastError, len) ; else LastError = safemalloc(len) ; /* Copy message into LastError (including terminating null char) */ strncpy(LastError, message, len) ; DLDEBUG(2,fprintf(stderr,"DynaLoader: stored error msg '%s'\n",LastError)); } /* prepend underscore to s. write into buf. return buf. */ char * dl_add_underscore(s, buf) char *s; char *buf; { *buf = '_'; (void)strcpy(buf + 1, s); return buf; } _require_symbols[0] = %.*s\n", symdsc.dsc$w_length, symdsc.dsc$a_pointer)); sts = lib$find_image_symbol(&(dlptr->name),&symdsc, perl5.000/ext/Fcntl/ 775 203 12 0 5650575663 7226 perl5.000/ext/Fcntl/Fcntl.pm 664 203 12 2376 5645374673 10731 package Fcntl; require Exporter; require AutoLoader; require DynaLoader; @ISA = (Exporter, AutoLoader, DynaLoader); # Items to export into callers namespace by default # (move infrequently used names to @EXPORT_OK below) @EXPORT = qw( F_DUPFD F_GETFD F_GETLK F_SETFD F_GETFL F_SETFL F_SETLK F_SETLKW FD_CLOEXEC F_RDLCK F_UNLCK F_WRLCK O_CREAT O_EXCL O_NOCTTY O_TRUNC O_APPEND O_NONBLOCK O_NDELAY O_RDONLY O_RDWR O_WRONLY ); # Other items we are prepared to export if requested @EXPORT_OK = qw( ); sub AUTOLOAD { if (@_ > 1) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } local($constname); ($constname = $AUTOLOAD) =~ s/.*:://; $val = constant($constname, @_ ? $_[0] : 0); if ($! != 0) { if ($! =~ /Invalid/) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } else { ($pack,$file,$line) = caller; die "Your vendor has not defined Fcntl macro $constname, used at $file line $line. "; } } eval "sub $AUTOLOAD { $val }"; goto &$AUTOLOAD; } bootstrap Fcntl; # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. package Fcntl; # return to package Fcntl so AutoSplit is happy 1; __END__ gs and saves the result in LastError */ #ifdef STANDARD_C static void SaveError(char* pat, ...) #else /*VARARGS0*/ static void SaveError(pat, va_alist) char *pat; va_dcl #endif { va_list args; char *message; int len; /* This code is perl5.000/ext/Fcntl/Fcntl.xs 664 203 12 6014 5645374674 10741 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include static int not_here(s) char *s; { croak("%s not implemented on this architecture", s); return -1; } static double constant(name, arg) char *name; int arg; { errno = 0; switch (*name) { case 'F': if (strnEQ(name, "F_", 2)) { if (strEQ(name, "F_DUPFD")) #ifdef F_DUPFD return F_DUPFD; #else goto not_there; #endif if (strEQ(name, "F_GETFD")) #ifdef F_GETFD return F_GETFD; #else goto not_there; #endif if (strEQ(name, "F_GETLK")) #ifdef F_GETLK return F_GETLK; #else goto not_there; #endif if (strEQ(name, "F_SETFD")) #ifdef F_SETFD return F_SETFD; #else goto not_there; #endif if (strEQ(name, "F_GETFL")) #ifdef F_GETFL return F_GETFL; #else goto not_there; #endif if (strEQ(name, "SETFL")) #ifdef SETFL return SETFL; #else goto not_there; #endif if (strEQ(name, "F_SETLK")) #ifdef F_SETLK return F_SETLK; #else goto not_there; #endif if (strEQ(name, "F_SETLKW")) #ifdef F_SETLKW return F_SETLKW; #else goto not_there; #endif if (strEQ(name, "F_RDLCK")) #ifdef F_RDLCK return F_RDLCK; #else goto not_there; #endif if (strEQ(name, "F_UNLCK")) #ifdef F_UNLCK return F_UNLCK; #else goto not_there; #endif if (strEQ(name, "F_WRLCK")) #ifdef F_WRLCK return F_WRLCK; #else goto not_there; #endif errno = EINVAL; return 0; } else if (strEQ(name, "FD_CLOEXEC")) #ifdef FD_CLOEXEC return FD_CLOEXEC; #else goto not_there; #endif break; case 'O': if (strnEQ(name, "O_", 2)) { if (strEQ(name, "O_CREAT")) #ifdef O_CREAT return O_CREAT; #else goto not_there; #endif if (strEQ(name, "O_EXCL")) #ifdef O_EXCL return O_EXCL; #else goto not_there; #endif if (strEQ(name, "O_NOCTTY")) #ifdef O_NOCTTY return O_NOCTTY; #else goto not_there; #endif if (strEQ(name, "O_TRUNC")) #ifdef O_TRUNC return O_TRUNC; #else goto not_there; #endif if (strEQ(name, "O_APPEND")) #ifdef O_APPEND return O_APPEND; #else goto not_there; #endif if (strEQ(name, "O_NONBLOCK")) #ifdef O_NONBLOCK return O_NONBLOCK; #else goto not_there; #endif if (strEQ(name, "O_NDELAY")) #ifdef O_NDELAY return O_NDELAY; #else goto not_there; #endif if (strEQ(name, "O_RDONLY")) #ifdef O_RDONLY return O_RDONLY; #else goto not_there; #endif if (strEQ(name, "O_RDWR")) #ifdef O_RDWR return O_RDWR; #else goto not_there; #endif if (strEQ(name, "O_WRONLY")) #ifdef O_WRONLY return O_WRONLY; #else goto not_there; #endif } else goto not_there; break; } errno = EINVAL; return 0; not_there: errno = ENOENT; return 0; } MODULE = Fcntl PACKAGE = Fcntl double constant(name,arg) char * name int arg slib.defspec)); DLDEBUG(2,fprintf(stderr,"\tlib$find_image_symbol returns %d\n",sts)); DLDEBUG(2,fprintf(stderr,"\tentry point is %d\n", (unsigned long int) entry)); if (!(sts & 1)) { dl_set_error(sts,0); ST(0) = &sv_undef; } else ST(0) = sv_2mortal(newSViv(entry)); 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_nperl5.000/ext/Fcntl/MANIFEST 664 203 12 47 5645374674 10410 Fcntl.pm Fcntl.xs MANIFEST Makefile.PL efile.SHXSUB.h" #include static int not_here(s) char *s; { croak("%s not implemented on this architecture", s); return -1; } static double constant(name, arg) char *name; int arg; { errno = 0; switch (*name) { case 'F': if (strnEQ(name, "F_", 2)) { if (strEQ(name, "F_DUPFD")) #ifdef F_DUPFD return F_DUPFD; #else goto not_there; #endif if (strEQ(name, "F_GETFD")) #ifdef F_GETFD return F_GETFD; #elseperl5.000/ext/Fcntl/Makefile.SH 664 203 12 12323 5650410572 11270 : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac 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 fi : Find absolute path name for TOP. This is needed when we cd to TOP : to run perl on autosplit. oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd case $CONFIG in '') . $TOP/config.sh ;; esac : Find out directory name. This is also the extension name. ext=`pwd | $sed -e 's@.*/@@'` : This extension might have its own typemap if test -f typemap; then exttypemap='typemap' else exttypemap='' fi : This extension might need additional libraries. potential_libs=" " . $TOP/ext/util/extliblist : This extension might need bootstrap support if test -f ${ext}_BS; then bootdep=${ext}_BS else bootdep='' fi case "$dlsrc" in dl_aix*) echo "#!" > $ext.exp echo "boot_$ext" >> $ext.exp ;; esac echo "Extracting ext/$ext/Makefile (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted : by putting a backslash in front. You may delete these comments. $spitshell >Makefile << !GROK!THIS! # # This Makefile is for the $ext extension to perl. # CC = $cc RANLIB = $ranlib TOP = $TOP ABSTOP = $ABSTOP LDFLAGS = $ldflags CLDFLAGS = $ldflags SMALL = $small LARGE = $large $split # To use an alternate make, set \$altmake in config.sh. MAKE = ${altmake-make} EXT = $ext # $ext might have its own typemap EXTTYPEMAP = $exttypemap # $ext might have its own bootstrap support BOOTDEP = $bootdep BOOTSTRAP = $ext.bs # The following are used to build and install shared libraries for # dynamic loading. LDDLFLAGS = $lddlflags CCDLFLAGS = $ccdlflags CCCDLFLAGS = $cccdlflags SO = $so DLEXT = $dlext # $ext might need to be linked with some extra libraries. # EXTRALIBS = full list of libraries needed for static linking. # Only those libraries that actually exist are included. # DYNLOADLIBS = list of those libraries that are needed but can be # linked in dynamically on this platform. On SunOS, for # example, this would be .so* libraries, but not archive # libraries. The bootstrap file is installed only if # this list is not empty. # STATLOADLIBS = list of those libraries which must be statically # linked into the shared library. On SunOS 4.1.3, # for example, I have only an archive version of # -lm, and it must be linked in statically. EXTRALIBS = $extralibs DYNALOADLIBS = $dynaloadlibs STATLOADLIBS = $statloadlibs !GROK!THIS! $spitshell >>Makefile <<'!NO!SUBS!' # Where to put things: AUTO = $(TOP)/lib/auto INSTALLBOOT = $(AUTO)/$(EXT)/$(EXT).bs INSTALLDYNAMIC = $(AUTO)/$(EXT)/$(EXT).$(DLEXT) INSTALLSTATIC = $(EXT).a INSTALLPM = $(TOP)/lib/$(EXT).pm PERL = $(ABSTOP)/miniperl XSUBPP = $(TOP)/ext/xsubpp SHELL = /bin/sh CCCMD = `sh $(shellflags) $(TOP)/cflags $@` .c.o: $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c all: dynamic # Phony target to force checking subdirectories. FORCE: config: # Target for Dynamic Loading: dynamic: $(INSTALLDYNAMIC) $(INSTALLPM) $(INSTALLBOOT) $(INSTALLDYNAMIC): $(EXT).o @test -d $(AUTO) || mkdir $(AUTO) @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) ld $(LDDLFLAGS) -o $@ $(EXT).o $(STATLOADLIBS) $(BOOTSTRAP): Makefile $(BOOTDEP) $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) touch $(BOOTSTRAP) $(INSTALLBOOT): $(BOOTSTRAP) @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ # Target for Static Loading: static: $(INSTALLSTATIC) $(INSTALLPM) $(INSTALLSTATIC): $(EXT).o ar cr $@ $(EXT).o $(RANLIB) $@ echo $(EXTRALIBS) >> $(TOP)/ext.libs $(EXT).c: $(EXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile $(PERL) $(XSUBPP) $(EXT).xs >tmp mv tmp $@ $(INSTALLPM): $(EXT).pm rm -f $@ cp $(EXT).pm $@ cd $(TOP); $(PERL) autosplit $(EXT) clean: rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp realclean: clean rm -f makefile Makefile rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) rm -rf $(AUTO)/$(EXT) purge: realclean $(EXT).o : $(TOP)/EXTERN.h $(EXT).o : $(TOP)/perl.h $(EXT).o : $(TOP)/embed.h $(EXT).o : $(TOP)/config.h $(EXT).o : $(TOP)/unixish.h $(EXT).o : $(TOP)/handy.h $(EXT).o : $(TOP)/regexp.h $(EXT).o : $(TOP)/sv.h $(EXT).o : $(TOP)/util.h $(EXT).o : $(TOP)/form.h $(EXT).o : $(TOP)/gv.h $(EXT).o : $(TOP)/cv.h $(EXT).o : $(TOP)/opcode.h $(EXT).o : $(TOP)/op.h $(EXT).o : $(TOP)/cop.h $(EXT).o : $(TOP)/av.h $(EXT).o : $(TOP)/hv.h $(EXT).o : $(TOP)/mg.h $(EXT).o : $(TOP)/scope.h $(EXT).o : $(TOP)/pp.h $(EXT).o : $(TOP)/proto.h $(EXT).o : $(TOP)/XSUB.h Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH $(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH $(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH $(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH !NO!SUBS! chmod 644 Makefile $eunicefix Makefile )symref, filename))); char * dl_error() CODE: RETVAL = LastError ; OUTPUT: RETVAL # end. return 0; } else { /* continuation line */ int errlen = strlen(LastError); LastError = saferealloc(LastError, errlen + msg->dsc$w_length + 1); LastError[errlen] perl5.000/ext/GDBM_File/ 775 203 12 0 5650575664 7631 perl5.000/ext/GDBM_File/GDBM_File.pm 664 203 12 1635 5633714612 11716 package GDBM_File; require Carp; require TieHash; require Exporter; require AutoLoader; require DynaLoader; @ISA = (TieHash, Exporter, AutoLoader, DynaLoader); @EXPORT = qw( GDBM_CACHESIZE GDBM_FAST GDBM_INSERT GDBM_NEWDB GDBM_READER GDBM_REPLACE GDBM_WRCREAT GDBM_WRITER ); sub AUTOLOAD { if (@_ > 1) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } local($constname); ($constname = $AUTOLOAD) =~ s/.*:://; $val = constant($constname, @_ ? $_[0] : 0); if ($! != 0) { if ($! =~ /Invalid/) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } else { Carp::croak("Your vendor has not defined GDBM_File macro $constname, used"); } } eval "sub $AUTOLOAD { $val }"; goto &$AUTOLOAD; } bootstrap GDBM_File; # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. 1; __END__ is platform. On SunOS, for # example, this would be .so* libraries, but not archive # libraries.perl5.000/ext/GDBM_File/GDBM_File.xs 664 203 12 6646 5645374675 11761 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include #include typedef GDBM_FILE GDBM_File; #define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */ #define gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func) \ gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func) #define gdbm_FETCH(db,key) gdbm_fetch(db,key) #define gdbm_STORE(db,key,value,flags) gdbm_store(db,key,value,flags) #define gdbm_DELETE(db,key) gdbm_delete(db,key) #define gdbm_FIRSTKEY(db) gdbm_firstkey(db) #define gdbm_NEXTKEY(db,key) gdbm_nextkey(db,key) typedef datum gdatum; typedef void (*FATALFUNC)(); static int not_here(s) char *s; { croak("GDBM_File::%s not implemented on this architecture", s); return -1; } static double constant(name, arg) char *name; int arg; { errno = 0; switch (*name) { case 'A': break; case 'B': break; case 'C': break; case 'D': break; case 'E': break; case 'F': break; case 'G': if (strEQ(name, "GDBM_CACHESIZE")) #ifdef GDBM_CACHESIZE return GDBM_CACHESIZE; #else goto not_there; #endif if (strEQ(name, "GDBM_FAST")) #ifdef GDBM_FAST return GDBM_FAST; #else goto not_there; #endif if (strEQ(name, "GDBM_FASTMODE")) #ifdef GDBM_FASTMODE return GDBM_FASTMODE; #else goto not_there; #endif if (strEQ(name, "GDBM_INSERT")) #ifdef GDBM_INSERT return GDBM_INSERT; #else goto not_there; #endif if (strEQ(name, "GDBM_NEWDB")) #ifdef GDBM_NEWDB return GDBM_NEWDB; #else goto not_there; #endif if (strEQ(name, "GDBM_READER")) #ifdef GDBM_READER return GDBM_READER; #else goto not_there; #endif if (strEQ(name, "GDBM_REPLACE")) #ifdef GDBM_REPLACE return GDBM_REPLACE; #else goto not_there; #endif if (strEQ(name, "GDBM_WRCREAT")) #ifdef GDBM_WRCREAT return GDBM_WRCREAT; #else goto not_there; #endif if (strEQ(name, "GDBM_WRITER")) #ifdef GDBM_WRITER return GDBM_WRITER; #else goto not_there; #endif break; case 'H': break; case 'I': break; case 'J': break; case 'K': break; case 'L': break; case 'M': break; case 'N': break; case 'O': break; case 'P': break; case 'Q': break; case 'R': break; case 'S': break; case 'T': break; case 'U': break; case 'V': break; case 'W': break; case 'X': break; case 'Y': break; case 'Z': break; } errno = EINVAL; return 0; not_there: errno = ENOENT; return 0; } MODULE = GDBM_File PACKAGE = GDBM_File PREFIX = gdbm_ double constant(name,arg) char * name int arg GDBM_File gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak) char * dbtype char * name int read_write int mode FATALFUNC fatal_func void gdbm_close(db) GDBM_File db CLEANUP: void gdbm_DESTROY(db) GDBM_File db CODE: gdbm_close(db); gdatum gdbm_FETCH(db, key) GDBM_File db datum key int gdbm_STORE(db, key, value, flags = GDBM_REPLACE) GDBM_File db datum key datum value int flags CLEANUP: if (RETVAL) { if (RETVAL < 0 && errno == EPERM) croak("No write permission to gdbm file"); warn("gdbm store returned %d, errno %d, key \"%.*s\"", RETVAL,errno,key.dsize,key.dptr); /* gdbm_clearerr(db); */ } int gdbm_DELETE(db, key) GDBM_File db datum key gdatum gdbm_FIRSTKEY(db) GDBM_File db gdatum gdbm_NEXTKEY(db, key) GDBM_File db datum key int gdbm_reorganize(db) GDBM_File db (INSTALLDYNAMIC): $(EXT).o @test -d $(AUTO) || mkdir $(AUTO) @test -d $(AUTO)/$(EXT) || perl5.000/ext/GDBM_File/Makefile.SH 664 203 12 12572 5650410573 11701 : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac 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 fi : Find absolute path name for TOP. This is needed when we cd to TOP : to run perl on autosplit. oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd case $CONFIG in '') . $TOP/config.sh ;; esac : Find out directory name. This is also the extension name. ext=`pwd | $sed -e 's@.*/@@'` : This extension might have its own typemap if test -f typemap; then exttypemap='typemap' else exttypemap='' fi : This extension might need additional libraries. potential_libs="-lgdbm" . $TOP/ext/util/extliblist case "${extralibs}${dynaloadlibs}${statloadlibs}" in '') : Try again. Maybe they have -ldbm instead potential_libs='-ldbm' . $TOP/ext/util/extliblist ;; esac : This extension might need bootstrap support if test -f ${ext}_BS; then bootdep=${ext}_BS else bootdep='' fi case "$dlsrc" in dl_aix*) echo "#!" > $ext.exp echo "boot_$ext" >> $ext.exp ;; esac echo "Extracting ext/$ext/Makefile (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted : by putting a backslash in front. You may delete these comments. $spitshell >Makefile << !GROK!THIS! # # This Makefile is for the $ext extension to perl. # CC = $cc RANLIB = $ranlib TOP = $TOP ABSTOP = $ABSTOP LDFLAGS = $ldflags CLDFLAGS = $ldflags SMALL = $small LARGE = $large $split # To use an alternate make, set \$altmake in config.sh. MAKE = ${altmake-make} EXT = $ext # $ext might have its own typemap EXTTYPEMAP = $exttypemap # $ext might have its own bootstrap support BOOTDEP = $bootdep BOOTSTRAP = $ext.bs # The following are used to build and install shared libraries for # dynamic loading. LDDLFLAGS = $lddlflags CCDLFLAGS = $ccdlflags CCCDLFLAGS = $cccdlflags SO = $so DLEXT = $dlext # $ext might need to be linked with some extra libraries. # EXTRALIBS = full list of libraries needed for static linking. # Only those libraries that actually exist are included. # DYNLOADLIBS = list of those libraries that are needed but can be # linked in dynamically on this platform. On SunOS, for # example, this would be .so* libraries, but not archive # libraries. The bootstrap file is installed only if # this list is not empty. # STATLOADLIBS = list of those libraries which must be statically # linked into the shared library. On SunOS 4.1.3, # for example, I have only an archive version of # -lm, and it must be linked in statically. EXTRALIBS = $extralibs DYNALOADLIBS = $dynaloadlibs STATLOADLIBS = $statloadlibs !GROK!THIS! $spitshell >>Makefile <<'!NO!SUBS!' # Where to put things: AUTO = $(TOP)/lib/auto INSTALLBOOT = $(AUTO)/$(EXT)/$(EXT).bs INSTALLDYNAMIC = $(AUTO)/$(EXT)/$(EXT).$(DLEXT) INSTALLSTATIC = $(EXT).a INSTALLPM = $(TOP)/lib/$(EXT).pm PERL = $(ABSTOP)/miniperl XSUBPP = $(TOP)/ext/xsubpp SHELL = /bin/sh CCCMD = `sh $(shellflags) $(TOP)/cflags $@` .c.o: $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c all: dynamic # Phony target to force checking subdirectories. FORCE: config: # Target for Dynamic Loading: dynamic: $(INSTALLDYNAMIC) $(INSTALLPM) $(INSTALLBOOT) $(INSTALLDYNAMIC): $(EXT).o @test -d $(AUTO) || mkdir $(AUTO) @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) ld $(LDDLFLAGS) -o $@ $(EXT).o $(STATLOADLIBS) $(BOOTSTRAP): Makefile $(BOOTDEP) $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) touch $(BOOTSTRAP) $(INSTALLBOOT): $(BOOTSTRAP) @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ # Target for Static Loading: static: $(INSTALLSTATIC) $(INSTALLPM) $(INSTALLSTATIC): $(EXT).o ar cr $@ $(EXT).o $(RANLIB) $@ echo $(EXTRALIBS) >> $(TOP)/ext.libs $(EXT).c: $(EXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile $(PERL) $(XSUBPP) $(EXT).xs >tmp mv tmp $@ $(INSTALLPM): $(EXT).pm rm -f $@ cp $(EXT).pm $@ cd $(TOP); $(PERL) autosplit $(EXT) clean: rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp realclean: clean rm -f makefile Makefile rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) rm -rf $(AUTO)/$(EXT) purge: realclean $(EXT).o : $(TOP)/EXTERN.h $(EXT).o : $(TOP)/perl.h $(EXT).o : $(TOP)/embed.h $(EXT).o : $(TOP)/config.h $(EXT).o : $(TOP)/unixish.h $(EXT).o : $(TOP)/handy.h $(EXT).o : $(TOP)/regexp.h $(EXT).o : $(TOP)/sv.h $(EXT).o : $(TOP)/util.h $(EXT).o : $(TOP)/form.h $(EXT).o : $(TOP)/gv.h $(EXT).o : $(TOP)/cv.h $(EXT).o : $(TOP)/opcode.h $(EXT).o : $(TOP)/op.h $(EXT).o : $(TOP)/cop.h $(EXT).o : $(TOP)/av.h $(EXT).o : $(TOP)/hv.h $(EXT).o : $(TOP)/mg.h $(EXT).o : $(TOP)/scope.h $(EXT).o : $(TOP)/pp.h $(EXT).o : $(TOP)/proto.h $(EXT).o : $(TOP)/XSUB.h Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH $(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH $(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH $(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH !NO!SUBS! chmod 644 Makefile $eunicefix Makefile parse = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &sv_undef; } elsperl5.000/ext/GDBM_File/typemap 664 203 12 652 5576407565 11304 # #################################### DBM SECTION # datum T_DATUM gdatum T_GDATUM NDBM_File T_PTROBJ GDBM_File T_PTROBJ SDBM_File T_PTROBJ ODBM_File T_PTROBJ DB_File T_PTROBJ DBZ_File T_PTROBJ FATALFUNC T_OPAQUEPTR INPUT T_DATUM $var.dptr = SvPV($arg, na); $var.dsize = (int)na; T_GDATUM UNIMPLEMENTED OUTPUT T_DATUM sv_setpvn($arg, $var.dptr, $var.dsize); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); ; else echo "Can't find config.sh."; exit 1 fi : Find absolute path name for TOP. Tperl5.000/ext/NDBM_File/ 775 203 12 0 5650575664 7640 perl5.000/ext/NDBM_File/Makefile.SH 664 203 12 12572 5650410573 11710 : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac 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 fi : Find absolute path name for TOP. This is needed when we cd to TOP : to run perl on autosplit. oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd case $CONFIG in '') . $TOP/config.sh ;; esac : Find out directory name. This is also the extension name. ext=`pwd | $sed -e 's@.*/@@'` : This extension might have its own typemap if test -f typemap; then exttypemap='typemap' else exttypemap='' fi : This extension might need additional libraries. potential_libs="-lndbm" . $TOP/ext/util/extliblist case "${extralibs}${dynaloadlibs}${statloadlibs}" in '') : Try again. Maybe they have -ldbm instead potential_libs='-ldbm' . $TOP/ext/util/extliblist ;; esac : This extension might need bootstrap support if test -f ${ext}_BS; then bootdep=${ext}_BS else bootdep='' fi case "$dlsrc" in dl_aix*) echo "#!" > $ext.exp echo "boot_$ext" >> $ext.exp ;; esac echo "Extracting ext/$ext/Makefile (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted : by putting a backslash in front. You may delete these comments. $spitshell >Makefile << !GROK!THIS! # # This Makefile is for the $ext extension to perl. # CC = $cc RANLIB = $ranlib TOP = $TOP ABSTOP = $ABSTOP LDFLAGS = $ldflags CLDFLAGS = $ldflags SMALL = $small LARGE = $large $split # To use an alternate make, set \$altmake in config.sh. MAKE = ${altmake-make} EXT = $ext # $ext might have its own typemap EXTTYPEMAP = $exttypemap # $ext might have its own bootstrap support BOOTDEP = $bootdep BOOTSTRAP = $ext.bs # The following are used to build and install shared libraries for # dynamic loading. LDDLFLAGS = $lddlflags CCDLFLAGS = $ccdlflags CCCDLFLAGS = $cccdlflags SO = $so DLEXT = $dlext # $ext might need to be linked with some extra libraries. # EXTRALIBS = full list of libraries needed for static linking. # Only those libraries that actually exist are included. # DYNLOADLIBS = list of those libraries that are needed but can be # linked in dynamically on this platform. On SunOS, for # example, this would be .so* libraries, but not archive # libraries. The bootstrap file is installed only if # this list is not empty. # STATLOADLIBS = list of those libraries which must be statically # linked into the shared library. On SunOS 4.1.3, # for example, I have only an archive version of # -lm, and it must be linked in statically. EXTRALIBS = $extralibs DYNALOADLIBS = $dynaloadlibs STATLOADLIBS = $statloadlibs !GROK!THIS! $spitshell >>Makefile <<'!NO!SUBS!' # Where to put things: AUTO = $(TOP)/lib/auto INSTALLBOOT = $(AUTO)/$(EXT)/$(EXT).bs INSTALLDYNAMIC = $(AUTO)/$(EXT)/$(EXT).$(DLEXT) INSTALLSTATIC = $(EXT).a INSTALLPM = $(TOP)/lib/$(EXT).pm PERL = $(ABSTOP)/miniperl XSUBPP = $(TOP)/ext/xsubpp SHELL = /bin/sh CCCMD = `sh $(shellflags) $(TOP)/cflags $@` .c.o: $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c all: dynamic # Phony target to force checking subdirectories. FORCE: config: # Target for Dynamic Loading: dynamic: $(INSTALLDYNAMIC) $(INSTALLPM) $(INSTALLBOOT) $(INSTALLDYNAMIC): $(EXT).o @test -d $(AUTO) || mkdir $(AUTO) @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) ld $(LDDLFLAGS) -o $@ $(EXT).o $(STATLOADLIBS) $(BOOTSTRAP): Makefile $(BOOTDEP) $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) touch $(BOOTSTRAP) $(INSTALLBOOT): $(BOOTSTRAP) @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ # Target for Static Loading: static: $(INSTALLSTATIC) $(INSTALLPM) $(INSTALLSTATIC): $(EXT).o ar cr $@ $(EXT).o $(RANLIB) $@ echo $(EXTRALIBS) >> $(TOP)/ext.libs $(EXT).c: $(EXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile $(PERL) $(XSUBPP) $(EXT).xs >tmp mv tmp $@ $(INSTALLPM): $(EXT).pm rm -f $@ cp $(EXT).pm $@ cd $(TOP); $(PERL) autosplit $(EXT) clean: rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp realclean: clean rm -f makefile Makefile rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) rm -rf $(AUTO)/$(EXT) purge: realclean $(EXT).o : $(TOP)/EXTERN.h $(EXT).o : $(TOP)/perl.h $(EXT).o : $(TOP)/embed.h $(EXT).o : $(TOP)/config.h $(EXT).o : $(TOP)/unixish.h $(EXT).o : $(TOP)/handy.h $(EXT).o : $(TOP)/regexp.h $(EXT).o : $(TOP)/sv.h $(EXT).o : $(TOP)/util.h $(EXT).o : $(TOP)/form.h $(EXT).o : $(TOP)/gv.h $(EXT).o : $(TOP)/cv.h $(EXT).o : $(TOP)/opcode.h $(EXT).o : $(TOP)/op.h $(EXT).o : $(TOP)/cop.h $(EXT).o : $(TOP)/av.h $(EXT).o : $(TOP)/hv.h $(EXT).o : $(TOP)/mg.h $(EXT).o : $(TOP)/scope.h $(EXT).o : $(TOP)/pp.h $(EXT).o : $(TOP)/proto.h $(EXT).o : $(TOP)/XSUB.h Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH $(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH $(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH $(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH !NO!SUBS! chmod 644 Makefile $eunicefix Makefile parse = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &sv_undef; } elsperl5.000/ext/NDBM_File/NDBM_File.pm 664 203 12 173 5626177710 11714 package NDBM_File; require TieHash; require DynaLoader; @ISA = qw(TieHash DynaLoader); bootstrap NDBM_File; 1; __END__ ind SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac 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 fi : Find absolute path name for TOP. Tperl5.000/ext/NDBM_File/NDBM_File.xs 664 203 12 2337 5630707567 11762 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include typedef DBM* NDBM_File; #define dbm_TIEHASH(dbtype,filename,flags,mode) dbm_open(filename,flags,mode) #define dbm_FETCH(db,key) dbm_fetch(db,key) #define dbm_STORE(db,key,value,flags) dbm_store(db,key,value,flags) #define dbm_DELETE(db,key) dbm_delete(db,key) #define dbm_FIRSTKEY(db) dbm_firstkey(db) #define dbm_NEXTKEY(db,key) dbm_nextkey(db) MODULE = NDBM_File PACKAGE = NDBM_File PREFIX = dbm_ NDBM_File dbm_TIEHASH(dbtype, filename, flags, mode) char * dbtype char * filename int flags int mode void dbm_DESTROY(db) NDBM_File db CODE: dbm_close(db); datum dbm_FETCH(db, key) NDBM_File db datum key int dbm_STORE(db, key, value, flags = DBM_REPLACE) NDBM_File db datum key datum value int flags CLEANUP: if (RETVAL) { if (RETVAL < 0 && errno == EPERM) croak("No write permission to ndbm file"); warn("ndbm store returned %d, errno %d, key \"%s\"", RETVAL,errno,key.dptr); dbm_clearerr(db); } int dbm_DELETE(db, key) NDBM_File db datum key datum dbm_FIRSTKEY(db) NDBM_File db datum dbm_NEXTKEY(db, key) NDBM_File db datum key int dbm_error(db) NDBM_File db void dbm_clearerr(db) NDBM_File db ' fi case "$dlsrc" in dl_aix*) echo "#!" > $ext.exp echo "boot_$ext" >> $ext.exp ;; esac echo "Extracting ext/$ext/Makefile (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!perl5.000/ext/NDBM_File/typemap 664 203 12 652 5576407566 11314 # #################################### DBM SECTION # datum T_DATUM gdatum T_GDATUM NDBM_File T_PTROBJ GDBM_File T_PTROBJ SDBM_File T_PTROBJ ODBM_File T_PTROBJ DB_File T_PTROBJ DBZ_File T_PTROBJ FATALFUNC T_OPAQUEPTR INPUT T_DATUM $var.dptr = SvPV($arg, na); $var.dsize = (int)na; T_GDATUM UNIMPLEMENTED OUTPUT T_DATUM sv_setpvn($arg, $var.dptr, $var.dsize); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); db) MODULE = NDBM_File PACKAGE = NDBM_File PREFIX = dbm_ NDBM_File dbm_TIEHASH(dbtypperl5.000/ext/ODBM_File/ 775 203 12 0 5650575665 7642 perl5.000/ext/ODBM_File/Makefile.SH 664 203 12 12644 5650410573 11711 : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac 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 fi : Find absolute path name for TOP. This is needed when we cd to TOP : to run perl on autosplit. oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd case $CONFIG in '') . $TOP/config.sh ;; esac : Find out directory name. This is also the extension name. ext=`pwd | $sed -e 's@.*/@@'` : This extension might have its own typemap if test -f typemap; then exttypemap='typemap' else exttypemap='' fi : This extension might need additional libraries. : dbm.nfs is an SCO library. potential_libs="-ldbm.nfs" . $TOP/ext/util/extliblist case "${extralibs}${dynaloadlibs}${statloadlibs}" in '') : Try again. Most systems have -ldbm instead potential_libs='-ldbm' . $TOP/ext/util/extliblist ;; esac : This extension might need bootstrap support if test -f ${ext}_BS; then bootdep=${ext}_BS else bootdep='' fi case "$dlsrc" in dl_aix*) echo "#!" > $ext.exp echo "boot_$ext" >> $ext.exp ;; esac echo "Extracting ext/$ext/Makefile (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted : by putting a backslash in front. You may delete these comments. $spitshell >Makefile << !GROK!THIS! # # This Makefile is for the $ext extension to perl. # CC = $cc RANLIB = $ranlib TOP = $TOP ABSTOP = $ABSTOP LDFLAGS = $ldflags CLDFLAGS = $ldflags SMALL = $small LARGE = $large $split # To use an alternate make, set \$altmake in config.sh. MAKE = ${altmake-make} EXT = $ext # $ext might have its own typemap EXTTYPEMAP = $exttypemap # $ext might have its own bootstrap support BOOTDEP = $bootdep BOOTSTRAP = $ext.bs # The following are used to build and install shared libraries for # dynamic loading. LDDLFLAGS = $lddlflags CCDLFLAGS = $ccdlflags CCCDLFLAGS = $cccdlflags SO = $so DLEXT = $dlext # $ext might need to be linked with some extra libraries. # EXTRALIBS = full list of libraries needed for static linking. # Only those libraries that actually exist are included. # DYNLOADLIBS = list of those libraries that are needed but can be # linked in dynamically on this platform. On SunOS, for # example, this would be .so* libraries, but not archive # libraries. The bootstrap file is installed only if # this list is not empty. # STATLOADLIBS = list of those libraries which must be statically # linked into the shared library. On SunOS 4.1.3, # for example, I have only an archive version of # -lm, and it must be linked in statically. EXTRALIBS = $extralibs DYNALOADLIBS = $dynaloadlibs STATLOADLIBS = $statloadlibs !GROK!THIS! $spitshell >>Makefile <<'!NO!SUBS!' # Where to put things: AUTO = $(TOP)/lib/auto INSTALLBOOT = $(AUTO)/$(EXT)/$(EXT).bs INSTALLDYNAMIC = $(AUTO)/$(EXT)/$(EXT).$(DLEXT) INSTALLSTATIC = $(EXT).a INSTALLPM = $(TOP)/lib/$(EXT).pm PERL = $(ABSTOP)/miniperl XSUBPP = $(TOP)/ext/xsubpp SHELL = /bin/sh CCCMD = `sh $(shellflags) $(TOP)/cflags $@` .c.o: $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c all: dynamic # Phony target to force checking subdirectories. FORCE: config: # Target for Dynamic Loading: dynamic: $(INSTALLDYNAMIC) $(INSTALLPM) $(INSTALLBOOT) $(INSTALLDYNAMIC): $(EXT).o @test -d $(AUTO) || mkdir $(AUTO) @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) ld $(LDDLFLAGS) -o $@ $(EXT).o $(STATLOADLIBS) $(BOOTSTRAP): Makefile $(BOOTDEP) $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) touch $(BOOTSTRAP) $(INSTALLBOOT): $(BOOTSTRAP) @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ # Target for Static Loading: static: $(INSTALLSTATIC) $(INSTALLPM) $(INSTALLSTATIC): $(EXT).o ar cr $@ $(EXT).o $(RANLIB) $@ echo $(EXTRALIBS) >> $(TOP)/ext.libs $(EXT).c: $(EXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile $(PERL) $(XSUBPP) $(EXT).xs >tmp mv tmp $@ $(INSTALLPM): $(EXT).pm rm -f $@ cp $(EXT).pm $@ cd $(TOP); $(PERL) autosplit $(EXT) clean: rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp realclean: clean rm -f makefile Makefile rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) rm -rf $(AUTO)/$(EXT) purge: realclean $(EXT).o : $(TOP)/EXTERN.h $(EXT).o : $(TOP)/perl.h $(EXT).o : $(TOP)/embed.h $(EXT).o : $(TOP)/config.h $(EXT).o : $(TOP)/unixish.h $(EXT).o : $(TOP)/handy.h $(EXT).o : $(TOP)/regexp.h $(EXT).o : $(TOP)/sv.h $(EXT).o : $(TOP)/util.h $(EXT).o : $(TOP)/form.h $(EXT).o : $(TOP)/gv.h $(EXT).o : $(TOP)/cv.h $(EXT).o : $(TOP)/opcode.h $(EXT).o : $(TOP)/op.h $(EXT).o : $(TOP)/cop.h $(EXT).o : $(TOP)/av.h $(EXT).o : $(TOP)/hv.h $(EXT).o : $(TOP)/mg.h $(EXT).o : $(TOP)/scope.h $(EXT).o : $(TOP)/pp.h $(EXT).o : $(TOP)/proto.h $(EXT).o : $(TOP)/XSUB.h Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH $(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH $(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH $(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH !NO!SUBS! chmod 644 Makefile $eunicefix Makefile = $large $split # To use an alternate make, set \$altmake in config.sh. MAKE = ${altmake-maperl5.000/ext/ODBM_File/ODBM_File.pm 664 203 12 173 5626212243 11705 package ODBM_File; require TieHash; require DynaLoader; @ISA = qw(TieHash DynaLoader); bootstrap ODBM_File; 1; __END__ STALLDYNAMIC): $(EXT).o @test -d $(AUTO) || mkdir $(AUTO) @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) ld $(LDDLFLAGS) -o $@ $(EXT).o $(STATLOADLIBS) $(BOOTSTRAP): Makefile $(BOOTDEP) $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) touch $(BOOTSTRAP) $(INSTALLBOOT): $(BOOTSTRAP) @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ # Target for Static Loading: statiperl5.000/ext/ODBM_File/ODBM_File.xs 664 203 12 3471 5630707433 11754 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef NULL #undef NULL #endif #include #include typedef void* ODBM_File; #define odbm_FETCH(db,key) fetch(key) #define odbm_STORE(db,key,value,flags) store(key,value) #define odbm_DELETE(db,key) delete(key) #define odbm_FIRSTKEY(db) firstkey() #define odbm_NEXTKEY(db,key) nextkey(key) static int dbmrefcnt; #ifndef DBM_REPLACE #define DBM_REPLACE 0 #endif MODULE = ODBM_File PACKAGE = ODBM_File PREFIX = odbm_ ODBM_File odbm_TIEHASH(dbtype, filename, flags, mode) char * dbtype char * filename int flags int mode CODE: { char tmpbuf[1025]; if (dbmrefcnt++) croak("Old dbm can only open one database"); sprintf(tmpbuf,"%s.dir",filename); if (stat(tmpbuf, &statbuf) < 0) { if (flags & O_CREAT) { if (mode < 0 || close(creat(tmpbuf,mode)) < 0) croak("ODBM_File: Can't create %s", filename); sprintf(tmpbuf,"%s.pag",filename); if (close(creat(tmpbuf,mode)) < 0) croak("ODBM_File: Can't create %s", filename); } else croak("ODBM_FILE: Can't open %s", filename); } RETVAL = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0); ST(0) = sv_mortalcopy(&sv_undef); sv_setptrobj(ST(0), RETVAL, "ODBM_File"); } void DESTROY(db) ODBM_File db CODE: dbmrefcnt--; dbmclose(); datum odbm_FETCH(db, key) ODBM_File db datum key int odbm_STORE(db, key, value, flags = DBM_REPLACE) ODBM_File db datum key datum value int flags CLEANUP: if (RETVAL) { if (RETVAL < 0 && errno == EPERM) croak("No write permission to odbm file"); warn("odbm store returned %d, errno %d, key \"%s\"", RETVAL,errno,key.dptr); } int odbm_DELETE(db, key) ODBM_File db datum key datum odbm_FIRSTKEY(db) ODBM_File db datum odbm_NEXTKEY(db, key) ODBM_File db datum key )/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH !NO!SUBS! chmod 644 Makefile $eunicefix Makefile = $large $split # To use an alternate make, set \$altmake in config.sh. MAKE = ${altmake-maperl5.000/ext/ODBM_File/typemap 664 203 12 652 5576407567 11316 # #################################### DBM SECTION # datum T_DATUM gdatum T_GDATUM NDBM_File T_PTROBJ GDBM_File T_PTROBJ SDBM_File T_PTROBJ ODBM_File T_PTROBJ DB_File T_PTROBJ DBZ_File T_PTROBJ FATALFUNC T_OPAQUEPTR INPUT T_DATUM $var.dptr = SvPV($arg, na); $var.dsize = (int)na; T_GDATUM UNIMPLEMENTED OUTPUT T_DATUM sv_setpvn($arg, $var.dptr, $var.dsize); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); DBM_REPLACE 0 #endif MODULE = ODBM_File PACKAGE = ODBM_File PREFIX = odbm_ ODBM_Fileperl5.000/ext/POSIX/ 775 203 12 0 5650575666 7065 perl5.000/ext/POSIX/Makefile.SH 664 203 12 12347 5650410573 11133 : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac 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 fi : Find absolute path name for TOP. This is needed when we cd to TOP : to run perl on autosplit. oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd case $CONFIG in '') . $TOP/config.sh ;; esac : Find out directory name. This is also the extension name. ext=`pwd | $sed -e 's@.*/@@'` : This extension might have its own typemap if test -f typemap; then exttypemap='typemap' else exttypemap='' fi : This extension might need additional libraries. potential_libs="-lm -lposix -lcposix " . $TOP/ext/util/extliblist : This extension might need bootstrap support if test -f ${ext}_BS; then bootdep=${ext}_BS else bootdep='' fi case "$dlsrc" in dl_aix*) echo "#!" > $ext.exp echo "boot_$ext" >> $ext.exp ;; esac echo "Extracting ext/$ext/Makefile (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted : by putting a backslash in front. You may delete these comments. $spitshell >Makefile << !GROK!THIS! # # This Makefile is for the $ext extension to perl. # CC = $cc RANLIB = $ranlib TOP = $TOP ABSTOP = $ABSTOP LDFLAGS = $ldflags CLDFLAGS = $ldflags SMALL = $small LARGE = $large $split # To use an alternate make, set \$altmake in config.sh. MAKE = ${altmake-make} EXT = $ext # $ext might have its own typemap EXTTYPEMAP = $exttypemap # $ext might have its own bootstrap support BOOTDEP = $bootdep BOOTSTRAP = $ext.bs # The following are used to build and install shared libraries for # dynamic loading. LDDLFLAGS = $lddlflags CCDLFLAGS = $ccdlflags CCCDLFLAGS = $cccdlflags SO = $so DLEXT = $dlext # $ext might need to be linked with some extra libraries. # EXTRALIBS = full list of libraries needed for static linking. # Only those libraries that actually exist are included. # DYNLOADLIBS = list of those libraries that are needed but can be # linked in dynamically on this platform. On SunOS, for # example, this would be .so* libraries, but not archive # libraries. The bootstrap file is installed only if # this list is not empty. # STATLOADLIBS = list of those libraries which must be statically # linked into the shared library. On SunOS 4.1.3, # for example, I have only an archive version of # -lm, and it must be linked in statically. EXTRALIBS = $extralibs DYNALOADLIBS = $dynaloadlibs STATLOADLIBS = $statloadlibs !GROK!THIS! $spitshell >>Makefile <<'!NO!SUBS!' # Where to put things: AUTO = $(TOP)/lib/auto INSTALLBOOT = $(AUTO)/$(EXT)/$(EXT).bs INSTALLDYNAMIC = $(AUTO)/$(EXT)/$(EXT).$(DLEXT) INSTALLSTATIC = $(EXT).a INSTALLPM = $(TOP)/lib/$(EXT).pm PERL = $(ABSTOP)/miniperl XSUBPP = $(TOP)/ext/xsubpp SHELL = /bin/sh CCCMD = `sh $(shellflags) $(TOP)/cflags $@` .c.o: $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c all: dynamic # Phony target to force checking subdirectories. FORCE: config: # Target for Dynamic Loading: dynamic: $(INSTALLDYNAMIC) $(INSTALLPM) $(INSTALLBOOT) $(INSTALLDYNAMIC): $(EXT).o @test -d $(AUTO) || mkdir $(AUTO) @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) ld $(LDDLFLAGS) -o $@ $(EXT).o $(STATLOADLIBS) $(BOOTSTRAP): Makefile $(BOOTDEP) $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) touch $(BOOTSTRAP) $(INSTALLBOOT): $(BOOTSTRAP) @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ # Target for Static Loading: static: $(INSTALLSTATIC) $(INSTALLPM) $(INSTALLSTATIC): $(EXT).o ar cr $@ $(EXT).o $(RANLIB) $@ echo $(EXTRALIBS) >> $(TOP)/ext.libs $(EXT).c: $(EXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile $(PERL) $(XSUBPP) $(EXT).xs >tmp mv tmp $@ $(INSTALLPM): $(EXT).pm rm -f $@ cp $(EXT).pm $@ cd $(TOP); $(PERL) autosplit $(EXT) clean: rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp realclean: clean rm -f makefile Makefile rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) rm -rf $(AUTO)/$(EXT) purge: realclean $(EXT).o : $(TOP)/EXTERN.h $(EXT).o : $(TOP)/perl.h $(EXT).o : $(TOP)/embed.h $(EXT).o : $(TOP)/config.h $(EXT).o : $(TOP)/unixish.h $(EXT).o : $(TOP)/handy.h $(EXT).o : $(TOP)/regexp.h $(EXT).o : $(TOP)/sv.h $(EXT).o : $(TOP)/util.h $(EXT).o : $(TOP)/form.h $(EXT).o : $(TOP)/gv.h $(EXT).o : $(TOP)/cv.h $(EXT).o : $(TOP)/opcode.h $(EXT).o : $(TOP)/op.h $(EXT).o : $(TOP)/cop.h $(EXT).o : $(TOP)/av.h $(EXT).o : $(TOP)/hv.h $(EXT).o : $(TOP)/mg.h $(EXT).o : $(TOP)/scope.h $(EXT).o : $(TOP)/pp.h $(EXT).o : $(TOP)/proto.h $(EXT).o : $(TOP)/XSUB.h Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH $(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH $(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH $(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH !NO!SUBS! chmod 644 Makefile $eunicefix Makefile : $(TOP)/sv.h $(EXT).o : $(TOP)/util.h $(EXT).o : $(TOP)/form.h $(EXT).o : $(TOP)/gv.h $(EXT).o : $(TOP)/cv.h $(EXT).o : $(TOP)/opcode.h $(EXT).o : $(TOP)/op.h $(EXT).o : $(TOP)/cop.h $(EXT).o : $(TOP)/av.h $(EXT).o : $(TOP)/hv.h $(EXT).o : $(TOP)/mg.h $(EXT).o : $(TOP)/scope.h $(perl5.000/ext/POSIX/POSIX.pm 664 203 12 47034 5646274222 10427 package POSIX; use Carp; require Exporter; require AutoLoader; require DynaLoader; require Config; @ISA = (Exporter, AutoLoader, DynaLoader); $H{assert_h} = [qw(assert NDEBUG)]; $H{ctype_h} = [qw(isalnum isalpha iscntrl isdigit isgraph islower isprint ispunct isspace isupper isxdigit tolower toupper)]; $H{dirent_h} = [qw()]; $H{errno_h} = [qw(E2BIG EACCES EAGAIN EBADF EBUSY ECHILD EDEADLK EDOM EEXIST EFAULT EFBIG EINTR EINVAL EIO EISDIR EMFILE EMLINK ENAMETOOLONG ENFILE ENODEV ENOENT ENOEXEC ENOLCK ENOMEM ENOSPC ENOSYS ENOTDIR ENOTEMPTY ENOTTY ENXIO EPERM EPIPE ERANGE EROFS ESPIPE ESRCH EXDEV errno)]; $H{fcntl_h} = [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC O_WRONLY creat SEEK_CUR SEEK_END SEEK_SET S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID S_IWGRP S_IWOTH S_IWUSR)]; $H{float_h} = [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP FLT_DIG FLT_EPSILON FLT_MANT_DIG FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP FLT_RADIX FLT_ROUNDS LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)]; $H{grp_h} = [qw()]; $H{limits_h} = [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX _POSIX_STREADM_MAX _POSIX_TZNAME_MAX)]; $H{locale_h} = [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC LC_TIME NULL localeconv setlocale)]; $H{math_h} = [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod frexp ldexp log10 modf pow sinh tanh)]; $H{pwd_h} = [qw()]; $H{setjmp_h} = [qw(longjmp setjmp siglongjmp sigsetjmp)]; $H{signal_h} = [qw(SA_NOCLDSTOP SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK raise sigaction signal sigpending sigprocmask sigsuspend)]; $H{stdarg_h} = [qw()]; $H{stddef_h} = [qw(NULL offsetof)]; $H{stdio_h} = [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET STREAM_MAX TMP_MAX stderr stdin stdout _IOFBF _IOLBF _IONBF clearerr fclose fdopen feof ferror fflush fgetc fgetpos fgets fopen fprintf fputc fputs fread freopen fscanf fseek fsetpos ftell fwrite getchar gets perror putc putchar puts remove rewind scanf setbuf setvbuf sscanf tmpfile tmpnam ungetc vfprintf vprintf vsprintf)]; $H{stdlib_h} = [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX abort atexit atof atoi atol bsearch calloc div free getenv labs ldiv malloc mblen mbstowcs mbtowc qsort realloc strtod strtol stroul wcstombs wctomb)]; $H{string_h} = [qw(NULL memchr memcmp memcpy memmove memset strcat strchr strcmp strcoll strcpy strcspn strerror strlen strncat strncmp strncpy strpbrk strrchr strspn strstr strtok strxfrm)]; $H{sys_stat_h} = [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR fstat mkfifo)]; $H{sys_times_h} = [qw()]; $H{sys_types_h} = [qw()]; $H{sys_utsname_h} = [qw(uname)]; $H{sys_wait_h} = [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED WNOHANG WSTOPSIG WTERMSIG WUNTRACED)]; $H{termios_h} = [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400 B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART VSTOP VSUSP VTIME cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain tcflow tcflush tcgetattr tcsendbreak tcsetattr )]; $H{time_h} = [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime difftime mktime strftime tzset tzname)]; $H{unistd_h} = [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET STRERR_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 _POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS _POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_SAVED_IDS _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION _exit access ctermid cuserid dup2 dup execl execle execlp execv execve execvp fpathconf getcwd getegid geteuid getgid getgroups getpid getuid isatty lseek pathconf pause setgid setpgid setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)]; $H{utime_h} = [qw()]; sub expand { local (@mylist); foreach $entry (@_) { if ($H{$entry}) { push(@mylist, @{$H{$entry}}); } else { push(@mylist, $entry); } } @mylist; } @EXPORT = expand qw(assert_h ctype_h dirent_h errno_h fcntl_h float_h grp_h limits_h locale_h math_h pwd_h setjmp_h signal_h stdarg_h stddef_h stdio_h stdlib_h string_h sys_stat_h sys_times_h sys_types_h sys_utsname_h sys_wait_h termios_h time_h unistd_h utime_h); @EXPORT_OK = qw( closedir opendir readdir rewinddir fcntl open getgrgid getgrnam atan2 cos exp log sin sqrt tan getpwnam getpwuid kill fileno getc printf rename sprintf abs exit rand srand system chmod mkdir stat umask times wait waitpid gmtime localtime time alarm chdir chown close fork getlogin getppid getpgrp link pipe read rmdir sleep unlink write utime ); sub import { my $this = shift; my @list = expand @_; local $Exporter::ExportLevel = 1; Exporter::import($this,@list); } sub AUTOLOAD { if ($AUTOLOAD =~ /::(_?[a-z])/) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD } local $constname = $AUTOLOAD; $constname =~ s/.*:://; $val = constant($constname, $_[0]); if ($! != 0) { if ($! =~ /Invalid/) { croak "$constname is not a valid POSIX macro"; } else { croak "Your vendor has not defined POSIX macro $constname, used"; } } eval "sub $AUTOLOAD { $val }"; goto &$AUTOLOAD; } @liblist = (); @liblist = split ' ', $Config::Config{"POSIX_loadlibs"} if defined $Config::Config{"POSIX_loadlibs"}; bootstrap POSIX @liblist; sub usage { local ($mess) = @_; croak "Usage: POSIX::$mess"; } sub redef { local ($mess) = @_; croak "Use method $mess instead"; } sub unimpl { local ($mess) = @_; $mess =~ s/xxx//; croak "Unimplemented: POSIX::$mess"; } $gensym = "SYM000"; sub gensym { *{"POSIX::" . $gensym++}; } sub ungensym { local($x) = shift; $x =~ s/.*:://; delete $::_POSIX{$x}; } ############################ package POSIX::SigAction; sub new { bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3]}; } ############################ package FileHandle; sub new { POSIX::usage "FileHandle->new(filename, posixmode)" if @_ != 3; local($class,$filename,$mode) = @_; local($glob) = &POSIX::gensym; $mode =~ s/a.*/>>/ || $mode =~ s/w.*/>/ || ($mode = '<'); open($glob, "$mode $filename"); bless \$glob; } sub new_from_fd { POSIX::usage "FileHandle->new_from_fd(fd,mode)" if @_ != 3; local($class,$fd,$mode) = @_; local($glob) = &POSIX::gensym; $mode =~ s/a.*/>>/ || $mode =~ s/w.*/>/ || ($mode = '<'); open($glob, "$mode&=$fd"); bless \$glob; } sub clearerr { POSIX::usage "clearerr(filehandle)" if @_ != 1; seek($_[0], 0, 1); } sub close { POSIX::usage "close(filehandle)" if @_ != 1; close($_[0]); ungensym($_[0]); } sub eof { POSIX::usage "eof(filehandle)" if @_ != 1; eof($_[0]); } sub getc { POSIX::usage "getc(filehandle)" if @_ != 1; getc($_[0]); } sub gets { POSIX::usage "gets(filehandle)" if @_ != 1; local($handle) = @_; scalar <$handle>; } sub fileno { POSIX::usage "fileno(filehandle)" if @_ != 1; fileno($_[0]); } sub seek { POSIX::usage "seek(filehandle,pos,whence)" if @_ != 3; seek($_[0], $_[1], $_[2]); } sub tell { POSIX::usage "tell(filehandle)" if @_ != 1; tell($_[0]); } ############################ package POSIX; # return to package POSIX so AutoSplit is happy 1; __END__ sub assert { usage "assert(expr)" if @_ != 1; if (!$_[0]) { croak "Assertion failed"; } } sub tolower { usage "tolower(string)" if @_ != 1; lc($_[0]); } sub toupper { usage "toupper(string)" if @_ != 1; uc($_[0]); } sub closedir { usage "closedir(dirhandle)" if @_ != 1; closedir($_[0]); ungensym($_[0]); } sub opendir { usage "opendir(directory)" if @_ != 1; local($dirhandle) = &gensym; opendir($dirhandle, $_[0]) ? $dirhandle : (ungensym($dirhandle), undef); } sub readdir { usage "readdir(dirhandle)" if @_ != 1; readdir($_[0]); } sub rewinddir { usage "rewinddir(dirhandle)" if @_ != 1; rewinddir($_[0]); } sub errno { usage "errno()" if @_ != 0; $! + 0; } sub creat { usage "creat(filename, mode)" if @_ != 2; &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[2]); } sub fcntl { usage "fcntl(filehandle, cmd, arg)" if @_ != 3; fcntl($_[0], $_[1], $_[2]); } sub getgrgid { usage "getgrgid(gid)" if @_ != 1; getgrgid($_[0]); } sub getgrnam { usage "getgrnam(name)" if @_ != 1; getgrnam($_[0]); } sub atan2 { usage "atan2(x,y)" if @_ != 2; atan2($_[0], $_[1]); } sub cos { usage "cos(x)" if @_ != 1; cos($_[0]); } sub exp { usage "exp(x)" if @_ != 1; exp($_[0]); } sub fabs { usage "fabs(x)" if @_ != 1; abs($_[0]); } sub log { usage "log(x)" if @_ != 1; log($_[0]); } sub pow { usage "pow(x,exponent)" if @_ != 2; $_[0] ** $_[1]; } sub sin { usage "sin(x)" if @_ != 1; sin($_[0]); } sub sqrt { usage "sqrt(x)" if @_ != 1; sqrt($_[0]); } sub tan { usage "tan(x)" if @_ != 1; tan($_[0]); } sub getpwnam { usage "getpwnam(name)" if @_ != 1; getpwnam($_[0]); } sub getpwuid { usage "getpwuid(uid)" if @_ != 1; getpwuid($_[0]); } sub longjmp { unimpl "longjmp() is C-specific: use die instead"; } sub setjmp { unimpl "setjmp() is C-specific: use eval {} instead"; } sub siglongjmp { unimpl "siglongjmp() is C-specific: use die instead"; } sub sigsetjmp { unimpl "sigsetjmp() is C-specific: use eval {} instead"; } sub kill { usage "kill(pid, sig)" if @_ != 2; kill $_[1], $_[0]; } sub raise { usage "raise(sig)" if @_ != 1; kill $$, $_[0]; # Is this good enough? } sub offsetof { unimpl "offsetof() is C-specific, stopped"; } sub clearerr { redef "$filehandle->clearerr(filehandle)"; } sub fclose { redef "$filehandle->fclose(filehandle)"; } sub fdopen { redef "FileHandle->new_from_fd(fd,mode)"; } sub feof { redef "$filehandle->eof()"; } sub fgetc { redef "$filehandle->getc()"; } sub fgets { redef "$filehandle->gets()"; } sub fileno { redef "$filehandle->fileno()"; } sub fopen { redef "FileHandle->open()"; } sub fprintf { unimpl "fprintf() is C-specific--use printf instead"; } sub fputc { unimpl "fputc() is C-specific--use print instead"; } sub fputs { unimpl "fputs() is C-specific--use print instead"; } sub fread { unimpl "fread() is C-specific--use read instead"; } sub freopen { unimpl "freopen() is C-specific--use open instead"; } sub fscanf { unimpl "fscanf() is C-specific--use <> and regular expressions instead"; } sub fseek { redef "$filehandle->seek(pos,whence)"; } sub ferror { redef "$filehandle->error()"; } sub fflush { redef "$filehandle->flush()"; } sub fgetpos { redef "$filehandle->getpos()"; } sub fsetpos { redef "$filehandle->setpos(pos)"; } sub ftell { redef "$filehandle->tell()"; } sub fwrite { unimpl "fwrite() is C-specific--use print instead"; } sub getc { usage "getc(handle)" if @_ != 1; getc($_[0]); } sub getchar { usage "getchar()" if @_ != 0; getc(STDIN); } sub gets { usage "gets()" if @_ != 0; scalar ; } sub perror { print STDERR "@_: " if @_; print STDERR $!,"\n"; } sub printf { usage "printf(pattern, args...)" if @_ < 1; printf STDOUT @_; } sub putc { unimpl "putc() is C-specific--use print instead"; } sub putchar { unimpl "putchar() is C-specific--use print instead"; } sub puts { unimpl "puts() is C-specific--use print instead"; } sub remove { usage "remove(filename)" if @_ != 1; unlink($_[0]); } sub rename { usage "rename(oldfilename, newfilename)" if @_ != 2; rename($_[0], $_[1]); } sub rewind { usage "rewind(filehandle)" if @_ != 1; seek($_[0],0,0); } sub scanf { unimpl "scanf() is C-specific--use <> and regular expressions instead"; } sub sprintf { usage "sprintf(pattern,args)" if @_ == 0; sprintf(shift,@_); } sub sscanf { unimpl "sscanf() is C-specific--use regular expressions instead"; } sub tmpfile { redef "FileHandle->new_tmpfile()"; } sub ungetc { redef "$filehandle->ungetc(char)"; } sub vfprintf { unimpl "vfprintf() is C-specific"; } sub vprintf { unimpl "vprintf() is C-specific"; } sub vsprintf { unimpl "vsprintf() is C-specific"; } sub abs { usage "abs(x)" if @_ != 1; abs($_[0]); } sub atexit { unimpl "atexit() is C-specific: use END {} instead"; } sub atof { unimpl "atof() is C-specific, stopped"; } sub atoi { unimpl "atoi() is C-specific, stopped"; } sub atol { unimpl "atol() is C-specific, stopped"; } sub bsearch { unimpl "bsearch(xxx)" if @_ != 123; bsearch($_[0]); } sub calloc { unimpl "calloc() is C-specific, stopped"; } sub div { unimpl "div() is C-specific, stopped"; } sub exit { usage "exit(status)" if @_ != 1; exit($_[0]); } sub free { unimpl "free() is C-specific, stopped"; free($_[0]); } sub getenv { usage "getenv(name)" if @_ != 1; $ENV{$_[0]}; } sub labs { unimpl "labs() is C-specific, use abs instead"; } sub ldiv { unimpl "ldiv() is C-specific, use / and int instead"; } sub malloc { unimpl "malloc() is C-specific, stopped"; } sub qsort { unimpl "qsort() is C-specific, use sort instead"; } sub rand { unimpl "rand() is non-portable, use Perl's rand instead"; } sub realloc { unimpl "realloc() is C-specific, stopped"; } sub srand { unimpl "srand()"; } sub strtod { unimpl "strtod() is C-specific, stopped"; } sub strtol { unimpl "strtol() is C-specific, stopped"; } sub stroul { unimpl "stroul() is C-specific, stopped"; } sub system { usage "system(command)" if @_ != 1; system($_[0]); } sub memchr { unimpl "memchr() is C-specific, use index() instead"; } sub memcmp { unimpl "memcmp() is C-specific, use eq instead"; } sub memcpy { unimpl "memcpy() is C-specific, use = instead"; memcpy($_[0]); sub memmove { unimpl "memmove() is C-specific, use = instead"; } sub memset { unimpl "memset() is C-specific, use x instead"; } sub strcat { unimpl "strcat() is C-specific, use .= instead"; } sub strchr { unimpl "strchr() is C-specific, use index() instead"; } sub strcmp { unimpl "strcmp() is C-specific, use eq instead"; } sub strcpy { unimpl "strcpy() is C-specific, use = instead"; } sub strcspn { unimpl "strcspn() is C-specific, use regular expressions instead"; } sub strerror { usage "strerror(errno)" if @_ != 1; local $! = $_[0]; $! . ""; } sub strlen { unimpl "strlen() is C-specific, use length instead"; } sub strncat { unimpl "strncat() is C-specific, use .= instead"; } sub strncmp { unimpl "strncmp() is C-specific, use eq instead"; } sub strncpy { unimpl "strncpy() is C-specific, use = instead"; } sub strpbrk { unimpl "strpbrk() is C-specific, stopped"; } sub strrchr { unimpl "strrchr() is C-specific, use rindex() instead"; } sub strspn { unimpl "strspn() is C-specific, stopped"; } sub strstr { usage "strstr(big, little)" if @_ != 2; index($_[0], $_[1]); } sub strtok { unimpl "strtok() is C-specific, stopped"; } sub chmod { usage "chmod(filename, mode)" if @_ != 2; chmod($_[0], $_[1]); } sub fstat { usage "fstat(fd)" if @_ != 1; local(*TMP); open(TMP, "<&$_[0]"); # Gross. local(@l) = stat(TMP); close(TMP); @l; } sub mkdir { usage "mkdir(directoryname, mode)" if @_ != 2; mkdir($_[0], $_[1]); } sub stat { usage "stat(filename)" if @_ != 1; stat($_[0]); } sub umask { usage "umask(mask)" if @_ != 1; umask($_[0]); } sub times { usage "times()" if @_ != 0; times(); } sub wait { usage "wait(statusvariable)" if @_ != 1; local $result = wait(); $_[0] = $?; $result; } sub waitpid { usage "waitpid(pid, statusvariable, options)" if @_ != 3; local $result = waitpid($_[0], $_[2]); $_[1] = $?; $result; } sub gmtime { usage "gmtime(time)" if @_ != 1; gmtime($_[0]); } sub localtime { usage "localtime(time)" if @_ != 1; localtime($_[0]); } sub time { unimpl "time()" if @_ != 0; time; } sub alarm { usage "alarm(seconds)" if @_ != 1; alarm($_[0]); } sub chdir { usage "chdir(directory)" if @_ != 1; chdir($_[0]); } sub chown { usage "chown(filename, uid, gid)" if @_ != 3; chown($_[0], $_[1], $_[2]); } sub execl { unimpl "execl() is C-specific, stopped"; execl($_[0]); } sub execle { unimpl "execle() is C-specific, stopped"; execle($_[0]); } sub execlp { unimpl "execlp() is C-specific, stopped"; execlp($_[0]); } sub execv { unimpl "execv() is C-specific, stopped"; execv($_[0]); } sub execve { unimpl "execve() is C-specific, stopped"; execve($_[0]); } sub execvp { unimpl "execvp() is C-specific, stopped"; execvp($_[0]); } sub fork { usage "fork()" if @_ != 0; fork; } sub getcwd { usage "getcwd()" if @_ != 0; chop($cwd = `pwd`); $cwd; } sub getegid { usage "getegid()" if @_ != 0; $) + 0; } sub geteuid { usage "geteuid()" if @_ != 0; $> + 0; } sub getgid { usage "getgid()" if @_ != 0; $( + 0; } sub getgroups { usage "getgroups()" if @_ != 0; local(%seen) = (); grep(!$seen{$_}++, split(' ', $) )); } sub getlogin { usage "getlogin()" if @_ != 0; getlogin(); } sub getpgrp { usage "getpgrp()" if @_ != 0; getpgrp($_[0]); } sub getpid { usage "getpid()" if @_ != 0; $$; } sub getppid { usage "getppid()" if @_ != 0; getppid; } sub getuid { usage "getuid()" if @_ != 0; $<; } sub isatty { usage "isatty(filehandle)" if @_ != 1; -t $_[0]; } sub link { usage "link(oldfilename, newfilename)" if @_ != 2; link($_[0], $_[1]); } sub rmdir { usage "rmdir(directoryname)" if @_ != 1; rmdir($_[0]); } sub setgid { usage "setgid(gid)" if @_ != 1; $( = $_[0]; } sub setuid { usage "setuid(uid)" if @_ != 1; $< = $_[0]; } sub sleep { usage "sleep(seconds)" if @_ != 1; sleep($_[0]); } sub unlink { usage "unlink(filename)" if @_ != 1; unlink($_[0]); } sub utime { usage "utime(filename, atime, mtime)" if @_ != 3; utime($_[1], $_[2], $_[0]); } unimpl "fprintf() is C-specific--use printf instead"; } sub fputc { unimpl "fputc() is C-specific--use print instead"; } sub fputs { unimpl "fputs() is C-specific--use print instead"; } sub fread { unimpl "fread() is C-specific--use read instead"; } sub freopen { unimpl "freopen() is C-specific--use open instead"; } sub fscanf { unimpl "fscanf() is C-specific--use <> and regular expressions instead"; } sub fseek { redef "$filehandle->seek(pos,wheperl5.000/ext/POSIX/POSIX.xs 600 203 12 154054 5645376765 10472 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include #ifdef I_DIRENT /* XXX maybe better to just rely on perl.h? */ #include #endif #include #include #ifdef I_FLOAT #include #endif #include #ifdef I_LIMITS #include #endif #include #include #ifdef I_PWD #include #endif #include #include #ifdef I_STDARG #include #endif #ifdef I_STDDEF #include #endif /* XXX This comment is just to make I_TERMIO and I_SGTTY visible to metaconfig for future extension writers. We don't use them in POSIX. (This is really sneaky :-) --AD */ #if defined(I_TERMIOS) #include #endif #include #ifdef I_STDLIB #include #endif #include #include #include #include #ifdef HAS_UNAME #include #endif #include #include #include #ifdef I_UTIME #include #endif typedef FILE * InputStream; typedef FILE * OutputStream; typedef int SysRet; typedef long SysRetLong; typedef sigset_t* POSIX__SigSet; typedef HV* POSIX__SigAction; #ifdef I_TERMIOS typedef struct termios* POSIX__Termios; #else /* Define termios types to int, and call not_here for the functions.*/ #define POSIX__Termios int #define speed_t int #define tcflag_t int #define cc_t int #define cfgetispeed(x) not_here("cfgetispeed") #define cfgetospeed(x) not_here("cfgetospeed") #define tcdrain(x) not_here("tcdrain") #define tcflush(x,y) not_here("tcflush") #define tcsendbreak(x,y) not_here("tcsendbreak") #define cfsetispeed(x,y) not_here("cfsetispeed") #define cfsetospeed(x,y) not_here("cfsetospeed") #define ctermid(x) (char *) not_here("ctermid") #define tcflow(x,y) not_here("tcflow") #define tcgetattr(x,y) not_here("tcgetattr") #define tcsetattr(x,y,z) not_here("tcsetattr") #endif /* Possibly needed prototypes */ char *cuserid _((char *)); #ifndef HAS_CUSERID #define cuserid(a) (char *) not_here("cuserid") #endif #ifndef HAS_DIFFTIME #ifndef difftime #define difftime(a,b) not_here("difftime") #endif #endif #ifndef HAS_FPATHCONF #define fpathconf(f,n) (SysRetLong) not_here("fpathconf") #endif #ifndef HAS_MKTIME #define mktime(a) not_here("mktime") #endif #ifndef HAS_NICE #define nice(a) not_here("nice") #endif #ifndef HAS_PATHCONF #define pathconf(f,n) (SysRetLong) not_here("pathconf") #endif #ifndef HAS_SYSCONF #define sysconf(n) (SysRetLong) not_here("sysconf") #endif #ifndef HAS_READLINK #define readlink(a,b,c) not_here("readlink") #endif #ifndef HAS_SETPGID #define setpgid(a,b) not_here("setpgid") #endif #ifndef HAS_SETSID #define setsid() not_here("setsid") #endif #ifndef HAS_STRCOLL #define strcoll(s1,s2) not_here("strcoll") #endif #ifndef HAS_STRXFRM #define strxfrm(s1,s2,n) not_here("strxfrm") #endif #ifndef HAS_TCGETPGRP #define tcgetpgrp(a) not_here("tcgetpgrp") #endif #ifndef HAS_TCSETPGRP #define tcsetpgrp(a,b) not_here("tcsetpgrp") #endif #ifndef HAS_TIMES #define times(a) not_here("times") #endif #ifndef HAS_UNAME #define uname(a) not_here("uname") #endif #ifndef HAS_WAITPID #define waitpid(a,b,c) not_here("waitpid") #endif #ifndef HAS_FGETPOS #define fgetpos(a,b) not_here("fgetpos") #endif #ifndef HAS_FSETPOS #define fsetpos(a,b) not_here("fsetpos") #endif #ifndef HAS_MBLEN #ifndef mblen #define mblen(a,b) not_here("mblen") #endif #endif #ifndef HAS_MBSTOWCS #define mbstowcs(s, pwcs, n) not_here("mbstowcs") #endif #ifndef HAS_MBTOWC #define mbtowc(pwc, s, n) not_here("mbtowc") #endif #ifndef HAS_WCSTOMBS #define wcstombs(s, pwcs, n) not_here("wcstombs") #endif #ifndef HAS_WCTOMB #define wctomb(s, wchar) not_here("wcstombs") #endif #if !defined(HAS_MBLEN) && !defined(HAS_MBSTOWCS) && !defined(HAS_MBTOWC) && !defined(HAS_WCSTOMBS) && !defined(HAS_WCTOMB) /* If we don't have these functions, then we wouldn't have gotten a typedef for wchar_t, the wide character type. Defining wchar_t allows the functions referencing it to compile. Its actual type is then meaningless, since without the above functions, all sections using it end up calling not_here() and croak. --Kaveh Ghazi (ghazi@noc.rutgers.edu) 9/18/94. */ #ifndef wchar_t #define wchar_t char #endif #endif #ifndef HAS_LOCALECONV #define localeconv() not_here("localeconv") #endif #ifdef HAS_TZNAME extern char *tzname[]; #else char *tzname[] = { "" , "" }; #endif #ifndef HAS_LONG_DOUBLE /* XXX What to do about long doubles? */ #ifdef LDBL_MAX #undef LDBL_MAX #endif #ifdef LDBL_MIN #undef LDBL_MIN #endif #ifdef LDBL_EPSILON #undef LDBL_EPSILON #endif #endif static int not_here(s) char *s; { croak("POSIX::%s not implemented on this architecture", s); return -1; } static double constant(name, arg) char *name; int arg; { errno = 0; switch (*name) { case 'A': if (strEQ(name, "ARG_MAX")) #ifdef ARG_MAX return ARG_MAX; #else goto not_there; #endif break; case 'B': if (strEQ(name, "BUFSIZ")) #ifdef BUFSIZ return BUFSIZ; #else goto not_there; #endif if (strEQ(name, "BRKINT")) #ifdef BRKINT return BRKINT; #else goto not_there; #endif if (strEQ(name, "B9600")) #ifdef B9600 return B9600; #else goto not_there; #endif if (strEQ(name, "B19200")) #ifdef B19200 return B19200; #else goto not_there; #endif if (strEQ(name, "B38400")) #ifdef B38400 return B38400; #else goto not_there; #endif if (strEQ(name, "B0")) #ifdef B0 return B0; #else goto not_there; #endif if (strEQ(name, "B110")) #ifdef B110 return B110; #else goto not_there; #endif if (strEQ(name, "B1200")) #ifdef B1200 return B1200; #else goto not_there; #endif if (strEQ(name, "B134")) #ifdef B134 return B134; #else goto not_there; #endif if (strEQ(name, "B150")) #ifdef B150 return B150; #else goto not_there; #endif if (strEQ(name, "B1800")) #ifdef B1800 return B1800; #else goto not_there; #endif if (strEQ(name, "B200")) #ifdef B200 return B200; #else goto not_there; #endif if (strEQ(name, "B2400")) #ifdef B2400 return B2400; #else goto not_there; #endif if (strEQ(name, "B300")) #ifdef B300 return B300; #else goto not_there; #endif if (strEQ(name, "B4800")) #ifdef B4800 return B4800; #else goto not_there; #endif if (strEQ(name, "B50")) #ifdef B50 return B50; #else goto not_there; #endif if (strEQ(name, "B600")) #ifdef B600 return B600; #else goto not_there; #endif if (strEQ(name, "B75")) #ifdef B75 return B75; #else goto not_there; #endif break; case 'C': if (strEQ(name, "CHAR_BIT")) #ifdef CHAR_BIT return CHAR_BIT; #else goto not_there; #endif if (strEQ(name, "CHAR_MAX")) #ifdef CHAR_MAX return CHAR_MAX; #else goto not_there; #endif if (strEQ(name, "CHAR_MIN")) #ifdef CHAR_MIN return CHAR_MIN; #else goto not_there; #endif if (strEQ(name, "CHILD_MAX")) #ifdef CHILD_MAX return CHILD_MAX; #else goto not_there; #endif if (strEQ(name, "CLK_TCK")) #ifdef CLK_TCK return CLK_TCK; #else goto not_there; #endif if (strEQ(name, "CLOCAL")) #ifdef CLOCAL return CLOCAL; #else goto not_there; #endif if (strEQ(name, "CLOCKS_PER_SEC")) #ifdef CLOCKS_PER_SEC return CLOCKS_PER_SEC; #else goto not_there; #endif if (strEQ(name, "CREAD")) #ifdef CREAD return CREAD; #else goto not_there; #endif if (strEQ(name, "CS5")) #ifdef CS5 return CS5; #else goto not_there; #endif if (strEQ(name, "CS6")) #ifdef CS6 return CS6; #else goto not_there; #endif if (strEQ(name, "CS7")) #ifdef CS7 return CS7; #else goto not_there; #endif if (strEQ(name, "CS8")) #ifdef CS8 return CS8; #else goto not_there; #endif if (strEQ(name, "CSIZE")) #ifdef CSIZE return CSIZE; #else goto not_there; #endif if (strEQ(name, "CSTOPB")) #ifdef CSTOPB return CSTOPB; #else goto not_there; #endif break; case 'D': if (strEQ(name, "DBL_MAX")) #ifdef DBL_MAX return DBL_MAX; #else goto not_there; #endif if (strEQ(name, "DBL_MIN")) #ifdef DBL_MIN return DBL_MIN; #else goto not_there; #endif if (strEQ(name, "DBL_DIG")) #ifdef DBL_DIG return DBL_DIG; #else goto not_there; #endif if (strEQ(name, "DBL_EPSILON")) #ifdef DBL_EPSILON return DBL_EPSILON; #else goto not_there; #endif if (strEQ(name, "DBL_MANT_DIG")) #ifdef DBL_MANT_DIG return DBL_MANT_DIG; #else goto not_there; #endif if (strEQ(name, "DBL_MAX_10_EXP")) #ifdef DBL_MAX_10_EXP return DBL_MAX_10_EXP; #else goto not_there; #endif if (strEQ(name, "DBL_MAX_EXP")) #ifdef DBL_MAX_EXP return DBL_MAX_EXP; #else goto not_there; #endif if (strEQ(name, "DBL_MIN_10_EXP")) #ifdef DBL_MIN_10_EXP return DBL_MIN_10_EXP; #else goto not_there; #endif if (strEQ(name, "DBL_MIN_EXP")) #ifdef DBL_MIN_EXP return DBL_MIN_EXP; #else goto not_there; #endif break; case 'E': switch (name[1]) { case 'A': if (strEQ(name, "EACCES")) #ifdef EACCES return EACCES; #else goto not_there; #endif if (strEQ(name, "EAGAIN")) #ifdef EAGAIN return EAGAIN; #else goto not_there; #endif break; case 'B': if (strEQ(name, "EBADF")) #ifdef EBADF return EBADF; #else goto not_there; #endif if (strEQ(name, "EBUSY")) #ifdef EBUSY return EBUSY; #else goto not_there; #endif break; case 'C': if (strEQ(name, "ECHILD")) #ifdef ECHILD return ECHILD; #else goto not_there; #endif if (strEQ(name, "ECHO")) #ifdef ECHO return ECHO; #else goto not_there; #endif if (strEQ(name, "ECHOE")) #ifdef ECHOE return ECHOE; #else goto not_there; #endif if (strEQ(name, "ECHOK")) #ifdef ECHOK return ECHOK; #else goto not_there; #endif if (strEQ(name, "ECHONL")) #ifdef ECHONL return ECHONL; #else goto not_there; #endif break; case 'D': if (strEQ(name, "EDEADLK")) #ifdef EDEADLK return EDEADLK; #else goto not_there; #endif if (strEQ(name, "EDOM")) #ifdef EDOM return EDOM; #else goto not_there; #endif break; case 'E': if (strEQ(name, "EEXIST")) #ifdef EEXIST return EEXIST; #else goto not_there; #endif break; case 'F': if (strEQ(name, "EFAULT")) #ifdef EFAULT return EFAULT; #else goto not_there; #endif if (strEQ(name, "EFBIG")) #ifdef EFBIG return EFBIG; #else goto not_there; #endif break; case 'I': if (strEQ(name, "EINTR")) #ifdef EINTR return EINTR; #else goto not_there; #endif if (strEQ(name, "EINVAL")) #ifdef EINVAL return EINVAL; #else goto not_there; #endif if (strEQ(name, "EIO")) #ifdef EIO return EIO; #else goto not_there; #endif if (strEQ(name, "EISDIR")) #ifdef EISDIR return EISDIR; #else goto not_there; #endif break; case 'M': if (strEQ(name, "EMFILE")) #ifdef EMFILE return EMFILE; #else goto not_there; #endif if (strEQ(name, "EMLINK")) #ifdef EMLINK return EMLINK; #else goto not_there; #endif break; case 'N': if (strEQ(name, "ENOMEM")) #ifdef ENOMEM return ENOMEM; #else goto not_there; #endif if (strEQ(name, "ENOSPC")) #ifdef ENOSPC return ENOSPC; #else goto not_there; #endif if (strEQ(name, "ENOEXEC")) #ifdef ENOEXEC return ENOEXEC; #else goto not_there; #endif if (strEQ(name, "ENOTTY")) #ifdef ENOTTY return ENOTTY; #else goto not_there; #endif if (strEQ(name, "ENOTDIR")) #ifdef ENOTDIR return ENOTDIR; #else goto not_there; #endif if (strEQ(name, "ENOTEMPTY")) #ifdef ENOTEMPTY return ENOTEMPTY; #else goto not_there; #endif if (strEQ(name, "ENFILE")) #ifdef ENFILE return ENFILE; #else goto not_there; #endif if (strEQ(name, "ENODEV")) #ifdef ENODEV return ENODEV; #else goto not_there; #endif if (strEQ(name, "ENOENT")) #ifdef ENOENT return ENOENT; #else goto not_there; #endif if (strEQ(name, "ENOLCK")) #ifdef ENOLCK return ENOLCK; #else goto not_there; #endif if (strEQ(name, "ENOSYS")) #ifdef ENOSYS return ENOSYS; #else goto not_there; #endif if (strEQ(name, "ENXIO")) #ifdef ENXIO return ENXIO; #else goto not_there; #endif if (strEQ(name, "ENAMETOOLONG")) #ifdef ENAMETOOLONG return ENAMETOOLONG; #else goto not_there; #endif break; case 'O': if (strEQ(name, "EOF")) #ifdef EOF return EOF; #else goto not_there; #endif break; case 'P': if (strEQ(name, "EPERM")) #ifdef EPERM return EPERM; #else goto not_there; #endif if (strEQ(name, "EPIPE")) #ifdef EPIPE return EPIPE; #else goto not_there; #endif break; case 'R': if (strEQ(name, "ERANGE")) #ifdef ERANGE return ERANGE; #else goto not_there; #endif if (strEQ(name, "EROFS")) #ifdef EROFS return EROFS; #else goto not_there; #endif break; case 'S': if (strEQ(name, "ESPIPE")) #ifdef ESPIPE return ESPIPE; #else goto not_there; #endif if (strEQ(name, "ESRCH")) #ifdef ESRCH return ESRCH; #else goto not_there; #endif break; case 'X': if (strEQ(name, "EXIT_FAILURE")) #ifdef EXIT_FAILURE return EXIT_FAILURE; #else return 1; #endif if (strEQ(name, "EXIT_SUCCESS")) #ifdef EXIT_SUCCESS return EXIT_SUCCESS; #else return 0; #endif if (strEQ(name, "EXDEV")) #ifdef EXDEV return EXDEV; #else goto not_there; #endif break; } if (strEQ(name, "E2BIG")) #ifdef E2BIG return E2BIG; #else goto not_there; #endif break; case 'F': if (strnEQ(name, "FLT_", 4)) { if (strEQ(name, "FLT_MAX")) #ifdef FLT_MAX return FLT_MAX; #else goto not_there; #endif if (strEQ(name, "FLT_MIN")) #ifdef FLT_MIN return FLT_MIN; #else goto not_there; #endif if (strEQ(name, "FLT_ROUNDS")) #ifdef FLT_ROUNDS return FLT_ROUNDS; #else goto not_there; #endif if (strEQ(name, "FLT_DIG")) #ifdef FLT_DIG return FLT_DIG; #else goto not_there; #endif if (strEQ(name, "FLT_EPSILON")) #ifdef FLT_EPSILON return FLT_EPSILON; #else goto not_there; #endif if (strEQ(name, "FLT_MANT_DIG")) #ifdef FLT_MANT_DIG return FLT_MANT_DIG; #else goto not_there; #endif if (strEQ(name, "FLT_MAX_10_EXP")) #ifdef FLT_MAX_10_EXP return FLT_MAX_10_EXP; #else goto not_there; #endif if (strEQ(name, "FLT_MAX_EXP")) #ifdef FLT_MAX_EXP return FLT_MAX_EXP; #else goto not_there; #endif if (strEQ(name, "FLT_MIN_10_EXP")) #ifdef FLT_MIN_10_EXP return FLT_MIN_10_EXP; #else goto not_there; #endif if (strEQ(name, "FLT_MIN_EXP")) #ifdef FLT_MIN_EXP return FLT_MIN_EXP; #else goto not_there; #endif if (strEQ(name, "FLT_RADIX")) #ifdef FLT_RADIX return FLT_RADIX; #else goto not_there; #endif break; } if (strnEQ(name, "F_", 2)) { if (strEQ(name, "F_DUPFD")) #ifdef F_DUPFD return F_DUPFD; #else goto not_there; #endif if (strEQ(name, "F_GETFD")) #ifdef F_GETFD return F_GETFD; #else goto not_there; #endif if (strEQ(name, "F_GETFL")) #ifdef F_GETFL return F_GETFL; #else goto not_there; #endif if (strEQ(name, "F_GETLK")) #ifdef F_GETLK return F_GETLK; #else goto not_there; #endif if (strEQ(name, "F_OK")) #ifdef F_OK return F_OK; #else goto not_there; #endif if (strEQ(name, "F_RDLCK")) #ifdef F_RDLCK return F_RDLCK; #else goto not_there; #endif if (strEQ(name, "F_SETFD")) #ifdef F_SETFD return F_SETFD; #else goto not_there; #endif if (strEQ(name, "F_SETFL")) #ifdef F_SETFL return F_SETFL; #else goto not_there; #endif if (strEQ(name, "F_SETLK")) #ifdef F_SETLK return F_SETLK; #else goto not_there; #endif if (strEQ(name, "F_SETLKW")) #ifdef F_SETLKW return F_SETLKW; #else goto not_there; #endif if (strEQ(name, "F_UNLCK")) #ifdef F_UNLCK return F_UNLCK; #else goto not_there; #endif if (strEQ(name, "F_WRLCK")) #ifdef F_WRLCK return F_WRLCK; #else goto not_there; #endif break; } if (strEQ(name, "FD_CLOEXEC")) return FD_CLOEXEC; if (strEQ(name, "FILENAME_MAX")) #ifdef FILENAME_MAX return FILENAME_MAX; #else goto not_there; #endif break; case 'H': if (strEQ(name, "HUGE_VAL")) #ifdef HUGE_VAL return HUGE_VAL; #else goto not_there; #endif if (strEQ(name, "HUPCL")) #ifdef HUPCL return HUPCL; #else goto not_there; #endif break; case 'I': if (strEQ(name, "INT_MAX")) #ifdef INT_MAX return INT_MAX; #else goto not_there; #endif if (strEQ(name, "INT_MIN")) #ifdef INT_MIN return INT_MIN; #else goto not_there; #endif if (strEQ(name, "ICANON")) #ifdef ICANON return ICANON; #else goto not_there; #endif if (strEQ(name, "ICRNL")) #ifdef ICRNL return ICRNL; #else goto not_there; #endif if (strEQ(name, "IEXTEN")) #ifdef IEXTEN return IEXTEN; #else goto not_there; #endif if (strEQ(name, "IGNBRK")) #ifdef IGNBRK return IGNBRK; #else goto not_there; #endif if (strEQ(name, "IGNCR")) #ifdef IGNCR return IGNCR; #else goto not_there; #endif if (strEQ(name, "IGNPAR")) #ifdef IGNPAR return IGNPAR; #else goto not_there; #endif if (strEQ(name, "INLCR")) #ifdef INLCR return INLCR; #else goto not_there; #endif if (strEQ(name, "INPCK")) #ifdef INPCK return INPCK; #else goto not_there; #endif if (strEQ(name, "ISIG")) #ifdef ISIG return ISIG; #else goto not_there; #endif if (strEQ(name, "ISTRIP")) #ifdef ISTRIP return ISTRIP; #else goto not_there; #endif if (strEQ(name, "IXOFF")) #ifdef IXOFF return IXOFF; #else goto not_there; #endif if (strEQ(name, "IXON")) #ifdef IXON return IXON; #else goto not_there; #endif break; case 'L': if (strnEQ(name, "LC_", 3)) { if (strEQ(name, "LC_ALL")) #ifdef LC_ALL return LC_ALL; #else goto not_there; #endif if (strEQ(name, "LC_COLLATE")) #ifdef LC_COLLATE return LC_COLLATE; #else goto not_there; #endif if (strEQ(name, "LC_CTYPE")) #ifdef LC_CTYPE return LC_CTYPE; #else goto not_there; #endif if (strEQ(name, "LC_MONETARY")) #ifdef LC_MONETARY return LC_MONETARY; #else goto not_there; #endif if (strEQ(name, "LC_NUMERIC")) #ifdef LC_NUMERIC return LC_NUMERIC; #else goto not_there; #endif if (strEQ(name, "LC_TIME")) #ifdef LC_TIME return LC_TIME; #else goto not_there; #endif break; } if (strnEQ(name, "LDBL_", 5)) { if (strEQ(name, "LDBL_MAX")) #ifdef LDBL_MAX return LDBL_MAX; #else goto not_there; #endif if (strEQ(name, "LDBL_MIN")) #ifdef LDBL_MIN return LDBL_MIN; #else goto not_there; #endif if (strEQ(name, "LDBL_DIG")) #ifdef LDBL_DIG return LDBL_DIG; #else goto not_there; #endif if (strEQ(name, "LDBL_EPSILON")) #ifdef LDBL_EPSILON return LDBL_EPSILON; #else goto not_there; #endif if (strEQ(name, "LDBL_MANT_DIG")) #ifdef LDBL_MANT_DIG return LDBL_MANT_DIG; #else goto not_there; #endif if (strEQ(name, "LDBL_MAX_10_EXP")) #ifdef LDBL_MAX_10_EXP return LDBL_MAX_10_EXP; #else goto not_there; #endif if (strEQ(name, "LDBL_MAX_EXP")) #ifdef LDBL_MAX_EXP return LDBL_MAX_EXP; #else goto not_there; #endif if (strEQ(name, "LDBL_MIN_10_EXP")) #ifdef LDBL_MIN_10_EXP return LDBL_MIN_10_EXP; #else goto not_there; #endif if (strEQ(name, "LDBL_MIN_EXP")) #ifdef LDBL_MIN_EXP return LDBL_MIN_EXP; #else goto not_there; #endif break; } if (strnEQ(name, "L_", 2)) { if (strEQ(name, "L_ctermid")) #ifdef L_ctermid return L_ctermid; #else goto not_there; #endif if (strEQ(name, "L_cuserid")) #ifdef L_cuserid return L_cuserid; #else goto not_there; #endif if (strEQ(name, "L_tmpname")) #ifdef L_tmpname return L_tmpname; #else goto not_there; #endif break; } if (strEQ(name, "LONG_MAX")) #ifdef LONG_MAX return LONG_MAX; #else goto not_there; #endif if (strEQ(name, "LONG_MIN")) #ifdef LONG_MIN return LONG_MIN; #else goto not_there; #endif if (strEQ(name, "LINK_MAX")) #ifdef LINK_MAX return LINK_MAX; #else goto not_there; #endif break; case 'M': if (strEQ(name, "MAX_CANON")) #ifdef MAX_CANON return MAX_CANON; #else goto not_there; #endif if (strEQ(name, "MAX_INPUT")) #ifdef MAX_INPUT return MAX_INPUT; #else goto not_there; #endif if (strEQ(name, "MB_CUR_MAX")) #ifdef MB_CUR_MAX return MB_CUR_MAX; #else goto not_there; #endif if (strEQ(name, "MB_LEN_MAX")) #ifdef MB_LEN_MAX return MB_LEN_MAX; #else goto not_there; #endif break; case 'N': if (strEQ(name, "NULL")) return 0; if (strEQ(name, "NAME_MAX")) #ifdef NAME_MAX return NAME_MAX; #else goto not_there; #endif if (strEQ(name, "NCCS")) #ifdef NCCS return NCCS; #else goto not_there; #endif if (strEQ(name, "NGROUPS_MAX")) #ifdef NGROUPS_MAX return NGROUPS_MAX; #else goto not_there; #endif if (strEQ(name, "NOFLSH")) #ifdef NOFLSH return NOFLSH; #else goto not_there; #endif break; case 'O': if (strnEQ(name, "O_", 2)) { if (strEQ(name, "O_APPEND")) #ifdef O_APPEND return O_APPEND; #else goto not_there; #endif if (strEQ(name, "O_CREAT")) #ifdef O_CREAT return O_CREAT; #else goto not_there; #endif if (strEQ(name, "O_TRUNC")) #ifdef O_TRUNC return O_TRUNC; #else goto not_there; #endif if (strEQ(name, "O_RDONLY")) #ifdef O_RDONLY return O_RDONLY; #else goto not_there; #endif if (strEQ(name, "O_RDWR")) #ifdef O_RDWR return O_RDWR; #else goto not_there; #endif if (strEQ(name, "O_WRONLY")) #ifdef O_WRONLY return O_WRONLY; #else goto not_there; #endif if (strEQ(name, "O_EXCL")) #ifdef O_EXCL return O_EXCL; #else goto not_there; #endif if (strEQ(name, "O_NOCTTY")) #ifdef O_NOCTTY return O_NOCTTY; #else goto not_there; #endif if (strEQ(name, "O_NONBLOCK")) #ifdef O_NONBLOCK return O_NONBLOCK; #else goto not_there; #endif if (strEQ(name, "O_ACCMODE")) #ifdef O_ACCMODE return O_ACCMODE; #else goto not_there; #endif break; } if (strEQ(name, "OPEN_MAX")) #ifdef OPEN_MAX return OPEN_MAX; #else goto not_there; #endif if (strEQ(name, "OPOST")) #ifdef OPOST return OPOST; #else goto not_there; #endif break; case 'P': if (strEQ(name, "PATH_MAX")) #ifdef PATH_MAX return PATH_MAX; #else goto not_there; #endif if (strEQ(name, "PARENB")) #ifdef PARENB return PARENB; #else goto not_there; #endif if (strEQ(name, "PARMRK")) #ifdef PARMRK return PARMRK; #else goto not_there; #endif if (strEQ(name, "PARODD")) #ifdef PARODD return PARODD; #else goto not_there; #endif if (strEQ(name, "PIPE_BUF")) #ifdef PIPE_BUF return PIPE_BUF; #else goto not_there; #endif break; case 'R': if (strEQ(name, "RAND_MAX")) #ifdef RAND_MAX return RAND_MAX; #else goto not_there; #endif if (strEQ(name, "R_OK")) #ifdef R_OK return R_OK; #else goto not_there; #endif break; case 'S': if (strnEQ(name, "SIG", 3)) { if (name[3] == '_') { if (strEQ(name, "SIG_BLOCK")) #ifdef SIG_BLOCK return SIG_BLOCK; #else goto not_there; #endif #ifdef SIG_DFL if (strEQ(name, "SIG_DFL")) return (int)SIG_DFL; #endif #ifdef SIG_ERR if (strEQ(name, "SIG_ERR")) return (int)SIG_ERR; #endif #ifdef SIG_IGN if (strEQ(name, "SIG_IGN")) return (int)SIG_IGN; #endif if (strEQ(name, "SIG_SETMASK")) #ifdef SIG_SETMASK return SIG_SETMASK; #else goto not_there; #endif if (strEQ(name, "SIG_UNBLOCK")) #ifdef SIG_UNBLOCK return SIG_UNBLOCK; #else goto not_there; #endif break; } if (strEQ(name, "SIGABRT")) #ifdef SIGABRT return SIGABRT; #else goto not_there; #endif if (strEQ(name, "SIGALRM")) #ifdef SIGALRM return SIGALRM; #else goto not_there; #endif if (strEQ(name, "SIGCHLD")) #ifdef SIGCHLD return SIGCHLD; #else goto not_there; #endif if (strEQ(name, "SIGCONT")) #ifdef SIGCONT return SIGCONT; #else goto not_there; #endif if (strEQ(name, "SIGFPE")) #ifdef SIGFPE return SIGFPE; #else goto not_there; #endif if (strEQ(name, "SIGHUP")) #ifdef SIGHUP return SIGHUP; #else goto not_there; #endif if (strEQ(name, "SIGILL")) #ifdef SIGILL return SIGILL; #else goto not_there; #endif if (strEQ(name, "SIGINT")) #ifdef SIGINT return SIGINT; #else goto not_there; #endif if (strEQ(name, "SIGKILL")) #ifdef SIGKILL return SIGKILL; #else goto not_there; #endif if (strEQ(name, "SIGPIPE")) #ifdef SIGPIPE return SIGPIPE; #else goto not_there; #endif if (strEQ(name, "SIGQUIT")) #ifdef SIGQUIT return SIGQUIT; #else goto not_there; #endif if (strEQ(name, "SIGSEGV")) #ifdef SIGSEGV return SIGSEGV; #else goto not_there; #endif if (strEQ(name, "SIGSTOP")) #ifdef SIGSTOP return SIGSTOP; #else goto not_there; #endif if (strEQ(name, "SIGTERM")) #ifdef SIGTERM return SIGTERM; #else goto not_there; #endif if (strEQ(name, "SIGTSTP")) #ifdef SIGTSTP return SIGTSTP; #else goto not_there; #endif if (strEQ(name, "SIGTTIN")) #ifdef SIGTTIN return SIGTTIN; #else goto not_there; #endif if (strEQ(name, "SIGTTOU")) #ifdef SIGTTOU return SIGTTOU; #else goto not_there; #endif if (strEQ(name, "SIGUSR1")) #ifdef SIGUSR1 return SIGUSR1; #else goto not_there; #endif if (strEQ(name, "SIGUSR2")) #ifdef SIGUSR2 return SIGUSR2; #else goto not_there; #endif break; } if (name[1] == '_') { #ifdef S_ISBLK if (strEQ(name, "S_ISBLK")) return S_ISBLK(arg); #endif #ifdef S_ISCHR if (strEQ(name, "S_ISCHR")) return S_ISCHR(arg); #endif #ifdef S_ISDIR if (strEQ(name, "S_ISDIR")) return S_ISDIR(arg); #endif #ifdef S_ISFIFO if (strEQ(name, "S_ISFIFO")) return S_ISFIFO(arg); #endif #ifdef S_ISREG if (strEQ(name, "S_ISREG")) return S_ISREG(arg); #endif if (strEQ(name, "S_ISGID")) #ifdef S_ISGID return S_ISGID; #else goto not_there; #endif if (strEQ(name, "S_ISUID")) #ifdef S_ISUID return S_ISUID; #else goto not_there; #endif if (strEQ(name, "S_IRGRP")) #ifdef S_IRGRP return S_IRGRP; #else goto not_there; #endif if (strEQ(name, "S_IROTH")) #ifdef S_IROTH return S_IROTH; #else goto not_there; #endif if (strEQ(name, "S_IRUSR")) #ifdef S_IRUSR return S_IRUSR; #else goto not_there; #endif if (strEQ(name, "S_IRWXG")) #ifdef S_IRWXG return S_IRWXG; #else goto not_there; #endif if (strEQ(name, "S_IRWXO")) #ifdef S_IRWXO return S_IRWXO; #else goto not_there; #endif if (strEQ(name, "S_IRWXU")) #ifdef S_IRWXU return S_IRWXU; #else goto not_there; #endif if (strEQ(name, "S_IWGRP")) #ifdef S_IWGRP return S_IWGRP; #else goto not_there; #endif if (strEQ(name, "S_IWOTH")) #ifdef S_IWOTH return S_IWOTH; #else goto not_there; #endif if (strEQ(name, "S_IWUSR")) #ifdef S_IWUSR return S_IWUSR; #else goto not_there; #endif if (strEQ(name, "S_IXGRP")) #ifdef S_IXGRP return S_IXGRP; #else goto not_there; #endif if (strEQ(name, "S_IXOTH")) #ifdef S_IXOTH return S_IXOTH; #else goto not_there; #endif if (strEQ(name, "S_IXUSR")) #ifdef S_IXUSR return S_IXUSR; #else goto not_there; #endif break; } if (strEQ(name, "SEEK_CUR")) #ifdef SEEK_CUR return SEEK_CUR; #else goto not_there; #endif if (strEQ(name, "SEEK_END")) #ifdef SEEK_END return SEEK_END; #else goto not_there; #endif if (strEQ(name, "SEEK_SET")) #ifdef SEEK_SET return SEEK_SET; #else goto not_there; #endif if (strEQ(name, "STREAM_MAX")) #ifdef STREAM_MAX return STREAM_MAX; #else goto not_there; #endif if (strEQ(name, "SHRT_MAX")) #ifdef SHRT_MAX return SHRT_MAX; #else goto not_there; #endif if (strEQ(name, "SHRT_MIN")) #ifdef SHRT_MIN return SHRT_MIN; #else goto not_there; #endif if (strEQ(name, "SA_NOCLDSTOP")) #ifdef SA_NOCLDSTOP return SA_NOCLDSTOP; #else goto not_there; #endif if (strEQ(name, "SCHAR_MAX")) #ifdef SCHAR_MAX return SCHAR_MAX; #else goto not_there; #endif if (strEQ(name, "SCHAR_MIN")) #ifdef SCHAR_MIN return SCHAR_MIN; #else goto not_there; #endif if (strEQ(name, "SSIZE_MAX")) #ifdef SSIZE_MAX return SSIZE_MAX; #else goto not_there; #endif if (strEQ(name, "STDIN_FILENO")) #ifdef STDIN_FILENO return STDIN_FILENO; #else goto not_there; #endif if (strEQ(name, "STDOUT_FILENO")) #ifdef STDOUT_FILENO return STDOUT_FILENO; #else goto not_there; #endif if (strEQ(name, "STRERR_FILENO")) #ifdef STRERR_FILENO return STRERR_FILENO; #else goto not_there; #endif break; case 'T': if (strEQ(name, "TCIFLUSH")) #ifdef TCIFLUSH return TCIFLUSH; #else goto not_there; #endif if (strEQ(name, "TCIOFF")) #ifdef TCIOFF return TCIOFF; #else goto not_there; #endif if (strEQ(name, "TCIOFLUSH")) #ifdef TCIOFLUSH return TCIOFLUSH; #else goto not_there; #endif if (strEQ(name, "TCION")) #ifdef TCION return TCION; #else goto not_there; #endif if (strEQ(name, "TCOFLUSH")) #ifdef TCOFLUSH return TCOFLUSH; #else goto not_there; #endif if (strEQ(name, "TCOOFF")) #ifdef TCOOFF return TCOOFF; #else goto not_there; #endif if (strEQ(name, "TCOON")) #ifdef TCOON return TCOON; #else goto not_there; #endif if (strEQ(name, "TCSADRAIN")) #ifdef TCSADRAIN return TCSADRAIN; #else goto not_there; #endif if (strEQ(name, "TCSAFLUSH")) #ifdef TCSAFLUSH return TCSAFLUSH; #else goto not_there; #endif if (strEQ(name, "TCSANOW")) #ifdef TCSANOW return TCSANOW; #else goto not_there; #endif if (strEQ(name, "TMP_MAX")) #ifdef TMP_MAX return TMP_MAX; #else goto not_there; #endif if (strEQ(name, "TOSTOP")) #ifdef TOSTOP return TOSTOP; #else goto not_there; #endif if (strEQ(name, "TZNAME_MAX")) #ifdef TZNAME_MAX return TZNAME_MAX; #else goto not_there; #endif break; case 'U': if (strEQ(name, "UCHAR_MAX")) #ifdef UCHAR_MAX return UCHAR_MAX; #else goto not_there; #endif if (strEQ(name, "UINT_MAX")) #ifdef UINT_MAX return UINT_MAX; #else goto not_there; #endif if (strEQ(name, "ULONG_MAX")) #ifdef ULONG_MAX return ULONG_MAX; #else goto not_there; #endif if (strEQ(name, "USHRT_MAX")) #ifdef USHRT_MAX return USHRT_MAX; #else goto not_there; #endif break; case 'V': if (strEQ(name, "VEOF")) #ifdef VEOF return VEOF; #else goto not_there; #endif if (strEQ(name, "VEOL")) #ifdef VEOL return VEOL; #else goto not_there; #endif if (strEQ(name, "VERASE")) #ifdef VERASE return VERASE; #else goto not_there; #endif if (strEQ(name, "VINTR")) #ifdef VINTR return VINTR; #else goto not_there; #endif if (strEQ(name, "VKILL")) #ifdef VKILL return VKILL; #else goto not_there; #endif if (strEQ(name, "VMIN")) #ifdef VMIN return VMIN; #else goto not_there; #endif if (strEQ(name, "VQUIT")) #ifdef VQUIT return VQUIT; #else goto not_there; #endif if (strEQ(name, "VSTART")) #ifdef VSTART return VSTART; #else goto not_there; #endif if (strEQ(name, "VSTOP")) #ifdef VSTOP return VSTOP; #else goto not_there; #endif if (strEQ(name, "VSUSP")) #ifdef VSUSP return VSUSP; #else goto not_there; #endif if (strEQ(name, "VTIME")) #ifdef VTIME return VTIME; #else goto not_there; #endif break; case 'W': if (strEQ(name, "W_OK")) #ifdef W_OK return W_OK; #else goto not_there; #endif #ifdef WEXITSTATUS if (strEQ(name, "WEXITSTATUS")) return WEXITSTATUS(arg); #endif #ifdef WIFEXITED if (strEQ(name, "WIFEXITED")) return WIFEXITED(arg); #endif #ifdef WIFSIGNALED if (strEQ(name, "WIFSIGNALED")) return WIFSIGNALED(arg); #endif #ifdef WIFSTOPPED if (strEQ(name, "WIFSTOPPED")) return WIFSTOPPED(arg); #endif if (strEQ(name, "WNOHANG")) #ifdef WNOHANG return WNOHANG; #else goto not_there; #endif #ifdef WSTOPSIG if (strEQ(name, "WSTOPSIG")) return WSTOPSIG(arg); #endif #ifdef WTERMSIG if (strEQ(name, "WTERMSIG")) return WTERMSIG(arg); #endif if (strEQ(name, "WUNTRACED")) #ifdef WUNTRACED return WUNTRACED; #else goto not_there; #endif break; case 'X': if (strEQ(name, "X_OK")) #ifdef X_OK return X_OK; #else goto not_there; #endif break; case '_': if (strnEQ(name, "_PC_", 4)) { if (strEQ(name, "_PC_CHOWN_RESTRICTED")) #ifdef _PC_CHOWN_RESTRICTED return _PC_CHOWN_RESTRICTED; #else goto not_there; #endif if (strEQ(name, "_PC_LINK_MAX")) #ifdef _PC_LINK_MAX return _PC_LINK_MAX; #else goto not_there; #endif if (strEQ(name, "_PC_MAX_CANON")) #ifdef _PC_MAX_CANON return _PC_MAX_CANON; #else goto not_there; #endif if (strEQ(name, "_PC_MAX_INPUT")) #ifdef _PC_MAX_INPUT return _PC_MAX_INPUT; #else goto not_there; #endif if (strEQ(name, "_PC_NAME_MAX")) #ifdef _PC_NAME_MAX return _PC_NAME_MAX; #else goto not_there; #endif if (strEQ(name, "_PC_NO_TRUNC")) #ifdef _PC_NO_TRUNC return _PC_NO_TRUNC; #else goto not_there; #endif if (strEQ(name, "_PC_PATH_MAX")) #ifdef _PC_PATH_MAX return _PC_PATH_MAX; #else goto not_there; #endif if (strEQ(name, "_PC_PIPE_BUF")) #ifdef _PC_PIPE_BUF return _PC_PIPE_BUF; #else goto not_there; #endif if (strEQ(name, "_PC_VDISABLE")) #ifdef _PC_VDISABLE return _PC_VDISABLE; #else goto not_there; #endif break; } if (strnEQ(name, "_POSIX_", 7)) { if (strEQ(name, "_POSIX_ARG_MAX")) #ifdef _POSIX_ARG_MAX return _POSIX_ARG_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_CHILD_MAX")) #ifdef _POSIX_CHILD_MAX return _POSIX_CHILD_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_CHOWN_RESTRICTED")) #ifdef _POSIX_CHOWN_RESTRICTED return _POSIX_CHOWN_RESTRICTED; #else return 0; #endif if (strEQ(name, "_POSIX_JOB_CONTROL")) #ifdef _POSIX_JOB_CONTROL return _POSIX_JOB_CONTROL; #else return 0; #endif if (strEQ(name, "_POSIX_LINK_MAX")) #ifdef _POSIX_LINK_MAX return _POSIX_LINK_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_MAX_CANON")) #ifdef _POSIX_MAX_CANON return _POSIX_MAX_CANON; #else return 0; #endif if (strEQ(name, "_POSIX_MAX_INPUT")) #ifdef _POSIX_MAX_INPUT return _POSIX_MAX_INPUT; #else return 0; #endif if (strEQ(name, "_POSIX_NAME_MAX")) #ifdef _POSIX_NAME_MAX return _POSIX_NAME_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_NGROUPS_MAX")) #ifdef _POSIX_NGROUPS_MAX return _POSIX_NGROUPS_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_NO_TRUNC")) #ifdef _POSIX_NO_TRUNC return _POSIX_NO_TRUNC; #else return 0; #endif if (strEQ(name, "_POSIX_OPEN_MAX")) #ifdef _POSIX_OPEN_MAX return _POSIX_OPEN_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_PATH_MAX")) #ifdef _POSIX_PATH_MAX return _POSIX_PATH_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_PIPE_BUF")) #ifdef _POSIX_PIPE_BUF return _POSIX_PIPE_BUF; #else return 0; #endif if (strEQ(name, "_POSIX_SAVED_IDS")) #ifdef _POSIX_SAVED_IDS return _POSIX_SAVED_IDS; #else return 0; #endif if (strEQ(name, "_POSIX_SSIZE_MAX")) #ifdef _POSIX_SSIZE_MAX return _POSIX_SSIZE_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_STREAM_MAX")) #ifdef _POSIX_STREAM_MAX return _POSIX_STREAM_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_TZNAME_MAX")) #ifdef _POSIX_TZNAME_MAX return _POSIX_TZNAME_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_VDISABLE")) #ifdef _POSIX_VDISABLE return _POSIX_VDISABLE; #else return 0; #endif if (strEQ(name, "_POSIX_VERSION")) #ifdef _POSIX_VERSION return _POSIX_VERSION; #else return 0; #endif break; } if (strnEQ(name, "_SC_", 4)) { if (strEQ(name, "_SC_ARG_MAX")) #ifdef _SC_ARG_MAX return _SC_ARG_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_CHILD_MAX")) #ifdef _SC_CHILD_MAX return _SC_CHILD_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_CLK_TCK")) #ifdef _SC_CLK_TCK return _SC_CLK_TCK; #else goto not_there; #endif if (strEQ(name, "_SC_JOB_CONTROL")) #ifdef _SC_JOB_CONTROL return _SC_JOB_CONTROL; #else goto not_there; #endif if (strEQ(name, "_SC_NGROUPS_MAX")) #ifdef _SC_NGROUPS_MAX return _SC_NGROUPS_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_OPEN_MAX")) #ifdef _SC_OPEN_MAX return _SC_OPEN_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_SAVED_IDS")) #ifdef _SC_SAVED_IDS return _SC_SAVED_IDS; #else goto not_there; #endif if (strEQ(name, "_SC_STREAM_MAX")) #ifdef _SC_STREAM_MAX return _SC_STREAM_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_TZNAME_MAX")) #ifdef _SC_TZNAME_MAX return _SC_TZNAME_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_VERSION")) #ifdef _SC_VERSION return _SC_VERSION; #else goto not_there; #endif break; } if (strEQ(name, "_IOFBF")) #ifdef _IOFBF return _IOFBF; #else goto not_there; #endif if (strEQ(name, "_IOLBF")) #ifdef _IOLBF return _IOLBF; #else goto not_there; #endif if (strEQ(name, "_IONBF")) #ifdef _IONBF return _IONBF; #else goto not_there; #endif break; } errno = EINVAL; return 0; not_there: errno = ENOENT; return 0; } MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig POSIX::SigSet new(packname = "POSIX::SigSet", ...) char * packname CODE: { int i; RETVAL = (sigset_t*)safemalloc(sizeof(sigset_t)); sigemptyset(RETVAL); for (i = 1; i < items; i++) sigaddset(RETVAL, SvIV(ST(i))); } OUTPUT: RETVAL void DESTROY(sigset) POSIX::SigSet sigset CODE: safefree((char *)sigset); SysRet sigaddset(sigset, sig) POSIX::SigSet sigset int sig SysRet sigdelset(sigset, sig) POSIX::SigSet sigset int sig SysRet sigemptyset(sigset) POSIX::SigSet sigset SysRet sigfillset(sigset) POSIX::SigSet sigset int sigismember(sigset, sig) POSIX::SigSet sigset int sig MODULE = Termios PACKAGE = POSIX::Termios PREFIX = cf POSIX::Termios new(packname = "POSIX::Termios", ...) char * packname CODE: { #ifdef I_TERMIOS RETVAL = (struct termios*)safemalloc(sizeof(struct termios)); #else not_here("termios"); #endif } OUTPUT: RETVAL void DESTROY(termios_ref) POSIX::Termios termios_ref CODE: #ifdef I_TERMIOS safefree((char *)termios_ref); #else not_here("termios"); #endif SysRet getattr(termios_ref, fd = 0) POSIX::Termios termios_ref int fd CODE: RETVAL = tcgetattr(fd, termios_ref); OUTPUT: RETVAL SysRet setattr(termios_ref, fd = 0, optional_actions = 0) POSIX::Termios termios_ref int fd int optional_actions CODE: RETVAL = tcsetattr(fd, optional_actions, termios_ref); OUTPUT: RETVAL speed_t cfgetispeed(termios_ref) POSIX::Termios termios_ref speed_t cfgetospeed(termios_ref) POSIX::Termios termios_ref tcflag_t getiflag(termios_ref) POSIX::Termios termios_ref CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ RETVAL = termios_ref->c_iflag; #else not_here("getiflag"); #endif OUTPUT: RETVAL tcflag_t getoflag(termios_ref) POSIX::Termios termios_ref CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ RETVAL = termios_ref->c_oflag; #else not_here("getoflag"); #endif OUTPUT: RETVAL tcflag_t getcflag(termios_ref) POSIX::Termios termios_ref CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ RETVAL = termios_ref->c_cflag; #else not_here("getcflag"); #endif OUTPUT: RETVAL tcflag_t getlflag(termios_ref) POSIX::Termios termios_ref CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ RETVAL = termios_ref->c_lflag; #else not_here("getlflag"); #endif OUTPUT: RETVAL cc_t getcc(termios_ref, ccix) POSIX::Termios termios_ref int ccix CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ if (ccix >= NCCS) croak("Bad getcc subscript"); RETVAL = termios_ref->c_cc[ccix]; #else not_here("getcc"); #endif OUTPUT: RETVAL SysRet cfsetispeed(termios_ref, speed) POSIX::Termios termios_ref speed_t speed SysRet cfsetospeed(termios_ref, speed) POSIX::Termios termios_ref speed_t speed void setiflag(termios_ref, iflag) POSIX::Termios termios_ref tcflag_t iflag CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ termios_ref->c_iflag = iflag; #else not_here("setiflag"); #endif void setoflag(termios_ref, oflag) POSIX::Termios termios_ref tcflag_t oflag CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ termios_ref->c_oflag = oflag; #else not_here("setoflag"); #endif void setcflag(termios_ref, cflag) POSIX::Termios termios_ref tcflag_t cflag CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ termios_ref->c_cflag = cflag; #else not_here("setcflag"); #endif void setlflag(termios_ref, lflag) POSIX::Termios termios_ref tcflag_t lflag CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ termios_ref->c_lflag = lflag; #else not_here("setlflag"); #endif void setcc(termios_ref, ccix, cc) POSIX::Termios termios_ref int ccix cc_t cc CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ if (ccix >= NCCS) croak("Bad setcc subscript"); termios_ref->c_cc[ccix] = cc; #else not_here("setcc"); #endif MODULE = FileHandle PACKAGE = FileHandle PREFIX = f SV * fgetpos(handle) InputStream handle CODE: { Fpos_t pos; fgetpos(handle, &pos); ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); } SysRet fsetpos(handle, pos) InputStream handle SV * pos CODE: RETVAL = fsetpos(handle, (Fpos_t*)SvPVX(pos)); OUTPUT: RETVAL int ungetc(handle, c) InputStream handle int c CODE: RETVAL = ungetc(c, handle); OUTPUT: RETVAL OutputStream new_tmpfile() CODE: RETVAL = tmpfile(); OUTPUT: RETVAL int ferror(handle) InputStream handle SysRet fflush(handle) OutputStream handle void setbuf(handle, buf) OutputStream handle char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0; SysRet setvbuf(handle, buf, type, size) OutputStream handle char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0; int type int size MODULE = POSIX PACKAGE = POSIX double constant(name,arg) char * name int arg int isalnum(charstring) char * charstring CODE: char *s; RETVAL = 1; for (s = charstring; *s && RETVAL; s++) if (!isalnum(*s)) RETVAL = 0; OUTPUT: RETVAL int isalpha(charstring) char * charstring CODE: char *s; RETVAL = 1; for (s = charstring; *s && RETVAL; s++) if (!isalpha(*s)) RETVAL = 0; OUTPUT: RETVAL int iscntrl(charstring) char * charstring CODE: char *s; RETVAL = 1; for (s = charstring; *s && RETVAL; s++) if (!iscntrl(*s)) RETVAL = 0; OUTPUT: RETVAL int isdigit(charstring) char * charstring CODE: char *s; RETVAL = 1; for (s = charstring; *s && RETVAL; s++) if (!isdigit(*s)) RETVAL = 0; OUTPUT: RETVAL int isgraph(charstring) char * charstring CODE: char *s; RETVAL = 1; for (s = charstring; *s && RETVAL; s++) if (!isgraph(*s)) RETVAL = 0; OUTPUT: RETVAL int islower(charstring) char * charstring CODE: char *s; RETVAL = 1; for (s = charstring; *s && RETVAL; s++) if (!islower(*s)) RETVAL = 0; OUTPUT: RETVAL int isprint(charstring) char * charstring CODE: char *s; RETVAL = 1; for (s = charstring; *s && RETVAL; s++) if (!isprint(*s)) RETVAL = 0; OUTPUT: RETVAL int ispunct(charstring) char * charstring CODE: char *s; RETVAL = 1; for (s = charstring; *s && RETVAL; s++) if (!ispunct(*s)) RETVAL = 0; OUTPUT: RETVAL int isspace(charstring) char * charstring CODE: char *s; RETVAL = 1; for (s = charstring; *s && RETVAL; s++) if (!isspace(*s)) RETVAL = 0; OUTPUT: RETVAL int isupper(charstring) char * charstring CODE: char *s; RETVAL = 1; for (s = charstring; *s && RETVAL; s++) if (!isupper(*s)) RETVAL = 0; OUTPUT: RETVAL int isxdigit(charstring) char * charstring CODE: char *s; RETVAL = 1; for (s = charstring; *s && RETVAL; s++) if (!isxdigit(*s)) RETVAL = 0; OUTPUT: RETVAL SysRet open(filename, flags = O_RDONLY, mode = 0666) char * filename int flags Mode_t mode HV * localeconv() CODE: #ifdef HAS_LOCALECONV struct lconv *lcbuf; RETVAL = newHV(); if (lcbuf = localeconv()) { /* the strings */ if (lcbuf->decimal_point && *lcbuf->decimal_point) hv_store(RETVAL, "decimal_point", 13, newSVpv(lcbuf->decimal_point, 0), 0); if (lcbuf->thousands_sep && *lcbuf->thousands_sep) hv_store(RETVAL, "thousands_sep", 13, newSVpv(lcbuf->thousands_sep, 0), 0); if (lcbuf->grouping && *lcbuf->grouping) hv_store(RETVAL, "grouping", 8, newSVpv(lcbuf->grouping, 0), 0); if (lcbuf->int_curr_symbol && *lcbuf->int_curr_symbol) hv_store(RETVAL, "int_curr_symbol", 15, newSVpv(lcbuf->int_curr_symbol, 0), 0); if (lcbuf->currency_symbol && *lcbuf->currency_symbol) hv_store(RETVAL, "currency_symbol", 15, newSVpv(lcbuf->currency_symbol, 0), 0); if (lcbuf->mon_decimal_point && *lcbuf->mon_decimal_point) hv_store(RETVAL, "mon_decimal_point", 17, newSVpv(lcbuf->mon_decimal_point, 0), 0); if (lcbuf->mon_thousands_sep && *lcbuf->mon_thousands_sep) hv_store(RETVAL, "mon_thousands_sep", 17, newSVpv(lcbuf->mon_thousands_sep, 0), 0); if (lcbuf->mon_grouping && *lcbuf->mon_grouping) hv_store(RETVAL, "mon_grouping", 12, newSVpv(lcbuf->mon_grouping, 0), 0); if (lcbuf->positive_sign && *lcbuf->positive_sign) hv_store(RETVAL, "positive_sign", 13, newSVpv(lcbuf->positive_sign, 0), 0); if (lcbuf->negative_sign && *lcbuf->negative_sign) hv_store(RETVAL, "negative_sign", 13, newSVpv(lcbuf->negative_sign, 0), 0); /* the integers */ if (lcbuf->int_frac_digits != CHAR_MAX) hv_store(RETVAL, "int_frac_digits", 15, newSViv(lcbuf->int_frac_digits), 0); if (lcbuf->frac_digits != CHAR_MAX) hv_store(RETVAL, "frac_digits", 11, newSViv(lcbuf->frac_digits), 0); if (lcbuf->p_cs_precedes != CHAR_MAX) hv_store(RETVAL, "p_cs_precedes", 13, newSViv(lcbuf->p_cs_precedes), 0); if (lcbuf->p_sep_by_space != CHAR_MAX) hv_store(RETVAL, "p_sep_by_space", 14, newSViv(lcbuf->p_sep_by_space), 0); if (lcbuf->n_cs_precedes != CHAR_MAX) hv_store(RETVAL, "n_cs_precedes", 13, newSViv(lcbuf->n_cs_precedes), 0); if (lcbuf->n_sep_by_space != CHAR_MAX) hv_store(RETVAL, "n_sep_by_space", 14, newSViv(lcbuf->n_sep_by_space), 0); if (lcbuf->p_sign_posn != CHAR_MAX) hv_store(RETVAL, "p_sign_posn", 11, newSViv(lcbuf->p_sign_posn), 0); if (lcbuf->n_sign_posn != CHAR_MAX) hv_store(RETVAL, "n_sign_posn", 11, newSViv(lcbuf->n_sign_posn), 0); } #else localeconv(); /* A stub to call not_here(). */ #endif OUTPUT: RETVAL char * setlocale(category, locale) int category char * locale double acos(x) double x double asin(x) double x double atan(x) double x double ceil(x) double x double cosh(x) double x double floor(x) double x double fmod(x,y) double x double y void frexp(x) double x PPCODE: int expvar; /* (We already know stack is long enough.) */ PUSHs(sv_2mortal(newSVnv(frexp(x,&expvar)))); PUSHs(sv_2mortal(newSViv(expvar))); double ldexp(x,exp) double x int exp double log10(x) double x void modf(x) double x PPCODE: double intvar; /* (We already know stack is long enough.) */ PUSHs(sv_2mortal(newSVnv(modf(x,&intvar)))); PUSHs(sv_2mortal(newSVnv(intvar))); double sinh(x) double x double tanh(x) double x SysRet sigaction(sig, action, oldaction = 0) int sig POSIX::SigAction action POSIX::SigAction oldaction CODE: # This code is really grody because we're trying to make the signal # interface look beautiful, which is hard. if (!siggv) gv_fetchpv("SIG", TRUE, SVt_PVHV); { struct sigaction act; struct sigaction oact; POSIX__SigSet sigset; SV** svp; SV** sigsvp = hv_fetch(GvHVn(siggv), sig_name[sig], strlen(sig_name[sig]), TRUE); /* Remember old handler name if desired. */ if (oldaction) { char *hand = SvPVx(*sigsvp, na); svp = hv_fetch(oldaction, "HANDLER", 7, TRUE); sv_setpv(*svp, *hand ? hand : "DEFAULT"); } if (action) { /* Vector new handler through %SIG. (We always use sighandler for the C signal handler, which reads %SIG to dispatch.) */ svp = hv_fetch(action, "HANDLER", 7, FALSE); if (!svp) croak("Can't supply an action without a HANDLER"); sv_setpv(*sigsvp, SvPV(*svp, na)); mg_set(*sigsvp); /* handles DEFAULT and IGNORE */ act.sa_handler = sighandler; /* Set up any desired mask. */ svp = hv_fetch(action, "MASK", 4, FALSE); if (svp && sv_isa(*svp, "POSIX::SigSet")) { unsigned long tmp; tmp = (unsigned long)SvNV((SV*)SvRV(*svp)); sigset = (sigset_t*) tmp; act.sa_mask = *sigset; } else sigemptyset(& act.sa_mask); /* Set up any desired flags. */ svp = hv_fetch(action, "FLAGS", 5, FALSE); act.sa_flags = svp ? SvIV(*svp) : 0; } /* Now work around sigaction oddities */ if (action && oldaction) RETVAL = sigaction(sig, & act, & oact); else if (action) RETVAL = sigaction(sig, & act, (struct sigaction*)0); else if (oldaction) RETVAL = sigaction(sig, (struct sigaction*)0, & oact); else RETVAL = -1; if (oldaction) { /* Get back the mask. */ svp = hv_fetch(oldaction, "MASK", 4, TRUE); if (sv_isa(*svp, "POSIX::SigSet")) { unsigned long tmp; tmp = (unsigned long)SvNV((SV*)SvRV(*svp)); sigset = (sigset_t*) tmp; } else { sigset = (sigset_t*)safemalloc(sizeof(sigset_t)); sv_setptrobj(*svp, sigset, "POSIX::SigSet"); } *sigset = oact.sa_mask; /* Get back the flags. */ svp = hv_fetch(oldaction, "FLAGS", 5, TRUE); sv_setiv(*svp, oact.sa_flags); } } OUTPUT: RETVAL SysRet sigpending(sigset) POSIX::SigSet sigset SysRet sigprocmask(how, sigset, oldsigset = 0) int how POSIX::SigSet sigset POSIX::SigSet oldsigset SysRet sigsuspend(signal_mask) POSIX::SigSet signal_mask void _exit(status) int status SysRet close(fd) int fd SysRet dup(fd) int fd SysRet dup2(fd1, fd2) int fd1 int fd2 SysRet lseek(fd, offset, whence) int fd Off_t offset int whence SysRet nice(incr) int incr int pipe() PPCODE: int fds[2]; if (pipe(fds) != -1) { EXTEND(sp,2); PUSHs(sv_2mortal(newSViv(fds[0]))); PUSHs(sv_2mortal(newSViv(fds[1]))); } SysRet read(fd, buffer, nbytes) int fd char * buffer = sv_grow(ST(1),SvIV(ST(2))+1); size_t nbytes CLEANUP: if (RETVAL >= 0) { SvCUR(ST(1)) = RETVAL; SvPOK_only(ST(1)); *SvEND(ST(1)) = '\0'; if (tainting) sv_magic(ST(1), 0, 't', 0, 0); } SysRet setgid(gid) Gid_t gid SysRet setpgid(pid, pgid) pid_t pid pid_t pgid pid_t setsid() SysRet setuid(uid) Uid_t uid pid_t tcgetpgrp(fd) int fd SysRet tcsetpgrp(fd, pgrp_id) int fd pid_t pgrp_id int uname() PPCODE: #ifdef HAS_UNAME struct utsname buf; if (uname(&buf) >= 0) { EXTEND(sp, 5); PUSHs(sv_2mortal(newSVpv(buf.sysname, 0))); PUSHs(sv_2mortal(newSVpv(buf.nodename, 0))); PUSHs(sv_2mortal(newSVpv(buf.release, 0))); PUSHs(sv_2mortal(newSVpv(buf.version, 0))); PUSHs(sv_2mortal(newSVpv(buf.machine, 0))); } #else uname((char *) 0); /* A stub to call not_here(). */ #endif SysRet write(fd, buffer, nbytes) int fd char * buffer size_t nbytes char * tmpnam(s = 0) char * s = 0; void abort() int mblen(s, n) char * s size_t n size_t mbstowcs(s, pwcs, n) wchar_t * s char * pwcs size_t n int mbtowc(pwc, s, n) wchar_t * pwc char * s size_t n int wcstombs(s, pwcs, n) char * s wchar_t * pwcs size_t n int wctomb(s, wchar) char * s wchar_t wchar int strcoll(s1, s2) char * s1 char * s2 SV * strxfrm(src) SV * src CODE: { STRLEN srclen; STRLEN dstlen; char *p = SvPV(src,srclen); srclen++; ST(0) = sv_2mortal(newSV(srclen)); dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)srclen); if (dstlen > srclen) { dstlen++; SvGROW(ST(0), dstlen); strxfrm(SvPVX(ST(0)), p, (size_t)dstlen); dstlen--; } SvCUR(ST(0)) = dstlen; SvPOK_only(ST(0)); } SysRet mkfifo(filename, mode) char * filename Mode_t mode SysRet tcdrain(fd) int fd SysRet tcflow(fd, action) int fd int action SysRet tcflush(fd, queue_selector) int fd int queue_selector SysRet tcsendbreak(fd, duration) int fd int duration char * asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) int sec int min int hour int mday int mon int year int wday int yday int isdst CODE: { struct tm mytm; mytm.tm_sec = sec; mytm.tm_min = min; mytm.tm_hour = hour; mytm.tm_mday = mday; mytm.tm_mon = mon; mytm.tm_year = year; mytm.tm_wday = wday; mytm.tm_yday = yday; mytm.tm_isdst = isdst; RETVAL = asctime(&mytm); } OUTPUT: RETVAL long clock() char * ctime(time) Time_t * time double difftime(time1, time2) Time_t time1 Time_t time2 SysRetLong mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) int sec int min int hour int mday int mon int year int wday int yday int isdst CODE: { struct tm mytm; mytm.tm_sec = sec; mytm.tm_min = min; mytm.tm_hour = hour; mytm.tm_mday = mday; mytm.tm_mon = mon; mytm.tm_year = year; mytm.tm_wday = wday; mytm.tm_yday = yday; mytm.tm_isdst = isdst; RETVAL = mktime(&mytm); } OUTPUT: RETVAL char * strftime(fmt, sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) char * fmt int sec int min int hour int mday int mon int year int wday int yday int isdst CODE: { char tmpbuf[128]; struct tm mytm; int len; mytm.tm_sec = sec; mytm.tm_min = min; mytm.tm_hour = hour; mytm.tm_mday = mday; mytm.tm_mon = mon; mytm.tm_year = year; mytm.tm_wday = wday; mytm.tm_yday = yday; mytm.tm_isdst = isdst; len = strftime(tmpbuf, sizeof tmpbuf, fmt, &mytm); ST(0) = sv_2mortal(newSVpv(tmpbuf, len)); } void tzset() void tzname() PPCODE: EXTEND(sp,2); PUSHs(sv_2mortal(newSVpv(tzname[0],strlen(tzname[0])))); PUSHs(sv_2mortal(newSVpv(tzname[1],strlen(tzname[1])))); SysRet access(filename, mode) char * filename Mode_t mode char * ctermid(s = 0) char * s = 0; char * cuserid(s = 0) char * s = 0; SysRetLong fpathconf(fd, name) int fd int name SysRetLong pathconf(filename, name) char * filename int name SysRet pause() SysRetLong sysconf(name) int name char * ttyname(fd) int fd newSViv(lcbuf->n_sign_posn), 0); } #else localeconv(); /* A stub to call not_here(). */ #endif OUTPUT: RETVAL char * setlocale(category, locale) int category char * locale double acos(x) double x double asin(x) double x double atan(x) double x double ceil(x) double x double cosh(x) double x double floor(x) double x double fmod(x,y) double x double y void frexp(x) double x PPCODE: int expvar; /* (We already know stacperl5.000/ext/POSIX/typemap 664 203 12 316 5645376637 10535 Mode_t T_NV pid_t T_NV Uid_t T_NV Time_t T_NV Gid_t T_NV Off_t T_NV fd T_IV speed_t T_IV tcflag_t T_IV cc_t T_IV POSIX::SigSet T_PTROBJ POSIX::Termios T_PTROBJ POSIX::SigAction T_HVREF category char * locale double acos(x) double x double asin(x) double x double atan(x) double x double ceil(x) double x double cosh(x) double x double floor(x) double x double fmod(x,y) double x double y void frexp(x) double x PPCODE: int expvar; /* (We already know stacperl5.000/ext/SDBM_File/ 775 203 12 0 5650575672 7644 perl5.000/ext/SDBM_File/Makefile.SH 664 203 12 12712 5650410574 11712 : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac 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 fi : Find absolute path name for TOP. This is needed when we cd to TOP : to run perl on autosplit. oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd case $CONFIG in '') . $TOP/config.sh ;; esac : Find out directory name. This is also the extension name. ext=`pwd | $sed -e 's@.*/@@'` : This extension might have its own typemap if test -f typemap; then exttypemap='typemap' else exttypemap='' fi : This extension might need additional libraries. potential_libs=" " . $TOP/ext/util/extliblist : This extension might need bootstrap support if test -f ${ext}_BS; then bootdep=${ext}_BS else bootdep='' fi case "$dlsrc" in dl_aix*) echo "#!" > $ext.exp echo "boot_$ext" >> $ext.exp ;; esac echo "Extracting ext/$ext/Makefile (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted : by putting a backslash in front. You may delete these comments. $spitshell >Makefile << !GROK!THIS! # # This Makefile is for the $ext extension to perl. # CC = $cc RANLIB = $ranlib TOP = $TOP ABSTOP = $ABSTOP LDFLAGS = $ldflags CLDFLAGS = $ldflags SMALL = $small LARGE = $large $split # To use an alternate make, set \$altmake in config.sh. MAKE = ${altmake-make} EXT = $ext # $ext might have its own typemap EXTTYPEMAP = $exttypemap # $ext might have its own bootstrap support BOOTDEP = $bootdep BOOTSTRAP = $ext.bs # The following are used to build and install shared libraries for # dynamic loading. LDDLFLAGS = $lddlflags CCDLFLAGS = $ccdlflags CCCDLFLAGS = $cccdlflags SO = $so DLEXT = $dlext # $ext might need to be linked with some extra libraries. # EXTRALIBS = full list of libraries needed for static linking. # Only those libraries that actually exist are included. # DYNLOADLIBS = list of those libraries that are needed but can be # linked in dynamically on this platform. On SunOS, for # example, this would be .so* libraries, but not archive # libraries. The bootstrap file is installed only if # this list is not empty. # STATLOADLIBS = list of those libraries which must be statically # linked into the shared library. On SunOS 4.1.3, # for example, I have only an archive version of # -lm, and it must be linked in statically. EXTRALIBS = $extralibs DYNALOADLIBS = $dynaloadlibs STATLOADLIBS = $statloadlibs !GROK!THIS! $spitshell >>Makefile <<'!NO!SUBS!' # Where to put things: AUTO = $(TOP)/lib/auto INSTALLBOOT = $(AUTO)/$(EXT)/$(EXT).bs INSTALLDYNAMIC = $(AUTO)/$(EXT)/$(EXT).$(DLEXT) INSTALLSTATIC = $(EXT).a INSTALLPM = $(TOP)/lib/$(EXT).pm PERL = $(ABSTOP)/miniperl XSUBPP = $(TOP)/ext/xsubpp SHELL = /bin/sh CCCMD = `sh $(shellflags) $(TOP)/cflags $@` .c.o: $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c all: dynamic # Phony target to force checking subdirectories. FORCE: config: # Target for Dynamic Loading: dynamic: $(INSTALLDYNAMIC) $(INSTALLPM) $(INSTALLBOOT) $(INSTALLDYNAMIC): $(EXT).o sdbm/libsdbm.a @test -d $(AUTO) || mkdir $(AUTO) @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) ld $(LDDLFLAGS) -o $@ $(EXT).o sdbm/libsdbm.a $(STATLOADLIBS) $(BOOTSTRAP): Makefile $(BOOTDEP) $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) touch $(BOOTSTRAP) $(INSTALLBOOT): $(BOOTSTRAP) @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ # Target for Static Loading: static: $(INSTALLSTATIC) $(INSTALLPM) $(INSTALLSTATIC): $(EXT).o sdbm/libsdbm.a cp sdbm/libsdbm.a $@ ar r $@ $(EXT).o $(RANLIB) $@ echo $(EXTRALIBS) >> $(TOP)/ext.libs $(EXT).c: $(EXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile $(PERL) $(XSUBPP) $(EXT).xs >tmp mv tmp $@ sdbm/libsdbm.a: FORCE @cd sdbm; \ if test ! -f Makefile ; then \ test -f Makefile.SH && sh Makefile.SH ; \ fi ; $(MAKE) $(INSTALLPM): $(EXT).pm rm -f $@ cp $(EXT).pm $@ cd $(TOP); $(PERL) autosplit $(EXT) clean: -cd sdbm; $(MAKE) clean rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp realclean: clean -cd sdbm; $(MAKE) realclean rm -f makefile Makefile rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) rm -rf $(AUTO)/$(EXT) purge: realclean $(EXT).o : $(TOP)/EXTERN.h $(EXT).o : $(TOP)/perl.h $(EXT).o : $(TOP)/embed.h $(EXT).o : $(TOP)/config.h $(EXT).o : $(TOP)/unixish.h $(EXT).o : $(TOP)/handy.h $(EXT).o : $(TOP)/regexp.h $(EXT).o : $(TOP)/sv.h $(EXT).o : $(TOP)/util.h $(EXT).o : $(TOP)/form.h $(EXT).o : $(TOP)/gv.h $(EXT).o : $(TOP)/cv.h $(EXT).o : $(TOP)/opcode.h $(EXT).o : $(TOP)/op.h $(EXT).o : $(TOP)/cop.h $(EXT).o : $(TOP)/av.h $(EXT).o : $(TOP)/hv.h $(EXT).o : $(TOP)/mg.h $(EXT).o : $(TOP)/scope.h $(EXT).o : $(TOP)/pp.h $(EXT).o : $(TOP)/proto.h $(EXT).o : $(TOP)/XSUB.h Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH $(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH $(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH $(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH !NO!SUBS! chmod 644 Makefile $eunicefix Makefile SvGROW(ST(0), dstlen); strxfrm(SvPVX(ST(perl5.000/ext/SDBM_File/SDBM_File.pm 664 203 12 173 5626200013 11705 package SDBM_File; require TieHash; require DynaLoader; @ISA = qw(TieHash DynaLoader); bootstrap SDBM_File; 1; __END__ ind SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac 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 fi : Find absolute path name for TOP. Tperl5.000/ext/SDBM_File/SDBM_File.xs 664 203 12 2374 5630707603 11764 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "sdbm/sdbm.h" typedef DBM* SDBM_File; #define sdbm_TIEHASH(dbtype,filename,flags,mode) sdbm_open(filename,flags,mode) #define sdbm_FETCH(db,key) sdbm_fetch(db,key) #define sdbm_STORE(db,key,value,flags) sdbm_store(db,key,value,flags) #define sdbm_DELETE(db,key) sdbm_delete(db,key) #define sdbm_FIRSTKEY(db) sdbm_firstkey(db) #define sdbm_NEXTKEY(db,key) sdbm_nextkey(db) MODULE = SDBM_File PACKAGE = SDBM_File PREFIX = sdbm_ SDBM_File sdbm_TIEHASH(dbtype, filename, flags, mode) char * dbtype char * filename int flags int mode void sdbm_DESTROY(db) SDBM_File db CODE: sdbm_close(db); datum sdbm_FETCH(db, key) SDBM_File db datum key int sdbm_STORE(db, key, value, flags = DBM_REPLACE) SDBM_File db datum key datum value int flags CLEANUP: if (RETVAL) { if (RETVAL < 0 && errno == EPERM) croak("No write permission to sdbm file"); warn("sdbm store returned %d, errno %d, key \"%s\"", RETVAL,errno,key.dptr); sdbm_clearerr(db); } int sdbm_DELETE(db, key) SDBM_File db datum key datum sdbm_FIRSTKEY(db) SDBM_File db datum sdbm_NEXTKEY(db, key) SDBM_File db datum key int sdbm_error(db) SDBM_File db int sdbm_clearerr(db) SDBM_File db will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted : by putting a backslash in front. You may delete these commenperl5.000/ext/SDBM_File/sdbm/ 775 203 12 0 5650575671 10570 perl5.000/ext/SDBM_File/sdbm/CHANGES 664 203 12 1604 5514407351 11635 Changes from the earlier BETA releases. o dbm_prep does everything now, so dbm_open is just a simple wrapper that builds the default filenames. dbm_prep no longer requires a (DBM *) db parameter: it allocates one itself. It returns (DBM *) db or (DBM *) NULL. o makroom is now reliable. In the common-case optimization of the page split, the page into which the incoming key/value pair is to be inserted is write-deferred (if the split is successful), thereby saving a cosly write. BUT, if the split does not make enough room (unsuccessful), the deferred page is written out, as the failure-window is now dependent on the number of split attempts. o if -DDUFF is defined, hash function will also use the DUFF construct. This may look like a micro-performance tweak (maybe it is), but in fact, the hash function is the third most-heavily used function, after read and write. croak("No write permission to sdbm file"); warn("sdbm store returned %d, errno %d, key \"%s\"", RETVAL,errno,key.perl5.000/ext/SDBM_File/sdbm/COMPARE 664 203 12 5420 5514407351 11653 Script started on Thu Sep 28 15:41:06 1989 % uname -a titan titan 4_0 UMIPS mips % make all x-dbm cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c dbm.c cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c sdbm.c cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c pair.c cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c hash.c ar cr libsdbm.a sdbm.o pair.o hash.o ranlib libsdbm.a cc -o dbm dbm.o libsdbm.a cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c dba.c cc -o dba dba.o cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c dbd.c cc -o dbd dbd.o cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -o x-dbm dbm.o % % % wc history 65110 218344 3204883 history % % /bin/time dbm build foo Makefile <>Makefile <<'!NO!SUBS!' SHELL = /bin/sh CCCMD = `sh $(shellflags) $(TOP)/cflags $@` .c.o: $(CCCMD) $(CCCDLFLAGS) -I$(TOP) -DSDBM -DDUFF $*.c LIBOBJS = sdbm.o pair.o hash.o LIBSRCS = sdbm.c pair.c hash.c HDRS = tune.h sdbm.h pair.h $(TOP)/config.h all: libsdbm.a libsdbm.a: $(LIBOBJS) ar cr libsdbm.a $(LIBOBJS) $(RANLIB) libsdbm.a $(LIBOBJS): $(HDRS) lint: lint -abchx $(LIBSRCS) clean: rm -f *.o *.a mon.out core realclean: clean rm -f dbu libsdbm.a dbd dba dbe x-dbu *.dir *.pag rm -f makefile Makefile purge: realclean sdbm.o : sdbm.c $(TOP)/config.h sdbm.h tune.h pair.h hash.o : hash.c $(TOP)/config.h sdbm.h pair.o : pair.c $(TOP)/config.h sdbm.h tune.h pair.h !NO!SUBS! chmod 755 Makefile $eunicefix Makefile % % dba bar | tail #13347: ok. no entries. #13348: ok. no entries. #13349perl5.000/ext/SDBM_File/sdbm/README 664 203 12 26301 5514407352 11544 sdbm - Substitute DBM or Berkeley ndbm for Every UN*X[1] Made Simple Ozan (oz) Yigit The Guild of PD Software Toolmakers Toronto - Canada oz@nexus.yorku.ca Implementation is the sincerest form of flattery. - L. Peter Deutsch A The Clone of the ndbm library The sources accompanying this notice - sdbm - consti- tute the first public release (Dec. 1990) of a complete clone of the Berkeley UN*X ndbm library. The sdbm library is meant to clone the proven functionality of ndbm as closely as possible, including a few improvements. It is practical, easy to understand, and compatible. The sdbm library is not derived from any licensed, proprietary or copyrighted software. The sdbm implementation is based on a 1978 algorithm [Lar78] by P.-A. (Paul) Larson known as ``Dynamic Hashing''. In the course of searching for a substitute for ndbm, I pro- totyped three different external-hashing algorithms [Lar78, Fag79, Lit80] and ultimately chose Larson's algorithm as a basis of the sdbm implementation. The Bell Labs dbm (and therefore ndbm) is based on an algorithm invented by Ken Thompson, [Tho90, Tor87] and predates Larson's work. The sdbm programming interface is totally compatible with ndbm and includes a slight improvement in database ini- tialization. It is also expected to be binary-compatible under most UN*X versions that support the ndbm library. The sdbm implementation shares the shortcomings of the ndbm library, as a side effect of various simplifications to the original Larson algorithm. It does produce holes in the page file as it writes pages past the end of file. (Larson's paper include a clever solution to this problem that is a result of using the hash value directly as a block address.) On the other hand, extensive tests seem to indicate that sdbm creates fewer holes in general, and the resulting page- files are smaller. The sdbm implementation is also faster than ndbm in database creation. Unlike the ndbm, the sdbm _________________________ [1] UN*X is not a trademark of any (dis)organization. - 2 - store operation will not ``wander away'' trying to split its data pages to insert a datum that cannot (due to elaborate worst-case situations) be inserted. (It will fail after a pre-defined number of attempts.) Important Compatibility Warning The sdbm and ndbm libraries cannot share databases: one cannot read the (dir/pag) database created by the other. This is due to the differences between the ndbm and sdbm algorithms[2], and the hash functions used. It is easy to convert between the dbm/ndbm databases and sdbm by ignoring the index completely: see dbd, dbu etc. Notice of Intellectual Property The entire sdbm library package, as authored by me, Ozan S. Yigit, is hereby placed in the public domain. As such, the author is not responsible for the consequences of use of this software, no matter how awful, even if they arise from defects in it. There is no expressed or implied warranty for the sdbm library. Since the sdbm library package is in the public domain, this original release or any additional public-domain releases of the modified original cannot possibly (by defin- ition) be withheld from you. Also by definition, You (singu- lar) have all the rights to this code (including the right to sell without permission, the right to hoard[3] and the right to do other icky things as you see fit) but those rights are also granted to everyone else. Please note that all previous distributions of this software contained a copyright (which is now dropped) to protect its origins and its current public domain status against any possible claims and/or challenges. Acknowledgments Many people have been very helpful and supportive. A partial list would necessarily include Rayan Zacherissen (who contributed the man page, and also hacked a MMAP _________________________ [2] Torek's discussion [Tor87] indicates that dbm/ndbm implementations use the hash value to traverse the radix trie differently than sdbm and as a result, the page indexes are generated in different order. For more information, send e-mail to the author. [3] You cannot really hoard something that is avail- able to the public at large, but try if it makes you feel any better. - 3 - version of sdbm), Arnold Robbins, Chris Lewis, Bill David- sen, Henry Spencer, Geoff Collyer, Rich Salz (who got me started in the first place), Johannes Ruschein (who did the minix port) and David Tilbrook. I thank you all. Distribution Manifest and Notes This distribution of sdbm includes (at least) the following: CHANGES change log README this file. biblio a small bibliography on external hashing dba.c a crude (n/s)dbm page file analyzer dbd.c a crude (n/s)dbm page file dumper (for conversion) dbe.1 man page for dbe.c dbe.c Janick's database editor dbm.c a dbm library emulation wrapper for ndbm/sdbm dbm.h header file for the above dbu.c a crude db management utility hash.c hashing function makefile guess. pair.c page-level routines (posted earlier) pair.h header file for the above readme.ms troff source for the README file sdbm.3 man page sdbm.c the real thing sdbm.h header file for the above tune.h place for tuning & portability thingies util.c miscellaneous dbu is a simple database manipulation program[4] that tries to look like Bell Labs' cbt utility. It is currently incomplete in functionality. I use dbu to test out the rou- tines: it takes (from stdin) tab separated key/value pairs for commands like build or insert or takes keys for commands like delete or look. dbu dbmfile dba is a crude analyzer of dbm/sdbm/ndbm page files. It scans the entire page file, reporting page level statistics, and totals at the end. dbd is a crude dump program for dbm/ndbm/sdbm data- bases. It ignores the bitmap, and dumps the data pages in sequence. It can be used to create input for the dbu util- ity. Note that dbd will skip any NULLs in the key and data fields, thus is unsuitable to convert some peculiar _________________________ [4] The dbd, dba, dbu utilities are quick hacks and are not fit for production use. They were developed late one night, just to test out sdbm, and convert some databases. - 4 - databases that insist in including the terminating null. I have also included a copy of the dbe (ndbm DataBase Editor) by Janick Bergeron [janick@bnr.ca] for your pleas- ure. You may find it more useful than the little dbu util- ity. dbm.[ch] is a dbm library emulation on top of ndbm (and hence suitable for sdbm). Written by Robert Elz. The sdbm library has been around in beta test for quite a long time, and from whatever little feedback I received (maybe no news is good news), I believe it has been func- tioning without any significant problems. I would, of course, appreciate all fixes and/or improvements. Portabil- ity enhancements would especially be useful. Implementation Issues Hash functions: The algorithm behind sdbm implementa- tion needs a good bit-scrambling hash function to be effec- tive. I ran into a set of constants for a simple hash func- tion that seem to help sdbm perform better than ndbm for various inputs: /* * polynomial conversion ignoring overflows * 65599 nice. 65587 even better. */ long dbm_hash(char *str, int len) { register unsigned long n = 0; while (len--) n = n * 65599 + *str++; return n; } There may be better hash functions for the purposes of dynamic hashing. Try your favorite, and check the pagefile. If it contains too many pages with too many holes, (in rela- tion to this one for example) or if sdbm simply stops work- ing (fails after SPLTMAX attempts to split) when you feed your NEWS history file to it, you probably do not have a good hashing function. If you do better (for different types of input), I would like to know about the function you use. Block sizes: It seems (from various tests on a few machines) that a page file block size PBLKSIZ of 1024 is by far the best for performance, but this also happens to limit the size of a key/value pair. Depending on your needs, you may wish to increase the page size, and also adjust PAIRMAX (the maximum size of a key/value pair allowed: should always - 5 - be at least three words smaller than PBLKSIZ.) accordingly. The system-wide version of the library should probably be configured with 1024 (distribution default), as this appears to be sufficient for most common uses of sdbm. Portability This package has been tested in many different UN*Xes even including minix, and appears to be reasonably portable. This does not mean it will port easily to non-UN*X systems. Notes and Miscellaneous The sdbm is not a very complicated package, at least not after you familiarize yourself with the literature on external hashing. There are other interesting algorithms in existence that ensure (approximately) single-read access to a data value associated with any key. These are directory- less schemes such as linear hashing [Lit80] (+ Larson varia- tions), spiral storage [Mar79] or directory schemes such as extensible hashing [Fag79] by Fagin et al. I do hope these sources provide a reasonable playground for experimentation with other algorithms. See the June 1988 issue of ACM Com- puting Surveys [Enb88] for an excellent overview of the field. References [Lar78] P.-A. Larson, ``Dynamic Hashing'', BIT, vol. 18, pp. 184-201, 1978. [Tho90] Ken Thompson, private communication, Nov. 1990 [Lit80] W. Litwin, `` Linear Hashing: A new tool for file and table addressing'', Proceedings of the 6th Conference on Very Large Dabatases (Montreal), pp. 212-223, Very Large Database Foundation, Saratoga, Calif., 1980. [Fag79] R. Fagin, J. Nievergelt, N. Pippinger, and H. R. Strong, ``Extendible Hashing - A Fast Access Method for Dynamic Files'', ACM Trans. Database Syst., vol. 4, no.3, pp. 315-344, Sept. 1979. [Wal84] Rich Wales, ``Discussion of "dbm" data base system'', USENET newsgroup unix.wizards, Jan. 1984. [Tor87] Chris Torek, ``Re: dbm.a and ndbm.a archives'', - 6 - USENET newsgroup comp.unix, 1987. [Mar79] G. N. Martin, ``Spiral Storage: Incrementally Augment- able Hash Addressed Storage'', Technical Report #27, University of Varwick, Coventry, U.K., 1979. [Enb88] R. J. Enbody and H. C. Du, ``Dynamic Hashing Schemes'',ACM Computing Surveys, vol. 20, no. 2, pp. 85-113, June 1988. ct tm mytm; int len; mytm.tm_sec = sec; mytm.tm_min = min; mytm.tm_hour = hour; mytm.tm_mday = mday; mytm.tm_mon = mon; mytm.tm_year = year; mytm.tm_wday = wday; mytm.tm_yday = yday; mytm.tm_isdst = isdst; len = strftime(tmpbuf, sizeof tmpbuf, fmt, &mytm); STperl5.000/ext/SDBM_File/sdbm/README.too 664 203 12 525 5557314627 12315 This version of sdbm merely has all the dbm_* names translated to sdbm_* so that we can link ndbm and sdbm into the same executable. (It also has the bad() macro redefined to allow a zero-length key.) Fri Apr 15 10:15:30 EDT 1994. Additional portability/configuration changes for libsdbm by Andy Dougherty doughera@lafcol.lafayette.edu. tˆA readme.psˆ˜Asdbm.3t¨A sdbm.cp¸A sdbm.hmÈA tune.hmA util.cmeel any better. perl5.000/ext/SDBM_File/sdbm/biblio 664 203 12 1764 5514407352 12035 %A R. J. Enbody %A H. C. Du %T Dynamic Hashing Schemes %J ACM Computing Surveys %V 20 %N 2 %D June 1988 %P 85-113 %K surveys %A P.-A. Larson %T Dynamic Hashing %J BIT %V 18 %P 184-201 %D 1978 %K dynamic %A W. Litwin %T Linear Hashing: A new tool for file and table addressing %J Proceedings of the 6th Conference on Very Large Dabatases (Montreal) %I Very Large Database Foundation %C Saratoga, Calif. %P 212-223 %D 1980 %K linear %A R. Fagin %A J. Nievergelt %A N. Pippinger %A H. R. Strong %T Extendible Hashing - A Fast Access Method for Dynamic Files %J ACM Trans. Database Syst. %V 4 %N 3 %D Sept. 1979 %P 315-344 %K extend %A G. N. Martin %T Spiral Storage: Incrementally Augmentable Hash Addressed Storage %J Technical Report #27 %I University of Varwick %C Coventry, U.K. %D 1979 %K spiral %A Chris Torek %T Re: dbm.a and ndbm.a archives %B USENET newsgroup comp.unix %D 1987 %K torek %A Rich Wales %T Discusson of "dbm" data base system %B USENET newsgroup unix.wizards %D Jan. 1984 %K rich nalyzer perl5.000/ext/SDBM_File/sdbm/dba.c 664 203 12 2371 5514407352 11537 /* * dba dbm analysis/recovery */ #include #include #include "sdbm.h" char *progname; extern void oops(); int main(argc, argv) char **argv; { int n; char *p; char *name; int pagf; progname = argv[0]; if (p = argv[1]) { name = (char *) malloc((n = strlen(p)) + 5); strcpy(name, p); strcpy(name + n, ".pag"); if ((pagf = open(name, O_RDONLY)) < 0) oops("cannot open %s.", name); sdump(pagf); } else oops("usage: %s dbname", progname); return 0; } sdump(pagf) int pagf; { register b; register n = 0; register t = 0; register o = 0; register e; char pag[PBLKSIZ]; while ((b = read(pagf, pag, PBLKSIZ)) > 0) { printf("#%d: ", n); if (!okpage(pag)) printf("bad\n"); else { printf("ok. "); if (!(e = pagestat(pag))) o++; else t += e; } n++; } if (b == 0) printf("%d pages (%d holes): %d entries\n", n, o, t); else oops("read failed: block %d", n); } pagestat(pag) char *pag; { register n; register free; register short *ino = (short *) pag; if (!(n = ino[0])) printf("no entries.\n"); else { free = ino[n] - (n + 1) * sizeof(short); printf("%3d entries %2d%% used free %d.\n", n / 2, ((PBLKSIZ - free) * 100) / PBLKSIZ, free); } return n / 2; } u.c a crude db management utility hash.c hashing function makefile guess. pair.c page-level routines (posted earlier) pair.h header file for the above readme.ms troff source for the README file sdbm.3 man pagperl5.000/ext/SDBM_File/sdbm/dbd.c 664 203 12 3267 5514407353 11550 /* * dbd - dump a dbm data file */ #include #include #include "sdbm.h" char *progname; extern void oops(); #define empty(page) (((short *) page)[0] == 0) int main(argc, argv) char **argv; { int n; char *p; char *name; int pagf; progname = argv[0]; if (p = argv[1]) { name = (char *) malloc((n = strlen(p)) + 5); strcpy(name, p); strcpy(name + n, ".pag"); if ((pagf = open(name, O_RDONLY)) < 0) oops("cannot open %s.", name); sdump(pagf); } else oops("usage: %s dbname", progname); return 0; } sdump(pagf) int pagf; { register r; register n = 0; register o = 0; char pag[PBLKSIZ]; while ((r = read(pagf, pag, PBLKSIZ)) > 0) { if (!okpage(pag)) fprintf(stderr, "%d: bad page.\n", n); else if (empty(pag)) o++; else dispage(pag); n++; } if (r == 0) fprintf(stderr, "%d pages (%d holes).\n", n, o); else oops("read failed: block %d", n); } #ifdef OLD dispage(pag) char *pag; { register i, n; register off; register short *ino = (short *) pag; off = PBLKSIZ; for (i = 1; i < ino[0]; i += 2) { printf("\t[%d]: ", ino[i]); for (n = ino[i]; n < off; n++) putchar(pag[n]); putchar(' '); off = ino[i]; printf("[%d]: ", ino[i + 1]); for (n = ino[i + 1]; n < off; n++) putchar(pag[n]); off = ino[i + 1]; putchar('\n'); } } #else dispage(pag) char *pag; { register i, n; register off; register short *ino = (short *) pag; off = PBLKSIZ; for (i = 1; i < ino[0]; i += 2) { for (n = ino[i]; n < off; n++) if (pag[n] != 0) putchar(pag[n]); putchar('\t'); off = ino[i]; for (n = ino[i + 1]; n < off; n++) if (pag[n] != 0) putchar(pag[n]); putchar('\n'); off = ino[i + 1]; } } #endif database manipulation program[4] that tries to look like Bell Labs' cbt utility. It is currently incomplete in functionality. I use dbu to test out the rou- tines: it takes (from stdin) tab separated key/value pairs for commands like build or insert or takes keys for commands like delete or look. dbu [-m r|w|rw] [-crtvx] -a|-d|-f|-F|-s [ []] .SH DESCRIPTION \fIdbme\fP operates on ndbm(3) databases. It can be used to create them, look at them or change them. When specifying the value of a key or the content of its associated entry, \\nnn, \\0, \\n, \\t, \\f and \\r are interpreted as usual. When displaying key/content pairs, non-printable characters are displayed using the \\nnn notation. .SH OPTIONS .IP -a List all entries in the database. .IP -c Create the database if it does not exist. .IP -d Delete the entry associated with the specified key. .IP -f Fetch and display the entry associated with the specified key. .IP -F Fetch and display all the entries whose key match the specified regular-expression .IP "-m r|w|rw" Open the database in read-only, write-only or read-write mode .IP -r Replace the entry associated with the specified key if it already exists. See option -s. .IP -s Store an entry under a specific key. An error occurs if the key already exists and the option -r was not specified. .IP -t Re-initialize the database before executing the command. .IP -v Verbose mode. Confirm stores and deletions. .IP -x If option -x is used with option -c, then if the database already exists, an error occurs. This can be used to implement a simple exclusive access locking mechanism. .SH SEE ALSO ndbm(3) .SH AUTHOR janick@bnr.ca airs, non-printable characters are displayed using the \\nnn notation. .SH OPTIONSperl5.000/ext/SDBM_File/sdbm/dbe.c 664 203 12 23107 5514410164 11556 #include #ifndef VMS #include #include #else #include "file.h" #include "ndbm.h" #endif #include /***************************************************************************\ ** ** ** Function name: getopt() ** ** Author: Henry Spencer, UofT ** ** Coding date: 84/04/28 ** ** ** ** Description: ** ** ** ** Parses argv[] for arguments. ** ** Works with Whitesmith's C compiler. ** ** ** ** Inputs - The number of arguments ** ** - The base address of the array of arguments ** ** - A string listing the valid options (':' indicates an ** ** argument to the preceding option is required, a ';' ** ** indicates an argument to the preceding option is optional) ** ** ** ** Outputs - Returns the next option character, ** ** '?' for non '-' arguments ** ** or ':' when there is no more arguments. ** ** ** ** Side Effects + The argument to an option is pointed to by 'optarg' ** ** ** ***************************************************************************** ** ** ** REVISION HISTORY: ** ** ** ** DATE NAME DESCRIPTION ** ** YY/MM/DD ------------------ ------------------------------------ ** ** 88/10/20 Janick Bergeron Returns '?' on unamed arguments ** ** returns '!' on unknown options ** ** and 'EOF' only when exhausted. ** ** 88/11/18 Janick Bergeron Return ':' when no more arguments ** ** 89/08/11 Janick Bergeron Optional optarg when ';' in optstring ** ** ** \***************************************************************************/ char *optarg; /* Global argument pointer. */ #ifdef VMS #define index strchr #endif char getopt(argc, argv, optstring) int argc; char **argv; char *optstring; { register int c; register char *place; extern char *index(); static int optind = 0; static char *scan = NULL; optarg = NULL; if (scan == NULL || *scan == '\0') { if (optind == 0) optind++; if (optind >= argc) return ':'; optarg = place = argv[optind++]; if (place[0] != '-' || place[1] == '\0') return '?'; if (place[1] == '-' && place[2] == '\0') return '?'; scan = place + 1; } c = *scan++; place = index(optstring, c); if (place == NULL || c == ':' || c == ';') { (void) fprintf(stderr, "%s: unknown option %c\n", argv[0], c); scan = NULL; return '!'; } if (*++place == ':') { if (*scan != '\0') { optarg = scan; scan = NULL; } else { if (optind >= argc) { (void) fprintf(stderr, "%s: %c requires an argument\n", argv[0], c); return '!'; } optarg = argv[optind]; optind++; } } else if (*place == ';') { if (*scan != '\0') { optarg = scan; scan = NULL; } else { if (optind >= argc || *argv[optind] == '-') optarg = NULL; else { optarg = argv[optind]; optind++; } } } return c; } void print_datum(db) datum db; { int i; putchar('"'); for (i = 0; i < db.dsize; i++) { if (isprint(db.dptr[i])) putchar(db.dptr[i]); else { putchar('\\'); putchar('0' + ((db.dptr[i] >> 6) & 0x07)); putchar('0' + ((db.dptr[i] >> 3) & 0x07)); putchar('0' + (db.dptr[i] & 0x07)); } } putchar('"'); } datum read_datum(s) char *s; { datum db; char *p; int i; db.dsize = 0; db.dptr = (char *) malloc(strlen(s) * sizeof(char)); for (p = db.dptr; *s != '\0'; p++, db.dsize++, s++) { if (*s == '\\') { if (*++s == 'n') *p = '\n'; else if (*s == 'r') *p = '\r'; else if (*s == 'f') *p = '\f'; else if (*s == 't') *p = '\t'; else if (isdigit(*s) && isdigit(*(s + 1)) && isdigit(*(s + 2))) { i = (*s++ - '0') << 6; i |= (*s++ - '0') << 3; i |= *s - '0'; *p = i; } else if (*s == '0') *p = '\0'; else *p = *s; } else *p = *s; } return db; } char * key2s(db) datum db; { char *buf; char *p1, *p2; buf = (char *) malloc((db.dsize + 1) * sizeof(char)); for (p1 = buf, p2 = db.dptr; *p2 != '\0'; *p1++ = *p2++); *p1 = '\0'; return buf; } main(argc, argv) int argc; char **argv; { typedef enum { YOW, FETCH, STORE, DELETE, SCAN, REGEXP } commands; char opt; int flags; int giveusage = 0; int verbose = 0; commands what = YOW; char *comarg[3]; int st_flag = DBM_INSERT; int argn; DBM *db; datum key; datum content; flags = O_RDWR; argn = 0; while ((opt = getopt(argc, argv, "acdfFm:rstvx")) != ':') { switch (opt) { case 'a': what = SCAN; break; case 'c': flags |= O_CREAT; break; case 'd': what = DELETE; break; case 'f': what = FETCH; break; case 'F': what = REGEXP; break; case 'm': flags &= ~(000007); if (strcmp(optarg, "r") == 0) flags |= O_RDONLY; else if (strcmp(optarg, "w") == 0) flags |= O_WRONLY; else if (strcmp(optarg, "rw") == 0) flags |= O_RDWR; else { fprintf(stderr, "Invalid mode: \"%s\"\n", optarg); giveusage = 1; } break; case 'r': st_flag = DBM_REPLACE; break; case 's': what = STORE; break; case 't': flags |= O_TRUNC; break; case 'v': verbose = 1; break; case 'x': flags |= O_EXCL; break; case '!': giveusage = 1; break; case '?': if (argn < 3) comarg[argn++] = optarg; else { fprintf(stderr, "Too many arguments.\n"); giveusage = 1; } break; } } if (giveusage | what == YOW | argn < 1) { fprintf(stderr, "Usage: %s databse [-m r|w|rw] [-crtx] -a|-d|-f|-F|-s [key [content]]\n", argv[0]); exit(-1); } if ((db = dbm_open(comarg[0], flags, 0777)) == NULL) { fprintf(stderr, "Error opening database \"%s\"\n", comarg[0]); exit(-1); } if (argn > 1) key = read_datum(comarg[1]); if (argn > 2) content = read_datum(comarg[2]); switch (what) { case SCAN: key = dbm_firstkey(db); if (dbm_error(db)) { fprintf(stderr, "Error when fetching first key\n"); goto db_exit; } while (key.dptr != NULL) { content = dbm_fetch(db, key); if (dbm_error(db)) { fprintf(stderr, "Error when fetching "); print_datum(key); printf("\n"); goto db_exit; } print_datum(key); printf(": "); print_datum(content); printf("\n"); if (dbm_error(db)) { fprintf(stderr, "Error when fetching next key\n"); goto db_exit; } key = dbm_nextkey(db); } break; case REGEXP: if (argn < 2) { fprintf(stderr, "Missing regular expression.\n"); goto db_exit; } if (re_comp(comarg[1])) { fprintf(stderr, "Invalid regular expression\n"); goto db_exit; } key = dbm_firstkey(db); if (dbm_error(db)) { fprintf(stderr, "Error when fetching first key\n"); goto db_exit; } while (key.dptr != NULL) { if (re_exec(key2s(key))) { content = dbm_fetch(db, key); if (dbm_error(db)) { fprintf(stderr, "Error when fetching "); print_datum(key); printf("\n"); goto db_exit; } print_datum(key); printf(": "); print_datum(content); printf("\n"); if (dbm_error(db)) { fprintf(stderr, "Error when fetching next key\n"); goto db_exit; } } key = dbm_nextkey(db); } break; case FETCH: if (argn < 2) { fprintf(stderr, "Missing fetch key.\n"); goto db_exit; } content = dbm_fetch(db, key); if (dbm_error(db)) { fprintf(stderr, "Error when fetching "); print_datum(key); printf("\n"); goto db_exit; } if (content.dptr == NULL) { fprintf(stderr, "Cannot find "); print_datum(key); printf("\n"); goto db_exit; } print_datum(key); printf(": "); print_datum(content); printf("\n"); break; case DELETE: if (argn < 2) { fprintf(stderr, "Missing delete key.\n"); goto db_exit; } if (dbm_delete(db, key) || dbm_error(db)) { fprintf(stderr, "Error when deleting "); print_datum(key); printf("\n"); goto db_exit; } if (verbose) { print_datum(key); printf(": DELETED\n"); } break; case STORE: if (argn < 3) { fprintf(stderr, "Missing key and/or content.\n"); goto db_exit; } if (dbm_store(db, key, content, st_flag) || dbm_error(db)) { fprintf(stderr, "Error when storing "); print_datum(key); printf("\n"); goto db_exit; } if (verbose) { print_datum(key); printf(": "); print_datum(content); printf(" STORED\n"); } break; } db_exit: dbm_clearerr(db); dbm_close(db); if (dbm_error(db)) { fprintf(stderr, "Error closing database \"%s\"\n", comarg[0]); exit(-1); } } ** ** 88/11/18 Janick Bergeron Return ':' when no more arguments ** ** 89/08/11 Janick Bergeron Optional optarg when ';' in optstring ** ** ** \***************************************************************************/ char *optarg; /* Global argument pointer. */ #ifdef VMS #define index strchr #endif char getopt(argc, argv, optperl5.000/ext/SDBM_File/sdbm/dbm.c 664 203 12 4572 5514407354 11562 /* * Copyright (c) 1985 The Regents of the University of California. * All rights reserved. * * Redistribution and use in source and binary forms are permitted * provided that the above copyright notice and this paragraph are * duplicated in all such forms and that any documentation, * advertising materials, and other materials related to such * distribution and use acknowledge that the software was developed * by the University of California, Berkeley. The name of the * University may not be used to endorse or promote products derived * from this software without specific prior written permission. * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. */ #ifndef lint static char sccsid[] = "@(#)dbm.c 5.4 (Berkeley) 5/24/89"; #endif /* not lint */ #include "dbm.h" #define NODB ((DBM *)0) static DBM *cur_db = NODB; static char no_db[] = "dbm: no open database\n"; dbminit(file) char *file; { if (cur_db != NODB) dbm_close(cur_db); cur_db = dbm_open(file, 2, 0); if (cur_db == NODB) { cur_db = dbm_open(file, 0, 0); if (cur_db == NODB) return (-1); } return (0); } long forder(key) datum key; { if (cur_db == NODB) { printf(no_db); return (0L); } return (dbm_forder(cur_db, key)); } datum fetch(key) datum key; { datum item; if (cur_db == NODB) { printf(no_db); item.dptr = 0; return (item); } return (dbm_fetch(cur_db, key)); } delete(key) datum key; { if (cur_db == NODB) { printf(no_db); return (-1); } if (dbm_rdonly(cur_db)) return (-1); return (dbm_delete(cur_db, key)); } store(key, dat) datum key, dat; { if (cur_db == NODB) { printf(no_db); return (-1); } if (dbm_rdonly(cur_db)) return (-1); return (dbm_store(cur_db, key, dat, DBM_REPLACE)); } datum firstkey() { datum item; if (cur_db == NODB) { printf(no_db); item.dptr = 0; return (item); } return (dbm_firstkey(cur_db)); } datum nextkey(key) datum key; { datum item; if (cur_db == NODB) { printf(no_db); item.dptr = 0; return (item); } return (dbm_nextkey(cur_db, key)); } datum(content); printf(" STORED\n"); } break; } db_exit: dbm_clearerr(db); dbm_close(db); if (dbm_error(db)) { fprintf(sperl5.000/ext/SDBM_File/sdbm/dbm.h 664 203 12 2270 5557314627 11567 /* * Copyright (c) 1983 The Regents of the University of California. * All rights reserved. * * Redistribution and use in source and binary forms are permitted * provided that the above copyright notice and this paragraph are * duplicated in all such forms and that any documentation, * advertising materials, and other materials related to such * distribution and use acknowledge that the software was developed * by the University of California, Berkeley. The name of the * University may not be used to endorse or promote products derived * from this software without specific prior written permission. * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. * * @(#)dbm.h 5.2 (Berkeley) 5/24/89 */ #ifndef NULL /* * this is lunacy, we no longer use it (and never should have * unconditionally defined it), but, this whole file is for * backwards compatability - someone may rely on this. */ #define NULL ((char *) 0) #endif #ifdef I_NDBM # include #endif datum fetch(); datum firstkey(); datum nextkey(); ur_db = dbm_open(file, 0, 0); if (cur_db == NODB) return (-1); } return (0); } long forder(key) datum key; { if (cur_db == NODB) { printf(no_db); return (0L); } return (dbm_forder(cur_db, key)); } datum fetch(key) datum key; { datum item; if (cur_db == NODB) { perl5.000/ext/SDBM_File/sdbm/dbu.c 664 203 12 10470 5514407355 11605 #include #include #ifdef SDBM #include "sdbm.h" #else #include #endif #include #ifdef BSD42 #define strchr index #endif extern int getopt(); extern char *strchr(); extern void oops(); char *progname; static int rflag; static char *usage = "%s [-R] cat | look |... dbmname"; #define DERROR 0 #define DLOOK 1 #define DINSERT 2 #define DDELETE 3 #define DCAT 4 #define DBUILD 5 #define DPRESS 6 #define DCREAT 7 #define LINEMAX 8192 typedef struct { char *sname; int scode; int flags; } cmd; static cmd cmds[] = { "fetch", DLOOK, O_RDONLY, "get", DLOOK, O_RDONLY, "look", DLOOK, O_RDONLY, "add", DINSERT, O_RDWR, "insert", DINSERT, O_RDWR, "store", DINSERT, O_RDWR, "delete", DDELETE, O_RDWR, "remove", DDELETE, O_RDWR, "dump", DCAT, O_RDONLY, "list", DCAT, O_RDONLY, "cat", DCAT, O_RDONLY, "creat", DCREAT, O_RDWR | O_CREAT | O_TRUNC, "new", DCREAT, O_RDWR | O_CREAT | O_TRUNC, "build", DBUILD, O_RDWR | O_CREAT, "squash", DPRESS, O_RDWR, "compact", DPRESS, O_RDWR, "compress", DPRESS, O_RDWR }; #define CTABSIZ (sizeof (cmds)/sizeof (cmd)) static cmd *parse(); static void badk(), doit(), prdatum(); int main(argc, argv) int argc; char *argv[]; { int c; register cmd *act; extern int optind; extern char *optarg; progname = argv[0]; while ((c = getopt(argc, argv, "R")) != EOF) switch (c) { case 'R': /* raw processing */ rflag++; break; default: oops("usage: %s", usage); break; } if ((argc -= optind) < 2) oops("usage: %s", usage); if ((act = parse(argv[optind])) == NULL) badk(argv[optind]); optind++; doit(act, argv[optind]); return 0; } static void doit(act, file) register cmd *act; char *file; { datum key; datum val; register DBM *db; register char *op; register int n; char *line; #ifdef TIME long start; extern long time(); #endif if ((db = dbm_open(file, act->flags, 0644)) == NULL) oops("cannot open: %s", file); if ((line = (char *) malloc(LINEMAX)) == NULL) oops("%s: cannot get memory", "line alloc"); switch (act->scode) { case DLOOK: while (fgets(line, LINEMAX, stdin) != NULL) { n = strlen(line) - 1; line[n] = 0; key.dptr = line; key.dsize = n; val = dbm_fetch(db, key); if (val.dptr != NULL) { prdatum(stdout, val); putchar('\n'); continue; } prdatum(stderr, key); fprintf(stderr, ": not found.\n"); } break; case DINSERT: break; case DDELETE: while (fgets(line, LINEMAX, stdin) != NULL) { n = strlen(line) - 1; line[n] = 0; key.dptr = line; key.dsize = n; if (dbm_delete(db, key) == -1) { prdatum(stderr, key); fprintf(stderr, ": not found.\n"); } } break; case DCAT: for (key = dbm_firstkey(db); key.dptr != 0; key = dbm_nextkey(db)) { prdatum(stdout, key); putchar('\t'); prdatum(stdout, dbm_fetch(db, key)); putchar('\n'); } break; case DBUILD: #ifdef TIME start = time(0); #endif while (fgets(line, LINEMAX, stdin) != NULL) { n = strlen(line) - 1; line[n] = 0; key.dptr = line; if ((op = strchr(line, '\t')) != 0) { key.dsize = op - line; *op++ = 0; val.dptr = op; val.dsize = line + n - op; } else oops("bad input; %s", line); if (dbm_store(db, key, val, DBM_REPLACE) < 0) { prdatum(stderr, key); fprintf(stderr, ": "); oops("store: %s", "failed"); } } #ifdef TIME printf("done: %d seconds.\n", time(0) - start); #endif break; case DPRESS: break; case DCREAT: break; } dbm_close(db); } static void badk(word) char *word; { register int i; if (progname) fprintf(stderr, "%s: ", progname); fprintf(stderr, "bad keywd %s. use one of\n", word); for (i = 0; i < (int)CTABSIZ; i++) fprintf(stderr, "%-8s%c", cmds[i].sname, ((i + 1) % 6 == 0) ? '\n' : ' '); fprintf(stderr, "\n"); exit(1); /*NOTREACHED*/ } static cmd * parse(str) register char *str; { register int i = CTABSIZ; register cmd *p; for (p = cmds; i--; p++) if (strcmp(p->sname, str) == 0) return p; return NULL; } static void prdatum(stream, d) FILE *stream; datum d; { register int c; register char *p = d.dptr; register int n = d.dsize; while (n--) { c = *p++ & 0377; if (c & 0200) { fprintf(stream, "M-"); c &= 0177; } if (c == 0177 || c < ' ') fprintf(stream, "^%c", (c == 0177) ? '?' : c + '@'); else putc(c, stream); } } ('\\'); putchar('0' + ((db.dptr[i] >> 6) & 0x07)); putchar('0' + ((db.dptr[i] >> 3) & 0x07)); putchar('0' + (db.dptr[i] & 0x07)); } } putchar('"'); } datum read_datum(s) char *s; { datperl5.000/ext/SDBM_File/sdbm/grind 775 203 12 311 5514407355 11651 #!/bin/sh rm -f /tmp/*.dir /tmp/*.pag awk -e '{ printf "%s\t", $0 for (i = 0; i < 40; i++) printf "%s.", $0 printf "\n" }' < /usr/dict/words | $1 build /tmp/$2 3ˆ¨A sdbm.cˆ¸A sdbm.hˆÈA tune.hˆA util.cˆ= "%s [-R] cat | look |... dbmname"; #define DERROR 0 #define DLOOK 1 #define DINSERT 2 #define DDELETE 3 #define DCAT 4 #define DBUILD 5 #define DPRESS 6 #define DCREAT 7 #define LINEMAX 8192 typedef struct { char *sname; perl5.000/ext/SDBM_File/sdbm/hash.c 664 203 12 1657 5557314627 11753 /* * sdbm - ndbm work-alike hashed database library * based on Per-Aake Larson's Dynamic Hashing algorithms. BIT 18 (1978). * author: oz@nexus.yorku.ca * status: public domain. keep it that way. * * hashing routine */ #include "config.h" #include "sdbm.h" /* * polynomial conversion ignoring overflows * [this seems to work remarkably well, in fact better * then the ndbm hash function. Replace at your own risk] * use: 65599 nice. * 65587 even better. */ long sdbm_hash(str, len) register char *str; register int len; { register unsigned long n = 0; #ifdef DUFF #define HASHC n = *str++ + 65599 * n if (len > 0) { register int loop = (len + 8 - 1) >> 3; switch(len & (8 - 1)) { case 0: do { HASHC; case 7: HASHC; case 6: HASHC; case 5: HASHC; case 4: HASHC; case 3: HASHC; case 2: HASHC; case 1: HASHC; } while (--loop); } } #else while (len--) n = *str++ + 65599 * n; #endif return n; } O_TRUNC, "build", DBUILD, O_RDWR | O_CREAT, "squash", DPRESS, O_RDWR, "compacperl5.000/ext/SDBM_File/sdbm/linux.patches 644 203 12 2636 5514407431 13355 *** sdbm.dist/./dbu.c Mon Feb 17 21:18:52 1992 --- sdbm/./dbu.c Mon Feb 17 21:11:20 1992 *************** *** 12,18 **** #endif extern int getopt(); ! extern char *strchr(); extern void oops(); char *progname; --- 12,18 ---- #endif extern int getopt(); ! /* extern char *strchr(); */ extern void oops(); char *progname; *** sdbm.dist/./makefile Mon Feb 17 21:18:56 1992 --- sdbm/./makefile Mon Feb 17 21:10:46 1992 *************** *** 2,8 **** # makefile for public domain ndbm-clone: sdbm # DUFF: use duff's device (loop unroll) in parts of the code # ! CFLAGS = -O -DSDBM -DDUFF -DBSD42 #LDFLAGS = -p OBJS = sdbm.o pair.o hash.o --- 2,8 ---- # makefile for public domain ndbm-clone: sdbm # DUFF: use duff's device (loop unroll) in parts of the code # ! CFLAGS = -O -DSDBM -DDUFF #LDFLAGS = -p OBJS = sdbm.o pair.o hash.o *** sdbm.dist/./sdbm.c Mon Feb 17 21:19:17 1992 --- sdbm/./sdbm.c Mon Feb 17 21:12:59 1992 *************** *** 25,30 **** --- 25,31 ---- #endif #include #include + #include #ifdef __STDC__ #include *************** *** 43,49 **** extern char *malloc proto((unsigned int)); extern void free proto((void *)); ! extern long lseek(); /* * forward --- 44,50 ---- extern char *malloc proto((unsigned int)); extern void free proto((void *)); ! /* extern long lseek(); */ /* * forward break; default: oops("usage: %s", usage); break; } if ((argc -= optind) < 2) oopsperl5.000/ext/SDBM_File/sdbm/makefile.sdbm 664 203 12 2200 5557314627 13271 # # makefile for public domain ndbm-clone: sdbm # DUFF: use duff's device (loop unroll) in parts of the code # CFLAGS = -O -DSDBM -DDUFF -DBSD42 -pic #LDFLAGS = -p OBJS = sdbm.o pair.o hash.o SRCS = sdbm.c pair.c hash.c dbu.c dba.c dbd.c util.c HDRS = tune.h sdbm.h pair.h MISC = README CHANGES COMPARE sdbm.3 dbe.c dbe.1 dbm.c dbm.h biblio \ readme.ms readme.ps all: dbu dba dbd dbe dbu: dbu.o sdbm util.o cc $(LDFLAGS) -o dbu dbu.o util.o libsdbm.a dba: dba.o util.o cc $(LDFLAGS) -o dba dba.o util.o dbd: dbd.o util.o cc $(LDFLAGS) -o dbd dbd.o util.o dbe: dbe.o sdbm cc $(LDFLAGS) -o dbe dbe.o libsdbm.a sdbm: $(OBJS) ar cr libsdbm.a $(OBJS) ranlib libsdbm.a ### cp libsdbm.a /usr/lib/libsdbm.a dba.o: sdbm.h dbu.o: sdbm.h util.o:sdbm.h $(OBJS): sdbm.h tune.h pair.h # # dbu using berkelezoid ndbm routines [if you have them] for testing # #x-dbu: dbu.o util.o # cc $(CFLAGS) -o x-dbu dbu.o util.o lint: lint -abchx $(SRCS) clean: rm -f *.o mon.out core purge: clean rm -f dbu libsdbm.a dbd dba dbe x-dbu *.dir *.pag shar: shar $(MISC) makefile $(SRCS) $(HDRS) >SDBM.SHAR readme: nroff -ms readme.ms | col -b >README ,49 **** extern char *malloc proto((unsigned int)); extern void free proto((void *)); ! extern long lseek(); /* * forward --- 44,50 ---- extern char *malloc proto((unsigned int)); extern void free proto((void *)); ! /* extern long lseek(); */ /* * forward break; default: oops("usage: %s", usage); break; } if ((argc -= optind) < 2) oopsperl5.000/ext/SDBM_File/sdbm/pair.c 664 203 12 13137 5647030702 11764 /* * sdbm - ndbm work-alike hashed database library * based on Per-Aake Larson's Dynamic Hashing algorithms. BIT 18 (1978). * author: oz@nexus.yorku.ca * status: public domain. * * page-level routines */ #ifndef lint static char rcsid[] = "$Id: pair.c,v 1.10 90/12/13 13:00:35 oz Exp $"; #endif #include "config.h" #include "sdbm.h" #include "tune.h" #include "pair.h" #define exhash(item) sdbm_hash((item).dptr, (item).dsize) /* * forward */ static int seepair proto((char *, int, char *, int)); /* * page format: * +------------------------------+ * ino | n | keyoff | datoff | keyoff | * +------------+--------+--------+ * | datoff | - - - ----> | * +--------+---------------------+ * | F R E E A R E A | * +--------------+---------------+ * | <---- - - - | data | * +--------+-----+----+----------+ * | key | data | key | * +--------+----------+----------+ * * calculating the offsets for free area: if the number * of entries (ino[0]) is zero, the offset to the END of * the free area is the block size. Otherwise, it is the * nth (ino[ino[0]]) entry's offset. */ int fitpair(pag, need) char *pag; int need; { register int n; register int off; register int free; register short *ino = (short *) pag; off = ((n = ino[0]) > 0) ? ino[n] : PBLKSIZ; free = off - (n + 1) * sizeof(short); need += 2 * sizeof(short); debug(("free %d need %d\n", free, need)); return need <= free; } void putpair(pag, key, val) char *pag; datum key; datum val; { register int n; register int off; register short *ino = (short *) pag; off = ((n = ino[0]) > 0) ? ino[n] : PBLKSIZ; /* * enter the key first */ off -= key.dsize; (void) memcpy(pag + off, key.dptr, key.dsize); ino[n + 1] = off; /* * now the data */ off -= val.dsize; (void) memcpy(pag + off, val.dptr, val.dsize); ino[n + 2] = off; /* * adjust item count */ ino[0] += 2; } datum getpair(pag, key) char *pag; datum key; { register int i; register int n; datum val; register short *ino = (short *) pag; if ((n = ino[0]) == 0) return nullitem; if ((i = seepair(pag, n, key.dptr, key.dsize)) == 0) return nullitem; val.dptr = pag + ino[i + 1]; val.dsize = ino[i] - ino[i + 1]; return val; } #ifdef SEEDUPS int duppair(pag, key) char *pag; datum key; { register short *ino = (short *) pag; return ino[0] > 0 && seepair(pag, ino[0], key.dptr, key.dsize) > 0; } #endif datum getnkey(pag, num) char *pag; int num; { datum key; register int off; register short *ino = (short *) pag; num = num * 2 - 1; if (ino[0] == 0 || num > ino[0]) return nullitem; off = (num > 1) ? ino[num - 1] : PBLKSIZ; key.dptr = pag + ino[num]; key.dsize = off - ino[num]; return key; } int delpair(pag, key) char *pag; datum key; { register int n; register int i; register short *ino = (short *) pag; if ((n = ino[0]) == 0) return 0; if ((i = seepair(pag, n, key.dptr, key.dsize)) == 0) return 0; /* * found the key. if it is the last entry * [i.e. i == n - 1] we just adjust the entry count. * hard case: move all data down onto the deleted pair, * shift offsets onto deleted offsets, and adjust them. * [note: 0 < i < n] */ if (i < n - 1) { register int m; register char *dst = pag + (i == 1 ? PBLKSIZ : ino[i - 1]); register char *src = pag + ino[i + 1]; register int zoo = dst - src; debug(("free-up %d ", zoo)); /* * shift data/keys down */ m = ino[i + 1] - ino[n]; #ifdef DUFF #define MOVB *--dst = *--src if (m > 0) { register int loop = (m + 8 - 1) >> 3; switch (m & (8 - 1)) { case 0: do { MOVB; case 7: MOVB; case 6: MOVB; case 5: MOVB; case 4: MOVB; case 3: MOVB; case 2: MOVB; case 1: MOVB; } while (--loop); } } #else #ifdef HAS_MEMMOVE dst -= m; src -= m; memmove(dst, src, m); #else while (m--) *--dst = *--src; #endif #endif /* * adjust offset index up */ while (i < n - 1) { ino[i] = ino[i + 2] + zoo; i++; } } ino[0] -= 2; return 1; } /* * search for the key in the page. * return offset index in the range 0 < i < n. * return 0 if not found. */ static int seepair(pag, n, key, siz) char *pag; register int n; register char *key; register int siz; { register int i; register int off = PBLKSIZ; register short *ino = (short *) pag; for (i = 1; i < n; i += 2) { if (siz == off - ino[i] && memcmp(key, pag + ino[i], siz) == 0) return i; off = ino[i + 1]; } return 0; } void splpage(pag, new, sbit) char *pag; char *new; long sbit; { datum key; datum val; register int n; register int off = PBLKSIZ; char cur[PBLKSIZ]; register short *ino = (short *) cur; (void) memcpy(cur, pag, PBLKSIZ); (void) memset(pag, 0, PBLKSIZ); (void) memset(new, 0, PBLKSIZ); n = ino[0]; for (ino++; n > 0; ino += 2) { key.dptr = cur + ino[0]; key.dsize = off - ino[0]; val.dptr = cur + ino[1]; val.dsize = ino[0] - ino[1]; /* * select the page pointer (by looking at sbit) and insert */ (void) putpair((exhash(key) & sbit) ? new : pag, key, val); off = ino[1]; n -= 2; } debug(("%d split %d/%d\n", ((short *) cur)[0] / 2, ((short *) new)[0] / 2, ((short *) pag)[0] / 2)); } /* * check page sanity: * number of entries should be something * reasonable, and all offsets in the index should be in order. * this could be made more rigorous. */ int chkpage(pag) char *pag; { register int n; register int off; register short *ino = (short *) pag; if ((n = ino[0]) < 0 || n > PBLKSIZ / sizeof(short)) return 0; if (n > 0) { off = PBLKSIZ; for (ino++; n > 0; ino += 2) { if (ino[0] > off || ino[1] > off || ino[1] > ino[0]) return 0; off = ino[1]; n -= 2; } } return 1; } ino[n] : PBLKSIZ; /* * enter the key first */ off -= key.dsize; (void) memcpy(pag + off, key.dptr, key.dsize); ino[n + 1] = off; /* * now the data */ off -= val.dsize; (void) memcpy(pag + off, val.dptr, val.dsize); ino[n + 2] = off; /* * adjust item count */ ino[0] += 2; } datum getpair(pag, key) char *pag; datum key; { register int i; register int n; datum val; register short *ino = (short *) pperl5.000/ext/SDBM_File/sdbm/pair.h 664 203 12 572 5514407356 11736 extern int fitpair proto((char *, int)); extern void putpair proto((char *, datum, datum)); extern datum getpair proto((char *, datum)); extern int delpair proto((char *, datum)); extern int chkpage proto((char *)); extern datum getnkey proto((char *, int)); extern void splpage proto((char *, char *, long)); #ifdef SEEDUPS extern int duppair proto((char *, datum)); #endif , new, sbit) char *pag; char *new; long sbit; { datum key; datum val; register int n; register int off = PBLKSIZ; char cur[PBLKSperl5.000/ext/SDBM_File/sdbm/readme.ms 664 203 12 26653 5514407357 12501 .\" tbl | readme.ms | [tn]roff -ms | ... .\" note the "C" (courier) and "CB" fonts: you will probably have to .\" change these. .\" $Id: readme.ms,v 1.1 90/12/13 13:09:15 oz Exp Locker: oz $ .de P1 .br .nr dT 4 .nf .ft C .sp .5 .nr t \\n(dT*\\w'x'u .ta 1u*\\ntu 2u*\\ntu 3u*\\ntu 4u*\\ntu 5u*\\ntu 6u*\\ntu 7u*\\ntu 8u*\\ntu 9u*\\ntu 10u*\\ntu 11u*\\ntu 12u*\\ntu 13u*\\ntu 14u*\\ntu .. .de P2 .br .ft 1 .br .sp .5 .br .fi .. .\" CW uses the typewriter/courier font. .de CW \fC\\$1\\fP\\$2 .. .\" Footnote numbering [by Henry Spencer] .\" \*f for a footnote number.. .\" .FS .\" \*F .\" .FE .\" .ds f \\u\\s-2\\n+f\\s+2\\d .nr f 0 1 .ds F \\n+F. .nr F 0 1 .ND .LP .TL \fIsdbm\fP \(em Substitute DBM .br or .br Berkeley \fIndbm\fP for Every UN*X\** Made Simple .AU Ozan (oz) Yigit .AI The Guild of PD Software Toolmakers Toronto - Canada .sp oz@nexus.yorku.ca .LP .FS UN*X is not a trademark of any (dis)organization. .FE .sp 2 \fIImplementation is the sincerest form of flattery. \(em L. Peter Deutsch\fP .SH A The Clone of the \fIndbm\fP library .PP The sources accompanying this notice \(em \fIsdbm\fP \(em constitute the first public release (Dec. 1990) of a complete clone of the Berkeley UN*X \fIndbm\fP library. The \fIsdbm\fP library is meant to clone the proven functionality of \fIndbm\fP as closely as possible, including a few improvements. It is practical, easy to understand, and compatible. The \fIsdbm\fP library is not derived from any licensed, proprietary or copyrighted software. .PP The \fIsdbm\fP implementation is based on a 1978 algorithm [Lar78] by P.-A. (Paul) Larson known as ``Dynamic Hashing''. In the course of searching for a substitute for \fIndbm\fP, I prototyped three different external-hashing algorithms [Lar78, Fag79, Lit80] and ultimately chose Larson's algorithm as a basis of the \fIsdbm\fP implementation. The Bell Labs \fIdbm\fP (and therefore \fIndbm\fP) is based on an algorithm invented by Ken Thompson, [Tho90, Tor87] and predates Larson's work. .PP The \fIsdbm\fR programming interface is totally compatible with \fIndbm\fP and includes a slight improvement in database initialization. It is also expected to be binary-compatible under most UN*X versions that support the \fIndbm\fP library. .PP The \fIsdbm\fP implementation shares the shortcomings of the \fIndbm\fP library, as a side effect of various simplifications to the original Larson algorithm. It does produce \fIholes\fP in the page file as it writes pages past the end of file. (Larson's paper include a clever solution to this problem that is a result of using the hash value directly as a block address.) On the other hand, extensive tests seem to indicate that \fIsdbm\fP creates fewer holes in general, and the resulting pagefiles are smaller. The \fIsdbm\fP implementation is also faster than \fIndbm\fP in database creation. Unlike the \fIndbm\fP, the \fIsdbm\fP .CW store operation will not ``wander away'' trying to split its data pages to insert a datum that \fIcannot\fP (due to elaborate worst-case situations) be inserted. (It will fail after a pre-defined number of attempts.) .SH Important Compatibility Warning .PP The \fIsdbm\fP and \fIndbm\fP libraries \fIcannot\fP share databases: one cannot read the (dir/pag) database created by the other. This is due to the differences between the \fIndbm\fP and \fIsdbm\fP algorithms\**, .FS Torek's discussion [Tor87] indicates that \fIdbm/ndbm\fP implementations use the hash value to traverse the radix trie differently than \fIsdbm\fP and as a result, the page indexes are generated in \fIdifferent\fP order. For more information, send e-mail to the author. .FE and the hash functions used. It is easy to convert between the \fIdbm/ndbm\fP databases and \fIsdbm\fP by ignoring the index completely: see .CW dbd , .CW dbu etc. .R .LP .SH Notice of Intellectual Property .LP \fIThe entire\fP sdbm \fIlibrary package, as authored by me,\fP Ozan S. Yigit, \fIis hereby placed in the public domain.\fP As such, the author is not responsible for the consequences of use of this software, no matter how awful, even if they arise from defects in it. There is no expressed or implied warranty for the \fIsdbm\fP library. .PP Since the \fIsdbm\fP library package is in the public domain, this \fIoriginal\fP release or any additional public-domain releases of the modified original cannot possibly (by definition) be withheld from you. Also by definition, You (singular) have all the rights to this code (including the right to sell without permission, the right to hoard\** .FS You cannot really hoard something that is available to the public at large, but try if it makes you feel any better. .FE and the right to do other icky things as you see fit) but those rights are also granted to everyone else. .PP Please note that all previous distributions of this software contained a copyright (which is now dropped) to protect its origins and its current public domain status against any possible claims and/or challenges. .SH Acknowledgments .PP Many people have been very helpful and supportive. A partial list would necessarily include Rayan Zacherissen (who contributed the man page, and also hacked a MMAP version of \fIsdbm\fP), Arnold Robbins, Chris Lewis, Bill Davidsen, Henry Spencer, Geoff Collyer, Rich Salz (who got me started in the first place), Johannes Ruschein (who did the minix port) and David Tilbrook. I thank you all. .SH Distribution Manifest and Notes .LP This distribution of \fIsdbm\fP includes (at least) the following: .P1 CHANGES change log README this file. biblio a small bibliography on external hashing dba.c a crude (n/s)dbm page file analyzer dbd.c a crude (n/s)dbm page file dumper (for conversion) dbe.1 man page for dbe.c dbe.c Janick's database editor dbm.c a dbm library emulation wrapper for ndbm/sdbm dbm.h header file for the above dbu.c a crude db management utility hash.c hashing function makefile guess. pair.c page-level routines (posted earlier) pair.h header file for the above readme.ms troff source for the README file sdbm.3 man page sdbm.c the real thing sdbm.h header file for the above tune.h place for tuning & portability thingies util.c miscellaneous .P2 .PP .CW dbu is a simple database manipulation program\** that tries to look .FS The .CW dbd , .CW dba , .CW dbu utilities are quick hacks and are not fit for production use. They were developed late one night, just to test out \fIsdbm\fP, and convert some databases. .FE like Bell Labs' .CW cbt utility. It is currently incomplete in functionality. I use .CW dbu to test out the routines: it takes (from stdin) tab separated key/value pairs for commands like .CW build or .CW insert or takes keys for commands like .CW delete or .CW look . .P1 dbu dbmfile .P2 .PP .CW dba is a crude analyzer of \fIdbm/sdbm/ndbm\fP page files. It scans the entire page file, reporting page level statistics, and totals at the end. .PP .CW dbd is a crude dump program for \fIdbm/ndbm/sdbm\fP databases. It ignores the bitmap, and dumps the data pages in sequence. It can be used to create input for the .CW dbu utility. Note that .CW dbd will skip any NULLs in the key and data fields, thus is unsuitable to convert some peculiar databases that insist in including the terminating null. .PP I have also included a copy of the .CW dbe (\fIndbm\fP DataBase Editor) by Janick Bergeron [janick@bnr.ca] for your pleasure. You may find it more useful than the little .CW dbu utility. .PP .CW dbm.[ch] is a \fIdbm\fP library emulation on top of \fIndbm\fP (and hence suitable for \fIsdbm\fP). Written by Robert Elz. .PP The \fIsdbm\fP library has been around in beta test for quite a long time, and from whatever little feedback I received (maybe no news is good news), I believe it has been functioning without any significant problems. I would, of course, appreciate all fixes and/or improvements. Portability enhancements would especially be useful. .SH Implementation Issues .PP Hash functions: The algorithm behind \fIsdbm\fP implementation needs a good bit-scrambling hash function to be effective. I ran into a set of constants for a simple hash function that seem to help \fIsdbm\fP perform better than \fIndbm\fP for various inputs: .P1 /* * polynomial conversion ignoring overflows * 65599 nice. 65587 even better. */ long dbm_hash(char *str, int len) { register unsigned long n = 0; while (len--) n = n * 65599 + *str++; return n; } .P2 .PP There may be better hash functions for the purposes of dynamic hashing. Try your favorite, and check the pagefile. If it contains too many pages with too many holes, (in relation to this one for example) or if \fIsdbm\fP simply stops working (fails after .CW SPLTMAX attempts to split) when you feed your NEWS .CW history file to it, you probably do not have a good hashing function. If you do better (for different types of input), I would like to know about the function you use. .PP Block sizes: It seems (from various tests on a few machines) that a page file block size .CW PBLKSIZ of 1024 is by far the best for performance, but this also happens to limit the size of a key/value pair. Depending on your needs, you may wish to increase the page size, and also adjust .CW PAIRMAX (the maximum size of a key/value pair allowed: should always be at least three words smaller than .CW PBLKSIZ .) accordingly. The system-wide version of the library should probably be configured with 1024 (distribution default), as this appears to be sufficient for most common uses of \fIsdbm\fP. .SH Portability .PP This package has been tested in many different UN*Xes even including minix, and appears to be reasonably portable. This does not mean it will port easily to non-UN*X systems. .SH Notes and Miscellaneous .PP The \fIsdbm\fP is not a very complicated package, at least not after you familiarize yourself with the literature on external hashing. There are other interesting algorithms in existence that ensure (approximately) single-read access to a data value associated with any key. These are directory-less schemes such as \fIlinear hashing\fP [Lit80] (+ Larson variations), \fIspiral storage\fP [Mar79] or directory schemes such as \fIextensible hashing\fP [Fag79] by Fagin et al. I do hope these sources provide a reasonable playground for experimentation with other algorithms. See the June 1988 issue of ACM Computing Surveys [Enb88] for an excellent overview of the field. .PG .SH References .LP .IP [Lar78] 4m P.-A. Larson, ``Dynamic Hashing'', \fIBIT\fP, vol. 18, pp. 184-201, 1978. .IP [Tho90] 4m Ken Thompson, \fIprivate communication\fP, Nov. 1990 .IP [Lit80] 4m W. Litwin, `` Linear Hashing: A new tool for file and table addressing'', \fIProceedings of the 6th Conference on Very Large Dabatases (Montreal)\fP, pp. 212-223, Very Large Database Foundation, Saratoga, Calif., 1980. .IP [Fag79] 4m R. Fagin, J. Nievergelt, N. Pippinger, and H. R. Strong, ``Extendible Hashing - A Fast Access Method for Dynamic Files'', \fIACM Trans. Database Syst.\fP, vol. 4, no.3, pp. 315-344, Sept. 1979. .IP [Wal84] 4m Rich Wales, ``Discussion of "dbm" data base system'', \fIUSENET newsgroup unix.wizards\fP, Jan. 1984. .IP [Tor87] 4m Chris Torek, ``Re: dbm.a and ndbm.a archives'', \fIUSENET newsgroup comp.unix\fP, 1987. .IP [Mar79] 4m G. N. Martin, ``Spiral Storage: Incrementally Augmentable Hash Addressed Storage'', \fITechnical Report #27\fP, University of Varwick, Coventry, U.K., 1979. .IP [Enb88] 4m R. J. Enbody and H. C. Du, ``Dynamic Hashing Schemes'',\fIACM Computing Surveys\fP, vol. 20, no. 2, pp. 85-113, June 1988. atum(comarg[2]); switch (what) { case SCAN: key = dbm_firstkey(db); if (dbm_eperl5.000/ext/SDBM_File/sdbm/readme.ps 664 203 12 101026 5514407360 12502 %!PS-Adobe-1.0 %%Creator: yetti:oz (Ozan Yigit) %%Title: stdin (ditroff) %%CreationDate: Thu Dec 13 15:56:08 1990 %%EndComments % lib/psdit.pro -- prolog for psdit (ditroff) files % Copyright (c) 1984, 1985 Adobe Systems Incorporated. All Rights Reserved. % last edit: shore Sat Nov 23 20:28:03 1985 % RCSID: $Header: psdit.pro,v 2.1 85/11/24 12:19:43 shore Rel $ /$DITroff 140 dict def $DITroff begin /fontnum 1 def /fontsize 10 def /fontheight 10 def /fontslant 0 def /xi {0 72 11 mul translate 72 resolution div dup neg scale 0 0 moveto /fontnum 1 def /fontsize 10 def /fontheight 10 def /fontslant 0 def F /pagesave save def}def /PB{save /psv exch def currentpoint translate resolution 72 div dup neg scale 0 0 moveto}def /PE{psv restore}def /arctoobig 90 def /arctoosmall .05 def /m1 matrix def /m2 matrix def /m3 matrix def /oldmat matrix def /tan{dup sin exch cos div}def /point{resolution 72 div mul}def /dround {transform round exch round exch itransform}def /xT{/devname exch def}def /xr{/mh exch def /my exch def /resolution exch def}def /xp{}def /xs{docsave restore end}def /xt{}def /xf{/fontname exch def /slotno exch def fontnames slotno get fontname eq not {fonts slotno fontname findfont put fontnames slotno fontname put}if}def /xH{/fontheight exch def F}def /xS{/fontslant exch def F}def /s{/fontsize exch def /fontheight fontsize def F}def /f{/fontnum exch def F}def /F{fontheight 0 le {/fontheight fontsize def}if fonts fontnum get fontsize point 0 0 fontheight point neg 0 0 m1 astore fontslant 0 ne{1 0 fontslant tan 1 0 0 m2 astore m3 concatmatrix}if makefont setfont .04 fontsize point mul 0 dround pop setlinewidth}def /X{exch currentpoint exch pop moveto show}def /N{3 1 roll moveto show}def /Y{exch currentpoint pop exch moveto show}def /S{show}def /ditpush{}def/ditpop{}def /AX{3 -1 roll currentpoint exch pop moveto 0 exch ashow}def /AN{4 2 roll moveto 0 exch ashow}def /AY{3 -1 roll currentpoint pop exch moveto 0 exch ashow}def /AS{0 exch ashow}def /MX{currentpoint exch pop moveto}def /MY{currentpoint pop exch moveto}def /MXY{moveto}def /cb{pop}def % action on unknown char -- nothing for now /n{}def/w{}def /p{pop showpage pagesave restore /pagesave save def}def /abspoint{currentpoint exch pop add exch currentpoint pop add exch}def /distance{dup mul exch dup mul add sqrt}def /dstroke{currentpoint stroke moveto}def /Dl{2 copy gsave rlineto stroke grestore rmoveto}def /arcellipse{/diamv exch def /diamh exch def oldmat currentmatrix pop currentpoint translate 1 diamv diamh div scale /rad diamh 2 div def currentpoint exch rad add exch rad -180 180 arc oldmat setmatrix}def /Dc{dup arcellipse dstroke}def /De{arcellipse dstroke}def /Da{/endv exch def /endh exch def /centerv exch def /centerh exch def /cradius centerv centerv mul centerh centerh mul add sqrt def /eradius endv endv mul endh endh mul add sqrt def /endang endv endh atan def /startang centerv neg centerh neg atan def /sweep startang endang sub dup 0 lt{360 add}if def sweep arctoobig gt {/midang startang sweep 2 div sub def /midrad cradius eradius add 2 div def /midh midang cos midrad mul def /midv midang sin midrad mul def midh neg midv neg endh endv centerh centerv midh midv Da currentpoint moveto Da} {sweep arctoosmall ge {/controldelt 1 sweep 2 div cos sub 3 sweep 2 div sin mul div 4 mul def centerv neg controldelt mul centerh controldelt mul endv neg controldelt mul centerh add endh add endh controldelt mul centerv add endv add centerh endh add centerv endv add rcurveto dstroke} {centerh endh add centerv endv add rlineto dstroke}ifelse}ifelse}def /Barray 200 array def % 200 values in a wiggle /D~{mark}def /D~~{counttomark Barray exch 0 exch getinterval astore /Bcontrol exch def pop /Blen Bcontrol length def Blen 4 ge Blen 2 mod 0 eq and {Bcontrol 0 get Bcontrol 1 get abspoint /Ycont exch def /Xcont exch def Bcontrol 0 2 copy get 2 mul put Bcontrol 1 2 copy get 2 mul put Bcontrol Blen 2 sub 2 copy get 2 mul put Bcontrol Blen 1 sub 2 copy get 2 mul put /Ybi /Xbi currentpoint 3 1 roll def def 0 2 Blen 4 sub {/i exch def Bcontrol i get 3 div Bcontrol i 1 add get 3 div Bcontrol i get 3 mul Bcontrol i 2 add get add 6 div Bcontrol i 1 add get 3 mul Bcontrol i 3 add get add 6 div /Xbi Xcont Bcontrol i 2 add get 2 div add def /Ybi Ycont Bcontrol i 3 add get 2 div add def /Xcont Xcont Bcontrol i 2 add get add def /Ycont Ycont Bcontrol i 3 add get add def Xbi currentpoint pop sub Ybi currentpoint exch pop sub rcurveto }for dstroke}if}def end /ditstart{$DITroff begin /nfonts 60 def % NFONTS makedev/ditroff dependent! /fonts[nfonts{0}repeat]def /fontnames[nfonts{()}repeat]def /docsave save def }def % character outcalls /oc {/pswid exch def /cc exch def /name exch def /ditwid pswid fontsize mul resolution mul 72000 div def /ditsiz fontsize resolution mul 72 div def ocprocs name known{ocprocs name get exec}{name cb} ifelse}def /fractm [.65 0 0 .6 0 0] def /fraction {/fden exch def /fnum exch def gsave /cf currentfont def cf fractm makefont setfont 0 .3 dm 2 copy neg rmoveto fnum show rmoveto currentfont cf setfont(\244)show setfont fden show grestore ditwid 0 rmoveto} def /oce {grestore ditwid 0 rmoveto}def /dm {ditsiz mul}def /ocprocs 50 dict def ocprocs begin (14){(1)(4)fraction}def (12){(1)(2)fraction}def (34){(3)(4)fraction}def (13){(1)(3)fraction}def (23){(2)(3)fraction}def (18){(1)(8)fraction}def (38){(3)(8)fraction}def (58){(5)(8)fraction}def (78){(7)(8)fraction}def (sr){gsave 0 .06 dm rmoveto(\326)show oce}def (is){gsave 0 .15 dm rmoveto(\362)show oce}def (->){gsave 0 .02 dm rmoveto(\256)show oce}def (<-){gsave 0 .02 dm rmoveto(\254)show oce}def (==){gsave 0 .05 dm rmoveto(\272)show oce}def end % an attempt at a PostScript FONT to implement ditroff special chars % this will enable us to % cache the little buggers % generate faster, more compact PS out of psdit % confuse everyone (including myself)! 50 dict dup begin /FontType 3 def /FontName /DIThacks def /FontMatrix [.001 0 0 .001 0 0] def /FontBBox [-260 -260 900 900] def% a lie but ... /Encoding 256 array def 0 1 255{Encoding exch /.notdef put}for Encoding dup 8#040/space put %space dup 8#110/rc put %right ceil dup 8#111/lt put %left top curl dup 8#112/bv put %bold vert dup 8#113/lk put %left mid curl dup 8#114/lb put %left bot curl dup 8#115/rt put %right top curl dup 8#116/rk put %right mid curl dup 8#117/rb put %right bot curl dup 8#120/rf put %right floor dup 8#121/lf put %left floor dup 8#122/lc put %left ceil dup 8#140/sq put %square dup 8#141/bx put %box dup 8#142/ci put %circle dup 8#143/br put %box rule dup 8#144/rn put %root extender dup 8#145/vr put %vertical rule dup 8#146/ob put %outline bullet dup 8#147/bu put %bullet dup 8#150/ru put %rule dup 8#151/ul put %underline pop /DITfd 100 dict def /BuildChar{0 begin /cc exch def /fd exch def /charname fd /Encoding get cc get def /charwid fd /Metrics get charname get def /charproc fd /CharProcs get charname get def charwid 0 fd /FontBBox get aload pop setcachedevice 2 setlinejoin 40 setlinewidth newpath 0 0 moveto gsave charproc grestore end}def /BuildChar load 0 DITfd put %/UniqueID 5 def /CharProcs 50 dict def CharProcs begin /space{}def /.notdef{}def /ru{500 0 rls}def /rn{0 840 moveto 500 0 rls}def /vr{0 800 moveto 0 -770 rls}def /bv{0 800 moveto 0 -1000 rls}def /br{0 750 moveto 0 -1000 rls}def /ul{0 -140 moveto 500 0 rls}def /ob{200 250 rmoveto currentpoint newpath 200 0 360 arc closepath stroke}def /bu{200 250 rmoveto currentpoint newpath 200 0 360 arc closepath fill}def /sq{80 0 rmoveto currentpoint dround newpath moveto 640 0 rlineto 0 640 rlineto -640 0 rlineto closepath stroke}def /bx{80 0 rmoveto currentpoint dround newpath moveto 640 0 rlineto 0 640 rlineto -640 0 rlineto closepath fill}def /ci{500 360 rmoveto currentpoint newpath 333 0 360 arc 50 setlinewidth stroke}def /lt{0 -200 moveto 0 550 rlineto currx 800 2cx s4 add exch s4 a4p stroke}def /lb{0 800 moveto 0 -550 rlineto currx -200 2cx s4 add exch s4 a4p stroke}def /rt{0 -200 moveto 0 550 rlineto currx 800 2cx s4 sub exch s4 a4p stroke}def /rb{0 800 moveto 0 -500 rlineto currx -200 2cx s4 sub exch s4 a4p stroke}def /lk{0 800 moveto 0 300 -300 300 s4 arcto pop pop 1000 sub 0 300 4 2 roll s4 a4p 0 -200 lineto stroke}def /rk{0 800 moveto 0 300 s2 300 s4 arcto pop pop 1000 sub 0 300 4 2 roll s4 a4p 0 -200 lineto stroke}def /lf{0 800 moveto 0 -1000 rlineto s4 0 rls}def /rf{0 800 moveto 0 -1000 rlineto s4 neg 0 rls}def /lc{0 -200 moveto 0 1000 rlineto s4 0 rls}def /rc{0 -200 moveto 0 1000 rlineto s4 neg 0 rls}def end /Metrics 50 dict def Metrics begin /.notdef 0 def /space 500 def /ru 500 def /br 0 def /lt 416 def /lb 416 def /rt 416 def /rb 416 def /lk 416 def /rk 416 def /rc 416 def /lc 416 def /rf 416 def /lf 416 def /bv 416 def /ob 350 def /bu 350 def /ci 750 def /bx 750 def /sq 750 def /rn 500 def /ul 500 def /vr 0 def end DITfd begin /s2 500 def /s4 250 def /s3 333 def /a4p{arcto pop pop pop pop}def /2cx{2 copy exch}def /rls{rlineto stroke}def /currx{currentpoint pop}def /dround{transform round exch round exch itransform} def end end /DIThacks exch definefont pop ditstart (psc)xT 576 1 1 xr 1(Times-Roman)xf 1 f 2(Times-Italic)xf 2 f 3(Times-Bold)xf 3 f 4(Times-BoldItalic)xf 4 f 5(Helvetica)xf 5 f 6(Helvetica-Bold)xf 6 f 7(Courier)xf 7 f 8(Courier-Bold)xf 8 f 9(Symbol)xf 9 f 10(DIThacks)xf 10 f 10 s 1 f xi %%EndProlog %%Page: 1 1 10 s 0 xH 0 xS 1 f 8 s 2 f 12 s 1778 672(sdbm)N 3 f 2004(\320)X 2124(Substitute)X 2563(DBM)X 2237 768(or)N 1331 864(Berkeley)N 2 f 1719(ndbm)X 3 f 1956(for)X 2103(Every)X 2373(UN*X)X 1 f 10 s 2628 832(1)N 3 f 12 s 2692 864(Made)N 2951(Simple)X 2 f 10 s 2041 1056(Ozan)N 2230(\(oz\))X 2375(Yigit)X 1 f 1658 1200(The)N 1803(Guild)X 2005(of)X 2092(PD)X 2214(Software)X 2524(Toolmakers)X 2000 1296(Toronto)N 2278(-)X 2325(Canada)X 1965 1488(oz@nexus.yorku.ca)N 2 f 555 1804(Implementation)N 1078(is)X 1151(the)X 1269(sincerest)X 1574(form)X 1745(of)X 1827(\257attery.)X 2094(\320)X 2185(L.)X 2269(Peter)X 2463(Deutsch)X 3 f 555 1996(A)N 633(The)X 786(Clone)X 1006(of)X 1093(the)X 2 f 1220(ndbm)X 3 f 1418(library)X 1 f 755 2120(The)N 903(sources)X 1167(accompanying)X 1658(this)X 1796(notice)X 2015(\320)X 2 f 2118(sdbm)X 1 f 2309(\320)X 2411(constitute)X 2744(the)X 2864(\256rst)X 3010(public)X 3232(release)X 3478(\(Dec.)X 3677(1990\))X 3886(of)X 3975(a)X 555 2216(complete)N 874(clone)X 1073(of)X 1165(the)X 1288(Berkeley)X 1603(UN*X)X 2 f 1842(ndbm)X 1 f 2045(library.)X 2304(The)X 2 f 2454(sdbm)X 1 f 2648(library)X 2887(is)X 2965(meant)X 3186(to)X 3273(clone)X 3472(the)X 3594(proven)X 3841(func-)X 555 2312(tionality)N 846(of)X 2 f 938(ndbm)X 1 f 1141(as)X 1233(closely)X 1485(as)X 1576(possible,)X 1882(including)X 2208(a)X 2268(few)X 2413(improvements.)X 2915(It)X 2988(is)X 3065(practical,)X 3386(easy)X 3553(to)X 3639(understand,)X 555 2408(and)N 691(compatible.)X 1107(The)X 2 f 1252(sdbm)X 1 f 1441(library)X 1675(is)X 1748(not)X 1870(derived)X 2131(from)X 2307(any)X 2443(licensed,)X 2746(proprietary)X 3123(or)X 3210(copyrighted)X 3613(software.)X 755 2532(The)N 2 f 910(sdbm)X 1 f 1109(implementation)X 1641(is)X 1723(based)X 1935(on)X 2044(a)X 2109(1978)X 2298(algorithm)X 2638([Lar78])X 2913(by)X 3022(P.-A.)X 3220(\(Paul\))X 3445(Larson)X 3697(known)X 3944(as)X 555 2628(``Dynamic)N 934(Hashing''.)X 1326(In)X 1424(the)X 1553(course)X 1794(of)X 1892(searching)X 2231(for)X 2355(a)X 2421(substitute)X 2757(for)X 2 f 2881(ndbm)X 1 f 3059(,)X 3109(I)X 3166(prototyped)X 3543(three)X 3734(different)X 555 2724(external-hashing)N 1119(algorithms)X 1490([Lar78,)X 1758(Fag79,)X 2007(Lit80])X 2236(and)X 2381(ultimately)X 2734(chose)X 2946(Larson's)X 3256(algorithm)X 3596(as)X 3692(a)X 3756(basis)X 3944(of)X 555 2820(the)N 2 f 680(sdbm)X 1 f 875(implementation.)X 1423(The)X 1574(Bell)X 1733(Labs)X 2 f 1915(dbm)X 1 f 2079(\(and)X 2248(therefore)X 2 f 2565(ndbm)X 1 f 2743(\))X 2796(is)X 2875(based)X 3084(on)X 3190(an)X 3292(algorithm)X 3629(invented)X 3931(by)X 555 2916(Ken)N 709(Thompson,)X 1091([Tho90,)X 1367(Tor87])X 1610(and)X 1746(predates)X 2034(Larson's)X 2335(work.)X 755 3040(The)N 2 f 903(sdbm)X 1 f 1095(programming)X 1553(interface)X 1857(is)X 1932(totally)X 2158(compatible)X 2536(with)X 2 f 2700(ndbm)X 1 f 2900(and)X 3038(includes)X 3327(a)X 3385(slight)X 3584(improvement)X 555 3136(in)N 641(database)X 942(initialization.)X 1410(It)X 1483(is)X 1560(also)X 1713(expected)X 2023(to)X 2109(be)X 2208(binary-compatible)X 2819(under)X 3025(most)X 3203(UN*X)X 3440(versions)X 3730(that)X 3873(sup-)X 555 3232(port)N 704(the)X 2 f 822(ndbm)X 1 f 1020(library.)X 755 3356(The)N 2 f 909(sdbm)X 1 f 1107(implementation)X 1638(shares)X 1868(the)X 1995(shortcomings)X 2455(of)X 2551(the)X 2 f 2678(ndbm)X 1 f 2885(library,)X 3148(as)X 3244(a)X 3309(side)X 3467(effect)X 3680(of)X 3775(various)X 555 3452(simpli\256cations)N 1046(to)X 1129(the)X 1248(original)X 1518(Larson)X 1762(algorithm.)X 2114(It)X 2183(does)X 2350(produce)X 2 f 2629(holes)X 1 f 2818(in)X 2900(the)X 3018(page)X 3190(\256le)X 3312(as)X 3399(it)X 3463(writes)X 3679(pages)X 3882(past)X 555 3548(the)N 680(end)X 823(of)X 917(\256le.)X 1066(\(Larson's)X 1400(paper)X 1605(include)X 1867(a)X 1929(clever)X 2152(solution)X 2435(to)X 2523(this)X 2664(problem)X 2957(that)X 3103(is)X 3182(a)X 3244(result)X 3448(of)X 3541(using)X 3740(the)X 3864(hash)X 555 3644(value)N 758(directly)X 1032(as)X 1128(a)X 1193(block)X 1400(address.\))X 1717(On)X 1844(the)X 1971(other)X 2165(hand,)X 2370(extensive)X 2702(tests)X 2873(seem)X 3067(to)X 3158(indicate)X 3441(that)X 2 f 3590(sdbm)X 1 f 3787(creates)X 555 3740(fewer)N 762(holes)X 954(in)X 1039(general,)X 1318(and)X 1456(the)X 1576(resulting)X 1878(page\256les)X 2185(are)X 2306(smaller.)X 2584(The)X 2 f 2731(sdbm)X 1 f 2922(implementation)X 3446(is)X 3521(also)X 3672(faster)X 3873(than)X 2 f 555 3836(ndbm)N 1 f 757(in)X 843(database)X 1144(creation.)X 1467(Unlike)X 1709(the)X 2 f 1831(ndbm)X 1 f 2009(,)X 2053(the)X 2 f 2175(sdbm)X 7 f 2396(store)X 1 f 2660(operation)X 2987(will)X 3134(not)X 3259(``wander)X 3573(away'')X 3820(trying)X 555 3932(to)N 642(split)X 804(its)X 904(data)X 1063(pages)X 1271(to)X 1358(insert)X 1561(a)X 1622(datum)X 1847(that)X 2 f 1992(cannot)X 1 f 2235(\(due)X 2403(to)X 2490(elaborate)X 2810(worst-case)X 3179(situations\))X 3537(be)X 3637(inserted.)X 3935(\(It)X 555 4028(will)N 699(fail)X 826(after)X 994(a)X 1050(pre-de\256ned)X 1436(number)X 1701(of)X 1788(attempts.\))X 3 f 555 4220(Important)N 931(Compatibility)X 1426(Warning)X 1 f 755 4344(The)N 2 f 904(sdbm)X 1 f 1097(and)X 2 f 1237(ndbm)X 1 f 1439(libraries)X 2 f 1726(cannot)X 1 f 1968(share)X 2162(databases:)X 2515(one)X 2654(cannot)X 2891(read)X 3053(the)X 3174(\(dir/pag\))X 3478(database)X 3778(created)X 555 4440(by)N 657(the)X 777(other.)X 984(This)X 1148(is)X 1222(due)X 1359(to)X 1442(the)X 1561(differences)X 1940(between)X 2229(the)X 2 f 2348(ndbm)X 1 f 2547(and)X 2 f 2684(sdbm)X 1 f 2874(algorithms)X 8 s 3216 4415(2)N 10 s 4440(,)Y 3289(and)X 3426(the)X 3545(hash)X 3713(functions)X 555 4536(used.)N 769(It)X 845(is)X 925(easy)X 1094(to)X 1182(convert)X 1449(between)X 1743(the)X 2 f 1867(dbm/ndbm)X 1 f 2231(databases)X 2565(and)X 2 f 2707(sdbm)X 1 f 2902(by)X 3008(ignoring)X 3305(the)X 3429(index)X 3633(completely:)X 555 4632(see)N 7 f 706(dbd)X 1 f (,)S 7 f 918(dbu)X 1 f 1082(etc.)X 3 f 555 4852(Notice)N 794(of)X 881(Intellectual)X 1288(Property)X 2 f 555 4976(The)N 696(entire)X 1 f 904(sdbm)X 2 f 1118(library)X 1361(package,)X 1670(as)X 1762(authored)X 2072(by)X 2169(me,)X 1 f 2304(Ozan)X 2495(S.)X 2580(Yigit,)X 2 f 2785(is)X 2858(hereby)X 3097(placed)X 3331(in)X 3413(the)X 3531(public)X 3751(domain.)X 1 f 555 5072(As)N 670(such,)X 863(the)X 987(author)X 1218(is)X 1297(not)X 1425(responsible)X 1816(for)X 1936(the)X 2060(consequences)X 2528(of)X 2621(use)X 2754(of)X 2847(this)X 2988(software,)X 3310(no)X 3415(matter)X 3645(how)X 3808(awful,)X 555 5168(even)N 727(if)X 796(they)X 954(arise)X 1126(from)X 1302(defects)X 1550(in)X 1632(it.)X 1716(There)X 1924(is)X 1997(no)X 2097(expressed)X 2434(or)X 2521(implied)X 2785(warranty)X 3091(for)X 3205(the)X 2 f 3323(sdbm)X 1 f 3512(library.)X 8 s 10 f 555 5316(hhhhhhhhhhhhhhhhhh)N 6 s 1 f 635 5391(1)N 8 s 691 5410(UN*X)N 877(is)X 936(not)X 1034(a)X 1078(trademark)X 1352(of)X 1421(any)X 1529(\(dis\)organization.)X 6 s 635 5485(2)N 8 s 691 5504(Torek's)N 908(discussion)X 1194([Tor87])X 1411(indicates)X 1657(that)X 2 f 1772(dbm/ndbm)X 1 f 2061(implementations)X 2506(use)X 2609(the)X 2705(hash)X 2840(value)X 2996(to)X 3064(traverse)X 3283(the)X 3379(radix)X 3528(trie)X 3631(dif-)X 555 5584(ferently)N 772(than)X 2 f 901(sdbm)X 1 f 1055(and)X 1166(as)X 1238(a)X 1285(result,)X 1462(the)X 1559(page)X 1698(indexes)X 1912(are)X 2008(generated)X 2274(in)X 2 f 2343(different)X 1 f 2579(order.)X 2764(For)X 2872(more)X 3021(information,)X 3357(send)X 3492(e-mail)X 3673(to)X 555 5664(the)N 649(author.)X 2 p %%Page: 2 2 8 s 0 xH 0 xS 1 f 10 s 2216 384(-)N 2263(2)X 2323(-)X 755 672(Since)N 971(the)X 2 f 1107(sdbm)X 1 f 1314(library)X 1566(package)X 1868(is)X 1959(in)X 2058(the)X 2193(public)X 2430(domain,)X 2727(this)X 2 f 2879(original)X 1 f 3173(release)X 3434(or)X 3538(any)X 3691(additional)X 555 768(public-domain)N 1045(releases)X 1323(of)X 1413(the)X 1534(modi\256ed)X 1841(original)X 2112(cannot)X 2348(possibly)X 2636(\(by)X 2765(de\256nition\))X 3120(be)X 3218(withheld)X 3520(from)X 3698(you.)X 3860(Also)X 555 864(by)N 659(de\256nition,)X 1009(You)X 1170(\(singular\))X 1505(have)X 1680(all)X 1783(the)X 1904(rights)X 2109(to)X 2194(this)X 2332(code)X 2507(\(including)X 2859(the)X 2980(right)X 3154(to)X 3239(sell)X 3373(without)X 3640(permission,)X 555 960(the)N 679(right)X 856(to)X 944(hoard)X 8 s 1127 935(3)N 10 s 1185 960(and)N 1327(the)X 1451(right)X 1628(to)X 1716(do)X 1821(other)X 2011(icky)X 2174(things)X 2394(as)X 2486(you)X 2631(see)X 2759(\256t\))X 2877(but)X 3004(those)X 3198(rights)X 3405(are)X 3529(also)X 3683(granted)X 3949(to)X 555 1056(everyone)N 870(else.)X 755 1180(Please)N 997(note)X 1172(that)X 1329(all)X 1446(previous)X 1759(distributions)X 2195(of)X 2298(this)X 2449(software)X 2762(contained)X 3110(a)X 3182(copyright)X 3525(\(which)X 3784(is)X 3873(now)X 555 1276(dropped\))N 868(to)X 953(protect)X 1199(its)X 1297(origins)X 1542(and)X 1681(its)X 1779(current)X 2030(public)X 2253(domain)X 2516(status)X 2721(against)X 2970(any)X 3108(possible)X 3392(claims)X 3623(and/or)X 3850(chal-)X 555 1372(lenges.)N 3 f 555 1564(Acknowledgments)N 1 f 755 1688(Many)N 966(people)X 1204(have)X 1380(been)X 1556(very)X 1723(helpful)X 1974(and)X 2114(supportive.)X 2515(A)X 2596(partial)X 2824(list)X 2944(would)X 3167(necessarily)X 3547(include)X 3806(Rayan)X 555 1784(Zacherissen)N 963(\(who)X 1152(contributed)X 1541(the)X 1663(man)X 1824(page,)X 2019(and)X 2158(also)X 2310(hacked)X 2561(a)X 2620(MMAP)X 2887(version)X 3146(of)X 2 f 3236(sdbm)X 1 f 3405(\),)X 3475(Arnold)X 3725(Robbins,)X 555 1880(Chris)N 763(Lewis,)X 1013(Bill)X 1166(Davidsen,)X 1523(Henry)X 1758(Spencer,)X 2071(Geoff)X 2293(Collyer,)X 2587(Rich)X 2772(Salz)X 2944(\(who)X 3143(got)X 3279(me)X 3411(started)X 3659(in)X 3755(the)X 3887(\256rst)X 555 1976(place\),)N 792(Johannes)X 1106(Ruschein)X 1424(\(who)X 1609(did)X 1731(the)X 1849(minix)X 2055(port\))X 2231(and)X 2367(David)X 2583(Tilbrook.)X 2903(I)X 2950(thank)X 3148(you)X 3288(all.)X 3 f 555 2168(Distribution)N 992(Manifest)X 1315(and)X 1463(Notes)X 1 f 555 2292(This)N 717(distribution)X 1105(of)X 2 f 1192(sdbm)X 1 f 1381(includes)X 1668(\(at)X 1773(least\))X 1967(the)X 2085(following:)X 7 f 747 2436(CHANGES)N 1323(change)X 1659(log)X 747 2532(README)N 1323(this)X 1563(file.)X 747 2628(biblio)N 1323(a)X 1419(small)X 1707(bibliography)X 2331(on)X 2475(external)X 2907(hashing)X 747 2724(dba.c)N 1323(a)X 1419(crude)X 1707(\(n/s\)dbm)X 2139(page)X 2379(file)X 2619(analyzer)X 747 2820(dbd.c)N 1323(a)X 1419(crude)X 1707(\(n/s\)dbm)X 2139(page)X 2379(file)X 2619(dumper)X 2955(\(for)X 3195(conversion\))X 747 2916(dbe.1)N 1323(man)X 1515(page)X 1755(for)X 1947(dbe.c)X 747 3012(dbe.c)N 1323(Janick's)X 1755(database)X 2187(editor)X 747 3108(dbm.c)N 1323(a)X 1419(dbm)X 1611(library)X 1995(emulation)X 2475(wrapper)X 2859(for)X 3051(ndbm/sdbm)X 747 3204(dbm.h)N 1323(header)X 1659(file)X 1899(for)X 2091(the)X 2283(above)X 747 3300(dbu.c)N 1323(a)X 1419(crude)X 1707(db)X 1851(management)X 2379(utility)X 747 3396(hash.c)N 1323(hashing)X 1707(function)X 747 3492(makefile)N 1323(guess.)X 747 3588(pair.c)N 1323(page-level)X 1851(routines)X 2283(\(posted)X 2667(earlier\))X 747 3684(pair.h)N 1323(header)X 1659(file)X 1899(for)X 2091(the)X 2283(above)X 747 3780(readme.ms)N 1323(troff)X 1611(source)X 1947(for)X 2139(the)X 2331(README)X 2667(file)X 747 3876(sdbm.3)N 1323(man)X 1515(page)X 747 3972(sdbm.c)N 1323(the)X 1515(real)X 1755(thing)X 747 4068(sdbm.h)N 1323(header)X 1659(file)X 1899(for)X 2091(the)X 2283(above)X 747 4164(tune.h)N 1323(place)X 1611(for)X 1803(tuning)X 2139(&)X 2235(portability)X 2811(thingies)X 747 4260(util.c)N 1323(miscellaneous)X 755 4432(dbu)N 1 f 924(is)X 1002(a)X 1063(simple)X 1301(database)X 1603(manipulation)X 2050(program)X 8 s 2322 4407(4)N 10 s 2379 4432(that)N 2524(tries)X 2687(to)X 2774(look)X 2941(like)X 3086(Bell)X 3244(Labs')X 7 f 3480(cbt)X 1 f 3649(utility.)X 3884(It)X 3958(is)X 555 4528(currently)N 867(incomplete)X 1245(in)X 1329(functionality.)X 1800(I)X 1849(use)X 7 f 2006(dbu)X 1 f 2172(to)X 2255(test)X 2387(out)X 2510(the)X 2629(routines:)X 2930(it)X 2995(takes)X 3181(\(from)X 3385(stdin\))X 3588(tab)X 3707(separated)X 555 4624(key/value)N 898(pairs)X 1085(for)X 1210(commands)X 1587(like)X 7 f 1765(build)X 1 f 2035(or)X 7 f 2160(insert)X 1 f 2478(or)X 2575(takes)X 2770(keys)X 2947(for)X 3071(commands)X 3448(like)X 7 f 3626(delete)X 1 f 3944(or)X 7 f 555 4720(look)N 1 f (.)S 7 f 747 4864(dbu)N 939()X 2715(dbmfile)X 755 5036(dba)N 1 f 927(is)X 1008(a)X 1072(crude)X 1279(analyzer)X 1580(of)X 2 f 1675(dbm/sdbm/ndbm)X 1 f 2232(page)X 2412(\256les.)X 2593(It)X 2670(scans)X 2872(the)X 2998(entire)X 3209(page)X 3389(\256le,)X 3538(reporting)X 3859(page)X 555 5132(level)N 731(statistics,)X 1046(and)X 1182(totals)X 1375(at)X 1453(the)X 1571(end.)X 7 f 755 5256(dbd)N 1 f 925(is)X 1004(a)X 1066(crude)X 1271(dump)X 1479(program)X 1777(for)X 2 f 1897(dbm/ndbm/sdbm)X 1 f 2452(databases.)X 2806(It)X 2881(ignores)X 3143(the)X 3267(bitmap,)X 3534(and)X 3675(dumps)X 3913(the)X 555 5352(data)N 717(pages)X 928(in)X 1018(sequence.)X 1361(It)X 1437(can)X 1576(be)X 1679(used)X 1853(to)X 1942(create)X 2162(input)X 2353(for)X 2474(the)X 7 f 2627(dbu)X 1 f 2798(utility.)X 3055(Note)X 3238(that)X 7 f 3413(dbd)X 1 f 3584(will)X 3735(skip)X 3895(any)X 8 s 10 f 555 5432(hhhhhhhhhhhhhhhhhh)N 6 s 1 f 635 5507(3)N 8 s 691 5526(You)N 817(cannot)X 1003(really)X 1164(hoard)X 1325(something)X 1608(that)X 1720(is)X 1779(available)X 2025(to)X 2091(the)X 2185(public)X 2361(at)X 2423(large,)X 2582(but)X 2680(try)X 2767(if)X 2822(it)X 2874(makes)X 3053(you)X 3165(feel)X 3276(any)X 3384(better.)X 6 s 635 5601(4)N 8 s 691 5620(The)N 7 f 829(dbd)X 1 f 943(,)X 7 f 998(dba)X 1 f 1112(,)X 7 f 1167(dbu)X 1 f 1298(utilities)X 1508(are)X 1602(quick)X 1761(hacks)X 1923(and)X 2032(are)X 2126(not)X 2225(\256t)X 2295(for)X 2385(production)X 2678(use.)X 2795(They)X 2942(were)X 3081(developed)X 3359(late)X 3467(one)X 3575(night,)X 555 5700(just)N 664(to)X 730(test)X 835(out)X 2 f 933(sdbm)X 1 f 1068(,)X 1100(and)X 1208(convert)X 1415(some)X 1566(databases.)X 3 p %%Page: 3 3 8 s 0 xH 0 xS 1 f 10 s 2216 384(-)N 2263(3)X 2323(-)X 555 672(NULLs)N 821(in)X 903(the)X 1021(key)X 1157(and)X 1293(data)X 1447(\256elds,)X 1660(thus)X 1813(is)X 1886(unsuitable)X 2235(to)X 2317(convert)X 2578(some)X 2767(peculiar)X 3046(databases)X 3374(that)X 3514(insist)X 3702(in)X 3784(includ-)X 555 768(ing)N 677(the)X 795(terminating)X 1184(null.)X 755 892(I)N 841(have)X 1052(also)X 1240(included)X 1575(a)X 1670(copy)X 1885(of)X 2011(the)X 7 f 2195(dbe)X 1 f 2397(\()X 2 f 2424(ndbm)X 1 f 2660(DataBase)X 3026(Editor\))X 3311(by)X 3449(Janick)X 3712(Bergeron)X 555 988([janick@bnr.ca])N 1098(for)X 1212(your)X 1379(pleasure.)X 1687(You)X 1845(may)X 2003(\256nd)X 2147(it)X 2211(more)X 2396(useful)X 2612(than)X 2770(the)X 2888(little)X 7 f 3082(dbu)X 1 f 3246(utility.)X 7 f 755 1112(dbm.[ch])N 1 f 1169(is)X 1252(a)X 2 f 1318(dbm)X 1 f 1486(library)X 1730(emulation)X 2079(on)X 2188(top)X 2319(of)X 2 f 2415(ndbm)X 1 f 2622(\(and)X 2794(hence)X 3011(suitable)X 3289(for)X 2 f 3412(sdbm)X 1 f 3581(\).)X 3657(Written)X 3931(by)X 555 1208(Robert)N 793(Elz.)X 755 1332(The)N 2 f 901(sdbm)X 1 f 1090(library)X 1324(has)X 1451(been)X 1623(around)X 1866(in)X 1948(beta)X 2102(test)X 2233(for)X 2347(quite)X 2527(a)X 2583(long)X 2745(time,)X 2927(and)X 3063(from)X 3239(whatever)X 3554(little)X 3720(feedback)X 555 1428(I)N 609(received)X 909(\(maybe)X 1177(no)X 1284(news)X 1476(is)X 1555(good)X 1741(news\),)X 1979(I)X 2032(believe)X 2290(it)X 2360(has)X 2493(been)X 2671(functioning)X 3066(without)X 3336(any)X 3478(signi\256cant)X 3837(prob-)X 555 1524(lems.)N 752(I)X 805(would,)X 1051(of)X 1144(course,)X 1400(appreciate)X 1757(all)X 1863(\256xes)X 2040(and/or)X 2271(improvements.)X 2774(Portability)X 3136(enhancements)X 3616(would)X 3841(espe-)X 555 1620(cially)N 753(be)X 849(useful.)X 3 f 555 1812(Implementation)N 1122(Issues)X 1 f 755 1936(Hash)N 944(functions:)X 1288(The)X 1437(algorithm)X 1772(behind)X 2 f 2014(sdbm)X 1 f 2207(implementation)X 2733(needs)X 2939(a)X 2998(good)X 3181(bit-scrambling)X 3671(hash)X 3841(func-)X 555 2032(tion)N 702(to)X 787(be)X 886(effective.)X 1211(I)X 1261(ran)X 1387(into)X 1534(a)X 1593(set)X 1705(of)X 1795(constants)X 2116(for)X 2233(a)X 2292(simple)X 2528(hash)X 2698(function)X 2988(that)X 3130(seem)X 3317(to)X 3401(help)X 2 f 3561(sdbm)X 1 f 3752(perform)X 555 2128(better)N 758(than)X 2 f 916(ndbm)X 1 f 1114(for)X 1228(various)X 1484(inputs:)X 7 f 747 2272(/*)N 795 2368(*)N 891(polynomial)X 1419(conversion)X 1947(ignoring)X 2379(overflows)X 795 2464(*)N 891(65599)X 1179(nice.)X 1467(65587)X 1755(even)X 1995(better.)X 795 2560(*/)N 747 2656(long)N 747 2752(dbm_hash\(char)N 1419(*str,)X 1707(int)X 1899(len\))X 2139({)X 939 2848(register)N 1371(unsigned)X 1803(long)X 2043(n)X 2139(=)X 2235(0;)X 939 3040(while)N 1227(\(len--\))X 1131 3136(n)N 1227(=)X 1323(n)X 1419(*)X 1515(65599)X 1803(+)X 1899(*str++;)X 939 3232(return)N 1275(n;)X 747 3328(})N 1 f 755 3500(There)N 975(may)X 1145(be)X 1253(better)X 1467(hash)X 1645(functions)X 1974(for)X 2099(the)X 2228(purposes)X 2544(of)X 2642(dynamic)X 2949(hashing.)X 3269(Try)X 3416(your)X 3594(favorite,)X 3895(and)X 555 3596(check)N 766(the)X 887(page\256le.)X 1184(If)X 1261(it)X 1328(contains)X 1618(too)X 1743(many)X 1944(pages)X 2150(with)X 2315(too)X 2440(many)X 2641(holes,)X 2853(\(in)X 2965(relation)X 3233(to)X 3318(this)X 3456(one)X 3595(for)X 3712(example\))X 555 3692(or)N 656(if)X 2 f 739(sdbm)X 1 f 942(simply)X 1193(stops)X 1391(working)X 1692(\(fails)X 1891(after)X 7 f 2101(SPLTMAX)X 1 f 2471(attempts)X 2776(to)X 2872(split\))X 3070(when)X 3278(you)X 3432(feed)X 3604(your)X 3784(NEWS)X 7 f 555 3788(history)N 1 f 912(\256le)X 1035(to)X 1118(it,)X 1203(you)X 1344(probably)X 1650(do)X 1751(not)X 1874(have)X 2047(a)X 2104(good)X 2285(hashing)X 2555(function.)X 2883(If)X 2958(you)X 3099(do)X 3200(better)X 3404(\(for)X 3545(different)X 3842(types)X 555 3884(of)N 642(input\),)X 873(I)X 920(would)X 1140(like)X 1280(to)X 1362(know)X 1560(about)X 1758(the)X 1876(function)X 2163(you)X 2303(use.)X 755 4008(Block)N 967(sizes:)X 1166(It)X 1236(seems)X 1453(\(from)X 1657(various)X 1914(tests)X 2077(on)X 2178(a)X 2235(few)X 2377(machines\))X 2727(that)X 2867(a)X 2923(page)X 3095(\256le)X 3217(block)X 3415(size)X 7 f 3588(PBLKSIZ)X 1 f 3944(of)X 555 4104(1024)N 738(is)X 814(by)X 917(far)X 1030(the)X 1150(best)X 1301(for)X 1417(performance,)X 1866(but)X 1990(this)X 2127(also)X 2278(happens)X 2563(to)X 2647(limit)X 2819(the)X 2939(size)X 3086(of)X 3175(a)X 3233(key/value)X 3567(pair.)X 3734(Depend-)X 555 4200(ing)N 681(on)X 785(your)X 956(needs,)X 1183(you)X 1327(may)X 1489(wish)X 1663(to)X 1748(increase)X 2035(the)X 2156(page)X 2331(size,)X 2499(and)X 2638(also)X 2790(adjust)X 7 f 3032(PAIRMAX)X 1 f 3391(\(the)X 3539(maximum)X 3886(size)X 555 4296(of)N 648(a)X 710(key/value)X 1048(pair)X 1199(allowed:)X 1501(should)X 1740(always)X 1989(be)X 2090(at)X 2173(least)X 2345(three)X 2531(words)X 2752(smaller)X 3013(than)X 7 f 3204(PBLKSIZ)X 1 f (.\))S 3612(accordingly.)X 555 4392(The)N 706(system-wide)X 1137(version)X 1399(of)X 1492(the)X 1616(library)X 1856(should)X 2095(probably)X 2406(be)X 2508(con\256gured)X 2877(with)X 3044(1024)X 3229(\(distribution)X 3649(default\),)X 3944(as)X 555 4488(this)N 690(appears)X 956(to)X 1038(be)X 1134(suf\256cient)X 1452(for)X 1566(most)X 1741(common)X 2041(uses)X 2199(of)X 2 f 2286(sdbm)X 1 f 2455(.)X 3 f 555 4680(Portability)N 1 f 755 4804(This)N 917(package)X 1201(has)X 1328(been)X 1500(tested)X 1707(in)X 1789(many)X 1987(different)X 2284(UN*Xes)X 2585(even)X 2757(including)X 3079(minix,)X 3305(and)X 3441(appears)X 3707(to)X 3789(be)X 3885(rea-)X 555 4900(sonably)N 824(portable.)X 1127(This)X 1289(does)X 1456(not)X 1578(mean)X 1772(it)X 1836(will)X 1980(port)X 2129(easily)X 2336(to)X 2418(non-UN*X)X 2799(systems.)X 3 f 555 5092(Notes)N 767(and)X 915(Miscellaneous)X 1 f 755 5216(The)N 2 f 913(sdbm)X 1 f 1115(is)X 1201(not)X 1336(a)X 1405(very)X 1581(complicated)X 2006(package,)X 2323(at)X 2414(least)X 2594(not)X 2729(after)X 2910(you)X 3063(familiarize)X 3444(yourself)X 3739(with)X 3913(the)X 555 5312(literature)N 879(on)X 993(external)X 1286(hashing.)X 1589(There)X 1811(are)X 1944(other)X 2143(interesting)X 2514(algorithms)X 2889(in)X 2984(existence)X 3316(that)X 3469(ensure)X 3712(\(approxi-)X 555 5408(mately\))N 825(single-read)X 1207(access)X 1438(to)X 1525(a)X 1586(data)X 1745(value)X 1944(associated)X 2299(with)X 2466(any)X 2607(key.)X 2768(These)X 2984(are)X 3107(directory-less)X 3568(schemes)X 3864(such)X 555 5504(as)N 2 f 644(linear)X 857(hashing)X 1 f 1132([Lit80])X 1381(\(+)X 1475(Larson)X 1720(variations\),)X 2 f 2105(spiral)X 2313(storage)X 1 f 2575([Mar79])X 2865(or)X 2954(directory)X 3265(schemes)X 3558(such)X 3726(as)X 2 f 3814(exten-)X 555 5600(sible)N 731(hashing)X 1 f 1009([Fag79])X 1288(by)X 1393(Fagin)X 1600(et)X 1683(al.)X 1786(I)X 1838(do)X 1943(hope)X 2124(these)X 2314(sources)X 2579(provide)X 2848(a)X 2908(reasonable)X 3276(playground)X 3665(for)X 3783(experi-)X 555 5696(mentation)N 907(with)X 1081(other)X 1277(algorithms.)X 1690(See)X 1837(the)X 1966(June)X 2144(1988)X 2335(issue)X 2526(of)X 2624(ACM)X 2837(Computing)X 3227(Surveys)X 3516([Enb88])X 3810(for)X 3935(an)X 555 5792(excellent)N 865(overview)X 1184(of)X 1271(the)X 1389(\256eld.)X 4 p %%Page: 4 4 10 s 0 xH 0 xS 1 f 2216 384(-)N 2263(4)X 2323(-)X 3 f 555 672(References)N 1 f 555 824([Lar78])N 875(P.-A.)X 1064(Larson,)X 1327(``Dynamic)X 1695(Hashing'',)X 2 f 2056(BIT)X 1 f (,)S 2216(vol.)X 2378(18,)X 2518(pp.)X 2638(184-201,)X 2945(1978.)X 555 948([Tho90])N 875(Ken)X 1029(Thompson,)X 2 f 1411(private)X 1658(communication)X 1 f 2152(,)X 2192(Nov.)X 2370(1990)X 555 1072([Lit80])N 875(W.)X 992(Litwin,)X 1246(``)X 1321(Linear)X 1552(Hashing:)X 1862(A)X 1941(new)X 2096(tool)X 2261(for)X 2396(\256le)X 2539(and)X 2675(table)X 2851(addressing'',)X 2 f 3288(Proceedings)X 3709(of)X 3791(the)X 3909(6th)X 875 1168(Conference)N 1269(on)X 1373(Very)X 1548(Large)X 1782(Dabatases)X 2163(\(Montreal\))X 1 f 2515(,)X 2558(pp.)X 2701(212-223,)X 3031(Very)X 3215(Large)X 3426(Database)X 3744(Founda-)X 875 1264(tion,)N 1039(Saratoga,)X 1360(Calif.,)X 1580(1980.)X 555 1388([Fag79])N 875(R.)X 969(Fagin,)X 1192(J.)X 1284(Nievergelt,)X 1684(N.)X 1803(Pippinger,)X 2175(and)X 2332(H.)X 2451(R.)X 2544(Strong,)X 2797(``Extendible)X 3218(Hashing)X 3505(-)X 3552(A)X 3630(Fast)X 3783(Access)X 875 1484(Method)N 1144(for)X 1258(Dynamic)X 1572(Files'',)X 2 f 1821(ACM)X 2010(Trans.)X 2236(Database)X 2563(Syst.)X 1 f 2712(,)X 2752(vol.)X 2894(4,)X 2994(no.3,)X 3174(pp.)X 3294(315-344,)X 3601(Sept.)X 3783(1979.)X 555 1608([Wal84])N 875(Rich)X 1055(Wales,)X 1305(``Discussion)X 1739(of)X 1835("dbm")X 2072(data)X 2235(base)X 2406(system'',)X 2 f 2730(USENET)X 3051(newsgroup)X 3430(unix.wizards)X 1 f 3836(,)X 3884(Jan.)X 875 1704(1984.)N 555 1828([Tor87])N 875(Chris)X 1068(Torek,)X 1300(``Re:)X 1505(dbm.a)X 1743(and)X 1899(ndbm.a)X 2177(archives'',)X 2 f 2539(USENET)X 2852(newsgroup)X 3223(comp.unix)X 1 f 3555(,)X 3595(1987.)X 555 1952([Mar79])N 875(G.)X 974(N.)X 1073(Martin,)X 1332(``Spiral)X 1598(Storage:)X 1885(Incrementally)X 2371(Augmentable)X 2843(Hash)X 3048(Addressed)X 3427(Storage'',)X 2 f 3766(Techni-)X 875 2048(cal)N 993(Report)X 1231(#27)X 1 f (,)S 1391(University)X 1749(of)X 1836(Varwick,)X 2153(Coventry,)X 2491(U.K.,)X 2687(1979.)X 555 2172([Enb88])N 875(R.)X 977(J.)X 1057(Enbody)X 1335(and)X 1480(H.)X 1586(C.)X 1687(Du,)X 1833(``Dynamic)X 2209(Hashing)X 2524(Schemes'',)X 2 f 2883(ACM)X 3080(Computing)X 3463(Surveys)X 1 f 3713(,)X 3761(vol.)X 3911(20,)X 875 2268(no.)N 995(2,)X 1075(pp.)X 1195(85-113,)X 1462(June)X 1629(1988.)X 4 p %%Trailer xt xs (functioning)X 3066(without)X 3336(any)X 3478(signi\256cant)X 3837(prob-)X 555 1524(lems.)N 752(I)X 805(would,)X 1051(of)X 1144(course,)X 1400(appreciate)X 1757(all)X 1863(\256xes)X 2040(and/or)X 2271(improvements.)X 2774(Portability)X 3136(enhancements)X 3616(would)X 3841(espe-)X 555 1620(cially)N 753(be)X 849(useful.)X 3 f 555 1812(Implementation)N 1122(Issues)X 1 f 755 1936(Hash)N 944(functions:)X 1288(The)X 1437(algorithm)X 1772(behind)X 2 f 2014(sdbm)X 1 f 2207(implementation)X 27perl5.000/ext/SDBM_File/sdbm/sdbm.3 664 203 12 21370 5514407360 11675 .\" $Id: sdbm.3,v 1.2 90/12/13 13:00:57 oz Exp $ .TH SDBM 3 "1 March 1990" .SH NAME sdbm, dbm_open, dbm_prep, dbm_close, dbm_fetch, dbm_store, dbm_delete, dbm_firstkey, dbm_nextkey, dbm_hash, dbm_rdonly, dbm_error, dbm_clearerr, dbm_dirfno, dbm_pagfno \- data base subroutines .SH SYNOPSIS .nf .ft B #include .sp typedef struct { char *dptr; int dsize; } datum; .sp datum nullitem = { NULL, 0 }; .sp \s-1DBM\s0 *dbm_open(char *file, int flags, int mode) .sp \s-1DBM\s0 *dbm_prep(char *dirname, char *pagname, int flags, int mode) .sp void dbm_close(\s-1DBM\s0 *db) .sp datum dbm_fetch(\s-1DBM\s0 *db, key) .sp int dbm_store(\s-1DBM\s0 *db, datum key, datum val, int flags) .sp int dbm_delete(\s-1DBM\s0 *db, datum key) .sp datum dbm_firstkey(\s-1DBM\s0 *db) .sp datum dbm_nextkey(\s-1DBM\s0 *db) .sp long dbm_hash(char *string, int len) .sp int dbm_rdonly(\s-1DBM\s0 *db) int dbm_error(\s-1DBM\s0 *db) dbm_clearerr(\s-1DBM\s0 *db) int dbm_dirfno(\s-1DBM\s0 *db) int dbm_pagfno(\s-1DBM\s0 *db) .ft R .fi .SH DESCRIPTION .IX "database library" sdbm "" "\fLsdbm\fR" .IX dbm_open "" "\fLdbm_open\fR \(em open \fLsdbm\fR database" .IX dbm_prep "" "\fLdbm_prep\fR \(em prepare \fLsdbm\fR database" .IX dbm_close "" "\fLdbm_close\fR \(em close \fLsdbm\fR routine" .IX dbm_fetch "" "\fLdbm_fetch\fR \(em fetch \fLsdbm\fR database data" .IX dbm_store "" "\fLdbm_store\fR \(em add data to \fLsdbm\fR database" .IX dbm_delete "" "\fLdbm_delete\fR \(em remove data from \fLsdbm\fR database" .IX dbm_firstkey "" "\fLdbm_firstkey\fR \(em access \fLsdbm\fR database" .IX dbm_nextkey "" "\fLdbm_nextkey\fR \(em access \fLsdbm\fR database" .IX dbm_hash "" "\fLdbm_hash\fR \(em string hash for \fLsdbm\fR database" .IX dbm_rdonly "" "\fLdbm_rdonly\fR \(em return \fLsdbm\fR database read-only mode" .IX dbm_error "" "\fLdbm_error\fR \(em return \fLsdbm\fR database error condition" .IX dbm_clearerr "" "\fLdbm_clearerr\fR \(em clear \fLsdbm\fR database error condition" .IX dbm_dirfno "" "\fLdbm_dirfno\fR \(em return \fLsdbm\fR database bitmap file descriptor" .IX dbm_pagfno "" "\fLdbm_pagfno\fR \(em return \fLsdbm\fR database data file descriptor" .IX "database functions \(em \fLsdbm\fR" dbm_open "" \fLdbm_open\fP .IX "database functions \(em \fLsdbm\fR" dbm_prep "" \fLdbm_prep\fP .IX "database functions \(em \fLsdbm\fR" dbm_close "" \fLdbm_close\fP .IX "database functions \(em \fLsdbm\fR" dbm_fetch "" \fLdbm_fetch\fP .IX "database functions \(em \fLsdbm\fR" dbm_store "" \fLdbm_store\fP .IX "database functions \(em \fLsdbm\fR" dbm_delete "" \fLdbm_delete\fP .IX "database functions \(em \fLsdbm\fR" dbm_firstkey "" \fLdbm_firstkey\fP .IX "database functions \(em \fLsdbm\fR" dbm_nextkey "" \fLdbm_nextkey\fP .IX "database functions \(em \fLsdbm\fR" dbm_rdonly "" \fLdbm_rdonly\fP .IX "database functions \(em \fLsdbm\fR" dbm_error "" \fLdbm_error\fP .IX "database functions \(em \fLsdbm\fR" dbm_clearerr "" \fLdbm_clearerr\fP .IX "database functions \(em \fLsdbm\fR" dbm_dirfno "" \fLdbm_dirfno\fP .IX "database functions \(em \fLsdbm\fR" dbm_pagfno "" \fLdbm_pagfno\fP .LP This package allows an application to maintain a mapping of pairs in disk files. This is not to be considered a real database system, but is still useful in many simple applications built around fast retrieval of a data value from a key. This implementation uses an external hashing scheme, called Dynamic Hashing, as described by Per-Aake Larson in BIT 18 (1978) pp. 184-201. Retrieval of any item usually requires a single disk access. The application interface is compatible with the .IR ndbm (3) library. .LP An .B sdbm database is kept in two files usually given the extensions .B \.dir and .BR \.pag . The .B \.dir file contains a bitmap representing a forest of binary hash trees, the leaves of which indicate data pages in the .B \.pag file. .LP The application interface uses the .B datum structure to describe both .I keys and .IR value s. A .B datum specifies a byte sequence of .I dsize size pointed to by .IR dptr . If you use .SM ASCII strings as .IR key s or .IR value s, then you must decide whether or not to include the terminating .SM NUL byte which sometimes defines strings. Including it will require larger database files, but it will be possible to get sensible output from a .IR strings (1) command applied to the data file. .LP In order to allow a process using this package to manipulate multiple databases, the applications interface always requires a .IR handle , a .BR "DBM *" , to identify the database to be manipulated. Such a handle can be obtained from the only routines that do not require it, namely .BR dbm_open (\|) or .BR dbm_prep (\|). Either of these will open or create the two necessary files. The difference is that the latter allows explicitly naming the bitmap and data files whereas .BR dbm_open (\|) will take a base file name and call .BR dbm_prep (\|) with the default extensions. The .I flags and .I mode parameters are the same as for .BR open (2). .LP To free the resources occupied while a database handle is active, call .BR dbm_close (\|). .LP Given a handle, one can retrieve data associated with a key by using the .BR dbm_fetch (\|) routine, and associate data with a key by using the .BR dbm_store (\|) routine. .LP The values of the .I flags parameter for .BR dbm_store (\|) can be either .BR \s-1DBM_INSERT\s0 , which will not change an existing entry with the same key, or .BR \s-1DBM_REPLACE\s0 , which will replace an existing entry with the same key. Keys are unique within the database. .LP To delete a key and its associated value use the .BR dbm_delete (\|) routine. .LP To retrieve every key in the database, use a loop like: .sp .nf .ft B for (key = dbm_firstkey(db); key.dptr != NULL; key = dbm_nextkey(db)) ; .ft R .fi .LP The order of retrieval is unspecified. .LP If you determine that the performance of the database is inadequate or you notice clustering or other effects that may be due to the hashing algorithm used by this package, you can override it by supplying your own .BR dbm_hash (\|) routine. Doing so will make the database unintelligable to any other applications that do not use your specialized hash function. .sp .LP The following macros are defined in the header file: .IP .BR dbm_rdonly (\|) returns true if the database has been opened read\-only. .IP .BR dbm_error (\|) returns true if an I/O error has occurred. .IP .BR dbm_clearerr (\|) allows you to clear the error flag if you think you know what the error was and insist on ignoring it. .IP .BR dbm_dirfno (\|) returns the file descriptor associated with the bitmap file. .IP .BR dbm_pagfno (\|) returns the file descriptor associated with the data file. .SH SEE ALSO .IR open (2). .SH DIAGNOSTICS Functions that return a .B "DBM *" handle will use .SM NULL to indicate an error. Functions that return an .B int will use \-1 to indicate an error. The normal return value in that case is 0. Functions that return a .B datum will return .B nullitem to indicate an error. .LP As a special case of .BR dbm_store (\|), if it is called with the .B \s-1DBM_INSERT\s0 flag and the key already exists in the database, the return value will be 1. .LP In general, if a function parameter is invalid, .B errno will be set to .BR \s-1EINVAL\s0 . If a write operation is requested on a read-only database, .B errno will be set to .BR \s-1ENOPERM\s0 . If a memory allocation (using .IR malloc (3)) failed, .B errno will be set to .BR \s-1ENOMEM\s0 . For I/O operation failures .B errno will contain the value set by the relevant failed system call, either .IR read (2), .IR write (2), or .IR lseek (2). .SH AUTHOR .IP "Ozan S. Yigit" (oz@nexus.yorku.ca) .SH BUGS The sum of key and value data sizes must not exceed .B \s-1PAIRMAX\s0 (1008 bytes). .LP The sum of the key and value data sizes where several keys hash to the same value must fit within one bitmap page. .LP The .B \.pag file will contain holes, so its apparent size is larger than its contents. When copied through the filesystem the holes will be filled. .LP The contents of .B datum values returned are in volatile storage. If you want to retain the values pointed to, you must copy them immediately before another call to this package. .LP The only safe way for multiple processes to (read and) update a database at the same time, is to implement a private locking scheme outside this package and open and close the database between lock acquisitions. It is safe for multiple processes to concurrently access a database read-only. .SH APPLICATIONS PORTABILITY For complete source code compatibility with the Berkeley Unix .IR ndbm (3) library, the .B sdbm.h header file should be installed in .BR /usr/include/ndbm.h . .LP The .B nullitem data item, and the .BR dbm_prep (\|), .BR dbm_hash (\|), .BR dbm_rdonly (\|), .BR dbm_dirfno (\|), and .BR dbm_pagfno (\|) functions are unique to this package. y mode" .IX dbm_error "" "\fLdbm_error\fR \(em return \fLsdbm\fR database error condition" .IX dbm_clearerr "" "\fLdbm_clearerr\fR \(em clear \fLsdbm\fR database error condition" .IX dbm_dirfno "" "\fLdbm_dirfno\fR \(em return \fLsdbm\fR database bitmap file descrperl5.000/ext/SDBM_File/sdbm/sdbm.c 664 203 12 25336 5562013424 11760 /* * sdbm - ndbm work-alike hashed database library * based on Per-Aake Larson's Dynamic Hashing algorithms. BIT 18 (1978). * author: oz@nexus.yorku.ca * status: public domain. * * core routines */ #ifndef lint static char rcsid[] = "$Id: sdbm.c,v 1.16 90/12/13 13:01:31 oz Exp $"; #endif #include "config.h" #include "sdbm.h" #include "tune.h" #include "pair.h" #ifdef I_FCNTL # include #endif #ifdef I_SYS_FILE # include #endif #ifdef I_STRING # include #else # include #endif /* * externals */ #ifndef sun extern int errno; #endif extern Malloc_t malloc proto((MEM_SIZE)); extern void free proto((void *)); extern Off_t lseek(); /* * forward */ static int getdbit proto((DBM *, long)); static int setdbit proto((DBM *, long)); static int getpage proto((DBM *, long)); static datum getnext proto((DBM *)); static int makroom proto((DBM *, long, int)); /* * useful macros */ #define bad(x) ((x).dptr == NULL || (x).dsize < 0) #define exhash(item) sdbm_hash((item).dptr, (item).dsize) #define ioerr(db) ((db)->flags |= DBM_IOERR) #define OFF_PAG(off) (long) (off) * PBLKSIZ #define OFF_DIR(off) (long) (off) * DBLKSIZ static long masks[] = { 000000000000, 000000000001, 000000000003, 000000000007, 000000000017, 000000000037, 000000000077, 000000000177, 000000000377, 000000000777, 000000001777, 000000003777, 000000007777, 000000017777, 000000037777, 000000077777, 000000177777, 000000377777, 000000777777, 000001777777, 000003777777, 000007777777, 000017777777, 000037777777, 000077777777, 000177777777, 000377777777, 000777777777, 001777777777, 003777777777, 007777777777, 017777777777 }; datum nullitem = {NULL, 0}; DBM * sdbm_open(file, flags, mode) register char *file; register int flags; register int mode; { register DBM *db; register char *dirname; register char *pagname; register int n; if (file == NULL || !*file) return errno = EINVAL, (DBM *) NULL; /* * need space for two seperate filenames */ n = strlen(file) * 2 + strlen(DIRFEXT) + strlen(PAGFEXT) + 2; if ((dirname = malloc((unsigned) n)) == NULL) return errno = ENOMEM, (DBM *) NULL; /* * build the file names */ dirname = strcat(strcpy(dirname, file), DIRFEXT); pagname = strcpy(dirname + strlen(dirname) + 1, file); pagname = strcat(pagname, PAGFEXT); db = sdbm_prep(dirname, pagname, flags, mode); free((char *) dirname); return db; } DBM * sdbm_prep(dirname, pagname, flags, mode) char *dirname; char *pagname; int flags; int mode; { register DBM *db; struct stat dstat; if ((db = (DBM *) malloc(sizeof(DBM))) == NULL) return errno = ENOMEM, (DBM *) NULL; db->flags = 0; db->hmask = 0; db->blkptr = 0; db->keyptr = 0; /* * adjust user flags so that WRONLY becomes RDWR, * as required by this package. Also set our internal * flag for RDONLY if needed. */ if (flags & O_WRONLY) flags = (flags & ~O_WRONLY) | O_RDWR; else if ((flags & 03) == O_RDONLY) db->flags = DBM_RDONLY; /* * open the files in sequence, and stat the dirfile. * If we fail anywhere, undo everything, return NULL. */ if ((db->pagf = open(pagname, flags, mode)) > -1) { if ((db->dirf = open(dirname, flags, mode)) > -1) { /* * need the dirfile size to establish max bit number. */ if (fstat(db->dirf, &dstat) == 0) { /* * zero size: either a fresh database, or one with a single, * unsplit data page: dirpage is all zeros. */ db->dirbno = (!dstat.st_size) ? 0 : -1; db->pagbno = -1; db->maxbno = dstat.st_size * BYTESIZ; (void) memset(db->pagbuf, 0, PBLKSIZ); (void) memset(db->dirbuf, 0, DBLKSIZ); /* * success */ return db; } (void) close(db->dirf); } (void) close(db->pagf); } free((char *) db); return (DBM *) NULL; } void sdbm_close(db) register DBM *db; { if (db == NULL) errno = EINVAL; else { (void) close(db->dirf); (void) close(db->pagf); free((char *) db); } } datum sdbm_fetch(db, key) register DBM *db; datum key; { if (db == NULL || bad(key)) return errno = EINVAL, nullitem; if (getpage(db, exhash(key))) return getpair(db->pagbuf, key); return ioerr(db), nullitem; } int sdbm_delete(db, key) register DBM *db; datum key; { if (db == NULL || bad(key)) return errno = EINVAL, -1; if (sdbm_rdonly(db)) return errno = EPERM, -1; if (getpage(db, exhash(key))) { if (!delpair(db->pagbuf, key)) return -1; /* * update the page file */ if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) return ioerr(db), -1; return 0; } return ioerr(db), -1; } int sdbm_store(db, key, val, flags) register DBM *db; datum key; datum val; int flags; { int need; register long hash; if (db == NULL || bad(key)) return errno = EINVAL, -1; if (sdbm_rdonly(db)) return errno = EPERM, -1; need = key.dsize + val.dsize; /* * is the pair too big (or too small) for this database ?? */ if (need < 0 || need > PAIRMAX) return errno = EINVAL, -1; if (getpage(db, (hash = exhash(key)))) { /* * if we need to replace, delete the key/data pair * first. If it is not there, ignore. */ if (flags == DBM_REPLACE) (void) delpair(db->pagbuf, key); #ifdef SEEDUPS else if (duppair(db->pagbuf, key)) return 1; #endif /* * if we do not have enough room, we have to split. */ if (!fitpair(db->pagbuf, need)) if (!makroom(db, hash, need)) return ioerr(db), -1; /* * we have enough room or split is successful. insert the key, * and update the page file. */ (void) putpair(db->pagbuf, key, val); if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) return ioerr(db), -1; /* * success */ return 0; } return ioerr(db), -1; } /* * makroom - make room by splitting the overfull page * this routine will attempt to make room for SPLTMAX times before * giving up. */ static int makroom(db, hash, need) register DBM *db; long hash; int need; { long newp; char twin[PBLKSIZ]; char *pag = db->pagbuf; char *new = twin; register int smax = SPLTMAX; do { /* * split the current page */ (void) splpage(pag, new, db->hmask + 1); /* * address of the new page */ newp = (hash & db->hmask) | (db->hmask + 1); /* * write delay, read avoidence/cache shuffle: * select the page for incoming pair: if key is to go to the new page, * write out the previous one, and copy the new one over, thus making * it the current page. If not, simply write the new page, and we are * still looking at the page of interest. current page is not updated * here, as sdbm_store will do so, after it inserts the incoming pair. */ if (hash & (db->hmask + 1)) { if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) return 0; db->pagbno = newp; (void) memcpy(pag, new, PBLKSIZ); } else if (lseek(db->pagf, OFF_PAG(newp), SEEK_SET) < 0 || write(db->pagf, new, PBLKSIZ) < 0) return 0; if (!setdbit(db, db->curbit)) return 0; /* * see if we have enough room now */ if (fitpair(pag, need)) return 1; /* * try again... update curbit and hmask as getpage would have * done. because of our update of the current page, we do not * need to read in anything. BUT we have to write the current * [deferred] page out, as the window of failure is too great. */ db->curbit = 2 * db->curbit + ((hash & (db->hmask + 1)) ? 2 : 1); db->hmask |= db->hmask + 1; if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) return 0; } while (--smax); /* * if we are here, this is real bad news. After SPLTMAX splits, * we still cannot fit the key. say goodnight. */ #ifdef BADMESS (void) write(2, "sdbm: cannot insert after SPLTMAX attempts.\n", 44); #endif return 0; } /* * the following two routines will break if * deletions aren't taken into account. (ndbm bug) */ datum sdbm_firstkey(db) register DBM *db; { if (db == NULL) return errno = EINVAL, nullitem; /* * start at page 0 */ if (lseek(db->pagf, OFF_PAG(0), SEEK_SET) < 0 || read(db->pagf, db->pagbuf, PBLKSIZ) < 0) return ioerr(db), nullitem; db->pagbno = 0; db->blkptr = 0; db->keyptr = 0; return getnext(db); } datum sdbm_nextkey(db) register DBM *db; { if (db == NULL) return errno = EINVAL, nullitem; return getnext(db); } /* * all important binary trie traversal */ static int getpage(db, hash) register DBM *db; register long hash; { register int hbit; register long dbit; register long pagb; dbit = 0; hbit = 0; while (dbit < db->maxbno && getdbit(db, dbit)) dbit = 2 * dbit + ((hash & (1 << hbit++)) ? 2 : 1); debug(("dbit: %d...", dbit)); db->curbit = dbit; db->hmask = masks[hbit]; pagb = hash & db->hmask; /* * see if the block we need is already in memory. * note: this lookaside cache has about 10% hit rate. */ if (pagb != db->pagbno) { /* * note: here, we assume a "hole" is read as 0s. * if not, must zero pagbuf first. */ if (lseek(db->pagf, OFF_PAG(pagb), SEEK_SET) < 0 || read(db->pagf, db->pagbuf, PBLKSIZ) < 0) return 0; if (!chkpage(db->pagbuf)) return 0; db->pagbno = pagb; debug(("pag read: %d\n", pagb)); } return 1; } static int getdbit(db, dbit) register DBM *db; register long dbit; { register long c; register long dirb; c = dbit / BYTESIZ; dirb = c / DBLKSIZ; if (dirb != db->dirbno) { if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 || read(db->dirf, db->dirbuf, DBLKSIZ) < 0) return 0; db->dirbno = dirb; debug(("dir read: %d\n", dirb)); } return db->dirbuf[c % DBLKSIZ] & (1 << dbit % BYTESIZ); } static int setdbit(db, dbit) register DBM *db; register long dbit; { register long c; register long dirb; c = dbit / BYTESIZ; dirb = c / DBLKSIZ; if (dirb != db->dirbno) { if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 || read(db->dirf, db->dirbuf, DBLKSIZ) < 0) return 0; db->dirbno = dirb; debug(("dir read: %d\n", dirb)); } db->dirbuf[c % DBLKSIZ] |= (1 << dbit % BYTESIZ); if (dbit >= db->maxbno) db->maxbno += DBLKSIZ * BYTESIZ; if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 || write(db->dirf, db->dirbuf, DBLKSIZ) < 0) return 0; return 1; } /* * getnext - get the next key in the page, and if done with * the page, try the next page in sequence */ static datum getnext(db) register DBM *db; { datum key; for (;;) { db->keyptr++; key = getnkey(db->pagbuf, db->keyptr); if (key.dptr != NULL) return key; /* * we either run out, or there is nothing on this page.. * try the next one... If we lost our position on the * file, we will have to seek. */ db->keyptr = 0; if (db->pagbno != db->blkptr++) if (lseek(db->pagf, OFF_PAG(db->blkptr), SEEK_SET) < 0) break; db->pagbno = db->blkptr; if (read(db->pagf, db->pagbuf, PBLKSIZ) <= 0) break; if (!chkpage(db->pagbuf)) break; } return ioerr(db), nullitem; } if (!fitpair(db->pagbuf, need)) if (!makroom(db, hash, need)) return ioerr(db), -1; /* * we have enough room or split is successful. insert the key, * and update the page file. */ (void) putpair(db->pagbuf, key, val); if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0perl5.000/ext/SDBM_File/sdbm/sdbm.h 664 203 12 12624 5614656047 11775 /* * sdbm - ndbm work-alike hashed database library * based on Per-Ake Larson's Dynamic Hashing algorithms. BIT 18 (1978). * author: oz@nexus.yorku.ca * status: public domain. */ #define DBLKSIZ 4096 #define PBLKSIZ 1024 #define PAIRMAX 1008 /* arbitrary on PBLKSIZ-N */ #define SPLTMAX 10 /* maximum allowed splits */ /* for a single insertion */ #define DIRFEXT ".dir" #define PAGFEXT ".pag" typedef struct { int dirf; /* directory file descriptor */ int pagf; /* page file descriptor */ int flags; /* status/error flags, see below */ long maxbno; /* size of dirfile in bits */ long curbit; /* current bit number */ long hmask; /* current hash mask */ long blkptr; /* current block for nextkey */ int keyptr; /* current key for nextkey */ long blkno; /* current page to read/write */ long pagbno; /* current page in pagbuf */ char pagbuf[PBLKSIZ]; /* page file block buffer */ long dirbno; /* current block in dirbuf */ char dirbuf[DBLKSIZ]; /* directory file block buffer */ } DBM; #define DBM_RDONLY 0x1 /* data base open read-only */ #define DBM_IOERR 0x2 /* data base I/O error */ /* * utility macros */ #define sdbm_rdonly(db) ((db)->flags & DBM_RDONLY) #define sdbm_error(db) ((db)->flags & DBM_IOERR) #define sdbm_clearerr(db) ((db)->flags &= ~DBM_IOERR) /* ouch */ #define sdbm_dirfno(db) ((db)->dirf) #define sdbm_pagfno(db) ((db)->pagf) typedef struct { char *dptr; int dsize; } datum; extern datum nullitem; #ifdef __STDC__ #define proto(p) p #else #define proto(p) () #endif /* * flags to sdbm_store */ #define DBM_INSERT 0 #define DBM_REPLACE 1 /* * ndbm interface */ extern DBM *sdbm_open proto((char *, int, int)); extern void sdbm_close proto((DBM *)); extern datum sdbm_fetch proto((DBM *, datum)); extern int sdbm_delete proto((DBM *, datum)); extern int sdbm_store proto((DBM *, datum, datum, int)); extern datum sdbm_firstkey proto((DBM *)); extern datum sdbm_nextkey proto((DBM *)); /* * other */ extern DBM *sdbm_prep proto((char *, char *, int, int)); extern long sdbm_hash proto((char *, int)); #ifndef SDBM_ONLY #define dbm_open sdbm_open; #define dbm_close sdbm_close; #define dbm_fetch sdbm_fetch; #define dbm_store sdbm_store; #define dbm_delete sdbm_delete; #define dbm_firstkey sdbm_firstkey; #define dbm_nextkey sdbm_nextkey; #define dbm_error sdbm_error; #define dbm_clearerr sdbm_clearerr; #endif /* Most of the following is stolen from perl.h. */ #ifndef H_PERL /* Include guard */ /* * The following contortions are brought to you on behalf of all the * standards, semi-standards, de facto standards, not-so-de-facto standards * of the world, as well as all the other botches anyone ever thought of. * The basic theory is that if we work hard enough here, the rest of the * code can be a lot prettier. Well, so much for theory. Sorry, Henry... */ #include #ifdef HAS_SOCKET # ifdef I_NET_ERRNO # include # endif #endif #ifdef MYMALLOC # ifdef HIDEMYMALLOC # define malloc Mymalloc # define realloc Myremalloc # define free Myfree # endif # define safemalloc malloc # define saferealloc realloc # define safefree free #endif #if defined(__STDC__) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) # define STANDARD_C 1 #endif #include #include #include #ifdef I_UNISTD #include #endif #ifndef MSDOS # ifdef PARAM_NEEDS_TYPES # include # endif # include #endif #ifndef _TYPES_ /* If types.h defines this it's easy. */ # ifndef major /* Does everyone's types.h define this? */ # include # endif #endif #include #ifndef SEEK_SET # ifdef L_SET # define SEEK_SET L_SET # else # define SEEK_SET 0 /* Wild guess. */ # endif #endif /* Use all the "standard" definitions? */ #ifdef STANDARD_C # include #endif /* STANDARD_C */ #define MEM_SIZE Size_t #ifdef I_STRING #include #else #include #endif #ifdef I_MEMORY #include #endif #if defined(mips) && defined(ultrix) && !defined(__STDC__) # undef HAS_MEMCMP #endif #ifdef HAS_MEMCPY # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memcpy extern char * memcpy _((char*, char*, int)); # endif # endif #else # ifndef memcpy # ifdef HAS_BCOPY # define memcpy(d,s,l) bcopy(s,d,l) # else # define memcpy(d,s,l) my_bcopy(s,d,l) # endif # endif #endif /* HAS_MEMCPY */ #ifdef HAS_MEMSET # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memset extern char *memset _((char*, int, int)); # endif # endif # define memzero(d,l) memset(d,0,l) #else # ifndef memzero # ifdef HAS_BZERO # define memzero(d,l) bzero(d,l) # else # define memzero(d,l) my_bzero(d,l) # endif # endif #endif /* HAS_MEMSET */ #ifdef HAS_MEMCMP # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memcmp extern int memcmp _((char*, char*, int)); # endif # endif #else # ifndef memcmp # define memcmp(s1,s2,l) my_memcmp(s1,s2,l) # endif #endif /* HAS_MEMCMP */ /* we prefer bcmp slightly for comparisons that don't care about ordering */ #ifndef HAS_BCMP # ifndef bcmp # define bcmp(s1,s2,l) memcmp(s1,s2,l) # endif #endif /* HAS_BCMP */ #ifdef I_NETINET_IN # include #endif #endif /* Include guard */ ->pagbuf, PBLKSIZ) < 0) return 0; if (!chkpage(db->pagbuf)) return 0; db->pagbno = pagb; debug(perl5.000/ext/SDBM_File/sdbm/tune.h 664 203 12 671 5562013425 11747 /* * sdbm - ndbm work-alike hashed database library * tuning and portability constructs [not nearly enough] * author: oz@nexus.yorku.ca */ #define BYTESIZ 8 /* * important tuning parms (hah) */ #define SEEDUPS /* always detect duplicates */ #define BADMESS /* generate a message for worst case: cannot make room after SPLTMAX splits */ /* * misc */ #ifdef DEBUG #define debug(x) printf x #else #define debug(x) #endif err; #endif /* Most of the following is stolen from perl.h. */ #ifndefperl5.000/ext/SDBM_File/sdbm/util.c 664 203 12 1377 5514407361 11773 #include #ifdef SDBM #include "sdbm.h" #else #include "ndbm.h" #endif void oops(s1, s2) register char *s1; register char *s2; { extern int errno, sys_nerr; extern char *sys_errlist[]; extern char *progname; if (progname) fprintf(stderr, "%s: ", progname); fprintf(stderr, s1, s2); if (errno > 0 && errno < sys_nerr) fprintf(stderr, " (%s)", sys_errlist[errno]); fprintf(stderr, "\n"); exit(1); } int okpage(pag) char *pag; { register unsigned n; register off; register short *ino = (short *) pag; if ((n = ino[0]) > PBLKSIZ / sizeof(short)) return 0; if (!n) return 1; off = PBLKSIZ; for (ino++; n; ino += 2) { if (ino[0] > off || ino[1] > off || ino[1] > ino[0]) return 0; off = ino[1]; n -= 2; } return 1; } The basic theory is that if we work hard enough here, the rest of the * code can be a lot prettier. Well, so much for theory. Sorry, Henry... */ #include #ifdef HAS_SOCKET # ifdef I_NET_ERRNO # include # endif #endif #iperl5.000/ext/SDBM_File/typemap 664 203 12 652 5576407570 11314 # #################################### DBM SECTION # datum T_DATUM gdatum T_GDATUM NDBM_File T_PTROBJ GDBM_File T_PTROBJ SDBM_File T_PTROBJ ODBM_File T_PTROBJ DB_File T_PTROBJ DBZ_File T_PTROBJ FATALFUNC T_OPAQUEPTR INPUT T_DATUM $var.dptr = SvPV($arg, na); $var.dsize = (int)na; T_GDATUM UNIMPLEMENTED OUTPUT T_DATUM sv_setpvn($arg, $var.dptr, $var.dsize); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); kpage(pag) char *pag; { register unsigned n; register off; register short *ino = (sperl5.000/ext/Socket/ 775 203 12 0 5650575672 7410 perl5.000/ext/Socket/Makefile.SH 664 203 12 12323 5650410574 11454 : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac 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 fi : Find absolute path name for TOP. This is needed when we cd to TOP : to run perl on autosplit. oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd case $CONFIG in '') . $TOP/config.sh ;; esac : Find out directory name. This is also the extension name. ext=`pwd | $sed -e 's@.*/@@'` : This extension might have its own typemap if test -f typemap; then exttypemap='typemap' else exttypemap='' fi : This extension might need additional libraries. potential_libs=" " . $TOP/ext/util/extliblist : This extension might need bootstrap support if test -f ${ext}_BS; then bootdep=${ext}_BS else bootdep='' fi case "$dlsrc" in dl_aix*) echo "#!" > $ext.exp echo "boot_$ext" >> $ext.exp ;; esac echo "Extracting ext/$ext/Makefile (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted : by putting a backslash in front. You may delete these comments. $spitshell >Makefile << !GROK!THIS! # # This Makefile is for the $ext extension to perl. # CC = $cc RANLIB = $ranlib TOP = $TOP ABSTOP = $ABSTOP LDFLAGS = $ldflags CLDFLAGS = $ldflags SMALL = $small LARGE = $large $split # To use an alternate make, set \$altmake in config.sh. MAKE = ${altmake-make} EXT = $ext # $ext might have its own typemap EXTTYPEMAP = $exttypemap # $ext might have its own bootstrap support BOOTDEP = $bootdep BOOTSTRAP = $ext.bs # The following are used to build and install shared libraries for # dynamic loading. LDDLFLAGS = $lddlflags CCDLFLAGS = $ccdlflags CCCDLFLAGS = $cccdlflags SO = $so DLEXT = $dlext # $ext might need to be linked with some extra libraries. # EXTRALIBS = full list of libraries needed for static linking. # Only those libraries that actually exist are included. # DYNLOADLIBS = list of those libraries that are needed but can be # linked in dynamically on this platform. On SunOS, for # example, this would be .so* libraries, but not archive # libraries. The bootstrap file is installed only if # this list is not empty. # STATLOADLIBS = list of those libraries which must be statically # linked into the shared library. On SunOS 4.1.3, # for example, I have only an archive version of # -lm, and it must be linked in statically. EXTRALIBS = $extralibs DYNALOADLIBS = $dynaloadlibs STATLOADLIBS = $statloadlibs !GROK!THIS! $spitshell >>Makefile <<'!NO!SUBS!' # Where to put things: AUTO = $(TOP)/lib/auto INSTALLBOOT = $(AUTO)/$(EXT)/$(EXT).bs INSTALLDYNAMIC = $(AUTO)/$(EXT)/$(EXT).$(DLEXT) INSTALLSTATIC = $(EXT).a INSTALLPM = $(TOP)/lib/$(EXT).pm PERL = $(ABSTOP)/miniperl XSUBPP = $(TOP)/ext/xsubpp SHELL = /bin/sh CCCMD = `sh $(shellflags) $(TOP)/cflags $@` .c.o: $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c all: dynamic # Phony target to force checking subdirectories. FORCE: config: # Target for Dynamic Loading: dynamic: $(INSTALLDYNAMIC) $(INSTALLPM) $(INSTALLBOOT) $(INSTALLDYNAMIC): $(EXT).o @test -d $(AUTO) || mkdir $(AUTO) @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) ld $(LDDLFLAGS) -o $@ $(EXT).o $(STATLOADLIBS) $(BOOTSTRAP): Makefile $(BOOTDEP) $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) touch $(BOOTSTRAP) $(INSTALLBOOT): $(BOOTSTRAP) @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ # Target for Static Loading: static: $(INSTALLSTATIC) $(INSTALLPM) $(INSTALLSTATIC): $(EXT).o ar cr $@ $(EXT).o $(RANLIB) $@ echo $(EXTRALIBS) >> $(TOP)/ext.libs $(EXT).c: $(EXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile $(PERL) $(XSUBPP) $(EXT).xs >tmp mv tmp $@ $(INSTALLPM): $(EXT).pm rm -f $@ cp $(EXT).pm $@ cd $(TOP); $(PERL) autosplit $(EXT) clean: rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp realclean: clean rm -f makefile Makefile rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) rm -rf $(AUTO)/$(EXT) purge: realclean $(EXT).o : $(TOP)/EXTERN.h $(EXT).o : $(TOP)/perl.h $(EXT).o : $(TOP)/embed.h $(EXT).o : $(TOP)/config.h $(EXT).o : $(TOP)/unixish.h $(EXT).o : $(TOP)/handy.h $(EXT).o : $(TOP)/regexp.h $(EXT).o : $(TOP)/sv.h $(EXT).o : $(TOP)/util.h $(EXT).o : $(TOP)/form.h $(EXT).o : $(TOP)/gv.h $(EXT).o : $(TOP)/cv.h $(EXT).o : $(TOP)/opcode.h $(EXT).o : $(TOP)/op.h $(EXT).o : $(TOP)/cop.h $(EXT).o : $(TOP)/av.h $(EXT).o : $(TOP)/hv.h $(EXT).o : $(TOP)/mg.h $(EXT).o : $(TOP)/scope.h $(EXT).o : $(TOP)/pp.h $(EXT).o : $(TOP)/proto.h $(EXT).o : $(TOP)/XSUB.h Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH $(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH $(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH $(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH !NO!SUBS! chmod 644 Makefile $eunicefix Makefile llitem; } if (!fitpair(db->pagbuf, need)) if (!makroom(db, hash, need)) return ioerr(db), -1; /* * we have enough room or split is successful. insert the key, * and update the page file. */ (void) putpair(db->pagbuf, key, val); if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0perl5.000/ext/Socket/Socket.pm 664 203 12 3127 5626223745 11260 package Socket; use Carp; require Exporter; require AutoLoader; require DynaLoader; @ISA = (Exporter, AutoLoader, DynaLoader); @EXPORT = qw( AF_802 AF_APPLETALK AF_CCITT AF_CHAOS AF_DATAKIT AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK AF_INET AF_LAT AF_MAX AF_NBS AF_NIT AF_NS AF_OSI AF_OSINET AF_PUP AF_SNA AF_UNIX AF_UNSPEC AF_X25 MSG_DONTROUTE MSG_MAXIOVLEN MSG_OOB MSG_PEEK PF_802 PF_APPLETALK PF_CCITT PF_CHAOS PF_DATAKIT PF_DECnet PF_DLI PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_LAT PF_MAX PF_NBS PF_NIT PF_NS PF_OSI PF_OSINET PF_PUP PF_SNA PF_UNIX PF_UNSPEC PF_X25 SOCK_DGRAM SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM SOL_SOCKET SOMAXCONN SO_ACCEPTCONN SO_BROADCAST SO_DEBUG SO_DONTLINGER SO_DONTROUTE SO_ERROR SO_KEEPALIVE SO_LINGER SO_OOBINLINE SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO SO_REUSEADDR SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO SO_TYPE SO_USELOOPBACK ); sub AUTOLOAD { if (@_ > 1) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } local($constname); ($constname = $AUTOLOAD) =~ s/.*:://; $val = constant($constname, @_ ? $_[0] : 0); if ($! != 0) { if ($! =~ /Invalid/) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } else { ($pack,$file,$line) = caller; croak "Your vendor has not defined Socket macro $constname, used"; } } eval "sub $AUTOLOAD { $val }"; goto &$AUTOLOAD; } bootstrap Socket; # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. 1; __END__ perl. # CC = $cc RANLIB = $ranlib TOP = $TOP ABSTOP = $ABSTOP LDFLAGS = $ldflags CLDFLAGS = $ldflags SMALL = $small LARGE = $large $split # To use an alternate make, set \$altmake in config.sh. MAKE = ${altmake-make} EXT = $ext # $ext might have its own typemap EXTTYPEMAP = $exttypemap # $ext might have its own bootstrap support BOOTDEP = $bootdep BOOTSTRAP = $ext.bs # The following are used to build and install sperl5.000/ext/Socket/Socket.xs 664 203 12 22000 5645376150 11305 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include #ifndef AF_NBS #undef PF_NBS #endif #ifndef AF_X25 #undef PF_X25 #endif static int not_here(s) char *s; { croak("Socket::%s not implemented on this architecture", s); return -1; } static double constant(name, arg) char *name; int arg; { errno = 0; switch (*name) { case 'A': if (strEQ(name, "AF_802")) #ifdef AF_802 return AF_802; #else goto not_there; #endif if (strEQ(name, "AF_APPLETALK")) #ifdef AF_APPLETALK return AF_APPLETALK; #else goto not_there; #endif if (strEQ(name, "AF_CCITT")) #ifdef AF_CCITT return AF_CCITT; #else goto not_there; #endif if (strEQ(name, "AF_CHAOS")) #ifdef AF_CHAOS return AF_CHAOS; #else goto not_there; #endif if (strEQ(name, "AF_DATAKIT")) #ifdef AF_DATAKIT return AF_DATAKIT; #else goto not_there; #endif if (strEQ(name, "AF_DECnet")) #ifdef AF_DECnet return AF_DECnet; #else goto not_there; #endif if (strEQ(name, "AF_DLI")) #ifdef AF_DLI return AF_DLI; #else goto not_there; #endif if (strEQ(name, "AF_ECMA")) #ifdef AF_ECMA return AF_ECMA; #else goto not_there; #endif if (strEQ(name, "AF_GOSIP")) #ifdef AF_GOSIP return AF_GOSIP; #else goto not_there; #endif if (strEQ(name, "AF_HYLINK")) #ifdef AF_HYLINK return AF_HYLINK; #else goto not_there; #endif if (strEQ(name, "AF_IMPLINK")) #ifdef AF_IMPLINK return AF_IMPLINK; #else goto not_there; #endif if (strEQ(name, "AF_INET")) #ifdef AF_INET return AF_INET; #else goto not_there; #endif if (strEQ(name, "AF_LAT")) #ifdef AF_LAT return AF_LAT; #else goto not_there; #endif if (strEQ(name, "AF_MAX")) #ifdef AF_MAX return AF_MAX; #else goto not_there; #endif if (strEQ(name, "AF_NBS")) #ifdef AF_NBS return AF_NBS; #else goto not_there; #endif if (strEQ(name, "AF_NIT")) #ifdef AF_NIT return AF_NIT; #else goto not_there; #endif if (strEQ(name, "AF_NS")) #ifdef AF_NS return AF_NS; #else goto not_there; #endif if (strEQ(name, "AF_OSI")) #ifdef AF_OSI return AF_OSI; #else goto not_there; #endif if (strEQ(name, "AF_OSINET")) #ifdef AF_OSINET return AF_OSINET; #else goto not_there; #endif if (strEQ(name, "AF_PUP")) #ifdef AF_PUP return AF_PUP; #else goto not_there; #endif if (strEQ(name, "AF_SNA")) #ifdef AF_SNA return AF_SNA; #else goto not_there; #endif if (strEQ(name, "AF_UNIX")) #ifdef AF_UNIX return AF_UNIX; #else goto not_there; #endif if (strEQ(name, "AF_UNSPEC")) #ifdef AF_UNSPEC return AF_UNSPEC; #else goto not_there; #endif if (strEQ(name, "AF_X25")) #ifdef AF_X25 return AF_X25; #else goto not_there; #endif break; case 'B': break; case 'C': break; case 'D': break; case 'E': break; case 'F': break; case 'G': break; case 'H': break; case 'I': break; case 'J': break; case 'K': break; case 'L': break; case 'M': if (strEQ(name, "MSG_DONTROUTE")) #ifdef MSG_DONTROUTE return MSG_DONTROUTE; #else goto not_there; #endif if (strEQ(name, "MSG_MAXIOVLEN")) #ifdef MSG_MAXIOVLEN return MSG_MAXIOVLEN; #else goto not_there; #endif if (strEQ(name, "MSG_OOB")) #ifdef MSG_OOB return MSG_OOB; #else goto not_there; #endif if (strEQ(name, "MSG_PEEK")) #ifdef MSG_PEEK return MSG_PEEK; #else goto not_there; #endif break; case 'N': break; case 'O': break; case 'P': if (strEQ(name, "PF_802")) #ifdef PF_802 return PF_802; #else goto not_there; #endif if (strEQ(name, "PF_APPLETALK")) #ifdef PF_APPLETALK return PF_APPLETALK; #else goto not_there; #endif if (strEQ(name, "PF_CCITT")) #ifdef PF_CCITT return PF_CCITT; #else goto not_there; #endif if (strEQ(name, "PF_CHAOS")) #ifdef PF_CHAOS return PF_CHAOS; #else goto not_there; #endif if (strEQ(name, "PF_DATAKIT")) #ifdef PF_DATAKIT return PF_DATAKIT; #else goto not_there; #endif if (strEQ(name, "PF_DECnet")) #ifdef PF_DECnet return PF_DECnet; #else goto not_there; #endif if (strEQ(name, "PF_DLI")) #ifdef PF_DLI return PF_DLI; #else goto not_there; #endif if (strEQ(name, "PF_ECMA")) #ifdef PF_ECMA return PF_ECMA; #else goto not_there; #endif if (strEQ(name, "PF_GOSIP")) #ifdef PF_GOSIP return PF_GOSIP; #else goto not_there; #endif if (strEQ(name, "PF_HYLINK")) #ifdef PF_HYLINK return PF_HYLINK; #else goto not_there; #endif if (strEQ(name, "PF_IMPLINK")) #ifdef PF_IMPLINK return PF_IMPLINK; #else goto not_there; #endif if (strEQ(name, "PF_INET")) #ifdef PF_INET return PF_INET; #else goto not_there; #endif if (strEQ(name, "PF_LAT")) #ifdef PF_LAT return PF_LAT; #else goto not_there; #endif if (strEQ(name, "PF_MAX")) #ifdef PF_MAX return PF_MAX; #else goto not_there; #endif if (strEQ(name, "PF_NBS")) #ifdef PF_NBS return PF_NBS; #else goto not_there; #endif if (strEQ(name, "PF_NIT")) #ifdef PF_NIT return PF_NIT; #else goto not_there; #endif if (strEQ(name, "PF_NS")) #ifdef PF_NS return PF_NS; #else goto not_there; #endif if (strEQ(name, "PF_OSI")) #ifdef PF_OSI return PF_OSI; #else goto not_there; #endif if (strEQ(name, "PF_OSINET")) #ifdef PF_OSINET return PF_OSINET; #else goto not_there; #endif if (strEQ(name, "PF_PUP")) #ifdef PF_PUP return PF_PUP; #else goto not_there; #endif if (strEQ(name, "PF_SNA")) #ifdef PF_SNA return PF_SNA; #else goto not_there; #endif if (strEQ(name, "PF_UNIX")) #ifdef PF_UNIX return PF_UNIX; #else goto not_there; #endif if (strEQ(name, "PF_UNSPEC")) #ifdef PF_UNSPEC return PF_UNSPEC; #else goto not_there; #endif if (strEQ(name, "PF_X25")) #ifdef PF_X25 return PF_X25; #else goto not_there; #endif break; case 'Q': break; case 'R': break; case 'S': if (strEQ(name, "SOCK_DGRAM")) #ifdef SOCK_DGRAM return SOCK_DGRAM; #else goto not_there; #endif if (strEQ(name, "SOCK_RAW")) #ifdef SOCK_RAW return SOCK_RAW; #else goto not_there; #endif if (strEQ(name, "SOCK_RDM")) #ifdef SOCK_RDM return SOCK_RDM; #else goto not_there; #endif if (strEQ(name, "SOCK_SEQPACKET")) #ifdef SOCK_SEQPACKET return SOCK_SEQPACKET; #else goto not_there; #endif if (strEQ(name, "SOCK_STREAM")) #ifdef SOCK_STREAM return SOCK_STREAM; #else goto not_there; #endif if (strEQ(name, "SOL_SOCKET")) #ifdef SOL_SOCKET return SOL_SOCKET; #else goto not_there; #endif if (strEQ(name, "SOMAXCONN")) #ifdef SOMAXCONN return SOMAXCONN; #else goto not_there; #endif if (strEQ(name, "SO_ACCEPTCONN")) #ifdef SO_ACCEPTCONN return SO_ACCEPTCONN; #else goto not_there; #endif if (strEQ(name, "SO_BROADCAST")) #ifdef SO_BROADCAST return SO_BROADCAST; #else goto not_there; #endif if (strEQ(name, "SO_DEBUG")) #ifdef SO_DEBUG return SO_DEBUG; #else goto not_there; #endif if (strEQ(name, "SO_DONTLINGER")) #ifdef SO_DONTLINGER return SO_DONTLINGER; #else goto not_there; #endif if (strEQ(name, "SO_DONTROUTE")) #ifdef SO_DONTROUTE return SO_DONTROUTE; #else goto not_there; #endif if (strEQ(name, "SO_ERROR")) #ifdef SO_ERROR return SO_ERROR; #else goto not_there; #endif if (strEQ(name, "SO_KEEPALIVE")) #ifdef SO_KEEPALIVE return SO_KEEPALIVE; #else goto not_there; #endif if (strEQ(name, "SO_LINGER")) #ifdef SO_LINGER return SO_LINGER; #else goto not_there; #endif if (strEQ(name, "SO_OOBINLINE")) #ifdef SO_OOBINLINE return SO_OOBINLINE; #else goto not_there; #endif if (strEQ(name, "SO_RCVBUF")) #ifdef SO_RCVBUF return SO_RCVBUF; #else goto not_there; #endif if (strEQ(name, "SO_RCVLOWAT")) #ifdef SO_RCVLOWAT return SO_RCVLOWAT; #else goto not_there; #endif if (strEQ(name, "SO_RCVTIMEO")) #ifdef SO_RCVTIMEO return SO_RCVTIMEO; #else goto not_there; #endif if (strEQ(name, "SO_REUSEADDR")) #ifdef SO_REUSEADDR return SO_REUSEADDR; #else goto not_there; #endif if (strEQ(name, "SO_REUSEPORT")) #ifdef SO_REUSEPORT return SO_REUSEPORT; #else goto not_there; #endif if (strEQ(name, "SO_SNDBUF")) #ifdef SO_SNDBUF return SO_SNDBUF; #else goto not_there; #endif if (strEQ(name, "SO_SNDLOWAT")) #ifdef SO_SNDLOWAT return SO_SNDLOWAT; #else goto not_there; #endif if (strEQ(name, "SO_SNDTIMEO")) #ifdef SO_SNDTIMEO return SO_SNDTIMEO; #else goto not_there; #endif if (strEQ(name, "SO_TYPE")) #ifdef SO_TYPE return SO_TYPE; #else goto not_there; #endif if (strEQ(name, "SO_USELOOPBACK")) #ifdef SO_USELOOPBACK return SO_USELOOPBACK; #else goto not_there; #endif break; case 'T': break; case 'U': break; case 'V': break; case 'W': break; case 'X': break; case 'Y': break; case 'Z': break; } errno = EINVAL; return 0; not_there: errno = ENOENT; return 0; } MODULE = Socket PACKAGE = Socket double constant(name,arg) char * name int arg perl5.000/ext/typemap 664 203 12 13412 5645376150 7662 # $Header$ # basic C types int T_IV unsigned T_IV unsigned int T_IV long T_IV unsigned long T_IV short T_IV unsigned short T_IV char T_CHAR unsigned char T_U_CHAR char * T_PV unsigned char * T_PV caddr_t T_PV wchar_t * T_PV wchar_t T_IV bool_t T_IV size_t T_IV ssize_t T_IV time_t T_NV unsigned long * T_OPAQUEPTR char ** T_PACKED void * T_PTR Time_t * T_PV SV * T_SV SVREF T_SVREF AV * T_AVREF HV * T_HVREF CV * T_CVREF IV T_IV I32 T_IV I16 T_IV I8 T_IV U32 T_U_LONG U16 T_U_SHORT U8 T_IV Result T_U_CHAR Boolean T_IV double T_DOUBLE SysRet T_SYSRET SysRetLong T_SYSRET FILE * T_IN FileHandle T_PTROBJ InputStream T_IN InOutStream T_INOUT OutputStream T_OUT ############################################################################# INPUT T_SV $var = $arg T_SVREF if (sv_isa($arg, \"${ntype}\")) $var = (SV*)SvRV($arg); else croak(\"$var is not of type ${ntype}\") T_AVREF if (sv_isa($arg, \"${ntype}\")) $var = (AV*)SvRV($arg); else croak(\"$var is not of type ${ntype}\") T_HVREF if (sv_isa($arg, \"${ntype}\")) $var = (HV*)SvRV($arg); else croak(\"$var is not of type ${ntype}\") T_CVREF if (sv_isa($arg, \"${ntype}\")) $var = (CV*)SvRV($arg); else croak(\"$var is not of type ${ntype}\") T_SYSRET $var NOT IMPLEMENTED T_IV $var = ($type)SvIV($arg) T_INT $var = (int)SvIV($arg) T_ENUM $var = ($type)SvIV($arg) T_U_INT $var = (unsigned int)SvIV($arg) T_SHORT $var = (short)SvIV($arg) T_U_SHORT $var = (unsigned short)SvIV($arg) T_LONG $var = (long)SvIV($arg) T_U_LONG $var = (unsigned long)SvIV($arg) T_CHAR $var = (char)*SvPV($arg,na) T_U_CHAR $var = (unsigned char)SvIV($arg) T_FLOAT $var = (float)SvNV($arg) T_NV $var = ($type)SvNV($arg) T_DOUBLE $var = (double)SvNV($arg) T_PV $var = ($type)SvPV($arg,na) T_PTR $var = ($type)SvIV($arg) T_PTRREF if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = ($type) tmp; } else croak(\"$var is not a reference\") T_REF_IV_REF if (sv_isa($arg, \"${type}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *($type *) tmp; } else croak(\"$var is not of type ${ntype}\") T_REF_IV_PTR if (sv_isa($arg, \"${type}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = ($type) tmp; } else croak(\"$var is not of type ${ntype}\") T_PTROBJ if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = ($type) tmp; } else croak(\"$var is not of type ${ntype}\") T_PTRDESC if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); ${type}_desc = (\U${type}_DESC\E*) tmp; $var = ${type}_desc->ptr; } else croak(\"$var is not of type ${ntype}\") T_REFREF if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *($type) tmp; } else croak(\"$var is not a reference\") T_REFOBJ if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *($type) tmp; } else croak(\"$var is not of type ${ntype}\") T_OPAQUE $var NOT IMPLEMENTED T_OPAQUEPTR $var = ($type)SvPV($arg,na) T_PACKED $var = XS_unpack_$ntype($arg) T_PACKEDARRAY $var = XS_unpack_$ntype($arg) T_CALLBACK $var = make_perl_cb_$type($arg) T_ARRAY $var = $ntype(items -= $argoff); U32 ix_$var = $argoff; while (items--) { DO_ARRAY_ELEM; } T_IN $var = IoIFP(sv_2io($arg)) T_INOUT $var = IoIFP(sv_2io($arg)) T_OUT $var = IoOFP(sv_2io($arg)) ############################################################################# OUTPUT T_SV $arg = $var; T_SVREF $arg = newRV((SV*)$var); T_AVREF $arg = newRV((SV*)$var); T_HVREF $arg = newRV((SV*)$var); T_CVREF $arg = newRV((SV*)$var); T_IV sv_setiv($arg, (IV)$var); T_INT sv_setiv($arg, (IV)$var); T_SYSRET if ($var != -1) { if ($var == 0) sv_setpvn($arg, "0 but true", 10); else sv_setiv($arg, (IV)$var); } T_ENUM sv_setiv($arg, (IV)$var); T_U_INT sv_setiv($arg, (IV)$var); T_SHORT sv_setiv($arg, (IV)$var); T_U_SHORT sv_setiv($arg, (IV)$var); T_LONG sv_setiv($arg, (IV)$var); T_U_LONG sv_setiv($arg, (IV)$var); T_CHAR sv_setpvn($arg, (char *)&$var, 1); T_U_CHAR sv_setiv($arg, (IV)$var); T_FLOAT sv_setnv($arg, (double)$var); T_NV sv_setnv($arg, (double)$var); T_DOUBLE sv_setnv($arg, (double)$var); T_PV sv_setpv((SV*)$arg, $var); T_PTR sv_setiv($arg, (IV)$var); T_PTRREF sv_setref_pv($arg, Nullch, (void*)$var); T_REF_IV_REF sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var)); T_REF_IV_PTR sv_setref_pv($arg, \"${ntype}\", (void*)$var); T_PTROBJ sv_setref_pv($arg, \"${ntype}\", (void*)$var); T_PTRDESC sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var)); T_REFREF sv_setrefref($arg, \"${ntype}\", XS_service_$ntype, ($var ? (void*)new $ntype($var) : 0)); T_REFOBJ NOT IMPLEMENTED T_OPAQUE sv_setpvn($arg, (char *)&$var, sizeof($var)); T_OPAQUEPTR sv_setpvn($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var); T_PACKED XS_pack_$ntype($arg, $var); T_PACKEDARRAY XS_pack_$ntype($arg, $var, count_$ntype); T_DATAUNIT sv_setpvn($arg, $var.chp(), $var.size()); T_CALLBACK sv_setpvn($arg, $var.context.value().chp(), $var.context.value().size()); T_ARRAY ST_EXTEND($var.size); for (U32 ix_$var = 0; ix_$var < $var.size; ix_$var++) { ST(ix_$var) = sv_newmortal(); DO_ARRAY_ELEM } sp += $var.size - 1; T_IN { GV *gv = newGVgen("$Package"); if ( do_open(gv, "<&", 2, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &sv_undef; } T_INOUT { GV *gv = newGVgen("$Package"); if ( do_open(gv, "+<&", 3, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &sv_undef; } T_OUT { GV *gv = newGVgen("$Package"); if ( do_open(gv, "+>&", 3, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &sv_undef; } _X25 return PF_X25; #else goto not_there; #endif break; case 'Q': break; case 'R': break; case 'S': if (strEQ(name, "SOCK_DGRAM")) #ifdef SOCK_DGRAM return SOCK_DGRAM; #else goto not_there; #endif if (strEQ(naperl5.000/ext/util/ 775 203 12 0 5650575673 7136 perl5.000/ext/util/extliblist 775 203 12 10002 5645376151 11337 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=../../../..; else echo "Can't find config.sh."; exit 1 fi . $TOP/config.sh ;; esac : extliblist : : Author: Andy Dougherty doughera@lafcol.lafayette.edu : : This utility takes a list of libraries in the form : -llib1 -llib2 -llib3 : and prints out lines suitable for inclusion in an extension : Makefile. : Extra library paths may be included with the form -L/another/path : this will affect the searches for all subsequent libraries. : : It is intended to be "dotted" from within an extension Makefile.SH. : see ext/POSIX/Makefile.SH for an example. : Prior to calling this, the variable potential_libs should be set : to the potential list of libraries : : It sets the following : extralibs = full list of libraries needed for static linking. : Only those libraries that actually exist are included. : dynaloadlibs = full path names of those libraries that are needed : but can be linked in dynamically on this platform. On : SunOS, for example, this would be .so* libraries, : but not archive libraries. : Eventually, this list can be used to write a bootstrap file. : statloadlibs = list of those libraries which must be statically : linked into the shared library. On SunOS 4.1.3, : for example, I have only an archive version of : -lm, and it must be linked in statically. : : This script uses config.sh variables libs, libpth, and so. It is mostly : taken from the metaconfig libs.U unit. extralibs='' dynaloadlibs='' statloadlibs='' Llibpth='' for thislib in `echo "XXX $potential_libs " | $sed 's/ -l/ /g'` ; do case "$thislib" in XXX) : Handle case where potential_libs is empty. ;; -L*) : Handle possible linker path arguments. newpath=`echo $thislib | $sed 's/^-L//'` if $test -d $newpath; then Llibpth="$Llibpth $newpath" extralibs="$extralibs $thislib" statloadlibs="$statloadlibs $thislib" fi ;; *) : Handle possible library arguments. for thispth in $Llibpth $libpth; do : Loop over possible wildcards and take the last one. for fullname in $thispth/lib$thislib.$so.[0-9]* ; do : done if $test -f $fullname; then break elif fullname=$thispth/lib$thislib.$so && $test -f $fullname; then break elif fullname=$thispth/lib${thislib}_s.a && $test -f $fullname; then thislib=${thislib}_s break elif fullname=$thispth/lib${thislib}.a && $test -f $fullname; then break elif fullname=$thispth/Slib${thislib}.a && $test -f $fullname; then break else fullname='' fi done : Now update library lists case "$fullname" in '') : Skip nonexistent files ;; *) : Do not add it into the extralibs if it is already linked in : with the main perl executable. case " $libs " in *" -l$thislib "*|*" -l${thislib}_s "*) ;; *) extralibs="$extralibs -l$thislib" ;; esac : : For NeXT and DLD, put files into DYNALOADLIBS to be : converted into a boostrap file. For other systems, : we will use ld with what I have misnamed STATLOADLIBS : to assemble the shared object. case "$dlsrc" in dl_dld*|dl_next*) dynaloadlibs="$dynaloadlibs $fullname" ;; *) case "$fullname" in *.a) statloadlibs="$statloadlibs -l$thislib" ;; *) : For SunOS4, do not add in this shared library : if it is already linked in the main : perl executable case "$osname" in sunos) case " $libs " in *" -l$thislib "*) ;; *) statloadlibs="$statloadlibs -l$thislib" ;; esac ;; *) statloadlibs="$statloadlibs -l$thislib" ;; esac ;; esac ;; esac ;; esac ;; esac done case "$dlsrc" in dl_next*) extralibs=`echo " $extralibs "| $sed -e 's/ -lm / /'` ;; esac set X $extralibs shift extralibs="$*" set X $dynaloadlibs shift dynaloadlibs="$*" set X $statloadlibs shift statloadlibs="$*" etpvn($arg, (char *)&$var, 1); T_U_CHAR sv_setiv($arg, (IV)$var); T_FLOAT sv_setnv($arg, (double)$var); T_NV sv_setnv($arg, (double)$var); T_DOUBLE sv_setnv($arg, (double)$var); T_PV sv_setpv((SV*)$arg, $var); T_PTR sv_setiv($arg, (IV)$var); T_PTRREF sv_setref_pv($arg, Nullch, (void*)$var); T_REF_IV_REF sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var)); T_REF_IV_PTR sv_setref_pv($arg, \"${ntype}\", (void*)$var); T_PTROBJ sv_setref_pv($arg, \"${ntype}\", (void*)$var); T_PTRDESC sv_setrefperl5.000/ext/util/make_ext 664 203 12 3472 5645373457 10751 # This script acts as a simple interface for building extensions. # It primarily used by the perl Makefile: # # d_dummy $(dynamic_ext): miniperl preplibrary FORCE # ext/util/make_ext dynamic $@ # # It may be deleted in a later release of perl so try to # avoid using it for other purposes. linktype=$1 extspec=$2 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=../../../..; else echo "Can't find config.sh generated by Configure"; exit 1 fi . $TOP/config.sh ;; esac if test "X$extspec" = X; then echo "make_ext: no extension specified" exit 1; fi # convert old style Name.a into ext/Name/Name.a format case "$extspec" in ext/*) ;; *) extspec=`echo "$extspec" | sed -e 's:\(.*\)\.\(.*\):ext/\1/\1.\2:'` esac # get extension directory path, module name and depth pname=`echo "$extspec" | sed -e 's:^ext/::' -e 's:/[^/]*$::'` mname=`echo "$pname" | sed -e 's!/!::!'` depth=`echo "$pname" | sed -e 's![^/][^/]*!..!g'` if test ! -d "ext/$pname"; then echo " Skipping $extspec (directory does not exist)" exit 0 # not an error ? fi # check link type and do any preliminaries case "$linktype" in static) makeargs='CCCDLFLAGS=' ;; dynamic) makeargs='' ;; *) echo "make_ext: unknown link type '$linktype'"; exit 1;; '') echo "make_ext: no link type specified (eg static or dynamic)"; exit 1;; esac echo "" echo " Making $mname ($linktype)" cd ext/$pname if test ! -f Makefile ; then test -f Makefile.PL && ../$depth/miniperl -I../$depth/lib Makefile.PL fi if test ! -f Makefile ; then test -f Makefile.SH && sh Makefile.SH fi make=${altmake-make} $make config $make $linktype $makeargs exit $? l_libs is empty. ;; -L*) : Handle possible linker path arguments. newpath=`echo $thislib | $sed 's/^-L//'` if $test -d $newpath; then Llibpth="$Llibpth $newpath" extralibs="$extralibsperl5.000/ext/util/mkbootstrap 664 203 12 137 5645376007 11466 #!../../miniperl -w -I../../lib use ExtUtils::MakeMaker; &mkbootstrap(join(" ",@ARGV)); exit; rl Makefile: # # d_dummy $(dynamic_ext): miniperl preplibrary FORCE # ext/util/make_ext dynamic $@ # # It may be deleted in a later release of perl so try to # avoid using it for other purposes. linktype=$1 extspec=$2 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; tperl5.000/ext/xsubpp 775 203 12 34175 5647030702 7530 #!./miniperl 'di '; 'ds 00 \"'; 'ig 00 '; # $Header$ $usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n"; SWITCH: while ($ARGV[0] =~ s/^-//) { $flag = shift @ARGV; $spat = shift, next SWITCH if $flag eq 's'; $cplusplus = 1, next SWITCH if $flag eq 'C++'; $except = 1, next SWITCH if $flag eq 'except'; push(@tm,shift), next SWITCH if $flag eq 'typemap'; die $usage; } @ARGV == 1 or die $usage; chop($pwd = `pwd`); ($dir, $filename) = @ARGV[0] =~ m#(.*)/(.*)# or ($dir, $filename) = @ARGV[0] =~ m#(.*[>\]])(.*)# or ($dir, $filename) = ('.', $ARGV[0]); chdir($dir); $typemap = shift @ARGV; foreach $typemap (@tm) { die "Can't find $typemap in $pwd\n" unless -r $typemap; } unshift @tm, qw(../../../typemap ../../typemap ../typemap typemap); foreach $typemap (@tm) { open(TYPEMAP, $typemap) || next; $mode = Typemap; $current = \$junk; while () { next if /^#/; if (/^INPUT\s*$/) { $mode = Input, next } if (/^OUTPUT\s*$/) { $mode = Output, next } if (/^TYPEMAP\s*$/) { $mode = Typemap, next } if ($mode eq Typemap) { chop; ($typename, $kind) = split(/\t+/, $_, 2); $type_kind{$typename} = $kind if $kind ne ''; } elsif ($mode eq Input) { if (/^\s/) { $$current .= $_; } else { s/\s*$//; $input_expr{$_} = ''; $current = \$input_expr{$_}; } } else { if (/^\s/) { $$current .= $_; } else { s/\s*$//; $output_expr{$_} = ''; $current = \$output_expr{$_}; } } } close(TYPEMAP); } foreach $key (keys %input_expr) { $input_expr{$key} =~ s/\n+$//; } sub Q { local $text = shift; $text =~ tr/#//d; $text =~ s/\[\[/{/g; $text =~ s/\]\]/}/g; $text; } open(F, $filename) || die "cannot open $filename\n"; while () { last if ($Module, $foo, $Package, $foo1, $Prefix) = /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/; print $_; } exit 0 if $_ eq ""; $lastline = $_; sub fetch_para { # parse paragraph @line = (); if ($lastline ne "") { if ($lastline =~ /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/) { $Module = $1; $foo = $2; $Package = $3; $foo1 = $4; $Prefix = $5; ($Module_cname = $Module) =~ s/\W/_/g; ($Packid = $Package) =~ s/:/_/g; $Packprefix = $Package; $Packprefix .= "::" if defined $Packprefix && $Packprefix ne ""; while () { chop; next if /^#/ && !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/; last if /^\S/; } push(@line, $_) if $_ ne ""; } else { push(@line, $lastline); } $lastline = ""; while () { next if /^#/ && !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/; chop; if (/^\S/ && @line && $line[-1] eq "") { $lastline = $_; last; } else { push(@line, $_); } } pop(@line) while @line && $line[-1] =~ /^\s*$/; } $PPCODE = grep(/PPCODE:/, @line); scalar @line; } while (&fetch_para) { # initialize info arrays undef(%args_match); undef(%var_types); undef(%var_addr); undef(%defaults); undef($class); undef($static); undef($elipsis); # extract return type, function name and arguments $ret_type = shift(@line); if ($ret_type =~ /^BOOT:/) { push (@BootCode, @line, "", "") ; next ; } if ($ret_type =~ /^static\s+(.*)$/) { $static = 1; $ret_type = $1; } $func_header = shift(@line); ($func_name, $orig_args) = $func_header =~ /^([\w:]+)\s*\((.*)\)$/; if ($func_name =~ /(.*)::(.*)/) { $class = $1; $func_name = $2; } ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/; push(@Func_name, "${Packid}_$func_name"); push(@Func_pname, $pname); @args = split(/\s*,\s*/, $orig_args); if (defined($class)) { if (defined($static)) { unshift(@args, "CLASS"); $orig_args = "CLASS, $orig_args"; $orig_args =~ s/^CLASS, $/CLASS/; } else { unshift(@args, "THIS"); $orig_args = "THIS, $orig_args"; $orig_args =~ s/^THIS, $/THIS/; } } $orig_args =~ s/"/\\"/g; $min_args = $num_args = @args; foreach $i (0..$num_args-1) { if ($args[$i] =~ s/\.\.\.//) { $elipsis = 1; $min_args--; if ($args[i] eq '' && $i == $num_args - 1) { pop(@args); last; } } if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) { $min_args--; $args[$i] = $1; $defaults{$args[$i]} = $2; $defaults{$args[$i]} =~ s/"/\\"/g; } } if (defined($class)) { $func_args = join(", ", @args[1..$#args]); } else { $func_args = join(", ", @args); } @args_match{@args} = 1..@args; # print function header print Q<<"EOF"; #XS(XS_${Packid}_$func_name) #[[ # dXSARGS; EOF if ($elipsis) { $cond = qq(items < $min_args); } elsif ($min_args == $num_args) { $cond = qq(items != $min_args); } else { $cond = qq(items < $min_args || items > $num_args); } print Q<<"EOF" if $except; # char errbuf[1024]; # *errbuf = '\0'; EOF print Q<<"EOF"; # if ($cond) { # croak("Usage: $pname($orig_args)"); # } EOF print Q<<"EOF" if $PPCODE; # SP -= items; EOF # Now do a block of some sort. $condnum = 0; if (!@line) { @line = "CLEANUP:"; } while (@line) { if ($_[0] =~ s/^\s*CASE\s*:\s*//) { $cond = shift(@line); if ($condnum == 0) { print " if ($cond)\n"; } elsif ($cond ne '') { print " else if ($cond)\n"; } else { print " else\n"; } $condnum++; } if ($except) { print Q<<"EOF"; # TRY [[ EOF } else { print Q<<"EOF"; # [[ EOF } # do initialization of input variables $thisdone = 0; $retvaldone = 0; $deferred = ""; while (@line) { $_ = shift(@line); last if /^\s*NOT_IMPLEMENTED_YET/; last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/; # Catch common error. Much more error checking required here. blurt("Error: no tab in $pname argument declaration '$_'\n") unless (m/\S+\s*\t\s*\S+/); ($var_type, $var_name, $var_init) = /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/; if ($var_name =~ /^&/) { $var_name =~ s/^&//; $var_addr{$var_name} = 1; } $thisdone |= $var_name eq "THIS"; $retvaldone |= $var_name eq "RETVAL"; $var_types{$var_name} = $var_type; print "\t" . &map_type($var_type); $var_num = $args_match{$var_name}; if ($var_addr{$var_name}) { $func_args =~ s/\b($var_name)\b/&\1/; } if ($var_init !~ /^=\s*NO_INIT\s*$/) { if ($var_init !~ /^\s*$/) { &output_init($var_type, $var_num, "$var_name $var_init"); } elsif ($var_num) { # generate initialization code &generate_init($var_type, $var_num, $var_name); } else { print ";\n"; } } else { print "\t$var_name;\n"; } } if (!$thisdone && defined($class)) { if (defined($static)) { print "\tchar *"; $var_types{"CLASS"} = "char *"; &generate_init("char *", 1, "CLASS"); } else { print "\t$class *"; $var_types{"THIS"} = "$class *"; &generate_init("$class *", 1, "THIS"); } } # do code if (/^\s*NOT_IMPLEMENTED_YET/) { print "\ncroak(\"$pname: not implemented yet\");\n"; } else { if ($ret_type ne "void") { print "\t" . &map_type($ret_type) . "\tRETVAL;\n" if !$retvaldone; $args_match{"RETVAL"} = 0; $var_types{"RETVAL"} = $ret_type; } if (/^\s*PPCODE:/) { print $deferred; while (@line) { $_ = shift(@line); die "PPCODE must be last thing" if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/; print "$_\n"; } print "\tPUTBACK;\n\treturn;\n"; } elsif (/^\s*CODE:/) { print $deferred; while (@line) { $_ = shift(@line); last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/; print "$_\n"; } } elsif ($func_name eq "DESTROY") { print $deferred; print "\n\t"; print "delete THIS;\n" } else { print $deferred; print "\n\t"; if ($ret_type ne "void") { print "RETVAL = "; } if (defined($static)) { if ($func_name =~ /^new/) { $func_name = "$class"; } else { print "$class::"; } } elsif (defined($class)) { print "THIS->"; } if (defined($spat) && $func_name =~ /^($spat)(.*)$/) { $func_name = $2; } print "$func_name($func_args);\n"; &generate_output($ret_type, 0, "RETVAL") unless $ret_type eq "void"; } } # do output variables if (/^\s*OUTPUT\s*:/) { while (@line) { $_ = shift(@line); last if /^\s*CLEANUP\s*:/; s/^\s+//; ($outarg, $outcode) = split(/\t+/); if ($outcode) { print "\t$outcode\n"; } else { die "$outarg not an argument" unless defined($args_match{$outarg}); $var_num = $args_match{$outarg}; &generate_output($var_types{$outarg}, $var_num, $outarg); } } } # do cleanup if (/^\s*CLEANUP\s*:/) { while (@line) { $_ = shift(@line); last if /^\s*CASE\s*:/; print "$_\n"; } } # print function trailer if ($except) { print Q<pp.h.y”9?pp_ctl.cp¨9@pp_hot.c9>¼9App_sys.cÌ9Bperl5.000/global.sym 644 203 12 22472 5647030703 7447 # Global symbols that need to be hidden in embedded applications. # Variables AMG_names No Sv Xpv Yes abs_amg add_amg add_ass_amg additem amagic_generation an atan2_amg autoboot_preamble band_amg bool__amg bor_amg buf bufend bufptr bxor_amg check coeff compiling compl_amg comppad comppad_name comppad_name_fill concat_amg concat_ass_amg cop_seqmax cos_amg cryptseen cryptswitch_add cshlen cshname curcop curinterp curpad dc dec_amg di div_amg div_ass_amg ds egid envgv eq_amg error_count euid evalseq exp_amg expect expectterm fallback_amg fold freq ge_amg gid gt_amg hexdigit hints in_my inc_amg know_next last_lop last_lop_op last_uni le_amg lex_state lex_defer lex_expect lex_brackets lex_formbrack lex_fakebrack lex_casemods lex_dojoin lex_starts lex_stuff lex_repl lex_op lex_inpat lex_inwhat lex_brackstack lex_casestack linestr log_amg lshift_amg lshift_ass_amg lt_amg markstack markstack_max markstack_ptr max_intro_pending min_intro_pending mod_amg mod_ass_amg mult_amg mult_ass_amg multi_close multi_end multi_open multi_start na ncmp_amg nextval nexttype nexttoke ne_amg neg_amg nexttype nextval no_aelem no_dir_func no_func no_helem no_mem no_modify no_security no_sock_func no_usym nointrp nomem nomemok nomethod_amg not_amg numer_amg oldbufptr oldoldbufptr op op_name op_seqmax opargs origalen origenviron padix patleave pow_amg pow_ass_amg ppaddr profiledata qrt_amg rcsid reall_srchlen regarglen regbol regcode regdummy regendp regeol regfold reginput reglastparen regmyendp regmyp_size regmystartp regnarrate regnaughty regnpar regparse regprecomp regprev regsawback regsize regstartp regtill regxend repeat_amg repeat_ass_amg retstack retstack_ix retstack_max rsfp rshift_amg rshift_ass_amg savestack savestack_ix savestack_max saw_return scmp_amg scopestack scopestack_ix scopestack_max scrgv seq_amg sge_amg sgt_amg sig_name siggv sighandler simple sin_amg sle_amg slt_amg sne_amg stack stack_base stack_max stack_sp statbuf string_amg sub_generation subline subname subtr_amg subtr_ass_amg sv_no sv_undef sv_yes tainting thisexpr timesbuf tokenbuf uid varies vert vtbl_amagic vtbl_amagicelem vtbl_arylen vtbl_bm vtbl_dbline vtbl_env vtbl_envelem vtbl_glob vtbl_isa vtbl_isaelem vtbl_mglob vtbl_pack vtbl_packelem vtbl_pos vtbl_sig vtbl_sigelem vtbl_substr vtbl_sv vtbl_taint vtbl_uvar vtbl_vec warn_nl warn_nosemi warn_reserved watchaddr watchok yychar yycheck yydebug yydefred yydgoto yyerrflag yygindex yylen yylhs yylval yyname yynerrs yyrindex yyrule yysindex yytable yyval # Functions append_elem append_list apply av_clear av_fake av_fetch av_fill av_len av_make av_pop av_push av_shift av_store av_undef av_unshift bind_match block_end block_start calllist cando check_uni checkcomma ck_aelem ck_concat ck_eof ck_eval ck_exec ck_formline ck_ftst ck_fun ck_glob ck_grep ck_gvconst ck_index ck_lengthconst ck_lfun ck_listiob ck_match ck_null ck_repeat ck_retarget ck_rvconst ck_select ck_shift ck_sort ck_spair ck_split ck_subr ck_trunc convert cpytill croak cv_undef cxinc deb deb_growlevel debop debstack debstackptrs deprecate die die_where do_aexec do_chop do_close do_eof do_exec do_execfree do_ipcctl do_ipcget do_join do_kv do_msgrcv do_msgsnd do_open do_pipe do_print do_readline do_chomp do_seek do_semop do_shmio do_sprintf do_tell do_trans do_vecset do_vop doeval dofindlabel dopoptoeval dump_all dump_eval dump_gv dump_op dump_packsubs dump_pm dump_sub fbm_compile fbm_instr fetch_gv fetch_io fold_constants force_ident force_next force_word free_tmps gen_constant_list gp_free gp_ref gv_AVadd gv_HVadd gv_check gv_efullname gv_fetchfile gv_fetchmeth gv_fetchmethod gv_fetchpv gv_fullname gv_init gv_stashpv gv_stashsv he_delayfree he_free hoistmust hv_clear hv_delete hv_exists hv_fetch hv_stashpv hv_iterinit hv_iterkey hv_iternext hv_iterval hv_magic hv_store hv_undef ibcmp ingroup instr intuit_more invert jmaybe keyword leave_scope lex_end lex_start linklist list listkids localize looks_like_number magic_clearpack magic_get magic_getarylen magic_getglob magic_getpack magic_getpos magic_gettaint magic_getuvar magic_len magic_nextpack magic_set magic_setamagic magic_setarylen magic_setbm magic_setdbline magic_setenv magic_setglob magic_setisa magic_setmglob magic_setpack magic_setpos magic_setsig magic_setsubstr magic_settaint magic_setuvar magic_setvec magic_wipepack magicname markstack_grow mess mg_clear mg_copy mg_find mg_free mg_get mg_len mg_magical mg_set mod modkids moreswitches my my_exit my_lstat my_pclose my_popen my_setenv my_stat my_unexec newANONHASH newANONLIST newASSIGNOP newAV newAVREF newBINOP newCONDOP newCVOP newCVREF newFORM newFOROP newGVOP newGVREF newGVgen newHV newHVREF newIO newLISTOP newLOGOP newLOOPEX newLOOPOP newMETHOD newNULLLIST newOP newPROG newPMOP newPVOP newRANGE newRV newSLICEOP newSTATEOP newSUB newSV newSVOP newSVREF newSViv newSVnv newSVpv newSVsv newUNOP newWHILEOP newXSUB newXS nextargv ninstr no_fh_allowed no_op oopsAV oopsCV oopsHV op_free package pad_alloc pad_allocmy pad_findmy pad_free pad_leavemy pad_reset pad_sv pad_swipe peep pidgone pmruntime pmtrans pop_return pop_scope pp_aassign pp_accept pp_add pp_aelem pp_aelemfast pp_alarm pp_and pp_andassign pp_anonhash pp_anonlist pp_aslice pp_atan2 pp_av2arylen pp_backtick pp_bind pp_binmode pp_bit_and pp_bit_or pp_bless pp_caller pp_chdir pp_chmod pp_chop pp_chown pp_chroot pp_close pp_closedir pp_complement pp_concat pp_cond_expr pp_connect pp_const pp_cos pp_crypt pp_cswitch pp_dbmclose pp_dbmopen pp_dbstate pp_defined pp_delete pp_die pp_divide pp_dofile pp_dump pp_each pp_egrent pp_ehostent pp_enetent pp_enter pp_entereval pp_enteriter pp_enterloop pp_entersub pp_entersubr pp_entertry pp_enterwrite pp_eof pp_eprotoent pp_epwent pp_eq pp_eservent pp_evalonce pp_exec pp_exists pp_exit pp_exp pp_fcntl pp_fileno pp_flip pp_flock pp_flop pp_fork pp_formline pp_ftatime pp_ftbinary pp_ftblk pp_ftchr pp_ftctime pp_ftdir pp_fteexec pp_fteowned pp_fteread pp_ftewrite pp_ftfile pp_ftis pp_ftlink pp_ftmtime pp_ftpipe pp_ftrexec pp_ftrowned pp_ftrread pp_ftrwrite pp_ftsgid pp_ftsize pp_ftsock pp_ftsuid pp_ftsvtx pp_fttext pp_fttty pp_ftzero pp_ge pp_getc pp_getlogin pp_getpeername pp_getpgrp pp_getppid pp_getpriority pp_getsockname pp_ggrent pp_ggrgid pp_ggrnam pp_ghbyaddr pp_ghbyname pp_ghostent pp_glob pp_gmtime pp_gnbyaddr pp_gnbyname pp_gnetent pp_goto pp_gpbyname pp_gpbynumber pp_gprotoent pp_gpwent pp_gpwnam pp_gpwuid pp_grepstart pp_grepwhile pp_gsbyname pp_gsbyport pp_gservent pp_gsockopt pp_gt pp_gv pp_gvsv pp_helem pp_hex pp_hslice pp_index pp_indread pp_int pp_interp pp_ioctl pp_iter pp_join pp_keys pp_kill pp_last pp_lc pp_lcfirst pp_le pp_leave pp_leaveeval pp_leaveloop pp_leavesub pp_leavetry pp_leavewrite pp_left_shift pp_length pp_lineseq pp_link pp_list pp_listen pp_localtime pp_log pp_lslice pp_lstat pp_lt pp_map pp_match pp_method pp_mkdir pp_modulo pp_msgctl pp_msgget pp_msgrcv pp_msgsnd pp_multiply pp_ncmp pp_ne pp_negate pp_next pp_nextstate pp_not pp_nswitch pp_null pp_oct pp_open pp_open_dir pp_or pp_orassign pp_ord pp_pack pp_padav pp_padhv pp_padsv pp_pipe_op pp_pop pp_pos pp_postdec pp_postinc pp_pow pp_predec pp_preinc pp_print pp_prtf pp_push pp_pushmark pp_pushre pp_rand pp_range pp_rcatline pp_read pp_readdir pp_readline pp_readlink pp_recv pp_redo pp_ref pp_refgen pp_regcmaybe pp_regcomp pp_rename pp_repeat pp_require pp_reset pp_return pp_reverse pp_rewinddir pp_right_shift pp_rindex pp_rmdir pp_rv2av pp_rv2cv pp_rv2gv pp_rv2hv pp_rv2sv pp_chomp pp_sassign pp_scalar pp_schop pp_scmp pp_scope pp_seek pp_seekdir pp_select pp_semctl pp_semget pp_semop pp_send pp_seq pp_setpgrp pp_setpriority pp_sge pp_sgrent pp_sgt pp_shift pp_shmctl pp_shmget pp_shmread pp_shmwrite pp_shostent pp_shutdown pp_sin pp_sle pp_sleep pp_slt pp_sne pp_snetent pp_socket pp_sockpair pp_sort pp_splice pp_split pp_sprintf pp_sprotoent pp_spwent pp_sqrt pp_srand pp_srefgen pp_schomp pp_sselect pp_sservent pp_ssockopt pp_stat pp_stub pp_study pp_subst pp_substcont pp_substr pp_subtract pp_sv2len pp_symlink pp_syscall pp_sysread pp_system pp_syswrite pp_tell pp_telldir pp_tie pp_time pp_tms pp_trans pp_truncate pp_uc pp_ucfirst pp_umask pp_undef pp_unlink pp_unpack pp_unshift pp_unstack pp_untie pp_utime pp_values pp_vec pp_wait pp_waitpid pp_wantarray pp_warn pp_xor prepend_elem push_return push_scope q ref refkids regcomp regdump regexec regfree regnext regprop repeatcpy rninstr run savepv savepvn save_I32 save_aptr save_ary save_clearsv save_delete save_freeop save_freepv save_freesv save_hash save_hptr save_int save_item save_list save_nogv save_scalar save_sptr save_svref savestack_grow sawparens scalar scalarkids scalarseq scalarvoid scan_const scan_formline scan_heredoc scan_hex scan_ident scan_inputsymbol scan_num scan_oct scan_pat scan_prefix scan_str scan_subst scan_trans scan_word scope screaminstr setenv_getix skipspace stack_grow start_subparse sublex_done sublex_start sv_2bool sv_2cv sv_2io sv_2iv sv_2mortal sv_2nv sv_2pv sv_backoff sv_bless sv_catpv sv_catpvn sv_catsv sv_chop sv_clean_all sv_clean_objs sv_clear sv_cmp sv_dec sv_dump sv_eq sv_free sv_gets sv_grow sv_inc sv_insert sv_isa sv_len sv_magic sv_mortalcopy sv_newmortal sv_peek sv_ref sv_replace sv_report_used sv_reset sv_setiv sv_setnv sv_setptrobj sv_setpv sv_setpvn sv_setref_iv sv_setref_pv sv_setsv sv_unmagic sv_upgrade sv_usepvn taint_env taint_not taint_proper too_few_arguments too_many_arguments wait4pid warn watch whichsig xiv_arenaroot xiv_root xnv_root xpv_root xrv_root yyerror yyerror yylex yyparse yywarn dump_sub fbm_compile fbm_instr fetch_gv fetch_io fold_constants force_ident force_next force_word free_tmps gen_constant_list gp_free gp_ref gv_AVadd gv_HVadd gv_check gv_efullname gv_fetchfile gv_perl5.000/gv.c 644 203 12 55056 5650572637 6254 /* gv.c * * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure * of your inquisitiveness, I shall spend all the rest of my days answering * you. What more do you want to know?' * 'The names of all the stars, and of all living things, and the whole * history of Middle-earth and Over-heaven and of the Sundering Seas,' * laughed Pippin. */ #include "EXTERN.h" #include "perl.h" extern char rcsid[]; GV * gv_AVadd(gv) register GV *gv; { if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) croak("Bad symbol for array"); if (!GvAV(gv)) GvAV(gv) = newAV(); return gv; } GV * gv_HVadd(gv) register GV *gv; { if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) croak("Bad symbol for hash"); if (!GvHV(gv)) GvHV(gv) = newHV(); return gv; } GV * gv_IOadd(gv) register GV *gv; { if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) croak("Bad symbol for filehandle"); if (!GvIOp(gv)) GvIOp(gv) = newIO(); return gv; } GV * gv_fetchfile(name) char *name; { char tmpbuf[1200]; GV *gv; sprintf(tmpbuf,"::_<%s", name); gv = gv_fetchpv(tmpbuf, TRUE, SVt_PVGV); sv_setpv(GvSV(gv), name); if (*name == '/' && (instr(name,"/lib/") || instr(name,".pm"))) SvMULTI_on(gv); if (perldb) hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L'); return gv; } void gv_init(gv, stash, name, len, multi) GV *gv; HV *stash; char *name; STRLEN len; int multi; { register GP *gp; sv_upgrade(gv, SVt_PVGV); if (SvLEN(gv)) Safefree(SvPVX(gv)); Newz(602,gp, 1, GP); GvGP(gv) = gp_ref(gp); GvREFCNT(gv) = 1; GvSV(gv) = NEWSV(72,0); GvLINE(gv) = curcop->cop_line; GvFILEGV(gv) = curcop->cop_filegv; GvEGV(gv) = gv; sv_magic((SV*)gv, (SV*)gv, '*', name, len); GvSTASH(gv) = stash; GvNAME(gv) = savepvn(name, len); GvNAMELEN(gv) = len; if (multi) SvMULTI_on(gv); } static void gv_init_sv(gv, sv_type) GV* gv; I32 sv_type; { switch (sv_type) { case SVt_PVIO: (void)GvIOn(gv); break; case SVt_PVAV: (void)GvAVn(gv); break; case SVt_PVHV: (void)GvHVn(gv); break; } } GV * gv_fetchmeth(stash, name, len, level) HV* stash; char* name; STRLEN len; I32 level; { AV* av; GV* topgv; GV* gv; GV** gvp; HV* lastchance; if (!stash) return 0; if (level > 100) croak("Recursive inheritance detected"); gvp = (GV**)hv_fetch(stash, name, len, TRUE); DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) ); topgv = *gvp; if (SvTYPE(topgv) != SVt_PVGV) gv_init(topgv, stash, name, len, TRUE); if (GvCV(topgv)) { if (!GvCVGEN(topgv) || GvCVGEN(topgv) >= sub_generation) return topgv; } gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) { SV** svp = AvARRAY(av); I32 items = AvFILL(av) + 1; while (items--) { SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { if (dowarn) warn("Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); continue; } gv = gv_fetchmeth(basestash, name, len, level + 1); if (gv) { GvCV(topgv) = GvCV(gv); /* cache the CV */ GvCVGEN(topgv) = sub_generation; /* valid for now */ return gv; } } } if (!level) { if (lastchance = gv_stashpv("UNIVERSAL", FALSE)) { if (gv = gv_fetchmeth(lastchance, name, len, level + 1)) { GvCV(topgv) = GvCV(gv); /* cache the CV */ GvCVGEN(topgv) = sub_generation; /* valid for now */ return gv; } } } return 0; } GV * gv_fetchmethod(stash, name) HV* stash; char* name; { register char *nend; char *nsplit = 0; GV* gv; for (nend = name; *nend; nend++) { if (*nend == ':' || *nend == '\'') nsplit = nend; } if (nsplit) { char ch; char *origname = name; name = nsplit + 1; ch = *nsplit; if (*nsplit == ':') --nsplit; *nsplit = '\0'; stash = gv_stashpv(origname,TRUE); *nsplit = ch; } gv = gv_fetchmeth(stash, name, nend - name, 0); if (!gv) { CV* cv; if (strEQ(name,"import") || strEQ(name,"unimport")) gv = &sv_yes; else if (strNE(name, "AUTOLOAD")) { gv = gv_fetchmeth(stash, "AUTOLOAD", 8, 0); if (gv && (cv = GvCV(gv))) { /* One more chance... */ SV *tmpstr = sv_newmortal(); sv_catpv(tmpstr,HvNAME(stash)); sv_catpvn(tmpstr,"::", 2); sv_catpvn(tmpstr, name, nend - name); sv_setsv(GvSV(CvGV(cv)), tmpstr); } } } return gv; } HV* gv_stashpv(name,create) char *name; I32 create; { char tmpbuf[1234]; HV *stash; GV *tmpgv; sprintf(tmpbuf,"%.*s::",1200,name); tmpgv = gv_fetchpv(tmpbuf,create, SVt_PVHV); if (!tmpgv) return 0; if (!GvHV(tmpgv)) GvHV(tmpgv) = newHV(); stash = GvHV(tmpgv); if (!HvNAME(stash)) HvNAME(stash) = savepv(name); return stash; } HV* gv_stashsv(sv,create) SV *sv; I32 create; { return gv_stashpv(SvPV(sv,na), create); } GV * gv_fetchpv(nambeg,add,sv_type) char *nambeg; I32 add; I32 sv_type; { register char *name = nambeg; register GV *gv = 0; GV**gvp; I32 len; register char *namend; HV *stash = 0; bool global = FALSE; char *tmpbuf; for (namend = name; *namend; namend++) { if ((*namend == '\'' && namend[1]) || (*namend == ':' && namend[1] == ':')) { if (!stash) stash = defstash; if (!SvREFCNT(stash)) /* symbol table under destruction */ return Nullgv; len = namend - name; if (len > 0) { New(601, tmpbuf, len+3, char); Copy(name, tmpbuf, len, char); tmpbuf[len++] = ':'; tmpbuf[len++] = ':'; tmpbuf[len] = '\0'; gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); Safefree(tmpbuf); if (!gvp || *gvp == (GV*)&sv_undef) return Nullgv; gv = *gvp; if (SvTYPE(gv) == SVt_PVGV) SvMULTI_on(gv); else if (!add) return Nullgv; else gv_init(gv, stash, nambeg, namend - nambeg, (add & 2)); if (!(stash = GvHV(gv))) stash = GvHV(gv) = newHV(); if (!HvNAME(stash)) HvNAME(stash) = savepvn(nambeg, namend - nambeg); } if (*namend == ':') namend++; namend++; name = namend; if (!*name) return gv ? gv : *hv_fetch(defstash, "main::", 6, TRUE); } } len = namend - name; if (!len) len = 1; /* No stash in name, so see how we can default */ if (!stash) { if (isIDFIRST(*name)) { if (isUPPER(*name)) { if (*name > 'I') { if (*name == 'S' && ( strEQ(name, "SIG") || strEQ(name, "STDIN") || strEQ(name, "STDOUT") || strEQ(name, "STDERR") )) global = TRUE; } else if (*name > 'E') { if (*name == 'I' && strEQ(name, "INC")) global = TRUE; } else if (*name > 'A') { if (*name == 'E' && strEQ(name, "ENV")) global = TRUE; } else if (*name == 'A' && ( strEQ(name, "ARGV") || strEQ(name, "ARGVOUT") )) global = TRUE; } else if (*name == '_' && !name[1]) global = TRUE; if (global) stash = defstash; else if ((COP*)curcop == &compiling) { stash = curstash; if (add && (hints & HINT_STRICT_VARS) && sv_type != SVt_PVCV) { if (stash && !hv_fetch(stash,name,len,0)) stash = 0; } } else stash = curcop->cop_stash; } else stash = defstash; } /* By this point we should have a stash and a name */ if (!stash) { if (add) { warn("Global symbol \"%s\" requires explicit package name", name); ++error_count; stash = curstash ? curstash : defstash; /* avoid core dumps */ } else return Nullgv; } if (!SvREFCNT(stash)) /* symbol table under destruction */ return Nullgv; gvp = (GV**)hv_fetch(stash,name,len,add); if (!gvp || *gvp == (GV*)&sv_undef) return Nullgv; gv = *gvp; if (SvTYPE(gv) == SVt_PVGV) { if (add) { SvMULTI_on(gv); gv_init_sv(gv, sv_type); } return gv; } /* Adding a new symbol */ if (add & 4) warn("Had to create %s unexpectedly", nambeg); gv_init(gv, stash, name, len, add & 2); gv_init_sv(gv, sv_type); /* set up magic where warranted */ switch (*name) { case 'A': if (strEQ(name, "ARGV")) { IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; } break; case 'a': case 'b': if (len == 1) SvMULTI_on(gv); break; case 'E': if (strnEQ(name, "EXPORT", 6)) SvMULTI_on(gv); break; case 'I': if (strEQ(name, "ISA")) { AV* av = GvAVn(gv); SvMULTI_on(gv); sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0); if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1) { char *pname; av_push(av, newSVpv(pname = "NDBM_File",0)); gv_stashpv(pname, TRUE); av_push(av, newSVpv(pname = "DB_File",0)); gv_stashpv(pname, TRUE); av_push(av, newSVpv(pname = "GDBM_File",0)); gv_stashpv(pname, TRUE); av_push(av, newSVpv(pname = "SDBM_File",0)); gv_stashpv(pname, TRUE); av_push(av, newSVpv(pname = "ODBM_File",0)); gv_stashpv(pname, TRUE); } } break; #ifdef OVERLOAD case 'O': if (strEQ(name, "OVERLOAD")) { HV* hv = GvHVn(gv); SvMULTI_on(gv); sv_magic((SV*)hv, (SV*)gv, 'A', 0, 0); } break; #endif /* OVERLOAD */ case 'S': if (strEQ(name, "SIG")) { HV *hv; siggv = gv; SvMULTI_on(siggv); hv = GvHVn(siggv); hv_magic(hv, siggv, 'S'); /* initialize signal stack */ signalstack = newAV(); AvREAL_off(signalstack); av_extend(signalstack, 30); av_fill(signalstack, 0); } break; case '&': if (len > 1) break; ampergv = gv; sawampersand = TRUE; goto ro_magicalize; case '`': if (len > 1) break; leftgv = gv; sawampersand = TRUE; goto ro_magicalize; case '\'': if (len > 1) break; rightgv = gv; sawampersand = TRUE; goto ro_magicalize; case ':': if (len > 1) break; sv_setpv(GvSV(gv),chopset); goto magicalize; case '#': case '*': if (dowarn && len == 1 && sv_type == SVt_PV) warn("Use of $%s is deprecated", name); /* FALL THROUGH */ case '[': case '!': case '?': case '^': case '~': case '=': case '-': case '%': case '.': case '(': case ')': case '<': case '>': case ',': case '\\': case '/': case '|': case '\004': case '\010': case '\t': case '\020': case '\024': case '\027': case '\006': if (len > 1) break; goto magicalize; case '+': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': ro_magicalize: SvREADONLY_on(GvSV(gv)); magicalize: sv_magic(GvSV(gv), (SV*)gv, 0, name, len); break; case '\014': if (len > 1) break; sv_setpv(GvSV(gv),"\f"); formfeed = GvSV(gv); break; case ';': if (len > 1) break; sv_setpv(GvSV(gv),"\034"); break; case ']': if (len == 1) { SV *sv; sv = GvSV(gv); sv_upgrade(sv, SVt_PVNV); sv_setpv(sv, patchlevel); } break; } return gv; } void gv_fullname(sv,gv) SV *sv; GV *gv; { HV *hv = GvSTASH(gv); if (!hv) return; sv_setpv(sv, sv == (SV*)gv ? "*" : ""); sv_catpv(sv,HvNAME(hv)); sv_catpvn(sv,"::", 2); sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); } void gv_efullname(sv,gv) SV *sv; GV *gv; { GV* egv = GvEGV(gv); HV *hv = GvSTASH(egv); if (!hv) return; sv_setpv(sv, sv == (SV*)gv ? "*" : ""); sv_catpv(sv,HvNAME(hv)); sv_catpvn(sv,"::", 2); sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv)); } IO * newIO() { IO *io; GV *iogv; io = (IO*)NEWSV(0,0); sv_upgrade((SV *)io,SVt_PVIO); SvREFCNT(io) = 1; SvOBJECT_on(io); iogv = gv_fetchpv("FileHandle::", TRUE, SVt_PVIO); SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv)); return io; } void gv_check(stash) HV* stash; { register HE *entry; register I32 i; register GV *gv; HV *hv; GV *filegv; if (!HvARRAY(stash)) return; for (i = 0; i <= (I32) HvMAX(stash); i++) { for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) { if (entry->hent_key[entry->hent_klen-1] == ':' && (gv = (GV*)entry->hent_val) && (hv = GvHV(gv)) && HvNAME(hv)) { if (hv != defstash) gv_check(hv); /* nested package */ } else if (isALPHA(*entry->hent_key)) { gv = (GV*)entry->hent_val; if (SvMULTI(gv)) continue; curcop->cop_line = GvLINE(gv); filegv = GvFILEGV(gv); curcop->cop_filegv = filegv; if (filegv && SvMULTI(filegv)) /* Filename began with slash */ continue; warn("Identifier \"%s::%s\" used only once: possible typo", HvNAME(stash), GvNAME(gv)); } } } } GV * newGVgen(pack) char *pack; { (void)sprintf(tokenbuf,"%s::_GEN_%ld",pack,(long)gensym++); return gv_fetchpv(tokenbuf,TRUE, SVt_PVGV); } /* hopefully this is only called on local symbol table entries */ GP* gp_ref(gp) GP* gp; { gp->gp_refcnt++; return gp; } void gp_free(gv) GV* gv; { IO *io; CV *cv; GP* gp; if (!gv || !(gp = GvGP(gv))) return; if (gp->gp_refcnt == 0) { warn("Attempt to free unreferenced glob pointers"); return; } if (--gp->gp_refcnt > 0) return; SvREFCNT_dec(gp->gp_sv); SvREFCNT_dec(gp->gp_av); SvREFCNT_dec(gp->gp_hv); if ((io = gp->gp_io) && SvTYPE(io) != SVTYPEMASK) { do_close(gv,FALSE); SvREFCNT_dec(io); } if ((cv = gp->gp_cv) && !GvCVGEN(gv)) SvREFCNT_dec(cv); Safefree(gp); GvGP(gv) = 0; } #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286)) #define MICROPORT #endif #ifdef MICROPORT /* Microport 2.4 hack */ AV *GvAVn(gv) register GV *gv; { if (GvGP(gv)->gp_av) return GvGP(gv)->gp_av; else return GvGP(gv_AVadd(gv))->gp_av; } HV *GvHVn(gv) register GV *gv; { if (GvGP(gv)->gp_hv) return GvGP(gv)->gp_hv; else return GvGP(gv_HVadd(gv))->gp_hv; } #endif /* Microport 2.4 hack */ #ifdef OVERLOAD /* Updates and caches the CV's */ bool Gv_AMupdate(stash) HV* stash; { GV** gvp; HV* hv; GV* gv; CV* cv; MAGIC* mg=mg_find((SV*)stash,'c'); AMT *amtp; if (mg && (amtp=((AMT*)(mg->mg_ptr)))->was_ok_am == amagic_generation && amtp->was_ok_sub == sub_generation) return HV_AMAGIC(stash)? TRUE: FALSE; gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); sv_unmagic((SV*)stash, 'c'); DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) ); if (gvp && ((gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv)))) { int filled=0; int i; char *cp; AMT amt; SV* sv; SV** svp; /* if (*(svp)==(SV*)amagic_generation && *(svp+1)==(SV*)sub_generation) { DEBUG_o( deb("Overload magic in package %s up-to-date\n",HvNAME(stash)) ); return HV_AMAGIC(stash)? TRUE: FALSE; }*/ amt.was_ok_am=amagic_generation; amt.was_ok_sub=sub_generation; amt.fallback=AMGfallNO; /* Work with "fallback" key, which we assume to be first in AMG_names */ if ((cp=((char**)(*AMG_names))[0]) && (svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) { if (SvTRUE(sv)) amt.fallback=AMGfallYES; else if (SvOK(sv)) amt.fallback=AMGfallNEVER; } for (i=1;icop_stash, SvPV(sv, na)); if (gv) cv = GvCV(gv); break; } cv = (CV*)SvRV(sv); if (SvTYPE(cv) == SVt_PVCV) break; /* FALL THROUGH */ case SVt_PVHV: case SVt_PVAV: die("Not a subroutine reference in %%OVERLOAD"); return FALSE; case SVt_PVCV: cv = (CV*)sv; break; case SVt_PVGV: if (!(cv = GvCV((GV*)sv))) cv = sv_2cv(sv, &stash, &gv, TRUE); break; } if (cv) filled=1; else { die("Method for operation %s not found in package %s during blessing\n", cp,HvNAME(stash)); return FALSE; } } } amt.table[i]=cv; } sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(amt)); if (filled) { /* HV_badAMAGIC_off(stash);*/ HV_AMAGIC_on(stash); return TRUE; } } /*HV_badAMAGIC_off(stash);*/ HV_AMAGIC_off(stash); return FALSE; } /* During call to this subroutine stack can be reallocated. It is * advised to call SPAGAIN macro in your code after call */ SV* amagic_call(left,right,method,flags) SV* left; SV* right; int method; int flags; { MAGIC *mg; CV *cv; CV **cvp=NULL, **ocvp=NULL; AMT *amtp, *oamtp; int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0; int postpr=0; HV* stash; if (!(AMGf_noleft & flags) && SvAMAGIC(left) && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c')) && (ocvp = cvp = ((oamtp=amtp=(AMT*)mg->mg_ptr)->table)) && (assign ? ((cv = cvp[off=method+1]) || ( amtp->fallback > AMGfallNEVER && /* fallback to * usual method */ (fl = 1, cv = cvp[off=method]))): (1 && (cv = cvp[off=method])) )) { lr = -1; /* Call method for left argument */ } else { if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { int logic; /* look for substituted methods */ switch (method) { case inc_amg: if ((cv = cvp[off=add_ass_amg]) || ((cv = cvp[off=add_amg]) && (postpr=1))) { right = &sv_yes; lr = -1; assign = 1; } break; case dec_amg: if ((cv = cvp[off=subtr_ass_amg]) || ((cv = cvp[off=subtr_amg]) && (postpr=1))) { right = &sv_yes; lr = -1; assign = 1; } break; case bool__amg: (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); break; case numer_amg: (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); break; case string_amg: (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); break; case abs_amg: if ((cvp[off1=lt_amg] || cvp[off1=lt_amg]) && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { if (off1==lt_amg) { SV* lessp = amagic_call(left, sv_2mortal(newSViv(0)), lt_amg,AMGf_noright); logic = SvTRUE(lessp); } else { SV* lessp = amagic_call(left, sv_2mortal(newSViv(0)), ncmp_amg,AMGf_noright); logic = (SvNV(lessp) < 0); } if (logic) { if (off==subtr_amg) { right = left; left = sv_2mortal(newSViv(0)); lr = 1; } } else { return left; } } break; case neg_amg: if (cv = cvp[off=subtr_amg]) { right = left; left = sv_2mortal(newSViv(0)); lr = 1; } break; default: goto not_found; } if (!cv) goto not_found; } else if (!(AMGf_noright & flags) && SvAMAGIC(right) && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c')) && (cvp = ((amtp=(AMT*)mg->mg_ptr)->table)) && (cv = cvp[off=method])) { /* Method for right * argument found */ lr=1; } else if (((ocvp && oamtp->fallback > AMGfallNEVER && (cvp=ocvp)) || (cvp && amtp->fallback > AMGfallNEVER && (lr=1))) && !(flags & AMGf_unary)) { /* We look for substitution for * comparison operations and * concatendation */ if (method==concat_amg || method==concat_ass_amg || method==repeat_amg || method==repeat_ass_amg) { return NULL; /* Delegate operation to string conversion */ } off = -1; switch (method) { case lt_amg: case le_amg: case gt_amg: case ge_amg: case eq_amg: case ne_amg: postpr = 1; off=ncmp_amg; break; case slt_amg: case sle_amg: case sgt_amg: case sge_amg: case seq_amg: case sne_amg: postpr = 1; off=scmp_amg; break; } if (off != -1) cv = cvp[off]; if (!cv) { goto not_found; } } else { not_found: /* No method found, either report or die */ if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ notfound = 1; lr = -1; } else if (cvp && (cv=cvp[nomethod_amg])) { notfound = 1; lr = 1; } else { char tmpstr[512]; sprintf(tmpstr,"Operation `%s': no method found,\n\tleft argument %s%200s,\n\tright argument %s%200s", ((char**)AMG_names)[off], SvAMAGIC(left)? "in overloaded package ": "has no overloaded magic", SvAMAGIC(left)? HvNAME(SvSTASH(SvRV(left))): "", SvAMAGIC(right)? "in overloaded package ": "has no overloaded magic", SvAMAGIC(right)? HvNAME(SvSTASH(SvRV(right))): ""); if (amtp && amtp->fallback >= AMGfallYES) { DEBUG_o( deb(tmpstr) ); } else { die(tmpstr); } return NULL; } } } if (!notfound) { DEBUG_o( deb("Operation `%s': method for %s argument found in package %s%s\n", ((char**)AMG_names)[off], (lr? "right": "left"), HvNAME(stash), fl? ",\n\tassignment variant used": "") ); /* Since we use shallow copy, we need to dublicate the contents, probably we need also to use user-supplied version of coping? */ if (assign || method==inc_amg || method==dec_amg) RvDEEPCP(left); } { dSP; BINOP myop; SV* res; Zero(&myop, 1, BINOP); myop.op_last = (OP *) &myop; myop.op_next = Nullop; myop.op_flags = OPf_KNOW|OPf_STACKED; ENTER; SAVESPTR(op); op = (OP *) &myop; PUTBACK; pp_pushmark(); EXTEND(sp, notfound + 5); PUSHs(lr>0? right: left); PUSHs(lr>0? left: right); PUSHs( assign ? &sv_undef : (lr>0? &sv_yes: &sv_no)); if (notfound) { PUSHs( sv_2mortal(newSVpv(((char**)AMG_names)[off],0)) ); } PUSHs((SV*)cv); PUTBACK; if (op = pp_entersub()) run(); LEAVE; SPAGAIN; res=POPs; PUTBACK; if (notfound) { /* sv_2mortal(res); */ return NULL; } if (postpr) { int ans; switch (method) { case le_amg: case sle_amg: ans=SvIV(res)<=0; break; case lt_amg: case slt_amg: ans=SvIV(res)<0; break; case ge_amg: case sge_amg: ans=SvIV(res)>=0; break; case gt_amg: case sgt_amg: ans=SvIV(res)>0; break; case eq_amg: case seq_amg: ans=SvIV(res)==0; break; case ne_amg: case sne_amg: ans=SvIV(res)!=0; break; case inc_amg: case dec_amg: SvSetSV(left,res); return res; break; } return ans? &sv_yes: &sv_no; } else { return res; } } } #endif /* OVERLOAD */ { DEBUG_o( deb("Overload magic in package %s up-to-date\n",HvNAME(stash)) ); return HV_AMAGIC(stash)? TRUE: FALSE; }*/ amt.was_ok_am=amagic_generation; amt.was_ok_sub=sub_generation; amt.fallback=AMGfallNO; /* Work with "fallback" key, which we assume to be first in AMG_names */ if ((cp=((char**)(*AMG_names))[0]) && (svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) { if (SvTRUE(sv)) amt.fallback=AMGfallYESperl5.000/gv.h 644 203 12 4766 5650572637 6243 /* gv.h * * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ struct gp { SV * gp_sv; /* scalar value */ U32 gp_refcnt; /* how many globs point to this? */ struct io * gp_io; /* filehandle value */ CV * gp_form; /* format value */ AV * gp_av; /* array value */ HV * gp_hv; /* associative array value */ GV * gp_egv; /* effective gv, if *glob */ CV * gp_cv; /* subroutine value */ U32 gp_cvgen; /* generational validity of cached gv_cv */ I32 gp_lastexpr; /* used by nothing_in_common() */ line_t gp_line; /* line first declared at (for -w) */ GV * gp_filegv; /* file first declared in (for -w) */ char gp_flags; }; #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286)) #define MICROPORT #endif #define GvXPVGV(gv) ((XPVGV*)SvANY(gv)) #define GvSV(gv) (GvGP(gv)->gp_sv) #define GvREFCNT(gv) (GvGP(gv)->gp_refcnt) #define GvIO(gv) ((gv) && SvTYPE((SV*)gv) == SVt_PVGV ? GvIOp(gv) : 0) #define GvIOp(gv) (GvGP(gv)->gp_io) #define GvIOn(gv) (GvIO(gv) ? GvIOp(gv) : GvIOp(gv_IOadd(gv))) #define GvFORM(gv) (GvGP(gv)->gp_form) #define GvAV(gv) (GvGP(gv)->gp_av) #ifdef MICROPORT /* Microport 2.4 hack */ AV *GvAVn(); #else #define GvAVn(gv) (GvGP(gv)->gp_av ? \ GvGP(gv)->gp_av : \ GvGP(gv_AVadd(gv))->gp_av) #endif #define GvHV(gv) ((GvGP(gv))->gp_hv) #ifdef MICROPORT /* Microport 2.4 hack */ HV *GvHVn(); #else #define GvHVn(gv) (GvGP(gv)->gp_hv ? \ GvGP(gv)->gp_hv : \ GvGP(gv_HVadd(gv))->gp_hv) #endif /* Microport 2.4 hack */ #define GvCV(gv) (GvGP(gv)->gp_cv) #define GvCVGEN(gv) (GvGP(gv)->gp_cvgen) #define GvLASTEXPR(gv) (GvGP(gv)->gp_lastexpr) #define GvLINE(gv) (GvGP(gv)->gp_line) #define GvFILEGV(gv) (GvGP(gv)->gp_filegv) #define GvFLAGS(gv) (GvGP(gv)->gp_flags) #define GvEGV(gv) (GvGP(gv)->gp_egv) #define GvGP(gv) (GvXPVGV(gv)->xgv_gp) #define GvNAME(gv) (GvXPVGV(gv)->xgv_name) #define GvNAMELEN(gv) (GvXPVGV(gv)->xgv_namelen) #define GvENAME(gv) GvNAME(GvEGV(gv)) #define GvSTASH(gv) (GvXPVGV(gv)->xgv_stash) #define GvESTASH(gv) GvSTASH(GvEGV(gv)) #define Nullgv Null(GV*) #define DM_UID 0x003 #define DM_RUID 0x001 #define DM_EUID 0x002 #define DM_GID 0x030 #define DM_RGID 0x010 #define DM_EGID 0x020 #define DM_DELAY 0x100 #define GVf_INTRO 0x01 #define GVf_IMPORTED 0x02 #define GV_ADD 0x01 #define GV_ADDMULTI 0x02 #define GV_ADDWARN 0x04 e { perl5.000/h2ph.SH 755 203 12 14613 5650572655 6566 case $CONFIG in '') if test ! -f config.sh; then ln ../config.sh . || \ ln ../../config.sh . || \ ln ../../../config.sh . || \ (echo "Can't find config.sh."; exit 1) fi 2>/dev/null . ./config.sh ;; esac : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac echo "Extracting h2ph (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted : by putting a backslash in front. You may delete these comments. rm -f h2ph $spitshell >h2ph <>h2ph <<'!NO!SUBS!' chdir '/usr/include' || die "Can't cd /usr/include"; @isatype = split(' ',<-"); } else { ($outfile = $file) =~ s/\.h$/.ph/ || next; print "$file -> $outfile\n"; if ($file =~ m|^(.*)/|) { $dir = $1; if (!-d "$perlincl/$dir") { mkdir("$perlincl/$dir",0777); } } open(IN,"$file") || ((warn "Can't open $file: $!\n"),next); open(OUT,">$perlincl/$outfile") || die "Can't create $outfile: $!\n"; } while () { chop; while (/\\$/) { chop; $_ .= ; chop; } if (s:/\*:\200:g) { s:\*/:\201:g; s/\200[^\201]*\201//g; # delete single line comments if (s/\200.*//) { # begin multi-line comment? $_ .= '/*'; $_ .= ; redo; } } if (s/^#\s*//) { if (s/^define\s+(\w+)//) { $name = $1; $new = ''; s/\s+$//; if (s/^\(([\w,\s]*)\)//) { $args = $1; if ($args ne '') { foreach $arg (split(/,\s*/,$args)) { $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/; $curargs{$arg} = 1; } $args =~ s/\b(\w)/\$$1/g; $args = "local($args) = \@_;\n$t "; } s/^\s+//; do expr(); $new =~ s/(["\\])/\\$1/g; if ($t ne '') { $new =~ s/(['\\])/\\$1/g; print OUT $t, "eval 'sub $name {\n$t ${args}eval \"$new\";\n$t}';\n"; } else { print OUT "sub $name {\n ${args}eval \"$new\";\n}\n"; } %curargs = (); } else { s/^\s+//; do expr(); $new = 1 if $new eq ''; if ($t ne '') { $new =~ s/(['\\])/\\$1/g; print OUT $t,"eval 'sub $name {",$new,";}';\n"; } else { print OUT $t,"sub $name {",$new,";}\n"; } } } elsif (/^include\s+<(.*)>/) { ($incl = $1) =~ s/\.h$/.ph/; print OUT $t,"require '$incl';\n"; } elsif (/^ifdef\s+(\w+)/) { print OUT $t,"if (defined &$1) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); } elsif (/^ifndef\s+(\w+)/) { print OUT $t,"if (!defined &$1) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); } elsif (s/^if\s+//) { $new = ''; do expr(); print OUT $t,"if ($new) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); } elsif (s/^elif\s+//) { $new = ''; do expr(); $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); print OUT $t,"}\n${t}elsif ($new) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); } elsif (/^else/) { $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); print OUT $t,"}\n${t}else {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); } elsif (/^endif/) { $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); print OUT $t,"}\n"; } } } print OUT "1;\n"; } sub expr { while ($_ ne '') { s/^(\s+)// && do {$new .= ' '; next;}; s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;}; s/^(\d+)// && do {$new .= $1; next;}; s/^("(\\"|[^"])*")// && do {$new .= $1; next;}; s/^'((\\"|[^"])*)'// && do { if ($curargs{$1}) { $new .= "ord('\$$1')"; } else { $new .= "ord('$1')"; } next; }; s/^sizeof\s*\(([^)]+)\)/{$1}/ && do { $new .= '$sizeof'; next; }; s/^([_a-zA-Z]\w*)// && do { $id = $1; if ($id eq 'struct') { s/^\s+(\w+)//; $id .= ' ' . $1; $isatype{$id} = 1; } elsif ($id eq 'unsigned') { s/^\s+(\w+)//; $id .= ' ' . $1; $isatype{$id} = 1; } if ($curargs{$id}) { $new .= '$' . $id; } elsif ($id eq 'defined') { $new .= 'defined'; } elsif (/^\(/) { s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat $new .= " &$id"; } elsif ($isatype{$id}) { if ($new =~ /{\s*$/) { $new .= "'$id'"; } elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) { $new =~ s/\(\s*$//; s/^[\s*]*\)//; } else { $new .= $id; } } else { $new .= ' &' . $id; } next; }; s/^(.)// && do {$new .= $1; next;}; } } ############################################################################## # These next few lines are legal in both Perl and nroff. .00 ; # finish .ig 'di \" finish diversion--previous line must be blank .nr nl 0-1 \" fake up transition to first page again .nr % 0 \" start at page 1 '; __END__ ############# From here on it's a standard manual page ############ .TH H2PH 1 "August 8, 1990" .AT 3 .SH NAME h2ph \- convert .h C header files to .ph Perl header files .SH SYNOPSIS .B h2ph [headerfiles] .SH DESCRIPTION .I h2ph converts any C header files specified to the corresponding Perl header file format. It is most easily run while in /usr/include: .nf cd /usr/include; h2ph * sys/* .fi If run with no arguments, filters standard input to standard output. .SH ENVIRONMENT No environment variables are used. .SH FILES /usr/include/*.h .br /usr/include/sys/*.h .br etc. .SH AUTHOR Larry Wall .SH "SEE ALSO" perl(1) .SH DIAGNOSTICS The usual warnings if it can't read or write the files involved. .SH BUGS Doesn't construct the %sizeof array for you. .PP It doesn't handle all C constructs, but it does attempt to isolate definitions inside evals so that you can get at the definitions that it can translate. .PP It's only intended as a rough tool. You may need to dicker with the files produced. .ex !NO!SUBS! chmod 755 h2ph $eunicefix h2ph rm -f h2ph.man ln h2ph h2ph.man (SV*)(stash=SvSTASH(SvRV(left))),'c')) && (ocvp = cvp = ((oamtp=amtp=(AMT*)mg->mg_ptr)->table)) && (assigperl5.000/h2pl/ 775 203 12 0 5650575676 6231 perl5.000/h2pl/README 644 203 12 5265 5240620544 7160 [This file of Tom Christiansen's has been edited to change makelib to h2ph and .h to .ph where appropriate--law.] This directory contains files to help you convert the *.ph files generated my h2ph out of the perl source directory into *.pl files with all the indirection of the subroutine calls removed. The .ph version will be more safely portable, because if something isn't defined on the new system, like &TIOCGETP, then you'll get a fatal run-time error on the system lacking that function. Using the .pl version means that the subsequent scripts will give you a 0 $TIOCGETP and God only knows what may then happen. Still, I like the .pl stuff because they're faster to load. FIrst, you need to run h2ph on things like sys/ioctl.h to get stuff into the perl library directory, often /usr/local/lib/perl. For example, # h2ph sys/ioctl.h takes /usr/include/sys/ioctl.h as input and writes (without i/o redirection) the file /usr/local/lib/perl/sys/ioctl.ph, which looks like this eval 'sub TIOCM_RTS {0004;}'; eval 'sub TIOCM_ST {0010;}'; eval 'sub TIOCM_SR {0020;}'; eval 'sub TIOCM_CTS {0040;}'; eval 'sub TIOCM_CAR {0100;}'; and much worse, rather than what Larry's ioctl.pl from the perl source dir has, which is: $TIOCM_RTS = 0004; $TIOCM_ST = 0010; $TIOCM_SR = 0020; $TIOCM_CTS = 0040; $TIOCM_CAR = 0100; [Workaround for fixed bug in makedir/h2ph deleted--law.] The more complicated ioctl subs look like this: eval 'sub TIOCGSIZE {&TIOCGWINSZ;}'; eval 'sub TIOCGWINSZ {&_IOR("t", 104, \'struct winsize\');}'; eval 'sub TIOCSETD {&_IOW("t", 1, \'int\');}'; eval 'sub TIOCGETP {&_IOR("t", 8,\'struct sgttyb\');}'; The _IO[RW] routines use a %sizeof array, which (presumably) is keyed on the type name with the value being the size in bytes. To build %sizeof, try running this in this directory: % ./getioctlsizes Which will tell you which things the %sizeof array needs to hold. You can try to build a sizeof.ph file with: % ./getioctlsizes | ./mksizes > sizeof.ph Note that mksizes hardcodes the #include files for all the types, so it will probably require customization. Once you have sizeof.ph, install it in the perl library directory. Run my tcbreak script to see whether you can do ioctls in perl now. You'll get some kind of fatal run-time error if you can't. That script should be included in this directory. If this works well, now you can try to convert the *.ph files into *.pl files. Try this: foreach file ( sysexits.ph sys/{errno.ph,ioctl.ph} ) ./mkvars $file > t/$file:r.pl end The last one will be the hardest. If it works, should be able to run tcbreak2 and have it work the same as tcbreak. Good luck. you need to run h2ph on things like sys/ioctl.h to get stuff into the perl library directory, often /usr/local/lib/perl. For example, # h2ph sys/ioctl.h takes /usr/include/sys/ioctl.h as input and writes (without i/o redirection) the file /usr/local/lib/perl/sys/ioctl.ph, which looks like this eval 'sub TIOCM_RTS {0004perl5.000/h2pl/cbreak.pl 644 203 12 1076 5240620547 10063 $sgttyb_t = 'C4 S'; sub cbreak { &set_cbreak(1); } sub cooked { &set_cbreak(0); } sub set_cbreak { local($on) = @_; require 'sizeof.ph'; require 'sys/ioctl.ph'; ioctl(STDIN,&TIOCGETP,$sgttyb) || die "Can't ioctl TIOCGETP: $!"; @ary = unpack($sgttyb_t,$sgttyb); if ($on) { $ary[4] |= &CBREAK; $ary[4] &= ~&ECHO; } else { $ary[4] &= ~&CBREAK; $ary[4] |= &ECHO; } $sgttyb = pack($sgttyb_t,@ary); ioctl(STDIN,&TIOCSETP,$sgttyb) || die "Can't ioctl TIOCSETP: $!"; } 1; e will be the hardest. If it works, should be able to run tcbreak2 and have it work the same as tcbreak. Good luck. you need to run h2ph on things like sys/ioctl.h to get stuff into the perl library directory, often /usr/local/lib/perl. For example, # h2ph sys/ioctl.h takes /usr/include/sys/ioctl.h as input and writes (without i/o redirection) the file /usr/local/lib/perl/sys/ioctl.ph, which looks like this eval 'sub TIOCM_RTS {0004perl5.000/h2pl/cbreak2.pl 644 203 12 1045 5240620552 10135 $sgttyb_t = 'C4 S'; sub cbreak { &set_cbreak(1); } sub cooked { &set_cbreak(0); } sub set_cbreak { local($on) = @_; require 'sys/ioctl.pl'; ioctl(STDIN,$TIOCGETP,$sgttyb) || die "Can't ioctl TIOCGETP: $!"; @ary = unpack($sgttyb_t,$sgttyb); if ($on) { $ary[4] |= $CBREAK; $ary[4] &= ~$ECHO; } else { $ary[4] &= ~$CBREAK; $ary[4] |= $ECHO; } $sgttyb = pack($sgttyb_t,@ary); ioctl(STDIN,$TIOCSETP,$sgttyb) || die "Can't ioctl TIOCSETP: $!"; } 1; tl TIOCSETP: $!"; } 1; e will be the hardest. If it works, should be able to run tcbreak2 and have it work the same as tcbreak. Good luck. you need to run h2ph on things like sys/ioctl.h to get stuff into the perl library directory, often /usr/local/lib/perl. For example, # h2ph sys/ioctl.h takes /usr/include/sys/ioctl.h as input and writes (without i/o redirection) the file /usr/local/lib/perl/sys/ioctl.ph, which looks like this eval 'sub TIOCM_RTS {0004perl5.000/h2pl/eg/ 775 203 12 0 5650575675 6623 perl5.000/h2pl/eg/sizeof.ph 644 203 12 624 5240620555 10477 $sizeof{'char'} = 1; $sizeof{'int'} = 4; $sizeof{'long'} = 4; $sizeof{'struct arpreq'} = 36; $sizeof{'struct ifconf'} = 8; $sizeof{'struct ifreq'} = 32; $sizeof{'struct ltchars'} = 6; $sizeof{'struct pcntl'} = 116; $sizeof{'struct rtentry'} = 52; $sizeof{'struct sgttyb'} = 6; $sizeof{'struct tchars'} = 6; $sizeof{'struct ttychars'} = 14; $sizeof{'struct winsize'} = 8; $sizeof{'struct termios'} = 132; [4] |= $ECHO; } $sgttyb = pack($sgttyb_t,@ary); ioctl(STDIN,$TIOCSETP,$sgttyb) || diperl5.000/h2pl/eg/sys/ 775 203 12 0 5650575675 7441 perl5.000/h2pl/eg/sys/errno.pl 644 203 12 3274 5240620560 11167 $EPERM = 0x1; $ENOENT = 0x2; $ESRCH = 0x3; $EINTR = 0x4; $EIO = 0x5; $ENXIO = 0x6; $E2BIG = 0x7; $ENOEXEC = 0x8; $EBADF = 0x9; $ECHILD = 0xA; $EAGAIN = 0xB; $ENOMEM = 0xC; $EACCES = 0xD; $EFAULT = 0xE; $ENOTBLK = 0xF; $EBUSY = 0x10; $EEXIST = 0x11; $EXDEV = 0x12; $ENODEV = 0x13; $ENOTDIR = 0x14; $EISDIR = 0x15; $EINVAL = 0x16; $ENFILE = 0x17; $EMFILE = 0x18; $ENOTTY = 0x19; $ETXTBSY = 0x1A; $EFBIG = 0x1B; $ENOSPC = 0x1C; $ESPIPE = 0x1D; $EROFS = 0x1E; $EMLINK = 0x1F; $EPIPE = 0x20; $EDOM = 0x21; $ERANGE = 0x22; $EWOULDBLOCK = 0x23; $EINPROGRESS = 0x24; $EALREADY = 0x25; $ENOTSOCK = 0x26; $EDESTADDRREQ = 0x27; $EMSGSIZE = 0x28; $EPROTOTYPE = 0x29; $ENOPROTOOPT = 0x2A; $EPROTONOSUPPORT = 0x2B; $ESOCKTNOSUPPORT = 0x2C; $EOPNOTSUPP = 0x2D; $EPFNOSUPPORT = 0x2E; $EAFNOSUPPORT = 0x2F; $EADDRINUSE = 0x30; $EADDRNOTAVAIL = 0x31; $ENETDOWN = 0x32; $ENETUNREACH = 0x33; $ENETRESET = 0x34; $ECONNABORTED = 0x35; $ECONNRESET = 0x36; $ENOBUFS = 0x37; $EISCONN = 0x38; $ENOTCONN = 0x39; $ESHUTDOWN = 0x3A; $ETOOMANYREFS = 0x3B; $ETIMEDOUT = 0x3C; $ECONNREFUSED = 0x3D; $ELOOP = 0x3E; $ENAMETOOLONG = 0x3F; $EHOSTDOWN = 0x40; $EHOSTUNREACH = 0x41; $ENOTEMPTY = 0x42; $EPROCLIM = 0x43; $EUSERS = 0x44; $EDQUOT = 0x45; $ESTALE = 0x46; $EREMOTE = 0x47; $EDEADLK = 0x48; $ENOLCK = 0x49; $MTH_UNDEF_SQRT = 0x12C; $MTH_OVF_EXP = 0x12D; $MTH_UNDEF_LOG = 0x12E; $MTH_NEG_BASE = 0x12F; $MTH_ZERO_BASE = 0x130; $MTH_OVF_POW = 0x131; $MTH_LRG_SIN = 0x132; $MTH_LRG_COS = 0x133; $MTH_LRG_TAN = 0x134; $MTH_LRG_COT = 0x135; $MTH_OVF_TAN = 0x136; $MTH_OVF_COT = 0x137; $MTH_UNDEF_ASIN = 0x138; $MTH_UNDEF_ACOS = 0x139; $MTH_UNDEF_ATAN2 = 0x13A; $MTH_OVF_SINH = 0x13B; $MTH_OVF_COSH = 0x13C; $MTH_UNDEF_ZLOG = 0x13D; $MTH_UNDEF_ZDIV = 0x13E; EFAULT = 0xE; $ENOTBLK = 0xF; $EBUSY = 0x10; $EEXIST = 0x11; $EXDEV = 0x12; $ENODEV = 0x13; $ENOTDIR = 0x14; $EISDIR = 0x15; $EINVAL = 0x16; $ENFILE = 0x17; $EMFILE = 0x18; $ENOTTY = 0x19; $ETXTBSY = 0x1A; $EFBIG = 0x1B; $ENOSPC = 0x1C; $ESPIPE = 0x1D; $EROFS = 0x1E; $EMLINK = 0x1F; $EPIPE = 0x20; $EDOM = 0x21; $ERANGE = 0perl5.000/h2pl/eg/sys/ioctl.pl 644 203 12 7743 5240620564 11165 $_IOCTL_ = 0x1; $TIOCGSIZE = 0x40087468; $TIOCSSIZE = 0x80087467; $IOCPARM_MASK = 0x7F; $IOC_VOID = 0x20000000; $IOC_OUT = 0x40000000; $IOC_IN = 0x80000000; $IOC_INOUT = 0xC0000000; $TIOCGETD = 0x40047400; $TIOCSETD = 0x80047401; $TIOCHPCL = 0x20007402; $TIOCMODG = 0x40047403; $TIOCMODS = 0x80047404; $TIOCM_LE = 0x1; $TIOCM_DTR = 0x2; $TIOCM_RTS = 0x4; $TIOCM_ST = 0x8; $TIOCM_SR = 0x10; $TIOCM_CTS = 0x20; $TIOCM_CAR = 0x40; $TIOCM_CD = 0x40; $TIOCM_RNG = 0x80; $TIOCM_RI = 0x80; $TIOCM_DSR = 0x100; $TIOCGETP = 0x40067408; $TIOCSETP = 0x80067409; $TIOCSETN = 0x8006740A; $TIOCEXCL = 0x2000740D; $TIOCNXCL = 0x2000740E; $TIOCFLUSH = 0x80047410; $TIOCSETC = 0x80067411; $TIOCGETC = 0x40067412; $TIOCSET = 0x80047413; $TIOCBIS = 0x80047414; $TIOCBIC = 0x80047415; $TIOCGET = 0x40047416; $TANDEM = 0x1; $CBREAK = 0x2; $LCASE = 0x4; $ECHO = 0x8; $CRMOD = 0x10; $RAW = 0x20; $ODDP = 0x40; $EVENP = 0x80; $ANYP = 0xC0; $NLDELAY = 0x300; $NL0 = 0x0; $NL1 = 0x100; $NL2 = 0x200; $NL3 = 0x300; $TBDELAY = 0xC00; $TAB0 = 0x0; $TAB1 = 0x400; $TAB2 = 0x800; $XTABS = 0xC00; $CRDELAY = 0x3000; $CR0 = 0x0; $CR1 = 0x1000; $CR2 = 0x2000; $CR3 = 0x3000; $VTDELAY = 0x4000; $FF0 = 0x0; $FF1 = 0x4000; $BSDELAY = 0x8000; $BS0 = 0x0; $BS1 = 0x8000; $ALLDELAY = 0xFF00; $CRTBS = 0x10000; $PRTERA = 0x20000; $CRTERA = 0x40000; $TILDE = 0x80000; $MDMBUF = 0x100000; $LITOUT = 0x200000; $TOSTOP = 0x400000; $FLUSHO = 0x800000; $NOHANG = 0x1000000; $L001000 = 0x2000000; $CRTKIL = 0x4000000; $L004000 = 0x8000000; $CTLECH = 0x10000000; $PENDIN = 0x20000000; $DECCTQ = 0x40000000; $NOFLSH = 0x80000000; $TIOCCSET = 0x800E7417; $TIOCCGET = 0x400E7418; $TIOCLBIS = 0x8004747F; $TIOCLBIC = 0x8004747E; $TIOCLSET = 0x8004747D; $TIOCLGET = 0x4004747C; $LCRTBS = 0x1; $LPRTERA = 0x2; $LCRTERA = 0x4; $LTILDE = 0x8; $LMDMBUF = 0x10; $LLITOUT = 0x20; $LTOSTOP = 0x40; $LFLUSHO = 0x80; $LNOHANG = 0x100; $LCRTKIL = 0x400; $LCTLECH = 0x1000; $LPENDIN = 0x2000; $LDECCTQ = 0x4000; $LNOFLSH = 0x8000; $TIOCSBRK = 0x2000747B; $TIOCCBRK = 0x2000747A; $TIOCSDTR = 0x20007479; $TIOCCDTR = 0x20007478; $TIOCGPGRP = 0x40047477; $TIOCSPGRP = 0x80047476; $TIOCSLTC = 0x80067475; $TIOCGLTC = 0x40067474; $TIOCOUTQ = 0x40047473; $TIOCSTI = 0x80017472; $TIOCNOTTY = 0x20007471; $TIOCPKT = 0x80047470; $TIOCPKT_DATA = 0x0; $TIOCPKT_FLUSHREAD = 0x1; $TIOCPKT_FLUSHWRITE = 0x2; $TIOCPKT_STOP = 0x4; $TIOCPKT_START = 0x8; $TIOCPKT_NOSTOP = 0x10; $TIOCPKT_DOSTOP = 0x20; $TIOCSTOP = 0x2000746F; $TIOCSTART = 0x2000746E; $TIOCREMOTE = 0x20007469; $TIOCGWINSZ = 0x40087468; $TIOCSWINSZ = 0x80087467; $TIOCRESET = 0x20007466; $OTTYDISC = 0x0; $NETLDISC = 0x1; $NTTYDISC = 0x2; $FIOCLEX = 0x20006601; $FIONCLEX = 0x20006602; $FIONREAD = 0x4004667F; $FIONBIO = 0x8004667E; $FIOASYNC = 0x8004667D; $FIOSETOWN = 0x8004667C; $FIOGETOWN = 0x4004667B; $STPUTTABLE = 0x8004667A; $STGETTABLE = 0x80046679; $SIOCSHIWAT = 0x80047300; $SIOCGHIWAT = 0x40047301; $SIOCSLOWAT = 0x80047302; $SIOCGLOWAT = 0x40047303; $SIOCATMARK = 0x40047307; $SIOCSPGRP = 0x80047308; $SIOCGPGRP = 0x40047309; $SIOCADDRT = 0x8034720A; $SIOCDELRT = 0x8034720B; $SIOCSIFADDR = 0x8020690C; $SIOCGIFADDR = 0xC020690D; $SIOCSIFDSTADDR = 0x8020690E; $SIOCGIFDSTADDR = 0xC020690F; $SIOCSIFFLAGS = 0x80206910; $SIOCGIFFLAGS = 0xC0206911; $SIOCGIFBRDADDR = 0xC0206912; $SIOCSIFBRDADDR = 0x80206913; $SIOCGIFCONF = 0xC0086914; $SIOCGIFNETMASK = 0xC0206915; $SIOCSIFNETMASK = 0x80206916; $SIOCGIFMETRIC = 0xC0206917; $SIOCSIFMETRIC = 0x80206918; $SIOCSARP = 0x8024691E; $SIOCGARP = 0xC024691F; $SIOCDARP = 0x80246920; $PIXCONTINUE = 0x80747000; $PIXSTEP = 0x80747001; $PIXTERMINATE = 0x20007002; $PIGETFLAGS = 0x40747003; $PIXINHERIT = 0x80747004; $PIXDETACH = 0x20007005; $PIXGETSUBCODE = 0xC0747006; $PIXRDREGS = 0xC0747007; $PIXWRREGS = 0xC0747008; $PIXRDVREGS = 0xC0747009; $PIXWRVREGS = 0xC074700A; $PIXRDVSTATE = 0xC074700B; $PIXWRVSTATE = 0xC074700C; $PIXRDCREGS = 0xC074700D; $PIXWRCREGS = 0xC074700E; $PIRDSDRS = 0xC074700F; $PIXGETSIGACTION = 0xC0747010; $PIGETU = 0xC0747011; $PISETRWTID = 0xC0747012; $PIXGETTHCOUNT = 0xC0747013; $PIXRUN = 0x20007014; .ph Perl header files .SH SYperl5.000/h2pl/eg/sysexits.pl 644 203 12 467 5240620566 11106 $EX_OK = 0x0; $EX__BASE = 0x40; $EX_USAGE = 0x40; $EX_DATAERR = 0x41; $EX_NOINPUT = 0x42; $EX_NOUSER = 0x43; $EX_NOHOST = 0x44; $EX_UNAVAILABLE = 0x45; $EX_SOFTWARE = 0x46; $EX_OSERR = 0x47; $EX_OSFILE = 0x48; $EX_CANTCREAT = 0x49; $EX_IOERR = 0x4A; $EX_TEMPFAIL = 0x4B; $EX_PROTOCOL = 0x4C; $EX_NOPERM = 0x4D; = 0x1; $TIOCM_DTR = 0x2; $TIOCM_RTS = 0x4; $TIOCM_ST = 0x8; $TIOCM_SR = 0x10; $TIOCM_CTS = 0x20; $TIOCM_CAR = 0x40; $TIOCM_CD = 0x40; $TIOCM_RNG = 0x80; $TIOCM_RI = 0x80; $TIOCM_DSR = 0x100; $TIOCGETPperl5.000/h2pl/getioctlsizes 644 203 12 410 5240620570 11055 #!/usr/bin/perl open (IOCTLS,'/usr/include/sys/ioctl.h') || die "ioctl open failed"; while () { if (/^\s*#\s*define\s+\w+\s+_IO(R|W|WR)\('?\w+'?,\s*\w+,\s*([^)]+)/) { $need{$2}++; } } foreach $key ( sort keys %need ) { print $key,"\n"; } 0x4B; $EX_PROTOCOL = 0x4C; $EX_NOPERM = 0x4D; = 0x1; $TIOCM_DTR = 0x2; $TIOCM_RTS = 0x4; $TIOCM_ST = 0x8; $TIOCM_SR = 0x10; $TIOCM_CTS = 0x20; $TIOCM_CAR = 0x40; $TIOCM_CD = 0x40; $TIOCM_RNG = 0x80; $TIOCM_RI = 0x80; $TIOCM_DSR = 0x100; $TIOCGETPperl5.000/h2pl/mksizes 644 203 12 1314 5240620574 7702 #!/usr/local/bin/perl ($iam = $0) =~ s%.*/%%; $tmp = "$iam.$$"; open (CODE,">$tmp.c") || die "$iam: cannot create $tmp.c: $!\n"; $mask = q/printf ("$sizeof{'%s'} = %d;\n"/; # write C program select(CODE); print < #include #include #include #include #include #include main() { EO_C_PROGRAM while ( <> ) { chop; printf "\t%s, \n\t\t\"%s\", sizeof(%s));\n", $mask, $_,$_; } print "\n}\n"; close CODE; # compile C program select(STDOUT); system "cc $tmp.c -o $tmp"; die "couldn't compile $tmp.c" if $?; system "./$tmp"; die "couldn't run $tmp" if $?; unlink "$tmp.c", $tmp; DE); print < #include #include #include #include #include #include main() { EO_C_PROGRAM while ( <> ) { chop; printf "\t%s, \n\t\t\"%s\", sizeof(%s));\n", $mask, $_,$_; } printperl5.000/h2pl/mkvars 644 203 12 1261 5240620577 7524 #!/usr/bin/perl require 'sizeof.ph'; $LIB = '/usr/local/lib/perl'; foreach $include (@ARGV) { printf STDERR "including %s\n", $include; do $include; warn "sourcing $include: $@\n" if ($@); if (!open (INCLUDE,"$LIB/$include")) { warn "can't open $LIB/$include: $!\n"; next; } while () { chop; if (/^\s*eval\s+'sub\s+(\w+)\s.*[^{]$/ || /^\s*sub\s+(\w+)\s.*[^{]$/) { $var = $1; $val = eval "&$var;"; if ($@) { warn "$@: $_"; print <) { chop; if (/^\s*eval\s+'sub\s+(\w+)\s.*[^{]$/ || /^\s*sub\s+(\w+)\s.*[^{]$/) { $var = $1; $val = eval "&$var;"; if ($@) { warn "$@: $_"; print <) { chop; if (/^\s*eval\s+'sub\s+(\w+)\s.*[^{]$/ || /^\s*sub\s+(\w+)\s.*[^{]$/) { $var = $1; $val = eval "&$var;"; if ($@) { warn "$@: $_"; print <$modfname.xs") || die "Can't create ext/$modpname/$modfname.xs: $!\n"; open(PM, ">$modfname.pm") || die "Can't create ext/$modpname/$modfname.pm: $!\n"; if( -r $path_h ){ open(CH, "<$path_h") || die "Can't open $path_h: $!\n"; while () { if (/^#[ \t]*define\s+(\w+)\b\s*[^("]/) { $_ = $1; next if /^_.*_h_*$/i; $names{$_}++; @AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/; @az = 'a' .. 'z' if !@az && /^[a-z]/; @under = '_' if !@under && /^_/; } } close(CH); @names = sort keys %names; } $" = "\n\t"; warn "Writing ext/$modpname/$modfname.pm\n"; if( ! $opt_a ){ print PM <<"END"; package $module; require Exporter; require AutoLoader; require DynaLoader; \@ISA = qw(Exporter AutoLoader DynaLoader); # Items to export into callers namespace by default # (move infrequently used names to \@EXPORT_OK below) \@EXPORT = qw( @names ); # Other items we are prepared to export if requested \@EXPORT_OK = qw( ); sub AUTOLOAD { if (\@_ > 1) { \$AutoLoader::AUTOLOAD = \$AUTOLOAD; goto &AutoLoader::AUTOLOAD; } local(\$constname); (\$constname = \$AUTOLOAD) =~ s/.*:://; \$val = constant(\$constname, \@_ ? \$_[0] : 0); if (\$! != 0) { if (\$! =~ /Invalid/) { \$AutoLoader::AUTOLOAD = \$AUTOLOAD; goto &AutoLoader::AUTOLOAD; } else { (\$pack,\$file,\$line) = caller; die "Your vendor has not defined $module macro \$constname, used at \$file line \$line.\n"; } } eval "sub \$AUTOLOAD { \$val }"; goto &\$AUTOLOAD; } bootstrap $module; # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. 1; __END__ END } else{ print PM <<"END"; package $module; require Exporter; require DynaLoader; \@ISA = qw(Exporter DynaLoader); # Items to export into callers namespace by default \@EXPORT = qw(); # Other items we are prepared to export if requested \@EXPORT_OK = qw(); bootstrap $module; 1; END } close PM; warn "Writing ext/$modpname/$modfname.xs\n"; print XS <<"END"; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" END if( $path_h ){ my($h) = $path_h; $h =~ s#^/usr/include/##; print XS <<"END"; #include <$h> END } if( ! $opt_c ){ print XS <<"END"; static int not_here(s) char *s; { croak("$module::%s not implemented on this architecture", s); return -1; } static double constant(name, arg) char *name; int arg; { errno = 0; switch (*name) { END foreach $letter (@AZ, @az, @under) { last if $letter eq 'a' && !@names; print XS " case '$letter':\n"; my($name); while (substr($names[0],0,1) eq $letter) { $name = shift(@names); print XS <<"END"; if (strEQ(name, "$name")) #ifdef $name return $name; #else goto not_there; #endif END } print XS <<"END"; break; END } print XS <<"END"; } errno = EINVAL; return 0; not_there: errno = ENOENT; return 0; } MODULE = $module PACKAGE = $module double constant(name,arg) char * name int arg END } else{ print XS <<"END"; MODULE = $module PACKAGE = $module END } close XS; { warn "Writing ext/$modpname/Makefile.PL\n"; open(PL, ">Makefile.PL") || die "Can't create ext/$modpname/Makefile.PL: $!\n"; # Ideally this should have a #!../.. ... miniperl etc header print PL <<'END'; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile being created. END print PL "&writeMakefile(\n"; print PL " 'potential_libs' => '$extralibs', # e.g., '-lm' \n"; print PL " 'INC' => '', # e.g., '-I/usr/include/other' \n"; print PL " 'DISTNAME' => 'myname',\n"; print PL " 'VERSION' => '0.1',\n"; print PL ");\n"; } if ($write_makefile_sh){ warn "Writing ext/$modpname/Makefile.SH\n"; open(MF, ">Makefile.SH") || die "Can't create ext/$modpname/Makefile.SH: $!\n"; print MF <<'END'; : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac 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 fi : Find absolute path name for TOP. This is needed when we cd to TOP : to run perl on autosplit. oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd case $CONFIG in '') . $TOP/config.sh ;; esac : Find out directory name. This is also the extension name. ext=`pwd | $sed -e 's@.*/@@'` : This extension might have its own typemap if test -f typemap; then exttypemap='typemap' else exttypemap='' fi : This extension might need additional libraries. END print MF "potential_libs=\"$extralibs\"\n"; print MF <<'END'; . $TOP/ext/util/extliblist : This extension might need bootstrap support if test -f ${ext}_BS; then bootdep=${ext}_BS else bootdep='' fi case "$dlsrc" in dl_aix*) echo "#!" > $ext.exp echo "boot_$ext" >> $ext.exp ;; esac echo "Extracting ext/$ext/Makefile (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted : by putting a backslash in front. You may delete these comments. $spitshell >Makefile << !GROK!THIS! # # This Makefile is for the $ext extension to perl. # CC = $cc RANLIB = $ranlib TOP = $TOP ABSTOP = $ABSTOP LDFLAGS = $ldflags CLDFLAGS = $ldflags SMALL = $small LARGE = $large $split # To use an alternate make, set \\$altmake in config.sh. MAKE = ${altmake-make} EXT = $ext # $ext might have its own typemap EXTTYPEMAP = $exttypemap # $ext might have its own bootstrap support BOOTDEP = $bootdep BOOTSTRAP = $ext.bs # The following are used to build and install shared libraries for # dynamic loading. LDDLFLAGS = $lddlflags CCDLFLAGS = $ccdlflags CCCDLFLAGS = $cccdlflags SO = $so # $ext might need to be linked with some extra libraries. # EXTRALIBS = full list of libraries needed for static linking. # Only those libraries that actually exist are included. # DYNLOADLIBS = list of those libraries that are needed but can be # linked in dynamically on this platform. On SunOS, for # example, this would be .so* libraries, but not archive # libraries. The bootstrap file is installed only if # this list is not empty. # STATLOADLIBS = list of those libraries which must be statically # linked into the shared library. On SunOS 4.1.3, # for example, I have only an archive version of # -lm, and it must be linked in statically. EXTRALIBS = $extralibs DYNALOADLIBS = $dynaloadlibs STATLOADLIBS = $statloadlibs !GROK!THIS! $spitshell >>Makefile <<'!NO!SUBS!' # Where to put things: AUTO = $(TOP)/lib/auto INSTALLBOOT = $(AUTO)/$(EXT)/$(EXT).bs INSTALLDYNAMIC = $(AUTO)/$(EXT)/$(EXT).$(SO) INSTALLSTATIC = $(EXT).a INSTALLPM = $(TOP)/lib/$(EXT).pm PERL = $(ABSTOP)/miniperl XSUBPP = $(TOP)/ext/xsubpp SHELL = /bin/sh CCCMD = `sh $(shellflags) $(TOP)/cflags $@` .c.o: $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c all: dynamic # Phony target to force checking subdirectories. FORCE: # Target for Dynamic Loading: dynamic: $(INSTALLDYNAMIC) $(INSTALLPM) $(INSTALLBOOT) $(INSTALLDYNAMIC): $(EXT).o @test -d $(AUTO) || mkdir $(AUTO) @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) ld $(LDDLFLAGS) -o $@ $(EXT).o $(STATLOADLIBS) $(BOOTSTRAP): Makefile $(BOOTDEP) $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) touch $(BOOTSTRAP) $(INSTALLBOOT): $(BOOTSTRAP) @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ # Target for Static Loading: static: $(INSTALLSTATIC) $(INSTALLPM) $(INSTALLSTATIC): $(EXT).o ar cr $@ $(EXT).o $(RANLIB) $@ echo $(EXTRALIBS) >> $(TOP)/ext.libs $(EXT).c: $(EXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile $(PERL) $(XSUBPP) $(EXT).xs >tmp mv tmp $@ END if( ! $opt_a ){ print MF <<'END'; $(INSTALLPM): $(EXT).pm rm -f $@ cp $(EXT).pm $@ cd $(TOP); $(PERL) autosplit $(EXT) END } else { print MF <<'END'; $(INSTALLPM): $(EXT).pm cp $(EXT).pm $@ END } print MF <<'END'; clean: rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp realclean: clean rm -f makefile Makefile rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) rm -rf $(AUTO)/$(EXT) purge: realclean $(EXT).o : $(TOP)/EXTERN.h $(EXT).o : $(TOP)/perl.h $(EXT).o : $(TOP)/embed.h $(EXT).o : $(TOP)/config.h $(EXT).o : $(TOP)/unixish.h $(EXT).o : $(TOP)/handy.h $(EXT).o : $(TOP)/regexp.h $(EXT).o : $(TOP)/sv.h $(EXT).o : $(TOP)/util.h $(EXT).o : $(TOP)/form.h $(EXT).o : $(TOP)/gv.h $(EXT).o : $(TOP)/cv.h $(EXT).o : $(TOP)/opcode.h $(EXT).o : $(TOP)/op.h $(EXT).o : $(TOP)/cop.h $(EXT).o : $(TOP)/av.h $(EXT).o : $(TOP)/hv.h $(EXT).o : $(TOP)/mg.h $(EXT).o : $(TOP)/scope.h $(EXT).o : $(TOP)/pp.h $(EXT).o : $(TOP)/proto.h $(EXT).o : $(TOP)/XSUB.h Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH $(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH $(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH $(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH !NO!SUBS! chmod 755 Makefile $eunicefix Makefile END close MF; } system '/bin/ls > MANIFEST'; # this needs fixing # system '[ -f Makefile.SH ] && sh Makefile.SH'; # system '[ -f Makefile.PL ] && perl Makefile.PL'; ############################################################################## # These next few lines are legal in both Perl and nroff. .00 ; # finish .ig 'di \" finish diversion--previous line must be blank .nr nl 0-1 \" fake up transition to first page again .nr % 0 \" start at page 1 '; __END__ ############# From here on it's a standard manual page ############ .TH H2XS 1 "August 9, 1994" .AT 3 .SH NAME h2xs \- convert .h C header files to Perl extensions .SH SYNOPSIS .B h2xs [-Aachfm] [-n module_name] [headerfile [extra_libraries]] .SH DESCRIPTION .I h2xs builds a Perl extension from any C header file. The extension will include functions which can be used to retrieve the value of any #define statement which was in the C header. .PP The .I module_name will be used for the name of the extension. If module_name is not supplied then the name of the header file will be used, with the first character capitalized. .PP If the extension might need extra libraries, they should be included here. The extension Makefile.SH will take care of checking whether the libraries actually exist and how they should be loaded. The extra libraries should be specified in the form -lm -lposix, etc, just as on the cc command line. By default, the Makefile.SH will search through the library path determined by Configure. That path can be augmented by including arguments of the form -L/another/library/path in the extra-libraries argument. .SH OPTIONS .TP .B \-f Allows an extension to be created for a header even if that header is not found in /usr/include. .TP .B \-a Omit AutoLoad(), AUTOLOAD, and autosplit from the .pm and Makefile files. .TP .B \-c Omit constant() from the .xs file. .TP .B \-n module_name Specifies a name to be used for the extension. .TP .B \-A Turns on both -a and -c. .TP .B \-m Causes an old-style Makefile.SH to be created. .SH EXAMPLES .nf # Default behavior, extension is Rusers h2xs rpcsvc/rusers # Same, but extension is RUSERS h2xs -n RUSERS rpcsvc/rusers # Extension is rpcsvc::rusers. Still finds h2xs rpcsvc::rusers # Extension is ONC::RPC. Still finds h2xs -n ONC::RPC rpcsvc/rusers # Without AUTOLOAD, AutoLoad, autosplit h2xs -a rpcsvc/rusers # Creates templates for an extension named RPC h2xs -Afn RPC # Extension is ONC::RPC. h2xs -An ONC::RPC # Makefile.SH will look for library -lrpc in # additional directory /opt/net/lib h2xs rpcsvc/rusers -L/opt/net/lib -lrpc .fi .SH ENVIRONMENT No environment variables are used. .SH AUTHOR Larry Wall .SH "SEE ALSO" perl(1) .SH DIAGNOSTICS The usual warnings if it can't read or write the files involved. .ex ives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac 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 fi : Find absolute path name for TOP. This is needed when weperl5.000/handy.h 644 203 12 12621 5650572637 6737 /* handy.h * * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ #if !defined(__STDC__) #ifdef NULL #undef NULL #endif #ifndef I286 # define NULL 0 #else # define NULL 0L #endif #endif #define Null(type) ((type)NULL) #define Nullch Null(char*) #define Nullfp Null(FILE*) #define Nullsv Null(SV*) #ifdef UTS #define bool int #else #define bool char #endif #ifdef TRUE #undef TRUE #endif #ifdef FALSE #undef FALSE #endif #define TRUE (1) #define FALSE (0) typedef char I8; typedef unsigned char U8; typedef short I16; typedef unsigned short U16; #if BYTEORDER > 0x4321 typedef int I32; typedef unsigned int U32; #else typedef long I32; typedef unsigned long U32; #endif #define Ctl(ch) (ch & 037) #define strNE(s1,s2) (strcmp(s1,s2)) #define strEQ(s1,s2) (!strcmp(s1,s2)) #define strLT(s1,s2) (strcmp(s1,s2) < 0) #define strLE(s1,s2) (strcmp(s1,s2) <= 0) #define strGT(s1,s2) (strcmp(s1,s2) > 0) #define strGE(s1,s2) (strcmp(s1,s2) >= 0) #define strnNE(s1,s2,l) (strncmp(s1,s2,l)) #define strnEQ(s1,s2,l) (!strncmp(s1,s2,l)) #ifdef HAS_SETLOCALE /* XXX Is there a better test for this? */ # ifndef CTYPE256 # define CTYPE256 # endif #endif #ifdef USE_NEXT_CTYPE #define isALNUM(c) (NXIsAlpha((unsigned int)c) || NXIsDigit((unsigned int)c) || c == '_') #define isIDFIRST(c) (NXIsAlpha((unsigned int)c) || c == '_') #define isALPHA(c) NXIsAlpha((unsigned int)c) #define isSPACE(c) NXIsSpace((unsigned int)c) #define isDIGIT(c) NXIsDigit((unsigned int)c) #define isUPPER(c) NXIsUpper((unsigned int)c) #define isLOWER(c) NXIsLower((unsigned int)c) #define toUPPER(c) NXToUpper((unsigned int)c) #define toLOWER(c) NXToLower((unsigned int)c) #else /* USE_NEXT_CTYPE */ #if defined(CTYPE256) || (!defined(isascii) && !defined(HAS_ISASCII)) #define isALNUM(c) (isalpha((unsigned char)(c)) || isdigit((unsigned char)(c)) || c == '_') #define isIDFIRST(c) (isalpha((unsigned char)(c)) || (c) == '_') #define isALPHA(c) isalpha((unsigned char)(c)) #define isSPACE(c) isspace((unsigned char)(c)) #define isDIGIT(c) isdigit((unsigned char)(c)) #define isUPPER(c) isupper((unsigned char)(c)) #define isLOWER(c) islower((unsigned char)(c)) #define toUPPER(c) toupper((unsigned char)(c)) #define toLOWER(c) tolower((unsigned char)(c)) #else #define isALNUM(c) (isascii(c) && (isalpha(c) || isdigit(c) || c == '_')) #define isIDFIRST(c) (isascii(c) && (isalpha(c) || (c) == '_')) #define isALPHA(c) (isascii(c) && isalpha(c)) #define isSPACE(c) (isascii(c) && isspace(c)) #define isDIGIT(c) (isascii(c) && isdigit(c)) #define isUPPER(c) (isascii(c) && isupper(c)) #define isLOWER(c) (isascii(c) && islower(c)) #define toUPPER(c) toupper(c) #define toLOWER(c) tolower(c) #endif #endif /* USE_NEXT_CTYPE */ /* Line numbers are unsigned, 16 bits. */ typedef U16 line_t; #ifdef lint #define NOLINE ((line_t)0) #else #define NOLINE ((line_t) 65535) #endif #ifndef lint #ifndef LEAKTEST #ifndef safemalloc char *safemalloc _((MEM_SIZE)); char *saferealloc _((char *, MEM_SIZE)); void safefree _((char *)); #endif #ifndef MSDOS #define New(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))) #define Newc(x,v,n,t,c) (v = (c*)safemalloc((MEM_SIZE)((n) * sizeof(t)))) #define Newz(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))), \ memzero((char*)(v), (n) * sizeof(t)) #define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) #define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) #else #define New(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t)))) #define Newc(x,v,n,t,c) (v = (c*)safemalloc(((unsigned long)(n) * sizeof(t)))) #define Newz(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t)))), \ memzero((char*)(v), (n) * sizeof(t)) #define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t)))) #define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t)))) #endif /* MSDOS */ #define Safefree(d) safefree((char*)d) #define NEWSV(x,len) newSV(len) #else /* LEAKTEST */ char *safexmalloc(); char *safexrealloc(); void safexfree(); #define New(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))) #define Newc(x,v,n,t,c) (v = (c*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))) #define Newz(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))), \ memzero((char*)(v), (n) * sizeof(t)) #define Renew(v,n,t) (v = (t*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) #define Renewc(v,n,t,c) (v = (c*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) #define Safefree(d) safexfree((char*)d) #define NEWSV(x,len) newSV(x,len) #define MAXXCOUNT 1200 long xcount[MAXXCOUNT]; long lastxcount[MAXXCOUNT]; #endif /* LEAKTEST */ #define Move(s,d,n,t) (void)memmove((char*)(d),(char*)(s), (n) * sizeof(t)) #define Copy(s,d,n,t) (void)memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) #define Zero(d,n,t) (void)memzero((char*)(d), (n) * sizeof(t)) #else /* lint */ #define New(x,v,n,s) (v = Null(s *)) #define Newc(x,v,n,s,c) (v = Null(s *)) #define Newz(x,v,n,s) (v = Null(s *)) #define Renew(v,n,s) (v = Null(s *)) #define Move(s,d,n,t) #define Copy(s,d,n,t) #define Zero(d,n,t) #define Safefree(d) d = d #endif /* lint */ #ifdef USE_STRUCT_COPY #define StructCopy(s,d,t) *((t*)(d)) = *((t*)(s)) #else #define StructCopy(s,d,t) Copy(s,d,1,t) #endif fine Nullfp Null(FILE*) #define Nullsv Null(SV*) #ifdef UTS #define bool int #else #define bool char #endif #perl5.000/hints/ 775 203 12 0 5650575702 6477 perl5.000/hints/3b1.sh 644 203 12 620 5240620617 7450 d_voidsig='undef' d_tosignal='int' gidtype='int' groupstype='int' uidtype='int' # Note that 'Configure' is run from 'UU', hence the strange 'ln' # command. for i in .. ../x2p do rm -f $i/3b1cc ln ../hints/3b1cc $i done echo "\nIf you want to use the 3b1 shared libraries, complete this script then" echo "read the header in 3b1cc. [Type carriage return to continue]\c" read vch  greenhills.sh.cl hpux_9.shde|i386.sh irix_4.sh.p¤ irix_5.shevperl5.000/hints/3b1cc 644 203 12 3463 5557314633 7406 # To incorporate the 7300/3b1 shared library, run this script in place # of 'CC'. # You can skip this is you have the shcc program installed as cc in # your path. # First: Run 'Configure' through to the end and run 'make depend'. # Second: Edit 'makefile' ( not Makefile ) and set CC = 3b1cc. # Third: Edit 'x2p/makefile' and set CC = 3b1cc. # # Do not use '3b1cc' as the default compiler. The call to the default # compiler is used by 'perl' and will not be available when running # 'perl'. # # Note: This script omits libraries which are redundant in the shared # library. It is an excerpt from a grander version available upon # request from "zebra!vern" or "vern@zebra.alphacdc.com". CC="cc" LIBS= INCL= LD="ld" SHAREDLIB="/lib/crt0s.o /lib/shlib.ifile" # Local variables COBJS= LOBJS= TARG= FLAGS= CMD= # These are libraries which are incorporated in the shared library OMIT="-lmalloc" # These routines are in libc.a but not in the shared library if [ ! -f vsprintf.o -o ! -f doprnt.o ] then echo "Extracting vsprintf.o from libc.a" ar -x /lib/libc.a vsprintf.o doprnt.o fi CMD="$CC" while [ $# -gt 0 ] do case $1 in -c) CFLAG=$1;; -o) CFLAG=$1 shift TARG="$1";; -l*) match=false for i in $OMIT do [ "$i" = "$1" ] && match=true done [ "$match" != false ] || LIBS="$LIBS $1";; -*) FLAGS="$FLAGS $1";; *.c) COBJS="$COBJS $1";; *.o) LOBJS="$LOBJS $1";; *) TARG="$1";; esac shift done if [ -n "$COBJS" ] then CMD="$CMD $FLAGS $INCL $LPATHS $LIBS $COBJS $CFLAG $TARG" elif [ -n "$LOBJS" ] then LOBJS="$LOBJS vsprintf.o doprnt.o" CMD="$LD -r $LOBJS $LPATHS $LIBS -o temp.o" echo "\t$CMD" $CMD CMD="$LD -s temp.o $SHAREDLIB -o $TARG" echo "\t$CMD" $CMD ccrslt=$? if [ $ccrslt -ne 0 ] then exit $ccrslt fi CMD="rm -f temp.o" else exit 1 fi echo "\t$CMD" $CMD ccrslt=$? rm -f $$.c exit $ccrslt E_NEXT_CTYPE */ #if defined(CTYPE256) || (!defined(isascii) && !defined(HAS_ISASCII)) #define isALNUM(c) (isalpha((unsigned char)(c)) || isdigit((unsigned char)(c)) || c == '_') #define isIDFIRST(c) (isaperl5.000/hints/README.hints 664 203 12 1572 5645376767 10613 These files are used by Configure to set things which Configure either can't or doesn't guess properly. Most of these hints files are from perl4. They may or may not work with perl5, but they are probably a good starting point. The following hints files have been tested with at least some version of perl5 and are probably reasonably close to being correct: aix.sh bsd386.sh dec_osf.sh dgux.sh esix4.sh freebsd.sh hpux_9.sh irix_4.sh irix_5.sh isc.sh linux.sh netbsd.sh next_3_2.sh sco_3.sh solaris_2.sh sunos_4_1.sh svr4.sh titanos.sh ultrix_4.sh unicos.sh utekv.sh The following hints files have not been tested with perl5: 3b1.sh altos486.sh apollo.sh aux.sh dnix.sh dynix.sh fps.sh genix.sh greenhills.sh i386.sh isc_2.sh mips.sh mpc.sh ncr_tower.sh opus.sh sco_2_3_0.sh sco_2_3_1.sh sco_2_3_2.sh sco_2_3_3.sh sco_2_3_4.sh stellar.sh sunos_4_0.sh ti1500.sh unisysdynix.sh uts.sh 8< sunos_4_1.sh<H=svr4.sh\> ti1500.sh\p? titanos.shp„@ ultrix_4.sh˜A unicperl5.000/hints/aix.sh 664 203 12 1340 5645376153 7702 d_fchmod=undef d_setrgid='undef' d_setruid='undef' alignbytes=8 # Changes for dynamic linking by Wayne Scott (wscott@ichips.intel.com) # # Tell perl which symbols to export for dynamic linking. ccdlflags='-bE:perl.exp' # The first 3 options would not be needed if dynamic libs. could be linked # with the compiler instead of ld. # -bI:$(TOP)/perl.exp Read the exported symbols from the perl binary # -bE:$(EXT).exp Export these symbols. This file contains only one # symbol: boot_$(EXP) can it be auto-generated? lddlflags='-H512 -T512 -bhalt:4 -bM:SRE -bI:$(TOP)/perl.exp -bE:$(EXT).exp -e _nostart -lc' ccflags='-D_ALL_SOURCE' # Make setsockopt work correctly. See man page. # ccflags='-D_BSD=44'  sco_2_3_4.sh6Ü8sco_3.sh.shô9 solaris_2.shÜ: stellar.shh ; sunos_4_0.shh8< sunos_4_1.sh;H=svr4.sh\> ti1500.shr4p? titanos.shs„@ ultrix_4.sh˜A unicos.sh_4°Bunisysdyperl5.000/hints/altos486.sh 644 203 12 157 5240620631 10450 : have heard of problems with -lc_s on Altos 486 set `echo " $libswanted " | sed "s/ c_s / /"` libswanted="$*" .shÀÐdgux.shàdnix.shôdynix.shôesix4.shfps.shh, freebsd.sh,@genix.sh@X greenhills.shl hpux_9.shl|i386.sh irix_4.sh¤ irix_5.sh¤´isc.shsÈ#isc_2.shÈÜ$linux.shÜì%mips.sh&mpc.sh' perl5.000/hints/apollo.sh 664 203 12 1365 5614655625 10416 optimize='' ccflags='-A cpu,mathchip -W0,-opt,2' cat <<'EOF' Some tests may fail unless you use 'chacl -B'. Also, op/stat test 2 may fail occasionally because Apollo doesn't guarantee that mtime will be equal to ctime on a newly created unmodified file. Finally, the sleep test will sometimes fail. See the sleep(3) man page to learn why. And a note on ccflags: Lastly, while -A cpu,mathchip generates optimal code for your DN3500 running sr10.3, be aware that you should be using -A cpu,mathlib_sr10 if your perl must also run on any machines running sr10.0, sr10.1, or sr10.2. The -A cpu,mathchip option generates code that doesn't work on pre-sr10.3 nodes. See the cc(1) man page for more details. -- Steve Vinoski EOF .shô: stellar.sh9 ; sunos_4_0.sh 8< sunos_4_1.sh8H=svr4.sh\> ti1500.shhp? titanos.sh\„@ ultrix_4.sh˜A unicos.shh°Bunisysdynix.sh°ÄCutekv.shhBDperl5.000/hints/aux.sh 644 203 12 170 5614655625 7674 optimize='-O' ccflags="$ccflags -B/usr/lib/big/ -DPARAM_NEEDS_TYPES" POSIX_cflags='ccflags="$ccflags -ZP -Du_long=U32"' dynix.shshesix4.shshfps.shh, freebsd.shh@genix.shhhX greenhills.shXl hpux_9.shX|i386.sh irix_4.shh¤ irix_5.shh´isc.shsÈ#isc_2.shhsÜ$linux.shhsì%mips.sh&mpc.shs' ncr_tower.sh,( netbsd.sh@)perl5.000/hints/bsd386.sh 664 203 12 1733 5645376767 10153 # hints file for BSD/386 1.x # Original by Neil Bowers # Tue Oct 4 12:01:34 EDT 1994 # # filename extension for shared libraries so='o' d_voidsig='define' sig_name='ZERO HUP INT QUIT ILL TRAP IOT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM URG STOP TSTP CONT CHLD TTIN TTOU IO XCPU XFSZ VTALRM PROF WINCH INFO USR1 USR2 ' signal_t='void' # we don't want to use -lnm, since exp() is busted in there (in 1.1 anyway) set `echo X "$libswanted "| sed -e 's/ nm / /'` shift libswanted="$*" # Avoid telldir prototype conflict in pp_sys.c (BSD/386 uses const DIR *) pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"' # Avoid problems with HUGE_VAL in POSIX in 1.0's cc. # Use gcc2 (2.5.8) if available in 1.1. case "$osvers" in 1.0*) POSIX_cflags='ccflags="$ccflags -UHUGE_VAL"' ;; 1.1*) case "$cc" in '') cc=gcc2 ;; esac ;; esac # BSD/386 has an older header file. DB_File_cflags='ccflags="$ccflags -DDBXS_HASH_TYPE=int -DDBXS_PREFIX_TYPE=int"' °Duts.shhhBDperl5.000/hints/dec_osf.sh 664 203 12 454 5645373462 10510 # hints/dec_osf.sh optimize="-g" ccflags="$ccflags -DSTANDARD_C -DDEBUGGING" # Version 1 has problems with -no_archive if only an archive # lib is available. case "$osvers" in 1*) lddlflags='-shared -expect_unresolved "*" -s' ;; *) lddlflags='-shared -no_archive -expect_unresolved "*" -s' ;; esac ´isc.shsÈ#isc_2.shhÜ$linux.shÈì%mips.sh&mpc.shs' ncr_tower.sh,( netbsd.sh'@) next_3_2.shP*opus.shh+perl5.000/hints/dgux.sh 644 203 12 1072 5645373462 10070 # # hints file for Data General DG/UX # these hints tweaked for perl5 on an AViiON mc88100, running DG/UX 5.4R2.01 # gidtype='gid_t' groupstype='gid_t' libswanted="dgc $libswanted" uidtype='uid_t' d_index='define' ccflags='-D_POSIX_SOURCE -D_DGUX_SOURCE' # this hasn't been tried with dynamic loading at all usedl='false' # # an ugly hack, since the Configure test for "gcc -P -" hangs. # can't just use 'cppstdin', since our DG has a broken cppstdin :-( # cppstdin=`cd ..; pwd`/cppstdin cpprun=`cd ..; pwd`/cppstdin # # you don't want to use /usr/ucb/cc # cc='gcc' 6 sco_2_3_3.sh°È7 sco_2_3_4.shÈÜ8sco_3.shÈô9 solaris_2.shô: stellar.shô ; sunos_4_0.sh 8< sunos_4_1.sh8H=svr4.sh\> ti1500.shhp? titanos.sh„@ ultrix_4.sh˜A unicos.shh°Bunisysdynix.sh°ÄCutekv.shh°Duts.shhhBDuts.shhDBXS_PREFIX_TYPE=int"' °Duts.shhhBDperl5.000/hints/dnix.sh 644 203 12 16 5240620646 10006 optimize='-g' ix.shôdynix.shôesix4.shfps.sh, freebsd.sh,@genix.sh@X greenhills.shl hpux_9.shl|i386.sh irix_4.sh¤ irix_5.sh¤´isc.shÈ#isc_2.shÈÜ$linux.shÜì%mips.sh&mpc.sh' ncr_tower.sh',( netbsd.sh,@) next_3_2.shP*opus.shh+ sco_2_3_0.sh+€- sco_2_3_1.shperl5.000/hints/dynix.sh 644 203 12 120 5645376770 10232 d_castneg=undef libswanted=`echo $libswanted | sed -e 's/socket /socket seq /'` freebsd.sh,@genix.sh@X greenhills.shl hpux_9.shl|i386.sh irix_4.sh¤ irix_5.sh¤´isc.sh¤È#isc_2.shÈÜ$linux.shÜì%mips.sh&mpc.sh' ncr_tower.sh',( netbsd.sh,@) next_3_2.shP*opus.shh+ sco_2_3_0.sh+€- sco_2_3_1.sh-˜/ sco_perl5.000/hints/esix4.sh 664 203 12 2075 5645376770 10170 # hints/esix4.sh # Original esix4 hint file courtesy of # Kevin O'Gorman ( kevin@kosman.UUCP, kevin%kosman.uucp@nrc.com ) # # Use Configure -Dcc=gcc to use gcc. case "$cc" in '') cc='/bin/cc' test -f $cc || cc='/usr/ccs/bin/cc' cccdlflags='-Kpic' ;; esac ldflags='-L/usr/ccs/lib -L/usr/ucblib' test -d /usr/local/man || mansrc='none' ccflags='-I/usr/include -I/usr/ucbinclude' libswanted=`echo " $libswanted " | sed -e 's/ malloc / /' ` d_index='undef' d_suidsafe=define lddlflags="-G $ldflags" usevfork='false' if test "$osvers" = "3.0"; then d_gconvert='undef' grep 'define[ ]*AF_OSI[ ]' /usr/include/sys/socket.h | grep '/\*[^*]*$' >/tmp/esix$$ if test -s /tmp/esix$$; then cat < # Date: Thu, 28 Jul 1994 19:17:05 -0500 (CDT) # # Additional 1.1.5 defines from # Ollivier Robert # Date: Wed, 28 Sep 1994 00:37:46 +0100 (MET) # case "$osvers" in 0.*|1.0*) usedl="$undef" ;; *) d_dlopen="$define" cccdlflags='-DPIC -fpic' lddlflags='-Bshareable' malloctype='void *' groupstype='int' d_setregid='undef' d_setreuid='undef' d_setrgid='undef' d_setruid='undef' i_unistd='undef' ;; esac # Avoid telldir prototype conflict in pp_sys.c (FreeBSD uses const DIR *) pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"' # FreeBSD has an older header file. DB_File_cflags='ccflags="$ccflags -DDBXS_HASH_TYPE=int -DDBXS_PREFIX_TYPE=int"' ynix.shBÄCutekv.shÄDuts.sh°Duts.shhde/sys/socket.h. EOM fi rm -f /tmp/esix$$ fi # dlopen routines exist but they don't work with perl. # The case statement allows experimenters to override hint with # Conperl5.000/hints/genix.sh 644 203 12 20 5240620654 10150 i_varargs=undef x.shh,X greenhills.shXl hpux_9.sh|i386.sh irix_4.shh¤ irix_5.sh´isc.shsÈ#isc_2.shhÜ$linux.shÈì%mips.sh&mpc.shs' ncr_tower.sh,( netbsd.sh'@) next_3_2.shP*opus.shh+ sco_2_3_0.shh€- sco_2_3_1.sh€˜/ sco_2_3_2.sh˜°6 sco_2_3_3.sh°È7 sco_2_3_4.shÈÜ8sco_3.sh7perl5.000/hints/greenhills.sh 644 203 12 30 5240620656 11175 ccflags="$ccflags -X18" hXl hpux_9.shX|i386.sh irix_4.shh¤ irix_5.shh´isc.shsÈ#isc_2.shhsÜ$linux.shhì%mips.sh&mpc.shs' ncr_tower.sh,( netbsd.sh@) next_3_2.shP*opus.shh+ sco_2_3_0.shh€- sco_2_3_1.sh€˜/ sco_2_3_2.sh˜°6 sco_2_3_3.sh°È7 sco_2_3_4.shÈÜ8sco_3.shÈô9 solaris_2.shperl5.000/hints/hpux_9.sh 664 203 12 420 5645374704 10313 libswanted='ndbm m dld' ccflags="$ccflags -Aa -D_POSIX_SOURCE -D_HPUX_SOURCE" # ldflags="-Wl,-E -Wl,-a,shared" # Force all shared? ldflags="-Wl,-E" optimize='+O1' usemymalloc='y' alignbytes=8 selecttype='int *' POSIX_cflags='ccflags="$ccflags -DFLT_MIN=1.17549435E-38"' .shP*opus.shh+ sco_2_3_0.shsh€- sco_2_3_1.shh˜/ sco_2_3_2.sh€°6 sco_2_3_3.sh˜È7 sco_2_3_4.sh°Ü8sco_3.sh.shô9 solaris_2.shÈ: stellar.shhperl5.000/hints/i386.sh 644 203 12 30 5240620672 7530 ldflags='-L/usr/ucblib'  irix_4.shh¤ irix_5.sh86´isc.shsÈ#isc_2.shhxÜ$linux.shsc.ì%mips.sh&mpc.shs' ncr_tower.sh,( netbsd.shs@) next_3_2.shP*opus.shh+ sco_2_3_0.shh€- sco_2_3_1.sh€˜/ sco_2_3_2.sh˜°6 sco_2_3_3.sh°È7 sco_2_3_4.shÈÜ8sco_3.sh°ô9 solaris_2.shô: stellar.shÈ ; sunos_4_0.shperl5.000/hints/irix_4.sh 664 203 12 155 5645373463 10303 optimize='-O1' usemymalloc='y' d_voidsig=define usevfork=false d_charsprf=undef ccflags="-ansiposix -signed" .shÜì%mips.sh&mpc.sh' ncr_tower.sh',( netbsd.sh,@) next_3_2.shP*opus.shh+ sco_2_3_0.sh+€- sco_2_3_1.sh-˜/ sco_2_3_2.sh/°6 sco_2_3_3.sh6È7 sco_2_3_4.sh7Ü8sco_3.shÜô9 solaris_2.sh9: stellar.sh ; sunos_4_0.sh;8< sunoperl5.000/hints/irix_5.sh 664 203 12 407 5645374704 10303 # irix_5.sh i_time='define' ccflags="$ccflags -D_POSIX_SOURCE -ansiposix -D_BSD_TYPES -Olimit 3000" lddlflags="-shared" case "$usedl" in '') usedl='y' ;; esac set `echo X "$libswanted "|sed -e 's/ socket / /' -e 's/ nsl / /' -e 's/ dl / /'` shift libswanted="$*" - sco_2_3_1.sh€˜/ sco_2_3_2.sh˜°6 sco_2_3_3.sh°È7 sco_2_3_4.shÈÜ8sco_3.sh7ô9 solaris_2.shô: stellar.sh9 ; sunos_4_0.sh 8< sunos_4_1.sh8H=perl5.000/hints/isc.sh 664 203 12 1000 5645376771 7676 # isc.sh # Interactive Unix Versions 3 and 4. # Compile perl entirely in posix mode. # Andy Dougherty doughera@lafcol.lafayette.edu # Wed Oct 5 15:57:37 EDT 1994 # # Use Configure -Dcc=gcc to use gcc # set `echo X "$libswanted "| sed -e 's/ c / /'` shift libswanted="$*" case "$cc" in *gcc*) ccflags="$ccflags -posix" ldflags="$ldflags -posix" ;; *) ccflags="$ccflags -Xp -D_POSIX_SOURCE" ldflags="$ldflags -Xp" ;; esac # Pick up dbm.h in ccflags="$ccflags -I/usr/include/rpcsvc" perl5.000/hints/isc_2.sh 664 203 12 1211 5645376771 10123 # isc_2.sh # Interactive Unix Version 2.2 # Compile perl entirely in posix mode. # Andy Dougherty doughera@lafcol.lafayette.edu # Wed Oct 5 15:57:37 EDT 1994 # # Use Configure -Dcc=gcc to use gcc # set `echo X "$libswanted "| sed -e 's/ c / /'` shift libswanted="$*" case "$cc" in *gcc*) ccflags="$ccflags -posix" ldflags="$ldflags -posix" ;; *) ccflags="$ccflags -Xp -D_POSIX_SOURCE" ldflags="$ldflags -Xp" ;; esac # Pick up dbm.h in ccflags="$ccflags -I/usr/include/rpcsvc" # Compensate for conflicts in doio_cflags='ccflags="$ccflags -DENOTSOCK=103"' pp_sys_cflags='ccflags="$ccflags -DENOTSOCK=103"' Duts.shhhBDuts.shhÄDuts.shDuts.shhix.Duts.shkv.shh°Duts.shhhBDuts.shhÄDuts.sh°Duts.shhde/sys/socket.h. EOM fi rm -f /tmp/esix$$ fi # dlopen routines exist but they don't work with perl. # The case statement allows experimenters to override hint with # Conperl5.000/hints/linux.sh 664 203 12 1641 5645374705 10265 # Configuration time: Mon May 16 03:41:24 EDT 1994 # Original version by rsanders # Additional dlext support by Kenneth Albanowski # Target system: linux hrothgar 1.1.12 #9 sat may 14 02:03:23 edt 1994 i486 bin='/usr/bin' ccflags='-I/usr/include/bsd' cppflags=' -I/usr/include/bsd' d_dosuid='define' d_voidsig='define' gidtype='gid_t' groupstype='gid_t' malloctype='void *' nm_opt='' optimize='-O2' sig_name='ZERO HUP INT QUIT ILL TRAP IOT UNUSED FPE KILL USR1 SEGV USR2 PIPE ALRM TERM STKFLT CHLD CONT STOP TSTP TTIN TTOU IO XCPU XFSZ VTALRM PROF WINCH' signal_t='void' uidtype='uid_t' usemymalloc='n' yacc='bison -y' lddlflags='-r' so='sa' dlext='o' ## If you are using DLD 3.2.4 which does not support shared libs, ## uncomment the next two lines: #ldflags="-static" #so='none' cat < ti1500.shhp? titanos.sh„@ ultrix_4.sh˜A perl5.000/hints/mpc.sh 644 203 12 30 5240620702 7610 ccflags="$ccflags -X18" ' ncr_tower.sh',( netbsd.sh,@) next_3_2.shP*opus.shh+ sco_2_3_0.sh+€- sco_2_3_1.sh-˜/ sco_2_3_2.sh/°6 sco_2_3_3.sh6È7 sco_2_3_4.sh7Ü8sco_3.shÜô9 solaris_2.sh9: stellar.sh ; sunos_4_0.sh;8< sunos_4_1.sh<H=svr4.sh\> ti1500.sh\p? titanos.shp„@ ultrix_4.sh˜A unicos.sh˜°Bperl5.000/hints/ncr_tower.sh 644 203 12 116 5576427127 11102 optimize='-O0' ccflags="$ccflags -W2,-Sl,2000" d_mkdir=$undef usemymalloc='y' P*opus.shh+ sco_2_3_0.sh+€- sco_2_3_1.sh-˜/ sco_2_3_2.sh/°6 sco_2_3_3.sh6È7 sco_2_3_4.sh7Ü8sco_3.shÜô9 solaris_2.sh9: stellar.sh ; sunos_4_0.sh;8< sunos_4_1.sh<H=svr4.sh\> ti1500.sh\p? titanos.shp„@ ultrix_4.sh˜A unicos.sh˜°Bunisysdynix.shBperl5.000/hints/netbsd.sh 664 203 12 242 5645374705 10361 # hints/netbsd.sh case "$osvers" in 0.9|0.8) usedl="$undef" ;; *) d_dlopen="$define" cccdlflags='-DPIC -fpic' lddlflags='-Bforcearchive -Bshareable' ;; esac sco_2_3_3.sh/È7 sco_2_3_4.sh6Ü8sco_3.sh.shô9 solaris_2.shÜ: stellar.shh ; sunos_4_0.shh8< sunos_4_1.sh;H=svr4.sh\> ti1500.shr4p? titanos.shs„@ ultrix_4.sh˜A unicos.sh_4°Bunisysdynix.sh˜ÄCutekv.shix.perl5.000/hints/next_3_2.sh 664 203 12 640 5647030703 10512 ccflags='-D_POSIX_SOURCE -DUSE_NEXT_CTYPE' ldflags='-u libsys_s' libswanted='dbm gdbm db' lddlflags='-r' i_utime='undef' groupstype='int' direntrytype='struct direct' d_strcoll='undef' # the simple program `for ($i=1;$i<38771;$i++){$t{$i}=123}' fails # with Larry's malloc on NS 3.2 due to broken sbrk() usemymalloc='n' d_uname='define' d_setpgid='define' d_setsid='define' d_tcgetpgrp='define' d_tcsetpgrp='define'  unicos.shh°Bunisysdynix.sh°ÄCutekv.shh˜Duts.shhix.perl5.000/hints/opus.sh 644 203 12 30 5240620710 10016 ccflags="$ccflags -X18" + sco_2_3_0.shh€- sco_2_3_1.sh€˜/ sco_2_3_2.sh˜°6 sco_2_3_3.sh°È7 sco_2_3_4.shÈÜ8sco_3.shÈô9 solaris_2.shô: stellar.shô ; sunos_4_0.sh 8< sunos_4_1.sh8H=svr4.sh\> ti1500.shhp? titanos.sh„@ ultrix_4.sh˜A unicos.shh°Bunisysdynix.sh°ÄCutekv.shh°Duts.shhh˜Duts.shhix.perl5.000/hints/sco_2_3_0.sh 644 203 12 55 5240620713 10510 yacc='/usr/bin/yacc -Sm25000' i_dirent=undef _3_1.sh-˜/ sco_2_3_2.sh/°6 sco_2_3_3.sh6È7 sco_2_3_4.sh7Ü8sco_3.shÜô9 solaris_2.sh9: stellar.sh ; sunos_4_0.sh;8< sunos_4_1.sh<H=svr4.sh\> ti1500.sh\p? titanos.shp„@ ultrix_4.sh˜A unicos.sh˜°Bunisysdynix.shBÄCutekv.shÄDuts.sh°Duts.shhh˜Duts.shhix.perl5.000/hints/sco_2_3_1.sh 644 203 12 55 5240620715 10513 yacc='/usr/bin/yacc -Sm25000' i_dirent=undef _3_2.sh-°6 sco_2_3_3.sh/È7 sco_2_3_4.sh6Ü8sco_3.sh.shô9 solaris_2.shÜ: stellar.shh ; sunos_4_0.shh8< sunos_4_1.sh;H=svr4.sh\> ti1500.shr4p? titanos.shs„@ ultrix_4.sh˜A unicos.sh_4°Bunisysdynix.sh˜ÄCutekv.shix.Duts.shkv.shÄDuts.sh°Duts.shhh˜Duts.shhix.perl5.000/hints/sco_2_3_2.sh 644 203 12 120 5645376772 10551 yacc='/usr/bin/yacc -Sm25000' libswanted=`echo " $libswanted "| sed 's/ x / /'` /Ü8sco_3.sh.shô9 solaris_2.sh.sh: stellar.shh ; sunos_4_0.shhh8< sunos_4_1.shhH=svr4.sh\> ti1500.shr4p? titanos.shs„@ ultrix_4.sh˜A unicos.sh_4°Bunisysdynix.sh4ÄCutekv.shix.Duts.shkv.shix.Duts.shkv.shÄDuts.sh°Duts.shhh˜Duts.shhix.perl5.000/hints/sco_2_3_3.sh 644 203 12 277 5240620720 10537 yacc='/usr/bin/yacc -Sm25000' echo "NOTE: you may have problems due to a spurious semicolon on the strerror()" echo "macro definition in /usr/include/string.h. If so, delete the semicolon." H=svr4.sh\> ti1500.shr4p? titanos.shs„@ ultrix_4.sh˜A unicos.sh_4°Bunisysdynix.sh4ÄCutekv.shix.Duts.shkv.shix.Duts.shkv.shix.Duts.shkv.shÄDuts.sh°Duts.shhh˜Duts.shhix.perl5.000/hints/sco_2_3_4.sh 644 203 12 352 5633716446 10553 yacc='/usr/bin/yacc -Sm25000' ccflags="$ccflags -UM_I86" usemymalloc='y' echo "NOTE: you may have problems due to a spurious semicolon on the strerror()" echo "macro definition in /usr/include/string.h. If so, delete the semicolon." @ ultrix_4.sh˜A unicos.sh_4°Bunisysdynix.sh4ÄCutekv.shix.Duts.shkv.shix.Duts.shkv.shix.Duts.shkv.shix.Duts.shkv.shÄDuts.sh°Duts.shhh˜Duts.shhix.perl5.000/hints/sco_3.sh 644 203 12 1266 5645373463 10135 # sco_3.sh # Courtesy of Joel Rosi-Schwartz # To use gcc, do Configure -Dcc=gcc # # Try to use libintl.a since it has strcoll and strxfrm libswanted="intl $libswanted" # Try to use libdbm.nfs.a since it has dbmclose. # if test -f /usr/lib/libdbm.nfs.a ; then libswanted=`echo "dbm.nfs $libswanted " | sed -e 's/ dbm / /'` fi set X $libswanted shift libswanted="$*" # # We don't want Xenix cross-development libraries glibpth=`echo $glibpth | sed -e 's! /usr/lib/386 ! !' -e 's! /lib/386 ! !'` xlibpth='' # case "$cc" in gcc) ccflags="$ccflags -U M_XENIX" optimize="$optimize -O2" ;; *) ccflags="$ccflags -W0 -U M_XENIX" ;; esac i_varargs=undef nm_opt='-p' DLD 3.2.4 which does not support shared libs, ## uncomment the next two lines: #ldflags="-static" #so='none' cat <&4;; *) ;; esac case $PATH in */usr/ucb*:/usr/bin:*) cat < ti1500.shr4p? titanos.shs„@ ultrix_4.sh˜A unicos.sh_4°Bunisysdynix.shÄCutekv.shix.Duts.shkchlib and also warn about possible -x486 flags needed. case "$archname" in '') if test -f /usr/bin/arch; then archname=`/usr/bin/arch` archname="${archname}-${osname}" elif test -f /usr/ucb/arch; then archname=`/usrperl5.000/hints/sunos_4_0.sh 664 203 12 41 5614655442 10664 ccflags="$ccflags -DFPUTS_BOTCH" < sunos_4_1.sh8H=svr4.sh\> ti1500.shhp? titanos.sh4„@ ultrix_4.sh˜A unicos.shh°Bunisysdynix.sh°ÄCutekv.shhDuts.shhix.Duts.shkchlib and also warn about possible -x486 flags needed. case "$archname" in '') if test -f /usr/bin/arch; then archname=`/usr/bin/arch` archname="${archname}-${osname}" elif test -f /usr/ucb/arch; then archname=`/usrperl5.000/hints/sunos_4_1.sh 664 203 12 571 5625472650 10715 case "$cc" in *gcc*) usevfork=false ;; *) usevfork=true ;; esac d_tzname='undef' # check if user is in a bsd or system 5 type environment if cat -b /dev/null 2>/dev/null then # bsd groupstype='int' else # sys5 groupstype='gid_t' fi # we don't set gidtype because unistd.h says gid_t getgid() but man # page says int getgid() for bsd. utils.c includes unistd.h :-( then archname=`/usr/bin/arch` archname="${archname}-${osname}" elif test -f /usr/ucb/arch; then archname=`/usrperl5.000/hints/svr4.sh 644 203 12 2655 5645376772 10036 # svr4 hints, System V Release 4.x # Use Configure -Dcc=gcc to use gcc. case "$cc" in '') cc='/bin/cc' test -f $cc || cc='/usr/ccs/bin/cc' cccdlflags='-Kpic' # Probably needed for dynamic loading ;; esac test -d /usr/local/man || mansrc='none' # We include support for using libraries in /usr/ucblib, but the setting # of libswanted excludes some libraries found there. You may want to # prevent "ucb" from being removed from libswanted and see if perl will # build on your system. ldflags='-L/usr/ccs/lib -L/usr/ucblib' ccflags='-I/usr/include -I/usr/ucbinclude' libswanted=`echo $libswanted | tr ' ' '\012' | egrep -v '^(malloc|ucb)$'` # -lucb: Defines setreuid() and other routines Perl wants but they don't # add any/much functionality and often won't ld properly. # -lmalloc: Anyone know what problems this caused? if [ "" = "$i_ndbm" -a ! -f /usr/ucblib/libndbm.a ]; then # UnixWare 1.1 may install /usr/ucbinclude/ndbm.h w/o /usr/ucblib/libndbm.a i_ndbm="$undef" # so Configure tries to build ext/NDBM_File and ld fi # can't find dbm_open()! "./Configure -D i_ndbm=define" overrides. d_index='undef' d_suidsafe=define # "./Configure -d" can't figure this out lddlflags="-G $ldflags" # Probably needed for dynamic loading usevfork='false' # dlopen routines exist but they don't work with perl. # The case statement allows experimenters to override hint with # Configure -D usedl case "$usedl" in '') usedl="$undef" ;; esac CMD $FLAGS $INCL $LPATHS $LIBS $COBJS $CFLAG $TARG" elif [ -n "$LOBJS" ] then LOBJperl5.000/hints/ti1500.sh 644 203 12 20 5576427133 7771 usemymalloc='n' 00.sh\p? titanos.shp„@ ultrix_4.sh˜A unicos.sh˜°Bunisysdynix.shBÄCutekv.shÄDuts.sh.Probably needed for dynamic loading ;; esac test -d /usr/local/man || mansrc='none' # We include support for using libraries in /usr/ucblib, but the setting # of libswanted excludes some libraries found there. You may want to # prevent "ucb" from being removed from libswanted and see if perl will # build on your system. ldflags='-L/usr/cperl5.000/hints/titanos.sh 664 203 12 1474 5645373464 10614 # Hints file (perl 4.019) for Kubota Pacific's Titan 3000 Series Machines. # Created by: JT McDuffie (jt@kpc.com) 26 DEC 1991 # p5ed by: Jarkko Hietaniemi Aug 27 1994 # NOTE: You should run Configure with tcsh (yes, tcsh). alignbytes="8" byteorder="4321" castflags='0' gidtype='ushort' groupstype='unsigned short' intsize='4' usenm='true' nm_opt='-eh' malloctype='void *' models='none' ccflags="$ccflags -I/usr/include/net -DDEBUGGING -DSTANDARD_C" cppflags="$cppflags -I/usr/include/net -DDEBUGGING -DSTANDARD_C" libs='-lnsl -ldbm -lPW -lmalloc -lm' stdchar='unsigned char' static_ext='DynaLoader NDBM_File Socket' uidtype='ushort' voidflags='7' inclwanted='/usr/include /usr/include/net' libpth='/usr/lib /usr/local/lib /lib' pth='. /bin /usr/bin /usr/ucb /usr/local/bin /usr/X11/bin /usr/lbin /etc /usr/lib' used? if [ "" = "$i_ndbm" -a ! -f /usr/ucblib/libndbm.a ]; then # UnixWare 1.1 may install /usr/ucbinclude/ndbm.h w/o /usr/ucblib/libndbm.a i_ndbm="$undef" # so Configure tries to build experl5.000/hints/ultrix_4.sh 644 203 12 1131 5645376773 10677 optimize=-g tmp=`(uname -a) 2>/dev/null` case "$tmp" in *RISC*) cat < 4 Oct. 1994 # The -X18 is only if you are using the Greenhills compiler. ccflags="$ccflags -X18" usemymalloc='y' # /usr/include/rpcsvc is for finding dbm.h inclwanted="$inclwanted /usr/include/rpcsvc" echo " " echo "NOTE: You may have to take out makefile dependencies on the files in" echo "/usr/include (i.e. /usr/include/ctype.h) or the make will fail. A" echo "simple 'grep -v /usr/include/ makefile' should suffice." nlib='ranlib' ;; esac groupstype='int' t='DynaLoader NDBM_File Socket' uidtype='ushort' voidflags='7' inclwanted='/usr/include /usr/include/net' libpth='/usr/lib /usr/local/lib /lib' pth='. /bin /usr/bin /usr/ucb /usr/local/bin /usr/X11/bin /usr/lbin /etc /usr/lib' used? if [ "" = "$i_ndbm" -a ! -f /usr/ucblib/libndbm.a ]; then # UnixWare 1.1 may install /usr/ucbinclude/ndbm.h w/o /usr/ucblib/libndbm.a i_ndbm="$undef" # so Configure tries to build experl5.000/hints/uts.sh 644 203 12 60 5240620752 7654 ccflags="$ccflags -DCRIPPLED_CC" d_lstat=define .rutgers.edu) 2/11/92 # Modified by Andy Dougherty 4 Oct. 1994 # The -X18 is only if you are using the Greenhills compiler. ccflags="$ccflags -X18" usemymalloc='y' # /usr/include/rpcsvc is for finding dbm.h inclwanted="$inclwanted /usr/include/rpcsvc" echo " " echo "NOTE: You may have to take out makefile dependencies on the files in" echo "/usr/include (i.e. /usr/include/ctype.h) or the make will fail. A" echo "simple 'perl5.000/hv.c 644 203 12 25074 5650573244 6245 /* hv.c * * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * "I sit beside the fire and think of all that I have seen." --Bilbo */ #include "EXTERN.h" #include "perl.h" static void hsplit _((HV *hv)); static void hfreeentries _((HV *hv)); SV** hv_fetch(hv,key,klen,lval) HV *hv; char *key; U32 klen; I32 lval; { register XPVHV* xhv; register char *s; register I32 i; register I32 hash; register HE *entry; SV *sv; if (!hv) return 0; if (SvRMAGICAL(hv)) { if (mg_find((SV*)hv,'P')) { sv = sv_newmortal(); mg_copy((SV*)hv, sv, key, klen); Sv = sv; return &Sv; } } xhv = (XPVHV*)SvANY(hv); if (!xhv->xhv_array) { if (lval #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */ || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) #endif ) Newz(503,xhv->xhv_array, sizeof(HE*) * (xhv->xhv_max + 1), char); else return 0; } i = klen; hash = 0; s = key; while (i--) hash = hash * 33 + *s++; entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; for (; entry; entry = entry->hent_next) { if (entry->hent_hash != hash) /* strings can't be equal */ continue; if (entry->hent_klen != klen) continue; if (bcmp(entry->hent_key,key,klen)) /* is this it? */ continue; return &entry->hent_val; } #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */ if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) { char *gotenv; gotenv = my_getenv(key); if (gotenv != NULL) { sv = newSVpv(gotenv,strlen(gotenv)); return hv_store(hv,key,klen,sv,hash); } } #endif if (lval) { /* gonna assign to this, so it better be there */ sv = NEWSV(61,0); return hv_store(hv,key,klen,sv,hash); } return 0; } SV** hv_store(hv,key,klen,val,hash) HV *hv; char *key; U32 klen; SV *val; register U32 hash; { register XPVHV* xhv; register char *s; register I32 i; register HE *entry; register HE **oentry; if (!hv) return 0; xhv = (XPVHV*)SvANY(hv); if (SvMAGICAL(hv)) { mg_copy((SV*)hv, val, key, klen); #ifndef OVERLOAD if (!xhv->xhv_array) return 0; #else if (!xhv->xhv_array && (SvMAGIC(hv)->mg_type != 'A' || SvMAGIC(hv)->mg_moremagic)) return 0; #endif /* OVERLOAD */ } if (!hash) { i = klen; s = key; while (i--) hash = hash * 33 + *s++; } if (!xhv->xhv_array) Newz(505, xhv->xhv_array, sizeof(HE**) * (xhv->xhv_max + 1), char); oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; i = 1; for (entry = *oentry; entry; i=0, entry = entry->hent_next) { if (entry->hent_hash != hash) /* strings can't be equal */ continue; if (entry->hent_klen != klen) continue; if (bcmp(entry->hent_key,key,klen)) /* is this it? */ continue; SvREFCNT_dec(entry->hent_val); entry->hent_val = val; return &entry->hent_val; } New(501,entry, 1, HE); entry->hent_klen = klen; entry->hent_key = savepvn(key,klen); entry->hent_val = val; entry->hent_hash = hash; entry->hent_next = *oentry; *oentry = entry; xhv->xhv_keys++; if (i) { /* initial entry? */ ++xhv->xhv_fill; if (xhv->xhv_keys > xhv->xhv_max) hsplit(hv); } return &entry->hent_val; } SV * hv_delete(hv,key,klen) HV *hv; char *key; U32 klen; { register XPVHV* xhv; register char *s; register I32 i; register I32 hash; register HE *entry; register HE **oentry; SV *sv; if (!hv) return Nullsv; if (SvRMAGICAL(hv)) { sv = *hv_fetch(hv, key, klen, TRUE); mg_clear(sv); if (mg_find(sv, 'p')) { sv_unmagic(sv, 'p'); /* No longer an element */ return sv; } } xhv = (XPVHV*)SvANY(hv); if (!xhv->xhv_array) return Nullsv; i = klen; hash = 0; s = key; while (i--) hash = hash * 33 + *s++; oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; entry = *oentry; i = 1; for (; entry; i=0, oentry = &entry->hent_next, entry = *oentry) { if (entry->hent_hash != hash) /* strings can't be equal */ continue; if (entry->hent_klen != klen) continue; if (bcmp(entry->hent_key,key,klen)) /* is this it? */ continue; *oentry = entry->hent_next; if (i && !*oentry) xhv->xhv_fill--; sv = sv_mortalcopy(entry->hent_val); if (entry == xhv->xhv_eiter) entry->hent_klen = -1; else he_free(entry); --xhv->xhv_keys; return sv; } return Nullsv; } bool hv_exists(hv,key,klen) HV *hv; char *key; U32 klen; { register XPVHV* xhv; register char *s; register I32 i; register I32 hash; register HE *entry; SV *sv; if (!hv) return 0; if (SvRMAGICAL(hv)) { if (mg_find((SV*)hv,'P')) { sv = sv_newmortal(); mg_copy((SV*)hv, sv, key, klen); magic_existspack(sv, mg_find(sv, 'p')); return SvTRUE(sv); } } xhv = (XPVHV*)SvANY(hv); if (!xhv->xhv_array) return 0; i = klen; hash = 0; s = key; while (i--) hash = hash * 33 + *s++; entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; for (; entry; entry = entry->hent_next) { if (entry->hent_hash != hash) /* strings can't be equal */ continue; if (entry->hent_klen != klen) continue; if (bcmp(entry->hent_key,key,klen)) /* is this it? */ continue; return TRUE; } return FALSE; } static void hsplit(hv) HV *hv; { register XPVHV* xhv = (XPVHV*)SvANY(hv); I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */ register I32 newsize = oldsize * 2; register I32 i; register HE **a; register HE **b; register HE *entry; register HE **oentry; a = (HE**)xhv->xhv_array; nomemok = TRUE; Renew(a, newsize, HE*); nomemok = FALSE; Zero(&a[oldsize], oldsize, HE*); /* zero 2nd half*/ xhv->xhv_max = --newsize; xhv->xhv_array = (char*)a; for (i=0; ihent_hash & newsize) != i) { *oentry = entry->hent_next; entry->hent_next = *b; if (!*b) xhv->xhv_fill++; *b = entry; continue; } else oentry = &entry->hent_next; } if (!*a) /* everything moved */ xhv->xhv_fill--; } } HV * newHV() { register HV *hv; register XPVHV* xhv; hv = (HV*)NEWSV(502,0); sv_upgrade((SV *)hv, SVt_PVHV); xhv = (XPVHV*)SvANY(hv); SvPOK_off(hv); SvNOK_off(hv); xhv->xhv_max = 7; /* start with 8 buckets */ xhv->xhv_fill = 0; xhv->xhv_pmroot = 0; (void)hv_iterinit(hv); /* so each() will start off right */ return hv; } void he_free(hent) register HE *hent; { if (!hent) return; SvREFCNT_dec(hent->hent_val); Safefree(hent->hent_key); Safefree(hent); } void he_delayfree(hent) register HE *hent; { if (!hent) return; sv_2mortal(hent->hent_val); /* free between statements */ Safefree(hent->hent_key); Safefree(hent); } void hv_clear(hv) HV *hv; { register XPVHV* xhv; if (!hv) return; xhv = (XPVHV*)SvANY(hv); hfreeentries(hv); xhv->xhv_fill = 0; xhv->xhv_keys = 0; if (xhv->xhv_array) (void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*)); if (SvRMAGICAL(hv)) mg_clear((SV*)hv); } static void hfreeentries(hv) HV *hv; { register HE **array; register HE *hent; register HE *ohent = Null(HE*); I32 riter; I32 max; if (!hv) return; if (!HvARRAY(hv)) return; riter = 0; max = HvMAX(hv); array = HvARRAY(hv); hent = array[0]; for (;;) { if (hent) { ohent = hent; hent = hent->hent_next; he_free(ohent); } if (!hent) { if (++riter > max) break; hent = array[riter]; } } (void)hv_iterinit(hv); } void hv_undef(hv) HV *hv; { register XPVHV* xhv; if (!hv) return; xhv = (XPVHV*)SvANY(hv); hfreeentries(hv); Safefree(xhv->xhv_array); if (HvNAME(hv)) { Safefree(HvNAME(hv)); HvNAME(hv) = 0; } xhv->xhv_array = 0; xhv->xhv_max = 7; /* it's a normal associative array */ xhv->xhv_fill = 0; xhv->xhv_keys = 0; if (SvRMAGICAL(hv)) mg_clear((SV*)hv); } I32 hv_iterinit(hv) HV *hv; { register XPVHV* xhv = (XPVHV*)SvANY(hv); HE *entry = xhv->xhv_eiter; if (entry && entry->hent_klen < 0) /* was deleted earlier? */ he_free(entry); xhv->xhv_riter = -1; xhv->xhv_eiter = Null(HE*); return xhv->xhv_fill; } HE * hv_iternext(hv) HV *hv; { register XPVHV* xhv; register HE *entry; HE *oldentry; MAGIC* mg; if (!hv) croak("Bad associative array"); xhv = (XPVHV*)SvANY(hv); oldentry = entry = xhv->xhv_eiter; if (SvRMAGICAL(hv) && (mg = mg_find((SV*)hv,'P'))) { SV *key = sv_newmortal(); if (entry) { sv_usepvn(key, entry->hent_key, entry->hent_klen); entry->hent_key = 0; } else { Newz(504,entry, 1, HE); xhv->xhv_eiter = entry; } magic_nextpack((SV*) hv,mg,key); if (SvOK(key)) { STRLEN len; entry->hent_key = SvPV_force(key, len); entry->hent_klen = len; SvPOK_off(key); SvPVX(key) = 0; return entry; } if (entry->hent_val) SvREFCNT_dec(entry->hent_val); Safefree(entry); xhv->xhv_eiter = Null(HE*); return Null(HE*); } if (!xhv->xhv_array) Newz(506,xhv->xhv_array, sizeof(HE*) * (xhv->xhv_max + 1), char); do { if (entry) entry = entry->hent_next; if (!entry) { ++xhv->xhv_riter; if (xhv->xhv_riter > xhv->xhv_max) { xhv->xhv_riter = -1; break; } entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter]; } } while (!entry); if (oldentry && oldentry->hent_klen < 0) /* was deleted earlier? */ he_free(oldentry); xhv->xhv_eiter = entry; return entry; } char * hv_iterkey(entry,retlen) register HE *entry; I32 *retlen; { *retlen = entry->hent_klen; return entry->hent_key; } SV * hv_iterval(hv,entry) HV *hv; register HE *entry; { if (SvRMAGICAL(hv)) { if (mg_find((SV*)hv,'P')) { SV* sv = sv_newmortal(); mg_copy((SV*)hv, sv, entry->hent_key, entry->hent_klen); return sv; } } return entry->hent_val; } SV * hv_iternextsv(hv, key, retlen) HV *hv; char **key; I32 *retlen; { HE *he; if ( (he = hv_iternext(hv)) == NULL) return NULL; *key = hv_iterkey(he, retlen); return hv_iterval(hv, he); } void hv_magic(hv, gv, how) HV* hv; GV* gv; int how; { sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0); } f( ! $opt_a ){ print MF <<'END'; $(INSTALLPM): $(EXT).pm rm -f $@ cp $(EXT).pm $@ cd $(TOP); $(PERL) autosplit $(EXT) END } else { print MF <<'END'; $(INSTALLPM): $(EXT).pm cp $(EXT).pm $@ END } print MF <<'END'; clean: rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp realclean: clean rm -f makefile Makefile rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) rm -rf $(AUTO)/$(EXT) purge: realcleaperl5.000/hv.h 644 203 12 3546 5650573247 6235 /* hv.h * * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ typedef struct he HE; struct he { HE *hent_next; char *hent_key; SV *hent_val; U32 hent_hash; I32 hent_klen; }; struct xpvhv { char * xhv_array; /* pointer to malloced string */ STRLEN xhv_fill; /* how full xhv_array currently is */ STRLEN xhv_max; /* subscript of last element of xhv_array */ I32 xhv_keys; /* how many elements in the array */ double xnv_nv; /* numeric value, if any */ MAGIC* xmg_magic; /* magic for scalar array */ HV* xmg_stash; /* class package */ I32 xhv_riter; /* current root of iterator */ HE *xhv_eiter; /* current entry of iterator */ PMOP *xhv_pmroot; /* list of pm's for this package */ char *xhv_name; /* name, if a symbol table */ }; #define Nullhv Null(HV*) #define HvARRAY(hv) ((HE**)((XPVHV*) SvANY(hv))->xhv_array) #define HvFILL(hv) ((XPVHV*) SvANY(hv))->xhv_fill #define HvMAX(hv) ((XPVHV*) SvANY(hv))->xhv_max #define HvKEYS(hv) ((XPVHV*) SvANY(hv))->xhv_keys #define HvRITER(hv) ((XPVHV*) SvANY(hv))->xhv_riter #define HvEITER(hv) ((XPVHV*) SvANY(hv))->xhv_eiter #define HvPMROOT(hv) ((XPVHV*) SvANY(hv))->xhv_pmroot #define HvNAME(hv) ((XPVHV*) SvANY(hv))->xhv_name #ifdef OVERLOAD /* Maybe amagical: */ /* #define HV_AMAGICmb(hv) (SvFLAGS(hv) & (SVpgv_badAM | SVpgv_AM)) */ #define HV_AMAGIC(hv) (SvFLAGS(hv) & SVpgv_AM) #define HV_AMAGIC_on(hv) (SvFLAGS(hv) |= SVpgv_AM) #define HV_AMAGIC_off(hv) (SvFLAGS(hv) &= ~SVpgv_AM) /* #define HV_AMAGICbad(hv) (SvFLAGS(hv) & SVpgv_badAM) #define HV_badAMAGIC_on(hv) (SvFLAGS(hv) |= SVpgv_badAM) #define HV_badAMAGIC_off(hv) (SvFLAGS(hv) &= ~SVpgv_badAM) */ #endif /* OVERLOAD */ ist of pm's for this package */ char *xhv_name; /* name, if a symbol table */ }; #define Nullhv Null(HV*) #define HvARRAY(hv) ((HE**)((XPVHV*) SvANYperl5.000/installperl 755 203 12 17542 5645377005 7745 #!./perl BEGIN { @INC=('./lib', '../lib') } use File::Find; $mainperldir = "/usr/bin"; while (@ARGV) { $nonono = 1 if $ARGV[0] eq '-n'; $versiononly = 1 if $ARGV[0] eq '-v'; shift; } umask 022; @scripts = ('cppstdin', 'c2ph', 'pstruct', 'x2p/s2p', 'x2p/find2perl'); @manpages = (, 'x2p/a2p.man', 'x2p/s2p.man'); # Read in the config file. open(CONFIG, "config.sh") || die "You haven't run Configure yet!\n"; while () { if (s/^(\w+=)/\$$1/) { $accum =~ s/'undef'/undef/g; eval $accum; $accum = ''; } $accum .= $_; } close CONFIG; open(PERL_C, "perl.c"); while () { last if /Revision:/; } close PERL_C; s/.*Revision: //; $major = $_ + 0; $ver = sprintf("%5.3f", $major + $PATCHLEVEL / 1000); $release = substr($ver,0,3); $patchlevel = substr($ver,3,2); # Do some quick sanity checks. if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; } $installbin || die "No installbin directory in config.sh\n"; -d $installbin || die "$installbin is not a directory\n"; -w $installbin || die "$installbin is not writable by you\n" unless $installbin =~ m#^/afs/#; -x 'perl' || die "perl isn't executable!\n"; -x 'suidperl' || die "suidperl isn't executable!\n" if $d_dosuid; -x 't/TEST' || warn "WARNING: You've never run 'make test'!!!", " (Installing anyway.)\n"; # First we install the version-numbered executables. &unlink("$installbin/perl$ver"); &cmd("cp perl $installbin/perl$ver"); &unlink("$installbin/sperl$ver"); if ($d_dosuid) { &cmd("cp suidperl $installbin/sperl$ver"); &chmod(04711, "$installbin/sperl$ver"); } exit 0 if $versiononly; # Make links to ordinary names if installbin directory isn't current directory. ($bdev,$bino) = stat($installbin); ($ddev,$dino) = stat('.'); if ($bdev != $ddev || $bino != $dino) { &unlink("$installbin/perl", "$installbin/suidperl"); &link("$installbin/perl$ver", "$installbin/perl"); &link("$installbin/sperl$ver", "$installbin/suidperl") if $d_dosuid; } ($bdev,$bino) = stat($installbin); ($ddev,$dino) = stat('x2p'); if ($bdev != $ddev || $bino != $dino) { &unlink("$installbin/a2p"); &cmd("cp x2p/a2p $installbin/a2p"); &chmod(0755, "$installbin/a2p"); } # Install scripts. &makedir($installscript); for (@scripts) { if (-f $_) { # cppstdin might not exist on this system. &cmd("cp $_ $installscript"); s#.*/##; &chmod(0755, "$installscript/$_"); } } # Install man pages. if ($installmansrc ne '') { &makedir($installmansrc); ($mdev,$mino) = stat($installmansrc); if ($mdev != $ddev || $mino != $dino) { for (@manpages) { ($new = $_) =~ s/man$/$manext/; $new =~ s#.*/##; print STDERR " Installing $installmansrc/$new\n"; next if $nonono; open(MI,$_) || warn "Can't open $_: $!\n"; open(MO,">$installmansrc/$new") || warn "Can't install $installmansrc/$new: $!\n"; print MO ".ds RP Release $release Patchlevel $patchlevel\n"; while () { print MO; } close MI; close MO; } } } # Install library files. $do_installarchlib = $do_installprivlib = 0; &makedir($installprivlib); &makedir($installarchlib); if (chdir "lib") { ($pdev,$pino) = stat($installarchlib); ($ldev,$lino) = stat('.'); $do_installarchlib = ($pdev != $ldev || $pino != $lino); ($pdev,$pino) = stat($installprivlib); ($ldev,$lino) = stat('.'); $do_installprivlib = ($pdev != $ldev || $pino != $lino); if ($do_installarchlib || $do_installprivlib) { find(\&installlib, '.'); } chdir ".." || die "Can't cd back to source directory: $!\n"; } else { warn "Can't cd to lib to install lib files: $!\n"; } # Offer to install perl in a "standard" location ($udev,$uino) = stat($mainperldir); $mainperl_is_instperl = 0; if (-w _ && ($udev != $bdev || $uino != $bino) && !$nonono) { # First make sure $mainperldir/perl is not already the same as # the perl we just installed if (-x "$mainperldir/perl") { # Use stat so we detect symbolic links transparently ($mpdev, $mpino) = stat("$mainperldir/perl"); ($ipdev, $ipino) = stat("$installbin/perl"); # Try to be clever about mainperl being a symbolic link # to binexp/perl if binexp and installbin are different. $mainperl_is_instperl = (($mpdev == $ipdev && $mpino == $ipino) || (($binexp ne $installbin) && (-l "$mainperldir/perl") && ((readlink "$mainperldir/perl") eq "$binexp/perl"))); } if ((! $mainperl_is_instperl) && (&yn("Many scripts expect perl to be installed as " . "$mainperldir/perl.\n" . "Do you wish to have $mainperldir/perl be the same as\n" . "$binexp/perl? [y] "))) { unlink("$mainperldir/perl"); eval 'link("$installbin/perl", "$mainperldir/perl")' || eval 'symlink("$binexp/perl", "$mainperldir/perl")' || &cmd("cp $installbin/perl $mainperldir"); $mainperl_is_instperl = 1; } } # Check to make sure there aren't other perls around in installer's # path. This is probably UNIX-specific. Check all absolute directories # in the path except for where public executables are supposed to live. # Also skip $mainperl if the user opted to have it be a link to the # installed perl. @path = split(/:/, $ENV{"PATH"}); @otherperls = (); for (@path) { next unless m,^/,; next if ($_ eq $binexp); # Use &samepath here because some systems have other dirs linked # to $mainperldir (like SunOS) next if ($mainperl_is_instperl && &samepath($_, $mainperldir)); push(@otherperls, "$_/perl") if (-x "$_/perl" && ! -d "$_/perl"); } if (@otherperls) { print STDERR "\nWarning: perl appears in your path in the following " . "locations beyond where\nwe just installed it:\n"; for (@otherperls) { print STDERR " ", $_, "\n"; } print STDERR "\n"; } print STDERR " Installation complete\n"; exit 0; ############################################################################### sub yn { local($prompt) = @_; local($answer); local($default) = $prompt =~ m/\[([yn])\]\s*$/i; print STDERR $prompt; chop($answer = ); $answer = $default if $answer =~ m/^\s*$/; ($answer =~ m/^[yY]/); } sub unlink { local(@names) = @_; foreach $name (@names) { next unless -e $name; print STDERR " unlink $name\n"; unlink($name) || warn "Couldn't unlink $name: $!\n" unless $nonono; } } sub cmd { local($cmd) = @_; print STDERR " $cmd\n"; unless ($nonono) { system $cmd; warn "Command failed!!!\n" if $?; } } sub link { local($from,$to) = @_; print STDERR " ln $from $to\n"; link($from,$to) || warn "Couldn't link $from to $to: $!\n" unless $nonono; } sub chmod { local($mode,$name) = @_; printf STDERR " chmod %o %s\n", $mode, $name; chmod($mode,$name) || warn sprintf("Couldn't chmod %o %s: $!\n",$mode,$name) unless $nonono; } sub makedir { local($dir) = @_; unless (-d $dir) { local($shortdir) = $dir; $shortdir =~ s#(.*)/.*#$1#; &makedir($shortdir); print STDERR " mkdir $dir\n"; mkdir($dir, 0777) || warn "Couldn't create $dir: $!\n" unless $nonono; } } sub samepath { local($p1, $p2) = @_; local($dev1, $ino1, $dev2, $ino2); if ($p1 ne p2) { ($dev1, $ino1) = stat($p1); ($dev2, $ino2) = stat($p2); ($dev1 == $dev2 && $ino1 == $ino2); } else { 1; } } sub installlib { my $dir = $File::Find::dir; $dir =~ s#^\.(?![^/])/?##; my $name = $_; $name = "$dir/$name" if $dir ne ''; my $installlib = $installprivlib; if ((substr($dir, 0, 4) eq 'auto') || ($name eq 'Config.pm')) { $installlib = $installarchlib; return unless $do_installarchlib; } else { return unless $do_installprivlib; } &makedir("$installlib/$dir"); if (-f $_) { system "cmp", "-s", $_, "$installlib/$name"; if ($?) { &unlink("$installlib/$name"); &cmd("cp $_ $installlib/$dir"); &chmod(0644, "$installlib/$name"); } } elsif (-d $_) { &makedir("$installlib/$name"); } } e version-numbered executables. &unlink("$installbin/perl$ver"); &cmd("cp perl $installbin/perl$ver"); &unlink("$installbin/sperl$ver"); if ($d_dosuid) { perl5.000/interp.sym 644 203 12 2363 5621526730 7467 Argv Cmd DBgv DBline DBsignal DBsingle DBsub DBtrace allgvs ampergv argvgv argvoutgv basetime beginav bodytarget cddir chopset copline curblock curcop curcsv curpm curstash curstname cxstack cxstack_ix cxstack_max dbargs debdelim debname debstash debug defgv defoutgv defstash delaymagic dirty dlevel dlmax do_undump doextract doswitches dowarn dumplvl e_fp e_tmpname endav envgv eval_root eval_start fdpid filemode firstgv forkprocess formfeed formtarget gensym in_eval incgv inplace last_in_gv lastfd lastretstr lastscream lastsize lastspbase laststatval laststype leftgv lineary localizing main_root main_start mainstack maxscream maxsysfd minus_F minus_a minus_c minus_l minus_n minus_p multiline mystack_base mystack_mark mystack_max mystack_sp mystrk nrs nrschar nrslen ofmt ofs ofslen oldlastpm oldname origargc origargv origfilename ors orslen pad padname patchlevel perldb pidstatus preambled preprocess restartop rightgv rs rschar rslen rspara runlevel sawampersand sawi sawstudy sawvec screamfirst screamnext secondgv siggv signalstack sortcop sortstack sortstash splitstr stack statcache statgv statname statusvalue stdingv strchop sv_count sv_objcount sv_root sv_arenaroot tainted tainting tmps_floor tmps_ix tmps_max tmps_stack top_env toptarget unsafe ir"); &chmod(0644, "$installlib/$name"); } } elsif (-d $_) { &makedir("$installlib/$name"); } } e version-numbered executables. &unlink("$installbin/perl$ver"); &cmd("cp perl $installbin/perl$ver"); &unlink("$installbin/sperl$ver"); if ($d_dosuid) { perl5.000/ioctl.pl 644 203 12 7332 5240620760 7077 $TIOCGSIZE = 0x40087468; $TIOCSSIZE = 0x80087467; $IOCPARM_MASK = 0x1fff; $IOCPARM_MAX = 0x200; $IOC_VOID = 0x20000000; $IOC_OUT = 0x40000000; $IOC_IN = 0x80000000; $IOC_INOUT = 0xC0000000; $IOC_DIRMASK = 0xe0000000; $TIOCGETD = 0x40047400; $TIOCSETD = 0x80047401; $TIOCHPCL = 0x20007402; $TIOCMODG = 0x40047403; $TIOCMODS = 0x80047404; $TIOCM_LE = 0001; $TIOCM_DTR = 0002; $TIOCM_RTS = 0004; $TIOCM_ST = 0010; $TIOCM_SR = 0020; $TIOCM_CTS = 0040; $TIOCM_CAR = 0100; $TIOCM_CD = 0x40; $TIOCM_RNG = 0200; $TIOCM_RI = 0x80; $TIOCM_DSR = 0400; $TIOCGETP = 0x40067408; $TIOCSETP = 0x80067409; $TIOCSETN = 0x8006740A; $TIOCEXCL = 0x2000740D; $TIOCNXCL = 0x2000740E; $TIOCFLUSH = 0x80047410; $TIOCSETC = 0x80067411; $TIOCGETC = 0x40067412; $TANDEM = 0x00000001; $CBREAK = 0x00000002; $LCASE = 0x00000004; $ECHO = 0x00000008; $CRMOD = 0x00000010; $RAW = 0x00000020; $ODDP = 0x00000040; $EVENP = 0x00000080; $ANYP = 0x000000c0; $NLDELAY = 0x00000300; $NL0 = 0x00000000; $NL1 = 0x00000100; $NL2 = 0x00000200; $NL3 = 0x00000300; $TBDELAY = 0x00000c00; $TAB0 = 0x00000000; $TAB1 = 0x00000400; $TAB2 = 0x00000800; $XTABS = 0x00000c00; $CRDELAY = 0x00003000; $CR0 = 0x00000000; $CR1 = 0x00001000; $CR2 = 0x00002000; $CR3 = 0x00003000; $VTDELAY = 0x00004000; $FF0 = 0x00000000; $FF1 = 0x00004000; $BSDELAY = 0x00008000; $BS0 = 0x00000000; $BS1 = 0x00008000; $ALLDELAY = 0xFF00; $CRTBS = 0x00010000; $PRTERA = 0x00020000; $CRTERA = 0x00040000; $TILDE = 0x00080000; $MDMBUF = 0x00100000; $LITOUT = 0x00200000; $TOSTOP = 0x00400000; $FLUSHO = 0x00800000; $NOHANG = 0x01000000; $L001000 = 0x02000000; $CRTKIL = 0x04000000; $PASS8 = 0x08000000; $CTLECH = 0x10000000; $PENDIN = 0x20000000; $DECCTQ = 0x40000000; $NOFLSH = 0x80000000; $TIOCLBIS = 0x8004747F; $TIOCLBIC = 0x8004747E; $TIOCLSET = 0x8004747D; $TIOCLGET = 0x4004747C; $LCRTBS = 0x1; $LPRTERA = 0x2; $LCRTERA = 0x4; $LTILDE = 0x8; $LMDMBUF = 0x10; $LLITOUT = 0x20; $LTOSTOP = 0x40; $LFLUSHO = 0x80; $LNOHANG = 0x100; $LCRTKIL = 0x400; $LPASS8 = 0x800; $LCTLECH = 0x1000; $LPENDIN = 0x2000; $LDECCTQ = 0x4000; $LNOFLSH = 0xFFFF8000; $TIOCSBRK = 0x2000747B; $TIOCCBRK = 0x2000747A; $TIOCSDTR = 0x20007479; $TIOCCDTR = 0x20007478; $TIOCGPGRP = 0x40047477; $TIOCSPGRP = 0x80047476; $TIOCSLTC = 0x80067475; $TIOCGLTC = 0x40067474; $TIOCOUTQ = 0x40047473; $TIOCSTI = 0x80017472; $TIOCNOTTY = 0x20007471; $TIOCPKT = 0x80047470; $TIOCPKT_DATA = 0x00; $TIOCPKT_FLUSHREAD = 0x01; $TIOCPKT_FLUSHWRITE = 0x02; $TIOCPKT_STOP = 0x04; $TIOCPKT_START = 0x08; $TIOCPKT_NOSTOP = 0x10; $TIOCPKT_DOSTOP = 0x20; $TIOCSTOP = 0x2000746F; $TIOCSTART = 0x2000746E; $TIOCMSET = 0x8004746D; $TIOCMBIS = 0x8004746C; $TIOCMBIC = 0x8004746B; $TIOCMGET = 0x4004746A; $TIOCREMOTE = 0x80047469; $TIOCGWINSZ = 0x40087468; $TIOCSWINSZ = 0x80087467; $TIOCUCNTL = 0x80047466; $TIOCSSOFTC = 0x80047465; $TIOCGSOFTC = 0x40047464; $TIOCSCARR = 0x80047463; $TIOCWCARR = 0x20007462; $OTTYDISC = 0; $NETLDISC = 1; $NTTYDISC = 2; $TABLDISC = 3; $SLIPDISC = 4; $FIOCLEX = 0x20006601; $FIONCLEX = 0x20006602; $FIONREAD = 0x4004667F; $FIONBIO = 0x8004667E; $FIOASYNC = 0x8004667D; $FIOSETOWN = 0x8004667C; $FIOGETOWN = 0x4004667B; $SIOCSHIWAT = 0x80047300; $SIOCGHIWAT = 0x40047301; $SIOCSLOWAT = 0x80047302; $SIOCGLOWAT = 0x40047303; $SIOCATMARK = 0x40047307; $SIOCSPGRP = 0x80047308; $SIOCGPGRP = 0x40047309; $SIOCADDRT = 0x8030720A; $SIOCDELRT = 0x8030720B; $SIOCSIFADDR = 0x8020690C; $SIOCGIFADDR = 0xC020690D; $SIOCSIFDSTADDR = 0x8020690E; $SIOCGIFDSTADDR = 0xC020690F; $SIOCSIFFLAGS = 0x80206910; $SIOCGIFFLAGS = 0xC0206911; $SIOCGIFBRDADDR = 0xC0206912; $SIOCSIFBRDADDR = 0x80206913; $SIOCGIFCONF = 0xC0086914; $SIOCGIFNETMASK = 0xC0206915; $SIOCSIFNETMASK = 0x80206916; $SIOCGIFMETRIC = 0xC0206917; $SIOCSIFMETRIC = 0x80206918; $SIOCSARP = 0x8024691E; $SIOCGARP = 0xC024691F; $SIOCDARP = 0x80246920; rl = 0; if (-w _ && ($udev != $bdev || $uino != $bino) && !$nonono) { # First make sure $mainperldir/perl is not already the same as # the perl we just installed if (-x "$mainperldir/perl") { # Use stat so we detect symbolic links transparently ($mpdev, $mpino) = stat("$mainperperl5.000/keywords.h 664 203 12 13010 5650572640 7470 #define KEY_NULL 0 #define KEY___LINE__ 1 #define KEY___FILE__ 2 #define KEY___END__ 3 #define KEY_AUTOLOAD 4 #define KEY_BEGIN 5 #define KEY_CORE 6 #define KEY_DESTROY 7 #define KEY_END 8 #define KEY_EQ 9 #define KEY_GE 10 #define KEY_GT 11 #define KEY_LE 12 #define KEY_LT 13 #define KEY_NE 14 #define KEY_abs 15 #define KEY_accept 16 #define KEY_alarm 17 #define KEY_and 18 #define KEY_atan2 19 #define KEY_bind 20 #define KEY_binmode 21 #define KEY_bless 22 #define KEY_caller 23 #define KEY_chdir 24 #define KEY_chmod 25 #define KEY_chomp 26 #define KEY_chop 27 #define KEY_chown 28 #define KEY_chr 29 #define KEY_chroot 30 #define KEY_close 31 #define KEY_closedir 32 #define KEY_cmp 33 #define KEY_connect 34 #define KEY_continue 35 #define KEY_cos 36 #define KEY_crypt 37 #define KEY_dbmclose 38 #define KEY_dbmopen 39 #define KEY_defined 40 #define KEY_delete 41 #define KEY_die 42 #define KEY_do 43 #define KEY_dump 44 #define KEY_each 45 #define KEY_else 46 #define KEY_elsif 47 #define KEY_endgrent 48 #define KEY_endhostent 49 #define KEY_endnetent 50 #define KEY_endprotoent 51 #define KEY_endpwent 52 #define KEY_endservent 53 #define KEY_eof 54 #define KEY_eq 55 #define KEY_eval 56 #define KEY_exec 57 #define KEY_exists 58 #define KEY_exit 59 #define KEY_exp 60 #define KEY_fcntl 61 #define KEY_fileno 62 #define KEY_flock 63 #define KEY_for 64 #define KEY_foreach 65 #define KEY_fork 66 #define KEY_format 67 #define KEY_formline 68 #define KEY_ge 69 #define KEY_getc 70 #define KEY_getgrent 71 #define KEY_getgrgid 72 #define KEY_getgrnam 73 #define KEY_gethostbyaddr 74 #define KEY_gethostbyname 75 #define KEY_gethostent 76 #define KEY_getlogin 77 #define KEY_getnetbyaddr 78 #define KEY_getnetbyname 79 #define KEY_getnetent 80 #define KEY_getpeername 81 #define KEY_getpgrp 82 #define KEY_getppid 83 #define KEY_getpriority 84 #define KEY_getprotobyname 85 #define KEY_getprotobynumber 86 #define KEY_getprotoent 87 #define KEY_getpwent 88 #define KEY_getpwnam 89 #define KEY_getpwuid 90 #define KEY_getservbyname 91 #define KEY_getservbyport 92 #define KEY_getservent 93 #define KEY_getsockname 94 #define KEY_getsockopt 95 #define KEY_glob 96 #define KEY_gmtime 97 #define KEY_goto 98 #define KEY_grep 99 #define KEY_gt 100 #define KEY_hex 101 #define KEY_if 102 #define KEY_index 103 #define KEY_int 104 #define KEY_ioctl 105 #define KEY_join 106 #define KEY_keys 107 #define KEY_kill 108 #define KEY_last 109 #define KEY_lc 110 #define KEY_lcfirst 111 #define KEY_le 112 #define KEY_length 113 #define KEY_link 114 #define KEY_listen 115 #define KEY_local 116 #define KEY_localtime 117 #define KEY_log 118 #define KEY_lstat 119 #define KEY_lt 120 #define KEY_m 121 #define KEY_map 122 #define KEY_mkdir 123 #define KEY_msgctl 124 #define KEY_msgget 125 #define KEY_msgrcv 126 #define KEY_msgsnd 127 #define KEY_my 128 #define KEY_ne 129 #define KEY_next 130 #define KEY_no 131 #define KEY_not 132 #define KEY_oct 133 #define KEY_open 134 #define KEY_opendir 135 #define KEY_or 136 #define KEY_ord 137 #define KEY_pack 138 #define KEY_package 139 #define KEY_pipe 140 #define KEY_pop 141 #define KEY_pos 142 #define KEY_print 143 #define KEY_printf 144 #define KEY_push 145 #define KEY_q 146 #define KEY_qq 147 #define KEY_quotemeta 148 #define KEY_qw 149 #define KEY_qx 150 #define KEY_rand 151 #define KEY_read 152 #define KEY_readdir 153 #define KEY_readline 154 #define KEY_readlink 155 #define KEY_readpipe 156 #define KEY_recv 157 #define KEY_redo 158 #define KEY_ref 159 #define KEY_rename 160 #define KEY_require 161 #define KEY_reset 162 #define KEY_return 163 #define KEY_reverse 164 #define KEY_rewinddir 165 #define KEY_rindex 166 #define KEY_rmdir 167 #define KEY_s 168 #define KEY_scalar 169 #define KEY_seek 170 #define KEY_seekdir 171 #define KEY_select 172 #define KEY_semctl 173 #define KEY_semget 174 #define KEY_semop 175 #define KEY_send 176 #define KEY_setgrent 177 #define KEY_sethostent 178 #define KEY_setnetent 179 #define KEY_setpgrp 180 #define KEY_setpriority 181 #define KEY_setprotoent 182 #define KEY_setpwent 183 #define KEY_setservent 184 #define KEY_setsockopt 185 #define KEY_shift 186 #define KEY_shmctl 187 #define KEY_shmget 188 #define KEY_shmread 189 #define KEY_shmwrite 190 #define KEY_shutdown 191 #define KEY_sin 192 #define KEY_sleep 193 #define KEY_socket 194 #define KEY_socketpair 195 #define KEY_sort 196 #define KEY_splice 197 #define KEY_split 198 #define KEY_sprintf 199 #define KEY_sqrt 200 #define KEY_srand 201 #define KEY_stat 202 #define KEY_study 203 #define KEY_sub 204 #define KEY_substr 205 #define KEY_symlink 206 #define KEY_syscall 207 #define KEY_sysread 208 #define KEY_system 209 #define KEY_syswrite 210 #define KEY_tell 211 #define KEY_telldir 212 #define KEY_tie 213 #define KEY_time 214 #define KEY_times 215 #define KEY_tr 216 #define KEY_truncate 217 #define KEY_uc 218 #define KEY_ucfirst 219 #define KEY_umask 220 #define KEY_undef 221 #define KEY_unless 222 #define KEY_unlink 223 #define KEY_unpack 224 #define KEY_unshift 225 #define KEY_untie 226 #define KEY_until 227 #define KEY_use 228 #define KEY_utime 229 #define KEY_values 230 #define KEY_vec 231 #define KEY_wait 232 #define KEY_waitpid 233 #define KEY_wantarray 234 #define KEY_warn 235 #define KEY_while 236 #define KEY_write 237 #define KEY_x 238 #define KEY_xor 239 #define KEY_y 240 erl appears in your path in the following " . "locations beyond where\nwe just installed it:\n"; for (@otherperls) { print STDERR " ", $_, "\n"; } print STDERR "\n"; } print STDERR " Installation complete\n"; exit 0; ############################################################################### sub yn { local($prompt) = @_; local($answer); local($default) = $prompt =~ m/\[([yn])\]\s*$/i; print STDERR $prompt; chop($answer = ); $answer = $default perl5.000/keywords.pl 775 203 12 4132 5626174572 7651 #!/usr/bin/perl open(KW, ">keywords.h") || die "Can't create keywords.h: $!\n"; select KW; # Read & print data. $keynum = 0; while () { chop; next unless $_; next if /^#/; ($keyword) = split; print &tab(5, "#define KEY_$keyword"), $keynum++, "\n"; } ########################################################################### sub tab { local($l, $t) = @_; $t .= "\t" x ($l - (length($t) + 1) / 8); $t; } ########################################################################### __END__ NULL __LINE__ __FILE__ __END__ AUTOLOAD BEGIN CORE DESTROY END EQ GE GT LE LT NE abs accept alarm and atan2 bind binmode bless caller chdir chmod chomp chop chown chr chroot close closedir cmp connect continue cos crypt dbmclose dbmopen defined delete die do dump each else elsif endgrent endhostent endnetent endprotoent endpwent endservent eof eq eval exec exists exit exp fcntl fileno flock for foreach fork format formline ge getc getgrent getgrgid getgrnam gethostbyaddr gethostbyname gethostent getlogin getnetbyaddr getnetbyname getnetent getpeername getpgrp getppid getpriority getprotobyname getprotobynumber getprotoent getpwent getpwnam getpwuid getservbyname getservbyport getservent getsockname getsockopt glob gmtime goto grep gt hex if index int ioctl join keys kill last lc lcfirst le length link listen local localtime log lstat lt m map mkdir msgctl msgget msgrcv msgsnd my ne next no not oct open opendir or ord pack package pipe pop pos print printf push q qq quotemeta qw qx rand read readdir readline readlink readpipe recv redo ref rename require reset return reverse rewinddir rindex rmdir s scalar seek seekdir select semctl semget semop send setgrent sethostent setnetent setpgrp setpriority setprotoent setpwent setservent setsockopt shift shmctl shmget shmread shmwrite shutdown sin sleep socket socketpair sort splice split sprintf sqrt srand stat study sub substr symlink syscall sysread system syswrite tell telldir tie time times tr truncate uc ucfirst umask undef unless unlink unpack unshift untie until use utime values vec wait waitpid wantarray warn while write x xor y Y_endnetent 50 #define KEY_endprotoent 51 #define KEY_endpwent 52 #define KEY_endservent 53 #define KEY_eof 54 #define KEY_eq 55 #define KEY_eval 56 #define KEY_exec 57 #define KEY_exists 58 #define KEY_exit 59 #define KEY_exp 60 #define KEY_fcntl 61 #define KEY_fileno 62 #define KEY_flock 63 #define KEY_for 64 #define KEY_foreach 65 #define KEY_fork 66 #define KEY_format 67 #define KEY_formline perl5.000/lib/ 775 203 12 0 5650575717 6126 perl5.000/lib/AnyDBM_File.pm 664 203 12 361 5604657012 10526 package AnyDBM_File; @ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA; eval { require NDBM_File } || eval { require DB_File } || eval { require GDBM_File } || eval { require SDBM_File } || eval { require ODBM_File }; xporter.pmäÑKExtUtilsôZFile9+ ðN FileHandle.pm  ðOShell.pm9-0BGetopt.@‘VI18N9/L¤ÐIPC\¸MathhpháÖNetxfSearchl„DÜSys”˜Termer¤äêTestperl5.000/lib/AutoLoader.pm 664 203 12 1205 5635200750 10567 package AutoLoader; use Carp; AUTOLOAD { my $name = "auto/$AUTOLOAD.al"; $name =~ s#::#/#g; eval {require $name}; if ($@) { # The load might just have failed because the filename was too # long for some old SVR3 systems which treat long names as errors. # If we can succesfully truncate a long name then it's worth a go. # There is a slight risk that we could pick up the wrong file here # but autosplit should have warned about that when splitting. if ($name =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){ eval {require $name}; } if ($@){ $@ =~ s/ at .*\n//; croak $@; } } goto &$AUTOLOAD; } 1; ði cacheout.pldðj chat2.interxðkchat2.pl Œðl complete.pl ðmctime.pl´ðndotsh.pl Èðo dumpvar.plàðp exceptions.pltsôðq fastcwd.plpòfind.plò† finddepth.pl 0ò‰flush.pl@òŠftp.pl Tò‹ getcwd.plò‰hòŒ getopt.plòŠ|ò getopts.pl perl5.000/lib/AutoSplit.pm 664 203 12 14600 5650421417 10501 package AutoSplit; require 5.000; require Exporter; use Config; use Carp; @ISA = qw(Exporter); @EXPORT = qw(&autosplit &autosplit_lib_modules); @EXPORT_OK = qw($Verbose $Keep); # for portability warn about names longer than $maxlen $Maxlen = 8; # 8 for dos, 11 (14-".al") for SYSVR3 $Verbose = 1; # 0=none, 1=minimal, 2=list .al files $Keep = 0; $IndexFile = "autosplit.ix"; # file also serves as timestamp $maxflen = 255; $maxflen = 14 if $Config{'d_flexfnam'} ne 'define'; $vms = ($Config{'osname'} eq 'VMS'); sub autosplit{ my($file, $autodir) = @_; autosplit_file($file, $autodir, $Keep, 1, 0); } # This function is used during perl building/installation # ./miniperl -e 'use AutoSplit; autosplit_modules(@ARGV)' ... sub autosplit_lib_modules{ my(@modules) = @_; # list of Module names foreach(@modules){ s#::#/#g; # incase specified as ABC::XYZ s#^lib/##; # incase specified as lib/*.pm if ($vms && /[:>\]]/) { # may need to convert VMS-style filespecs my ($dir,$name) = (/(.*])(.*)/); $dir =~ s/.*lib[\.\]]//; $dir =~ s#[\.\]]#/#g; $_ = $dir . $name; } autosplit_file("lib/$_", "lib/auto", $Keep, 1, 1); } 0; } # private functions sub autosplit_file{ my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) = @_; my(@names); # where to write output files $autodir = "lib/auto" unless $autodir; die "autosplit directory $autodir does not exist" unless -d $autodir; # allow just a package name to be used $filename .= ".pm" unless ($filename =~ m/\.pm$/); open(IN, "<$filename") || die "AutoSplit: Can't open $filename: $!\n"; my($pm_mod_time) = (stat($filename))[9]; my($autoloader_seen) = 0; while () { # record last package name seen $package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); ++$autoloader_seen if m/^\s*use\s+AutoLoader\b/; ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/; last if /^__END__/; } return 0 if ($check_for_autoloader && !$autoloader_seen); $_ or die "Can't find __END__ in $filename\n"; $package or die "Can't find 'package Name;' in $filename\n"; my($modpname) = $package; $modpname =~ s#::#/#g; my($al_idx_file) = "$autodir/$modpname/$IndexFile"; die "Package $package does not match filename $filename" unless ($filename =~ m/$modpname.pm$/ or $vms && $filename =~ m/$modpname.pm/i); if ($check_mod_time){ my($al_ts_time) = (stat("$al_idx_file"))[9] || 1; if ($al_ts_time >= $pm_mod_time){ print "AutoSplit skipped ($al_idx_file newer that $filename)\n" if ($Verbose >= 2); return undef; # one undef, not a list } } my($from) = ($Verbose>=2) ? "$filename => " : ""; print "AutoSplitting $package ($from$autodir/$modpname)\n" if $Verbose; unless (-d "$autodir/$modpname"){ local($", @p)="/"; foreach(split(/\//,"$autodir/$modpname")){ push(@p, $_); next if -d "@p"; mkdir("@p",0777) or die "AutoSplit unable to mkdir @p: $!"; } } # We must try to deal with some SVR3 systems with a limit of 14 # characters for file names. Sadly we *cannot* simply truncate all # file names to 14 characters on these systems because we *must* # create filenames which exactly match the names used by AutoLoader.pm. # This is a problem because some systems silently truncate the file # names while others treat long file names as an error. # We do not yet deal with multiple packages within one file. # Ideally both of these styles should work. # # package NAME; # __END__ # sub AAA { ... } # package NAME::option1; # sub BBB { ... } # package NAME::option2; # sub BBB { ... } # # package NAME; # __END__ # sub AAA { ... } # sub NAME::option1::BBB { ... } # sub NAME::option2::BBB { ... } # # For now both of these produce warnings. open(OUT,">/dev/null") || open(OUT,">nla0:"); # avoid 'not opened' warning my(@subnames); while () { if (/^package ([\w:]+)\s*;/) { warn "package $1; in AutoSplit section ignored. Not currently supported."; } if (/^sub ([\w:]+)/) { print OUT "1;\n"; my($subname) = $1; if ($subname =~ m/::/){ warn "subs with package names not currently supported in AutoSplit section"; } push(@subnames, $subname); my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3)); my($lpath) = "$autodir/$modpname/$lname.al"; my($spath) = "$autodir/$modpname/$sname.al"; unless(open(OUT, ">$lpath")){ open(OUT, ">$spath") or die "Can't create $spath: $!\n"; push(@names, $sname); print " writing $spath (with truncated name)\n" if ($Verbose>=1); }else{ push(@names, $lname); print " writing $lpath\n" if ($Verbose>=2); } print OUT "# NOTE: Derived from $filename. ", "Changes made here will be lost.\n"; print OUT "package $package;\n\n"; } print OUT $_; } print OUT "1;\n"; close(OUT); close(IN); if (!$keep){ # don't keep any obsolete *.al files in the directory my(%names); @names{@names} = @names; opendir(OUTDIR,"$autodir/$modpname"); foreach(sort readdir(OUTDIR)){ next unless /\.al$/; my($subname) = m/(.*)\.al$/; next if $names{substr($subname,0,$maxflen-3)}; my($file) = "$autodir/$modpname/$_"; print " deleting $file\n" if ($Verbose>=2); unlink $file or carp "Unable to delete $file: $!"; } closedir(OUTDIR); } open(TS,">$al_idx_file") or carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!"; print TS "# Index created by AutoSplit for $filename (file acts as timestamp)\n"; print TS map("sub $_ ;\n", @subnames); close(TS); check_unique($package, $Maxlen, 1, @names); @names; } sub check_unique{ my($module, $maxlen, $warn, @names) = @_; my(%notuniq) = (); my(%shorts) = (); my(@toolong) = grep(length > $maxlen, @names); foreach(@toolong){ my($trunc) = substr($_,0,$maxlen); $notuniq{$trunc}=1 if $shorts{$trunc}; $shorts{$trunc} = ($shorts{$trunc}) ? "$shorts{$trunc}, $_" : $_; } if (%notuniq && $warn){ print "$module: some names are not unique when truncated to $maxlen characters:\n"; foreach(keys %notuniq){ print " $shorts{$_} truncate to $_\n"; } } %notuniq; } 1; __END__ # test functions so AutoSplit.pm can be applied to itself: sub test1{ "test 1\n"; } sub test2{ "test 2\n"; } sub test3{ "test 3\n"; } sub test4{ "test 4\n"; } _qw 149 #define KEY_qx 150 #define KEY_rand 151 #define KEY_read 152 #define KEY_readdir 153 #define KEY_readline 154 #dperl5.000/lib/Benchmark.pm 664 203 12 14643 5645373503 10464 package Benchmark; # Purpose: benchmark running times of code. # # # Usage - to time code snippets and print results: # # timethis($count, '...code...'); # # prints: # timethis 100: 2 secs ( 0.23 usr 0.10 sys = 0.33 cpu) # # # timethese($count, { # Name1 => '...code1...', # Name2 => '...code2...', # ... }); # prints: # Benchmark: timing 100 iterations of Name1, Name2... # Name1: 2 secs ( 0.50 usr 0.00 sys = 0.50 cpu) # Name2: 1 secs ( 0.48 usr 0.00 sys = 0.48 cpu) # # The default display style will automatically add child process # values if non-zero. # # # Usage - to time sections of your own code: # # use Benchmark; # $t0 = new Benchmark; # ... your code here ... # $t1 = new Benchmark; # $td = &timediff($t1, $t0); # print "the code took:",timestr($td),"\n"; # # $t = &timeit($count, '...other code...') # print "$count loops of other code took:",timestr($t),"\n"; # # # Data format: # The data is stored as a list of values from the time and times # functions: ($real, $user, $system, $children_user, $children_system) # in seconds for the whole loop (not divided by the number of rounds). # # Internals: # The timing is done using time(3) and times(3). # # Code is executed in the callers package # # Enable debugging by: $Benchmark::debug = 1; # # The time of the null loop (a loop with the same # number of rounds but empty loop body) is substracted # from the time of the real loop. # # The null loop times are cached, the key being the # number of rounds. The caching can be controlled using # &clearcache($key); &clearallcache; # &disablecache; &enablecache; # # Caveats: # # The real time timing is done using time(2) and # the granularity is therefore only one second. # # Short tests may produce negative figures because perl # can appear to take longer to execute the empty loop # than a short test: try timethis(100,'1'); # # The system time of the null loop might be slightly # more than the system time of the loop with the actual # code and therefore the difference might end up being < 0 # # More documentation is needed :-( # Especially for styles and formats. # # Authors: Jarkko Hietaniemi # Tim Bunce # # # Last updated: Sept 8th 94 by Tim Bunce # use Exporter; @ISA=(Exporter); @EXPORT=qw(timeit timethis timethese timediff timestr); @EXPORT_OK=qw(clearcache clearallcache disablecache enablecache); &init; sub init { $debug = 0; $min_count = 4; $min_cpu = 0.4; $defaultfmt = '5.2f'; $defaultstyle = 'auto'; # The cache can cause a slight loss of sys time accuracy. If a # user does many tests (>10) with *very* large counts (>10000) # or works on a very slow machine the cache may be useful. &disablecache; &clearallcache; } sub clearcache { delete $cache{$_[0]}; } sub clearallcache { %cache = (); } sub enablecache { $cache = 1; } sub disablecache { $cache = 0; } # --- Functions to process the 'time' data type sub new { my(@t)=(time, times); print "new=@t\n" if $debug; bless \@t; } sub cpu_p { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps ; } sub cpu_c { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $cu+$cs ; } sub cpu_a { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps+$cu+$cs ; } sub real { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $r ; } sub timediff{ my($a, $b) = @_; my(@r); for($i=0; $i < @$a; ++$i){ push(@r, $a->[$i] - $b->[$i]); } bless \@r; } sub timestr{ my($tr, $style, $f) = @_; my(@t) = @$tr; warn "bad time value" unless @t==5; my($r, $pu, $ps, $cu, $cs) = @t; my($pt, $ct, $t) = ($tr->cpu_p, $tr->cpu_c, $tr->cpu_a); $f = $defaultfmt unless $f; # format a time in the required style, other formats may be added here $style = $defaultstyle unless $style; $style = ($ct>0) ? 'all' : 'noc' if $style=~/^auto$/; my($s) = "@t $style"; # default for unknown style $s=sprintf("%2d secs (%$f usr %$f sys + %$f cusr %$f csys = %$f cpu)", @t,$t) if $style =~ /^all$/; $s=sprintf("%2d secs (%$f usr %$f sys = %$f cpu)", $r,$pu,$ps,$pt) if $style =~ /^noc$/; $s=sprintf("%2d secs (%$f cusr %$f csys = %$f cpu)", $r,$cu,$cs,$ct) if $style =~ /^nop$/; $s; } sub timedebug{ my($msg, $t) = @_; print STDERR "$msg",timestr($t),"\n" if ($debug); } # --- Functions implementing low-level support for timing loops sub runloop { my($n, $c) = @_; my($t0, $t1, $td); # before, after, difference # find package of caller so we can execute code there my ($curpack) = caller(0); my ($i, $pack)= 0; while (($pack) = caller(++$i)) { last if $pack ne $curpack; } my $subcode = "sub { package $pack; my(\$_i)=$n; while (\$_i--){$c;} }"; my $subref = eval $subcode; die "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@; print STDERR "runloop $n '$subcode'\n" if ($debug); $t0 = &new; &$subref; $t1 = &new; $td = &timediff($t1, $t0); timedebug("runloop:",$td); $td; } sub timeit { my($n, $code) = @_; my($wn, $wc, $wd); printf STDERR "timeit $n $code\n" if $debug; if ($cache && exists $cache{$n}){ $wn = $cache{$n}; }else{ $wn = &runloop($n, ''); $cache{$n} = $wn; } $wc = &runloop($n, $code); $wd = timediff($wc, $wn); timedebug("timeit: ",$wc); timedebug(" - ",$wn); timedebug(" = ",$wd); $wd; } # --- Functions implementing high-level time-then-print utilities sub timethis{ my($n, $code, $title, $style) = @_; my($t) = timeit($n, $code); local($|) = 1; $title = "timethis $n" unless $title; $style = "" unless $style; printf("%10s: ", $title); print timestr($t, $style),"\n"; # A conservative warning to spot very silly tests. # Don't assume that your benchmark is ok simply because # you don't get this warning! print " (warning: too few iterations for a reliable count)\n" if ( $n < $min_count || ($t->real < 1 && $n < 1000) || $t->cpu_a < $min_cpu); $t; } sub timethese{ my($n, $alt, $style) = @_; die "usage: timethese(count, { 'Name1'=>'code1', ... }\n" unless ref $alt eq HASH; my(@all); my(@names) = sort keys %$alt; $style = "" unless $style; print "Benchmark: timing $n iterations of ",join(', ',@names),"...\n"; foreach(@names){ $t = timethis($n, $alt->{$_}, $_, $style); push(@all, $t); } # we could produce a summary from @all here # sum, min, max, avg etc etc @all; } 1; $min_count = 4; $min_cpu = 0.4; $defaultfmt = '5.2f'; $defaultstyle = 'auto'; perl5.000/lib/Carp.pm 664 203 12 1532 5646423026 7425 package Carp; # This package implements handy routines for modules that wish to throw # exceptions outside of the current package. require Exporter; @ISA = Exporter; @EXPORT = qw(confess croak carp); sub longmess { my $error = shift; my $mess = ""; my $i = 2; my ($pack,$file,$line,$sub); while (($pack,$file,$line,$sub) = caller($i++)) { $mess .= "\t$sub " if $error eq "called"; $mess .= "$error at $file line $line\n"; $error = "called"; } $mess || $error; } sub shortmess { my $error = shift; my ($curpack) = caller(1); my $i = 2; my ($pack,$file,$line,$sub); while (($pack,$file,$line,$sub) = caller($i++)) { return "$error at $file line $line\n" if $pack ne $curpack; } longmess $error; } sub confess { die longmess @_; } sub croak { die shortmess @_; } sub carp { warn shortmess @_; } ftp.plsTò‹ getcwd.plp.hòŒ getopt.pl.p|ò getopts.plpòŽ hostname.pl¨ò importenv.plpl¼ò integer.pmlÌò‘perl5.000/lib/Cwd.pm 664 203 12 6003 5645374707 7265 package Cwd; require 5.000; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(getcwd fastcwd); @EXPORT_OK = qw(chdir); # By Brandon S. Allbery # # Usage: $cwd = getcwd(); sub getcwd { my($dotdots, $cwd, @pst, @cst, $dir, @tst); unless (@cst = stat('.')) { warn "stat(.): $!"; return ''; } $cwd = ''; do { $dotdots .= '/' if $dotdots; $dotdots .= '..'; @pst = @cst; unless (opendir(PARENT, $dotdots)) { warn "opendir($dotdots): $!"; return ''; } unless (@cst = stat($dotdots)) { warn "stat($dotdots): $!"; closedir(PARENT); return ''; } if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) { $dir = ''; } else { do { unless ($dir = readdir(PARENT)) { warn "readdir($dotdots): $!"; closedir(PARENT); return ''; } unless (@tst = lstat("$dotdots/$dir")) { warn "lstat($dotdots/$dir): $!"; closedir(PARENT); return ''; } } while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || $tst[1] != $pst[1]); } $cwd = "$dir/$cwd"; closedir(PARENT); } while ($dir); chop($cwd); $cwd; } # By John Bazik # # Usage: $cwd = &fastcwd; # # This is a faster version of getcwd. It's also more dangerous because # you might chdir out of a directory that you can't chdir back into. sub fastcwd { my($odev, $oino, $cdev, $cino, $tdev, $tino); my(@path, $path); local(*DIR); ($cdev, $cino) = stat('.'); for (;;) { ($odev, $oino) = ($cdev, $cino); chdir('..'); ($cdev, $cino) = stat('.'); last if $odev == $cdev && $oino == $cino; opendir(DIR, '.'); for (;;) { $_ = readdir(DIR); next if $_ eq '.'; next if $_ eq '..'; last unless $_; ($tdev, $tino) = lstat($_); last unless $tdev != $odev || $tino != $oino; } closedir(DIR); unshift(@path, $_); } chdir($path = '/' . join('/', @path)); $path; } # keeps track of current working directory in PWD environment var # # $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $ # # $Log: pwd.pl,v $ # # Usage: # use Cwd 'chdir'; # chdir $newdir; $chdir_init = 0; sub chdir_init{ if ($ENV{'PWD'}) { my($dd,$di) = stat('.'); my($pd,$pi) = stat($ENV{'PWD'}); if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { chop($ENV{'PWD'} = `pwd`); } } else { chop($ENV{'PWD'} = `pwd`); } if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) { my($pd,$pi) = stat($2); my($dd,$di) = stat($1); if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { $ENV{'PWD'}="$2$3"; } } $chdir_init = 1; } sub chdir { my($newdir) = shift; chdir_init() unless $chdir_init; return 0 unless (CORE::chdir $newdir); if ($newdir =~ m#^/#) { $ENV{'PWD'} = $newdir; }else{ my(@curdir) = split(m#/#,$ENV{'PWD'}); @curdir = '' unless @curdir; foreach $component (split(m#/#, $newdir)) { next if $component eq '.'; pop(@curdir),next if $component eq '..'; push(@curdir,$component); } $ENV{'PWD'} = join('/',@curdir) || '/'; } } 1; pu_p { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps ; } sub cpu_c { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $cu+$cs ; } sub cpu_a { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps+$cu+$cs ; } sub real { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $r ; } sub timediff{ my($a, $b) = @_; my(@r); for($i=0; $i < @$a; ++$i){ push(@r, $a->[$i] - $b->[$i]); } bless \@r; } sub timestr{ my($tr, $style, $f) = @_; my(@t) = @$tr; warn "bad time value" unless @t==5; my($rperl5.000/lib/English.pm 664 203 12 4407 5645723250 10136 package English; require Exporter; @ISA = (Exporter); local($^W) = 0; @EXPORT = qw( *ARG $MATCH $PREMATCH $POSTMATCH $LAST_PAREN_MATCH $INPUT_LINE_NUMBER $NR $INPUT_RECORD_SEPARATOR $RS $OUTPUT_AUTOFLUSH $OUTPUT_FIELD_SEPARATOR $OFS $OUTPUT_RECORD_SEPARATOR $ORS $LIST_SEPARATOR $SUBSCRIPT_SEPARATOR $SUBSEP $FORMAT_PAGE_NUMBER $FORMAT_LINES_PER_PAGE $FORMAT_LINES_LEFT $FORMAT_NAME $FORMAT_TOP_NAME $FORMAT_LINE_BREAK_CHARACTERS $FORMAT_FORMFEED $CHILD_ERROR $OS_ERROR $ERRNO $EVAL_ERROR $PROCESS_ID $PID $REAL_USER_ID $UID $EFFECTIVE_USER_ID $EUID $REAL_GROUP_ID $GID $EFFECTIVE_GROUP_ID $EGID $PROGRAM_NAME $PERL_VERSION $DEBUGGING $SYSTEM_FD_MAX $INPLACE_EDIT $PERLDB $BASETIME $WARNING $EXECUTABLE_NAME $ARRAY_BASE $OFMT $MULTILINE_MATCHING ); # The ground of all being. *ARG = *_ ; # Matching. *MATCH = \$& ; *PREMATCH = \$` ; *POSTMATCH = \$' ; *LAST_PAREN_MATCH = \$+ ; # Input. *INPUT_LINE_NUMBER = \$. ; *NR = \$. ; *INPUT_RECORD_SEPARATOR = \$/ ; *RS = \$/ ; # Output. *OUTPUT_AUTOFLUSH = \$| ; *OUTPUT_FIELD_SEPARATOR = \$, ; *OFS = \$, ; *OUTPUT_RECORD_SEPARATOR = \$\ ; *ORS = \$\ ; # Interpolation "constants". *LIST_SEPARATOR = \$" ; *SUBSCRIPT_SEPARATOR = \$; ; *SUBSEP = \$; ; # Formats *FORMAT_PAGE_NUMBER = \$% ; *FORMAT_LINES_PER_PAGE = \$= ; *FORMAT_LINES_LEFT = \$- ; *FORMAT_NAME = \$~ ; *FORMAT_TOP_NAME = \$^ ; *FORMAT_LINE_BREAK_CHARACTERS = \$: ; *FORMAT_FORMFEED = \$^L ; # Error status. *CHILD_ERROR = \$? ; *OS_ERROR = \$! ; *ERRNO = \$! ; *EVAL_ERROR = \$@ ; # Process info. *PROCESS_ID = \$$ ; *PID = \$$ ; *REAL_USER_ID = \$< ; *UID = \$< ; *EFFECTIVE_USER_ID = \$> ; *EUID = \$> ; *REAL_GROUP_ID = \$( ; *GID = \$( ; *EFFECTIVE_GROUP_ID = \$) ; *EGID = \$) ; *PROGRAM_NAME = \$0 ; # Internals. *PERL_VERSION = \$] ; *ACCUMULATOR = \$^A ; *DEBUGGING = \$^D ; *SYSTEM_FD_MAX = \$^F ; *INPLACE_EDIT = \$^I ; *PERLDB = \$^P ; *BASETIME = \$^T ; *WARNING = \$^W ; *EXECUTABLE_NAME = \$^X ; # Deprecated. # *ARRAY_BASE = \$[ ; # *OFMT = \$# ; # *MULTILINE_MATCHING = \$* ; 1; V{'PWD'} = `pwd`); } } else { chop($ENV{'PWD'} = `pwd`); } if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) { my($pd,$pi) = stat($2); my($dd,$di) = stat($1); if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { perl5.000/lib/Env.pm 664 203 12 2626 5650415044 7271 package Env; =head1 NAME Env - Perl module that imports environment variables =head1 DESCRIPTION Perl maintains environment variables in a pseudo-associative-array named %ENV. For when this access method is inconvenient, the Perl module C allows environment variables to be treated as simple variables. The Env::import() function ties environment variables with suitable names to global Perl variables with the same names. By default it does so with all existing environment variables (C). If the import function receives arguments, it takes them to be a list of environment variables to tie; it's okay if they don't yet exist. After an environment variable is tied, merely use it like a normal variable. You may access its value @path = split(/:/, $PATH); or modify it $PATH .= ":."; however you'd like. To remove a tied environment variable from the environment, assign it the undefined value undef $PATH; =head1 AUTHOR Chip Salzenberg =cut sub import { my ($callpack) = caller(0); my $pack = shift; my @vars = @_ ? @_ : keys(%ENV); foreach (@vars) { tie ${"${callpack}::$_"}, Env, $_ if /^[A-Za-z_]\w*$/; } } sub TIESCALAR { bless \($_[1]); } sub FETCH { my ($self) = @_; $ENV{$$self}; } sub STORE { my ($self, $value) = @_; if (defined($value)) { $ENV{$$self} = $value; } else { delete $ENV{$$self}; } } 1; NES_LEFT = \$- ; *FORMAT_NAME = \$~ ; *FORMAT_TOP_NAME = \$^ ; *FORMAT_LINE_BREAK_CHARACTERS = perl5.000/lib/Exporter.pm 664 203 12 2373 5645562165 10363 package Exporter; require 5.000; $ExportLevel = 0; sub export { my $pack = shift; my $callpack = shift; my @imports = @_; *exports = \@{"${pack}::EXPORT"}; if (@imports) { my $oops; my $type; *exports = \%{"${pack}::EXPORT"}; if (!%exports) { grep(s/^&//, @exports); @exports{@exports} = (1) x @exports; foreach $extra (@{"${pack}::EXPORT_OK"}) { $exports{$extra} = 1; } } foreach $sym (@imports) { if (!$exports{$sym}) { if ($sym !~ s/^&// || !$exports{$sym}) { warn qq["$sym" is not exported by the $pack module ], "at $callfile line $callline\n"; $oops++; next; } } } die "Can't continue with import errors.\n" if $oops; } else { @imports = @exports; } foreach $sym (@imports) { $type = '&'; $type = $1 if $sym =~ s/^(\W)//; *{"${callpack}::$sym"} = $type eq '&' ? \&{"${pack}::$sym"} : $type eq '$' ? \${"${pack}::$sym"} : $type eq '@' ? \@{"${pack}::$sym"} : $type eq '%' ? \%{"${pack}::$sym"} : $type eq '*' ? *{"${pack}::$sym"} : warn "Can't export symbol: $type$sym\n"; } }; sub import { local ($callpack, $callfile, $callline) = caller($ExportLevel); my $pack = shift; export $pack, $callpack, @_; } 1; .plèò  timelocal.plò ò¡ validate.pl if (defined($value)) { $ENV{$$self} = $value; } else { delete $ENV{$$self}; } } 1; NES_LEFT = \$- ; *FORMAT_NAME = \$~ ; *FORMAT_TOP_NAME = \$^ ; *FORMAT_LINE_BREAK_CHARACTERS = perl5.000/lib/ExtUtils/ 775 203 12 0 5650575705 7704 perl5.000/lib/ExtUtils/MakeMaker.pm 664 203 12 44534 5650525641 12210 package ExtUtils::MakeMaker; # Authors: Andy Dougherty # Andreas Koenig # Tim Bunce # Last Revision: 12 Oct 1994 # This utility is designed to write a Makefile for an extension # module from a Makefile.PL. It is based on the excellent Makefile.SH # model provided by Andy Dougherty and the perl5-porters. # It splits the task of generating the Makefile into several # subroutines that can be individually overridden. # Each subroutine returns the text it wishes to have written to # the Makefile. use Config; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(writeMakefile mkbootstrap $Verbose); @EXPORT_OK = qw(%att @recognized_att_keys); use strict qw(refs); # Setup dummy package: # MY exists for overriding methods to be defined within unshift(@MY::ISA, qw(MM)); $Verbose = 0; $Subdirs = 0; # set to 1 to have this .PL run all below $^W=1; # For most extensions it will do to call # # use ExtUtils::MakeMaker # &writeMakefile("potential_libs" => "-L/usr/alpha -lfoo -lbar"); # # from Makefile.PL in the extension directory # It is also handy to include some of the following attributes: # @recognized_att_keys=qw( TOP INC DISTNAME VERSION DEFINE OBJECT LDTARGET ARMAYBE BACKUP_LIBS AUTOSPLITMAXLEN LINKTYPE potential_libs otherldflags perl fullperl distclean_tarflags clean_files realclean_files ); # # TOP is the directory above lib/ and ext/ (normally ../..) # (MakeMaker will normally work this out for itself) # INC is something like "-I/usr/local/Minerva/include" # DISTNAME is a name of your choice for distributing the package # VERSION is your version number # DEFINE is something like "-DHAVE_UNISTD_H" # OBJECT defaults to '$(BASEEXT).o', but can be a long string containing # all object files, e.g. "tkpBind.o tkpButton.o tkpCanvas.o" # LDTARGET defaults to $(OBJECT) and is used in the ld command # (some machines need additional switches for bigger projects) # ARMAYBE defaults to ":", but can be used to run ar before ld # BACKUP_LIBS is an anonymous array of libraries to be searched for # until we get at least some output from ext/util/extliblist # 'potential_libs' => "-lgdbm", # 'BACKUP_LIBS' => [ "-ldbm -lfoo", "-ldbm.nfs" ] # AUTOSPLITMAXLEN defaults to 8 and is used when autosplit is done # (can be set higher on a case-by-case basis) # defaults to `dynamic', can be set to `static' # # `make distclean' builds $(DISTNAME)-$(VERSION).tar.Z after a clean # Be aware, that you can also pass attributes into the %att hash table # by calling Makefile.PL with an argument of the form TOP=/some/where. # If the Makefile generated by default does not fit your purpose, # you may specify private subroutines in the Makefile.PL as there are: # # MY->initialize => sub MY::initialize{ ... } # MY->post_initialize => sub MY::post_initialize{ ... } # MY->constants => etc # MY->dynamic # etc. (see function writeMakefile, for the current breakpoints) # # Each subroutines returns the text it wishes to have written to # the Makefile. To override a section of the Makefile you can # either say: sub MY::co { "new literal text" } # or you can edit the default by saying something like: # sub MY::co { $_=MM->co; s/old text/new text/; $_ } # # If you still need a different solution, try to develop another # subroutine, that fits your needs and submit the diffs to # perl5-porters or comp.lang.perl as appropriate. sub writeMakefile { %att = @_; local($\)="\n"; foreach (@ARGV){ $att{$1}=$2 if m/(.*)=(.*)/; } print STDOUT "MakeMaker" if $Verbose; print STDOUT map(" $_ = '$att{$_}'\n", sort keys %att) if ($Verbose && %att); MY->initialize(); print STDOUT "Writing ext/$att{FULLEXT}/Makefile (with variable substitutions)"; open MAKE, ">Makefile" or die "Unable to open Makefile: $!"; MY->mkbootstrap(split(" ", $att{'dynaloadlibs'})); print MAKE MY->post_initialize; print MAKE MY->constants; print MAKE MY->post_constants; print MAKE MY->subdir if $Subdirs; print MAKE MY->dynamic; print MAKE MY->force; print MAKE MY->static; print MAKE MY->co; print MAKE MY->c; print MAKE MY->installpm; print MAKE MY->clean; print MAKE MY->realclean; print MAKE MY->test; print MAKE MY->install; print MAKE MY->perldepend; print MAKE MY->distclean; print MAKE MY->postamble; MY->finish; close MAKE; 1; } sub mkbootstrap{ MY->mkbootstrap(@_) } sub avoid_typo_warnings{ local($t) = "$t $main::writeMakefile $main::mkbootstrap $main::Verbose $DynaLoader::dl_resolve_using $ExtUtils::MakeMaker::Config $DynaLoader::Config "; } # --- Supply the MakeMaker default methods --- package MM; use Config; require Exporter; Exporter::import('ExtUtils::MakeMaker', qw(%att @recognized_att_keys)); # These attributes cannot be overridden @other_att_keys=qw(extralibs dynaloadlibs statloadlibs bootdep); sub find_perl{ my($self, $ver, $names, $dirs, $trace) = @_; my($name, $dir); print "Looking for perl $ver by these names: @$names, in these dirs: @$dirs\n" if ($trace); foreach $dir (@$dirs){ foreach $name (@$names){ print "checking $dir/$name\n" if ($trace >= 2); next unless -x "$dir/$name"; print "executing $dir/$name\n" if ($trace); my($out) = `$dir/$name -e 'require $ver; print "5OK\n" ' 2>&1`; return "$dir/$name" if $out =~ /5OK/; } } warn "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n"; 0; # false and not empty } sub initialize { # Find out directory name. This is also the extension name. chop($pwd=`pwd`); unless ( $top = $att{TOP} ){ foreach(qw(../.. ../../.. ../../../..)){ ($top=$_, last) if -f "$_/config.sh"; } die "Can't find config.sh" unless -f "$top/config.sh"; } chdir $top or die "Couldn't chdir $top: $!"; chop($abstop=`pwd`); chdir $pwd; # EXTMODNAME = The perl module name for this extension. # FULLEXT = Full pathname to extension directory. # BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. # ROOTEXT = Directory part of FULLEXT. May be empty. my($p) = $pwd; $p =~ s:^\Q$abstop/ext/\E::; ($att{EXTMODNAME}=$p) =~ s#/#::#g ; #eg. BSD::Foo::Socket ($att{FULLEXT} =$p); #eg. BSD/Foo/Socket ($att{BASEEXT} =$p) =~ s:.*/:: ; #eg. Socket ($att{ROOTEXT} =$p) =~ s:/?\Q$att{BASEEXT}\E$:: ; #eg. BSD/Foo # Find Perl 5. The only contract here is that both 'perl' and 'fullperl' # will be working versions of perl 5. $att{'perl'} = MY->find_perl(5.0, [ qw(perl5 perl miniperl) ], [ $abstop, split(":", $ENV{PATH}) ], 0 ) unless ($att{'perl'} && -x $att{'perl'}); # Define 'fullperl' to be a non-miniperl (used in test: target) ($att{'fullperl'} = $att{'perl'}) =~ s/miniperl$/perl/ unless ($att{'fullperl'} && -x $att{'fullperl'}); for $key (@recognized_att_keys, @other_att_keys){ # avoid warnings for uninitialized vars $att{$key} = "" unless defined $att{$key}; } # compute extralibs, dynaloadlibs and statloadlibs from # $att{'potential_libs'} unless ( &run_extliblist($att{'potential_libs'}) ){ foreach ( @{$att{'BACKUP_LIBS'} || []} ){ # Try again. Maybe they have specified some other libraries last if &run_extliblist($_); } } } sub run_extliblist { my($potential_libs)=@_; # Now run ext/util/extliblist to discover what *libs definitions # are required for the needs of $potential_libs $ENV{'potential_libs'} = $potential_libs; $_=`. $abstop/ext/util/extliblist; echo extralibs=\$extralibs echo dynaloadlibs=\$dynaloadlibs echo statloadlibs=\$statloadlibs echo bootdep=\$bootdep `; my(@w); foreach $line (split "\n", $_){ chomp $line; if ($line =~ /(.*)\s*=\s*(.*)$/){ $att{$1} = $2; print STDERR " $1 = $2" if $Verbose; }else{ push(@w, $line); } } print STDERR "Messages from extliblist:\n", join("\n",@w,'') if @w ; join '', @att{qw(extralibs dynaloadlibs statloadlibs)}; } sub post_initialize{ ""; } sub constants { my(@m); $att{BOOTDEP} = (-f "$att{BASEEXT}_BS") ? "$att{BASEEXT}_BS" : ""; $att{OBJECT} = '$(BASEEXT).o' unless $att{OBJECT}; $att{LDTARGET} = '$(OBJECT)' unless $att{LDTARGET}; $att{ARMAYBE} = ":" unless $att{ARMAYBE}; $att{AUTOSPLITMAXLEN} = 8 unless $att{AUTOSPLITMAXLEN}; $att{LINKTYPE} = ($Config{'usedl'}) ? 'dynamic' : 'static' unless $att{LINKTYPE}; push @m, " # # This Makefile is for the $att{FULLEXT} extension to perl. # It was written by Makefile.PL, so don't edit it, edit # Makefile.PL instead. ANY CHANGES MADE HERE WILL BE LOST! # DISTNAME = $att{DISTNAME} VERSION = $att{VERSION} TOP = $top ABSTOP = $abstop PERL = $att{'perl'} FULLPERL = $att{'fullperl'} INC = $att{INC} DEFINE = $att{DEFINE} OBJECT = $att{OBJECT} LDTARGET = $att{LDTARGET} "; push @m, " CC = $Config{'cc'} LIBC = $Config{'libc'} LDFLAGS = $Config{'ldflags'} CLDFLAGS = $Config{'ldflags'} LINKTYPE = $att{LINKTYPE} ARMAYBE = $att{ARMAYBE} RANLIB = $Config{'ranlib'} SMALL = $Config{'small'} LARGE = $Config{'large'} $Config{'split'} # The following are used to build and install shared libraries for # dynamic loading. LDDLFLAGS = $Config{'lddlflags'} CCDLFLAGS = $Config{'ccdlflags'} CCCDLFLAGS = $Config{'cccdlflags'} SO = $Config{'so'} DLEXT = $Config{'dlext'} DLSRC = $Config{'dlsrc'} "; push @m, " # $att{FULLEXT} might need to be linked with some extra libraries. # EXTRALIBS = full list of libraries needed for static linking. # Only those libraries that actually exist are included. # DYNALOADLIBS = list of those libraries that are needed but can be # linked in dynamically on this platform. On SunOS, for # example, this would be .so* libraries, but not archive # libraries. The bootstrap file is installed only if # this list is not empty. # STATLOADLIBS = list of those libraries which must be statically # linked into the shared library. On SunOS 4.1.3, # for example, I have only an archive version of # -lm, and it must be linked in statically. EXTRALIBS = $att{'extralibs'} DYNALOADLIBS = $att{'dynaloadlibs'} STATLOADLIBS = $att{'statloadlibs'} "; push @m, " # EXTMODNAME = The perl module name for this extension. # FULLEXT = Full pathname to extension directory. # BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. # ROOTEXT = Directory part of FULLEXT. May be empty. EXTMODNAME = $att{EXTMODNAME} FULLEXT = $att{FULLEXT} BASEEXT = $att{BASEEXT} ROOTEXT = $att{ROOTEXT} # and for backward compatibility and for AIX support (due to change!) EXT = $att{BASEEXT} # $att{FULLEXT} might have its own typemap EXTTYPEMAP = ".(-f "typemap" ? "typemap" : "")." # $att{FULLEXT} might have its own bootstrap support BOOTSTRAP = $att{BASEEXT}.bs BOOTDEP = $att{BOOTDEP} "; push @m, ' # Where to put things: AUTO = $(TOP)/lib/auto AUTOEXT = $(TOP)/lib/auto/$(FULLEXT) INST_BOOT = $(AUTOEXT)/$(BASEEXT).bs INST_DYNAMIC = $(AUTOEXT)/$(BASEEXT).$(DLEXT) INST_STATIC = $(BASEEXT).a INST_PM = $(TOP)/lib/$(FULLEXT).pm '." # These two are only used by install: targets INSTALLPRIVLIB = $Config{'installprivlib'} INSTALLARCHLIB = $Config{'installarchlib'} "; push @m, "\nshellflags = $Config{'shellflags'}" if $Config{'shellflags'}; push @m, q{ # Tools SHELL = /bin/sh CCCMD = `sh $(shellflags) $(ABSTOP)/cflags $@` XSUBPP = $(TOP)/ext/xsubpp # the following is a portable way to say mkdir -p MKPATH = $(PERL) -we '$$"="/"; foreach(split(/\//,$$ARGV[0])){ push(@p, $$_); next if -d "@p"; print "mkdir @p\n"; mkdir("@p",0777)||die "mkdir @p: $$!" } exit 0;' AUTOSPLITLIB = cd $(TOP); \ $(PERL) -Ilib -e 'use AutoSplit; $$AutoSplit::Maxlen=}.$att{AUTOSPLITMAXLEN}.q{; autosplit_lib_modules(@ARGV) ;' }; push @m, ' all :: config :: Makefile @$(MKPATH) $(AUTOEXT) install :: '; join('',@m); } sub post_constants{ ""; } sub subdir { my(@m); foreach $MakefilePL (<*/Makefile.PL>){ ($subdir=$MakefilePL) =~ s:/Makefile\.PL$:: ; push @m, " config :: \@cd $subdir ; \\ if test ! -f Makefile; then \\ test -f Makefile.PL && \$(PERL) -I\$(ABSTOP)/lib Makefile.PL TOP=\$(ABSTOP) ; \\ fi all :: cd $subdir ; \$(MAKE) config cd $subdir ; \$(MAKE) all "; } join('',@m); } sub co { ' .c.o: $(CCCMD) $(CCCDLFLAGS) $(DEFINE) -I$(TOP) $(INC) $*.c '; } sub force { ' # Phony target to force checking subdirectories. FORCE: '; } sub dynamic { ' all:: $(LINKTYPE) # Target for Dynamic Loading: dynamic:: $(INST_DYNAMIC) $(INST_PM) $(INST_BOOT) $(INST_DYNAMIC): $(OBJECT) @$(MKPATH) $(AUTOEXT) $(ARMAYBE) cr $(EXTMODNAME).a $(OBJECT) ld $(LDDLFLAGS) -o $@ $(LDTARGET) '.$att{'otherldflags'}.' $(STATLOADLIBS) $(BOOTSTRAP): $(BOOTDEP) $(PERL) -I$(TOP)/lib -e \'use ExtUtils::MakeMaker; &mkbootstrap("$(DYNALOADLIBS)");\' touch $(BOOTSTRAP) $(INST_BOOT): $(BOOTSTRAP) @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ '; } sub static { ' # Target for Static Loading: static:: $(INST_STATIC) $(INST_PM) $(INST_STATIC): $(OBJECT) ar cr $@ $(OBJECT) $(RANLIB) $@ echo $(EXTRALIBS) >> $(TOP)/ext.libs '; } sub c { ' $(BASEEXT).c: $(BASEEXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags $(PERL) $(XSUBPP) $(BASEEXT).xs >tmp mv tmp $@ '; } sub installpm { ' $(INST_PM): $(BASEEXT).pm @$(MKPATH) $(TOP)/lib/$(ROOTEXT) rm -f $@ cp $(BASEEXT).pm $@ @$(AUTOSPLITLIB) $(EXTMODNAME) '; } sub clean { ' clean:: rm -f *.o *.a mon.out core $(BASEEXT).c so_locations rm -f makefile Makefile $(BOOTSTRAP) $(BASEEXT).bso '.$att{'clean_files'}.' '; } sub realclean { ' realclean:: clean rm -f $(INST_DYNAMIC) $(INST_STATIC) $(INST_BOOT) rm -rf $(INST_PM) $(AUTOEXT) '.$att{'realclean_files'}.' purge: realclean '; } sub test { ' test: all $(FULLPERL) -I$(TOP)/lib -e \'use Test::Harness; runtests @ARGV;\' t/*.t '; } sub install { ' # used if installperl will not be installing it for you install:: all # not yet defined '; } sub distclean { my($tarflags) = $att{'distclean_tarflags'} || 'cvf'; ' distclean: clean rm -f Makefile *~ t/*~ cd ..; tar '.$tarflags.' "$(DISTNAME)-$(VERSION).tar" $(BASEEXT) cd ..; compress "$(DISTNAME)-$(VERSION).tar" '; } sub perldepend { ' $(OBJECT) : Makefile $(OBJECT) : $(TOP)/EXTERN.h $(OBJECT) : $(TOP)/INTERN.h $(OBJECT) : $(TOP)/XSUB.h $(OBJECT) : $(TOP)/av.h $(OBJECT) : $(TOP)/cop.h $(OBJECT) : $(TOP)/cv.h $(OBJECT) : $(TOP)/dosish.h $(OBJECT) : $(TOP)/embed.h $(OBJECT) : $(TOP)/form.h $(OBJECT) : $(TOP)/gv.h $(OBJECT) : $(TOP)/handy.h $(OBJECT) : $(TOP)/hv.h $(OBJECT) : $(TOP)/keywords.h $(OBJECT) : $(TOP)/mg.h $(OBJECT) : $(TOP)/op.h $(OBJECT) : $(TOP)/opcode.h $(OBJECT) : $(TOP)/patchlevel.h $(OBJECT) : $(TOP)/perl.h $(OBJECT) : $(TOP)/perly.h $(OBJECT) : $(TOP)/pp.h $(OBJECT) : $(TOP)/proto.h $(OBJECT) : $(TOP)/regcomp.h $(OBJECT) : $(TOP)/regexp.h $(OBJECT) : $(TOP)/scope.h $(OBJECT) : $(TOP)/sv.h $(OBJECT) : $(TOP)/unixish.h $(OBJECT) : $(TOP)/util.h $(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH $(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH $(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH Makefile: Makefile.PL $(PERL) -I$(TOP)/lib Makefile.PL '; } sub postamble{ ""; } sub finish { chmod 0644, "Makefile"; system("$Config{'eunicefix'} Makefile") unless $Config{'eunicefix'} eq ":"; } sub mkbootstrap { # # mkbootstrap, by: # # Andreas Koenig # Tim Bunce # Andy Dougherty # # This perl script attempts to make a bootstrap file for use by this # system's DynaLoader. It typically gets called from an extension # Makefile. # # There is no .bs file supplied with the extension. Instead a _BS # file which has code for the special cases, like posix for berkeley db # on the NeXT. # # This file will get parsed, and produce a maybe empty # @DynaLoader::dl_resolve_using array for the current architecture. # That will be extended by $dynaloadlibs, which was computed by Andy's # extliblist script. If this array still is empty, we do nothing, else # we write a .bs file with an @DynaLoader::dl_resolve_using array, but # without any `if's, because there is no longer a need to deal with # special cases. # # The _BS file can put some code into the generated .bs file by placing # it in $bscode. This is a handy 'escape' mechanism that may prove # useful in complex situations. # # If @DynaLoader::dl_resolve_using contains -L* or -l* entries then # mkbootstrap will automatically add a dl_findfile() call to the # generated .bs file. # my($self, @dynaloadlibs)=@_; print STDERR " dynaloadlibs=@dynaloadlibs" if $Verbose; require DynaLoader; # we need DynaLoader, if the *_BS gets interpreted import DynaLoader; # we don't say `use', so if DynaLoader is not # yet built MakeMaker works nonetheless except here &initialize unless defined $att{'perl'}; rename "$att{BASEEXT}.bs", "$att{BASEEXT}.bso"; if (-f "$att{BASEEXT}_BS"){ $_ = "$att{BASEEXT}_BS"; package DynaLoader; # execute code as if in DynaLoader local($osname, $dlsrc) = (); # avoid warnings ($osname, $dlsrc) = @Config{qw(osname dlsrc)}; $bscode = ""; unshift @INC, "."; require $_; } if ($Config{'dlsrc'} =~ /^dl_dld/){ package DynaLoader; push(@dl_resolve_using, dl_findfile('-lc')); } my(@all) = (@dynaloadlibs, @DynaLoader::dl_resolve_using); my($method) = ''; if (@all){ open BS, ">$att{BASEEXT}.bs" or die "Unable to open $att{BASEEXT}.bs: $!"; print STDOUT "Writing $att{BASEEXT}.bs\n"; print STDOUT " containing: @all" if $Verbose; print BS "# $att{BASEEXT} DynaLoader bootstrap file for $Config{'osname'} architecture.\n"; print BS "# Do not edit this file, changes will be lost.\n"; print BS "# This file was automatically generated by the\n"; print BS "# mkbootstrap routine in ExtUtils/MakeMaker.pm.\n"; print BS "\@DynaLoader::dl_resolve_using = "; if (" @all" =~ m/ -[lL]/){ print BS " dl_findfile(qw(\n @all\n ));\n"; }else{ print BS " qw(@all);\n"; } # write extra code if *_BS says so print BS $DynaLoader::bscode if $DynaLoader::bscode; print BS "1;\n"; close BS; } if ($Config{'dlsrc'} =~ /^dl_aix/){ open AIX, ">$att{BASEEXT}.exp"; print AIX "#!\nboot_$att{BASEEXT}\n"; close AIX; } } # the following makes AutoSplit happy (bug in perl5b3e) package ExtUtils::MakeMaker; 1; __END__ asename part of FULLEXT. May be just equal FULLEXT. # ROOTEXT = Directory part of FULLEXT. May be empty. EXTMODNAME = $att{EXTMODNAME} FULLEXT = $att{FULLEXT} BASEEperl5.000/lib/File/ 775 203 12 0 5650575705 7002 perl5.000/lib/File/Basename.pm 664 203 12 11002 5650421442 11136 package File::Basename; require 5.000; use Config; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(fileparse set_fileparse_fstype basename dirname); # fileparse_set_fstype() - specify OS-based rules used in future # calls to routines in this package # # Currently recognized values: VMS, MSDOS, MacOS # Any other name uses Unix-style rules sub fileparse_set_fstype { $Fileparse_fstype = $_[0]; } # fileparse() - parse file specification # # calling sequence: # ($filename,$prefix,$tail) = &basename_pat($filespec,@excludelist); # where $filespec is the file specification to be parsed, and # @excludelist is a list of patterns which should be removed # from the end of $filename. # $filename is the part of $filespec after $prefix (i.e. the # name of the file). The elements of @excludelist # are compared to $filename, and if an # $prefix is the path portion $filespec, up to and including # the end of the last directory name # $tail any characters removed from $filename because they # matched an element of @excludelist. # # fileparse() first removes the directory specification from $filespec, # according to the syntax of the OS (code is provided below to handle # VMS, Unix, MSDOS and MacOS; you can pick the one you want using # fileparse_set_fstype(), or you can accept the default, which is # based on the information in the %Config array). It then compares # each element of @excludelist to $filename, and if that element is a # suffix of $filename, it is removed from $filename and prepended to # $tail. By specifying the elements of @excludelist in the right order, # you can 'nibble back' $filename to extract the portion of interest # to you. # # For example, on a system running Unix, # ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7', # '\.book\d+'); # would yield $base == 'draft', # $path == '/virgil/aeneid', and # $tail == '.book7'. # Similarly, on a system running VMS, # ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh','\..*'); # would yield $name == 'Rhetoric'; # $dir == 'Doc_Root:[Help]', and # $type == '.Rnh'. # # Version 2.2 13-Oct-1994 Charles Bailey bailey@genetics.upenn.edu sub fileparse { my($fullname,@suffices) = @_; my($fstype) = $Fileparse_fstype; my($dirpath,$tail,$suffix,$idx); if ($fstype =~ /^VMS/i) { if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation else { ($dirpath,$basename) = ($fullname =~ /(.*[:>\]])?(.*)/); $dirpath = $ENV{'PATH'} unless $dirpath; } } if ($fstype =~ /^MSDOS/i) { ($dirpath,$basename) = ($fullname =~ /(.*\\)?(.*)/); $dirpath = '.' unless $dirpath; } elsif ($fstype =~ /^MAC/i) { ($dirpath,$basename) = ($fullname =~ /(.*:)?(.*)/); } else { # default to Unix ($dirpath,$basename) = ($fullname =~ m#(.*/)?(.*)#); $dirpath = '.' unless $dirpath; } if (@suffices) { foreach $suffix (@suffices) { if ($basename =~ /($suffix)$/) { $tail = $1 . $tail; $basename = $`; } } } ($basename,$dirpath,$tail); } # basename() - returns first element of list returned by fileparse() sub basename { (fileparse(@_))[0]; } # dirname() - returns device and directory portion of file specification # Behavior matches that of Unix dirname(1) exactly for Unix and MSDOS # filespecs. This differs from the second element of the list returned # by fileparse() in that the trailing '/' (Unix) or '\' (MSDOS) (and # the last directory name if the filespec ends in a '/' or '\'), is lost. sub dirname { my($basename,$dirname) = fileparse($_[0]); my($fstype) = $Fileparse_fstype; if ($fstype =~ /VMS/i) { if (m#/#) { $fstype = '' } else { return $dirname } } if ($fstype =~ /MacOS/i) { return $dirname } elsif ($fstype =~ /MSDOS/i) { if ( $dirname =~ /:\\$/) { return $dirname } chop $dirname; $dirname =~ s:[^/]+$:: unless $basename; $dirname = '.' unless $dirname; } else { if ( $dirname eq '/') { return $dirname } chop $dirname; $dirname =~ s:[^/]+$:: unless $basename; $dirname = '.' unless $dirname; } $dirname; } $Fileparse_fstype = $Config{'osname'}; 1; ckage File::Basename; require 5.000; use Config; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(fileparse set_fileparse_fstype basename dirname); # fileparse_set_fstype() - specify OS-based rules used in future # calls to routines in this package # # Currently recognized values: VMS, MSDOS, MacOS # Any other name uses Unix-style rules sub fileparse_set_fstype { $Fileparse_fstype = $_[0]; } # fileparse() - parse file specification # # calling sequence: # perl5.000/lib/File/CheckTree.pm 664 203 12 7443 5645374711 11270 package File::CheckTree; require 5.000; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(validate); # $RCSfile: validate.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:19 $ # The validate routine takes a single multiline string consisting of # lines containing a filename plus a file test to try on it. (The # file test may also be a 'cd', causing subsequent relative filenames # to be interpreted relative to that directory.) After the file test # you may put '|| die' to make it a fatal error if the file test fails. # The default is '|| warn'. The file test may optionally have a ! prepended # to test for the opposite condition. If you do a cd and then list some # relative filenames, you may want to indent them slightly for readability. # If you supply your own "die" or "warn" message, you can use $file to # interpolate the filename. # Filetests may be bunched: -rwx tests for all of -r, -w and -x. # Only the first failed test of the bunch will produce a warning. # The routine returns the number of warnings issued. # Usage: # use File::CheckTree; # $warnings += validate(' # /vmunix -e || die # /boot -e || die # /bin cd # csh -ex # csh !-ug # sh -ex # sh !-ug # /usr -d || warn "What happened to $file?\n" # '); sub validate { local($file,$test,$warnings,$oldwarnings); foreach $check (split(/\n/,$_[0])) { next if $check =~ /^#/; next if $check =~ /^$/; ($file,$test) = split(' ',$check,2); if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) { $testlist = $2; @testlist = split(//,$testlist); } else { @testlist = ('Z'); } $oldwarnings = $warnings; foreach $one (@testlist) { $this = $test; $this =~ s/(-\w\b)/$1 \$file/g; $this =~ s/-Z/-$one/; $this .= ' || warn' unless $this =~ /\|\|/; $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || valmess('$2','$1')/; $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g; eval $this; last if $warnings > $oldwarnings; } } $warnings; } sub valmess { local($disposition,$this) = @_; $file = $cwd . '/' . $file unless $file =~ m|^/|; if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) { $neg = $1; $tmp = $2; $tmp eq 'r' && ($mess = "$file is not readable by uid $>."); $tmp eq 'w' && ($mess = "$file is not writable by uid $>."); $tmp eq 'x' && ($mess = "$file is not executable by uid $>."); $tmp eq 'o' && ($mess = "$file is not owned by uid $>."); $tmp eq 'R' && ($mess = "$file is not readable by you."); $tmp eq 'W' && ($mess = "$file is not writable by you."); $tmp eq 'X' && ($mess = "$file is not executable by you."); $tmp eq 'O' && ($mess = "$file is not owned by you."); $tmp eq 'e' && ($mess = "$file does not exist."); $tmp eq 'z' && ($mess = "$file does not have zero size."); $tmp eq 's' && ($mess = "$file does not have non-zero size."); $tmp eq 'f' && ($mess = "$file is not a plain file."); $tmp eq 'd' && ($mess = "$file is not a directory."); $tmp eq 'l' && ($mess = "$file is not a symbolic link."); $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO)."); $tmp eq 'S' && ($mess = "$file is not a socket."); $tmp eq 'b' && ($mess = "$file is not a block special file."); $tmp eq 'c' && ($mess = "$file is not a character special file."); $tmp eq 'u' && ($mess = "$file does not have the setuid bit set."); $tmp eq 'g' && ($mess = "$file does not have the setgid bit set."); $tmp eq 'k' && ($mess = "$file does not have the sticky bit set."); $tmp eq 'T' && ($mess = "$file is not a text file."); $tmp eq 'B' && ($mess = "$file is not a binary file."); if ($neg eq '!') { $mess =~ s/ is not / should not be / || $mess =~ s/ does not / should not / || $mess =~ s/ not / /; } print stderr $mess,"\n"; } else { $this =~ s/\$file/'$file'/g; print stderr "Can't do $this.\n"; } if ($disposition eq 'die') { exit 1; } ++$warnings; } 1; ec ends in a '/' or '\'), is lost. sub dirname { my($basename,$dirname) = fileparse($_[0]); my($fstype) = $Fileparse_fstype; if ($fstype =~ /VMS/i) { if (m#/#) { $fstype = '' } else { returnperl5.000/lib/File/Find.pm 664 203 12 12030 5645374711 10317 package File::Find; require 5.000; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(find finddepth); # Usage: # use File::Find; # # find(\&wanted, '/foo','/bar'); # # sub wanted { ... } # where wanted does whatever you want. $dir contains the # current directory name, and $_ the current filename within # that directory. $name contains "$dir/$_". You are cd'ed # to $dir when the function is called. The function may # set $prune to prune the tree. # # This library is primarily for find2perl, which, when fed # # find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune # # spits out something like this # # sub wanted { # /^\.nfs.*$/ && # (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && # int(-M _) > 7 && # unlink($_) # || # ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && # $dev < 0 && # ($prune = 1); # } # # Set the variable $dont_use_nlink if you're using AFS, since AFS cheats. sub find { my $wanted = shift; chop($cwd = `pwd`); foreach $topdir (@_) { (($topdev,$topino,$topmode,$topnlink) = stat($topdir)) || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { ($dir,$_) = ($topdir,'.'); $name = $topdir; &$wanted; ($fixtopdir = $topdir) =~ s,/$,, ; &finddir($wanted,$fixtopdir,$topnlink); } else { warn "Can't cd to $topdir: $!\n"; } } else { unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) { ($dir,$_) = ('.', $topdir); } $name = $topdir; chdir $dir && &$wanted; } chdir $cwd; } } sub finddir { local($wanted,$dir,$nlink) = @_; local($dev,$ino,$mode,$subcount); local($name); # Get the list of files in the current directory. opendir(DIR,'.') || (warn "Can't open $dir: $!\n", return); local(@filenames) = readdir(DIR); closedir(DIR); if ($nlink == 2 && !$dont_use_nlink) { # This dir has no subdirectories. for (@filenames) { next if $_ eq '.'; next if $_ eq '..'; $name = "$dir/$_"; $nlink = 0; &$wanted; } } else { # This dir has subdirectories. $subcount = $nlink - 2; for (@filenames) { next if $_ eq '.'; next if $_ eq '..'; $nlink = $prune = 0; $name = "$dir/$_"; &$wanted; if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs? # Get link count and check for directoriness. ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink; if (-d _) { # It really is a directory, so do it recursively. if (!$prune && chdir $_) { &finddir($wanted,$name,$nlink); chdir '..'; } --$subcount; } } } } } # Usage: # use File::Find; # # finddepth(\&wanted, '/foo','/bar'); # # sub wanted { ... } # where wanted does whatever you want. $dir contains the # current directory name, and $_ the current filename within # that directory. $name contains "$dir/$_". You are cd'ed # to $dir when the function is called. The function may # set $prune to prune the tree. # # This library is primarily for find2perl, which, when fed # # find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune # # spits out something like this # # sub wanted { # /^\.nfs.*$/ && # (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && # int(-M _) > 7 && # unlink($_) # || # ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && # $dev < 0 && # ($prune = 1); # } sub finddepth { my $wanted = shift; chop($cwd = `pwd`); foreach $topdir (@_) { (($topdev,$topino,$topmode,$topnlink) = stat($topdir)) || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { ($fixtopdir = $topdir) =~ s,/$,, ; &finddepthdir($wanted,$fixtopdir,$topnlink); ($dir,$_) = ($fixtopdir,'.'); $name = $fixtopdir; &$wanted; } else { warn "Can't cd to $topdir: $!\n"; } } else { unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) { ($dir,$_) = ('.', $topdir); } chdir $dir && &$wanted; } chdir $cwd; } } sub finddepthdir { my($wanted,$dir,$nlink) = @_; my($dev,$ino,$mode,$subcount); my($name); # Get the list of files in the current directory. opendir(DIR,'.') || warn "Can't open $dir: $!\n"; my(@filenames) = readdir(DIR); closedir(DIR); if ($nlink == 2) { # This dir has no subdirectories. for (@filenames) { next if $_ eq '.'; next if $_ eq '..'; $name = "$dir/$_"; $nlink = 0; &$wanted; } } else { # This dir has subdirectories. $subcount = $nlink - 2; for (@filenames) { next if $_ eq '.'; next if $_ eq '..'; $nlink = $prune = 0; $name = "$dir/$_"; if ($subcount > 0) { # Seen all the subdirs? # Get link count and check for directoriness. ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink; if (-d _) { # It really is a directory, so do it recursively. if (!$prune && chdir $_) { &finddepthdir($wanted,$name,$nlink); chdir '..'; } --$subcount; } } &$wanted; } } } 1; ."); $tmp eq 'O' && ($mess = "$file is not owned by you."); $tmp eq 'e' && ($mess = "$file does not exist."); $tmp eq 'z' && ($mess = "$file does not have zero size."); $tmp eq 's' && ($mess = "$file does not have non-zero size."); $tmp eq 'f' && ($mess = "$file is not a plain file."); $tmp eq 'd' && ($mess = "$file is not a directory."); $tmp eq 'l' && ($mess = "$file is not a symbolic link."); $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO)."); $tmp eq 'S' && ($mperl5.000/lib/FileHandle.pm 664 203 12 7164 5645374712 10550 package FileHandle; # Note that some additional FileHandle methods are defined in POSIX.pm. require 5.000; use English; use Exporter; @ISA = qw(Exporter); @EXPORT = qw( print autoflush output_field_separator output_record_separator input_record_separator input_line_number format_page_number format_lines_per_page format_lines_left format_name format_top_name format_line_break_characters format_formfeed cacheout ); sub print { local($this) = shift; print $this @_; } sub autoflush { local($old) = select($_[0]); local($prev) = $OUTPUT_AUTOFLUSH; $OUTPUT_AUTOFLUSH = @_ > 1 ? $_[1] : 1; select($old); $prev; } sub output_field_separator { local($old) = select($_[0]); local($prev) = $OUTPUT_FIELD_SEPARATOR; $OUTPUT_FIELD_SEPARATOR = $_[1] if @_ > 1; select($old); $prev; } sub output_record_separator { local($old) = select($_[0]); local($prev) = $OUTPUT_RECORD_SEPARATOR; $OUTPUT_RECORD_SEPARATOR = $_[1] if @_ > 1; select($old); $prev; } sub input_record_separator { local($old) = select($_[0]); local($prev) = $INPUT_RECORD_SEPARATOR; $INPUT_RECORD_SEPARATOR = $_[1] if @_ > 1; select($old); $prev; } sub input_line_number { local($old) = select($_[0]); local($prev) = $INPUT_LINE_NUMBER; $INPUT_LINE_NUMBER = $_[1] if @_ > 1; select($old); $prev; } sub format_page_number { local($old) = select($_[0]); local($prev) = $FORMAT_PAGE_NUMBER; $FORMAT_PAGE_NUMBER = $_[1] if @_ > 1; select($old); $prev; } sub format_lines_per_page { local($old) = select($_[0]); local($prev) = $FORMAT_LINES_PER_PAGE; $FORMAT_LINES_PER_PAGE = $_[1] if @_ > 1; select($old); $prev; } sub format_lines_left { local($old) = select($_[0]); local($prev) = $FORMAT_LINES_LEFT; $FORMAT_LINES_LEFT = $_[1] if @_ > 1; select($old); $prev; } sub format_name { local($old) = select($_[0]); local($prev) = $FORMAT_NAME; $FORMAT_NAME = $_[1] if @_ > 1; select($old); $prev; } sub format_top_name { local($old) = select($_[0]); local($prev) = $FORMAT_TOP_NAME; $FORMAT_TOP_NAME = $_[1] if @_ > 1; select($old); $prev; } sub format_line_break_characters { local($old) = select($_[0]); local($prev) = $FORMAT_LINE_BREAK_CHARACTERS; $FORMAT_LINE_BREAK_CHARACTERS = $_[1] if @_ > 1; select($old); $prev; } sub format_formfeed { local($old) = select($_[0]); local($prev) = $FORMAT_FORMFEED; $FORMAT_FORMFEED = $_[1] if @_ > 1; select($old); $prev; } # --- cacheout functions --- # Open in their package. sub cacheout_open { my $pack = caller(1); open(*{$pack . '::' . $_[0]}, $_[1]); } sub cacheout_close { my $pack = caller(1); close(*{$pack . '::' . $_[0]}); } # But only this sub name is visible to them. sub cacheout { ($file) = @_; if (!$cacheout_maxopen){ if (open(PARAM,'/usr/include/sys/param.h')) { local($.); while () { $cacheout_maxopen = $1 - 4 if /^\s*#\s*define\s+NOFILE\s+(\d+)/; } close PARAM; } $cacheout_maxopen = 16 unless $cacheout_maxopen; } if (!$isopen{$file}) { if (++$cacheout_numopen > $cacheout_maxopen) { local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen); splice(@lru, $cacheout_maxopen / 3); $cacheout_numopen -= @lru; for (@lru) { &cacheout_close($_); delete $isopen{$_}; } } &cacheout_open($file, ($saw{$file}++ ? '>>' : '>') . $file) || croak("Can't create $file: $!"); } $isopen{$file} = ++$cacheout_seq; } $cacheout_seq = 0; $cacheout_numopen = 0; 1; stderr $mess,"\n"; } else { $this =~ s/\$file/'$file'/g; print stderr "Can't do $this.\n"; } if ($disposition eq 'die') { exit 1; } ++$warnings; } 1; ec ends in a '/' or '\'), is lost. sub dirname { my($basename,$dirname) = fileparse($_[0]); my($fstype) = $Fileparse_fstype; if ($fstype =~ /VMS/i) { if (m#/#) { $fstype = '' } else { returnperl5.000/lib/Shell.pm 664 203 12 1401 5640651271 7601 package Shell; sub import { my $self = shift; my ($callpack, $callfile, $callline) = caller; my @EXPORT; if (@_) { @EXPORT = @_; } else { @EXPORT = 'AUTOLOAD'; } foreach $sym (@EXPORT) { *{"${callpack}::$sym"} = \&{"Shell::$sym"}; } }; AUTOLOAD { my $cmd = $AUTOLOAD; $cmd =~ s/^.*:://; eval qq { sub $AUTOLOAD { if (\@_ < 2) { `$cmd \@_`; } else { open(SUBPROC, "-|") or exec '$cmd', \@_ or die "Can't exec $cmd: \$!\n"; if (wantarray) { my \@ret = ; close SUBPROC; # XXX Oughta use a destructor. \@ret; } else { local(\$/) = undef; my \$ret = ; close SUBPROC; \$ret; } } } }; goto &$AUTOLOAD; } 1;  hostname.pl¨ò importenv.plpl¼ò integer.pmlÌò‘less.pmÜò’look.plò“ newgetopt.plplò”open2.pl.pl(ò•open3.pl.pl<ò– perl5db.pllLò—pwd.plldò˜ shellwords.plperl5.000/lib/Getopt/ 775 203 12 0 5650575706 7366 perl5.000/lib/Getopt/Long.pm 664 203 12 35366 5645376164 10746 package Getopt::Long; require 5.000; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(GetOptions); # newgetopt.pl -- new options parsing # SCCS Status : @(#)@ newgetopt.pl 1.14 # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans # Last Modified On: Sat Feb 12 18:24:02 1994 # Update Count : 138 # Status : Okay ################ Introduction ################ # # This package implements an extended getopt function. This function adheres # to the new syntax (long option names, no bundling). # It tries to implement the better functionality of traditional, GNU and # POSIX getopt functions. # # This program is Copyright 1990,1994 by Johan Vromans. # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 2 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # If you do not have a copy of the GNU General Public License write to # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, # MA 02139, USA. ################ Description ################ # # Usage: # # require "newgetopt.pl"; # ...change configuration values, if needed... # $result = &NGetOpt (...option-descriptions...); # # Each description should designate a valid perl identifier, optionally # followed by an argument specifier. # # Values for argument specifiers are: # # option does not take an argument # ! option does not take an argument and may be negated # =s :s option takes a mandatory (=) or optional (:) string argument # =i :i option takes a mandatory (=) or optional (:) integer argument # =f :f option takes a mandatory (=) or optional (:) real number argument # # If option "name" is set, it will cause the perl variable $opt_name to # be set to the specified value. The calling program can use this # variable to detect whether the option has been set. Options that do # not take an argument will be set to 1 (one). # # Options that take an optional argument will be defined, but set to '' # if no actual argument has been supplied. # # If an "@" sign is appended to the argument specifier, the option is # treated as an array. Value(s) are not set, but pushed into array # @opt_name. # # Options that do not take a value may have an "!" argument spacifier to # indicate that they may be negated. E.g. "foo!" will allow -foo (which # sets $opt_foo to 1) and -nofoo (which will set $opt_foo to 0). # # The option name may actually be a list of option names, separated by # '|'s, e.g. "foo|bar|blech=s". In this example, options 'bar' and # 'blech' will set $opt_foo instead. # # Option names may be abbreviated to uniqueness, depending on # configuration variable $autoabbrev. # # Dashes in option names are allowed (e.g. pcc-struct-return) and will # be translated to underscores in the corresponding perl variable (e.g. # $opt_pcc_struct_return). Note that a lone dash "-" is considered an # option, corresponding perl identifier is $opt_ . # # A double dash "--" signals end of the options list. # # If the first option of the list consists of non-alphanumeric # characters only, it is interpreted as a generic option starter. # Everything starting with one of the characters from the starter will # be considered an option. # # The default values for the option starters are "-" (traditional), "--" # (POSIX) and "+" (GNU, being phased out). # # Options that start with "--" may have an argument appended, separated # with an "=", e.g. "--foo=bar". # # If configuration varaible $getopt_compat is set to a non-zero value, # options that start with "+" may also include their arguments, # e.g. "+foo=bar". # # A return status of 0 (false) indicates that the function detected # one or more errors. # ################ Some examples ################ # # If option "one:i" (i.e. takes an optional integer argument), then # the following situations are handled: # # -one -two -> $opt_one = '', -two is next option # -one -2 -> $opt_one = -2 # # Also, assume "foo=s" and "bar:s" : # # -bar -xxx -> $opt_bar = '', '-xxx' is next option # -foo -bar -> $opt_foo = '-bar' # -foo -- -> $opt_foo = '--' # # In GNU or POSIX format, option names and values can be combined: # # +foo=blech -> $opt_foo = 'blech' # --bar= -> $opt_bar = '' # --bar=-- -> $opt_bar = '--' # ################ Configuration values ################ # # $autoabbrev Allow option names to be abbreviated to uniqueness. # Default is 1 unless environment variable # POSIXLY_CORRECT has been set. # # $getopt_compat Allow '+' to start options. # Default is 1 unless environment variable # POSIXLY_CORRECT has been set. # # $option_start Regexp with option starters. # Default is (--|-) if environment variable # POSIXLY_CORRECT has been set, (--|-|\+) otherwise. # # $order Whether non-options are allowed to be mixed with # options. # Default is $REQUIRE_ORDER if environment variable # POSIXLY_CORRECT has been set, $PERMUTE otherwise. # # $ignorecase Ignore case when matching options. Default is 1. # # $debug Enable debugging output. Default is 0. ################ History ################ # # 12-Feb-1994 Johan Vromans # Added "!" for negation. # Released to the net. # # 26-Aug-1992 Johan Vromans # More POSIX/GNU compliance. # Lone dash and double-dash are now independent of the option prefix # that is used. # Make errors in NGetOpt parameters fatal. # Allow options to be mixed with arguments. # Check $ENV{"POSIXLY_CORRECT"} to suppress this. # Allow --foo=bar and +foo=bar (but not -foo=bar). # Allow options to be abbreviated to minimum needed for uniqueness. # (Controlled by configuration variable $autoabbrev.) # Allow alias names for options (e.g. "foo|bar=s"). # Allow "-" in option names (e.g. --pcc-struct-return). Dashes are # translated to "_" to form valid perl identifiers # (e.g. $opt_pcc_struct_return). # # 2-Jun-1992 Johan Vromans # Do not use //o to allow multiple NGetOpt calls with different delimeters. # Prevent typeless option from using previous $array state. # Prevent empty option from being eaten as a (negative) number. # # 25-May-1992 Johan Vromans # Add array options. "foo=s@" will return an array @opt_foo that # contains all values that were supplied. E.g. "-foo one -foo -two" will # return @opt_foo = ("one", "-two"); # Correct bug in handling options that allow for a argument when followed # by another option. # # 4-May-1992 Johan Vromans # Add $ignorecase to match options in either case. # Allow '' option. # # 19-Mar-1992 Johan Vromans # Allow require from packages. # NGetOpt is now defined in the package that requires it. # @ARGV and $opt_... are taken from the package that calls it. # Use standard (?) option prefixes: -, -- and +. # # 20-Sep-1990 Johan Vromans # Set options w/o argument to 1. # Correct the dreadful semicolon/require bug. ################ Configuration Section ################ { # Values for $order. See GNU getopt.c for details. $REQUIRE_ORDER = 0; $PERMUTE = 1; $RETURN_IN_ORDER = 2; # Handle POSIX compliancy. if ( defined $ENV{"POSIXLY_CORRECT"} ) { $autoabbrev = 0; # no automatic abbrev of options (???) $getopt_compat = 0; # disallow '+' to start options $option_start = "(--|-)"; $order = $REQUIRE_ORDER; } else { $autoabbrev = 1; # automatic abbrev of options $getopt_compat = 1; # allow '+' to start options $option_start = "(--|-|\\+)"; $order = $PERMUTE; } # Other configurable settings. $debug = 0; # for debugging $ignorecase = 1; # ignore case when matching options $argv_end = "--"; # don't change this! } ################ Subroutines ################ sub GetOptions { @optionlist = @_; #'; local ($[) = 0; local ($genprefix) = $option_start; local ($argend) = $argv_end; local ($error) = 0; local ($opt, $optx, $arg, $type, $mand, %opctl); local ($pkg) = (caller)[0]; local ($optarg); local (%aliases); local (@ret) = (); print STDERR "NGetOpt 1.14 -- called from $pkg\n" if $debug; # See if the first element of the optionlist contains option # starter characters. if ( $optionlist[0] =~ /^\W+$/ ) { $genprefix = shift (@optionlist); # Turn into regexp. $genprefix =~ s/(\W)/\\$1/g; $genprefix = "[" . $genprefix . "]"; } # Verify correctness of optionlist. %opctl = (); foreach $opt ( @optionlist ) { $opt =~ tr/A-Z/a-z/ if $ignorecase; if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) { die ("Error in option spec: \"", $opt, "\"\n"); $error++; next; } local ($o, $c, $a) = ($1, $2); if ( ! defined $o ) { $opctl{''} = defined $c ? $c : ''; } else { # Handle alias names foreach ( split (/\|/, $o)) { if ( defined $c && $c eq '!' ) { $opctl{"no$_"} = $c; $c = ''; } $opctl{$_} = defined $c ? $c : ''; if ( defined $a ) { # Note alias. $aliases{$_} = $a; } else { # Set primary name. $a = $_; } } } } @opctl = sort(keys (%opctl)) if $autoabbrev; return 0 if $error; if ( $debug ) { local ($arrow, $k, $v); $arrow = "=> "; while ( ($k,$v) = each(%opctl) ) { print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n"); $arrow = " "; } } # Process argument list while ( $#ARGV >= 0 ) { # >>> See also the continue block <<< #### Get next argument #### $opt = shift (@ARGV); print STDERR ("=> option \"", $opt, "\"\n") if $debug; $arg = undef; $optarg = undef; $array = 0; #### Determine what we have #### # Double dash is option list terminator. if ( $opt eq $argend ) { unshift (@ret, @ARGV) if $order == $PERMUTE; return ($error == 0); } elsif ( $opt =~ /^$genprefix/ ) { # Looks like an option. $opt = $'; # option name (w/o prefix) # If it is a long opt, it may include the value. if (($+ eq "--" || ($getopt_compat && $+ eq "+")) && $opt =~ /^([^=]+)=/ ) { $opt = $1; $optarg = $'; print STDERR ("=> option \"", $opt, "\", optarg = \"$optarg\"\n") if $debug; } } # Not an option. Save it if we may permute... elsif ( $order == $PERMUTE ) { push (@ret, $opt); next; } # ...otherwise, terminate. else { # Push back and exit. unshift (@ARGV, $opt); return ($error == 0); } #### Look it up ### $opt =~ tr/A-Z/a-z/ if $ignorecase; local ($tryopt) = $opt; if ( $autoabbrev ) { local ($pat, @hits); # Turn option name into pattern. ($pat = $opt) =~ s/(\W)/\\$1/g; # Look up in option names. @hits = grep (/^$pat/, @opctl); print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ", "out of ", 0+@opctl, "\n") if $debug; # Check for ambiguous results. unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) { print STDERR ("Option ", $opt, " is ambiguous (", join(", ", @hits), ")\n"); $error++; next; } # Complete the option name, if appropriate. if ( @hits == 1 && $hits[0] ne $opt ) { $tryopt = $hits[0]; print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n") if $debug; } } unless ( defined ( $type = $opctl{$tryopt} ) ) { print STDERR ("Unknown option: ", $opt, "\n"); $error++; next; } $opt = $tryopt; print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug; #### Determine argument status #### # If it is an option w/o argument, we're almost finished with it. if ( $type eq '' || $type eq '!' ) { if ( defined $optarg ) { print STDERR ("Option ", $opt, " does not take an argument\n"); $error++; } elsif ( $type eq '' ) { $arg = 1; # supply explicit value } else { substr ($opt, 0, 2) = ''; # strip NO prefix $arg = 0; # supply explicit value } next; } # Get mandatory status and type info. ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/; # Check if there is an option argument available. if ( defined $optarg ? ($optarg eq '') : ($#ARGV < 0) ) { # Complain if this option needs an argument. if ( $mand eq "=" ) { print STDERR ("Option ", $opt, " requires an argument\n"); $error++; } if ( $mand eq ":" ) { $arg = $type eq "s" ? '' : 0; } next; } # Get (possibly optional) argument. $arg = defined $optarg ? $optarg : shift (@ARGV); #### Check if the argument is valid for this option #### if ( $type eq "s" ) { # string # A mandatory string takes anything. next if $mand eq "="; # An optional string takes almost anything. next if defined $optarg; next if $arg eq "-"; # Check for option or option list terminator. if ($arg eq $argend || $arg =~ /^$genprefix.+/) { # Push back. unshift (@ARGV, $arg); # Supply empty value. $arg = ''; } next; } if ( $type eq "n" || $type eq "i" ) { # numeric/integer if ( $arg !~ /^-?[0-9]+$/ ) { if ( defined $optarg || $mand eq "=" ) { print STDERR ("Value \"", $arg, "\" invalid for option ", $opt, " (number expected)\n"); $error++; undef $arg; # don't assign it } else { # Push back. unshift (@ARGV, $arg); # Supply default value. $arg = 0; } } next; } if ( $type eq "f" ) { # fixed real number, int is also ok if ( $arg !~ /^-?[0-9.]+$/ ) { if ( defined $optarg || $mand eq "=" ) { print STDERR ("Value \"", $arg, "\" invalid for option ", $opt, " (real number expected)\n"); $error++; undef $arg; # don't assign it } else { # Push back. unshift (@ARGV, $arg); # Supply default value. $arg = 0.0; } } next; } die ("NGetOpt internal error (Can't happen)\n"); } continue { if ( defined $arg ) { $opt = $aliases{$opt} if defined $aliases{$opt}; # Make sure a valid perl identifier results. $opt =~ s/\W/_/g; if ( $array ) { print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n") if $debug; eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);"); } else { print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n") if $debug; eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;"); } } } if ( $order == $PERMUTE && @ret > 0 ) { unshift (@ARGV, @ret); } return ($error == 0); } ################ Package return ################ 1; es that were supplied. E.g. "-foo one -foo -two" will # return @opt_foo = ("one", "-two"); # Correct bug in handling options that allow for a argument when followed # by another option. # # 4-May-1992 Johan Vromans # Add $ignorecase to match options inperl5.000/lib/Getopt/Std.pm 664 203 12 4377 5645374713 10555 package Getopt::Std; require 5.000; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(getopt getopts); # $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $ # Process single-character switches with switch clustering. Pass one argument # which is a string containing all switches that take an argument. For each # switch found, sets $opt_x (where x is the switch name) to the value of the # argument, or 1 if no argument. Switches which take an argument don't care # whether there is a space between the switch and the argument. # Usage: # getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. sub getopt { local($argumentative) = @_; local($_,$first,$rest); local $Exporter::ExportLevel; while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { ($first,$rest) = ($1,$2); if (index($argumentative,$first) >= 0) { if ($rest ne '') { shift(@ARGV); } else { shift(@ARGV); $rest = shift(@ARGV); } eval "\$opt_$first = \$rest;"; push( @EXPORT, "\$opt_$first" ); } else { eval "\$opt_$first = 1;"; push( @EXPORT, "\$opt_$first" ); if ($rest ne '') { $ARGV[0] = "-$rest"; } else { shift(@ARGV); } } } $Exporter::ExportLevel++; import Getopt::Std; } # Usage: # getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a # # side effect. sub getopts { local($argumentative) = @_; local(@args,$_,$first,$rest); local($errs) = 0; local $Exporter::ExportLevel; @args = split( / */, $argumentative ); while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { ($first,$rest) = ($1,$2); $pos = index($argumentative,$first); if($pos >= 0) { if($args[$pos+1] eq ':') { shift(@ARGV); if($rest eq '') { ++$errs unless @ARGV; $rest = shift(@ARGV); } eval "\$opt_$first = \$rest;"; push( @EXPORT, "\$opt_$first" ); } else { eval "\$opt_$first = 1"; push( @EXPORT, "\$opt_$first" ); if($rest eq '') { shift(@ARGV); } else { $ARGV[0] = "-$rest"; } } } else { print STDERR "Unknown option: $first\n"; ++$errs; if($rest ne '') { $ARGV[0] = "-$rest"; } else { shift(@ARGV); } } } $Exporter::ExportLevel++; import Getopt::Std; $errs == 0; } 1; 0; local ($genprefix) = $option_start; local ($argend) = $argv_end; local ($error) = 0; local ($opt, $optx, $arg, $type, $mand, %opctl); local ($pkg) = (caller)[0]; local ($optarg); local (%aliases); local (@ret) = (); pperl5.000/lib/I18N/ 775 203 12 0 5650575706 6603 perl5.000/lib/I18N/Collate.pm 664 203 12 4371 5645374714 10616 package I18N::Collate; # Collate.pm # # Author: Jarkko Hietaniemi # Helsinki University of Technology, Finland # # Acks: Guy Decoux understood # overloading magic much deeper than I and told # how to cut the size of this code by more than half. # (my first version did overload all of lt gt eq le ge cmp) # # Purpose: compare 8-bit scalar data according to the current locale # # Requirements: Perl5 POSIX::setlocale() and POSIX::strxfrm() # # Exports: setlocale 1) # collate_xfrm 2) # # Overloads: cmp # 3) # # Usage: use Collate; # setlocale(&LC_COLLATE, 'locale-of-your-choice'); # 4) # $s1 = new Collate "scalar_data_1"; # $s2 = new Collate "scalar_data_2"; # # now you can compare $s1 and $s2: $s1 le $s2 # to extract the data itself, you need to deref: $$s1 # # Notes: # 1) this uses POSIX::setlocale # 2) the basic collation conversion is done by strxfrm() which # terminates at NUL characters being a decent C routine. # collate_xfrm handles embedded NUL characters gracefully. # 3) due to cmp and overload magic, lt le eq ge gt work also # 4) the available locales depend on your operating system; # try whether "locale -a" shows them or the more direct # approach "ls /usr/lib/nls/loc" or "ls /usr/lib/nls". # The locale names are probably something like # 'xx_XX.(ISO)?8859-N'. # # Updated: 19940913 1341 GMT # # --- use POSIX qw(strxfrm LC_COLLATE); require Exporter; @ISA = qw(Exporter); @EXPORT = qw(collate_xfrm setlocale LC_COLLATE); @EXPORT_OK = qw(); %OVERLOAD = qw( fallback 1 cmp collate_cmp ); sub new { my $new = $_[1]; bless \$new } sub setlocale { my ($category, $locale) = @_[0,1]; POSIX::setlocale($category, $locale) if (defined $category); # the current $LOCALE $LOCALE = $locale || $ENV{'LC_COLLATE'} || $ENV{'LC_ALL'} || ''; } sub C { my $s = ${$_[0]}; $C->{$LOCALE}->{$s} = collate_xfrm($s) unless (defined $C->{$LOCALE}->{$s}); # cache when met $C->{$LOCALE}->{$s}; } sub collate_xfrm { my $s = $_[0]; my $x = ''; for (split(/(\000+)/, $s)) { $x .= (/^\000/) ? $_ : strxfrm("$_\000"); } $x; } sub collate_cmp { &C($_[0]) cmp &C($_[1]); } # init $LOCALE &I18N::Collate::setlocale(); 1; # keep require happy 1; 0; local ($genprefix) = $option_start; local ($argend) = $argv_end; local ($error) = 0; local ($opt, $optx, $arg, $type, $mand, %opctl); local ($pkg) = (caller)[0]; local ($optarg); local (%aliases); local (@ret) = (); pperl5.000/lib/IPC/ 775 203 12 0 5650575706 6537 perl5.000/lib/IPC/Open2.pm 664 203 12 3157 5645374714 10153 package IPC::Open2; require 5.000; require Exporter; use Carp; @ISA = qw(Exporter); @EXPORT = qw(open2); # &open2: tom christiansen, # # usage: $pid = open2('rdr', 'wtr', 'some cmd and args'); # or $pid = open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args'); # # spawn the given $cmd and connect $rdr for # reading and $wtr for writing. return pid # of child, or 0 on failure. # # WARNING: this is dangerous, as you may block forever # unless you are very careful. # # $wtr is left unbuffered. # # abort program if # rdr or wtr are null # pipe or fork or exec fails $fh = 'FHOPEN000'; # package static in case called more than once sub open2 { local($kidpid); local($dad_rdr, $dad_wtr, @cmd) = @_; $dad_rdr ne '' || croak "open2: rdr should not be null"; $dad_wtr ne '' || croak "open2: wtr should not be null"; # force unqualified filehandles into callers' package local($package) = caller; $dad_rdr =~ s/^[^']+$/$package'$&/; $dad_wtr =~ s/^[^']+$/$package'$&/; local($kid_rdr) = ++$fh; local($kid_wtr) = ++$fh; pipe($dad_rdr, $kid_wtr) || croak "open2: pipe 1 failed: $!"; pipe($kid_rdr, $dad_wtr) || croak "open2: pipe 2 failed: $!"; if (($kidpid = fork) < 0) { croak "open2: fork failed: $!"; } elsif ($kidpid == 0) { close $dad_rdr; close $dad_wtr; open(STDIN, "<&$kid_rdr"); open(STDOUT, ">&$kid_wtr"); warn "execing @cmd\n" if $debug; exec @cmd; croak "open2: exec of @cmd failed"; } close $kid_rdr; close $kid_wtr; select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe $kidpid; } 1; # so require is happy = $_[1]; bless \$new } sub setlocale { my ($category, $locale) = @_[0,1]; POSIX::setlocale($category, $locale) if (defined $category); # the current $LOCALE $LOCALE = $locale || $ENV{'LC_COLLATE'} || $ENV{'LC_ALL'} || ''; } sub C { my $s = ${$_[0]}; $C->{$LOCALE}->{$s} = collate_xfrm($s) unless (defined $C->{$LOCALE}->{$s}); # cache when met $C->{$LOCALE}->{$s}; } sub collate_xperl5.000/lib/IPC/Open3.pm 664 203 12 6054 5645374714 10153 package IPC::Open3; require 5.000; require Exporter; use Carp; @ISA = qw(Exporter); @EXPORT = qw(open3); # &open3: Marc Horowitz # derived mostly from &open2 by tom christiansen, # # $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $ # # usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...); # # spawn the given $cmd and connect rdr for # reading, wtr for writing, and err for errors. # if err is '', or the same as rdr, then stdout and # stderr of the child are on the same fh. returns pid # of child, or 0 on failure. # if wtr begins with '>&', then wtr will be closed in the parent, and # the child will read from it directly. if rdr or err begins with # '>&', then the child will send output directly to that fd. In both # cases, there will be a dup() instead of a pipe() made. # WARNING: this is dangerous, as you may block forever # unless you are very careful. # # $wtr is left unbuffered. # # abort program if # rdr or wtr are null # pipe or fork or exec fails $fh = 'FHOPEN000'; # package static in case called more than once sub open3 { local($kidpid); local($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_; local($dup_wtr, $dup_rdr, $dup_err); $dad_wtr || croak "open3: wtr should not be null"; $dad_rdr || croak "open3: rdr should not be null"; $dad_err = $dad_rdr if ($dad_err eq ''); $dup_wtr = ($dad_wtr =~ s/^\>\&//); $dup_rdr = ($dad_rdr =~ s/^\>\&//); $dup_err = ($dad_err =~ s/^\>\&//); # force unqualified filehandles into callers' package local($package) = caller; $dad_wtr =~ s/^[^']+$/$package'$&/; $dad_rdr =~ s/^[^']+$/$package'$&/; $dad_err =~ s/^[^']+$/$package'$&/; local($kid_rdr) = ++$fh; local($kid_wtr) = ++$fh; local($kid_err) = ++$fh; if (!$dup_wtr) { pipe($kid_rdr, $dad_wtr) || croak "open3: pipe 1 (stdin) failed: $!"; } if (!$dup_rdr) { pipe($dad_rdr, $kid_wtr) || croak "open3: pipe 2 (stdout) failed: $!"; } if ($dad_err ne $dad_rdr && !$dup_err) { pipe($dad_err, $kid_err) || croak "open3: pipe 3 (stderr) failed: $!"; } if (($kidpid = fork) < 0) { croak "open2: fork failed: $!"; } elsif ($kidpid == 0) { if ($dup_wtr) { open(STDIN, ">&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr)); } else { close($dad_wtr); open(STDIN, ">&$kid_rdr"); } if ($dup_rdr) { open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr)); } else { close($dad_rdr); open(STDOUT, ">&$kid_wtr"); } if ($dad_rdr ne $dad_err) { if ($dup_err) { open(STDERR, ">&$dad_err") if (fileno(STDERR) != fileno($dad_err)); } else { close($dad_err); open(STDERR, ">&$kid_err"); } } else { open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT)); } local($")=(" "); exec @cmd; croak "open2: exec of @cmd failed"; } close $kid_rdr; close $kid_wtr; close $kid_err; if ($dup_wtr) { close($dad_wtr); } select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe $kidpid; } 1; # so require is happy ; $error++; next; } local ($o, $c, $a) = ($1, $2); if ( ! defined $o ) { $opctl{''} = defined $c ? $c : ''; } else { # Handle alias names foreach ( split (/\|/, $o)) { if ( defined $c && $c eq '!' ) { $opctl{"no$_"} = $c; $c = ''; } $opctl{$_} = defined $c ? $c : ''; if ( defined $a ) { # Note alias. $aliases{$_} = $a; } else { # Set primary name. $a = $_; } } } } @opctlperl5.000/lib/Math/ 775 203 12 0 5650575707 7016 perl5.000/lib/Math/BigInt.pm 664 203 12 22614 5646163457 10642 package Math::BigInt; %OVERLOAD = ( # Anonymous subroutines: '+' => sub {new BigInt &badd}, '-' => sub {new BigInt $_[2]? bsub($_[1],${$_[0]}) : bsub(${$_[0]},$_[1])}, '<=>' => sub {new BigInt $_[2]? bcmp($_[1],${$_[0]}) : bcmp(${$_[0]},$_[1])}, 'cmp' => sub {new BigInt $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])}, '*' => sub {new BigInt &bmul}, '/' => sub {new BigInt $_[2]? scalar bdiv($_[1],${$_[0]}) : scalar bdiv(${$_[0]},$_[1])}, '%' => sub {new BigInt $_[2]? bmod($_[1],${$_[0]}) : bmod(${$_[0]},$_[1])}, '**' => sub {new BigInt $_[2]? bpow($_[1],${$_[0]}) : bpow(${$_[0]},$_[1])}, 'neg' => sub {new BigInt &bneg}, 'abs' => sub {new BigInt &babs}, qw( "" stringify 0+ numify) # Order of arguments unsignificant ); sub new { my $foo = bnorm($_[1]); die "Not a number initialized to BigInt" if $foo eq "NaN"; bless \$foo; } sub stringify { "${$_[0]}" } sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead # comparing to direct compilation based on # stringify # arbitrary size integer math package # # by Mark Biggar # # Canonical Big integer value are strings of the form # /^[+-]\d+$/ with leading zeros suppressed # Input values to these routines may be strings of the form # /^\s*[+-]?[\d\s]+$/. # Examples: # '+0' canonical zero value # ' -123 123 123' canonical value '-123123123' # '1 23 456 7890' canonical value '+1234567890' # Output values always always in canonical form # # Actual math is done in an internal format consisting of an array # whose first element is the sign (/^[+-]$/) and whose remaining # elements are base 100000 digits with the least significant digit first. # The string 'NaN' is used to represent the result when input arguments # are not numbers, as well as the result of dividing by zero # # routines provided are: # # bneg(BINT) return BINT negation # babs(BINT) return BINT absolute value # bcmp(BINT,BINT) return CODE compare numbers (undef,<0,=0,>0) # badd(BINT,BINT) return BINT addition # bsub(BINT,BINT) return BINT subtraction # bmul(BINT,BINT) return BINT multiplication # bdiv(BINT,BINT) return (BINT,BINT) division (quo,rem) just quo if scalar # bmod(BINT,BINT) return BINT modulus # bgcd(BINT,BINT) return BINT greatest common divisor # bnorm(BINT) return BINT normalization # $zero = 0; # normalize string form of number. Strip leading zeros. Strip any # white space and add a sign, if missing. # Strings that are not numbers result the value 'NaN'. sub bnorm { #(num_str) return num_str local($_) = @_; s/\s+//g; # strip white space if (s/^([+-]?)0*(\d+)$/$1$2/) { # test if number substr($_,$[,0) = '+' unless $1; # Add missing sign s/^-0/+0/; $_; } else { 'NaN'; } } # Convert a number from string format to internal base 100000 format. # Assumes normalized value as input. sub internal { #(num_str) return int_num_array local($d) = @_; ($is,$il) = (substr($d,$[,1),length($d)-2); substr($d,$[,1) = ''; ($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d))); } # Convert a number from internal base 100000 format to string format. # This routine scribbles all over input array. sub external { #(int_num_array) return num_str $es = shift; grep($_ > 9999 || ($_ = substr('0000'.$_,-5)), @_); # zero pad &bnorm(join('', $es, reverse(@_))); # reverse concat and normalize } # Negate input value. sub bneg { #(num_str) return num_str local($_) = &bnorm(@_); vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0'; s/^H/N/; $_; } # Returns the absolute value of the input. sub babs { #(num_str) return num_str &abs(&bnorm(@_)); } sub abs { # post-normalized abs for internal use local($_) = @_; s/^-/+/; $_; } # Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort) sub bcmp { #(num_str, num_str) return cond_code local($x,$y) = (&bnorm($_[$[]),&bnorm($_[$[+1])); if ($x eq 'NaN') { undef; } elsif ($y eq 'NaN') { undef; } else { &cmp($x,$y); } } sub cmp { # post-normalized compare for internal use local($cx, $cy) = @_; $cx cmp $cy && ( ord($cy) <=> ord($cx) || ($cx cmp ',') * (length($cy) <=> length($cx) || $cy cmp $cx) ); } sub badd { #(num_str, num_str) return num_str local(*x, *y); ($x, $y) = (&bnorm($_[$[]),&bnorm($_[$[+1])); if ($x eq 'NaN') { 'NaN'; } elsif ($y eq 'NaN') { 'NaN'; } else { @x = &internal($x); # convert to internal form @y = &internal($y); local($sx, $sy) = (shift @x, shift @y); # get signs if ($sx eq $sy) { &external($sx, &add(*x, *y)); # if same sign add } else { ($x, $y) = (&abs($x),&abs($y)); # make abs if (&cmp($y,$x) > 0) { &external($sy, &sub(*y, *x)); } else { &external($sx, &sub(*x, *y)); } } } } sub bsub { #(num_str, num_str) return num_str &badd($_[$[],&bneg($_[$[+1])); } # GCD -- Euclids algorithm Knuth Vol 2 pg 296 sub bgcd { #(num_str, num_str) return num_str local($x,$y) = (&bnorm($_[$[]),&bnorm($_[$[+1])); if ($x eq 'NaN' || $y eq 'NaN') { 'NaN'; } else { ($x, $y) = ($y,&bmod($x,$y)) while $y ne '+0'; $x; } } # routine to add two base 1e5 numbers # stolen from Knuth Vol 2 Algorithm A pg 231 # there are separate routines to add and sub as per Kunth pg 233 sub add { #(int_num_array, int_num_array) return int_num_array local(*x, *y) = @_; $car = 0; for $x (@x) { last unless @y || $car; $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5); } for $y (@y) { last unless $car; $y -= 1e5 if $car = (($y += $car) >= 1e5); } (@x, @y, $car); } # subtract base 1e5 numbers -- stolen from Knuth Vol 2 pg 232, $x > $y sub sub { #(int_num_array, int_num_array) return int_num_array local(*sx, *sy) = @_; $bar = 0; for $sx (@sx) { last unless @y || $bar; $sx += 1e5 if $bar = (($sx -= shift(@sy) + $bar) < 0); } @sx; } # multiply two numbers -- stolen from Knuth Vol 2 pg 233 sub bmul { #(num_str, num_str) return num_str local(*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1])); if ($x eq 'NaN') { 'NaN'; } elsif ($y eq 'NaN') { 'NaN'; } else { @x = &internal($x); @y = &internal($y); &external(&mul(*x,*y)); } } # multiply two numbers in internal representation # destroys the arguments, supposes that two arguments are different sub mul { #(*int_num_array, *int_num_array) return int_num_array local(*x, *y) = (shift, shift); local($signr) = (shift @x ne shift @y) ? '-' : '+'; @prod = (); for $x (@x) { ($car, $cty) = (0, $[); for $y (@y) { $prod = $x * $y + $prod[$cty] + $car; $prod[$cty++] = $prod - ($car = int($prod * 1e-5)) * 1e5; } $prod[$cty] += $car if $car; $x = shift @prod; } ($signr, @x, @prod); } # modulus sub bmod { #(num_str, num_str) return num_str (&bdiv(@_))[$[+1]; } sub bdiv { #(dividend: num_str, divisor: num_str) return num_str local (*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1])); return wantarray ? ('NaN','NaN') : 'NaN' if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0'); return wantarray ? ('+0',$x) : '+0' if (&cmp(&abs($x),&abs($y)) < 0); @x = &internal($x); @y = &internal($y); $srem = $y[$[]; $sr = (shift @x ne shift @y) ? '-' : '+'; $car = $bar = $prd = 0; if (($dd = int(1e5/($y[$#y]+1))) != 1) { for $x (@x) { $x = $x * $dd + $car; $x -= ($car = int($x * 1e-5)) * 1e5; } push(@x, $car); $car = 0; for $y (@y) { $y = $y * $dd + $car; $y -= ($car = int($y * 1e-5)) * 1e5; } } else { push(@x, 0); } @q = (); ($v2,$v1) = @y[-2,-1]; while ($#x > $#y) { ($u2,$u1,$u0) = @x[-3..-1]; $q = (($u0 == $v1) ? 99999 : int(($u0*1e5+$u1)/$v1)); --$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*1e5+$u2); if ($q) { ($car, $bar) = (0,0); for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) { $prd = $q * $y[$y] + $car; $prd -= ($car = int($prd * 1e-5)) * 1e5; $x[$x] += 1e5 if ($bar = (($x[$x] -= $prd + $bar) < 0)); } if ($x[$#x] < $car + $bar) { $car = 0; --$q; for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) { $x[$x] -= 1e5 if ($car = (($x[$x] += $y[$y] + $car) > 1e5)); } } } pop(@x); unshift(@q, $q); } if (wantarray) { @d = (); if ($dd != 1) { $car = 0; for $x (reverse @x) { $prd = $car * 1e5 + $x; $car = $prd - ($tmp = int($prd / $dd)) * $dd; unshift(@d, $tmp); } } else { @d = @x; } (&external($sr, @q), &external($srem, @d, $zero)); } else { &external($sr, @q); } } # compute power of two numbers -- stolen from Knuth Vol 2 pg 233 sub bpow { #(num_str, num_str) return num_str local(*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1])); if ($x eq 'NaN') { 'NaN'; } elsif ($y eq 'NaN') { 'NaN'; } elsif ($x eq '+1') { '+1'; } elsif ($x eq '-1') { &bmod($x,2) ? '-1': '+1'; } elsif ($y =~ /^-/) { 'NaN'; } elsif ($x eq '+0' && $y eq '+0') { 'NaN'; } else { @x = &internal($x); local(@pow2)=@x; local(@pow)=&internal("+1"); local($y1,$res,@tmp1,@tmp2)=(1); # need tmp to send to mul while ($y ne '+0') { ($y,$res)=&bdiv($y,2); if ($res ne '+0') {@tmp=@pow2; @pow=&mul(*pow,*tmp);} if ($y ne '+0') {@tmp=@pow2;@pow2=&mul(*pow2,*tmp);} } &external(@pow); } } 1; canonical value '-123123123' # '1 23 456 7890' canonical value '+1234567890' # Output valueperl5.000/lib/Math/BigFloat.pm 664 203 12 17711 5650575145 11153 package Math::BigFloat; use Math::BigInt; use Exporter; # just for use to be happy @ISA = (Exporter); %OVERLOAD = ( # Anonymous subroutines: '+' => sub {new BigFloat &fadd}, '-' => sub {new BigFloat $_[2]? fsub($_[1],${$_[0]}) : fsub(${$_[0]},$_[1])}, '<=>' => sub {new BigFloat $_[2]? fcmp($_[1],${$_[0]}) : fcmp(${$_[0]},$_[1])}, 'cmp' => sub {new BigFloat $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])}, '*' => sub {new BigFloat &fmul}, '/' => sub {new BigFloat $_[2]? scalar fdiv($_[1],${$_[0]}) : scalar fdiv(${$_[0]},$_[1])}, 'neg' => sub {new BigFloat &fneg}, 'abs' => sub {new BigFloat &fabs}, qw( "" stringify 0+ numify) # Order of arguments unsignificant ); sub new { my $foo = fnorm($_[1]); panic("Not a number initialized to BigFloat") if $foo eq "NaN"; bless \$foo; } sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead # comparing to direct compilation based on # stringify sub stringify { my $n = ${$_[0]}; $n =~ s/^\+//; $n =~ s/E//; $n =~ s/([-+]\d+)$//; my $e = $1; my $ln = length($n); if ($e > 0) { $n .= "0" x $e . '.'; } elsif (abs($e) < $ln) { substr($n, $ln + $e, 0) = '.'; } else { $n = '.' . ("0" x (abs($e) - $ln)) . $n; } # 1 while $n =~ s/(.*\d)(\d\d\d)/$1,$2/; return $n; } # Arbitrary length float math package # # by Mark Biggar # # number format # canonical strings have the form /[+-]\d+E[+-]\d+/ # Input values can have inbedded whitespace # Error returns # 'NaN' An input parameter was "Not a Number" or # divide by zero or sqrt of negative number # Division is computed to # max($div_scale,length(dividend)+length(divisor)) # digits by default. # Also used for default sqrt scale $div_scale = 40; # Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'. $rnd_mode = 'even'; sub fadd; sub fsub; sub fmul; sub fdiv; sub fneg; sub fabs; sub fcmp; sub fround; sub ffround; sub fnorm; sub fsqrt; # bigfloat routines # # fadd(NSTR, NSTR) return NSTR addition # fsub(NSTR, NSTR) return NSTR subtraction # fmul(NSTR, NSTR) return NSTR multiplication # fdiv(NSTR, NSTR[,SCALE]) returns NSTR division to SCALE places # fneg(NSTR) return NSTR negation # fabs(NSTR) return NSTR absolute value # fcmp(NSTR,NSTR) return CODE compare undef,<0,=0,>0 # fround(NSTR, SCALE) return NSTR round to SCALE digits # ffround(NSTR, SCALE) return NSTR round at SCALEth place # fnorm(NSTR) return (NSTR) normalize # fsqrt(NSTR[, SCALE]) return NSTR sqrt to SCALE places # Convert a number to canonical string form. # Takes something that looks like a number and converts it to # the form /^[+-]\d+E[+-]\d+$/. sub fnorm { #(string) return fnum_str local($_) = @_; s/\s+//g; # strip white space if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/ && "$2$4" ne '') { &norm(($1 ? "$1$2$4" : "+$2$4"),(($4 ne '') ? $6-length($4) : $6)); } else { 'NaN'; } } # normalize number -- for internal use sub norm { #(mantissa, exponent) return fnum_str local($_, $exp) = @_; if ($_ eq 'NaN') { 'NaN'; } else { s/^([+-])0+/$1/; # strip leading zeros if (length($_) == 1) { '+0E+0'; } else { $exp += length($1) if (s/(0+)$//); # strip trailing zeros sprintf("%sE%+ld", $_, $exp); } } } # negation sub fneg { #(fnum_str) return fnum_str local($_) = fnorm($_[$[]); vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign s/^H/N/; $_; } # absolute value sub fabs { #(fnum_str) return fnum_str local($_) = fnorm($_[$[]); s/^-/+/; # mash sign $_; } # multiplication sub fmul { #(fnum_str, fnum_str) return fnum_str local($x,$y) = (fnorm($_[$[]),fnorm($_[$[+1])); if ($x eq 'NaN' || $y eq 'NaN') { 'NaN'; } else { local($xm,$xe) = split('E',$x); local($ym,$ye) = split('E',$y); &norm(Math::BigInt::bmul($xm,$ym),$xe+$ye); } } # addition sub fadd { #(fnum_str, fnum_str) return fnum_str local($x,$y) = (fnorm($_[$[]),fnorm($_[$[+1])); if ($x eq 'NaN' || $y eq 'NaN') { 'NaN'; } else { local($xm,$xe) = split('E',$x); local($ym,$ye) = split('E',$y); ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye); &norm(Math::BigInt::badd($ym,$xm.('0' x ($xe-$ye))),$ye); } } # subtraction sub fsub { #(fnum_str, fnum_str) return fnum_str fadd($_[$[],fneg($_[$[+1])); } # division # args are dividend, divisor, scale (optional) # result has at most max(scale, length(dividend), length(divisor)) digits sub fdiv #(fnum_str, fnum_str[,scale]) return fnum_str { local($x,$y,$scale) = (fnorm($_[$[]),fnorm($_[$[+1]),$_[$[+2]); if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') { 'NaN'; } else { local($xm,$xe) = split('E',$x); local($ym,$ye) = split('E',$y); $scale = $div_scale if (!$scale); $scale = length($xm)-1 if (length($xm)-1 > $scale); $scale = length($ym)-1 if (length($ym)-1 > $scale); $scale = $scale + length($ym) - length($xm); &norm(&round(Math::BigInt::bdiv($xm.('0' x $scale),$ym),$ym), $xe-$ye-$scale); } } # round int $q based on fraction $r/$base using $rnd_mode sub round { #(int_str, int_str, int_str) return int_str local($q,$r,$base) = @_; if ($q eq 'NaN' || $r eq 'NaN') { 'NaN'; } elsif ($rnd_mode eq 'trunc') { $q; # just truncate } else { local($cmp) = Math::BigInt::bcmp(Math::BigInt::bmul($r,'+2'),$base); if ( $cmp < 0 || ($cmp == 0 && ( $rnd_mode eq 'zero' || ($rnd_mode eq '-inf' && (substr($q,$[,1) eq '+')) || ($rnd_mode eq '+inf' && (substr($q,$[,1) eq '-')) || ($rnd_mode eq 'even' && $q =~ /[24680]$/) || ($rnd_mode eq 'odd' && $q =~ /[13579]$/) )) ) { $q; # round down } else { Math::BigInt::badd($q, ((substr($q,$[,1) eq '-') ? '-1' : '+1')); # round up } } } # round the mantissa of $x to $scale digits sub fround { #(fnum_str, scale) return fnum_str local($x,$scale) = (fnorm($_[$[]),$_[$[+1]); if ($x eq 'NaN' || $scale <= 0) { $x; } else { local($xm,$xe) = split('E',$x); if (length($xm)-1 <= $scale) { $x; } else { &norm(&round(substr($xm,$[,$scale+1), "+0".substr($xm,$[+$scale+1,1),"+10"), $xe+length($xm)-$scale-1); } } } # round $x at the 10 to the $scale digit place sub ffround { #(fnum_str, scale) return fnum_str local($x,$scale) = (fnorm($_[$[]),$_[$[+1]); if ($x eq 'NaN') { 'NaN'; } else { local($xm,$xe) = split('E',$x); if ($xe >= $scale) { $x; } else { $xe = length($xm)+$xe-$scale; if ($xe < 1) { '+0E+0'; } elsif ($xe == 1) { &norm(&round('+0',"+0".substr($xm,$[+1,1),"+10"), $scale); } else { &norm(&round(substr($xm,$[,$xe), "+0".substr($xm,$[+$xe,1),"+10"), $scale); } } } } # compare 2 values returns one of undef, <0, =0, >0 # returns undef if either or both input value are not numbers sub fcmp #(fnum_str, fnum_str) return cond_code { local($x, $y) = (fnorm($_[$[]),fnorm($_[$[+1])); if ($x eq "NaN" || $y eq "NaN") { undef; } else { ord($y) <=> ord($x) || ( local($xm,$xe,$ym,$ye) = split('E', $x."E$y"), (($xe <=> $ye) * (substr($x,$[,1).'1') || Math::BigInt::cmp($xm,$ym)) ); } } # square root by Newtons method. sub fsqrt { #(fnum_str[, scale]) return fnum_str local($x, $scale) = (fnorm($_[$[]), $_[$[+1]); if ($x eq 'NaN' || $x =~ /^-/) { 'NaN'; } elsif ($x eq '+0E+0') { '+0E+0'; } else { local($xm, $xe) = split('E',$x); $scale = $div_scale if (!$scale); $scale = length($xm)-1 if ($scale < length($xm)-1); local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2)); while ($gs < 2*$scale) { $guess = fmul(fadd($guess,fdiv($x,$guess,$gs*2)),".5"); $gs *= 2; } new BigFloat &fround($guess, $scale); } } 1; nput values can have inbedded whitespace # Error returnperl5.000/lib/Math/Complex.pm 664 203 12 6135 5650574620 11046 # # Perl5 Package for complex numbers # # 1994 by David Nadler # Coding know-how provided by Tom Christiansen, Tim Bunce, and Larry Wall # sqrt() added by Tom Christiansen; beware should have two roots, # but only returns one. (use wantarray?) # # # The functions "Re", "Im", and "arg" are provided. # "~" is used as the conjugation operator and "abs" is overloaded. # # Transcendental functions overloaded: so far only sin, cos, and exp. # package Math::Complex; require Exporter; @ISA = ('Exporter'); # just to make use happy %OVERLOAD= ( '+' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]}); bless [ $x1+$x2, $y1+$y2]; }, '-' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]}); bless [ $x1-$x2, $y1-$y2]; }, '*' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]}); bless [ $x1*$x2-$y1*$y2,$x1*$y2+$x2*$y1]; }, '/' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]}); my $q = $x2*$x2+$y2*$y2; bless [($x1*$x2+$y1*$y2)/$q, ($y1*$x2-$y2*$x1)/$q]; }, 'neg' => sub { my($x,$y) = @{$_[0]}; bless [ -$x, -$y]; }, '~' => sub { my($x,$y) = @{$_[0]}; bless [ $x, -$y]; }, 'abs' => sub { my($x,$y) = @{$_[0]}; sqrt $x*$x+$y*$y; }, 'cos' => sub { my($x,$y) = @{$_[0]}; my ($ab,$c,$s) = (exp $y, cos $x, sin $x); my $abr = 1/(2*$ab); $ab /= 2; bless [ ($abr+$ab)*$c, ($abr-$ab)*$s]; }, 'sin' => sub { my($x,$y) = @{$_[0]}; my ($ab,$c,$s) = (exp $y, cos $x, sin $x); my $abr = 1/(2*$ab); $ab /= 2; bless [ (-$abr-$ab)*$s, ($abr-$ab)*$c]; }, 'exp' => sub { my($x,$y) = @{$_[0]}; my ($ab,$c,$s) = (exp $x, cos $y, sin $y); bless [ $ab*$c, $ab*$s ]; }, 'sqrt' => sub { my($zr,$zi) = @{$_[0]}; my ($x, $y, $r, $w); my $c = new Math::Complex (0,0); if (($zr == 0) && ($zi == 0)) { # nothing, $c already set } else { $x = abs($zr); $y = abs($zi); if ($x >= $y) { $r = $y/$x; $w = sqrt($x) * sqrt(0.5*(1.0+sqrt(1.0+$r*$r))); } else { $r = $x/$y; $w = sqrt($y) * sqrt($y) * sqrt(0.5*($r+sqrt(1.0+$r*$r))); } if ( $zr >= 0) { @$c = ($w, $zi/(2 * $w) ); } else { $c->[1] = ($zi >= 0) ? $w : -$w; $c->[0] = $zi/(2.0* $c->[1]); } } return $c; }, qw("" stringify) ); sub new { shift; my @C = @_; bless \@C; } sub Re { my($x,$y) = @{$_[0]}; $x; } sub Im { my($x,$y) = @{$_[0]}; $y; } sub arg { my($x,$y) = @{$_[0]}; atan2($y,$x); } sub stringify { my($x,$y) = @{$_[0]}; my($re,$im); $re = $x if ($x); if ($y == 1) {$im = 'i';} elsif ($y == -1){$im = '-i';} elsif ($y) {$im = "${y}i"; } local $_ = $re.'+'.$im; s/\+-/-/; s/^\+//; s/[\+-]$//; $_ = 0 if ($_ eq ''); return $_; } } # normalize number -- for internal use sub norm { #(mantissa, exponent) return fnum_str local($_, $exp) = @_; if ($_ eq 'NaN') { 'NaN'; } else { s/^([+-])0+/$1/; # strip leading zeros if (length($_) == 1) { '+0E+0'; } else { $exp += length($1) if (s/(0+)$//); # strip trailing zeros sprintf("%sE%+ld", $_, $exp); } } } # negation sub fneg { #(fnum_str) reperl5.000/lib/Net/ 775 203 12 0 5650575707 6653 perl5.000/lib/Net/Ping.pm 664 203 12 2501 5645374716 10172 package Net::Ping; # Authors: karrer@bernina.ethz.ch (Andreas Karrer) # pmarquess@bfsec.bt.co.uk (Paul Marquess) require Exporter; @ISA = qw(Exporter); @EXPORT = qw(ping pingecho); use Socket; use Carp ; $tcp_proto = (getprotobyname('tcp'))[2]; $echo_port = (getservbyname('echo', 'tcp'))[2]; sub ping { croak "ping not implemented yet. Use pingecho()"; } sub pingecho { croak "usage: pingecho host [timeout]" unless @_ == 1 || @_ == 2 ; local ($host, $timeout) = @_; local (*PINGSOCK); local ($saddr, $ip); local ($ret) ; # check if $host is alive by connecting to its echo port, within $timeout # (default 5) seconds. returns 1 if OK, 0 if no answer, 0 if host not found $timeout = 5 unless $timeout; if ($host =~ /^\s*((\d+\.){3}\d+)\s*$/) { $ip = pack ('C4', split (/\./, $1)) } else { $ip = (gethostbyname($host))[4] } return 0 unless $ip; # "no such host" $saddr = pack('S n a4 x8', AF_INET, $echo_port, $ip); $SIG{'ALRM'} = sub { die } ; alarm($timeout); $ret = eval <<'EOM' ; return 0 unless socket(PINGSOCK, PF_INET, SOCK_STREAM, $tcp_proto) ; return 0 unless connect(PINGSOCK, $saddr) ; return 1 ; EOM alarm(0); close(PINGSOCK); $ret == 1 ? 1 : 0 ; } 1; $_[0]}; sqrt $x*$x+$y*$y; }, 'cos' => sub { my($x,$y) = @{$_[0]}; my ($ab,$c,$s) = (exp $y, cos $x, sin $x); my $abr = 1/(2*$ab); $ab /perl5.000/lib/Search/ 775 203 12 0 5650575707 7332 perl5.000/lib/Search/Dict.pm 664 203 12 2141 5645374716 10637 package Search::Dict; require 5.000; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(look); # Usage: look(*FILEHANDLE,$key,$dict,$fold) # Sets file position in FILEHANDLE to be first line greater than or equal # (stringwise) to $key. Pass flags for dictionary order and case folding. sub look { local(*FH,$key,$dict,$fold) = @_; local($max,$min,$mid,$_); local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat(FH); $blksize = 8192 unless $blksize; $key =~ s/[^\w\s]//g if $dict; $key =~ tr/A-Z/a-z/ if $fold; $max = int($size / $blksize); while ($max - $min > 1) { $mid = int(($max + $min) / 2); seek(FH,$mid * $blksize,0); $_ = if $mid; # probably a partial line $_ = ; chop; s/[^\w\s]//g if $dict; tr/A-Z/a-z/ if $fold; if ($_ lt $key) { $min = $mid; } else { $max = $mid; } } $min *= $blksize; seek(FH,$min,0); if $min; while () { chop; s/[^\w\s]//g if $dict; y/A-Z/a-z/ if $fold; last if $_ ge $key; $min = tell(FH); } seek(FH,$min,0); $min; } 1; unless socket(PINGSOCK, PF_INET, SOCK_STREAM, $tcp_proto) ; return 0 unless connect(PINGSOCK, $saddr) ; return 1 ; EOM alarm(0); close(PINGSOCK); $ret == 1 ? 1 : 0 ; } 1; $_[0]}; sqrt $x*$x+$y*$y; }, 'cos' => sub { my($x,$y) = @{$_[0]}; my ($ab,$c,$s) = (exp $y, cos $x, sin $x); my $abr = 1/(2*$ab); $ab /perl5.000/lib/Sys/ 775 203 12 0 5650575710 6675 perl5.000/lib/Sys/Hostname.pm 664 203 12 1765 5645374717 11117 # by David Sundstrom sunds@asictest.sc.ti.com # Texas Instruments package Sys::Hostname; use Carp; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(hostname); # # Try every conceivable way to get hostname. # sub hostname { # method 1 - we already know it return $host if defined $host; # method 2 - syscall is preferred since it avoids tainting problems eval { { package main; require "syscall.ph"; } $host = "\0" x 65; ## preload scalar syscall(&main::SYS_gethostname, $host, 65) == 0; } # method 3 - trusty old hostname command || eval { $host = `(hostname) 2>/dev/null`; # bsdish } # method 4 - sysV uname command (may truncate) || eval { $host = `uname -n 2>/dev/null`; ## sysVish } # method 5 - Apollo pre-SR10 || eval { ($host,$a,$b,$c,$d)=split(/[:\. ]/,`/com/host`,6); } # bummer || Carp::croak "Cannot get host name of local machine"; # remove garbage $host =~ tr/\0\r\n//d; $host; } 1; ainted.plÔperl5.000/lib/Sys/Syslog.pm 664 203 12 10764 5645374717 10640 package Sys::Syslog; require 5.000; require Exporter; use Carp; @ISA = qw(Exporter); @EXPORT = qw(openlog closelog setlogmask syslog); # # syslog.pl # # $Log: syslog.pl,v $ # # tom christiansen # modified to use sockets by Larry Wall # NOTE: openlog now takes three arguments, just like openlog(3) # # call syslog() with a string priority and a list of printf() args # like syslog(3) # # usage: use Syslog; # # then (put these all in a script to test function) # # openlog($program,'cons,pid','user'); # syslog('info','this is another test'); # syslog('mail|warning','this is a better test: %d', time); # closelog(); # # syslog('debug','this is the last test'); # openlog("$program $$",'ndelay','user'); # syslog('notice','fooprogram: this is really done'); # # $! = 55; # syslog('info','problem was %m'); # %m == $! in syslog(3) $host = 'localhost' unless $host; # set $Syslog::host to change require 'syslog.ph'; $maskpri = &LOG_UPTO(&LOG_DEBUG); sub openlog { ($ident, $logopt, $facility) = @_; # package vars $lo_pid = $logopt =~ /\bpid\b/; $lo_ndelay = $logopt =~ /\bndelay\b/; $lo_cons = $logopt =~ /\bcons\b/; $lo_nowait = $logopt =~ /\bnowait\b/; &connect if $lo_ndelay; } sub closelog { $facility = $ident = ''; &disconnect; } sub setlogmask { local($oldmask) = $maskpri; $maskpri = shift; $oldmask; } sub syslog { local($priority) = shift; local($mask) = shift; local($message, $whoami); local(@words, $num, $numpri, $numfac, $sum); local($facility) = $facility; # may need to change temporarily. croak "syslog: expected both priority and mask" unless $mask && $priority; @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility". undef $numpri; undef $numfac; foreach (@words) { $num = &xlate($_); # Translate word to number. if (/^kern$/ || $num < 0) { croak "syslog: invalid level/facility: $_"; } elsif ($num <= &LOG_PRIMASK) { croak "syslog: too many levels given: $_" if defined($numpri); $numpri = $num; return 0 unless &LOG_MASK($numpri) & $maskpri; } else { croak "syslog: too many facilities given: $_" if defined($numfac); $facility = $_; $numfac = $num; } } croak "syslog: level must be given" unless defined($numpri); if (!defined($numfac)) { # Facility not specified in this call. $facility = 'user' unless $facility; $numfac = &xlate($facility); } &connect unless $connected; $whoami = $ident; if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) { $whoami = $1; $mask = $2; } unless ($whoami) { ($whoami = getlogin) || ($whoami = getpwuid($<)) || ($whoami = 'syslog'); } $whoami .= "[$$]" if $lo_pid; $mask =~ s/%m/$!/g; $mask .= "\n" unless $mask =~ /\n$/; $message = sprintf ($mask, @_); $sum = $numpri + $numfac; unless (send(SYSLOG,"<$sum>$whoami: $message",0)) { if ($lo_cons) { if ($pid = fork) { unless ($lo_nowait) { do {$died = wait;} until $died == $pid || $died < 0; } } else { open(CONS,">/dev/console"); print CONS "<$facility.$priority>$whoami: $message\r"; exit if defined $pid; # if fork failed, we're parent close CONS; } } } } sub xlate { local($name) = @_; $name =~ y/a-z/A-Z/; $name = "LOG_$name" unless $name =~ /^LOG_/; $name = "syslog'$name"; eval(&$name) || -1; } sub connect { $pat = 'S n C4 x8'; $af_unix = 1; $af_inet = 2; $stream = 1; $datagram = 2; ($name,$aliases,$proto) = getprotobyname('udp'); $udp = $proto; ($name,$aliase,$port,$proto) = getservbyname('syslog','udp'); $syslog = $port; if (chop($myname = `hostname`)) { ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname); croak "Can't lookup $myname" unless $name; @bytes = unpack("C4",$addrs[0]); } else { @bytes = (0,0,0,0); } $this = pack($pat, $af_inet, 0, @bytes); if ($host =~ /^\d+\./) { @bytes = split(/\./,$host); } else { ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host); croak "Can't lookup $host" unless $name; @bytes = unpack("C4",$addrs[0]); } $that = pack($pat,$af_inet,$syslog,@bytes); socket(SYSLOG,$af_inet,$datagram,$udp) || croak "socket: $!"; bind(SYSLOG,$this) || croak "bind: $!"; connect(SYSLOG,$that) || croak "connect: $!"; local($old) = select(SYSLOG); $| = 1; select($old); $connected = 1; } sub disconnect { close SYSLOG; $connected = 0; } 1; ; local(perl5.000/lib/Term/ 775 203 12 0 5650575710 7026 perl5.000/lib/Term/Cap.pm 664 203 12 7365 5645374720 10171 package Term::Cap; require 5.000; require Exporter; use Carp; @ISA = qw(Exporter); @EXPORT = qw(&Tgetent &Tputs &Tgoto $ispeed $ospeed %TC); # $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $ # # Usage: # require 'ioctl.pl'; # ioctl(TTY,$TIOCGETP,$foo); # ($ispeed,$ospeed) = unpack('cc',$foo); # use Termcap; # &Tgetent('vt100'); # sets $TC{'cm'}, etc. # &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE'); # &Tputs($TC{'dl'},$affcnt,'FILEHANDLE'); # sub Tgetent { local($TERM) = @_; local($TERMCAP,$_,$entry,$loop,$field); warn "Tgetent: no ospeed set" unless $ospeed; foreach $key (keys(%TC)) { delete $TC{$key}; } $TERM = $ENV{'TERM'} unless $TERM; $TERM =~ s/(\W)/\\$1/g; $TERMCAP = $ENV{'TERMCAP'}; $TERMCAP = '/etc/termcap' unless $TERMCAP; if ($TERMCAP !~ m:^/:) { if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) { $TERMCAP = '/etc/termcap'; } } if ($TERMCAP =~ m:^/:) { $entry = ''; do { $loop = " open(TERMCAP,'<$TERMCAP') || croak \"Can't open $TERMCAP\"; while () { next if /^#/; next if /^\t/; if (/(^|\\|)${TERM}[:\\|]/) { chop; while (chop eq '\\\\') { \$_ .= ; chop; } \$_ .= ':'; last; } } close TERMCAP; \$entry .= \$_; "; eval $loop; } while s/:tc=([^:]+):/:/ && ($TERM = $1); $TERMCAP = $entry; } foreach $field (split(/:[\s:\\]*/,$TERMCAP)) { if ($field =~ /^\w\w$/) { $TC{$field} = 1; } elsif ($field =~ /^(\w\w)#(.*)/) { $TC{$1} = $2 unless defined $TC{$1}; } elsif ($field =~ /^(\w\w)=(.*)/) { $entry = $1; $_ = $2; s/\\E/\033/g; s/\\(\d\d\d)/pack('c',$1 & 0177)/eg; s/\\n/\n/g; s/\\r/\r/g; s/\\t/\t/g; s/\\b/\b/g; s/\\f/\f/g; s/\\\^/\377/g; s/\^\?/\177/g; s/\^(.)/pack('c',ord($1) & 31)/eg; s/\\(.)/$1/g; s/\377/^/g; $TC{$entry} = $_ unless defined $TC{$entry}; } } $TC{'pc'} = "\0" unless defined $TC{'pc'}; $TC{'bc'} = "\b" unless defined $TC{'bc'}; } @Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2); sub Tputs { local($string,$affcnt,$FH) = @_; local($ms); if ($string =~ /(^[\d.]+)(\*?)(.*)$/) { $ms = $1; $ms *= $affcnt if $2; $string = $3; $decr = $Tputs[$ospeed]; if ($decr > .1) { $ms += $decr / 2; $string .= $TC{'pc'} x ($ms / $decr); } } print $FH $string if $FH; $string; } sub Tgoto { local($string) = shift(@_); local($result) = ''; local($after) = ''; local($code,$tmp) = @_; local(@tmp); @tmp = ($tmp,$code); local($online) = 0; while ($string =~ /^([^%]*)%(.)(.*)/) { $result .= $1; $code = $2; $string = $3; if ($code eq 'd') { $result .= sprintf("%d",shift(@tmp)); } elsif ($code eq '.') { $tmp = shift(@tmp); if ($tmp == 0 || $tmp == 4 || $tmp == 10) { if ($online) { ++$tmp, $after .= $TC{'up'} if $TC{'up'}; } else { ++$tmp, $after .= $TC{'bc'}; } } $result .= sprintf("%c",$tmp); $online = !$online; } elsif ($code eq '+') { $result .= sprintf("%c",shift(@tmp)+ord($string)); $string = substr($string,1,99); $online = !$online; } elsif ($code eq 'r') { ($code,$tmp) = @tmp; @tmp = ($tmp,$code); $online = !$online; } elsif ($code eq '>') { ($code,$tmp,$string) = unpack("CCa99",$string); if ($tmp[$[] > $code) { $tmp[$[] += $tmp; } } elsif ($code eq '2') { $result .= sprintf("%02d",shift(@tmp)); $online = !$online; } elsif ($code eq '3') { $result .= sprintf("%03d",shift(@tmp)); $online = !$online; } elsif ($code eq 'i') { ($code,$tmp) = @tmp; @tmp = ($code+1,$tmp+1); } else { return "OOPS"; } } $result . $string . $after; } 1; # mash sign $_; } # multiplication sub fmul { #(fnum_str, fnum_str) return fnum_str local($x,$y) = (fnorm($_[$[]),fnorm($_[$[+1])); if ($x eq 'NaN' || $y eq 'NaN') { 'NaN'; } else { local($xm,$xe) = split('E',$x); local($ym,$yperl5.000/lib/Term/Complete.pm 664 203 12 5465 5645374720 11235 package Term::Complete; require 5.000; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(Complete); # # @(#)complete.pl,v1.1 (me@anywhere.EBay.Sun.COM) 09/23/91 # # Author: Wayne Thompson # # Description: # This routine provides word completion. # (TAB) attempts word completion. # (^D) prints completion list. # (These may be changed by setting $Complete::complete, etc.) # # Diagnostics: # Bell when word completion fails. # # Dependencies: # The tty driver is put into raw mode. # # Bugs: # # Usage: # $input = complete('prompt_string', \@completion_list); # or # $input = complete('prompt_string', @completion_list); # CONFIG: { $complete = "\004"; $kill = "\025"; $erase1 = "\177"; $erase2 = "\010"; } sub complete { $prompt = shift; if (ref $_[0] || $_[0] =~ /^\*/) { @cmp_lst = sort @{$_[0]}; } else { @cmp_lst = sort(@_); } system('stty raw -echo'); LOOP: { print($prompt, $return); while (($_ = getc(STDIN)) ne "\r") { CASE: { # (TAB) attempt completion $_ eq "\t" && do { @match = grep(/^$return/, @cmp_lst); $l = length($test = shift(@match)); unless ($#match < 0) { foreach $cmp (@match) { until (substr($cmp, 0, $l) eq substr($test, 0, $l)) { $l--; } } print("\a"); } print($test = substr($test, $r, $l - $r)); $r = length($return .= $test); last CASE; }; # (^D) completion list $_ eq $complete && do { print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n"); redo LOOP; }; # (^U) kill $_ eq $kill && do { if ($r) { undef($r, $return); print("\r\n"); redo LOOP; } last CASE; }; # (DEL) || (BS) erase ($_ eq $erase1 || $_ eq $erase2) && do { if($r) { print("\b \b"); chop($return); $r--; } last CASE; }; # printable char ord >= 32 && do { $return .= $_; $r++; print; last CASE; }; } } } system('stty -raw echo'); print("\n"); $return; } 1; /pack('c',ord($1) & 31)/eg; s/\\(.)/$1/g; s/\377/^/g; $TC{$entry} = $_ unless defined $TC{$entry}; } } $TC{'pc'} = "\0" unless defined $TC{'pc'}; $TC{'bc'} = "\b" unless definperl5.000/lib/Test/ 775 203 12 0 5650575710 7036 perl5.000/lib/Test/Harness.pm 664 203 12 3745 5647030706 11072 package Test::Harness; use Exporter; use Benchmark; @ISA=(Exporter); @EXPORT= qw(&runtests &test_lib); @EXPORT_OK= qw($verbose $switches); $verbose = 0; $switches = "-w"; sub runtests { my(@tests) = @_; local($|) = 1; my($test,$te,$ok,$next,$max,$totmax, $files,$pct); my $bad = 0; my $good = 0; my $total = @tests; local($ENV{'PERL5LIB'}) = join(':', @INC); # pass -I flags to children my $t_start = new Benchmark; while ($test = shift(@tests)) { $te = $test; chop($te); print "$te" . '.' x (20 - length($te)); my $fh = "RESULTS"; open($fh,"$^X $switches $test|") || (print "can't run. $!\n"); $ok = 0; $next = 0; while (<$fh>) { if( $verbose ){ print $_; } unless (/^#/) { if (/^1\.\.([0-9]+)/) { $max = $1; $totmax += $max; $files += 1; $next = 1; $ok = 1; } else { $next = $1, $ok = 0, last if /^not ok ([0-9]*)/; if (/^ok (.*)/ && $1 == $next) { $next = $next + 1; } } } } close($fh); # must close to reap child resource values $next -= 1; if ($ok && $next == $max) { print "ok\n"; $good += 1; } else { $next += 1; print "FAILED on test $next\n"; $bad += 1; $_ = $test; } } my $t_total = timediff(new Benchmark, $t_start); if ($bad == 0) { if ($ok) { print "All tests successful.\n"; } else { die "FAILED--no tests were run for some reason.\n"; } } else { $pct = sprintf("%.2f", $good / $total * 100); if ($bad == 1) { warn "Failed 1 test, $pct% okay.\n"; } else { die "Failed $bad/$total tests, $pct% okay.\n"; } } printf("Files=%d, Tests=%d, %s\n", $files,$totmax, timestr($t_total, 'nop')); } 1; C{'bc'} = "\b" unless definperl5.000/lib/Text/ 775 203 12 0 5650575711 7044 perl5.000/lib/Text/Abbrev.pm 664 203 12 1121 5645374721 10665 package Text::Abbrev; require 5.000; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(abbrev); # Usage: # &abbrev(*foo,LIST); # ... # $long = $foo{$short}; sub abbrev { local(*domain) = shift; @cmp = @_; %domain = (); foreach $name (@_) { @extra = split(//,$name); $abbrev = shift(@extra); $len = 1; foreach $cmp (@cmp) { next if $cmp eq $name; while (substr($cmp,0,$len) eq $abbrev) { $abbrev .= shift(@extra); ++$len; } } $domain{$abbrev} = $name; while (@extra) { $abbrev .= shift(@extra); $domain{$abbrev} = $name; } } } 1; ¨ò importenv.plò¼ò integer.pm¼Ìò‘less.pmÜò’look.plò“ newgetopt.plò“ò”open2.pl(ò•open3.pl(<ò– perl5db.pl<Lò—pwd.pl<dò˜ shellwords.plò˜xò™ sigtrap.pmxˆòšstat.plœò› strict.pmœ¬òœsubs.pmÀò syslog.plÀÔòž tainted.plÔèòŸ termcap.plèò  timelocal.plò perl5.000/lib/Text/ParseWords.pm 664 203 12 11317 5645374721 11605 package Text::ParseWords; require 5.000; require Exporter; require AutoLoader; use Carp; @ISA = qw(Exporter AutoLoader); @EXPORT = qw(shellwords quotewords); @EXPORT_OK = qw(old_shellwords); # This code needs updating to use new Perl 5 features (regexp etc). # ParseWords.pm # # Usage: # use ParseWords; # @words = "ewords($delim, $keep, @lines); # @words = &shellwords(@lines); # @words = &old_shellwords(@lines); # Hal Pomeranz (pomeranz@netcom.com), 23 March 1994 # Permission to use and distribute under the same terms as Perl. # No warranty expressed or implied. # Basically an update and generalization of the old shellwords.pl. # Much code shamelessly stolen from the old version (author unknown). # # "ewords() accepts a delimiter (which can be a regular expression) # and a list of lines and then breaks those lines up into a list of # words ignoring delimiters that appear inside quotes. # # The $keep argument is a boolean flag. If true, the quotes are kept # with each word, otherwise quotes are stripped in the splitting process. # $keep also defines whether unprotected backslashes are retained. # 1; __END__ sub shellwords { # A &shellwords() replacement is included to demonstrate the new package. # This version differs from the original in that it will _NOT_ default # to using $_ if no arguments are given. I personally find the old behavior # to be a mis-feature. local(@lines) = @_; $lines[$#lines] =~ s/\s+$//; "ewords('\s+', 0, @lines); } sub quotewords { # "ewords() works by simply jamming all of @lines into a single # string in $_ and then pulling off words a bit at a time until $_ # is exhausted. # # The inner "for" loop builds up each word (or $field) one $snippet # at a time. A $snippet is a quoted string, a backslashed character, # or an unquoted string. We fall out of the "for" loop when we reach # the end of $_ or when we hit a delimiter. Falling out of the "for" # loop, we push the $field we've been building up onto the list of # @words we'll be returning, and then loop back and pull another word # off of $_. # # The first two cases inside the "for" loop deal with quoted strings. # The first case matches a double quoted string, removes it from $_, # and assigns the double quoted string to $snippet in the body of the # conditional. The second case handles single quoted strings. In # the third case we've found a quote at the current beginning of $_, # but it didn't match the quoted string regexps in the first two cases, # so it must be an unbalanced quote and we croak with an error (which can # be caught by eval()). # # The next case handles backslashed characters, and the next case is the # exit case on reaching the end of the string or finding a delimiter. # # Otherwise, we've found an unquoted thing and we pull of characters one # at a time until we reach something that could start another $snippet-- # a quote of some sort, a backslash, or the delimiter. This one character # at a time behavior was necessary if the delimiter was going to be a # regexp (love to hear it if you can figure out a better way). local($delim, $keep, @lines) = @_; local(@words,$snippet,$field,$_); $_ = join('', @lines); while ($_) { $field = ''; for (;;) { $snippet = ''; if (s/^"(([^"\\]|\\[\\"])*)"//) { $snippet = $1; $snippet = "\"$snippet\"" if ($keep); } elsif (s/^'(([^'\\]|\\[\\'])*)'//) { $snippet = $1; $snippet = "'$snippet'" if ($keep); } elsif (/^["']/) { croak "Unmatched quote"; } elsif (s/^\\(.)//) { $snippet = $1; $snippet = "\\$snippet" if ($keep); } elsif (!$_ || s/^$delim//) { last; } else { while ($_ && !(/^$delim/ || /^['"\\]/)) { $snippet .= substr($_, 0, 1); substr($_, 0, 1) = ''; } } $field .= $snippet; } push(@words, $field); } @words; } sub old_shellwords { # Usage: # use ParseWords; # @words = old_shellwords($line); # or # @words = old_shellwords(@lines); local($_) = join('', @_); my(@words,$snippet,$field); s/^\s+//; while ($_ ne '') { $field = ''; for (;;) { if (s/^"(([^"\\]|\\.)*)"//) { ($snippet = $1) =~ s#\\(.)#$1#g; } elsif (/^"/) { croak "Unmatched double quote: $_"; } elsif (s/^'(([^'\\]|\\.)*)'//) { ($snippet = $1) =~ s#\\(.)#$1#g; } elsif (/^'/) { croak "Unmatched single quote: $_"; } elsif (s/^\\(.)//) { $snippet = $1; } elsif (s/^([^\s\\'"]+)//) { $snippet = $1; } else { s/^\s+//; last; } $field .= $snippet; } push(@words, $field); } @words; } || $y eq 'NaN') { 'NaN'; } else { local($xm,$xe) = split('E',$x); local($ym,$ye) = split('E',$y); ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye); &norm(Math::BigInt::badd($ym,$xm.('0' x ($xe-$ye))),$ye); } } # subtraction sub fsub { #(fnum_str, fnum_str) return fnum_str fadd($_[$[perl5.000/lib/Text/Soundex.pm 664 203 12 3307 5645374722 11122 package Text::Soundex; require 5.000; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(&soundex $soundex_nocode); # $Id: soundex.pl,v 1.2 1994/03/24 00:30:27 mike Exp $ # # Implementation of soundex algorithm as described by Knuth in volume # 3 of The Art of Computer Programming, with ideas stolen from Ian # Phillips . # # Mike Stok , 2 March 1994. # # Knuth's test cases are: # # Euler, Ellery -> E460 # Gauss, Ghosh -> G200 # Hilbert, Heilbronn -> H416 # Knuth, Kant -> K530 # Lloyd, Ladd -> L300 # Lukasiewicz, Lissajous -> L222 # # $Log: soundex.pl,v $ # Revision 1.2 1994/03/24 00:30:27 mike # Subtle bug (any excuse :-) spotted by Rich Pinder # in the way I handles leasing characters which were different but had # the same soundex code. This showed up comparing it with Oracle's # soundex output. # # Revision 1.1 1994/03/02 13:01:30 mike # Initial revision # # ############################################################################## # $soundex_nocode is used to indicate a string doesn't have a soundex # code, I like undef other people may want to set it to 'Z000'. $soundex_nocode = undef; # soundex # # usage: # # @codes = &soundex (@wordList); # $code = &soundex ($word); # # This strenuously avoids 0 sub soundex { local (@s, $f, $fc, $_) = @_; foreach (@s) { tr/a-z/A-Z/; tr/A-Z//cd; if ($_ eq '') { $_ = $soundex_nocode; } else { ($f) = /^(.)/; tr/AEHIOUWYBFPVCGJKQSXZDTLMNR/00000000111122222222334556/; ($fc) = /^(.)/; s/^$fc+//; tr///cs; tr/0//d; $_ = $f . $_ . '000'; s/^(.{4}).*/$1/; } } wantarray ? @s : shift @s; } 1; t from $_, # and assigns the double quoted string to $snippet in the body of the # conditional. The second case handles single quoted strings. In # the third case we've found a quote at the current beginning of $_, # but it didn't match the quoted string regexps in the first two cases, # so it must be an unbalperl5.000/lib/Text/Tabs.pm 664 203 12 1245 5645711024 10353 # # expand and unexpand tabs as per the unix expand and # unexpand programs. # # expand and unexpand operate on arrays of lines. Do not # feed strings that contain newlines to them. # # David Muir Sharnoff # package Tabs; require Exporter; @ISA = (Exporter); @EXPORT = qw(expand unexpand $tabstop); $tabstop = 8; sub expand { my @l = @_; for $_ (@l) { 1 while s/^([^\t]*)(\t+)/ $1 . (" " x ($tabstop * length($2) - (length($1) % $tabstop))) /e; } return @l; } sub unexpand { my @l = &expand(@_); my @e; for $x (@l) { @e = split(/(.{$tabstop})/,$x); for $_ (@e) { s/ +$/\t/; } $x = join('',@e); } return @l; } 1; newlines to them. # # David Muir Sharnoff # package Tabs; require Exporter; @ISA = (Exporter); @EXPORT = qw(expand unexpand $tabstop); $tabstop = 8; sub expand { my @l = @_; for $_ (@l) { 1 while s/^([^\t]*)(\t+)/ $1 . (" " x ($tabstop * length($2) - (length($1) % $tabstop))) /e; } return @l; } sub uperl5.000/lib/TieHash.pm 664 203 12 1255 5626250015 10061 package TieHash; use Carp; sub new { my $pack = shift; $pack->TIEHASH(@_); } # Grandfather "new" sub TIEHASH { my $pack = shift; if (defined &{"{$pack}::new"}) { carp "WARNING: calling ${pack}->new since ${pack}->TIEHASH is missing" if $^W; $pack->new(@_); } else { croak "$pack doesn't define a TIEHASH method"; } } sub EXISTS { my $pack = ref $_[0]; croak "$pack doesn't define an EXISTS method"; } sub CLEAR { my $self = shift; my $key = $self->FIRSTKEY(@_); my @keys; while (defined $key) { push @keys, $key; $key = $self->NEXTKEY(@_, $key); } foreach $key (@keys) { $self->DELETE(@_, $key); } } 1; .plò“ò”open2.pl(ò•open3.pl(<ò– perl5db.pl<Lò—pwd.pl<dò˜ shellwords.plò˜xò™ sigtrap.pmxˆòšstat.plœò› strict.pmœ¬òœsubs.pmÀò syslog.plÀÔòž tainted.plÔèòŸ termcap.plèò  timelocal.plò ò¡ validate.plperl5.000/lib/Time/ 775 203 12 0 5650575711 7016 perl5.000/lib/Time/Local.pm 664 203 12 6546 5645374722 10511 package Time::Local; require 5.000; require Exporter; use Carp; @ISA = qw(Exporter); @EXPORT = qw(timegm timelocal); # timelocal.pl # # Usage: # $time = timelocal($sec,$min,$hours,$mday,$mon,$year); # $time = timegm($sec,$min,$hours,$mday,$mon,$year); # These routines are quite efficient and yet are always guaranteed to agree # with localtime() and gmtime(). We manage this by caching the start times # of any months we've seen before. If we know the start time of the month, # we can always calculate any time within the month. The start times # themselves are guessed by successive approximation starting at the # current time, since most dates seen in practice are close to the # current date. Unlike algorithms that do a binary search (calling gmtime # once for each bit of the time value, resulting in 32 calls), this algorithm # calls it at most 6 times, and usually only once or twice. If you hit # the month cache, of course, it doesn't call it at all. # timelocal is implemented using the same cache. We just assume that we're # translating a GMT time, and then fudge it when we're done for the timezone # and daylight savings arguments. The timezone is determined by examining # the result of localtime(0) when the package is initialized. The daylight # savings offset is currently assumed to be one hour. # Both routines return -1 if the integer limit is hit. I.e. for dates # after the 1st of January, 2038 on most machines. @epoch = localtime(0); $tzmin = $epoch[2] * 60 + $epoch[1]; # minutes east of GMT if ($tzmin > 0) { $tzmin = 24 * 60 - $tzmin; # minutes west of GMT $tzmin -= 24 * 60 if $epoch[5] == 70; # account for the date line } $SEC = 1; $MIN = 60 * $SEC; $HR = 60 * $MIN; $DAYS = 24 * $HR; $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0; sub timegm { $ym = pack(C2, @_[5,4]); $cheat = $cheat{$ym} || &cheat; return -1 if $cheat<0; $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS; } sub timelocal { $time = &timegm + $tzmin*$MIN; return -1 if $cheat<0; @test = localtime($time); $time -= $HR if $test[2] != $_[2]; $time; } sub cheat { $year = $_[5]; $month = $_[4]; croak "Month out of range 0..11 in timelocal.pl" if $month > 11 || $month < 0; croak "Day out of range 1..31 in timelocal.pl" if $_[3] > 31 || $_[3] < 1; croak "Hour out of range 0..23 in timelocal.pl" if $_[2] > 23 || $_[2] < 0; croak "Minute out of range 0..59 in timelocal.pl" if $_[1] > 59 || $_[1] < 0; croak "Second out of range 0..59 in timelocal.pl" if $_[0] > 59 || $_[0] < 0; $guess = $^T; @g = gmtime($guess); $year += $YearFix if $year < $epoch[5]; $lastguess = ""; while ($diff = $year - $g[5]) { $guess += $diff * (363 * $DAYS); @g = gmtime($guess); if (($thisguess = "@g") eq $lastguess){ return -1; #date beyond this machine's integer limit } $lastguess = $thisguess; } while ($diff = $month - $g[4]) { $guess += $diff * (27 * $DAYS); @g = gmtime($guess); if (($thisguess = "@g") eq $lastguess){ return -1; #date beyond this machine's integer limit } $lastguess = $thisguess; } @gfake = gmtime($guess-1); #still being sceptic if ("@gfake" eq $lastguess){ return -1; #date beyond this machine's integer limit } $g[3]--; $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAYS; $cheat{$ym} = $guess; } 1; } } $field .= $snippet; } push(@words, $field); } @words; } sub old_shellwords { # Usage: # use ParseWordsperl5.000/lib/abbrev.pl 644 203 12 1047 5240620761 7772 ;# Usage: ;# %foo = (); ;# &abbrev(*foo,LIST); ;# ... ;# $long = $foo{$short}; package abbrev; sub main'abbrev { local(*domain) = @_; shift(@_); @cmp = @_; local($[) = 0; foreach $name (@_) { @extra = split(//,$name); $abbrev = shift(@extra); $len = 1; foreach $cmp (@cmp) { next if $cmp eq $name; while (substr($cmp,0,$len) eq $abbrev) { $abbrev .= shift(@extra); ++$len; } } $domain{$abbrev} = $name; while ($#extra >= 0) { $abbrev .= shift(@extra); $domain{$abbrev} = $name; } } } 1; lò¼ò integer.pm¼Ìò‘less.pmÜò’look.plò“ newgetopt.plò“ò”open2.pl(ò•open3.pl(<ò– perl5db.pl<Lò—pwd.pl(dò˜ shellwords.plò˜xò™ sigtrap.pmxˆòšstat.plœò› strict.pmœ¬òœsubs.pmÀò syslog.plÀÔòž tainted.plÔèòŸ termcap.plèò  timelocal.plò ò¡ validate.plcal is implemented using the same cache. Weperl5.000/lib/assert.pl 644 203 12 2363 5306760472 10043 # assert.pl # tchrist@convex.com (Tom Christiansen) # # Usage: # # &assert('@x > @y'); # &assert('$var > 10', $var, $othervar, @various_info); # # That is, if the first expression evals false, we blow up. The # rest of the args, if any, are nice to know because they will # be printed out by &panic, which is just the stack-backtrace # routine shamelessly borrowed from the perl debugger. sub assert { &panic("ASSERTION BOTCHED: $_[$[]",$@) unless eval $_[$[]; } sub panic { select(STDERR); print "\npanic: @_\n"; exit 1 if $] <= 4.003; # caller broken # stack traceback gratefully borrowed from perl debugger local($i,$_); local($p,$f,$l,$s,$h,$a,@a,@sub); for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { @a = @DB'args; for (@a) { if (/^StB\000/ && length($_) == length($_main{'_main'})) { $_ = sprintf("%s",$_); } else { s/'/\\'/g; s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; } } $w = $w ? '@ = ' : '$ = '; $a = $h ? '(' . join(', ', @a) . ')' : ''; push(@sub, "$w&$s$a from file $f line $l\n"); } for ($i=0; $i <= $#sub; $i++) { print $sub[$i]; } exit 1; } 1; daylight # savings offset is currently assumed to be one hour. # Both routines return -1 if the integer limit is hit. I.e. for dates # after the 1st of January, 2038 on most machines. @epoch = localtime(0); $tzmin = $epoch[2] * 60 + $epoch[1]; # minutes east of GMT iperl5.000/lib/bigfloat.pl 644 203 12 15067 5367003624 10352 package bigfloat; require "bigint.pl"; # Arbitrary length float math package # # by Mark Biggar # # number format # canonical strings have the form /[+-]\d+E[+-]\d+/ # Input values can have inbedded whitespace # Error returns # 'NaN' An input parameter was "Not a Number" or # divide by zero or sqrt of negative number # Division is computed to # max($div_scale,length(dividend)+length(divisor)) # digits by default. # Also used for default sqrt scale $div_scale = 40; # Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'. $rnd_mode = 'even'; # bigfloat routines # # fadd(NSTR, NSTR) return NSTR addition # fsub(NSTR, NSTR) return NSTR subtraction # fmul(NSTR, NSTR) return NSTR multiplication # fdiv(NSTR, NSTR[,SCALE]) returns NSTR division to SCALE places # fneg(NSTR) return NSTR negation # fabs(NSTR) return NSTR absolute value # fcmp(NSTR,NSTR) return CODE compare undef,<0,=0,>0 # fround(NSTR, SCALE) return NSTR round to SCALE digits # ffround(NSTR, SCALE) return NSTR round at SCALEth place # fnorm(NSTR) return (NSTR) normalize # fsqrt(NSTR[, SCALE]) return NSTR sqrt to SCALE places # Convert a number to canonical string form. # Takes something that looks like a number and converts it to # the form /^[+-]\d+E[+-]\d+$/. sub main'fnorm { #(string) return fnum_str local($_) = @_; s/\s+//g; # strip white space if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/ && "$2$4" ne '') { &norm(($1 ? "$1$2$4" : "+$2$4"),(($4 ne '') ? $6-length($4) : $6)); } else { 'NaN'; } } # normalize number -- for internal use sub norm { #(mantissa, exponent) return fnum_str local($_, $exp) = @_; if ($_ eq 'NaN') { 'NaN'; } else { s/^([+-])0+/$1/; # strip leading zeros if (length($_) == 1) { '+0E+0'; } else { $exp += length($1) if (s/(0+)$//); # strip trailing zeros sprintf("%sE%+ld", $_, $exp); } } } # negation sub main'fneg { #(fnum_str) return fnum_str local($_) = &'fnorm($_[$[]); vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign s/^H/N/; $_; } # absolute value sub main'fabs { #(fnum_str) return fnum_str local($_) = &'fnorm($_[$[]); s/^-/+/; # mash sign $_; } # multiplication sub main'fmul { #(fnum_str, fnum_str) return fnum_str local($x,$y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1])); if ($x eq 'NaN' || $y eq 'NaN') { 'NaN'; } else { local($xm,$xe) = split('E',$x); local($ym,$ye) = split('E',$y); &norm(&'bmul($xm,$ym),$xe+$ye); } } # addition sub main'fadd { #(fnum_str, fnum_str) return fnum_str local($x,$y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1])); if ($x eq 'NaN' || $y eq 'NaN') { 'NaN'; } else { local($xm,$xe) = split('E',$x); local($ym,$ye) = split('E',$y); ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye); &norm(&'badd($ym,$xm.('0' x ($xe-$ye))),$ye); } } # subtraction sub main'fsub { #(fnum_str, fnum_str) return fnum_str &'fadd($_[$[],&'fneg($_[$[+1])); } # division # args are dividend, divisor, scale (optional) # result has at most max(scale, length(dividend), length(divisor)) digits sub main'fdiv #(fnum_str, fnum_str[,scale]) return fnum_str { local($x,$y,$scale) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]),$_[$[+2]); if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') { 'NaN'; } else { local($xm,$xe) = split('E',$x); local($ym,$ye) = split('E',$y); $scale = $div_scale if (!$scale); $scale = length($xm)-1 if (length($xm)-1 > $scale); $scale = length($ym)-1 if (length($ym)-1 > $scale); $scale = $scale + length($ym) - length($xm); &norm(&round(&'bdiv($xm.('0' x $scale),$ym),$ym), $xe-$ye-$scale); } } # round int $q based on fraction $r/$base using $rnd_mode sub round { #(int_str, int_str, int_str) return int_str local($q,$r,$base) = @_; if ($q eq 'NaN' || $r eq 'NaN') { 'NaN'; } elsif ($rnd_mode eq 'trunc') { $q; # just truncate } else { local($cmp) = &'bcmp(&'bmul($r,'+2'),$base); if ( $cmp < 0 || ($cmp == 0 && ( $rnd_mode eq 'zero' || ($rnd_mode eq '-inf' && (substr($q,$[,1) eq '+')) || ($rnd_mode eq '+inf' && (substr($q,$[,1) eq '-')) || ($rnd_mode eq 'even' && $q =~ /[24680]$/) || ($rnd_mode eq 'odd' && $q =~ /[13579]$/) )) ) { $q; # round down } else { &'badd($q, ((substr($q,$[,1) eq '-') ? '-1' : '+1')); # round up } } } # round the mantissa of $x to $scale digits sub main'fround { #(fnum_str, scale) return fnum_str local($x,$scale) = (&'fnorm($_[$[]),$_[$[+1]); if ($x eq 'NaN' || $scale <= 0) { $x; } else { local($xm,$xe) = split('E',$x); if (length($xm)-1 <= $scale) { $x; } else { &norm(&round(substr($xm,$[,$scale+1), "+0".substr($xm,$[+$scale+1,1),"+10"), $xe+length($xm)-$scale-1); } } } # round $x at the 10 to the $scale digit place sub main'ffround { #(fnum_str, scale) return fnum_str local($x,$scale) = (&'fnorm($_[$[]),$_[$[+1]); if ($x eq 'NaN') { 'NaN'; } else { local($xm,$xe) = split('E',$x); if ($xe >= $scale) { $x; } else { $xe = length($xm)+$xe-$scale; if ($xe < 1) { '+0E+0'; } elsif ($xe == 1) { &norm(&round('+0',"+0".substr($xm,$[+1,1),"+10"), $scale); } else { &norm(&round(substr($xm,$[,$xe), "+0".substr($xm,$[+$xe,1),"+10"), $scale); } } } } # compare 2 values returns one of undef, <0, =0, >0 # returns undef if either or both input value are not numbers sub main'fcmp #(fnum_str, fnum_str) return cond_code { local($x, $y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1])); if ($x eq "NaN" || $y eq "NaN") { undef; } else { ord($y) <=> ord($x) || ( local($xm,$xe,$ym,$ye) = split('E', $x."E$y"), (($xe <=> $ye) * (substr($x,$[,1).'1') || &bigint'cmp($xm,$ym)) ); } } # square root by Newtons method. sub main'fsqrt { #(fnum_str[, scale]) return fnum_str local($x, $scale) = (&'fnorm($_[$[]), $_[$[+1]); if ($x eq 'NaN' || $x =~ /^-/) { 'NaN'; } elsif ($x eq '+0E+0') { '+0E+0'; } else { local($xm, $xe) = split('E',$x); $scale = $div_scale if (!$scale); $scale = length($xm)-1 if ($scale < length($xm)-1); local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2)); while ($gs < 2*$scale) { $guess = &'fmul(&'fadd($guess,&'fdiv($x,$guess,$gs*2)),".5"); $gs *= 2; } &'fround($guess, $scale); } } 1; urn NSTR round to SCALE digits # ffround(NSTR, SCALE) return NSTR round at SCALEth place # fnorm(NSTR) return (NSTR) normalize # fsqrt(NSTR[, SCALE]) return NSTR sqrt to SCALE places # Convert a number to canonical string form. # Takes something that looks like a number and converts it to # the form /^[+-]\d+E[+-]\d+$/. sub main'fnorm { #(string) return fnum_str local($_) = @_; s/\s+//g; perl5.000/lib/bigint.pl 644 203 12 16707 5553661225 10045 package bigint; # arbitrary size integer math package # # by Mark Biggar # # Canonical Big integer value are strings of the form # /^[+-]\d+$/ with leading zeros suppressed # Input values to these routines may be strings of the form # /^\s*[+-]?[\d\s]+$/. # Examples: # '+0' canonical zero value # ' -123 123 123' canonical value '-123123123' # '1 23 456 7890' canonical value '+1234567890' # Output values always always in canonical form # # Actual math is done in an internal format consisting of an array # whose first element is the sign (/^[+-]$/) and whose remaining # elements are base 100000 digits with the least significant digit first. # The string 'NaN' is used to represent the result when input arguments # are not numbers, as well as the result of dividing by zero # # routines provided are: # # bneg(BINT) return BINT negation # babs(BINT) return BINT absolute value # bcmp(BINT,BINT) return CODE compare numbers (undef,<0,=0,>0) # badd(BINT,BINT) return BINT addition # bsub(BINT,BINT) return BINT subtraction # bmul(BINT,BINT) return BINT multiplication # bdiv(BINT,BINT) return (BINT,BINT) division (quo,rem) just quo if scalar # bmod(BINT,BINT) return BINT modulus # bgcd(BINT,BINT) return BINT greatest common divisor # bnorm(BINT) return BINT normalization # $zero = 0; # normalize string form of number. Strip leading zeros. Strip any # white space and add a sign, if missing. # Strings that are not numbers result the value 'NaN'. sub main'bnorm { #(num_str) return num_str local($_) = @_; s/\s+//g; # strip white space if (s/^([+-]?)0*(\d+)$/$1$2/) { # test if number substr($_,$[,0) = '+' unless $1; # Add missing sign s/^-0/+0/; $_; } else { 'NaN'; } } # Convert a number from string format to internal base 100000 format. # Assumes normalized value as input. sub internal { #(num_str) return int_num_array local($d) = @_; ($is,$il) = (substr($d,$[,1),length($d)-2); substr($d,$[,1) = ''; ($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d))); } # Convert a number from internal base 100000 format to string format. # This routine scribbles all over input array. sub external { #(int_num_array) return num_str $es = shift; grep($_ > 9999 || ($_ = substr('0000'.$_,-5)), @_); # zero pad &'bnorm(join('', $es, reverse(@_))); # reverse concat and normalize } # Negate input value. sub main'bneg { #(num_str) return num_str local($_) = &'bnorm(@_); vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0'; s/^H/N/; $_; } # Returns the absolute value of the input. sub main'babs { #(num_str) return num_str &abs(&'bnorm(@_)); } sub abs { # post-normalized abs for internal use local($_) = @_; s/^-/+/; $_; } # Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort) sub main'bcmp { #(num_str, num_str) return cond_code local($x,$y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1])); if ($x eq 'NaN') { undef; } elsif ($y eq 'NaN') { undef; } else { &cmp($x,$y); } } sub cmp { # post-normalized compare for internal use local($cx, $cy) = @_; $cx cmp $cy && ( ord($cy) <=> ord($cx) || ($cx cmp ',') * (length($cy) <=> length($cx) || $cy cmp $cx) ); } sub main'badd { #(num_str, num_str) return num_str local(*x, *y); ($x, $y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1])); if ($x eq 'NaN') { 'NaN'; } elsif ($y eq 'NaN') { 'NaN'; } else { @x = &internal($x); # convert to internal form @y = &internal($y); local($sx, $sy) = (shift @x, shift @y); # get signs if ($sx eq $sy) { &external($sx, &add(*x, *y)); # if same sign add } else { ($x, $y) = (&abs($x),&abs($y)); # make abs if (&cmp($y,$x) > 0) { &external($sy, &sub(*y, *x)); } else { &external($sx, &sub(*x, *y)); } } } } sub main'bsub { #(num_str, num_str) return num_str &'badd($_[$[],&'bneg($_[$[+1])); } # GCD -- Euclids algorithm Knuth Vol 2 pg 296 sub main'bgcd { #(num_str, num_str) return num_str local($x,$y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1])); if ($x eq 'NaN' || $y eq 'NaN') { 'NaN'; } else { ($x, $y) = ($y,&'bmod($x,$y)) while $y ne '+0'; $x; } } # routine to add two base 1e5 numbers # stolen from Knuth Vol 2 Algorithm A pg 231 # there are separate routines to add and sub as per Kunth pg 233 sub add { #(int_num_array, int_num_array) return int_num_array local(*x, *y) = @_; $car = 0; for $x (@x) { last unless @y || $car; $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5); } for $y (@y) { last unless $car; $y -= 1e5 if $car = (($y += $car) >= 1e5); } (@x, @y, $car); } # subtract base 1e5 numbers -- stolen from Knuth Vol 2 pg 232, $x > $y sub sub { #(int_num_array, int_num_array) return int_num_array local(*sx, *sy) = @_; $bar = 0; for $sx (@sx) { last unless @y || $bar; $sx += 1e5 if $bar = (($sx -= shift(@sy) + $bar) < 0); } @sx; } # multiply two numbers -- stolen from Knuth Vol 2 pg 233 sub main'bmul { #(num_str, num_str) return num_str local(*x, *y); ($x, $y) = (&'bnorm($_[$[]), &'bnorm($_[$[+1])); if ($x eq 'NaN') { 'NaN'; } elsif ($y eq 'NaN') { 'NaN'; } else { @x = &internal($x); @y = &internal($y); local($signr) = (shift @x ne shift @y) ? '-' : '+'; @prod = (); for $x (@x) { ($car, $cty) = (0, $[); for $y (@y) { $prod = $x * $y + $prod[$cty] + $car; $prod[$cty++] = $prod - ($car = int($prod * 1e-5)) * 1e5; } $prod[$cty] += $car if $car; $x = shift @prod; } &external($signr, @x, @prod); } } # modulus sub main'bmod { #(num_str, num_str) return num_str (&'bdiv(@_))[$[+1]; } sub main'bdiv { #(dividend: num_str, divisor: num_str) return num_str local (*x, *y); ($x, $y) = (&'bnorm($_[$[]), &'bnorm($_[$[+1])); return wantarray ? ('NaN','NaN') : 'NaN' if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0'); return wantarray ? ('+0',$x) : '+0' if (&cmp(&abs($x),&abs($y)) < 0); @x = &internal($x); @y = &internal($y); $srem = $y[$[]; $sr = (shift @x ne shift @y) ? '-' : '+'; $car = $bar = $prd = 0; if (($dd = int(1e5/($y[$#y]+1))) != 1) { for $x (@x) { $x = $x * $dd + $car; $x -= ($car = int($x * 1e-5)) * 1e5; } push(@x, $car); $car = 0; for $y (@y) { $y = $y * $dd + $car; $y -= ($car = int($y * 1e-5)) * 1e5; } } else { push(@x, 0); } @q = (); ($v2,$v1) = @y[-2,-1]; while ($#x > $#y) { ($u2,$u1,$u0) = @x[-3..-1]; $q = (($u0 == $v1) ? 99999 : int(($u0*1e5+$u1)/$v1)); --$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*1e5+$u2); if ($q) { ($car, $bar) = (0,0); for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) { $prd = $q * $y[$y] + $car; $prd -= ($car = int($prd * 1e-5)) * 1e5; $x[$x] += 1e5 if ($bar = (($x[$x] -= $prd + $bar) < 0)); } if ($x[$#x] < $car + $bar) { $car = 0; --$q; for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) { $x[$x] -= 1e5 if ($car = (($x[$x] += $y[$y] + $car) > 1e5)); } } } pop(@x); unshift(@q, $q); } if (wantarray) { @d = (); if ($dd != 1) { $car = 0; for $x (reverse @x) { $prd = $car * 1e5 + $x; $car = $prd - ($tmp = int($prd / $dd)) * $dd; unshift(@d, $tmp); } } else { @d = @x; } (&external($sr, @q), &external($srem, @d, $zero)); } else { &external($sr, @q); } } 1; o = 0; # normalize string form of number. Strip leadperl5.000/lib/bigrat.pl 644 203 12 10177 5307712477 10037 package bigrat; require "bigint.pl"; # Arbitrary size rational math package # # by Mark Biggar # # Input values to these routines consist of strings of the form # m|^\s*[+-]?[\d\s]+(/[\d\s]+)?$|. # Examples: # "+0/1" canonical zero value # "3" canonical value "+3/1" # " -123/123 123" canonical value "-1/1001" # "123 456/7890" canonical value "+20576/1315" # Output values always include a sign and no leading zeros or # white space. # This package makes use of the bigint package. # The string 'NaN' is used to represent the result when input arguments # that are not numbers, as well as the result of dividing by zero and # the sqrt of a negative number. # Extreamly naive algorthims are used. # # Routines provided are: # # rneg(RAT) return RAT negation # rabs(RAT) return RAT absolute value # rcmp(RAT,RAT) return CODE compare numbers (undef,<0,=0,>0) # radd(RAT,RAT) return RAT addition # rsub(RAT,RAT) return RAT subtraction # rmul(RAT,RAT) return RAT multiplication # rdiv(RAT,RAT) return RAT division # rmod(RAT) return (RAT,RAT) integer and fractional parts # rnorm(RAT) return RAT normalization # rsqrt(RAT, cycles) return RAT square root # Convert a number to the canonical string form m|^[+-]\d+/\d+|. sub main'rnorm { #(string) return rat_num local($_) = @_; s/\s+//g; if (m#^([+-]?\d+)(/(\d*[1-9]0*))?$#) { &norm($1, $3 ? $3 : '+1'); } else { 'NaN'; } } # Normalize by reducing to lowest terms sub norm { #(bint, bint) return rat_num local($num,$dom) = @_; if ($num eq 'NaN') { 'NaN'; } elsif ($dom eq 'NaN') { 'NaN'; } elsif ($dom =~ /^[+-]?0+$/) { 'NaN'; } else { local($gcd) = &'bgcd($num,$dom); if ($gcd ne '+1') { $num = &'bdiv($num,$gcd); $dom = &'bdiv($dom,$gcd); } else { $num = &'bnorm($num); $dom = &'bnorm($dom); } substr($dom,$[,1) = ''; "$num/$dom"; } } # negation sub main'rneg { #(rat_num) return rat_num local($_) = &'rnorm(@_); tr/-+/+-/ if ($_ ne '+0/1'); $_; } # absolute value sub main'rabs { #(rat_num) return $rat_num local($_) = &'rnorm(@_); substr($_,$[,1) = '+' unless $_ eq 'NaN'; $_; } # multipication sub main'rmul { #(rat_num, rat_num) return rat_num local($xn,$xd) = split('/',&'rnorm($_[$[])); local($yn,$yd) = split('/',&'rnorm($_[$[+1])); &norm(&'bmul($xn,$yn),&'bmul($xd,$yd)); } # division sub main'rdiv { #(rat_num, rat_num) return rat_num local($xn,$xd) = split('/',&'rnorm($_[$[])); local($yn,$yd) = split('/',&'rnorm($_[$[+1])); &norm(&'bmul($xn,$yd),&'bmul($xd,$yn)); } # addition sub main'radd { #(rat_num, rat_num) return rat_num local($xn,$xd) = split('/',&'rnorm($_[$[])); local($yn,$yd) = split('/',&'rnorm($_[$[+1])); &norm(&'badd(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd)); } # subtraction sub main'rsub { #(rat_num, rat_num) return rat_num local($xn,$xd) = split('/',&'rnorm($_[$[])); local($yn,$yd) = split('/',&'rnorm($_[$[+1])); &norm(&'bsub(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd)); } # comparison sub main'rcmp { #(rat_num, rat_num) return cond_code local($xn,$xd) = split('/',&'rnorm($_[$[])); local($yn,$yd) = split('/',&'rnorm($_[$[+1])); &bigint'cmp(&'bmul($xn,$yd),&'bmul($yn,$xd)); } # int and frac parts sub main'rmod { #(rat_num) return (rat_num,rat_num) local($xn,$xd) = split('/',&'rnorm(@_)); local($i,$f) = &'bdiv($xn,$xd); if (wantarray) { ("$i/1", "$f/$xd"); } else { "$i/1"; } } # square root by Newtons method. # cycles specifies the number of iterations default: 5 sub main'rsqrt { #(fnum_str[, cycles]) return fnum_str local($x, $scale) = (&'rnorm($_[$[]), $_[$[+1]); if ($x eq 'NaN') { 'NaN'; } elsif ($x =~ /^-/) { 'NaN'; } else { local($gscale, $guess) = (0, '+1/1'); $scale = 5 if (!$scale); while ($gscale++ < $scale) { $guess = &'rmul(&'radd($guess,&'rdiv($x,$guess)),"+1/2"); } "$guess"; # quotes necessary due to perl bug } } 1; _str) return num_str local($x,$y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1])); if ($x eq 'NaN' || $y eq 'NaN') { 'NaN'; } else { ($x, $y) = ($y,&'bmod($x,$y)) while $y ne '+0'; $x; } } # routine to add two base 1e5 numbers # stolen from Knuth Vol 2 Algorithm A pg 231 # there are separate routines to add and sub as per Kunth pg 233 sub add { #(int_num_array, int_nuperl5.000/lib/cacheout.pl 644 203 12 1516 5636434766 10346 # Open in their package. sub cacheout'open { open($_[0], $_[1]); } # Close as well sub cacheout'close { close($_[0]); } # But only this sub name is visible to them. sub cacheout { package cacheout; ($file) = @_; if (!$isopen{$file}) { if (++$numopen > $maxopen) { local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen); splice(@lru, $maxopen / 3); $numopen -= @lru; for (@lru) { &close($_); delete $isopen{$_}; } } &open($file, ($saw{$file}++ ? '>>' : '>') . $file) || die "Can't create $file: $!\n"; } $isopen{$file} = ++$seq; } package cacheout; $seq = 0; $numopen = 0; if (open(PARAM,'/usr/include/sys/param.h')) { local($.); while () { $maxopen = $1 - 4 if /^\s*#\s*define\s+NOFILE\s+(\d+)/; } close PARAM; } $maxopen = 16 unless $maxopen; 1; validate.pl negation # rabs(RAT) return RAT absolute value # rcmp(RAT,RAT) return CODE compare numbers (undef,<0,=0,>0) # radd(RATperl5.000/lib/chat2.inter 664 203 12 31316 5554057307 10274 Article 20992 of comp.lang.perl: Path: netlabs!news.cerf.net!mvb.saic.com!MathWorks.Com!europa.eng.gtefsd.com!howland.reston.ans.net!cs.utexas.edu!swrinde!ihnp4.ucsd.edu!ames!koriel!male.EBay.Sun.COM!jethro.Corp.Sun.COM!eric From: eric.arnold@sun.com (Eric Arnold) Newsgroups: comp.lang.perl Subject: Re: Need a bidirectional filter for interactive Unix applications Date: 15 Apr 94 21:24:03 GMT Organization: Sun Microsystems Lines: 478 Sender: news@sun.com Message-ID: References: <1994Apr15.110134.4581@chemabs.uucp> NNTP-Posting-Host: animus.corp.sun.com X-Newsreader: prn Ver 1.09 In-reply-to: btf64@cas.org's message of Fri, 15 Apr 1994 11:01:34 GMT In article <1994Apr15.110134.4581@chemabs.uucp> btf64@cas.org (Bernard T. French) writes: >In article dgf@netcom.com (David Feldman) writes: >>I need to write a bidirectional filter that would (ideally) sit between a .. >>program's stdin & stdout to point to a pty pair known to perl. The perl app- >>lication would talk to the user's crt/keyboard, translate (application-specific) >>the input & output streams, and pass these as appropriate to/from the pty pair, .. > > I'm afraid I can't offer you a perl solution, but err..... there is a >Tcl solution. There is a Tcl extension called "expect" that is designed to There *is* an old, established Perl solution: "chat2.pl" which does everything (well, basically) "expect" does but you get it in the expressive Perl environment. "chat2.pl" is delivered with the Perl source. Randal: "interact()" still hasn't made it into Perl5alpha8 "chat2.pl", so I've included a version which does. -Eric ## chat.pl: chat with a server ## V2.01.alpha.7 91/06/16 ## Randal L. Schwartz package chat; $sockaddr = 'S n a4 x8'; chop($thishost = `hostname`); $thisaddr = (gethostbyname($thishost))[4]; $thisproc = pack($sockaddr, 2, 0, $thisaddr); # *S = symbol for current I/O, gets assigned *chatsymbol.... $next = "chatsymbol000000"; # next one $nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++ ## $handle = &chat'open_port("server.address",$port_number); ## opens a named or numbered TCP server sub open_port { ## public local($server, $port) = @_; local($serveraddr,$serverproc); *S = ++$next; if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) { $serveraddr = pack('C4', $1, $2, $3, $4); } else { local(@x) = gethostbyname($server); return undef unless @x; $serveraddr = $x[4]; } $serverproc = pack($sockaddr, 2, $port, $serveraddr); unless (socket(S, 2, 1, 6)) { # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp' # but who the heck would change these anyway? (:-) ($!) = ($!, close(S)); # close S while saving $! return undef; } unless (bind(S, $thisproc)) { ($!) = ($!, close(S)); # close S while saving $! return undef; } unless (connect(S, $serverproc)) { ($!) = ($!, close(S)); # close S while saving $! return undef; } select((select(S), $| = 1)[0]); $next; # return symbol for switcharound } ## ($host, $port, $handle) = &chat'open_listen([$port_number]); ## opens a TCP port on the current machine, ready to be listened to ## if $port_number is absent or zero, pick a default port number ## process must be uid 0 to listen to a low port number sub open_listen { ## public *S = ++$next; local($thisport) = shift || 0; local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr); local(*NS) = "__" . time; unless (socket(NS, 2, 1, 6)) { # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp' # but who the heck would change these anyway? (:-) ($!) = ($!, close(NS)); return undef; } unless (bind(NS, $thisproc_local)) { ($!) = ($!, close(NS)); return undef; } unless (listen(NS, 1)) { ($!) = ($!, close(NS)); return undef; } select((select(NS), $| = 1)[0]); local($family, $port, @myaddr) = unpack("S n C C C C x8", getsockname(NS)); $S{"needs_accept"} = *NS; # so expect will open it (@myaddr, $port, $next); # returning this } ## $handle = &chat'open_proc("command","arg1","arg2",...); ## opens a /bin/sh on a pseudo-tty sub open_proc { ## public local(@cmd) = @_; *S = ++$next; local(*TTY) = "__TTY" . time; local($pty,$tty,$pty_handle) = &_getpty(S,TTY); #local($pty,$tty,$pty_handle) = &getpty(S,TTY); #$Tty = $tty; die "Cannot find a new pty" unless defined $pty; local($pid) = fork; die "Cannot fork: $!" unless defined $pid; unless ($pid) { close STDIN; close STDOUT; close STDERR; #close($pty_handle); setpgrp(0,$$); if (open(DEVTTY, "/dev/tty")) { ioctl(DEVTTY,0x20007471,0); # XXX s/b &TIOCNOTTY close DEVTTY; } open(STDIN,"<&TTY"); open(STDOUT,">&TTY"); open(STDERR,">&STDOUT"); die "Oops" unless fileno(STDERR) == 2; # sanity close(S); exec @cmd; die "Cannot exec @cmd: $!"; } close(TTY); $PID{$next} = $pid; $next; # return symbol for switcharound } # $S is the read-ahead buffer ## $return = &chat'expect([$handle,] $timeout_time, ## $pat1, $body1, $pat2, $body2, ... ) ## $handle is from previous &chat'open_*(). ## $timeout_time is the time (either relative to the current time, or ## absolute, ala time(2)) at which a timeout event occurs. ## $pat1, $pat2, and so on are regexs which are matched against the input ## stream. If a match is found, the entire matched string is consumed, ## and the corresponding body eval string is evaled. ## ## Each pat is a regular-expression (probably enclosed in single-quotes ## in the invocation). ^ and $ will work, respecting the current value of $*. ## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded. ## If pat is 'EOF', the body is executed if the process exits before ## the other patterns are seen. ## ## Pats are scanned in the order given, so later pats can contain ## general defaults that won't be examined unless the earlier pats ## have failed. ## ## The result of eval'ing body is returned as the result of ## the invocation. Recursive invocations are not thought ## through, and may work only accidentally. :-) ## ## undef is returned if either a timeout or an eof occurs and no ## corresponding body has been defined. ## I/O errors of any sort are treated as eof. $nextsubname = "expectloop000000"; # used for subroutines sub expect { ## public if ($_[0] =~ /$nextpat/) { *S = shift; } local($endtime) = shift; local($timeout,$eof) = (1,1); local($caller) = caller; local($rmask, $nfound, $timeleft, $thisbuf); local($cases, $pattern, $action, $subname); $endtime += time if $endtime < 600_000_000; if (defined $S{"needs_accept"}) { # is it a listen socket? local(*NS) = $S{"needs_accept"}; delete $S{"needs_accept"}; $S{"needs_close"} = *NS; unless(accept(S,NS)) { ($!) = ($!, close(S), close(NS)); return undef; } select((select(S), $| = 1)[0]); } # now see whether we need to create a new sub: unless ($subname = $expect_subname{$caller,@_}) { # nope. make a new one: $expect_subname{$caller,@_} = $subname = $nextsubname++; $cases .= <<"EDQ"; # header is funny to make everything elsif's sub $subname { LOOP: { if (0) { ; } EDQ while (@_) { ($pattern,$action) = splice(@_,0,2); if ($pattern =~ /^eof$/i) { $cases .= <<"EDQ"; elsif (\$eof) { package $caller; $action; } EDQ $eof = 0; } elsif ($pattern =~ /^timeout$/i) { $cases .= <<"EDQ"; elsif (\$timeout) { package $caller; $action; } EDQ $timeout = 0; } else { $pattern =~ s#/#\\/#g; $cases .= <<"EDQ"; elsif (\$S =~ /$pattern/) { \$S = \$'; package $caller; $action; } EDQ } } $cases .= <<"EDQ" if $eof; elsif (\$eof) { undef; } EDQ $cases .= <<"EDQ" if $timeout; elsif (\$timeout) { undef; } EDQ $cases .= <<'ESQ'; else { $rmask = ""; vec($rmask,fileno(S),1) = 1; ($nfound, $rmask) = select($rmask, undef, undef, $endtime - time); if ($nfound) { $nread = sysread(S, $thisbuf, 1024); if ($nread > 0) { $S .= $thisbuf; } else { $eof++, redo LOOP; # any error is also eof } } else { $timeout++, redo LOOP; # timeout } redo LOOP; } } } ESQ eval $cases; die "$cases:\n$@" if $@; } $eof = $timeout = 0; do $subname(); } ## &chat'print([$handle,] @data) ## $handle is from previous &chat'open(). ## like print $handle @data sub print { ## public if ($_[0] =~ /$nextpat/) { *S = shift; } print S @_; } ## &chat'close([$handle,]) ## $handle is from previous &chat'open(). ## like close $handle sub close { ## public local($pid); if ($_[0] =~ /$nextpat/) { $pid = $PID{$_[0]}; *S = shift; } else { $pid = $PID{$next}; } close(S); waitpid($pid,0); if (defined $S{"needs_close"}) { # is it a listen socket? local(*NS) = $S{"needs_close"}; delete $S{"needs_close"}; close(NS); } } ## @ready_handles = &chat'select($timeout, @handles) ## select()'s the handles with a timeout value of $timeout seconds. ## Returns an array of handles that are ready for I/O. ## Both user handles and chat handles are supported (but beware of ## stdio's buffering for user handles). sub select { ## public local($timeout) = shift; local(@handles) = @_; local(%handlename) = (); local(%ready) = (); local($caller) = caller; local($rmask) = ""; for (@handles) { if (/$nextpat/o) { # one of ours... see if ready local(*SYM) = $_; if (length($SYM)) { $timeout = 0; # we have a winner $ready{$_}++; } $handlename{fileno($_)} = $_; } else { $handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_; } } for (sort keys %handlename) { vec($rmask, $_, 1) = 1; } select($rmask, undef, undef, $timeout); for (sort keys %handlename) { $ready{$handlename{$_}}++ if vec($rmask,$_,1); } sort keys %ready; } # ($pty,$tty) = $chat'_getpty(PTY,TTY): # internal procedure to get the next available pty. # opens pty on handle PTY, and matching tty on handle TTY. # returns undef if can't find a pty. sub _getpty { ## private local($_PTY,$_TTY) = @_; $_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e; $_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e; local($pty,$tty); for $bank (112..127) { next unless -e sprintf("/dev/pty%c0", $bank); for $unit (48..57) { $pty = sprintf("/dev/pty%c%c", $bank, $unit); open($_PTY,"+>$pty") || next; select((select($_PTY), $| = 1)[0]); ($tty = $pty) =~ s/pty/tty/; open($_TTY,"+>$tty") || next; select((select($_TTY), $| = 1)[0]); system "stty nl>$tty"; return ($pty,$tty,$_PTY); } } undef; } sub getpty { local( $pty_handle, $tty_handle ) = @_; print "--------in getpty----------\n"; $pty_handle =~ s/^([^']+)$/(caller)[$[]."'".$1/e; $pty_handle =~ s/^([^']+)$/(caller)[$[]."'".$1/e; #$pty_handle = ++$next_handle; chop( @ptys = `ls /dev/pty*` ); for $pty ( @ptys ) { open($pty_handle,"+>$pty") || next; select((select($pty_handle), $| = 1)[0]); ($tty = $pty) =~ s/pty/tty/; open($tty_handle,"+>$tty") || next; select((select($tty_handle), $| = 1)[0]); ($tty = $pty) =~ s/pty/tty/; return ($pty, $tty, $pty_handle ); } return undef; } # from: Randal L. Schwartz # Usage: # # ($chathandle = &chat'open_proc("/bin/sh")) || die "cannot open shell"; # system("stty cbreak raw -echo >/dev/tty\n"); # &chat'interact($chathandle); # &chat'close($chathandle); # system("stty -cbreak -raw echo >/dev/tty\n"); sub interact { local( $chathandle ) = @_; &chat'print($chathandle, "stty sane\n"); select(STDOUT) ; $| = 1; # unbuffer STDOUT #print "tty=$Tty,whoami=",`whoami`,"\n"; #&change_utmp( "", $Tty, "eric", "", time() ); { @ready = &chat'select(30, STDIN,$chathandle); print "after select, ready=",join(",",@ready),"\n"; #(warn "[waiting]"), redo unless @ready; if (grep($_ eq $chathandle, @ready)) { print "checking $chathandle\n"; last unless $text = &chat'expect($chathandle,0,'[\s\S]+','$&'); print "$chathandle OK\n"; print "got=($text)"; #print $text; } if (grep($_ eq STDIN, @ready)) { print "checking STDIN\n"; last unless sysread(STDIN,$buf,1024) > 0; print "STDIN OK\n"; &chat'print($chathandle,$buf); } redo; } #&change_utmp( $Tty, "$Tty", "", "", 0 ); print "leaving interact, \$!=$!\n"; } ## $handle = &chat'open_duphandle(handle); ## duplicates an input file handle to conform to chat format sub open_duphandle { ## public *S = ++$next; open(S,"<&$_[0]"); $next; # return symbol for switcharound } #Here is an example which uses this routine. # # # The following lines makes stdin unbuffered # # $BSD = -f '/vmunix'; # # if ($BSD) { # system "stty cbreak /dev/tty 2>&1"; # } # else { # system "stty", '-icanon'; # system "stty", 'eol', '^A'; # } # # require 'mychat2.pl'; # # &chat'open_duphandle(STDIN); # # print # &chat'expect(3, # '[A-Z]', '" :-)"', # '.', '" :-("', # TIMEOUT, '"-o-"', # EOF, '"\$\$"'), # "\n"; 1; matched string is consumed, ## and the corresponding body eval string is evaled. ## ## Each pat is a regular-expression (probably enclosed in single-quotes ## in the invocation). ^ and $ will work, respecting the current value of $*. ## If pat is 'TIMEOUT', the body is executed if the timeout is exceedeperl5.000/lib/chat2.pl 664 203 12 22623 5645374723 7574 # chat.pl: chat with a server # Based on: V2.01.alpha.7 91/06/16 # Randal L. Schwartz (was ) # multihome additions by A.Macpherson@bnr.co.uk # allow for /dev/pts based systems by Joe Doupnik package chat; if( defined( &main'PF_INET ) ){ $pf_inet = &main'PF_INET; $sock_stream = &main'SOCK_STREAM; local($name, $aliases, $proto) = getprotobyname( 'tcp' ); $tcp_proto = $proto; } else { # XXX hardwired $PF_INET, $SOCK_STREAM, 'tcp' # but who the heck would change these anyway? (:-) $pf_inet = 2; $sock_stream = 1; $tcp_proto = 6; } $sockaddr = 'S n a4 x8'; chop($thishost = `hostname`); # *S = symbol for current I/O, gets assigned *chatsymbol.... $next = "chatsymbol000000"; # next one $nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++ ## $handle = &chat'open_port("server.address",$port_number); ## opens a named or numbered TCP server sub open_port { ## public local($server, $port) = @_; local($serveraddr,$serverproc); # We may be multi-homed, start with 0, fixup once connexion is made $thisaddr = "\0\0\0\0" ; $thisproc = pack($sockaddr, 2, 0, $thisaddr); *S = ++$next; if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) { $serveraddr = pack('C4', $1, $2, $3, $4); } else { local(@x) = gethostbyname($server); return undef unless @x; $serveraddr = $x[4]; } $serverproc = pack($sockaddr, 2, $port, $serveraddr); unless (socket(S, $pf_inet, $sock_stream, $tcp_proto)) { ($!) = ($!, close(S)); # close S while saving $! return undef; } unless (bind(S, $thisproc)) { ($!) = ($!, close(S)); # close S while saving $! return undef; } unless (connect(S, $serverproc)) { ($!) = ($!, close(S)); # close S while saving $! return undef; } # We opened with the local address set to ANY, at this stage we know # which interface we are using. This is critical if our machine is # multi-homed, with IP forwarding off, so fix-up. local($fam,$lport); ($fam,$lport,$thisaddr) = unpack($sockaddr, getsockname(S)); $thisproc = pack($sockaddr, 2, 0, $thisaddr); # end of post-connect fixup select((select(S), $| = 1)[0]); $next; # return symbol for switcharound } ## ($host, $port, $handle) = &chat'open_listen([$port_number]); ## opens a TCP port on the current machine, ready to be listened to ## if $port_number is absent or zero, pick a default port number ## process must be uid 0 to listen to a low port number sub open_listen { ## public *S = ++$next; local($thisport) = shift || 0; local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr); local(*NS) = "__" . time; unless (socket(NS, $pf_inet, $sock_stream, $tcp_proto)) { ($!) = ($!, close(NS)); return undef; } unless (bind(NS, $thisproc_local)) { ($!) = ($!, close(NS)); return undef; } unless (listen(NS, 1)) { ($!) = ($!, close(NS)); return undef; } select((select(NS), $| = 1)[0]); local($family, $port, @myaddr) = unpack("S n C C C C x8", getsockname(NS)); $S{"needs_accept"} = *NS; # so expect will open it (@myaddr, $port, $next); # returning this } ## $handle = &chat'open_proc("command","arg1","arg2",...); ## opens a /bin/sh on a pseudo-tty sub open_proc { ## public local(@cmd) = @_; *S = ++$next; local(*TTY) = "__TTY" . time; local($pty,$tty) = &_getpty(S,TTY); die "Cannot find a new pty" unless defined $pty; $pid = fork; die "Cannot fork: $!" unless defined $pid; unless ($pid) { close STDIN; close STDOUT; close STDERR; setpgrp(0,$$); if (open(DEVTTY, "/dev/tty")) { ioctl(DEVTTY,0x20007471,0); # XXX s/b &TIOCNOTTY close DEVTTY; } open(STDIN,"<&TTY"); open(STDOUT,">&TTY"); open(STDERR,">&STDOUT"); die "Oops" unless fileno(STDERR) == 2; # sanity close(S); exec @cmd; die "Cannot exec @cmd: $!"; } close(TTY); $next; # return symbol for switcharound } # $S is the read-ahead buffer ## $return = &chat'expect([$handle,] $timeout_time, ## $pat1, $body1, $pat2, $body2, ... ) ## $handle is from previous &chat'open_*(). ## $timeout_time is the time (either relative to the current time, or ## absolute, ala time(2)) at which a timeout event occurs. ## $pat1, $pat2, and so on are regexs which are matched against the input ## stream. If a match is found, the entire matched string is consumed, ## and the corresponding body eval string is evaled. ## ## Each pat is a regular-expression (probably enclosed in single-quotes ## in the invocation). ^ and $ will work, respecting the current value of $*. ## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded. ## If pat is 'EOF', the body is executed if the process exits before ## the other patterns are seen. ## ## Pats are scanned in the order given, so later pats can contain ## general defaults that won't be examined unless the earlier pats ## have failed. ## ## The result of eval'ing body is returned as the result of ## the invocation. Recursive invocations are not thought ## through, and may work only accidentally. :-) ## ## undef is returned if either a timeout or an eof occurs and no ## corresponding body has been defined. ## I/O errors of any sort are treated as eof. $nextsubname = "expectloop000000"; # used for subroutines sub expect { ## public if ($_[0] =~ /$nextpat/) { *S = shift; } local($endtime) = shift; local($timeout,$eof) = (1,1); local($caller) = caller; local($rmask, $nfound, $timeleft, $thisbuf); local($cases, $pattern, $action, $subname); $endtime += time if $endtime < 600_000_000; if (defined $S{"needs_accept"}) { # is it a listen socket? local(*NS) = $S{"needs_accept"}; delete $S{"needs_accept"}; $S{"needs_close"} = *NS; unless(accept(S,NS)) { ($!) = ($!, close(S), close(NS)); return undef; } select((select(S), $| = 1)[0]); } # now see whether we need to create a new sub: unless ($subname = $expect_subname{$caller,@_}) { # nope. make a new one: $expect_subname{$caller,@_} = $subname = $nextsubname++; $cases .= <<"EDQ"; # header is funny to make everything elsif's sub $subname { LOOP: { if (0) { ; } EDQ while (@_) { ($pattern,$action) = splice(@_,0,2); if ($pattern =~ /^eof$/i) { $cases .= <<"EDQ"; elsif (\$eof) { package $caller; $action; } EDQ $eof = 0; } elsif ($pattern =~ /^timeout$/i) { $cases .= <<"EDQ"; elsif (\$timeout) { package $caller; $action; } EDQ $timeout = 0; } else { $pattern =~ s#/#\\/#g; $cases .= <<"EDQ"; elsif (\$S =~ /$pattern/) { \$S = \$'; package $caller; $action; } EDQ } } $cases .= <<"EDQ" if $eof; elsif (\$eof) { undef; } EDQ $cases .= <<"EDQ" if $timeout; elsif (\$timeout) { undef; } EDQ $cases .= <<'ESQ'; else { $rmask = ""; vec($rmask,fileno(S),1) = 1; ($nfound, $rmask) = select($rmask, undef, undef, $endtime - time); if ($nfound) { $nread = sysread(S, $thisbuf, 1024); if ($nread > 0) { $S .= $thisbuf; } else { $eof++, redo LOOP; # any error is also eof } } else { $timeout++, redo LOOP; # timeout } redo LOOP; } } } ESQ eval $cases; die "$cases:\n$@" if $@; } $eof = $timeout = 0; do $subname(); } ## &chat'print([$handle,] @data) ## $handle is from previous &chat'open(). ## like print $handle @data sub print { ## public if ($_[0] =~ /$nextpat/) { *S = shift; } print S @_; if( $chat'debug ){ print STDERR "printed:"; print STDERR @_; } } ## &chat'close([$handle,]) ## $handle is from previous &chat'open(). ## like close $handle sub close { ## public if ($_[0] =~ /$nextpat/) { *S = shift; } close(S); if (defined $S{"needs_close"}) { # is it a listen socket? local(*NS) = $S{"needs_close"}; delete $S{"needs_close"}; close(NS); } } ## @ready_handles = &chat'select($timeout, @handles) ## select()'s the handles with a timeout value of $timeout seconds. ## Returns an array of handles that are ready for I/O. ## Both user handles and chat handles are supported (but beware of ## stdio's buffering for user handles). sub select { ## public local($timeout) = shift; local(@handles) = @_; local(%handlename) = (); local(%ready) = (); local($caller) = caller; local($rmask) = ""; for (@handles) { if (/$nextpat/o) { # one of ours... see if ready local(*SYM) = $_; if (length($SYM)) { $timeout = 0; # we have a winner $ready{$_}++; } $handlename{fileno($_)} = $_; } else { $handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_; } } for (sort keys %handlename) { vec($rmask, $_, 1) = 1; } select($rmask, undef, undef, $timeout); for (sort keys %handlename) { $ready{$handlename{$_}}++ if vec($rmask,$_,1); } sort keys %ready; } # ($pty,$tty) = $chat'_getpty(PTY,TTY): # internal procedure to get the next available pty. # opens pty on handle PTY, and matching tty on handle TTY. # returns undef if can't find a pty. # Modify "/dev/pty" to "/dev/pts" for Dell Unix v2.2 (aka SVR4.04). Joe Doupnik. sub _getpty { ## private local($_PTY,$_TTY) = @_; $_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e; $_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e; local($pty, $tty, $kind); if( -e "/dev/pts000" ){ ## mods by Joe Doupnik Dec 1992 $kind = "pts"; ## SVR4 Streams } else { $kind = "pty"; ## BSD Clist stuff } for $bank (112..127) { next unless -e sprintf("/dev/$kind%c0", $bank); for $unit (48..57) { $pty = sprintf("/dev/$kind%c%c", $bank, $unit); open($_PTY,"+>$pty") || next; select((select($_PTY), $| = 1)[0]); ($tty = $pty) =~ s/pty/tty/; open($_TTY,"+>$tty") || next; select((select($_TTY), $| = 1)[0]); system "stty nl>$tty"; return ($pty,$tty); } } undef; } 1; caller; $action; } EDQ } } $cases .= <<"EDQ" if $eof; elsif (\$eof) { undef; } EDQ $caseperl5.000/lib/complete.pl 644 203 12 5447 5240620776 10357 ;# ;# @(#)complete.pl,v1.1 (me@anywhere.EBay.Sun.COM) 09/23/91 ;# ;# Author: Wayne Thompson ;# ;# Description: ;# This routine provides word completion. ;# (TAB) attempts word completion. ;# (^D) prints completion list. ;# (These may be changed by setting $Complete'complete, etc.) ;# ;# Diagnostics: ;# Bell when word completion fails. ;# ;# Dependencies: ;# The tty driver is put into raw mode. ;# ;# Bugs: ;# ;# Usage: ;# $input = &Complete('prompt_string', *completion_list); ;# or ;# $input = &Complete('prompt_string', @completion_list); ;# CONFIG: { package Complete; $complete = "\004"; $kill = "\025"; $erase1 = "\177"; $erase2 = "\010"; } sub Complete { package Complete; local($[) = 0; if ($_[1] =~ /^StB\0/) { ($prompt, *_) = @_; } else { $prompt = shift(@_); } @cmp_lst = sort(@_); system('stty raw -echo'); LOOP: { print($prompt, $return); while (($_ = getc(STDIN)) ne "\r") { CASE: { # (TAB) attempt completion $_ eq "\t" && do { @match = grep(/^$return/, @cmp_lst); $l = length($test = shift(@match)); unless ($#match < 0) { foreach $cmp (@match) { until (substr($cmp, 0, $l) eq substr($test, 0, $l)) { $l--; } } print("\a"); } print($test = substr($test, $r, $l - $r)); $r = length($return .= $test); last CASE; }; # (^D) completion list $_ eq $complete && do { print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n"); redo LOOP; }; # (^U) kill $_ eq $kill && do { if ($r) { undef($r, $return); print("\r\n"); redo LOOP; } last CASE; }; # (DEL) || (BS) erase ($_ eq $erase1 || $_ eq $erase2) && do { if($r) { print("\b \b"); chop($return); $r--; } last CASE; }; # printable char ord >= 32 && do { $return .= $_; $r++; print; last CASE; }; } } } system('stty -raw echo'); print("\n"); $return; } 1; are not thought ## through, and may work only accidentally. :-) ## ## undef is returned if either a timeout or an eof occurs and no ## corresponding body has been defined. ## I/O errors of any sort are treated as eof.perl5.000/lib/ctime.pl 644 203 12 3253 5451614457 7644 ;# ctime.pl is a simple Perl emulation for the well known ctime(3C) function. ;# ;# Waldemar Kebsch, Federal Republic of Germany, November 1988 ;# kebsch.pad@nixpbe.UUCP ;# Modified March 1990, Feb 1991 to properly handle timezones ;# $RCSfile: ctime.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:47 $ ;# Marion Hakanson (hakanson@cse.ogi.edu) ;# Oregon Graduate Institute of Science and Technology ;# ;# usage: ;# ;# #include # see the -P and -I option in perl.man ;# $Date = &ctime(time); CONFIG: { package ctime; @DoW = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat'); @MoY = ('Jan','Feb','Mar','Apr','May','Jun', 'Jul','Aug','Sep','Oct','Nov','Dec'); } sub ctime { package ctime; local($time) = @_; local($[) = 0; local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst); # Determine what time zone is in effect. # Use GMT if TZ is defined as null, local time if TZ undefined. # There's no portable way to find the system default timezone. $TZ = defined($ENV{'TZ'}) ? ( $ENV{'TZ'} ? $ENV{'TZ'} : 'GMT' ) : ''; ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = ($TZ eq 'GMT') ? gmtime($time) : localtime($time); # Hack to deal with 'PST8PDT' format of TZ # Note that this can't deal with all the esoteric forms, but it # does recognize the most common: [:]STDoff[DST[off][,rule]] if($TZ=~/^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/){ $TZ = $isdst ? $4 : $1; } $TZ .= ' ' unless $TZ eq ''; $year += 1900; sprintf("%s %s %2d %2d:%02d:%02d %s%4d\n", $DoW[$wday], $MoY[$mon], $mday, $hour, $min, $sec, $TZ, $year); } 1; last CASE; }; # (^D) completion list $_ eq $complete && do { print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n"); redo LOOP; }; # (^U) kill $_ eq $kill && do { iperl5.000/lib/dotsh.pl 664 203 12 3706 5627540726 7673 # # @(#)dotsh.pl 03/19/94 # # Author: Charles Collins # # Description: # This routine takes a shell script and 'dots' it into the current perl # environment. This makes it possible to use existing system scripts # to alter environment variables on the fly. # # Usage: # &dotsh ('ShellScript', 'DependentVariable(s)'); # # where # # 'ShellScript' is the full name of the shell script to be dotted # # 'DependentVariable(s)' is an optional list of shell variables in the # form VARIABLE=VALUE,VARIABLE=VALUE,... that 'ShellScript' is # dependent upon. These variables MUST be defined using shell syntax. # # Example: # &dotsh ('/tmp/foo', 'arg1'); # &dotsh ('/tmp/foo'); # &dotsh ('/tmp/foo arg1 ... argN'); # sub dotsh { local(@sh) = @_; local($tmp,$key,$shell,*dotsh,$command,$args,$vars) = ''; $dotsh = shift(@sh); @dotsh = split (/\s/, $dotsh); $command = shift (@dotsh); $args = join (" ", @dotsh); $vars = join ("\n", @sh); open (_SH_ENV, "$command") || die "Could not open $dotsh!\n"; chop($_ = <_SH_ENV>); $shell = "$1 -c" if ($_ =~ /^\#\!\s*(\S+(\/sh|\/ksh|\/zsh|\/csh))\s*$/); close (_SH_ENV); if (!$shell) { if ($ENV{'SHELL'} =~ /\/sh$|\/ksh$|\/zsh$|\/csh$/) { $shell = "$ENV{'SHELL'} -c"; } else { print "SHELL not recognized!\nUsing /bin/sh...\n"; $shell = "/bin/sh -c"; } } if (length($vars) > 0) { system "$shell \"$vars;. $command $args; set > /tmp/_sh_env$$\""; } else { system "$shell \". $command $args; set > /tmp/_sh_env$$\""; } open (_SH_ENV, "/tmp/_sh_env$$") || die "Could not open /tmp/_sh_env$$!\n"; while (<_SH_ENV>) { chop; /=/; $ENV{$`} = $'; } close (_SH_ENV); system "rm -f /tmp/_sh_env$$"; foreach $key (keys(ENV)) { $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; } eval $tmp; } 1; $_ eq $kill && do { iperl5.000/lib/dumpvar.pl 644 203 12 1764 5643426041 10217 package dumpvar; # translate control chars to ^X - Randal Schwartz sub unctrl { local($_) = @_; return \$_ if ref \$_ eq "GLOB"; s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg; $_; } sub main'dumpvar { ($package,@vars) = @_; $package .= "::" unless $package =~ /::$/; *stab = *{"main::"}; while ($package =~ /(\w+?::)/g){ *stab = ${stab}{$1}; } while (($key,$val) = each(%stab)) { { next if @vars && !grep($key eq $_,@vars); local(*entry) = $val; if (defined $entry) { print "\$",&unctrl($key)," = '",&unctrl($entry),"'\n"; } if (defined @entry) { print "\@$key = (\n"; foreach $num ($[ .. $#entry) { print " $num\t'",&unctrl($entry[$num]),"'\n"; } print ")\n"; } if ($key ne "main::" && $key ne "DB::" && defined %entry && !($package eq "dumpvar" and $key eq "stab")) { print "\%$key = (\n"; foreach $key (sort keys(%entry)) { print " $key\t'",&unctrl($entry{$key}),"'\n"; } print ")\n"; } } } } 1; ; $args =perl5.000/lib/exceptions.pl 644 203 12 2734 5240621001 10702 # exceptions.pl # tchrist@convex.com # # Here's a little code I use for exception handling. It's really just # glorfied eval/die. The way to use use it is when you might otherwise # exit, use &throw to raise an exception. The first enclosing &catch # handler looks at the exception and decides whether it can catch this kind # (catch takes a list of regexps to catch), and if so, it returns the one it # caught. If it *can't* catch it, then it will reraise the exception # for someone else to possibly see, or to die otherwise. # # I use oddly named variables in order to make darn sure I don't conflict # with my caller. I also hide in my own package, and eval the code in his. # # The EXCEPTION: prefix is so you can tell whether it's a user-raised # exception or a perl-raised one (eval error). # # --tom # # examples: # if (&catch('/$user_input/', 'regexp', 'syntax error') { # warn "oops try again"; # redo; # } # # if ($error = &catch('&subroutine()')) { # catches anything # # &throw('bad input') if /^$/; sub catch { package exception; local($__code__, @__exceptions__) = @_; local($__package__) = caller; local($__exception__); eval "package $__package__; $__code__"; if ($__exception__ = &'thrown) { for (@__exceptions__) { return $__exception__ if /$__exception__/; } &'throw($__exception__); } } sub throw { local($exception) = @_; die "EXCEPTION: $exception\n"; } sub thrown { $@ =~ /^(EXCEPTION: )+(.+)/ && $2; } 1; { system "$shell \"$vars;. $coperl5.000/lib/fastcwd.pl 644 203 12 1362 5240621003 10152 # By John Bazik # # Usage: $cwd = &fastcwd; # # This is a faster version of getcwd. It's also more dangerous because # you might chdir out of a directory that you can't chdir back into. sub fastcwd { local($odev, $oino, $cdev, $cino, $tdev, $tino); local(@path, $path); local(*DIR); ($cdev, $cino) = stat('.'); for (;;) { ($odev, $oino) = ($cdev, $cino); chdir('..'); ($cdev, $cino) = stat('.'); last if $odev == $cdev && $oino == $cino; opendir(DIR, '.'); for (;;) { $_ = readdir(DIR); next if $_ eq '.'; next if $_ eq '..'; last unless $_; ($tdev, $tino) = lstat($_); last unless $tdev != $odev || $tino != $oino; } closedir(DIR); unshift(@path, $_); } chdir($path = '/' . join('/', @path)); $path; } 1; aised # exception or a perl-raised one (eval error). # # --tom # # examples: # if (&catch('/$user_input/', 'regexp', 'syntax error') { # warn "oops try again"; # redo; # } # # if ($error = &catch('&subroutine()')) { # catches anything # # &throw('bad input') if /^$/;perl5.000/lib/find.pl 644 203 12 4732 5614655446 7472 # Usage: # require "find.pl"; # # &find('/foo','/bar'); # # sub wanted { ... } # where wanted does whatever you want. $dir contains the # current directory name, and $_ the current filename within # that directory. $name contains "$dir/$_". You are cd'ed # to $dir when the function is called. The function may # set $prune to prune the tree. # # This library is primarily for find2perl, which, when fed # # find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune # # spits out something like this # # sub wanted { # /^\.nfs.*$/ && # (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && # int(-M _) > 7 && # unlink($_) # || # ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && # $dev < 0 && # ($prune = 1); # } # # Set the variable $dont_use_nlink if you're using AFS, since AFS cheats. sub find { chop($cwd = `pwd`); foreach $topdir (@_) { (($topdev,$topino,$topmode,$topnlink) = stat($topdir)) || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { ($dir,$_) = ($topdir,'.'); $name = $topdir; &wanted; ($fixtopdir = $topdir) =~ s,/$,, ; &finddir($fixtopdir,$topnlink); } else { warn "Can't cd to $topdir: $!\n"; } } else { unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) { ($dir,$_) = ('.', $topdir); } $name = $topdir; chdir $dir && &wanted; } chdir $cwd; } } sub finddir { local($dir,$nlink) = @_; local($dev,$ino,$mode,$subcount); local($name); # Get the list of files in the current directory. opendir(DIR,'.') || (warn "Can't open $dir: $!\n", return); local(@filenames) = readdir(DIR); closedir(DIR); if ($nlink == 2 && !$dont_use_nlink) { # This dir has no subdirectories. for (@filenames) { next if $_ eq '.'; next if $_ eq '..'; $name = "$dir/$_"; $nlink = 0; &wanted; } } else { # This dir has subdirectories. $subcount = $nlink - 2; for (@filenames) { next if $_ eq '.'; next if $_ eq '..'; $nlink = $prune = 0; $name = "$dir/$_"; &wanted; if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs? # Get link count and check for directoriness. ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink; if (-d _) { # It really is a directory, so do it recursively. if (!$prune && chdir $_) { &finddir($name,$nlink); chdir '..'; } --$subcount; } } } } } 1; last CASE; }; perl5.000/lib/finddepth.pl 644 203 12 4561 5614655626 10517 # Usage: # require "finddepth.pl"; # # &finddepth('/foo','/bar'); # # sub wanted { ... } # where wanted does whatever you want. $dir contains the # current directory name, and $_ the current filename within # that directory. $name contains "$dir/$_". You are cd'ed # to $dir when the function is called. The function may # set $prune to prune the tree. # # This library is primarily for find2perl, which, when fed # # find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune # # spits out something like this # # sub wanted { # /^\.nfs.*$/ && # (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && # int(-M _) > 7 && # unlink($_) # || # ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && # $dev < 0 && # ($prune = 1); # } sub finddepth { chop($cwd = `pwd`); foreach $topdir (@_) { (($topdev,$topino,$topmode,$topnlink) = stat($topdir)) || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { ($fixtopdir = $topdir) =~ s,/$,, ; &finddepthdir($fixtopdir,$topnlink); ($dir,$_) = ($fixtopdir,'.'); $name = $fixtopdir; &wanted; } else { warn "Can't cd to $topdir: $!\n"; } } else { unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) { ($dir,$_) = ('.', $topdir); } chdir $dir && &wanted; } chdir $cwd; } } sub finddepthdir { local($dir,$nlink) = @_; local($dev,$ino,$mode,$subcount); local($name); # Get the list of files in the current directory. opendir(DIR,'.') || warn "Can't open $dir: $!\n"; local(@filenames) = readdir(DIR); closedir(DIR); if ($nlink == 2) { # This dir has no subdirectories. for (@filenames) { next if $_ eq '.'; next if $_ eq '..'; $name = "$dir/$_"; $nlink = 0; &wanted; } } else { # This dir has subdirectories. $subcount = $nlink - 2; for (@filenames) { next if $_ eq '.'; next if $_ eq '..'; $nlink = $prune = 0; $name = "$dir/$_"; if ($subcount > 0) { # Seen all the subdirs? # Get link count and check for directoriness. ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink; if (-d _) { # It really is a directory, so do it recursively. if (!$prune && chdir $_) { &finddepthdir($name,$nlink); chdir '..'; } --$subcount; } } &wanted; } } } 1; hdir $_) { &finddir($name,$nlink); chdir '..'; } --$subcount; } } } } } 1; last CASE; }; perl5.000/lib/flush.pl 644 203 12 560 5240621007 7623 ;# Usage: &flush(FILEHANDLE) ;# flushes the named filehandle ;# Usage: &printflush(FILEHANDLE, "prompt: ") ;# prints arguments and flushes filehandle sub flush { local($old) = select(shift); $| = 1; print ""; $| = 0; select($old); } sub printflush { local($old) = select(shift); $| = 1; print @_; $| = 0; select($old); } 1; lwords.pllxò™ sigtrap.pmpˆòšstat.plœò› strict.pmat¬òœsubs.pmÀò syslog.plbsÔòž tainted.perl5.000/lib/ftp.pl 664 203 12 56266 5365274154 7372 #-*-perl-*- # This is a wrapper to the chat2.pl routines that make life easier # to do ftp type work. # Mostly by Lee McLoughlin # based on original version by Alan R. Martello # And by A.Macpherson@bnr.co.uk for multi-homed hosts # # $Header: /a/swan/home/swan/staff/csg/lmjm/src/perl/mirror/RCS/ftp.pl,v 1.17 1993/04/21 10:06:54 lmjm Exp lmjm $ # $Log: ftp.pl,v $ # Revision 1.17 1993/04/21 10:06:54 lmjm # Send all status reports to STDERR not to STDOUT (to allow use by ftpcat). # Allow target file to be '-' meaning STDOUT # Added ftp'quote # # Revision 1.16 1993/01/28 18:59:05 lmjm # Allow socket arguemtns to come from main. # Minor cleanups - removed old comments. # # Revision 1.15 1992/11/25 21:09:30 lmjm # Added another REST return code. # # Revision 1.14 1992/08/12 14:33:42 lmjm # Fail ftp'write if out of space. # # Revision 1.13 1992/03/20 21:01:03 lmjm # Added in the proxy ftp code from Edwards Reed # Added ftp'delete from Aaron Wohl # # Revision 1.12 1992/02/06 23:25:56 lmjm # Moved code around so can use this as a lib for both mirror and ftpmail. # Time out opens. In case Unix doesn't bother to. # # Revision 1.11 1991/11/27 22:05:57 lmjm # Match the response code number at the start of a line allowing # for any leading junk. # # Revision 1.10 1991/10/23 22:42:20 lmjm # Added better timeout code. # Tried to optimise file transfer # Moved open/close code to not leak file handles. # Cleaned up the alarm code. # Added $fatalerror to show wether the ftp link is really dead. # # Revision 1.9 1991/10/07 18:30:35 lmjm # Made the timeout-read code work. # Added restarting file gets. # Be more verbose if ever have to call die. # # Revision 1.8 1991/09/17 22:53:16 lmjm # Spot when open_data_socket fails and return a failure rather than dying. # # Revision 1.7 1991/09/12 22:40:25 lmjm # Added Andrew Macpherson's patches for hosts without ip forwarding. # # Revision 1.6 1991/09/06 19:53:52 lmjm # Relaid out the code the way I like it! # Changed the debuggin to produce more "appropriate" messages # Fixed bugs in the ordering of put and dir listing. # Allow for hash printing when getting files (a la ftp). # Added the new commands from Al. # Don't print passwords in debugging. # # Revision 1.5 1991/08/29 16:23:49 lmjm # Timeout reads from the remote ftp server. # No longer call die expect on fatal errors. Just return fail codes. # Changed returns so higher up routines can tell whats happening. # Get expect/accept in correct order for dir listing. # When ftp_show is set then print hashes every 1k transfered (like ftp). # Allow for stripping returns out of incoming data. # Save last error in a global string. # # Revision 1.4 1991/08/14 21:04:58 lmjm # ftp'get now copes with ungetable files. # ftp'expect code changed such that the string_to_print is # ignored and the string sent back from the remote system is printed # instead. # Implemented patches from al. Removed spuiours tracing statements. # # Revision 1.3 1991/08/09 21:32:18 lmjm # Allow for another ok code on cwd's # Rejigger the log levels # Send \r\n for some odd ftp daemons # # Revision 1.2 1991/08/09 18:07:37 lmjm # Don't print messages unless ftp_show says to. # # Revision 1.1 1991/08/08 20:31:00 lmjm # Initial revision # require 'chat2.pl'; require 'socket.ph'; package ftp; if( defined( &main'PF_INET ) ){ $pf_inet = &main'PF_INET; $sock_stream = &main'SOCK_STREAM; local($name, $aliases, $proto) = getprotobyname( 'tcp' ); $tcp_proto = $proto; } else { # XXX hardwired $PF_INET, $SOCK_STREAM, 'tcp' # but who the heck would change these anyway? (:-) $pf_inet = 2; $sock_stream = 1; $tcp_proto = 6; } # If the remote ftp daemon doesn't respond within this time presume its dead # or something. $timeout = 30; # Timeout a read if I don't get data back within this many seconds $timeout_read = 20 * $timeout; # Timeout an open $timeout_open = $timeout; # This is a "global" it contains the last response from the remote ftp server # for use in error messages $ftp'response = ""; # Also ftp'NS is the socket containing the data coming in from the remote ls # command. # The size of block to be read or written when talking to the remote # ftp server $ftp'ftpbufsize = 4096; # How often to print a hash out, when debugging $ftp'hashevery = 1024; # Output a newline after this many hashes to prevent outputing very long lines $ftp'hashnl = 70; # If a proxy connection then who am I really talking to? $real_site = ""; # This is just a tracing aid. $ftp_show = 0; sub ftp'debug { $ftp_show = @_[0]; # if( $ftp_show ){ # print STDERR "ftp debugging on\n"; # } } sub ftp'set_timeout { $timeout = @_[0]; $timeout_open = $timeout; $timeout_read = 20 * $timeout; if( $ftp_show ){ print STDERR "ftp timeout set to $timeout\n"; } } sub ftp'open_alarm { die "timeout: open"; } sub ftp'timed_open { local( $site, $ftp_port, $retry_call, $attempts ) = @_; local( $connect_site, $connect_port ); local( $res ); alarm( $timeout_open ); while( $attempts-- ){ if( $ftp_show ){ print STDERR "proxy connecting via $proxy_gateway [$proxy_ftp_port]\n" if $proxy; print STDERR "Connecting to $site"; if( $ftp_port != 21 ){ print STDERR " [port $ftp_port]"; } print STDERR "\n"; } if( $proxy ) { if( ! $proxy_gateway ) { # if not otherwise set $proxy_gateway = "internet-gateway"; } if( $debug ) { print STDERR "using proxy services of $proxy_gateway, "; print STDERR "at $proxy_ftp_port\n"; } $connect_site = $proxy_gateway; $connect_port = $proxy_ftp_port; $real_site = $site; } else { $connect_site = $site; $connect_port = $ftp_port; } if( ! &chat'open_port( $connect_site, $connect_port ) ){ if( $retry_call ){ print STDERR "Failed to connect\n" if $ftp_show; next; } else { print STDERR "proxy connection failed " if $proxy; print STDERR "Cannot open ftp to $connect_site\n" if $ftp_show; return 0; } } $res = &ftp'expect( $timeout, 120, "service unavailable to $site", 0, 220, "ready for login to $site", 1, 421, "service unavailable to $site, closing connection", 0); if( ! $res ){ &chat'close(); next; } return 1; } continue { print STDERR "Pausing between retries\n"; sleep( $retry_pause ); } return 0; } sub ftp'open { local( $site, $ftp_port, $retry_call, $attempts ) = @_; $SIG{ 'ALRM' } = "ftp\'open_alarm"; local( $ret ) = eval "&timed_open( '$site', $ftp_port, $retry_call, $attempts )"; alarm( 0 ); if( $@ =~ /^timeout/ ){ return -1; } return $ret; } sub ftp'login { local( $remote_user, $remote_password ) = @_; if( $proxy ){ &ftp'send( "USER $remote_user@$site" ); } else { &ftp'send( "USER $remote_user" ); } local( $val ) = &ftp'expect($timeout, 230, "$remote_user logged in", 1, 331, "send password for $remote_user", 2, 500, "syntax error", 0, 501, "syntax error", 0, 530, "not logged in", 0, 332, "account for login not supported", 0, 421, "service unavailable, closing connection", 0); if( $val == 1 ){ return 1; } if( $val == 2 ){ # A password is needed &ftp'send( "PASS $remote_password" ); $val = &ftp'expect( $timeout, 230, "$remote_user logged in", 1, 202, "command not implemented", 0, 332, "account for login not supported", 0, 530, "not logged in", 0, 500, "syntax error", 0, 501, "syntax error", 0, 503, "bad sequence of commands", 0, 421, "service unavailable, closing connection", 0); if( $val == 1){ # Logged in return 1; } } # If I got here I failed to login return 0; } sub ftp'close { &ftp'quit(); &chat'close(); } # Change directory # return 1 if successful # 0 on a failure sub ftp'cwd { local( $dir ) = @_; &ftp'send( "CWD $dir" ); return &ftp'expect( $timeout, 200, "working directory = $dir", 1, 250, "working directory = $dir", 1, 500, "syntax error", 0, 501, "syntax error", 0, 502, "command not implemented", 0, 530, "not logged in", 0, 550, "cannot change directory", 0, 421, "service unavailable, closing connection", 0 ); } # Get a full directory listing: # &ftp'dir( remote LIST options ) # Start a list goin with the given options. # Presuming that the remote deamon uses the ls command to generate the # data to send back then then you can send it some extra options (eg: -lRa) # return 1 if sucessful and 0 on a failure sub ftp'dir_open { local( $options ) = @_; local( $ret ); if( ! &ftp'open_data_socket() ){ return 0; } if( $options ){ &ftp'send( "LIST $options" ); } else { &ftp'send( "LIST" ); } $ret = &ftp'expect( $timeout, 150, "reading directory", 1, 125, "data connection already open?", 0, 450, "file unavailable", 0, 500, "syntax error", 0, 501, "syntax error", 0, 502, "command not implemented", 0, 530, "not logged in", 0, 421, "service unavailable, closing connection", 0 ); if( ! $ret ){ &ftp'close_data_socket; return 0; } # # the data should be coming at us now # # now accept accept(NS,S) || die "accept failed $!"; return 1; } # Close down reading the result of a remote ls command # return 1 if successful and 0 on failure sub ftp'dir_close { local( $ret ); # read the close # $ret = &ftp'expect($timeout, 226, "", 1, # transfer complete, closing connection 250, "", 1, # action completed 425, "can't open data connection", 0, 426, "connection closed, transfer aborted", 0, 451, "action aborted, local error", 0, 421, "service unavailable, closing connection", 0); # shut down our end of the socket &ftp'close_data_socket; if( ! $ret ){ return 0; } return 1; } # Quit from the remote ftp server # return 1 if successful and 0 on failure sub ftp'quit { $site_command_check = 0; @site_command_list = (); &ftp'send("QUIT"); return &ftp'expect($timeout, 221, "Goodbye", 1, # transfer complete, closing connection 500, "error quitting??", 0); } sub ftp'read_alarm { die "timeout: read"; } sub ftp'timed_read { alarm( $timeout_read ); return sysread( NS, $buf, $ftpbufsize ); } sub ftp'read { $SIG{ 'ALRM' } = "ftp\'read_alarm"; local( $ret ) = eval '&timed_read()'; alarm( 0 ); if( $@ =~ /^timeout/ ){ return -1; } return $ret; } # Get a remote file back into a local file. # If no loc_fname passed then uses rem_fname. # returns 1 on success and 0 on failure sub ftp'get { local($rem_fname, $loc_fname, $restart ) = @_; if ($loc_fname eq "") { $loc_fname = $rem_fname; } if( ! &ftp'open_data_socket() ){ print STDERR "Cannot open data socket\n"; return 0; } if( $loc_fname ne '-' ){ # Find the size of the target file local( $restart_at ) = &ftp'filesize( $loc_fname ); if( $restart && $restart_at > 0 && &ftp'restart( $restart_at ) ){ $restart = 1; # Make sure the file can be updated chmod( 0644, $loc_fname ); } else { $restart = 0; unlink( $loc_fname ); } } &ftp'send( "RETR $rem_fname" ); local( $ret ) = &ftp'expect($timeout, 150, "receiving $rem_fname", 1, 125, "data connection already open?", 0, 450, "file unavailable", 2, 550, "file unavailable", 2, 500, "syntax error", 0, 501, "syntax error", 0, 530, "not logged in", 0, 421, "service unavailable, closing connection", 0); if( $ret != 1 ){ print STDERR "Failure on RETR command\n"; # shut down our end of the socket &ftp'close_data_socket; return 0; } # # the data should be coming at us now # # now accept accept(NS,S) || die "accept failed: $!"; # # open the local fname # concatenate on the end if restarting, else just overwrite if( !open(FH, ($restart ? '>>' : '>') . $loc_fname) ){ print STDERR "Cannot create local file $loc_fname\n"; # shut down our end of the socket &ftp'close_data_socket; return 0; } # while () { # print FH ; # } local( $start_time ) = time; local( $bytes, $lasthash, $hashes ) = (0, 0, 0); while( ($len = &ftp'read()) > 0 ){ $bytes += $len; if( $strip_cr ){ $ftp'buf =~ s/\r//g; } if( $ftp_show ){ while( $bytes > ($lasthash + $ftp'hashevery) ){ print STDERR '#'; $lasthash += $ftp'hashevery; $hashes++; if( ($hashes % $ftp'hashnl) == 0 ){ print STDERR "\n"; } } } if( ! print FH $ftp'buf ){ print STDERR "\nfailed to write data"; return 0; } } close( FH ); # shut down our end of the socket &ftp'close_data_socket; if( $len < 0 ){ print STDERR "\ntimed out reading data!\n"; return 0; } if( $ftp_show ){ if( $hashes && ($hashes % $ftp'hashnl) != 0 ){ print STDERR "\n"; } local( $secs ) = (time - $start_time); if( $secs <= 0 ){ $secs = 1; # To avoid a divide by zero; } local( $rate ) = int( $bytes / $secs ); print STDERR "Got $bytes bytes ($rate bytes/sec)\n"; } # # read the close # $ret = &ftp'expect($timeout, 226, "Got file", 1, # transfer complete, closing connection 250, "Got file", 1, # action completed 110, "restart not supported", 0, 425, "can't open data connection", 0, 426, "connection closed, transfer aborted", 0, 451, "action aborted, local error", 0, 421, "service unavailable, closing connection", 0); return $ret; } sub ftp'delete { local( $rem_fname, $val ) = @_; &ftp'send("DELE $rem_fname" ); $val = &ftp'expect( $timeout, 250,"Deleted $rem_fname", 1, 550,"Permission denied",0 ); return $val == 1; } sub ftp'deldir { local( $fname ) = @_; # not yet implemented # RMD } # UPDATE ME!!!!!! # Add in the hash printing and newline conversion sub ftp'put { local( $loc_fname, $rem_fname ) = @_; local( $strip_cr ); if ($loc_fname eq "") { $loc_fname = $rem_fname; } if( ! &ftp'open_data_socket() ){ return 0; } &ftp'send("STOR $rem_fname"); # # the data should be coming at us now # local( $ret ) = &ftp'expect($timeout, 150, "sending $loc_fname", 1, 125, "data connection already open?", 0, 450, "file unavailable", 0, 532, "need account for storing files", 0, 452, "insufficient storage on system", 0, 553, "file name not allowed", 0, 500, "syntax error", 0, 501, "syntax error", 0, 530, "not logged in", 0, 421, "service unavailable, closing connection", 0); if( $ret != 1 ){ # shut down our end of the socket &ftp'close_data_socket; return 0; } # # the data should be coming at us now # # now accept accept(NS,S) || die "accept failed: $!"; # # open the local fname # if( !open(FH, "<$loc_fname") ){ print STDERR "Cannot open local file $loc_fname\n"; # shut down our end of the socket &ftp'close_data_socket; return 0; } while () { print NS ; } close(FH); # shut down our end of the socket to signal EOF &ftp'close_data_socket; # # read the close # $ret = &ftp'expect($timeout, 226, "file put", 1, # transfer complete, closing connection 250, "file put", 1, # action completed 110, "restart not supported", 0, 425, "can't open data connection", 0, 426, "connection closed, transfer aborted", 0, 451, "action aborted, local error", 0, 551, "page type unknown", 0, 552, "storage allocation exceeded", 0, 421, "service unavailable, closing connection", 0); if( ! $ret ){ print STDERR "error putting $loc_fname\n"; } return $ret; } sub ftp'restart { local( $restart_point, $ret ) = @_; &ftp'send("REST $restart_point"); # # see what they say $ret = &ftp'expect($timeout, 350, "restarting at $restart_point", 1, 500, "syntax error", 0, 501, "syntax error", 0, 502, "REST not implemented", 2, 530, "not logged in", 0, 554, "REST not implemented", 2, 421, "service unavailable, closing connection", 0); return $ret; } # Set the file transfer type sub ftp'type { local( $type ) = @_; &ftp'send("TYPE $type"); # # see what they say $ret = &ftp'expect($timeout, 200, "file type set to $type", 1, 500, "syntax error", 0, 501, "syntax error", 0, 504, "Invalid form or byte size for type $type", 0, 421, "service unavailable, closing connection", 0); return $ret; } $site_command_check = 0; @site_command_list = (); # routine to query the remote server for 'SITE' commands supported sub ftp'site_commands { local( $ret ); # if we havent sent a 'HELP SITE', send it now if( !$site_command_check ){ $site_command_check = 1; &ftp'send( "HELP SITE" ); # assume the line in the HELP SITE response with the 'HELP' # command is the one for us $ret = &ftp'expect( $timeout, ".*HELP.*", "", "\$1", 214, "", "0", 202, "", "0" ); if( $ret eq "0" ){ print STDERR "No response from HELP SITE\n" if( $ftp_show ); } @site_command_list = split(/\s+/, $ret); } return @site_command_list; } # return the pwd, or null if we can't get the pwd sub ftp'pwd { local( $ret, $cwd ); &ftp'send( "PWD" ); # # see what they say $ret = &ftp'expect( $timeout, 257, "working dir is", 1, 500, "syntax error", 0, 501, "syntax error", 0, 502, "PWD not implemented", 0, 550, "file unavailable", 0, 421, "service unavailable, closing connection", 0 ); if( $ret ){ if( $ftp'response =~ /^257\s"(.*)"\s.*$/ ){ $cwd = $1; } } return $cwd; } # return 1 for success, 0 for failure sub ftp'mkdir { local( $path ) = @_; local( $ret ); &ftp'send( "MKD $path" ); # # see what they say $ret = &ftp'expect( $timeout, 257, "made directory $path", 1, 500, "syntax error", 0, 501, "syntax error", 0, 502, "MKD not implemented", 0, 530, "not logged in", 0, 550, "file unavailable", 0, 421, "service unavailable, closing connection", 0 ); return $ret; } # return 1 for success, 0 for failure sub ftp'chmod { local( $path, $mode ) = @_; local( $ret ); &ftp'send( sprintf( "SITE CHMOD %o $path", $mode ) ); # # see what they say $ret = &ftp'expect( $timeout, 200, "chmod $mode $path succeeded", 1, 500, "syntax error", 0, 501, "syntax error", 0, 502, "CHMOD not implemented", 0, 530, "not logged in", 0, 550, "file unavailable", 0, 421, "service unavailable, closing connection", 0 ); return $ret; } # rename a file sub ftp'rename { local( $old_name, $new_name ) = @_; local( $ret ); &ftp'send( "RNFR $old_name" ); # # see what they say $ret = &ftp'expect( $timeout, 350, "", 1, 500, "syntax error", 0, 501, "syntax error", 0, 502, "RNFR not implemented", 0, 530, "not logged in", 0, 550, "file unavailable", 0, 450, "file unavailable", 0, 421, "service unavailable, closing connection", 0); # check if the "rename from" occurred ok if( $ret ) { &ftp'send( "RNTO $new_name" ); # # see what they say $ret = &ftp'expect( $timeout, 250, "rename $old_name to $new_name", 1, 500, "syntax error", 0, 501, "syntax error", 0, 502, "RNTO not implemented", 0, 503, "bad sequence of commands", 0, 530, "not logged in", 0, 532, "need account for storing files", 0, 553, "file name not allowed", 0, 421, "service unavailable, closing connection", 0); } return $ret; } sub ftp'quote { local( $cmd ) = @_; &ftp'send( $cmd ); return &ftp'expect( $timeout, 200, "Remote '$cmd' OK", 1, 500, "error in remote '$cmd'", 0 ); } # ------------------------------------------------------------------------------ # These are the lower level support routines sub ftp'expectgot { ($ftp'response, $ftp'fatalerror) = @_; if( $ftp_show ){ print STDERR "$ftp'response\n"; } } # # create the list of parameters for chat'expect # # ftp'expect(time_out, {value, string_to_print, return value}); # if the string_to_print is "" then nothing is printed # the last response is stored in $ftp'response # # NOTE: lmjm has changed this code such that the string_to_print is # ignored and the string sent back from the remote system is printed # instead. # sub ftp'expect { local( $ret ); local( $time_out ); local( $expect_args ); $ftp'response = ''; $ftp'fatalerror = 0; @expect_args = (); $time_out = shift(@_); while( @_ ){ local( $code ) = shift( @_ ); local( $pre ) = '^'; if( $code =~ /^\d/ ){ $pre =~ "[.|\n]*^"; } push( @expect_args, "$pre(" . $code . " .*)\\015\\n" ); shift( @_ ); push( @expect_args, "&ftp'expectgot( \$1, 0 ); " . shift( @_ ) ); } # Treat all unrecognised lines as continuations push( @expect_args, "^(.*)\\015\\n" ); push( @expect_args, "&ftp'expectgot( \$1, 0 ); 100" ); # add patterns TIMEOUT and EOF push( @expect_args, 'TIMEOUT' ); push( @expect_args, "&ftp'expectgot( \"timed out\", 1 ); 0" ); push( @expect_args, 'EOF' ); push( @expect_args, "&ftp'expectgot( \"remote server gone away\", 1 ); 0" ); if( $ftp_show > 9 ){ &printargs( $time_out, @expect_args ); } $ret = &chat'expect( $time_out, @expect_args ); if( $ret == 100 ){ # we saw a continuation line, wait for the end push( @expect_args, "^.*\n" ); push( @expect_args, "100" ); while( $ret == 100 ){ $ret = &chat'expect( $time_out, @expect_args ); } } return $ret; } # # opens NS for io # sub ftp'open_data_socket { local( $ret ); local( $hostname ); local( $sockaddr, $name, $aliases, $proto, $port ); local( $type, $len, $thisaddr, $myaddr, $a, $b, $c, $d ); local( $mysockaddr, $family, $hi, $lo ); $sockaddr = 'S n a4 x8'; chop( $hostname = `hostname` ); $port = "ftp"; ($name, $aliases, $proto) = getprotobyname( 'tcp' ); ($name, $aliases, $port) = getservbyname( $port, 'tcp' ); # ($name, $aliases, $type, $len, $thisaddr) = # gethostbyname( $hostname ); ($a,$b,$c,$d) = unpack( 'C4', $chat'thisaddr ); # $this = pack( $sockaddr, &main'AF_INET, 0, $thisaddr ); $this = $chat'thisproc; socket(S, $pf_inet, $sock_stream, $proto ) || die "socket: $!"; bind(S, $this) || die "bind: $!"; # get the port number $mysockaddr = getsockname(S); ($family, $port, $myaddr) = unpack( $sockaddr, $mysockaddr ); $hi = ($port >> 8) & 0x00ff; $lo = $port & 0x00ff; # # we MUST do a listen before sending the port otherwise # the PORT may fail # listen( S, 5 ) || die "listen"; &ftp'send( "PORT $a,$b,$c,$d,$hi,$lo" ); return &ftp'expect($timeout, 200, "PORT command successful", 1, 250, "PORT command successful", 1 , 500, "syntax error", 0, 501, "syntax error", 0, 530, "not logged in", 0, 421, "service unavailable, closing connection", 0); } sub ftp'close_data_socket { close(NS); } sub ftp'send { local($send_cmd) = @_; if( $send_cmd =~ /\n/ ){ print STDERR "ERROR, \\n in send string for $send_cmd\n"; } if( $ftp_show ){ local( $sc ) = $send_cmd; if( $send_cmd =~ /^PASS/){ $sc = "PASS "; } print STDERR "---> $sc\n"; } &chat'print( "$send_cmd\r\n" ); } sub ftp'printargs { while( @_ ){ print STDERR shift( @_ ) . "\n"; } } sub ftp'filesize { local( $fname ) = @_; if( ! -f $fname ){ return -1; } return (stat( _ ))[ 7 ]; } # make this package return true 1; n", 0, 552, "storage allocation exceeded", 0, 421, "service unavailable, closing connection", 0); if( ! $ret ){ print STDERR "error putting $loc_fname\n"; } return $ret; } sub ftp'restart { local( $restart_point, $ret ) = @_; &ftp'send("REST $restart_point"); # # see what they say $ret = &ftp'expect($timeoutperl5.000/lib/getcwd.pl 644 203 12 2155 5240621011 7774 # By Brandon S. Allbery # # Usage: $cwd = &getcwd; sub getcwd { local($dotdots, $cwd, @pst, @cst, $dir, @tst); unless (@cst = stat('.')) { warn "stat(.): $!"; return ''; } $cwd = ''; do { $dotdots .= '/' if $dotdots; $dotdots .= '..'; @pst = @cst; unless (opendir(getcwd'PARENT, $dotdots)) #')) { warn "opendir($dotdots): $!"; return ''; } unless (@cst = stat($dotdots)) { warn "stat($dotdots): $!"; closedir(getcwd'PARENT); #'); return ''; } if ($pst[$[] == $cst[$[] && $pst[$[ + 1] == $cst[$[ + 1]) { $dir = ''; } else { do { unless ($dir = readdir(getcwd'PARENT)) #')) { warn "readdir($dotdots): $!"; closedir(getcwd'PARENT); #'); return ''; } unless (@tst = lstat("$dotdots/$dir")) { warn "lstat($dotdots/$dir): $!"; closedir(getcwd'PARENT); #'); return ''; } } while ($dir eq '.' || $dir eq '..' || $tst[$[] != $pst[$[] || $tst[$[ + 1] != $pst[$[ + 1]); } $cwd = "$dir/$cwd"; closedir(getcwd'PARENT); #'); } while ($dir); chop($cwd); $cwd; } 1; gnised lines as continuations push( @expect_args, "^(.*)\\015\\n" ); push( @expect_args, "&ftp'expectgot( \$1, 0 ); 100" ); # add patterns TIMEOUT and EOF push( @expect_args, 'TIMEOUT' ); push( @expect_args, "&ftp'expectgot( \"timed out\", 1 ); 0" ); push( @expect_args, 'EOF' ); push( @expect_args, "&ftp'expectgot( \"remote server gone away\", 1 ); 0" ); if( $ftp_show > 9 ){ &printaperl5.000/lib/getopt.pl 644 203 12 2022 5240621012 10013 ;# $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $ ;# Process single-character switches with switch clustering. Pass one argument ;# which is a string containing all switches that take an argument. For each ;# switch found, sets $opt_x (where x is the switch name) to the value of the ;# argument, or 1 if no argument. Switches which take an argument don't care ;# whether there is a space between the switch and the argument. ;# Usage: ;# do Getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. sub Getopt { local($argumentative) = @_; local($_,$first,$rest); local($[) = 0; while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { ($first,$rest) = ($1,$2); if (index($argumentative,$first) >= $[) { if ($rest ne '') { shift(@ARGV); } else { shift(@ARGV); $rest = shift(@ARGV); } eval "\$opt_$first = \$rest;"; } else { eval "\$opt_$first = 1;"; if ($rest ne '') { $ARGV[0] = "-$rest"; } else { shift(@ARGV); } } } } 1; d"; closedir(getcwd'PARENT); #'); } while ($dir); chop($cwd); $cwd; } 1; gnised lines as continuations push( @expect_args, "^(.*)\\015\\n" ); push( @expect_args, "&ftp'expectgot( \$1, 0 ); 100" ); # add patterns TIMEOUT and EOF push( @expect_args, 'TIMEOUT' ); push( @expect_args, "&ftp'expectgot( \"timed out\", 1 ); 0" ); push( @expect_args, 'EOF' ); push( @expect_args, "&ftp'expectgot( \"remote server gone away\", 1 ); 0" ); if( $ftp_show > 9 ){ &printaperl5.000/lib/getopts.pl 644 203 12 1673 5240621014 10213 ;# getopts.pl - a better getopt.pl ;# Usage: ;# do Getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a ;# # side effect. sub Getopts { local($argumentative) = @_; local(@args,$_,$first,$rest); local($errs) = 0; local($[) = 0; @args = split( / */, $argumentative ); while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { ($first,$rest) = ($1,$2); $pos = index($argumentative,$first); if($pos >= $[) { if($args[$pos+1] eq ':') { shift(@ARGV); if($rest eq '') { ++$errs unless @ARGV; $rest = shift(@ARGV); } eval "\$opt_$first = \$rest;"; } else { eval "\$opt_$first = 1"; if($rest eq '') { shift(@ARGV); } else { $ARGV[0] = "-$rest"; } } } else { print STDERR "Unknown option: $first\n"; ++$errs; if($rest ne '') { $ARGV[0] = "-$rest"; } else { shift(@ARGV); } } } $errs == 0; } 1; '') { $ARGV[0] = "-$rest"; } else { shift(@ARGV); perl5.000/lib/hostname.pl 664 203 12 703 5460725125 10333 # From: asherman@fmrco.com (Aaron Sherman) sub hostname { local(*P,@tmp,$hostname,$_); if (open(P,"hostname 2>&1 |") && (@tmp =

) && close(P)) { chop($hostname = $tmp[$#tmp]); } elsif (open(P,"uname -n 2>&1 |") && (@tmp =

) && close(P)) { chop($hostname = $tmp[$#tmp]); } else { die "$0: Cannot get hostname from 'hostname' or 'uname -n'\n"; } @tmp = (); close P; # Just in case we failed in an odd spot.... $hostname; } 1; ò¡ validate.plargs[$pos+1] eq ':') { shift(@ARGVperl5.000/lib/importenv.pl 644 203 12 543 5240621016 10526 ;# $RCSfile: importenv.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:02 $ ;# This file, when interpreted, pulls the environment into normal variables. ;# Usage: ;# require 'importenv.pl'; ;# or ;# #include local($tmp,$key) = ''; foreach $key (keys(ENV)) { $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; } eval $tmp; 1; Ôòž tainted.plèòŸ termcap.plò  timelocal.plò¡ validate.plò¡ validate.plargs[$pos+1] eq ':') { shift(@ARGVperl5.000/lib/integer.pm 664 203 12 124 5563515717 10160 package integer; sub import { $^H |= 1; } sub unimport { $^H &= ~1; } 1; t.plplò”open2.pl.pl(ò•open3.pl.pl<ò– perl5db.pllLò—pwd.plldò˜ shellwords.pl.xò™ sigtrap.pmpˆòšstat.plœò› strict.pmat¬òœsubs.pmÀò syslog.plbsÔòž tainted.plpèòŸ termcap.pl.ò  timelocal.pllò¡ validate.plò¡ validate.plò¡ validate.plargs[$pos+1] eq ':') { shift(@ARGVperl5.000/lib/less.pm 664 203 12 21 5616060231 7426 package less; 1; pmÜò’look.plò“ newgetopt.plò”open2.plpl(ò•open3.pl.pl<ò– perl5db.pllLò—pwd.pl.dò˜ shellwords.pldxò™ sigtrap.pm.ˆòšstat.plœò› strict.pml¬òœsubs.pmÀò syslog.plmÔòž tainted.plsèòŸ termcap.plpò  timelocal.plò¡ validate.plò¡ validate.plò¡ validate.plò¡ validate.plargs[$pos+1] eq ':') { shift(@ARGVperl5.000/lib/look.pl 644 203 12 2000 5240621017 7456 ;# Usage: &look(*FILEHANDLE,$key,$dict,$fold) ;# Sets file position in FILEHANDLE to be first line greater than or equal ;# (stringwise) to $key. Pass flags for dictionary order and case folding. sub look { local(*FH,$key,$dict,$fold) = @_; local($max,$min,$mid,$_); local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat(FH); $blksize = 8192 unless $blksize; $key =~ s/[^\w\s]//g if $dict; $key =~ y/A-Z/a-z/ if $fold; $max = int($size / $blksize); while ($max - $min > 1) { $mid = int(($max + $min) / 2); seek(FH,$mid * $blksize,0); $_ = if $mid; # probably a partial line $_ = ; chop; s/[^\w\s]//g if $dict; y/A-Z/a-z/ if $fold; if ($_ lt $key) { $min = $mid; } else { $max = $mid; } } $min *= $blksize; seek(FH,$min,0); if $min; while () { chop; s/[^\w\s]//g if $dict; y/A-Z/a-z/ if $fold; last if $_ ge $key; $min = tell(FH); } seek(FH,$min,0); $min; } 1; perl5.000/lib/newgetopt.pl 644 203 12 17005 5240621021 10554 # newgetopt.pl -- new options parsing # SCCS Status : @(#)@ newgetopt.pl 1.13 # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans # Last Modified On: Tue Jun 2 11:24:03 1992 # Update Count : 75 # Status : Okay # This package implements a new getopt function. This function adheres # to the new syntax (long option names, no bundling). # # Arguments to the function are: # # - a list of possible options. These should designate valid perl # identifiers, optionally followed by an argument specifier ("=" # for mandatory arguments or ":" for optional arguments) and an # argument type specifier: "n" or "i" for integer numbers, "f" for # real (fix) numbers or "s" for strings. # If an "@" sign is appended, the option is treated as an array. # Value(s) are not set, but pushed. # # - if the first option of the list consists of non-alphanumeric # characters only, it is interpreted as a generic option starter. # Everything starting with one of the characters from the starter # will be considered an option. # Likewise, a double occurrence (e.g. "--") signals end of # the options list. # The default value for the starter is "-", "--" or "+". # # Upon return, the option variables, prefixed with "opt_", are defined # and set to the respective option arguments, if any. # Options that do not take an argument are set to 1. Note that an # option with an optional argument will be defined, but set to '' if # no actual argument has been supplied. # A return status of 0 (false) indicates that the function detected # one or more errors. # # Special care is taken to give a correct treatment to optional arguments. # # E.g. if option "one:i" (i.e. takes an optional integer argument), # then the following situations are handled: # # -one -two -> $opt_one = '', -two is next option # -one -2 -> $opt_one = -2 # # Also, assume "foo=s" and "bar:s" : # # -bar -xxx -> $opt_bar = '', '-xxx' is next option # -foo -bar -> $opt_foo = '-bar' # -foo -- -> $opt_foo = '--' # # HISTORY # 2-Jun-1992 Johan Vromans # Do not use //o to allow multiple NGetOpt calls with different delimeters. # Prevent typeless option from using previous $array state. # Prevent empty option from being eaten as a (negative) number. # 25-May-1992 Johan Vromans # Add array options. "foo=s@" will return an array @opt_foo that # contains all values that were supplied. E.g. "-foo one -foo -two" will # return @opt_foo = ("one", "-two"); # Correct bug in handling options that allow for a argument when followed # by another option. # 4-May-1992 Johan Vromans # Add $ignorecase to match options in either case. # Allow '' option. # 19-Mar-1992 Johan Vromans # Allow require from packages. # NGetOpt is now defined in the package that requires it. # @ARGV and $opt_... are taken from the package that calls it. # Use standard (?) option prefixes: -, -- and +. # 20-Sep-1990 Johan Vromans # Set options w/o argument to 1. # Correct the dreadful semicolon/require bug. { package newgetopt; $debug = 0; # for debugging $ignorecase = 1; # ignore case when matching options } sub NGetOpt { @newgetopt'optionlist = @_; *newgetopt'ARGV = *ARGV; package newgetopt; local ($[) = 0; local ($genprefix) = "(--|-|\\+)"; local ($argend) = "--"; local ($error) = 0; local ($opt, $optx, $arg, $type, $mand, %opctl); local ($pkg) = (caller)[0]; print STDERR "NGetOpt 1.13 -- called from $pkg\n" if $debug; # See if the first element of the optionlist contains option # starter characters. if ( $optionlist[0] =~ /^\W+$/ ) { $genprefix = shift (@optionlist); # Turn into regexp. $genprefix =~ s/(\W)/\\\1/g; $genprefix = "[" . $genprefix . "]"; undef $argend; } # Verify correctness of optionlist. %opctl = (); foreach $opt ( @optionlist ) { $opt =~ tr/A-Z/a-z/ if $ignorecase; if ( $opt !~ /^(\w*)([=:][infse]@?)?$/ ) { print STDERR ("Error in option spec: \"", $opt, "\"\n"); $error++; next; } $opctl{$1} = defined $2 ? $2 : ""; } return 0 if $error; if ( $debug ) { local ($arrow, $k, $v); $arrow = "=> "; while ( ($k,$v) = each(%opctl) ) { print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n"); $arrow = " "; } } # Process argument list while ( $#ARGV >= 0 ) { # >>> See also the continue block <<< # Get next argument $opt = shift (@ARGV); print STDERR ("=> option \"", $opt, "\"\n") if $debug; $arg = undef; # Check for exhausted list. if ( $opt =~ /^$genprefix/ ) { # Double occurrence is terminator return ($error == 0) if ($opt eq "$+$+") || ((defined $argend) && $opt eq $argend); $opt = $'; # option name (w/o prefix) } else { # Apparently not an option - push back and exit. unshift (@ARGV, $opt); return ($error == 0); } # Look it up. $opt =~ tr/A-Z/a-z/ if $ignorecase; unless ( defined ( $type = $opctl{$opt} ) ) { print STDERR ("Unknown option: ", $opt, "\n"); $error++; next; } # Determine argument status. print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug; # If it is an option w/o argument, we're almost finished with it. if ( $type eq "" ) { $arg = 1; # supply explicit value $array = 0; next; } # Get mandatory status and type info. ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/; # Check if the argument list is exhausted. if ( $#ARGV < 0 ) { # Complain if this option needs an argument. if ( $mand eq "=" ) { print STDERR ("Option ", $opt, " requires an argument\n"); $error++; } if ( $mand eq ":" ) { $arg = $type eq "s" ? "" : 0; } next; } # Get (possibly optional) argument. $arg = shift (@ARGV); # Check if it is a valid argument. A mandatory string takes # anything. if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/ ) { # Check for option list terminator. if ( $arg eq "$+$+" || ((defined $argend) && $arg eq $argend)) { # Push back so the outer loop will terminate. unshift (@ARGV, $arg); # Complain if an argument is required. if ($mand eq "=") { print STDERR ("Option ", $opt, " requires an argument\n"); $error++; undef $arg; # don't assign it } else { # Supply empty value. $arg = $type eq "s" ? "" : 0; } next; } # Maybe the optional argument is the next option? if ( $mand eq ":" && ($' eq "" || $' =~ /[a-zA-Z_]/) ) { # Yep. Push back. unshift (@ARGV, $arg); $arg = $type eq "s" ? "" : 0; next; } } if ( $type eq "n" || $type eq "i" ) { # numeric/integer if ( $arg !~ /^-?[0-9]+$/ ) { print STDERR ("Value \"", $arg, "\" invalid for option ", $opt, " (number expected)\n"); $error++; undef $arg; # don't assign it } next; } if ( $type eq "f" ) { # fixed real number, int is also ok if ( $arg !~ /^-?[0-9.]+$/ ) { print STDERR ("Value \"", $arg, "\" invalid for option ", $opt, " (real number expected)\n"); $error++; undef $arg; # don't assign it } next; } if ( $type eq "s" ) { # string next; } } continue { if ( defined $arg ) { if ( $array ) { print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n") if $debug; eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);"); } else { print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n") if $debug; eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;"); } } } return ($error == 0); } 1; ax error", 0, 501, "syntax error", 0, 502, "RNFR not implemented", 0, 530, "not logged in", 0, 550, "file unavailable", 0, 450, "file unavailable", 0, 421, "service unavailable, closing connection", 0); # check if the "rename from" occurred ok if( $ret ) { &ftp'send( "RNTO $new_name" ); # # see what they say $ret = &ftp'expect( $timeout, 250, "rename $old_name to $new_name", 1, 500, "syntax eperl5.000/lib/open2.pl 644 203 12 3015 5240621022 7540 # &open2: tom christiansen, # # usage: $pid = &open2('rdr', 'wtr', 'some cmd and args'); # or $pid = &open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args'); # # spawn the given $cmd and connect $rdr for # reading and $wtr for writing. return pid # of child, or 0 on failure. # # WARNING: this is dangerous, as you may block forever # unless you are very careful. # # $wtr is left unbuffered. # # abort program if # rdr or wtr are null # pipe or fork or exec fails package open2; $fh = 'FHOPEN000'; # package static in case called more than once sub main'open2 { local($kidpid); local($dad_rdr, $dad_wtr, @cmd) = @_; $dad_rdr ne '' || die "open2: rdr should not be null"; $dad_wtr ne '' || die "open2: wtr should not be null"; # force unqualified filehandles into callers' package local($package) = caller; $dad_rdr =~ s/^[^']+$/$package'$&/; $dad_wtr =~ s/^[^']+$/$package'$&/; local($kid_rdr) = ++$fh; local($kid_wtr) = ++$fh; pipe($dad_rdr, $kid_wtr) || die "open2: pipe 1 failed: $!"; pipe($kid_rdr, $dad_wtr) || die "open2: pipe 2 failed: $!"; if (($kidpid = fork) < 0) { die "open2: fork failed: $!"; } elsif ($kidpid == 0) { close $dad_rdr; close $dad_wtr; open(STDIN, "<&$kid_rdr"); open(STDOUT, ">&$kid_wtr"); warn "execing @cmd\n" if $debug; exec @cmd; die "open2: exec of @cmd failed"; } close $kid_rdr; close $kid_wtr; select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe $kidpid; } 1; # so require is happy bar' # -foo -- -> $opt_foo = '--' # # HISTORY # 2-Jun-1992 Johan Vromans # Do not use //o to allow multiple NGetOpt calls with different delimeters. # Prevent typeless option from using previous $array state. # Prevent empty option from being eaten as a (negative) number. # 25-May-1992 Johan Vromans # Add array options. "foo=s@" will return an array @opt_foo that # contains all values that were supplied. E.g. "-foo one -foo -two" will # return @opt_foo = ("one", "-twperl5.000/lib/open3.pl 664 203 12 5707 5615101251 7560 # &open3: Marc Horowitz # derived mostly from &open2 by tom christiansen, # # $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $ # # usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...); # # spawn the given $cmd and connect rdr for # reading, wtr for writing, and err for errors. # if err is '', or the same as rdr, then stdout and # stderr of the child are on the same fh. returns pid # of child, or 0 on failure. # if wtr begins with '>&', then wtr will be closed in the parent, and # the child will read from it directly. if rdr or err begins with # '>&', then the child will send output directly to that fd. In both # cases, there will be a dup() instead of a pipe() made. # WARNING: this is dangerous, as you may block forever # unless you are very careful. # # $wtr is left unbuffered. # # abort program if # rdr or wtr are null # pipe or fork or exec fails package open3; $fh = 'FHOPEN000'; # package static in case called more than once sub main'open3 { local($kidpid); local($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_; local($dup_wtr, $dup_rdr, $dup_err); $dad_wtr || die "open3: wtr should not be null"; $dad_rdr || die "open3: rdr should not be null"; $dad_err = $dad_rdr if ($dad_err eq ''); $dup_wtr = ($dad_wtr =~ s/^\>\&//); $dup_rdr = ($dad_rdr =~ s/^\>\&//); $dup_err = ($dad_err =~ s/^\>\&//); # force unqualified filehandles into callers' package local($package) = caller; $dad_wtr =~ s/^[^']+$/$package'$&/; $dad_rdr =~ s/^[^']+$/$package'$&/; $dad_err =~ s/^[^']+$/$package'$&/; local($kid_rdr) = ++$fh; local($kid_wtr) = ++$fh; local($kid_err) = ++$fh; if (!$dup_wtr) { pipe($kid_rdr, $dad_wtr) || die "open3: pipe 1 (stdin) failed: $!"; } if (!$dup_rdr) { pipe($dad_rdr, $kid_wtr) || die "open3: pipe 2 (stdout) failed: $!"; } if ($dad_err ne $dad_rdr && !$dup_err) { pipe($dad_err, $kid_err) || die "open3: pipe 3 (stderr) failed: $!"; } if (($kidpid = fork) < 0) { die "open2: fork failed: $!"; } elsif ($kidpid == 0) { if ($dup_wtr) { open(STDIN, ">&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr)); } else { close($dad_wtr); open(STDIN, ">&$kid_rdr"); } if ($dup_rdr) { open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr)); } else { close($dad_rdr); open(STDOUT, ">&$kid_wtr"); } if ($dad_rdr ne $dad_err) { if ($dup_err) { open(STDERR, ">&$dad_err") if (fileno(STDERR) != fileno($dad_err)); } else { close($dad_err); open(STDERR, ">&$kid_err"); } } else { open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT)); } local($")=(" "); exec @cmd; die "open2: exec of @cmd failed"; } close $kid_rdr; close $kid_wtr; close $kid_err; if ($dup_wtr) { close($dad_wtr); } select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe $kidpid; } 1; # so require is happy ($pkg) = (caller)[0]; print STDERR "NGetOpt 1.13 -- perl5.000/lib/perl5db.pl 644 203 12 35365 5646440166 10131 package DB; # modified Perl debugger, to be run from Emacs in perldb-mode # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 # Johan Vromans -- upgrade to 4.0 pl 10 $header = '$RCSfile: perl5db.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:07 $'; # # This file is automatically included if you do perl -d. # It's probably not useful to include this yourself. # # Perl supplies the values for @line and %sub. It effectively inserts # a &DB'DB(); in front of every place that can # have a breakpoint. It also inserts a do 'perldb.pl' before the first line. # # $Log: perldb.pl,v $ local($^W) = 0; if (-e "/dev/tty") { $console = "/dev/tty"; $rcfile=".perldb"; } elsif (-e "con") { $console = "con"; $rcfile="perldb.ini"; } else { $console = "sys\$command"; $rcfile="perldb.ini"; } open(IN, "<$console") || open(IN, "<&STDIN"); # so we don't dingle stdin open(OUT,">$console") || open(OUT, ">&STDERR") || open(OUT, ">&STDOUT"); # so we don't dongle stdout select(OUT); $| = 1; # for DB::OUT select(STDOUT); $| = 1; # for real STDOUT $sub = ''; # Is Perl being run from Emacs? $emacs = $main::ARGV[0] eq '-emacs'; shift(@main::ARGV) if $emacs; $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; print OUT "\nLoading DB routines from $header\n"; print OUT ("Emacs support ", $emacs ? "enabled" : "available", ".\n"); print OUT "\nEnter h for help.\n\n"; sub DB { &save; ($package, $filename, $line) = caller; $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' . "package $package;"; # this won't let them modify, alas local(*dbline) = "::_<$filename"; $max = $#dbline; if (($stop,$action) = split(/\0/,$dbline{$line})) { if ($stop eq '1') { $signal |= 1; } else { $evalarg = "\$DB::signal |= do {$stop;}"; &eval; $dbline{$line} =~ s/;9($|\0)/$1/; } } if ($single || $trace || $signal) { if ($emacs) { print OUT "\032\032$filename:$line:0\n"; } else { $prefix = $sub =~ /'|::/ ? "" : "${package}::"; $prefix .= "$sub($filename:"; if (length($prefix) > 30) { print OUT "$prefix$line):\n$line:\t",$dbline[$line]; $prefix = ""; $infix = ":\t"; } else { $infix = "):\t"; print OUT "$prefix$line$infix",$dbline[$line]; } for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { last if $dbline[$i] =~ /^\s*(}|#|\n)/; print OUT "$prefix$i$infix",$dbline[$i]; } } } $evalarg = $action, &eval if $action; if ($single || $signal) { $evalarg = $pre, &eval if $pre; print OUT $#stack . " levels deep in subroutine calls!\n" if $single & 4; $start = $line; CMD: while ((print OUT " DB<", $#hist+1, "> "), $cmd=&gets) { { $single = 0; $signal = 0; $cmd eq '' && exit 0; chop($cmd); $cmd =~ s/\\$// && do { print OUT " cont: "; $cmd .= &gets; redo CMD; }; $cmd =~ /^q$/ && exit 0; $cmd =~ /^$/ && ($cmd = $laststep); push(@hist,$cmd) if length($cmd) > 1; ($i) = split(/\s+/,$cmd); eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i}; $cmd =~ /^h$/ && do { print OUT " T Stack trace. s Single step. n Next, steps over subroutine calls. r Return from current subroutine. c [line] Continue; optionally inserts a one-time-only breakpoint at the specified line. Repeat last n or s. l min+incr List incr+1 lines starting at min. l min-max List lines. l line List line; l List next window. - List previous window. w line List window around line. l subname List subroutine. f filename Switch to filename. /pattern/ Search forwards for pattern; final / is optional. ?pattern? Search backwards for pattern. L List breakpoints and actions. S List subroutine names. t Toggle trace mode. b [line] [condition] Set breakpoint; line defaults to the current execution line; condition breaks if it evaluates to true, defaults to \'1\'. b subname [condition] Set breakpoint at first line of subroutine. d [line] Delete breakpoint. D Delete all breakpoints. a [line] command Set an action to be done before the line is executed. Sequence is: check for breakpoint, print line if necessary, do action, prompt user if breakpoint or step, evaluate line. A Delete all actions. V [pkg [vars]] List some (default all) variables in package (default current). X [vars] Same as \"V currentpackage [vars]\". < command Define command before prompt. > command Define command after prompt. ! number Redo command (default previous command). ! -number Redo number\'th to last command. H -number Display last number commands (default all). q or ^D Quit. p expr Same as \"print DB::OUT expr\" in current package. = [alias value] Define a command alias, or list current aliases. command Execute as a perl statement in current package. "; next CMD; }; $cmd =~ /^t$/ && do { $trace = !$trace; print OUT "Trace = ".($trace?"on":"off")."\n"; next CMD; }; $cmd =~ /^S$/ && do { foreach $subname (sort(keys %sub)) { print OUT $subname,"\n"; } next CMD; }; $cmd =~ s/^X\b/V $package/; $cmd =~ /^V$/ && do { $cmd = "V $package"; }; $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do { local ($savout) = select(OUT); $packname = $1; @vars = split(' ',$2); do 'dumpvar.pl' unless defined &main::dumpvar; if (defined &main::dumpvar) { &main::dumpvar($packname,@vars); } else { print DB::OUT "dumpvar.pl not available.\n"; } select ($savout); next CMD; }; $cmd =~ /^f\b\s*(.*)/ && do { $file = $1; if (!$file) { print OUT "The old f command is now the r command.\n"; print OUT "The new f command switches filenames.\n"; next CMD; } if (!defined $main::{'_<' . $file}) { if (($try) = grep(m#^_<.*$file#, keys %main::)) { $file = substr($try,2); print "\n$file:\n"; } } if (!defined $main::{'_<' . $file}) { print OUT "There's no code here anything matching $file.\n"; next CMD; } elsif ($file ne $filename) { *dbline = "::_<$file"; $max = $#dbline; $filename = $file; $start = 1; $cmd = "l"; } }; $cmd =~ /^l\b\s*([':A-Za-z_][':\w]*)/ && do { $subname = $1; $subname = "main::" . $subname unless $subname =~ /'|::/; $subname = "main" . $subname if substr($subname,0,1)eq "'"; $subname = "main" . $subname if substr($subname,0,2)eq "::"; ($file,$subrange) = split(/:/,$sub{$subname}); if ($file ne $filename) { *dbline = "::_<$file"; $max = $#dbline; $filename = $file; } if ($subrange) { if (eval($subrange) < -$window) { $subrange =~ s/-.*/+/; } $cmd = "l $subrange"; } else { print OUT "Subroutine $1 not found.\n"; next CMD; } }; $cmd =~ /^w\b\s*(\d*)$/ && do { $incr = $window - 1; $start = $1 if $1; $start -= $preview; $cmd = 'l ' . $start . '-' . ($start + $incr); }; $cmd =~ /^-$/ && do { $incr = $window - 1; $cmd = 'l ' . ($start-$window*2) . '+'; }; $cmd =~ /^l$/ && do { $incr = $window - 1; $cmd = 'l ' . $start . '-' . ($start + $incr); }; $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do { $start = $1 if $1; $incr = $2; $incr = $window - 1 unless $incr; $cmd = 'l ' . $start . '-' . ($start + $incr); }; $cmd =~ /^l\b\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do { $end = (!$2) ? $max : ($4 ? $4 : $2); $end = $max if $end > $max; $i = $2; $i = $line if $i eq '.'; $i = 1 if $i < 1; if ($emacs) { print OUT "\032\032$filename:$i:0\n"; $i = $end; } else { for (; $i <= $end; $i++) { print OUT "$i:\t", $dbline[$i]; last if $signal; } } $start = $i; # remember in case they want more $start = $max if $start > $max; next CMD; }; $cmd =~ /^D$/ && do { print OUT "Deleting all breakpoints...\n"; for ($i = 1; $i <= $max ; $i++) { if (defined $dbline{$i}) { $dbline{$i} =~ s/^[^\0]+//; if ($dbline{$i} =~ s/^\0?$//) { delete $dbline{$i}; } } } next CMD; }; $cmd =~ /^L$/ && do { for ($i = 1; $i <= $max; $i++) { if (defined $dbline{$i}) { print OUT "$i:\t", $dbline[$i]; ($stop,$action) = split(/\0/, $dbline{$i}); print OUT " break if (", $stop, ")\n" if $stop; print OUT " action: ", $action, "\n" if $action; last if $signal; } } next CMD; }; $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do { $subname = $1; $cond = $2 || '1'; $subname = "${package}::" . $subname unless $subname =~ /'|::/; $subname = "main" . $subname if substr($subname,0,1) eq "'"; $subname = "main" . $subname if substr($subname,0,2) eq "::"; ($filename,$i) = split(/:/, $sub{$subname}); $i += 0; if ($i) { *dbline = "::_<$filename"; ++$i while $dbline[$i] == 0 && $i < $#dbline; $dbline{$i} =~ s/^[^\0]*/$cond/; } else { print OUT "Subroutine $subname not found.\n"; } next CMD; }; $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do { $i = ($1?$1:$line); $cond = $2 || '1'; if ($dbline[$i] == 0) { print OUT "Line $i not breakable.\n"; } else { $dbline{$i} =~ s/^[^\0]*/$cond/; } next CMD; }; $cmd =~ /^d\b\s*(\d+)?/ && do { $i = ($1?$1:$line); $dbline{$i} =~ s/^[^\0]*//; delete $dbline{$i} if $dbline{$i} eq ''; next CMD; }; $cmd =~ /^A$/ && do { for ($i = 1; $i <= $max ; $i++) { if (defined $dbline{$i}) { $dbline{$i} =~ s/\0[^\0]*//; delete $dbline{$i} if $dbline{$i} eq ''; } } next CMD; }; $cmd =~ /^<\s*(.*)/ && do { $pre = action($1); next CMD; }; $cmd =~ /^>\s*(.*)/ && do { $post = action($1); next CMD; }; $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do { $i = $1; if ($dbline[$i] == 0) { print OUT "Line $i may not have an action.\n"; } else { $dbline{$i} =~ s/\0[^\0]*//; $dbline{$i} .= "\0" . action($3); } next CMD; }; $cmd =~ /^n$/ && do { $single = 2; $laststep = $cmd; last CMD; }; $cmd =~ /^s$/ && do { $single = 1; $laststep = $cmd; last CMD; }; $cmd =~ /^c\b\s*(\d*)\s*$/ && do { $i = $1; if ($i) { if ($dbline[$i] == 0) { print OUT "Line $i not breakable.\n"; next CMD; } $dbline{$i} =~ s/(\0|$)/;9$1/; # add one-time-only b.p. } for ($i=0; $i <= $#stack; ) { $stack[$i++] &= ~1; } last CMD; }; $cmd =~ /^r$/ && do { $stack[$#stack] |= 2; last CMD; }; $cmd =~ /^T$/ && do { local($p,$f,$l,$s,$h,$a,@a,@sub); for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { @a = (); for $arg (@args) { $_ = "$arg"; s/'/\\'/g; s/([^\0]*)/'$1'/ unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; push(@a, $_); } $w = $w ? '@ = ' : '$ = '; $a = $h ? '(' . join(', ', @a) . ')' : ''; push(@sub, "$w$s$a from file $f line $l\n"); last if $signal; } for ($i=0; $i <= $#sub; $i++) { last if $signal; print OUT $sub[$i]; } next CMD; }; $cmd =~ /^\/(.*)$/ && do { $inpat = $1; $inpat =~ s:([^\\])/$:$1:; if ($inpat ne "") { eval '$inpat =~ m'."\a$inpat\a"; if ($@ ne "") { print OUT "$@"; next CMD; } $pat = $inpat; } $end = $start; eval ' for (;;) { ++$start; $start = 1 if ($start > $max); last if ($start == $end); if ($dbline[$start] =~ m'."\a$pat\a".'i) { if ($emacs) { print OUT "\032\032$filename:$start:0\n"; } else { print OUT "$start:\t", $dbline[$start], "\n"; } last; } } '; print OUT "/$pat/: not found\n" if ($start == $end); next CMD; }; $cmd =~ /^\?(.*)$/ && do { $inpat = $1; $inpat =~ s:([^\\])\?$:$1:; if ($inpat ne "") { eval '$inpat =~ m'."\a$inpat\a"; if ($@ ne "") { print OUT "$@"; next CMD; } $pat = $inpat; } $end = $start; eval ' for (;;) { --$start; $start = $max if ($start <= 0); last if ($start == $end); if ($dbline[$start] =~ m'."\a$pat\a".'i) { if ($emacs) { print OUT "\032\032$filename:$start:0\n"; } else { print OUT "$start:\t", $dbline[$start], "\n"; } last; } } '; print OUT "?$pat?: not found\n" if ($start == $end); next CMD; }; $cmd =~ /^!+\s*(-)?(\d+)?$/ && do { pop(@hist) if length($cmd) > 1; $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist)); $cmd = $hist[$i] . "\n"; print OUT $cmd; redo CMD; }; $cmd =~ /^!(.+)$/ && do { $pat = "^$1"; pop(@hist) if length($cmd) > 1; for ($i = $#hist; $i; --$i) { last if $hist[$i] =~ $pat; } if (!$i) { print OUT "No such command!\n\n"; next CMD; } $cmd = $hist[$i] . "\n"; print OUT $cmd; redo CMD; }; $cmd =~ /^H\b\s*(-(\d+))?/ && do { $end = $2?($#hist-$2):0; $hist = 0 if $hist < 0; for ($i=$#hist; $i>$end; $i--) { print OUT "$i: ",$hist[$i],"\n" unless $hist[$i] =~ /^.?$/; }; next CMD; }; $cmd =~ s/^p( .*)?$/print DB::OUT$1/; $cmd =~ /^=/ && do { if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) { $alias{$k}="s~$k~$v~"; print OUT "$k = $v\n"; } elsif ($cmd =~ /^=\s*$/) { foreach $k (sort keys(%alias)) { if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) { print OUT "$k = $v\n"; } else { print OUT "$k\t$alias{$k}\n"; }; }; }; next CMD; }; } $evalarg = $cmd; &eval; print OUT "\n"; } if ($post) { $evalarg = $post; &eval; } } ($@, $!, $,, $/, $\) = @saved; } sub save { @saved = ($@, $!, $,, $/, $\, $^W); $, = ""; $/ = "\n"; $\ = ""; $^W = 0; } # The following takes its argument via $evalarg to preserve current @_ sub eval { eval "$usercontext $evalarg; &DB::save"; print OUT $@; } sub action { local($action) = @_; while ($action =~ s/\\$//) { print OUT "+ "; $action .= &gets; } $action; } sub gets { local($.); ; } sub catch { $signal = 1; } sub sub { push(@stack, $single); $single &= 1; $single |= 4 if $#stack == $deep; if (wantarray) { @i = &$sub; $single |= pop(@stack); @i; } else { $i = &$sub; $single |= pop(@stack); $i; } } $trace = $signal = $single = 0; # uninitialized warning suppression @hist = ('?'); $SIG{'INT'} = "DB::catch"; $deep = 100; # warning if stack gets this deep $window = 10; $preview = 3; @stack = (0); @ARGS = @ARGV; for (@args) { s/'/\\'/g; s/(.*)/'$1'/ unless /^-?[\d.]+$/; } if (-f $rcfile) { do "./$rcfile"; } elsif (-f "$ENV{'LOGDIR'}/$rcfile") { do "$ENV{'LOGDIR'}/$rcfile"; } elsif (-f "$ENV{'HOME'}/$rcfile") { do "$ENV{'HOME'}/$rcfile"; } 1; $cmd = 'l ' . $start . '-' . ($start + $incr); }; $cmd =~ /^-$/ && do { $incr = $window - 1; $cmd = 'l ' . ($start-$window*2) . '+'; }; $cmd =~ /^l$/ && do { $incr = $window - 1; $cmd = 'l ' . $start . '-' . ($start + $incr); }; $cmd =~perl5.000/lib/pwd.pl 644 203 12 2136 5576233322 7330 ;# pwd.pl - keeps track of current working directory in PWD environment var ;# ;# $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $ ;# ;# $Log: pwd.pl,v $ ;# ;# Usage: ;# require "pwd.pl"; ;# &initpwd; ;# ... ;# &chdir($newdir); package pwd; sub main'initpwd { if ($ENV{'PWD'}) { local($dd,$di) = stat('.'); local($pd,$pi) = stat($ENV{'PWD'}); if ($di != $pi || $dd != $pd) { chop($ENV{'PWD'} = `pwd`); } } else { chop($ENV{'PWD'} = `pwd`); } if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) { local($pd,$pi) = stat($2); local($dd,$di) = stat($1); if ($di == $pi && $dd == $pd) { $ENV{'PWD'}="$2$3"; } } } sub main'chdir { local($newdir) = shift; if (chdir $newdir) { if ($newdir =~ m#^/#) { $ENV{'PWD'} = $newdir; } else { local(@curdir) = split(m#/#,$ENV{'PWD'}); @curdir = '' unless @curdir; foreach $component (split(m#/#, $newdir)) { next if $component eq '.'; pop(@curdir),next if $component eq '..'; push(@curdir,$component); } $ENV{'PWD'} = join('/',@curdir) || '/'; } } else { 0; } } 1; npat = $1; $inpat =~ s:([^\\])/$:$1:; if ($inpat ne "") { eval '$inpat =~ m'."\a$inpat\a"; if ($@ ne "") { print OUT "$@"; next CMD; } $pat = $inpat; } $end = $start; eval ' for (;;) { ++$start; $start = 1 if ($start > $max); last if ($start == $end); if ($dbline[$start] =~ m'."\a$pat\a".'i) { if ($emacs) { print OUT "\032\032$filperl5.000/lib/shellwords.pl 644 203 12 1560 5576475717 10744 ;# shellwords.pl ;# ;# Usage: ;# require 'shellwords.pl'; ;# @words = &shellwords($line); ;# or ;# @words = &shellwords(@lines); ;# or ;# @words = &shellwords; # defaults to $_ (and clobbers it) sub shellwords { package shellwords; local($_) = join('', @_) if @_; local(@words,$snippet,$field); s/^\s+//; while ($_ ne '') { $field = ''; for (;;) { if (s/^"(([^"\\]|\\.)*)"//) { ($snippet = $1) =~ s#\\(.)#$1#g; } elsif (/^"/) { die "Unmatched double quote: $_\n"; } elsif (s/^'(([^'\\]|\\.)*)'//) { ($snippet = $1) =~ s#\\(.)#$1#g; } elsif (/^'/) { die "Unmatched single quote: $_\n"; } elsif (s/^\\(.)//) { $snippet = $1; } elsif (s/^([^\s\\'"]+)//) { $snippet = $1; } else { s/^\s+//; last; } $field .= $snippet; } push(@words, $field); } @words; } 1; ;) { if (s/^"(([^"\\]|\\.)*)"//) { ($snippet = $1) =~ s#\\(.)#$1#g; } elsif (/^"/) { die "Unmatched double quote: $_\n"; perl5.000/lib/sigtrap.pm 664 203 12 2235 5646435440 10215 package sigtrap; require Carp; sub import { my $pack = shift; my @sigs = @_; @sigs or @sigs = qw(QUIT ILL TRAP ABRT EMT FPE BUS SEGV SYS PIPE TERM); foreach $sig (@sigs) { $SIG{$sig} = 'sigtrap::trap'; } } sub trap { package DB; # To get subroutine args. $SIG{'ABRT'} = DEFAULT; kill 'ABRT', $$ if $panic++; syswrite(STDERR, 'Caught a SIG', 12); syswrite(STDERR, $_[0], length($_[0])); syswrite(STDERR, ' at ', 4); ($pack,$file,$line) = caller; syswrite(STDERR, $file, length($file)); syswrite(STDERR, ' line ', 6); syswrite(STDERR, $line, length($line)); syswrite(STDERR, "\n", 1); # Now go for broke. for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { @a = (); for $arg (@args) { $_ = "$arg"; s/'/\\'/g; s/([^\0]*)/'$1'/ unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; push(@a, $_); } $w = $w ? '@ = ' : '$ = '; $a = $h ? '(' . join(', ', @a) . ')' : ''; $mess = "$w$s$a called from $f line $l\n"; syswrite(STDERR, $mess, length($mess)); } kill 'ABRT', $$; } 1; "") { eval '$inpat =~ m'."\a$inpat\a"; if ($@ ne "") { print OUT "$@"; next CMD; } $pat = $inpat; } $end = $start; eval ' for (;;) { ++$start; $start = 1 if ($start > $max); last if ($start == $end); if ($dbline[$start] =~ m'."\a$pat\a".'i) { if ($emacs) { print OUT "\032\032$filperl5.000/lib/stat.pl 644 203 12 1222 5240621031 7466 ;# $RCSfile: stat.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:13 $ ;# Usage: ;# require 'stat.pl'; ;# @ary = stat(foo); ;# $st_dev = @ary[$ST_DEV]; ;# $ST_DEV = 0 + $[; $ST_INO = 1 + $[; $ST_MODE = 2 + $[; $ST_NLINK = 3 + $[; $ST_UID = 4 + $[; $ST_GID = 5 + $[; $ST_RDEV = 6 + $[; $ST_SIZE = 7 + $[; $ST_ATIME = 8 + $[; $ST_MTIME = 9 + $[; $ST_CTIME = 10 + $[; $ST_BLKSIZE = 11 + $[; $ST_BLOCKS = 12 + $[; ;# Usage: ;# require 'stat.pl'; ;# do Stat('foo'); # sets st_* as a side effect ;# sub Stat { ($st_dev,$st_ino,$st_mode,$st_nlink,$st_uid,$st_gid,$st_rdev,$st_size, $st_atime,$st_mtime,$st_ctime,$st_blksize,$st_blocks) = stat(shift(@_)); } 1; Now go for broke. for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { @a = (); for $arg (@args) { $_ = "$arg"; s/'/\\'/g; s/([^\0]*)/'$1'/ unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; push(@a, $_); } $w = $w ? '@ = ' : '$ = '; $a =perl5.000/lib/strict.pm 664 203 12 571 5635116016 10026 package strict; sub bits { my $bits = 0; foreach $sememe (@_) { $bits |= 0x00000002 if $sememe eq 'refs'; $bits |= 0x00000200 if $sememe eq 'subs'; $bits |= 0x00000400 if $sememe eq 'vars'; } $bits; } sub import { shift; $^H |= bits(@_ ? @_ : qw(refs subs vars)); } sub unimport { shift; $^H &= ~ bits(@_ ? @_ : qw(refs subs vars)); } 1; 1 + $[; $ST_BLOCKS = 12 + $[; ;# Usage: ;# require 'stat.pl'; ;# do Stat('foo'); # sets st_* as a side effect ;# sub Stat { ($st_perl5.000/lib/subs.pm 664 203 12 344 5625232075 7473 package subs; require 5.000; $ExportLevel = 0; sub import { my $callpack = caller; my $pack = shift; my @imports = @_; foreach $sym (@imports) { *{"${callpack}::$sym"} = \&{"${callpack}::$sym"}; } }; 1; port { shift; $^H |= bits(@_ ? @_ : qw(refs subs vars)); } sub unimport { shift; $^H &= ~ bits(@_ ? @_ : qw(refs subs vars)); } 1; 1 + $[; $ST_BLOCKS = 12 + $[; ;# Usage: ;# require 'stat.pl'; ;# do Stat('foo'); # sets st_* as a side effect ;# sub Stat { ($st_perl5.000/lib/syslog.pl 644 203 12 10657 5576233433 10110 # # syslog.pl # # $Log: syslog.pl,v $ # # tom christiansen # modified to use sockets by Larry Wall # NOTE: openlog now takes three arguments, just like openlog(3) # # call syslog() with a string priority and a list of printf() args # like syslog(3) # # usage: require 'syslog.pl'; # # then (put these all in a script to test function) # # # do openlog($program,'cons,pid','user'); # do syslog('info','this is another test'); # do syslog('mail|warning','this is a better test: %d', time); # do closelog(); # # do syslog('debug','this is the last test'); # do openlog("$program $$",'ndelay','user'); # do syslog('notice','fooprogram: this is really done'); # # $! = 55; # do syslog('info','problem was %m'); # %m == $! in syslog(3) package syslog; $host = 'localhost' unless $host; # set $syslog'host to change require 'syslog.ph'; $maskpri = &LOG_UPTO(&LOG_DEBUG); sub main'openlog { ($ident, $logopt, $facility) = @_; # package vars $lo_pid = $logopt =~ /\bpid\b/; $lo_ndelay = $logopt =~ /\bndelay\b/; $lo_cons = $logopt =~ /\bcons\b/; $lo_nowait = $logopt =~ /\bnowait\b/; &connect if $lo_ndelay; } sub main'closelog { $facility = $ident = ''; &disconnect; } sub main'setlogmask { local($oldmask) = $maskpri; $maskpri = shift; $oldmask; } sub main'syslog { local($priority) = shift; local($mask) = shift; local($message, $whoami); local(@words, $num, $numpri, $numfac, $sum); local($facility) = $facility; # may need to change temporarily. die "syslog: expected both priority and mask" unless $mask && $priority; @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility". undef $numpri; undef $numfac; foreach (@words) { $num = &xlate($_); # Translate word to number. if (/^kern$/ || $num < 0) { die "syslog: invalid level/facility: $_\n"; } elsif ($num <= &LOG_PRIMASK) { die "syslog: too many levels given: $_\n" if defined($numpri); $numpri = $num; return 0 unless &LOG_MASK($numpri) & $maskpri; } else { die "syslog: too many facilities given: $_\n" if defined($numfac); $facility = $_; $numfac = $num; } } die "syslog: level must be given\n" unless defined($numpri); if (!defined($numfac)) { # Facility not specified in this call. $facility = 'user' unless $facility; $numfac = &xlate($facility); } &connect unless $connected; $whoami = $ident; if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) { $whoami = $1; $mask = $2; } unless ($whoami) { ($whoami = getlogin) || ($whoami = getpwuid($<)) || ($whoami = 'syslog'); } $whoami .= "[$$]" if $lo_pid; $mask =~ s/%m/$!/g; $mask .= "\n" unless $mask =~ /\n$/; $message = sprintf ($mask, @_); $sum = $numpri + $numfac; unless (send(SYSLOG,"<$sum>$whoami: $message",0)) { if ($lo_cons) { if ($pid = fork) { unless ($lo_nowait) { do {$died = wait;} until $died == $pid || $died < 0; } } else { open(CONS,">/dev/console"); print CONS "<$facility.$priority>$whoami: $message\r"; exit if defined $pid; # if fork failed, we're parent close CONS; } } } } sub xlate { local($name) = @_; $name =~ y/a-z/A-Z/; $name = "LOG_$name" unless $name =~ /^LOG_/; $name = "syslog'$name"; eval(&$name) || -1; } sub connect { $pat = 'S n C4 x8'; $af_unix = 1; $af_inet = 2; $stream = 1; $datagram = 2; ($name,$aliases,$proto) = getprotobyname('udp'); $udp = $proto; ($name,$aliase,$port,$proto) = getservbyname('syslog','udp'); $syslog = $port; if (chop($myname = `hostname`)) { ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname); die "Can't lookup $myname\n" unless $name; @bytes = unpack("C4",$addrs[0]); } else { @bytes = (0,0,0,0); } $this = pack($pat, $af_inet, 0, @bytes); if ($host =~ /^\d+\./) { @bytes = split(/\./,$host); } else { ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host); die "Can't lookup $host\n" unless $name; @bytes = unpack("C4",$addrs[0]); } $that = pack($pat,$af_inet,$syslog,@bytes); socket(SYSLOG,$af_inet,$datagram,$udp) || die "socket: $!\n"; bind(SYSLOG,$this) || die "bind: $!\n"; connect(SYSLOG,$that) || die "connect: $!\n"; local($old) = select(SYSLOG); $| = 1; select($old); $connected = 1; } sub disconnect { close SYSLOG; $connected = 0; } 1; st < 0; for ($i=$#hist; $i>$end; $i--) { print OUT "$i: ",$hist[$i],"\n"perl5.000/lib/tainted.pl 664 203 12 244 5242570134 10141 # This subroutine returns true if its argument is tainted, false otherwise. sub tainted { local($@); eval { kill 0 * $_[0] }; $@ =~ /^Insecure/; } 1; low "level" or "level|facility". undef $numpri; undef $numfac; foreach (@words) { $num = &xlate($_); # Translate word to number. if (/^kern$/ || $num < 0) { die "syslog: invalid level/facility: $_\n"; } elsif ($num <= &LOG_PRIMASK) { die "syslog: too many levels given: $_\n" if defined($numpri); $numpri = $num; perl5.000/lib/termcap.pl 644 203 12 7137 5635211167 10176 ;# $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $ ;# ;# Usage: ;# require 'ioctl.pl'; ;# ioctl(TTY,$TIOCGETP,$foo); ;# ($ispeed,$ospeed) = unpack('cc',$foo); ;# require 'termcap.pl'; ;# &Tgetent('vt100'); # sets $TC{'cm'}, etc. ;# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE'); ;# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE'); ;# sub Tgetent { local($TERM) = @_; local($TERMCAP,$_,$entry,$loop,$field); warn "Tgetent: no ospeed set" unless $ospeed; foreach $key (keys(TC)) { delete $TC{$key}; } $TERM = $ENV{'TERM'} unless $TERM; $TERM =~ s/(\W)/\\$1/g; $TERMCAP = $ENV{'TERMCAP'}; $TERMCAP = '/etc/termcap' unless $TERMCAP; if ($TERMCAP !~ m:^/:) { if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) { $TERMCAP = '/etc/termcap'; } } if ($TERMCAP =~ m:^/:) { $entry = ''; do { $loop = " open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\"; while () { next if /^#/; next if /^\t/; if (/(^|\\|)${TERM}[:\\|]/) { chop; while (chop eq '\\\\') { \$_ .= ; chop; } \$_ .= ':'; last; } } close TERMCAP; \$entry .= \$_; "; eval $loop; } while s/:tc=([^:]+):/:/ && ($TERM = $1); $TERMCAP = $entry; } foreach $field (split(/:[\s:\\]*/,$TERMCAP)) { if ($field =~ /^\w\w$/) { $TC{$field} = 1; } elsif ($field =~ /^(\w\w)#(.*)/) { $TC{$1} = $2 if $TC{$1} eq ''; } elsif ($field =~ /^(\w\w)=(.*)/) { $entry = $1; $_ = $2; s/\\E/\033/g; s/\\(\d\d\d)/pack('c',$1 & 0177)/eg; s/\\n/\n/g; s/\\r/\r/g; s/\\t/\t/g; s/\\b/\b/g; s/\\f/\f/g; s/\\\^/\377/g; s/\^\?/\177/g; s/\^(.)/pack('c',ord($1) & 31)/eg; s/\\(.)/$1/g; s/\377/^/g; $TC{$entry} = $_ if $TC{$entry} eq ''; } } $TC{'pc'} = "\0" if $TC{'pc'} eq ''; $TC{'bc'} = "\b" if $TC{'bc'} eq ''; } @Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2); sub Tputs { local($string,$affcnt,$FH) = @_; local($ms); if ($string =~ /(^[\d.]+)(\*?)(.*)$/) { $ms = $1; $ms *= $affcnt if $2; $string = $3; $decr = $Tputs[$ospeed]; if ($decr > .1) { $ms += $decr / 2; $string .= $TC{'pc'} x ($ms / $decr); } } print $FH $string if $FH; $string; } sub Tgoto { local($string) = shift(@_); local($result) = ''; local($after) = ''; local($code,$tmp) = @_; local(@tmp); @tmp = ($tmp,$code); local($online) = 0; while ($string =~ /^([^%]*)%(.)(.*)/) { $result .= $1; $code = $2; $string = $3; if ($code eq 'd') { $result .= sprintf("%d",shift(@tmp)); } elsif ($code eq '.') { $tmp = shift(@tmp); if ($tmp == 0 || $tmp == 4 || $tmp == 10) { if ($online) { ++$tmp, $after .= $TC{'up'} if $TC{'up'}; } else { ++$tmp, $after .= $TC{'bc'}; } } $result .= sprintf("%c",$tmp); $online = !$online; } elsif ($code eq '+') { $result .= sprintf("%c",shift(@tmp)+ord($string)); $string = substr($string,1,99); $online = !$online; } elsif ($code eq 'r') { ($code,$tmp) = @tmp; @tmp = ($tmp,$code); $online = !$online; } elsif ($code eq '>') { ($code,$tmp,$string) = unpack("CCa99",$string); if ($tmp[$[] > $code) { $tmp[$[] += $tmp; } } elsif ($code eq '2') { $result .= sprintf("%02d",shift(@tmp)); $online = !$online; } elsif ($code eq '3') { $result .= sprintf("%03d",shift(@tmp)); $online = !$online; } elsif ($code eq 'i') { ($code,$tmp) = @tmp; @tmp = ($code+1,$tmp+1); } else { return "OOPS"; } } $result . $string . $after; } 1; ioctl.pl'; ;# ioctl(TTY,$TIOCGETP,$foo); ;# ($ispeed,$ospeed) = unpack('cc',$foo); ;# require 'termcap.pl'; ;# &Tgetent('vt100'); # sets $TC{'cm'}, etc. ;# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE'); ;# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE'); ;# sub Tgetent { local($TERM) = @_; local($TERMCAP,$_,$entry,$loop,$field); warn "Tgetent: no ospeed set" unless $ospeed; foreach $key (keys(TC)) {perl5.000/lib/timelocal.pl 644 203 12 6720 5614656052 10514 ;# timelocal.pl ;# ;# Usage: ;# $time = timelocal($sec,$min,$hours,$mday,$mon,$year); ;# $time = timegm($sec,$min,$hours,$mday,$mon,$year); ;# These routines are quite efficient and yet are always guaranteed to agree ;# with localtime() and gmtime(). We manage this by caching the start times ;# of any months we've seen before. If we know the start time of the month, ;# we can always calculate any time within the month. The start times ;# themselves are guessed by successive approximation starting at the ;# current time, since most dates seen in practice are close to the ;# current date. Unlike algorithms that do a binary search (calling gmtime ;# once for each bit of the time value, resulting in 32 calls), this algorithm ;# calls it at most 6 times, and usually only once or twice. If you hit ;# the month cache, of course, it doesn't call it at all. ;# timelocal is implemented using the same cache. We just assume that we're ;# translating a GMT time, and then fudge it when we're done for the timezone ;# and daylight savings arguments. The timezone is determined by examining ;# the result of localtime(0) when the package is initialized. The daylight ;# savings offset is currently assumed to be one hour. ;# Both routines return -1 if the integer limit is hit. I.e. for dates ;# after the 1st of January, 2038 on most machines. CONFIG: { package timelocal; local($[) = 0; @epoch = localtime(0); $tzmin = $epoch[2] * 60 + $epoch[1]; # minutes east of GMT if ($tzmin > 0) { $tzmin = 24 * 60 - $tzmin; # minutes west of GMT $tzmin -= 24 * 60 if $epoch[5] == 70; # account for the date line } $SEC = 1; $MIN = 60 * $SEC; $HR = 60 * $MIN; $DAYS = 24 * $HR; $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0; 1; } sub timegm { package timelocal; local($[) = 0; $ym = pack(C2, @_[5,4]); $cheat = $cheat{$ym} || &cheat; return -1 if $cheat<0; $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS; } sub timelocal { package timelocal; local($[) = 0; $time = &main'timegm + $tzmin*$MIN; return -1 if $cheat<0; @test = localtime($time); $time -= $HR if $test[2] != $_[2]; $time; } package timelocal; sub cheat { $year = $_[5]; $month = $_[4]; die "Month out of range 0..11 in timelocal.pl\n" if $month > 11 || $month < 0; die "Day out of range 1..31 in timelocal.pl\n" if $_[3] > 31 || $_[3] < 1; die "Hour out of range 0..23 in timelocal.pl\n" if $_[2] > 23 || $_[2] < 0; die "Minute out of range 0..59 in timelocal.pl\n" if $_[1] > 59 || $_[1] < 0; die "Second out of range 0..59 in timelocal.pl\n" if $_[0] > 59 || $_[0] < 0; $guess = $^T; @g = gmtime($guess); $year += $YearFix if $year < $epoch[5]; $lastguess = ""; while ($diff = $year - $g[5]) { $guess += $diff * (363 * $DAYS); @g = gmtime($guess); if (($thisguess = "@g") eq $lastguess){ return -1; #date beyond this machine's integer limit } $lastguess = $thisguess; } while ($diff = $month - $g[4]) { $guess += $diff * (27 * $DAYS); @g = gmtime($guess); if (($thisguess = "@g") eq $lastguess){ return -1; #date beyond this machine's integer limit } $lastguess = $thisguess; } @gfake = gmtime($guess-1); #still being sceptic if ("@gfake" eq $lastguess){ return -1; #date beyond this machine's integer limit } $g[3]--; $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAYS; $cheat{$ym} = $guess; } q 'i') { ($code,$tmp) = @tmp; @tmp = (perl5.000/lib/validate.pl 644 203 12 7333 5240621037 10323 ;# $RCSfile: validate.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:19 $ ;# The validate routine takes a single multiline string consisting of ;# lines containing a filename plus a file test to try on it. (The ;# file test may also be a 'cd', causing subsequent relative filenames ;# to be interpreted relative to that directory.) After the file test ;# you may put '|| die' to make it a fatal error if the file test fails. ;# The default is '|| warn'. The file test may optionally have a ! prepended ;# to test for the opposite condition. If you do a cd and then list some ;# relative filenames, you may want to indent them slightly for readability. ;# If you supply your own "die" or "warn" message, you can use $file to ;# interpolate the filename. ;# Filetests may be bunched: -rwx tests for all of -r, -w and -x. ;# Only the first failed test of the bunch will produce a warning. ;# The routine returns the number of warnings issued. ;# Usage: ;# require "validate.pl"; ;# $warnings += do validate(' ;# /vmunix -e || die ;# /boot -e || die ;# /bin cd ;# csh -ex ;# csh !-ug ;# sh -ex ;# sh !-ug ;# /usr -d || warn "What happened to $file?\n" ;# '); sub validate { local($file,$test,$warnings,$oldwarnings); foreach $check (split(/\n/,$_[0])) { next if $check =~ /^#/; next if $check =~ /^$/; ($file,$test) = split(' ',$check,2); if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) { $testlist = $2; @testlist = split(//,$testlist); } else { @testlist = ('Z'); } $oldwarnings = $warnings; foreach $one (@testlist) { $this = $test; $this =~ s/(-\w\b)/$1 \$file/g; $this =~ s/-Z/-$one/; $this .= ' || warn' unless $this =~ /\|\|/; $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || do valmess('$2','$1')/; $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g; eval $this; last if $warnings > $oldwarnings; } } $warnings; } sub valmess { local($disposition,$this) = @_; $file = $cwd . '/' . $file unless $file =~ m|^/|; if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) { $neg = $1; $tmp = $2; $tmp eq 'r' && ($mess = "$file is not readable by uid $>."); $tmp eq 'w' && ($mess = "$file is not writable by uid $>."); $tmp eq 'x' && ($mess = "$file is not executable by uid $>."); $tmp eq 'o' && ($mess = "$file is not owned by uid $>."); $tmp eq 'R' && ($mess = "$file is not readable by you."); $tmp eq 'W' && ($mess = "$file is not writable by you."); $tmp eq 'X' && ($mess = "$file is not executable by you."); $tmp eq 'O' && ($mess = "$file is not owned by you."); $tmp eq 'e' && ($mess = "$file does not exist."); $tmp eq 'z' && ($mess = "$file does not have zero size."); $tmp eq 's' && ($mess = "$file does not have non-zero size."); $tmp eq 'f' && ($mess = "$file is not a plain file."); $tmp eq 'd' && ($mess = "$file is not a directory."); $tmp eq 'l' && ($mess = "$file is not a symbolic link."); $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO)."); $tmp eq 'S' && ($mess = "$file is not a socket."); $tmp eq 'b' && ($mess = "$file is not a block special file."); $tmp eq 'c' && ($mess = "$file is not a character special file."); $tmp eq 'u' && ($mess = "$file does not have the setuid bit set."); $tmp eq 'g' && ($mess = "$file does not have the setgid bit set."); $tmp eq 'k' && ($mess = "$file does not have the sticky bit set."); $tmp eq 'T' && ($mess = "$file is not a text file."); $tmp eq 'B' && ($mess = "$file is not a binary file."); if ($neg eq '!') { $mess =~ s/ is not / should not be / || $mess =~ s/ does not / should not / || $mess =~ s/ not / /; } print stderr $mess,"\n"; } else { $this =~ s/\$file/'$file'/g; print stderr "Can't do $this.\n"; } if ($disposition eq 'die') { exit 1; } ++$warnings; } 1; terpolate the filename. ;# Filetests may be bunched: -rwx tests for all of -r, -w and -x. ;# Only the first failed test of the bunch will produce a warning. ;# The routine returns the number of warnings issued. ;# Usage: ;# require "validate.pl"; ;# $warnings += do validate(' ;# /vmunix perl5.000/makedepend.SH 755 203 12 10613 5650572655 10016 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=../../../..; else echo "Can't find config.sh."; exit 1 fi . $TOP/config.sh ;; esac : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac echo "Extracting makedepend (with variable substitutions)" rm -f makedepend $spitshell >makedepend <<'!NO!SUBS!' # makedepend.SH # export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$) 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=../../../..; else echo "Can't find config.sh."; exit 1 fi . $TOP/config.sh ;; esac PATH="$PATH:." export PATH $cat /dev/null >.deptmp $rm -f *.c.c c/*.c.c if test -f Makefile; then cp Makefile makefile fi mf=makefile if test -f $mf; then defrule=`<$mf sed -n \ -e '/^\.c\.o:.*;/{' \ -e 's/\$\*\.c//' \ -e 's/^[^;]*;[ ]*//p' \ -e q \ -e '}' \ -e '/^\.c\.o: *$/{' \ -e N \ -e 's/\$\*\.c//' \ -e 's/^.*\n[ ]*//p' \ -e q \ -e '}'` fi case "$defrule" in '') defrule='$(CC) -c $(CFLAGS)' ;; esac : Create files in UU directory to avoid problems with long filenames : on systems with 14 character filename limits so file.c.c and file.c : might be identical $test -d UU || mkdir UU make clist || ($echo "Searching for .c files..."; \ $echo *.c | $tr ' ' '\012' | $egrep -v '\*' >.clist) for file in `$cat .clist`; do # for file in `cat /dev/null`; do case "$file" in *.c) filebase=`basename $file .c` ;; *.y) filebase=`basename $file .y` ;; esac case "$file" in */*) finc="-I`echo $file | sed 's#/[^/]*$##`" ;; *) finc= ;; esac $echo "Finding dependencies for $filebase.o." ( $echo "#line 1 \"$file\""; \ $sed -n <$file \ -e "/^${filebase}_init(/q" \ -e '/^#line/d' \ -e '/^#/{' \ -e 's|/\*.*$||' \ -e 's|\\$||' \ -e p \ -e '}' ) >UU/$file.c $cppstdin $finc -I/usr/local/include -I. $cppflags $cppminus > .deptmp done $sed <$mf >$mf.new -e '1,/^# AUTOMATICALLY/!d' make shlist || ($echo "Searching for .SH files..."; \ $echo *.SH | $tr ' ' '\012' | $egrep -v '\*' >.shlist) if $test -s .deptmp; then for file in `cat .shlist`; do $echo `$expr X$file : 'X\(.*\).SH'`: $file $TOP/config.sh \; \ /bin/sh $file >> .deptmp done $echo "Updating $mf..." $echo "# If this runs make out of memory, delete /usr/include lines." \ >> $mf.new $sed 's|^\(.*\.o:\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \ >>$mf.new else make hlist || ($echo "Searching for .h files..."; \ $echo *.h | $tr ' ' '\012' | $egrep -v '\*' >.hlist) $echo "You don't seem to have a proper C preprocessor. Using grep instead." $egrep '^#include ' `cat .clist` `cat .hlist` >.deptmp $echo "Updating $mf..." <.clist $sed -n \ -e '/\//{' \ -e 's|^\(.*\)/\(.*\)\.c|\2.o: \1/\2.c; '"$defrule \1/\2.c|p" \ -e d \ -e '}' \ -e 's|^\(.*\)\.c|\1.o: \1.c|p' >> $mf.new <.hlist $sed -n 's|\(.*/\)\(.*\)|s= \2= \1\2=|p' >.hsed <.deptmp $sed -n 's|c:#include "\(.*\)".*$|o: \1|p' | \ $sed 's|^[^;]*/||' | \ $sed -f .hsed >> $mf.new <.deptmp $sed -n 's|h:#include "\(.*\)".*$|h: \1|p' | \ $sed -f .hsed >> $mf.new for file in `$cat .shlist`; do $echo `$expr X$file : 'X\(.*\).SH'`: $file $TOP/config.sh \; \ /bin/sh $file >> $mf.new done fi $rm -f $mf.old $cp $mf $mf.old $cp $mf.new $mf $rm $mf.new $echo "# WARNING: Put nothing here or make depend will gobble it up!" >> $mf $rm -rf .deptmp UU .shlist .clist .hlist .hsed !NO!SUBS! $eunicefix makedepend chmod +x makedepend case `pwd` in *SH) $rm -f ../makedepend ln makedepend ../makedepend ;; esac $deep = 100; # warning if stack gets this deep $window = 10; $preview = 3; @stack = (0); @ARGS = @ARGV; for (@args)perl5.000/makedir.SH 755 203 12 2237 5650572655 7320 case $CONFIG in '') if test ! -f config.sh; then ln ../config.sh . || \ ln ../../config.sh . || \ ln ../../../config.sh . || \ (echo "Can't find config.sh."; exit 1) fi 2>/dev/null . ./config.sh ;; esac case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac echo "Extracting makedir (with variable substitutions)" rm -f makedir $spitshell >makedir </dev/null 2>&1 done !GROK!THIS! $eunicefix makedir chmod +x makedir -f Makefile; then cp Makefile makefile fi mf=makefile if test -f $mf; then defrule=`<$mf sed -n \ -e '/^\.c\.o:.*;/{' \ -e 's/\$\*\.c//' \ -e 's/^[^;]*;[ ]*//p' \ -e q \ -e '}' \ -e '/^\.c\.o: *$/{' \ -e N \ -e 's/\$\*\.c//' \ -e 's/^.*\n[ ]*//p' \ -e q \ -e '}'` fi case "$defrule" in '') defperl5.000/malloc.c 644 203 12 26640 5650572640 7076 /* malloc.c * */ #ifndef lint #ifdef DEBUGGING #define RCHECK #endif /* * malloc.c (Caltech) 2/21/82 * Chris Kingsley, kingsley@cit-20. * * This is a very fast storage allocator. It allocates blocks of a small * number of different sizes, and keeps free lists of each size. Blocks that * don't exactly fit are passed up to the next larger size. In this * implementation, the available sizes are 2^n-4 (or 2^n-12) bytes long. * This is designed for use in a program that uses vast quantities of memory, * but bombs when it runs out. */ #include "EXTERN.h" #include "perl.h" /* I don't much care whether these are defined in sys/types.h--LAW */ #define u_char unsigned char #define u_int unsigned int #define u_short unsigned short /* * The overhead on a block is at least 4 bytes. When free, this space * contains a pointer to the next free block, and the bottom two bits must * be zero. When in use, the first byte is set to MAGIC, and the second * byte is the size index. The remaining bytes are for alignment. * If range checking is enabled and the size of the block fits * in two bytes, then the top two bytes hold the size of the requested block * plus the range checking words, and the header word MINUS ONE. */ union overhead { union overhead *ov_next; /* when free */ #if MEM_ALIGNBYTES > 4 double strut; /* alignment problems */ #endif struct { u_char ovu_magic; /* magic number */ u_char ovu_index; /* bucket # */ #ifdef RCHECK u_short ovu_size; /* actual block size */ u_int ovu_rmagic; /* range magic number */ #endif } ovu; #define ov_magic ovu.ovu_magic #define ov_index ovu.ovu_index #define ov_size ovu.ovu_size #define ov_rmagic ovu.ovu_rmagic }; #ifdef debug static void botch _((char *s)); #endif static void morecore _((int bucket)); static int findbucket _((union overhead *freep, int srchlen)); #define MAGIC 0xff /* magic # on accounting info */ #define RMAGIC 0x55555555 /* magic # on range info */ #ifdef RCHECK #define RSLOP sizeof (u_int) #else #define RSLOP 0 #endif /* * nextf[i] is the pointer to the next free block of size 2^(i+3). The * smallest allocatable block is 8 bytes. The overhead information * precedes the data area returned to the user. */ #define NBUCKETS 30 static union overhead *nextf[NBUCKETS]; extern char *sbrk(); #ifdef MSTATS /* * nmalloc[i] is the difference between the number of mallocs and frees * for a given block size. */ static u_int nmalloc[NBUCKETS]; #include #endif #ifdef debug #define ASSERT(p) if (!(p)) botch("p"); else static void botch(s) char *s; { printf("assertion botched: %s\n", s); abort(); } #else #define ASSERT(p) #endif Malloc_t malloc(nbytes) register MEM_SIZE nbytes; { register union overhead *p; register int bucket = 0; register MEM_SIZE shiftr; #ifdef safemalloc #ifdef DEBUGGING MEM_SIZE size = nbytes; #endif #ifdef MSDOS if (nbytes > 0xffff) { fprintf(stderr, "Allocation too large: %lx\n", (long)nbytes); my_exit(1); } #endif /* MSDOS */ #ifdef DEBUGGING if ((long)nbytes < 0) croak("panic: malloc"); #endif #endif /* safemalloc */ /* * Convert amount of memory requested into * closest block size stored in hash buckets * which satisfies request. Account for * space used per block for accounting. */ nbytes += sizeof (union overhead) + RSLOP; nbytes = (nbytes + 3) &~ 3; shiftr = (nbytes - 1) >> 2; /* apart from this loop, this is O(1) */ while (shiftr >>= 1) bucket++; /* * If nothing in hash bucket right now, * request more memory from the system. */ if (nextf[bucket] == NULL) morecore(bucket); if ((p = (union overhead *)nextf[bucket]) == NULL) { #ifdef safemalloc if (!nomemok) { fputs("Out of memory!\n", stderr); my_exit(1); } #else return (NULL); #endif } #ifdef safemalloc DEBUG_m(fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n", (unsigned long)(p+1),an++,(long)size)); #endif /* safemalloc */ /* remove from linked list */ #ifdef RCHECK if (*((int*)p) & (sizeof(union overhead) - 1)) fprintf(stderr,"Corrupt malloc ptr 0x%lx at 0x%lx\n", (unsigned long)*((int*)p),(unsigned long)p); #endif nextf[bucket] = p->ov_next; p->ov_magic = MAGIC; p->ov_index= bucket; #ifdef MSTATS nmalloc[bucket]++; #endif #ifdef RCHECK /* * Record allocated size of block and * bound space with magic numbers. */ if (nbytes <= 0x10000) p->ov_size = nbytes - 1; p->ov_rmagic = RMAGIC; *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC; #endif return ((Malloc_t)(p + 1)); } /* * Allocate more memory to the indicated bucket. */ static void morecore(bucket) register int bucket; { register union overhead *op; register int rnu; /* 2^rnu bytes will be requested */ register int nblks; /* become nblks blocks of the desired size */ register MEM_SIZE siz; if (nextf[bucket]) return; /* * Insure memory is allocated * on a page boundary. Should * make getpageize call? */ #ifndef atarist /* on the atari we dont have to worry about this */ op = (union overhead *)sbrk(0); #ifndef I286 if ((int)op & 0x3ff) (void)sbrk(1024 - ((int)op & 0x3ff)); #else /* The sbrk(0) call on the I286 always returns the next segment */ #endif #endif /* atarist */ #if !(defined(I286) || defined(atarist)) /* take 2k unless the block is bigger than that */ rnu = (bucket <= 8) ? 11 : bucket + 3; #else /* take 16k unless the block is bigger than that (80286s like large segments!), probably good on the atari too */ rnu = (bucket <= 11) ? 14 : bucket + 3; #endif nblks = 1 << (rnu - (bucket + 3)); /* how many blocks to get */ if (rnu < bucket) rnu = bucket; op = (union overhead *)sbrk(1L << rnu); /* no more room! */ if ((int)op == -1) return; /* * Round up to minimum allocation size boundary * and deduct from block count to reflect. */ #ifndef I286 if ((int)op & 7) { op = (union overhead *)(((MEM_SIZE)op + 8) &~ 7); nblks--; } #else /* Again, this should always be ok on an 80286 */ #endif /* * Add new memory allocated to that on * free list for this hash bucket. */ nextf[bucket] = op; siz = 1 << (bucket + 3); while (--nblks > 0) { op->ov_next = (union overhead *)((caddr_t)op + siz); op = (union overhead *)((caddr_t)op + siz); } } void free(mp) Malloc_t mp; { register MEM_SIZE size; register union overhead *op; char *cp = (char*)mp; #ifdef safemalloc DEBUG_m(fprintf(stderr,"0x%lx: (%05d) free\n",(unsigned long)cp,an++)); #endif /* safemalloc */ if (cp == NULL) return; op = (union overhead *)((caddr_t)cp - sizeof (union overhead)); #ifdef debug ASSERT(op->ov_magic == MAGIC); /* make sure it was in use */ #else if (op->ov_magic != MAGIC) { #ifdef RCHECK warn("%s free() ignored", op->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad"); #else warn("Bad free() ignored"); #endif return; /* sanity */ } #endif #ifdef RCHECK ASSERT(op->ov_rmagic == RMAGIC); if (op->ov_index <= 13) ASSERT(*(u_int *)((caddr_t)op + op->ov_size + 1 - RSLOP) == RMAGIC); op->ov_rmagic = RMAGIC - 1; #endif ASSERT(op->ov_index < NBUCKETS); size = op->ov_index; op->ov_next = nextf[size]; nextf[size] = op; #ifdef MSTATS nmalloc[size]--; #endif } /* * When a program attempts "storage compaction" as mentioned in the * old malloc man page, it realloc's an already freed block. Usually * this is the last block it freed; occasionally it might be farther * back. We have to search all the free lists for the block in order * to determine its bucket: 1st we make one pass thru the lists * checking only the first block in each; if that fails we search * ``reall_srchlen'' blocks in each list for a match (the variable * is extern so the caller can modify it). If that fails we just copy * however many bytes was given to realloc() and hope it's not huge. */ int reall_srchlen = 4; /* 4 should be plenty, -1 =>'s whole list */ Malloc_t realloc(mp, nbytes) Malloc_t mp; MEM_SIZE nbytes; { register MEM_SIZE onb; union overhead *op; char *res; register int i; int was_alloced = 0; char *cp = (char*)mp; #ifdef safemalloc #ifdef DEBUGGING MEM_SIZE size = nbytes; #endif #ifdef MSDOS if (nbytes > 0xffff) { fprintf(stderr, "Reallocation too large: %lx\n", size); my_exit(1); } #endif /* MSDOS */ if (!cp) return malloc(nbytes); #ifdef DEBUGGING if ((long)nbytes < 0) croak("panic: realloc"); #endif #endif /* safemalloc */ op = (union overhead *)((caddr_t)cp - sizeof (union overhead)); if (op->ov_magic == MAGIC) { was_alloced++; i = op->ov_index; } else { /* * Already free, doing "compaction". * * Search for the old block of memory on the * free list. First, check the most common * case (last element free'd), then (this failing) * the last ``reall_srchlen'' items free'd. * If all lookups fail, then assume the size of * the memory block being realloc'd is the * smallest possible. */ if ((i = findbucket(op, 1)) < 0 && (i = findbucket(op, reall_srchlen)) < 0) i = 0; } onb = (1L << (i + 3)) - sizeof (*op) - RSLOP; /* avoid the copy if same size block */ if (was_alloced && nbytes <= onb && nbytes > (onb >> 1) - sizeof(*op) - RSLOP) { #ifdef RCHECK /* * Record new allocated size of block and * bound space with magic numbers. */ if (op->ov_index <= 13) { /* * Convert amount of memory requested into * closest block size stored in hash buckets * which satisfies request. Account for * space used per block for accounting. */ nbytes += sizeof (union overhead) + RSLOP; nbytes = (nbytes + 3) &~ 3; op->ov_size = nbytes - 1; *((u_int *)((caddr_t)op + nbytes - RSLOP)) = RMAGIC; } #endif res = cp; } else { if ((res = (char*)malloc(nbytes)) == NULL) return (NULL); if (cp != res) /* common optimization */ Copy(cp, res, (MEM_SIZE)(nbytesov_next) { if (p == freep) return (i); j++; } } return (-1); } #ifdef MSTATS /* * mstats - print out statistics about malloc * * Prints two lines of numbers, one showing the length of the free list * for each size category, the second showing the number of mallocs - * frees for each size category. */ void mstats(s) char *s; { register int i, j; register union overhead *p; int totfree = 0, totused = 0; fprintf(stderr, "Memory allocation statistics %s\nfree:\t", s); for (i = 0; i < NBUCKETS; i++) { for (j = 0, p = nextf[i]; p; p = p->ov_next, j++) ; fprintf(stderr, " %d", j); totfree += j * (1 << (i + 3)); } fprintf(stderr, "\nused:\t"); for (i = 0; i < NBUCKETS; i++) { fprintf(stderr, " %d", nmalloc[i]); totused += nmalloc[i] * (1 << (i + 3)); } fprintf(stderr, "\n\tTotal in use: %d, total free: %d\n", totused, totfree); } #endif #endif /* lint */ e from linked list */ #ifdef RCHECK if (*((int*)p) & (sizeof(union overhead) - 1)) fprintfperl5.000/mg.c 664 203 12 55310 5650573260 6227 /* mg.c * * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * "Sam sat on the ground and put his head in his hands. 'I wish I had never * come here, and I don't want to see no more magic,' he said, and fell silent." */ #include "EXTERN.h" #include "perl.h" /* Omit -- it causes too much grief on mixed systems. #ifdef I_UNISTD # include #endif */ void mg_magical(sv) SV* sv; { MAGIC* mg; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; if (vtbl) { if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) SvGMAGICAL_on(sv); if (vtbl->svt_set) SvSMAGICAL_on(sv); if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear) SvRMAGICAL_on(sv); } } } int mg_get(sv) SV* sv; { MAGIC* mg; U32 savemagic = SvMAGICAL(sv) | SvREADONLY(sv); assert(SvGMAGICAL(sv)); SvMAGICAL_off(sv); SvREADONLY_off(sv); SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { (*vtbl->svt_get)(sv, mg); if (mg->mg_flags & MGf_GSKIP) savemagic = 0; } } if (savemagic) SvFLAGS(sv) |= savemagic; else mg_magical(sv); if (SvGMAGICAL(sv)) SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); return 0; } int mg_set(sv) SV* sv; { MAGIC* mg; MAGIC* nextmg; U32 savemagic = SvMAGICAL(sv); SvMAGICAL_off(sv); for (mg = SvMAGIC(sv); mg; mg = nextmg) { MGVTBL* vtbl = mg->mg_virtual; nextmg = mg->mg_moremagic; /* it may delete itself */ if (mg->mg_flags & MGf_GSKIP) { mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ savemagic = 0; } if (vtbl && vtbl->svt_set) (*vtbl->svt_set)(sv, mg); } if (SvMAGIC(sv)) { if (savemagic) SvFLAGS(sv) |= savemagic; else mg_magical(sv); if (SvGMAGICAL(sv)) SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); } return 0; } U32 mg_len(sv) SV* sv; { MAGIC* mg; char *s; STRLEN len; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; if (vtbl && vtbl->svt_len) { U32 savemagic = SvMAGICAL(sv); SvMAGICAL_off(sv); SvFLAGS(sv) |= (SvFLAGS(sv)&(SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; /* omit MGf_GSKIP -- not changed here */ len = (*vtbl->svt_len)(sv, mg); SvFLAGS(sv) |= savemagic; if (SvGMAGICAL(sv)) SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); return len; } } s = SvPV(sv, len); return len; } int mg_clear(sv) SV* sv; { MAGIC* mg; U32 savemagic = SvMAGICAL(sv); SvMAGICAL_off(sv); SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; /* omit GSKIP -- never set here */ if (vtbl && vtbl->svt_clear) (*vtbl->svt_clear)(sv, mg); } SvFLAGS(sv) |= savemagic; if (SvGMAGICAL(sv)) SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); return 0; } MAGIC* mg_find(sv, type) SV* sv; int type; { MAGIC* mg; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { if (mg->mg_type == type) return mg; } return 0; } int mg_copy(sv, nsv, key, klen) SV* sv; SV* nsv; char *key; STRLEN klen; { int count = 0; MAGIC* mg; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { if (isUPPER(mg->mg_type)) { sv_magic(nsv, mg->mg_obj, toLOWER(mg->mg_type), key, klen); count++; } } return count; } int mg_free(sv) SV* sv; { MAGIC* mg; MAGIC* moremagic; for (mg = SvMAGIC(sv); mg; mg = moremagic) { MGVTBL* vtbl = mg->mg_virtual; moremagic = mg->mg_moremagic; if (vtbl && vtbl->svt_free) (*vtbl->svt_free)(sv, mg); if (mg->mg_ptr && mg->mg_type != 'g') Safefree(mg->mg_ptr); if (mg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(mg->mg_obj); Safefree(mg); } SvMAGIC(sv) = 0; return 0; } #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) #include #endif U32 magic_len(sv, mg) SV *sv; MAGIC *mg; { register I32 paren; register char *s; register I32 i; switch (*mg->mg_ptr) { case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': if (curpm) { paren = atoi(mg->mg_ptr); getparen: if (curpm->op_pmregexp && paren <= curpm->op_pmregexp->nparens && (s = curpm->op_pmregexp->startp[paren]) ) { i = curpm->op_pmregexp->endp[paren] - s; if (i >= 0) return i; else return 0; } else return 0; } break; case '+': if (curpm) { paren = curpm->op_pmregexp->lastparen; if (!paren) return 0; goto getparen; } break; case '`': if (curpm) { if (curpm->op_pmregexp && (s = curpm->op_pmregexp->subbeg) ) { i = curpm->op_pmregexp->startp[0] - s; if (i >= 0) return i; else return 0; } else return 0; } break; case '\'': if (curpm) { if (curpm->op_pmregexp && (s = curpm->op_pmregexp->endp[0]) ) { return (STRLEN) (curpm->op_pmregexp->subend - s); } else return 0; } break; case ',': return (STRLEN)ofslen; case '\\': return (STRLEN)orslen; } magic_get(sv,mg); if (!SvPOK(sv) && SvNIOK(sv)) sv_2pv(sv, &na); if (SvPOK(sv)) return SvCUR(sv); return 0; } int magic_get(sv, mg) SV *sv; MAGIC *mg; { register I32 paren; register char *s; register I32 i; switch (*mg->mg_ptr) { case '\004': /* ^D */ sv_setiv(sv,(I32)(debug & 32767)); break; case '\006': /* ^F */ sv_setiv(sv,(I32)maxsysfd); break; case '\010': /* ^H */ sv_setiv(sv,(I32)hints); break; case '\t': /* ^I */ if (inplace) sv_setpv(sv, inplace); else sv_setsv(sv,&sv_undef); break; case '\020': /* ^P */ sv_setiv(sv,(I32)perldb); break; case '\024': /* ^T */ sv_setiv(sv,(I32)basetime); break; case '\027': /* ^W */ sv_setiv(sv,(I32)dowarn); break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': if (curpm) { paren = atoi(GvENAME(mg->mg_obj)); getparen: if (curpm->op_pmregexp && paren <= curpm->op_pmregexp->nparens && (s = curpm->op_pmregexp->startp[paren]) && curpm->op_pmregexp->endp[paren] ) { i = curpm->op_pmregexp->endp[paren] - s; if (i >= 0) sv_setpvn(sv,s,i); else sv_setsv(sv,&sv_undef); } else sv_setsv(sv,&sv_undef); } break; case '+': if (curpm) { paren = curpm->op_pmregexp->lastparen; if (paren) goto getparen; else sv_setsv(sv,&sv_undef); } break; case '`': if (curpm) { if (curpm->op_pmregexp && (s = curpm->op_pmregexp->subbeg) ) { i = curpm->op_pmregexp->startp[0] - s; if (i >= 0) sv_setpvn(sv,s,i); else sv_setpvn(sv,"",0); } else sv_setpvn(sv,"",0); } break; case '\'': if (curpm) { if (curpm->op_pmregexp && (s = curpm->op_pmregexp->endp[0]) ) { sv_setpvn(sv,s, curpm->op_pmregexp->subend - s); } else sv_setpvn(sv,"",0); } break; case '.': #ifndef lint if (GvIO(last_in_gv)) { sv_setiv(sv,(I32)IoLINES(GvIO(last_in_gv))); } #endif break; case '?': sv_setiv(sv,(I32)statusvalue); break; case '^': s = IoTOP_NAME(GvIOp(defoutgv)); if (s) sv_setpv(sv,s); else { sv_setpv(sv,GvENAME(defoutgv)); sv_catpv(sv,"_TOP"); } break; case '~': s = IoFMT_NAME(GvIOp(defoutgv)); if (!s) s = GvENAME(defoutgv); sv_setpv(sv,s); break; #ifndef lint case '=': sv_setiv(sv,(I32)IoPAGE_LEN(GvIOp(defoutgv))); break; case '-': sv_setiv(sv,(I32)IoLINES_LEFT(GvIOp(defoutgv))); break; case '%': sv_setiv(sv,(I32)IoPAGE(GvIOp(defoutgv))); break; #endif case ':': break; case '/': break; case '[': sv_setiv(sv,(I32)curcop->cop_arybase); break; case '|': sv_setiv(sv, (IoFLAGS(GvIOp(defoutgv)) & IOf_FLUSH) != 0 ); break; case ',': sv_setpvn(sv,ofs,ofslen); break; case '\\': sv_setpvn(sv,ors,orslen); break; case '#': sv_setpv(sv,ofmt); break; case '!': sv_setnv(sv,(double)errno); sv_setpv(sv, errno ? Strerror(errno) : ""); SvNOK_on(sv); /* what a wonderful hack! */ break; case '<': sv_setiv(sv,(I32)uid); break; case '>': sv_setiv(sv,(I32)euid); break; case '(': s = buf; (void)sprintf(s,"%d",(int)gid); goto add_groups; case ')': s = buf; (void)sprintf(s,"%d",(int)egid); add_groups: while (*s) s++; #ifdef HAS_GETGROUPS #ifndef NGROUPS #define NGROUPS 32 #endif { Groups_t gary[NGROUPS]; i = getgroups(NGROUPS,gary); while (--i >= 0) { (void)sprintf(s," %ld", (long)gary[i]); while (*s) s++; } } #endif sv_setpv(sv,buf); break; case '*': break; case '0': break; } return 0; } int magic_getuvar(sv, mg) SV *sv; MAGIC *mg; { struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr; if (uf && uf->uf_val) (*uf->uf_val)(uf->uf_index, sv); return 0; } int magic_setenv(sv,mg) SV* sv; MAGIC* mg; { register char *s; STRLEN len; I32 i; s = SvPV(sv,len); my_setenv(mg->mg_ptr,s); #ifdef DYNAMIC_ENV_FETCH /* We just undefd an environment var. Is a replacement */ /* waiting in the wings? */ if (!len) { SV **envsvp; if (envsvp = hv_fetch(GvHVn(envgv),mg->mg_ptr,mg->mg_len,FALSE)) s = SvPV(*envsvp,len); } #endif /* And you'll never guess what the dog had */ /* in its mouth... */ if (tainting) { if (s && strEQ(mg->mg_ptr,"PATH")) { char *strend = s + len; while (s < strend) { s = cpytill(tokenbuf,s,strend,':',&i); s++; if (*tokenbuf != '/' || (Stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) ) MgTAINTEDDIR_on(mg); } } } return 0; } int magic_clearenv(sv,mg) SV* sv; MAGIC* mg; { my_setenv(mg->mg_ptr,Nullch); return 0; } int magic_setsig(sv,mg) SV* sv; MAGIC* mg; { register char *s; I32 i; i = whichsig(mg->mg_ptr); /* ...no, a brick */ if (!i && (dowarn || strEQ(mg->mg_ptr,"ALARM"))) warn("No such signal: SIG%s", mg->mg_ptr); if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) { (void)signal(i,sighandler); return 0; } s = SvPV_force(sv,na); if (strEQ(s,"IGNORE")) #ifndef lint (void)signal(i,SIG_IGN); #else ; #endif else if (strEQ(s,"DEFAULT") || !*s) (void)signal(i,SIG_DFL); else { (void)signal(i,sighandler); if (!strchr(s,':') && !strchr(s,'\'')) { sprintf(tokenbuf, "main::%s",s); sv_setpv(sv,tokenbuf); } } return 0; } int magic_setisa(sv,mg) SV* sv; MAGIC* mg; { sub_generation++; return 0; } #ifdef OVERLOAD int magic_setamagic(sv,mg) SV* sv; MAGIC* mg; { /* HV_badAMAGIC_on(Sv_STASH(sv)); */ amagic_generation++; return 0; } #endif /* OVERLOAD */ static int magic_methpack(sv,mg,meth) SV* sv; MAGIC* mg; char *meth; { dSP; ENTER; SAVETMPS; PUSHMARK(sp); EXTEND(sp, 2); PUSHs(mg->mg_obj); if (mg->mg_ptr) PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len))); else if (mg->mg_type == 'p') PUSHs(sv_2mortal(newSViv(mg->mg_len))); PUTBACK; if (perl_call_method(meth, G_SCALAR)) sv_setsv(sv, *stack_sp--); FREETMPS; LEAVE; return 0; } int magic_getpack(sv,mg) SV* sv; MAGIC* mg; { magic_methpack(sv,mg,"FETCH"); if (mg->mg_ptr) mg->mg_flags |= MGf_GSKIP; return 0; } int magic_setpack(sv,mg) SV* sv; MAGIC* mg; { dSP; PUSHMARK(sp); EXTEND(sp, 3); PUSHs(mg->mg_obj); if (mg->mg_ptr) PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len))); else if (mg->mg_type == 'p') PUSHs(sv_2mortal(newSViv(mg->mg_len))); PUSHs(sv); PUTBACK; perl_call_method("STORE", G_SCALAR|G_DISCARD); return 0; } int magic_clearpack(sv,mg) SV* sv; MAGIC* mg; { return magic_methpack(sv,mg,"DELETE"); } int magic_wipepack(sv,mg) SV* sv; MAGIC* mg; { dSP; PUSHMARK(sp); XPUSHs(mg->mg_obj); PUTBACK; perl_call_method("CLEAR", G_SCALAR|G_DISCARD); return 0; } int magic_nextpack(sv,mg,key) SV* sv; MAGIC* mg; SV* key; { dSP; char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY"; ENTER; SAVETMPS; PUSHMARK(sp); EXTEND(sp, 2); PUSHs(mg->mg_obj); if (SvOK(key)) PUSHs(key); PUTBACK; if (perl_call_method(meth, G_SCALAR)) sv_setsv(key, *stack_sp--); FREETMPS; LEAVE; return 0; } int magic_existspack(sv,mg) SV* sv; MAGIC* mg; { return magic_methpack(sv,mg,"EXISTS"); } int magic_setdbline(sv,mg) SV* sv; MAGIC* mg; { OP *o; I32 i; GV* gv; SV** svp; gv = DBline; i = SvTRUE(sv); svp = av_fetch(GvAV(gv),atoi(mg->mg_ptr), FALSE); if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp))) o->op_private = i; else warn("Can't break at that line\n"); return 0; } int magic_getarylen(sv,mg) SV* sv; MAGIC* mg; { sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + curcop->cop_arybase); return 0; } int magic_setarylen(sv,mg) SV* sv; MAGIC* mg; { av_fill((AV*)mg->mg_obj, SvIV(sv) - curcop->cop_arybase); return 0; } int magic_getpos(sv,mg) SV* sv; MAGIC* mg; { SV* lsv = LvTARG(sv); if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) { mg = mg_find(lsv, 'g'); if (mg && mg->mg_len >= 0) { sv_setiv(sv, mg->mg_len + curcop->cop_arybase); return 0; } } (void)SvOK_off(sv); return 0; } int magic_setpos(sv,mg) SV* sv; MAGIC* mg; { SV* lsv = LvTARG(sv); SSize_t pos; STRLEN len; mg = 0; if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) mg = mg_find(lsv, 'g'); if (!mg) { if (!SvOK(sv)) return 0; sv_magic(lsv, (SV*)0, 'g', Nullch, 0); mg = mg_find(lsv, 'g'); } else if (!SvOK(sv)) { mg->mg_len = -1; return 0; } len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv); pos = SvIV(sv) - curcop->cop_arybase; if (pos < 0) { pos += len; if (pos < 0) pos = 0; } else if (pos > len) pos = len; mg->mg_len = pos; return 0; } int magic_getglob(sv,mg) SV* sv; MAGIC* mg; { gv_efullname(sv,((GV*)sv));/* a gv value, be nice */ return 0; } int magic_setglob(sv,mg) SV* sv; MAGIC* mg; { register char *s; GV* gv; if (!SvOK(sv)) return 0; s = SvPV(sv, na); if (*s == '*' && s[1]) s++; gv = gv_fetchpv(s,TRUE, SVt_PVGV); if (sv == (SV*)gv) return 0; if (GvGP(sv)) gp_free(sv); GvGP(sv) = gp_ref(GvGP(gv)); if (!GvAV(gv)) gv_AVadd(gv); if (!GvHV(gv)) gv_HVadd(gv); if (!GvIOp(gv)) GvIOp(gv) = newIO(); return 0; } int magic_setsubstr(sv,mg) SV* sv; MAGIC* mg; { STRLEN len; char *tmps = SvPV(sv,len); sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len); return 0; } int magic_gettaint(sv,mg) SV* sv; MAGIC* mg; { tainted = TRUE; return 0; } int magic_settaint(sv,mg) SV* sv; MAGIC* mg; { if (!tainted) { if (!SvMAGICAL(sv)) SvMAGICAL_on(sv); sv_unmagic(sv, 't'); } return 0; } int magic_setvec(sv,mg) SV* sv; MAGIC* mg; { do_vecset(sv); /* XXX slurp this routine */ return 0; } int magic_setmglob(sv,mg) SV* sv; MAGIC* mg; { mg->mg_len = -1; return 0; } int magic_setbm(sv,mg) SV* sv; MAGIC* mg; { sv_unmagic(sv, 'B'); SvVALID_off(sv); return 0; } int magic_setuvar(sv,mg) SV* sv; MAGIC* mg; { struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr; if (uf && uf->uf_set) (*uf->uf_set)(uf->uf_index, sv); return 0; } int magic_set(sv,mg) SV* sv; MAGIC* mg; { register char *s; I32 i; STRLEN len; switch (*mg->mg_ptr) { case '\004': /* ^D */ debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000; DEBUG_x(dump_all()); break; case '\006': /* ^F */ maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); break; case '\010': /* ^H */ hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); break; case '\t': /* ^I */ if (inplace) Safefree(inplace); if (SvOK(sv)) inplace = savepv(SvPV(sv,na)); else inplace = Nullch; break; case '\020': /* ^P */ i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); if (i != perldb) { if (perldb) oldlastpm = curpm; else curpm = oldlastpm; } perldb = i; break; case '\024': /* ^T */ basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); break; case '\027': /* ^W */ dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); break; case '.': if (localizing) save_sptr((SV**)&last_in_gv); else if (SvOK(sv)) IoLINES(GvIOp(last_in_gv)) = (long)SvIV(sv); break; case '^': Safefree(IoTOP_NAME(GvIOp(defoutgv))); IoTOP_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na)); IoTOP_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO); break; case '~': Safefree(IoFMT_NAME(GvIOp(defoutgv))); IoFMT_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na)); IoFMT_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO); break; case '=': IoPAGE_LEN(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); break; case '-': IoLINES_LEFT(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); if (IoLINES_LEFT(GvIOp(defoutgv)) < 0L) IoLINES_LEFT(GvIOp(defoutgv)) = 0L; break; case '%': IoPAGE(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); break; case '|': IoFLAGS(GvIOp(defoutgv)) &= ~IOf_FLUSH; if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) != 0) { IoFLAGS(GvIOp(defoutgv)) |= IOf_FLUSH; } break; case '*': i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); multiline = (i != 0); break; case '/': if (SvOK(sv)) { nrs = rs = SvPV_force(sv,rslen); nrslen = rslen; if (rspara = !rslen) { nrs = rs = "\n\n"; nrslen = rslen = 2; } nrschar = rschar = rs[rslen - 1]; } else { nrschar = rschar = 0777; /* fake a non-existent char */ nrslen = rslen = 1; } break; case '\\': if (ors) Safefree(ors); ors = savepv(SvPV(sv,orslen)); break; case ',': if (ofs) Safefree(ofs); ofs = savepv(SvPV(sv, ofslen)); break; case '#': if (ofmt) Safefree(ofmt); ofmt = savepv(SvPV(sv,na)); break; case '[': compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); break; case '?': statusvalue = U_S(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); break; case '!': errno = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); /* will anyone ever use this? */ break; case '<': uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); if (delaymagic) { delaymagic |= DM_RUID; break; /* don't do magic till later */ } #ifdef HAS_SETRUID (void)setruid((Uid_t)uid); #else #ifdef HAS_SETREUID (void)setreuid((Uid_t)uid, (Uid_t)-1); #ifdef HAS_SETRESUID (void)setresuid((Uid_t)uid, (Uid_t)-1, (Uid_t)-1); #else if (uid == euid) /* special case $< = $> */ (void)setuid(uid); else { uid = (I32)getuid(); croak("setruid() not implemented"); } #endif #endif #endif uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); tainting |= (euid != uid || egid != gid); break; case '>': euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); if (delaymagic) { delaymagic |= DM_EUID; break; /* don't do magic till later */ } #ifdef HAS_SETEUID (void)seteuid((Uid_t)euid); #else #ifdef HAS_SETREUID (void)setreuid((Uid_t)-1, (Uid_t)euid); #else #ifdef HAS_SETRESUID (void)setresuid((Uid_t)-1, (Uid_t)euid, (Uid_t)-1); #else if (euid == uid) /* special case $> = $< */ setuid(euid); else { euid = (I32)geteuid(); croak("seteuid() not implemented"); } #endif #endif #endif euid = (I32)geteuid(); tainting |= (euid != uid || egid != gid); break; case '(': gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); if (delaymagic) { delaymagic |= DM_RGID; break; /* don't do magic till later */ } #ifdef HAS_SETRGID (void)setrgid((Gid_t)gid); #else #ifdef HAS_SETREGID (void)setregid((Gid_t)gid, (Gid_t)-1); #else #ifdef HAS_SETRESGID (void)setresgid((Gid_t)gid, (Gid_t)-1, (Gid_t) 1); #else if (gid == egid) /* special case $( = $) */ (void)setgid(gid); else croak("setrgid() not implemented"); #endif #endif #endif gid = (I32)getgid(); tainting |= (euid != uid || egid != gid); break; case ')': egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); if (delaymagic) { delaymagic |= DM_EGID; break; /* don't do magic till later */ } #ifdef HAS_SETEGID (void)setegid((Gid_t)egid); #else #ifdef HAS_SETREGID (void)setregid((Gid_t)-1, (Gid_t)egid); #else #ifdef HAS_SETRESGID (void)setresgid((Gid_t)-1, (Gid_t)egid, (Gid_t)-1); #else if (egid == gid) /* special case $) = $( */ (void)setgid(egid); else croak("setegid() not implemented"); #endif #endif #endif egid = (I32)getegid(); tainting |= (euid != uid || egid != gid); break; case ':': chopset = SvPV_force(sv,na); break; case '0': if (!origalen) { s = origargv[0]; s += strlen(s); /* See if all the arguments are contiguous in memory */ for (i = 1; i < origargc; i++) { if (origargv[i] == s + 1) s += strlen(++s); /* this one is ok too */ } if (origenviron[0] == s + 1) { /* can grab env area too? */ my_setenv("NoNeSuCh", Nullch); /* force copy of environment */ for (i = 0; origenviron[i]; i++) if (origenviron[i] == s + 1) s += strlen(++s); } origalen = s - origargv[0]; } s = SvPV_force(sv,len); i = len; if (i >= origalen) { i = origalen; SvCUR_set(sv, i); *SvEND(sv) = '\0'; Copy(s, origargv[0], i, char); } else { Copy(s, origargv[0], i, char); s = origargv[0]+i; *s++ = '\0'; while (++i < origalen) *s++ = ' '; s = origargv[0]+i; for (i = 1; i < origargc; i++) origargv[i] = Nullch; } break; } return 0; } I32 whichsig(sig) char *sig; { register char **sigv; for (sigv = sig_name+1; *sigv; sigv++) if (strEQ(sig,*sigv)) return sigv - sig_name; #ifdef SIGCLD if (strEQ(sig,"CHLD")) return SIGCLD; #endif #ifdef SIGCHLD if (strEQ(sig,"CLD")) return SIGCHLD; #endif return 0; } VOIDRET sighandler(sig) int sig; { dSP; GV *gv; HV *st; SV *sv; CV *cv; AV *oldstack; #ifdef OS2 /* or anybody else who requires SIG_ACK */ signal(sig, SIG_ACK); #endif cv = sv_2cv(*hv_fetch(GvHVn(siggv),sig_name[sig],strlen(sig_name[sig]), TRUE), &st, &gv, TRUE); if (!cv || !CvROOT(cv) && *sig_name[sig] == 'C' && instr(sig_name[sig],"LD")) { if (sig_name[sig][1] == 'H') cv = sv_2cv(*hv_fetch(GvHVn(siggv),"CLD",3,TRUE), &st, &gv, TRUE); else cv = sv_2cv(*hv_fetch(GvHVn(siggv),"CHLD",4,TRUE), &st, &gv, TRUE); /* gag */ } if (!cv || !CvROOT(cv)) { if (dowarn) warn("SIG%s handler \"%s\" not defined.\n", sig_name[sig], GvENAME(gv) ); return; } oldstack = stack; if (stack != signalstack) AvFILL(signalstack) = 0; SWITCHSTACK(stack, signalstack); sv = sv_newmortal(); sv_setpv(sv,sig_name[sig]); PUSHMARK(sp); PUSHs(sv); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); SWITCHSTACK(signalstack, oldstack); return; } return 0; } int magic_settaint(sv,mg) SV* sv; MAGIC* mg; { if (!tainted) { if (!SvMAGICAL(sv)) SvMAGICAL_on(sv); sv_unmagic(sv, 't'); } return 0; } int magic_setvec(sv,mg) SV* sv; MAGIC* mg; { do_vecset(sv); /* XXX slurp this routine */ return 0; } int magic_setmglob(sv,mg) SV* svperl5.000/pod/ 775 203 12 0 5650575734 6141 perl5.000/pod/Makefile 664 203 12 2735 5650567043 7667 all: man POD = \ perl.pod \ perlapi.pod \ perlbook.pod \ perlbot.pod \ perlcall.pod \ perldata.pod \ perldebug.pod \ perldiag.pod \ perlembed.pod \ perlform.pod \ perlfunc.pod \ perlguts.pod \ perlipc.pod \ perlmod.pod \ perlobj.pod \ perlop.pod \ perlovl.pod \ perlpod.pod \ perlre.pod \ perlref.pod \ perlrun.pod \ perlsec.pod \ perlstyle.pod \ perlsub.pod \ perlsyn.pod \ perltrap.pod \ perlvar.pod MAN = \ perl.man \ perlapi.man \ perlbook.man \ perlbot.man \ perlcall.man \ perldata.man \ perldebug.man \ perldiag.man \ perlembed.man \ perlform.man \ perlfunc.man \ perlguts.man \ perlipc.man \ perlmod.man \ perlobj.man \ perlop.man \ perlovl.man \ perlpod.man \ perlre.man \ perlref.man \ perlrun.man \ perlsec.man \ perlstyle.man \ perlsub.man \ perlsyn.man \ perltrap.man \ perlvar.man HTML = \ perl.html \ perlapi.html \ perlbook.html \ perlbot.html \ perlcall.html \ perldata.html \ perldebug.html \ perldiag.html \ perlembed.html \ perlform.html \ perlfunc.html \ perlguts.html \ perlipc.html \ perlmod.html \ perlobj.html \ perlop.html \ perlovl.html \ perlpod.html \ perlre.html \ perlref.html \ perlrun.html \ perlsec.html \ perlstyle.html \ perlsub.html \ perlsyn.html \ perltrap.html \ perlvar.html man: $(MAN) html: $(HTML) .SUFFIXES: .pod .man .pod.man: ../miniperl pod2man $*.pod >$*.man .SUFFIXES: .pod .html .pod.html: ../miniperl pod2html $*.pod >$*.html clean: rm -f $(MAN) $(HTML) argv[0]; } s = SvPV_force(sv,len)perl5.000/pod/modpods/ 775 203 12 0 5650575727 7610 perl5.000/pod/modpods/Abbrev.pod 664 203 12 565 5650406014 11546 =head1 NAME abbrev - create an abbreviation table from a list =head1 SYNOPSIS use Abbrev; abbrev *HASH, LIST =head1 DESCRIPTION Stores all unambiguous truncations of each element of LIST as keys key in the associative array indicated by C<*hash>. The values are the original list elements. =head1 EXAMPLE abbrev(*hash,qw("list edit send abort gripe")); ¾^ English.podX¾|Env.podp¾} Exporter.poddl„¾~ Fcntl.poddœ¾FileHandle.podÜ°¾€Find.podperl5.000/pod/modpods/AnyDBMFile.pod 664 203 12 4157 5650406015 12241 =head1 NAME AnyDBM_File - provide framework for multiple DBMs NDBM_File, ODBM_File, SDBM_File, GDBM_File - various DBM implementations =head1 SYNOPSIS use AnyDBM_File; =head1 DESCRIPTION This module is a "pure virtual base class"--it has nothing of us its own. It's just there to inherit from one of the various DBM packages. It prefers ndbm for compatibility reasons with Perl 4, then Berkeley DB (See L), GDBM, SDBM (which is always there -- it comes with Perl), and finally ODBM. This way old programs that used to use NDBM via dbmopen() can still do so, but new ones can reorder @ISA: @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File); This makes it trivial to copy database formats: use POSIX; use NDBM_File; use DB_File; tie %newhash, DB_File, $new_filename, O_CREAT|O_RDWR; tie %oldhash, NDBM_File, $old_filename, 1, 0; %newhash = %oldhash; =head2 DBM Comparisons Here's a partial table of features the different packages offer: odbm ndbm sdbm gdbm bsd-db ---- ---- ---- ---- ------ Linkage comes w/ perl yes yes yes yes yes Src comes w/ perl no no yes no no Comes w/ many unix os yes yes[0] no no no Builds ok on !unix ? ? yes yes ? Code Size ? ? small big big Database Size ? ? small big? ok[1] Speed ? ? slow ok fast FTPable no no yes yes yes Easy to build N/A N/A yes yes ok[2] Size limits 1k 4k 1k[3] none none Byte-order independent no no no no yes Licensing restrictions ? ? no yes no =over 4 =item [0] on mixed universe machines, may be in the bsd compat library, which is often shunned. =item [1] Can be trimmed if you compile for one access method. =item [2] See L. Requires symbolic links. =item [3] By default, but can be redefined. =back =head1 SEE ALSO dbm(3), ndbm(3), DB_File(3) (strEQ(sig,"CLD")) return SIGCHLD; #endif return 0; } VOIDRET sighandler(sig) int sig; { dSP; GV *gv; HV *st; SV *sv; CV *cv; AV *oldstack; #ifdef OS2 /* or anybody else who requires SIG_ACK */ signal(sig, SIG_ACK); #endif cv = sv_2cv(*hv_fetch(GvHVn(siggv),sig_name[sig],strlen(sig_name[sig]), TRUE), &st, &gv, TRUE); if (!cv || !CvROOT(cv) && *sperl5.000/pod/modpods/AutoLoader.pod 664 203 12 515 5650406015 12400 =head1 NAME AutoLoader - load functions only on demand =head1 SYNOPSIS package FOOBAR; use Exporter; use AutoLoader; @ISA = (Exporter, AutoLoader); =head1 DESCRIPTION This module tells its users that functions in the FOOBAR package are to be autoloaded from F. See L. ¾} Exporter.podod„¾~ Fcntl.pododœ¾FileHandle.pod.°¾€Find.pode.pȾ Finddepth.podpoྂGetOptions.podp¾ƒ Getopt.podpperl5.000/pod/modpods/AutoSplit.pod 664 203 12 504 5650406015 12263 =head1 NAME AutoSplit - split a package for autoloading =head1 DESCRIPTION This function will split up your program into files that the AutoLoader module can handle. Normally only used to build autoloading Perl library modules, especially extensions (like POSIX). You should look at how they're built out for details. od„¾~ Fcntl.pododœ¾FileHandle.podd°¾€Find.pode.pȾ Finddepth.pod.pྂGetOptions.podo¾ƒ Getopt.podp¾„ MakeMaker.podpperl5.000/pod/modpods/Basename.pod 664 203 12 7163 5650406016 12103 =head1 NAME Basename - parse file specifications fileparse - split a pathname into pieces basename - extract just the filename from a path dirname - extract just the directory from a path =head1 SYNOPSIS use File::Basename; ($name,$path,$suffix) = fileparse($fullname,@suffixlist) fileparse_set_fstype($os_string); $basename = basename($fullname,@suffixlist); $dirname = dirname($fullname); ($name,$path,$suffix) = fileparse("lib/File/Basename.pm",".pm"); fileparse_set_fstype("VMS"); $basename = basename("lib/File/Basename.pm",".pm"); $dirname = dirname("lib/File/Basename.pm"); =head1 DESCRIPTION These routines allow you to parse file specifications into useful pieces according using the syntax of different operating systems. =over 4 =item fileparse_set_fstype You select the syntax via the routine fileparse_set_fstype(). If the argument passed to it contains one of the substrings "VMS", "MSDOS", or "MacOS", the file specification syntax of that operating system is used in future calls to fileparse(), basename(), and dirname(). If it contains none of these substrings, UNIX syntax is used. This pattern matching is case-insensitive. If you've selected VMS syntax, and the file specification you pass to one of these routines contains a "/", they assume you are using UNIX emulation and apply the UNIX syntax rules instead, for that function call only. If you haven't called fileparse_set_fstype(), the syntax is chosen by examining the "osname" entry from the C package according to these rules. =item fileparse The fileparse() routine divides a file specification into three parts: a leading B, a file B, and a B. The B contains everything up to and including the last directory separator in the input file specification. The remainder of the input file specification is then divided into B and B based on the optional patterns you specify in C<@suffixlist>. Each element of this list is interpreted as a regular expression, and is matched against the end of B. If this succeeds, the matching portion of B is removed and prepended to B. By proper use of C<@suffixlist>, you can remove file types or versions for examination. You are guaranteed that if you concatenate B, B, and B together in that order, the result will be identical to the input file specification. =back =head1 EXAMPLES Using UNIX file syntax: ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7', '\.book\d+'); would yield $base eq 'draft' $path eq '/virgil/aeneid', $tail eq '.book7' Similarly, using VMS syntax: ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh', '\..*'); would yield $name eq 'Rhetoric' $dir eq 'Doc_Root:[Help]' $type eq '.Rnh' =item C The basename() routine returns the first element of the list produced by calling fileparse() with the same arguments. It is provided for compatibility with the UNIX shell command basename(1). =item C The dirname() routine returns the directory portion of the input file specification. When using VMS or MacOS syntax, this is identical to the second element of the list produced by calling fileparse() with the same input file specification. When using UNIX or MSDOS syntax, the return value conforms to the behavior of the UNIX shell command dirname(1). This is usually the same as the behavior of fileparse(), but differs in some cases. For example, for the input file specification F, fileparse() considers the directory name to be F, while dirname() considers the directory name to be F<.>). head1 DESCRIPTION These routines allow you to parse file specifications into useful pieces according using the syntax of different operating systems. =over 4 =item fileparse_set_fstype You select the syntax via the routine fileparse_set_fstype(). If the argument passed to it contains one of the substrings "VMS", "MSDOS", or "MacOS", the file specification syntax of that operating system is perl5.000/pod/modpods/Benchmark.pod 664 203 12 6304 5650550132 12255 =head1 NAME Benchmark - benchmark running times of code timethis - run a chunk of code several times timethese - run several chunks of code several times timeit - run a chunk of code and see how long it goes =head1 SYNOPSYS timethis ($count, "code"); timethese($count, { 'Name1' => '...code1...', 'Name2' => '...code2...', }); $t = timeit($count, '...other code...') print "$count loops of other code took:",timestr($t),"\n"; =head1 DESCRIPTION The Benchmark module encapsulates a number of routines to help you figure out how long it takes to execute some code. =head2 Methods =over 10 =item new Returns the current time. Example: use Benchmark; $t0 = new Benchmark; # ... your code here ... $t1 = new Benchmark; $td = timediff($t1, $t0); print "the code took:",timestr($dt),"\n"; =item debug Enables or disable debugging by setting the C<$Benchmark::Debug> flag: debug Benchmark 1; $t = timeit(10, ' 5 ** $Global '); debug Benchmark 0; =back =head2 Standard Exports The following routines will be exported into your namespace if you use the Benchmark module: =over 10 =item timeit(COUNT, CODE) Arguments: COUNT is the number of time to run the loop, and the second is the code to run. CODE may be a string containing the code, a reference to the function to run, or a reference to a hash containing keys which are names and values which are more CODE specs. Side-effects: prints out noise to standard out. Returns: a Benchmark object. =item timethis =item timethese =item timediff =item timestr =back =head2 Optional Exports The following routines will be exported into your namespace if you specifically ask that they be imported: =over 10 clearcache clearallcache disablecache enablecache =back =head1 NOTES The data is stored as a list of values from the time and times functions: ($real, $user, $system, $children_user, $children_system) in seconds for the whole loop (not divided by the number of rounds). The timing is done using time(3) and times(3). Code is executed in the caller's package. Enable debugging by: $Benchmark::debug = 1; The time of the null loop (a loop with the same number of rounds but empty loop body) is subtracted from the time of the real loop. The null loop times are cached, the key being the number of rounds. The caching can be controlled using calls like these: clearcache($key); clearallcache(); disablecache(); enablecache(); =head1 INHERITANCE Benchmark inherits from no other class, except of course for Exporter. =head1 CAVEATS The real time timing is done using time(2) and the granularity is therefore only one second. Short tests may produce negative figures because perl can appear to take longer to execute the empty loop than a short test; try: timethis(100,'1'); The system time of the null loop might be slightly more than the system time of the loop with the actual code and therefore the difference might end up being < 0. More documentation is needed :-( especially for styles and formats. =head1 AUTHORS Jarkko Hietaniemi , Tim Bunce =head1 MODIFICATION HISTORY September 8th, 1994; by Tim Bunce. ; } return 0; } int magic_settaint(sv,mg) SV* sv; MAGIC* mg; { if (!tainted) { if (!SvMAGICAL(sv)) SvMAGICAL_on(sv); sv_unmagic(sv, 't'); } return 0; } int magic_setvec(sv,mg) SV* sv; MAGIC* mg; { do_vecset(sv); /* XXX slurp this routine */ return 0; } int magic_setmglob(sv,mg) SV* svperl5.000/pod/modpods/Carp.pod 664 203 12 1067 5650550132 11251 =head1 NAME carp - warn of errors (from perspective of caller) croak - die of errors (from perspective of caller) confess - die of errors with stack backtrace =head1 SYNOPSIS use Carp; croak "We're outta here!"; =head1 DESCRIPTION The Carp routines are useful in your own modules because they act like die() or warn(), but report where the error was in the code they were called from. Thus if you have a routine Foo() that has a carp() in it, then the carp() will report the error as occurring where Foo() was called, not where carp() was called. .pod¤¾‹less.poder.¸¾Œ sigtrap.pod̾ strict.pod.¾Žsubs.podt.p: use Benchmark; $t0 = new Benchmark; # ... your code here ... $t1 = new Benchmark; $td = timediff($t1, $t0); print "the code took:",timestr($dt),"\n"; =item debug Enables or disable debugging by setting the C<$Benchmark::Debug> flag: debug Benchmark 1; $t = timeit(10, ' 5 ** $Global '); debug Benchmark 0; =backperl5.000/pod/modpods/CheckTree.pod 664 203 12 2417 5650550133 12222 =head1 NAME validate - run many filetest checks on a tree =head1 SYNOPSIS use File::CheckTree; $warnings += validate( q{ /vmunix -e || die /boot -e || die /bin cd csh -ex csh !-ug sh -ex sh !-ug /usr -d || warn "What happened to $file?\n" }); =head1 DESCRIPTION The validate() routine takes a single multiline string consisting of lines containing a filename plus a file test to try on it. (The file test may also be a "cd", causing subsequent relative filenames to be interpreted relative to that directory.) After the file test you may put C<|| die> to make it a fatal error if the file test fails. The default is C<|| warn>. The file test may optionally have a "!' prepended to test for the opposite condition. If you do a cd and then list some relative filenames, you may want to indent them slightly for readability. If you supply your own die() or warn() message, you can use $file to interpolate the filename. Filetests may be bunched: "-rwx" tests for all of C<-r>, C<-w>, and C<-x>. Only the first failed test of the bunch will produce a warning. The routine returns the number of warnings issued. !-ug sh -ex sh !-ug /usr -d || warn "What happened to $file?\n" }); =head1 DESCRIPTION The validate() routine takes a single multiline string consisting of lperl5.000/pod/modpods/Collate.pod 664 203 12 2070 5650406017 11744 =head1 NAME Collate - compare 8-bit scalar data according to the current locale =head1 SYNOPSIS use Collate; setlocale(LC_COLLATE, 'locale-of-your-choice'); $s1 = new Collate "scalar_data_1"; $s2 = new Collate "scalar_data_2"; =head1 DESCRIPTION This module provides you with objects that will collate according to your national character set, providing the POSIX setlocale() function should be supported on your system. You can compare $s1 and $s2 above with $s1 le $s2 to extract the data itself, you'll need a dereference: $$s1 This uses POSIX::setlocale The basic collation conversion is done by strxfrm() which terminates at NUL characters being a decent C routine. collate_xfrm() handles embedded NUL characters gracefully. Due to C and overload magic, C, C, C, C, and C work also. The available locales depend on your operating system; try whether C shows them or the more direct approach C or C. The locale names are probably something like "xx_XX.(ISO)?8859-N". e exported into your namespace if you use the Benchmark module: =over 10 =item timeit(COUNT, CODE) Arguments: COUNT is the number of time to run the loop, and the second is the code to run. CODE may be a string containing the code, a reference to the function to run, or a reference to a hash containing keys which are names and values which are more CODE specs. Side-effects: prints out noise to standard out. Returns: a Benchmark object. =iteperl5.000/pod/modpods/Config.pod 664 203 12 1535 5650406017 11573 =head1 NAME Config - access Perl configuration option =head1 SYNOPSIS use Config; if ($Config{'cc'} =~ /gcc/) { print "built by gcc\n"; } =head1 DESCRIPTION The Config module contains everything that was available to the C program at Perl build time. Shell variables from F are stored in the readonly-variable C<%Config>, indexed by their names. =head1 EXAMPLE Here's a more sophisticated example of using %Config: use Config; defined $Config{sig_name} || die "No sigs?"; foreach $name (split(' ', $Config{sig_name})) { $signo{$name} = $i; $signame[$i] = $name; $i++; } print "signal #17 = $signame[17]\n"; if ($signo{ALRM}) { print "SIGALRM is $signo{ALRM}\n"; } =head1 NOTE This module contains a good example of how to make a variable readonly to those outside of it. locales depend on your operating system; try whether C shows them or the more direct approach C or C. The locale perl5.000/pod/modpods/Cwd.pod 664 203 12 1247 5650406020 11075 =head1 NAME getcwd - get pathname of current working directory =head1 SYNOPSIS require Cwd; $dir = Cwd::getcwd()' use Cwd; $dir = getcwd()' use Cwd 'chdir'; chdir "/tmp"; print $ENV{'PWD'}; =head1 DESCRIPTION The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions in Perl. If you ask to override your chdir() built-in function, then your PWD environment variable will be kept up to date. (See L.) The fastgetcwd() function looks the same as getcwd(), but runs faster. It's also more dangerous because you might conceivably chdir() out of a directory that you can't chdir() back into. if ($signo{ALRM}) { print "SIGALRM is $signo{ALRM}\n"; } =head1 NOTE This module contains a good example of how to make a variable readonly to those outside of it. locales depend on your operating system; try whether C shows them or the more direct approach C or C. The locale perl5.000/pod/modpods/DB_File.pod 664 203 12 21275 5650406020 11627 =head1 NAME DB_File - Perl5 access to Berkeley DB =head1 SYNOPSIS use DB_File ; [$X =] tie %hash, DB_File, $filename [, $flags, $mode, $DB_HASH] ; [$X =] tie %hash, DB_File, $filename, $flags, $mode, $DB_BTREE ; [$X =] tie @array, DB_File, $filename, $flags, $mode, $DB_RECNO ; $status = $X->del($key [, $flags]) ; $status = $X->put($key, $value [, $flags]) ; $status = $X->get($key, $value [, $flags]) ; $status = $X->seq($key, $value [, $flags]) ; $status = $X->sync([$flags]) ; $status = $X->fd ; untie %hash ; untie @array ; =head1 DESCRIPTION B is a module which allows Perl programs to make use of the facilities provided by Berkeley DB. If you intend to use this module you should really have a copy of the Berkeley DB manual page at hand. The interface defined here mirrors the Berkeley DB interface closely. Berkeley DB is a C library which provides a consistent interface to a number of database formats. B provides an interface to all three of the database types currently supported by Berkeley DB. The file types are: =over 5 =item DB_HASH This database type allows arbitrary key/data pairs to be stored in data files. This is equivalent to the functionality provided by other hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though, the files created using DB_HASH are not compatible with any of the other packages mentioned. A default hashing algorithm, which will be adequate for most applications, is built into Berkeley DB. If you do need to use your own hashing algorithm it is possible to write your own in Perl and have B use it instead. =item DB_BTREE The btree format allows arbitrary key/data pairs to be stored in a sorted, balanced binary tree. As with the DB_HASH format, it is possible to provide a user defined Perl routine to perform the comparison of keys. By default, though, the keys are stored in lexical order. =item DB_RECNO DB_RECNO allows both fixed-length and variable-length flat text files to be manipulated using the same key/value pair interface as in DB_HASH and DB_BTREE. In this case the key will consist of a record (line) number. =back =head2 How does DB_File interface to Berkeley DB? B allows access to Berkeley DB files using the tie() mechanism in Perl 5 (for full details, see L). This facility allows B to access Berkeley DB files using either an associative array (for DB_HASH & DB_BTREE file types) or an ordinary array (for the DB_RECNO file type). In addition to the tie() interface, it is also possible to use most of the functions provided in the Berkeley DB API. =head2 Differences with Berkeley DB Berkeley DB uses the function dbopen() to open or create a database. Below is the C prototype for dbopen(). DB* dbopen (const char * file, int flags, int mode, DBTYPE type, const void * openinfo) The parameter C is an enumeration which specifies which of the 3 interface methods (DB_HASH, DB_BTREE or DB_RECNO) is to be used. Depending on which of these is actually chosen, the final parameter, I points to a data structure which allows tailoring of the specific interface method. This interface is handled slightly differently in B. Here is an equivalent call using B. tie %array, DB_File, $filename, $flags, $mode, $DB_HASH ; The C, C and C parameters are the direct equivalent of their dbopen() counterparts. The final parameter $DB_HASH performs the function of both the C and C parameters in dbopen(). In the example above $DB_HASH is actually a reference to a hash object. B has three of these pre-defined references. Apart from $DB_HASH, there is also $DB_BTREE and $DB_RECNO. The keys allowed in each of these pre-defined references is limited to the names used in the equivalent C structure. So, for example, the $DB_HASH reference will only allow keys called C, C, C, C, C and C. To change one of these elements, just assign to it like this $DB_HASH{cachesize} = 10000 ; =head2 RECNO In order to make RECNO more compatible with Perl the array offset for all RECNO arrays begins at 0 rather than 1 as in Berkeley DB. =head2 In Memory Databases Berkeley DB allows the creation of in-memory databases by using NULL (that is, a C<(char *)0 in C) in place of the filename. B uses C instead of NULL to provide this functionality. =head2 Using the Berkeley DB Interface Directly As well as accessing Berkeley DB using a tied hash or array, it is also possible to make direct use of most of the functions defined in the Berkeley DB documentation. To do this you need to remember the return value from the tie. $db = tie %hash, DB_File, "filename" Once you have done that, you can access the Berkeley DB API functions directly. $db->put($key, $value, R_NOOVERWRITE) ; All the functions defined in L are available except for close() and dbopen() itself. The B interface to these functions have been implemented to mirror the the way Berkeley DB works. In particular note that all the functions return only a status value. Whenever a Berkeley DB function returns data via one of its parameters, the B equivalent does exactly the same. All the constants defined in L are also available. Below is a list of the functions available. =over 5 =item get Same as in C except that the flags parameter is optional. Remember the value associated with the key you request is returned in the $value parameter. =item put As usual the flags parameter is optional. If you use either the R_IAFTER or R_IBEFORE flags, the key parameter will have the record number of the inserted key/value pair set. =item del The flags parameter is optional. =item fd As in I. =item seq The flags parameter is optional. Both the key and value parameters will be set. =item sync The flags parameter is optional. =back =head1 EXAMPLES It is always a lot easier to understand something when you see a real example. So here are a few. =head2 Using HASH use DB_File ; use Fcntl ; tie %h, DB_File, "hashed", O_RDWR|O_CREAT, 0640, $DB_HASH ; # Add a key/value pair to the file $h{"apple"} = "orange" ; # Check for existence of a key print "Exists\n" if $h{"banana"} ; # Delete delete $h{"apple"} ; untie %h ; =head2 Using BTREE Here is sample of code which used BTREE. Just to make life more interesting the default comparision function will not be used. Instead a Perl sub, C, will be used to do a case insensitive comparison. use DB_File ; use Fcntl ; sub Compare { my ($key1, $key2) = @_ ; "\L$key1" cmp "\L$key2" ; } $DB_BTREE->{compare} = 'Compare' ; tie %h, DB_File, "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE ; # Add a key/value pair to the file $h{'Wall'} = 'Larry' ; $h{'Smith'} = 'John' ; $h{'mouse'} = 'mickey' ; $h{'duck'} = 'donald' ; # Delete delete $h{"duck"} ; # Cycle through the keys printing them in order. # Note it is not necessary to sort the keys as # the btree will have kept them in order automatically. foreach (keys %h) { print "$_\n" } untie %h ; Here is the output from the code above. mouse Smith Wall =head2 Using RECNO use DB_File ; use Fcntl ; $DB_RECNO->{psize} = 3000 ; tie @h, DB_File, "text", O_RDWR|O_CREAT, 0640, $DB_RECNO ; # Add a key/value pair to the file $h[0] = "orange" ; # Check for existence of a key print "Exists\n" if $h[1] ; untie @h ; =head1 WARNINGS If you happen find any other functions defined in the source for this module that have not been mentioned in this document -- beware. I may drop them at a moments notice. If you cannot find any, then either you didn't look very hard or the moment has passed and I have dropped them. =head1 BUGS Some older versions of Berkeley DB had problems with fixed length records using the RECNO file format. The newest version at the time of writing was 1.85 - this seems to have fixed the problems with RECNO. I am sure there are bugs in the code. If you do find any, or can suggest any enhancements, I would welcome your comments. =head1 AVAILABILITY Berkeley DB is available via the hold C in the directory C. It is I under the GPL. =head1 SEE ALSO L, L, L, L, L Berkeley DB is available from F in the directory F. =head1 AUTHOR The DB_File interface was written by Paul Marquess . Questions about the DB system itself may be addressed to Keith Bostic . { delaymagic |= DM_RUID; break; /* don't do magic till later */ } #ifdef HAS_SETRUID (void)setruid((Uid_t)uid); #else #ifdef HAS_SETREUID (void)setreuid((Uid_t)uid, (Uid_t)-1); #ifdef HAS_SETRESUID (void)setresuid((Uid_t)uid, (Uid_t)-1, (Uid_t)-1); #else if (uid == euid) /* special case $< = $> */ perl5.000/pod/modpods/Dynaloader.pod 664 203 12 24073 5650550134 12472 =head1 NAME DynaLoader - Dynamically load C libraries into Perl code dl_error(), dl_findfile(), dl_expandspec(), dl_load_file(), dl_find_symbol(), dl_undef_symbols(), dl_install_xsub(), boostrap() - routines used by DynaLoader modules =head1 SYNOPSIS require DynaLoader; push (@ISA, 'DynaLoader'); =head1 DESCRIPTION This specification defines a standard generic interface to the dynamic linking mechanisms available on many platforms. Its primary purpose is to implement automatic dynamic loading of Perl modules. The DynaLoader is designed to be a very simple high-level interface that is sufficiently general to cover the requirements of SunOS, HP-UX, NeXT, Linux, VMS and other platforms. It is also hoped that the interface will cover the needs of OS/2, NT etc and allow pseudo-dynamic linking (using C at runtime). This document serves as both a specification for anyone wishing to implement the DynaLoader for a new platform and as a guide for anyone wishing to use the DynaLoader directly in an application. It must be stressed that the DynaLoader, by itself, is practically useless for accessing non-Perl libraries because it provides almost no Perl-to-C 'glue'. There is, for example, no mechanism for calling a C library function or supplying arguments. It is anticipated that any glue that may be developed in the future will be implemented in a separate dynamically loaded module. DynaLoader Interface Summary @dl_library_path @dl_resolve_using @dl_require_symbols $dl_debug Implemented in: bootstrap($modulename) Perl @filepaths = dl_findfile(@names) Perl $libref = dl_load_file($filename) C $symref = dl_find_symbol($libref, $symbol) C @symbols = dl_undef_symbols() C dl_install_xsub($name, $symref [, $filename]) C $message = dl_error C =over 4 =item @dl_library_path The standard/default list of directories in which dl_findfile() will search for libraries etc. Directories are searched in order: $dl_library_path[0], [1], ... etc @dl_library_path is initialised to hold the list of 'normal' directories (F, etc) determined by B (C<$Config{'libpth'}.). This should ensure portability across a wide range of platforms. @dl_library_path should also be initialised with any other directories that can be determined from the environment at runtime (such as LD_LIBRARY_PATH for SunOS). After initialisation @dl_library_path can be manipulated by an application using push and unshift before calling dl_findfile(). Unshift can be used to add directories to the front of the search order either to save search time or to override libraries with the same name in the 'normal' directories. The load function that dl_load_file() calls may require an absolute pathname. The dl_findfile() function and @dl_library_path can be used to search for and return the absolute pathname for the library/object that you wish to load. =item @dl_resolve_using A list of additional libraries or other shared objects which can be used to resolve any undefined symbols that might be generated by a later call to load_file(). This is only required on some platforms which do not handle dependent libraries automatically. For example the Socket Perl extension library (F) contains references to many socket functions which need to be resolved when it's loaded. Most platforms will automatically know where to find the 'dependent' library (e.g., F). A few platforms need to to be told the location of the dependent library explicitly. Use @dl_resolve_using for this. Example usage: @dl_resolve_using = dl_findfile('-lsocket'); =item @dl_require_symbols A list of one or more symbol names that are in the library/object file to be dynamically loaded. This is only required on some platforms. =item dl_error() Syntax: $message = dl_error(); Error message text from the last failed DynaLoader function. Note that, similar to errno in unix, a successful function call does not reset this message. Implementations should detect the error as soon as it occurs in any of the other functions and save the corresponding message for later retrieval. This will avoid problems on some platforms (such as SunOS) where the error message is very temporary (e.g., dlerror()). =item $dl_debug Internal debugging messages are enabled when $dl_debug is set true. Currently setting $dl_debug only affects the Perl side of the DynaLoader. These messages should help an application developer to resolve any DynaLoader usage problems. $dl_debug is set to C<$ENV{'PERL_DL_DEBUG'}> if defined. For the DynaLoader developer/porter there is a similar debugging variable added to the C code (see dlutils.c) and enabled if Perl was built with the B<-DDEBUGGING> flag. This can also be set via the PERL_DL_DEBUG environment variable. Set to 1 for minimal information or higher for more. =item dl_findfile() Syntax: @filepaths = dl_findfile(@names) Determine the full paths (including file suffix) of one or more loadable files given their generic names and optionally one or more directories. Searches directories in @dl_library_path by default and returns an empty list if no files were found. Names can be specified in a variety of platform independent forms. Any names in the form B<-lname> are converted into F, where F<.*> is an appropriate suffix for the platform. If a name does not already have a suitable prefix and/or suffix then the corresponding file will be searched for by trying combinations of prefix and suffix appropriate to the platform: "$name.o", "lib$name.*" and "$name". If any directories are included in @names they are searched before @dl_library_path. Directories may be specified as B<-Ldir>. Any other names are treated as filenames to be searched for. Using arguments of the form C<-Ldir> and C<-lname> is recommended. Example: @dl_resolve_using = dl_findfile(qw(-L/usr/5lib -lposix)); =item dl_expandspec() Syntax: $filepath = dl_expandspec($spec) Some unusual systems, such as VMS, require special filename handling in order to deal with symbolic names for files (i.e., VMS's Logical Names). To support these systems a dl_expandspec() function can be implemented either in the F file or code can be added to the autoloadable dl_expandspec(0 function in F for more information. =item dl_load_file() Syntax: $libref = dl_load_file($filename) Dynamically load $filename, which must be the path to a shared object or library. An opaque 'library reference' is returned as a handle for the loaded object. Returns undef on error. (On systems that provide a handle for the loaded object such as SunOS and HPUX, $libref will be that handle. On other systems $libref will typically be $filename or a pointer to a buffer containing $filename. The application should not examine or alter $libref in any way.) This is function that does the real work. It should use the current values of @dl_require_symbols and @dl_resolve_using if required. SunOS: dlopen($filename) HP-UX: shl_load($filename) Linux: dld_create_reference(@dl_require_symbols); dld_link($filename) NeXT: rld_load($filename, @dl_resolve_using) VMS: lib$find_image_symbol($filename,$dl_require_symbols[0]) =item dl_find_symbol() Syntax: $symref = dl_find_symbol($libref, $symbol) Return the address of the symbol $symbol or C if not found. If the target system has separate functions to search for symbols of different types then dl_find_symbol() should search for function symbols first and then other types. The exact manner in which the address is returned in $symref is not currently defined. The only initial requirement is that $symref can be passed to, and understood by, dl_install_xsub(). SunOS: dlsym($libref, $symbol) HP-UX: shl_findsym($libref, $symbol) Linux: dld_get_func($symbol) and/or dld_get_symbol($symbol) NeXT: rld_lookup("_$symbol") VMS: lib$find_image_symbol($libref,$symbol) =item dl_undef_symbols() Example @symbols = dl_undef_symbols() Return a list of symbol names which remain undefined after load_file(). Returns C<()> if not known. Don't worry if your platform does not provide a mechanism for this. Most do not need it and hence do not provide it. =item dl_install_xsub() Syntax: dl_install_xsub($perl_name, $symref [, $filename]) Create a new Perl external subroutine named $perl_name using $symref as a pointer to the function which implements the routine. This is simply a direct call to newXSUB(). Returns a reference to the installed function. The $filename parameter is used by Perl to identify the source file for the function if required by die(), caller() or the debugger. If $filename is not defined then "DynaLoader" will be used. =item boostrap() Syntax: bootstrap($module) This is the normal entry point for automatic dynamic loading in Perl. It performs the following actions: =over 8 =item * locates an auto/$module directory by searching @INC =item * uses dl_findfile() to determine the filename to load =item * sets @dl_require_symbols to C<("boot_$module")> =item * executes an F file if it exists (typically used to add to @dl_resolve_using any files which are required to load the module on the current platform) =item * calls dl_load_file() to load the file =item * calls dl_undef_symbols() and warns if any symbols are undefined =item * calls dl_find_symbol() for "boot_$module" =item * calls dl_install_xsub() to install it as "${module}::bootstrap" =item * calls &{"${module}::bootstrap"} to bootstrap the module =back =back =head1 AUTHOR This interface is based on the work and comments of (in no particular order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno Siegel, Thomas Neumann, Paul Marquess, Charles Bailey, and others. Larry Wall designed the elegant inherited bootstrap mechanism and implemented the first Perl 5 dynamic loader using it. Tim Bunce, 11 August 1994. h for libraries etc. Directories are searched in order: $dl_library_path[0], [1], ... etc @dl_library_path is initialised to hold the list of 'normal' directories (F, etc) determined by B (C<$Config{'libpth'}.). This should ensure portability across a wide range of platforms. @dl_library_path should also be initialised with any other directories that can be determined from the environment at runtime (such as LD_LIBRARY_PATH perl5.000/pod/modpods/English.pod 664 203 12 1240 5650550134 11750 =head1 NAME English - use nice English (or awk) names for ugly punctuation variables =head1 SYNOPSIS use English; ... if ($ERRNO =~ /denied/) { ... } =head1 DESCRIPTION This module provides aliases for the built-in variables whose names no one seems to like to read. Variables with side-effects which get triggered just by accessing them (like $0) will still be affected. For those variables that have an B version, both long and short English alternatives are provided. For example, the C<$/> variable can be referred to either $RS or $INPUT_RECORD_SEPARATOR if you are using the English module. See L for a complete list of these. equire_symbols to C<("boot_$module")> =item * executes an F file if it exists (typically used to add to @dl_resolve_using any files which are required to load the module on the current platform) =item * calls dl_load_file() to load the file =item * calls dl_undef_symbols() and warns if any symbols are undefined =item *perl5.000/pod/modpods/Env.pod 664 203 12 1651 5650406021 11110 =head1 NAME Env - Perl module that imports environment variables =head1 DESCRIPTION Perl maintains environment variables in a pseudo-associative-array named %ENV. For when this access method is inconvenient, the Perl module C allows environment variables to be treated as simple variables. The Env::import() function ties environment variables with suitable names to global Perl variables with the same names. By default it does so with all existing environment variables (C). If the import function receives arguments, it takes them to be a list of environment variables to tie; it's okay if they don't yet exist. After an environment variable is tied, merely use it like a normal variable. You may access its value @path = split(/:/, $PATH); or modify it $PATH .= ":."; however you'd like. To remove a tied environment variable from the environment, assign it the undefined value undef $PATH; file =item * calls dl_undef_symbols() and warns if any symbols are undefined =item *perl5.000/pod/modpods/Exporter.pod 664 203 12 3364 5650550135 12201 =head1 NAME Exporter - module to control namespace manipulations import - import functions into callers namespace =head1 SYNOPSYS package WhatEver; require Exporter; @ISA = (Exporter); @EXPORT = qw(func1, $foo, %tabs); @EXPORT_OK = qw(sin cos); ... use Whatever; use WhatEver 'sin'; =head1 DESCRIPTION The Exporter module is used by well-behaved Perl modules to control what they will export into their user's namespace. The WhatEver module above has placed in its export list the function C, the scalar C<$foo>, and the hash C<%tabs>. When someone decides to C, they get those identifier grafted onto their own namespace. That means the user of package whatever can use the function func1() instead of fully qualifying it as WhatEver::func1(). You should be careful of such namespace pollution. Of course, the user of the WhatEver module is free to use a C instead of a C, which will preserve the sanctity of their namespace. In particular, you almost certainly shouldn't automatically export functions whose names are already used in the language. For this reason, the @EXPORT_OK list contains those function which may be selectively imported, as the sin() function was above. See L. You can't import names that aren't in either the @EXPORT or the @EXPORT_OK list. Remember that these two constructs are identical: use WhatEver; BEGIN { require WhatEver; import Module; } The import() function above is not predefined in the language. Rather, it's a method in the Exporter module. A sneaky library writer could conceivably have an import() method that behaved differently from the standard one, but that's not very friendly. etermined by B (C<$Config{'libpth'}.). This should ensure portability across a wide range of platforms. @dl_library_path should also be initialised with any other directories that can be determined from the environment at runtime (such as LD_LIBRARY_PATH perl5.000/pod/modpods/Fcntl.pod 664 203 12 1052 5650406022 11422 =head1 NAME Fcntl - load the C Fcntl.h defines =head1 SYNOPSIS use Fcntl; =head1 DESCRIPTION This module is just a translation of the C F file. Unlike the old mechanism of requiring a translated F file, this uses the B program (see the Perl source distribution) and your native C compiler. This means that it has a far more likely chance of getting the numbers right. =head1 NOTE Only C<#define> symbols get translated; you must still correctly pack up your own arguments to pass as args for locking functions, etc. C<$foo>, and the hash C<%tabs>. When someone decides to C, they get those identifier grafted onto their own namespace. That means the user of package whatever can use the function func1() instead of fully qualifying it as WhatEver::func1(). You should be careful of such namespace pollution. Of course, the user of the WhatEver module is free to use a C instead of a C, which will preserve the sanctity of their namespace. In partiperl5.000/pod/modpods/FileHandle.pod 664 203 12 2322 5650574464 12370 =head1 NAME FileHandle - supply object methods for filehandles cacheout - keep more files open than the system permits =head1 SYNOPSIS use FileHandle; autoflush STDOUT 1; cacheout($path); print $path @data; =head1 DESCRIPTION See L for complete descriptions of each of the following supported C methods: print autoflush output_field_separator output_record_separator input_record_separator input_line_number format_page_number format_lines_per_page format_lines_left format_name format_top_name format_line_break_characters format_formfeed The cacheout() function will make sure that there's a filehandle open for writing available as the pathname you give it. It automatically closes and re-opens files if you exceed your system file descriptor maximum. =head1 BUGS F lies with its C define on some systems, so you may have to set $cacheout::maxopen yourself. Due to backwards compatibility, all filehandles resemble objects of class C, or actually classes derived from that class. They actually aren't. Which means you can't derive your own class from C and inherit those methods. ed, as the sin() function was above. See L. You can't import names that aren't in either the @EXPORT or the @EXPORT_OK list. Remember that these two constructs are identical: use WhatEver; BEGIN { require WhatEver; import Module; } The import(perl5.000/pod/modpods/Find.pod 664 203 12 2157 5650406023 11244 =head1 NAME find - traverse a file tree =head1 SYNOPSYS use File::Find; find(\&wanted, '/foo','/bar'); sub wanted { ... } =head1 DESCRIPTION The wanted() function does whatever verificationsyou want. $dir contains the current directory name, and $_ the current filename within that directory. $name contains C<"$dir/$_">. You are chdir()'d to $dir when the function is called. The function may set $prune to prune the tree. This library is primarily for the C tool, which when fed, find2perl / -name .nfs\* -mtime +7 \ -exec rm -f {} \; -o -fstype nfs -prune produces something like: sub wanted { /^\.nfs.*$/ && (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && int(-M _) > 7 && unlink($_) || ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && $dev < 0 && ($prune = 1); } Set the variable $dont_use_nlink if you're using AFS, since AFS cheats. Here's another interesting wanted function. It will find all symlinks that don't resolve: sub wanted { -l && !-e && print "bogus link: $name\n"; } ren't. Which means you can't derive your own class from C and inherit those methods. ed, as the sin() function was above. See L. You can't import names that aren't in either the @EXPORT or the @EXPORT_OK list. Remember that these two constructs are identical: use WhatEver; BEGIN { require WhatEver; import Module; } The import(perl5.000/pod/modpods/Finddepth.pod 664 203 12 530 5650406023 12242 =head1 NAME finddepth - traverse a directory structure depth-first =head1 SYNOPSYS use File::Finddepth; finddepth(\&wanted, '/foo','/bar'); sub wanted { ... } =head2 DESCRIPTION This is just like C, except that it does a depthfirst search uses finddepth() rather than find(), and performs a depth-first search. d.e chdir()'d to $dir when the function is called. The function may set $prune to prune the tree. This library is primarily for the C tool, which when feperl5.000/pod/modpods/GetOptions.pod 664 203 12 10206 5650406023 12471 =head1 NAME Getopt::Long, GetOptions - extended getopt processing =head1 SYNOPSIS use Getopt::Long; $result = GetOptions (...option-descriptions...); =head1 DESCRIPTION This package implements an extended getopt function. This function adheres to the new syntax (long option names, no bundling). It tries to implement the better functionality of traditional, GNU and POSIX getopt() functions. Each description should designate a valid Perl identifier, optionally followed by an argument specifier. Values for argument specifiers are: option does not take an argument ! option does not take an argument and may be negated =s :s option takes a mandatory (=) or optional (:) string argument =i :i option takes a mandatory (=) or optional (:) integer argument =f :f option takes a mandatory (=) or optional (:) real number argument If option "name" is set, it will cause the Perl variable $opt_name to be set to the specified value. The calling program can use this variable to detect whether the option has been set. Options that do not take an argument will be set to 1 (one). Options that take an optional argument will be defined, but set to '' if no actual argument has been supplied. If an "@" sign is appended to the argument specifier, the option is treated as an array. Value(s) are not set, but pushed into array @opt_name. Options that do not take a value may have an "!" argument spacifier to indicate that they may be negated. E.g. "foo!" will allow B<-foo> (which sets $opt_foo to 1) and B<-nofoo> (which will set $opt_foo to 0). The option name may actually be a list of option names, separated by '|'s, e.g. B<"foo|bar|blech=s". In this example, options 'bar' and 'blech' will set $opt_foo instead. Option names may be abbreviated to uniqueness, depending on configuration variable $autoabbrev. Dashes in option names are allowed (e.g. pcc-struct-return) and will be translated to underscores in the corresponding Perl variable (e.g. $opt_pcc_struct_return). Note that a lone dash "-" is considered an option, corresponding Perl identifier is $opt_ . A double dash "--" signals end of the options list. If the first option of the list consists of non-alphanumeric characters only, it is interpreted as a generic option starter. Everything starting with one of the characters from the starter will be considered an option. The default values for the option starters are "-" (traditional), "--" (POSIX) and "+" (GNU, being phased out). Options that start with "--" may have an argument appended, separated with an "=", e.g. "--foo=bar". If configuration varaible $getopt_compat is set to a non-zero value, options that start with "+" may also include their arguments, e.g. "+foo=bar". A return status of 0 (false) indicates that the function detected one or more errors. =head1 EXAMPLES If option "one:i" (i.e. takes an optional integer argument), then the following situations are handled: -one -two -> $opt_one = '', -two is next option -one -2 -> $opt_one = -2 Also, assume "foo=s" and "bar:s" : -bar -xxx -> $opt_bar = '', '-xxx' is next option -foo -bar -> $opt_foo = '-bar' -foo -- -> $opt_foo = '--' In GNU or POSIX format, option names and values can be combined: +foo=blech -> $opt_foo = 'blech' --bar= -> $opt_bar = '' --bar=-- -> $opt_bar = '--' =over 12 =item $autoabbrev Allow option names to be abbreviated to uniqueness. Default is 1 unless environment variable POSIXLY_CORRECT has been set. =item $getopt_compat Allow '+' to start options. Default is 1 unless environment variable POSIXLY_CORRECT has been set. =item $option_start Regexp with option starters. Default is (--|-) if environment variable POSIXLY_CORRECT has been set, (--|-|\+) otherwise. =item $order Whether non-options are allowed to be mixed with options. Default is $REQUIRE_ORDER if environment variable POSIXLY_CORRECT has been set, $PERMUTE otherwise. =item $ignorecase Ignore case when matching options. Default is 1. =item $debug Enable debugging output. Default is 0. =back =head1 NOTE Does not yet use the Exporter--or even packages!! Thus, it's not a real module. o resolve any undefined symbols that might be generated by a later call to load_file(). This is only required on some platforms which do not handle dependent libraries automatically. For example the Socket Perl extension library (F) contains references to many socket functions which need to be resolved when it's loaded. Most platforms will automaticaperl5.000/pod/modpods/Getopt.pod 664 203 12 11467 5650550135 11656 =head1 NAME getopt - Process single-character switches with switch clustering getopts - Process single-character switches with switch clustering GetOptions - extended getopt processing =head1 SYNOPSIS use Getopt::Std; getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. getopts('oif:'); # likewise, but all of them use Getopt::Long; $result = GetOptions (...option-descriptions...); =head1 DESCRIPTION The getopt() functions processes single-character switches with switch clustering. Pass one argument which is a string containing all switches that take an argument. For each switch found, sets $opt_x (where x is the switch name) to the value of the argument, or 1 if no argument. Switches which take an argument don't care whether there is a space between the switch and the argument. The Getopt::Long module implements an extended getopt function called GetOptions(). This function adheres to the new syntax (long option names, no bundling). It tries to implement the better functionality of traditional, GNU and POSIX getopt() functions. Each description should designate a valid Perl identifier, optionally followed by an argument specifier. Values for argument specifiers are: option does not take an argument ! option does not take an argument and may be negated =s :s option takes a mandatory (=) or optional (:) string argument =i :i option takes a mandatory (=) or optional (:) integer argument =f :f option takes a mandatory (=) or optional (:) real number argument If option "name" is set, it will cause the Perl variable $opt_name to be set to the specified value. The calling program can use this variable to detect whether the option has been set. Options that do not take an argument will be set to 1 (one). Options that take an optional argument will be defined, but set to '' if no actual argument has been supplied. If an "@" sign is appended to the argument specifier, the option is treated as an array. Value(s) are not set, but pushed into array @opt_name. Options that do not take a value may have an "!" argument specifier to indicate that they may be negated. E.g. "foo!" will allow B<-foo> (which sets $opt_foo to 1) and B<-nofoo> (which will set $opt_foo to 0). The option name may actually be a list of option names, separated by '|'s, e.g. B<"foo|bar|blech=s". In this example, options 'bar' and 'blech' will set $opt_foo instead. Option names may be abbreviated to uniqueness, depending on configuration variable $autoabbrev. Dashes in option names are allowed (e.g. pcc-struct-return) and will be translated to underscores in the corresponding Perl variable (e.g. $opt_pcc_struct_return). Note that a lone dash "-" is considered an option, corresponding Perl identifier is $opt_ . A double dash "--" signals end of the options list. If the first option of the list consists of non-alphanumeric characters only, it is interpreted as a generic option starter. Everything starting with one of the characters from the starter will be considered an option. The default values for the option starters are "-" (traditional), "--" (POSIX) and "+" (GNU, being phased out). Options that start with "--" may have an argument appended, separated with an "=", e.g. "--foo=bar". If configuration variable $getopt_compat is set to a non-zero value, options that start with "+" may also include their arguments, e.g. "+foo=bar". A return status of 0 (false) indicates that the function detected one or more errors. =head1 EXAMPLES If option "one:i" (i.e. takes an optional integer argument), then the following situations are handled: -one -two -> $opt_one = '', -two is next option -one -2 -> $opt_one = -2 Also, assume "foo=s" and "bar:s" : -bar -xxx -> $opt_bar = '', '-xxx' is next option -foo -bar -> $opt_foo = '-bar' -foo -- -> $opt_foo = '--' In GNU or POSIX format, option names and values can be combined: +foo=blech -> $opt_foo = 'blech' --bar= -> $opt_bar = '' --bar=-- -> $opt_bar = '--' =over 12 =item $autoabbrev Allow option names to be abbreviated to uniqueness. Default is 1 unless environment variable POSIXLY_CORRECT has been set. =item $getopt_compat Allow '+' to start options. Default is 1 unless environment variable POSIXLY_CORRECT has been set. =item $option_start Regexp with option starters. Default is (--|-) if environment variable POSIXLY_CORRECT has been set, (--|-|\+) otherwise. =item $order Whether non-options are allowed to be mixed with options. Default is $REQUIRE_ORDER if environment variable POSIXLY_CORRECT has been set, $PERMUTE otherwise. =item $ignorecase Ignore case when matching options. Default is 1. =item $debug Enable debugging output. Default is 0. =back =head1 NOTE Does not yet use the Exporter--or even packages!! Thus, it's not a real module. s('oif:'); # likewise, but all of them use Getopt::Long; $result = GetOptions (...option-descriptions...); =head1 DESCRIPTION The getopt() functions processes single-character switches withperl5.000/pod/modpods/MakeMaker.pod 664 203 12 1232 5650406024 12213 =head1 NAME MakeMaker - generate a Makefile for Perl extension =head1 SYNOPSIS use ExtUtils::MakeMaker; =head1 DESCRIPTION This utility is designed to write a Makefile for an extension module from a Makefile.PL. It splits the task of generating the Makefile into several subroutines that can be individually overridden. Each subroutines returns the text it wishes to have written to the Makefile. The best way to learn to use this is to look at how some of the extensions are generated, such as Socket. =head1 AUTHOR Andy Dougherty >, Andreas Koenig >, and Tim Bunce >. e switch name) to the value of the argument, or 1 if no argument. Switches which take an argument don't care whether there is a space between the switch and the argument. The Getopt::Long module implements an extended getopt function called GetOptions(). This function adheres to the new syntax (long option names, no bundling). It tries to implement the perl5.000/pod/modpods/Open2.pod 664 203 12 2220 5650406025 11340 =head1 NAME IPC::Open2, open2 - open a process for both reading and writing =head1 SYNOPSIS use IPC::Open2; $pid = open2('rdr', 'wtr', 'some cmd and args'); # or $pid = open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args'); =head1 DESCRIPTION The open2() function spawns the given $cmd and connects $rdr for reading and $wtr for writing. It's what you think should work when you try open(HANDLE, "|cmd args"); open2() returns the process ID of the child process. It doesn't return on failure: it just raises an exception matching C. =head1 WARNING It will not create these file handles for you. You have to do this yourself. So don't pass it empty variables expecting them to get filled in for you. Additionally, this is very dangerous as you may block forever. It assumes it's going to talk to something like B, both writing to it and reading from it. This is presumably safe because you "know" that commands like B will read a line at a time and output a line at a time. Programs like B that read their entire input stream first, however, are quite apt to cause deadlock. See L for an alternative. llowed by an argument specifier. Values for argument specifiers are: option does not take an argument ! option does not take an argument and may be negated =s :s option takes a mandatory (=) or optional (:) string argument =i :i option takes a mandatory (=) or optional (:) integer argument =f :f option takes a mandatory (=) or opperl5.000/pod/modpods/Open3.pod 664 203 12 1441 5650406025 11345 =head1 NAME IPC::Open3, open3 - open a process for reading, writing, and error handling =head1 SYNOPSIS $pid = open3('WTRFH', 'RDRFH', 'ERRFH' 'some cmd and args', 'optarg', ...); =head1 DESCRIPTION Extremely similar to open2(), open3() spawns the given $cmd and connects RDRFH for reading, WTRFH for writing, and ERRFH for errors. If ERRFH is '', or the same as RDRFH, then STDOUT and STDERR of the child are on the same file handle. If WTRFH begins with ">&", then WTRFH will be closed in the parent, and the child will read from it directly. if RDRFH or ERRFH begins with ">&", then the child will send output directly to that file handle. In both cases, there will be a dup(2) instead of a pipe(2) made. All caveats from open2() continue to apply. See L for details. ver. It assumes it's going to talk to something like B, both writing to it and reading from it. This is presumably safe because you "know" that commands like B will read a line at a time and output a line at a timeperl5.000/pod/modpods/POSIX.pod 664 203 12 3676 5650406025 11277 =head1 NAME POSIX - Perl interface to IEEE 1003.1 namespace =head1 SYNOPSIS use POSIX; use POSIX 'strftime'; =head1 DESCRIPTION The POSIX module permits you to access all (or nearly all) the standard POSIX 1003.1 identifiers. Things which are C<#defines> in C, like EINTR or O_NDELAY, are automatically exported into your namespace. All functions are only exported if you ask for them explicitly. Most likely people will prefer to use the fully-qualified function names. To get a list of all the possible identifiers available to you--and their semantics--you should pick up a 1003.1 spec, or look in the F module. =head1 EXAMPLES printf "EENTR is %d\n", EINTR; POSIX::setsid(0); $fd = POSIX::open($path, O_CREAT|O_EXCL|O_WRONLY, 0644); # note: that's a filedescriptor, *NOT* a filehandle =head1 NOTE The POSIX module is probably the most complex Perl module supplied with the standard distribution. It incorporates autoloading, namespace games, and dynamic loading of code that's in Perl, C, or both. It's a great source of wisdom. =head1 CAVEATS A few functions are not implemented because they are C specific. If you attempt to call these, they will print a message telling you that they aren't implemented because they're, supplying the Perl equivalent if one exists. For example, trying to access the setjmp() call will elicit the message "setjmp() is C-specific: use eval {} instead". Furthermore, some evil vendors will claim 1003.1 compliance, but in fact are not so: they will not pass the PCTS (POSIX Compliance Test Suites). For example, one vendor may not define EDEADLK, or the semantics of the errno values set by open(2) might not be quite right. Perl does not attempt to verify POSIX compliance. That means you can currently successfully say "use POSIX", and then later in your program you find that your vendor has been lax and there's no usable ICANON macro after all. This could be construed to be a bug. the option is treated as an array. Value(s) are not set, but pusperl5.000/pod/modpods/Ping.pod 664 203 12 1522 5650550136 11261 =head1 NAME Net::Ping, pingecho - check a host for upness =head1 SYNOPSIS use Net::Ping; print "'jimmy' is alive and kicking\n" if pingecho('jimmy', 10) ; =head1 DESCRIPTION This module contains routines to test for the reachability of remote hosts. Currently the only routine implemented is pingecho(). pingecho() uses a TCP echo (I an ICMP one) to determine if the remote host is reachable. This is usually adequate to tell that a remote host is available to rsh(1), ftp(1), or telnet(1) onto. =head2 Parameters =over 5 =item hostname The remote host to check, specified either as a hostname or as an IP address. =item timeout The timeout in seconds. If not specified it will default to 5 seconds. =back =head1 WARNING pingecho() uses alarm to implement the timeout, so don't set another alarm while you are using it. POSIX module is probably the most complex Perl module supplied with the standard distribution. It incorporates autoloading, namespace games, and dynamic loading of code thaperl5.000/pod/modpods/Socket.pod 664 203 12 1207 5650406026 11612 =head1 NAME Socket - load the C socket.h defines =head1 SYNOPSIS use Socket; $proto = (getprotobyname('udp'))[2]; socket(Socket_Handle, PF_INET, SOCK_DGRAM, $proto); =head1 DESCRIPTION This module is just a translation of the C F file. Unlike the old mechanism of requiring a translated F file, this uses the B program (see the Perl source distribution) and your native C compiler. This means that it has a far more likely chance of getting the numbers right. =head1 NOTE Only C<#define> symbols get translated; you must still correctly pack up your own arguments to pass to bind(), etc. imeout The timeout in seconds. If not specified it will default to 5 seconds. =back =head1 WARNING pingecho() uses alarm to implement the timeout, so don't set another alarm while you are using it. POSIX module is probably the most complex Perl module supplied with the standard distribution. It incorporates autoloading, namespace games, and dynamic loading of code thaperl5.000/pod/modpods/integer.pod 664 203 12 762 5650406026 12004 =head1 NAME integer - Perl pragma to compute arithmetic in integer instead of double =head1 SYNOPSIS use integer; $x = 10/3; # $x is now 3, not 3.33333333333333333 =head1 DESCRIPTION This tells the compiler that it's okay to use integer operations from here to the end of the enclosing BLOCK. On many machines, this doesn't matter a great deal for most computations, but on those without floating point hardware, it can make a big difference. See L. the numbers riperl5.000/pod/modpods/less.pod 664 203 12 422 5650406027 11307 =head1 NAME less - Perl pragma to request less of something from the compiler =head1 DESCRIPTION Currently unimplemented, this may someday be a compiler directive to make certain trade-off, such as perhaps use less 'memory'; use less 'CPU'; use less 'fat'; to the end of the enclosing BLOCK. On many machines, this doesn't matter a great deal for most computations, but on those without floating point hardware, it can make a big difference. See L. the numbers riperl5.000/pod/modpods/sigtrap.pod 664 203 12 1045 5650406027 12034 =head1 NAME sigtrap - Perl pragma to enable stack backtrace on unexpected signals =head1 SYNOPSIS use sigtrap; use sigtrap qw(BUS SEGV PIPE SYS ABRT TRAP); =head1 DESCRIPTION The C pragma initializes some default signal handlers that print a stack dump of your Perl program, then sends itself a SIGABRT. This provides a nice starting point if something horrible goes wrong. By default, handlers are installed for the ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT, SEGV, SYS, TERM, and TRAP signals. See L. mbols get translated; you must still correctly pack up your own arguments to pass to bind(), etc. imeout The timeout in seconds. If not specified it will default to 5 seconds. =back =head1 WARNING pingecho() uses alarm to implement the timeout, so don't set another alarm while you are using it. POSIX module is probably the most complex Perl module supplied with the standard distribution. It incorporates autoloading, namespace games, and dynamic loading of code thaperl5.000/pod/modpods/strict.pod 664 203 12 3071 5650406027 11674 =head1 NAME strict - Perl pragma to restrict unsafe constructs =head1 SYNOPSIS use strict; use strict "vars"; use strict "refs"; use strict "subs"; use strict; no strict "vars"; =head1 DESCRIPTION If no import list is supplied, all possible restrictions are assumed. (This the safest mode to operate in, but is sometimes too strict for casual programming.) Currently, there are three possible things to be strict about: "subs", "vars", or "refs". =over 6 =item C This generates a runtime error if you use symbolic references (see L). use strict 'refs'; $ref = \$foo; print $$ref; # ok $ref = "foo"; print $$ref; # runtime error; normally ok =item C This generates a compile-time error if you access a variable that wasn't localized via C or wasn't fully qualified. Because this is to avoid variable suicide problems and subtle dynamic scoping issues, a merely local() variable isn't good enough. See L and L. use strict 'vars'; $X::foo = 1; # ok, fully qualified my $foo = 10; # ok, my() var local $foo = 9; # blows up The local() generated a compile-time error because you just touched a global name without fully qualifying it. =item C This disables the poetry optimization, generating a compile-time error if you try to use a bareword identifiers that's not a subroutine. use strict 'subs'; $SIG{PIPE} = Plumber; # blows up $SIG{"PIPE"} = "Plumber"; # just fine =back See L. nces (see L). use strict 'refs'; $ref = \$foo; print $$ref; # ok $ref = "foo"; print $$ref; # runtime error; normally ok =item C This generates a compile-time error if you access a variable that wasn't localized via C or wasn't fully qualified. Because this is to avoid variable suicide problems and subtle dynamic scoping issues, a merely local() variable isn't good enough. See L and L and L. compile-time error if you try to use a bareword identifiers that's not a subroutine. use strict 'subs'; $SIG{PIPE} = Plumber; # blows up $SIG{"PIPE"} = "Plumber";perl5.000/pod/perl.pod 664 203 12 23047 5650551552 7712 =head1 NAME perl - Practical Extraction and Report Language =head1 SYNOPSIS For ease of access, the Perl manual has been split up into a number of sections: perl Perl overview (this section) perldata Perl data structures perlsyn Perl syntax perlop Perl operators and precedence perlre Perl regular expressions perlrun Perl execution and options perlfunc Perl builtin functions perlvar Perl predefined variables perlsub Perl subroutines perlmod Perl modules perlref Perl references and nested data structures perlobj Perl objects perlbot Perl OO tricks and examples perldebug Perl debugging perldiag Perl diagnostic messages perlform Perl formats perlipc Perl interprocess communication perlsec Perl security perltrap Perl traps for the unwary perlstyle Perl style guide perlapi Perl application programming interface perlguts Perl internal functions for those doing extensions perlcall Perl calling conventions from C perlovl Perl overloading semantics perlbook Perl book information (If you're intending to read these straight through for the first time, the suggested order will tend to reduce the number of forward references.) If something strange has gone wrong with your program and you're not sure where you should look for help, try the B<-w> switch first. It will often point out exactly where the trouble is. =head1 DESCRIPTION Perl is an interpreted language optimized for scanning arbitrary text files, extracting information from those text files, and printing reports based on that information. It's also a good language for many system management tasks. The language is intended to be practical (easy to use, efficient, complete) rather than beautiful (tiny, elegant, minimal). It combines (in the author's opinion, anyway) some of the best features of C, B, B, and B, so people familiar with those languages should have little difficulty with it. (Language historians will also note some vestiges of B, Pascal, and even BASIC-PLUS.) Expression syntax corresponds quite closely to C expression syntax. Unlike most Unix utilities, Perl does not arbitrarily limit the size of your data--if you've got the memory, Perl can slurp in your whole file as a single string. Recursion is of unlimited depth. And the hash tables used by associative arrays grow as necessary to prevent degraded performance. Perl uses sophisticated pattern matching techniques to scan large amounts of data very quickly. Although optimized for scanning text, Perl can also deal with binary data, and can make dbm files look like associative arrays (where dbm is available). Setuid Perl scripts are safer than C programs through a dataflow tracing mechanism which prevents many stupid security holes. If you have a problem that would ordinarily use B or B or B, but it exceeds their capabilities or must run a little faster, and you don't want to write the silly thing in C, then Perl may be for you. There are also translators to turn your B and B scripts into Perl scripts. But wait, there's more... Perl version 5 is nearly a complete rewrite, and provides the following additional benefits: =over 5 =item * Many usability enhancements It is now possible to write much more readable Perl code (even within regular expressions). Formerly cryptic variable names can be replaced by mnemonic identifiers. Error messages are more informative, and the optional warnings will catch many of the mistakes a novice might make. This cannot be stressed enough. Whenever you get mysterious behavior, try the B<-w> switch!!! Whenever you don't get mysterious behavior, try using B<-w> anyway. =item * Simplified grammar The new yacc grammar is one half the size of the old one. Many of the arbitrary grammar rules have been regularized. The number of reserved words has been cut by 2/3. Despite this, nearly all old Perl scripts will continue to work unchanged. =item * Lexical scoping Perl variables may now be declared within a lexical scope, like "auto" variables in C. Not only is this more efficient, but it contributes to better privacy for "programming in the large". =item * Arbitrarily nested data structures Any scalar value, including any array element, may now contain a reference to any other variable or subroutine. You can easily create anonymous variables and subroutines. Perl manages your reference counts for you. =item * Modularity and reusability The Perl library is now defined in terms of modules which can be easily shared among various packages. A package may choose to import all or a portion of a module's published interface. Pragmas (that is, compiler directives) are defined and used by the same mechanism. =item * Object-oriented programming A package can function as a class. Dynamic multiple inheritance and virtual methods are supported in a straightforward manner and with very little new syntax. Filehandles may now be treated as objects. =item * Embeddible and Extensible Perl may now be embedded easily in your C or C++ application, and can either call or be called by your routines through a documented interface. The XS preprocessor is provided to make it easy to glue your C or C++ routines into Perl. Dynamic loading of modules is supported. =item * POSIX compliant A major new module is the POSIX module, which provides access to all available POSIX routines and definitions, via object classes where appropriate. =item * Package constructors and destructors The new BEGIN and END blocks provide means to capture control as a package is being compiled, and after the program exits. As a degenerate case they work just like awk's BEGIN and END when you use the B<-p> or B<-n> switches. =item * Multiple simultaneous DBM implementations A Perl program may now access DBM, NDBM, SDBM, GDBM, and Berkeley DB files from the same script simultaneously. In fact, the old dbmopen interface has been generalized to allow any variable to be tied to an object class which defines its access methods. =item * Subroutine definitions may now be autoloaded In fact, the AUTOLOAD mechanism also allows you to define any arbitrary semantics for undefined subroutine calls. It's not just for autoloading. =item * Regular expression enhancements You can now specify non-greedy quantifiers. You can now do grouping without creating a backreference. You can now write regular expressions with embedded whitespace and comments for readability. A consistent extensibility mechanism has been added that is upwardly compatible with all old regular expressions. =back Ok, that's I enough hype. =head1 ENVIRONMENT =over 12 =item HOME Used if chdir has no argument. =item LOGDIR Used if chdir has no argument and HOME is not set. =item PATH Used in executing subprocesses, and in finding the script if B<-S> is used. =item PERL5LIB A colon-separated list of directories in which to look for Perl library files before looking in the standard library and the current directory. If PERL5LIB is not defined, PERLLIB is used. =item PERL5DB The command used to get the debugger code. If unset, uses BEGIN { require 'perl5db.pl' } =item PERLLIB A colon-separated list of directories in which to look for Perl library files before looking in the standard library and the current directory. If PERL5LIB is defined, PERLLIB is not used. =back Apart from these, Perl uses no other environment variables, except to make them available to the script being executed, and to child processes. However, scripts running setuid would do well to execute the following lines before doing anything else, just to keep people honest: $ENV{'PATH'} = '/bin:/usr/bin'; # or whatever you need $ENV{'SHELL'} = '/bin/sh' if defined $ENV{'SHELL'}; $ENV{'IFS'} = '' if defined $ENV{'IFS'}; =head1 AUTHOR Larry Wall , with the help of oodles of other folks. =head1 FILES "/tmp/perl-e$$" temporary file for -e commands "@INC" locations of perl 5 libraries =head1 SEE ALSO a2p awk to perl translator s2p sed to perl translator =head1 DIAGNOSTICS The B<-w> switch produces some lovely diagnostics. See L for explanations of all Perl's diagnostics. Compilation errors will tell you the line number of the error, with an indication of the next token or token type that was to be examined. (In the case of a script passed to Perl via B<-e> switches, each B<-e> is counted as one line.) Setuid scripts have additional constraints that can produce error messages such as "Insecure dependency". See L. Did we mention that you should definitely consider using the B<-w> switch? =head1 BUGS The B<-w> switch is not mandatory. Perl is at the mercy of your machine's definitions of various operations such as type casting, atof() and sprintf(). If your stdio requires an seek or eof between reads and writes on a particular stream, so does Perl. (This doesn't apply to sysread() and syswrite().) While none of the built-in data types have any arbitrary size limits (apart from memory size), there are still a few arbitrary limits: a given identifier may not be longer than 255 characters, and no component of your PATH may be longer than 255 if you use B<-S>. A regular expression may not compile to more than 32767 bytes internally. Perl actually stands for Pathologically Eclectic Rubbish Lister, but don't tell anyone I said that. =head1 NOTES The Perl motto is "There's more than one way to do it." Divining how many more is left as an exercise to the reader. The three principle virtues of a programmer are Laziness, Impatience, and Hubris. See the Camel Book for why. ly is this more efficient, but it contributes to better privacy for "programming in the large". =item * Arbitrarily nested data structures Any scalar value, including any array element, may now contain a reference to any other variable or subroutine. You can easily create anonymous variables and subroutines. Perl manages your reference counts for you. =item * Modularity and reusability The Perl library is now defined in terms of modules which can be easily sharedperl5.000/pod/perlapi.pod 664 203 12 103417 5650550114 10415 =head1 NAME perlapi - Perl 5 application programming interface for C extensions =head1 DESCRIPTION =head2 Introduction XS is a language used to create an extension interface between Perl and some C library which one wishes to use with Perl. The XS interface is combined with the library to create a new library which can be linked to Perl. An B is a function in the XS language and is the core component of the Perl application interface. The XS compiler is called B. This compiler will embed the constructs necessary to let an XSUB, which is really a C function in disguise, manipulate Perl values and creates the glue necessary to let Perl access the XSUB. The compiler uses B to determine how to map C function parameters and variables to Perl values. The default typemap handles many common C types. A supplement typemap must be created to handle special structures and types for the library being linked. Many of the examples which follow will concentrate on creating an interface between Perl and the ONC+RPC bind library functions. Specifically, the rpcb_gettime() function will be used to demonstrate many features of the XS language. This function has two parameters; the first is an input parameter and the second is an output parameter. The function also returns a status value. bool_t rpcb_gettime(const char *host, time_t *timep); From C this function will be called with the following statements. #include bool_t status; time_t timep; status = rpcb_gettime( "localhost", &timep ); If an XSUB is created to offer a direct translation between this function and Perl, then this XSUB will be used from Perl with the following code. The $status and $timep variables will contain the output of the function. use RPC; $status = rpcb_gettime( "localhost", $timep ); The following XS file shows an XS subroutine, or XSUB, which demonstrates one possible interface to the rpcb_gettime() function. This XSUB represents a direct translation between C and Perl and so preserves the interface even from Perl. This XSUB will be invoked from Perl with the usage shown above. Note that the first three #include statements, for C, C, and C, will always be present at the beginning of an XS file. This approach and others will be expanded later in this document. #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include MODULE = RPC PACKAGE = RPC bool_t rpcb_gettime(host,timep) char * host time_t &timep OUTPUT: timep Any extension to Perl, including those containing XSUBs, should have a Perl module to serve as the bootstrap which pulls the extension into Perl. This module will export the extension's functions and variables to the Perl program and will cause the extension's XSUBs to be linked into Perl. The following module will be used for most of the examples in this document and should be used from Perl with the C command as shown earlier. Perl modules are explained in more detail later in this document. package RPC; require Exporter; require DynaLoader; @ISA = qw(Exporter DynaLoader); @EXPORT = qw( rpcb_gettime ); bootstrap RPC; 1; Throughout this document a variety of interfaces to the rpcb_gettime() XSUB will be explored. The XSUBs will take their parameters in different orders or will take different numbers of parameters. In each case the XSUB is an abstraction between Perl and the real C rpcb_gettime() function, and the XSUB must always ensure that the real rpcb_gettime() function is called with the correct parameters. This abstraction will allow the programmer to create a more Perl-like interface to the C function. =head2 The Anatomy of an XSUB The following XSUB allows a Perl program to access a C library function called sin(). The XSUB will imitate the C function which takes a single argument and returns a single value. double sin(x) doublex The compiler expects a tab between the parameter name and its type, and any or no whitespace before the type. When using C pointers the indirection operator C<*> should be considered part of the type and the address operator C<&> should be considered part of the variable, as is demonstrated in the rpcb_gettime() function above. See the section on typemaps for more about handling qualifiers and unary operators in C types. The parameter list of a function must not have whitespace after the open-parenthesis or before the close-parenthesis. INCORRECT CORRECT double double sin( x ) sin(x) double x double x The function name and the return type must be placed on separate lines. INCORRECT CORRECT double sin(x) double double x sin(x) double x =head2 The Argument Stack The argument stack is used to store the values which are sent as parameters to the XSUB and to store the XSUB's return value. In reality all Perl functions keep their values on this stack at the same time, each limited to its own range of positions on the stack. In this document the first position on that stack which belongs to the active function will be referred to as position 0 for that function. XSUBs refer to their stack arguments with the macro B, where I refers to a position in this XSUB's part of the stack. Position 0 for that function would be known to the XSUB as ST(0). The XSUB's incoming parameters and outgoing return values always begin at ST(0). For many simple cases the B compiler will generate the code necessary to handle the argument stack by embedding code fragments found in the typemaps. In more complex cases the programmer must supply the code. =head2 The RETVAL Variable The RETVAL variable is a magic variable which always matches the return type of the C library function. The B compiler will supply this variable in each XSUB and by default will use it to hold the return value of the C library function being called. In simple cases the value of RETVAL will be placed in ST(0) of the argument stack where it can be received by Perl as the return value of the XSUB. If the XSUB has a return type of C then the compiler will not supply a RETVAL variable for that function. When using the PPCODE: directive the RETVAL variable may not be needed. =head2 The MODULE Keyword The MODULE keyword is used to start the XS code and to specify the package of the functions which are being defined. All text preceding the first MODULE keyword is considered C code and is passed through to the output untouched. Every XS module will have a bootstrap function which is used to hook the XSUBs into Perl. The package name of this bootstrap function will match the value of the last MODULE statement in the XS source files. The value of MODULE should always remain constant within the same XS file, though this is not required. The following example will start the XS code and will place all functions in a package named RPC. MODULE = RPC =head2 The PACKAGE Keyword When functions within an XS source file must be separated into packages the PACKAGE keyword should be used. This keyword is used with the MODULE keyword and must follow immediately after it when used. MODULE = RPC PACKAGE = RPC [ XS code in package RPC ] MODULE = RPC PACKAGE = RPCB [ XS code in package RPCB ] MODULE = RPC PACKAGE = RPC [ XS code in package RPC ] Although this keyword is optional and in some cases provides redundant information it should always be used. This keyword will ensure that the XSUBs appear in the desired package. =head2 The PREFIX Keyword The PREFIX keyword designates prefixes which should be removed from the Perl function names. If the C function is C and the PREFIX value is C then Perl will see this function as C. This keyword should follow the PACKAGE keyword when used. If PACKAGE is not used then PREFIX should follow the MODULE keyword. MODULE = RPC PREFIX = rpc_ MODULE = RPC PACKAGE = RPCB PREFIX = rpcb_ =head2 The OUTPUT: Keyword The OUTPUT: keyword indicates that certain function parameters should be updated (new values made visible to Perl) when the XSUB terminates or that certain values should be returned to the calling Perl function. For simple functions, such as the sin() function above, the RETVAL variable is automatically designated as an output value. In more complex functions the B compiler will need help to determine which variables are output variables. This keyword will normally be used to complement the CODE: keyword. The RETVAL variable is not recognized as an output variable when the CODE: keyword is present. The OUTPUT: keyword is used in this situation to tell the compiler that RETVAL really is an output variable. The OUTPUT: keyword can also be used to indicate that function parameters are output variables. This may be necessary when a parameter has been modified within the function and the programmer would like the update to be seen by Perl. If function parameters are listed under OUTPUT: along with the RETVAL variable then the RETVAL variable must be the last one listed. bool_t rpcb_gettime(host,timep) char * host time_t &timep OUTPUT: timep The OUTPUT: keyword will also allow an output parameter to be mapped to a matching piece of code rather than to a typemap. bool_t rpcb_gettime(host,timep) char * host time_t &timep OUTPUT: timepsv_setnv(ST(1), (double)timep); =head2 The CODE: Keyword This keyword is used in more complicated XSUBs which require special handling for the C function. The RETVAL variable is available but will not be returned unless it is specified under the OUTPUT: keyword. The following XSUB is for a C function which requires special handling of its parameters. The Perl usage is given first. $status = rpcb_gettime( "localhost", $timep ); The XSUB follows. bool_t rpcb_gettime(host,timep) char * host time_t timep CODE: RETVAL = rpcb_gettime( host, &timep ); OUTPUT: timep RETVAL In many of the examples shown here the CODE: block (and other blocks) will often be contained within braces ( C<{> and C<}> ). This protects the CODE: block from complex INPUT typemaps and ensures the resulting C code is legal. =head2 The NO_INIT Keyword The NO_INIT keyword is used to indicate that a function parameter is being used only as an output value. The B compiler will normally generate code to read the values of all function parameters from the argument stack and assign them to C variables upon entry to the function. NO_INIT will tell the compiler that some parameters will be used for output rather than for input and that they will be handled before the function terminates. The following example shows a variation of the rpcb_gettime() function. This function uses the timep variable only as an output variable and does not care about its initial contents. bool_t rpcb_gettime(host,timep) char * host time_t &timep = NO_INIT OUTPUT: timep =head2 Initializing Function Parameters Function parameters are normally initialized with their values from the argument stack. The typemaps contain the code segments which are used to transfer the Perl values to the C parameters. The programmer, however, is allowed to override the typemaps and supply alternate initialization code. The following code demonstrates how to supply initialization code for function parameters. The initialization code is eval'd by the compiler before it is added to the output so anything which should be interpreted literally, such as double quotes, must be protected with backslashes. bool_t rpcb_gettime(host,timep) char * host = (char *)SvPV(ST(0),na); time_t &timep = 0; OUTPUT: timep This should not be used to supply default values for parameters. One would normally use this when a function parameter must be processed by another library function before it can be used. Default parameters are covered in the next section. =head2 Default Parameter Values Default values can be specified for function parameters by placing an assignment statement in the parameter list. The default value may be a number or a string. Defaults should always be used on the right-most parameters only. To allow the XSUB for rpcb_gettime() to have a default host value the parameters to the XSUB could be rearranged. The XSUB will then call the real rpcb_gettime() function with the parameters in the correct order. Perl will call this XSUB with either of the following statements. $status = rpcb_gettime( $timep, $host ); $status = rpcb_gettime( $timep ); The XSUB will look like the code which follows. A CODE: block is used to call the real rpcb_gettime() function with the parameters in the correct order for that function. bool_t rpcb_gettime(timep,host="localhost") char * host time_t timep = NO_INIT CODE: RETVAL = rpcb_gettime( host, &timep ); OUTPUT: timep RETVAL =head2 Variable-length Parameter Lists XSUBs can have variable-length parameter lists by specifying an ellipsis C<(...)> in the parameter list. This use of the ellipsis is similar to that found in ANSI C. The programmer is able to determine the number of arguments passed to the XSUB by examining the C variable which the B compiler supplies for all XSUBs. By using this mechanism one can create an XSUB which accepts a list of parameters of unknown length. The I parameter for the rpcb_gettime() XSUB can be optional so the ellipsis can be used to indicate that the XSUB will take a variable number of parameters. Perl should be able to call this XSUB with either of the following statments. $status = rpcb_gettime( $timep, $host ); $status = rpcb_gettime( $timep ); The XS code, with ellipsis, follows. bool_t rpcb_gettime(timep, ...) time_t timep = NO_INIT CODE: { char *host = "localhost"; if( items > 1 ) host = (char *)SvPV(ST(1), na); RETVAL = rpcb_gettime( host, &timep ); } OUTPUT: timep RETVAL =head2 The PPCODE: Keyword The PPCODE: keyword is an alternate form of the CODE: keyword and is used to tell the B compiler that the programmer is supplying the code to control the argument stack for the XSUBs return values. Occassionally one will want an XSUB to return a list of values rather than a single value. In these cases one must use PPCODE: and then explicitly push the list of values on the stack. The PPCODE: and CODE: keywords are not used together within the same XSUB. The following XSUB will call the C rpcb_gettime() function and will return its two output values, timep and status, to Perl as a single list. void rpcb_gettime(host) char * host PPCODE: { time_t timep; bool_t status; status = rpcb_gettime( host, &timep ); EXTEND(sp, 2); PUSHs(sv_2mortal(newSVnv(status))); PUSHs(sv_2mortal(newSVnv(timep))); } Notice that the programmer must supply the C code necessary to have the real rpcb_gettime() function called and to have the return values properly placed on the argument stack. The C return type for this function tells the B compiler that the RETVAL variable is not needed or used and that it should not be created. In most scenarios the void return type should be used with the PPCODE: directive. The EXTEND() macro is used to make room on the argument stack for 2 return values. The PPCODE: directive causes the B compiler to create a stack pointer called C, and it is this pointer which is being used in the EXTEND() macro. The values are then pushed onto the stack with the PUSHs() macro. Now the rpcb_gettime() function can be used from Perl with the following statement. ($status, $timep) = rpcb_gettime("localhost"); =head2 Returning Undef And Empty Lists Occassionally the programmer will want to simply return C or an empty list if a function fails rather than a separate status value. The rpcb_gettime() function offers just this situation. If the function succeeds we would like to have it return the time and if it fails we would like to have undef returned. In the following Perl code the value of $timep will either be undef or it will be a valid time. $timep = rpcb_gettime( "localhost" ); The following XSUB uses the C return type to disable the generation of the RETVAL variable and uses a CODE: block to indicate to the compiler that the programmer has supplied all the necessary code. The sv_newmortal() call will initialize the return value to undef, making that the default return value. void rpcb_gettime(host) char * host CODE: { time_t timep; bool_t x; ST(0) = sv_newmortal(); if( rpcb_gettime( host, &timep ) ) sv_setnv( ST(0), (double)timep); } The next example demonstrates how one would place an explicit undef in the return value, should the need arise. void rpcb_gettime(host) char * host CODE: { time_t timep; bool_t x; ST(0) = sv_newmortal(); if( rpcb_gettime( host, &timep ) ){ sv_setnv( ST(0), (double)timep); } else{ ST(0) = &sv_undef; } } To return an empty list one must use a PPCODE: block and then not push return values on the stack. void rpcb_gettime(host) char * host PPCODE: { time_t timep; if( rpcb_gettime( host, &timep ) ) PUSHs(sv_2mortal(newSVnv(timep))); else{ /* Nothing pushed on stack, so an empty */ /* list is implicitly returned. */ } } =head2 The CLEANUP: Keyword This keyword can be used when an XSUB requires special cleanup procedures before it terminates. When the CLEANUP: keyword is used it must follow any CODE:, PPCODE:, or OUTPUT: blocks which are present in the XSUB. The code specified for the cleanup block will be added as the last statements in the XSUB. =head2 The BOOT: Keyword The BOOT: keyword is used to add code to the extension's bootstrap function. The bootstrap function is generated by the B compiler and normally holds the statements necessary to register any XSUBs with Perl. With the BOOT: keyword the programmer can tell the compiler to add extra statements to the bootstrap function. This keyword may be used any time after the first MODULE keyword and should appear on a line by itself. The first blank line after the keyword will terminate the code block. BOOT: # The following message will be printed when the # bootstrap function executes. printf("Hello from the bootstrap!\n"); =head2 Inserting Comments and C Preprocessor Directives Comments and C preprocessor directives are allowed within CODE:, PPCODE:, BOOT:, and CLEANUP: blocks. The compiler will pass the preprocessor directives through untouched and will remove the commented lines. Comments can be added to XSUBs by placing a C<#> at the beginning of the line. Care should be taken to avoid making the comment look like a C preprocessor directive, lest it be interpreted as such. =head2 Using XS With C++ If a function is defined as a C++ method then it will assume its first argument is an object pointer. The object pointer will be stored in a variable called THIS. The object should have been created by C++ with the new() function and should be blessed by Perl with the sv_setptrobj() macro. The blessing of the object by Perl can be handled by the T_PTROBJ typemap. If the method is defined as static it will call the C++ function using the class::method() syntax. If the method is not static the function will be called using the THIS->method() syntax. =head2 Perl Variables The following demonstrates how the Perl variable $host can be accessed from an XSUB. The function B is used to obtain a pointer to the variable, known as an B (Scalar Variable) internally. The package name C will be added to the name of the variable so perl_get_sv() will know in which package $host can be found. If the package name is not supplied then perl_get_sv() will search package C

for the variable. The macro B is then used to dereference the SV to obtain a C pointer to its contents. void rpcb_gettime() PPCODE: { char *host; SV *hostsv; time_t timep; hostsv = perl_get_sv( "RPC::host", FALSE ); if( hostsv != NULL ){ host = SvPVX( hostsv ); if( rpcb_gettime( host, &timep ) ) PUSHs(sv_2mortal(newSVnv(timep))); } } This Perl code can be used to call that XSUB. $RPC::host = "localhost"; $timep = rpcb_gettime(); In the above example the SV contained a C C but a Perl scalar variable may also contain numbers and references. If the SV is expected to have a C C then the macro B should be used to dereference the SV. When the SV contains a C double then B should be used. The macro B can be used to dereference an SV when it is a Perl reference. The result will be another SV which points to the actual Perl variable. This can then be dereferenced with SvPVX(), SvNVX(), or SvIVX(). The following XSUB will use SvRV(). void rpcb_gettime() PPCODE: { char *host; SV *rv; SV *hostsv; time_t timep; rv = perl_get_sv( "RPC::host", FALSE ); if( rv != NULL ){ hostsv = SvRV( rv ); host = SvPVX( hostsv ); if( rpcb_gettime( host, &timep ) ) PUSHs(sv_2mortal(newSVnv(timep))); } } This Perl code will create a variable $RPC::host which is a reference to $MY::host. The variable $MY::host contains the hostname which will be used. $MY::host = "localhost"; $RPC::host = \$MY::host; $timep = rpcb_gettime(); The second argument to perl_get_sv() will normally be B as shown in the above examples. An argument of B will cause variables to be created if they do not already exist. One should not use TRUE unless steps are taken to deal with a possibly empty SV. XSUBs may use B, B, and B to access Perl arrays, hashes, and code values. =head2 Interface Stategy When designing an interface between Perl and a C library a straight translation from C to XS is often sufficient. The interface will often be very C-like and occasionally nonintuitive, especially when the C function modifies one of its parameters. In cases where the programmer wishes to create a more Perl-like interface the following strategy may help to identify the more critical parts of the interface. Identify the C functions which modify their parameters. The XSUBs for these functions may be able to return lists to Perl, or may be candidates to return undef or an empty list in case of failure. Identify which values are used only by the C and XSUB functions themselves. If Perl does not need to access the contents of the value then it may not be necessary to provide a translation for that value from C to Perl. Identify the pointers in the C function parameter lists and return values. Some pointers can be handled in XS with the & unary operator on the variable name while others will require the use of the * operator on the type name. In general it is easier to work with the & operator. Identify the structures used by the C functions. In many cases it may be helpful to use the T_PTROBJ typemap for these structures so they can be manipulated by Perl as blessed objects. =head2 The Perl Module The Perl module is the link between the extension library, which was generated from XS code, and the Perl interpreter. The module is used to tell Perl what the extension library contains. The name and package of the module should match the name of the library. The following is a Perl module for an extension containing some ONC+ RPC bind library functions. package RPC; require Exporter; require DynaLoader; @ISA = qw(Exporter DynaLoader); @EXPORT = qw( rpcb_gettime rpcb_getmaps rpcb_getaddr rpcb_rmtcall rpcb_set rpcb_unset ); bootstrap RPC; 1; The RPC extension contains the functions found in the @EXPORT list. By using the C module the RPC module can make these function names visible to the rest of the Perl program. The C module will allow the RPC module to bootstrap the extension library. To load this extension and make the functions available, the following Perl statement should be used. use RPC; For more information about the DynaLoader consult its documentation in the ext/DynaLoader directory in the Perl source. =head2 Perl Objects And C Structures When dealing with C structures one should select either B or B for the XS type. Both types are designed to handle pointers to complex objects. The T_PTRREF type will allow the Perl object to be unblessed while the T_PTROBJ type requires that the object be blessed. By using T_PTROBJ one can achieve a form of type-checking since the XSUB will attempt to verify that the Perl object is of the expected type. The following XS code shows the getnetconfigent() function which is used with ONC TIRPC. The getnetconfigent() function will return a pointer to a C structure and has the C prototype shown below. The example will demonstrate how the C pointer will become a Perl reference. Perl will consider this reference to be a pointer to a blessed object and will attempt to call a destructor for the object. A destructor will be provided in the XS source to free the memory used by getnetconfigent(). Destructors in XS can be created by specifying an XSUB function whose name ends with the word B. XS destructors can be used to free memory which may have been malloc'd by another XSUB. struct netconfig *getnetconfigent(const char *netid); A C will be created for C. The Perl object will be blessed in a class matching the name of the C type, with the tag C appended, and the name should not have embedded spaces if it will be a Perl package name. The destructor will be placed in a class corresponding to the class of the object and the PREFIX keyword will be used to trim the name to the word DESTROY as Perl will expect. typedef struct netconfig Netconfig; MODULE = RPC PACKAGE = RPC Netconfig * getnetconfigent(netid) char * netid MODULE = RPC PACKAGE = NetconfigPtr PREFIX = rpcb_ void rpcb_DESTROY(netconf) Netconfig * netconf CODE: printf("Now in NetconfigPtr::DESTROY\n"); free( netconf ); This example requires the following typemap entry. Consult the typemap section for more information about adding new typemaps for an extension. TYPEMAP Netconfig * T_PTROBJ This example will be used with the following Perl statements. use RPC; $netconf = getnetconfigent("udp"); When Perl destroys the object referenced by $netconf it will send the object to the supplied XSUB DESTROY function. Perl cannot determine, and does not care, that this object is a C struct and not a Perl object. In this sense, there is no difference between the object created by the getnetconfigent() XSUB and an object created by a normal Perl subroutine. =head2 C Headers and Perl The B compiler is designed to convert C header files in /usr/include into Perl extensions. This compiler will create a directory under the C directory of the Perl source and will populate it with a Makefile, a Perl Module, an XS source file, and a MANIFEST file. The following command will create an extension called C from the header. h2xs rpcsvc/rusers When the Rusers extension has been compiled and installed Perl can use it to retrieve any C<#define> statements which were in the C header. use Rusers; print "RPC program number for rusers service: "; print &RUSERSPROG, "\n"; =head2 Creating A New Extension The B compiler can generate template source files and Makefiles. These templates offer a suitable starting point for most extensions. The following example demonstrates how one might use B to create an extension containing the RPC functions in this document. The extension will not use autoloaded functions and will not define constants, so the B<-A> option will be given to B. When run from the Perl source directory, the B compiler will create the directory ext/RPC and will populate it with files called RPC.xs, RPC.pm, Makefile.PL, and MANIFEST. The XS code for the RPC functions should be added to the RPC.xs file. The @EXPORT list in RPC.pm should be updated to include the functions from RPC.xs. h2xs -An RPC To compile the extension for dynamic loading the following command should be executed from the ext/RPC directory. make dynamic If the extension will be statically linked into the Perl binary then the makefile (use C, not C) in the Perl source directory should be edited to add C to the C variable. Before making this change Perl should have already been built. After the makefile has been updated the following command should be executed from the Perl source directory. make Perl's B script can also be used to add extensions. The extension should be placed in the C directory under the Perl source before Perl has been built and prior to running Configure. When Configure is run it will find the extension along with the other extensions in the C directory and will add it to the list of extensions to be built. When make is run the extension will be built along with the other extensions. Configure recognizes extensions if they have an XS source file which matches the name of the extension directory. If the extension directory includes a MANIFEST file Configure will search that file for any B<.SH> files and extract them after it extracts all the other .SH files listed in the main MANIFEST. The main Perl Makefile will then run B in the extension's directory if it finds an XS file matching the name of the extension's directory. =head2 The Typemap The typemap is a collection of code fragments which are used by the B compiler to map C function parameters and values to Perl values. The typemap file may consist of three sections labeled C, C, and C. The INPUT section tells the compiler how to translate Perl values into variables of certain C types. The OUTPUT section tells the compiler how to translate the values from certain C types into values Perl can understand. The TYPEMAP section tells the compiler which of the INPUT and OUTPUT code fragments should be used to map a given C type to a Perl value. Each of the sections of the typemap must be preceded by one of the TYPEMAP, INPUT, or OUTPUT keywords. The default typemap in the C directory of the Perl source contains many useful types which can be used by Perl extensions. Some extensions define additional typemaps which they keep in their own directory. These additional typemaps may reference INPUT and OUTPUT maps in the main typemap. The B compiler will allow the extension's own typemap to override any mappings which are in the default typemap. Most extensions which require a custom typemap will need only the TYPEMAP section of the typemap file. The custom typemap used in the getnetconfigent() example shown earlier demonstrates what may be the typical use of extension typemaps. That typemap is used to equate a C structure with the T_PTROBJ typemap. The typemap used by getnetconfigent() is shown here. Note that the C type is separated from the XS type with a tab and that the C unary operator C<*> is considered to be a part of the C type name. TYPEMAP Netconfig *T_PTROBJ =head1 EXAMPLES File C: Interface to some ONC+ RPC bind library functions. #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include typedef struct netconfig Netconfig; MODULE = RPC PACKAGE = RPC void rpcb_gettime(host="localhost") char * host CODE: { time_t timep; ST(0) = sv_newmortal(); if( rpcb_gettime( host, &timep ) ) sv_setnv( ST(0), (double)timep ); } Netconfig * getnetconfigent(netid="udp") char * netid MODULE = RPC PACKAGE = NetconfigPtr PREFIX = rpcb_ void rpcb_DESTROY(netconf) Netconfig * netconf CODE: printf("NetconfigPtr::DESTROY\n"); free( netconf ); File C: Custom typemap for RPC.xs. TYPEMAP Netconfig * T_PTROBJ File C: Perl module for the RPC extension. package RPC; require Exporter; require DynaLoader; @ISA = qw(Exporter DynaLoader); @EXPORT = qw(rpcb_gettime getnetconfigent); bootstrap RPC; 1; File C: Perl test program for the RPC extension. use RPC; $netconf = getnetconfigent(); $a = rpcb_gettime(); print "time = $a\n"; print "netconf = $netconf\n"; $netconf = getnetconfigent("tcp"); $a = rpcb_gettime("poplar"); print "time = $a\n"; print "netconf = $netconf\n"; =head1 AUTHOR Dean Roehrich September 27, 1994 r to a C structure and has the C prototype shown below. The example will demonstrate how the C pointer will become a Perl reference. Perl will consider this reference to be a pointer to a blessed object and will attempt to call a destructoperl5.000/pod/perlbook.pod 664 203 12 1137 5650412643 10536 =head1 NAME perlbook - Perl book information =head1 DESCRIPTION You can order Perl books from O'Reilly & Associates, 1-800-998-9938. Local/overseas is 1-707-829-0515. If you can locate an O'Reilly order form, you can also fax to 1-707-829-0104. I is a reference work that covers nearly all of Perl (version 4, alas), while I is a tutorial that covers the most frequently used subset of the language. Programming Perl (the Camel Book): ISBN 0-937175-64-1 (English) ISBN 4-89052-384-7 (Japanese) Learning Perl (the Llama Book): ISBN 1-56592-042-2 (English) m O'Reilly & Associates, 1-800-998-9938. Local/overseas is 1-707-829-0515. If you can locate an O'Reilly order form, you can also fax to 1-707-829-0104. I is a reference work that covers nearly all of Perl (version 4, alas), while I is a tutorial that covers the most frequently used subset of the language. Programming Perl (the Camel Book): ISBN 0-937175-64-1 (English) ISBperl5.000/pod/perlbot.pod 664 203 12 16367 5650550624 10425 =head1 NAME perlbot - Bag'o Object Tricks For Perl5 (the BOT) =head1 INTRODUCTION The following collection of tricks and hints is intended to whet curious appetites about such things as the use of instance variables and the mechanics of object and class relationships. The reader is encouraged to consult relevant textbooks for discussion of Object Oriented definitions and methodology. This is not intended as a comprehensive guide to Perl5's object oriented features, nor should it be construed as a style guide. The Perl motto still holds: There's more than one way to do it. =head1 INSTANCE VARIABLES An anonymous array or anonymous hash can be used to hold instance variables. Named parameters are also demonstrated. package Foo; sub new { my $type = shift; my %params = @_; my $self = {}; $self->{'High'} = $params{'High'}; $self->{'Low'} = $params{'Low'}; bless $self; } package Bar; sub new { my $type = shift; my %params = @_; my $self = []; $self->[0] = $params{'Left'}; $self->[1] = $params{'Right'}; bless $self; } package main; $a = new Foo ( 'High' => 42, 'Low' => 11 ); print "High=$a->{'High'}\n"; print "Low=$a->{'Low'}\n"; $b = new Bar ( 'Left' => 78, 'Right' => 40 ); print "Left=$b->[0]\n"; print "Right=$b->[1]\n"; =head1 SCALAR INSTANCE VARIABLES An anonymous scalar can be used when only one instance variable is needed. package Foo; sub new { my $type = shift; my $self; $self = shift; bless \$self; } package main; $a = new Foo 42; print "a=$$a\n"; =head1 INSTANCE VARIABLE INHERITANCE This example demonstrates how one might inherit instance variables from a superclass for inclusion in the new class. This requires calling the superclass's constructor and adding one's own instance variables to the new object. package Bar; sub new { my $self = {}; $self->{'buz'} = 42; bless $self; } package Foo; @ISA = qw( Bar ); sub new { my $self = new Bar; $self->{'biz'} = 11; bless $self; } package main; $a = new Foo; print "buz = ", $a->{'buz'}, "\n"; print "biz = ", $a->{'biz'}, "\n"; =head1 OBJECT RELATIONSHIPS The following demonstrates how one might implement "containing" and "using" relationships between objects. package Bar; sub new { my $self = {}; $self->{'buz'} = 42; bless $self; } package Foo; sub new { my $self = {}; $self->{'Bar'} = new Bar (); $self->{'biz'} = 11; bless $self; } package main; $a = new Foo; print "buz = ", $a->{'Bar'}->{'buz'}, "\n"; print "biz = ", $a->{'biz'}, "\n"; =head1 OVERRIDING SUPERCLASS METHODS The following example demonstrates how one might override a superclass method and then call the method after it has been overridden. The Foo::Inherit class allows the programmer to call an overridden superclass method without actually knowing where that method is defined. package Buz; sub goo { print "here's the goo\n" } package Bar; @ISA = qw( Buz ); sub google { print "google here\n" } package Baz; sub mumble { print "mumbling\n" } package Foo; @ISA = qw( Bar Baz ); @Foo::Inherit::ISA = @ISA; # Access to overridden methods. sub new { bless [] } sub grr { print "grumble\n" } sub goo { my $self = shift; $self->Foo::Inherit::goo(); } sub mumble { my $self = shift; $self->Foo::Inherit::mumble(); } sub google { my $self = shift; $self->Foo::Inherit::google(); } package main; $foo = new Foo; $foo->mumble; $foo->grr; $foo->goo; $foo->google; =head1 USING RELATIONSHIP WITH SDBM This example demonstrates an interface for the SDBM class. This creates a "using" relationship between the SDBM class and the new class Mydbm. use SDBM_File; use POSIX; package Mydbm; sub TIEHASH { my $self = shift; my $ref = SDBM_File->new(@_); bless {'dbm' => $ref}; } sub FETCH { my $self = shift; my $ref = $self->{'dbm'}; $ref->FETCH(@_); } sub STORE { my $self = shift; if (defined $_[0]){ my $ref = $self->{'dbm'}; $ref->STORE(@_); } else { die "Cannot STORE an undefined key in Mydbm\n"; } } package main; tie %foo, Mydbm, "Sdbm", O_RDWR|O_CREAT, 0640; $foo{'bar'} = 123; print "foo-bar = $foo{'bar'}\n"; tie %bar, Mydbm, "Sdbm2", O_RDWR|O_CREAT, 0640; $bar{'Cathy'} = 456; print "bar-Cathy = $bar{'Cathy'}\n"; =head1 THINKING OF CODE REUSE One strength of Object-Oriented languages is the ease with which old code can use new code. The following examples will demonstrate first how one can hinder code reuse and then how one can promote code reuse. This first example illustrates a class which uses a fully-qualified method call to access the "private" method BAZ(). The second example will show that it is impossible to override the BAZ() method. package FOO; sub new { bless {} } sub bar { my $self = shift; $self->FOO::private::BAZ; } package FOO::private; sub BAZ { print "in BAZ\n"; } package main; $a = FOO->new; $a->bar; Now we try to override the BAZ() method. We would like FOO::bar() to call GOOP::BAZ(), but this cannot happen since FOO::bar() explicitly calls FOO::private::BAZ(). package FOO; sub new { bless {} } sub bar { my $self = shift; $self->FOO::private::BAZ; } package FOO::private; sub BAZ { print "in BAZ\n"; } package GOOP; @ISA = qw( FOO ); sub new { bless {} } sub BAZ { print "in GOOP::BAZ\n"; } package main; $a = GOOP->new; $a->bar; To create reusable code we must modify class FOO, flattening class FOO::private. The next example shows a reusable class FOO which allows the method GOOP::BAZ() to be used in place of FOO::BAZ(). package FOO; sub new { bless {} } sub bar { my $self = shift; $self->BAZ; } sub BAZ { print "in BAZ\n"; } package GOOP; @ISA = qw( FOO ); sub new { bless {} } sub BAZ { print "in GOOP::BAZ\n"; } package main; $a = GOOP->new; $a->bar; =head1 CLASS CONTEXT AND THE OBJECT Use the object to solve package and class context problems. Everything a method needs should be available via the object or should be passed as a parameter to the method. A class will sometimes have static or global data to be used by the methods. A subclass may want to override that data and replace it with new data. When this happens the superclass may not know how to find the new copy of the data. This problem can be solved by using the object to define the context of the method. Let the method look in the object for a reference to the data. The alternative is to force the method to go hunting for the data ("Is it in my class, or in a subclass? Which subclass?"), and this can be inconvenient and will lead to hackery. It is better to just let the object tell the method where that data is located. package Bar; %fizzle = ( 'Password' => 'XYZZY' ); sub new { my $self = {}; $self->{'fizzle'} = \%fizzle; bless $self; } sub enter { my $self = shift; # Don't try to guess if we should use %Bar::fizzle # or %Foo::fizzle. The object already knows which # we should use, so just ask it. # my $fizzle = $self->{'fizzle'}; print "The word is ", $fizzle->{'Password'}, "\n"; } package Foo; @ISA = qw( Bar ); %fizzle = ( 'Password' => 'Rumple' ); sub new { my $self = Bar->new; $self->{'fizzle'} = \%fizzle; bless $self; } package main; $a = Bar->new; $b = Foo->new; $a->enter; $b->enter; and class relationships. The reader is encouraged to consult relevant textbooks for discussion of Object Oriented definitions and methodology. This is not intended as a comprehensive guide to Perl5's object oriented features, nor should it be construed as a styleperl5.000/pod/perlcall.pod 664 203 12 52112 5650551512 10535 =head1 NAME perlcall - Perl calling conventions from C =head1 DESCRIPTION B The purpose of this document is to show you how to write I, i.e. how to call Perl from C. The main focus is on how to interface back to Perl from a bit of C code that has itself been run by Perl, i.e. the 'main' program is a Perl script; you are using it to execute a section of code written in C; that bit of C code wants you to do something with a particular event, so you want a Perl sub to be executed whenever it happens. Examples where this is necessary include =over 5 =item * You have created an XSUB interface to an application's C API. A fairly common feature in applications is to allow you to define a C function that will get called whenever something nasty occurs. What we would like is for a Perl sub to be called instead. =item * The classic example of where callbacks are used is in an event driven program like for X-windows. In this case your register functions to be called whenever a specific events occur, e.g. a mouse button is pressed. =back Although the techniques described are applicable to embedding Perl in a C program, this is not the primary goal of this document. For details on embedding Perl in C refer to L (currently unwritten). Before you launch yourself head first into the rest of this document, it would be a good idea to have read the following two documents - L and L. This stuff is easier to explain using examples. But first here are a few definitions anyway. =head2 Definitions Perl has a number of C functions which allow you to call Perl subs. They are I32 perl_call_sv(SV* sv, I32 flags) ; I32 perl_call_pv(char *subname, I32 flags) ; I32 perl_call_method(char *methname, I32 flags) ; I32 perl_call_argv(char *subname, I32 flags, register char **argv) ; The key function is I. All the other functions make use of I to do what they do. I takes two parameters, the first is an SV*. This allows you to specify the Perl sub to be called either as a C string (which has first been converted to an SV) or a reference to a sub. Example 7, shows you how you can make use of I. The second parameter, C, is a general purpose option command. This parameter is common to all the I functions. It is discussed in the next section. The function, I, is similar as I except it expects it's first parameter has to be a C char* which identifies the Perl sub you want to call, e.g. C. The function I expects its first argument to contain a blessed reference to a class. Using that reference it looks up and calls C from that class. See example 9. I calls the Perl sub specified by the C parameter. It also takes the usual C parameter. The final parameter, C, consists of a list of C strings to be sent to the Perl sub. See example 8. All the functions return a number. This is a count of the number of items returned by the Perl sub on the stack. As a general rule you should I check the return value from these functions. Even if you are only expecting a particular number of values to be returned from the Perl sub, there is nothing to stop someone from doing something unexpected - don't say you havn't been warned. =head2 Flag Values The C parameter in all the I functions consists of any combination of the symbols defined below, OR'ed together. =over 5 =item G_SCALAR Calls the Perl sub in a scalar context. Whatever the Perl sub actually returns, we only want a scalar. If the perl sub does return a scalar, the return value from the I function will be 1 or 0. If 1, then the value actually returned by the Perl sub will be contained on the top of the stack. If 0, then the sub has probably called I or you have used the G_DISCARD flag. If the Perl sub returns a list, the I function will still only return 1 or 0. If 1, then the number of elements in the list will be stored on top of the stack. The actual values of the list will not be accessable. G_SCALAR is the default flag setting for all the functions. =item G_ARRAY Calls the Perl sub in a list context. The return code from the I functions will indicate how many elements of the stack are used to store the array. =item G_DISCARD If you are not interested in the values returned by the Perl sub then setting this flag will make Perl get rid of them automatically for you. This will take precedence to either G_SCALAR or G_ARRAY. If you do not set this flag then you may need to explicitly get rid of temporary values. See example 3 for details. =item G_NOARGS If you are not passing any parameters to the Perl sub, you can save a bit of time by setting this flag. It has the effect of of not creating the C<@_> array for the Perl sub. A point worth noting is that if this flag is specified the Perl sub called can still access an C<@_> array from a previous Perl sub. This functionality can be illustrated with the perl code below sub fred { print "@_\n" } sub joe { &fred } &joe(1,2,3) ; This will print 1 2 3 What has happened is that C accesses the C<@_> array which belongs to C. =item G_EVAL If the Perl sub you are calling has the ability to terminate abnormally, e.g. by calling I or by not actually existing, and you want to catch this type of event, specify this flag setting. It will put an I around the sub call. Whenever control returns from the I function you need to check the C<$@> variable as you would in a normal Perl script. See example 6 for details of how to do this. =back =head1 EXAMPLES Enough of the definition talk, let's have a few examples. Perl provides many macros to assist in accessing the Perl stack. These macros should always be used when interfacing to Perl internals. Hopefully this should make the code less vulnerable to changes made to Perl in the future. Another point worth noting is that in the first series of examples I have only made use of the I function. This has only been done to ease you into the topic. Wherever possible, if the choice is between using I and I, I would always try to use I. The code for these examples is stored in the file F. (Once this document settles down, all the example code will be available in the file). =head2 Example1: No Parameters, Nothing returned This first trivial example will call a Perl sub, I, to print out the UID of the process. sub PrintUID { print "UID is $<\n" ; } and here is the C to call it void call_PrintUID() { dSP ; PUSHMARK(sp) ; perl_call_pv("PrintUID", G_DISCARD|G_NOARGS) ; } Simple, eh. A few points to note about this example. =over 5 =item 1. We aren't passing any parameters to I so G_NOARGS can be specified. =item 2. Ignore C and C for now. They will be discussed in the next example. =item 3. We aren't interested in anything returned from I, so G_DISCARD is specified. Even if I was changed to actually return some value(s), having specified G_DISCARD will mean that they will be wiped by the time control returns from I. =item 4. Because we specified G_DISCARD, it is not necessary to check the value returned from I. It will always be 0. =item 5. As I is being used, the Perl sub is specified as a C string. =back =head2 Example 2: Passing Parameters Now let's make a slightly more complex example. This time we want to call a Perl sub which will take 2 parameters - a string (C<$s>) and an integer (C<$n>). The sub will simply print the first C<$n> characters of the string. So the Perl sub would look like this sub LeftString { my($s, $n) = @_ ; print substr($s, 0, $n), "\n" ; } The C function required to call I would look like this. static void call_LeftString(a, b) char * a ; int b ; { dSP ; PUSHMARK(sp) ; XPUSHs(sv_2mortal(newSVpv(a, 0))); XPUSHs(sv_2mortal(newSViv(b))); PUTBACK ; perl_call_pv("LeftString", G_DISCARD); } Here are a few notes on the C function I. =over 5 =item 1. The only flag specified this time is G_DISCARD. As we are passing 2 parameters to the Perl sub this time, we have not specified G_NOARGS. =item 2. Parameters are passed to the Perl sub using the Perl stack. This is the purpose of the code beginning with the line C and ending with the line C. =item 3. If you are going to put something onto the Perl stack, you need to know where to put it. This is the purpose of the macro C - it declares and initialises a local copy of the Perl stack pointer. All the other macros which will be used in this example require you to have used this macro. If you are calling a Perl sub directly from an XSUB function, it is not necessary to explicitly use the C macro - it will be declared for you. =item 4. Any parameters to be pushed onto the stack should be bracketed by the C and C macros. The purpose of these two macros, in this context, is to automatically count the number of parameters you are pushing. Then whenever Perl is creating the C<@_> array for the sub, it knows how big to make it. The C macro tells Perl to make a mental note of the current stack pointer. Even if you aren't passing any parameters (like in Example 1) you must still call the C macro before you can call any of the I functions - Perl still needs to know that there are no parameters. The C macro sets the global copy of the stack pointer to be the same as our local copy. If we didn't do this I wouldn't know where the two parameters we pushed were - remember that up to now all the stack pointer manipulation we have done is with our local copy, I the global copy. =item 5. Next, we come to XPUSHs. This is where the parameters actually get pushed onto the stack. In this case we are pushing a string and an integer. See the section I in L for details on how the XPUSH macros work. =item 6. Finally, I can now be called via the I function. =back =head2 Example 3: Returning a Scalar Now for an example of dealing with the values returned from a Perl sub. Here is a Perl sub, I, which takes 2 integer parameters and simply returns their sum. sub Adder { my($a, $b) = @_ ; $a + $b ; } As we are now concerned with the return value from I, the C function is now a bit more complex. static void call_Adder(a, b) int a ; int b ; { dSP ; int count ; ENTER ; SAVETMPS; PUSHMARK(sp) ; XPUSHs(sv_2mortal(newSViv(a))); XPUSHs(sv_2mortal(newSViv(b))); PUTBACK ; count = perl_call_pv("Adder", G_SCALAR); SPAGAIN ; if (count != 1) croak("Big trouble\n") ; printf ("The sum of %d and %d is %d\n", a, b, POPi) ; PUTBACK ; FREETMPS ; LEAVE ; } Points to note this time are =over 5 =item 1. The only flag specified this time was G_SCALAR. That means the @_ array will be created and that the value returned by I will still exist after the call to I. =item 2. Because we are interested in what is returned from I we cannot specify G_DISCARD. This means that we will have to tidy up the Perl stack and dispose of any temporary values ourselves. This is the purpose of ENTER ; SAVETMPS ; at the start of the function, and FREETMPS ; LEAVE ; at the end. The C/C pair creates a boundary for any temporaries we create. This means that the temporaries we get rid of will be limited to those which were created after these calls. The C/C pair will get rid of any values returned by the Perl sub, plus it will also dump the mortal SV's we created. Having C/C at the beginning of the code makes sure that no other mortals are destroyed. =item 3. The purpose of the macro C is to refresh the local copy of the stack pointer. This is necessary because it is possible that the memory allocated to the Perl stack has been re-allocated whilst in the I call. If you are making use of the Perl stack pointer in your code you must always refresh the your local copy using SPAGAIN whenever you make use of of the I functions or any other Perl internal function. =item 4. Although only a single value was expected to be returned from I, it is still good practice to check the return code from I anyway. Expecting a single value is not quite the same as knowing that there will be one. If someone modified I to return a list and we didn't check for that possibility and take appropriate action the Perl stack would end up in an inconsistant state. That is something you I don't want to ever happen. =item 5. The C macro is used here to pop the return value from the stack. In this case we wanted an integer, so C was used. Here is the complete list of POP macros available, along with the types they return. POPs SV POPp pointer POPn double POPi integer POPl long =item 6. The final C is used to leave the Perl stack in a consistant state before exiting the function. This is necessary because when we popped the return value from the stack with C it only updated our local copy of the stack pointer. Remember, C sets the global stack pointer to be the same as our local copy. =back =head2 Example 4: Returning a list of values Now, let's extend the previous example to return both the sum of the parameters and the difference. Here is the Perl sub sub AddSubtract { my($a, $b) = @_ ; ($a+$b, $a-$b) ; } and this is the C function static void call_AddSubtract(a, b) int a ; int b ; { dSP ; int count ; ENTER ; SAVETMPS; PUSHMARK(sp) ; XPUSHs(sv_2mortal(newSViv(a))); XPUSHs(sv_2mortal(newSViv(b))); PUTBACK ; count = perl_call_pv("AddSubtract", G_ARRAY); SPAGAIN ; if (count != 2) croak("Big trouble\n") ; printf ("%d - %d = %d\n", a, b, POPi) ; printf ("%d + %d = %d\n", a, b, POPi) ; PUTBACK ; FREETMPS ; LEAVE ; } Notes =over 5 =item 1. We wanted array context, so we used G_ARRAY. =item 2. Not surprisingly there are 2 POPi's this time because we were retrieving 2 values from the stack. The main point to note is that they came off the stack in reverse order. =back =head2 Example 5: Returning Data from Perl via the parameter list It is also possible to return values directly via the parameter list - whether it is actually desirable to do it is another matter entirely. The Perl sub, I, below takes 2 parameters and increments each. sub Inc { ++ $_[0] ; ++ $_[1] ; } and here is a C function to call it. static void call_Inc(a, b) int a ; int b ; { dSP ; int count ; SV * sva ; SV * svb ; ENTER ; SAVETMPS; sva = sv_2mortal(newSViv(a)) ; svb = sv_2mortal(newSViv(b)) ; PUSHMARK(sp) ; XPUSHs(sva); XPUSHs(svb); PUTBACK ; count = perl_call_pv("Inc", G_DISCARD); if (count != 0) croak ("call_Inc : expected 0 return value from 'Inc', got %d\n", count) ; printf ("%d + 1 = %d\n", a, SvIV(sva)) ; printf ("%d + 1 = %d\n", b, SvIV(svb)) ; FREETMPS ; LEAVE ; } To be able to access the two parameters that were pushed onto the stack after they return from I it is necessary to make a note of their addresses - thus the two variables C and C. The reason this is necessary is that the area of the Perl stack which held them will very likely have been overwritten by something else by the time control returns from I. =head2 Example 6: Using G_EVAL Now an example using G_EVAL. Below is a Perl sub which computes the difference of its 2 parameters. If this would result in a negative result, the sub calls I. sub Subtract { my ($a, $b) = @_ ; die "death can be fatal\n" if $a < $b ; $a - $b ; } and some C to call it static void call_Subtract(a, b) int a ; int b ; { dSP ; int count ; SV * sv ; ENTER ; SAVETMPS; PUSHMARK(sp) ; XPUSHs(sv_2mortal(newSViv(a))); XPUSHs(sv_2mortal(newSViv(b))); PUTBACK ; count = perl_call_pv("Subtract", G_EVAL|G_SCALAR); /* Check the eval first */ sv = GvSV(gv_fetchpv("@", TRUE, SVt_PV)); if (SvTRUE(sv)) printf ("Uh oh - %s\n", SvPV(sv, na)) ; SPAGAIN ; if (count != 1) croak ("call_Subtract : expected 1 return value from 'Subtract', got %d\n", count) ; printf ("%d - %d = %d\n", a, b, POPi) ; PUTBACK ; FREETMPS ; LEAVE ; } If I is called thus call_Subtract(4, 5) the following will be printed Uh oh - death can be fatal Notes =over 5 =item 1. We want to be able to catch the I so we have used the G_EVAL flag. Not specifying this flag would mean that the program would terminate. =item 2. The code sv = GvSV(gv_fetchpv("@", TRUE, SVt_PV)); if (SvTRUE(sv)) printf ("Uh oh - %s\n", SvPVx(sv, na)) ; is the equivalent of this bit of Perl print "Uh oh - $@\n" if $@ ; =back =head2 Example 7: Using perl_call_sv In all the previous examples I have 'hard-wried' the name of the Perl sub to be called from C. Sometimes though, it is necessary to be able to specify the name of the Perl sub from within the Perl script. Consider the Perl code below sub fred { print "Hello there\n" ; } CallSub("fred") ; here is a snippet of XSUB which defines I. void CallSub(name) char * name CODE: PUSHMARK(sp) ; perl_call_pv(name, G_DISCARD|G_NOARGS) ; That is fine as far as it goes. The thing is, it only allows the Perl sub to be specified as a string. For perl 4 this was adequate, but Perl 5 allows references to subs and anonymous subs. This is where I is useful. The code below for I is identical to the previous time except that the C parameter is now defined as an SV* and we use I instead of I. void CallSub(name) SV* name CODE: PUSHMARK(sp) ; perl_call_sv(name, G_DISCARD|G_NOARGS) ; As we are using an SV to call I the following can all be used CallSub("fred") ; Callsub(\&fred) ; $ref = \&fred ; CallSub($ref) ; CallSub( sub { print "Hello there\n" } ) ; As you can see, I gives you greater flexibility in how you can specify the Perl sub. =head2 Example 8: Using perl_call_argv Here is a Perl sub which prints whatever parameters are passed to it. sub PrintList { my(@list) = @_ ; foreach (@list) { print "$_\n" } } and here is an example of I which will call I. call_PrintList { dSP ; char * words[] = {"alpha", "beta", "gamma", "delta", NULL } ; perl_call_argv("PrintList", words, G_DISCARD) ; } Note that it is not necessary to call C in this instance. This is because I will do it for you. =head2 Example 9: Using perl_call_method [This section is under construction] Consider the following Perl code { package Mine ; sub new { bless [@_] } sub Display { print $_[0][1], "\n" } } $a = new Mine ('red', 'green', 'blue') ; call_Display($a, 'Display') ; The method C just prints out the first element of the list. Here is a XSUB implementation of I. void call_Display(ref, method) SV * ref char * method CODE: PUSHMARK(sp); XPUSHs(ref); PUTBACK; perl_call_method(method, G_DISCARD) ; =head2 Strategies for storing Context Information [This section is under construction] One of the trickiest problems to overcome when designing a callback interface is figuring out how to store the mapping between the C callback functions and the Perl equivalent. Consider the following example. =head2 Alternate Stack Manipulation [This section is under construction] Although I have only made use of the POP* macros to access values returned from Perl subs, it is also possible to bypass these macros and read the stack directly. The code below is example 4 recoded to =head1 SEE ALSO L, L, L =head1 AUTHOR Paul Marquess Special thanks to the following people who assisted in the creation of the document. Jeff Okamoto, Tim Bunce. =head1 DATE Version 0.4, 17th October 1994 ssibility and take appropriate action the Perl stack would end up in an inconsistant state. That is something you I don't want to ever happen. =item 5. The C macro is used here to pop the return value from the stack. In this case we wanted an integer, so C was used. Here is the complete list of POP macros available, along with the types they return. POPs SV POPp pointer POPn double POPi integer POPl lonperl5.000/pod/perldata.pod 664 203 12 40316 5650550114 10533 =head1 NAME perldata - Perl data structures =head1 DESCRIPTION =head2 Variable names Perl has three data structures: scalars, arrays of scalars, and associative arrays of scalars, known as "hashes". Normal arrays are indexed by number, starting with 0. (Negative subscripts count from the end.) Hash arrays are indexed by string. Scalar values are always named with '$', even when referring to a scalar that is part of an array. It works like the English word "the". Thus we have: $days # the simple scalar value "days" $days[28] # the 29th element of array @days $days{'Feb'} # the 'Feb' value from hash %days $#days # the last index of array @days but entire arrays or array slices are denoted by '@', which works much like the word "these" or "those": @days # ($days[0], $days[1],... $days[n]) @days[3,4,5] # same as @days[3..5] @days{'a','c'} # same as ($days{'a'},$days{'c'}) and entire hashes are denoted by '%': %days # (key1, val1, key2, val2 ...) In addition, subroutines are named with an initial '&', though this is optional when it's otherwise unambiguous (just as "do" is often redundant in English). Symbol table entries can be named with an initial '*', but you don't really care about that yet. Every variable type has its own namespace. You can, without fear of conflict, use the same name for a scalar variable, an array, or a hash (or, for that matter, a filehandle, a subroutine name, or a label). This means that $foo and @foo are two different variables. It also means that $foo[1] is a part of @foo, not a part of $foo. This may seem a bit weird, but that's okay, because it is weird. Since variable and array references always start with '$', '@', or '%', the "reserved" words aren't in fact reserved with respect to variable names. (They ARE reserved with respect to labels and filehandles, however, which don't have an initial special character. You can't have a filehandle named "log", for instance. Hint: you could say C rather than C. Using uppercase filehandles also improves readability and protects you from conflict with future reserved words.) Case I significant--"FOO", "Foo" and "foo" are all different names. Names that start with a letter or underscore may also contain digits and underscores. It is possible to replace such an alphanumeric name with an expression that returns a reference to an object of that type. For a description of this, see L. Names that start with a digit may only contain more digits. Names which do not start with a letter, underscore, or digit are limited to one character, e.g. "$%" or "$$". (Most of these one character names have a predefined significance to Perl. For instance, $$ is the current process id.) =head2 Context The interpretation of operations and values in Perl sometimes depends on the requirements of the context around the operation or value. There are two major contexts: scalar and list. Certain operations return list values in contexts wanting a list, and scalar values otherwise. (If this is true of an operation it will be mentioned in the documentation for that operation.) In other words, Perl overloads certain operations based on whether the expected return value is singular or plural. (Some words in English work this way, like "fish" and "sheep".) In a reciprocal fashion, an operation provides either a scalar or a list context to each of its arguments. For example, if you say int( ) the integer operation provides a scalar context for the operator, which responds by reading one line from STDIN and passing it back to the integer operation, which will then find the integer value of that line and return that. If, on the other hand, you say sort( ) then the sort operation provides a list context for , which will proceed to read every line available up to the end of file, and pass that list of lines back to the sort routine, which will then sort those lines and return them as a list to whatever the context of the sort was. Assignment is a little bit special in that it uses its left argument to determine the context for the right argument. Assignment to a scalar evaluates the righthand side in a scalar context, while assignment to an array or array slice evaluates the righthand side in a list context. Assignment to a list also evaluates the righthand side in a list context. User defined subroutines may choose to care whether they are being called in a scalar or list context, but most subroutines do not need to care, because scalars are automatically interpolated into lists. See L. =head2 Scalar values Scalar variables may contain various kinds of singular data, such as numbers, strings and references. In general, conversion from one form to another is transparent. (A scalar may not contain multiple values, but may contain a reference to an array or hash containing multiple values.) Because of the automatic conversion of scalars, operations and functions that return scalars don't need to care (and, in fact, can't care) whether the context is looking for a string or a number. A scalar value is interpreted as TRUE in the Boolean sense if it is not the null string or the number 0 (or its string equivalent, "0"). The Boolean context is just a special kind of scalar context. There are actually two varieties of null scalars: defined and undefined. Undefined null scalars are returned when there is no real value for something, such as when there was an error, or at end of file, or when you refer to an uninitialized variable or element of an array. An undefined null scalar may become defined the first time you use it as if it were defined, but prior to that you can use the defined() operator to determine whether the value is defined or not. The length of an array is a scalar value. You may find the length of array @days by evaluating C<$#days>, as in B. (Actually, it's not the length of the array, it's the subscript of the last element, since there is (ordinarily) a 0th element.) Assigning to C<$#days> changes the length of the array. Shortening an array by this method destroys intervening values. Lengthening an array that was previously shortened I recovers the values that were in those elements. (It used to in Perl 4, but we had to break this make to make sure destructors were called when expected.) You can also gain some measure of efficiency by preextending an array that is going to get big. (You can also extend an array by assigning to an element that is off the end of the array.) You can truncate an array down to nothing by assigning the null list () to it. The following are equivalent: @whatever = (); $#whatever = $[ - 1; If you evaluate a named array in a scalar context, it returns the length of the array. (Note that this is not true of lists, which return the last value, like the C comma operator.) The following is always true: scalar(@whatever) == $#whatever - $[ + 1; Version 5 of Perl changed the semantics of $[: files that don't set the value of $[ no longer need to worry about whether another file changed its value. (In other words, use of $[ is deprecated.) So in general you can just assume that scalar(@whatever) == $#whatever + 1; If you evaluate a hash in a scalar context, it returns a value which is true if and only if the hash contains any key/value pairs. (If there are any key/value pairs, the value returned is a string consisting of the number of used buckets and the number of allocated buckets, separated by a slash. This is pretty much only useful to find out whether Perl's (compiled in) hashing algorithm is performing poorly on your data set. For example, you stick 10,000 things in a hash, but evaluating %HASH in scalar context reveals "1/16", which means only one out of sixteen buckets has been touched, and presumably contains all 10,000 of your items. This isn't supposed to happen.) =head2 Scalar value constructors Numeric literals are specified in any of the customary floating point or integer formats: 12345 12345.67 .23E-10 0xffff # hex 0377 # octal 4_294_967_296 # underline for legibility String literals are delimited by either single or double quotes. They work much like shell quotes: double-quoted string literals are subject to backslash and variable substitution; single-quoted strings are not (except for "C<\'>" and "C<\\>"). The usual Unix backslash rules apply for making characters such as newline, tab, etc., as well as some more exotic forms. See L for a list. You can also embed newlines directly in your strings, i.e. they can end on a different line than they begin. This is nice, but if you forget your trailing quote, the error will not be reported until Perl finds another line containing the quote character, which may be much further on in the script. Variable substitution inside strings is limited to scalar variables, arrays, and array slices. (In other words, identifiers beginning with $ or @, followed by an optional bracketed expression as a subscript.) The following code segment prints out "The price is $100." $Price = '$100'; # not interpreted print "The price is $Price.\n"; # interpreted As in some shells, you can put curly brackets around the identifier to delimit it from following alphanumerics. Also note that a single-quoted string must be separated from a preceding word by a space, since single quote is a valid (though discouraged) character in an identifier (see L). Two special literals are __LINE__ and __FILE__, which represent the current line number and filename at that point in your program. They may only be used as separate tokens; they will not be interpolated into strings. In addition, the token __END__ may be used to indicate the logical end of the script before the actual end of file. Any following text is ignored, but may be read via the DATA filehandle. (The DATA filehandle may read data only from the main script, but not from any required file or evaluated string.) The two control characters ^D and ^Z are synonyms for __END__. A word that doesn't have any other interpretation in the grammar will be treated as if it were a quoted string. These are known as "barewords". As with filehandles and labels, a bareword that consists entirely of lowercase letters risks conflict with future reserved words, and if you use the B<-w> switch, Perl will warn you about any such words. Some people may wish to outlaw barewords entirely. If you say use strict 'subs'; then any bareword that would NOT be interpreted as a subroutine call produces a compile-time error instead. The restriction lasts to the end of the enclosing block. An inner block may countermand this by saying C. Array variables are interpolated into double-quoted strings by joining all the elements of the array with the delimiter specified in the C<$"> variable, space by default. The following are equivalent: $temp = join($",@ARGV); system "echo $temp"; system "echo @ARGV"; Within search patterns (which also undergo double-quotish substitution) there is a bad ambiguity: Is C to be interpreted as C (where C<[bar]> is a character class for the regular expression) or as C (where C<[bar]> is the subscript to array @foo)? If @foo doesn't otherwise exist, then it's obviously a character class. If @foo exists, Perl takes a good guess about C<[bar]>, and is almost always right. If it does guess wrong, or if you're just plain paranoid, you can force the correct interpretation with curly brackets as above. A line-oriented form of quoting is based on the shell "here-doc" syntax. Following a CE> you specify a string to terminate the quoted material, and all lines following the current line down to the terminating string are the value of the item. The terminating string may be either an identifier (a word), or some quoted text. If quoted, the type of quotes you use determines the treatment of the text, just as in regular quoting. An unquoted identifier works like double quotes. There must be no space between the CE> and the identifier. (If you put a space it will be treated as a null identifier, which is valid, and matches the first blank line--see the Merry Christmas example below.) The terminating string must appear by itself (unquoted and with no surrounding whitespace) on the terminating line. print < interpolate, see L. The null list is represented by (). Interpolating it in a list has no effect. Thus ((),(),()) is equivalent to (). Similarly, interpolating an array with no elements is the same as if no array had been interpolated at that point. A list value may also be subscripted like a normal array. You must put the list in parentheses to avoid ambiguity. Examples: # Stat returns list value. $time = (stat($file))[8]; # Find a hex digit. $hexdigit = ('a','b','c','d','e','f')[$digit-10]; # A "reverse comma operator". return (pop(@foo),pop(@foo))[0]; Lists may be assigned to if and only if each element of the list is legal to assign to: ($a, $b, $c) = (1, 2, 3); ($map{'red'}, $map{'blue'}, $map{'green'}) = (0x00f, 0x0f0, 0xf00); The final element may be an array or a hash: ($a, $b, @rest) = split; local($a, $b, %rest) = @_; You can actually put an array anywhere in the list, but the first array in the list will soak up all the values, and anything after it will get a null value. This may be useful in a local() or my(). A hash literal contains pairs of values to be interpreted as a key and a value: # same as map assignment above %map = ('red',0x00f,'blue',0x0f0,'green',0xf00); It is often more readable to use the C<=E> operator between key/value pairs (the C<=E> operator is actually nothing more than a more visually distinctive synonym for a comma): %map = ( 'red' => 0x00f, 'blue' => 0x0f0, 'green' => 0xf00, ); Array assignment in a scalar context returns the number of elements produced by the expression on the right side of the assignment: $x = (($foo,$bar) = (3,2,1)); # set $x to 3, not 2 This is very handy when you want to do a list assignment in a Boolean context, since most list functions return a null list when finished, which when assigned produces a 0, which is interpreted as FALSE. e-quoted string literals are subject to backslash and variable substitution; single-quoted strings are not (except for "C<\'>" and "C<\\>"). The usual Unix backslash rules apply for making characters such as newline, tab, etc., as well as some more exotic forms. See L for a list. You can alsperl5.000/pod/perldebug.pod 664 203 12 14032 5650550115 10705 =head1 NAME perldebug - Perl debugging =head1 DESCRIPTION First of all, have you tried using the B<-w> switch? =head2 Debugging If you invoke Perl with a B<-d> switch, your script will be run under the debugger. However, the Perl debugger is not a separate program as it is in a C environment. Instead, the B<-d> flag tells the compiler to insert source information into the pseudocode it's about to hand to the interpreter. (That means your code must compile correctly for the debugger to work on it.) Then when the interpreter starts up, it pre-loads a Perl library file containing the debugger itself. The program will halt before the first executable statement (but see below) and ask you for one of the following commands: =over 12 =item h Prints out a help message. =item T Stack trace. If you do bizarre things to your @_ arguments in a subroutine, the stack backtrace will not always show the original values. =item s Single step. Executes until it reaches the beginning of another statement. =item n Next. Executes over subroutine calls, until it reaches the beginning of the next statement. =item f Finish. Executes statements until it has finished the current subroutine. =item c Continue. Executes until the next breakpoint is reached. =item c line Continue to the specified line. Inserts a one-time-only breakpoint at the specified line. =item Repeat last n or s. =item l min+incr List incr+1 lines starting at min. If min is omitted, starts where last listing left off. If incr is omitted, previous value of incr is used. =item l min-max List lines in the indicated range. =item l line List just the indicated line. =item l List next window. =item - List previous window. =item w line List window (a few lines worth of code) around line. =item l subname List subroutine. If it's a long subroutine it just lists the beginning. Use "l" to list more. =item /pattern/ Regular expression search forward in the source code for pattern; the final / is optional. =item ?pattern? Regular expression search backward in the source code for pattern; the final ? is optional. =item L List lines that have breakpoints or actions. =item S Lists the names of all subroutines. =item t Toggle trace mode on or off. =item b line [ condition ] Set a breakpoint. If line is omitted, sets a breakpoint on the line that is about to be executed. If a condition is specified, it is evaluated each time the statement is reached and a breakpoint is taken only if the condition is true. Breakpoints may only be set on lines that begin an executable statement. Conditions don't use C: b 237 $x > 30 b 33 /pattern/i =item b subname [ condition ] Set breakpoint at first executable line of subroutine. =item d line Delete breakpoint. If line is omitted, deletes the breakpoint on the line that is about to be executed. =item D Delete all breakpoints. =item a line command Set an action for line. A multiline command may be entered by backslashing the newlines. This command is Perl code, not another debugger command. =item A Delete all line actions. =item < command Set an action to happen before every debugger prompt. A multiline command may be entered by backslashing the newlines. =item > command Set an action to happen after the prompt when you've just given a command to return to executing the script. A multiline command may be entered by backslashing the newlines. =item V package [symbols] Display all (or some) variables in package (defaulting to the C
package) using a data pretty-printer (hashes show their keys and values so you see what's what, control characters are made printable, etc.). Make sure you don't put the type specifier (like $) there, just the symbol names, like this: V DB filename line =item X [symbols] Same as as "V" command, but within the current package. =item ! number Redo a debugging command. If number is omitted, redoes the previous command. =item ! -number Redo the command that was that many commands ago. =item H -number Display last n commands. Only commands longer than one character are listed. If number is omitted, lists them all. =item q or ^D Quit. ("quit" doesn't work for this.) =item command Execute command as a Perl statement. A missing semicolon will be supplied. =item p expr Same as C. The DB::OUT filehandle is opened to /dev/tty, regardless of where STDOUT may be redirected to. =back Any command you type in that isn't recognized by the debugger will be directly executed (C'd) as Perl code. Leading white space will cause the debugger to think it's C a debugger command. If you have any compile-time executable statements (code within a BEGIN block or a C statement), these will I be stopped by debugger, although Cs will. From your own code, however, you can transfer control back to the debugger using the following statement, which is harmless if the debugger is not running: $DB::single = 1; =head2 Customization If you want to modify the debugger, copy F from the Perl library to another name and modify it as necessary. You'll also want to set environment variable PERL5DB to say something like this: BEGIN { require "myperl5db.pl" } You can do some customization by setting up a F<.perldb> file which contains initialization code. For instance, you could make aliases like these (the last one in particular most people seem to expect to be there): $DB::alias{'len'} = 's/^len(.*)/p length($1)/'; $DB::alias{'stop'} = 's/^stop (at|in)/b/'; $DB::alias{'.'} = 's/^\./p ' . '"\$DB::sub(\$DB::filename:\$DB::line):\t"' . ',\$DB::dbline[\$DB::line]/' ; =head2 Other resources You did try the B<-w> switch, didn't you? =head1 BUGS If your program exit()s or die()s, so does the debugger. There's no builtin way to restart the debugger without exiting and coming back into it. You could use an alias like this: $DB::alias{'rerun'} = 'exec "perl -d $DB::filename"'; But you'd lose any pending breakpoint information, and that might not be the right path, etc. map{'blue'}, $map{'green'}) = (0x00f, 0x0f0, 0xf00); The final element may be an array or a hash: ($a, $b, @rest) = split; local($a, $b, %rest) = @_; You can actually put an array anywhere in the list, but the first array in the list will soak up all the values, and anything after it will get a null value. This may be useful in a local() or my(). A hash literal contains pairs of values to be interpreted as a key and a value: # same as map assignment above %mapperl5.000/pod/perldiag.pod 664 203 12 176553 5650550116 10565 =head1 NAME perldiag - various Perl diagnostics =head1 DESCRIPTION These messages are classified as follows (listed in increasing order of desperation): (W) A warning (optional). (D) A deprecation (optional). (S) A severe warning (mandatory). (F) A fatal error (trappable). (P) An internal error you should never see (trappable). (X) A very fatal error (non-trappable). Optional warnings are enabled by using the B<-w> switch. Trappable errors may be trapped using the eval operator. See L. Some of these messages are generic. Spots that vary are denoted with a %s, just as in a printf format. Note that some message start with a %s! The symbols C<"%-?@> sort before the letters, while C<[> and C<\> sort after. =over 4 =item "my" variable %s can't be in a package (F) Lexically scoped variables aren't in a package, so it doesn't make sense to try to declare one with a package qualifier on the front. Use local() if you want to localize a package variable. =item "no" not allowed in expression (F) The "no" keyword is recognized and executed at compile time, and returns no useful value. See L. =item "use" not allowed in expression (F) The "use" keyword is recognized and executed at compile time, and returns no useful value. See L. =item % may only be used in unpack (F) You can't pack a string by supplying a checksum, since the checksumming process loses information, and you can't go the other way. See L. =item %s (...) interpreted as function (W) You've run afoul of the rule that says that any list operator followed by parentheses turns into a function, with all the list operators arguments found inside the parens. See L. =item %s argument is not a HASH element (F) The argument to delete() or exists() must be a hash element, such as $foo{$bar} $ref->[12]->{"susie"} =item %s did not return a true value (F) A required (or used) file must return a true value to indicate that it compiled correctly and ran its initialization code correctly. It's traditional to end such a file with a "1;", though any true value would do. See L. =item %s found where operator expected (S) The Perl lexer knows whether to expect a term or an operator. If it sees what it knows to be a term when it was expecting to see an operator, it gives you this warning. Usually it indicates that an operator or delimiter was omitted, such as a semicolon. =item %s had compilation errors. (F) The final summary message when a C fails. =item %s has too many errors. (F) The parser has given up trying to parse the program after 10 errors. Further error messages would likely be uninformative. =item %s matches null string many times (W) The pattern you've specified would be an infinite loop if the regular expression engine didn't specifically check for that. See L. =item %s never introduced (S) The symbol in question was declared but somehow went out of scope before it could possibly have been used. =item %s syntax OK (F) The final summary message when a C succeeds. =item B<-P> not allowed for setuid/setgid script (F) The script would have to be opened by the C preprocessor by name, which provides a race condition that breaks security. =item C<-T> and C<-B> not implemented on filehandles (F) Perl can't peek at the stdio buffer of filehandles when it doesn't know about your kind of stdio. You'll have to use a filename instead. =item ?+* follows nothing in regexp (F) You started a regular expression with a quantifier. Backslash it if you meant it literally. See L. =item @ outside of string (F) You had a pack template that specified an absolution position outside the string being unpacked. See L. =item accept() on closed fd (W) You tried to do an accept on a closed socket. Did you forget to check the return value of your socket() call? See L. =item Allocation too large: %lx (F) You can't allocate more than 64K on an MSDOS machine. =item Arg too short for msgsnd (F) msgsnd() requires a string at least as long as sizeof(long). =item Args must match #! line (F) The setuid emulator requires that the arguments Perl was invoked with match the arguments specified on the #! line. =item Argument "%s" isn't numeric (W) The indicated string was fed as an argument to an operator that expected a numeric value instead. If you're fortunate the message will identify which operator was so unfortunate. =item Array @%s missing the @ in argument %d of %s() (D) Really old Perl let you omit the @ on array names in some spots. This is now heavily deprecated. =item assertion botched: %s (P) The malloc package that comes with Perl had an internal failure. =item Assertion failed: file "%s" (P) A general assertion failed. The file in question must be examined. =item Assignment to both a list and a scalar (F) If you assign to a conditional operator, the 2nd and 3rd arguments must either both be scalars or both be lists. Otherwise Perl won't know which context to supply to the right side. =item Attempt to free non-arena SV: 0x%lx (P) All SV objects are supposed to be allocated from arenas that will be garbage collected on exit. An SV was discovered to be outside any of those arenas. =item Attempt to free temp prematurely (W) Mortalized values are supposed to be freed by the free_tmps() routine. This indicates that something else is freeing the SV before the free_tmps() routine gets a chance, which means that the free_tmps() routine will be freeing an unreferenced scalar when it does try to free it. =item Attempt to free unreferenced glob pointers (P) The reference counts got screwed up on symbol aliases. =item Attempt to free unreferenced scalar (W) Perl went to decrement the reference count of a scalar to see if it would go to 0, and discovered that it had already gone to 0 earlier, and should have been freed, and in fact, probably was freed. This could indicate that SvREFCNT_dec() was called too many times, or that SvREFCNT_inc() was called too few times, or that the SV was mortalized when it shouldn't have been, or that memory has been corrupted. =item Bad arg length for %s, is %d, should be %d (F) You passed a buffer of the wrong size to one of msgctl(), semctl() or shmctl(). In C parlance, the correct sized are, respectively, S, S and S. =item Bad associative array (P) One of the internal hash routines was passed a null HV pointer. =item Bad filehandle: %s (F) A symbol was passed to something wanting a filehandle, but the symbol has no filehandle associated with it. Perhaps you didn't do an open(), or did it in another package. =item Bad free() ignored (S) An internal routine called free() on something that had never been malloc()ed in the first place. =item Bad name after %s:: (F) You started to name a symbol by using a package prefix, and then didn't finish the symbol. In particular, you can't interpolate outside of quotes, so $var = 'myvar'; $sym = mypack::$var; is not the same as $var = 'myvar'; $sym = "mypack::$var"; =item Bad symbol for array (P) An internal request asked to add an array entry to something that wasn't a symbol table entry. =item Bad symbol for filehandle (P) An internal request asked to add a filehandle entry to something that wasn't a symbol table entry. =item Bad symbol for hash (P) An internal request asked to add a hash entry to something that wasn't a symbol table entry. =item BEGIN failed--compilation aborted (F) An untrapped exception was raised while executing a BEGIN subroutine. Compilation stops immediately and the interpreter is exited. =item bind() on closed fd (W) You tried to do a bind on a closed socket. Did you forget to check the return value of your socket() call? See L. =item Callback called exit (F) A subroutine invoked from an external package via perl_call_sv() exited by calling exit. =item Can't "last" outside a block (F) A "last" statement was executed to break out of the current block, except that there's this itty bitty problem called there isn't a current block. Note that an "if" or "else" block doesn't count as a "loopish" block. You can usually double the curlies to get the same effect though, since the inner curlies will be considered a block that loops once. See L. =item Can't "next" outside a block (F) A "next" statement was executed to reiterate the current block, but there isn't a current block. Note that an "if" or "else" block doesn't count as a "loopish" block. You can usually double the curlies to get the same effect though, since the inner curlies will be considered a block that loops once. See L. =item Can't "redo" outside a block (F) A "redo" statement was executed to restart the current block, but there isn't a current block. Note that an "if" or "else" block doesn't count as a "loopish" block. You can usually double the curlies to get the same effect though, since the inner curlies will be considered a block that loops once. See L. =item Can't bless non-reference value (F) Only hard references may be blessed. This is how Perl "enforces" encapsulation of objects. See L. =item Can't break at that line (S) A warning intended for while running within the debugger, indicating the line number specified wasn't the location of a statement that could be stopped at. =item Can't call method "%s" in empty package "%s" (F) You called a method correctly, and it correctly indicated a package functioning as a class, but that package doesn't have ANYTHING defined in it, let alone methods. See L. =item Can't call method "%s" on unblessed reference (F) A method call must know what package it's supposed to run in. It ordinarily finds this out from the object reference you supply, but you didn't supply an object reference in this case. A reference isn't an object reference until it has been blessed. See L. =item Can't call method "%s" without a package or object reference (F) You used the syntax of a method call, but the slot filled by the object reference or package name contains an expression that returns neither an object reference nor a package name. (Perhaps it's null?) Something like this will reproduce the error: $BADREF = undef; process $BADREF 1,2,3; $BADREF->process(1,2,3); =item Can't chdir to %s (F) You called C, but C is not a directory that you can chdir to, possibly because it doesn't exist. =item Can't coerce %s to integer in %s (F) Certain types of SVs, in particular real symbol table entries (type GLOB), can't be forced to stop being what they are. So you can't say things like: *foo += 1; You CAN say $foo = *foo; $foo += 1; but then $foo no longer contains a glob. =item Can't coerce %s to number in %s (F) Certain types of SVs, in particular real symbol table entries (type GLOB), can't be forced to stop being what they are. =item Can't coerce %s to string in %s (F) Certain types of SVs, in particular real symbol table entries (type GLOB), can't be forced to stop being what they are. =item Can't create pipe mailbox (F) An error peculiar to VMS. =item Can't declare %s in my (F) Only scalar, array and hash variables may be declared as lexical variables. They must have ordinary identifiers as names. =item Can't do inplace edit on %s: %s (S) The creation of the new file failed for the indicated reason. =item Can't do inplace edit without backup (F) You're on a system such as MSDOS that gets confused if you try reading from a deleted (but still opened) file. You have to say B<-i>C<.bak>, or some such. =item Can't do inplace edit: %s > 14 characters (S) There isn't enough room in the filename to make a backup name for the file. =item Can't do inplace edit: %s is not a regular file (S) You tried to use the B<-i> switch on a special file, such as a file in /dev, or a FIFO. The file was ignored. =item Can't do setegid! (P) The setegid() call failed for some reason in the setuid emulator of suidperl. =item Can't do seteuid! (P) The setuid emulator of suidperl failed for some reason. =item Can't do setuid (F) This typically means that ordinary perl tried to exec suidperl to do setuid emulation, but couldn't exec it. It looks for a name of the form sperl5.000 in the same directory that the perl executable resides under the name perl5.000, typically /usr/local/bin on Unix machines. If the file is there, check the execute permissions. If it isn't, ask your sysadmin why he and/or she removed it. =item Can't do waitpid with flags (F) This machine doesn't have either waitpid() or wait4(), so only waitpid() without flags is emulated. =item Can't do {n,m} with n > m (F) Minima must be less than or equal to maxima. If you really want your regexp to match something 0 times, just put {0}. See L. =item Can't emulate -%s on #! line (F) The #! line specifies a switch that doesn't make sense at this point. For example, it'd be kind of silly to put a B<-x> on the #! line. =item Can't exec "%s": %s (W) An system(), exec() or piped open call could not execute the named program for the indicated reason. Typical reasons include: the permissions were wrong on the file, the file wasn't found in C<$ENV{PATH}>, the executable in question was compiled for another architecture, or the #! line in a script points to an interpreter that can't be run for similar reasons. (Or maybe your system doesn't support #! at all.) =item Can't exec %s (F) Perl was trying to execute the indicated program for you because that's what the #! line said. If that's not what you wanted, you may need to mention "perl" on the #! line somewhere. =item Can't execute %s (F) You used the B<-S> switch, but the script to execute could not be found in the PATH, or at least not with the correct permissions. =item Can't find label %s (F) You said to goto a label that isn't mentioned anywhere that it's possible for us to go to. See L. =item Can't find string terminator %s anywhere before EOF (F) Perl strings can stretch over multiple lines. This message means that the closing delimiter was omitted. Since bracketed quotes count nesting levels, the following is missing its final parenthesis: print q(The character '(' starts a side comment.) =item Can't fork (F) A fatal error occurred while trying to fork while opening a pipeline. =item Can't get pipe mailbox device name (F) An error peculiar to VMS. =item Can't get SYSGEN parameter value for MAXBUF (F) An error peculiar to VMS. =item Can't goto subroutine outside a subroutine (F) The deeply magical "goto subroutine" call can only replace one subroutine call for another. It can't manufacture one out of whole cloth. In general you should only be calling it out of an AUTOLOAD routine anyway. See L. =item Can't locate %s in @INC (F) You said to do (or require, or use) a file that couldn't be found in any of the libraries mentioned in @INC. Perhaps you need to set the PERL5LIB environment variable to say where the extra library is, or maybe the script needs to add the library name to @INC. Or maybe you just misspelled the name of the file. See L. =item Can't locate object method "%s" via package "%s" (F) You called a method correctly, and it correctly indicated a package functioning as a class, but that package doesn't define that particular method, nor does any of it's base classes. See L. =item Can't locate package %s for @%s::ISA (W) The @ISA array contained the name of another package that doesn't seem to exist. =item Can't mktemp() (F) The mktemp() routine failed for some reason while trying to process a B<-e> switch. Maybe your /tmp partition is full, or clobbered. =item Can't modify %s in %s (F) You aren't allowed to assign to the item indicated, or otherwise try to change it, such as with an autoincrement. =item Can't modify non-existent substring (P) The internal routine that does assignment to a substr() was handed a NULL. =item Can't msgrcv to readonly var (F) The target of a msgrcv must be modifiable in order to be used as a receive buffer. =item Can't open %s: %s (S) An inplace edit couldn't open the original file for the indicated reason. Usually this is because you don't have read permission for the file. =item Can't open bidirectional pipe (W) You tried to say C, which is not supported. You can try any of several modules in the Perl library to do this, such as "open2.pl". Alternately, direct the pipe's output to a file using ">", and then read it in under a different file handle. =item Can't open perl script "%s": %s (F) The script you specified can't be opened for the indicated reason. =item Can't rename %s to %s: %s, skipping file (S) The rename done by the B<-i> switch failed for some reason, probably because you don't have write permission to the directory. =item Can't reswap uid and euid (P) The setreuid() call failed for some reason in the setuid emulator of suidperl. =item Can't return outside a subroutine (F) The return statement was executed in mainline code, that is, where there was no subroutine call to return out of. See L. =item Can't stat script "%s" (P) For some reason you can't fstat() the script even though you have it open already. Bizarre. =item Can't swap uid and euid (P) The setreuid() call failed for some reason in the setuid emulator of suidperl. =item Can't take log of %g (F) Logarithms are only defined on positive real numbers. =item Can't take sqrt of %g (F) For ordinary real numbers, you can't take the square root of a negative number. There's a Complex package available for Perl, though, if you really want to do that. =item Can't undef active subroutine (F) You can't undefine a routine that's currently running. You can, however, redefine it while it's running, and you can even undef the redefined subroutine while the old routine is running. Go figure. =item Can't unshift (F) You tried to unshift an "unreal" array that can't be unshifted, such as the main Perl stack. =item Can't upgrade that kind of scalar (P) The internal sv_upgrade routine adds "members" to an SV, making it into a more specialized kind of SV. The top several SV types are so specialized, however, that they cannot be interconverted. This message indicates that such a conversion was attempted. =item Can't upgrade to undef (P) The undefined SV is the bottom of the totem pole, in the scheme of upgradability. Upgrading to undef indicates an error in the code calling sv_upgrade. =item Can't use %s as left arg of an implicit -> (F) The compiler tried to interpret a bracketed expression as a subscript to an array reference. But to the left of the brackets was an expression that didn't end in an arrow (->), or look like a subscripted expression. Only subscripted expressions with multiple subscripts are allowed to omit the intervening arrow. =item Can't use %s for loop variable (F) Only a simple scalar variable may be used as a loop variable on a foreach. =item Can't use %s ref as %s ref (F) You've mixed up your reference types. You have to dereference a reference of the type needed. You can use the ref() function to test the type of the reference, if need be. =item Can't use a string as %s ref while "strict refs" in use (F) Only hard references are allowed by "strict refs". Symbolic references are disallowed. See L. =item Can't use an undefined value as %s reference (F) A value used as either a hard reference or a symbolic reference must be a defined value. This helps to de-lurk some insidious errors. =item Can't use delimiter brackets within expression (F) The ${name} construct is for disambiguating identifiers in strings, not in ordinary code. =item Can't use global %s in "my" (F) You tried to declare a magical variable as a lexical variable. This is not allowed, because the magic can only be tied to one location (namely the global variable) and it would be incredibly confusing to have variables in your program that looked like magical variables but weren't. =item Can't write to temp file for B<-e>: %s (F) The write routine failed for some reason while trying to process a B<-e> switch. Maybe your /tmp partition is full, or clobbered. =item Can't x= to readonly value (F) You tried to repeat a constant value (often the undefined value) with an assignment operator, which implies modifying the value itself. Perhaps you need to copy the value to a temporary, and repeat that. =item Cannot open temporary file (F) The create routine failed for some reaon while trying to process a B<-e> switch. Maybe your /tmp partition is full, or clobbered. =item chmod: mode argument is missing initial 0 (W) A novice will sometimes say chmod 777, $filename not realizing that 777 will be interpreted as a decimal number, equivalent to 01411. Octal constants are introduced with a leading 0 in Perl, as in C. =item Close on unopened file <%s> (W) You tried to close a filehandle that was never opened. =item connect() on closed fd (W) You tried to do a connect on a closed socket. Did you forget to check the return value of your socket() call? See L. =item Corrupt malloc ptr 0x%lx at 0x%lx (P) The malloc package that comes with Perl had an internal failure. =item corrupted regexp pointers (P) The regular expression engine got confused by what the regular expression compiler gave it. =item corrupted regexp program (P) The regular expression engine got passed a regexp program without a valid magic number. =item Deep recursion on subroutine "%s" (W) This subroutine has called itself (directly or indirectly) 100 times than it has returned. This probably indicates an infinite recursion, unless you're writing strange benchmark programs, in which case it indicates something else. =item Did you mean $ instead of %? (W) You probably said %hash{$key} when you meant $hash{$key}. =item Don't know how to handle magic of type '%s' (P) The internal handling of magical variables has been cursed. =item do_study: out of memory (P) This should have been caught by safemalloc() instead. =item Duplicate free() ignored (S) An internal routine called free() on something that had already been freed. =item END failed--cleanup aborted (F) An untrapped exception was raised while executing an END subroutine. The interpreter is immediately exited. =item Execution of %s aborted due to compilation errors. (F) The final summary message when a Perl compilation fails. =item Exiting eval via %s (W) You are exiting an eval by unconventional means, such as a a goto, or a loop control statement. =item Exiting subroutine via %s (W) You are exiting a subroutine by unconventional means, such as a a goto, or a loop control statement. =item Exiting substitution via %s (W) You are exiting a substitution by unconventional means, such as a a return, a goto, or a loop control statement. =item Fatal $PUTMSG error: %d (F) An error peculiar to VMS. =item fcntl is not implemented (F) Your machine apparently doesn't implement fcntl(). What is this, a PDP-11 or something? =item Filehandle %s never opened (W) An I/O operation was attempted on a filehandle that was never initialized. You need to do an open() or a socket() call, or call a constructor from the FileHandle package. =item Filehandle %s opened only for input (W) You tried to write on a read-only filehandle. If you intended it to be a read-write filehandle, you needed to open it with "+<" or "+>" or "+>>" instead of with "<" or nothing. If you only intended to write the file, use ">" or ">>". See L. =item Filehandle only opened for input (W) You tried to write on a read-only filehandle. If you intended it to be a read-write filehandle, you needed to open it with "+<" or "+>" or "+>>" instead of with "<" or nothing. If you only intended to write the file, use ">" or ">>". See L. =item Final $ should be \$ or $name (F) You must now decide whether the final $ in a string was meant to be a literal dollar sign, or was meant to introduce a variable name that happens to be missing. So you have to put either the backslash or the name. =item Final @ should be \@ or @name (F) You must now decide whether the final @ in a string was meant to be a literal "at" sign, or was meant to introduce a variable name that happens to be missing. So you have to put either the backslash or the name. =item Format %s redefined (W) You redefined a format. To suppress this warning, say { local $^W = 0; eval "format NAME =..."; } =item Format not terminated (F) A format must be terminated by a line with a solitary dot. Perl got to the end of your file without finding such a line. =item Found = in conditional, should be == (W) You said if ($foo = 123) when you meant if ($foo == 123) (or something like that). =item gdbm store returned %d, errno %d, key "%s" (S) A warning from the GDBM_File extension that a store failed. =item gethostent not implemented (F) Your C library apparently doesn't implement gethostent(), probably because if it did, it'd feel morally obligated to return every hostname on the Internet. =item get{sock,peer}name() on closed fd (W) You tried to get a socket or peer socket name on a closed socket. Did you forget to check the return value of your socket() call? =item Glob not terminated (F) The lexer saw a left angle bracket in a place where it was expecting a term, so it's looking for the corresponding right angle bracket, and not finding it. Chances are you left some needed parentheses out earlier in the line, and you really meant a "less than". =item Global symbol "%s" requires explicit package name (F) You've said "use strict vars", which indicates that all variables must either be lexically scoped (using "my"), or explicitly qualified to say which package the global variable is in (using "::"). =item goto must have label (F) Unlike with "next" or "last", you're not allowed to goto an unspecified destination. See L. =item Had to create %s unexpectedly (S) A routine asked for a symbol from a symbol table that ought to have existed already, but for some reason it didn't, and had to be created on an emergency basis to prevent a core dump. =item Hash %%s missing the % in argument %d of %s() (D) Really old Perl let you omit the % on hash names in some spots. This is now heavily deprecated. =item Identifier "%s::%s" used only once: possible typo (W) Typographical errors often show up as unique identifiers. If you had a good reason for having a unique identifier, then just mention it again somehow to suppress the message. =item Illegal division by zero (F) You tried to divide a number by 0. Either something was wrong in your logic, or you need to put a conditional in to guard against meaningless input. =item Illegal modulus zero (F) You tried to divide a number by 0 to get the remainder. Most numbers don't take to this kindly. =item Illegal octal digit (F) You used an 8 or 9 in a octal number. =item Insecure dependency in %s (F) You tried to do something that the tainting mechanism didn't like. The tainting mechanism is turned on when you're running setuid or setgid, or when you specify B<-T> to turn it on explicitly. The tainting mechanism labels all data that's derived directly or indirectly from the user, who is considered to be unworthy of your trust. If any such data is used in a "dangerous" operation, you get this error. See L for more information. =item Insecure directory in %s (F) You can't use system(), exec(), or a piped open in a setuid or setgid script if $ENV{PATH} contains a directory that is writable by the world. See L. =item Insecure PATH (F) You can't use system(), exec(), or a piped open in a setuid or setgid script if $ENV{PATH} is derived from data supplied (or potentially supplied) by the user. The script must set the path to a known value, using trustworthy data. See L. =item internal disaster in regexp (P) Something went badly wrong in the regular expression parser. =item internal urp in regexp at /%s/ (P) Something went badly awry in the regular expression parser. =item invalid [] range in regexp (F) The range specified in a character class had a minimum character greater than the maximum character. See L. =item ioctl is not implemented (F) Your machine apparently doesn't implement ioctl(), which is pretty strange for a machine that supports C. =item junk on end of regexp (P) The regular expression parser is confused. =item Label not found for "last %s" (F) You named a loop to break out of, but you're not currently in a loop of that name, not even if you count where you were called from. See L. =item Label not found for "next %s" (F) You named a loop to continue, but you're not currently in a loop of that name, not even if you count where you were called from. See L. =item Label not found for "redo %s" (F) You named a loop to restart, but you're not currently in a loop of that name, not even if you count where you were called from. See L. =item listen() on closed fd (W) You tried to do a listen on a closed socket. Did you forget to check the return value of your socket() call? See L. =item Literal @%s now requires backslash (F) It used to be that Perl would try to guess whether you wanted an array interpolated or a literal @. It did this when the string was first used at runtime. Now strings are parsed at compile time, and ambiguous instances of @ must be disambiguated, either by putting a backslash to indicate a literal, or by declaring (or using) the array within the program before the string (lexically). (Someday it will simply assume that an unbackslashed @ interpolates an array.) =item Method for operation %s not found in package %s during blessing (F) An attempt was made to specify an entry in an overloading table that doesn't somehow point to a valid method. See L. =item Might be a runaway multi-line %s string starting on line %d (S) An advisory indicating that the previous error may have been caused by a missing delimiter on a string or pattern, because it eventually ended earlier on the current line. =item Misplaced _ in number (W) An underline in a decimal constant wasn't on a 3-digit boundary. =item Missing $ on loop variable (F) Apparently you've been programming in csh too much. Variables are always mentioned with the $ in Perl, unlike in the shells, where it can vary from one line to the next. =item Missing comma after first argument to %s function (F) While certain functions allow you to specify a filehandle or an "indirect object" before the argument list, this ain't one of them. =item Missing right bracket (F) The lexer counted more opening curly brackets (braces) than closing ones. As a general rule, you'll find it's missing near the place you were last editing. =item Missing semicolon on previous line? (S) This is an educated guess made in conjunction with the message "%s found where operator expected". Don't automatically put a semicolon on the previous line just because you saw this message. =item Modification of a read-only value attempted (F) You tried, directly or indirectly, to change the value of a constant. You didn't, of course, try "2 = 1", since the compiler catches that. But an easy way to do the same thing is: sub mod { $_[0] = 1 } mod(2); Another way is to assign to a substr() that's off the end of the string. =item Modification of non-creatable array value attempted, subscript %d (F) You tried to make an array value spring into existence, and the subscript was probably negative, even counting from end of the array backwards. =item Modification of non-creatable hash value attempted, subscript "%s" (F) You tried to make a hash value spring into existence, and it couldn't be created for some peculiar reason. =item Module name must be constant (F) Only a bare module name is allowed as the first argument to a "use". =item msg%s not implemented (F) You don't have System V message IPC on your system. =item Multidimensional syntax %s not supported (W) Multidimensional arrays aren't written like $foo[1,2,3]. They're written like $foo[1][2][3], as in C. =item Negative length (F) You tried to do a read/write/send/recv operation with a buffer length that is less than 0. This is difficult to imagine. =item nested *?+ in regexp (F) You can't quantify a quantifier without intervening parens. So things like ** or +* or ?* are illegal. Note, however, that the minimal matching quantifiers, *?, +? and ?? appear to be nested quantifiers, but aren't. See L. =item No #! line (F) The setuid emulator requires that scripts have a well-formed #! line even on machines that don't support the #! construct. =item No %s allowed while running setuid (F) Certain operations are deemed to be too insecure for a setuid or setgid script to even be allowed to attempt. Generally speaking there will be another way to do what you want that is, if not secure, at least securable. See L. =item No B<-e> allowed in setuid scripts (F) A setuid script can't be specified by the user. =item No comma allowed after %s (F) A list operator that has a filehandle or "indirect object" is not allowed to have a comma between that and the following arguments. Otherwise it'd be just another one of the arguments. =item No DB::DB routine defined (F) The currently executing code was compiled with the B<-d> switch, but for some reason the perl5db.pl file (or some facsimile thereof) didn't define a routine to be called at the beginning of each statement. Which is odd, because the file should have been required automatically, and should have blown up the require if it didn't parse right. =item No dbm on this machine (P) This is counted as an internal error, because every machine should supply dbm nowadays, since Perl comes with SDBM. See L. =item No DBsub routine (F) The currently executing code was compiled with the B<-d> switch, but for some reason the perl5db.pl file (or some facsimile thereof) didn't define a DB::sub routine to be called at the beginning of each ordinary subroutine call. =item No Perl script found in input (F) You called C, but no line was found in the file beginning with #! and containing the word "perl". =item No setregid available (F) Configure didn't find anything resembling the setregid() call for your system. =item No setreuid available (F) Configure didn't find anything resembling the setreuid() call for your system. =item No space allowed after B<-I> (F) The argument to B<-I> must follow the B<-I> immediately with no intervening space. =item No such signal: SIG%s (W) You specified a signal name as a subscript to %SIG that was not recognized. Say C in your shell to see the valid signal names on your system. =item Not a CODE reference (F) Perl was trying to evaluate a reference to a code value (that is, a subroutine), but found a reference to something else instead. You can use the ref() function to find out what kind of ref it really was. See also L. =item Not a format reference (F) I'm not sure how you managed to generate a reference to an anonymous format, but this indicates you did, and that it didn't exist. =item Not a GLOB reference (F) Perl was trying to evaluate a reference to a "type glob" (that is, a symbol table entry that looks like C<*foo>), but found a reference to something else instead. You can use the ref() function to find out what kind of ref it really was. See L. =item Not a HASH reference (F) Perl was trying to evaluate a reference to a hash value, but found a reference to something else instead. You can use the ref() function to find out what kind of ref it really was. See L. =item Not a perl script (F) The setuid emulator requires that scripts have a well-formed #! line even on machines that don't support the #! construct. The line must mention perl. =item Not a SCALAR reference (F) Perl was trying to evaluate a reference to a scalar value, but found a reference to something else instead. You can use the ref() function to find out what kind of ref it really was. See L. =item Not a subroutine reference (F) Perl was trying to evaluate a reference to a code value (that is, a subroutine), but found a reference to something else instead. You can use the ref() function to find out what kind of ref it really was. See also L. =item Not a subroutine reference in %OVERLOAD (F) An attempt was made to specify an entry in an overloading table that doesn't somehow point to a valid subroutine. See L. =item Not an ARRAY reference (F) Perl was trying to evaluate a reference to an array value, but found a reference to something else instead. You can use the ref() function to find out what kind of ref it really was. See L. =item Not enough arguments for %s (F) The function requires more arguments than you specified. =item Not enough format arguments (W) A format specified more picture fields than the next line supplied. See L. =item Null filename used (F) You can't require the null filename, especially since on many machines that means the current directory! See L. =item NULL OP IN RUN (P) Some internal routine called run() with a null opcode pointer. =item Null realloc (P) An attempt was made to realloc NULL. =item NULL regexp argument (P) The internal pattern matching routines blew it bigtime. =item NULL regexp parameter (P) The internal pattern matching routines are out of their gourd. =item Odd number of elements in hash list (S) You specified an odd number of elements to a hash list, which is odd, since hash lists come in key/value pairs. =item oops: oopsAV (S) An internal warning that the grammar is screwed up. =item oops: oopsHV (S) An internal warning that the grammar is screwed up. =item Operation `%s' %s: no method found, (F) An attempt was made to use an entry in an overloading table that somehow no longer points to a valid method. See L. =item Out of memory for yacc stack (F) The yacc parser wanted to grow its stack so it could continue parsing, but realloc() wouldn't give it more memory, virtual or otherwise. =item Out of memory! (X) The malloc() function returned 0, indicating there was insufficient remaining memory (or virtual memory) to satisfy the request. =item page overflow (W) A single call to write() produced more lines than can fit on a page. See L. =item panic: ck_grep (P) Failed an internal consistency check trying to compile a grep. =item panic: ck_split (P) Failed an internal consistency check trying to compile a split. =item panic: corrupt saved stack index (P) The savestack was requested to restore more localized values than there are in the savestack. =item panic: die %s (P) We popped the context stack to an eval context, and then discovered it wasn't an eval context. =item panic: do_match (P) The internal pp_match() routine was called with invalid operational data. =item panic: do_split (P) Something terrible went wrong in setting up for the split. =item panic: do_subst (P) The internal pp_subst() routine was called with invalid operational data. =item panic: do_trans (P) The internal do_trans() routine was called with invalid operational data. =item panic: goto (P) We popped the context stack to a context with the specified label, and then discovered it wasn't a context we know how to do a goto in. =item panic: INTERPCASEMOD (P) The lexer got into a bad state at a case modifier. =item panic: INTERPCONCAT (P) The lexer got into a bad state parsing a string with brackets. =item panic: last (P) We popped the context stack to a block context, and then discovered it wasn't a block context. =item panic: leave_scope clearsv (P) A writable lexical variable became readonly somehow within the scope. =item panic: leave_scope inconsistency (P) The savestack probably got out of sync. At least, there was an invalid enum on the top of it. =item panic: malloc (P) Something requested a negative number of bytes of malloc. =item panic: mapstart (P) The compiler is screwed up with respect to the map() function. =item panic: null array (P) One of the internal array routines was passed a null AV pointer. =item panic: pad_alloc (P) The compiler got confused about which scratch pad it was allocating and freeing temporaries and lexicals from. =item panic: pad_free curpad (P) The compiler got confused about which scratch pad it was allocating and freeing temporaries and lexicals from. =item panic: pad_free po (P) An invalid scratch pad offset was detected internally. =item panic: pad_reset curpad (P) The compiler got confused about which scratch pad it was allocating and freeing temporaries and lexicals from. =item panic: pad_sv po (P) An invalid scratch pad offset was detected internally. =item panic: pad_swipe curpad (P) The compiler got confused about which scratch pad it was allocating and freeing temporaries and lexicals from. =item panic: pad_swipe po (P) An invalid scratch pad offset was detected internally. =item panic: pp_iter (P) The foreach iterator got called in a non-loop context frame. =item panic: realloc (P) Something requested a negative number of bytes of realloc. =item panic: restartop (P) Some internal routine requested a goto (or something like it), and didn't supply the destination. =item panic: return (P) We popped the context stack to a subroutine or eval context, and then discovered it wasn't a subroutine or eval context. =item panic: scan_num (P) scan_num() got called on something that wasn't a number. =item panic: sv_insert (P) The sv_insert() routine was told to remove more string than there was string. =item panic: top_env (P) The compiler attempted to do a goto, or something weird like that. =item panic: yylex (P) The lexer got into a bad state while processing a case modifier. =item Parens missing around "%s" list (W) You said something like my $foo, $bar = @_; when you meant my ($foo, $bar) = @_; Remember that "my" and "local" bind closer than comma. =item Perl %3.3f required--this is only version %s, stopped (F) The module in question uses features of a version of Perl more recent than the currently running version. How long has it been since you upgraded, anyway? See L. =item Permission denied (F) The setuid emulator in suidperl decided you were up to no good. =item POSIX getpgrp can't take an argument (F) Your C compiler uses POSIX getpgrp(), which takes no argument, unlike the BSD version, which takes a pid. =item Possible memory corruption: %s overflowed 3rd argument (F) An ioctl() or fcntl() returned more than Perl was bargaining for. Perl guesses a reasonable buffer size, but puts a sentinel byte at the end of the buffer just in case. This sentinel byte got clobbered, and Perl assumes that memory is now corrupted. See L. =item Precedence problem: open %s should be open(%s) (S) The old irregular construct open FOO || die; is now misinterpreted as open(FOO || die); because of the strict regularization of Perl 5's grammar into unary and list operators. (The old open was a little of both.) You must put parens around the filehandle, or use the new "or" operator instead of "||". =item print on closed filehandle %s (W) The filehandle you're printing on got itself closed sometime before now. Check your logic flow. =item printf on closed filehandle %s (W) The filehandle you're writing to got itself closed sometime before now. Check your logic flow. =item Probable precedence problem on %s (W) The compiler found a bare word where it expected a conditional, which often indicates that an || or && was parsed as part of the last argument of the previous construct, for example: open FOO || die; =item Read on closed filehandle <%s> (W) The filehandle you're reading from got itself closed sometime before now. Check your logic flow. =item Reallocation too large: %lx (F) You can't allocate more than 64K on an MSDOS machine. =item Recompile perl with B<-D>DEBUGGING to use B<-D> switch (F) You can't use the B<-D> option unless the code to produce the desired output is compiled into Perl, which entails some overhead, which is why it's currently left out of your copy. =item Recursive inheritance detected (F) More than 100 levels of inheritance were used. Probably indicates an unintended loop in your inheritance hierarchy. =item Reference miscount in sv_replace() (W) The internal sv_replace() function was handed a new SV with a reference count of other than 1. =item regexp memory corruption (P) The regular expression engine got confused by what the regular expression compiler gave it. =item regexp out of space (P) A "can't happen" error, because safemalloc() should have caught it earlier. =item regexp too big (F) The current implementation of regular expression uses shorts as address offsets within a string. Unfortunately this means that if the regular expression compiles to longer than 32767, it'll blow up. Usually when you want a regular expression this big, there is a better way to do it with multiple statements. See L. =item Reversed %s= operator (W) You wrote your assignment operator backwards. The = must always comes last, to avoid ambiguity with subsequent unary operators. =item Runaway format (F) Your format contained the ~~ repeat-until-blank sequence, but it produced 200 lines at once, and the 200th line looked exactly like the 199th line. Apparently you didn't arrange for the arguments to exhaust themselves, either by using ^ instead of @ (for scalar variables), or by shifting or popping (for array variables). See L. =item Scalar value @%s[%s] better written as $%s[%s] (W) You've used an array slice (indicated by @) to select a single value of an array. Generally it's better to ask for a scalar value (indicated by $). The difference is that $foo[&bar] always behaves like a scalar, both when assigning to it and when evaluating its argument, while @foo[&bar] behaves like a list when you assign to it, and provides a list context to its subscript, which can do weird things if you're only expecting one subscript. =item Script is not setuid/setgid in suidperl (F) Oddly, the suidperl program was invoked on a script with its setuid or setgid bit set. This doesn't make much sense. =item Search pattern not terminated (F) The lexer couldn't find the final delimiter of a // or m{} construct. Remember that bracketing delimiters count nesting level. =item seek() on unopened file (W) You tried to use the seek() function on a filehandle that was either never opened or has been closed since. =item select not implemented (F) This machine doesn't implement the select() system call. =item sem%s not implemented (F) You don't have System V semaphore IPC on your system. =item semi-panic: attempt to dup freed string (S) The internal newSVsv() routine was called to duplicate a scalar that had previously been marked as free. =item Semicolon seems to be missing (W) A nearby syntax error was probably caused by a missing semicolon, or possibly some other missing operator, such as a comma. =item Send on closed socket (W) The filehandle you're sending to got itself closed sometime before now. Check your logic flow. =item Sequence (?#... not terminated (F) A regular expression comment must be terminated by a closing parenthesis. Embedded parens aren't allowed. See L. =item Sequence (?%s...) not implemented (F) A proposed regular expression extension has the character reserved but has not yet been written. See L. =item Sequence (?%s...) not recognized (F) You used a regular expression extension that doesn't make sense. See L. =item setegid() not implemented (F) You tried to assign to $), and your operating system doesn't support the setegid() system call (or equivalent), or at least Configure didn't think so. =item seteuid() not implemented (F) You tried to assign to $>, and your operating system doesn't support the seteuid() system call (or equivalent), or at least Configure didn't think so. =item setrgid() not implemented (F) You tried to assign to $(, and your operating system doesn't support the setrgid() system call (or equivalent), or at least Configure didn't think so. =item setruid() not implemented (F) You tried to assign to $<, and your operating system doesn't support the setruid() system call (or equivalent), or at least Configure didn't think so. =item Setuid/gid script is writable by world (F) The setuid emulator won't run a script that is writable by the world, because the world might have written on it already. =item shm%s not implemented (F) You don't have System V shared memory IPC on your system. =item shutdown() on closed fd (W) You tried to do a shutdown on a closed socket. Seems a bit superfluous. =item SIG%s handler "%s" not defined. (W) The signal handler named in %SIG doesn't, in fact, exist. Perhaps you put it into the wrong package? =item sort is now a reserved word (F) An ancient error message that almost nobody ever runs into anymore. But before sort was a keyword, people sometimes used it as a filehandle. =item Sort subroutine didn't return a numeric value (F) A sort comparison routine must return a number. You probably blew it by not using C=E or C, or by not using them correctly. See L. =item Sort subroutine didn't return single value (F) A sort comparison subroutine may not return a list value with more or less than one element. See L. =item Split loop (P) The split was looping infinitely. (Obviously, a split shouldn't iterate more times than there are characters of input, which is what happened.) See L. =item Stat on unopened file <%s> (W) You tried to use the stat() function (or an equivalent file test) on a filehandle that was either never opened or has been closed since. =item Statement unlikely to be reached (W) You did an exec() with some statement after it other than a die(). This is almost always an error, because exec() never returns unless there was a failure. You probably wanted to use system() instead, which does return. To suppress this warning, put the exec() in a block by itself. =item Subroutine %s redefined (W) You redefined a subroutine. To suppress this warning, say { local $^W = 0; eval "sub name { ... }"; } =item Substitution loop (P) The substitution was looping infinitely. (Obviously, a substitution shouldn't iterate more times than there are characters of input, which is what happened.) See the discussion of substitution in L. =item Substitution pattern not terminated (F) The lexer couldn't find the interior delimiter of a s/// or s{}{} construct. Remember that bracketing delimiters count nesting level. =item Substitution replacement not terminated (F) The lexer couldn't find the final delimiter of a s/// or s{}{} construct. Remember that bracketing delimiters count nesting level. =item substr outside of string (W) You tried to reference a substr() that pointed outside of a string. That is, the absolute value of the offset was larger than the length of the string. See L. =item suidperl is no longer needed since... (F) Your Perl was compiled with B<-D>SETUID_SCRIPTS_ARE_SECURE_NOW, but a version of the setuid emulator somehow got run anyway. =item syntax error (F) Probably means you had a syntax error. Common reasons include: A keyword is misspelled. A semicolon is missing. A comma is missing. An opening or closing parenthesis is missing. An opening or closing brace is missing. A closing quote is missing. Often there will be another error message associated with the syntax error giving more information. (Sometimes it helps to turn on B<-w>.) The error message itself often tells you where it was in the line when it decided to give up. Sometimes the actual error is several tokens before this, since Perl is good at understanding random input. Occasionally the line number may be misleading, and once in a blue moon the only way to figure out what's triggering the error is to call C repeatedly, chopping away half the program each time to see if the error went away. Sort of the cybernetic version of S<20 questions>. =item System V IPC is not implemented on this machine (F) You tried to do something with a function beginning with "sem", "shm" or "msg". See L, for example. =item Syswrite on closed filehandle (W) The filehandle you're writing to got itself closed sometime before now. Check your logic flow. =item tell() on unopened file (W) You tried to use the tell() function on a filehandle that was either never opened or has been closed since. =item Test on unopened file <%s> (W) You tried to invoke a file test operator on a filehandle that isn't open. Check your logic. See also L. =item That use of $[ is unsupported (F) Assignment to $[ is now strictly circumscribed, and interpreted as a compiler directive. You may only say one of $[ = 0; $[ = 1; ... local $[ = 0; local $[ = 1; ... This is to prevent the problem of one module changing the array base out from under another module inadvertently. See L. =item The %s function is unimplemented The function indicated isn't implemented on this architecture, according to the probings of Configure. =item The crypt() function is unimplemented due to excessive paranoia. (F) Configure couldn't find the crypt() function on your machine, probably because your vendor didn't supply it, probably because they think the U.S. Govermnment thinks it's a secret, or at least that they will continue to pretend that it is. And if you quote me on that, I will deny it. =item The stat preceding C<-l _> wasn't an lstat (F) It makes no sense to test the current stat buffer for symbolic linkhood if the last stat that wrote to the stat buffer already went past the symlink to get to the real file. Use an actual filename instead. =item times not implemented (F) Your version of the C library apparently doesn't do times(). I suspect you're not running on Unix. =item Too few args to syscall (F) There has to be at least one argument to syscall() to specify the system call to call, silly dilly. =item Too many args to syscall (F) Perl only supports a maximum of 14 args to syscall(). =item Too many arguments for %s (F) The function requires fewer arguments than you specified. =item trailing \ in regexp (F) The regular expression ends with an unbackslashed backslash. Backslash it. See L. =item Translation pattern not terminated (F) The lexer couldn't find the interior delimiter of a tr/// or tr[][] construct. =item Translation replacement not terminated (F) The lexer couldn't find the final delimiter of a tr/// or tr[][] construct. =item truncate not implemented (F) Your machine doesn't implement a file truncation mechanism that Configure knows about. =item Type of arg %d to %s must be %s (not %s) (F) This function requires the argument in that position to be of a certain type. Arrays must be @NAME or @{EXPR}. Hashes must be %NAME or %{EXPR}. No implicit dereferencing is allowed--use the {EXPR} forms as an explicit dereference. See L. =item umask: argument is missing initial 0 (W) A umask of 222 is incorrect. It should be 0222, since octal literals always start with 0 in Perl, as in C. =item Unbalanced context: %d more PUSHes than POPs (W) The exit code detected an internal inconsistency in how many execution contexts were entered and left. =item Unbalanced saves: %d more saves than restores (W) The exit code detected an internal inconsistency in how many values were temporarily localized. =item Unbalanced scopes: %d more ENTERs than LEAVEs (W) The exit code detected an internal inconsistency in how many blocks were entered and left. =item Unbalanced tmps: %d more allocs than frees (W) The exit code detected an internal inconsistency in how many mortal scalars were allocated and freed. =item Undefined format "%s" called (F) The format indicated doesn't seem to exist. Perhaps it's really in another package? See L. =item Undefined sort subroutine "%s" called (F) The sort comparison routine specified doesn't seem to exist. Perhaps it's in a different package? See L. =item Undefined subroutine &%s called (F) The subroutine indicated hasn't been defined, or if it was, it has since been undefined. =item Undefined subroutine called (F) The anonymous subroutine you're trying to call hasn't been defined, or if it was, it has since been undefined. =item Undefined subroutine in sort (F) The sort comparison routine specified is declared but doesn't seem to have been defined yet. See L. =item unexec of %s into %s failed! (F) The unexec() routine failed for some reason. See your local FSF representative, who probably put it there in the first place. =item Unknown BYTEORDER (F) There are no byteswapping functions for a machine with this byte order. =item unmatched () in regexp (F) Unbackslashed parentheses must always be balanced in regular expressions. If you're a vi user, the % key is valuable for finding the matching paren. See L. =item Unmatched right bracket (F) The lexer counted more closing curly brackets (braces) than opening ones, so you're probably missing an opening bracket. As a general rule, you'll find the missing one (so to speak) near the place you were last editing. =item unmatched [] in regexp (F) The brackets around a character class must match. If you wish to include a closing bracket in a character class, backslash it or put it first. See L. =item Unquoted string "%s" may clash with future reserved word (W) You used a bare word that might someday be claimed as a reserved word. It's best to put such a word in quotes, or capitalize it somehow, or insert an underbar into it. You might also declare it as a subroutine. =item Unrecognized character \%03o ignored (S) A garbage character was found in the input, and ignored, in case it's a weird control character on an EBCDIC machine, or some such. =item Unrecognized signal name "%s" (F) You specified a signal name to the kill() function that was not recognized. Say C in your shell to see the valid signal names on your system. =item Unrecognized switch: -%s (F) You specified an illegal option to Perl. Don't do that. (If you think you didn't do that, check the #! line to see if it's supplying the bad switch on your behalf.) =item Unsuccessful %s on filename containing newline (W) A file operation was attempted on a filename, and that operation failed, PROBABLY because the filename contained a newline, PROBABLY because you forgot to chop() or chomp() it off. See L. =item Unsupported directory function "%s" called (F) Your machine doesn't support opendir() and readdir(). =item Unsupported function %s (F) This machines doesn't implement the indicated function, apparently. At least, Configure doesn't think so. =item Unsupported socket function "%s" called (F) Your machine doesn't support the Berkeley socket mechanism, or at least that's what Configure thought. =item Unterminated <> operator (F) The lexer saw a left angle bracket in a place where it was expecting a term, so it's looking for the corresponding right angle bracket, and not finding it. Chances are you left some needed parentheses out earlier in the line, and you really meant a "less than". =item Use of $# is deprecated (D) This was an ill-advised attempt to emulate a poorly defined awk feature. Use an explicit printf() or sprintf() instead. =item Use of $* is deprecated (D) This variable magically turned on multiline pattern matching, both for you and for any luckless subroutine that you happen to call. You should use the new C and C modifiers now to do that without the dangerous action-at-a-distance effects of C<$*>. =item Use of %s is deprecated (D) The construct indicated is no longer recommended for use, generally because there's a better way to do it, and also because the old way has bad side effects. =item Use of implicit split to @_ is deprecated (D) It makes a lot of work for the compiler when you clobber a subroutine's argument list, so it's better if you assign the results of a split() explicitly to an array (or list). =item Use of uninitialized value (W) An undefined value was used as if it were already defined. It was interpreted as a "" or a 0, but maybe it was a mistake. To suppress this warning assign an initial value to your variables. =item Useless use of %s in void context (W) You did something without a side effect in a context that does nothing with the return value, such as a statement that doesn't return a value from a block, or the left side of a scalar comma operator. Very often this points not to stupidity on your part, but a failure of Perl to parse your program the way you thought it would. For example, you'd get this if you mixed up your C precedence with Python precedence and said $one, $two = 1, 2; when you meant to say ($one, $two) = (1, 2); =item Warning: unable to close filehandle %s properly. (S) The implicit close() done by an open() got an error indication on the close(0. This usually indicates your filesystem ran out of disk space. =item Warning: Use of "%s" without parens is ambiguous (S) You wrote a unary operator followed by something that looks like a binary operator that could also have been interpreted as a term or unary operator. For instance, if you know that the rand function has a default argument of 1.0, and you write rand + 5; you may THINK you wrote the same thing as rand() + 5; but in actual fact, you got rand(+5); So put in parens to say what you really mean. =item Write on closed filehandle (W) The filehandle you're writing to got itself closed sometime before now. Check your logic flow. =item X outside of string (F) You had a pack template that specified a relative position before the beginning of the string being unpacked. See L. =item x outside of string (F) You had a pack template that specified a relative position after the end of the string being unpacked. See L. =item Xsub "%s" called in sort (F) The use of an external subroutine as a sort comparison is not yet supported. =item Xsub called in sort (F) The use of an external subroutine as a sort comparison is not yet supported. =item You can't use C<-l> on a filehandle (F) A filehandle represents an opened file, and when you opened the file it already went past any symlink you are presumably trying to look for. Use a filename instead. =item YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET! (F) And you probably never will, since you probably don't have the sources to your kernel, and your vendor probably doesn't give a rip about what you want. Your best bet is to use the wrapsuid script in the eg directory to put a setuid C wrapper around your script. =item You need to quote "%s" (W) You assigned a bareword as a signal handler name. Unfortunately, you already have a subroutine of that name declared, which means that Perl 5 will try to call the subroutine when the assignment is executed, which is probably not what you want. (If it IS what you want, put an & in front.) =item [gs]etsockopt() on closed fd (W) You tried to get or set a socket option on a closed socket. Did you forget to check the return value of your socket() call? See L. =item \1 better written as $1 (W) Outside of patterns, backreferences live on as variables. The use of backslashes is grandfathered on the righthand side of a substitution, but stylistically it's better to use the variable form because other Perl programmers will expect it, and it works better if there are more than 9 backreferences. =back ERs than LEAVEs (W) The exit code detected an internal inconsistency in how many blocks were entered and left. =item Unbalanced tmps: %d more allocperl5.000/pod/perlembed.pod 664 203 12 205 5650550116 10631 =head1 NAME perlembed - how to embed perl in your C or C++ app =head1 DESCRIPTION Look at perlmain.c, and do something like that. odxÂ] perlmod.podŒÂ^ perlobj.pod Â_ perlop.podl´Â` perlovl.podÈÂa perlpod.podÜÂb perlre.podlðÂc perlref.pod‹pod2manÂd perlrun.pod(Âe perlsec.pod@Âf perlstyle.podn.TÂg perlsub.podh‡ perlsyn.pod€ˆ perltrap.podub.”‰ perlvar.pod¨Šperl5.000/pod/perlform.pod 664 203 12 27070 5650550117 10572 =head1 NAME perlform - Perl formats =head1 DESCRIPTION Perl has a mechanism to help you generate simple reports and charts. To facilitate this, Perl helps you lay out your output page in your code in a fashion that's close to how it will look when it's printed. It can keep track of things like how many lines on a page, what page you're, when to print page headers, etc. The keywords used are borrowed from FORTRAN: format() to declare and write() to execute; see their entries in L. Fortunately, the layout is much more legible, more like BASIC's PRINT USING statement. Think of it as a poor man's nroff(1). Formats, like packages and subroutines, are declared rather than executed, so they may occur at any point in your program. (Usually it's best to keep them all together though.) They have their own namespace apart from all the other "types" in Perl. This means that if you have a function named "Foo", it is not the same thing as having a format named "Foo". However, the default name for the format associated with a given filehandle is the same as the name of the filehandle. Thus, the default format for STDOUT is name "STDOUT", and the default format for filehandle TEMP is name "TEMP". They just look the same. They aren't. Output record formats are declared as follows: format NAME = FORMLIST . If name is omitted, format "STDOUT" is defined. FORMLIST consists of a sequence of lines, each of which may be of one of three types: =over 4 =item 1. A comment, indicated by putting a '#' in the first column. =item 2. A "picture" line giving the format for one output line. =item 3. An argument line supplying values to plug into the previous picture line. =back Picture lines are printed exactly as they look, except for certain fields that substitute values into the line. Each field in a picture line starts with either "@" (at) or "^" (caret). These lines do not undergo any kind of variable interpolation. The at field (not to be confused with the array marker @) is the normal kind of field; the other kind, caret fields, are used to do rudimentary multi-line text block filling. The length of the field is supplied by padding out the field with multiple "<", ">", or "|" characters to specify, respectively, left justification, right justification, or centering. If the variable would exceed the width specified, it is truncated. As an alternate form of right justification, you may also use "#" characters (with an optional ".") to specify a numeric field. This way you can line up the decimal points. If any value supplied for these fields contains a newline, only the text up to the newline is printed. Finally, the special field "@*" can be used for printing multi-line, non-truncated values; it should appear by itself on a line. The values are specified on the following line in the same order as the picture fields. The expressions providing the values should be separated by commas. The expressions are all evaluated in a list context before the line is processed, so a single list expression could produce multiple list elements. The expressions may be spread out to more than one line if enclosed in braces. If so, the opening brace must be the first token on the first line. Picture fields that begin with ^ rather than @ are treated specially. With a # field, the field is blanked out if the value is undefined. For other field types, the caret enables a kind of fill mode. Instead of an arbitrary expression, the value supplied must be a scalar variable name that contains a text string. Perl puts as much text as it can into the field, and then chops off the front of the string so that the next time the variable is referenced, more of the text can be printed. (Yes, this means that the variable itself is altered during execution of the write() call, and is not returned.) Normally you would use a sequence of fields in a vertical stack to print out a block of text. You might wish to end the final field with the text "...", which will appear in the output if the text was too long to appear in its entirety. You can change which characters are legal to break on by changing the variable C<$:> (that's $FORMAT_LINE_BREAK_CHARACTERS if you're using the English module) to a list of the desired characters. Since use of caret fields can produce variable length records. If the text to be formatted is short, you can suppress blank lines by putting a "~" (tilde) character anywhere in the line. The tilde will be translated to a space upon output. If you put a second tilde contiguous to the first, the line will be repeated until all the fields on the line are exhausted. (If you use a field of the at variety, the expression you supply had better not give the same value every time forever!) Top-of-form processing is by default handled by a format with the same name as the current filehandle with "_TOP" concatenated to it. It's triggered at the top of each page. See . Examples: # a report on the /etc/passwd file format STDOUT_TOP = Passwd File Name Login Office Uid Gid Home ------------------------------------------------------------------ . format STDOUT = @<<<<<<<<<<<<<<<<<< @||||||| @<<<<<<@>>>> @>>>> @<<<<<<<<<<<<<<<<< $name, $login, $office,$uid,$gid, $home . # a report from a bug report form format STDOUT_TOP = Bug Reports @<<<<<<<<<<<<<<<<<<<<<<< @||| @>>>>>>>>>>>>>>>>>>>>>>> $system, $%, $date ------------------------------------------------------------------ . format STDOUT = Subject: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< $subject Index: @<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< $index, $description Priority: @<<<<<<<<<< Date: @<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< $priority, $date, $description From: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< $from, $description Assigned to: @<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< $programmer, $description ~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< $description ~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< $description ~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< $description ~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< $description ~ ^<<<<<<<<<<<<<<<<<<<<<<<... $description . It is possible to intermix print()s with write()s on the same output channel, but you'll have to handle $- ($FORMAT_LINES_LEFT) yourself. =head2 Format Variables The current format name is stored in the variable C<$~> ($FORMAT_NAME), and the current top of form format name is in C<$^> ($FORMAT_TOP_NAME). The current output page number is stored in C<$%> ($FORMAT_PAGE_NUMBER), and the number of lines on the page is in C<$=> ($FORMAT_LINES_PER_PAGE). Whether to autoflush output on this handle is stored in $<$|> ($OUTPUT_AUTOFLUSH). The string output before each top of page (except the first) is stored in C<$^L> ($FORMAT_FORMFEED). These variables are set on a per-filehandle basis, so you'll need to select() into a different one to affect them: select((select(OUTF), $~ = "My_Other_Format", $^ = "My_Top_Format" )[0]); Pretty ugly, eh? It's a common idiom though, so don't be too surprised when you see it. You can at least use a temporary variable to hold the previous filehandle: (this is a much better approach in general, because not only does legibility improve, you now have intermediary stage in the expression to single-step the debugger through): $ofh = select(OUTF); $~ = "My_Other_Format"; $^ = "My_Top_Format"; select($ofh); If you use the English module, you can even read the variable names: use English; $ofh = select(OUTF); $FORMAT_NAME = "My_Other_Format"; $FORMAT_TOP_NAME = "My_Top_Format"; select($ofh); But you still have those funny select()s. So just use the FileHandle module. Now, you can access these special variables using lower-case method names instead: use FileHandle; format_name OUTF "My_Other_Format"; format_top_name OUTF "My_Top_Format"; Much better! =head1 NOTES Since the values line may contain arbitrary expression (for at fields, not caret fields), you can farm out any more sophisticated processing to other functions, like sprintf() or one of your own. For example: format Ident = @<<<<<<<<<<<<<<< &commify($n) . To get a real at or caret into the field, do this: format Ident = I have an @ here. "@" . To center a whole line of text, do something like this: format Ident = @||||||||||||||||||||||||||||||||||||||||||||||| "Some text line" . There is no builtin way to say "float this to the right hand side of the page, however wide it is." You have to specify where it goes. The truly desperate can generate their own format on the fly, based on the current number of columns, and then eval() it: $format = "format STDOUT = \n"; . '^' . '<' x $cols . "\n"; . '$entry' . "\n"; . "\t^" . "<" x ($cols-8) . "~~\n"; . '$entry' . "\n"; . ".\n"; print $format if $Debugging; eval $format; die $@ if $@; Which would generate a format looking something like this: format STDOUT = ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< $entry ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~ $entry . Here's a little program that's somewhat like fmt(1): format = ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~ $_ . $/ = ''; while (<>) { s/\s*\n\s*/ /g; write; } =head2 Footers While $FORMAT_TOP_NAME contains the name of the current header format, there is no corresponding mechanism to automatically do the same thing for a footer. Not knowing how big a format is going to be until you evaluate it is one of the major problems. It's on the TODO list. Here's one strategy: If you have a fixed-size footer, you can get footers by checking $FORMAT_LINES_LEFT before each write() and print the footer yourself if necessary. Here's another strategy; open a pipe to yourself, using C (see L) and always write() to MESELF instead of STDOUT. Have your child process postprocesses its STDIN to rearrange headers and footers however you like. Not very convenient, but doable. =head2 Accessing Formatting Internals For low-level access to the formatting mechanism. you may use formline() and access C<$^A> (the $ACCUMULATOR variable) directly. For example: $str = formline <<'END', 1,2,3; @<<< @||| @>>> END print "Wow, I just stored `$^A' in the accumulator!\n"; Or to make an swrite() subroutine which is to write() what sprintf() is to printf(), do this: use English; use Carp; sub swrite { croak "usage: swrite PICTURE ARGS" unless @ARG; local($ACCUMULATOR); formline(@ARG); return $ACCUMULATOR; } $string = swrite(<<'END', 1, 2, 3); Check me out @<<< @||| @>>> END print $string; =head1 WARNING During the execution of a format, only global variables are visible, or dynamically-scoped ones declared with local(). Lexically scoped variables declared with my() are I available, as they are not considered to reside in the same lexical scope as the format. n chops off the front of the string so that the next time the variable is referenced, more of the text can be printed. (Yes, this means that the variable itself is altered during execution of the write() call, and is not returned.) Normally you would use a sequence of fields in a vertical stack to print out a block of text. You might wish to end the final field with the text "...", which will appear in the output if the text was too long to appear iperl5.000/pod/perlfunc.pod 664 203 12 277767 5650550121 10621 =head1 NAME perlfunc - Perl builtin functions =head1 DESCRIPTION The functions in this section can serve as terms in an expression. They fall into two major categories: list operators and named unary operators. These differ in their precedence relationship with a following comma. (See the precedence table in L.) List operators take more than one argument, while unary operators can never take more than one argument. Thus, a comma terminates the argument of a unary operator, but merely separates the arguments of a list operator. A unary operator generally provides a scalar context to its argument, while a list operator may provide either scalar and list contexts for its arguments. If it does both, the scalar arguments will be first, and the list argument will follow. (Note that there can only ever be one list argument.) For instance, splice() has three scalar arguments followed by a list. In the syntax descriptions that follow, list operators that expect a list (and provide list context for the elements of the list) are shown with LIST as an argument. Such a list may consist of any combination of scalar arguments or list values; the list values will be included in the list as if each individual element were interpolated at that point in the list, forming a longer single-dimensional list value. Elements of the LIST should be separated by commas. Any function in the list below may be used either with or without parentheses around its arguments. (The syntax descriptions omit the parens.) If you use the parens, the simple (but occasionally surprising) rule is this: It I like a function, therefore it I a function, and precedence doesn't matter. Otherwise it's a list operator or unary operator, and precedence does matter. And whitespace between the function and left parenthesis doesn't count--so you need to be careful sometimes: print 1+2+3; # Prints 6. print(1+2) + 3; # Prints 3. print (1+2)+3; # Also prints 3! print +(1+2)+3; # Prints 6. print ((1+2)+3); # Prints 6. If you run Perl with the B<-w> switch it can warn you about this. For example, the third line above produces: print (...) interpreted as function at - line 1. Useless use of integer addition in void context at - line 1. For functions that can be used in either a scalar or list context, non-abortive failure is generally indicated in a scalar context by returning the undefined value, and in a list context by returning the null list. Remember the following rule: =over 5 =item * I =back Each operator and function decides which sort of value it would be most appropriate to return in a scalar context. Some operators return the length of the list that would have been returned in a list context. Some operators return the first value in the list. Some operators return the last value in the list. Some operators return a count of successful operations. In general, they do what you want, unless you want consistency. =over 8 =item -X FILEHANDLE =item -X EXPR =item -X A file test, where X is one of the letters listed below. This unary operator takes one argument, either a filename or a filehandle, and tests the associated file to see if something is true about it. If the argument is omitted, tests $_, except for C<-t>, which tests STDIN. Unless otherwise documented, it returns C<1> for TRUE and C<''> for FALSE, or the undefined value if the file doesn't exist. Despite the funny names, precedence is the same as any other named unary operator, and the argument may be parenthesized like any other unary operator. The operator may be any of: -r File is readable by effective uid/gid. -w File is writable by effective uid/gid. -x File is executable by effective uid/gid. -o File is owned by effective uid. -R File is readable by real uid/gid. -W File is writable by real uid/gid. -X File is executable by real uid/gid. -O File is owned by real uid. -e File exists. -z File has zero size. -s File has non-zero size (returns size). -f File is a plain file. -d File is a directory. -l File is a symbolic link. -p File is a named pipe (FIFO). -S File is a socket. -b File is a block special file. -c File is a character special file. -t Filehandle is opened to a tty. -u File has setuid bit set. -g File has setgid bit set. -k File has sticky bit set. -T File is a text file. -B File is a binary file (opposite of -T). -M Age of file in days when script started. -A Same for access time. -C Same for inode change time. The interpretation of the file permission operators C<-r>, C<-R>, C<-w>, C<-W>, C<-x> and C<-X> is based solely on the mode of the file and the uids and gids of the user. There may be other reasons you can't actually read, write or execute the file. Also note that, for the superuser, C<-r>, C<-R>, C<-w> and C<-W> always return 1, and C<-x> and C<-X> return 1 if any execute bit is set in the mode. Scripts run by the superuser may thus need to do a stat() in order to determine the actual mode of the file, or temporarily set the uid to something else. Example: while (<>) { chop; next unless -f $_; # ignore specials ... } Note that C<-s/a/b/> does not do a negated substitution. Saying C<-exp($foo)> still works as expected, however--only single letters following a minus are interpreted as file tests. The C<-T> and C<-B> switches work as follows. The first block or so of the file is examined for odd characters such as strange control codes or characters with the high bit set. If too many odd characters (>30%) are found, it's a C<-B> file, otherwise it's a C<-T> file. Also, any file containing null in the first block is considered a binary file. If C<-T> or C<-B> is used on a filehandle, the current stdio buffer is examined rather than the first block. Both C<-T> and C<-B> return TRUE on a null file, or a file at EOF when testing a filehandle. If any of the file tests (or either the stat() or lstat() operators) are given the special filehandle consisting of a solitary underline, then the stat structure of the previous file test (or stat operator) is used, saving a system call. (This doesn't work with C<-t>, and you need to remember that lstat() and C<-l> will leave values in the stat structure for the symbolic link, not the real file.) Example: print "Can do.\n" if -r $a || -w _ || -x _; stat($filename); print "Readable\n" if -r _; print "Writable\n" if -w _; print "Executable\n" if -x _; print "Setuid\n" if -u _; print "Setgid\n" if -g _; print "Sticky\n" if -k _; print "Text\n" if -T _; print "Binary\n" if -B _; =item abs VALUE Returns the absolute value of its argument. =item accept NEWSOCKET,GENERICSOCKET Accepts an incoming socket connect, just as the accept(2) system call does. Returns the packed address if it succeeded, FALSE otherwise. See example in L. =item alarm SECONDS Arranges to have a SIGALRM delivered to this process after the specified number of seconds have elapsed. (On some machines, unfortunately, the elapsed time may be up to one second less than you specified because of how seconds are counted.) Only one timer may be counting at once. Each call disables the previous timer, and an argument of 0 may be supplied to cancel the previous timer without starting a new one. The returned value is the amount of time remaining on the previous timer. For sleeps of finer granularity than one second, you may use Perl's syscall() interface to access setitimer(2) if your system supports it, or else see L below. =item atan2 Y,X Returns the arctangent of Y/X in the range -PI to PI. =item bind SOCKET,NAME Binds a network address to a socket, just as the bind system call does. Returns TRUE if it succeeded, FALSE otherwise. NAME should be a packed address of the appropriate type for the socket. See example in L. =item binmode FILEHANDLE Arranges for the file to be read or written in "binary" mode in operating systems that distinguish between binary and text files. Files that are not in binary mode have CR LF sequences translated to LF on input and LF translated to CR LF on output. Binmode has no effect under Unix; in DOS, it may be imperative. If FILEHANDLE is an expression, the value is taken as the name of the filehandle. =item bless REF,PACKAGE =item bless REF This function tells the referenced object (passed as REF) that it is now an object in PACKAGE--or the current package if no PACKAGE is specified, which is the usual case. It returns the reference for convenience, since a bless() is often the last thing in a constructor. See L for more about the blessing (and blessings) of objects. =item caller EXPR =item caller Returns the context of the current subroutine call. In a scalar context, returns TRUE if there is a caller, that is, if we're in a subroutine or eval() or require(), and FALSE otherwise. In a list context, returns ($package,$filename,$line) = caller; With EXPR, it returns some extra information that the debugger uses to print a stack trace. The value of EXPR indicates how many call frames to go back before the current one. =item chdir EXPR Changes the working directory to EXPR, if possible. If EXPR is omitted, changes to home directory. Returns TRUE upon success, FALSE otherwise. See example under die(). =item chmod LIST Changes the permissions of a list of files. The first element of the list must be the numerical mode. Returns the number of files successfully changed. $cnt = chmod 0755, 'foo', 'bar'; chmod 0755, @executables; =item chomp VARIABLE =item chomp LIST =item chomp This is a slightly safer version of chop (see below). It removes any line ending that corresponds to the current value of C<$/> (also known as $INPUT_RECORD_SEPARATOR in the C module). It returns the number of characters removed. It's often used to remove the newline from the end of an input record when you're worried that the final record may be missing its newline. When in paragraph mode (C<$/ = "">), it removes all trailing newlines from the string. If VARIABLE is omitted, it chomps $_. Example: while (<>) { chomp; # avoid \n on last field @array = split(/:/); ... } You can actually chomp anything that's an lvalue, including an assignment: chomp($cwd = `pwd`); chomp($answer = ); If you chomp a list, each element is chomped, and the total number of characters removed is returned. =item chop VARIABLE =item chop LIST =item chop Chops off the last character of a string and returns the character chopped. It's used primarily to remove the newline from the end of an input record, but is much more efficient than C because it neither scans nor copies the string. If VARIABLE is omitted, chops $_. Example: while (<>) { chop; # avoid \n on last field @array = split(/:/); ... } You can actually chop anything that's an lvalue, including an assignment: chop($cwd = `pwd`); chop($answer = ); If you chop a list, each element is chopped. Only the value of the last chop is returned. =item chown LIST Changes the owner (and group) of a list of files. The first two elements of the list must be the I uid and gid, in that order. Returns the number of files successfully changed. $cnt = chown $uid, $gid, 'foo', 'bar'; chown $uid, $gid, @filenames; Here's an example that looks up non-numeric uids in the passwd file: print "User: "; chop($user = ); print "Files: " chop($pattern = ); ($login,$pass,$uid,$gid) = getpwnam($user) or die "$user not in passwd file"; @ary = <${pattern}>; # expand filenames chown $uid, $gid, @ary; =item chr NUMBER Returns the character represented by that NUMBER in the character set. For example, C is "A" in ASCII. =item chroot FILENAME Does the same as the system call of that name. If you don't know what it does, don't worry about it. If FILENAME is omitted, does chroot to $_. =item close FILEHANDLE Closes the file or pipe associated with the file handle, returning TRUE only if stdio successfully flushes buffers and closes the system file descriptor. You don't have to close FILEHANDLE if you are immediately going to do another open on it, since open will close it for you. (See open().) However, an explicit close on an input file resets the line counter ($.), while the implicit close done by open() does not. Also, closing a pipe will wait for the process executing on the pipe to complete, in case you want to look at the output of the pipe afterwards. Closing a pipe explicitly also puts the status value of the command into C<$?>. Example: open(OUTPUT, '|sort >foo'); # pipe to sort ... # print stuff to output close OUTPUT; # wait for sort to finish open(INPUT, 'foo'); # get sort's results FILEHANDLE may be an expression whose value gives the real filehandle name. =item closedir DIRHANDLE Closes a directory opened by opendir(). =item connect SOCKET,NAME Attempts to connect to a remote socket, just as the connect system call does. Returns TRUE if it succeeded, FALSE otherwise. NAME should be a package address of the appropriate type for the socket. See example in L. =item cos EXPR Returns the cosine of EXPR (expressed in radians). If EXPR is omitted takes cosine of $_. =item crypt PLAINTEXT,SALT Encrypts a string exactly like the crypt(3) function in the C library. Useful for checking the password file for lousy passwords, amongst other things. Only the guys wearing white hats should do this. Here's an example that makes sure that whoever runs this program knows their own password: $pwd = (getpwuid($<))[1]; $salt = substr($pwd, 0, 2); system "stty -echo"; print "Password: "; chop($word = ); print "\n"; system "stty echo"; if (crypt($word, $salt) ne $pwd) { die "Sorry...\n"; } else { print "ok\n"; } Of course, typing in your own password to whoever asks you for it is unwise at best. =item dbmclose ASSOC_ARRAY [This function has been superseded by the untie() function.] Breaks the binding between a DBM file and an associative array. =item dbmopen ASSOC,DBNAME,MODE [This function has been superseded by the tie() function.] This binds a dbm(3) or ndbm(3) file to an associative array. ASSOC is the name of the associative array. (Unlike normal open, the first argument is I a filehandle, even though it looks like one). DBNAME is the name of the database (without the F<.dir> or F<.pag> extension). If the database does not exist, it is created with protection specified by MODE (as modified by the umask()). If your system only supports the older DBM functions, you may perform only one dbmopen() in your program. If your system has neither DBM nor ndbm, calling dbmopen() produces a fatal error. If you don't have write access to the DBM file, you can only read associative array variables, not set them. If you want to test whether you can write, either use file tests or try setting a dummy array entry inside an eval(), which will trap the error. Note that functions such as keys() and values() may return huge array values when used on large DBM files. You may prefer to use the each() function to iterate over large DBM files. Example: # print out history file offsets dbmopen(%HIST,'/usr/lib/news/history',0666); while (($key,$val) = each %HIST) { print $key, ' = ', unpack('L',$val), "\n"; } dbmclose(%HIST); =item defined EXPR Returns a boolean value saying whether the lvalue EXPR has a real value or not. Many operations return the undefined value under exceptional conditions, such as end of file, uninitialized variable, system error and such. This function allows you to distinguish between an undefined null scalar and a defined null scalar with operations that might return a real null string, such as referencing elements of an array. You may also check to see if arrays or subroutines exist. Use of defined on predefined variables is not guaranteed to produce intuitive results. When used on a hash array element, it tells you whether the value is defined, not whether the key exists in the hash. Use exists() for that. Examples: print if defined $switch{'D'}; print "$val\n" while defined($val = pop(@ary)); die "Can't readlink $sym: $!" unless defined($value = readlink $sym); eval '@foo = ()' if defined(@foo); die "No XYZ package defined" unless defined %_XYZ; sub foo { defined &$bar ? &$bar(@_) : die "No bar"; } See also undef(). =item delete EXPR Deletes the specified value from its hash array. Returns the deleted value, or the undefined value if nothing was deleted. Deleting from C<$ENV{}> modifies the environment. Deleting from an array tied to a DBM file deletes the entry from the DBM file. (But deleting from a tie()d hash doesn't necessarily return anything.) The following deletes all the values of an associative array: foreach $key (keys %ARRAY) { delete $ARRAY{$key}; } (But it would be faster to use the undef() command.) Note that the EXPR can be arbitrarily complicated as long as the final operation is a hash key lookup: delete $ref->[$x][$y]{$key}; =item die LIST Outside of an eval(), prints the value of LIST to C and exits with the current value of $! (errno). If $! is 0, exits with the value of C<($? EE 8)> (`command` status). If C<($? EE 8)> is 0, exits with 255. Inside an eval(), the error message is stuffed into C<$@>. and the eval() is terminated with the undefined value. Equivalent examples: die "Can't cd to spool: $!\n" unless chdir '/usr/spool/news'; chdir '/usr/spool/news' or die "Can't cd to spool: $!\n" If the value of EXPR does not end in a newline, the current script line number and input line number (if any) are also printed, and a newline is supplied. Hint: sometimes appending ", stopped" to your message will cause it to make better sense when the string "at foo line 123" is appended. Suppose you are running script "canasta". die "/etc/games is no good"; die "/etc/games is no good, stopped"; produce, respectively /etc/games is no good at canasta line 123. /etc/games is no good, stopped at canasta line 123. See also exit() and warn(). =item do BLOCK Not really a function. Returns the value of the last command in the sequence of commands indicated by BLOCK. When modified by a loop modifier, executes the BLOCK once before testing the loop condition. (On other statements the loop modifiers test the conditional first.) =item do SUBROUTINE(LIST) A deprecated form of subroutine call. See L. =item do EXPR Uses the value of EXPR as a filename and executes the contents of the file as a Perl script. Its primary use is to include subroutines from a Perl subroutine library. do 'stat.pl'; is just like eval `cat stat.pl`; except that it's more efficient, more concise, keeps track of the current filename for error messages, and searches all the B<-I> libraries if the file isn't in the current directory (see also the @INC array in L). It's the same, however, in that it does reparse the file every time you call it, so you probably don't want to do this inside a loop. Note that inclusion of library modules is better done with the use() and require() operators. =item dump LABEL This causes an immediate core dump. Primarily this is so that you can use the B program to turn your core dump into an executable binary after having initialized all your variables at the beginning of the program. When the new binary is executed it will begin by executing a C (with all the restrictions that C suffers). Think of it as a goto with an intervening core dump and reincarnation. If LABEL is omitted, restarts the program from the top. WARNING: any files opened at the time of the dump will NOT be open any more when the program is reincarnated, with possible resulting confusion on the part of Perl. See also B<-u> option in L. Example: #!/usr/bin/perl require 'getopt.pl'; require 'stat.pl'; %days = ( 'Sun' => 1, 'Mon' => 2, 'Tue' => 3, 'Wed' => 4, 'Thu' => 5, 'Fri' => 6, 'Sat' => 7, ); dump QUICKSTART if $ARGV[0] eq '-d'; QUICKSTART: Getopt('f'); =item each ASSOC_ARRAY Returns a 2 element array consisting of the key and value for the next value of an associative array, so that you can iterate over it. Entries are returned in an apparently random order. When the array is entirely read, a null array is returned (which when assigned produces a FALSE (0) value). The next call to each() after that will start iterating again. The iterator can be reset only by reading all the elements from the array. You should not add elements to an array while you're iterating over it. There is a single iterator for each associative array, shared by all each(), keys() and values() function calls in the program. The following prints out your environment like the printenv(1) program, only in a different order: while (($key,$value) = each %ENV) { print "$key=$value\n"; } See also keys() and values(). =item eof FILEHANDLE =item eof Returns 1 if the next read on FILEHANDLE will return end of file, or if FILEHANDLE is not open. FILEHANDLE may be an expression whose value gives the real filehandle name. (Note that this function actually reads a character and then ungetc()s it, so it is not very useful in an interactive context.) An C without an argument returns the eof status for the last file read. Empty parentheses () may be used to indicate the pseudo file formed of the files listed on the command line, i.e. C is reasonable to use inside a while (<>) loop to detect the end of only the last file. Use C or eof without the parentheses to test I file in a while (<>) loop. Examples: # insert dashes just before last line of last file while (<>) { if (eof()) { print "--------------\n"; } print; } # reset line numbering on each input file while (<>) { print "$.\t$_"; if (eof) { # Not eof(). close(ARGV); } } Practical hint: you almost never need to use C in Perl, because the input operators return undef when they run out of data. =item eval EXPR =item eval BLOCK EXPR is parsed and executed as if it were a little Perl program. It is executed in the context of the current Perl program, so that any variable settings, subroutine or format definitions remain afterwards. The value returned is the value of the last expression evaluated, or a return statement may be used, just as with subroutines. If there is a syntax error or runtime error, or a die() statement is executed, an undefined value is returned by eval(), and C<$@> is set to the error message. If there was no error, C<$@> is guaranteed to be a null string. If EXPR is omitted, evaluates $_. The final semicolon, if any, may be omitted from the expression. Note that, since eval() traps otherwise-fatal errors, it is useful for determining whether a particular feature (such as dbmopen() or symlink()) is implemented. It is also Perl's exception trapping mechanism, where the die operator is used to raise exceptions. If the code to be executed doesn't vary, you may use the eval-BLOCK form to trap run-time errors without incurring the penalty of recompiling each time. The error, if any, is still returned in C<$@>. Examples: # make divide-by-zero non-fatal eval { $answer = $a / $b; }; warn $@ if $@; # same thing, but less efficient eval '$answer = $a / $b'; warn $@ if $@; # a compile-time error eval { $answer = }; # a run-time error eval '$answer ='; # sets $@ With an eval(), you should be especially careful to remember what's being looked at when: eval $x; # CASE 1 eval "$x"; # CASE 2 eval '$x'; # CASE 3 eval { $x }; # CASE 4 eval "\$$x++" # CASE 5 $$x++; # CASE 6 Cases 1 and 2 above behave identically: they run the code contained in the variable $x. (Although case 2 has misleading double quotes making the reader wonder what else might be happening (nothing is).) Cases 3 and 4 likewise behave in the same way: they run the code <$x>, which does nothing at all. (Case 4 is preferred for purely visual reasons.) Case 5 is a place where normally you I like to use double quotes, except that in particular situation, you can just use symbolic references instead, as in case 6. =item exec LIST The exec() function executes a system command I. Use the system() function if you want it to return. If there is more than one argument in LIST, or if LIST is an array with more than one value, calls execvp(3) with the arguments in LIST. If there is only one scalar argument, the argument is checked for shell metacharacters. If there are any, the entire argument is passed to C for parsing. If there are none, the argument is split into words and passed directly to execvp(), which is more efficient. Note: exec() (and system(0) do not flush your output buffer, so you may need to set C<$|> to avoid lost output. Examples: exec '/bin/echo', 'Your arguments are: ', @ARGV; exec "sort $outfile | uniq"; If you don't really want to execute the first argument, but want to lie to the program you are executing about its own name, you can specify the program you actually want to run as an "indirect object" (without a comma) in front of the LIST. (This always forces interpretation of the LIST as a multi-valued list, even if there is only a single scalar in the list.) Example: $shell = '/bin/csh'; exec $shell '-sh'; # pretend it's a login shell or, more directly, exec {'/bin/csh'} '-sh'; # pretend it's a login shell =item exists EXPR Returns TRUE if the specified hash key exists in its hash array, even if the corresponding value is undefined. print "Exists\n" if exists $array{$key}; print "Defined\n" if defined $array{$key}; print "True\n" if $array{$key}; A hash element can only be TRUE if it's defined, and defined if it exists, but the reverse doesn't necessarily hold true. Note that the EXPR can be arbitrarily complicated as long as the final operation is a hash key lookup: if (exists $ref->[$x][$y]{$key}) { ... } =item exit EXPR Evaluates EXPR and exits immediately with that value. (Actually, it calls any defined C routines first, but the C routines may not abort the exit. Likewise any object destructors that need to be called are called before exit.) Example: $ans = ; exit 0 if $ans =~ /^[Xx]/; See also die(). If EXPR is omitted, exits with 0 status. =item exp EXPR Returns I (the natural logarithm base) to the power of EXPR. If EXPR is omitted, gives C. =item fcntl FILEHANDLE,FUNCTION,SCALAR Implements the fcntl(2) function. You'll probably have to say use Fcntl; first to get the correct function definitions. Argument processing and value return works just like ioctl() below. Note that fcntl() will produce a fatal error if used on a machine that doesn't implement fcntl(2). For example: use Fcntl; fcntl($filehandle, F_GETLK, $packed_return_buffer); =item fileno FILEHANDLE Returns the file descriptor for a filehandle. This is useful for constructing bitmaps for select(). If FILEHANDLE is an expression, the value is taken as the name of the filehandle. =item flock FILEHANDLE,OPERATION Calls flock(2) on FILEHANDLE. See L for definition of OPERATION. Returns TRUE for success, FALSE on failure. Will produce a fatal error if used on a machine that doesn't implement flock(2). Here's a mailbox appender for BSD systems. $LOCK_SH = 1; $LOCK_EX = 2; $LOCK_NB = 4; $LOCK_UN = 8; sub lock { flock(MBOX,$LOCK_EX); # and, in case someone appended # while we were waiting... seek(MBOX, 0, 2); } sub unlock { flock(MBOX,$LOCK_UN); } open(MBOX, ">>/usr/spool/mail/$ENV{'USER'}") or die "Can't open mailbox: $!"; lock(); print MBOX $msg,"\n\n"; unlock(); Note that flock() can't lock things over the network. You need to do locking with fcntl() for that. =item fork Does a fork(2) system call. Returns the child pid to the parent process and 0 to the child process, or undef if the fork is unsuccessful. Note: unflushed buffers remain unflushed in both processes, which means you may need to set C<$|> ($AUTOFLUSH in English) or call the autoflush() FileHandle method to avoid duplicate output. If you fork() without ever waiting on your children, you will accumulate zombies: $SIG{'CHLD'} = sub { wait }; There's also the double-fork trick (error checking on fork() returns omitted); unless ($pid = fork) { unless (fork) { exec "what you really wanna do"; die "no exec"; # ... or ... some_perl_code_here; exit 0; } exit 0; } waitpid($pid,0); =item formline PICTURE, LIST This is an internal function used by formats, though you may call it too. It formats (see L) a list of values according to the contents of PICTURE, placing the output into the format output accumulator, C<$^A>. Eventually, when a write() is done, the contents of C<$^A> are written to some filehandle, but you could also read C<$^A> yourself and then set C<$^A> back to "". Note that a format typically does one formline() per line of form, but the formline() function itself doesn't care how many newlines are embedded in the PICTURE. Be careful if you put double quotes around the picture, since an "C<@>" character may be taken to mean the beginning of an array name. formline() always returns TRUE. =item getc FILEHANDLE =item getc Returns the next character from the input file attached to FILEHANDLE, or a null string at end of file. If FILEHANDLE is omitted, reads from STDIN. =item getlogin Returns the current login from F, if any. If null, use getpwuid(). $login = getlogin || (getpwuid($<))[0] || "Kilroy"; =item getpeername SOCKET Returns the packed sockaddr address of other end of the SOCKET connection. # An internet sockaddr $sockaddr = 'S n a4 x8'; $hersockaddr = getpeername(S); ($family, $port, $heraddr) = unpack($sockaddr,$hersockaddr); =item getpgrp PID Returns the current process group for the specified PID, 0 for the current process. Will produce a fatal error if used on a machine that doesn't implement getpgrp(2). If PID is omitted, returns process group of current process. =item getppid Returns the process id of the parent process. =item getpriority WHICH,WHO Returns the current priority for a process, a process group, or a user. (See L.) Will produce a fatal error if used on a machine that doesn't implement getpriority(2). =item getpwnam NAME =item getgrnam NAME =item gethostbyname NAME =item getnetbyname NAME =item getprotobyname NAME =item getpwuid UID =item getgrgid GID =item getservbyname NAME,PROTO =item gethostbyaddr ADDR,ADDRTYPE =item getnetbyaddr ADDR,ADDRTYPE =item getprotobynumber NUMBER =item getservbyport PORT,PROTO =item getpwent =item getgrent =item gethostent =item getnetent =item getprotoent =item getservent =item setpwent =item setgrent =item sethostent STAYOPEN =item setnetent STAYOPEN =item setprotoent STAYOPEN =item setservent STAYOPEN =item endpwent =item endgrent =item endhostent =item endnetent =item endprotoent =item endservent These routines perform the same functions as their counterparts in the system library. Within a list context, the return values from the various get routines are as follows: ($name,$passwd,$uid,$gid, $quota,$comment,$gcos,$dir,$shell) = getpw* ($name,$passwd,$gid,$members) = getgr* ($name,$aliases,$addrtype,$length,@addrs) = gethost* ($name,$aliases,$addrtype,$net) = getnet* ($name,$aliases,$proto) = getproto* ($name,$aliases,$port,$proto) = getserv* (If the entry doesn't exist you get a null list.) Within a scalar context, you get the name, unless the function was a lookup by name, in which case you get the other thing, whatever it is. (If the entry doesn't exist you get the undefined value.) For example: $uid = getpwnam $name = getpwuid $name = getpwent $gid = getgrnam $name = getgrgid $name = getgrent etc. The $members value returned by I is a space separated list of the login names of the members of the group. For the I functions, if the C variable is supported in C, it will be returned to you via C<$?> if the function call fails. The @addrs value returned by a successful call is a list of the raw addresses returned by the corresponding system library call. In the Internet domain, each address is four bytes long and you can unpack it by saying something like: ($a,$b,$c,$d) = unpack('C4',$addr[0]); =item getsockname SOCKET Returns the packed sockaddr address of this end of the SOCKET connection. # An internet sockaddr $sockaddr = 'S n a4 x8'; $mysockaddr = getsockname(S); ($family, $port, $myaddr) = unpack($sockaddr,$mysockaddr); =item getsockopt SOCKET,LEVEL,OPTNAME Returns the socket option requested, or undefined if there is an error. =item glob EXPR Returns the value of EXPR with filename expansions such as a shell would do. This is the internal function implementing the <*.*> operator. =item gmtime EXPR Converts a time as returned by the time function to a 9-element array with the time analyzed for the Greenwich timezone. Typically used as follows: ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time); All array elements are numeric, and come straight out of a struct tm. In particular this means that $mon has the range 0..11 and $wday has the range 0..6. If EXPR is omitted, does C. =item goto LABEL =item goto &NAME The goto-LABEL form finds the statement labeled with LABEL and resumes execution there. It may not be used to go into any construct that requires initialization, such as a subroutine or a foreach loop. It also can't be used to go into a construct that is optimized away. It can be used to go almost anywhere else within the dynamic scope, including out of subroutines, but it's usually better to use some other construct such as last or die. The author of Perl has never felt the need to use this form of goto (in Perl, that is--C is another matter). The goto-&NAME form is highly magical, and substitutes a call to the named subroutine for the currently running subroutine. This is used by AUTOLOAD subroutines that wish to load another subroutine and then pretend that the other subroutine had been called in the first place (except that any modifications to @_ in the current subroutine are propagated to the other subroutine.) After the goto, not even caller() will be able to tell that this routine was called first. =item grep BLOCK LIST =item grep EXPR,LIST Evaluates the BLOCK or EXPR for each element of LIST (locally setting $_ to each element) and returns the list value consisting of those elements for which the expression evaluated to TRUE. In a scalar context, returns the number of times the expression was TRUE. @foo = grep(!/^#/, @bar); # weed out comments or equivalently, @foo = grep {!/^#/} @bar; # weed out comments Note that, since $_ is a reference into the list value, it can be used to modify the elements of the array. While this is useful and supported, it can cause bizarre results if the LIST is not a named array. =item hex EXPR Returns the decimal value of EXPR interpreted as an hex string. (To interpret strings that might start with 0 or 0x see oct().) If EXPR is omitted, uses $_. =item import There is no built-in import() function. It is merely an ordinary method subroutine defined (or inherited) by modules that wish to export names to another module. The use() function calls the import() method for the package used. See also L below and L. =item index STR,SUBSTR,POSITION =item index STR,SUBSTR Returns the position of the first occurrence of SUBSTR in STR at or after POSITION. If POSITION is omitted, starts searching from the beginning of the string. The return value is based at 0, or whatever you've set the $[ variable to. If the substring is not found, returns one less than the base, ordinarily -1. =item int EXPR Returns the integer portion of EXPR. If EXPR is omitted, uses $_. =item ioctl FILEHANDLE,FUNCTION,SCALAR Implements the ioctl(2) function. You'll probably have to say require "ioctl.ph"; # probably /usr/local/lib/perl/ioctl.ph first to get the correct function definitions. If ioctl.ph doesn't exist or doesn't have the correct definitions you'll have to roll your own, based on your C header files such as . (There is a Perl script called B that comes with the Perl kit which may help you in this.) SCALAR will be read and/or written depending on the FUNCTION--a pointer to the string value of SCALAR will be passed as the third argument of the actual ioctl call. (If SCALAR has no string value but does have a numeric value, that value will be passed rather than a pointer to the string value. To guarantee this to be TRUE, add a 0 to the scalar before using it.) The pack() and unpack() functions are useful for manipulating the values of structures used by ioctl(). The following example sets the erase character to DEL. require 'ioctl.ph'; $sgttyb_t = "ccccs"; # 4 chars and a short if (ioctl(STDIN,$TIOCGETP,$sgttyb)) { @ary = unpack($sgttyb_t,$sgttyb); $ary[2] = 127; $sgttyb = pack($sgttyb_t,@ary); ioctl(STDIN,$TIOCSETP,$sgttyb) || die "Can't ioctl: $!"; } The return value of ioctl (and fcntl) is as follows: if OS returns: then Perl returns: -1 undefined value 0 string "0 but true" anything else that number Thus Perl returns TRUE on success and FALSE on failure, yet you can still easily determine the actual value returned by the operating system: ($retval = ioctl(...)) || ($retval = -1); printf "System returned %d\n", $retval; =item join EXPR,LIST Joins the separate strings of LIST or ARRAY into a single string with fields separated by the value of EXPR, and returns the string. Example: $_ = join(':', $login,$passwd,$uid,$gid,$gcos,$home,$shell); See L. =item keys ASSOC_ARRAY Returns a normal array consisting of all the keys of the named associative array. (In a scalar context, returns the number of keys.) The keys are returned in an apparently random order, but it is the same order as either the values() or each() function produces (given that the associative array has not been modified). Here is yet another way to print your environment: @keys = keys %ENV; @values = values %ENV; while ($#keys >= 0) { print pop(@keys), '=', pop(@values), "\n"; } or how about sorted by key: foreach $key (sort(keys %ENV)) { print $key, '=', $ENV{$key}, "\n"; } =item kill LIST Sends a signal to a list of processes. The first element of the list must be the signal to send. Returns the number of processes successfully signaled. $cnt = kill 1, $child1, $child2; kill 9, @goners; Unlike in the shell, in Perl if the I is negative, it kills process groups instead of processes. (On System V, a negative I number will also kill process groups, but that's not portable.) That means you usually want to use positive not negative signals. You may also use a signal name in quotes. =item last LABEL =item last The C command is like the C statement in C (as used in loops); it immediately exits the loop in question. If the LABEL is omitted, the command refers to the innermost enclosing loop. The C block, if any, is not executed: line: while () { last line if /^$/; # exit when done with header ... } =item lc EXPR Returns an lowercased version of EXPR. This is the internal function implementing the \L escape in double-quoted strings. =item lcfirst EXPR Returns the value of EXPR with the first character lowercased. This is the internal function implementing the \l escape in double-quoted strings. =item length EXPR Returns the length in characters of the value of EXPR. If EXPR is omitted, returns length of $_. =item link OLDFILE,NEWFILE Creates a new filename linked to the old filename. Returns 1 for success, 0 otherwise. =item listen SOCKET,QUEUESIZE Does the same thing that the listen system call does. Returns TRUE if it succeeded, FALSE otherwise. See example in L. =item local EXPR In general, you should be using "my" instead of "local", because it's faster and safer. Format variables have to use "local" though, as do any other variables whose local value must be visible to called subroutines. This is known as dynamic scoping. Lexical scoping is done with "my", which works more like C's auto declarations. A local modifies the listed variables to be local to the enclosing block, subroutine, eval or "do". If more than one value is listed, the list must be placed in parens. All the listed elements must be legal lvalues. This operator works by saving the current values of those variables in LIST on a hidden stack and restoring them upon exiting the block, subroutine or eval. This means that called subroutines can also reference the local variable, but not the global one. The LIST may be assigned to if desired, which allows you to initialize your local variables. (If no initializer is given for a particular variable, it is created with an undefined value.) Commonly this is used to name the parameters to a subroutine. Examples: sub RANGEVAL { local($min, $max, $thunk) = @_; local $result = ''; local $i; # Presumably $thunk makes reference to $i for ($i = $min; $i < $max; $i++) { $result .= eval $thunk; } $result; } if ($sw eq '-v') { # init local array with global array local @ARGV = @ARGV; unshift(@ARGV,'echo'); system @ARGV; } # @ARGV restored # temporarily add to digits associative array if ($base12) { # (NOTE: not claiming this is efficient!) local(%digits) = (%digits,'t',10,'e',11); parse_num(); } Note that local() is a run-time command, and so gets executed every time through a loop. In Perl 4 it used up more stack storage each time until the loop was exited. Perl 5 reclaims the space each time through, but it's still more efficient to declare your variables outside the loop. When you assign to a localized EXPR, the local doesn't change whether EXPR is viewed as a scalar or an array. So local($foo) = ; local @FOO = ; both supply a list context to the righthand side, while local $foo = ; supplies a scalar context. =item localtime EXPR Converts a time as returned by the time function to a 9-element array with the time analyzed for the local timezone. Typically used as follows: ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); All array elements are numeric, and come straight out of a struct tm. In particular this means that $mon has the range 0..11 and $wday has the range 0..6. If EXPR is omitted, does localtime(time). In a scalar context, prints out the ctime(3) value: $now_string = localtime; # e.g. "Thu Oct 13 04:54:34 1994" See also L and the strftime(3) function available via the POSIX modulie. =item log EXPR Returns logarithm (base I) of EXPR. If EXPR is omitted, returns log of $_. =item lstat FILEHANDLE =item lstat EXPR Does the same thing as the stat() function, but stats a symbolic link instead of the file the symbolic link points to. If symbolic links are unimplemented on your system, a normal stat() is done. =item m// The match operator. See L. =item map BLOCK LIST =item map EXPR,LIST Evaluates the BLOCK or EXPR for each element of LIST (locally setting $_ to each element) and returns the list value composed of the results of each such evaluation. Evaluates BLOCK or EXPR in a list context, so each element of LIST may produce zero, one, or more elements in the returned value. @chars = map(chr, @nums); translates a list of numbers to the corresponding characters. And %hash = map {&key($_), $_} @array; is just a funny way to write %hash = (); foreach $_ (@array) { $hash{&key($_)} = $_; } =item mkdir FILENAME,MODE Creates the directory specified by FILENAME, with permissions specified by MODE (as modified by umask). If it succeeds it returns 1, otherwise it returns 0 and sets $! (errno). =item msgctl ID,CMD,ARG Calls the System V IPC function msgctl. If CMD is &IPC_STAT, then ARG must be a variable which will hold the returned msqid_ds structure. Returns like ioctl: the undefined value for error, "0 but true" for zero, or the actual return value otherwise. =item msgget KEY,FLAGS Calls the System V IPC function msgget. Returns the message queue id, or the undefined value if there is an error. =item msgsnd ID,MSG,FLAGS Calls the System V IPC function msgsnd to send the message MSG to the message queue ID. MSG must begin with the long integer message type, which may be created with C. Returns TRUE if successful, or FALSE if there is an error. =item msgrcv ID,VAR,SIZE,TYPE,FLAGS Calls the System V IPC function msgrcv to receive a message from message queue ID into variable VAR with a maximum message size of SIZE. Note that if a message is received, the message type will be the first thing in VAR, and the maximum length of VAR is SIZE plus the size of the message type. Returns TRUE if successful, or FALSE if there is an error. =item my EXPR A "my" declares the listed variables to be local (lexically) to the enclosing block, subroutine, eval or "do". If more than one value is listed, the list must be placed in parens. All the listed elements must be legal lvalues. Only alphanumeric identifiers may be lexically scoped--magical builtins like $/ must be localized with "local" instead. In particular, you're not allowed to say my $_; # Illegal. Unlike the "local" declaration, variables declared with "my" are totally hidden from the outside world, including any called subroutines (even if it's the same subroutine--every call gets its own copy). (An eval(), however, can see the lexical variables of the scope it is being evaluated in so long as the names aren't hidden by declarations within the eval() itself. See L.) The EXPR may be assigned to if desired, which allows you to initialize your variables. (If no initializer is given for a particular variable, it is created with an undefined value.) Commonly this is used to name the parameters to a subroutine. Examples: sub RANGEVAL { my($min, $max, $thunk) = @_; my $result = ''; my $i; # Presumably $thunk makes reference to $i for ($i = $min; $i < $max; $i++) { $result .= eval $thunk; } $result; } if ($sw eq '-v') { # init my array with global array my @ARGV = @ARGV; unshift(@ARGV,'echo'); system @ARGV; } # Outer @ARGV again visible When you assign to the EXPR, the "my" doesn't change whether EXPR is viewed as a scalar or an array. So my($foo) = ; my @FOO = ; both supply a list context to the righthand side, while my $foo = ; supplies a scalar context. Some users may wish to encourage the use of lexically scoped variables. As an aid to catching implicit references to package variables, if you say use strict 'vars'; then any variable reference from there to the end of the enclosing block must either refer to a lexical variable, or must be fully qualified with the package name. A compilation error results otherwise. An inner block may countermand this with S<"no strict 'vars'">. =item next LABEL =item next The C command is like the C statement in C; it starts the next iteration of the loop: line: while () { next line if /^#/; # discard comments ... } Note that if there were a C block on the above, it would get executed even on discarded lines. If the LABEL is omitted, the command refers to the innermost enclosing loop. =item no Module LIST See the "use" function, which "no" is the opposite of. =item oct EXPR Returns the decimal value of EXPR interpreted as an octal string. (If EXPR happens to start off with 0x, interprets it as a hex string instead.) The following will handle decimal, octal, and hex in the standard Perl or C notation: $val = oct($val) if $val =~ /^0/; If EXPR is omitted, uses $_. =item open FILEHANDLE,EXPR =item open FILEHANDLE Opens the file whose filename is given by EXPR, and associates it with FILEHANDLE. If FILEHANDLE is an expression, its value is used as the name of the real filehandle wanted. If EXPR is omitted, the scalar variable of the same name as the FILEHANDLE contains the filename. If the filename begins with "<" or nothing, the file is opened for input. If the filename begins with ">", the file is opened for output. If the filename begins with ">>", the file is opened for appending. (You can put a '+' in front of the '>' or '<' to indicate that you want both read and write access to the file.) If the filename begins with "|", the filename is interpreted as a command to which output is to be piped, and if the filename ends with a "|", the filename is interpreted as command which pipes input to us. (You may not have a command that pipes both in and out.) Opening '-' opens STDIN and opening '>-' opens STDOUT. Open returns non-zero upon success, the undefined value otherwise. If the open involved a pipe, the return value happens to be the pid of the subprocess. Examples: $ARTICLE = 100; open ARTICLE or die "Can't find article $ARTICLE: $!\n"; while (
) {... open(LOG, '>>/usr/spool/news/twitlog'); # (log is reserved) open(article, "caesar <$article |"); # decrypt article open(extract, "|sort >/tmp/Tmp$$"); # $$ is our process id # process argument list of files along with any includes foreach $file (@ARGV) { process($file, 'fh00'); } sub process { local($filename, $input) = @_; $input++; # this is a string increment unless (open($input, $filename)) { print STDERR "Can't open $filename: $!\n"; return; } while (<$input>) { # note use of indirection if (/^#include "(.*)"/) { process($1, $input); next; } ... # whatever } } You may also, in the Bourne shell tradition, specify an EXPR beginning with ">&", in which case the rest of the string is interpreted as the name of a filehandle (or file descriptor, if numeric) which is to be duped and opened. You may use & after >, >>, <, +>, +>> and +<. The mode you specify should match the mode of the original filehandle. Here is a script that saves, redirects, and restores STDOUT and STDERR: #!/usr/bin/perl open(SAVEOUT, ">&STDOUT"); open(SAVEERR, ">&STDERR"); open(STDOUT, ">foo.out") || die "Can't redirect stdout"; open(STDERR, ">&STDOUT") || die "Can't dup stdout"; select(STDERR); $| = 1; # make unbuffered select(STDOUT); $| = 1; # make unbuffered print STDOUT "stdout 1\n"; # this works for print STDERR "stderr 1\n"; # subprocesses too close(STDOUT); close(STDERR); open(STDOUT, ">&SAVEOUT"); open(STDERR, ">&SAVEERR"); print STDOUT "stdout 2\n"; print STDERR "stderr 2\n"; If you specify "<&=N", where N is a number, then Perl will do an equivalent of C's fdopen() of that file descriptor. For example: open(FILEHANDLE, "<&=$fd") If you open a pipe on the command "-", i.e. either "|-" or "-|", then there is an implicit fork done, and the return value of open is the pid of the child within the parent process, and 0 within the child process. (Use defined($pid) to determine whether the open was successful.) The filehandle behaves normally for the parent, but i/o to that filehandle is piped from/to the STDOUT/STDIN of the child process. In the child process the filehandle isn't opened--i/o happens from/to the new STDOUT or STDIN. Typically this is used like the normal piped open when you want to exercise more control over just how the pipe command gets executed, such as when you are running setuid, and don't want to have to scan shell commands for metacharacters. The following pairs are more or less equivalent: open(FOO, "|tr '[a-z]' '[A-Z]'"); open(FOO, "|-") || exec 'tr', '[a-z]', '[A-Z]'; open(FOO, "cat -n '$file'|"); open(FOO, "-|") || exec 'cat', '-n', $file; Explicitly closing any piped filehandle causes the parent process to wait for the child to finish, and returns the status value in $?. Note: on any operation which may do a fork, unflushed buffers remain unflushed in both processes, which means you may need to set $| to avoid duplicate output. The filename that is passed to open will have leading and trailing whitespace deleted. In order to open a file with arbitrary weird characters in it, it's necessary to protect any leading and trailing whitespace thusly: $file =~ s#^(\s)#./$1#; open(FOO, "< $file\0"); =item opendir DIRHANDLE,EXPR Opens a directory named EXPR for processing by readdir(), telldir(), seekdir(), rewinddir() and closedir(). Returns TRUE if successful. DIRHANDLEs have their own namespace separate from FILEHANDLEs. =item ord EXPR Returns the numeric ascii value of the first character of EXPR. If EXPR is omitted, uses $_. =item pack TEMPLATE,LIST Takes an array or list of values and packs it into a binary structure, returning the string containing the structure. The TEMPLATE is a sequence of characters that give the order and type of values, as follows: A An ascii string, will be space padded. a An ascii string, will be null padded. b A bit string (ascending bit order, like vec()). B A bit string (descending bit order). h A hex string (low nybble first). H A hex string (high nybble first). c A signed char value. C An unsigned char value. s A signed short value. S An unsigned short value. i A signed integer value. I An unsigned integer value. l A signed long value. L An unsigned long value. n A short in "network" order. N A long in "network" order. v A short in "VAX" (little-endian) order. V A long in "VAX" (little-endian) order. f A single-precision float in the native format. d A double-precision float in the native format. p A pointer to a null-terminated string. P A pointer to a structure (fixed-length string). u A uuencoded string. x A null byte. X Back up a byte. @ Null fill to absolute position. Each letter may optionally be followed by a number which gives a repeat count. With all types except "a", "A", "b", "B", "h" and "H", and "P" the pack function will gobble up that many values from the LIST. A * for the repeat count means to use however many items are left. The "a" and "A" types gobble just one value, but pack it as a string of length count, padding with nulls or spaces as necessary. (When unpacking, "A" strips trailing spaces and nulls, but "a" does not.) Likewise, the "b" and "B" fields pack a string that many bits long. The "h" and "H" fields pack a string that many nybbles long. The "P" packs a pointer to a structure of the size indicated by the length. Real numbers (floats and doubles) are in the native machine format only; due to the multiplicity of floating formats around, and the lack of a standard "network" representation, no facility for interchange has been made. This means that packed floating point data written on one machine may not be readable on another - even if both use IEEE floating point arithmetic (as the endian-ness of the memory representation is not part of the IEEE spec). Note that Perl uses doubles internally for all numeric calculation, and converting from double into float and thence back to double again will lose precision (i.e. C) will not in general equal $foo). Examples: $foo = pack("cccc",65,66,67,68); # foo eq "ABCD" $foo = pack("c4",65,66,67,68); # same thing $foo = pack("ccxxcc",65,66,67,68); # foo eq "AB\0\0CD" $foo = pack("s2",1,2); # "\1\0\2\0" on little-endian # "\0\1\0\2" on big-endian $foo = pack("a4","abcd","x","y","z"); # "abcd" $foo = pack("aaaa","abcd","x","y","z"); # "axyz" $foo = pack("a14","abcdefg"); # "abcdefg\0\0\0\0\0\0\0" $foo = pack("i9pl", gmtime); # a real struct tm (on my system anyway) sub bintodec { unpack("N", pack("B32", substr("0" x 32 . shift, -32))); } The same template may generally also be used in the unpack function. =item pipe READHANDLE,WRITEHANDLE Opens a pair of connected pipes like the corresponding system call. Note that if you set up a loop of piped processes, deadlock can occur unless you are very careful. In addition, note that Perl's pipes use stdio buffering, so you may need to set $| to flush your WRITEHANDLE after each command, depending on the application. =item pop ARRAY Pops and returns the last value of the array, shortening the array by 1. Has a similar effect to $tmp = $ARRAY[$#ARRAY--]; If there are no elements in the array, returns the undefined value. =item pos SCALAR Returns the offset of where the last m//g search left off for the variable in question. May be modified to change that offset. =item print FILEHANDLE LIST =item print LIST =item print Prints a string or a comma-separated list of strings. Returns non-zero if successful. FILEHANDLE may be a scalar variable name, in which case the variable contains the name of the filehandle, thus introducing one level of indirection. (NOTE: If FILEHANDLE is a variable and the next token is a term, it may be misinterpreted as an operator unless you interpose a + or put parens around the arguments.) If FILEHANDLE is omitted, prints by default to standard output (or to the last selected output channel--see select()). If LIST is also omitted, prints $_ to STDOUT. To set the default output channel to something other than STDOUT use the select operation. Note that, because print takes a LIST, anything in the LIST is evaluated in a list context, and any subroutine that you call will have one or more of its expressions evaluated in a list context. Also be careful not to follow the print keyword with a left parenthesis unless you want the corresponding right parenthesis to terminate the arguments to the print--interpose a + or put parens around all the arguments. =item printf FILEHANDLE LIST =item printf LIST Equivalent to a "print FILEHANDLE sprintf(LIST)". The first argument of the list will be interpreted as the printf format. =item push ARRAY,LIST Treats ARRAY as a stack, and pushes the values of LIST onto the end of ARRAY. The length of ARRAY increases by the length of LIST. Has the same effect as for $value (LIST) { $ARRAY[++$#ARRAY] = $value; } but is more efficient. Returns the new number of elements in the array. =item q/STRING/ =item qq/STRING/ =item qx/STRING/ =item qw/STRING/ Generalized quotes. See L. =item quotemeta EXPR Returns the value of EXPR with with all regular expression metacharacters backslashed. This is the internal function implementing the \Q escape in double-quoted strings. =item rand EXPR =item rand Returns a random fractional number between 0 and the value of EXPR. (EXPR should be positive.) If EXPR is omitted, returns a value between 0 and 1. This function produces repeatable sequences unless srand() is invoked. See also srand(). (Note: if your rand function consistently returns numbers that are too large or too small, then your version of Perl was probably compiled with the wrong number of RANDBITS. As a workaround, you can usually multiply EXPR by the correct power of 2 to get the range you want. This will make your script unportable, however. It's better to recompile if you can.) =item read FILEHANDLE,SCALAR,LENGTH,OFFSET =item read FILEHANDLE,SCALAR,LENGTH Attempts to read LENGTH bytes of data into variable SCALAR from the specified FILEHANDLE. Returns the number of bytes actually read, or undef if there was an error. SCALAR will be grown or shrunk to the length actually read. An OFFSET may be specified to place the read data at some other place than the beginning of the string. This call is actually implemented in terms of stdio's fread call. To get a true read system call, see sysread(). =item readdir DIRHANDLE Returns the next directory entry for a directory opened by opendir(). If used in a list context, returns all the rest of the entries in the directory. If there are no more entries, returns an undefined value in a scalar context or a null list in a list context. =item readlink EXPR Returns the value of a symbolic link, if symbolic links are implemented. If not, gives a fatal error. If there is some system error, returns the undefined value and sets $! (errno). If EXPR is omitted, uses $_. =item recv SOCKET,SCALAR,LEN,FLAGS Receives a message on a socket. Attempts to receive LENGTH bytes of data into variable SCALAR from the specified SOCKET filehandle. Actually does a C recvfrom(), so that it can returns the address of the sender. Returns the undefined value if there's an error. SCALAR will be grown or shrunk to the length actually read. Takes the same flags as the system call of the same name. =item redo LABEL =item redo The C command restarts the loop block without evaluating the conditional again. The C block, if any, is not executed. If the LABEL is omitted, the command refers to the innermost enclosing loop. This command is normally used by programs that want to lie to themselves about what was just input: # a simpleminded Pascal comment stripper # (warning: assumes no { or } in strings) line: while () { while (s|({.*}.*){.*}|$1 |) {} s|{.*}| |; if (s|{.*| |) { $front = $_; while () { if (/}/) { # end of comment? s|^|$front{|; redo line; } } } print; } =item ref EXPR Returns a TRUE value if EXPR is a reference, FALSE otherwise. The value returned depends on the type of thing the reference is a reference to. Builtin types include: REF SCALAR ARRAY HASH CODE GLOB If the referenced object has been blessed into a package, then that package name is returned instead. You can think of ref() as a typeof() operator. if (ref($r) eq "HASH") { print "r is a reference to an associative array.\n"; } if (!ref ($r) { print "r is not a reference at all.\n"; } See also L. =item rename OLDNAME,NEWNAME Changes the name of a file. Returns 1 for success, 0 otherwise. Will not work across filesystem boundaries. =item require EXPR =item require Demands some semantics specified by EXPR, or by $_ if EXPR is not supplied. If EXPR is numeric, demands that the current version of Perl ($] or $PERL_VERSION) be equal or greater than EXPR. Otherwise, demands that a library file be included if it hasn't already been included. The file is included via the do-FILE mechanism, which is essentially just a variety of eval(). Has semantics similar to the following subroutine: sub require { local($filename) = @_; return 1 if $INC{$filename}; local($realfilename,$result); ITER: { foreach $prefix (@INC) { $realfilename = "$prefix/$filename"; if (-f $realfilename) { $result = do $realfilename; last ITER; } } die "Can't find $filename in \@INC"; } die $@ if $@; die "$filename did not return true value" unless $result; $INC{$filename} = $realfilename; $result; } Note that the file will not be included twice under the same specified name. The file must return TRUE as the last statement to indicate successful execution of any initialization code, so it's customary to end such a file with "1;" unless you're sure it'll return TRUE otherwise. But it's better just to put the "C<1;>", in case you add more statements. If EXPR is a bare word, the require assumes a "F<.pm>" extension for you, to make it easy to load standard modules. This form of loading of modules does not risk altering your namespace. For a yet more powerful import facility, see the L below, and also L. =item reset EXPR =item reset Generally used in a C block at the end of a loop to clear variables and reset ?? searches so that they work again. The expression is interpreted as a list of single characters (hyphens allowed for ranges). All variables and arrays beginning with one of those letters are reset to their pristine state. If the expression is omitted, one-match searches (?pattern?) are reset to match again. Only resets variables or searches in the current package. Always returns 1. Examples: reset 'X'; # reset all X variables reset 'a-z'; # reset lower case variables reset; # just reset ?? searches Resetting "A-Z" is not recommended since you'll wipe out your ARGV and ENV arrays. Only resets package variables--lexical variables are unaffected, but they clean themselves up on scope exit anyway, so anymore you probably want to use them instead. See L. =item return LIST Returns from a subroutine or eval with the value specified. (Note that in the absence of a return a subroutine or eval will automatically return the value of the last expression evaluated.) =item reverse LIST In a list context, returns a list value consisting of the elements of LIST in the opposite order. In a scalar context, returns a string value consisting of the bytes of the first element of LIST in the opposite order. =item rewinddir DIRHANDLE Sets the current position to the beginning of the directory for the readdir() routine on DIRHANDLE. =item rindex STR,SUBSTR,POSITION =item rindex STR,SUBSTR Works just like index except that it returns the position of the LAST occurrence of SUBSTR in STR. If POSITION is specified, returns the last occurrence at or before that position. =item rmdir FILENAME Deletes the directory specified by FILENAME if it is empty. If it succeeds it returns 1, otherwise it returns 0 and sets $! (errno). If FILENAME is omitted, uses $_. =item s/// The substitution operator. See L. =item scalar EXPR Forces EXPR to be interpreted in a scalar context and returns the value of EXPR. =item seek FILEHANDLE,POSITION,WHENCE Randomly positions the file pointer for FILEHANDLE, just like the fseek() call of stdio. FILEHANDLE may be an expression whose value gives the name of the filehandle. The values for WHENCE are 0 to set the file pointer to POSITION, 1 to set the it to current plus POSITION, and 2 to set it to EOF plus offset. You may use the values SEEK_SET, SEEK_CUR, and SEEK_END for this is usin the POSIX module. Returns 1 upon success, 0 otherwise. =item seekdir DIRHANDLE,POS Sets the current position for the readdir() routine on DIRHANDLE. POS must be a value returned by telldir(). Has the same caveats about possible directory compaction as the corresponding system library routine. =item select FILEHANDLE =item select Returns the currently selected filehandle. Sets the current default filehandle for output, if FILEHANDLE is supplied. This has two effects: first, a C or a C without a filehandle will default to this FILEHANDLE. Second, references to variables related to output will refer to this output channel. For example, if you have to set the top of form format for more than one output channel, you might do the following: select(REPORT1); $^ = 'report1_top'; select(REPORT2); $^ = 'report2_top'; FILEHANDLE may be an expression whose value gives the name of the actual filehandle. Thus: $oldfh = select(STDERR); $| = 1; select($oldfh); With Perl 5, filehandles are objects with methods, and the last example is preferably written use FileHandle; STDERR->autoflush(1); =item select RBITS,WBITS,EBITS,TIMEOUT This calls the select system(2) call with the bitmasks specified, which can be constructed using fileno() and vec(), along these lines: $rin = $win = $ein = ''; vec($rin,fileno(STDIN),1) = 1; vec($win,fileno(STDOUT),1) = 1; $ein = $rin | $win; If you want to select on many filehandles you might wish to write a subroutine: sub fhbits { local(@fhlist) = split(' ',$_[0]); local($bits); for (@fhlist) { vec($bits,fileno($_),1) = 1; } $bits; } $rin = &fhbits('STDIN TTY SOCK'); The usual idiom is: ($nfound,$timeleft) = select($rout=$rin, $wout=$win, $eout=$ein, $timeout); or to block until something becomes ready: $nfound = select($rout=$rin, $wout=$win, $eout=$ein, undef); Any of the bitmasks can also be undef. The timeout, if specified, is in seconds, which may be fractional. Note: not all implementations are capable of returning the $timeleft. If not, they always return $timeleft equal to the supplied $timeout. You can effect a 250 microsecond sleep this way: select(undef, undef, undef, 0.25); =item semctl ID,SEMNUM,CMD,ARG Calls the System V IPC function semctl. If CMD is &IPC_STAT or &GETALL, then ARG must be a variable which will hold the returned semid_ds structure or semaphore value array. Returns like ioctl: the undefined value for error, "0 but true" for zero, or the actual return value otherwise. =item semget KEY,NSEMS,FLAGS Calls the System V IPC function semget. Returns the semaphore id, or the undefined value if there is an error. =item semop KEY,OPSTRING Calls the System V IPC function semop to perform semaphore operations such as signaling and waiting. OPSTRING must be a packed array of semop structures. Each semop structure can be generated with C. The number of semaphore operations is implied by the length of OPSTRING. Returns TRUE if successful, or FALSE if there is an error. As an example, the following code waits on semaphore $semnum of semaphore id $semid: $semop = pack("sss", $semnum, -1, 0); die "Semaphore trouble: $!\n" unless semop($semid, $semop); To signal the semaphore, replace "-1" with "1". =item send SOCKET,MSG,FLAGS,TO =item send SOCKET,MSG,FLAGS Sends a message on a socket. Takes the same flags as the system call of the same name. On unconnected sockets you must specify a destination to send TO, in which case it does a C sendto(). Returns the number of characters sent, or the undefined value if there is an error. =item setpgrp PID,PGRP Sets the current process group for the specified PID, 0 for the current process. Will produce a fatal error if used on a machine that doesn't implement setpgrp(2). =item setpriority WHICH,WHO,PRIORITY Sets the current priority for a process, a process group, or a user. (See Lsetpriority(2)>.) Will produce a fatal error if used on a machine that doesn't implement setpriority(2). =item setsockopt SOCKET,LEVEL,OPTNAME,OPTVAL Sets the socket option requested. Returns undefined if there is an error. OPTVAL may be specified as undef if you don't want to pass an argument. =item shift ARRAY =item shift Shifts the first value of the array off and returns it, shortening the array by 1 and moving everything down. If there are no elements in the array, returns the undefined value. If ARRAY is omitted, shifts the @ARGV array in the main program, and the @_ array in subroutines. (This is determined lexically.) See also unshift(), push(), and pop(). Shift() and unshift() do the same thing to the left end of an array that push() and pop() do to the right end. =item shmctl ID,CMD,ARG Calls the System V IPC function shmctl. If CMD is &IPC_STAT, then ARG must be a variable which will hold the returned shmid_ds structure. Returns like ioctl: the undefined value for error, "0 but true" for zero, or the actual return value otherwise. =item shmget KEY,SIZE,FLAGS Calls the System V IPC function shmget. Returns the shared memory segment id, or the undefined value if there is an error. =item shmread ID,VAR,POS,SIZE =item shmwrite ID,STRING,POS,SIZE Reads or writes the System V shared memory segment ID starting at position POS for size SIZE by attaching to it, copying in/out, and detaching from it. When reading, VAR must be a variable which will hold the data read. When writing, if STRING is too long, only SIZE bytes are used; if STRING is too short, nulls are written to fill out SIZE bytes. Return TRUE if successful, or FALSE if there is an error. =item shutdown SOCKET,HOW Shuts down a socket connection in the manner indicated by HOW, which has the same interpretation as in the system call of the same name. =item sin EXPR Returns the sine of EXPR (expressed in radians). If EXPR is omitted, returns sine of $_. =item sleep EXPR =item sleep Causes the script to sleep for EXPR seconds, or forever if no EXPR. May be interrupted by sending the process a SIGALRM. Returns the number of seconds actually slept. You probably cannot mix alarm() and sleep() calls, since sleep() is often implemented using alarm(). On some older systems, it may sleep up to a full second less than what you requested, depending on how it counts seconds. Most modern systems always sleep the full amount. =item socket SOCKET,DOMAIN,TYPE,PROTOCOL Opens a socket of the specified kind and attaches it to filehandle SOCKET. DOMAIN, TYPE and PROTOCOL are specified the same as for the system call of the same name. You should "use Socket;" first to get the proper definitions imported. See the example in L. =item socketpair SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL Creates an unnamed pair of sockets in the specified domain, of the specified type. DOMAIN, TYPE and PROTOCOL are specified the same as for the system call of the same name. If unimplemented, yields a fatal error. Returns TRUE if successful. =item sort SUBNAME LIST =item sort BLOCK LIST =item sort LIST Sorts the LIST and returns the sorted list value. Nonexistent values of arrays are stripped out. If SUBNAME or BLOCK is omitted, sorts in standard string comparison order. If SUBNAME is specified, it gives the name of a subroutine that returns an integer less than, equal to, or greater than 0, depending on how the elements of the array are to be ordered. (The <=> and cmp operators are extremely useful in such routines.) SUBNAME may be a scalar variable name, in which case the value provides the name of the subroutine to use. In place of a SUBNAME, you can provide a BLOCK as an anonymous, in-line sort subroutine. In the interests of efficiency the normal calling code for subroutines is bypassed, with the following effects: the subroutine may not be a recursive subroutine, and the two elements to be compared are passed into the subroutine not via @_ but as $a and $b (see example below). They are passed by reference, so don't modify $a and $b. Examples: # sort lexically @articles = sort @files; # same thing, but with explicit sort routine @articles = sort {$a cmp $b} @files; # same thing in reversed order @articles = sort {$b cmp $a} @files; # sort numerically ascending @articles = sort {$a <=> $b} @files; # sort numerically descending @articles = sort {$b <=> $a} @files; # sort using explicit subroutine name sub byage { $age{$a} <=> $age{$b}; # presuming integers } @sortedclass = sort byage @class; sub backwards { $b cmp $a; } @harry = ('dog','cat','x','Cain','Abel'); @george = ('gone','chased','yz','Punished','Axed'); print sort @harry; # prints AbelCaincatdogx print sort backwards @harry; # prints xdogcatCainAbel print sort @george, 'to', @harry; # prints AbelAxedCainPunishedcatchaseddoggonetoxyz =item splice ARRAY,OFFSET,LENGTH,LIST =item splice ARRAY,OFFSET,LENGTH =item splice ARRAY,OFFSET Removes the elements designated by OFFSET and LENGTH from an array, and replaces them with the elements of LIST, if any. Returns the elements removed from the array. The array grows or shrinks as necessary. If LENGTH is omitted, removes everything from OFFSET onward. The following equivalencies hold (assuming $[ == 0): push(@a,$x,$y) splice(@a,$#a+1,0,$x,$y) pop(@a) splice(@a,-1) shift(@a) splice(@a,0,1) unshift(@a,$x,$y) splice(@a,0,0,$x,$y) $a[$x] = $y splice(@a,$x,1,$y); Example, assuming array lengths are passed before arrays: sub aeq { # compare two list values local(@a) = splice(@_,0,shift); local(@b) = splice(@_,0,shift); return 0 unless @a == @b; # same len? while (@a) { return 0 if pop(@a) ne pop(@b); } return 1; } if (&aeq($len,@foo[1..$len],0+@bar,@bar)) { ... } =item split /PATTERN/,EXPR,LIMIT =item split /PATTERN/,EXPR =item split /PATTERN/ =item split Splits a string into an array of strings, and returns it. If not in a list context, returns the number of fields found and splits into the @_ array. (In a list context, you can force the split into @_ by using C as the pattern delimiters, but it still returns the array value.) The use of implicit split to @_ is deprecated, however. If EXPR is omitted, splits the $_ string. If PATTERN is also omitted, splits on whitespace (C). Anything matching PATTERN is taken to be a delimiter separating the fields. (Note that the delimiter may be longer than one character.) If LIMIT is specified and is not negative, splits into no more than that many fields (though it may split into fewer). If LIMIT is unspecified, trailing null fields are stripped (which potential users of pop() would do well to remember). If LIMIT is negative, it is treated as if an arbitrarily large LIMIT had been specified. A pattern matching the null string (not to be confused with a null pattern C may be replaced with an expression to specify patterns that vary at runtime. (To do runtime compilation only once, use C.) As a special case, specifying a space S<(' ')> will split on white space just as split with no arguments does, but leading white space does I produce a null first field. Thus, split(' ') can be used to emulate B's default behavior, whereas C will give you as many null initial fields as there are leading spaces. Example: open(passwd, '/etc/passwd'); while () { ($login, $passwd, $uid, $gid, $gcos, $home, $shell) = split(/:/); ... } (Note that $shell above will still have a newline on it. See L, L, and L.) =item sprintf FORMAT,LIST Returns a string formatted by the usual printf conventions of the C language. (The * character for an indirectly specified length is not supported, but you can get the same effect by interpolating a variable into the pattern.) =item sqrt EXPR Return the square root of EXPR. If EXPR is omitted, returns square root of $_. =item srand EXPR Sets the random number seed for the C operator. If EXPR is omitted, does C. Of course, you'd need something much more random than that for cryptographic purposes, since it's easy to guess the current time. Checksumming the compressed output of rapidly changing operating system status programs is the usual method. Examples are posted regularly to comp.security.unix. =item stat FILEHANDLE =item stat EXPR Returns a 13-element array giving the status info for a file, either the file opened via FILEHANDLE, or named by EXPR. Returns a null list if the stat fails. Typically used as follows: ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) = stat($filename); If stat is passed the special filehandle consisting of an underline, no stat is done, but the current contents of the stat structure from the last stat or filetest are returned. Example: if (-x $file && (($d) = stat(_)) && $d < 0) { print "$file is executable NFS file\n"; } (This only works on machines for which the device number is negative under NFS.) =item study SCALAR =item study Takes extra time to study SCALAR ($_ if unspecified) in anticipation of doing many pattern matches on the string before it is next modified. This may or may not save time, depending on the nature and number of patterns you are searching on, and on the distribution of character frequencies in the string to be searched--you probably want to compare runtimes with and without it to see which runs faster. Those loops which scan for many short constant strings (including the constant parts of more complex patterns) will benefit most. You may have only one study active at a time--if you study a different scalar the first is "unstudied". (The way study works is this: a linked list of every character in the string to be searched is made, so we know, for example, where all the 'k' characters are. From each search string, the rarest character is selected, based on some static frequency tables constructed from some C programs and English text. Only those places that contain this "rarest" character are examined.) For example, here is a loop which inserts index producing entries before any line containing a certain pattern: while (<>) { study; print ".IX foo\n" if /\bfoo\b/; print ".IX bar\n" if /\bbar\b/; print ".IX blurfl\n" if /\bblurfl\b/; ... print; } In searching for /\bfoo\b/, only those locations in $_ that contain "f" will be looked at, because "f" is rarer than "o". In general, this is a big win except in pathological cases. The only question is whether it saves you more time than it took to build the linked list in the first place. Note that if you have to look for strings that you don't know till runtime, you can build an entire loop as a string and eval that to avoid recompiling all your patterns all the time. Together with undefining $/ to input entire files as one record, this can be very fast, often faster than specialized programs like fgrep(1). The following scans a list of files (@files) for a list of words (@words), and prints out the names of those files that contain a match: $search = 'while (<>) { study;'; foreach $word (@words) { $search .= "++\$seen{\$ARGV} if /\\b$word\\b/;\n"; } $search .= "}"; @ARGV = @files; undef $/; eval $search; # this screams $/ = "\n"; # put back to normal input delim foreach $file (sort keys(%seen)) { print $file, "\n"; } =item substr EXPR,OFFSET,LEN =item substr EXPR,OFFSET Extracts a substring out of EXPR and returns it. First character is at offset 0, or whatever you've set $[ to. If OFFSET is negative, starts that far from the end of the string. If LEN is omitted, returns everything to the end of the string. You can use the substr() function as an lvalue, in which case EXPR must be an lvalue. If you assign something shorter than LEN, the string will shrink, and if you assign something longer than LEN, the string will grow to accommodate it. To keep the string the same length you may need to pad or chop your value using sprintf(). =item symlink OLDFILE,NEWFILE Creates a new filename symbolically linked to the old filename. Returns 1 for success, 0 otherwise. On systems that don't support symbolic links, produces a fatal error at run time. To check for that, use eval: $symlink_exists = (eval 'symlink("","");', $@ eq ''); =item syscall LIST Calls the system call specified as the first element of the list, passing the remaining elements as arguments to the system call. If unimplemented, produces a fatal error. The arguments are interpreted as follows: if a given argument is numeric, the argument is passed as an int. If not, the pointer to the string value is passed. You are responsible to make sure a string is pre-extended long enough to receive any result that might be written into a string. If your integer arguments are not literals and have never been interpreted in a numeric context, you may need to add 0 to them to force them to look like numbers. require 'syscall.ph'; # may need to run h2ph syscall(&SYS_write, fileno(STDOUT), "hi there\n", 9); Note that Perl only supports passing of up to 14 arguments to your system call, which in practice should usually suffice. =item sysread FILEHANDLE,SCALAR,LENGTH,OFFSET =item sysread FILEHANDLE,SCALAR,LENGTH Attempts to read LENGTH bytes of data into variable SCALAR from the specified FILEHANDLE, using the system call read(2). It bypasses stdio, so mixing this with other kinds of reads may cause confusion. Returns the number of bytes actually read, or undef if there was an error. SCALAR will be grown or shrunk to the length actually read. An OFFSET may be specified to place the read data at some other place than the beginning of the string. =item system LIST Does exactly the same thing as "exec LIST" except that a fork is done first, and the parent process waits for the child process to complete. Note that argument processing varies depending on the number of arguments. The return value is the exit status of the program as returned by the wait() call. To get the actual exit value divide by 256. See also L. =item syswrite FILEHANDLE,SCALAR,LENGTH,OFFSET =item syswrite FILEHANDLE,SCALAR,LENGTH Attempts to write LENGTH bytes of data from variable SCALAR to the specified FILEHANDLE, using the system call write(2). It bypasses stdio, so mixing this with prints may cause confusion. Returns the number of bytes actually written, or undef if there was an error. An OFFSET may be specified to place the read data at some other place than the beginning of the string. =item tell FILEHANDLE =item tell Returns the current file position for FILEHANDLE. FILEHANDLE may be an expression whose value gives the name of the actual filehandle. If FILEHANDLE is omitted, assumes the file last read. =item telldir DIRHANDLE Returns the current position of the readdir() routines on DIRHANDLE. Value may be given to seekdir() to access a particular location in a directory. Has the same caveats about possible directory compaction as the corresponding system library routine. =item tie VARIABLE,PACKAGENAME,LIST This function binds a variable to a package that will provide the implementation for the variable. VARIABLE is the name of the variable to be enchanted. PACKAGENAME is the name of a package implementing objects of correct type. Any additional arguments are passed to the "new" method of the package. Typically these are arguments such as might be passed to the dbm_open() function of C. Note that functions such as keys() and values() may return huge array values when used on large DBM files. You may prefer to use the each() function to iterate over large DBM files. Example: # print out history file offsets tie(%HIST, NDBM_File, '/usr/lib/news/history', 1, 0); while (($key,$val) = each %HIST) { print $key, ' = ', unpack('L',$val), "\n"; } untie(%HIST); A package implementing an associative array should have the following methods: TIEHASH objectname, LIST DESTROY this FETCH this, key STORE this, key, value DELETE this, key EXISTS this, key FIRSTKEY this NEXTKEY this, lastkey A package implementing an ordinary array should have the following methods: TIEARRAY objectname, LIST DESTROY this FETCH this, key STORE this, key, value [others TBD] A package implementing a scalar should have the following methods: TIESCALAR objectname, LIST DESTROY this FETCH this, STORE this, value =item time Returns the number of non-leap seconds since 00:00:00 UTC, January 1, 1970. Suitable for feeding to gmtime() and localtime(). =item times Returns a four-element array giving the user and system times, in seconds, for this process and the children of this process. ($user,$system,$cuser,$csystem) = times; =item tr/// The translation operator. See L. =item truncate FILEHANDLE,LENGTH =item truncate EXPR,LENGTH Truncates the file opened on FILEHANDLE, or named by EXPR, to the specified length. Produces a fatal error if truncate isn't implemented on your system. =item uc EXPR Returns an uppercased version of EXPR. This is the internal function implementing the \U escape in double-quoted strings. =item ucfirst EXPR Returns the value of EXPR with the first character uppercased. This is the internal function implementing the \u escape in double-quoted strings. =item umask EXPR =item umask Sets the umask for the process and returns the old one. If EXPR is omitted, merely returns current umask. =item undef EXPR =item undef Undefines the value of EXPR, which must be an lvalue. Use only on a scalar value, an entire array, or a subroutine name (using "&"). (Using undef() will probably not do what you expect on most predefined variables or DBM list values, so don't do that.) Always returns the undefined value. You can omit the EXPR, in which case nothing is undefined, but you still get an undefined value that you could, for instance, return from a subroutine. Examples: undef $foo; undef $bar{'blurfl'}; undef @ary; undef %assoc; undef &mysub; return (wantarray ? () : undef) if $they_blew_it; =item unlink LIST Deletes a list of files. Returns the number of files successfully deleted. $cnt = unlink 'a', 'b', 'c'; unlink @goners; unlink <*.bak>; Note: unlink will not delete directories unless you are superuser and the B<-U> flag is supplied to Perl. Even if these conditions are met, be warned that unlinking a directory can inflict damage on your filesystem. Use rmdir instead. =item unpack TEMPLATE,EXPR Unpack does the reverse of pack: it takes a string representing a structure and expands it out into a list value, returning the array value. (In a scalar context, it merely returns the first value produced.) The TEMPLATE has the same format as in the pack function. Here's a subroutine that does substring: sub substr { local($what,$where,$howmuch) = @_; unpack("x$where a$howmuch", $what); } and then there's sub ordinal { unpack("c",$_[0]); } # same as ord() In addition, you may prefix a field with a % to indicate that you want a -bit checksum of the items instead of the items themselves. Default is a 16-bit checksum. For example, the following computes the same number as the System V sum program: while (<>) { $checksum += unpack("%16C*", $_); } $checksum %= 65536; The following efficiently counts the number of set bits in a bit vector: $setbits = unpack("%32b*", $selectmask); =item untie VARIABLE Breaks the binding between a variable and a package. (See tie().) =item unshift ARRAY,LIST Does the opposite of a C. Or the opposite of a C, depending on how you look at it. Prepends list to the front of the array, and returns the new number of elements in the array. unshift(ARGV, '-e') unless $ARGV[0] =~ /^-/; Note the LIST is prepended whole, not one element at a time, so the prepended elements stay in the same order. Use reverse to do the reverse. =item use Module LIST =item use Module Imports some semantics into the current package from the named module, generally by aliasing certain subroutine or variable names into your package. It is exactly equivalent to BEGIN { require Module; import Module LIST; } If you don't want your namespace altered, use require instead. The BEGIN forces the require and import to happen at compile time. The require makes sure the module is loaded into memory if it hasn't been yet. The import is not a builtin--it's just an ordinary static method call into the "Module" package to tell the module to import the list of features back into the current package. The module can implement its import method any way it likes, though most modules just choose to derive their import method via inheritance from the Exporter class that is defined in the Exporter module. Because this is a wide-open interface, pragmas (compiler directives) are also implemented this way. Currently implemented pragmas are: use integer; use sigtrap qw(SEGV BUS); use strict qw(subs vars refs); use subs qw(afunc blurfl); These pseudomodules import semantics into the current block scope, unlike ordinary modules, which import symbols into the current package (which are effective through the end of the file). There's a corresponding "no" command that unimports meanings imported by use. no integer; no strict 'refs'; See L for a list of standard modules and pragmas. =item utime LIST Changes the access and modification times on each file of a list of files. The first two elements of the list must be the NUMERICAL access and modification times, in that order. Returns the number of files successfully changed. The inode modification time of each file is set to the current time. Example of a "touch" command: #!/usr/bin/perl $now = time; utime $now, $now, @ARGV; =item values ASSOC_ARRAY Returns a normal array consisting of all the values of the named associative array. (In a scalar context, returns the number of values.) The values are returned in an apparently random order, but it is the same order as either the keys() or each() function would produce on the same array. See also keys() and each(). =item vec EXPR,OFFSET,BITS Treats a string as a vector of unsigned integers, and returns the value of the bitfield specified. May also be assigned to. BITS must be a power of two from 1 to 32. Vectors created with vec() can also be manipulated with the logical operators |, & and ^, which will assume a bit vector operation is desired when both operands are strings. To transform a bit vector into a string or array of 0's and 1's, use these: $bits = unpack("b*", $vector); @bits = split(//, unpack("b*", $vector)); If you know the exact length in bits, it can be used in place of the *. =item wait Waits for a child process to terminate and returns the pid of the deceased process, or -1 if there are no child processes. The status is returned in $?. =item waitpid PID,FLAGS Waits for a particular child process to terminate and returns the pid of the deceased process, or -1 if there is no such child process. The status is returned in $?. If you say use POSIX "wait_h"; ... waitpid(-1,&WNOHANG); then you can do a non-blocking wait for any process. Non-blocking wait is only available on machines supporting either the waitpid(2) or wait4(2) system calls. However, waiting for a particular pid with FLAGS of 0 is implemented everywhere. (Perl emulates the system call by remembering the status values of processes that have exited but have not been harvested by the Perl script yet.) =item wantarray Returns TRUE if the context of the currently executing subroutine is looking for a list value. Returns FALSE if the context is looking for a scalar. return wantarray ? () : undef; =item warn LIST Produces a message on STDERR just like die(), but doesn't exit or throw an exception. =item write FILEHANDLE =item write EXPR =item write Writes a formatted record (possibly multi-line) to the specified file, using the format associated with that file. By default the format for a file is the one having the same name is the filehandle, but the format for the current output channel (see the select() function) may be set explicitly by assigning the name of the format to the $~ variable. Top of form processing is handled automatically: if there is insufficient room on the current page for the formatted record, the page is advanced by writing a form feed, a special top-of-page format is used to format the new page header, and then the record is written. By default the top-of-page format is the name of the filehandle with "_TOP" appended, but it may be dynamically set to the format of your choice by assigning the name to the $^ variable while the filehandle is selected. The number of lines remaining on the current page is in variable $-, which can be set to 0 to force a new page. If FILEHANDLE is unspecified, output goes to the current default output channel, which starts out as STDOUT but may be changed by the C