From cf90a21ebd2262e09730a5a55c5ccb62f1622fad Mon Sep 17 00:00:00 2001 From: Mark Murray Date: Sat, 16 Mar 2002 20:14:31 +0000 Subject: Vendor import Perl 5.6.1 --- contrib/perl5/Porting/repository.pod | 327 + contrib/perl5/ext/B/B/Concise.pm | 823 ++ contrib/perl5/ext/DynaLoader/dl_dllload.xs | 189 + contrib/perl5/ext/DynaLoader/dl_mac.xs | 137 + contrib/perl5/ext/DynaLoader/hints/netbsd.pl | 3 + contrib/perl5/ext/POSIX/hints/svr4.pl | 12 + contrib/perl5/ext/re/hints/aix.pl | 22 + contrib/perl5/hints/nonstopux.sh | 17 + contrib/perl5/lib/File/Spec/Epoc.pm | 378 + contrib/perl5/lib/File/Temp.pm | 1863 +++++ contrib/perl5/lib/Pod/LaTeX.pm | 1591 ++++ contrib/perl5/lib/Pod/Text/Overstrike.pm | 160 + contrib/perl5/lib/Win32.pod | 287 + contrib/perl5/lib/unicode/BidiMirr.txt | 238 + contrib/perl5/lib/unicode/CaseFold.txt | 821 ++ contrib/perl5/lib/unicode/Is/BidiAL.pl | 25 + contrib/perl5/lib/unicode/Is/BidiBN.pl | 15 + contrib/perl5/lib/unicode/Is/BidiLRE.pl | 6 + contrib/perl5/lib/unicode/Is/BidiLRO.pl | 6 + contrib/perl5/lib/unicode/Is/BidiNSM.pl | 97 + contrib/perl5/lib/unicode/Is/BidiPDF.pl | 6 + contrib/perl5/lib/unicode/Is/BidiRLE.pl | 6 + contrib/perl5/lib/unicode/Is/BidiRLO.pl | 6 + contrib/perl5/lib/unicode/Is/Blank.pl | 12 + contrib/perl5/lib/unicode/Is/Cf.pl | 12 + contrib/perl5/lib/unicode/Is/Cs.pl | 8 + contrib/perl5/lib/unicode/Is/DCfraction.pl | 7 + contrib/perl5/lib/unicode/Is/DCmedial.pl | 59 + contrib/perl5/lib/unicode/Is/LbrkAI.pl | 139 + contrib/perl5/lib/unicode/Is/LbrkAL.pl | 387 + contrib/perl5/lib/unicode/Is/LbrkB2.pl | 6 + contrib/perl5/lib/unicode/Is/LbrkBA.pl | 19 + contrib/perl5/lib/unicode/Is/LbrkBB.pl | 8 + contrib/perl5/lib/unicode/Is/LbrkBK.pl | 7 + contrib/perl5/lib/unicode/Is/LbrkCB.pl | 6 + contrib/perl5/lib/unicode/Is/LbrkCL.pl | 47 + contrib/perl5/lib/unicode/Is/LbrkCM.pl | 117 + contrib/perl5/lib/unicode/Is/LbrkCR.pl | 6 + contrib/perl5/lib/unicode/Is/LbrkEX.pl | 10 + contrib/perl5/lib/unicode/Is/LbrkGL.pl | 11 + contrib/perl5/lib/unicode/Is/LbrkHY.pl | 6 + contrib/perl5/lib/unicode/Is/LbrkID.pl | 81 + contrib/perl5/lib/unicode/Is/LbrkIN.pl | 6 + contrib/perl5/lib/unicode/Is/LbrkIS.pl | 9 + contrib/perl5/lib/unicode/Is/LbrkLF.pl | 6 + contrib/perl5/lib/unicode/Is/LbrkNS.pl | 41 + contrib/perl5/lib/unicode/Is/LbrkNU.pl | 24 + contrib/perl5/lib/unicode/Is/LbrkOP.pl | 43 + contrib/perl5/lib/unicode/Is/LbrkPO.pl | 16 + contrib/perl5/lib/unicode/Is/LbrkPR.pl | 21 + contrib/perl5/lib/unicode/Is/LbrkQU.pl | 13 + contrib/perl5/lib/unicode/Is/LbrkSA.pl | 30 + contrib/perl5/lib/unicode/Is/LbrkSG.pl | 8 + contrib/perl5/lib/unicode/Is/LbrkSP.pl | 6 + contrib/perl5/lib/unicode/Is/LbrkSY.pl | 6 + contrib/perl5/lib/unicode/Is/LbrkXX.pl | 5 + contrib/perl5/lib/unicode/Is/LbrkZW.pl | 6 + contrib/perl5/lib/unicode/Is/Me.pl | 9 + contrib/perl5/lib/unicode/Is/Nl.pl | 9 + contrib/perl5/lib/unicode/Is/Pc.pl | 12 + contrib/perl5/lib/unicode/Is/Pf.pl | 9 + contrib/perl5/lib/unicode/Is/Pi.pl | 10 + contrib/perl5/lib/unicode/Is/Sk.pl | 27 + contrib/perl5/lib/unicode/Is/SpacePerl.pl | 14 + contrib/perl5/lib/unicode/Is/SylAA.pl | 25 + contrib/perl5/lib/unicode/Is/SylAAI.pl | 19 + contrib/perl5/lib/unicode/Is/SylAI.pl | 7 + contrib/perl5/lib/unicode/Is/SylEE.pl | 34 + contrib/perl5/lib/unicode/Is/SylII.pl | 25 + contrib/perl5/lib/unicode/Is/SylN.pl | 6 + contrib/perl5/lib/unicode/Is/SylOO.pl | 25 + contrib/perl5/lib/unicode/Is/SylWAA.pl | 19 + contrib/perl5/lib/unicode/Is/SylWEE.pl | 6 + contrib/perl5/lib/unicode/Is/SylWII.pl | 15 + contrib/perl5/lib/unicode/Is/SylWO.pl | 16 + contrib/perl5/lib/unicode/Is/SylWOO.pl | 15 + contrib/perl5/lib/unicode/Is/SylWU.pl | 6 + contrib/perl5/lib/unicode/PropList.txt | 3592 +++++++++ contrib/perl5/lib/unicode/README.perl | 37 + contrib/perl5/lib/unicode/UCD301.html | 201 + contrib/perl5/lib/unicode/UCDFF301.html | 1025 +++ contrib/perl5/lib/unicode/Unicode.301 | 10621 +++++++++++++++++++++++++ contrib/perl5/pod/Makefile.SH | 167 + contrib/perl5/pod/buildtoc.PL | 492 ++ contrib/perl5/pod/perlclib.pod | 197 + contrib/perl5/pod/perldebtut.pod | 721 ++ contrib/perl5/pod/perlebcdic.pod | 1235 +++ contrib/perl5/pod/perlmodlib.PL | 1383 ++++ contrib/perl5/pod/perlnewmod.pod | 282 + contrib/perl5/pod/perlrequick.pod | 503 ++ contrib/perl5/pod/perlretut.pod | 2504 ++++++ contrib/perl5/pod/perlutil.pod | 185 + contrib/perl5/t/lib/b.t | 163 + contrib/perl5/t/lib/cgi-esc.t | 56 + contrib/perl5/t/lib/cgi-pretty.t | 41 + contrib/perl5/t/lib/class-struct.t | 66 + contrib/perl5/t/lib/ftmp-mktemp.t | 114 + contrib/perl5/t/lib/ftmp-posix.t | 81 + contrib/perl5/t/lib/ftmp-security.t | 140 + contrib/perl5/t/lib/ftmp-tempfile.t | 145 + contrib/perl5/t/lib/gol-oo.t | 26 + contrib/perl5/t/lib/peek.t | 312 + contrib/perl5/t/lib/selfloader.t | 201 + contrib/perl5/t/lib/syslog.t | 59 + contrib/perl5/t/lib/tie-refhash.t | 305 + contrib/perl5/t/lib/tie-splice.t | 17 + contrib/perl5/t/lib/tie-substrhash.t | 111 + contrib/perl5/t/op/anonsub.t | 93 + contrib/perl5/t/op/concat.t | 100 + contrib/perl5/t/op/length.t | 85 + contrib/perl5/t/op/my_stash.t | 31 + contrib/perl5/t/op/regmesg.t | 179 + contrib/perl5/t/op/reverse.t | 33 + contrib/perl5/t/op/utf8decode.t | 183 + contrib/perl5/t/pod/find.t | 119 + contrib/perl5/t/run/runenv.t | 147 + 116 files changed, 34483 insertions(+) create mode 100644 contrib/perl5/Porting/repository.pod create mode 100644 contrib/perl5/ext/B/B/Concise.pm create mode 100644 contrib/perl5/ext/DynaLoader/dl_dllload.xs create mode 100644 contrib/perl5/ext/DynaLoader/dl_mac.xs create mode 100644 contrib/perl5/ext/DynaLoader/hints/netbsd.pl create mode 100644 contrib/perl5/ext/POSIX/hints/svr4.pl create mode 100644 contrib/perl5/ext/re/hints/aix.pl create mode 100644 contrib/perl5/hints/nonstopux.sh create mode 100644 contrib/perl5/lib/File/Spec/Epoc.pm create mode 100644 contrib/perl5/lib/File/Temp.pm create mode 100644 contrib/perl5/lib/Pod/LaTeX.pm create mode 100644 contrib/perl5/lib/Pod/Text/Overstrike.pm create mode 100644 contrib/perl5/lib/Win32.pod create mode 100644 contrib/perl5/lib/unicode/BidiMirr.txt create mode 100644 contrib/perl5/lib/unicode/CaseFold.txt create mode 100644 contrib/perl5/lib/unicode/Is/BidiAL.pl create mode 100644 contrib/perl5/lib/unicode/Is/BidiBN.pl create mode 100644 contrib/perl5/lib/unicode/Is/BidiLRE.pl create mode 100644 contrib/perl5/lib/unicode/Is/BidiLRO.pl create mode 100644 contrib/perl5/lib/unicode/Is/BidiNSM.pl create mode 100644 contrib/perl5/lib/unicode/Is/BidiPDF.pl create mode 100644 contrib/perl5/lib/unicode/Is/BidiRLE.pl create mode 100644 contrib/perl5/lib/unicode/Is/BidiRLO.pl create mode 100644 contrib/perl5/lib/unicode/Is/Blank.pl create mode 100644 contrib/perl5/lib/unicode/Is/Cf.pl create mode 100644 contrib/perl5/lib/unicode/Is/Cs.pl create mode 100644 contrib/perl5/lib/unicode/Is/DCfraction.pl create mode 100644 contrib/perl5/lib/unicode/Is/DCmedial.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkAI.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkAL.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkB2.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkBA.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkBB.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkBK.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkCB.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkCL.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkCM.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkCR.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkEX.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkGL.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkHY.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkID.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkIN.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkIS.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkLF.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkNS.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkNU.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkOP.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkPO.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkPR.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkQU.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkSA.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkSG.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkSP.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkSY.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkXX.pl create mode 100644 contrib/perl5/lib/unicode/Is/LbrkZW.pl create mode 100644 contrib/perl5/lib/unicode/Is/Me.pl create mode 100644 contrib/perl5/lib/unicode/Is/Nl.pl create mode 100644 contrib/perl5/lib/unicode/Is/Pc.pl create mode 100644 contrib/perl5/lib/unicode/Is/Pf.pl create mode 100644 contrib/perl5/lib/unicode/Is/Pi.pl create mode 100644 contrib/perl5/lib/unicode/Is/Sk.pl create mode 100644 contrib/perl5/lib/unicode/Is/SpacePerl.pl create mode 100644 contrib/perl5/lib/unicode/Is/SylAA.pl create mode 100644 contrib/perl5/lib/unicode/Is/SylAAI.pl create mode 100644 contrib/perl5/lib/unicode/Is/SylAI.pl create mode 100644 contrib/perl5/lib/unicode/Is/SylEE.pl create mode 100644 contrib/perl5/lib/unicode/Is/SylII.pl create mode 100644 contrib/perl5/lib/unicode/Is/SylN.pl create mode 100644 contrib/perl5/lib/unicode/Is/SylOO.pl create mode 100644 contrib/perl5/lib/unicode/Is/SylWAA.pl create mode 100644 contrib/perl5/lib/unicode/Is/SylWEE.pl create mode 100644 contrib/perl5/lib/unicode/Is/SylWII.pl create mode 100644 contrib/perl5/lib/unicode/Is/SylWO.pl create mode 100644 contrib/perl5/lib/unicode/Is/SylWOO.pl create mode 100644 contrib/perl5/lib/unicode/Is/SylWU.pl create mode 100644 contrib/perl5/lib/unicode/PropList.txt create mode 100644 contrib/perl5/lib/unicode/README.perl create mode 100644 contrib/perl5/lib/unicode/UCD301.html create mode 100644 contrib/perl5/lib/unicode/UCDFF301.html create mode 100644 contrib/perl5/lib/unicode/Unicode.301 create mode 100644 contrib/perl5/pod/Makefile.SH create mode 100755 contrib/perl5/pod/buildtoc.PL create mode 100644 contrib/perl5/pod/perlclib.pod create mode 100644 contrib/perl5/pod/perldebtut.pod create mode 100644 contrib/perl5/pod/perlebcdic.pod create mode 100755 contrib/perl5/pod/perlmodlib.PL create mode 100644 contrib/perl5/pod/perlnewmod.pod create mode 100644 contrib/perl5/pod/perlrequick.pod create mode 100644 contrib/perl5/pod/perlretut.pod create mode 100644 contrib/perl5/pod/perlutil.pod create mode 100755 contrib/perl5/t/lib/b.t create mode 100755 contrib/perl5/t/lib/cgi-esc.t create mode 100755 contrib/perl5/t/lib/cgi-pretty.t create mode 100755 contrib/perl5/t/lib/class-struct.t create mode 100755 contrib/perl5/t/lib/ftmp-mktemp.t create mode 100755 contrib/perl5/t/lib/ftmp-posix.t create mode 100755 contrib/perl5/t/lib/ftmp-security.t create mode 100755 contrib/perl5/t/lib/ftmp-tempfile.t create mode 100755 contrib/perl5/t/lib/gol-oo.t create mode 100755 contrib/perl5/t/lib/peek.t create mode 100755 contrib/perl5/t/lib/selfloader.t create mode 100755 contrib/perl5/t/lib/syslog.t create mode 100755 contrib/perl5/t/lib/tie-refhash.t create mode 100755 contrib/perl5/t/lib/tie-splice.t create mode 100755 contrib/perl5/t/lib/tie-substrhash.t create mode 100755 contrib/perl5/t/op/anonsub.t create mode 100755 contrib/perl5/t/op/concat.t create mode 100755 contrib/perl5/t/op/length.t create mode 100755 contrib/perl5/t/op/my_stash.t create mode 100755 contrib/perl5/t/op/regmesg.t create mode 100755 contrib/perl5/t/op/reverse.t create mode 100755 contrib/perl5/t/op/utf8decode.t create mode 100755 contrib/perl5/t/pod/find.t create mode 100755 contrib/perl5/t/run/runenv.t (limited to 'contrib') diff --git a/contrib/perl5/Porting/repository.pod b/contrib/perl5/Porting/repository.pod new file mode 100644 index 000000000000..5f1338dd6405 --- /dev/null +++ b/contrib/perl5/Porting/repository.pod @@ -0,0 +1,327 @@ +=head1 NAME + +repository - Using the Perl repository + +This document describes what a Perl Porter needs to do +to start using the Perl repository. + +=head1 Prerequisites + +You'll need to get hold of the following software. + +=over 4 + +=item Perforce + +Download a perforce client from: + + http://www.perforce.com/perforce/loadprog.html + +You'll probably also want to look at: + + http://www.perforce.com/perforce/technical.html + +where you can look at or download its documentation. + +=item ssh + +If you don't already have access to an ssh client, then look at its +home site C which mentions ftp sites from +which it's available. You only need to build the client parts (ssh +and ssh-keygen should suffice). + +=back + +=head1 Creating an SSH Key Pair + +If you already use ssh and want to use the same key pair for perl +repository access then you can skip the rest of this section. +Otherwise, generate an ssh key pair for use with the repository +by typing the command + + ssh-keygen + +After generating a key pair and testing it, ssh-keygen will ask you +to enter a filename in which to save the key. The default it offers +will be the file F<~/.ssh/identity> which is suitable unless you +particularly want to keep separate ssh identities for some reason. +If so, you could save the perl repository private key in the file +F<~/.ssh/perl>, for example, but I will use the standard filename +in the remainder of the examples of this document. + +After typing in the filename, it will prompt you to type in a +passphrase. The private key will itself be encrypted so that it is +usable only when that passphrase is typed. (When using ssh, you will +be prompted when it requires a pass phrase to unlock a private key.) +If you provide a blank passphrase then no passphrase will be needed +to unlock the key and, as a consequence, anyone who gains access to +the key file gains access to accounts protected with that key +(barring additional configuration to restrict access by IP address). + +When you have typed the passphrase in twice, ssh-keygen will confirm +where it has saved the private key (in the filename you gave and +with permissions set to be only readable by you), what your public +key is (don't worry: you don't need to memorise it) and where it +has saved the corresponding public key. The public key is saved in +a filename corresponding to your private key's filename but with +".pub" appended, usually F<~/.ssh/identity.pub>. That public key +can be (but need not be) world readable. It is not used by your +own system at all. + +=head1 Notifying the Repository Keeper + +Mail the contents of that public key file to the keeper of the perl +repository (see L below). +When the key is added to the repository host's configuration file, +you will be able to connect to it with ssh by using the corresponding +private key file (after unlocking it with your chosen passphrase). + +=head1 Connecting to the Repository + +Connections to the repository are made by using ssh to provide a +TCP "tunnel" rather than by using ssh to login to or invoke any +ordinary commands on the repository. When you want to start a +session using the repository, use the command + + ssh -l perlrep -f -q -x -L 1666:127.0.0.1:1666 sickle.activestate.com +foo + +If you are not using the default filename of F<~/.ssh/identity> +to hold your perl repository private key then you'll need to add +the option B<-i filename> to tell ssh where it is. Unless you chose +a blank passphrase for that private key, ssh will prompt you for the +passphrase to unlock that key. Then ssh will fork and put itself +in the background, returning you (silently) to your shell prompt. +The tunnel for repository access is now ready for use. + +For the sake of completeness (and for the case where the chosen +port of 1666 is already in use on your machine), I'll briefly +describe what all those ssh arguments are for. + +=over 4 + +=item B<-l perl> + +Use a remote username of perl. The account on the repository which +provides the end-point of the ssh tunnel is named "perl". + +=item B<-f> + +Tells ssh to fork and remain running in the background. Since ssh +is only being used for its tunnelling capabilities, the command +that ssh runs never does any I/O and can sit silently in the +background. + +=item B<-q> + +Tells ssh to be quiet. Without this option, ssh will output a +message each time you use a p4 command (since each p4 command +tunnels over the ssh connection to reach the repository). + +=item B<-x> + +Tells ssh not to bother to set up a tunnel for X11 connections. +The repository doesn't allow this anyway. + +=item B<-L 1666:127.0.0.1:1666> + +This is the important option. It tells ssh to listen out for +connections made to port 1666 on your local machine. When such +a connection is made, the ssh client tells the remote side +(the corresponding ssh daemon on the repository) to make a +connection to IP address 127.0.0.1, port 1666. Data flowing +along that connection is tunnelled over the ssh connection +(encrypted). The perforce daemon running on the repository +only accepts connections from localhost and that is exactly +where ssh-tunnelled connections appear to come from. + +If port 1666 is already in use on your machine then you can +choose any non-privileged port (a number between 1024 and 65535) +which happens to be free on your machine. It's the first of the +three colon separated values that you should change. Picking +port 2345 would mean changing the option to +B<-L 2345:127.0.0.1:1666>. Whatever port number you choose should +be used for the value of the P4PORT environment variable (q.v.). + +=item sickle.activestate.com + +This is the canonical IP name of the host on which the perl +repository runs. Its IP number is 199.60.48.20. + +=item foo + +This is a dummy place holder argument. Without an argument +here, ssh will try to perform an interactive login to the +repository which is not allowed. Ordinarily, this argument +is for the one-off command which is to be executed on the +remote host. However, the repository's ssh configuration +file uses the "command=" option to force a particular +command to run so the actual value of the argument is +ignored. The command that's actually run merely pauses and +waits for the ssh connection to drop, then exits. + +=back + +=head1 Problems + +You should normally get a prompt that asks for the passphrase +for your RSA key when you connect with the ssh command shown +above. If you see a prompt that looks like: + + perlrep@sickle.activestate.com's password: + +Then you either don't have a ~/.ssh/identity file corresponding +to your public key, or your ~/.ssh/identity file is not readable. +Fix the problem and try again. + +=head1 Using the Perforce Client + +Remember to read the documentation for Perforce. You need +to make sure that three environment variable are set +correctly before using the p4 client with the perl repository. + +=over 4 + +=item P4PORT + +Set this to localhost:1666 (the port for your ssh client to listen on) +unless that port is already in use on your host. If it is, see +the section above on the B<-L 1666:127.0.0.1:1666> option to ssh. + +=item P4CLIENT + +The value of this is the name by which Perforce knows your +host's workspace. You need to pick a name (for example, your +hostname unless that clashes with someone else's client name) +when you first start using the perl repository and then +stick with it. If you connect from multiple hosts (with +different workspaces) then maybe you could have multiple +clients. There is a licence limit on the number of perforce +clients which can be created. Although we have been told that +Perforce will raise our licence limits within reason, it's +probably best not to use additional clients unless needed. + +Note that perforce only needs the client name so that it can +find the directory under which your client files are stored. +If you have multiple hosts sharing the same directory structure +via NFS then only one client name is necessary. + +The C command lists all currently known clients. + +=item P4USER + +This is the username by which perforce knows you. Use your +username if you have a well known or obvious one or else pick +a new one which other perl5-porters will recognise. There is +a licence limit on the number of these usernames. Perforce +doesn't enforce security between usernames. If you set P4USER +to be somebody else's username then perforce will believe you +completely with regard to access control, logging and so on. + +The C command lists all currently known users. + +=back + +Once these three environment variables are set, you can use the +perforce p4 client exactly as described in its documentation. +After setting these variables and connecting to the repository +for the first time, you should use the C and +C commands to tell perforce the details of your +new username and your new client workspace specifications. + +=head1 Ending a Repository Session + +When you have finished a session using the repository, you +should kill off the ssh client process to break the tunnel. +Since ssh forked itself into the background, you'll need to use +something like ps with the appropriate options to find the ssh +process and then kill it manually. The default signal of +SIGTERM is fine. + +=head1 Overview of the Repository + +Please read at least the introductory sections of the Perforce +User Guide (and perhaps the Quick Start Guide as well) before +reading this section. + +Every repository user typically "owns" a "branch" of the mainline +code in the repository. They hold the "pumpkin" for things in this +area, and are usually the only user who will modify files there. +This is not strictly enforced in order to allow the flexibility +of other users stealing the pumpkin for short periods with the +owner's permission. + +Here is the current structure of the repository: + + /----+-----perl - Mainline development (bleadperl) + +-----cfgperl - Configure Pumpkin's Perl + +-----vmsperl - VMS Pumpkin's Perl + +-----maint-5.004------perl - Maintainance branches + +-----maint-5.005------perl + +-----maint-5.6------perl + +Perforce uses a branching model that simply tracks relationships +between files. It does not care about directories at all, so +any file can be a branch of any other file--the fully qualified +depot path name (of the form //depot/foo/bar.c) uniquely determines +a file for the purpose of establishing branching relationships. +Since a branch usually involves hundreds of files, such relationships +are typically specified en masse using a branch map (try `p4 help branch`). +`p4 branches` lists the existing branches that have been set up. +`p4 branch -o branchname` can be used to view the map for a particular +branch, if you want to determine the ancestor for a particular set of +files. + +The mainline (aka "trunk") code in the Perl repository is under +"//depot/perl/...". Most branches typically map its entire +contents under a directory that goes by the same name as the branch +name. Thus the contents of the cfgperl branch are to be found +in //depot/cfgperl. + +Run `p4 client` to specify how the repository contents should map to +your local disk. Most users will typically have a client map that +includes at least their entire branch and the contents of the mainline. + +Run `p4 changes -l -m10` to check on the activity in the repository. +//depot/perl/Porting/genlog is useful to get an annotated changelog +that shows files and branches. You can use this listing to determine +if there are any changes in the mainline that you need to merge into +your own branch. A typical merging session looks like this: + + % cd ~/p4view/cfgperl + % p4 integrate -b cfgperl # to bring parent changes into cfgperl + % p4 resolve -a ./... # auto merge the changes + % p4 resolve ./... # manual merge conflicting changes + % p4 submit ./... # check in + +If the owner of the mainline wants to bring the changes in cfgperl +back into the mainline, they do: + + % p4 integrate -r -b cfgperl + ... + +Generating a patch for change#42 is done as follows: + + % p4 describe -du 42 | p4desc | p4d2p > change-42.patch + +p4desc and p4d2p are to be found in //depot/perl/Porting/. + +=head1 Contact Information + +The mail alias can be used to reach +all current users of the repository. + +The repository keeper is currently Gurusamy Sarathy +. + +=head1 AUTHORS + +Malcolm Beattie, mbeattie@sable.ox.ac.uk, 24 June 1997. + +Gurusamy Sarathy, gsar@activestate.com, 8 May 1999. + +Slightly updated by Simon Cozens, simon@brecon.co.uk, 3 July 2000 + +=cut + + diff --git a/contrib/perl5/ext/B/B/Concise.pm b/contrib/perl5/ext/B/B/Concise.pm new file mode 100644 index 000000000000..cb352ebf1cd7 --- /dev/null +++ b/contrib/perl5/ext/B/B/Concise.pm @@ -0,0 +1,823 @@ +package B::Concise; +# Copyright (C) 2000, 2001 Stephen McCamant. All rights reserved. +# This program is free software; you can redistribute and/or modify it +# under the same terms as Perl itself. + +our $VERSION = "0.51"; +use strict; +use B qw(class ppname main_start main_root main_cv cstring svref_2object + SVf_IOK SVf_NOK SVf_POK OPf_KIDS); + +my %style = + ("terse" => + ["(?(#label =>\n)?)(*( )*)#class (#addr) #name (?([#targ])?) " + . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n", + "(*( )*)goto #class (#addr)\n", + "#class pp_#name"], + "concise" => + ["#hyphseq2 (*( (x( ;)x))*)<#classsym> " + . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n", + " (*( )*) goto #seq\n", + "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"], + "linenoise" => + ["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)", + "gt_#seq ", + "(?(#seq)?)#noise#arg(?([#targarg])?)"], + "debug" => + ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t" + . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n\top_seq\t\t" + . "#seqnum\n\top_flags\t#flagval\n\top_private\t#privval\n" + . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)" + . "(?(\top_sv\t\t#svaddr\n)?)", + " GOTO #addr\n", + "#addr"], + "env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT}, + $ENV{B_CONCISE_TREE_FORMAT}], + ); + +my($format, $gotofmt, $treefmt); +my $curcv; +my($seq_base, $cop_seq_base); + +sub concise_cv { + my ($order, $cvref) = @_; + my $cv = svref_2object($cvref); + $curcv = $cv; + if ($order eq "exec") { + walk_exec($cv->START); + } elsif ($order eq "basic") { + walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0); + } else { + print tree($cv->ROOT, 0) + } +} + +my $start_sym = "\e(0"; # "\cN" sometimes also works +my $end_sym = "\e(B"; # "\cO" respectively + +my @tree_decorations = + ([" ", "--", "+-", "|-", "| ", "`-", "-", 1], + [" ", "-", "+", "+", "|", "`", "", 0], + [" ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1], + [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0], + ); +my $tree_style = 0; + +my $base = 36; +my $big_endian = 1; + +my $order = "basic"; + +sub compile { + my @options = grep(/^-/, @_); + my @args = grep(!/^-/, @_); + my $do_main = 0; + ($format, $gotofmt, $treefmt) = @{$style{"concise"}}; + for my $o (@options) { + if ($o eq "-basic") { + $order = "basic"; + } elsif ($o eq "-exec") { + $order = "exec"; + } elsif ($o eq "-tree") { + $order = "tree"; + } elsif ($o eq "-compact") { + $tree_style |= 1; + } elsif ($o eq "-loose") { + $tree_style &= ~1; + } elsif ($o eq "-vt") { + $tree_style |= 2; + } elsif ($o eq "-ascii") { + $tree_style &= ~2; + } elsif ($o eq "-main") { + $do_main = 1; + } elsif ($o =~ /^-base(\d+)$/) { + $base = $1; + } elsif ($o eq "-bigendian") { + $big_endian = 1; + } elsif ($o eq "-littleendian") { + $big_endian = 0; + } elsif (exists $style{substr($o, 1)}) { + ($format, $gotofmt, $treefmt) = @{$style{substr($o, 1)}}; + } else { + warn "Option $o unrecognized"; + } + } + if (@args) { + return sub { + for my $objname (@args) { + $objname = "main::" . $objname unless $objname =~ /::/; + eval "concise_cv(\$order, \\&$objname)"; + die "concise_cv($order, \\&$objname) failed: $@" if $@; + } + } + } + if (!@args or $do_main) { + if ($order eq "exec") { + return sub { return if class(main_start) eq "NULL"; + $curcv = main_cv; + walk_exec(main_start) } + } elsif ($order eq "tree") { + return sub { return if class(main_root) eq "NULL"; + $curcv = main_cv; + print tree(main_root, 0) } + } elsif ($order eq "basic") { + return sub { return if class(main_root) eq "NULL"; + $curcv = main_cv; + walk_topdown(main_root, + sub { $_[0]->concise($_[1]) }, 0); } + } + } +} + +my %labels; +my $lastnext; + +my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|", + 'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*", + 'PVOP' => '"', 'LOOP' => "{", 'COP' => ";"); + +my @linenoise = + qw'# () sc ( @? 1 $* gv *{ m$ m@ m% m? p/ *$ $ $# & a& pt \\ s\\ rf bl + ` *? <> ?? ?/ r/ c/ // qr s/ /c y/ = @= C sC Cp sp df un BM po +1 +I + -1 -I 1+ I+ 1- I- ** * i* / i/ %$ i% x + i+ - i- . " << >> < i< + > i> <= i, >= i. == i= != i! s, s. s= s! s? b& b^ b| -0 -i + ! ~ a2 si cs rd sr e^ lg sq in %x %o ab le ss ve ix ri sf FL od ch cy + uf lf uc lc qm @ [f [ @[ eh vl ky dl ex % ${ @{ uk pk st jn ) )[ a@ + a% sl +] -] [- [+ so rv GS GW MS MW .. f. .f && || ^^ ?: &= |= -> s{ s} + v} ca wa di rs ;; ; ;d }{ { } {} f{ it {l l} rt }l }n }r dm }g }e ^o + ^c ^| ^# um bm t~ u~ ~d DB db ^s se ^g ^r {w }w pf pr ^O ^K ^R ^W ^d ^v + ^e ^t ^k t. fc ic fl .s .p .b .c .l .a .h g1 s1 g2 s2 ?. l? -R -W -X -r + -w -x -e -o -O -z -s -M -A -C -S -c -b -f -d -p -l -u -g -k -t -T -B cd + co cr u. cm ut r. l@ s@ r@ mD uD oD rD tD sD wD cD f$ w$ p$ sh e$ k$ g3 + g4 s4 g5 s5 T@ C@ L@ G@ A@ S@ Hg Hc Hr Hw Mg Mc Ms Mr Sg Sc So rq do {e + e} {t t} g6 G6 6e g7 G7 7e g8 G8 8e g9 G9 9e 6s 7s 8s 9s 6E 7E 8E 9E Pn + Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n>'; + +my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; + +sub op_flags { + my($x) = @_; + my(@v); + push @v, "v" if ($x & 3) == 1; + push @v, "s" if ($x & 3) == 2; + push @v, "l" if ($x & 3) == 3; + push @v, "K" if $x & 4; + push @v, "P" if $x & 8; + push @v, "R" if $x & 16; + push @v, "M" if $x & 32; + push @v, "S" if $x & 64; + push @v, "*" if $x & 128; + return join("", @v); +} + +sub base_n { + my $x = shift; + return "-" . base_n(-$x) if $x < 0; + my $str = ""; + do { $str .= substr($chars, $x % $base, 1) } while $x = int($x / $base); + $str = reverse $str if $big_endian; + return $str; +} + +sub seq { return $_[0]->seq ? base_n($_[0]->seq - $seq_base) : "-" } + +sub walk_topdown { + my($op, $sub, $level) = @_; + $sub->($op, $level); + if ($op->flags & OPf_KIDS) { + for (my $kid = $op->first; $$kid; $kid = $kid->sibling) { + walk_topdown($kid, $sub, $level + 1); + } + } + if (class($op) eq "PMOP" and $ {$op->pmreplroot} + and $op->pmreplroot->isa("B::OP")) { + walk_topdown($op->pmreplroot, $sub, $level + 1); + } +} + +sub walklines { + my($ar, $level) = @_; + for my $l (@$ar) { + if (ref($l) eq "ARRAY") { + walklines($l, $level + 1); + } else { + $l->concise($level); + } + } +} + +sub walk_exec { + my($top, $level) = @_; + my %opsseen; + my @lines; + my @todo = ([$top, \@lines]); + while (@todo and my($op, $targ) = @{shift @todo}) { + for (; $$op; $op = $op->next) { + last if $opsseen{$$op}++; + push @$targ, $op; + my $name = $op->name; + if ($name + =~ /^(or|and|(map|grep)while|entertry|range|cond_expr)$/) { + my $ar = []; + push @$targ, $ar; + push @todo, [$op->other, $ar]; + } elsif ($name eq "subst" and $ {$op->pmreplstart}) { + my $ar = []; + push @$targ, $ar; + push @todo, [$op->pmreplstart, $ar]; + } elsif ($name =~ /^enter(loop|iter)$/) { + $labels{$op->nextop->seq} = "NEXT"; + $labels{$op->lastop->seq} = "LAST"; + $labels{$op->redoop->seq} = "REDO"; + } + } + } + walklines(\@lines, 0); +} + +sub fmt_line { + my($hr, $fmt, $level) = @_; + my $text = $fmt; + $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/ + $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg; + $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs; + $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs; + $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs; + $text =~ s/#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg; + $text =~ s/#([a-zA-Z]+)/$hr->{$1}/eg; + $text =~ s/[ \t]*~+[ \t]*/ /g; + return $text; +} + +my %priv; +$priv{$_}{128} = "LVINTRO" + for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv", + "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv", + "padav", "padhv"); +$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite"); +$priv{"aassign"}{64} = "COMMON"; +$priv{"aassign"}{32} = "PHASH"; +$priv{"sassign"}{64} = "BKWARD"; +$priv{$_}{64} = "RTIME" for ("match", "subst", "substcont"); +@{$priv{"trans"}}{1,2,4,8,16,64} = ("UTF", "IDENT", "SQUASH", "DEL", + "COMPL", "GROWS"); +$priv{"repeat"}{64} = "DOLIST"; +$priv{"leaveloop"}{64} = "CONT"; +@{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV") + for ("entersub", map("rv2${_}v", "a", "s", "h", "g"), "aelem", "helem"); +$priv{"entersub"}{16} = "DBG"; +$priv{"entersub"}{32} = "TARG"; +@{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv"); +$priv{"gv"}{32} = "EARLYCV"; +$priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER"; +$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv"); +$priv{$_}{16} = "TARGMY" + for (map(($_,"s$_"),"chop", "chomp"), + map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo", + "add", "subtract", "negate"), "pow", "concat", "stringify", + "left_shift", "right_shift", "bit_and", "bit_xor", "bit_or", + "complement", "atan2", "sin", "cos", "rand", "exp", "log", "sqrt", + "int", "hex", "oct", "abs", "length", "index", "rindex", "sprintf", + "ord", "chr", "crypt", "quotemeta", "join", "push", "unshift", "flock", + "chdir", "chown", "chroot", "unlink", "chmod", "utime", "rename", + "link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system", + "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority", + "setpriority", "time", "sleep"); +@{$priv{"const"}}{8,16,32,64,128} = ("STRICT","ENTERED", "$[", "BARE", "WARN"); +$priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM"; +$priv{"list"}{64} = "GUESSED"; +$priv{"delete"}{64} = "SLICE"; +$priv{"exists"}{64} = "SUB"; +$priv{$_}{64} = "LOCALE" + for ("sort", "prtf", "sprintf", "slt", "sle", "seq", "sne", "sgt", "sge", + "scmp", "lc", "uc", "lcfirst", "ucfirst"); +@{$priv{"sort"}}{1,2,4} = ("NUM", "INT", "REV"); +$priv{"threadsv"}{64} = "SVREFd"; +$priv{$_}{16} = "INBIN" for ("open", "backtick"); +$priv{$_}{32} = "INCR" for ("open", "backtick"); +$priv{$_}{64} = "OUTBIN" for ("open", "backtick"); +$priv{$_}{128} = "OUTCR" for ("open", "backtick"); +$priv{"exit"}{128} = "VMS"; + +sub private_flags { + my($name, $x) = @_; + my @s; + for my $flag (128, 96, 64, 32, 16, 8, 4, 2, 1) { + if ($priv{$name}{$flag} and $x & $flag and $x >= $flag) { + $x -= $flag; + push @s, $priv{$name}{$flag}; + } + } + push @s, $x if $x; + return join(",", @s); +} + +sub concise_op { + my ($op, $level, $format) = @_; + my %h; + $h{exname} = $h{name} = $op->name; + $h{NAME} = uc $h{name}; + $h{class} = class($op); + $h{extarg} = $h{targ} = $op->targ; + $h{extarg} = "" unless $h{extarg}; + if ($h{name} eq "null" and $h{targ}) { + $h{exname} = "ex-" . substr(ppname($h{targ}), 3); + $h{extarg} = ""; + } elsif ($h{targ}) { + my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}]; + if (defined $padname and class($padname) ne "SPECIAL") { + $h{targarg} = $padname->PVX; + my $intro = $padname->NVX - $cop_seq_base; + my $finish = int($padname->IVX) - $cop_seq_base; + $finish = "end" if $finish == 999999999 - $cop_seq_base; + $h{targarglife} = "$h{targarg}:$intro,$finish"; + } else { + $h{targarglife} = $h{targarg} = "t" . $h{targ}; + } + } + $h{arg} = ""; + $h{svclass} = $h{svaddr} = $h{svval} = ""; + if ($h{class} eq "PMOP") { + my $precomp = $op->precomp; + $precomp = defined($precomp) ? "/$precomp/" : ""; + my $pmreplroot = $op->pmreplroot; + my ($pmreplroot, $pmreplstart); + if ($ {$pmreplroot = $op->pmreplroot} && $pmreplroot->isa("B::GV")) { + # with C<@stash_array = split(/pat/, str);>, + # *stash_array is stored in pmreplroot. + $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")"; + } elsif ($ {$op->pmreplstart}) { + undef $lastnext; + $pmreplstart = "replstart->" . seq($op->pmreplstart); + $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")"; + } else { + $h{arg} = "($precomp)"; + } + } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") { + $h{arg} = '("' . $op->pv . '")'; + $h{svval} = '"' . $op->pv . '"'; + } elsif ($h{class} eq "COP") { + my $label = $op->label; + $h{coplabel} = $label; + $label = $label ? "$label: " : ""; + my $loc = $op->file; + $loc =~ s[.*/][]; + $loc .= ":" . $op->line; + my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base); + my $arybase = $op->arybase; + $arybase = $arybase ? ' $[=' . $arybase : ""; + $h{arg} = "($label$stash $cseq $loc$arybase)"; + } elsif ($h{class} eq "LOOP") { + $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop) + . " redo->" . seq($op->redoop) . ")"; + } elsif ($h{class} eq "LOGOP") { + undef $lastnext; + $h{arg} = "(other->" . seq($op->other) . ")"; + } elsif ($h{class} eq "SVOP") { + my $sv = $op->sv; + $h{svclass} = class($sv); + $h{svaddr} = sprintf("%#x", $$sv); + if ($h{svclass} eq "GV") { + my $gv = $sv; + my $stash = $gv->STASH->NAME; + if ($stash eq "main") { + $stash = ""; + } else { + $stash = $stash . "::"; + } + $h{arg} = "(*$stash" . $gv->SAFENAME . ")"; + $h{svval} = "*$stash" . $gv->SAFENAME; + } else { + while (class($sv) eq "RV") { + $h{svval} .= "\\"; + $sv = $sv->RV; + } + if (class($sv) eq "SPECIAL") { + $h{svval} = ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv]; + } elsif ($sv->FLAGS & SVf_NOK) { + $h{svval} = $sv->NV; + } elsif ($sv->FLAGS & SVf_IOK) { + $h{svval} = $sv->IV; + } elsif ($sv->FLAGS & SVf_POK) { + $h{svval} = cstring($sv->PV); + } + $h{arg} = "($h{svclass} $h{svval})"; + } + } + $h{seq} = $h{hyphseq} = seq($op); + $h{seq} = "" if $h{seq} eq "-"; + $h{seqnum} = $op->seq; + $h{next} = $op->next; + $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next}); + $h{nextaddr} = sprintf("%#x", $ {$op->next}); + $h{sibaddr} = sprintf("%#x", $ {$op->sibling}); + $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first"); + $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last"); + + $h{classsym} = $opclass{$h{class}}; + $h{flagval} = $op->flags; + $h{flags} = op_flags($op->flags); + $h{privval} = $op->private; + $h{private} = private_flags($h{name}, $op->private); + $h{addr} = sprintf("%#x", $$op); + $h{label} = $labels{$op->seq}; + $h{typenum} = $op->type; + $h{noise} = $linenoise[$op->type]; + return fmt_line(\%h, $format, $level); +} + +sub B::OP::concise { + my($op, $level) = @_; + if ($order eq "exec" and $lastnext and $$lastnext != $$op) { + my $h = {"seq" => seq($lastnext), "class" => class($lastnext), + "addr" => sprintf("%#x", $$lastnext)}; + print fmt_line($h, $gotofmt, $level+1); + } + $lastnext = $op->next; + print concise_op($op, $level, $format); +} + +sub tree { + my $op = shift; + my $level = shift; + my $style = $tree_decorations[$tree_style]; + my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style; + my $name = concise_op($op, $level, $treefmt); + if (not $op->flags & OPf_KIDS) { + return $name . "\n"; + } + my @lines; + for (my $kid = $op->first; $$kid; $kid = $kid->sibling) { + push @lines, tree($kid, $level+1); + } + my $i; + for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) { + $lines[$i] = $space . $lines[$i]; + } + if ($i > 0) { + $lines[$i] = $last . $lines[$i]; + while ($i-- > 1) { + if (substr($lines[$i], 0, 1) eq " ") { + $lines[$i] = $nokid . $lines[$i]; + } else { + $lines[$i] = $kid . $lines[$i]; + } + } + $lines[$i] = $kids . $lines[$i]; + } else { + $lines[0] = $single . $lines[0]; + } + return("$name$lead" . shift @lines, + map(" " x (length($name)+$size) . $_, @lines)); +} + +# This is a bit of a hack; the 2 and 15 were determined empirically. +# These need to stay the last things in the module. +$cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + 2; +$seq_base = svref_2object(eval 'sub{}')->START->seq + 15; + +1; + +__END__ + +=head1 NAME + +B::Concise - Walk Perl syntax tree, printing concise info about ops + +=head1 SYNOPSIS + + perl -MO=Concise[,OPTIONS] foo.pl + +=head1 DESCRIPTION + +This compiler backend prints the internal OPs of a Perl program's syntax +tree in one of several space-efficient text formats suitable for debugging +the inner workings of perl or other compiler backends. It can print OPs in +the order they appear in the OP tree, in the order they will execute, or +in a text approximation to their tree structure, and the format of the +information displyed is customizable. Its function is similar to that of +perl's B<-Dx> debugging flag or the B module, but it is more +sophisticated and flexible. + +=head1 OPTIONS + +Arguments that don't start with a hyphen are taken to be the names of +subroutines to print the OPs of; if no such functions are specified, the +main body of the program (outside any subroutines, and not including use'd +or require'd files) is printed. + +=over 4 + +=item B<-basic> + +Print OPs in the order they appear in the OP tree (a preorder +traversal, starting at the root). The indentation of each OP shows its +level in the tree. This mode is the default, so the flag is included +simply for completeness. + +=item B<-exec> + +Print OPs in the order they would normally execute (for the majority +of constructs this is a postorder traversal of the tree, ending at the +root). In most cases the OP that usually follows a given OP will +appear directly below it; alternate paths are shown by indentation. In +cases like loops when control jumps out of a linear path, a 'goto' +line is generated. + +=item B<-tree> + +Print OPs in a text approximation of a tree, with the root of the tree +at the left and 'left-to-right' order of children transformed into +'top-to-bottom'. Because this mode grows both to the right and down, +it isn't suitable for large programs (unless you have a very wide +terminal). + +=item B<-compact> + +Use a tree format in which the minimum amount of space is used for the +lines connecting nodes (one character in most cases). This squeezes out +a few precious columns of screen real estate. + +=item B<-loose> + +Use a tree format that uses longer edges to separate OP nodes. This format +tends to look better than the compact one, especially in ASCII, and is +the default. + +=item B<-vt> + +Use tree connecting characters drawn from the VT100 line-drawing set. +This looks better if your terminal supports it. + +=item B<-ascii> + +Draw the tree with standard ASCII characters like C<+> and C<|>. These don't +look as clean as the VT100 characters, but they'll work with almost any +terminal (or the horizontal scrolling mode of less(1)) and are suitable +for text documentation or email. This is the default. + +=item B<-main> + +Include the main program in the output, even if subroutines were also +specified. + +=item B<-base>I + +Print OP sequence numbers in base I. If I is greater than 10, the +digit for 11 will be 'a', and so on. If I is greater than 36, the digit +for 37 will be 'A', and so on until 62. Values greater than 62 are not +currently supported. The default is 36. + +=item B<-bigendian> + +Print sequence numbers with the most significant digit first. This is the +usual convention for Arabic numerals, and the default. + +=item B<-littleendian> + +Print seqence numbers with the least significant digit first. + +=item B<-concise> + +Use the author's favorite set of formatting conventions. This is the +default, of course. + +=item B<-terse> + +Use formatting conventions that emulate the ouput of B. The +basic mode is almost indistinguishable from the real B, and the +exec mode looks very similar, but is in a more logical order and lacks +curly brackets. B doesn't have a tree mode, so the tree mode +is only vaguely reminiscient of B. + +=item B<-linenoise> + +Use formatting conventions in which the name of each OP, rather than being +written out in full, is represented by a one- or two-character abbreviation. +This is mainly a joke. + +=item B<-debug> + +Use formatting conventions reminiscient of B; these aren't +very concise at all. + +=item B<-env> + +Use formatting conventions read from the environment variables +C, C, and C. + +=back + +=head1 FORMATTING SPECIFICATIONS + +For each general style ('concise', 'terse', 'linenoise', etc.) there are +three specifications: one of how OPs should appear in the basic or exec +modes, one of how 'goto' lines should appear (these occur in the exec +mode only), and one of how nodes should appear in tree mode. Each has the +same format, described below. Any text that doesn't match a special +pattern is copied verbatim. + +=over 4 + +=item B<(x(>IB<;>IB<)x)> + +Generates I in exec mode, or I in basic mode. + +=item B<(*(>IB<)*)> + +Generates one copy of I for each indentation level. + +=item B<(*(>IB<;>IB<)*)> + +Generates one fewer copies of I than the indentation level, followed +by one copy of I if the indentation level is more than 0. + +=item B<(?(>IB<#>IIB<)?)> + +If the value of I is true (not empty or zero), generates the +value of I surrounded by I and I, otherwise +nothing. + +=item B<#>I + +Generates the value of the variable I. + +=item B<#>II + +Generates the value of I, left jutified to fill I spaces. + +=item B<~> + +Any number of tildes and surrounding whitespace will be collapsed to +a single space. + +=back + +The following variables are recognized: + +=over 4 + +=item B<#addr> + +The address of the OP, in hexidecimal. + +=item B<#arg> + +The OP-specific information of the OP (such as the SV for an SVOP, the +non-local exit pointers for a LOOP, etc.) enclosed in paretheses. + +=item B<#class> + +The B-determined class of the OP, in all caps. + +=item B<#classym> + +A single symbol abbreviating the class of the OP. + +=item B<#coplabel> + +The label of the statement or block the OP is the start of, if any. + +=item B<#exname> + +The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo. + +=item B<#extarg> + +The target of the OP, or nothing for a nulled OP. + +=item B<#firstaddr> + +The address of the OP's first child, in hexidecimal. + +=item B<#flags> + +The OP's flags, abbreviated as a series of symbols. + +=item B<#flagval> + +The numeric value of the OP's flags. + +=item B<#hyphenseq> + +The sequence number of the OP, or a hyphen if it doesn't have one. + +=item B<#label> + +'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec +mode, or empty otherwise. + +=item B<#lastaddr> + +The address of the OP's last child, in hexidecimal. + +=item B<#name> + +The OP's name. + +=item B<#NAME> + +The OP's name, in all caps. + +=item B<#next> + +The sequence number of the OP's next OP. + +=item B<#nextaddr> + +The address of the OP's next OP, in hexidecimal. + +=item B<#noise> + +The two-character abbreviation for the OP's name. + +=item B<#private> + +The OP's private flags, rendered with abbreviated names if possible. + +=item B<#privval> + +The numeric value of the OP's private flags. + +=item B<#seq> + +The sequence number of the OP. + +=item B<#seqnum> + +The real sequence number of the OP, as a regular number and not adjusted +to be relative to the start of the real program. (This will generally be +a fairly large number because all of B is compiled before +your program is). + +=item B<#sibaddr> + +The address of the OP's next youngest sibling, in hexidecimal. + +=item B<#svaddr> + +The address of the OP's SV, if it has an SV, in hexidecimal. + +=item B<#svclass> + +The class of the OP's SV, if it has one, in all caps (e.g., 'IV'). + +=item B<#svval> + +The value of the OP's SV, if it has one, in a short human-readable format. + +=item B<#targ> + +The numeric value of the OP's targ. + +=item B<#targarg> + +The name of the variable the OP's targ refers to, if any, otherwise the +letter t followed by the OP's targ in decimal. + +=item B<#targarglife> + +Same as B<#targarg>, but followed by the COP sequence numbers that delimit +the variable's lifetime (or 'end' for a variable in an open scope) for a +variable. + +=item B<#typenum> + +The numeric value of the OP's type, in decimal. + +=back + +=head1 ABBREVIATIONS + +=head2 OP flags abbreviations + + v OPf_WANT_VOID Want nothing (void context) + s OPf_WANT_SCALAR Want single value (scalar context) + l OPf_WANT_LIST Want list of any length (list context) + K OPf_KIDS There is a firstborn child. + P OPf_PARENS This operator was parenthesized. + (Or block needs explicit scope entry.) + R OPf_REF Certified reference. + (Return container, not containee). + M OPf_MOD Will modify (lvalue). + S OPf_STACKED Some arg is arriving on the stack. + * OPf_SPECIAL Do something weird for this op (see op.h) + +=head2 OP class abbreviations + + 0 OP (aka BASEOP) An OP with no children + 1 UNOP An OP with one child + 2 BINOP An OP with two children + | LOGOP A control branch OP + @ LISTOP An OP that could have lots of children + / PMOP An OP with a regular expression + $ SVOP An OP with an SV + " PVOP An OP with a string + { LOOP An OP that holds pointers for a loop + ; COP An OP that marks the start of a statement + +=head1 AUTHOR + +Stephen McCamant, C + +=cut diff --git a/contrib/perl5/ext/DynaLoader/dl_dllload.xs b/contrib/perl5/ext/DynaLoader/dl_dllload.xs new file mode 100644 index 000000000000..fe6957ac200d --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_dllload.xs @@ -0,0 +1,189 @@ +/* dl_dllload.xs + * + * Platform: OS/390, possibly others that use dllload(),dllfree() (VM/ESA?). + * Authors: John Goodyear && Peter Prymmer + * Created: 28 October 2000 + * Modified: + * 16 January 2001 - based loosely on dl_dlopen.xs. + */ + +/* Porting notes: + + OS/390 Dynamic Loading functions: + + dllload + ------- + dllhandle * dllload(const char *dllName) + + This function takes the name of a dynamic object file and returns + a descriptor which can be used by dlllqueryfn() and/or dllqueryvar() + later. If dllName contains a slash, it is used to locate the dll. + If not then the LIBPATH environment variable is used to + search for the requested dll (at least within the HFS). + It returns NULL on error and sets errno. + + dllfree + ------- + int dllfree(dllhandle *handle); + + dllfree() decrements the load count for the dll and frees + it if the count is 0. It returns zero on success, and + non-zero on failure. + + dllqueryfn && dllqueryvar + ------------------------- + void (* dllqueryfn(dllhandle *handle, const char *function))(); + void * dllqueryvar(dllhandle *handle, const char *symbol); + + dllqueryfn() takes the handle returned from dllload() and the name + of a function to get the address of. If the function was found + a pointer is returned, otherwise NULL is returned. + + dllqueryvar() takes the handle returned from dllload() and the name + of a symbol to get the address of. If the variable was found a + pointer is returned, otherwise NULL is returned. + + The XS dl_find_symbol() first calls dllqueryfn(). If it fails + dlqueryvar() is then called. + + strerror + -------- + char * strerror(int errno) + + Returns a null-terminated string which describes the last error + that occurred with other functions (not necessarily unique to + dll loading). + + Return Types + ============ + In this implementation the two functions, dl_load_file() && + dl_find_symbol(), return (void *). This is primarily because the + dlopen() && dlsym() style dynamic linker calls return (void *). + We suspect that casting to (void *) may be easier than teaching XS + typemaps about the (dllhandle *) type. + + 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 OS/390 the function strerror(errno) returns the error + message associated with the last dynamic link error. As the S/390 + dynamic linker functions dllload() && dllqueryvar() both return NULL + on error every call to an S/390 dynamic link routine is coded + like this: + + RETVAL = dllload(filename) ; + if (RETVAL == NULL) + SaveError("%s",strerror(errno)) ; + + Note that SaveError() takes a printf format string. Use a "%s" as + the first parameter if the error may contain any % characters. + + Other comments within the dl_dlopen.xs file may be helpful as well. +*/ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include /* the dynamic linker include file for S/390 */ +#include /* strerror() and friends */ + +#include "dlutils.c" /* SaveError() etc */ + +static void +dl_private_init(pTHX) +{ + (void)dl_generic_private_init(aTHX); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(aTHX); + + +void * +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: + int mode = 0; + CODE: +{ + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); + /* add a (void *) dllload(filename) ; cast if needed */ + RETVAL = dllload(filename) ; + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError(aTHX_ "%s",strerror(errno)) ; + else + sv_setiv( ST(0), PTR2IV(RETVAL)); +} + + +int +dl_unload_file(libref) + void * libref + CODE: + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", PTR2ul(libref))); + /* RETVAL = (dllfree((dllhandle *)libref) == 0 ? 1 : 0); */ + RETVAL = (dllfree(libref) == 0 ? 1 : 0); + if (!RETVAL) + SaveError(aTHX_ "%s", strerror(errno)) ; + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " retval = %d\n", RETVAL)); + OUTPUT: + RETVAL + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + DLDEBUG(2, PerlIO_printf(Perl_debug_log, + "dl_find_symbol(handle=%lx, symbol=%s)\n", + (unsigned long) libhandle, symbolname)); + if((RETVAL = (void*)dllqueryfn(libhandle, symbolname)) == NULL) + RETVAL = dllqueryvar(libhandle, symbolname); + DLDEBUG(2, PerlIO_printf(Perl_debug_log, + " symbolref = %lx\n", (unsigned long) RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError(aTHX_ "%s",strerror(errno)) ; + else + sv_setiv( ST(0), PTR2IV(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,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n", + perl_name, (unsigned long) symref)); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_mac.xs b/contrib/perl5/ext/DynaLoader/dl_mac.xs new file mode 100644 index 000000000000..5f48139c56a0 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_mac.xs @@ -0,0 +1,137 @@ +/* dl_mac.xs + * + * Platform: Macintosh CFM + * Author: Matthias Neeracher + * Adapted from dl_dlopen.xs reference implementation by + * Paul Marquess (pmarquess@bfsec.bt.co.uk) + * $Log: dl_mac.xs,v $ + * Revision 1.3 1998/04/07 01:47:24 neeri + * MacPerl 5.2.0r4b1 + * + * Revision 1.2 1997/08/08 16:39:18 neeri + * MacPerl 5.1.4b1 + time() fix + * + * Revision 1.1 1997/04/07 20:48:23 neeri + * Synchronized with MacPerl 5.1.4a1 + * + */ + +#define MAC_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include + + +#include "dlutils.c" /* SaveError() etc */ + +typedef CFragConnectionID ConnectionID; + +static ConnectionID ** connections; + +static void terminate(void) +{ + int size = GetHandleSize((Handle) connections) / sizeof(ConnectionID); + HLock((Handle) connections); + while (size) + CloseConnection(*connections + --size); + DisposeHandle((Handle) connections); + connections = nil; +} + +static void +dl_private_init(pTHX) +{ + (void)dl_generic_private_init(aTHX); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(aTHX); + + +ConnectionID +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: + OSErr err; + FSSpec spec; + ConnectionID connID; + Ptr mainAddr; + Str255 errName; + CODE: + DLDEBUG(1,PerlIO_printf(Perl_debug_log,"dl_load_file(%s):\n", filename)); + err = GUSIPath2FSp(filename, &spec); + if (!err) + err = + GetDiskFragment( + &spec, 0, 0, spec.name, kLoadCFrag, &connID, &mainAddr, errName); + if (!err) { + if (!connections) { + connections = (ConnectionID **)NewHandle(0); + atexit(terminate); + } + PtrAndHand((Ptr) &connID, (Handle) connections, sizeof(ConnectionID)); + RETVAL = connID; + } else + RETVAL = (ConnectionID) 0; + DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%d\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (err) + SaveError(aTHX_ "DynaLoader error [%d, %#s]", err, errName) ; + else + sv_setiv( ST(0), (IV)RETVAL); + +void * +dl_find_symbol(connID, symbol) + ConnectionID connID + Str255 symbol + CODE: + { + OSErr err; + Ptr symAddr; + CFragSymbolClass symClass; + DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%#s)\n", + connID, symbol)); + err = FindSymbol(connID, symbol, &symAddr, &symClass); + if (err) + symAddr = (Ptr) 0; + RETVAL = (void *) symAddr; + DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref = %x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (err) + SaveError(aTHX_ "DynaLoader error [%d]!", err) ; + else + sv_setiv( ST(0), (IV)RETVAL); + } + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/hints/netbsd.pl b/contrib/perl5/ext/DynaLoader/hints/netbsd.pl new file mode 100644 index 000000000000..a0fbaf7d89ee --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/hints/netbsd.pl @@ -0,0 +1,3 @@ +# XXX Configure test needed? +# Some NetBSDs seem to have a dlopen() that won't accept relative paths +$self->{CCFLAGS} = $Config{ccflags} . ' -DDLOPEN_WONT_DO_RELATIVE_PATHS'; diff --git a/contrib/perl5/ext/POSIX/hints/svr4.pl b/contrib/perl5/ext/POSIX/hints/svr4.pl new file mode 100644 index 000000000000..07f2cb041266 --- /dev/null +++ b/contrib/perl5/ext/POSIX/hints/svr4.pl @@ -0,0 +1,12 @@ +# NCR MP-RAS. Thanks to Doug Hendricks for this info. +# Configure sets osname=svr4.0, osvers=3.0, archname='3441-svr4.0' +# This system needs to explicitly link against -lmw to pull in some +# symbols such as _mwoflocheckl and possibly others. +# A. Dougherty Thu Dec 7 11:55:28 EST 2000 +if ($Config{'archname'} =~ /3441-svr4/) { + $self->{LIBS} = ['-lm -posix -lcposix -lmw']; +} +# Not sure what OS this one is. +elsif ($Config{archname} =~ /RM\d\d\d-svr4/) { + $self->{LIBS} = ['-lm -lc -lposix -lcposix']; +} diff --git a/contrib/perl5/ext/re/hints/aix.pl b/contrib/perl5/ext/re/hints/aix.pl new file mode 100644 index 000000000000..4fbfefd73585 --- /dev/null +++ b/contrib/perl5/ext/re/hints/aix.pl @@ -0,0 +1,22 @@ +# Add explicit link to deb.o to pick up .Perl_deb symbol which is not +# mentioned in perl.exp for earlier cc (xlc) versions in at least +# non DEBUGGING builds +# Peter Prymmer + +use Config; + +if ($^O eq 'aix' && defined($Config{'ccversion'}) && + ( $Config{'ccversion'} =~ /^3\.\d/ + # needed for at least these versions: + # $Config{'ccversion'} eq '3.6.6.0' + # $Config{'ccversion'} eq '3.6.4.0' + # $Config{'ccversion'} eq '3.1.4.0' AIX 4.2 + # $Config{'ccversion'} eq '3.1.4.10' AIX 4.2 + # $Config{'ccversion'} eq '3.1.3.3' + || + $Config{'ccversion'} =~ /^4\.4\.0\.[0-3]/ + ) + ) { + $self->{OBJECT} .= ' ../../deb$(OBJ_EXT)'; +} + diff --git a/contrib/perl5/hints/nonstopux.sh b/contrib/perl5/hints/nonstopux.sh new file mode 100644 index 000000000000..aec05ee680a8 --- /dev/null +++ b/contrib/perl5/hints/nonstopux.sh @@ -0,0 +1,17 @@ +# tom_bates@att.net +# mips-compaq-nonstopux + +. $src/hints/svr4.sh + +case "$cc" in + *gcc*) + ccflags='-fno-strict-aliasing' + lddlflags='-shared' + ldflags='' + ;; + *) + cc="cc -Xa -Olimit 4096" + malloctype="void *" + ;; +esac + diff --git a/contrib/perl5/lib/File/Spec/Epoc.pm b/contrib/perl5/lib/File/Spec/Epoc.pm new file mode 100644 index 000000000000..65d5e1fcb5e6 --- /dev/null +++ b/contrib/perl5/lib/File/Spec/Epoc.pm @@ -0,0 +1,378 @@ +package File::Spec::Epoc; + +use strict; +use Cwd; +use vars qw(@ISA); +require File::Spec::Unix; +@ISA = qw(File::Spec::Unix); + +=head1 NAME + +File::Spec::Epoc - methods for Epoc file specs + +=head1 SYNOPSIS + + require File::Spec::Epoc; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See File::Spec::Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +This package is still work in progress ;-) +o.flebbe@gmx.de + + +=over + +=item devnull + +Returns a string representation of the null device. + +=cut + +sub devnull { + return "nul:"; +} + +=item tmpdir + +Returns a string representation of a temporay directory: + +=cut + +my $tmpdir; +sub tmpdir { + return "C:/System/temp"; +} + +sub case_tolerant { + return 1; +} + +sub file_name_is_absolute { + my ($self,$file) = @_; + return scalar($file =~ m{^([a-z?]:)?[\\/]}is); +} + +=item path + +Takes no argument, returns the environment variable PATH as an array. Since +there is no search path supported, it returns undef, sorry. + +=cut +sub path { + return undef; +} + +=item canonpath + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminated successive slashes and successive "/.". + +=cut + +sub canonpath { + my ($self,$path) = @_; + $path =~ s/^([a-z]:)/\u$1/s; + + $path =~ s|/+|/|g unless($^O eq 'cygwin'); # xx////xx -> xx/xx + $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx + $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx + $path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx + $path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx + return $path; +} + +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Splits a path in to volume, directory, and filename portions. Assumes that +the last file is a path unless the path ends in '\\', '\\.', '\\..' +or $no_file is true. On Win32 this means that $no_file true makes this return +( $volume, $path, undef ). + +Separators accepted are \ and /. + +The results can be passed to L to get back a path equivalent to +(usually identical to) the original path. + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + my ($volume,$directory,$file) = ('','',''); + if ( $nofile ) { + $path =~ + m{^( (?:[a-zA-Z?]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + } + else { + $path =~ + m{^ ( (?: [a-zA-Z?]: | + (?:\\\\|//)[^\\/]+[\\/][^\\/]+ + )? + ) + ( (?:.*[\\\\/](?:\.\.?\z)?)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + $file = $3; + } + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of L. + + @dirs = File::Spec->splitdir( $directories ); + +$directories must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, leading empty and +trailing directory entries can be returned, because these are significant +on some OSs. So, + + File::Spec->splitdir( "/a/b/c" ); + +Yields: + + ( '', 'a', 'b', '', 'c', '' ) + +=cut + +sub splitdir { + my ($self,$directories) = @_ ; + # + # split() likes to forget about trailing null fields, so here we + # check to be sure that there will not be any before handling the + # simple case. + # + if ( $directories !~ m|[\\/]\z| ) { + return split( m|[\\/]|, $directories ); + } + else { + # + # since there was a trailing separator, add a file name to the end, + # then do the split, then replace it with ''. + # + my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ; + $directories[ $#directories ]= '' ; + return @directories ; + } +} + + +=item catpath + +Takes volume, directory and file portions and returns an entire path. Under +Unix, $volume is ignored, and this is just like catfile(). On other OSs, +the $volume become significant. + +=cut + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + # If it's UNC, make sure the glue separator is there, reusing + # whatever separator is first in the $volume + $volume .= $1 + if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\z@s && + $directory =~ m@^[^\\/]@s + ) ; + + $volume .= $directory ; + + # If the volume is not just A:, make sure the glue separator is + # there, reusing whatever separator is first in the $volume if possible. + if ( $volume !~ m@^[a-zA-Z]:\z@s && + $volume =~ m@[^\\/]\z@ && + $file =~ m@[^\\/]@ + ) { + $volume =~ m@([\\/])@ ; + my $sep = $1 ? $1 : '\\' ; + $volume .= $sep ; + } + + $volume .= $file ; + + return $volume ; +} + + +=item abs2rel + +Takes a destination path and an optional base path returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $destination ) ; + $rel_path = File::Spec->abs2rel( $destination, $base ) ; + +If $base is not present or '', then L is used. If $base is relative, +then it is converted to absolute form using L. This means that it +is taken to be relative to L. + +On systems with the concept of a volume, this assumes that both paths +are on the $destination volume, and ignores the $base volume. + +On systems that have a grammar that indicates filenames, this ignores the +$base filename as well. Otherwise all path components are assumed to be +directories. + +If $path is relative, it is converted to absolute form using L. +This means that it is taken to be relative to L. + +Based on code written by Shigio Yamaguchi. + +No checks against the filesystem are made. + +=cut + +sub abs2rel { + my($self,$path,$base) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + $path = $self->rel2abs( $path ) ; + } + else { + $path = $self->canonpath( $path ) ; + } + + # Figure out the effective $base and clean it up. + if ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + elsif ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( $path_volume, $path_directories, $path_file ) = + $self->splitpath( $path, 1 ) ; + + my ( undef, $base_directories, undef ) = + $self->splitpath( $base, 1 ) ; + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my @basechunks = $self->splitdir( $base_directories ); + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) + ) { + shift @pathchunks ; + shift @basechunks ; + } + + # No need to catdir, we know these are well formed. + $path_directories = CORE::join( '\\', @pathchunks ); + $base_directories = CORE::join( '\\', @basechunks ); + + # $base_directories now contains the directories the resulting relative + # path must ascend out of before it can descend to $path_directory. So, + # replace all names with $parentDir + + #FA Need to replace between backslashes... + $base_directories =~ s|[^\\]+|..|g ; + + # Glue the two together, using a separator if necessary, and preventing an + # empty result. + + #FA Must check that new directories are not empty. + if ( $path_directories ne '' && $base_directories ne '' ) { + $path_directories = "$base_directories\\$path_directories" ; + } else { + $path_directories = "$base_directories$path_directories" ; + } + + # It makes no sense to add a relative path to a UNC volume + $path_volume = '' unless $path_volume =~ m{^[A-Z]:}is ; + + return $self->canonpath( + $self->catpath($path_volume, $path_directories, $path_file ) + ) ; +} + +=item rel2abs + +Converts a relative path to an absolute path. + + $abs_path = File::Spec->rel2abs( $destination ) ; + $abs_path = File::Spec->rel2abs( $destination, $base ) ; + +If $base is not present or '', then L is used. If $base is relative, +then it is converted to absolute form using L. This means that it +is taken to be relative to L. + +Assumes that both paths are on the $base volume, and ignores the +$destination volume. + +On systems that have a grammar that indicates filenames, this ignores the +$base filename as well. Otherwise all path components are assumed to be +directories. + +If $path is absolute, it is cleaned up and returned using L. + +Based on code written by Shigio Yamaguchi. + +No checks against the filesystem are made. + +=cut + +sub rel2abs($;$;) { + my ($self,$path,$base ) = @_; + + if ( ! $self->file_name_is_absolute( $path ) ) { + + if ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + my ( undef, $path_directories, $path_file ) = + $self->splitpath( $path, 1 ) ; + + my ( $base_volume, $base_directories, undef ) = + $self->splitpath( $base, 1 ) ; + + $path = $self->catpath( + $base_volume, + $self->catdir( $base_directories, $path_directories ), + $path_file + ) ; + } + + return $self->canonpath( $path ) ; +} + +=back + +=head1 SEE ALSO + +L + +=cut + +1; diff --git a/contrib/perl5/lib/File/Temp.pm b/contrib/perl5/lib/File/Temp.pm new file mode 100644 index 000000000000..b686682e5a21 --- /dev/null +++ b/contrib/perl5/lib/File/Temp.pm @@ -0,0 +1,1863 @@ +package File::Temp; + +=head1 NAME + +File::Temp - return name and handle of a temporary file safely + +=begin __INTERNALS + +=head1 PORTABILITY + +This module is designed to be portable across operating systems +and it currently supports Unix, VMS, DOS, OS/2 and Windows. When +porting to a new OS there are generally three main issues +that have to be solved: + +=over 4 + +=item * + +Can the OS unlink an open file? If it can not then the +C<_can_unlink_opened_file> method should be modified. + +=item * + +Are the return values from C reliable? By default all the +return values from C are compared when unlinking a temporary +file using the filename and the handle. Operating systems other than +unix do not always have valid entries in all fields. If C fails +then the C comparison should be modified accordingly. + +=item * + +Security. Systems that can not support a test for the sticky bit +on a directory can not use the MEDIUM and HIGH security tests. +The C<_can_do_level> method should be modified accordingly. + +=back + +=end __INTERNALS + +=head1 SYNOPSIS + + use File::Temp qw/ tempfile tempdir /; + + $dir = tempdir( CLEANUP => 1 ); + ($fh, $filename) = tempfile( DIR => $dir ); + + ($fh, $filename) = tempfile( $template, DIR => $dir); + ($fh, $filename) = tempfile( $template, SUFFIX => '.dat'); + + $fh = tempfile(); + +MkTemp family: + + use File::Temp qw/ :mktemp /; + + ($fh, $file) = mkstemp( "tmpfileXXXXX" ); + ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix); + + $tmpdir = mkdtemp( $template ); + + $unopened_file = mktemp( $template ); + +POSIX functions: + + use File::Temp qw/ :POSIX /; + + $file = tmpnam(); + $fh = tmpfile(); + + ($fh, $file) = tmpnam(); + ($fh, $file) = tmpfile(); + + +Compatibility functions: + + $unopened_file = File::Temp::tempnam( $dir, $pfx ); + +=begin later + +Objects (NOT YET IMPLEMENTED): + + require File::Temp; + + $fh = new File::Temp($template); + $fname = $fh->filename; + +=end later + +=head1 DESCRIPTION + +C can be used to create and open temporary files in a safe way. +The tempfile() function can be used to return the name and the open +filehandle of a temporary file. The tempdir() function can +be used to create a temporary directory. + +The security aspect of temporary file creation is emphasized such that +a filehandle and filename are returned together. This helps guarantee +that a race condition can not occur where the temporary file is +created by another process between checking for the existence of the +file and its opening. Additional security levels are provided to +check, for example, that the sticky bit is set on world writable +directories. See L<"safe_level"> for more information. + +For compatibility with popular C library functions, Perl implementations of +the mkstemp() family of functions are provided. These are, mkstemp(), +mkstemps(), mkdtemp() and mktemp(). + +Additionally, implementations of the standard L +tmpnam() and tmpfile() functions are provided if required. + +Implementations of mktemp(), tmpnam(), and tempnam() are provided, +but should be used with caution since they return only a filename +that was valid when function was called, so cannot guarantee +that the file will not exist by the time the caller opens the filename. + +=cut + +# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls +# People would like a version on 5.005 so give them what they want :-) +use 5.005; +use strict; +use Carp; +use File::Spec 0.8; +use File::Path qw/ rmtree /; +use Fcntl 1.03; +use Errno; +require VMS::Stdio if $^O eq 'VMS'; + +# Need the Symbol package if we are running older perl +require Symbol if $] < 5.006; + + +# use 'our' on v5.6.0 +use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG); + +$DEBUG = 0; + +# We are exporting functions + +use base qw/Exporter/; + +# Export list - to allow fine tuning of export table + +@EXPORT_OK = qw{ + tempfile + tempdir + tmpnam + tmpfile + mktemp + mkstemp + mkstemps + mkdtemp + unlink0 + }; + +# Groups of functions for export + +%EXPORT_TAGS = ( + 'POSIX' => [qw/ tmpnam tmpfile /], + 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/], + ); + +# add contents of these tags to @EXPORT +Exporter::export_tags('POSIX','mktemp'); + +# Version number + +$VERSION = '0.12'; + +# This is a list of characters that can be used in random filenames + +my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z + a b c d e f g h i j k l m n o p q r s t u v w x y z + 0 1 2 3 4 5 6 7 8 9 _ + /); + +# Maximum number of tries to make a temp file before failing + +use constant MAX_TRIES => 10; + +# Minimum number of X characters that should be in a template +use constant MINX => 4; + +# Default template when no template supplied + +use constant TEMPXXX => 'X' x 10; + +# Constants for the security level + +use constant STANDARD => 0; +use constant MEDIUM => 1; +use constant HIGH => 2; + +# OPENFLAGS. If we defined the flag to use with Sysopen here this gives +# us an optimisation when many temporary files are requested + +my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR; + +for my $oflag (qw/ FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT /) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + no strict 'refs'; + $OPENFLAGS |= $bit if eval { + # Make sure that redefined die handlers do not cause problems + # eg CGI::Carp + local $SIG{__DIE__} = sub {}; + local $SIG{__WARN__} = sub {}; + $bit = &$func(); + 1; + }; +} + +# On some systems the O_TEMPORARY flag can be used to tell the OS +# to automatically remove the file when it is closed. This is fine +# in most cases but not if tempfile is called with UNLINK=>0 and +# the filename is requested -- in the case where the filename is to +# be passed to another routine. This happens on windows. We overcome +# this by using a second open flags variable + +my $OPENTEMPFLAGS = $OPENFLAGS; +for my $oflag (qw/ TEMPORARY /) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + no strict 'refs'; + $OPENTEMPFLAGS |= $bit if eval { + # Make sure that redefined die handlers do not cause problems + # eg CGI::Carp + local $SIG{__DIE__} = sub {}; + local $SIG{__WARN__} = sub {}; + $bit = &$func(); + 1; + }; +} + +# INTERNAL ROUTINES - not to be used outside of package + +# Generic routine for getting a temporary filename +# modelled on OpenBSD _gettemp() in mktemp.c + +# The template must contain X's that are to be replaced +# with the random values + +# Arguments: + +# TEMPLATE - string containing the XXXXX's that is converted +# to a random filename and opened if required + +# Optionally, a hash can also be supplied containing specific options +# "open" => if true open the temp file, else just return the name +# default is 0 +# "mkdir"=> if true, we are creating a temp directory rather than tempfile +# default is 0 +# "suffixlen" => number of characters at end of PATH to be ignored. +# default is 0. +# "unlink_on_close" => indicates that, if possible, the OS should remove +# the file as soon as it is closed. Usually indicates +# use of the O_TEMPORARY flag to sysopen. +# Usually irrelevant on unix + +# Optionally a reference to a scalar can be passed into the function +# On error this will be used to store the reason for the error +# "ErrStr" => \$errstr + +# "open" and "mkdir" can not both be true +# "unlink_on_close" is not used when "mkdir" is true. + +# The default options are equivalent to mktemp(). + +# Returns: +# filehandle - open file handle (if called with doopen=1, else undef) +# temp name - name of the temp file or directory + +# For example: +# ($fh, $name) = _gettemp($template, "open" => 1); + +# for the current version, failures are associated with +# stored in an error string and returned to give the reason whilst debugging +# This routine is not called by any external function +sub _gettemp { + + croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);' + unless scalar(@_) >= 1; + + # the internal error string - expect it to be overridden + # Need this in case the caller decides not to supply us a value + # need an anonymous scalar + my $tempErrStr; + + # Default options + my %options = ( + "open" => 0, + "mkdir" => 0, + "suffixlen" => 0, + "unlink_on_close" => 0, + "ErrStr" => \$tempErrStr, + ); + + # Read the template + my $template = shift; + if (ref($template)) { + # Use a warning here since we have not yet merged ErrStr + carp "File::Temp::_gettemp: template must not be a reference"; + return (); + } + + # Check that the number of entries on stack are even + if (scalar(@_) % 2 != 0) { + # Use a warning here since we have not yet merged ErrStr + carp "File::Temp::_gettemp: Must have even number of options"; + return (); + } + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # Make sure the error string is set to undef + ${$options{ErrStr}} = undef; + + # Can not open the file and make a directory in a single call + if ($options{"open"} && $options{"mkdir"}) { + ${$options{ErrStr}} = "doopen and domkdir can not both be true\n"; + return (); + } + + # Find the start of the end of the Xs (position of last X) + # Substr starts from 0 + my $start = length($template) - 1 - $options{"suffixlen"}; + + # Check that we have at least MINX x X (eg 'XXXX") at the end of the string + # (taking suffixlen into account). Any fewer is insecure. + + # Do it using substr - no reason to use a pattern match since + # we know where we are looking and what we are looking for + + if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) { + ${$options{ErrStr}} = "The template must contain at least ". + MINX . " 'X' characters\n"; + return (); + } + + # Replace all the X at the end of the substring with a + # random character or just all the XX at the end of a full string. + # Do it as an if, since the suffix adjusts which section to replace + # and suffixlen=0 returns nothing if used in the substr directly + # and generate a full path from the template + + my $path = _replace_XX($template, $options{"suffixlen"}); + + + # Split the path into constituent parts - eventually we need to check + # whether the directory exists + # We need to know whether we are making a temp directory + # or a tempfile + + my ($volume, $directories, $file); + my $parent; # parent directory + if ($options{"mkdir"}) { + # There is no filename at the end + ($volume, $directories, $file) = File::Spec->splitpath( $path, 1); + + # The parent is then $directories without the last directory + # Split the directory and put it back together again + my @dirs = File::Spec->splitdir($directories); + + # If @dirs only has one entry that means we are in the current + # directory + if ($#dirs == 0) { + $parent = File::Spec->curdir; + } else { + + if ($^O eq 'VMS') { # need volume to avoid relative dir spec + $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]); + $parent = 'sys$disk:[]' if $parent eq ''; + } else { + + # Put it back together without the last one + $parent = File::Spec->catdir(@dirs[0..$#dirs-1]); + + # ...and attach the volume (no filename) + $parent = File::Spec->catpath($volume, $parent, ''); + } + + } + + } else { + + # Get rid of the last filename (use File::Basename for this?) + ($volume, $directories, $file) = File::Spec->splitpath( $path ); + + # Join up without the file part + $parent = File::Spec->catpath($volume,$directories,''); + + # If $parent is empty replace with curdir + $parent = File::Spec->curdir + unless $directories ne ''; + + } + + # Check that the parent directories exist + # Do this even for the case where we are simply returning a name + # not a file -- no point returning a name that includes a directory + # that does not exist or is not writable + + unless (-d $parent) { + ${$options{ErrStr}} = "Parent directory ($parent) is not a directory"; + return (); + } + unless (-w _) { + ${$options{ErrStr}} = "Parent directory ($parent) is not writable\n"; + return (); + } + + + # Check the stickiness of the directory and chown giveaway if required + # If the directory is world writable the sticky bit + # must be set + + if (File::Temp->safe_level == MEDIUM) { + my $safeerr; + unless (_is_safe($parent,\$safeerr)) { + ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)"; + return (); + } + } elsif (File::Temp->safe_level == HIGH) { + my $safeerr; + unless (_is_verysafe($parent, \$safeerr)) { + ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)"; + return (); + } + } + + + # Now try MAX_TRIES time to open the file + for (my $i = 0; $i < MAX_TRIES; $i++) { + + # Try to open the file if requested + if ($options{"open"}) { + my $fh; + + # If we are running before perl5.6.0 we can not auto-vivify + if ($] < 5.006) { + $fh = &Symbol::gensym; + } + + # Try to make sure this will be marked close-on-exec + # XXX: Win32 doesn't respect this, nor the proper fcntl, + # but may have O_NOINHERIT. This may or may not be in Fcntl. + local $^F = 2; + + # Store callers umask + my $umask = umask(); + + # Set a known umask + umask(066); + + # Attempt to open the file + my $open_success = undef; + if ( $^O eq 'VMS' and $options{"unlink_on_close"} ) { + # make it auto delete on close by setting FAB$V_DLT bit + $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt'); + $open_success = $fh; + } else { + my $flags = ( $options{"unlink_on_close"} ? + $OPENTEMPFLAGS : + $OPENFLAGS ); + $open_success = sysopen($fh, $path, $flags, 0600); + } + if ( $open_success ) { + + # Reset umask + umask($umask); + + # Opened successfully - return file handle and name + return ($fh, $path); + + } else { + # Reset umask + umask($umask); + + # Error opening file - abort with error + # if the reason was anything but EEXIST + unless ($!{EEXIST}) { + ${$options{ErrStr}} = "Could not create temp file $path: $!"; + return (); + } + + # Loop round for another try + + } + } elsif ($options{"mkdir"}) { + + # Store callers umask + my $umask = umask(); + + # Set a known umask + umask(066); + + # Open the temp directory + if (mkdir( $path, 0700)) { + # created okay + # Reset umask + umask($umask); + + return undef, $path; + } else { + + # Reset umask + umask($umask); + + # Abort with error if the reason for failure was anything + # except EEXIST + unless ($!{EEXIST}) { + ${$options{ErrStr}} = "Could not create directory $path: $!"; + return (); + } + + # Loop round for another try + + } + + } else { + + # Return true if the file can not be found + # Directory has been checked previously + + return (undef, $path) unless -e $path; + + # Try again until MAX_TRIES + + } + + # Did not successfully open the tempfile/dir + # so try again with a different set of random letters + # No point in trying to increment unless we have only + # 1 X say and the randomness could come up with the same + # file MAX_TRIES in a row. + + # Store current attempt - in principal this implies that the + # 3rd time around the open attempt that the first temp file + # name could be generated again. Probably should store each + # attempt and make sure that none are repeated + + my $original = $path; + my $counter = 0; # Stop infinite loop + my $MAX_GUESS = 50; + + do { + + # Generate new name from original template + $path = _replace_XX($template, $options{"suffixlen"}); + + $counter++; + + } until ($path ne $original || $counter > $MAX_GUESS); + + # Check for out of control looping + if ($counter > $MAX_GUESS) { + ${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)"; + return (); + } + + } + + # If we get here, we have run out of tries + ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts (" + . MAX_TRIES . ") to open temp file/dir"; + + return (); + +} + +# Internal routine to return a random character from the +# character list. Does not do an srand() since rand() +# will do one automatically + +# No arguments. Return value is the random character + +# No longer called since _replace_XX runs a few percent faster if +# I inline the code. This is important if we are creating thousands of +# temporary files. + +sub _randchar { + + $CHARS[ int( rand( $#CHARS ) ) ]; + +} + +# Internal routine to replace the XXXX... with random characters +# This has to be done by _gettemp() every time it fails to +# open a temp file/dir + +# Arguments: $template (the template with XXX), +# $ignore (number of characters at end to ignore) + +# Returns: modified template + +sub _replace_XX { + + croak 'Usage: _replace_XX($template, $ignore)' + unless scalar(@_) == 2; + + my ($path, $ignore) = @_; + + # Do it as an if, since the suffix adjusts which section to replace + # and suffixlen=0 returns nothing if used in the substr directly + # Alternatively, could simply set $ignore to length($path)-1 + # Don't want to always use substr when not required though. + + if ($ignore) { + substr($path, 0, - $ignore) =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge; + } else { + $path =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge; + } + + return $path; +} + +# internal routine to check to see if the directory is safe +# First checks to see if the directory is not owned by the +# current user or root. Then checks to see if anyone else +# can write to the directory and if so, checks to see if +# it has the sticky bit set + +# Will not work on systems that do not support sticky bit + +#Args: directory path to check +# Optionally: reference to scalar to contain error message +# Returns true if the path is safe and false otherwise. +# Returns undef if can not even run stat() on the path + +# This routine based on version written by Tom Christiansen + +# Presumably, by the time we actually attempt to create the +# file or directory in this directory, it may not be safe +# anymore... Have to run _is_safe directly after the open. + +sub _is_safe { + + my $path = shift; + my $err_ref = shift; + + # Stat path + my @info = stat($path); + unless (scalar(@info)) { + $$err_ref = "stat(path) returned no values"; + return 0; + }; + return 1 if $^O eq 'VMS'; # owner delete control at file level + + # Check to see whether owner is neither superuser (or a system uid) nor me + # Use the real uid from the $< variable + # UID is in [4] + if ($info[4] > File::Temp->top_system_uid() && $info[4] != $<) { + + Carp::cluck(sprintf "uid=$info[4] topuid=%s \$<=$< path='$path'", + File::Temp->top_system_uid()); + + $$err_ref = "Directory owned neither by root nor the current user" + if ref($err_ref); + return 0; + } + + # check whether group or other can write file + # use 066 to detect either reading or writing + # use 022 to check writability + # Do it with S_IWOTH and S_IWGRP for portability (maybe) + # mode is in info[2] + if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable? + ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable? + # Must be a directory + unless (-d _) { + $$err_ref = "Path ($path) is not a directory" + if ref($err_ref); + return 0; + } + # Must have sticky bit set + unless (-k _) { + $$err_ref = "Sticky bit not set on $path when dir is group|world writable" + if ref($err_ref); + return 0; + } + } + + return 1; +} + +# Internal routine to check whether a directory is safe +# for temp files. Safer than _is_safe since it checks for +# the possibility of chown giveaway and if that is a possibility +# checks each directory in the path to see if it is safe (with _is_safe) + +# If _PC_CHOWN_RESTRICTED is not set, does the full test of each +# directory anyway. + +# Takes optional second arg as scalar ref to error reason + +sub _is_verysafe { + + # Need POSIX - but only want to bother if really necessary due to overhead + require POSIX; + + my $path = shift; + print "_is_verysafe testing $path\n" if $DEBUG; + return 1 if $^O eq 'VMS'; # owner delete control at file level + + my $err_ref = shift; + + # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined + # and If it is not there do the extensive test + my $chown_restricted; + $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED() + if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1}; + + # If chown_resticted is set to some value we should test it + if (defined $chown_restricted) { + + # Return if the current directory is safe + return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted ); + + } + + # To reach this point either, the _PC_CHOWN_RESTRICTED symbol + # was not avialable or the symbol was there but chown giveaway + # is allowed. Either way, we now have to test the entire tree for + # safety. + + # Convert path to an absolute directory if required + unless (File::Spec->file_name_is_absolute($path)) { + $path = File::Spec->rel2abs($path); + } + + # Split directory into components - assume no file + my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1); + + # Slightly less efficient than having a a function in File::Spec + # to chop off the end of a directory or even a function that + # can handle ../ in a directory tree + # Sometimes splitdir() returns a blank at the end + # so we will probably check the bottom directory twice in some cases + my @dirs = File::Spec->splitdir($directories); + + # Concatenate one less directory each time around + foreach my $pos (0.. $#dirs) { + # Get a directory name + my $dir = File::Spec->catpath($volume, + File::Spec->catdir(@dirs[0.. $#dirs - $pos]), + '' + ); + + print "TESTING DIR $dir\n" if $DEBUG; + + # Check the directory + return 0 unless _is_safe($dir,$err_ref); + + } + + return 1; +} + + + +# internal routine to determine whether unlink works on this +# platform for files that are currently open. +# Returns true if we can, false otherwise. + +# Currently WinNT, OS/2 and VMS can not unlink an opened file +# On VMS this is because the O_EXCL flag is used to open the +# temporary file. Currently I do not know enough about the issues +# on VMS to decide whether O_EXCL is a requirement. + +sub _can_unlink_opened_file { + + if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos') { + return 0; + } else { + return 1; + } + +} + +# internal routine to decide which security levels are allowed +# see safe_level() for more information on this + +# Controls whether the supplied security level is allowed + +# $cando = _can_do_level( $level ) + +sub _can_do_level { + + # Get security level + my $level = shift; + + # Always have to be able to do STANDARD + return 1 if $level == STANDARD; + + # Currently, the systems that can do HIGH or MEDIUM are identical + if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos') { + return 0; + } else { + return 1; + } + +} + +# This routine sets up a deferred unlinking of a specified +# filename and filehandle. It is used in the following cases: +# - Called by unlink0 if an opened file can not be unlinked +# - Called by tempfile() if files are to be removed on shutdown +# - Called by tempdir() if directories are to be removed on shutdown + +# Arguments: +# _deferred_unlink( $fh, $fname, $isdir ); +# +# - filehandle (so that it can be expclicitly closed if open +# - filename (the thing we want to remove) +# - isdir (flag to indicate that we are being given a directory) +# [and hence no filehandle] + +# Status is not referred to since all the magic is done with an END block + +{ + # Will set up two lexical variables to contain all the files to be + # removed. One array for files, another for directories + # They will only exist in this block + # This means we only have to set up a single END block to remove all files + # @files_to_unlink contains an array ref with the filehandle and filename + my (@files_to_unlink, @dirs_to_unlink); + + # Set up an end block to use these arrays + END { + # Files + foreach my $file (@files_to_unlink) { + # close the filehandle without checking its state + # in order to make real sure that this is closed + # if its already closed then I dont care about the answer + # probably a better way to do this + close($file->[0]); # file handle is [0] + + if (-f $file->[1]) { # file name is [1] + unlink $file->[1] or warn "Error removing ".$file->[1]; + } + } + # Dirs + foreach my $dir (@dirs_to_unlink) { + if (-d $dir) { + rmtree($dir, $DEBUG, 1); + } + } + + } + + # This is the sub called to register a file for deferred unlinking + # This could simply store the input parameters and defer everything + # until the END block. For now we do a bit of checking at this + # point in order to make sure that (1) we have a file/dir to delete + # and (2) we have been called with the correct arguments. + sub _deferred_unlink { + + croak 'Usage: _deferred_unlink($fh, $fname, $isdir)' + unless scalar(@_) == 3; + + my ($fh, $fname, $isdir) = @_; + + warn "Setting up deferred removal of $fname\n" + if $DEBUG; + + # If we have a directory, check that it is a directory + if ($isdir) { + + if (-d $fname) { + + # Directory exists so store it + # first on VMS turn []foo into [.foo] for rmtree + $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS'; + push (@dirs_to_unlink, $fname); + + } else { + carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W; + } + + } else { + + if (-f $fname) { + + # file exists so store handle and name for later removal + push(@files_to_unlink, [$fh, $fname]); + + } else { + carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W; + } + + } + + } + + +} + +=head1 FUNCTIONS + +This section describes the recommended interface for generating +temporary files and directories. + +=over 4 + +=item B + +This is the basic function to generate temporary files. +The behaviour of the file can be changed using various options: + + ($fh, $filename) = tempfile(); + +Create a temporary file in the directory specified for temporary +files, as specified by the tmpdir() function in L. + + ($fh, $filename) = tempfile($template); + +Create a temporary file in the current directory using the supplied +template. Trailing `X' characters are replaced with random letters to +generate the filename. At least four `X' characters must be present +in the template. + + ($fh, $filename) = tempfile($template, SUFFIX => $suffix) + +Same as previously, except that a suffix is added to the template +after the `X' translation. Useful for ensuring that a temporary +filename has a particular extension when needed by other applications. +But see the WARNING at the end. + + ($fh, $filename) = tempfile($template, DIR => $dir); + +Translates the template as before except that a directory name +is specified. + + ($fh, $filename) = tempfile($template, UNLINK => 1); + +Return the filename and filehandle as before except that the file is +automatically removed when the program exits. Default is for the file +to be removed if a file handle is requested and to be kept if the +filename is requested. In a scalar context (where no filename is +returned) the file is always deleted either on exit or when it is closed. + +If the template is not specified, a template is always +automatically generated. This temporary file is placed in tmpdir() +(L) unless a directory is specified explicitly with the +DIR option. + + $fh = tempfile( $template, DIR => $dir ); + +If called in scalar context, only the filehandle is returned +and the file will automatically be deleted when closed (see +the description of tmpfile() elsewhere in this document). +This is the preferred mode of operation, as if you only +have a filehandle, you can never create a race condition +by fumbling with the filename. On systems that can not unlink +an open file or can not mark a file as temporary when it is opened +(for example, Windows NT uses the C flag)) +the file is marked for deletion when the program ends (equivalent +to setting UNLINK to 1). The C flag is ignored if present. + + (undef, $filename) = tempfile($template, OPEN => 0); + +This will return the filename based on the template but +will not open this file. Cannot be used in conjunction with +UNLINK set to true. Default is to always open the file +to protect from possible race conditions. A warning is issued +if warnings are turned on. Consider using the tmpnam() +and mktemp() functions described elsewhere in this document +if opening the file is not required. + +Options can be combined as required. + +=cut + +sub tempfile { + + # Can not check for argument count since we can have any + # number of args + + # Default options + my %options = ( + "DIR" => undef, # Directory prefix + "SUFFIX" => '', # Template suffix + "UNLINK" => 0, # Do not unlink file on exit + "OPEN" => 1, # Open file + ); + + # Check to see whether we have an odd or even number of arguments + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef); + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # First decision is whether or not to open the file + if (! $options{"OPEN"}) { + + warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n" + if $^W; + + } + + if ($options{"DIR"} and $^O eq 'VMS') { + + # on VMS turn []foo into [.foo] for concatenation + $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"}); + } + + # Construct the template + + # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc + # functions or simply constructing a template and using _gettemp() + # explicitly. Go for the latter + + # First generate a template if not defined and prefix the directory + # If no template must prefix the temp directory + if (defined $template) { + if ($options{"DIR"}) { + + $template = File::Spec->catfile($options{"DIR"}, $template); + + } + + } else { + + if ($options{"DIR"}) { + + $template = File::Spec->catfile($options{"DIR"}, TEMPXXX); + + } else { + + $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX); + + } + + } + + # Now add a suffix + $template .= $options{"SUFFIX"}; + + # Determine whether we should tell _gettemp to unlink the file + # On unix this is irrelevant and can be worked out after the file is + # opened (simply by unlinking the open filehandle). On Windows or VMS + # we have to indicate temporary-ness when we open the file. In general + # we only want a true temporary file if we are returning just the + # filehandle - if the user wants the filename they probably do not + # want the file to disappear as soon as they close it. + # For this reason, tie unlink_on_close to the return context regardless + # of OS. + my $unlink_on_close = ( wantarray ? 0 : 1); + + # Create the file + my ($fh, $path, $errstr); + croak "Error in tempfile() using $template: $errstr" + unless (($fh, $path) = _gettemp($template, + "open" => $options{'OPEN'}, + "mkdir"=> 0 , + "unlink_on_close" => $unlink_on_close, + "suffixlen" => length($options{'SUFFIX'}), + "ErrStr" => \$errstr, + ) ); + + # Set up an exit handler that can do whatever is right for the + # system. This removes files at exit when requested explicitly or when + # system is asked to unlink_on_close but is unable to do so because + # of OS limitations. + # The latter should be achieved by using a tied filehandle. + # Do not check return status since this is all done with END blocks. + _deferred_unlink($fh, $path, 0) if $options{"UNLINK"}; + + # Return + if (wantarray()) { + + if ($options{'OPEN'}) { + return ($fh, $path); + } else { + return (undef, $path); + } + + } else { + + # Unlink the file. It is up to unlink0 to decide what to do with + # this (whether to unlink now or to defer until later) + unlink0($fh, $path) or croak "Error unlinking file $path using unlink0"; + + # Return just the filehandle. + return $fh; + } + + +} + +=item B + +This is the recommended interface for creation of temporary directories. +The behaviour of the function depends on the arguments: + + $tempdir = tempdir(); + +Create a directory in tmpdir() (see L). + + $tempdir = tempdir( $template ); + +Create a directory from the supplied template. This template is +similar to that described for tempfile(). `X' characters at the end +of the template are replaced with random letters to construct the +directory name. At least four `X' characters must be in the template. + + $tempdir = tempdir ( DIR => $dir ); + +Specifies the directory to use for the temporary directory. +The temporary directory name is derived from an internal template. + + $tempdir = tempdir ( $template, DIR => $dir ); + +Prepend the supplied directory name to the template. The template +should not include parent directory specifications itself. Any parent +directory specifications are removed from the template before +prepending the supplied directory. + + $tempdir = tempdir ( $template, TMPDIR => 1 ); + +Using the supplied template, creat the temporary directory in +a standard location for temporary files. Equivalent to doing + + $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir); + +but shorter. Parent directory specifications are stripped from the +template itself. The C option is ignored if C is set +explicitly. Additionally, C is implied if neither a template +nor a directory are supplied. + + $tempdir = tempdir( $template, CLEANUP => 1); + +Create a temporary directory using the supplied template, but +attempt to remove it (and all files inside it) when the program +exits. Note that an attempt will be made to remove all files from +the directory even if they were not created by this module (otherwise +why ask to clean it up?). The directory removal is made with +the rmtree() function from the L module. +Of course, if the template is not specified, the temporary directory +will be created in tmpdir() and will also be removed at program exit. + +=cut + +# ' + +sub tempdir { + + # Can not check for argument count since we can have any + # number of args + + # Default options + my %options = ( + "CLEANUP" => 0, # Remove directory on exit + "DIR" => '', # Root directory + "TMPDIR" => 0, # Use tempdir with template + ); + + # Check to see whether we have an odd or even number of arguments + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef ); + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # Modify or generate the template + + # Deal with the DIR and TMPDIR options + if (defined $template) { + + # Need to strip directory path if using DIR or TMPDIR + if ($options{'TMPDIR'} || $options{'DIR'}) { + + # Strip parent directory from the filename + # + # There is no filename at the end + $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS'; + my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1); + + # Last directory is then our template + $template = (File::Spec->splitdir($directories))[-1]; + + # Prepend the supplied directory or temp dir + if ($options{"DIR"}) { + + $template = File::Spec->catdir($options{"DIR"}, $template); + + } elsif ($options{TMPDIR}) { + + # Prepend tmpdir + $template = File::Spec->catdir(File::Spec->tmpdir, $template); + + } + + } + + } else { + + if ($options{"DIR"}) { + + $template = File::Spec->catdir($options{"DIR"}, TEMPXXX); + + } else { + + $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX); + + } + + } + + # Create the directory + my $tempdir; + my $suffixlen = 0; + if ($^O eq 'VMS') { # dir names can end in delimiters + $template =~ m/([\.\]:>]+)$/; + $suffixlen = length($1); + } + + my $errstr; + croak "Error in tempdir() using $template: $errstr" + unless ((undef, $tempdir) = _gettemp($template, + "open" => 0, + "mkdir"=> 1 , + "suffixlen" => $suffixlen, + "ErrStr" => \$errstr, + ) ); + + # Install exit handler; must be dynamic to get lexical + if ( $options{'CLEANUP'} && -d $tempdir) { + _deferred_unlink(undef, $tempdir, 1); + } + + # Return the dir name + return $tempdir; + +} + +=back + +=head1 MKTEMP FUNCTIONS + +The following functions are Perl implementations of the +mktemp() family of temp file generation system calls. + +=over 4 + +=item B + +Given a template, returns a filehandle to the temporary file and the name +of the file. + + ($fh, $name) = mkstemp( $template ); + +In scalar context, just the filehandle is returned. + +The template may be any filename with some number of X's appended +to it, for example F. The trailing X's are replaced +with unique alphanumeric combinations. + +=cut + + + +sub mkstemp { + + croak "Usage: mkstemp(template)" + if scalar(@_) != 1; + + my $template = shift; + + my ($fh, $path, $errstr); + croak "Error in mkstemp using $template: $errstr" + unless (($fh, $path) = _gettemp($template, + "open" => 1, + "mkdir"=> 0 , + "suffixlen" => 0, + "ErrStr" => \$errstr, + ) ); + + if (wantarray()) { + return ($fh, $path); + } else { + return $fh; + } + +} + + +=item B + +Similar to mkstemp(), except that an extra argument can be supplied +with a suffix to be appended to the template. + + ($fh, $name) = mkstemps( $template, $suffix ); + +For example a template of C and suffix of C<.dat> +would generate a file similar to F. + +Returns just the filehandle alone when called in scalar context. + +=cut + +sub mkstemps { + + croak "Usage: mkstemps(template, suffix)" + if scalar(@_) != 2; + + + my $template = shift; + my $suffix = shift; + + $template .= $suffix; + + my ($fh, $path, $errstr); + croak "Error in mkstemps using $template: $errstr" + unless (($fh, $path) = _gettemp($template, + "open" => 1, + "mkdir"=> 0 , + "suffixlen" => length($suffix), + "ErrStr" => \$errstr, + ) ); + + if (wantarray()) { + return ($fh, $path); + } else { + return $fh; + } + +} + +=item B + +Create a directory from a template. The template must end in +X's that are replaced by the routine. + + $tmpdir_name = mkdtemp($template); + +Returns the name of the temporary directory created. +Returns undef on failure. + +Directory must be removed by the caller. + +=cut + +#' # for emacs + +sub mkdtemp { + + croak "Usage: mkdtemp(template)" + if scalar(@_) != 1; + + my $template = shift; + my $suffixlen = 0; + if ($^O eq 'VMS') { # dir names can end in delimiters + $template =~ m/([\.\]:>]+)$/; + $suffixlen = length($1); + } + my ($junk, $tmpdir, $errstr); + croak "Error creating temp directory from template $template\: $errstr" + unless (($junk, $tmpdir) = _gettemp($template, + "open" => 0, + "mkdir"=> 1 , + "suffixlen" => $suffixlen, + "ErrStr" => \$errstr, + ) ); + + return $tmpdir; + +} + +=item B + +Returns a valid temporary filename but does not guarantee +that the file will not be opened by someone else. + + $unopened_file = mktemp($template); + +Template is the same as that required by mkstemp(). + +=cut + +sub mktemp { + + croak "Usage: mktemp(template)" + if scalar(@_) != 1; + + my $template = shift; + + my ($tmpname, $junk, $errstr); + croak "Error getting name to temp file from template $template: $errstr" + unless (($junk, $tmpname) = _gettemp($template, + "open" => 0, + "mkdir"=> 0 , + "suffixlen" => 0, + "ErrStr" => \$errstr, + ) ); + + return $tmpname; +} + +=back + +=head1 POSIX FUNCTIONS + +This section describes the re-implementation of the tmpnam() +and tmpfile() functions described in L +using the mkstemp() from this module. + +Unlike the L implementations, the directory used +for the temporary file is not specified in a system include +file (C) but simply depends on the choice of tmpdir() +returned by L. On some implementations this +location can be set using the C environment variable, which +may not be secure. +If this is a problem, simply use mkstemp() and specify a template. + +=over 4 + +=item B + +When called in scalar context, returns the full name (including path) +of a temporary file (uses mktemp()). The only check is that the file does +not already exist, but there is no guarantee that that condition will +continue to apply. + + $file = tmpnam(); + +When called in list context, a filehandle to the open file and +a filename are returned. This is achieved by calling mkstemp() +after constructing a suitable template. + + ($fh, $file) = tmpnam(); + +If possible, this form should be used to prevent possible +race conditions. + +See L for information on the choice of temporary +directory for a particular operating system. + +=cut + +sub tmpnam { + + # Retrieve the temporary directory name + my $tmpdir = File::Spec->tmpdir; + + croak "Error temporary directory is not writable" + if $tmpdir eq ''; + + # Use a ten character template and append to tmpdir + my $template = File::Spec->catfile($tmpdir, TEMPXXX); + + if (wantarray() ) { + return mkstemp($template); + } else { + return mktemp($template); + } + +} + +=item B + +In scalar context, returns the filehandle of a temporary file. + + $fh = tmpfile(); + +The file is removed when the filehandle is closed or when the program +exits. No access to the filename is provided. + +If the temporary file can not be created undef is returned. +Currently this command will probably not work when the temporary +directory is on an NFS file system. + +=cut + +sub tmpfile { + + # Simply call tmpnam() in a list context + my ($fh, $file) = tmpnam(); + + # Make sure file is removed when filehandle is closed + # This will fail on NFS + unlink0($fh, $file) + or return undef; + + return $fh; + +} + +=back + +=head1 ADDITIONAL FUNCTIONS + +These functions are provided for backwards compatibility +with common tempfile generation C library functions. + +They are not exported and must be addressed using the full package +name. + +=over 4 + +=item B + +Return the name of a temporary file in the specified directory +using a prefix. The file is guaranteed not to exist at the time +the function was called, but such guarantees are good for one +clock tick only. Always use the proper form of C +with C if you must open such a filename. + + $filename = File::Temp::tempnam( $dir, $prefix ); + +Equivalent to running mktemp() with $dir/$prefixXXXXXXXX +(using unix file convention as an example) + +Because this function uses mktemp(), it can suffer from race conditions. + +=cut + +sub tempnam { + + croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2; + + my ($dir, $prefix) = @_; + + # Add a string to the prefix + $prefix .= 'XXXXXXXX'; + + # Concatenate the directory to the file + my $template = File::Spec->catfile($dir, $prefix); + + return mktemp($template); + +} + +=back + +=head1 UTILITY FUNCTIONS + +Useful functions for dealing with the filehandle and filename. + +=over 4 + +=item B + +Given an open filehandle and the associated filename, make a safe +unlink. This is achieved by first checking that the filename and +filehandle initially point to the same file and that the number of +links to the file is 1 (all fields returned by stat() are compared). +Then the filename is unlinked and the filehandle checked once again to +verify that the number of links on that file is now 0. This is the +closest you can come to making sure that the filename unlinked was the +same as the file whose descriptor you hold. + + unlink0($fh, $path) or die "Error unlinking file $path safely"; + +Returns false on error. The filehandle is not closed since on some +occasions this is not required. + +On some platforms, for example Windows NT, it is not possible to +unlink an open file (the file must be closed first). On those +platforms, the actual unlinking is deferred until the program ends and +good status is returned. A check is still performed to make sure that +the filehandle and filename are pointing to the same thing (but not at +the time the end block is executed since the deferred removal may not +have access to the filehandle). + +Additionally, on Windows NT not all the fields returned by stat() can +be compared. For example, the C and C fields seem to be +different. Also, it seems that the size of the file returned by stat() +does not always agree, with C being more accurate than +C, presumably because of caching issues even when +using autoflush (this is usually overcome by waiting a while after +writing to the tempfile before attempting to C it). + +Finally, on NFS file systems the link count of the file handle does +not always go to zero immediately after unlinking. Currently, this +command is expected to fail on NFS disks. + +=cut + +sub unlink0 { + + croak 'Usage: unlink0(filehandle, filename)' + unless scalar(@_) == 2; + + # Read args + my ($fh, $path) = @_; + + warn "Unlinking $path using unlink0\n" + if $DEBUG; + + # Stat the filehandle + my @fh = stat $fh; + + if ($fh[3] > 1 && $^W) { + carp "unlink0: fstat found too many links; SB=@fh" if $^W; + } + + # Stat the path + my @path = stat $path; + + unless (@path) { + carp "unlink0: $path is gone already" if $^W; + return; + } + + # this is no longer a file, but may be a directory, or worse + unless (-f _) { + confess "panic: $path is no longer a file: SB=@fh"; + } + + # Do comparison of each member of the array + # On WinNT dev and rdev seem to be different + # depending on whether it is a file or a handle. + # Cannot simply compare all members of the stat return + # Select the ones we can use + my @okstat = (0..$#fh); # Use all by default + if ($^O eq 'MSWin32') { + @okstat = (1,2,3,4,5,7,8,9,10); + } elsif ($^O eq 'os2') { + @okstat = (0, 2..$#fh); + } elsif ($^O eq 'VMS') { # device and file ID are sufficient + @okstat = (0, 1); + } elsif ($^O eq 'dos') { + @okstat = (0,2..7,11..$#fh); + } + + # Now compare each entry explicitly by number + for (@okstat) { + print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG; + # Use eq rather than == since rdev, blksize, and blocks (6, 11, + # and 12) will be '' on platforms that do not support them. This + # is fine since we are only comparing integers. + unless ($fh[$_] eq $path[$_]) { + warn "Did not match $_ element of stat\n" if $DEBUG; + return 0; + } + } + + # attempt remove the file (does not work on some platforms) + if (_can_unlink_opened_file()) { + # XXX: do *not* call this on a directory; possible race + # resulting in recursive removal + croak "unlink0: $path has become a directory!" if -d $path; + unlink($path) or return 0; + + # Stat the filehandle + @fh = stat $fh; + + print "Link count = $fh[3] \n" if $DEBUG; + + # Make sure that the link count is zero + # - Cygwin provides deferred unlinking, however, + # on Win9x the link count remains 1 + # On NFS the link count may still be 1 but we cant know that + # we are on NFS + return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0); + + } else { + _deferred_unlink($fh, $path, 0); + return 1; + } + +} + +=back + +=head1 PACKAGE VARIABLES + +These functions control the global state of the package. + +=over 4 + +=item B + +Controls the lengths to which the module will go to check the safety of the +temporary file or directory before proceeding. +Options are: + +=over 8 + +=item STANDARD + +Do the basic security measures to ensure the directory exists and +is writable, that the umask() is fixed before opening of the file, +that temporary files are opened only if they do not already exist, and +that possible race conditions are avoided. Finally the L +function is used to remove files safely. + +=item MEDIUM + +In addition to the STANDARD security, the output directory is checked +to make sure that it is owned either by root or the user running the +program. If the directory is writable by group or by other, it is then +checked to make sure that the sticky bit is set. + +Will not work on platforms that do not support the C<-k> test +for sticky bit. + +=item HIGH + +In addition to the MEDIUM security checks, also check for the +possibility of ``chown() giveaway'' using the L +sysconf() function. If this is a possibility, each directory in the +path is checked in turn for safeness, recursively walking back to the +root directory. + +For platforms that do not support the L +C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is +assumed that ``chown() giveaway'' is possible and the recursive test +is performed. + +=back + +The level can be changed as follows: + + File::Temp->safe_level( File::Temp::HIGH ); + +The level constants are not exported by the module. + +Currently, you must be running at least perl v5.6.0 in order to +run with MEDIUM or HIGH security. This is simply because the +safety tests use functions from L that are not +available in older versions of perl. The problem is that the version +number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though +they are different versions. + +On systems that do not support the HIGH or MEDIUM safety levels +(for example Win NT or OS/2) any attempt to change the level will +be ignored. The decision to ignore rather than raise an exception +allows portable programs to be written with high security in mind +for the systems that can support this without those programs failing +on systems where the extra tests are irrelevant. + +If you really need to see whether the change has been accepted +simply examine the return value of C. + + $newlevel = File::Temp->safe_level( File::Temp::HIGH ); + die "Could not change to high security" + if $newlevel != File::Temp::HIGH; + +=cut + +{ + # protect from using the variable itself + my $LEVEL = STANDARD; + sub safe_level { + my $self = shift; + if (@_) { + my $level = shift; + if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) { + carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W; + } else { + # Dont allow this on perl 5.005 or earlier + if ($] < 5.006 && $level != STANDARD) { + # Cant do MEDIUM or HIGH checks + croak "Currently requires perl 5.006 or newer to do the safe checks"; + } + # Check that we are allowed to change level + # Silently ignore if we can not. + $LEVEL = $level if _can_do_level($level); + } + } + return $LEVEL; + } +} + +=item TopSystemUID + +This is the highest UID on the current system that refers to a root +UID. This is used to make sure that the temporary directory is +owned by a system UID (C, C, C etc) rather than +simply by root. + +This is required since on many unix systems C is not owned +by root. + +Default is to assume that any UID less than or equal to 10 is a root +UID. + + File::Temp->top_system_uid(10); + my $topid = File::Temp->top_system_uid; + +This value can be adjusted to reduce security checking if required. +The value is only relevant when C is set to MEDIUM or higher. + +=back + +=cut + +{ + my $TopSystemUID = 10; + sub top_system_uid { + my $self = shift; + if (@_) { + my $newuid = shift; + croak "top_system_uid: UIDs should be numeric" + unless $newuid =~ /^\d+$/s; + $TopSystemUID = $newuid; + } + return $TopSystemUID; + } +} + +=head1 WARNING + +For maximum security, endeavour always to avoid ever looking at, +touching, or even imputing the existence of the filename. You do not +know that that filename is connected to the same file as the handle +you have, and attempts to check this can only trigger more race +conditions. It's far more secure to use the filehandle alone and +dispense with the filename altogether. + +If you need to pass the handle to something that expects a filename +then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary +programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl +programs. You will have to clear the close-on-exec bit on that file +descriptor before passing it to another process. + + use Fcntl qw/F_SETFD F_GETFD/; + fcntl($tmpfh, F_SETFD, 0) + or die "Can't clear close-on-exec flag on temp fh: $!\n"; + +=head2 Temporary files and NFS + +Some problems are associated with using temporary files that reside +on NFS file systems and it is recommended that a local filesystem +is used whenever possible. Some of the security tests will most probably +fail when the temp file is not local. Additionally, be aware that +the performance of I/O operations over NFS will not be as good as for +a local disk. + +=head1 HISTORY + +Originally began life in May 1999 as an XS interface to the system +mkstemp() function. In March 2000, the OpenBSD mkstemp() code was +translated to Perl for total control of the code's +security checking, to ensure the presence of the function regardless of +operating system and to help with portability. + +=head1 SEE ALSO + +L, L, L, L + +See L and L for different implementations of +temporary file handling. + +=head1 AUTHOR + +Tim Jenness Et.jenness@jach.hawaii.eduE + +Copyright (C) 1999-2001 Tim Jenness and the UK Particle Physics and +Astronomy Research Council. All Rights Reserved. This program is free +software; you can redistribute it and/or modify it under the same +terms as Perl itself. + +Original Perl implementation loosely based on the OpenBSD C code for +mkstemp(). Thanks to Tom Christiansen for suggesting that this module +should be written and providing ideas for code improvements and +security enhancements. + +=cut + + +1; diff --git a/contrib/perl5/lib/Pod/LaTeX.pm b/contrib/perl5/lib/Pod/LaTeX.pm new file mode 100644 index 000000000000..c909d21f35d9 --- /dev/null +++ b/contrib/perl5/lib/Pod/LaTeX.pm @@ -0,0 +1,1591 @@ +package Pod::LaTeX; + +# Copyright (C) 2000 by Tim Jenness +# All Rights Reserved. + +=head1 NAME + +Pod::LaTeX - Convert Pod data to formatted Latex + +=head1 SYNOPSIS + + use Pod::LaTeX; + my $parser = Pod::LaTeX->new ( ); + + $parser->parse_from_filehandle; + + $parser->parse_from_file ('file.pod', 'file.tex'); + +=head1 DESCRIPTION + +C is a module to convert documentation in the Pod format +into Latex. The L|pod2latex> X command uses +this module for translation. + +C is a derived class from L. + +=cut + + +use strict; +require Pod::ParseUtils; +use base qw/ Pod::Select /; + +# use Data::Dumper; # for debugging +use Carp; + +use vars qw/ $VERSION %HTML_Escapes @LatexSections /; + +$VERSION = '0.53'; + +# Definitions of =headN -> latex mapping +@LatexSections = (qw/ + chapter + section + subsection + subsubsection + paragraph + subparagraph + /); + +# Standard escape sequences converted to Latex +# Up to "yuml" these are taken from the original pod2latex +# command written by Taro Kawagish (kawagish@imslab.co.jp) + +%HTML_Escapes = ( + 'amp' => '&', # ampersand + 'lt' => '$<$', # ' left chevron, less-than + 'gt' => '$>$', # ' right chevron, greater-than + 'quot' => '"', # double quote + 'sol' => '/', + 'verbar' => '$|$', + + "Aacute" => "\\'{A}", # capital A, acute accent + "aacute" => "\\'{a}", # small a, acute accent + "Acirc" => "\\^{A}", # capital A, circumflex accent + "acirc" => "\\^{a}", # small a, circumflex accent + "AElig" => '\\AE', # capital AE diphthong (ligature) + "aelig" => '\\ae', # small ae diphthong (ligature) + "Agrave" => "\\`{A}", # capital A, grave accent + "agrave" => "\\`{a}", # small a, grave accent + "Aring" => '\\u{A}', # capital A, ring + "aring" => '\\u{a}', # small a, ring + "Atilde" => '\\~{A}', # capital A, tilde + "atilde" => '\\~{a}', # small a, tilde + "Auml" => '\\"{A}', # capital A, dieresis or umlaut mark + "auml" => '\\"{a}', # small a, dieresis or umlaut mark + "Ccedil" => '\\c{C}', # capital C, cedilla + "ccedil" => '\\c{c}', # small c, cedilla + "Eacute" => "\\'{E}", # capital E, acute accent + "eacute" => "\\'{e}", # small e, acute accent + "Ecirc" => "\\^{E}", # capital E, circumflex accent + "ecirc" => "\\^{e}", # small e, circumflex accent + "Egrave" => "\\`{E}", # capital E, grave accent + "egrave" => "\\`{e}", # small e, grave accent + "ETH" => '\\OE', # capital Eth, Icelandic + "eth" => '\\oe', # small eth, Icelandic + "Euml" => '\\"{E}', # capital E, dieresis or umlaut mark + "euml" => '\\"{e}', # small e, dieresis or umlaut mark + "Iacute" => "\\'{I}", # capital I, acute accent + "iacute" => "\\'{i}", # small i, acute accent + "Icirc" => "\\^{I}", # capital I, circumflex accent + "icirc" => "\\^{i}", # small i, circumflex accent + "Igrave" => "\\`{I}", # capital I, grave accent + "igrave" => "\\`{i}", # small i, grave accent + "Iuml" => '\\"{I}', # capital I, dieresis or umlaut mark + "iuml" => '\\"{i}', # small i, dieresis or umlaut mark + "Ntilde" => '\\~{N}', # capital N, tilde + "ntilde" => '\\~{n}', # small n, tilde + "Oacute" => "\\'{O}", # capital O, acute accent + "oacute" => "\\'{o}", # small o, acute accent + "Ocirc" => "\\^{O}", # capital O, circumflex accent + "ocirc" => "\\^{o}", # small o, circumflex accent + "Ograve" => "\\`{O}", # capital O, grave accent + "ograve" => "\\`{o}", # small o, grave accent + "Oslash" => "\\O", # capital O, slash + "oslash" => "\\o", # small o, slash + "Otilde" => "\\~{O}", # capital O, tilde + "otilde" => "\\~{o}", # small o, tilde + "Ouml" => '\\"{O}', # capital O, dieresis or umlaut mark + "ouml" => '\\"{o}', # small o, dieresis or umlaut mark + "szlig" => '\\ss{}', # small sharp s, German (sz ligature) + "THORN" => '\\L', # capital THORN, Icelandic + "thorn" => '\\l',, # small thorn, Icelandic + "Uacute" => "\\'{U}", # capital U, acute accent + "uacute" => "\\'{u}", # small u, acute accent + "Ucirc" => "\\^{U}", # capital U, circumflex accent + "ucirc" => "\\^{u}", # small u, circumflex accent + "Ugrave" => "\\`{U}", # capital U, grave accent + "ugrave" => "\\`{u}", # small u, grave accent + "Uuml" => '\\"{U}', # capital U, dieresis or umlaut mark + "uuml" => '\\"{u}', # small u, dieresis or umlaut mark + "Yacute" => "\\'{Y}", # capital Y, acute accent + "yacute" => "\\'{y}", # small y, acute accent + "yuml" => '\\"{y}', # small y, dieresis or umlaut mark + + # Added by TimJ + + "iexcl" => '!`', # inverted exclamation mark +# "cent" => ' ', # cent sign + "pound" => '\pounds', # (UK) pound sign +# "curren" => ' ', # currency sign +# "yen" => ' ', # yen sign +# "brvbar" => ' ', # broken vertical bar + "sect" => '\S', # section sign + "uml" => '\"{}', # diaresis + "copy" => '\copyright', # Copyright symbol +# "ordf" => ' ', # feminine ordinal indicator + "laquo" => '$\ll$', # ' # left pointing double angle quotation mark + "not" => '$\neg$', # ' # not sign + "shy" => '-', # soft hyphen +# "reg" => ' ', # registered trademark + "macr" => '$^-$', # ' # macron, overline + "deg" => '$^\circ$', # ' # degree sign + "plusmn" => '$\pm$', # ' # plus-minus sign + "sup2" => '$^2$', # ' # superscript 2 + "sup3" => '$^3$', # ' # superscript 3 + "acute" => "\\'{}", # acute accent + "micro" => '$\mu$', # micro sign + "para" => '\P', # pilcrow sign = paragraph sign + "middot" => '$\cdot$', # middle dot = Georgian comma + "cedil" => '\c{}', # cedilla + "sup1" => '$^1$', # ' # superscript 1 +# "ordm" => ' ', # masculine ordinal indicator + "raquo" => '$\gg$', # ' # right pointing double angle quotation mark + "frac14" => '$\frac{1}{4}$', # ' # vulgar fraction one quarter + "frac12" => '$\frac{1}{2}$', # ' # vulgar fraction one half + "frac34" => '$\frac{3}{4}$', # ' # vulgar fraction three quarters + "iquest" => "?'", # inverted question mark + "times" => '$\times$', # ' # multiplication sign + "divide" => '$\div$', # division sign + + # Greek letters using HTML codes + "alpha" => '$\alpha$', # ' + "beta" => '$\beta$', # ' + "gamma" => '$\gamma$', # ' + "delta" => '$\delta$', # ' + "epsilon"=> '$\epsilon$', # ' + "zeta" => '$\zeta$', # ' + "eta" => '$\eta$', # ' + "theta" => '$\theta$', # ' + "iota" => '$\iota$', # ' + "kappa" => '$\kappa$', # ' + "lambda" => '$\lambda$', # ' + "mu" => '$\mu$', # ' + "nu" => '$\nu$', # ' + "xi" => '$\xi$', # ' + "omicron"=> '$o$', # ' + "pi" => '$\pi$', # ' + "rho" => '$\rho$', # ' + "sigma" => '$\sigma$', # ' + "tau" => '$\tau$', # ' + "upsilon"=> '$\upsilon$', # ' + "phi" => '$\phi$', # ' + "chi" => '$\chi$', # ' + "psi" => '$\psi$', # ' + "omega" => '$\omega$', # ' + + "Alpha" => '$A$', # ' + "Beta" => '$B$', # ' + "Gamma" => '$\Gamma$', # ' + "Delta" => '$\Delta$', # ' + "Epsilon"=> '$E$', # ' + "Zeta" => '$Z$', # ' + "Eta" => '$H$', # ' + "Theta" => '$\Theta$', # ' + "Iota" => '$I$', # ' + "Kappa" => '$K$', # ' + "Lambda" => '$\Lambda$', # ' + "Mu" => '$M$', # ' + "Nu" => '$N$', # ' + "Xi" => '$\Xi$', # ' + "Omicron"=> '$O$', # ' + "Pi" => '$\Pi$', # ' + "Rho" => '$R$', # ' + "Sigma" => '$\Sigma$', # ' + "Tau" => '$T$', # ' + "Upsilon"=> '$\Upsilon$', # ' + "Phi" => '$\Phi$', # ' + "Chi" => '$X$', # ' + "Psi" => '$\Psi$', # ' + "Omega" => '$\Omega$', # ' + + +); + + +=head1 OBJECT METHODS + +The following methods are provided in this module. Methods inherited +from C are not described in the public interface. + +=over 4 + +=begin __PRIVATE__ + +=item C + +Initialise the object. This method is subclassed from C. +The base class method is invoked. This method defines the default +behaviour of the object unless overridden by supplying arguments to +the constructor. + +Internal settings are defaulted as well as the public instance data. +Internal hash values are accessed directly (rather than through +a method) and start with an underscore. + +This method should not be invoked by the user directly. + +=end __PRIVATE__ + +=cut + + + +# - An array for nested lists + +# Arguments have already been read by this point + +sub initialize { + my $self = shift; + + # print Dumper($self); + + # Internals + $self->{_Lists} = []; # For nested lists + $self->{_suppress_all_para} = 0; # For =begin blocks + $self->{_suppress_next_para} = 0; # For =for blocks + $self->{_dont_modify_any_para}=0; # For =begin blocks + $self->{_dont_modify_next_para}=0; # For =for blocks + $self->{_CURRENT_HEAD1} = ''; # Name of current HEAD1 section + + # Options - only initialise if not already set + + # Cause the '=head1 NAME' field to be treated specially + # The contents of the NAME paragraph will be converted + # to a section title. All subsequent =head1 will be converted + # to =head2 and down. Will not affect =head1's prior to NAME + # Assumes: 'Module - purpose' format + # Also creates a purpose field + # The name is used for Labeling of the subsequent subsections + $self->{ReplaceNAMEwithSection} = 0 + unless exists $self->{ReplaceNAMEwithSection}; + $self->{AddPreamble} = 1 # make full latex document + unless exists $self->{AddPreamble}; + $self->{StartWithNewPage} = 0 # Start new page for pod section + unless exists $self->{StartWithNewPage}; + $self->{TableOfContents} = 0 # Add table of contents + unless exists $self->{TableOfContents}; # only relevent if AddPreamble=1 + $self->{AddPostamble} = 1 # Add closing latex code at end + unless exists $self->{AddPostamble}; # effectively end{document} and index + $self->{MakeIndex} = 1 # Add index (only relevant AddPostamble + unless exists $self->{MakeIndex}; # and AddPreamble) + + $self->{UniqueLabels} = 1 # Use label unique for each pod + unless exists $self->{UniqueLabels}; # either based on the filename + # or supplied + + # Control the level of =head1. default is \section + # + $self->{Head1Level} = 1 # Offset in latex sections + unless exists $self->{Head1Level}; # 0 is chapter, 2 is subsection + + # Control at which level numbering of sections is turned off + # ie subsection becomes subsection* + # The numbering is relative to the latex sectioning commands + # and is independent of Pod heading level + # default is to number \section but not \subsection + $self->{LevelNoNum} = 2 + unless exists $self->{LevelNoNum}; + + # Label to be used as prefix to all internal section names + # If not defined will attempt to derive it from the filename + # This can not happen when running parse_from_filehandle though + # hence the ability to set the label externally + # The label could then be Pod::Parser_DESCRIPTION or somesuch + + $self->{Label} = undef # label to be used as prefix + unless exists $self->{Label}; # to all internal section names + + # These allow the caller to add arbritrary latex code to + # start and end of document. AddPreamble and AddPostamble are ignored + # if these are set. + # Also MakeIndex and TableOfContents are also ignored. + $self->{UserPreamble} = undef # User supplied start (AddPreamble =1) + unless exists $self->{Label}; + $self->{UserPostamble} = undef # Use supplied end (AddPostamble=1) + unless exists $self->{Label}; + + # Run base initialize + $self->SUPER::initialize; + +} + +=back + +=head2 Data Accessors + +The following methods are provided for accessing instance data. These +methods should be used for accessing configuration parameters rather +than assuming the object is a hash. + +Default values can be supplied by using these names as keys to a hash +of arguments when using the C constructor. + +=over 4 + +=item B + +Logical to control whether a C preamble is to be written. +If true, a valid C preamble is written before the pod data is written. +This is similar to: + + \documentclass{article} + \begin{document} + +but will be more complicated if table of contents and indexing are required. +Can be used to set or retrieve the current value. + + $add = $parser->AddPreamble(); + $parser->AddPreamble(1); + +If used in conjunction with C a full latex document will +be written that could be immediately processed by C. + +=cut + +sub AddPreamble { + my $self = shift; + if (@_) { + $self->{AddPreamble} = shift; + } + return $self->{AddPreamble}; +} + +=item B + +Logical to control whether a standard C ending is written to the output +file after the document has been processed. +In its simplest form this is simply: + + \end{document} + +but can be more complicated if a index is required. +Can be used to set or retrieve the current value. + + $add = $parser->AddPostamble(); + $parser->AddPostamble(1); + +If used in conjunction with C a full latex document will +be written that could be immediately processed by C. + +=cut + +sub AddPostamble { + my $self = shift; + if (@_) { + $self->{AddPostamble} = shift; + } + return $self->{AddPostamble}; +} + +=item B + +The C sectioning level that should be used to correspond to +a pod C<=head1> directive. This can be used, for example, to turn +a C<=head1> into a C C. This should hold a number +corresponding to the required position in an array containing the +following elements: + + [0] chapter + [1] section + [2] subsection + [3] subsubsection + [4] paragraph + [5] subparagraph + +Can be used to set or retrieve the current value: + + $parser->Head1Level(2); + $sect = $parser->Head1Level; + +Setting this number too high can result in sections that may not be reproducible +in the expected way. For example, setting this to 4 would imply that C<=head3> +do not have a corresponding C section (C<=head1> would correspond to +a C). + +A check is made to ensure that the supplied value is an integer in the +range 0 to 5. + +Default is for a value of 1 (i.e. a C
). + +=cut + +sub Head1Level { + my $self = shift; + if (@_) { + my $arg = shift; + if ($arg =~ /^\d$/ && $arg <= $#LatexSections) { + $self->{Head1Level} = $arg; + } else { + carp "Head1Level supplied ($arg) must be integer in range 0 to ".$#LatexSections . "- Ignoring\n"; + } + } + return $self->{Head1Level}; +} + +=item B