From: Charles Bailey Date: Mon, 8 Jan 2001 08:53:52 +0000 (+0000) Subject: Once again syncing after too long an absence X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0e06870bf080a38cda51c06c6612359afc2334e1;p=p5sagit%2Fp5-mst-13.2.git Once again syncing after too long an absence p4raw-id: //depot/vmsperl@8367 --- diff --git a/AUTHORS b/AUTHORS index b3d240c..e3bc2af 100644 --- a/AUTHORS +++ b/AUTHORS @@ -1,138 +1,557 @@ -# Two sections: the real one and the virtual one. -# The real section has three \t+ fields: alias, name, email. -# The sections are separated by one or more empty lines. -# The virtual section (each record two \t+ separated fields) builds -# meta-aliases based on the real section. - -alan.burlison Alan Burlison Alan.Burlison@UK.Sun.com -allen Norton T. Allen allen@huarp.harvard.edu -bradapp Brad Appleton bradapp@enteract.com -cbail Charles Bailey bailey@newman.upenn.edu -dgris Daniel Grisinger dgris@dimensional.com -dmulholl Daniel Yacob dmulholl@cs.indiana.edu -dogcow Tom Spindler dogcow@merit.edu -domo Dominic Dunlop domo@computer.org -doug Doug MacEachern dougm@covalent.net -doughera Andy Dougherty doughera@lafcol.lafayette.edu -efifer Eric Fifer EFifer@sanwaint.com -francois Francois Desarmenien desar@club-internet.fr -gbarr Graham Barr gbarr@ti.com -gerben Gerben Wierda Gerben_Wierda@RnA.nl -gerti Gerd Knops gerti@BITart.com -gibreel Stephen Zander gibreel@pobox.com -gnat Nathan Torkington gnat@frii.com -gsar Gurusamy Sarathy gsar@activestate.com -hansmu Hans Mulder hansmu@xs4all.nl -hops Mike Hopkirk hops@sco.com -hugo Hugo van der Sanden hv@crypt.demon.co.uk -ilya Ilya Zakharevich ilya@math.ohio-state.edu -jbuehler Joe Buehler jbuehler@hekimian.com -jfs John Stoffel jfs@fluent.com -jhi Jarkko Hietaniemi jhi@iki.fi -jon Jon Orwant orwant@oreilly.com -jvromans Johan Vromans jvromans@squirrel.nl -k Andreas König a.koenig@mind.de -kjahds Kenneth Albanowski kjahds@kjahds.com -krishna Krishna Sethuraman krishna@sgi.com -kstar Kurt D. Starsinic kstar@chapin.edu -lane Charles Lane lane@DUPHY4.Physics.Drexel.Edu -lstein Lincoln D. Stein lstein@genome.wi.mit.edu -lutherh Luther Huffman lutherh@stratcom.com -lutz Mark P. Lutz mark.p.lutz@boeing.com -lwall Larry Wall larry@wall.org -makemaker MakeMaker list makemaker@franz.ww.tu-berlin.de -mbiggar Mark A Biggar mab@wdl.loral.com -mbligh Martin J. Bligh mbligh@sequent.com -mikestok Mike Stok mike@stok.co.uk -millert Todd Miller millert@openbsd.org -mkvale Mark Kvale kvale@phy.ucsf.edu -mjd Mark-Jason Dominus mjd@plover.com -mjtg Mike Guy mjtg@cam.ac.uk -laszlo.molnar Laszlo Molnar Laszlo.Molnar@eth.ericsson.se -mpeix Mark Bixby markb@cccd.edu -muir David Muir Sharnoff muir@idiom.com -neale Neale Ferguson neale@VMA.TABNSW.COM.AU -nik Nick Ing-Simmons nik@tiuk.ti.com -okamoto Jeff Okamoto okamoto@corp.hp.com -paul_green Paul Green Paul_Green@stratus.com -pmarquess Paul Marquess Paul.Marquess@btinternet.com -pomeranz Hal Pomeranz pomeranz@netcom.com -pudge Chris Nandor pudge@pobox.com -pueschel Norbert Pueschel pueschel@imsdd.meb.uni-bonn.de -pvhp Peter Prymmer pvhp@forte.com -raphael Raphael Manfredi Raphael.Manfredi@pobox.com -rdieter Rex Dieter rdieter@math.unl.edu -richard Richard Foley Richard.Foley@m.dasa.de -rra Russ Allbery rra@stanford.edu -rsanders Robert Sanders Robert.Sanders@linux.org -roberto Ollivier Robert roberto@keltia.freenix.fr -roderick Roderick Schertler roderick@argon.org -roehrich Dean Roehrich roehrich@cray.com -tsanders Tony Sanders sanders@bsdi.com -schinder Paul Schinder schinder@pobox.com -scotth Scott Henry scotth@sgi.com -seibert Greg Seibert seibert@Lynx.COM -simon Simon Cozens simon@brecon.co.uk -spider Spider Boardman spider@Orb.Nashua.NH.US -smccam Stephen McCamant smccam@uclink4.berkeley.edu -sthoenna Yitzchak Scott-Thoennes sthoenna@efn.org -sugalskd Dan Sugalski dan@sidhe.org -sundstrom David Sundstrom sunds@asictest.sc.ti.com -tchrist Tom Christiansen tchrist@perl.com -thomas.dorner Dorner Thomas Thomas.Dorner@start.de -tjenness Tim Jenness t.jenness@jach.hawaii.edu -timb Tim Bunce Tim.Bunce@ig.co.uk -tom.horsley Tom Horsley Tom.Horsley@mail.ccur.com -tye Tye McQueen tye@metronet.com -wayne.thompson Wayne Thompson Wayne.Thompson@Ebay.sun.com -wilfredo Wilfredo Sánchez wsanchez@apple.com - -PUMPKING jhi -aix jhi -amiga pueschel -beos dogcow -bsdos tsanders -cfg jhi -cgi lstein -complex jhi,raphael -cpan k -cxux tom.horsley -cygwin win32 -dec_osf jhi,spider -dgux roderick -doc tchrist -dos laszlo.molnar -dynix/ptx mbligh -ebcdic os390,vmesa,posix-bc -filespec kjahds -freebsd roberto -hpux okamoto,jhi -irix scotth,krishna,jfs,kstar -jpl gibreel -lexwarn pmarquess -linux kjahds,kstar -locale jhi,domo -machten domo -mm makemaker -netbsd jhi -next gerben,hansmu -openbsd millert -os2 ilya -os390 pvhp -plan9 lutherl -posix-bc thomas.dorner -powerux tom.horsley -qnx allen -regex ilya,jfriedl,hugo,mjd -sco francois,hops -solaris doughera,alan.burlison -step gerti,hansmu,rdieter -sunos4 doughera -svr4 tye -unicos jhi,lutz -uwin jbuehler -vmesa neale -vms sugalskd,cbail -vos paul_green -warn pmarquess -win32 gsar +# To give due honor to those who have made Perl 5 what is is today, +# here are easily-from-changelogs-extractable people and their +# (hopefully) current and preferred email addresses (as of late 2000 +# if known) from the Changes files. These people have either submitted +# patches or suggestions, or their bug reports or comments have inspired +# the appropriate patches. Corrections, additions, deletions welcome. +# +-- +Aaron B. Dossett +Abigail +Achim Bohnet +Adam Krolnik +Akim Demaille +Alan Burlison +Alan Champion +Alan Harder +Alan Modra +Albert Chin-A-Young +Albert Dvornik +Alexander Smishlajev +Allen Smith +Ambrose Kofi Laing +Andreas Klussmann +Andreas König +Andreas Schwab +Andrew Bettison +Andrew Cohen +Andrew M. Langmead +Andrew Pimlott +Andrew Vignaux +Andrew Wilcox +Andy Dougherty +Anno Siegel +Anthony David +Anton Berezin +Art Green +Artur +Barrie Slaymaker +Barry Friedman +Ben Tilly +Benjamin Low +Benjamin Stuhl +Benjamin Sugars +Bernard Quatermass +Bill Campbell +Bill Glicker +Billy Constantine +Blair Zajac +Boyd Gerber +Brad Appleton +Brad Howerter +Brad Hughes +Brad Lanam +Brent B. Powers +Brian Callaghan +Brian Clarke +Brian Grossman +Brian Harrison +Brian Jepson +Brian Katzung +Brian Reichert +Brian S. Cashman +Bruce Barnett +Bruce J. Keeler +Bruce P. Schuck +Bud Huff +Byron Brummer +Calle Dybedahl +Carl M. Fongheiser +Carl Witty +Cary D. Renzema +Casey R. Tweten +Castor Fu +Chaim Frenkel +Charles Bailey +Charles F. Randall +Charles Lane +Charles Wilson +Chip Salzenberg +Chris Faylor +Chris Nandor +Chris Wick +Christian Kirsch +Christopher Chan-Nui +Christopher Davis +Chuck D. Phillips +Chuck Phillips +Chunhui Teng +Clark Cooper +Clinton Pierce +Colin Kuskie +Conrad Augustin +Conrad E. Kimball +Craig A. Berry +Craig Milo Rogers +Dale Amon +Damian Conway +Damon Atkins +Dan Boorstein +Dan Carson +Dan Schmidt +Dan Sugalski +Daniel Chetlin +Daniel Grisinger +Daniel Muiño +Daniel S. Lewart +Daniel Yacob +Danny R. Faught +Danny Sadinoff +Darrell Kindred +Darrell Schiebel +Darren/Torin/Who Ever... +Dave Bianchi +Dave Hartnoll +Dave Nelson +Dave Schweisguth +David Billinghurst +David Campbell +David Couture +David Denholm +David Dyck +David F. Haertig +David Filo +David Glasser +David Hammen +David J. Fiander +David Kerry +David Muir Sharnoff +David R. Favor +David Sparks +David Starks-Browning +David Sundstrom +Davin Milun +Dean Roehrich +Dennis Marsa +dive +Dominic Dunlop +Dominique Dumont +Doug Campbell +Doug MacEachern +Douglas E. Wegscheid +Douglas Lankshear +Dov Grobgeld +Drago Goricanec +Ed Mooring +Ed Peschko +Elaine -HFB- Ashton +Eric Arnold +Eric Bartley +Eric E. Coe +Eric Fifer +Erich Rickheit +Eryq +Etienne Grossman +Eugene Alterman +Fabien Tassin +Felix Gallo +Florent Guillaume +Frank Crawford +Frank Ridderbusch +Frank Tobin +François Désarménien +Fréderic Chauveau +G. Del Merritt +Gabe Schaffer +Gary Clark +Gary Ng <71564.1743@compuserve.com> +Gerben Wierda +Gerd Knops +Giles Lean +Gisle Aas +Gordon J. Miller +Grace Lee +Graham Barr +Graham TerMarsch +Greg Bacon +Greg Chapman +Greg Earle +Greg Kuperberg +Greg Seibert +Greg Ward +Gregory Martin Pfeil +Guenter Schmidt +Guido Flohr +Gurusamy Sarathy +Gustaf Neumann +Guy Decoux +H.J. Lu +H.Merijn Brand +Hal Pomeranz +Hallvard B Furuseth +Hannu Napari +Hans Mulder +Hans de Graaff +Harold O Morris +Harry Edmon +Helmut Jarausch +Henrik Tougaard +Hershel Walters +Holger Bechtold +Horst von Brand +Hubert Feyrer +Hugo van der Sanden +Hunter Kelly +Huw Rogers +Ian Maloney +Ian Phillipps +Ignasi Roca +Ilya Sandler +Ilya Zakharevich +Inaba Hiroto +Irving Reid +J. David Blackstone +J. van Krieken +JD Laub +JT McDuffie +Jack Shirazi +Jacqui Caren +Jake Hamby +James FitzGibbon +Jamshid Afshar +Jan D. +Jan Dubois +Jan Pazdziora +Jan-Erik Karlsson +Jan-Pieter Cornet +Jared Rhine +Jarkko Hietaniemi +Jason A. Smith +Jason Shirk +Jason Stewart +Jason Varsoke +Jay Rogers +Jeff Bouis +Jeff McDougal +Jeff Okamoto +Jeff Pinyan +Jeff Urlwin +Jeffrey Friedl +Jeffrey S. Haemer +Jens Hamisch +Jens T. Berger Thielemann +Jens Thomsen +Jens-Uwe Mager +Jeremy D. Zawodny +Jerome Abela +Jim Anderson +Jim Avera +Jim Balter +Jim Meyering +Jim Miner +Jim Richardson +Joachim Huober +Jochen Wiedmann +Joe Buehler +Joe Smith +Joel Rosi-Schwartz +Joerg Porath +Joergen Haegg +Johan Holtman +Johan Vromans +Johann Klasek +John Bley +John Borwick +John Cerney +John D Groenveld +John Hasstedt +John Hughes +John L. Allen +John Macdonald +John Nolan +John Peacock +John Pfuntner +John Rowe +John Salinas +John Stoffel +John Tobey +Jon Orwant +Jonathan Biggar +Jonathan D Johnston +Jonathan Fine +Jonathan I. Kamens +Jonathan Roy +Joseph N. Hall +Joseph S. Myers +Joshua Pritikin +Juan Gallego +Julian Yip +Justin Banks +Ka-Ping Yee +Karl Glazebrook +Karl Heuer +Karl Simon Berg +Karsten Sperling +Kaveh Ghazi +Keith Neufeld +Keith Thompson +Ken Estes +Ken Fox +Ken MacLeod +Ken Shan +Kenneth Albanowski +Kenneth Duda +Keong Lim +Kevin O'Gorman +Kevin White +Kim Frutiger +Kragen Sitaker +Krishna Sethuraman +Kurt D. Starsinic +Kyriakos Georgiou +Larry Parmelee +Larry Schuler +Larry Schwimmer +Larry W. Virden +Larry Wall +Lars Hecking +Laszlo Molnar +Len Johnson +Les Peters +Lincoln D. Stein +Lionel Cons +Luca Fini +Lupe Christoph +Luther Huffman +M. J. T. Guy +Major Sébastien +Makoto MATSUSHITA +Malcolm Beattie +Marc Lehmann +Marc Paquette +Marcel Grunauer +Mark A Biggar +Mark Bixby +Mark Dickinson +Mark Hanson +Mark K Trettin +Mark Kaehny +Mark Kettenis +Mark Klein +Mark Knutsen +Mark Kvale +Mark Leighton Fisher +Mark Murray +Mark P. Lutz +Mark Pease +Mark Pizzolato +Mark R. Levinson +Mark-Jason Dominus +Martijn Koster +Martin J. Bligh +Martin Jost +Martin Lichtin +Martin Plechsmid +Marty Lucich +Martyn Pearce +Masahiro KAJIURA +Mathias Koerber +Matt Kimball +Matthew Black +Matthew Green +Matthew T Harden +Matthias Ulrich Neeracher +Matthias Urlichs +Maurizio Loreti +Michael Cook +Michael De La Rue +Michael Engel +Michael G Schwern +Michael H. Moran +Michael Mahan +Michael Stevens +Michele Sardo +Mik Firestone +Mike Fletcher +Mike Hopkirk +Mike Rogers +Mike Stok +Mike W Ellwood +Milton Hankins +Milton L. Hankins +Molnar Laszlo +Murray Nesbitt +Nathan Kurz +Nathan Torkington +Neale Ferguson +Neil Bowers +Nicholas Clark +Nick Duffek +Nick Gianniotis +Nick Ing-Simmons +Norbert Pueschel +Norton T. Allen +Olaf Flebbe +Olaf Titz +Ollivier Robert +Owen Taylor +Patrick Hayes +Patrick O'Brien +Paul A Sand +Paul David Fardy +Paul Green +Paul Hoffman +Paul Holser +Paul Johnson +Paul Marquess +Paul Moore +Paul Rogers +Paul Saab +Paul Schinder +Pete Peterson +Peter Chines +Peter Gordon +Peter Haworth +Peter J. Farley III +Peter Jaspers-Fayer +Peter Prymmer +Peter Scott +Peter Wolfe +Peter van Heusden +Petter Reinholdtsen +Phil Lobbes +Philip Hazel +Philip Newton +Piers Cawley +Piotr Klaban +Prymmer/Kahn +Quentin Fennessy +Radu Greab +Ralf S. Engelschall +Randal L. Schwartz +Randy J. Ray +Raphael Manfredi +Raymund Will +Rex Dieter +Rich Morin +Rich Salz +Richard A. Wells +Richard Foley +Richard L. England +Richard L. Maus, Jr. +Richard Soderberg +Richard Yeh +Rick Delaney +Rick Pluta +Rickard Westman +Rob Henderson +Robert Partington +Robert Sanders +Robert Spier +Robin Barker +Robin Houston +Rocco Caputo +Roderick Schertler +Rodger Anderson +Ronald F. Guilmette +Ronald J. Kimball +Ruben Schattevoy +Rujith S. de Silva +Russ Allbery +Russell Fulton +Russell Mosemann +Ryan Herbert +SAKAI Kiyotaka +Samuli Kärkkäinen +Scott Gifford +Scott Henry +Sean Robinson +Sean Sheedy +Sebastien Barre +Shigeya Suzuki +Shimpei Yamashita +Shishir Gundavaram +Simon Cozens +Simon Leinen +Simon Parsons +Slaven Rezic +Spider Boardman +Stephane Payrard +Stephanie Beals +Stephen McCamant +Stephen O. Lidie +Stephen P. Potter +Stephen Zander +Steve A Fink +Steve Kelem +Steve McDougall +Steve Nielsen +Steve Pearlmutter +Steve Vinoski +Steven Hirsch +Steven Knight +Steven Morlock +Steven N. Hirsch +Steven Parkes +Sven Verdoolaege +SynaptiCAD, Inc. +Taro KAWAGISHI +Ted Ashton +Ted Law +Teun Burgers +Thad Floryan +Thomas Bowditch +Thomas Conté +Thomas Dorner +Thomas Kofler +Thomas König +Tim Adye +Tim Ayers +Tim Bunce +Tim Conrow +Tim Freeman +Tim Jenness +Tim Mooney +Tim Witham +Timur I. Bakeyev +Tkil +Todd C. Miller +Tom Bates +Tom Christiansen +Tom Horsley +Tom Hughes +Tom Phoenix +Tom Spindler +Tony Camas +Tony Cook +Tony Sanders +Tor Lillqvist +Trevor Blackwell +Tuomas J. Lukka +Tye McQueen +Ulrich Kunitz +Ulrich Pfeifer +Vadim Konovalov +Valeriy E. Ushakov +Vishal Bhatia +Vlad Harchev +Vladimir Alexiev +W. Phillip Moore +Warren Hyde +Warren Jones +Wayne Berke +Wayne Scott +Wayne Thompson +Wilfredo Sánchez +William J. Middleton +William Mann +William R Ward +William Setzer +Winfried König +Wolfgang Laun +Yary Hluchan +Yasushi Nakajima +Yitzchak Scott-Thoennes +Yutaka OIWA +Yutao Feng +Zachary Miller diff --git a/Changes5.6 b/Changes5.6 index 3dc17bc..47adbff 100644 --- a/Changes5.6 +++ b/Changes5.6 @@ -13319,7 +13319,7 @@ ____________________________________________________________________________ [ 3914] By: jhi on 1999/08/03 21:11:11 Log: The op/filetest.t failed subtest 7 if testing as root. - From: =?iso-8859-1?Q?Fran=E7ois=20D=E9sarm=E9nien?= + From: François Désarménien To: perl5-porters@perl.org Subject: [ID 19990727.039] Not OK: perl 5.00558 on i386-sco 3.2v5.0.4 Date: Tue, 27 Jul 1999 22:54:05 +0200 diff --git a/Configure b/Configure index 03004be..023df36 100755 --- a/Configure +++ b/Configure @@ -20,10 +20,10 @@ # $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $ # -# Generated on Thu Oct 19 22:28:50 EET DST 2000 [metaconfig 3.0 PL70] +# Generated on Fri Jan 5 20:11:52 EET 2001 [metaconfig 3.0 PL70] # (with additional metaconfig patches by perlbug@perl.org) -cat >/tmp/c1$$ <c1$$ </tmp/c2$$ <c2$$ </dev/null 2>&1`; then echo "Using the test built into your sh." + echo "Using the test built into your sh." test=test _test=test fi @@ -2159,6 +2171,93 @@ else fi $rm -f blurfl sym +: determine whether symbolic links are supported +echo " " +case "$lns" in +*"ln -s") + echo "Checking how to test for symbolic links..." >&4 + $lns blurfl sym + if $test "X$issymlink" = X; then + sh -c "PATH= test -h sym" >/dev/null 2>&1 + if test $? = 0; then + issymlink="test -h" + fi + fi + if $test "X$issymlink" = X; then + if $test -h >/dev/null 2>&1; then + issymlink="$test -h" + echo "Your builtin 'test -h' may be broken, I'm using external '$test -h'." >&4 + fi + fi + if $test "X$issymlink" = X; then + if $test -L sym 2>/dev/null; then + issymlink="$test -L" + fi + fi + if $test "X$issymlink" != X; then + echo "You can test for symbolic links with '$issymlink'." >&4 + else + echo "I do not know how you can test for symbolic links." >&4 + fi + $rm -f blurfl sym + ;; +*) echo "No symbolic links, so not testing for their testing..." >&4 + ;; +esac +echo " " + + +case "$mksymlinks" in +$define|true|[yY]*) + case "$src" in + ''|'.') echo "Cannot create symlinks in the original directory." >&4 + exit 1 + ;; + *) case "$lns:$issymlink" in + *"ln -s:"*"test -"?) + echo "Creating the symbolic links..." >&4 + echo "(First creating the subdirectories...)" >&4 + cd .. + awk '{print $1}' $src/MANIFEST | grep / | sed 's:/[^/]*$::' | sort -u | while true; do + read directory + test -z "$directory" && break + mkdir -p $directory + done + # Sanity check 1. + if test ! -d t/base; then + echo "Failed to create the subdirectories. Aborting." >&4 + exit 1 + fi + echo "(Then creating the symlinks...)" >&4 + awk '{print $1}' $src/MANIFEST | while true; do + read filename + test -z "$filename" && break + if test -f $filename; then + if $issymlink $filename; then + rm -f $filename + fi + fi + if test -f $filename; then + echo "$filename already exists, not symlinking." + else + ln -s $src/$filename $filename + fi + done + # Sanity check 2. + if test ! -f t/base/commonsense.t; then + echo "Failed to create the symlinks. Aborting." >&4 + exit 1 + fi + cd UU + ;; + *) echo "(I cannot figure out how to do symbolic links, ignoring mksymlinks)." >&4 + ;; + esac + ;; + esac + ;; +esac + : see whether [:lower:] and [:upper:] are supported character classes echo " " case "`echo AbyZ | $tr '[:lower:]' '[:upper:]' 2>/dev/null`" in @@ -2261,7 +2360,10 @@ if test -f config.sh; then rp="I see a config.sh file. Shall I use it to set the defaults?" . UU/myread case "$ans" in - n*|N*) echo "OK, I'll ignore it."; mv config.sh config.sh.old;; + n*|N*) echo "OK, I'll ignore it." + mv config.sh config.sh.old + myuname="$newmyuname" + ;; *) echo "Fetching default answers from your old config.sh file..." >&4 tmp_n="$n" tmp_c="$c" @@ -2426,7 +2528,7 @@ EOM esac ;; next*) osname=next ;; - NonStop-UX) osname=nonstopux ;; + nonstop-ux) osname=nonstopux ;; POSIX-BC | posix-bc ) osname=posix-bc osvers="$3" ;; @@ -2672,7 +2774,6 @@ cd UU ;; esac test "$override" && . ./optdef.sh -myuname="$newmyuname" : Restore computed paths for file in $loclist $trylist; do @@ -2906,7 +3007,7 @@ if test -f /osf_boot || $contains 'OSF/1' /usr/include/ctype.h >/dev/null 2>&1 then echo "Looks kind of like an OSF/1 system, but we'll see..." echo exit 0 >osf1 -elif test `echo abc | tr a-z A-Z` = Abc ; then +elif test `echo abc | $tr a-z A-Z` = Abc ; then xxx=`./loc addbib blurfl $pth` if $test -f $xxx; then echo "Looks kind of like a USG system with BSD features, but we'll see..." @@ -3286,7 +3387,7 @@ esac case "$fn" in *\(*) - expr $fn : '.*(\(.*\)).*' | tr ',' $trnl >getfile.ok + expr $fn : '.*(\(.*\)).*' | $tr ',' $trnl >getfile.ok fn=`echo $fn | sed 's/(.*)//'` ;; esac @@ -3663,7 +3764,8 @@ esac cat <&4 @@ -4041,8 +4147,8 @@ and I got the following output: EOM dflt=y -if sh -c "$cc -o try $optimize $ccflags $ldflags try.c $libs" >>try.msg 2>&1; then - if sh -c './try' >>try.msg 2>&1; then +if $sh -c "$cc -o try $optimize $ccflags $ldflags try.c $libs" >>try.msg 2>&1; then + if $sh -c './try' >>try.msg 2>&1; then xxx=`./try` case "$xxx" in "Ok") dflt=n ;; @@ -4739,7 +4845,7 @@ unknown) s/0*\([0-9][0-9][0-9][0-9][0-9]\)/\1/g G s/\n/ /' | \ - sort | $sed -e 's/^.* //'` + $sort | $sed -e 's/^.* //'` eval set \$$# done $test -r $1 || set /usr/ccs/lib/libc.$so @@ -4799,7 +4905,7 @@ compiler, or your machine supports multiple models), you can override it here. EOM else dflt='' - echo $libpth | tr ' ' $trnl | sort | uniq > libpath + echo $libpth | $tr ' ' $trnl | $sort | $uniq > libpath cat >&4 < libnames +echo $libc $libnames | $tr ' ' $trnl | $sort | $uniq > libnames set X `cat libnames` shift xxx=files @@ -7266,6 +7372,25 @@ rp='Perl administrator e-mail address' . ./myread perladmin="$ans" +: determine whether to only install version-specific parts. +echo " " +$cat <. Versions 5.003_02 and later of perl allow alternate IO -mechanisms via a "PerlIO" abstraction, but the stdio mechanism is still -the default. This abstraction layer can use AT&T's sfio (if you already -have sfio installed) or regular stdio. Using PerlIO with sfio may cause -problems with some extension modules. Using PerlIO with stdio is safe, -but it is slower than plain stdio and therefore is not the default. +Previous version of $package used the standard IO mechanisms as +defined in . Versions 5.003_02 and later of perl allow +alternate IO mechanisms via the PerlIO abstraction layer, but the +stdio mechanism is still the default. This abstraction layer can +use AT&T's sfio (if you already have sfio installed) or regular stdio. +Using PerlIO with sfio may cause problems with some extension modules. If this doesn't make any sense to you, just accept the default '$dflt'. EOM @@ -7413,13 +7540,29 @@ y|Y) val="$define" ;; *) - echo "Ok, doing things the stdio way" + echo "Ok, doing things the stdio way." val="$undef" ;; esac set useperlio eval $setvar +case "$usesocks" in +$define|true|[yY]*) + case "$useperlio" in + $define|true|[yY]*) ;; + *) cat >&4 <try.c <<'EOCP' +#include +#include +#include +int main() { +#if defined(F_SETLK) && defined(F_SETLKW) + struct flock flock; + int retval, fd; + fd = open("try.c", O_RDONLY); + flock.l_type = F_RDLCK; + flock.l_whence = SEEK_SET; + flock.l_start = flock.l_len = 0; + retval = fcntl(fd, F_SETLK, &flock); + close(fd); + (retval < 0 ? exit(2) : exit(0)); +#else + exit(2); +#endif +} +EOCP +echo "Checking if fcntl-based file locking works... " +case "$d_fcntl" in +"$define") + set try + if eval $compile_ok; then + if ./try; then + echo "Yes, it seems to work." + val="$define" + else + echo "Nope, it didn't work." + val="$undef" + fi + else + echo "I'm unable to compile the test program, so I'll assume not." + val="$undef" + fi + ;; +*) val="$undef"; + echo "Nope, since you don't even have fcntl()." + ;; +esac +set d_fcntl_can_lock +eval $setvar +$rm -f try* + + hasfield='varname=$1; struct=$2; field=$3; shift; shift; shift; while $test $# -ge 2; do case "$1" in @@ -9219,6 +9395,10 @@ set fstatvfs d_fstatvfs eval $inlibc +: see if fsync exists +set fsync d_fsync +eval $inlibc + : see if ftello exists set ftello d_ftello eval $inlibc @@ -9378,6 +9558,10 @@ echo " " set d_getnetprotos getnetent $i_netdb netdb.h eval $hasproto +: see if getpagesize exists +set getpagesize d_getpagsz +eval $inlibc + : see if getprotobyname exists set getprotobyname d_getpbyname @@ -10040,6 +10224,37 @@ rp="What is the size of a character (in bytes)?" charsize="$ans" $rm -f try.c try +: check for volatile keyword +echo " " +echo 'Checking to see if your C compiler knows about "volatile"...' >&4 +$cat >try.c <<'EOCP' +int main() +{ + typedef struct _goo_struct goo_struct; + goo_struct * volatile goo = ((goo_struct *)0); + struct _goo_struct { + long long_int; + int reg_int; + char char_var; + }; + typedef unsigned short foo_t; + char *volatile foo; + volatile int bar; + volatile foo_t blech; + foo = foo; +} +EOCP +if $cc -c $ccflags try.c >/dev/null 2>&1 ; then + val="$define" + echo "Yup, it does." +else + val="$undef" + echo "Nope, it doesn't." +fi +set d_volatile +eval $setvar +$rm -f try.* + echo " " $echo "Choosing the C types to be used for Perl's internal types..." >&4 @@ -10218,67 +10433,68 @@ case "$i64type" in ;; esac -$echo "Checking whether your NVs can preserve your UVs..." >&4 +$echo "Checking how many bits of your UVs your NVs can preserve..." >&4 +: volatile so that the compiler has to store it out to memory. +if test X"$d_volatile" = X"$define"; then + volatile=volatile +fi $cat <try.c #include -int main() { - $uvtype k = ($uvtype)~0, l; - $nvtype d; - l = k; - d = ($nvtype)l; - l = ($uvtype)d; - if (l == k) - printf("preserve\n"); - exit(0); -} -EOP -set try -if eval $compile; then - case "`./try$exe_ext`" in - preserve) d_nv_preserves_uv="$define" ;; - esac -fi -case "$d_nv_preserves_uv" in -$define) $echo "Yes, they can." 2>&1 ;; -*) $echo "No, they can't." 2>&1 - d_nv_preserves_uv="$undef" - ;; -esac - -$rm -f try.* try - -case "$d_nv_preserves_uv" in -"$define") d_nv_preserves_uv_bits=`expr $uvsize \* 8` ;; -*) $echo "Checking how many bits of your UVs your NVs can preserve..." >&4 - $cat <try.c -#include +#include +#include +#ifdef SIGFPE +$volatile int bletched = 0; +$signal_t blech(s) int s; { bletched = 1; } +#endif int main() { $uvtype u = 0; + $nvtype d; int n = 8 * $uvsize; int i; +#ifdef SIGFPE + signal(SIGFPE, blech); +#endif + for (i = 0; i < n; i++) { u = u << 1 | ($uvtype)1; - if (($uvtype)($nvtype)u != u) + d = ($nvtype)u; + if (($uvtype)d != u) + break; + if (d <= 0) + break; + d = ($nvtype)(u - 1); + if (($uvtype)d != (u - 1)) break; +#ifdef SIGFPE + if (bletched) { + break; +#endif + } } - printf("%d\n", i); + printf("%d\n", ((i == n) ? -n : i)); exit(0); } EOP - set try - if eval $compile; then - d_nv_preserves_uv_bits="`./try$exe_ext`" - fi - case "$d_nv_preserves_uv_bits" in - [1-9]*) $echo "Your NVs can preserve $d_nv_preserves_uv_bits bits of your UVs." 2>&1 ;; - *) $echo "Can't figure out how many bits your NVs preserve." 2>&1 - d_nv_preserves_uv_bits="$undef" - ;; - esac - $rm -f try.* try +set try + +d_nv_preserves_uv="$undef" +if eval $compile; then + d_nv_preserves_uv_bits="`./try$exe_ext`" +fi +case "$d_nv_preserves_uv_bits" in +\-[1-9]*) + d_nv_preserves_uv_bits=`expr 0 - $d_nv_preserves_uv_bits` + $echo "Your NVs can preserve all $d_nv_preserves_uv_bits bits of your UVs." 2>&1 + d_nv_preserves_uv="$define" ;; +[1-9]*) $echo "Your NVs can preserve only $d_nv_preserves_uv_bits bits of your UVs." 2>&1 + d_nv_preserves_uv="$undef" ;; +*) $echo "Can't figure out how many bits your NVs preserve." 2>&1 + d_nv_preserves_uv_bits="$undef" ;; esac +$rm -f try.* try + : check for off64_t echo " " @@ -10792,6 +11008,11 @@ $rm -f try.* try core set d_sanemcmp eval $setvar +: see if prototype for sbrk is available +echo " " +set d_sbrkproto sbrk $i_unistd unistd.h +eval $hasproto + : see if select exists set select d_select eval $inlibc @@ -11390,7 +11611,28 @@ esac : see if _ptr and _cnt from stdio act std echo " " -if $contains '_IO_fpos_t' `./findhdr stdio.h` `./findhdr libio.h` >/dev/null 2>&1 ; then + +if $contains '_lbfsize' `./findhdr stdio.h` >/dev/null 2>&1 ; then + echo "(Looks like you have stdio.h from BSD.)" + case "$stdio_ptr" in + '') stdio_ptr='((fp)->_p)' + ptr_lval=$define + ;; + *) ptr_lval=$d_stdio_ptr_lval;; + esac + case "$stdio_cnt" in + '') stdio_cnt='((fp)->_r)' + cnt_lval=$define + ;; + *) cnt_lval=$d_stdio_cnt_lval;; + esac + case "$stdio_base" in + '') stdio_base='((fp)->_ub._base ? (fp)->_ub._base : (fp)->_bf._base)';; + esac + case "$stdio_bufsiz" in + '') stdio_bufsiz='((fp)->_ub._base ? (fp)->_ub._size : (fp)->_bf._size)';; + esac +elif $contains '_IO_fpos_t' `./findhdr stdio.h` `./findhdr libio.h` >/dev/null 2>&1 ; then echo "(Looks like you have stdio.h from Linux.)" case "$stdio_ptr" in '') stdio_ptr='((fp)->_IO_read_ptr)' @@ -11430,6 +11672,7 @@ else '') stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)';; esac fi + : test whether _ptr and _cnt really work echo "Checking how std your stdio is..." >&4 $cat >try.c <&4 +$cat >try.c < +/* Can we scream? */ +/* Eat dust sed :-) */ +/* In the buffer space, no one can hear you scream. */ +#define FILE_ptr(fp) $stdio_ptr +#define FILE_cnt(fp) $stdio_cnt +#include +int main() { + FILE *fp = fopen("try.c", "r"); + int c; + char *ptr; + size_t cnt; + if (!fp) { + puts("Fail even to read"); + exit(1); + } + c = getc(fp); /* Read away the first # */ + if (c == EOF) { + puts("Fail even to read"); + exit(1); + } + if (!( + 18 <= FILE_cnt(fp) && + strncmp(FILE_ptr(fp), "include \n", 18) == 0 + )) { + puts("Fail even to read"); + exit (1); + } + ptr = (char*) FILE_ptr(fp); + cnt = (size_t)FILE_cnt(fp); + + FILE_ptr(fp) += 42; + + if ((char*)FILE_ptr(fp) != (ptr + 42)) { + printf("Fail ptr check %p != %p", FILE_ptr(fp), (ptr + 42)); + exit (1); + } + if (FILE_cnt(fp) <= 20) { + printf ("Fail (<20 chars to test)"); + exit (1); + } + if (strncmp(FILE_ptr(fp), "Eat dust sed :-) */\n", 20) != 0) { + puts("Fail compare"); + exit (1); + } + if (cnt == FILE_cnt(fp)) { + puts("Pass_unchanged"); + exit (0); + } + if (FILE_cnt(fp) == (cnt - 42)) { + puts("Pass_changed"); + exit (0); + } + printf("Fail count was %d now %d\n", cnt, FILE_cnt(fp)); + return 1; + +} +EOP + set try + if eval $compile; then + case `./try$exe_ext` in + Pass_changed) + echo "Increasing ptr in your stdio decreases cnt by the same amount. Good." >&4 + d_stdio_ptr_lval_sets_cnt="$define" ;; + Pass_unchanged) + echo "Increasing ptr in your stdio leaves cnt unchanged. Good." >&4 + d_stdio_ptr_lval_nochange_cnt="$define" ;; + Fail*) + echo "Increasing ptr in your stdio didn't do exactly what I expected. We'll not be doing that then." >&4 ;; + *) + echo "It appears attempting to set ptr in your stdio is a bad plan." >&4 ;; + esac + else + echo "It seems we can't set ptr in your stdio. Nevermind." >&4 + fi + $rm -f try.c try + ;; +esac + : see if _base is also standard val="$undef" case "$d_stdstdio" in @@ -11688,26 +12018,103 @@ EOM ;; esac -: see if strtoul exists -set strtoul d_strtoul +: see if strtoq exists +set strtoq d_strtoq eval $inlibc -: see if strtoull exists -set strtoull d_strtoull +: see if strtoul exists +set strtoul d_strtoul eval $inlibc -case "$d_longlong-$d_strtoull" in -"$define-$define") +case "$d_strtoul" in +"$define") $cat <try.c <<'EOCP' #include -#ifdef __hpux -#define strtoull __strtoull -#endif #include -extern unsigned long long int strtoull(char *s, char **, int); +extern unsigned long int strtoul(char *s, char **, int); +static int bad = 0; +void check(char *s, unsigned long eul, int een) { + unsigned long gul; + errno = 0; + gul = strtoul(s, 0, 10); + if (!((gul == eul) && (errno == een))) + bad++; +} +int main() { + check(" 1", 1L, 0); + check(" 0", 0L, 0); +EOCP + case "$longsize" in + 8) + $cat >>try.c <<'EOCP' + check("18446744073709551615", 18446744073709551615UL, 0); + check("18446744073709551616", 18446744073709551615UL, ERANGE); +#if 0 /* strtoul() for /^-/ strings is undefined. */ + check("-1", 18446744073709551615UL, 0); + check("-18446744073709551614", 2, 0); + check("-18446744073709551615", 1, 0); + check("-18446744073709551616", 18446744073709551615UL, ERANGE); + check("-18446744073709551617", 18446744073709551615UL, ERANGE); +#endif +EOCP + ;; + 4) + $cat >>try.c <<'EOCP' + check("4294967295", 4294967295UL, 0); + check("4294967296", 4294967295UL, ERANGE); +#if 0 /* strtoul() for /^-/ strings is undefined. */ + check("-1", 4294967295UL, 0); + check("-4294967294", 2, 0); + check("-4294967295", 1, 0); + check("-4294967296", 4294967295UL, ERANGE); + check("-4294967297", 4294967295UL, ERANGE); +#endif +EOCP + ;; + *) +: Should we write these tests to be more portable by sprintf-ing +: ~0 and then manipulating that char string as input for strtol? + ;; + esac + $cat >>try.c <<'EOCP' + if (!bad) + printf("ok\n"); + return 0; +} +EOCP + set try + if eval $compile; then + case "`./try`" in + ok) echo "Your strtoul() seems to be working okay." ;; + *) cat <&4 +Your strtoul() doesn't seem to be working okay. +EOM + d_strtoul="$undef" + ;; + esac + fi + ;; +esac + +: see if strtoull exists +set strtoull d_strtoull +eval $inlibc + +case "$d_longlong-$d_strtoull" in +"$define-$define") + $cat <try.c <<'EOCP' +#include +#ifdef __hpux +#define strtoull __strtoull +#endif +#include +extern unsigned long long int strtoull(char *s, char **, int); static int bad = 0; int check(char *s, long long eull, int een) { long long gull; @@ -11717,10 +12124,17 @@ int check(char *s, long long eull, int een) { bad++; } int main() { - check(" 1", 1LL, 0); - check(" 0", 0LL, 0); - check("18446744073709551615", 18446744073709551615ULL, 0); - check("18446744073709551616", 18446744073709551615ULL, ERANGE); + check(" 1", 1LL, 0); + check(" 0", 0LL, 0); + check("18446744073709551615", 18446744073709551615ULL, 0); + check("18446744073709551616", 18446744073709551615ULL, ERANGE); +#if 0 /* strtoull() for /^-/ strings is undefined. */ + check("-1", 18446744073709551615ULL, 0); + check("-18446744073709551614", 2LL, 0); + check("-18446744073709551615", 1LL, 0); + check("-18446744073709551616", 18446744073709551615ULL, ERANGE); + check("-18446744073709551617", 18446744073709551615ULL, ERANGE); +#endif if (!bad) printf("ok\n"); } @@ -11743,6 +12157,54 @@ esac set strtouq d_strtouq eval $inlibc +case "$d_strtouq" in +"$define") + $cat <try.c <<'EOCP' +#include +#include +extern unsigned long long int strtouq(char *s, char **, int); +static int bad = 0; +void check(char *s, unsigned long long eull, int een) { + unsigned long long gull; + errno = 0; + gull = strtouq(s, 0, 10); + if (!((gull == eull) && (errno == een))) + bad++; +} +int main() { + check(" 1", 1LL, 0); + check(" 0", 0LL, 0); + check("18446744073709551615", 18446744073709551615ULL, 0); + check("18446744073709551616", 18446744073709551615ULL, ERANGE); +#if 0 /* strtouq() for /^-/ strings is undefined. */ + check("-1", 18446744073709551615ULL, 0); + check("-18446744073709551614", 2LL, 0); + check("-18446744073709551615", 1LL, 0); + check("-18446744073709551616", 18446744073709551615ULL, ERANGE); + check("-18446744073709551617", 18446744073709551615ULL, ERANGE); +#endif + if (!bad) + printf("ok\n"); + return 0; +} +EOCP + set try + if eval $compile; then + case "`./try`" in + ok) echo "Your strtouq() seems to be working okay." ;; + *) cat <&4 +Your strtouq() doesn't seem to be working okay. +EOM + d_strtouq="$undef" + ;; + esac + fi + ;; +esac + : see if strxfrm exists set strxfrm d_strxfrm eval $inlibc @@ -11934,37 +12396,6 @@ esac set d_void_closedir eval $setvar $rm -f closedir* -: check for volatile keyword -echo " " -echo 'Checking to see if your C compiler knows about "volatile"...' >&4 -$cat >try.c <<'EOCP' -int main() -{ - typedef struct _goo_struct goo_struct; - goo_struct * volatile goo = ((goo_struct *)0); - struct _goo_struct { - long long_int; - int reg_int; - char char_var; - }; - typedef unsigned short foo_t; - char *volatile foo; - volatile int bar; - volatile foo_t blech; - foo = foo; -} -EOCP -if $cc -c $ccflags try.c >/dev/null 2>&1 ; then - val="$define" - echo "Yup, it does." -else - val="$undef" - echo "Nope, it doesn't." -fi -set d_volatile -eval $setvar -$rm -f try.* - : see if there is a wait4 set wait4 d_wait4 eval $inlibc @@ -13274,6 +13705,168 @@ rp="What is the type used for file modes for system calls (e.g. fchmod())?" set mode_t modetype int stdio.h sys/types.h eval $typedef_ask +: see if stdarg is available +echo " " +if $test `./findhdr stdarg.h`; then + echo " found." >&4 + valstd="$define" +else + echo " NOT found." >&4 + valstd="$undef" +fi + +: see if varags is available +echo " " +if $test `./findhdr varargs.h`; then + echo " found." >&4 +else + echo " NOT found, but that's ok (I hope)." >&4 +fi + +: set up the varargs testing programs +$cat > varargs.c < +#endif +#ifdef I_VARARGS +#include +#endif + +#ifdef I_STDARG +int f(char *p, ...) +#else +int f(va_alist) +va_dcl +#endif +{ + va_list ap; +#ifndef I_STDARG + char *p; +#endif +#ifdef I_STDARG + va_start(ap,p); +#else + va_start(ap); + p = va_arg(ap, char *); +#endif + va_end(ap); +} +EOP +$cat > varargs </dev/null 2>&1; then + echo "true" +else + echo "false" +fi +$rm -f varargs$_o +EOP +chmod +x varargs + +: now check which varargs header should be included +echo " " +i_varhdr='' +case "$valstd" in +"$define") + if `./varargs I_STDARG`; then + val='stdarg.h' + elif `./varargs I_VARARGS`; then + val='varargs.h' + fi + ;; +*) + if `./varargs I_VARARGS`; then + val='varargs.h' + fi + ;; +esac +case "$val" in +'') +echo "I could not find the definition for va_dcl... You have problems..." >&4 + val="$undef"; set i_stdarg; eval $setvar + val="$undef"; set i_varargs; eval $setvar + ;; +*) + set i_varhdr + eval $setvar + case "$i_varhdr" in + stdarg.h) + val="$define"; set i_stdarg; eval $setvar + val="$undef"; set i_varargs; eval $setvar + ;; + varargs.h) + val="$undef"; set i_stdarg; eval $setvar + val="$define"; set i_varargs; eval $setvar + ;; + esac + echo "We'll include <$i_varhdr> to get va_dcl definition." >&4;; +esac +$rm -f varargs* + +: see if we need va_copy +echo " " +case "$i_stdarg" in +"$define") + $cat >try.c < +#include +#$i_stdlib I_STDLIB +#ifdef I_STDLIB +#include +#endif +#include + +int +ivfprintf(FILE *f, const char *fmt, va_list *valp) +{ + return vfprintf(f, fmt, *valp); +} + +int +myvfprintf(FILE *f, const char *fmt, va_list val) +{ + return ivfprintf(f, fmt, &val); +} + +int +myprintf(char *fmt, ...) +{ + va_list val; + va_start(val, fmt); + return myvfprintf(stdout, fmt, val); +} + +int +main(int ac, char **av) +{ + signal(SIGSEGV, exit); + + myprintf("%s%cs all right, then\n", "that", '\''); + exit(0); +} +EOCP + set try + if eval $compile && ./try 2>&1 >/dev/null; then + case "`./try`" in + "that's all right, then") + okay=yes + ;; + esac + fi + case "$okay" in + yes) echo "It seems that you don't need va_copy()." >&4 + need_va_copy="$undef" + ;; + *) echo "It seems that va_copy() or similar will be needed." >&4 + need_va_copy="$define" + ;; + esac + $rm -f try.* core core.* *.core *.core.* + ;; +*) echo "You don't have , not checking for va_copy()." >&4 + ;; +esac + : define a fucntion to check prototypes $cat > protochk </dev/null 2>&1 ; then +echo '#include ' | $cppstdin $cppminus > stdioh +if $contains 'unsigned.*char.*_ptr;' stdioh >/dev/null 2>&1 ; then echo "Your stdio uses unsigned chars." >&4 stdchar="unsigned char" else echo "Your stdio uses signed chars." >&4 stdchar="char" fi +$rm -f stdioh + + : see if time exists echo " " @@ -14514,7 +15123,7 @@ EOSH ./tr '[a-z]' '[A-Z]' < Cppsym.know > Cppsym.a ./tr '[A-Z]' '[a-z]' < Cppsym.know > Cppsym.b $cat Cppsym.know > Cppsym.c -$cat Cppsym.a Cppsym.b Cppsym.c | $tr ' ' $trnl | sort | uniq > Cppsym.know +$cat Cppsym.a Cppsym.b Cppsym.c | $tr ' ' $trnl | $sort | $uniq > Cppsym.know $rm -f Cppsym.a Cppsym.b Cppsym.c cat < Cppsym $startsh @@ -14697,108 +15306,6 @@ val=$val3; set i_termios; eval $setvar set shadow.h i_shadow eval $inhdr -: see if this is a socks.h system -set socks.h i_socks -eval $inhdr - -: see if stdarg is available -echo " " -if $test `./findhdr stdarg.h`; then - echo " found." >&4 - valstd="$define" -else - echo " NOT found." >&4 - valstd="$undef" -fi - -: see if varags is available -echo " " -if $test `./findhdr varargs.h`; then - echo " found." >&4 -else - echo " NOT found, but that's ok (I hope)." >&4 -fi - -: set up the varargs testing programs -$cat > varargs.c < -#endif -#ifdef I_VARARGS -#include -#endif - -#ifdef I_STDARG -int f(char *p, ...) -#else -int f(va_alist) -va_dcl -#endif -{ - va_list ap; -#ifndef I_STDARG - char *p; -#endif -#ifdef I_STDARG - va_start(ap,p); -#else - va_start(ap); - p = va_arg(ap, char *); -#endif - va_end(ap); -} -EOP -$cat > varargs </dev/null 2>&1; then - echo "true" -else - echo "false" -fi -$rm -f varargs$_o -EOP -chmod +x varargs - -: now check which varargs header should be included -echo " " -i_varhdr='' -case "$valstd" in -"$define") - if `./varargs I_STDARG`; then - val='stdarg.h' - elif `./varargs I_VARARGS`; then - val='varargs.h' - fi - ;; -*) - if `./varargs I_VARARGS`; then - val='varargs.h' - fi - ;; -esac -case "$val" in -'') -echo "I could not find the definition for va_dcl... You have problems..." >&4 - val="$undef"; set i_stdarg; eval $setvar - val="$undef"; set i_varargs; eval $setvar - ;; -*) - set i_varhdr - eval $setvar - case "$i_varhdr" in - stdarg.h) - val="$define"; set i_stdarg; eval $setvar - val="$undef"; set i_varargs; eval $setvar - ;; - varargs.h) - val="$undef"; set i_stdarg; eval $setvar - val="$define"; set i_varargs; eval $setvar - ;; - esac - echo "We'll include <$i_varhdr> to get va_dcl definition." >&4;; -esac -$rm -f varargs* - : see if stddef is available set stddef.h i_stddef eval $inhdr @@ -15343,6 +15850,7 @@ d_PRIo64='$d_PRIo64' d_PRIu64='$d_PRIu64' d_PRIx64='$d_PRIx64' d_SCNfldbl='$d_SCNfldbl' +d__fwalk='$d__fwalk' d_access='$d_access' d_accessx='$d_accessx' d_alarm='$d_alarm' @@ -15389,6 +15897,7 @@ d_eunice='$d_eunice' d_fchmod='$d_fchmod' d_fchown='$d_fchown' d_fcntl='$d_fcntl' +d_fcntl_can_lock='$d_fcntl_can_lock' d_fd_macros='$d_fd_macros' d_fd_set='$d_fd_set' d_fds_bits='$d_fds_bits' @@ -15404,6 +15913,7 @@ d_fseeko='$d_fseeko' d_fsetpos='$d_fsetpos' d_fstatfs='$d_fstatfs' d_fstatvfs='$d_fstatvfs' +d_fsync='$d_fsync' d_ftello='$d_ftello' d_ftime='$d_ftime' d_getcwd='$d_getcwd' @@ -15423,6 +15933,7 @@ d_getnbyaddr='$d_getnbyaddr' d_getnbyname='$d_getnbyname' d_getnent='$d_getnent' d_getnetprotos='$d_getnetprotos' +d_getpagsz='$d_getpagsz' d_getpbyname='$d_getpbyname' d_getpbynumber='$d_getpbynumber' d_getpent='$d_getpent' @@ -15526,6 +16037,7 @@ d_rmdir='$d_rmdir' d_safebcpy='$d_safebcpy' d_safemcpy='$d_safemcpy' d_sanemcmp='$d_sanemcmp' +d_sbrkproto='$d_sbrkproto' d_sched_yield='$d_sched_yield' d_scm_rights='$d_scm_rights' d_seekdir='$d_seekdir' @@ -15580,6 +16092,8 @@ d_statfs_s='$d_statfs_s' d_statvfs='$d_statvfs' d_stdio_cnt_lval='$d_stdio_cnt_lval' d_stdio_ptr_lval='$d_stdio_ptr_lval' +d_stdio_ptr_lval_nochange_cnt='$d_stdio_ptr_lval_nochange_cnt' +d_stdio_ptr_lval_sets_cnt='$d_stdio_ptr_lval_sets_cnt' d_stdio_stream_array='$d_stdio_stream_array' d_stdiobase='$d_stdiobase' d_stdstdio='$d_stdstdio' @@ -15592,6 +16106,7 @@ d_strtod='$d_strtod' d_strtol='$d_strtol' d_strtold='$d_strtold' d_strtoll='$d_strtoll' +d_strtoq='$d_strtoq' d_strtoul='$d_strtoul' d_strtoull='$d_strtoull' d_strtouq='$d_strtouq' @@ -15783,6 +16298,7 @@ installvendorarch='$installvendorarch' installvendorbin='$installvendorbin' installvendorlib='$installvendorlib' intsize='$intsize' +issymlink='$issymlink' ivdformat='$ivdformat' ivsize='$ivsize' ivtype='$ivtype' @@ -15845,6 +16361,7 @@ mydomain='$mydomain' myhostname='$myhostname' myuname='$myuname' n='$n' +need_va_copy='$need_va_copy' netdb_hlen_type='$netdb_hlen_type' netdb_host_type='$netdb_host_type' netdb_name_type='$netdb_name_type' @@ -16057,9 +16574,9 @@ echo "CONFIGDOTSH=true" >>config.sh : propagate old symbols if $test -f UU/config.sh; then - UU/oldconfig.sh + UU/oldconfig.sh sed -n 's/^\([a-zA-Z_0-9]*\)=.*/\1/p' config.sh config.sh UU/oldconfig.sh |\ - sort | uniq -u >UU/oldsyms + $sort | $uniq -u >UU/oldsyms set X `cat UU/oldsyms` shift case $# in diff --git a/EXTERN.h b/EXTERN.h index 897fae6..1480551 100644 --- a/EXTERN.h +++ b/EXTERN.h @@ -1,6 +1,6 @@ /* EXTERN.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. diff --git a/INSTALL b/INSTALL index 50e7773..3aa80ca 100644 --- a/INSTALL +++ b/INSTALL @@ -517,6 +517,23 @@ directories to add to @INC. By default, it will be empty. Perl will search these directories (including architecture and version-specific subdirectories) for add-on modules and extensions. +=item APPLLIB_EXP + +There is one other way of adding paths to @INC at perl build time, and +that is by setting the APPLLIB_EXP C pre-processor token to a colon- +separated list of directories, like this + + sh Configure -Accflags='-DAPPLLIB_EXP=\"/usr/libperl\"' + +The directories defined by APPLLIB_EXP get added to @INC I, +ahead of any others, and so provide a way to override the standard perl +modules should you, for example, want to distribute fixes without +touching the perl distribution proper. And, like otherlib dirs, +version and architecture specific subdirectories are also searched, if +present, at run time. Of course, you can still search other @INC +directories ahead of those in APPLLIB_EXP by using any of the standard +run-time methods: $PERLLIB, $PERL5LIB, -I, use lib, etc. + =item Man Pages In versions 5.005_57 and earlier, the default was to store module man @@ -1131,6 +1148,39 @@ you have some libraries under /usr/local/ and others under =back +=head2 Building DB, NDBM, and ODBM interfaces with Berkeley DB 3 + +Perl interface for DB3 is part of Berkeley DB, but if you want to +compile standard Perl DB/ODBM/NDBM interfaces, you must follow +following instructions. + +Berkeley DB3 from Sleepycat Software is by default installed without +DB1 compatibility code (needed for DB_File interface) and without +links to compatibility files. So if you want to use packages written +for DB/ODBM/NDBM interfaces, you need to configure DB3 with +--enable-compat185 (and optionally with --enable-dump185) and create +additional references (suppose you are installing DB3 with +--prefix=/usr): + + ln -s libdb-3.so /usr/lib/libdbm.so + ln -s libdb-3.so /usr/lib/libndbm.so + echo '#define DB_DBM_HSEARCH 1' >dbm.h + echo '#include ' >>dbm.h + install -m 0644 dbm.h /usr/include/dbm.h + install -m 0644 dbm.h /usr/include/ndbm.h + +Optionally, if you have compiled with --enable-compat185 (not needed +for ODBM/NDBM): + + ln -s libdb-3.so /usr/lib/libdb1.so + ln -s libdb-3.so /usr/lib/libdb.so + +ODBM emulation seems not to be perfect, but is quite usable, +using DB 3.1.17: + + lib/odbm.............FAILED at test 9 + Failed 1/64 tests, 98.44% okay + =head2 What if it doesn't work? If you run into problems, try some of the following ideas. @@ -1397,36 +1447,6 @@ numbers and function name may vary in different versions of perl): it might well be a symptom of the gcc "varargs problem". See the previous L<"varargs"> item. -=item Solaris and SunOS dynamic loading - -If you have problems with dynamic loading using gcc on SunOS or -Solaris, and you are using GNU as and GNU ld, you may need to add --B/bin/ (for SunOS) or -B/usr/ccs/bin/ (for Solaris) to your -$ccflags, $ldflags, and $lddlflags so that the system's versions of as -and ld are used. Note that the trailing '/' is required. -Alternatively, you can use the GCC_EXEC_PREFIX -environment variable to ensure that Sun's as and ld are used. Consult -your gcc documentation for further information on the -B option and -the GCC_EXEC_PREFIX variable. - -One convenient way to ensure you are not using GNU as and ld is to -invoke Configure with - - sh Configure -Dcc='gcc -B/usr/ccs/bin/' - -for Solaris systems. For a SunOS system, you must use -B/bin/ -instead. - -Alternatively, recent versions of GNU ld reportedly work if you -include C<-Wl,-export-dynamic> in the ccdlflags variable in -config.sh. - -=item ld.so.1: ./perl: fatal: relocation error: - -If you get this message on SunOS or Solaris, and you're using gcc, -it's probably the GNU as or GNU ld problem in the previous item -L<"Solaris and SunOS dynamic loading">. - =item LD_LIBRARY_PATH If you run into dynamic loading problems, check your setting of @@ -1435,18 +1455,6 @@ Perl library (libperl.a rather than libperl.so) it should build fine with LD_LIBRARY_PATH unset, though that may depend on details of your local set-up. -=item dlopen: stub interception failed - -The primary cause of the 'dlopen: stub interception failed' message is -that the LD_LIBRARY_PATH environment variable includes a directory -which is a symlink to /usr/lib (such as /lib). - -The reason this causes a problem is quite subtle. The file libdl.so.1.0 -actually *only* contains functions which generate 'stub interception -failed' errors! The runtime linker intercepts links to -"/usr/lib/libdl.so.1.0" and links in internal implementation of those -functions instead. [Thanks to Tim Bunce for this explanation.] - =item nm extraction If Configure seems to be having trouble finding library functions, @@ -1632,24 +1640,11 @@ official site named at the start of this document. If you do find that any site is carrying a corrupted or incomplete source code archive, please report it to the site's maintainer. -This message can also be a symptom of using (say) a GNU tar compiled -for SunOS4 on Solaris. When you run SunOS4 binaries on Solaris the -run-time system magically alters pathnames matching m#lib/locale# - so -when tar tries to create lib/locale.pm a differently-named file gets -created instead. - -You may find the file under its assumed name and be able to rename it -back. Or use Sun's tar to do the extract. - =item invalid token: ## You are using a non-ANSI-compliant C compiler. See L. -=item lib/locale.pm: No such file or directory - -See L. - =item Miscellaneous Some additional things that have been reported for either perl4 or perl5: diff --git a/INTERN.h b/INTERN.h index 286cc46..1b35c13 100644 --- a/INTERN.h +++ b/INTERN.h @@ -1,6 +1,6 @@ /* INTERN.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. diff --git a/MAINTAIN b/MAINTAIN deleted file mode 100644 index cd1e4ed..0000000 --- a/MAINTAIN +++ /dev/null @@ -1,904 +0,0 @@ -# In addition to actual maintainers this file also lists "interested parties". -# -# The maintainer aliases come from AUTHORS. They may be defined in -# a layered way: 'doc' expands to tchrist which expands to Tom Christiansen. -# -# A file that is in MANIFEST need not be here at all. -# In any case, if nobody else is listed as maintainer, -# PUMPKING (from AUTHORS) should be it. -# -# Filenames can contain * which means qr(.*) on the filenames found -# using File::Find (it's _not_ filename glob). -# -# Maintainership definitions are of course cumulative: if A maintains -# X/* and B maintains X/Y/Z, if X/Y/Z is changed, both A and B should -# be notified. -# -# The filename(glob) and the maintainer(s) are separated by one or more tabs. - -Artistic -Changes -Changes5.000 -Changes5.001 -Changes5.002 -Changes5.003 -Changes5.004 -Changes5.005 -Configure cfg -Copying -EXTERN.h -INSTALL -INTERN.h -MANIFEST -Makefile.SH -Makefile.micro simon -objXSUB.h -Policy_sh.SH -Porting/* cfg -Porting/Contract -Porting/Glossary -Porting/config.sh -Porting/config_H -Porting/findvars -Porting/fixCORE -Porting/fixvars -Porting/genlog -Porting/makerel -Porting/p4d2p -Porting/p4desc -Porting/patching.pod dgris -Porting/patchls -Porting/pumpkin.pod -README -README.amiga amiga -README.beos beos -README.cygwin cygwin -README.dos dos -README.hpux hpux -README.lexwarn lexwarn -README.machten machten -README.micro simon -README.mpeix mpeix -README.os2 os2 -README.os390 os390 -README.plan9 plan9 -README.posix-bc posix-bc -README.qnx qnx -README.threads -README.vmesa vmesa -README.vms vms -README.vos vos -README.win32 win32 -Todo -Todo-5.005 -Todo.micro simon -XSlock.h -XSUB.h -av.c -av.h -beos/* beos -bytecode.h -bytecode.pl -byterun.c -byterun.h -cc_runtime.h -cflags.SH -config_h.SH cfg -configpm -configure.com vms -configure.gnu -cop.h -cv.h -cygwin/* cygwin -deb.c -djgpp/* dos -doio.c -doop.c -dosish.h -dump.c -ebcdic.c -eg/ADB -eg/README -eg/cgi/* cgi -eg/changes -eg/client -eg/down -eg/dus -eg/findcp -eg/findtar -eg/g/gcp -eg/g/gcp.man -eg/g/ged -eg/g/ghosts -eg/g/gsh -eg/g/gsh.man -eg/muck -eg/muck.man -eg/myrup -eg/nih -eg/relink -eg/rename -eg/rmfrom -eg/scan/scan_df -eg/scan/scan_last -eg/scan/scan_messages -eg/scan/scan_passwd -eg/scan/scan_ps -eg/scan/scan_sudo -eg/scan/scan_suid -eg/scan/scanner -eg/server -eg/shmkill -eg/sysvipc/README -eg/sysvipc/ipcmsg -eg/sysvipc/ipcsem -eg/sysvipc/ipcshm -eg/travesty -eg/unuc -eg/uudecode -eg/van/empty -eg/van/unvanish -eg/van/vanexp -eg/van/vanish -eg/who -eg/wrapsuid -emacs/* ilya -embed.h -embed.pl -embedvar.h -ext/*/hints* cfg -ext/B/* nik -ext/B/B/Deparse.pm smccam -ext/DB_File* pmarquess -ext/DB_File/hints/dynixptx.pl dynix/ptx -ext/Data/Dumper/* gsar -ext/Devel/DProf/* -ext/Devel/Peek/* ilya -ext/DynaLoader/DynaLoader_pm.PL -ext/DynaLoader/Makefile.PL -ext/DynaLoader/README -ext/DynaLoader/dl_aix.xs aix -ext/DynaLoader/dl_dld.xs rsanders -ext/DynaLoader/dl_dlopen.xs timb -ext/DynaLoader/dl_hpux.xs hpux -ext/DynaLoader/dl_mpeix.xs mpeix -ext/DynaLoader/dl_next.xs next -ext/DynaLoader/dl_none.xs -ext/DynaLoader/dl_vms.xs vms -ext/DynaLoader/dl_vmesa.xs vmesa -ext/DynaLoader/dlutils.c -ext/DynaLoader/hints/linux.pl linux -ext/Errno/* gbarr -ext/Fcntl/* jhi -ext/GDBM_File/GDBM_File.pm -ext/GDBM_File/GDBM_File.xs -ext/GDBM_File/Makefile.PL -ext/GDBM_File/typemap -ext/IO/* -ext/IPC/SysV/* gbarr -ext/NDBM_File/Makefile.PL -ext/NDBM_File/NDBM_File.pm -ext/NDBM_File/NDBM_File.xs -ext/NDBM_File/hints/dec_osf.pl dec_osf -ext/NDBM_File/hints/dynixptx.pl dynix/ptx -ext/NDBM_File/hints/solaris.pl solaris -ext/NDBM_File/hints/svr4.pl svr4 -ext/NDBM_File/typemap -ext/ODBM_File/Makefile.PL -ext/ODBM_File/ODBM_File.pm -ext/ODBM_File/ODBM_File.xs -ext/ODBM_File/hints/dec_osf.pl dec_osf -ext/ODBM_File/hints/hpux.pl hpux -ext/ODBM_File/hints/sco.pl sco -ext/ODBM_File/hints/solaris.pl solaris -ext/ODBM_File/hints/svr4.pl svr4 -ext/ODBM_File/hints/ultrix.pl -ext/ODBM_File/typemap -ext/Opcode/Makefile.PL -ext/Opcode/Opcode.pm -ext/Opcode/Opcode.xs -ext/Opcode/Safe.pm -ext/Opcode/ops.pm -ext/POSIX/Makefile.PL -ext/POSIX/POSIX.pm -ext/POSIX/POSIX.pod -ext/POSIX/POSIX.xs -ext/POSIX/hints/bsdos.pl bsdos -ext/POSIX/hints/dynixptx.pl dynix/ptx -ext/POSIX/hints/freebsd.pl freebsd -ext/POSIX/hints/linux.pl linux -ext/POSIX/hints/netbsd.pl netbsd -ext/POSIX/hints/next_3.pl next -ext/POSIX/hints/openbsd.pl openbsd -ext/POSIX/hints/sunos_4.pl sunos4 -ext/POSIX/typemap -ext/SDBM_File/Makefile.PL -ext/SDBM_File/SDBM_File.pm -ext/SDBM_File/SDBM_File.xs -ext/SDBM_File/sdbm/CHANGES -ext/SDBM_File/sdbm/COMPARE -ext/SDBM_File/sdbm/Makefile.PL -ext/SDBM_File/sdbm/README -ext/SDBM_File/sdbm/README.too -ext/SDBM_File/sdbm/biblio -ext/SDBM_File/sdbm/dba.c -ext/SDBM_File/sdbm/dbd.c -ext/SDBM_File/sdbm/dbe.1 -ext/SDBM_File/sdbm/dbe.c -ext/SDBM_File/sdbm/dbm.c -ext/SDBM_File/sdbm/dbm.h -ext/SDBM_File/sdbm/dbu.c -ext/SDBM_File/sdbm/grind -ext/SDBM_File/sdbm/hash.c -ext/SDBM_File/sdbm/linux.patches -ext/SDBM_File/sdbm/makefile.sdbm -ext/SDBM_File/sdbm/pair.c -ext/SDBM_File/sdbm/pair.h -ext/SDBM_File/sdbm/readme.ms -ext/SDBM_File/sdbm/sdbm.3 -ext/SDBM_File/sdbm/sdbm.c -ext/SDBM_File/sdbm/sdbm.h -ext/SDBM_File/sdbm/tune.h -ext/SDBM_File/sdbm/util.c -ext/SDBM_File/typemap -ext/Socket/Makefile.PL -ext/Socket/Socket.pm -ext/Socket/Socket.xs -ext/Thread/Makefile.PL -ext/Thread/Notes -ext/Thread/README -ext/Thread/Thread.pm -ext/Thread/Thread.xs -ext/Thread/Thread/Queue.pm -ext/Thread/Thread/Semaphore.pm -ext/Thread/Thread/Signal.pm -ext/Thread/Thread/Specific.pm -ext/Thread/create.t -ext/Thread/die.t -ext/Thread/die2.t -ext/Thread/io.t -ext/Thread/join.t -ext/Thread/join2.t -ext/Thread/list.t -ext/Thread/lock.t -ext/Thread/queue.t -ext/Thread/specific.t -ext/Thread/sync.t -ext/Thread/sync2.t -ext/Thread/typemap -ext/Thread/unsync.t -ext/Thread/unsync2.t -ext/Thread/unsync3.t -ext/Thread/unsync4.t -ext/attrs/Makefile.PL -ext/attrs/attrs.pm -ext/attrs/attrs.xs -ext/re/Makefile.PL -ext/re/hints/mpeix.pl mpeix -ext/re/re.pm regex -ext/re/re.xs regex -ext/util/make_ext -ext/util/mkbootstrap -fakethr.h -form.h -global.sym -globals.c -globvar.sym -gv.c -gv.h -h2pl/README -h2pl/cbreak.pl -h2pl/cbreak2.pl -h2pl/eg/sizeof.ph -h2pl/eg/sys/errno.pl -h2pl/eg/sys/ioctl.pl -h2pl/eg/sysexits.pl -h2pl/getioctlsizes -h2pl/mksizes -h2pl/mkvars -h2pl/tcbreak -h2pl/tcbreak2 -handy.h -hints/* cfg -hints/3b1.sh -hints/3b1cc -hints/README.hints -hints/aix.sh aix -hints/altos486.sh -hints/amigaos.sh amiga -hints/apollo.sh -hints/aux_3.sh -hints/beos.sh beos -hints/broken-db.msg -hints/bsdos.sh bsdos -hints/convexos.sh -hints/cxux.sh cxux -hints/cygwin.sh cygwin -hints/dcosx.sh -hints/dec_osf.sh dec_osf -hints/dgux.sh dgux -hints/dos_djgpp.sh dos -hints/dynix.sh dynix/ptx -hints/dynixptx.sh dynix/ptx -hints/epix.sh -hints/esix4.sh -hints/fps.sh -hints/freebsd.sh freebsd -hints/genix.sh -hints/greenhills.sh -hints/hpux.sh hpux -hints/i386.sh -hints/irix* irix -hints/isc.sh -hints/isc_2.sh -hints/linux.sh linux -hints/lynxos.sh -hints/machten.sh machten -hints/machten_2.sh -hints/mips.sh -hints/mpc.sh -hints/mpeix.sh mpeix -hints/ncr_tower.sh -hints/netbsd.sh netbsd -hints/newsos4.sh -hints/next* step -hints/openbsd.sh openbsd -hints/opus.sh -hints/os2.sh os2 -hints/os390.sh os390 -hints/posix-bc.sh posix-bc -hints/powerux.sh powerux -hints/qnx.sh qnx -hints/sco.sh -hints/sco_2_3_0.sh -hints/sco_2_3_1.sh -hints/sco_2_3_2.sh -hints/sco_2_3_3.sh -hints/sco_2_3_4.sh -hints/solaris_2.sh solaris -hints/stellar.sh -hints/sunos_4* sunos4 -hints/svr4.sh svr4 -hints/ti1500.sh -hints/titanos.sh -hints/ultrix_4.sh ultrix -hints/umips.sh -hints/unicos* unicos -hints/unisysdynix.sh -hints/utekv.sh -hints/uts.sh -hints/uwin.sh uwin -hints/vmesa.sh vmesa -hv.c -hv.h -installhtml -installman -installperl -intrpvar.h -iperlsys.h -jpl/* jpl -keywords.h -keywords.pl -lib/AnyDBM_File.pm -lib/AutoLoader.pm -lib/AutoSplit.pm -lib/Benchmark.pm jhi,timb -lib/CGI* cgi -lib/CPAN* cpan -lib/Carp.pm -lib/Class/Struct.pm tchrist -lib/Cwd.pm -lib/Devel/SelfStubber.pm -lib/DirHandle.pm -lib/English.pm -lib/Env.pm -lib/Exporter.pm -lib/ExtUtils/* mm -lib/ExtUtils/Command.pm nik -lib/ExtUtils/Embed.pm doug -lib/ExtUtils/Installed.pm alan.burlison -lib/ExtUtils/Mksymlists.pm cbail -lib/ExtUtils/MM_OS2.pm os2 -lib/ExtUtils/MM_VMS.pm vms -lib/ExtUtils/MM_Win32.pm win32 -lib/ExtUtils/Packlist.pm alan.burlison -lib/Fatal.pm -lib/File/Basename.pm -lib/File/CheckTree.pm -lib/File/Compare.pm nik -lib/File/Copy.pm cbail -lib/File/DosGlob.pm gsar -lib/File/Find.pm -lib/File/Path.pm timb,cbail -lib/File/Spec* kjahds -lib/File/Spec/Mac.pm schinder -lib/File/Spec/OS2.pm ilya -lib/File/Spec/VMS.pm vms -lib/File/Spec/Win32.pm win32 -lib/File/Temp.pm tjenness -lib/File/stat.pm tchrist -lib/FileCache.pm -lib/FileHandle.pm -lib/FindBin.pm -lib/Getopt/Long.pm jvromans -lib/I18N/Collate.pm jhi -lib/IPC/Open2.pm -lib/IPC/Open3.pm -lib/Math/BigFloat.pm mbiggar -lib/Math/BigInt.pm mbiggar -lib/Math/Complex.pm complex -lib/Math/Trig.pm complex -lib/Net/Ping.pm -lib/Net/hostent.pm tchrist -lib/Net/netent.pm tchrist -lib/Net/protoent.pm tchrist -lib/Net/servent.pm tchrist -lib/Pod/Checker.pm bradapp -lib/Pod/Functions.pm -lib/Pod/Html.pm tchrist -lib/Pod/InputObjects.pm bradapp -lib/Pod/LaTeX.pm tjenness -lib/Pod/Man.pm rra -lib/Pod/Parser.pm bradapp -lib/Pod/PlainText.pm bradapp -lib/Pod/Select.pm bradapp -lib/Pod/Text.pm rra -lib/Pod/Text/* rra -lib/Pod/Usage.pm bradapp -lib/Search/Dict.pm -lib/SelectSaver.pm -lib/SelfLoader.pm -lib/Shell.pm -lib/Symbol.pm -lib/Sys/Hostname.pm sundstrom -lib/Sys/Syslog.pm tchrist -lib/Term/ANSIcolor.pm rra -lib/Term/Cap.pm -lib/Term/Complete.pm wayne.thompson -lib/Term/ReadLine.pm -lib/Test.pm -lib/Test/Harness.pm k -lib/Text/Abbrev.pm -lib/Text/ParseWords.pm pomeranz -lib/Text/Soundex.pm mikestok -lib/Text/Tabs.pm muir -lib/Text/Wrap.pm muir -lib/Tie/Array.pm nik -lib/Tie/Handle.pm -lib/Tie/Hash.pm -lib/Tie/RefHash.pm gsar -lib/Tie/Scalar.pm -lib/Tie/SubstrHash.pm -lib/Time/Local.pm pomeranz -lib/Time/gmtime.pm tchrist -lib/Time/localtime.pm tchrist -lib/Time/tm.pm tchrist -lib/UNIVERSAL.pm -lib/User/grent.pm tchrist -lib/User/pwent.pm tchrist -lib/abbrev.pl -lib/assert.pl -lib/autouse.pm -lib/base.pm -lib/bigfloat.pl -lib/bigint.pl -lib/bigrat.pl -lib/blib.pm -lib/cacheout.pl -lib/charnames.pm ilya -lib/chat2.pl -lib/complete.pl -lib/constant.pm -lib/ctime.pl -lib/diagnostics.pm doc -lib/dotsh.pl -lib/dumpvar.pl -lib/exceptions.pl -lib/fastcwd.pl -lib/fields.pm -lib/filetest.pm -lib/find.pl -lib/finddepth.pl -lib/flush.pl -lib/ftp.pl -lib/getcwd.pl -lib/getopt.pl -lib/getopts.pl -lib/hostname.pl -lib/importenv.pl -lib/integer.pm -lib/less.pm -lib/lib.pm -lib/locale.pm locale -lib/look.pl -lib/newgetopt.pl -lib/open2.pl -lib/open3.pl -lib/overload.pm ilya -lib/perl5db.pl ilya -lib/pwd.pl -lib/shellwords.pl -lib/sigtrap.pm -lib/stat.pl -lib/strict.pm -lib/subs.pm -lib/syslog.pl -lib/tainted.pl -lib/termcap.pl -lib/timelocal.pl -lib/unicode/*Ethiopic* dmulholl -lib/unicode* lwall -lib/utf8* lwall -lib/validate.pl -lib/vars.pm -lib/warning.pm lexwarn -makeaperl.SH -makedepend.SH -makedir.SH -malloc.c ilya -mg.c -mg.h -minimod.pl -miniperlmain.c -mpeix/* mpeix -mv-if-diff -myconfig -nostdio.h -op.c -op.h -opcode.h -opcode.pl -os2/* ilya -patchlevel.h -perl.c -perl.h -perl_exp.SH -perlio.c -perlio.h -perlio.sym -perlsdio.h -perlsfio.h -perlsh -perlvars.h -perly.c -perly_c.diff -perly.fixer -perly.h -perly.y -plan9/* plan9 -pod/pod2usage.PL bradapp -pod/podchecker.PL bradapp -pod/podselect.PL bradapp -pod/* doc -pod/buildtoc -pod/checkpods.PL -pod/perl.pod -pod/perlapio.pod -pod/perlbook.pod -pod/perlbot.pod -pod/perlcall.pod pmarquess -pod/perldata.pod -pod/perldebug.pod -pod/perldelta.pod -pod/perl5005delta.pod -pod/perl5004delta.pod -pod/perldebtut.pod richard -pod/perldiag.pod -pod/perldsc.pod tchrist -pod/perlembed.pod doug,jon -pod/perlebcdic.pod pvhp -pod/perlfaq* gnat -pod/perlform.pod -pod/perlfunc.pod -pod/perlguts.pod -pod/perlhack.pod simon -pod/perlhist.pod jhi -pod/perlipc.pod tchrist -pod/perllocale.pod locale -pod/perllol.pod tchrist -pod/perlmod.pod -pod/perlmodinstall.pod jon -pod/perlmodlib.pod simon -pod/perlmodlib.PL simon -pod/perlnewmod.pod simon -pod/perlobj.pod -pod/perlop.pod -pod/perlpod.pod lwall -pod/perlport.pod pudge -pod/perlposix-bc.pod posix-bc -pod/perlre.pod regex -pod/perlref.pod -pod/perlreftut.pod mjd -pod/perlrequick.pod mkvale -pod/perlretut.pod mkvale -pod/perlrun.pod -pod/perlsec.pod -pod/perlstyle.pod -pod/perlsub.pod -pod/perlsyn.pod -pod/perltie.pod tchrist -pod/perltoc.pod -pod/perltoot.pod tchrist -pod/perltrap.pod -pod/perlunicode.pod simon -pod/perlutil.pod simon -pod/perlvar.pod -pod/perlxs.pod roehrich -pod/perlxstut.pod okamoto -pod/pod2html.PL -pod/pod2latex.PL -pod/pod2man.PL -pod/pod2text.PL -pod/roffitall -pod/rofftoc -pod/splitman -pod/splitpod -pp.c -pp.h -pp.sym -pp_ctl.c -pp_hot.c -pp_proto.h -pp_sys.c -proto.h -qnx/* qnx -regcomp.c regex -regcomp.h regex -regcomp.pl regex -regcomp.sym regex -regexec.c regex -regexp.h regex -regnodes.h regex -run.c -scope.c -scope.h -sv.c -sv.h -t/README -t/TEST -t/UTEST -t/base/cond.t -t/base/if.t -t/base/lex.t -t/base/pat.t -t/base/rs.t -t/base/term.t -t/cmd/elsif.t -t/cmd/for.t -t/cmd/mod.t -t/cmd/subval.t -t/cmd/switch.t -t/cmd/while.t -t/comp/cmdopt.t -t/comp/colon.t -t/comp/cpp.aux -t/comp/cpp.t -t/comp/decl.t -t/comp/multiline.t -t/comp/package.t -t/comp/proto.t -t/comp/redef.t -t/comp/require.t -t/comp/script.t -t/comp/term.t -t/comp/use.t -t/harness -t/io/argv.t -t/io/dup.t -t/io/fs.t -t/io/inplace.t -t/io/iprefix.t -t/io/pipe.t -t/io/print.t -t/io/read.t -t/io/tell.t -t/lib/abbrev.t -t/lib/anydbm.t -t/lib/ansicolor.t rra -t/lib/autoloader.t -t/lib/basename.t -t/lib/bigint.t -t/lib/bigintpm.t -t/lib/cgi-form.t -t/lib/cgi-function.t -t/lib/cgi-html.t -t/lib/cgi-request.t -t/lib/charnames.t ilya -t/lib/checktree.t -t/lib/complex.t complex -t/lib/db-btree.t pmarquess -t/lib/db-hash.t pmarquess -t/lib/db-recno.t pmarquess -t/lib/dirhand.t -t/lib/dosglob.t -t/lib/dumper-ovl.t gsar -t/lib/dumper.t gsar -t/lib/english.t -t/lib/env.t -t/lib/errno.t gbarr -t/lib/fields.t -t/lib/filecache.t -t/lib/filecopy.t -t/lib/filefind.t -t/lib/filehand.t -t/lib/filepath.t -t/lib/filespec.t kjahds -t/lib/findbin.t -t/lib/ftmp-*.t tjenness -t/lib/gol-basic.t jvromans -t/lib/gol-compat.t jvromans -t/lib/gol-linkage.t jvromans -t/lib/gdbm.t -t/lib/getopt.t jvromans -t/lib/h2ph* kstar -t/lib/hostname.t -t/lib/io_* gbarr -t/lib/ipc_sysv.t gbarr -t/lib/ndbm.t -t/lib/odbm.t -t/lib/opcode.t -t/lib/open2.t -t/lib/open3.t -t/lib/ops.t -t/lib/parsewords.t -t/lib/ph.t kstar -t/lib/posix.t -t/lib/safe1.t -t/lib/safe2.t -t/lib/sdbm.t -t/lib/searchdict.t -t/lib/selectsaver.t -t/lib/socket.t -t/lib/soundex.t -t/lib/symbol.t -t/lib/texttabs.t muir -t/lib/textfill.t muir -t/lib/textwrap.t -t/lib/thr5005.t -t/lib/tie-push.t -t/lib/tie-stdarray.t -t/lib/tie-stdpush.t -t/lib/timelocal.t -t/lib/trig.t -t/op/append.t -t/op/arith.t -t/op/array.t -t/op/assignwarn.t -t/op/auto.t -t/op/avhv.t -t/op/bop.t -t/op/chop.t -t/op/closure.t -t/op/cmp.t -t/op/cond.t -t/op/context.t -t/op/defins.t -t/op/delete.t -t/op/die.t -t/op/die_exit.t -t/op/do.t -t/op/each.t -t/op/eval.t -t/op/exec.t -t/op/exp.t -t/op/filetest.t -t/op/flip.t -t/op/fork.t -t/op/glob.t -t/op/goto.t -t/op/goto_xs.t -t/op/grent.t -t/op/groups.t -t/op/gv.t -t/op/hashwarn.t -t/op/inc.t -t/op/index.t -t/op/int.t -t/op/join.t -t/op/lex_assign.t -t/op/list.t -t/op/local.t -t/op/magic.t -t/op/method.t -t/op/misc.t -t/op/mkdir.t -t/op/my.t -t/op/nothr5005.t -t/op/oct.t -t/op/ord.t -t/op/pack.t -t/op/pat.t -t/op/pos.t -t/op/push.t -t/op/pwent.t -t/op/quotemeta.t -t/op/rand.t -t/op/range.t -t/op/re_tests regex -t/op/read.t -t/op/readdir.t -t/op/recurse.t -t/op/ref.t -t/op/regexp.t regex -t/op/regexp_noamp.t regex -t/op/repeat.t -t/op/runlevel.t -t/op/sleep.t -t/op/sort.t -t/op/splice.t -t/op/split.t -t/op/sprintf.t -t/op/stat.t -t/op/study.t -t/op/subst.t -t/op/substr.t -t/op/sysio.t -t/op/taint.t -t/op/tie.t -t/op/tiearray.t -t/op/tiehandle.t -t/op/time.t -t/op/tr.t -t/op/undef.t -t/op/universal.t -t/op/unshift.t -t/op/vec.t -t/op/wantarray.t -t/op/write.t -t/pod/* bradapp -t/pragma/constant.t -t/pragma/locale.t locale -t/pragma/overload.t ilya -t/pragma/strict-refs -t/pragma/strict-subs -t/pragma/strict-vars -t/pragma/strict.t -t/pragma/subs.t -t/pragma/warn/* lexwarn -t/pragma/warn/regcomp regex -t/pragma/warn/regexec regex -t/pragma/warning.t lexwarn -taint.c -thrdvar.h -thread.h -toke.c -uconfig.h simon -uconfig.sh simon -universal.c -unixish.h -utf* lwall -utils/Makefile -utils/c2ph.PL tchrist -utils/h2ph.PL kstar -utils/h2xs.PL -utils/perlbug.PL -utils/perlcc.PL -utils/perldoc.PL -utils/pl2pm.PL -utils/splain.PL doc -vmesa/* vmesa -vms/* vms -vos/* vos -warning.h lexwarn -warning.pl lexwarn -win32/* -writemain.SH -x2p/EXTERN.h -x2p/INTERN.h -x2p/Makefile.SH -x2p/a2p.c -x2p/a2p.h -x2p/a2p.pod -x2p/a2p.y -x2p/a2py.c -x2p/cflags.SH -x2p/find2perl.PL -x2p/hash.c -x2p/hash.h -x2p/proto.h -x2p/s2p.PL -x2p/str.c -x2p/str.h -x2p/util.c -x2p/util.h -x2p/walk.c diff --git a/MANIFEST b/MANIFEST index dbe97ca..18ae760 100644 --- a/MANIFEST +++ b/MANIFEST @@ -13,7 +13,6 @@ Copying The GNU General Public License EXTERN.h Included before foreign .h files INSTALL Detailed installation instructions INTERN.h Included before domestic .h files -MAINTAIN Who maintains which files MANIFEST This list of files Makefile.SH A script that generates Makefile Makefile.micro microperl Makefile @@ -32,6 +31,7 @@ Porting/p4desc Smarter 'p4 describe', outputs diffs for new files Porting/patching.pod How to report changes made to Perl Porting/patchls Flexible patch file listing utility Porting/pumpkin.pod Guidelines and hints for Perl maintainers +Porting/repository.pod How to use the Perl repository README The Instructions README.Y2K Notes about Year 2000 concerns README.aix Notes about AIX port @@ -52,6 +52,7 @@ README.os390 Notes about OS/390 (nee MVS) port README.plan9 Notes about Plan9 port README.posix-bc Notes about BS2000 POSIX port README.qnx Notes about QNX port +README.solaris Notes about Solaris port README.threads Notes about multithreading README.vmesa Notes about VM/ESA port README.vms Notes about installing the VMS port @@ -191,10 +192,11 @@ ext/DynaLoader/hints/netbsd.pl Hint for DynaLoader for named architecture ext/DynaLoader/hints/openbsd.pl Hint for DynaLoader for named architecture ext/Encode/Encode.pm Encode extension ext/Encode/Encode.xs Encode extension -ext/Encode/Makefile.PL Encode extension -ext/Encode/Todo Encode extension +ext/Encode/Encode/EncodeFormat.pod Encoding table format ext/Encode/Encode/ascii.enc Encoding tables ext/Encode/Encode/big5.enc Encoding tables +ext/Encode/Encode/cp1006.enc Encoding tables +ext/Encode/Encode/cp1047.enc Encoding tables ext/Encode/Encode/cp1250.enc Encoding tables ext/Encode/Encode/cp1251.enc Encoding tables ext/Encode/Encode/cp1252.enc Encoding tables @@ -204,12 +206,15 @@ ext/Encode/Encode/cp1255.enc Encoding tables ext/Encode/Encode/cp1256.enc Encoding tables ext/Encode/Encode/cp1257.enc Encoding tables ext/Encode/Encode/cp1258.enc Encoding tables +ext/Encode/Encode/cp37.enc Encoding tables +ext/Encode/Encode/cp424.enc Encoding tables ext/Encode/Encode/cp437.enc Encoding tables ext/Encode/Encode/cp737.enc Encoding tables ext/Encode/Encode/cp775.enc Encoding tables ext/Encode/Encode/cp850.enc Encoding tables ext/Encode/Encode/cp852.enc Encoding tables ext/Encode/Encode/cp855.enc Encoding tables +ext/Encode/Encode/cp856.enc Encoding tables ext/Encode/Encode/cp857.enc Encoding tables ext/Encode/Encode/cp860.enc Encoding tables ext/Encode/Encode/cp861.enc Encoding tables @@ -231,10 +236,16 @@ ext/Encode/Encode/euc-kr.enc Encoding tables ext/Encode/Encode/gb12345.enc Encoding tables ext/Encode/Encode/gb1988.enc Encoding tables ext/Encode/Encode/gb2312.enc Encoding tables +ext/Encode/Encode/gsm0338.enc Encoding tables ext/Encode/Encode/iso2022-jp.enc Encoding tables ext/Encode/Encode/iso2022-kr.enc Encoding tables ext/Encode/Encode/iso2022.enc Encoding tables ext/Encode/Encode/iso8859-1.enc Encoding tables +ext/Encode/Encode/iso8859-10.enc Encoding tables +ext/Encode/Encode/iso8859-13.enc Encoding tables +ext/Encode/Encode/iso8859-14.enc Encoding tables +ext/Encode/Encode/iso8859-15.enc Encoding tables +ext/Encode/Encode/iso8859-16.enc Encoding tables ext/Encode/Encode/iso8859-2.enc Encoding tables ext/Encode/Encode/iso8859-3.enc Encoding tables ext/Encode/Encode/iso8859-4.enc Encoding tables @@ -260,8 +271,14 @@ ext/Encode/Encode/macRomania.enc Encoding tables ext/Encode/Encode/macThai.enc Encoding tables ext/Encode/Encode/macTurkish.enc Encoding tables ext/Encode/Encode/macUkraine.enc Encoding tables +ext/Encode/Encode/posix-bc.enc Encoding tables ext/Encode/Encode/shiftjis.enc Encoding tables ext/Encode/Encode/symbol.enc Encoding tables +ext/Encode/Makefile.PL Encode extension +ext/Encode/Todo Encode extension +ext/Encode/compile Encode extension +ext/Encode/encengine.c Encode extension +ext/Encode/encode.h Encode extension ext/Errno/ChangeLog Errno perl module change log ext/Errno/Errno_pm.PL Errno perl module create script ext/Errno/Makefile.PL Errno extension makefile writer @@ -275,6 +292,9 @@ ext/File/Glob/Makefile.PL File::Glob extension makefile writer ext/File/Glob/TODO File::Glob extension todo list ext/File/Glob/bsd_glob.c File::Glob extension run time code ext/File/Glob/bsd_glob.h File::Glob extension header file +ext/Filter/Util/Call/Call.pm Filter::Util::Call extension module +ext/Filter/Util/Call/Call.xs Filter::Util::Call extension external subroutines +ext/Filter/Util/Call/Makefile.PL Filter::Util::Call extension makefile writer ext/GDBM_File/GDBM_File.pm GDBM extension Perl module ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines ext/GDBM_File/Makefile.PL GDBM extension makefile writer @@ -348,6 +368,7 @@ ext/POSIX/hints/netbsd.pl Hint for POSIX for named architecture ext/POSIX/hints/next_3.pl Hint for POSIX for named architecture ext/POSIX/hints/openbsd.pl Hint for POSIX for named architecture ext/POSIX/hints/sunos_4.pl Hint for POSIX for named architecture +ext/POSIX/hints/svr4.pl Hint for POSIX for named architecture ext/POSIX/typemap POSIX extension interface types ext/SDBM_File/Makefile.PL SDBM extension makefile writer ext/SDBM_File/SDBM_File.pm SDBM extension Perl module @@ -382,8 +403,8 @@ ext/Socket/Makefile.PL Socket extension makefile writer ext/Socket/Socket.pm Socket extension Perl module ext/Socket/Socket.xs Socket extension external subroutines ext/Storable/ChangeLog Storable extension -ext/Storable/Makefile.PL Storable extension ext/Storable/MANIFEST Storable extension +ext/Storable/Makefile.PL Storable extension ext/Storable/README Storable extension ext/Storable/Storable.pm Storable extension ext/Storable/Storable.xs Storable extension @@ -423,13 +444,14 @@ ext/attrs/Makefile.PL attrs extension makefile writer ext/attrs/attrs.pm attrs extension Perl module ext/attrs/attrs.xs attrs extension external subroutines ext/re/Makefile.PL re extension makefile writer +ext/re/hints/aix.pl Hints for re for named architecture ext/re/hints/mpeix.pl Hints for re for named architecture ext/re/re.pm re extension Perl module ext/re/re.xs re extension external subroutines ext/util/make_ext Used by Makefile to execute extension Makefiles ext/util/mkbootstrap Turns ext/*/*_BS into bootstrap info +fakesdio.h stdio in terms of PerlIO fakethr.h Fake threads header -fix_pl Fix up patchlevel.h for repository perls form.h Public declarations for the above global.sym Symbols that need hiding when embedded globals.c File to declare global symbols (for shared library) @@ -633,6 +655,7 @@ lib/ExtUtils/Embed.pm Utilities for embedding Perl in C programs lib/ExtUtils/Install.pm Handles 'make install' on extensions lib/ExtUtils/Installed.pm Information on installed extensions lib/ExtUtils/Liblist.pm Locates libraries +lib/ExtUtils/MANIFEST.SKIP The default MANIFEST.SKIP lib/ExtUtils/MM_Cygwin.pm MakeMaker methods for Cygwin lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2 lib/ExtUtils/MM_Unix.pm MakeMaker base class for Unix @@ -656,6 +679,7 @@ lib/File/DosGlob.pm Win32 DOS-globbing module lib/File/Find.pm Routines to do a find lib/File/Path.pm Do things like `mkdir -p' and `rm -r' lib/File/Spec.pm portable operations on file names +lib/File/Spec/Epoc.pm portable operations on EPOC file names lib/File/Spec/Functions.pm Function interface to File::Spec object methods lib/File/Spec/Mac.pm portable operations on Mac file names lib/File/Spec/OS2.pm portable operations on OS2 file names @@ -666,6 +690,7 @@ lib/File/Temp.pm create safe temporary files and file handles lib/File/stat.pm By-name interface to Perl's builtin stat lib/FileCache.pm Keep more files open than the system permits lib/FileHandle.pm Backward-compatible front end to IO extension +lib/Filter/Simple.pm Simple frontend to Filter::Util::Call lib/FindBin.pm Find name of currently executing program lib/Getopt/Long.pm Fetch command options (GetOptions) lib/Getopt/Std.pm Fetch command options (getopt, getopts) @@ -694,6 +719,7 @@ lib/Pod/Plainer.pm Pod migration utility module lib/Pod/Select.pm Pod-Parser - select portions of POD docs lib/Pod/Text.pm Pod-Parser - convert POD data to formatted ASCII text lib/Pod/Text/Color.pm Convert POD data to color ASCII text +lib/Pod/Text/Overstrike.pm Convert POD data to formatted overstrike text lib/Pod/Text/Termcap.pm Convert POD data to ASCII text with format escapes lib/Pod/Usage.pm Pod-Parser - print usage messages lib/Search/Dict.pm Perform binary search on dictionaries @@ -769,6 +795,7 @@ lib/open2.pl Open a two-ended pipe (uses IPC::Open2) lib/open3.pl Open a three-ended pipe (uses IPC::Open3) lib/overload.pm Module for overloading perl operators lib/perl5db.pl Perl debugging routines +lib/perlio.pm Perl IO interface pragma lib/pwd.pl Routines to keep track of PWD environment variable lib/shellwords.pl Perl library to split into words with shell quoting lib/sigtrap.pm For trapping an abort and giving traceback @@ -902,6 +929,7 @@ lib/unicode/Is/BidiRLE.pl Unicode character database lib/unicode/Is/BidiRLO.pl Unicode character database lib/unicode/Is/BidiS.pl Unicode character database lib/unicode/Is/BidiWS.pl Unicode character database +lib/unicode/Is/Blank.pl Unicode character database lib/unicode/Is/C.pl Unicode character database lib/unicode/Is/Cc.pl Unicode character database lib/unicode/Is/Cf.pl Unicode character database @@ -914,9 +942,9 @@ lib/unicode/Is/DCcompat.pl Unicode character database lib/unicode/Is/DCfinal.pl Unicode character database lib/unicode/Is/DCfont.pl Unicode character database lib/unicode/Is/DCfraction.pl Unicode character database -lib/unicode/Is/DCinital.pl Unicode character database lib/unicode/Is/DCinitial.pl Unicode character database lib/unicode/Is/DCisolated.pl Unicode character database +lib/unicode/Is/DCmedial.pl Unicode character database lib/unicode/Is/DCnarrow.pl Unicode character database lib/unicode/Is/DCnoBreak.pl Unicode character database lib/unicode/Is/DCsmall.pl Unicode character database @@ -990,6 +1018,7 @@ lib/unicode/Is/Sk.pl Unicode character database lib/unicode/Is/Sm.pl Unicode character database lib/unicode/Is/So.pl Unicode character database lib/unicode/Is/Space.pl Unicode character database +lib/unicode/Is/SpacePerl.pl Unicode character database lib/unicode/Is/SylA.pl Unicode character database lib/unicode/Is/SylAA.pl Unicode character database lib/unicode/Is/SylAAI.pl Unicode character database @@ -1043,6 +1072,7 @@ lib/unicode/To/Upper.pl Unicode character database lib/unicode/UCD301.html Unicode character database lib/unicode/UCDFF301.html Unicode character database lib/unicode/Unicode.301 Unicode character database +lib/unicode/distinct.pm Perl pragma to strictly distinguish UTF8 data and non-UTF data lib/unicode/mktables.PL Unicode character database generator lib/unicode/syllables.txt Unicode character database lib/utf8.pm Pragma to control Unicode support @@ -1134,8 +1164,9 @@ perl.h Global declarations perlapi.c Perl API functions perlapi.h Perl API function declarations perlio.c C code for PerlIO abstraction -perlio.h compatibility stub +perlio.h PerlIO abstraction perlio.sym Symbols for PerlIO abstraction +perliol.h PerlIO Layer definition perlsdio.h Fake stdio using perlio perlsfio.h Prototype sfio mapping for PerlIO perlsh A poor man's perl shell @@ -1275,6 +1306,7 @@ sv.h Scalar value header t/README Instructions for regression tests t/TEST The regression tester t/UTEST Run regression tests with -Mutf8 +t/base/commonsense.t See if configuration meets basic needs t/base/cond.t See if conditionals work t/base/if.t See if if works t/base/lex.t See if lexical items work @@ -1314,6 +1346,7 @@ t/io/pipe.t See if secure pipes work t/io/print.t See if print commands work t/io/read.t See if read works t/io/tell.t See if file seeking works +t/io/utf8.t See if file seeking works t/lib/abbrev.t See if Text::Abbrev works t/lib/ansicolor.t See if Term::ANSIColor works t/lib/anydbm.t See if AnyDBM_File works @@ -1332,6 +1365,7 @@ t/lib/cgi-pretty.t See if CGI.pm works t/lib/cgi-request.t See if CGI.pm works t/lib/charnames.t See if character names work t/lib/checktree.t See if File::CheckTree works +t/lib/class-struct.t See if Class::Struct works t/lib/complex.t See if Math::Complex works t/lib/db-btree.t See if DB_File works t/lib/db-hash.t See if DB_File works @@ -1354,9 +1388,9 @@ t/lib/dprof/test6_t Perl code profiler tests t/lib/dprof/test6_v Perl code profiler tests t/lib/dumper-ovl.t See if Data::Dumper works for overloaded data t/lib/dumper.t See if Data::Dumper works +t/lib/encode.t See if Encode works t/lib/english.t See if English works t/lib/env-array.t See if Env works for arrays -t/lib/encode.t See if Encode works t/lib/env.t See if Env works t/lib/errno.t See if Errno works t/lib/fatal.t See if Fatal works @@ -1368,6 +1402,8 @@ t/lib/filefunc.t See if File::Spec::Functions works t/lib/filehand.t See if FileHandle works t/lib/filepath.t See if File::Path works t/lib/filespec.t See if File::Spec works +t/lib/filter-util.pl See if Filter::Util::Call works +t/lib/filter-util.t See if Filter::Util::Call works t/lib/findbin.t See if FindBin works t/lib/ftmp-mktemp.t See if File::Temp works t/lib/ftmp-posix.t See if File::Temp works @@ -1403,6 +1439,7 @@ t/lib/io_unix.t See if UNIX socket-related methods from IO work t/lib/io_xs.t See if XSUB methods from IO work t/lib/ipc_sysv.t See if IPC::SysV works t/lib/ndbm.t See if NDBM_File works +t/lib/net-hostent.t See if Net::hostent works t/lib/odbm.t See if ODBM_File works t/lib/opcode.t See if Opcode works t/lib/open2.t See if IPC::Open2 works @@ -1444,9 +1481,12 @@ t/lib/texttabs.t See if Text::Tabs works t/lib/textwrap.t See if Text::Wrap::wrap works t/lib/thr5005.t Test 5.005-style threading (skipped if no use5005threads) t/lib/tie-push.t Test for Tie::Array +t/lib/tie-refhash.t Test for Tie::RefHash and Tie::RefHash::Nestable +t/lib/tie-splice.t Test for Tie::Array::SPLICE t/lib/tie-stdarray.t Test for Tie::StdArray t/lib/tie-stdhandle.t Test for Tie::StdHandle t/lib/tie-stdpush.t Test for Tie::StdArray +t/lib/tie-substrhash.t Test for Tie::SubstrHash t/lib/timelocal.t See if Time::Local works t/lib/trig.t See if Math::Trig works t/op/64bitint.t See if 64 bit integers work @@ -1464,6 +1504,7 @@ t/op/chars.t See if character escapes work t/op/chop.t See if chop works t/op/closure.t See if closures work t/op/cmp.t See if the various string and numeric compare work +t/op/concat.t See if string concatenation works t/op/cond.t See if conditional expressions work t/op/context.t See if context propagation works t/op/defins.t See if auto-insert of defined() works @@ -1492,6 +1533,7 @@ t/op/inc.t See if inc/dec of integers near 32 bit limit work t/op/index.t See if index works t/op/int.t See if int works t/op/join.t See if join works +t/op/length.t See if length works t/op/lex_assign.t See if ops involving lexicals or pad temps work t/op/lfs.t See if large files work for perlio t/op/list.t See if array lists work @@ -1524,6 +1566,7 @@ t/op/regexp.t See if regular expressions work t/op/regexp_noamp.t See if regular expressions work with optimizations t/op/regmesg.t See if one can get regular expression errors t/op/repeat.t See if x operator works +t/op/reverse.t See if reverse operator works t/op/runlevel.t See if die() works from perl_call_*() t/op/sleep.t See if sleep works t/op/sort.t See if sort works @@ -1546,6 +1589,7 @@ t/op/tr.t See if tr works t/op/undef.t See if undef works t/op/universal.t See if UNIVERSAL class works t/op/unshift.t See if unshift works +t/op/utf8decode.t See if UTF-8 decoding works t/op/vec.t See if vectors work t/op/ver.t See if v-strings and the %v format flag work t/op/wantarray.t See if wantarray works @@ -1691,10 +1735,13 @@ vms/writemain.pl Generate perlmain.c from miniperlmain.c+extensions vos/Changes Changes made to port Perl to the VOS operating system vos/build.cm VOS command macro to build Perl vos/compile_perl.cm VOS command macro to build multiple version of Perl -vos/config.def input for config.pl -vos/config.h config.h for VOS +vos/config.alpha.def definitions used by config.pl +vos/config.alpha.h config.h for use with alpha VOS POSIX.1 support +vos/config.ga.def definitions used by config.pl +vos/config.ga.h config.h for use with generally-available VOS POSIX.1 support vos/config.pl script to convert a config_h.SH to a config.h -vos/config_h.SH_orig config_h.SH at the time config.h was created +vos/configure_perl.cm VOS command macro to configure perl before building +vos/install_perl.cm VOS command macro to install perl after building vos/perl.bind VOS bind control file vos/test_vos_dummies.c Test program for "vos_dummies.c" vos/vos_dummies.c Wrappers to soak up undefined functions @@ -1703,6 +1750,7 @@ warnings.h The warning numbers warnings.pl Program to write warnings.h and lib/warnings.pm win32/Makefile Win32 makefile for NMAKE (Visual C++ build) win32/bin/exetype.pl Set executable type to CONSOLE or WINDOWS +win32/bin/mdelete.bat multifile delete win32/bin/perlglob.pl Win32 globbing win32/bin/pl2bat.pl wrap perl scripts into batch files win32/bin/runperl.pl run perl script via batch file namesake @@ -1716,6 +1764,7 @@ win32/config_H.vc Win32 config header (Visual C++ build) win32/config_h.PL Perl code to convert Win32 config.sh to config.h win32/config_sh.PL Perl code to update Win32 config.sh from Makefile win32/des_fcrypt.patch Win32 port +win32/distclean.bat Remove _ALL_ files not listed here in MANIFEST win32/dl_win32.xs Win32 port win32/genmk95.pl Perl code to generate command.com-usable makefile.95 win32/include/arpa/inet.h Win32 port diff --git a/Makefile.SH b/Makefile.SH index 5418fc4..d0b5465 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -137,6 +137,7 @@ CLDFLAGS = $ldflags mallocsrc = $mallocsrc mallocobj = $mallocobj LNS = $lns +CPS = $cp -f RMS = rm -f ranlib = $ranlib @@ -300,9 +301,13 @@ utilities: miniperl lib/Config.pm $(plextract) lib/lib.pm FORCE FORCE: @sh -c true -opmini$(OBJ_EXT): op.c +# We do a copy of the op.c instead of a symlink because gcc gets huffy +# if we have a symlink forest to another disk (it complains about too many +# levels of symbolic links, even if we have only two) + +opmini$(OBJ_EXT): op.c config.h $(RMS) opmini.c - $(LNS) op.c opmini.c + $(CPS) op.c opmini.c $(CCCMD) $(PLDLFLAGS) -DPERL_EXTERNAL_GLOB opmini.c $(RMS) opmini.c @@ -324,14 +329,6 @@ ext.libs: $(static_ext) !NO!SUBS! -# if test -f .patch ; then $spitshell >>Makefile <<'!NO!SUBS!' -# patchlevel.h: .patch -# perl fix_pl || (make -f Makefile.micro && ./microperl fix_pl) -# $(SHELL) Makefile.SH -# fi -# -# !NO!SUBS! - # How to build libperl. This is still rather convoluted. # Load up custom Makefile.SH fragment for shared loading and executables: case "$osname" in @@ -600,7 +597,7 @@ install.html: all installhtml run_byacc: FORCE $(BYACC) -d perly.y - -chmod 664 perly.c + -chmod 664 perly.c perly.h sh $(shellflags) ./perly.fixer y.tab.c perly.c sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \ -e 's/y\.tab/perly/g' perly.c >perly.tmp && mv perly.tmp perly.c @@ -618,6 +615,11 @@ perly.c: perly.y perly.h: perly.y -@sh -c true +PERLYVMS = vms/perly_c.vms vms/perly_h.vms + +$(PERLYVMS): perly.c perly.h vms/vms_yfix.pl + perl vms/vms_yfix.pl perly.c perly.h vms/perly_c.vms vms/perly_h.vms + # No compat3.sym here since and including the 5.004_50. # No interp.sym since 5.005_03. SYM = global.sym globvar.sym perlio.sym pp.sym @@ -642,6 +644,31 @@ CHMOD_W = chmod +w # To force them to be regenerated, type # make regen_headers +keywords.h: keywords.pl + -perl keywords.pl + +OPCODE_PL_OUTPUT = opcode.h opnames.h pp_proto.h pp.sym + +$(OPCODE_PL_OUTPUT): opcode.pl + -perl opcode.pl + +# Really the prerequisites for the next rule should only be "embed.pl pp.sym" +# Writing it this way gives make a big hint to always run opcode.pl before +# embed.pl. The alternative - running embed.pl then opcode.pl causes embed.pl +# to be re-run next make invocation, and then all object files get recompiled. + +proto.h embed.h embedvar.h global.sym objXSUB.h perlapi.h perlapi.c pod/perlintern.pod pod/perlapi.pod: embed.pl $(OPCODE_PL_OUTPUT) + -perl embed.pl + +ext/ByteLoader/byterun.h ext/ByteLoader/byterun.c ext/B/B/Asmdata.pm: bytecode.pl + -perl bytecode.pl + +regnodes.h: regcomp.pl + -perl regcomp.pl + +warnings.h lib/warnings.pm: warnings.pl + -perl warnings.pl + AUTOGEN_FILES = keywords.h opcode.h opnames.h pp_proto.h pp.sym proto.h \ embed.h embedvar.h global.sym \ pod/perlintern.pod pod/perlapi.pod \ @@ -661,6 +688,8 @@ regen_headers: FORCE regen_pods: FORCE -cd pod; $(LDLIBPTH) make regen_pods +regen_all: $(PERLYVMS) regen_headers regen_pods + # Extensions: # Names added to $(dynamic_ext) or $(static_ext) or $(nonxs_ext) will # automatically get built. There should ordinarily be no need to change @@ -734,11 +763,11 @@ _cleaner2: rm -f $(FIRSTMAKEFILE) $(FIRSTMAKEFILE).old rm -f $(private) rm -rf lib/auto - rm -f lib/.exists lib/*/.exists + rm -f lib/.exists lib/*/.exists lib/*/*/.exists rm -f h2ph.man pstruct rm -rf .config rm -f testcompile compilelog - -rmdir lib/B lib/Data lib/Encode lib/IO/Socket lib/IO lib/Sys lib/Thread + -rmdir lib/B lib/Data lib/Encode lib/IO/Socket lib/IO lib/Filter/Util lib/Sys lib/Thread _realcleaner: @$(LDLIBPTH) $(MAKE) _cleaner1 CLEAN=realclean @@ -823,12 +852,24 @@ ok: utilities okfile: utilities $(LDLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' -F perl.ok +oknack: utilities + $(LDLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' -A + +okfilenack: utilities + $(LDLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' -F perl.ok -A + nok: utilities $(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)' nokfile: utilities $(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)' -F perl.nok +noknack: utilities + $(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)' -A + +nokfilenack: utilities + $(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)' -F perl.nok -A + clist: $(c) echo $(c) | tr ' ' $(TRNL) >.clist diff --git a/Porting/Contract b/Porting/Contract index cc91af2..2b619fd 100644 --- a/Porting/Contract +++ b/Porting/Contract @@ -19,7 +19,7 @@ community, mutual respect, trust, and good-faith cooperation. We recognize that the Perl core, defined as the software distributed with the heart of Perl itself, is a joint project on the part of all of us. ->From time to time, a script, module, or set of modules (hereafter referred +From time to time, a script, module, or set of modules (hereafter referred to simply as a "module") will prove so widely useful and/or so integral to the correct functioning of Perl itself that it should be distributed with Perl core. This should never be done without the author's explicit diff --git a/Porting/Glossary b/Porting/Glossary index 1b93821..0095ef1 100644 --- a/Porting/Glossary +++ b/Porting/Glossary @@ -340,6 +340,10 @@ csh (Loc.U): full pathname (if any) of the csh program. After Configure runs, the value is reset to a plain "csh" and is not useful. +d__fwalk (d__fwalk.U): + This variable conditionally defines HAS__FWALK if _fwalk() is + available to apply a function to all the file handles. + d_access (d_access.U): This variable conditionally defines HAS_ACCESS if the access() system call is available to check for access permissions using real IDs. @@ -545,6 +549,10 @@ d_fcntl (d_fcntl.U): This variable conditionally defines the HAS_FCNTL symbol, and indicates whether the fcntl() function exists +d_fcntl_can_lock (d_fcntl_can_lock.U): + This variable conditionally defines the FCNTL_CAN_LOCK symbol + and indicates whether file locking with fcntl() works. + d_fd_macros (d_fd_set.U): This variable contains the eventual value of the HAS_FD_MACROS symbol, which indicates if your C compiler knows about the macros which @@ -610,6 +618,10 @@ d_fstatvfs (d_statvfs.U): This variable conditionally defines the HAS_FSTATVFS symbol, which indicates to the C program that the fstatvfs() routine is available. +d_fsync (d_fsync.U): + This variable conditionally defines the HAS_FSYNC symbol, which + indicates to the C program that the fsync() routine is available. + d_ftello (d_ftello.U): This variable conditionally defines the HAS_FTELLO symbol, which indicates to the C program that the ftello() routine is available. @@ -711,6 +723,10 @@ d_getnetprotos (d_getnetprotos.U): prototypes for the various getnet*() functions. See also netdbtype.U for probing for various netdb types. +d_getpagsz (d_getpagsz.U): + This variable conditionally defines HAS_GETPAGESIZE if getpagesize() + is available to get the system page size. + d_getpbyname (d_getprotby.U): This variable conditionally defines the HAS_GETPROTOBYNAME symbol, which indicates to the C program that the @@ -1235,6 +1251,12 @@ d_sanemcmp (d_sanemcmp.U): the memcpy() routine is available and can be used to compare relative magnitudes of chars with their high bits set. +d_sbrkproto (d_sbrkproto.U): + This variable conditionally defines the HAS_SBRK_PROTO symbol, + which indicates to the C program that the system provides + a prototype for the sbrk() function. Otherwise, it is + up to the program to supply one. + d_sched_yield (d_pthread_y.U): This variable conditionally defines the HAS_SCHED_YIELD symbol if the sched_yield routine is available to yield @@ -1478,6 +1500,15 @@ d_stdio_ptr_lval (d_stdstdio.U): This variable conditionally defines STDIO_PTR_LVALUE if the FILE_ptr macro can be used as an lvalue. +d_stdio_ptr_lval_nochange_cnt (d_stdstdio.U): + This symbol is defined if using the FILE_ptr macro as an lvalue + to increase the pointer by n leaves File_cnt(fp) unchanged. + +d_stdio_ptr_lval_sets_cnt (d_stdstdio.U): + This symbol is defined if using the FILE_ptr macro as an lvalue + to increase the pointer by n has the side effect of decreasing the + value of File_cnt(fp) by n. + d_stdio_stream_array (stdio_streams.U): This variable tells whether there is an array holding the stdio streams. @@ -1533,6 +1564,10 @@ d_strtoll (d_strtoll.U): This variable conditionally defines the HAS_STRTOLL symbol, which indicates to the C program that the strtoll() routine is available. +d_strtoq (d_strtoq.U): + This variable conditionally defines the HAS_STRTOQ symbol, which + indicates to the C program that the strtoq() routine is available. + d_strtoul (d_strtoul.U): This variable conditionally defines the HAS_STRTOUL symbol, which indicates to the C program that the strtoul() routine is available @@ -2408,6 +2443,11 @@ intsize (intsize.U): This variable contains the value of the INTSIZE symbol, which indicates to the C program how many bytes there are in an int. +issymlink (issymlink.U): + This variable holds the switch of the test command to test + for a symbolic link (if they are supported). Typical values + include '-h' and '-L'. + ivdformat (perlxvf.U): This variable contains the format string used for printing a Perl IV as a signed decimal integer. @@ -2709,6 +2749,15 @@ n (n.U): command to suppress newline. Otherwise it is null. Correct usage is $echo $n "prompt for a question: $c". +need_va_copy (need_va_copy.U): + This symbol, if defined, indicates that the system stores + the variable argument list datatype, va_list, in a format + that cannot be copied by simple assignment, so that some + other means must be used when copying is required. + As such systems vary in their provision (or non-provision) + of copying mechanisms, handy.h defines a platform- + independent macro, Perl_va_copy(src, dst), to do the job. + netdb_hlen_type (netdbtype.U): This variable holds the type used for the 2nd argument to gethostbyaddr(). Usually, this is int or size_t or unsigned. diff --git a/Porting/config.sh b/Porting/config.sh index 632c469..90e7dc5 100644 --- a/Porting/config.sh +++ b/Porting/config.sh @@ -8,7 +8,7 @@ # Package name : perl5 # Source directory : /m/fs/work/work/permanent/perl/pp4/perl -# Configuration time: Fri Oct 13 02:12:22 EET DST 2000 +# Configuration time: Thu Dec 21 18:13:27 EET 2000 # Configured by : jhi # Target system : osf1 alpha.hut.fi v4.0 878 alpha @@ -62,7 +62,7 @@ ccsymbols='__alpha=1 __LANGUAGE_C__=1 __osf__=1 __unix__=1 _LONGLONG=1 _SYSTYPE_ ccversion='V5.6-082' cf_by='jhi' cf_email='yourname@yourhost.yourplace.com' -cf_time='Fri Oct 13 02:12:22 EET DST 2000' +cf_time='Thu Dec 21 18:13:27 EET 2000' charsize='1' chgrp='' chmod='' @@ -99,6 +99,7 @@ d_PRIo64='define' d_PRIu64='define' d_PRIx64='define' d_SCNfldbl='define' +d__fwalk='undef' d_access='define' d_accessx='undef' d_alarm='define' @@ -145,6 +146,7 @@ d_eunice='undef' d_fchmod='define' d_fchown='define' d_fcntl='define' +d_fcntl_can_lock='define' d_fd_macros='define' d_fd_set='define' d_fds_bits='define' @@ -160,6 +162,7 @@ d_fseeko='undef' d_fsetpos='define' d_fstatfs='define' d_fstatvfs='define' +d_fsync='define' d_ftello='undef' d_ftime='undef' d_getcwd='define' @@ -179,6 +182,7 @@ d_getnbyaddr='define' d_getnbyname='define' d_getnent='define' d_getnetprotos='define' +d_getpagsz='define' d_getpbyname='define' d_getpbynumber='define' d_getpent='define' @@ -282,6 +286,7 @@ d_rmdir='define' d_safebcpy='define' d_safemcpy='undef' d_sanemcmp='define' +d_sbrkproto='define' d_sched_yield='define' d_scm_rights='define' d_seekdir='define' @@ -336,6 +341,8 @@ d_statfs_s='define' d_statvfs='define' d_stdio_cnt_lval='define' d_stdio_ptr_lval='define' +d_stdio_ptr_lval_nochange_cnt='define' +d_stdio_ptr_lval_sets_cnt='undef' d_stdio_stream_array='define' d_stdiobase='define' d_stdstdio='define' @@ -348,6 +355,7 @@ d_strtod='define' d_strtol='define' d_strtold='undef' d_strtoll='undef' +d_strtoq='undef' d_strtoul='define' d_strtoull='undef' d_strtouq='undef' @@ -394,7 +402,7 @@ dlext='so' dlsrc='dl_dlopen.xs' doublesize='8' drand01='drand48()' -dynamic_ext='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re' +dynamic_ext='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob Filter/Util/Call IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re' eagain='EAGAIN' ebcdic='undef' echo='echo' @@ -403,7 +411,7 @@ emacs='' eunicefix=':' exe_ext='' expr='expr' -extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re Errno' +extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob Filter/Util/Call IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re Errno' fflushNULL='define' fflushall='undef' find='' @@ -539,10 +547,11 @@ installvendorarch='' installvendorbin='' installvendorlib='' intsize='4' +issymlink='-h' ivdformat='"ld"' ivsize='8' ivtype='long' -known_extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob GDBM_File IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re' +known_extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob Filter/Util/Call GDBM_File IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re' ksh='' ld='ld' lddlflags='-shared -expect_unresolved "*" -msym -std -s' @@ -601,6 +610,7 @@ mydomain='.yourplace.com' myhostname='yourhost' myuname='osf1 alpha.hut.fi v4.0 878 alpha ' n='' +need_va_copy='undef' netdb_hlen_type='int' netdb_host_type='const char *' netdb_name_type='const char *' diff --git a/Porting/config_H b/Porting/config_H index 149760c..039ed25 100644 --- a/Porting/config_H +++ b/Porting/config_H @@ -17,7 +17,7 @@ /* * Package name : perl5 * Source directory : /m/fs/work/work/permanent/perl/pp4/perl - * Configuration time: Fri Oct 13 02:12:22 EET DST 2000 + * Configuration time: Thu Dec 21 18:13:27 EET 2000 * Configured by : jhi * Target system : osf1 alpha.hut.fi v4.0 878 alpha */ @@ -585,12 +585,6 @@ */ #define HAS_STRTOL /**/ -/* HAS_STRTOUL: - * This symbol, if defined, indicates that the strtoul routine is - * available to provide conversion of strings to unsigned long. - */ -#define HAS_STRTOUL /**/ - /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. @@ -961,12 +955,6 @@ */ #define SH_PATH "/bin/sh" /**/ -/* STDCHAR: - * This symbol is defined to be the type of char used in stdio.h. - * It has the values "unsigned char" or "char". - */ -#define STDCHAR unsigned char /**/ - /* CROSSCOMPILE: * This symbol, if defined, signifies that we our * build process is a cross-compilation. @@ -1208,6 +1196,12 @@ #define CPPRUN "/usr/bin/cpp" #define CPPLAST "" +/* HAS__FWALK: + * This symbol, if defined, indicates that the _fwalk system call is + * available to apply a function to all the file handles. + */ +/*#define HAS__FWALK / **/ + /* HAS_ACCESS: * This manifest constant lets the C program know that the access() * system call is available to check for accessibility using real UID/GID. @@ -1305,6 +1299,13 @@ */ #define HAS_ENDSERVENT /**/ +/* FCNTL_CAN_LOCK: + * This symbol, if defined, indicates that fcntl() can be used + * for file locking. Normally on Unix systems this is defined. + * It may be undefined on VMS. + */ +#define FCNTL_CAN_LOCK /**/ + /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in @@ -1347,6 +1348,13 @@ */ #define HAS_FSTATFS /**/ +/* HAS_FSYNC: + * This symbol, if defined, indicates that the fsync routine is + * available to write a file's modified data and attributes to + * permanent storage. + */ +#define HAS_FSYNC /**/ + /* HAS_FTELLO: * This symbol, if defined, indicates that the ftello routine is * available to ftell beyond 32 bits (useful for ILP32 hosts). @@ -1487,12 +1495,30 @@ */ #define HAS_GETNET_PROTOS /**/ +/* HAS_GETPAGESIZE: + * This symbol, if defined, indicates that the getpagesize system call + * is available to get system page size, which is the granularity of + * many memory management calls. + */ +#define HAS_GETPAGESIZE /**/ + /* HAS_GETPROTOENT: * This symbol, if defined, indicates that the getprotoent() routine is * available to look up protocols in some data base or another. */ #define HAS_GETPROTOENT /**/ +/* HAS_GETPGRP: + * This symbol, if defined, indicates that the getpgrp routine is + * available to get the current process group. + */ +/* USE_BSD_GETPGRP: + * This symbol, if defined, indicates that getpgrp needs one + * arguments whereas USG one needs none. + */ +#define HAS_GETPGRP /**/ +/*#define USE_BSD_GETPGRP / **/ + /* HAS_GETPROTOBYNAME: * This symbol, if defined, indicates that the getprotobyname() * routine is available to look up protocols by their name. @@ -1802,6 +1828,15 @@ */ #define HAS_SANE_MEMCMP /**/ +/* HAS_SBRK_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the sbrk() function. Otherwise, it is up + * to the program to supply one. Good guesses are + * extern void* sbrk _((int)); + * extern void* sbrk _((size_t)); + */ +#define HAS_SBRK_PROTO /**/ + /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. @@ -1839,6 +1874,18 @@ */ #define HAS_SETPROTOENT /**/ +/* HAS_SETPGRP: + * This symbol, if defined, indicates that the setpgrp routine is + * available to set the current process group. + */ +/* USE_BSD_SETPGRP: + * This symbol, if defined, indicates that setpgrp needs two + * arguments whereas USG one needs none. See also HAS_SETPGID + * for a POSIX interface. + */ +#define HAS_SETPGRP /**/ +#define USE_BSD_SETPGRP /**/ + /* HAS_SETPROCTITLE: * This symbol, if defined, indicates that the setproctitle routine is * available to set process title. @@ -2028,12 +2075,23 @@ * This symbol is defined if the FILE_cnt macro can be used as an * lvalue. */ +/* STDIO_PTR_LVAL_SETS_CNT: + * This symbol is defined if using the FILE_ptr macro as an lvalue + * to increase the pointer by n has the side effect of decreasing the + * value of File_cnt(fp) by n. + */ +/* STDIO_PTR_LVAL_NOCHANGE_CNT: + * This symbol is defined if using the FILE_ptr macro as an lvalue + * to increase the pointer by n leaves File_cnt(fp) unchanged. + */ #define USE_STDIO_PTR /**/ #ifdef USE_STDIO_PTR #define FILE_ptr(fp) ((fp)->_ptr) #define STDIO_PTR_LVALUE /**/ #define FILE_cnt(fp) ((fp)->_cnt) #define STDIO_CNT_LVALUE /**/ +/*#define STDIO_PTR_LVAL_SETS_CNT / **/ +#define STDIO_PTR_LVAL_NOCHANGE_CNT /**/ #endif /* USE_STDIO_BASE: @@ -2093,6 +2151,18 @@ */ /*#define HAS_STRTOLL / **/ +/* HAS_STRTOQ: + * This symbol, if defined, indicates that the strtoq routine is + * available to convert strings to long longs (quads). + */ +/*#define HAS_STRTOQ / **/ + +/* HAS_STRTOUL: + * This symbol, if defined, indicates that the strtoul routine is + * available to provide conversion of strings to unsigned long. + */ +#define HAS_STRTOUL /**/ + /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. @@ -2583,6 +2653,17 @@ #define RD_NODATA -1 #define EOF_NONBLOCK +/* NEED_VA_COPY: + * This symbol, if defined, indicates that the system stores + * the variable argument list datatype, va_list, in a format + * that cannot be copied by simple assignment, so that some + * other means must be used when copying is required. + * As such systems vary in their provision (or non-provision) + * of copying mechanisms, handy.h defines a platform- + * independent macro, Perl_va_copy(src, dst), to do the job. + */ +/*#define NEED_VA_COPY / **/ + /* Netdb_host_t: * This symbol holds the type used for the 1st argument * to gethostbyaddr(). @@ -2932,6 +3013,12 @@ */ #define STARTPERL "#!/opt/perl/bin/perl" /**/ +/* STDCHAR: + * This symbol is defined to be the type of char used in stdio.h. + * It has the values "unsigned char" or "char". + */ +#define STDCHAR unsigned char /**/ + /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array * holding the stdio streams. @@ -3150,27 +3237,4 @@ #define PERL_XS_APIVERSION "5.7.0" #define PERL_PM_APIVERSION "5.005" -/* HAS_GETPGRP: - * This symbol, if defined, indicates that the getpgrp routine is - * available to get the current process group. - */ -/* USE_BSD_GETPGRP: - * This symbol, if defined, indicates that getpgrp needs one - * arguments whereas USG one needs none. - */ -#define HAS_GETPGRP /**/ -/*#define USE_BSD_GETPGRP / **/ - -/* HAS_SETPGRP: - * This symbol, if defined, indicates that the setpgrp routine is - * available to set the current process group. - */ -/* USE_BSD_SETPGRP: - * This symbol, if defined, indicates that setpgrp needs two - * arguments whereas USG one needs none. See also HAS_SETPGID - * for a POSIX interface. - */ -#define HAS_SETPGRP /**/ -#define USE_BSD_SETPGRP /**/ - #endif diff --git a/Porting/genlog b/Porting/genlog index 218da41..627ba31 100755 --- a/Porting/genlog +++ b/Porting/genlog @@ -73,6 +73,7 @@ else { while (@desc) { my ($change,$who,$date,$time,@log,$branch,$file,$type,%files); my $skip = 0; + my $nbranch = 0; $_ = shift @desc; if (/^Change (\d+) by (\w+)\@.+ on (\S+) (\S+)\s*$/) { ($change, $who, $date, $time) = ($1,$2,$3,$4); @@ -88,6 +89,7 @@ else { last unless /^\.\.\./; if (m{^\.\.\. //depot/(.*?perl|[^/]*)/([^#]+)#\d+ (\w+)\s*$}) { ($branch,$file,$type) = ($1,$2,$3); + $nbranch++; if (exists $branch_exclude{$branch} or @branch_include and not exists $branch_include{$branch}) { @@ -103,7 +105,7 @@ else { } } } - next if not $change or $skip; + next if not $change; print "_" x 76, "\n"; printf <. This +and amounts to C<$revision + $version/1000 + $subversion/100000>. This can still be used in comparisons. print "You've got an old perl\n" if $] < 5.005_03; @@ -210,7 +210,7 @@ unset appropriate Configure variables, based on the Configure command line options and possibly existing config.sh and Policy.sh files from previous Configure runs. -The extension hints are written Perl (by the time they are used +The extension hints are written in Perl (by the time they are used miniperl has been built) and control the building of their respective extensions. They can be used to for example manipulate compilation and linking flags. @@ -252,7 +252,8 @@ the first B to have a system call also update the list of A file called F at the top level that explains things like how to install perl at this platform, where to get any possibly required additional software, and for example what test suite errors -to expect, is nice too. +to expect, is nice too. Such files are in the process of being written +in pod format and will eventually be renamed F. You may also want to write a separate F<.pod> file for your operating system to tell about existing mailing lists, os-specific modules, @@ -449,7 +450,9 @@ safely be sorted, so it's easy to track (typically very small) changes to config.sh and then propoagate them to a canned 'config.h' by any number of means, including a perl script in win32/ or carrying config.sh and config_h.SH to a Unix system and running sh -config_h.SH.) +config_h.SH.) Vms uses configure.com to generate its own config.sh +and config.h. If you want to add a new variable to config.sh check +with vms folk how to add it to configure.com too. XXX] The Porting/config.sh and Porting/config_H files are provided to @@ -460,7 +463,7 @@ distinguish the file from config.h even on case-insensitive file systems.) Simply edit the existing config_H file; keep the first few explanatory lines and then copy your new config.h below. -It may also be necessary to update win32/config.?c, vms/config.vms and +It may also be necessary to update win32/config.?c, and plan9/config.plan9, though you should be quite careful in doing so if you are not familiar with those systems. You might want to issue your patch with a promise to quickly issue a follow-up that handles those @@ -481,8 +484,10 @@ output statements mean the patch won't apply cleanly. Long ago I started to fix F to detect this, but I never completed the task. -If C changes, make sure you run C to -update the corresponding VMS files. See L. +If C or C changes, make sure you run C +to update the corresponding VMS files. This could be taken care of by +the regen_all target in the Unix Makefile. See also +L. Some additional notes from Larry on this: @@ -507,6 +512,11 @@ could be automated, but it doesn't happen very often nowadays. Larry +=head2 make regen_all + +This target takes care of the PERLYVMS, regen_headers, and regen_pods +targets. + =head2 make regen_headers The F, F, and F files are all automatically @@ -532,6 +542,10 @@ and effort by manually running C myself rather than answering all the questions and complaints about the failing command. +=head2 make regen_pods + +Will run `make regen_pods` in the pod directory for indexing. + =head2 global.sym, interp.sym and perlio.sym Make sure these files are up-to-date. Read the comments in these @@ -541,7 +555,7 @@ files and in perl_exp.SH to see what to do. If you do change F or F, think carefully about what you are doing. To the extent reasonable, we'd like to maintain -souce and binary compatibility with older releases of perl. That way, +source and binary compatibility with older releases of perl. That way, extensions built under one version of perl will continue to work with new versions of perl. @@ -594,11 +608,11 @@ things that need to be fixed in Configure. =head2 VMS-specific updates If you have changed F or F, then you most probably want -to update F by running C. +to update F by running C, or +by running `make regen_all` which will run that script for you. -The Perl version number appears in several places under F. -It is courteous to update these versions. For example, if you are -making 5.004_42, replace "5.00441" with "5.00442". +The Perl revision number appears as "perl5" in configure.com. +It is courteous to update that if necessary. =head2 Making the new distribution @@ -1353,7 +1367,8 @@ have good reason to do otherwise, I see no reason not to support them. =item File locking Somehow, straighten out, document, and implement lockf(), flock(), -and/or fcntl() file locking. It's a mess. +and/or fcntl() file locking. It's a mess. See $d_fcntl_can_lock +in recent config.sh files though. =back diff --git a/Porting/repository.pod b/Porting/repository.pod new file mode 100644 index 0000000..5f1338d --- /dev/null +++ b/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/README b/README index b828893..28c5de8 100644 --- a/README +++ b/README @@ -1,7 +1,7 @@ Perl Kit, Version 5.0 - Copyright 1989-2000, Larry Wall + Copyright 1989-2001, Larry Wall All rights reserved. This program is free software; you can redistribute it and/or modify diff --git a/README.aix b/README.aix index 6346a18..bf83535 100644 --- a/README.aix +++ b/README.aix @@ -8,13 +8,13 @@ README.aix - Perl version 5 on IBM Unix (AIX) systems =head1 DESCRIPTION -This document describes various features of IBM's Unix operating system -(AIX) that will affect how Perl version 5 (hereafter just Perl) is -compiled and/or runs. +This document describes various features of IBM's Unix operating +system (AIX) that will affect how Perl version 5 (hereafter just Perl) +is compiled and/or runs. =head2 Compiling Perl 5 on AIX -When compiling Perl, you must use an ANSI C compiler. AIX does not shif +When compiling Perl, you must use an ANSI C compiler. AIX does not ship an ANSI compliant C-compiler with AIX by default, but binary builds of gcc for AIX are widely available. @@ -26,8 +26,8 @@ upgrade to the latest available patch level. Currently: xlC.C 3.1.4.0 vac.C 4.4.0.3 (5.0 is already available) -Perl can be compiled with either IBM's ANSI C compiler or with gcc. The -former is recommended, as not only can it compile Perl with no +Perl can be compiled with either IBM's ANSI C compiler or with gcc. +The former is recommended, as not only can it compile Perl with no difficulty, but also can take advantage of features listed later that require the use of IBM compiler-specific command-line flags. @@ -39,7 +39,7 @@ details. Before installing the patches to the IBM C-compiler you need to know the level of patching for the Operating System. IBM's command 'oslevel' will -show the base, but is not allways complete: +show the base, but is not always complete: # oslevel 4.3.0.0 @@ -52,7 +52,7 @@ show the base, but is not allways complete: AIX supports dynamically loadable libraries (shared libraries). Shared libraries end with the suffix .a, which is a bit misleading, -cause *all* libraries are shared ;-). +because *all* libraries are shared ;-). =head2 The IBM ANSI C Compiler @@ -61,12 +61,86 @@ All defaults for Configure can be used. If you've chosen to use vac 4, be sure to run 4.4.0.3. Older versions will turn up nasty later on. +Here's a brief lead of how to upgrade the compiler to the latest +level. Of course this is subject to changes. You can only upgrade +versions from ftp-available updates if the first three digit groups +are the same (in where you can skip intermediate unlike the patches +in the developer snapshots of perl), or to one version up where the +`base' is available. In other words, the AIX compiler patches are +cumulative. + + vac.C.4.4.0.1 => vac.C.4.4.0.3 is OK (vac.C.4.4.0.2 not needed) + xlC.C.3.1.3.3 => xlC.C.3.1.4.10 is NOT OK (xlC.C.3.1.4.0 is not available) + + # ftp ftp.software.ibm.com + Connected to service.boulder.ibm.com. + : welcome message ... + Name (ftp.software.ibm.com:merijn): anonymous + 331 Guest login ok, send your complete e-mail address as password. + Password: + ... accepted login stuff + ftp> cd /aix/fixes/v4/ + ftp> dir other other.ll + output to local-file: other.ll? y + 200 PORT command successful. + 150 Opening ASCII mode data connection for /bin/ls. + 226 Transfer complete. + ftp> dir xlc xlc.ll + output to local-file: xlc.ll? y + 200 PORT command successful. + 150 Opening ASCII mode data connection for /bin/ls. + 226 Transfer complete. + ftp> bye + ... goodbye messages + # ls -l *.ll + -rw-rw-rw- 1 merijn system 1169432 Nov 2 17:29 other.ll + -rw-rw-rw- 1 merijn system 29170 Nov 2 17:29 xlc.ll + +On AIX 4.2 using xlC, we continue: + + # lslpp -l | fgrep 'xlC.C ' + xlC.C 3.1.4.9 COMMITTED C for AIX Compiler + xlC.C 3.1.4.0 COMMITTED C for AIX Compiler + # grep 'xlC.C.3.1.4.*.bff' xlc.ll + -rw-r--r-- 1 45776101 1 6286336 Jul 22 1996 xlC.C.3.1.4.1.bff + -rw-rw-r-- 1 45776101 1 6173696 Aug 24 1998 xlC.C.3.1.4.10.bff + -rw-r--r-- 1 45776101 1 6319104 Aug 14 1996 xlC.C.3.1.4.2.bff + -rw-r--r-- 1 45776101 1 6316032 Oct 21 1996 xlC.C.3.1.4.3.bff + -rw-r--r-- 1 45776101 1 6315008 Dec 20 1996 xlC.C.3.1.4.4.bff + -rw-rw-r-- 1 45776101 1 6178816 Mar 28 1997 xlC.C.3.1.4.5.bff + -rw-rw-r-- 1 45776101 1 6188032 May 22 1997 xlC.C.3.1.4.6.bff + -rw-rw-r-- 1 45776101 1 6191104 Sep 5 1997 xlC.C.3.1.4.7.bff + -rw-rw-r-- 1 45776101 1 6185984 Jan 13 1998 xlC.C.3.1.4.8.bff + -rw-rw-r-- 1 45776101 1 6169600 May 27 1998 xlC.C.3.1.4.9.bff + # wget ftp://ftp.software.ibm.com/aix/fixes/v4/xlc/xlC.C.3.1.4.10.bff + # + +On AIX 4.3 using vac, we continue: + + # lslpp -l | fgrep 'vac.C ' + vac.C 4.4.0.2 COMMITTED C for AIX Compiler + vac.C 4.4.0.0 COMMITTED C for AIX Compiler + # grep 'vac.C.4.4.0.*.bff' other.ll + -rw-rw-r-- 1 45776101 1 13466624 May 26 1999 vac.C.4.4.0.1.bff + -rw-rw-r-- 1 45776101 1 13473792 Aug 31 1999 vac.C.4.4.0.2.bff + -rw-rw-r-- 1 45776101 1 13480960 May 19 20:32 vac.C.4.4.0.3.bff + # wget ftp://ftp.software.ibm.com/aix/fixes/v4/other/vac.C.4.4.0.3.bff + # + +Then execute the following command, and fill in its choices + + # smit install_update + -> Install and Update from LATEST Available Software + * INPUT device / directory for software [ vac.C.4.4.0.3.bff ] + [ OK ] + [ OK ] + +Follow the messages ... and you're done. + =head2 Using GNU's gcc for building perl ... ? -Wait, I'll have to scan perlbug ... - =head2 Using Large Files with Perl ... ? diff --git a/README.amiga b/README.amiga index 8951f35..3b2a1bd 100644 --- a/README.amiga +++ b/README.amiga @@ -4,18 +4,10 @@ specially designed to be readable as is. =head1 NAME -perlamiga - Perl under Amiga OS (possibly very outdated information) +perlamiga - Perl under Amiga OS =head1 SYNOPSIS -NOTE: No one has reported building Perl on the Amiga in a long -time. The following information is highly unlikely to be correct. -If you would like to help the Amiga port to stay current, see: - - http://us.aminet.net/aminet/dirs/dev_gg.html - -for Amiga resources and information. - One can read this document in the following formats: man perlamiga @@ -24,6 +16,11 @@ One can read this document in the following formats: to list some (not all may be available simultaneously), or it may be read I: either as F, or F. +A recent version of perl for the Amiga can be found at the Geek Gadgets +section of the Aminet: + + http://www.aminet.net/~aminet/dirs/dev_gg.html + =cut Contents @@ -61,16 +58,12 @@ Contents =item B You need the Unix emulation for AmigaOS, whose most important part is -B. For a minimum setup, get the following archives from -ftp://ftp.ninemoons.com/pub/ade/current or a mirror: +B. For a minimum setup, get the latest versions +of the following packages from the Aminet archives (http://www.aminet.net/~aminet/): -ixemul-46.0-bin.lha -ixemul-46.0-env-bin.lha -pdksh-4.9-bin.lha -ADE-misc-bin.lha - -Note that there might be newer versions available by the time you read -this. + ixemul-bin + ixemul-env-bin + pdksh-bin Note also that this is a minimum setup; you might want to add other packages of B (the I). @@ -108,16 +101,24 @@ easier to use your script under *nix.) Perl under AmigaOS lacks some features of perl under UNIX because of deficiencies in the UNIX-emulation, most notably: -=over 6 +=over 4 + +=item * + +fork() -=item fork() +=item * -=item some features of the UNIX filesystem regarding link count and file dates +some features of the UNIX filesystem regarding link count and file dates -=item inplace operation (the -i switch) without backup file +=item * -=item umask() works, but the correct permissions are only set when the file is - finally close()d +inplace operation (the -i switch) without backup file + +=item * + +umask() works, but the correct permissions are only set when the file is +finally close()d =back @@ -126,11 +127,11 @@ deficiencies in the UNIX-emulation, most notably: Change to the installation directory (most probably ADE:), and extract the binary distribution: -lha -mraxe x perl-5.003-bin.lha +lha -mraxe x perl-$VERSION-bin.lha or -tar xvzpf perl-5.003-bin.tgz +tar xvzpf perl-$VERSION-bin.tgz (Of course you need lha or tar and gunzip for this.) @@ -189,16 +190,15 @@ Here we discuss how to build Perl under AmigaOS. =head2 Prerequisites -You need to have the latest B (Amiga Developers Environment) -from ftp://ftp.ninemoons.com/pub/ade/current. -Also, you need a lot of free memory, probably at least 8MB. +You need to have the latest B (Unix emulation for Amiga) +from Aminet. =head2 Getting the perl source You can either get the latest perl-for-amiga source from Ninemoons and extract it with: - tar xvzpf perl-5.004-src.tgz + tar xvzpf perl-$VERSION-src.tgz or get the official source from CPAN: @@ -206,7 +206,7 @@ or get the official source from CPAN: Extract it like this - tar xvzpf perl5.004.tar.gz + tar xvzpf perl-$VERSION.tar.gz You will see a message about errors while extracting F. This is normal and expected. (There is a conflict with a similarly-named file @@ -214,12 +214,60 @@ F, but it causes no harm.) =head2 Making - sh configure.gnu --prefix=/ade +=over 4 + +=item * + +remember to use a healthy sized stack (I used 2000000) + +=item * + +your PATH environment variable must include /bin (e.g. ".:/bin" is good) +(or, more precisely, it must include the directory where you have your +basic UNIX utilities like test, cat, sed, and so on) + +=item * + + sh Configure -Dprefix=/ade -Dloclibpth=/ade/lib -Now +=item * + +fix makedepend + + In the file 'makedepend' there are three spots like this `$cat ...`: + a for loop near line 75, an egrep near line 161, and a for loop near + line 175. In all those spots using an editor change the $cat to + /bin/cat. + +=item * + +now type make depend + + When the make depend has ended load the gnumakefile into + an editor and go to the end of the file. + + Move upwards in the file until you reach av.o: EXTERN.h + and delete all lines down to # WARNING: Put.... + +=item * + +now go to the x2p directory + + Load the gnumakefile into an editor. + + Go to the end moveup until you reach hash.o: EXTERN.h + and delete all lines dowonwards until you reach a line saying + + # WARNING: Put nothing.... + +=item * + +Now! make +=back + =head2 Testing Now run @@ -237,9 +285,10 @@ Run make install -=head1 AUTHOR +=head1 AUTHORS Norbert Pueschel, pueschel@imsdd.meb.uni-bonn.de +Jan-Erik Karlsson, trg@privat.utfors.se =head1 SEE ALSO diff --git a/README.cygwin b/README.cygwin index 9718bb5..6264a15 100644 --- a/README.cygwin +++ b/README.cygwin @@ -27,11 +27,11 @@ platforms. They run thanks to the Cygwin library which provides the UNIX system calls and environment these programs expect. More information about this project can be found at: - http://sources.redhat.com/cygwin/ + http://www.cygwin.com/ A recent net or commercial release of Cygwin is required. -At the time this document was last updated, Cygwin 1.1.4 was current. +At the time this document was last updated, Cygwin 1.1.5 was current. B At this point, minimal effort has been made to provide compatibility with old (beta) Cygwin releases. The focus has been to @@ -253,14 +253,6 @@ closed pipe. You will see the following messages: At least for consistency with WinNT, you should keep the recommended value. -=item * Checking how std your stdio is... - -Configure reports: - - Your stdio doesn't appear very std. - -This is correct. - =item * Compiler/Preprocessor defines The following error occurs because of the Cygwin C<#define> of @@ -500,12 +492,11 @@ be kept as clean as possible. =item Documentation - INSTALL README.cygwin + INSTALL README.cygwin README.win32 MANIFEST Changes Changes5.005 Changes5.004 Changes5.6 - AUTHORS MAINTAIN MANIFEST README.win32 - pod/buildtoc.PL pod/perl.pod pod/perl5004delta.pod pod/perl56delta.pod - pod/perlfaq3.pod pod/perlhist.pod pod/perlmodlib.pod pod/perlport.pod - pod/perltoc.pod + pod/perl.pod pod/perlport.pod pod/perlfaq3.pod + pod/perldelta.pod pod/perl5004delta.pod pod/perl56delta.pod + pod/perlhist.pod pod/perlmodlib.pod pod/buildtoc.PL pod/perltoc.pod =item Build, Configure, Make, Install @@ -543,9 +534,7 @@ be kept as clean as possible. perl.h - binmode doio.c - win9x can not rename a file when it is open pp_sys.c - do not define h_errno, pp_system with spawn - mg.c - environ WORKAROUND - unixish.h - environ WORKAROUND - util.c - environ WORKAROUND + util.c - use setenv =item Compiled Module Source @@ -585,10 +574,14 @@ On WinNT Cygwin provides setuid(), seteuid(), setgid() and setegid(). However, additional Cygwin calls for manipulating WinNT access tokens and security contexts are required. +When building DLLs, `C' is used to export +global symbols. It might be better to generate an explicit F<.def> file +(see F). Also, DLLs can now be build with `C'. + =head1 AUTHORS Charles Wilson , -Eric Fifer , +Eric Fifer , alexander smishlajev , Steven Morlock , Sebastien Barre , @@ -596,4 +589,4 @@ Teun Burgers . =head1 HISTORY -Last updated: 15 August 2000 +Last updated: 9 November 2000 diff --git a/README.dos b/README.dos index 51cd1d6..fe649ed 100644 --- a/README.dos +++ b/README.dos @@ -9,7 +9,7 @@ perldos - Perl under DOS, W31, W95. =head1 SYNOPSIS These are instructions for building Perl under DOS (or w??), using -DJGPP v2.01 or later. Under w95 long filenames are supported. +DJGPP v2.03 or later. Under w95 long filenames are supported. =head1 DESCRIPTION @@ -22,6 +22,10 @@ This port currently supports MakeMaker (the set of modules that is used to build extensions to perl). Therefore, you should be able to build and install most extensions found in the CPAN sites. +Detailed instructions on how to build and install perl extension +modules, including XS-type modules, is included. See 'BUILDING AND +INSTALLING MODULES'. + =head2 Prerequisites =over 4 @@ -46,19 +50,19 @@ the world. Like: You need the following files to build perl (or add new modules): - v2/djdev202.zip - v2/bnu27b.zip - v2gnu/gcc2721b.zip - v2gnu/bsh1147b.zip - v2gnu/mak3761b.zip + v2/djdev203.zip + v2/bnu2951b.zip + v2gnu/gcc2952b.zip + v2gnu/bsh204b.zip + v2gnu/mak3791b.zip v2gnu/fil316b.zip - v2gnu/sed118b.zip - v2gnu/txt122b.zip - v2gnu/dif271b.zip - v2gnu/grep21b.zip + v2gnu/sed302b.zip + v2gnu/txt20b.zip + v2gnu/dif272b.zip + v2gnu/grep24b.zip v2gnu/shl112b.zip v2gnu/gawk303b.zip - v2misc/csdpmi4b.zip + v2misc/csdpmi4b.zip or possibly any newer version. @@ -104,7 +108,7 @@ to use long file names under w95 and also to get Perl to pass all its tests, don't forget to use set LFN=y - set FNCASE=y + set FNCASE=y before unpacking the archive. @@ -115,6 +119,9 @@ directory. ln -s bash.exe sh.exe +[If you have the recommended version of bash for DJGPP, this is already +done for you.] + And make the C environment variable point to this F: set SHELL=c:/djgpp/bin/sh.exe (use full path name!) @@ -131,20 +138,34 @@ F to F, and F to F. Copy or link F to F if you don't have F. Copy or link F to F if you don't have F. +[If you have the recommended versions of djdev, shell utilities and +gawk, all these are already done for you, and you will not need to do +anything.] + =item * Chdir to the djgpp subdirectory of perl toplevel and type the following -command: +commands: + set FNCASE=y configure.bat This will do some preprocessing then run the Configure script for you. -The Configure script is interactive, but in most cases you -just need to press ENTER. +The Configure script is interactive, but in most cases you just need to +press ENTER. The "set" command ensures that DJGPP preserves the letter +case of file names when reading directories. If you already issued this +set command when unpacking the archive, and you are in the same DOS +session as when you unpacked the archive, you don't have to issue the +set command again. This command is necessary *before* you start to +(re)configure or (re)build perl in order to ensure both that perl builds +correctly and that building XS-type modules can succeed. See the DJGPP +info entry for "_preserve_fncase" for more information: + + info libc alphabetical _preserve_fncase If the script says that your package is incomplete, and asks whether to continue, just answer with Y (this can only happen if you don't use -long filenames). +long filenames or forget to issue "set FNCASE=y" first). When Configure asks about the extensions, I suggest IO and Fcntl, and if you want database handling then SDBM_File or GDBM_File @@ -203,9 +224,106 @@ directory structure. Perl.exe and the utilities go into C<($DJDIR)/bin>, and the library goes under C<($DJDIR)/lib/perl5>. The pod documentation goes under C<($DJDIR)/lib/perl5/pod>. +=head1 BUILDING AND INSTALLING MODULES + + +=head2 Prerequisites + +For building and installing non-XS modules, all you need is a working +perl under DJGPP. Non-XS modules do not require re-linking the perl +binary, and so are simpler to build and install. + +XS-type modules do require re-linking the perl binary, because part of +an XS module is written in "C", and has to be linked together with the +perl binary to be executed. This is required because perl under DJGPP +is built with the "static link" option, due to the lack of "dynamic +linking" in the DJGPP environment. + +Because XS modules require re-linking of the perl binary, you need both +the perl binary distribution and the perl source distribution to build +an XS extension module. In addition, you will have to have built your +perl binary from the source distribution so that all of the components +of the perl binary are available for the required link step. + +=head2 Unpacking CPAN Modules + +First, download the module package from CPAN (e.g., the "Comma Separated +Value" text package, Text-CSV-0.01.tar.gz). Then expand the contents of +the package into some location on your disk. Most CPAN modules are +built with an internal directory structure, so it is usually safe to +expand it in the root of your DJGPP installation. Some people prefer to +locate source trees under /usr/src (i.e., C<($DJDIR)/usr/src>), but you may +put it wherever seems most logical to you, *EXCEPT* under the same +directory as your perl source code. There are special rules that apply +to modules which live in the perl source tree that do not apply to most +of the modules in CPAN. + +Unlike other DJGPP packages, which are normal "zip" files, most CPAN +module packages are "gzipped tarballs". Recent versions of WinZip will +safely unpack and expand them, *UNLESS* they have zero-length files. It +is a known WinZip bug (as of v7.0) that it will not extract zero-length +files. + +From the command line, you can use the djtar utility provided with DJGPP +to unpack and expand these files. For example: + + C:\djgpp>djtarx -v Text-CSV-0.01.tar.gz + +This will create the new directory C<($DJDIR)/Text-CSV-0.01>, filling +it with the source for this module. + +=head2 Building Non-XS Modules + +To build a non-XS module, you can use the standard module-building +instructions distributed with perl modules. + + perl Makefile.PL + make + make test + make install + +This is sufficient because non-XS modules install only ".pm" files and +(sometimes) pod and/or man documentation. No re-linking of the perl +binary is needed to build, install or use non-XS modules. + +=head2 Building XS Modules + +To build an XS module, you must use the standard module-building +instructions distributed with perl modules *PLUS* three extra +instructions specific to the DJGPP "static link" build environment. + + set FNCASE=y + perl Makefile.PL + make + make perl + make test + make -f Makefile.aperl inst_perl MAP_TARGET=perl.exe + make install + +The first extra instruction sets DJGPP's FNCASE environment variable so +that the new perl binary which you must build for an XS-type module will +build correctly. The second extra instruction re-builds the perl binary +in your module directory before you run "make test", so that you are +testing with the new module code you built with "make". The third extra +instruction installs the perl binary from your module directory into the +standard DJGPP binary directory, C<($DJDIR)/bin>, replacing your +previous perl binary. + +Note that the MAP_TARGET value *must* have the ".exe" extension or you +will not create a "perl.exe" to replace the one in C<($DJDIR)/bin>. + +When you are done, the XS-module install process will have added information +to yout "perllocal" information telling that the perl binary has been replaced, +and what module was installed. you can view this information at any time +by using the command: + + perl -S perldoc perllocal + =head1 AUTHOR -Laszlo Molnar, F +Laszlo Molnar, F [Installing/building perl] + +Peter J. Farley III F [Building/installing modules] =head1 SEE ALSO diff --git a/README.epoc b/README.epoc index 06290c3..6c62565 100644 --- a/README.epoc +++ b/README.epoc @@ -1,14 +1,16 @@ -===================================================================== -Perl 5 README file for the EPOC operating system. -===================================================================== +If you read this file _as_is_, just ignore the funny characters you +see. It is written in the POD format (see pod/perlpod.pod) which is +specially designed to be readable as is. -Olaf Flebbe -http://members.linuxstart.com/~oflebbe/perl/perl5.html -2000-09-18 +=head1 NAME + +README.epoc - Perl for EPOC -===================================================================== -Introduction -===================================================================== +=head1 SYNOPSIS + +Perl 5 README file for the EPOC operating system. + +=head1 INTRODUCTION EPOC is a OS for palmtops and mobile phones. For more informations look at: http://www.symbian.com/ @@ -18,9 +20,7 @@ This is a port of perl to EPOC. It runs on the Psion Series 5, 5mx, the Psion Netbook or the S7. For information about this hardware please refer to http://www.psion.com. -===================================================================== -Installation/Usage -===================================================================== +=head1 INSTALLING PERL ON EPOC You will need ~4MB free space in order to install and run perl. @@ -40,9 +40,9 @@ you are leaving perl, you get into the system screen. You have to switch back manually to ESHELL. When perl is running, you will see a task with the name STDOUT in the task list. -====================================================================== -IO Redirection -====================================================================== +=head1 USING PERL ON EPOC + +=head2 IO Redirection You can redirect the output with the UNIX bourne shell syntax (this is built into perl rather then eshell) For instance the following command @@ -51,12 +51,10 @@ stdout_file, the errors to stderr_file and input from stdin_file. perl test.pl >stdout_file stderr_file -Alternativly you can use 2>&1 in order to add the standard error +Alternatively you can use 2>&1 in order to add the standard error output to stdout. -====================================================================== -PATH Names -====================================================================== +=head2 PATH Names ESHELL looks for executables in ?:/System/Programs. The SIS file installs perl in this special folder directory. The default drive and @@ -80,68 +78,96 @@ You can automatically search for file on all EPOC drives with a ? as the driver letter. For instance ?:\a.txt searches for C:\a.txt, D:\b.txt (and Z:\a.txt). -====================================================================== -Editors -====================================================================== +=head2 Editors A suitable text-editor can be downloaded from symbian http://developer.epocworld.com/downloads/progs/Editor.zip -==================================================================== -Features -==================================================================== +=head2 Features The built-in function EPOC::getcwd returns the current directory. -====================================================================== -Restrictions -====================================================================== +=head2 Restrictions Features are left out, because of restrictions of the POSIX support in EPOC: -+ backquoting, pipes etc. +=over 4 + +=item * + +backquoting, pipes etc. + +=item * + +system() does not inherit ressources like: file descriptors, +environment etc. + +=item * + +signal, kill, alarm. Do not try to use them. This may be +impossible to implement on EPOC. + +=item * + +select is missing. + +=item * -+ system() does not inherit ressources like: file descriptors, - environment etc. +binmode does not exist. (No CR LF to LF translation for text files) -+ signal, kill, alarm. Do not try to use them. This may be - impossible to implement on EPOC. +=item * -+ select is missing. +EPOC does not handle the notion of current drive and current +directory very well (i.e. not at all, but it tries hard to emulate +one) See PATH. -+ binmode does not exist. (No CR LF to LF translation for text files) +=item * -+ EPOC does not handle the notion of current drive and current - directory very well (i.e. not at all, but it tries hard to emulate - one) See PATH. +You need the shell eshell.exe in order to run perl.exe and supply +it with arguments. -+ You need the shell eshell.exe in order to run perl.exe and supply - it with arguments. +=item * -+ Heap is limited to 4MB. +Heap is limited to 4MB. -=================================================================== -Compiling Perl 5 on the EPOC cross compiling envionment. -=================================================================== +=back + +=head2 Compiling Perl 5 on the EPOC cross compiling environment Sorry, this is far too short. - You will need the C++ SDK from http://developer.epocworld.com/. +=over 4 + +=item * + +You will need the C++ SDK from http://developer.epocworld.com/. + +=item * + +You will need to set up the cross SDK from +http://www.science-computing.de/o.flebbe/sdk + +=item * + +You may have to adjust config.sh (cc, cppflags) for your epoc +install location. + +=item * + +You may have to adjust config.sh for your cross SDK location - You will need to set up the cross SDK from - http://members.linuxstart.com/~oflebbe +=item * - You may have to adjust config.sh (cc, cppflags) for your epoc - install location. +Get the Perl sources from your nearest CPAN site. - You may have to adjust config.sh for your cross SDK location +=item * - Get the Perl sources from your nearest CPAN site. +Unpack the sources. - Unpack the sources. +=item * - Build a native perl from this sources... +Build a native perl from this sources... cp epoc/* . ./Configure -S @@ -159,10 +185,20 @@ Sorry, this is far too short. wine G:/bin/makesis perl.pkg perl.sis +=back -==================================================================== -Support Status -==================================================================== +=head1 SUPPORT STATUS I'm offering this port "as is". You can ask me questions, but I can't guarantee I'll be able to answer them. + +=head1 AUTHOR + +Olaf Flebbe +http://members.linuxstart.com/~oflebbe/perl/perl5.html + +=head1 LAST UPDATE + +2000-09-18 + +=cut diff --git a/README.hpux b/README.hpux index e12c60d..e850441 100644 --- a/README.hpux +++ b/README.hpux @@ -243,22 +243,22 @@ fix is currently available. =head2 perl -P and // -In HP-UX perl is compiled with flags that will cause problems if the +In HP-UX Perl is compiled with flags that will cause problems if the -P flag of Perl (preprocess Perl code with the C preprocessor before perl sees it) is used. The problem is that C, being a C++-style until-end-of-line comment, will disappear along with the remainder of the line. This means that common Perl constructs like - s/foo//; + s/foo//; will turn into illegal code - s/foo + s/foo -The workaround is to use some other quoting characters than /, -like for example ! +The workaround is to use some other quoting separator than C<"/">, +like for example C<"!">: - s!foo!!; + s!foo!!; =head1 AUTHOR diff --git a/README.mpeix b/README.mpeix index 9e0b51d..7976db5 100644 --- a/README.mpeix +++ b/README.mpeix @@ -1,260 +1,675 @@ -Perl/iX for HP 3000 MPE +If you read this file _as_is_, just ignore the funny characters you +see. It is written in the POD format (see perlpod manpage) which is +specially designed to be readable as is. -http://www.cccd.edu/~markb/perlix.html -Perl language for MPE -Last updated July 15, 1998 @ 2030 UTC +=head1 NAME - ------------------------------------------------------------------------ +README.mpeix - Perl/iX for HP e3000 MPE + +=head1 SYNOPSIS -What's New + http://www.bixby.org/mark/perlix.html + Perl language for MPE + Last updated June 2, 2000 @ 0400 UTC + +=head1 NOTE - * July 15, 1998 - o Changed startperl to #!/PERL/PUB/perl so that Perl will recognize - scripts more easily and efficiently. - * July 8, 1998 - o Updated to version 5.004_70 (internal developer release) which is - now MPE-ready. The next public freeware release of Perl should - compile "straight out of the box" on MPE. Note that this version - of Perl/iX was strictly internal to me and never publicly - released. Note that BIND/iX is now required (well, the include - files and libbind.a) if you wish to compile Perl/iX. - * November 6, 1997 - o Updated to version 5.004_04. No changes in MPE-specific - functionality. +This is a podified version of the above-mentioned web page, +podified by Jarkko Hietaniemi 2001-Jan-01. - ------------------------------------------------------------------------ +=head1 What's New -Welcome +June 1, 2000 + +=over 4 -This is the official home page for the HP 3000 MPE port of the Perl -scripting language which gives you all of the power of C, awk, sed, and sh -in a single language. Check here for the latest news, implemented -functionality, known bugs, to-do list, etc. Status reports about major -milestones will also be posted to the HP3000-L mailing list and its -associated gatewayed newsgroup comp.sys.hp.mpe. +=item * -I'm doing this port because I can't live without Perl on the HPUX machines -that I administer for the Coast Community College District, and I want to -have the same power available to me on MPE. +Rebuilt to be compatible with mod_perl. If you plan on using +mod_perl, you MUST download and install this version of Perl/iX! + +=item * -Please send your comments, questions, and bug reports directly to me, Mark -Bixby, by e-mailing to markb@cccd.edu. Or just post them to HP3000-L. You -can also telephone me at +1 714 438-4647 Monday-Friday 0815-1745 PDT -(1615-0145 UTC). +bincompat5005="undef": sorry, but you will have to recompile any +binary 5.005 extensions that you may be using (if any; there is no +5.005 code in what you download from bixby.org) +uselargefiles="undef": not available in MPE for POSIX files yet. + +=item * -The platform I'm using to do this port is an HP 3000 969KS200 running -MPE/iX 5.5 and using the gcc 2.8 compiler from -http://www.interex.org/sources/freeware.html. +Now bundled with various add-on packages: -The combined porting wisdom from all of my ports can be found in my MPE/iX -Porting Guide. +=over 8 - ------------------------------------------------------------------------ +=item * -System Requirements +libnet (http://www.gbarr.demon.co.uk/libnet/FAQ.html) - * MPE/iX 5.5 or later. This version of Perl/iX does NOT run on MPE/iX - 5.0 or earlier, nor does it run on "classic" MPE/V machines. - * The Perl binary requires that you must have converted your NMRL - libraries in /lib/lib*.a and /usr/lib/lib*.a to NMXL libraries - /lib/lib*.sl and /usr/lib/lib*.sl via the LIBSHP3K script that comes - with the GNUCORE portion of the FREEWARE tape. - * If you wish to recompile Perl, you must install both GNUCORE and - GNUGCC from the FREEWARE tape. - * Perl/iX will be happier if you install the MPEKX76A additional POSIX - filename characters patch, but this is optional. - * If you will be compiling Perl/iX yourself, you will also need the - /BIND/PUB/include and /BIND/PUB/lib portions of BIND/iX. +=item * - ------------------------------------------------------------------------ +libwww-perl (LWP) which lets Perl programs behave like web browsers: + + 1. #!/PERL/PUB/perl + 2. use LWP::Simple; + 3. $doc = get('http://www.bixby.org/mark/perlix.html'); # reads the + web page into variable $doc + +(http://www.bixby.org/mark/perlix.html) -Demos +=item * -Here is a brief selection of some sample Perl/iX uses: +mod_perl (just the perl portion; the actual DSO will be released +soon with Apache/iX 1.3.12 from bixby.org). This module allows you to +write high performance persistent Perl CGI scripts and all sorts of +cool things. (http://perl.apache.org/) + +and much much more hiding under /PERL/PUB/.cpan/ + +=item * - * A web feedback CGI form that lets a web browser user enter some data - and send e-mail to the person responsible for reading the feedback - comments. The CGI is written in Perl and requires Sendmail/iX. +The CPAN module now works for automatic downloading and +installing of add-on packages: - ------------------------------------------------------------------------ + 1. export FTP_PASSIVE=1 + 2. perl -MCPAN -e shell + 3. Ignore any terminal I/O related complaints! + +(http://theoryx5.uwinnipeg.ca/CPAN/data/perl/CPAN.html) -How to Obtain Perl/iX +=back - 1. Download Perl using either FTP.ARPA.SYS or some other client - 2. Extract the installation script - 3. Edit the installation script - 4. Run the installation script +=back + +May 20, 2000 + +=over 4 + +=item * + +Updated to version 5.6.0. Builds straight out of the box on MPE/iX. + +=item * + +Perl's getpwnam() function which had regressed to being +unimplemented on MPE is now implemented once again. + +=back + +September 17, 1999 + +=over 4 + +=item * + +Migrated from cccd.edu to bixby.org. + +=back + +=head1 Welcome + +This is the official home page for the HP e3000 MPE/iX +(http://www.businessservers.hp.com/) port of the Perl scripting +language (http://www.perl.com/) which gives you all of the power of C, +awk, sed, and sh in a single language. Check here for the latest news, +implemented functionality, known bugs, to-do list, etc. Status reports +about major milestones will also be posted to the HP3000-L mailing list +(http://www.lsoft.com/scripts/wl.exe?SL1=HP3000-L&H=RAVEN.UTC.EDU) and +its associated gatewayed newsgroup comp.sys.hp.mpe. + +I'm doing this port because I can't live without Perl on the Unix +machines that I administer, and I want to have the same power +available to me on MPE. + +Please send your comments, questions, and bug reports directly to me, +Mark Bixby (http://www.bixby.org/mark/), by e-mailing to +mark@bixby.org. Or just post them to HP3000-L. + +The platform I'm using to do this port is an HP 3000 957RX running +MPE/iX 6.0 and using the GNU gcc C compiler +(http://jazz.external.hp.com/src/gnu/gnuframe.html). + +The combined porting wisdom from all of my ports can be found in my +MPE/iX Porting Guide (http://www.bixby.org/mark/porting.html). + +IMPORTANT NOTICE: Yes, I do work for the HP CSY R&D lab, but ALL of +the software you download from bixby.org is my personal freeware that +is NOT supported by HP. + +=head1 System Requirements + +=over 4 + +=item * + +MPE/iX 5.5 or later. This version of Perl/iX does NOT run on +MPE/iX 5.0 or earlier, nor does it run on "classic" MPE/V machines. + +=item * + +If you wish to recompile Perl, you must install both GNUCORE and +GNUGCC from jazz (http://jazz.external.hp.com/src/gnu/gnuframe.html). + +=item * + +Perl/iX will be happier on MPE/iX 5.5 if you install the MPEKX40B +extended POSIX filename characters patch, but this is optional. + +=item * + +Patch LBCJXT6A is required on MPE/iX 5.5 machines in order to +prevent Perl/iX from dying with an unresolved external reference +to _getenv_libc. + +=item * + +If you will be compiling Perl/iX yourself, you will also need +Syslog/iX (http://www.bixby.org/mark/syslogix.html) and the +/BIND/PUB/include and /BIND/PUB/lib portions of BIND/iX +(http://www.bixby.org/mark/bindix.html). + +=back + +=head1 How to Obtain Perl/iX + +=over 4 + +=item 1. + +Download Perl using either FTP.ARPA.SYS or some other client + +=item 2. + +Extract the installation script + +=item 3. + +Edit the installation script + +=item 4. + +Run the installation script + +=item 5. + +Convert your *.a system archive libraries to *.sl shared libraries + +=back Download Perl using FTP.ARPA.SYS from your HP 3000 (the preferred method)..... - -:HELLO MANAGER.SYS -:XEQ FTP.ARPA.SYS -open ftp.cccd.edu -anonymous -your@email.address -bytestream -cd /pub/mpe -get perl5.005.tar.Z /tmp/perl.tar.Z -exit + + :HELLO MANAGER.SYS + :XEQ FTP.ARPA.SYS + open ftp.bixby.org + anonymous + your@email.address + bytestream + cd /pub/mpe + get perl-5.6.0-mpe.tar.Z /tmp/perl.tar.Z;disc=2147483647 + exit .....Or download using some other generic web or ftp client (the alternate method) - + Download the following files (make sure that you use "binary mode" or whatever client feature that is 8-bit clean): - * Perl from http://www.cccd.edu/ftp/pub/mpe/perl5.005.tar.Z or - ftp://ftp.cccd.edu/pub/mpe/perl5.005.tar.Z +=over 4 + +=item * + +Perl from + + http://www.bixby.org/ftp/pub/mpe/perl-5.6.0-mpe.tar.Z + +or + + ftp://ftp.bixby.org/pub/mpe/perl-5.6.0-mpe.tar.Z + +=item * Upload those files to your HP 3000 in an 8-bit clean bytestream manner to: - * /tmp/perl.tar.Z + /tmp/perl.tar.Z + +=item * Then extract the installation script (after both download methods) + + :CHDIR /tmp + :XEQ TAR.HPBIN.SYS 'xvfopz /tmp/perl.tar.Z INSTALL' -:CHDIR /tmp -:XEQ TAR.HPBIN.SYS 'xvfopz /tmp/perl.tar.Z INSTALL' +=item * Edit the installation script + +Examine the accounting structure creation commands and modify if +necessary (adding additional capabilities, choosing a non-system +volume set, etc). -Examine the accounting structure creation commands and modify if necessary -(adding additional capabilities, choosing a non-system volume set, etc). + :XEQ VI.HPBIN.SYS /tmp/INSTALL -:XEQ VI.HPBIN.SYS /tmp/INSTALL - -Run the installation script +=item * +Run the installation script. + The accounting structure will be created and then all files will be extracted from the archive. -:XEQ SH.HPBIN.SYS /tmp/INSTALL - - ------------------------------------------------------------------------ - -Distribution Contents Highlights - -README - The file you're reading now. -INSTALL - Perl/iX Installation script. -PERL - Perl NMPRG executable. A version-numbered backup copy also exists. - You might wish to "ln -s /PERL/PUB/PERL /usr/local/bin/perl". -lib/ - Perl libraries, both core and add-on. -man/ - Perl man page documentation. -public_html/feedback.cgi - Sample feedback CGI form written in Perl. -src/perl5.005 - Source code. - - ------------------------------------------------------------------------ - -How to Compile Perl/iX - - 1. cd src/perl5.005 - 2. Read the INSTALL file for the official instructions - 3. ./Configure - 4. make - 5. ./mpeix/relink - 6. make test (expect 31 out of 5899 subtests to fail, mostly due to MPE - not supporting hard links and handling exit() return codes improperly) - 7. make install - 8. Optionally create symbolic links that point to the Perl executable, - i.e. ln -s /usr/local/bin/perl /PERL/PUB/PERL + :XEQ SH.HPBIN.SYS /tmp/INSTALL + +=item * + +Convert your *.a system archive libraries to *.sl shared libraries + +You only have to do this ONCE on your MPE/iX 5.5 machine in order to +convert /lib/lib*.a and /usr/lib/lib*.a libraries to their *.sl +equivalents. This step should not be necessary on MPE/iX 6.0 or later +machines because the 6.0 or later update process does it for you. + + :XEQ SH.HPBIN.SYS /PERL/PUB/LIBSHP3K + +=back + +=head1 Distribution Contents Highlights + +=over 4 + +=item README + +The file you're reading now. + +=item INSTALL + +Perl/iX Installation script. + +=item LIBSHP3K + +Script to convert *.a system archive libraries to *.sl shared libraries. + +=item PERL + +Perl NMPRG executable. A version-numbered backup copy also +exists. You might wish to "ln -s /PERL/PUB/PERL /usr/local/bin/perl". + +=item .cpan/ + +Much add-on source code downloaded with the CPAN module. + +=item lib/ + +Perl libraries, both core and add-on. + +=item man/ + +Perl man page documentation. + +=item public_html/feedback.cgi + +Sample feedback CGI form written in Perl. + +=item src/perl-5.6.0-mpe + +Source code. + +=back + +=head1 How to Compile Perl/iX + +=over 4 + +=item 1. + +cd src/perl-5.6.0-mpe + +=item 2. + +Read the INSTALL file for the official instructions + +=item 3. + +./Configure -d + +=item 4. + +make + +=item 5. + +./mpeix/relink + +=item 6. + +make test (expect approximately 15 out of 11306 subtests to fail, +mostly due to MPE not supporting hard links, UDP socket problems, +and handling exit() return codes improperly) + +=item 7. + +make install + +=item 8. + +Optionally create symbolic links that point to the Perl +executable, i.e. ln -s /PERL/PUB/PERL /usr/local/bin/perl + +=back The summary test results from "cd t; ./perl -I../lib harness": -Failed Test Status Wstat Total Fail Failed List of failed -------------------------------------------------------------------------------- -io/fs.t 26 8 30.77% 2-5, 7-9, 11 -io/pipe.t 12 2 16.67% 11-12 -lib/posix.t 18 1 5.56% 12 -op/die_exit.t 16 16 100.00% 1-16 -op/exec.t 8 2 25.00% 5-6 -op/stat.t 58 2 3.45% 3, 35 -Failed 6/183 test scripts, 96.72% okay. 31/5899 subtests failed, 99.47% okay. - - ------------------------------------------------------------------------ - -Getting Started with Perl/iX - -Create your Perl script files with "#!/PERL/PUB/perl" (or an equivalent -symbolic link) as the first line. Use the chmod command to make sure that -your script has execute permission. Run your script! - -If you want to use Perl to write web server CGI scripts, obtain and install -CGI.pm. Build CGI.pm and all other add-on modules below /PERL/PUB/src/. - -Be sure to take a look at the CPAN module list. A wide variety of free Perl -software is available. - - ------------------------------------------------------------------------ - -MPE/iX Implementation Considerations - -There some minor functionality issues to be aware of when comparing Perl -for Unix (Perl/UX) to Perl/iX: - - * MPE gcc/ld doesn't properly support linking NMPRG executables against - NMXL dynamic libraries, so you must manually run mpeix/relink after - each re-build of Perl. - * Perl/iX File::Copy will use MPE's /bin/cp command to copy files by - name in order to preserve file attributes like file code. - * MPE (and thus Perl/iX) lacks support for setgrent(), endgrent(), - setpwent(), endpwent(). - * MPE (and thus Perl/iX) lacks support for hard links. - * MPE requires GETPRIVMODE() in order to bind() to ports less than - 1024. Perl/iX will call GETPRIVMODE() automatically on your behalf if - you attempt to bind() to these low-numbered ports. Note that the - Perl/iX executable and the PERL account do not normally have CAP=PM, - so if you will be bind()-ing to these privileged ports, you will - manually need to add PM capability as appropriate. - * MPE requires that you bind() to an IP address of zero. Perl/iX - automatically replaces the IP address that you pass to bind() with a - zero. - * If you use Perl/iX fcntl() against a socket it will fail, because MPE - requires that you use sfcntl() instead. Perl/iX does not presently - support sfcntl(). - * MPE requires GETPRIVMODE() in order to setuid(). There are too many - calls to setuid() within Perl/iX, so I have not attempted an automatic - GETPRIVMODE() solution similar to bind(). - - ------------------------------------------------------------------------ - -Known Bugs Under Investigation - - * None - - ------------------------------------------------------------------------ - -To-Do List - - * Make setuid()/setgid() support work. - * Make sure that fcntl() against a socket descriptor is redirected to - sfcntl(). - * Add support for Berkeley DB once I've finished porting Berkeley DB. - * Write an MPE XS extension library containing miscellaneous important - MPE functions like GETPRIVMODE(), GETUSERMODE(), and sfcntl(). - - ------------------------------------------------------------------------ - -Change History - - * October 16, 1997 - o Added Demos section to the Perl/iX home page so you can see some - sample Perl applications running on my 3000. - * October 3, 1997 - o Added System Requirements section to the Perl/iX home page just - so the prerequisites stand out more. Various other home page - tweaks. - * October 2, 1997 - o Initial public release. - * September 1997 - o Porting begins. - - ------------------------------------------------------------------------ - -Mark Bixby, markb@cccd.edu + Failed Test Status Wstat Total Fail Failed List of failed + --------------------------------------------------------------------------- + io/fs.t 29 8 27.59% 2-5, 7-9, 11 + io/openpid.t 10 1 10.00% 7 + lib/io_sock.t 14 1 7.14% 13 + lib/io_udp.t 7 2 28.57% 3, 5 + lib/posix.t 27 1 3.70% 12 + op/lex_assign.t 187 1 0.53% 13 + op/stat.t 58 1 1.72% 3 + 15 tests and 94 subtests skipped. + Failed 7/236 test scripts, 97.03% okay. 15/11306 subtests failed, 99.87% okay. + +=head1 Getting Started with Perl/iX + +Create your Perl script files with "#!/PERL/PUB/perl" (or an +equivalent symbolic link) as the first line. Use the chmod command to +make sure that your script has execute permission. Run your script! + +Be sure to take a look at the CPAN module list +(http://www.cpan.org/CPAN.html). A wide variety of free Perl software +is available. You can automatically download these packages by using +the CPAN module (http://theoryx5.uwinnipeg.ca/CPAN/data/perl/CPAN.html). + +=head1 MPE/iX Implementation Considerations + +There some minor functionality issues to be aware of when comparing +Perl for Unix (Perl/UX) to Perl/iX: + +=over 4 + +=item * + +MPE gcc/ld doesn't properly support linking NMPRG executables against +NMXL dynamic libraries, so you must manually run mpeix/relink after +each re-build of Perl. + +=item * + +Perl/iX File::Copy will use MPE's /bin/cp command to copy files by +name in order to preserve file attributes like file code. + +=item * + +MPE (and thus Perl/iX) lacks support for setgrent(), endgrent(), +setpwent(), endpwent(). + +=item * + +MPE (and thus Perl/iX) lacks support for hard links. + +=item * + +MPE requires GETPRIVMODE() in order to bind() to ports less than 1024. +Perl/iX will call GETPRIVMODE() automatically on your behalf if you +attempt to bind() to these low-numbered ports. Note that the Perl/iX +executable and the PERL account do not normally have CAP=PM, so if you +will be bind()-ing to these privileged ports, you will manually need +to add PM capability as appropriate. + +=item * + +MPE requires that you bind() to an IP address of zero. Perl/iX +automatically replaces the IP address that you pass to bind() with +a zero. + +=item * + +If you use Perl/iX fcntl() against a socket it will fail, because MPE +requires that you use sfcntl() instead. Perl/iX does not presently +support sfcntl(). + +=item * + +MPE requires GETPRIVMODE() in order to setuid(). There are too many +calls to setuid() within Perl/iX, so I have not attempted an automatic +GETPRIVMODE() solution similar to bind(). + +=back + +=head1 Known Bugs Under Investigation + +None. + +=head1 To-Do List + +=over 4 + +=item * + +Make setuid()/setgid() support work. + +=item * + +Make sure that fcntl() against a socket descriptor is redirected to sfcntl(). + +=item * + +Add support for Berkeley DB once I've finished porting Berkeley DB. + +=item * + +Write an MPE XS extension library containing miscellaneous important +MPE functions like GETPRIVMODE(), GETUSERMODE(), and sfcntl(). + +=back + +=head1 Change History + +May 6, 1999 + +=over 4 + +=item * + +Patch LBCJXT6A is required on MPE/iX 5.5 machines in order to prevent +Perl/iX from dying with an unresolved external reference to _getenv_libc. + +=back + +April 7, 1999 + +=over 4 + +=item * + +Updated to version 5.005_03. + +=item * + +The official source distribution once again compiles "straight out +of the box" for MPE. + +=item * + +The current incarnation of the 5.5 POSIX filename extended +characters patch is now MPEKX40B. + +=item * + +The LIBSHP3K *.a -> *.sl library conversion script is now included +as /PERL/PUB/LIBSHP3K. + +=back + +November 20, 1998 + +=over 4 + +=item * + +Updated to version 5.005_02. + +=item * + +Fixed a DynaLoader bug that was unable to load symbols from relative +path name libraries. + +=item * + +Fixed a .xs compilation bug where the mpeixish.sh include file wasn't +being installed into the proper directory. + +=item * + +All bugfixes will be submitted back to the official Perl developers. + +=item * + +The current incarnation of the POSIX filename extended characters +patch is now MPEKXJ3A. + +=back + +August 14, 1998 + +=over 4 + +=item * + +The previous POSIX filename extended characters patch MPEKX44C has +been superseded by MPEKXB5A. + +=back + +August 7, 1998 + +=over 4 + +=item * + +The previous POSIX filename extended characters patch MPEKX76A has +been superseded by MPEKX44C. + +=over 4 + +=back + +July 28, 1998 + +=item * + +Updated to version 5.005_01. + +=back + +July 23, 1998 + +=over 4 + +=item * + +Updated to version 5.005 (production release). The public +freeware sources are now 100% MPE-ready "straight out of the box". + +=back + +July 17, 1998 + +=over 4 + +=item * + +Updated to version 5.005b1 (public beta release). The public +freeware sources are now 99.9% MPE-ready. By installing and +testing this beta on your own HP3000, you will be helping to +insure that the final release of 5.005 will be 100% MPE-ready and +100% bug free. + +=item * + +My MPE binary release is now extracted using my standard INSTALL script. + +=back + +July 15, 1998 + +=over 4 + +=item * + +Changed startperl to #!/PERL/PUB/perl so that Perl will recognize +scripts more easily and efficiently. + +=back + +July 8, 1998 + +=over 4 + +=item * + +Updated to version 5.004_70 (internal developer release) which is now +MPE-ready. The next public freeware release of Perl should compile +"straight out of the box" on MPE. Note that this version of Perl/iX +was strictly internal to me and never publicly released. Note that +[21]BIND/iX is now required (well, the include files and libbind.a) if +you wish to compile Perl/iX. + +=back + +November 6, 1997 + +=over 4 + +=item * + +Updated to version 5.004_04. No changes in MPE-specific functionality. + +=back + +October 16, 1997 + +=over 4 + +=item * + +Added Demos section to the Perl/iX home page so you can see some +sample Perl applications running on my 3000. + +=back + +October 3, 1997 + +=over 4 + +=item * + +Added System Requirements section to the Perl/iX home page just so the +prerequisites stand out more. Various other home page tweaks. + +=back + +October 2, 1997 + +=over 4 + +=item * + +Initial public release. + +=back + +September 1997 + +=over 4 + +=item * + +Porting begins. + +=back + +=head1 Author + +Mark Bixby, mark@bixby.org + diff --git a/README.os2 b/README.os2 index b46fa7a..19af8c5 100644 --- a/README.os2 +++ b/README.os2 @@ -115,7 +115,7 @@ Contents - Threads AUTHOR SEE ALSO - + =head1 DESCRIPTION =head2 Target @@ -394,12 +394,12 @@ is considered a bug and should be fixed soon. =over 4 -=item +=item * Did you run your programs with C<-w> switch? See L. -=item +=item * Do you try to run I shell commands, like C<`copy a b`> (internal for F), or C<`glob a*b`> (internal for ksh)? You @@ -1163,18 +1163,18 @@ eventually). =over 4 -=item +=item * Since L is present in EMX, but is not functional, it is emulated by perl. To disable the emulations, set environment variable C. -=item +=item * Here is the list of things which may be "broken" on EMX (from EMX docs): -=over +=over 4 =item * @@ -1205,7 +1205,7 @@ L: Note that C does not work with the current version of EMX. -=item +=item * Since F is used for globing (see L), the bugs of F plague perl as well. @@ -1517,9 +1517,9 @@ cannot test it. For the details of the current situation with calling external programs, see L. -=over +=over 4 -=item +=item * External scripts may be called by name. Perl will try the same extensions as when processing B<-S> command-line switch. @@ -1549,7 +1549,7 @@ preliminary. Most notable problems: -=over +=over 4 =item C diff --git a/README.os390 b/README.os390 index 571d027..8dd0483 100644 --- a/README.os390 +++ b/README.os390 @@ -1,5 +1,6 @@ + This document is written in pod format hence there are punctuation -characters in in odd places. Do not worry, you've apparently got +characters in odd places. Do not worry, you've apparently got the ASCII->EBCDIC translation worked out correctly. You can read more about pod in pod/perlpod.pod or the short summary in the INSTALL file. @@ -15,12 +16,12 @@ on OS/390 Unix System Services. =head1 DESCRIPTION -This is a fully ported perl for OS/390 Release 3, 5 and 6. -It may work on other versions, but those are the ones we've -tested it on. +This is a fully ported Perl for OS/390 Version 2 Release 3, 5, 6, 7, +8, and 9. It may work on other versions or releases, but those are +the ones we've tested it on. You may need to carry out some system configuration tasks before -running the Configure script for perl. +running the Configure script for Perl. =head2 Unpacking @@ -41,12 +42,39 @@ parser template files. If you have not already done so then be sure to: This may also be a good time to ensure that your /etc/protocol file and either your /etc/resolv.conf or /etc/hosts files are in place. +The IBM document that described such USS system setup issues was +SC28-1890-07 "OS/390 UNIX System Services Planning", in particular +Chapter 6 on customizing the OE shell. -GNU make for OS/390, which may be required for the build of perl, -is available from: +GNU make for OS/390, which is required for the build of perl (as well as +building CPAN modules and extensions), is available from: http://www.mks.com/s390/gnu/index.htm +Some people have reported encountering "Out of memory!" errors while +trying to build Perl using GNU make binaries. If you encounter such +trouble then try to download the source code kit and build GNU make +from source to eliminate any such trouble. You might also find GNU make +(as well as Perl and Apache) in the red-piece/book "Open Source Software +for OS/390 UNIX", SG24-5944-00 from IBM. + +There is a syntax error in the /usr/include/sys/socket.h header file +that IBM supplies with USS V2R7, V2R8, and possibly V2R9. The problem with +the header file is that near the definition of the SO_REUSEPORT constant +there is a spurious extra '/' character outside of a comment like so: + + #define SO_REUSEPORT 0x0200 /* allow local address & port + reuse */ / + +You could edit that header yourself to remove that last '/', or you might +note that Language Environment (LE) APAR PQ39997 describes the problem +and PTF's UQ46272 and UQ46271 are the (R8 at least) fixes and apply them. +If left unattended that syntax error will turn up as an inability for Perl +to build its "Socket" extension. + +For successful testing you may need to turn on the sticky bit for your +world readable /tmp directory if you have not already done so (see man chmod). + =head2 Configure Once you've unpacked the distribution, run "sh Configure" (see INSTALL @@ -58,25 +86,83 @@ to watch out for include: =item * +A message of the form: + + (I see you are using the Korn shell. Some ksh's blow up on Configure, + mainly on older exotic systems. If yours does, try the Bourne shell instead.) + +is nothing to worry about at all. + +=item * + Some of the parser default template files in /samples are needed in /etc. In particular be sure that you at least copy /samples/yyparse.c to /etc -before running perl's Configure. This step ensures successful extraction -of EBCDIC versions of parser files such as perly.c. +before running Perl's Configure. This step ensures successful extraction +of EBCDIC versions of parser files such as perly.c. This has to be done +before running Configure the first time. If you failed to do so then the +easiest way to re-Configure Perl is to delete your misconfigured build root +and re extract the source from the tar ball. If for some reason you do not +want to do that then, after ensuring that /etc/yyparse.c is properly in place +run the following commands from within the Perl build directory: + + rm -f y.tab.c y.tab.h + yacc -d perly.y + mv -f y.tab.c perly.c + chmod u+w perly.c + sed -e '/^#include "perl\.h"/a\ + \ + #define yydebug PL_yydebug\ + #define yynerrs PL_yynerrs\ + #define yyerrflag PL_yyerrflag\ + #define yychar PL_yychar\ + #define yyval PL_yyval\ + #define yylval PL_yylval' \ + -e '/YYSTYPE *yyval;/D' \ + -e '/YYSTYPE *yylval;/D' \ + -e '/int yychar,/,/yynerrs;/D' \ + -e 's/int yydebug = 0;/yydebug = 0;/' \ + -e 's/[^_]realloc(/PerlMem_realloc(/g' \ + -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \ + -e 's/y\.tab/perly/g' perly.c >perly.tmp + mv -f perly.tmp perly.c + mv -f y.tab.h perly.h + cd x2p + rm -f y.tab.c y.tab.h + yacc a2p.y + mv -f y.tab.c a2p.c + chmod u+w a2p.c + sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \ + -e 's/y\.tab/a2p/g' a2p.c >a2p.tmp + mv -f a2p.tmp a2p.c + mv -f y.tab.h a2p.h + cd .. + +There, easy huh? If you find typing all that in difficult then perhaps +you should reconsider the rm -rf of the perl build directory and +re extraction of the source tar ball. =item * -This port doesn't support dynamic loading. Although -OS/390 has support for DLLs, there are some differences -that cause problems for perl. +This port doesn't support dynamic loading. Although OS/390 has support +for DLLs via dllload(), there are some differences that cause problems +for Perl. (We need a volunteer to write a ext/DynaLoader/dl_dllload.xs +file). =item * -You may see a "WHOA THERE!!!" message for $d_shmatprototype -it is OK to keep the recommended "define". +A message of the form: + + shmat() found. + and it returns (void *). + *** WHOA THERE!!! *** + The recommended value for $d_shmatprototype on this machine was "define"! + Keep the recommended value? [y] + +is nothing to worry about at all. =item * -Don't turn on the compiler optimization flag "-O". There's +Do not turn on the compiler optimization flag "-O". There is a bug in either the optimizer or perl that causes perl to not work correctly when the optimizer is on. @@ -85,7 +171,7 @@ not work correctly when the optimizer is on. Some of the configuration files in /etc used by the networking APIs are either missing or have the wrong names. In particular, make sure that there's either -an /etc/resolv.conf or and /etc/hosts, so that +an /etc/resolv.conf or an /etc/hosts, so that gethostbyname() works, and make sure that the file /etc/proto has been renamed to /etc/protocol (NOT /etc/protocols, as used by other Unix systems). @@ -100,7 +186,7 @@ Simply put: make make test -if everything looks ok then: +if everything looks ok (see the next section for test/IVP diagnosis) then: make install @@ -108,51 +194,168 @@ this last step may or may not require UID=0 privileges depending on how you answered the questions that Configure asked and whether or not you have write access to the directories you specified. +=head2 build anomalies + +"Out of memory!" messages during the build of Perl are most often fixed +by re building the GNU make utility for OS/390 from a source code kit. + +Another memory limiting item to check is your MAXASSIZE parameter in your +'SYS1.PARMLIB(BPXPRMxx)' data set (note too that as of V2R8 address space +limits can be set on a per user ID basis in the USS segment of a RACF +profile). People have reported successful builds of Perl with MAXASSIZE +parameters as small as 503316480 (and it may be possible to build Perl +with a MAXASSIZE smaller than that). + +Within USS your /etc/profile or $HOME/.profile may limit your ulimit +settings. Check that the following command returns reasonable values: + + ulimit -a + +To conserve memory you should have your compiler modules loaded into the +Link Pack Area (LPA/ELPA) rather than in a link list or step lib. + +If the c89 compiler complains of syntax errors during the build of the +Socket extension then be sure to fix the syntax error in the system +header /usr/include/sys/socket.h. + +=head2 testing anomalies + +The `make test` step runs a Perl Verification Procedure, usually before +installation. You might encounter STDERR messages even during a successful +run of `make test`. Here is a guide to some of the more commonly seen +anomalies: + +=over 4 + +=item * + +A message of the form: + + comp/cpp.............ERROR CBC3191 ./.301989890.c:1 The character $ is not a + valid C source character. + FSUM3065 The COMPILE step ended with return code 12. + FSUM3017 Could not compile .301989890.c. Correct the errors and try again. + ok + +indicates that the t/comp/cpp.t test of Perl's -P command line switch has +passed but that the particular invocation of c89 -E in the cpp script does +not suppress the C compiler check of source code validity. + +=item * + +A message of the form: + + io/openpid...........CEE5210S The signal SIGHUP was received. + CEE5210S The signal SIGHUP was received. + CEE5210S The signal SIGHUP was received. + ok + +indicates that the t/io/openpid.t test of Perl has passed but done so +with extraneous messages on stderr from CEE. + +=item * + +A message of the form: + + lib/ftmp-security....File::Temp::_gettemp: Parent directory (/tmp/) is not safe + (sticky bit not set when world writable?) at lib/ftmp-security.t line 100 + File::Temp::_gettemp: Parent directory (/tmp/) is not safe (sticky bit not + set when world writable?) at lib/ftmp-security.t line 100 + ok + +indicates a problem with the permissions on your /tmp directory within the HFS. +To correct that problem issue the command: + + chmod a+t /tmp + +from an account with write access to the directory entry for /tmp. + +=back + =head2 Usage Hints When using perl on OS/390 please keep in mind that the EBCDIC and ASCII -character sets are different. Perl builtin functions that may behave -differently under EBCDIC are mentioned in the perlport.pod document. +character sets are different. See perlebcdic.pod for more on such character +set issues. Perl builtin functions that may behave differently under +EBCDIC are also mentioned in the perlport.pod document. -OpenEdition (UNIX System Services) does not (yet) support the #! means -of script invocation. -See: +Open Edition (UNIX System Services) from V2R8 onward does support +#!/path/to/perl script invocation. There is a PTF available from +IBM for V2R7 that will allow shell/kernel support for #!. USS +releases prior to V2R7 did not support the #! means of script invocation. +If you are running V2R6 or earlier then see: head `whence perldoc` for an example of how to use the "eval exec" trick to ask the shell to -have perl run your scripts for you. +have Perl run your scripts on those older releases of Unix System Services. + +=head2 Modules and Extensions + +Pure pure (that is non xs) modules may be installed via the usual: + + perl Makefile.PL + make + make test + make install + +You can also build xs based extensions to Perl for OS/390 but will need +to follow the instructions in ExtUtils::MakeMaker for building +statically linked perl binaries. In the simplest configurations building +a static perl + xs extension boils down to: -=head2 Extensions + perl Makefile.PL + make + make perl + make test + make install + make -f Makefile.aperl inst_perl MAP_TARGET=perl -You can build xs based extensions to Perl for OS/390 but will need to -follow the instructions in ExtUtils::MakeMaker for building statically -linked perl binaries. In most cases people have reported better -results with GNU make rather than the system's /bin/make. +In most cases people have reported better results with GNU make rather +than the system's /bin/make program, whether for plain modules or for +xs based extensions. =head1 AUTHORS -David Fiander and Peter Prymmer. +David Fiander and Peter Prymmer with thanks to Dennis Longnecker +and William Raffloer for valuable reports, LPAR and PTF feedback. +Thanks to Mike MacIsaac and Egon Terwedow for SG24-5944-00. =head1 SEE ALSO -L, L, L. +L, L, L, L. + + http://www.mks.com/s390/gnu/index.htm + + http://www.redbooks.ibm.com/abstracts/sg245944.html + + http://www.s390.ibm.com/products/oe/bpxa1ty1.html#opensrc + + http://www.s390.ibm.com/products/oe/portbk/bpxacenv.html + + http://www.xray.mpe.mpg.de/mailing-lists/perl-mvs/ =head2 Mailing list The Perl Institute (http://www.perl.org/) maintains a perl-mvs mailing list of interest to all folks building and/or -using perl on EBCDIC platforms. To subscribe, send a message of: +using perl on all EBCDIC platforms (not just OS/390). +To subscribe, send a message of: subscribe perl-mvs -to majordomo@perl.org. +to majordomo@perl.org. There is a web archive of the mailing list at: + + http://www.xray.mpe.mpg.de/mailing-lists/perl-mvs/ =head1 HISTORY This document was originally written by David Fiander for the 5.005 release of Perl. -This document was podified for the 5.005_03 release of perl 11 March 1999. +This document was podified for the 5.005_03 release of Perl 11 March 1999. + +Updated 12 November 2000 for the 5.7.1 release of Perl. =cut + diff --git a/README.solaris b/README.solaris new file mode 100644 index 0000000..97e84a3 --- /dev/null +++ b/README.solaris @@ -0,0 +1,522 @@ +If you read this file _as_is_, just ignore the funny characters you +see. It is written in the POD format (see pod/perlpod.pod) which is +specifically designed to be readable as is. + +=head1 NAME + +README.solaris - Perl version 5 on Solaris systems + +=head1 DESCRIPTION + +This document describes various features of Sun's Solaris operating system +that will affect how Perl version 5 (hereafter just perl) is +compiled and/or runs. Some issues relating to the older SunOS 4.x are +also discussed, though they may be out of date. + +For the most part, everything should just work. + +Starting with Solaris 8, perl5.00503 (or higher) is supplied with the +operating system, so you might not even need to build a newer version +of perl at all. The Sun-supplied version is installed in /usr/perl5 +with /usr/bin/perl pointing to /usr/perl5/bin/perl. Do not disturb +that installation unless you really know what you are doing. If you +remove the perl supplied with the OS, there is a good chance you will +render some bits of your system inoperable. If you wish to install a +newer version of perl, install it under a different prefix from +/usr/perl5. Common prefixes to use are /usr/local and /opt/perl. + +You may wish to put your version of perl in the PATH of all users by +changing the link /usr/bin/perl. This is OK, as all Perl scripts +shipped with Solaris use /usr/perl5/bin/perl. + +=head2 Solaris Version Numbers. + +For consistency with common usage, perl's Configure script performs +some minor manipulations on the operating system name and version +number as reported by uname. Here's a partial translation table: + + Sun: perl's Configure: + uname uname -r Name osname osvers + SunOS 4.1.3 Solaris 1.1 sunos 4.1.3 + SunOS 5.6 Solaris 2.6 solaris 2.6 + SunOS 5.8 Solaris 8 solaris 2.8 + +The complete table can be found in the Sun Managers' FAQ +L under +"9.1) Which Sun models run which versions of SunOS?". + +=head1 RESOURCES + +There are many, many source for Solaris information. A few of the +important ones for perl: + +=over 4 + +=item Solaris FAQ + +The Solaris FAQ is available at +L. + +The Sun Managers' FAQ is available at +L + +=item Precompiled Binaries + +Precompiled binaries, links to many sites, and much, much more is +available at L. + +=item Solaris Documentation + +All Solaris documentation is available on-line at L. + +=back + +=head1 SETTING UP + +=head2 File Extraction Problems. + +Be sure to use a tar program compiled under Solaris (not SunOS 4.x) +to extract the perl-5.x.x.tar.gz file. Do not use GNU tar compiled +for SunOS4 on Solaris. (GNU tar compiled for Solaris should be fine.) +When you run SunOS4 binaries on Solaris, the run-time system magically +alters pathnames matching m#lib/locale# so that when tar tries to create +lib/locale.pm, a file named lib/oldlocale.pm gets created instead. +If you found this advice it too late and used a SunOS4-compiled tar +anyway, you must find the incorrectly renamed file and move it back +to lib/locale.pm. + +=head2 Compiler and Related Tools. + +You must use an ANSI C compiler to build perl. Perl can be compiled +with either Sun's add-on C compiler or with gcc. The C compiler that +shipped with SunOS4 will not do. + +=head3 Include /usr/ccs/bin/ in your PATH. + +Several tools needed to build perl are located in /usr/ccs/bin/: ar, +as, ld, and make. Make sure that /usr/ccs/bin/ is in your PATH. + +You need to make sure the following packages are installed +(this info is extracted from the Solaris FAQ): + +for tools (sccs, lex, yacc, make, nm, truss, ld, as): SUNWbtool, +SUNWsprot, SUNWtoo + +for libraries & headers: SUNWhea, SUNWarc, SUNWlibm, SUNWlibms, SUNWdfbh, +SUNWcg6h, SUNWxwinc, SUNWolinc + +for 64 bit development: SUNWarcx, SUNWbtoox, SUNWdplx, SUNWscpux, +SUNWsprox, SUNWtoox, SUNWlmsx, SUNWlmx, SUNWlibCx + +If you are in doubt which package contains a file you are missing, +try to find an installation that has that file. Then do a + + grep /my/missing/file /var/sadm/install/contents + +This will display a line like this: + +/usr/include/sys/errno.h f none 0644 root bin 7471 37605 956241356 SUNWhea + +The last item listed (SUNWhea in this example) is the package you need. + +=head3 Avoid /usr/ucb/cc. + +You don't need to have /usr/ucb/ in your PATH to build perl. If you +want /usr/ucb/ in your PATH anyway, make sure that /usr/ucb/ is NOT +in your PATH before the directory containing the right C compiler. + +=head3 Sun's C Compiler + +If you use Sun's C compiler, make sure the correct directory +(usually /opt/SUNWspro/bin/) is in your PATH (before /usr/ucb/). + +=head3 GCC + +If you use gcc, make sure your installation is recent and +complete. As a point of reference, perl-5.6.0 built fine with +gcc-2.8.1 on both Solaris 2.6 and Solaris 8. You'll be able to +Configure perl with + + sh Configure -Dcc=gcc + +If you have updated your Solaris version, you may also have to update +your GCC. For example, if you are running Solaris 2.6 and your gcc is +installed under /usr/local, check in /usr/local/lib/gcc-lib and make +sure you have the appropriate directory, sparc-sun-solaris2.6/ or +i386-pc-solaris2.6/. If gcc's directory is for a different version of +Solaris than you are running, then you will need to rebuild gcc for +your new version of Solaris. + +You can get a precompiled version of gcc from +L. Make sure you pick up the package for +your Solaris release. + +=head3 GNU as and GNU ld + +The versions of as and ld supplied with Solaris work fine for building +perl. There is normally no need to install the GNU versions. + +If you decide to ignore this advice and use the GNU versions anyway, +then be sure that they are relatively recent. Versions newer than 2.7 +are apparently new enough. Older versions may have trouble with +dynamic loading. + +If your gcc is configured to use GNU as and ld but you want to use the +Solaris ones instead to build perl, then you'll need to add +-B/usr/ccs/bin/ to the gcc command line. One convenient way to do +that is with + + sh Configure -Dcc='gcc -B/usr/ccs/bin/' + +Note that the trailing slash is required. This will result in some +harmless warnings as Configure is run: + + gcc: file path prefix `/usr/ccs/bin/' never used + +These messages may safely be ignored. +(Note that for a SunOS4 system, you must use -B/bin/ instead.) + +Alternatively, you can use the GCC_EXEC_PREFIX environment variable to +ensure that Sun's as and ld are used. Consult your gcc documentation +for further information on the -B option and the GCC_EXEC_PREFIX variable. + +=head3 GNU make + +Sun's make works fine for building perl. +If you wish to use GNU make anyway, be sure that the set-group-id bit is not +set. If it is, then arrange your PATH so that /usr/ccs/bin/make is +before GNU make or else have the system administrator disable the +set-group-id bit on GNU make. + +=head3 Avoid libucb. + +Solaris provides some BSD-compatibility functions in /usr/ucblib/libucb.a. +Perl will not build and run correctly if linked against -lucb since it +contains routines that are incompatible with the standard Solaris libc. +Normally this is not a problem since the solaris hints file prevents +Configure from even looking in /usr/ucblib for libraries, and also +explicitly omits -lucb. + +=head2 Environment + +=head3 PATH + +Make sure your PATH includes the compiler (/opt/SUNWspro/bin/ if you're +using Sun's compiler) as well as /usr/ccs/bin/ to pick up the other +development tools (such as make, ar, as, and ld). Make sure your path +either doesn't include /usr/ucb or that it includes it after the +compiler and compiler tools and other standard Solaris directories. +You definitely don't want /usr/ucb/cc. + +=head3 LD_LIBRARY_PATH + +If you have the LD_LIBRARY_PATH environment variable set, be sure that +it does NOT include /lib or /usr/lib. If you will be building +extensions that call third-party shared libraries (e.g. Berkeley DB) +then make sure that your LD_LIBRARY_PATH environment variable includes +the directory with that library (e.g. /usr/local/lib). + +If you get an error message + + dlopen: stub interception failed + +it is probably because your LD_LIBRARY_PATH environment variable +includes a directory which is a symlink to /usr/lib (such as /lib). +The reason this causes a problem is quite subtle. The file +libdl.so.1.0 actually *only* contains functions which generate 'stub +interception failed' errors! The runtime linker intercepts links to +"/usr/lib/libdl.so.1.0" and links in internal implementations of those +functions instead. [Thanks to Tim Bunce for this explanation.] + +=head1 RUN CONFIGURE. + +See the INSTALL file for general information regarding Configure. +Only Solaris-specific issues are discussed here. Usually, the +defaults should be fine. + +=head2 64-bit Issues. + +See the INSTALL file for general information regarding 64-bit compiles. +In general, the defaults should be fine for most people. + +By default, perl-5.6.0 (or later) is compiled as a 32-bit application +with largefile and long-long support. + +=head3 General 32-bit vs. 64-bit issues. + +Solaris 7 and above will run in either 32 bit or 64 bit mode on SPARC +CPUs, via a reboot. You can build 64 bit apps whilst running 32 bit +mode and vice-versa. 32 bit apps will run under Solaris running in +either 32 or 64 bit mode. 64 bit apps require Solaris to be running +64 bit mode. + +Existing 32 bit apps are properly known as LP32, i.e. Longs and +Pointers are 32 bit. 64-bit apps are more properly known as LP64. +The discriminating feature of a LP64 bit app is its ability to utilise a +64-bit address space. It is perfectly possible to have a LP32 bit app +that supports both 64-bit integers (long long) and largefiles (> 2GB), +and this is the default for perl-5.6.0. + +For a more complete explanation of 64-bit issues, see the Solaris 64-bit +Developer's Guide at http://docs.sun.com:80/ab2/coll.45.13/SOL64TRANS/ + +You can detect the OS mode using "isainfo -v", e.g. + + fubar$ isainfo -v # Ultra 30 in 64 bit mode + 64-bit sparcv9 applications + 32-bit sparc applications + +By default, perl will be compiled as a 32-bit application. Unless you +want to allocate more than ~ 4GB of memory inside Perl, you probably +don't need Perl to be a 64-bit app. + +=head3 Large File Suppprt + +For Solaris 2.6 and onwards, there are two different ways for 32-bit +applications to manipulate large files (files whose size is > 2GByte). +(A 64-bit application automatically has largefile support built in +by default.) + +First is the "transitional compilation environment", described in +lfcompile64(5). According to the man page, + + The transitional compilation environment exports all the + explicit 64-bit functions (xxx64()) and types in addition to + all the regular functions (xxx()) and types. Both xxx() and + xxx64() functions are available to the program source. A + 32-bit application must use the xxx64() functions in order + to access large files. See the lf64(5) manual page for a + complete listing of the 64-bit transitional interfaces. + +The transitional compilation environment is obtained with the +following compiler and linker flags: + + getconf LFS64_CFLAGS -D_LARGEFILE64_SOURCE + getconf LFS64_LDFLAG # nothing special needed + getconf LFS64_LIBS # nothing special needed + +Second is the "large file compilation environment", described in +lfcompile(5). According to the man page, + + Each interface named xxx() that needs to access 64-bit entities + to access large files maps to a xxx64() call in the + resulting binary. All relevant data types are defined to be + of correct size (for example, off_t has a typedef definition + for a 64-bit entity). + + An application compiled in this environment is able to use + the xxx() source interfaces to access both large and small + files, rather than having to explicitly utilize the transitional + xxx64() interface calls to access large files. + +Two exceptions are fseek() and ftell(). 32-bit applications should +use fseeko(3C) and ftello(3C). These will get automatically mapped +to fseeko64() and ftello64(). + +The large file compilation environment is obtained with + + getconf LFS_CFLAGS -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 + getconf LFS_LDFLAGS # nothing special needed + getconf LFS_LIBS # nothing special needed + +By default, perl uses the large file compilation environment and +relies on Solaris to do the underlying mapping of interfaces. + +=head3 Building an LP64 Perl + +To compile a 64-bit application on an UltraSparc with a recent Sun Compiler, +you need to use the flag "-xarch=v9". getconf(1) will tell you this, e.g. + + fubar$ getconf -a | grep v9 + XBS5_LP64_OFF64_CFLAGS: -xarch=v9 + XBS5_LP64_OFF64_LDFLAGS: -xarch=v9 + XBS5_LP64_OFF64_LINTFLAGS: -xarch=v9 + XBS5_LPBIG_OFFBIG_CFLAGS: -xarch=v9 + XBS5_LPBIG_OFFBIG_LDFLAGS: -xarch=v9 + XBS5_LPBIG_OFFBIG_LINTFLAGS: -xarch=v9 + _XBS5_LP64_OFF64_CFLAGS: -xarch=v9 + _XBS5_LP64_OFF64_LDFLAGS: -xarch=v9 + _XBS5_LP64_OFF64_LINTFLAGS: -xarch=v9 + _XBS5_LPBIG_OFFBIG_CFLAGS: -xarch=v9 + _XBS5_LPBIG_OFFBIG_LDFLAGS: -xarch=v9 + _XBS5_LPBIG_OFFBIG_LINTFLAGS: -xarch=v9 + +This flag is supported in Sun WorkShop Compilers 5.0 and onwards +(now marketed under the name Forte) when used on Solaris 7 or later on +UltraSparc systems. + +If you are using gcc, you would need to use -mcpu=v9 -m64 instead. This +option is not yet supported as of gcc 2.95.2; from install/SPECIFIC +in that release: + +GCC version 2.95 is not able to compile code correctly for sparc64 +targets. Users of the Linux kernel, at least, can use the sparc32 +program to start up a new shell invocation with an environment that +causes configure to recognize (via uname -a) the system as sparc-*-* +instead. + +All this should be handled automatically by the hints file, if +requested. + +If you do want to be able to allocate more than 4GB memory inside +perl, then you should use the Solaris malloc, since the perl +malloc breaks when dealing with more than 2GB of memory. You can do +this with + + sh Configure -Uusemymalloc + +=head3 Long Doubles. + +As of 5.6.0, long doubles are not working. + +=head2 Threads. + +It is possible to build a threaded version of perl on Solaris. The entire +perl thread implementation is still experimental, however, so beware. +Perl uses the sched_yield(3RT) function. In versions of Solaris up +to 2.6, that function is in -lposix4. Starting with Solaris 7, it is +in -lrt. The hints file should handle adding this automatically. + +=head2 Malloc Issues. + +You should not use perl's malloc if you are building with gcc. There +are reports of core dumps, especially in the PDL module. The problem +appears to go away under -DDEBUGGING, so it has been difficult to +track down. Sun's compiler appears to be ok with or without perl's +malloc. [XXX further investigation is needed here.] + +You should also not use perl's malloc if you are building perl as +an LP64 application, since perl's malloc has trouble allocating more +than 2GB of memory. + +You can avoid perl's malloc by Configuring with + + sh Configure -Uusemymalloc + +[XXX Update hints file.] + +=head1 MAKE PROBLEMS. + +=over 4 + +=item Dynamic Loading Problems With GNU as and GNU ld + +If you have problems with dynamic loading using gcc on SunOS or +Solaris, and you are using GNU as and GNU ld, see the section +L<"GNU as and GNU ld"> above. + +=item ld.so.1: ./perl: fatal: relocation error: + +If you get this message on SunOS or Solaris, and you're using gcc, +it's probably the GNU as or GNU ld problem in the previous item +L<"GNU as and GNU ld">. + +=item dlopen: stub interception failed + +The primary cause of the 'dlopen: stub interception failed' message is +that the LD_LIBRARY_PATH environment variable includes a directory +which is a symlink to /usr/lib (such as /lib). See +L<"LD_LIBRARY_PATH"> above. + +=item #error "No DATAMODEL_NATIVE specified" + +This is a common error when trying to build perl on Solaris 2.6 with a +gcc installation from Solaris 2.5 or 2.5.1. The Solaris header files +changed, so you need to update your gcc installation. You can either +rerun the fixincludes script from gcc or take the opportunity to +update your gcc installation. + +=item sh: ar: not found + +This is a message from your shell telling you that the command 'ar' +was not found. You need to check your PATH environment variable to +make sure that it includes the directory with the 'ar' command. This +is a common problem on Solaris, where 'ar' is in the /usr/ccs/bin/ +directory. + +=back + +=head1 MAKE TEST + +=head2 op/stat.t test 4 + +op/stat.t test 4 may fail if you are on a tmpfs of some sort. +Building in /tmp sometimes shows this behavior. The +test suite detects if you are building in /tmp, but it may not be able +to catch all tmpfs situations. + +=head1 PREBUILT BINARIES. + +You can pick up prebuilt binaries for Solaris from +L, ActiveState L, +and L under the Binaries list at the top of the page. +There are probably other sources as well. Please note that these sites +are under the control of their respective owners, not the perl developers. + +=head1 RUNTIME ISSUES. + +=head2 Limits on Numbers of Open Files. + +The stdio(3C) manpage notes that only 255 files may be opened using +fopen(), and only file descriptors 0 through 255 can be used in a +stream. Since perl calls open() and then fdopen(3C) with the +resulting file descriptor, perl is limited to 255 simultaneous open +files. + +=head1 SOLARIS-SPECIFIC MODULES. + +See the modules under the Solaris:: namespace on CPAN, +L. + +=head1 SOLARIS-SPECIFIC PROBLEMS WITH MODULES. + +=head2 Proc::ProcessTable + +Proc::ProcessTable does not compile on Solaris with perl5.6.0 and higher +if you have LARGEFILES defined. Since largefile support is the +default in 5.6.0 and later, you have to take special steps to use this +module. + +The problem is that various structures visible via procfs use off_t, +and if you compile with largefile support these change from 32 bits to +64 bits. Thus what you get back from procfs doesn't match up with +the structures in perl, resulting in garbage. See proc(4) for further +discussion. + +A fix for Proc::ProcessTable is to edit Makefile to +explicitly remove the largefile flags from the ones MakeMaker picks up +from Config.pm. This will result in Proc::ProcessTable being built +under the correct environment. Everything should then be OK as long as +Proc::ProcessTable doesn't try to share off_t's with the rest of perl, +or if it does they should be explicitly specified as off64_t. + +=head2 BSD::Resource + +BSD::Resource versions earlier than 1.09 do not compile on Solaris +with perl 5.6.0 and higher, for the same reasons as Proc::ProcessTable. +BSD::Resource versions starting from 1.09 have a workaround for the problem. + +=head2 Net::SSLeay + +Net::SSLeay requires a /dev/urandom to be present. This device is not +part of Solaris. You can either get the package SUNWski (packaged with +several Sun software products, for example the Sun WebServer, which is +part of the Solaris Server Intranet Extension, or the Sun Directory +Services, part of Solaris for ISPs) or download the ANDIrand package +from L. If you use SUNWski, make a +symbolic link /dev/urandom pointing to /dev/random. + +It may be possible to use the Entropy Gathering Daemon (written in +Perl!), available from L. + +=head1 AUTHOR + +The original was written by Andy Dougherty F +drawing heavily on advice from Alan Burlison, Nick Ing-Simmons, Tim Bunce, +and many other Solaris users over the years. + +Please report any errors, updates, or suggestions to F. + +=head1 LAST MODIFIED + +$Id: README.solaris,v 1.4 2000/11/11 20:29:58 doughera Exp $ diff --git a/README.vos b/README.vos index 99abf0d..b44f3cf 100644 --- a/README.vos +++ b/README.vos @@ -1,128 +1,189 @@ -Perl 5 README file for the Stratus VOS operating system. -Paul Green (Paul_Green@stratus.com) -February 3, 2000 +If you read this file _as_is_, just ignore the funny characters you +see. It is written in the POD format (see pod/perlpod.pod) which is +specially designed to be readable as is. + +=head1 NAME + +README.vos - Perl for Stratus VOS + +=head1 SYNOPSIS +This is a port of Perl version 5, revision 7, to VOS. Perl is a +scripting or macro language that is popular on many systems. See your +local computer bookstore for a number of good books on Perl. -Introduction ------------- -This is a port of Perl version 5, revision 005-63, to VOS. Perl -is a scripting or macro language that is popular on many -systems. See your local computer bookstore for a number of good -books on Perl. +=head2 Stratus POSIX Support -Most of the Perl features should work on VOS. However, any +Note that there are two different implementations of POSIX.1 +support on VOS. There is an alpha version of POSIX that is +available from the Stratus anonymous ftp site +(ftp://ftp.stratus.com/pub/vos/posix/alpha/alpha.html). There +is a generally-available version of POSIX that comes with the +VOS Standard C compiler and C runtime in VOS Release 14.3.0 or +higher. This port of POSIX will compile and bind with either +version of POSIX. + +Most of the Perl features should work on VOS regardless of which +version of POSIX that you are using. However, the alpha version +of POSIX is missing a number of key functions, and therefore any attempt by perl.pm to call the following unimplemented POSIX functions will result in an error message and an immediate and fatal call to the VOS debugger. They are "dup", "fork", and "waitpid". The lack of these functions pretty much prevents you from starting VOS commands and grabbing their output in perl. The workaround is to run the commands outside of perl, then have -perl process the output file. +perl process the output file. These functions are all available +in the generally-available version of POSIX. + +=head1 INSTALLING PERL IN VOS +=head2 Compiling Perl 5 on VOS -Compiling Perl 5 on VOS ------------------------ Before you can build Perl 5 on VOS, you need to have or acquire the following additional items. -1. The VOS Standard C Compiler and Runtime, or the VOS Standard C - Cross-Compiler. This is a standard Stratus product. +=over 5 + +=item 1 + +The VOS Standard C Compiler and Runtime, or the VOS Standard C +Cross-Compiler. This is a standard Stratus product. -2. The VOS OS TCP/IP product set. While the necessary header - files are included with VOS POSIX.1, you still need the - appropriate object files in order to bind perl.pm. This is - a standard Stratus product. +=item 2 -3. The VOS POSIX.1 environment. As of this writing, this is - available on the VOS FTP site. Login anonymously to - ftp.stratus.com and get the file - /pub/vos/alpha/posix.save.evf.gz in binary file-transfer - mode. Or use the Uniform Resource Locator (URL) - ftp://ftp.stratus.com/pub/vos/alpha/posix.save.evf.gz from - your web browser. This is not a standard Stratus product. +Either the VOS OS TCP/IP or STCP product set. If you are +building with the alpha version of POSIX you need the OS +TCP/IP product set. If you are building with the +generally-available version of POSIX you need the STCP +product set. These are standard Stratus products. - Instructions for unbundling this file are at - ftp://ftp.stratus.com/pub/vos/utility/utility.html. +=item 3 -4. You must compile this version of Perl 5 on VOS Release - 14.1.0 or higher because some of the perl source files - contain more than 32,767 source lines. Due to VOS - release-compatibility rules, this port of perl may not - execute on VOS Release 12 or earlier. +Either the alpha or generally-available version of the VOS +POSIX.1 environment. + +The alpha version of POSIX.1 support is available on the +Stratus FTP site. Login anonymously to ftp.stratus.com and +get the file /pub/vos/posix/alpha/posix.save.evf.gz in +binary file-transfer mode. Or use the Uniform Resource +Locator (URL) +ftp://ftp.stratus.com/pub/vos/alpha/posix.save.evf.gz from +your web browser. Instructions for unbundling this file +are at ftp://ftp.stratus.com/pub/vos/utility/utility.html. +This is not a standard Stratus product. + +The generally-available version of POSIX.1 support is +bundled with the VOS Standard C compiler and Runtime (or +Cross-Compiler) in VOS Release 14.3.0 or higher. This is a +standard Stratus product. + +=item 4 + +You must compile this version of Perl 5 on VOS Release +14.1.0 or higher because some of the perl source files +contain more than 32,767 source lines. Due to VOS +release-compatibility rules, this port of perl may not +execute on VOS Release 12 or earlier. + +=back To build perl 5, change to the "vos" subdirectory and type the command "compile_perl -processor X", where X is the processor type (mc68020, i80860, pa7100, pa8000) that you wish to use. +Note that the generally-available version of POSIX.1 support is +not available for the mc68020 or i80860 processors. + +You must have purchased the VOS Standard C Cross Compiler in +order to compile perl for a processor type that is different +from the processor type of the module. + Note that code compiled for the pa7100 processor type can -execute on the PA7100, PA8000, and PA8500 processors, and that -code compiled for the pa8000 processor type can execute on the -PA8000 and PA8500 processors. +execute on the PA7100, PA8000, PA8500 and PA8600 processors, and +that code compiled for the pa8000 processor type can execute on +the PA8000, PA8500 and PA8600 processors. +=head2 Installing Perl 5 on VOS -Installing Perl 5 on VOS ------------------------- -1. Create the directory >system>ported>command_library. +=over 4 -2. Copy the appropriate version of the perl program module to - this directory. For example, with your current directory - set to the top-level directory of Perl 5, to install the - executable program module for the Motorola 68K - architecture, enter: +=item 1 + +Create the directory >system>ported>command_library. + +=item 2 + +Copy the appropriate version of the perl program module to +this directory. For example, with your current directory +set to the top-level directory of Perl 5, to install the +executable program module for the Motorola 68K +architecture, enter: !copy_file vos>obj>perl.pm >system>ported>command_library>* - (If you wish to use both Perl version 4 and Perl version 5, - you must give them different names; for example, perl.pm - and perl5.pm). +(If you wish to use both Perl version 4 and Perl version 5, +you must give them different names; for example, perl.pm +and perl5.pm). + +=item 3 + +Create the directory >system>ported>perl>lib. + +=item 4 + +Copy all of the files and subdirectories from the lib +subdirectory into this new directory. For example, with +the current directory set to the top-level directory of the +perl distribution, enter: + + !copy_dir lib >system>ported>perl>lib>5.7 -3. Create the directory >system>ported>perl>lib. +=item 5 -4. Copy all of the files and subdirectories from the lib - subdirectory into this new directory. For example, with - the current directory set to the top-level directory of the - perl distribution, enter: +While there are currently no architecture-specific +extensions or modules distributed with perl, the following +directories can be used to hold such files: - !copy_dir lib >system>ported>perl>lib>5.005 + >system>ported>perl>lib>5.7.68k + >system>ported>perl>lib>5.7.860 + >system>ported>perl>lib>5.7.7100 + >system>ported>perl>lib>5.7.8000 -5. While there are currently no architecture-specific - extensions or modules distributed with perl, the following - directories can be used to hold such files: +=item 6 - >system>ported>perl>lib>5.005.68k - >system>ported>perl>lib>5.005.860 - >system>ported>perl>lib>5.005.7100 - >system>ported>perl>lib>5.005.8000 +Site-specific perl extensions and modules can be installed in one of +two places. Put architecture-independent files into: -6. Site-specific perl extensions and modules can be installed - in one of two places. Put architecture-independent files - into: + >system>ported>perl>lib>site>5.7 - >system>ported>perl>lib>site>5.005 +Put architecture-dependent files into one of the following +directories: - Put architecture-dependent files into one of the following - directories: + >system>ported>perl>lib>site>5.7.68k + >system>ported>perl>lib>site>5.7.860 + >system>ported>perl>lib>site>5.7.7100 + >system>ported>perl>lib>site>5.7.8000 - >system>ported>perl>lib>site>5.005.68k - >system>ported>perl>lib>site>5.005.860 - >system>ported>perl>lib>site>5.005.7100 - >system>ported>perl>lib>site>5.005.8000 +=item 7 -7. You can examine the @INC variable from within a perl program - to see the order in which Perl searches these directories. +You can examine the @INC variable from within a perl program +to see the order in which Perl searches these directories. +=back -Unimplemented Features ----------------------- -If Perl 5 attempts to call an unimplemented VOS POSIX.1 function, -it will print a fatal error message and enter the VOS debugger. -This error is not recoverable. See vos_dummies.c for a list of -the unimplemented POSIX.1 functions. To see what functions are -unimplemented and what the error message looks like, compile and -execute "test_vos_dummies.c". +=head1 USING PERL IN VOS +=head2 Unimplemented Features + +If perl is built with the alpha version of VOS POSIX.1 support +and if it attempts to call an unimplemented VOS POSIX.1 +function, it will print a fatal error message and enter the VOS +debugger. This error is not recoverable. See vos_dummies.c for +a list of the unimplemented POSIX.1 functions. To see what +functions are unimplemented and what the error message looks +like, compile and execute "test_vos_dummies.c". + +=head2 Restrictions -Restrictions ------------- This port of Perl version 5 to VOS prefers Unix-style, slash-separated pathnames over VOS-style greater-than-separated pathnames. VOS-style pathnames should work in most contexts, but @@ -139,13 +200,19 @@ supported epoch is January 1, 1980 to January 17, 2038. See the file pod/perlport.pod for more information about the VOS port of Perl. +=head1 SUPPORT STATUS -Support Status --------------- I'm offering this port "as is". You can ask me questions, but I -can't guarantee I'll be able to answer them; I don't know much -about Perl itself; I'm still learning that. There are some +can't guarantee I'll be able to answer them. There are some excellent books available on the Perl language; consult a book seller. -(end) +=head1 AUTHOR + +Paul Green (Paul_Green@stratus.com) + +=head1 LAST UPDATE + +October 24, 2000 + +=cut diff --git a/README.win32 b/README.win32 index 8e29acc..ddc1f84 100644 --- a/README.win32 +++ b/README.win32 @@ -14,7 +14,7 @@ These are instructions for building Perl under Windows (9x, NT and =head1 DESCRIPTION Before you start, you should glance through the README file -found in the top-level directory where the Perl distribution +found in the top-level directory to which the Perl distribution was extracted. Make sure you read and understand the terms under which this software is being distributed. @@ -28,10 +28,10 @@ particular, you can safely ignore any information that talks about You may also want to look at two other options for building a perl that will work on Windows NT: the README.cygwin and -README.os2 files, which each give a different set of rules to build -a Perl that will work on Win32 platforms. Those two methods will -probably enable you to build a more Unix-compatible perl, but you -will also need to download and use various other build-time and +README.os2 files, each of which give a different set of rules to +build a Perl that will work on Win32 platforms. Those two methods +will probably enable you to build a more Unix-compatible perl, but +you will also need to download and use various other build-time and run-time support software described in those files. This set of instructions is meant to describe a so-called "native" @@ -70,9 +70,9 @@ A port of dmake for Windows is available from: http://www.cpan.org/authors/id/GSAR/dmake-4.1pl1-win32.zip -(This is a fixed version of original dmake sources obtained from +(This is a fixed version of the original dmake sources obtained from http://www.wticorp.com/dmake/. As of version 4.1PL1, the original -sources did not build as shipped, and had various other problems. +sources did not build as shipped and had various other problems. A patch is included in the above fixed version.) Fetch and install dmake somewhere on your path (follow the instructions @@ -97,20 +97,20 @@ build usually works in this circumstance, but some tests will fail. =item Borland C++ If you are using the Borland compiler, you will need dmake. -(The make that Borland supplies is seriously crippled, and will not +(The make that Borland supplies is seriously crippled and will not work for MakeMaker builds.) -See L/"Make"> above. +See L above. =item Microsoft Visual C++ The nmake that comes with Visual C++ will suffice for building. -You will need to run the VCVARS32.BAT file usually found somewhere +You will need to run the VCVARS32.BAT file, usually found somewhere like C:\MSDEV4.2\BIN. This will set your build environment. -You can also use dmake to build using Visual C++, provided: +You can also use dmake to build using Visual C++; provided, however, you set OSRELEASE to "microsft" (or whatever the directory name -under which the Visual C dmake configuration lives) in your environment, +under which the Visual C dmake configuration lives) in your environment and edit win32/config.vc to change "make=nmake" into "make=dmake". The latter step is only essential if you want to use dmake as your default make for building extensions using MakeMaker. @@ -125,7 +125,7 @@ The GCC-2.95.2 bundle comes with Mingw32 libraries and headers. Make sure you install the binaries that work with MSVCRT.DLL as indicated in the README for the GCC bundle. You may need to set up a few environment -variables (usually run from a batch file). +variables (usually ran from a batch file). The version of gcc-2.95.2-msvcrt.exe released 7 November 1999 left out a fix for certain command line quotes, so be sure to download and install @@ -149,12 +149,12 @@ makefile are setup to build using the GCC compiler. =item * -Edit the makefile.mk (or Makefile, if using nmake) and change the values -of INST_DRV and INST_TOP. You can also enable various build -flags. These are explained in the makefiles. +Edit the makefile.mk (or Makefile, if you're using nmake) and change +the values of INST_DRV and INST_TOP. You can also enable various +build flags. These are explained in the makefiles. -You will have to make sure CCTYPE is set correctly, and CCHOME points -to wherever you installed your compiler. +You will have to make sure that CCTYPE is set correctly and that +CCHOME points to wherever you installed your compiler. The default value for CCHOME in the makefiles for Visual C++ may not be correct for some versions. Make sure the default exists @@ -165,7 +165,7 @@ enable the appropriate option in the makefile. des_fcrypt() is not bundled with the distribution due to US Government restrictions on the export of cryptographic software. Nevertheless, this routine is part of the "libdes" library (written by Eric Young) which is widely -available worldwide, usually along with SSLeay (for example: +available worldwide, usually along with SSLeay (for example, "ftp://fractal.mta.ca/pub/crypto/SSLeay/DES/"). Set CRYPT_SRC to the name of the file that implements des_fcrypt(). Alternatively, if you have built a library that contains des_fcrypt(), you can set @@ -212,7 +212,7 @@ If you're using the Borland compiler, you may see a failure in op/taint.t arising from the inability to find the Borland Runtime DLLs on the system default path. You will need to copy the DLLs reported by the messages from where Borland chose to install it, into the Windows system directory -(usually somewhere like C:\WINNT\SYSTEM32), and rerun the test. +(usually somewhere like C:\WINNT\SYSTEM32) and rerun the test. Please report any other failures as described under L. @@ -224,7 +224,7 @@ Makefile. It will also install the pod documentation under C<$INST_TOP\$VERSION\lib\pod> and HTML versions of the same under C<$INST_TOP\$VERSION\lib\pod\html>. To use the Perl you just installed, you will need to add two components to your PATH environment variable, -C<$INST_TOP\$VERSION\bin>, and C<$INST_TOP\$VERSION\bin\$ARCHNAME>. +C<$INST_TOP\$VERSION\bin> and C<$INST_TOP\$VERSION\bin\$ARCHNAME>. For example: set PATH c:\perl\5.6.0\bin;c:\perl\5.6.0\bin\MSWin32-x86;%PATH% @@ -301,24 +301,28 @@ runtime do any wildcard expansions of command-line arguments (so wildcards need not be quoted). Also, the quoting behaviours of the shell and the C runtime are rudimentary at best (and may, if you are using a non-standard shell, be inconsistent). The only (useful) quote -character is the double quote ("). It can be used to protect spaces in -arguments and other special characters. The Windows NT documentation -has almost no description of how the quoting rules are implemented, but -here are some general observations based on experiments: The C runtime -breaks arguments at spaces and passes them to programs in argc/argv. -Doublequotes can be used to prevent arguments with spaces in them from -being split up. You can put a double quote in an argument by escaping -it with a backslash and enclosing the whole argument within double -quotes. The backslash and the pair of double quotes surrounding the -argument will be stripped by the C runtime. +character is the double quote ("). It can be used to protect spaces +and other special characters in arguments. + +The Windows NT documentation has almost no description of how the +quoting rules are implemented, but here are some general observations +based on experiments: The C runtime breaks arguments at spaces and +passes them to programs in argc/argv. Double quotes can be used to +prevent arguments with spaces in them from being split up. You can +put a double quote in an argument by escaping it with a backslash and +enclosing the whole argument within double quotes. The backslash and +the pair of double quotes surrounding the argument will be stripped by +the C runtime. The file redirection characters "<", ">", and "|" can be quoted by double quotes (although there are suggestions that this may not always -be true). Single quotes are not treated as quotes by the shell or the C -runtime. The caret "^" has also been observed to behave as a quoting -character, but this appears to be a shell feature, and the caret is not -stripped from the command line, so Perl still sees it (and the C runtime -phase does not treat the caret as a quote character). +be true). Single quotes are not treated as quotes by the shell or +the C runtime, they don't get stripped by the shell (just to make +this type of quoting completely useless). The caret "^" has also +been observed to behave as a quoting character, but this appears +to be a shell feature, and the caret is not stripped from the command +line, so Perl still sees it (and the C runtime phase does not treat +the caret as a quote character). Here are some examples of usage of the "cmd" shell: @@ -386,12 +390,12 @@ be built, tested and installed with the standard mantra: where $MAKE is whatever 'make' program you have configured perl to use. Use "perl -V:make" to find out what this is. Some extensions -may not provide a testsuite (so "$MAKE test" may not do anything, or +may not provide a testsuite (so "$MAKE test" may not do anything or fail), but most serious ones do. It is important that you use a supported 'make' program, and ensure Config.pm knows about it. If you don't have nmake, you can -either get dmake from the location mentioned earlier, or get an +either get dmake from the location mentioned earlier or get an old version of nmake reportedly available from: ftp://ftp.microsoft.com/Softlib/MSLFILES/nmake15.exe @@ -439,11 +443,11 @@ be a source of frustration if you use such a perl binary with an alternate shell that *does* expand wildcards. Instead, the following solution works rather well. The nice things -about it: 1) you can start using it right away 2) it is more powerful, -because it will do the right thing with a pattern like */*/*.c -3) you can decide whether you do/don't want to use it 4) you can -extend the method to add any customizations (or even entirely -different kinds of wildcard expansion). +about it are 1) you can start using it right away; 2) it is more +powerful, because it will do the right thing with a pattern like +*/*/*.c; 3) you can decide whether you do/don't want to use it; and +4) you can extend the method to add any customizations (or even +entirely different kinds of wildcard expansion). C:\> copy con c:\perl\lib\Wild.pm # Wild.pm - emulate shell @ARGV expansion on shells that don't @@ -485,7 +489,7 @@ from CPAN. You may find that many of these extensions are meant to be used under the Activeware port of Perl, which used to be the only native port for the Win32 platform. Since the Activeware port does not have adequate support for Perl's extension building tools, these -extensions typically do not support those tools either, and therefore +extensions typically do not support those tools either and, therefore, cannot be built using the generic steps shown in the previous section. To ensure smooth transitioning of existing code that uses the @@ -541,7 +545,7 @@ If you use the 4DOS/NT or similar command shell, note that refer to all the command line arguments, so you may need to make sure that construct works in batch files. As of this writing, 4DOS/NT users will need a "ParameterChar = *" statement in their -4NT.INI file, or will need to execute "setdos /p*" in the 4DOS/NT +4NT.INI file or will need to execute "setdos /p*" in the 4DOS/NT startup file to enable this to work. =item 3 @@ -591,11 +595,25 @@ find a mailer on your system). =head1 BUGS AND CAVEATS +Norton AntiVirus interferes with the build process, particularly if +set to "AutoProtect, All Files, when Opened". Unlike large applications +the perl build process opens and modifies a lot of files. Having the +the AntiVirus scan each and every one slows build the process significantly. +Worse, with PERLIO=stdio the build process fails with peculiar messages +as the virus checker interacts badly with miniperl.exe writing configure +files (it seems to either catch file part written and treat it as suspicious, +or virus checker may have it "locked" in a way which inhibits miniperl +updating it). The build does complete with + + set PERLIO=perlio + +but that may be just luck. Other AntiVirus software may have similar issues. + Some of the built-in functions do not act exactly as documented in L, and a few are not implemented at all. To avoid surprises, particularly if you have had prior exposure to Perl in other operating environments or if you intend to write code -that will be portable to other environments, see L +that will be portable to other environments. See L for a reasonably definitive list of these differences. Not all extensions available from CPAN may build or work properly @@ -620,11 +638,11 @@ by C. =over 4 -Gary Ng E71564.1743@CompuServe.COME +=item Gary Ng E71564.1743@CompuServe.COME -Gurusamy Sarathy Egsar@activestate.comE +=item Gurusamy Sarathy Egsar@activestate.comE -Nick Ing-Simmons Enick@ni-s.u-net.comE +=item Nick Ing-Simmons Enick@ing-simmons.netE =back @@ -651,6 +669,6 @@ Support for fork() emulation was added in 5.6 (ActiveState Tool Corp). Win9x support was added in 5.6 (Benjamin Stuhl). -Last updated: 22 March 2000 +Last updated: 22 November 2000 =cut diff --git a/av.c b/av.c index ef2c905..273fed9 100644 --- a/av.c +++ b/av.c @@ -1,6 +1,6 @@ /* av.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -34,10 +34,8 @@ Perl_av_reify(pTHX_ AV *av) while (key) { sv = AvARRAY(av)[--key]; assert(sv); - if (sv != &PL_sv_undef) { - dTHR; + if (sv != &PL_sv_undef) (void)SvREFCNT_inc(sv); - } } key = AvARRAY(av) - AvALLOC(av); while (key) @@ -58,7 +56,6 @@ extended. void Perl_av_extend(pTHX_ AV *av, I32 key) { - dTHR; /* only necessary if we have to extend stack */ MAGIC *mg; if ((mg = SvTIED_mg((SV*)av, 'P'))) { dSP; @@ -189,7 +186,6 @@ Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval) if (SvRMAGICAL(av)) { if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) { - dTHR; sv = sv_newmortal(); mg_copy((SV*)av, sv, 0, key); PL_av_fetch_sv = sv; @@ -272,7 +268,6 @@ Perl_av_store(pTHX_ register AV *av, I32 key, SV *val) ary = AvARRAY(av); if (AvFILLp(av) < key) { if (!AvREAL(av)) { - dTHR; if (av == PL_curstack && key > PL_stack_sp - PL_stack_base) PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */ do @@ -554,6 +549,7 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num) register I32 i; register SV **ary; MAGIC* mg; + I32 slide; if (!av || num <= 0) return; @@ -591,6 +587,9 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num) } if (num) { i = AvFILLp(av); + /* Create extra elements */ + slide = i > 0 ? i : 0; + num += slide; av_extend(av, i + num); AvFILLp(av) += num; ary = AvARRAY(av); @@ -598,6 +597,10 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num) do { ary[--num] = &PL_sv_undef; } while (num); + /* Make extra elements into a buffer */ + AvMAX(av) -= slide; + AvFILLp(av) -= slide; + SvPVX(av) = (char*)(AvARRAY(av) + slide); } } @@ -796,9 +799,14 @@ Perl_av_exists(pTHX_ AV *av, I32 key) if (SvRMAGICAL(av)) { if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) { SV *sv = sv_newmortal(); + MAGIC *mg; + mg_copy((SV*)av, sv, 0, key); - magic_existspack(sv, mg_find(sv, 'p')); - return SvTRUE(sv); + mg = mg_find(sv, 'p'); + if (mg) { + magic_existspack(sv, mg); + return SvTRUE(sv); + } } } if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef diff --git a/av.h b/av.h index 4a18430..8f130d6 100644 --- a/av.h +++ b/av.h @@ -1,6 +1,6 @@ /* av.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. diff --git a/bytecode.pl b/bytecode.pl index 9321604..8d77620 100644 --- a/bytecode.pl +++ b/bytecode.pl @@ -106,7 +106,6 @@ bset_obj_store(pTHXo_ struct byteloader_state *bstate, void *obj, I32 ix) void byterun(pTHXo_ register struct byteloader_state *bstate) { - dTHR; register int insn; U32 ix; SV *specialsv_list[6]; diff --git a/config_h.SH b/config_h.SH index a209e6d..596faf9 100644 --- a/config_h.SH +++ b/config_h.SH @@ -605,12 +605,6 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_strtol HAS_STRTOL /**/ -/* HAS_STRTOUL: - * This symbol, if defined, indicates that the strtoul routine is - * available to provide conversion of strings to unsigned long. - */ -#$d_strtoul HAS_STRTOUL /**/ - /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. @@ -981,12 +975,6 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #define SH_PATH "$sh" /**/ -/* STDCHAR: - * This symbol is defined to be the type of char used in stdio.h. - * It has the values "unsigned char" or "char". - */ -#define STDCHAR $stdchar /**/ - /* CROSSCOMPILE: * This symbol, if defined, signifies that we our * build process is a cross-compilation. @@ -1228,6 +1216,12 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #define CPPRUN "$cpprun" #define CPPLAST "$cpplast" +/* HAS__FWALK: + * This symbol, if defined, indicates that the _fwalk system call is + * available to apply a function to all the file handles. + */ +#$d__fwalk HAS__FWALK /**/ + /* HAS_ACCESS: * This manifest constant lets the C program know that the access() * system call is available to check for accessibility using real UID/GID. @@ -1325,6 +1319,13 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_endsent HAS_ENDSERVENT /**/ +/* FCNTL_CAN_LOCK: + * This symbol, if defined, indicates that fcntl() can be used + * for file locking. Normally on Unix systems this is defined. + * It may be undefined on VMS. + */ +#$d_fcntl_can_lock FCNTL_CAN_LOCK /**/ + /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in @@ -1367,6 +1368,13 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_fstatfs HAS_FSTATFS /**/ +/* HAS_FSYNC: + * This symbol, if defined, indicates that the fsync routine is + * available to write a file's modified data and attributes to + * permanent storage. + */ +#$d_fsync HAS_FSYNC /**/ + /* HAS_FTELLO: * This symbol, if defined, indicates that the ftello routine is * available to ftell beyond 32 bits (useful for ILP32 hosts). @@ -1507,12 +1515,30 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_getnetprotos HAS_GETNET_PROTOS /**/ +/* HAS_GETPAGESIZE: + * This symbol, if defined, indicates that the getpagesize system call + * is available to get system page size, which is the granularity of + * many memory management calls. + */ +#$d_getpagsz HAS_GETPAGESIZE /**/ + /* HAS_GETPROTOENT: * This symbol, if defined, indicates that the getprotoent() routine is * available to look up protocols in some data base or another. */ #$d_getpent HAS_GETPROTOENT /**/ +/* HAS_GETPGRP: + * This symbol, if defined, indicates that the getpgrp routine is + * available to get the current process group. + */ +/* USE_BSD_GETPGRP: + * This symbol, if defined, indicates that getpgrp needs one + * arguments whereas USG one needs none. + */ +#$d_getpgrp HAS_GETPGRP /**/ +#$d_bsdgetpgrp USE_BSD_GETPGRP /**/ + /* HAS_GETPROTOBYNAME: * This symbol, if defined, indicates that the getprotobyname() * routine is available to look up protocols by their name. @@ -1822,6 +1848,15 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_sanemcmp HAS_SANE_MEMCMP /**/ +/* HAS_SBRK_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the sbrk() function. Otherwise, it is up + * to the program to supply one. Good guesses are + * extern void* sbrk _((int)); + * extern void* sbrk _((size_t)); + */ +#$d_sbrkproto HAS_SBRK_PROTO /**/ + /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. @@ -1859,6 +1894,18 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_setpent HAS_SETPROTOENT /**/ +/* HAS_SETPGRP: + * This symbol, if defined, indicates that the setpgrp routine is + * available to set the current process group. + */ +/* USE_BSD_SETPGRP: + * This symbol, if defined, indicates that setpgrp needs two + * arguments whereas USG one needs none. See also HAS_SETPGID + * for a POSIX interface. + */ +#$d_setpgrp HAS_SETPGRP /**/ +#$d_bsdsetpgrp USE_BSD_SETPGRP /**/ + /* HAS_SETPROCTITLE: * This symbol, if defined, indicates that the setproctitle routine is * available to set process title. @@ -2048,12 +2095,23 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol is defined if the FILE_cnt macro can be used as an * lvalue. */ +/* STDIO_PTR_LVAL_SETS_CNT: + * This symbol is defined if using the FILE_ptr macro as an lvalue + * to increase the pointer by n has the side effect of decreasing the + * value of File_cnt(fp) by n. + */ +/* STDIO_PTR_LVAL_NOCHANGE_CNT: + * This symbol is defined if using the FILE_ptr macro as an lvalue + * to increase the pointer by n leaves File_cnt(fp) unchanged. + */ #$d_stdstdio USE_STDIO_PTR /**/ #ifdef USE_STDIO_PTR #define FILE_ptr(fp) $stdio_ptr #$d_stdio_ptr_lval STDIO_PTR_LVALUE /**/ #define FILE_cnt(fp) $stdio_cnt #$d_stdio_cnt_lval STDIO_CNT_LVALUE /**/ +#$d_stdio_ptr_lval_sets_cnt STDIO_PTR_LVAL_SETS_CNT /**/ +#$d_stdio_ptr_lval_nochange_cnt STDIO_PTR_LVAL_NOCHANGE_CNT /**/ #endif /* USE_STDIO_BASE: @@ -2113,6 +2171,18 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_strtoll HAS_STRTOLL /**/ +/* HAS_STRTOQ: + * This symbol, if defined, indicates that the strtoq routine is + * available to convert strings to long longs (quads). + */ +#$d_strtoq HAS_STRTOQ /**/ + +/* HAS_STRTOUL: + * This symbol, if defined, indicates that the strtoul routine is + * available to provide conversion of strings to unsigned long. + */ +#$d_strtoul HAS_STRTOUL /**/ + /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. @@ -2603,6 +2673,17 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #define RD_NODATA $rd_nodata #$d_eofnblk EOF_NONBLOCK +/* NEED_VA_COPY: + * This symbol, if defined, indicates that the system stores + * the variable argument list datatype, va_list, in a format + * that cannot be copied by simple assignment, so that some + * other means must be used when copying is required. + * As such systems vary in their provision (or non-provision) + * of copying mechanisms, handy.h defines a platform- + * independent macro, Perl_va_copy(src, dst), to do the job. + */ +#$need_va_copy NEED_VA_COPY /**/ + /* Netdb_host_t: * This symbol holds the type used for the 1st argument * to gethostbyaddr(). @@ -2952,6 +3033,12 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #define STARTPERL "$startperl" /**/ +/* STDCHAR: + * This symbol is defined to be the type of char used in stdio.h. + * It has the values "unsigned char" or "char". + */ +#define STDCHAR $stdchar /**/ + /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array * holding the stdio streams. @@ -3170,28 +3257,5 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #define PERL_XS_APIVERSION "$xs_apiversion" #define PERL_PM_APIVERSION "$pm_apiversion" -/* HAS_GETPGRP: - * This symbol, if defined, indicates that the getpgrp routine is - * available to get the current process group. - */ -/* USE_BSD_GETPGRP: - * This symbol, if defined, indicates that getpgrp needs one - * arguments whereas USG one needs none. - */ -#$d_getpgrp HAS_GETPGRP /**/ -#$d_bsdgetpgrp USE_BSD_GETPGRP /**/ - -/* HAS_SETPGRP: - * This symbol, if defined, indicates that the setpgrp routine is - * available to set the current process group. - */ -/* USE_BSD_SETPGRP: - * This symbol, if defined, indicates that setpgrp needs two - * arguments whereas USG one needs none. See also HAS_SETPGID - * for a POSIX interface. - */ -#$d_setpgrp HAS_SETPGRP /**/ -#$d_bsdsetpgrp USE_BSD_SETPGRP /**/ - #endif !GROK!THIS! diff --git a/configure.com b/configure.com index 28ce5e8..2efd8bd 100644 --- a/configure.com +++ b/configure.com @@ -53,10 +53,20 @@ $ use_two_pot_malloc = "N" $ use_pack_malloc = "N" $ use_debugmalloc = "N" $ ccflags = "" +$ static_ext = "" $ vms_default_directory_name = F$ENVIRONMENT("DEFAULT") $ max_allowed_dir_depth = 3 ! e.g. [A.B.PERLxxx] not [A.B.C.PERLxxx] $! max_allowed_dir_depth = 2 ! e.g. [A.PERLxxx] not [A.B.PERLxxx] $! +$! Sebastian Bazley's request: close the CONFIG handle with /NOLOG +$! qualifier "just in case" (configure.com is re @ed in a bad state). +$! This construct was tested to be not a problem as far back as +$! VMS V5.5-2, hopefully earlier versions are OK as well. +$! +$ CLOSE/NOLOG CONFIG +$! +$! Now keep track of open files +$! $ vms_filcnt = F$GETJPI ("","FILCNT") $! $!: compute my invocation name @@ -2061,6 +2071,10 @@ $ ans = F$EDIT(ans,"TRIM,COMPRESS,LOWERCASE") $ IF ans.eqs."decc" then Has_Dec_C_Sockets = "T" $ IF ans.eqs."socketshr" then Has_socketshr = "T" $ ENDIF +$ IF Has_Dec_C_Sockets .or. Has_socketshr +$ THEN +$ static_ext = f$edit(static_ext+" "+"Socket","trim,compress") +$ ENDIF $! $! $! Ask if they want to build with VMS_DEBUG perl @@ -2367,8 +2381,8 @@ $ echo "you might, for example, want to build GDBM_File instead of" $ echo "SDBM_File if you have the GDBM library built on your machine." $ echo "" $ echo "Which modules do you want to build into perl?" -$! dflt = "Fcntl Errno File::Glob IO Opcode Byteloader Devel::Peek Devel::DProf Data::Dumper attrs re VMS::Stdio VMS::DCLsym B SDBM_File" -$ dflt = "re Fcntl Errno File::Glob IO Opcode Devel::Peek Devel::DProf Data::Dumper attrs VMS::Stdio VMS::DCLsym B SDBM_File Storable Thread Sys::Hostname" +$! we need to add Byteloader to this list: +$ dflt = "re Fcntl Encode Errno File::Glob Filter::Util::Call IO Opcode Devel::Peek Devel::DProf Data::Dumper attrs VMS::Stdio VMS::DCLsym B SDBM_File Storable Thread Sys::Hostname" $ IF Using_Dec_C .OR. using_cxx $ THEN $ dflt = dflt + " POSIX" @@ -2594,6 +2608,39 @@ $ GOTO Clean_up $ ENDIF $ ENDIF $! +$! PerlIO abstraction +$! +$ dflt = "n" +$ IF F$TYPE(useperlio) .NES. "" +$ THEN +$ IF useperlio THEN dflt = "y" +$ IF useperlio .EQS. "define" THEN dflt = "y" +$ ENDIF +$ IF .NOT. silent +$ THEN +$ echo "Previous version of ''package' used the standard IO mechanisms as" +$ TYPE SYS$INPUT: +$ DECK +defined in . Versions 5.003_02 and later of perl allow +alternate IO mechanisms via the PerlIO abstraction layer, but the +stdio mechanism is still the default. This abstraction layer can +use AT&T's sfio (if you already have sfio installed) or regular stdio. +Using PerlIO with sfio may cause problems with some extension modules. + +$ EOD +$ echo "If this does not make any sense to you, just accept the default '" + dflt + "'." +$ ENDIF +$ rp = "Use the experimental PerlIO abstraction layer? [''dflt'] " +$ GOSUB myread +$ IF ans .EQS. "" THEN ans = dflt +$ IF ans +$ THEN +$ useperlio = "define" +$ ELSE +$ echo "Ok, doing things the stdio way." +$ useperlio = "undef" +$ ENDIF +$! $ echo "" $ echo4 "Checking the C run-time library." $! @@ -2733,7 +2780,8 @@ $ ELSE d_mymalloc="undef" $ ENDIF $! $ usedl="define" -$ startperl="""$ perl 'f$env(\""procedure\"")' 'p1' 'p2' 'p3' 'p4' 'p5' 'p6' 'p7' 'p8' !\n$ exit++ + ++$status != 0 and $exit = $status = undef;""" +$ startperl="""$ perl 'f$env(\""procedure\"")' \""'"+"'p1'\"" \""'"+"'p2'\"" \""'"+"'p3'\"" \""'"+"'p4'\"" \""'"+"'p5'\"" \""'"+"'p6'\"" \""'"+"'p7'\"" \""'"+"'p8'\""!\n" +$ startperl=startperl + "$ exit++ + ++$status!=0 and $exit=$status=undef; while($#ARGV != -1 and $ARGV[$#ARGV] eq '"+"'){pop @ARGV;}""" $! $ IF ((Use_Threads) .AND. (vms_ver .LES. "6.2")) $ THEN @@ -3475,6 +3523,54 @@ $ tmp = "fcntl" $ GOSUB inlibc $ d_fcntl = tmp $! +$! Check for fcntl locking capability +$! +$ echo4 "Checking if fcntl-based file locking works... " +$ tmp = "undef" +$ IF d_fcntl .EQS. "define" +$ THEN +$ OS +$ WS "#include " +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include " +$ WS "#endif" +$ WS "#include " +$ WS "#include " +$ WS "int main() {" +$ WS "#if defined(F_SETLK) && defined(F_SETLKW)" +$ WS " struct flock flock;" +$ WS " int retval, fd;" +$ WS " fd = open(""try.c"", O_RDONLY);" +$ WS " flock.l_type = F_RDLCK;" +$ WS " flock.l_whence = SEEK_SET;" +$ WS " flock.l_start = flock.l_len = 0;" +$ WS " retval = fcntl(fd, F_SETLK, &flock);" +$ WS " close(fd);" +$ WS " (retval < 0 ? printf(""undef\n"") : printf(""define\n""));" +$ WS "#else" +$ WS " printf(""undef\n"");" +$ WS "#endif" +$ WS "}" +$ CS +$ GOSUB link_ok +$ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link +$ THEN +$ GOSUB just_mcr_it +$ IF tmp .EQS. "define" +$ THEN +$ echo4 "Yes, it seems to work." +$ ELSE +$ echo4 "Nope, it didn't work." +$ ENDIF +$ ELSE +$ echo4 "I'm unable to compile the test program, so I'll assume not." +$ tmp = "undef" +$ ENDIF +$ ELSE +$ echo4 "Nope, since you don't even have fcntl()." +$ ENDIF +$ d_fcntl_can_lock = tmp +$! $! Check for memchr $! $ OS @@ -3547,6 +3643,42 @@ $ tmp = "strtoll" $ GOSUB inlibc $ d_strtoll = tmp $! +$! Check for strtoq +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include " +$ WS "#endif" +$ WS "#include " +$ WS "int main()" +$ WS "{" +$ WS "__int64 result;" +$ WS "result = strtoq(""123123"", NULL, 10);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "strtoq" +$ GOSUB inlibc +$ d_strtoq = tmp +$! +$! Check for strtoq +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include " +$ WS "#endif" +$ WS "#include " +$ WS "int main()" +$ WS "{" +$ WS "__int64 result;" +$ WS "result = strtoq(""123123"", NULL, 10);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "strtoq" +$ GOSUB inlibc +$ d_strtoq = tmp +$! $! Check for strtold $! $ OS @@ -3764,6 +3896,43 @@ $ tmp = "setvbuf" $ GOSUB inlibc $ d_setvbuf = tmp $! +$! see if sfio.h is available +$! see if sfio library is available +$! Ok, but do we want to use it. +$! IF F$TYPE(usesfio) .EQS. "" THEN usesfio = "undef" +$! IF val .EQS. "define" +$! THEN +$! IF usesfio .EQS. "define" +$! THEN dflt = "y" +$! ELSE dflt = "n" +$! ENDIF +$! echo "''package' can use the sfio library, but it is experimental." +$! IF useperlio .EQS. "undef" +$! THEN +$! echo "For sfio also the PerlIO abstraction layer is needed." +$! echo "Earlier you said you would not want that." +$! ENDIF +$! rp="You seem to have sfio available, do you want to try using it? [''dflt'] " +$! GOSUB myread +$! IF ans .EQS. "" THEN ans = dflt +$! IF ans +$! THEN +$! echo "Ok, turning on both sfio and PerlIO, then." +$! useperlio="define" +$! val="define" +$! ELSE +$! echo "Ok, avoiding sfio this time. I'll use stdio instead." +$! val="undef" +$! ENDIF +$! ELSE +$! IF usesfio .EQS. "define" +$! THEN +$! echo4 "Sorry, cannot find sfio on this machine." +$! echo4 "Ignoring your setting of usesfio=''usesfio'." +$! val="undef" +$! ENDIF +$! ENDIF +$! $! Check for setenv $! $ OS @@ -4401,6 +4570,8 @@ $ i_locale="undef" $ d_locconv="undef" $ d_setlocale="undef" $ ENDIF +$ d_stdio_ptr_lval_sets_cnt="undef" +$ d_stdio_ptr_lval_nochange_cnt="undef" $! $! Sockets? $ if Has_Socketshr .OR. Has_Dec_C_Sockets @@ -4691,6 +4862,7 @@ $ WC "cppminus='" + cppminus + "'" $ WC "cpprun='" + cpprun + "'" $ WC "cppstdin='" + cppstdin + "'" $ WC "crosscompile='undef'" +$ WC "d__fwalk='undef'" $ WC "d_Gconvert='my_gconvert(x,n,t,b)'" $ WC "d_PRId64='" + d_PRId64 + "'" $ WC "d_PRIEldbl='" + d_PRIEUldbl + "'" @@ -4750,6 +4922,7 @@ $ WC "d_eunice='undef'" $ WC "d_fchmod='undef'" $ WC "d_fchown='undef'" $ WC "d_fcntl='" + d_fcntl + "'" +$ WC "d_fcntl_can_lock='" + d_fcntl_can_lock + "'" $ WC "d_fd_set='" + d_fd_set + "'" $ WC "d_fgetpos='define'" $ WC "d_flexfnam='define'" @@ -4763,6 +4936,7 @@ $ WC "d_fseeko='undef'" $ WC "d_fsetpos='define'" $ WC "d_fstatfs='undef'" $ WC "d_fstatvfs='undef'" +$ WC "d_fsync='undef'" $ WC "d_ftello='undef'" $ WC "d_getcwd='undef'" $ WC "d_getespwnam='undef'" @@ -4781,6 +4955,7 @@ $ WC "d_getnbyaddr='" + d_getnbyaddr + "'" $ WC "d_getnbyname='" + d_getnbyname + "'" $ WC "d_getnent='" + d_getnent + "'" $ WC "d_getnetprotos='" + d_getnetprotos + "'" +$ WC "d_getpagsz='undef'" $ WC "d_getpbyname='" + d_getpbyname + "'" $ WC "d_getpbynumber='" + d_getpbynumber + "'" $ WC "d_getpent='" + d_getpent + "'" @@ -4885,6 +5060,7 @@ $ WC "d_rmdir='define'" $ WC "d_safebcpy='undef'" $ WC "d_safemcpy='define'" $ WC "d_sanemcmp='define'" +$ WC "d_sbrkproto='undef'" $ WC "d_sched_yield='" + d_sched_yield + "'" $ WC "d_scm_rights='undef'" $ WC "d_seekdir='define'" @@ -4934,6 +5110,8 @@ $ WC "d_statfs_s='undef'" $ WC "d_statfsflags='undef'" $ WC "d_stdio_cnt_lval='" + d_stdio_cnt_lval + "'" $ WC "d_stdio_ptr_lval='" + d_stdio_ptr_lval + "'" +$ WC "d_stdio_ptr_lval_sets_cnt='" + d_stdio_ptr_lval_sets_cnt + "'" +$ WC "d_stdio_ptr_lval_nochange_cnt='" + d_stdio_ptr_lval_nochange_cnt + "'" $ WC "d_stdio_stream_array='undef'" $ WC "d_stdiobase='" + d_stdiobase + "'" $ WC "d_stdstdio='" + d_stdstdio + "'" @@ -4946,6 +5124,7 @@ $ WC "d_strtod='define'" $ WC "d_strtol='define'" $ WC "d_strtold='" + d_strtold + "'" $ WC "d_strtoll='" + d_strtoll + "'" +$ WC "d_strtoq='define'" $ WC "d_strtoul='define'" $ WC "d_strtoull='" + d_strtoull + "'" $ WC "d_strtouq='" + d_strtouq + "'" @@ -4995,6 +5174,7 @@ $ WC "drand01='" + drand01 + "'" $ WC "dynamic_ext='" + extensions + "'" $ WC "eagain=' '" $ WC "ebcdic='undef'" +$ WC "embedmymalloc='" + mymalloc + "'" $ WC "eunicefix=':'" $ WC "exe_ext='" + exe_ext + "'" $ WC "extensions='" + extensions + "'" @@ -5131,6 +5311,7 @@ $ WC "multiarch='undef'" $ WC "mydomain='" + mydomain + "'" $ WC "myhostname='" + myhostname + "'" $ WC "myuname='" + myuname + "'" +$ WC "need_va_copy='undef'" $ WC "netdb_hlen_type='" + netdb_hlen_type + "'" $ WC "netdb_host_type='" + netdb_host_type + "'" $ WC "netdb_name_type='" + netdb_name_type + "'" @@ -5213,7 +5394,7 @@ $ WC "spitshell='write sys$output '" $ WC "src='" + src + "'" $ WC "ssizetype='int'" $ WC "startperl=" + startperl ! This one's special--no enclosing single quotes -$ WC "static_ext='" + "'" +$ WC "static_ext='" + static_ext + "'" $ WC "stdchar='" + stdchar + "'" $ WC "stdio_base='((*fp)->_base)'" $ WC "stdio_bufsiz='((*fp)->_cnt + (*fp)->_ptr - (*fp)->_base)'" @@ -5238,6 +5419,7 @@ $ WC "uquadtype='" + uquadtype + "'" $ WC "use5005threads='" + use5005threads + "'" $ WC "use64bitall='" + use64bitall + "'" $ WC "use64bitint='" + use64bitint + "'" +$ WC "usedebugging_perl='" + use_debugging_perl + "'" $ WC "usedl='" + usedl + "'" $ WC "useithreads='" + useithreads + "'" $ WC "uselargefiles='" + uselargefiles + "'" @@ -5245,7 +5427,7 @@ $ WC "uselongdouble='" + uselongdouble + "'" $ WC "usemorebits='" + usemorebits + "'" $ WC "usemultiplicity='" + usemultiplicity + "'" $ WC "usemymalloc='" + usemymalloc + "'" -$ WC "useperlio='undef'" +$ WC "useperlio='" + useperlio + "'" $ WC "useposix='false'" $ WC "usesocks='undef'" $ WC "usethreads='" + usethreads + "'" diff --git a/cop.h b/cop.h index 6e8bd91..5c3bafa 100644 --- a/cop.h +++ b/cop.h @@ -1,6 +1,6 @@ /* cop.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -21,6 +21,7 @@ struct cop { I32 cop_arybase; /* array base this line was compiled with */ line_t cop_line; /* line # of this command */ SV * cop_warnings; /* lexical warnings bitmask */ + SV * cop_io; /* lexical IO defaults */ }; #define Nullcop Null(COP*) diff --git a/cv.h b/cv.h index adb424e..4ade508 100644 --- a/cv.h +++ b/cv.h @@ -1,6 +1,6 @@ /* cv.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -75,6 +75,7 @@ Returns the stash of the CV. #define CVf_METHOD 0x0040 /* CV is explicitly marked as a method */ #define CVf_LOCKED 0x0080 /* CV locks itself or first arg on entry */ #define CVf_LVALUE 0x0100 /* CV return value can be used as lvalue */ +#define CVf_CONST 0x0200 /* inlinable sub */ #define CvCLONE(cv) (CvFLAGS(cv) & CVf_CLONE) #define CvCLONE_on(cv) (CvFLAGS(cv) |= CVf_CLONE) @@ -122,3 +123,7 @@ Returns the stash of the CV. #define CvSPECIAL(cv) (CvUNIQUE(cv) && SvFAKE(cv)) #define CvSPECIAL_on(cv) (CvUNIQUE_on(cv),SvFAKE_on(cv)) #define CvSPECIAL_off(cv) (CvUNIQUE_off(cv),SvFAKE_off(cv)) + +#define CvCONST(cv) (CvFLAGS(cv) & CVf_CONST) +#define CvCONST_on(cv) (CvFLAGS(cv) |= CVf_CONST) +#define CvCONST_off(cv) (CvFLAGS(cv) &= ~CVf_CONST) diff --git a/cygwin/cygwin.c b/cygwin/cygwin.c index db1c426..962a60a 100644 --- a/cygwin/cygwin.c +++ b/cygwin/cygwin.c @@ -27,11 +27,9 @@ do_spawnvp (const char *path, const char * const *argv) childpid = spawnvp(_P_NOWAIT,path,argv); if (childpid < 0) { status = -1; - if(ckWARN(WARN_EXEC)) { - dTHR; + if(ckWARN(WARN_EXEC)) Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%s\": %s", path,Strerror (errno)); - } } else { do { result = wait4pid(childpid, &status, 0); @@ -146,7 +144,7 @@ XS(Cygwin_cwd) if(items != 0) Perl_croak(aTHX_ "Usage: Cwd::cwd()"); - if((cwd = getcwd(NULL, 0))) { + if((cwd = getcwd(NULL, -1))) { ST(0) = sv_2mortal(newSVpv(cwd, 0)); safesysfree(cwd); XSRETURN(1); diff --git a/deb.c b/deb.c index 441487f..dec5c06 100644 --- a/deb.c +++ b/deb.c @@ -1,6 +1,6 @@ /* deb.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -45,7 +45,6 @@ void Perl_vdeb(pTHX_ const char *pat, va_list *args) { #ifdef DEBUGGING - dTHR; char* file = CopFILE(PL_curcop); #ifdef USE_THREADS @@ -65,7 +64,6 @@ I32 Perl_debstackptrs(pTHX) { #ifdef DEBUGGING - dTHR; PerlIO_printf(Perl_debug_log, "%8"UVxf" %8"UVxf" %8"IVdf" %8"IVdf" %8"IVdf"\n", PTR2UV(PL_curstack), PTR2UV(PL_stack_base), @@ -84,7 +82,6 @@ I32 Perl_debstack(pTHX) { #ifdef DEBUGGING - dTHR; I32 top = PL_stack_sp - PL_stack_base; register I32 i = top - 30; I32 *markscan = PL_markstack + PL_curstackinfo->si_markoff; diff --git a/djgpp/config.over b/djgpp/config.over index b48774f..1bdd8ca 100644 --- a/djgpp/config.over +++ b/djgpp/config.over @@ -1,5 +1,5 @@ ln='cp' -pager='less' +pager='${DJDIR}/bin/less.exe' # fix extension names under DOS repair() @@ -35,7 +35,9 @@ repair() -e 's=File/=='\ -e 's=glob=='\ -e 's=Glob=='\ - -e 's/storable/Storable/' + -e 's/storable/Storable/'\ + -e 's/encode/Encode/'\ + -e 's=filter/util/call=Filter/Util/Call=' } static_ext=$(repair "$static_ext") extensions=$(repair "$extensions") diff --git a/djgpp/djgpp.c b/djgpp/djgpp.c index 80a627e..4e390cf 100644 --- a/djgpp/djgpp.c +++ b/djgpp/djgpp.c @@ -130,7 +130,6 @@ convretcode (pTHX_ int rc,char *prog,int fl) int do_aspawn (pTHX_ SV *really,SV **mark,SV **sp) { - dTHR; int rc; char **a,*tmps,**argv; STRLEN n_a; diff --git a/doio.c b/doio.c index eba2f8c..2bccc73 100644 --- a/doio.c +++ b/doio.c @@ -1,6 +1,6 @@ /* doio.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -51,26 +51,6 @@ #include #endif -/* XXX If this causes problems, set i_unistd=undef in the hint file. */ -#ifdef I_UNISTD -# include -#endif - -#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */ -# include -# if defined(USE_SOCKS) && defined(I_SOCKS) -# include -# endif -# ifdef I_NETBSD -# include -# endif -# ifndef ENOTSOCK -# ifdef I_NET_ERRNO -# include -# endif -# endif -#endif - bool Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp) @@ -94,9 +74,14 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int result; bool was_fdopen = FALSE; bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0; + char *type = NULL; + char *deftype = NULL; + char mode[4]; /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */ + Zero(mode,sizeof(mode),char); PL_forkprocess = 1; /* assume true if no fork */ + /* Collect default raw/crlf info from the op */ if (PL_op && PL_op->op_type == OP_OPEN) { /* set up disciplines */ U8 flags = PL_op->op_private; @@ -106,6 +91,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, out_crlf = (flags & OPpOPEN_OUT_CRLF); } + /* If currently open - close before we re-open */ if (IoIFP(io)) { fd = PerlIO_fileno(IoIFP(io)); if (IoTYPE(io) == IoTYPE_STD) @@ -136,6 +122,8 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } if (as_raw) { + /* sysopen style args, i.e. integer mode and permissions */ + #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE) rawmode |= O_LARGEFILE; #endif @@ -163,78 +151,81 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (fd == -1) fp = NULL; else { - char fpmode[4]; STRLEN ix = 0; - if (result == O_RDONLY) - fpmode[ix++] = 'r'; + if (result == O_RDONLY) { + mode[ix++] = 'r'; + } #ifdef O_APPEND else if (rawmode & O_APPEND) { - fpmode[ix++] = 'a'; + mode[ix++] = 'a'; if (result != O_WRONLY) - fpmode[ix++] = '+'; + mode[ix++] = '+'; } #endif else { if (result == O_WRONLY) - fpmode[ix++] = 'w'; + mode[ix++] = 'w'; else { - fpmode[ix++] = 'r'; - fpmode[ix++] = '+'; + mode[ix++] = 'r'; + mode[ix++] = '+'; } } if (rawmode & O_BINARY) - fpmode[ix++] = 'b'; - fpmode[ix] = '\0'; - fp = PerlIO_fdopen(fd, fpmode); + mode[ix++] = 'b'; + mode[ix] = '\0'; + fp = PerlIO_fdopen(fd, mode); if (!fp) PerlLIO_close(fd); } } else { - char *type; + /* Regular (non-sys) open */ char *oname = name; - STRLEN tlen; STRLEN olen = len; - char mode[4]; /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */ - int dodup; + char *tend; + int dodup = 0; type = savepvn(name, len); - tlen = len; + tend = type+len; SAVEFREEPV(type); + /* Loose trailing white space */ + while (tend > type && isSPACE(tend[-1])) + *tend-- = '\0'; if (num_svs) { + /* New style explict name, type is just mode and discipline/layer info */ STRLEN l; name = SvPV(svs, l) ; len = (I32)l; name = savepvn(name, len); SAVEFREEPV(name); + /*SUPPRESS 530*/ + for (; isSPACE(*type); type++) ; } else { - while (tlen && isSPACE(type[tlen-1])) - type[--tlen] = '\0'; name = type; - len = tlen; + len = tend-type; } - mode[0] = mode[1] = mode[2] = mode[3] = '\0'; IoTYPE(io) = *type; - if (*type == IoTYPE_RDWR && tlen > 1 && type[tlen-1] != IoTYPE_PIPE) { /* scary */ + if (*type == IoTYPE_RDWR && (!num_svs || tend > type+1 && tend[-1] != IoTYPE_PIPE)) { /* scary */ mode[1] = *type++; - --tlen; writing = 1; } if (*type == IoTYPE_PIPE) { - if (num_svs && (tlen != 2 || type[1] != IoTYPE_STD)) { - unknown_desr: - Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname); + if (num_svs) { + if (type[1] != IoTYPE_STD) { + unknown_desr: + Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname); + } + type++; } /*SUPPRESS 530*/ - for (type++, tlen--; isSPACE(*type); type++, tlen--) ; + for (type++; isSPACE(*type); type++) ; if (!num_svs) { name = type; - len = tlen; + len = tend-type; } if (*name == '\0') { /* command is missing 19990114 */ - dTHR; if (ckWARN(WARN_PIPE)) Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open"); errno = EPIPE; @@ -243,23 +234,18 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (strNE(name,"-") || num_svs) TAINT_ENV(); TAINT_PROPER("piped open"); - if (name[len-1] == '|') { - dTHR; + if (!num_svs && name[len-1] == '|') { name[--len] = '\0' ; if (ckWARN(WARN_PIPE)) Perl_warner(aTHX_ WARN_PIPE, "Can't open bidirectional pipe"); } - { - char *mode; - if (out_raw) - mode = "wb"; - else if (out_crlf) - mode = "wt"; - else - mode = "w"; - fp = PerlProc_popen(name,mode); - } + mode[0] = 'w'; writing = 1; + if (out_raw) + strcat(mode, "b"); + else if (out_crlf) + strcat(mode, "t"); + fp = PerlProc_popen(name,mode); } else if (*type == IoTYPE_WRONLY) { TAINT_PROPER("open"); @@ -268,7 +254,6 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */ mode[0] = IoTYPE(io) = IoTYPE_APPEND; type++; - tlen--; } else mode[0] = 'w'; @@ -279,11 +264,11 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, else if (out_crlf) strcat(mode, "t"); - if (num_svs && tlen != 1) - goto unknown_desr; if (*type == '&') { name = type; duplicity: + if (num_svs) + goto unknown_desr; dodup = 1; name++; if (*name == '=') { @@ -355,7 +340,9 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, else { /*SUPPRESS 530*/ for (; isSPACE(*type); type++) ; - if (*type == IoTYPE_STD && !type[1]) { + if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { + /*SUPPRESS 530*/ + type++; fp = PerlIO_stdout(); IoTYPE(io) = IoTYPE_STD; } @@ -365,8 +352,6 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } } else if (*type == IoTYPE_RDONLY) { - if (num_svs && tlen != 1) - goto unknown_desr; /*SUPPRESS 530*/ for (type++; isSPACE(*type); type++) ; mode[0] = 'r'; @@ -379,28 +364,30 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, name = type; goto duplicity; } - if (*type == IoTYPE_STD && !type[1]) { + if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { + /*SUPPRESS 530*/ + type++; fp = PerlIO_stdin(); IoTYPE(io) = IoTYPE_STD; } else fp = PerlIO_open((num_svs ? name : type), mode); } - else if (tlen > 1 && type[tlen-1] == IoTYPE_PIPE) { + else if ((num_svs && type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) || + (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) { if (num_svs) { - if (tlen != 2 || type[0] != IoTYPE_STD) - goto unknown_desr; + type += 2; /* skip over '-|' */ } else { - type[--tlen] = '\0'; - while (tlen && isSPACE(type[tlen-1])) - type[--tlen] = '\0'; + *--tend = '\0'; + while (tend > type && isSPACE(tend[-1])) + *--tend = '\0'; /*SUPPRESS 530*/ for (; isSPACE(*type); type++) ; name = type; + len = tend-type; } if (*name == '\0') { /* command is missing 19990114 */ - dTHR; if (ckWARN(WARN_PIPE)) Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open"); errno = EPIPE; @@ -409,16 +396,12 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (strNE(name,"-") || num_svs) TAINT_ENV(); TAINT_PROPER("piped open"); - { - char *mode; - if (in_raw) - mode = "rb"; - else if (in_crlf) - mode = "rt"; - else - mode = "r"; - fp = PerlProc_popen(name,mode); - } + mode[0] = 'r'; + if (in_raw) + strcat(mode, "b"); + else if (in_crlf) + strcat(mode, "t"); + fp = PerlProc_popen(name,mode); IoTYPE(io) = IoTYPE_PIPE; } else { @@ -428,31 +411,26 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, IoTYPE(io) = IoTYPE_RDONLY; /*SUPPRESS 530*/ for (; isSPACE(*name); name++) ; + mode[0] = 'r'; + if (in_raw) + strcat(mode, "b"); + else if (in_crlf) + strcat(mode, "t"); if (strEQ(name,"-")) { fp = PerlIO_stdin(); IoTYPE(io) = IoTYPE_STD; } else { - char *mode; - if (in_raw) - mode = "rb"; - else if (in_crlf) - mode = "rt"; - else - mode = "r"; fp = PerlIO_open(name,mode); } } } if (!fp) { - dTHR; if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == IoTYPE_RDONLY && strchr(name, '\n')) Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open"); goto say_false; } - if (IoTYPE(io) && - IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD) { - dTHR; + if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD) { if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) { (void)PerlIO_close(fp); goto say_false; @@ -480,13 +458,17 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, #endif } if (saveifp) { /* must use old fp? */ + /* If fd is less that PL_maxsysfd i.e. STDIN..STDERR + then dup the new fileno down + */ fd = PerlIO_fileno(saveifp); if (saveofp) { - PerlIO_flush(saveofp); /* emulate PerlIO_close() */ + PerlIO_flush(saveofp); /* emulate PerlIO_close() */ if (saveofp != saveifp) { /* was a socket? */ PerlIO_close(saveofp); + /* This looks very suspect - NI-S 24 Nov 2000 */ if (fd > 2) - Safefree(saveofp); + Safefree(saveofp); /* ??? */ } } if (fd != PerlIO_fileno(fp)) { @@ -494,6 +476,15 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, SV *sv; PerlLIO_dup2(PerlIO_fileno(fp), fd); +#ifdef VMS + if (fd != PerlIO_fileno(PerlIO_stdin())) { + char newname[FILENAME_MAX+1]; + if (fgetname(fp, newname)) { + if (fd == PerlIO_fileno(PerlIO_stdout())) Perl_vmssetuserlnm("SYS$OUTPUT", newname); + if (fd == PerlIO_fileno(PerlIO_stderr())) Perl_vmssetuserlnm("SYS$ERROR", newname); + } + } +#endif LOCK_FDPID_MUTEX; sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE); (void)SvUPGRADE(sv, SVt_IV); @@ -519,25 +510,51 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } #endif IoIFP(io) = fp; + if (!num_svs) { + /* Need to supply default type info from open.pm */ + SV *layers = PL_curcop->cop_io; + type = NULL; + if (layers) { + STRLEN len; + type = SvPV(layers,len); + if (type && mode[0] != 'r') { + /* Skip to write part */ + char *s = strchr(type,0); + if (s && (s-type) < len) { + type = s+1; + } + } + } + } + if (type) { + while (isSPACE(*type)) type++; + if (*type) { + if (PerlIO_apply_layers(aTHX_ IoIFP(io),mode,type) != 0) { + goto say_false; + } + } + } + IoFLAGS(io) &= ~IOf_NOLINE; if (writing) { - dTHR; if (IoTYPE(io) == IoTYPE_SOCKET || (IoTYPE(io) == IoTYPE_WRONLY && S_ISCHR(PL_statbuf.st_mode)) ) { - char *mode; - if (out_raw) - mode = "wb"; - else if (out_crlf) - mode = "wt"; - else - mode = "w"; - + mode[0] = 'w'; if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),mode))) { PerlIO_close(fp); IoIFP(io) = Nullfp; goto say_false; } + if (type && *type) { + if (PerlIO_apply_layers(aTHX_ IoOFP(io),mode,type) != 0) { + PerlIO_close(IoOFP(io)); + PerlIO_close(fp); + IoIFP(io) = Nullfp; + IoOFP(io) = Nullfp; + goto say_false; + } + } } else IoOFP(io) = fp; @@ -583,7 +600,6 @@ Perl_nextargv(pTHX_ register GV *gv) } PL_filemode = 0; while (av_len(GvAV(gv)) >= 0) { - dTHR; STRLEN oldlen; sv = av_shift(GvAV(gv)); SAVEFREESV(sv); @@ -649,7 +665,7 @@ Perl_nextargv(pTHX_ register GV *gv) #if !defined(DOSISH) && !defined(__CYGWIN__) if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) { if (ckWARN_d(WARN_INPLACE)) - Perl_warner(aTHX_ WARN_INPLACE, + Perl_warner(aTHX_ WARN_INPLACE, "Can't rename %s to %s: %s, skipping file", PL_oldname, SvPVX(sv), Strerror(errno) ); do_close(gv,FALSE); @@ -732,7 +748,6 @@ Perl_nextargv(pTHX_ register GV *gv) return IoIFP(GvIOp(gv)); } else { - dTHR; if (ckWARN_d(WARN_INPLACE)) { int eno = errno; if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0 @@ -827,7 +842,6 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit) io = GvIO(gv); if (!io) { /* never opened */ if (not_implicit) { - dTHR; if (ckWARN(WARN_UNOPENED)) /* no check for closed here */ report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,SS$_IVCHAN); @@ -883,7 +897,6 @@ Perl_io_close(pTHX_ IO *io, bool not_implicit) bool Perl_do_eof(pTHX_ GV *gv) { - dTHR; register IO *io; int ch; @@ -896,7 +909,7 @@ Perl_do_eof(pTHX_ GV *gv) || IoIFP(io) == PerlIO_stderr())) { /* integrate to report_evil_fh()? */ - char *name = NULL; + char *name = NULL; if (isGV(gv)) { SV* sv = sv_newmortal(); gv_efullname4(sv, gv, Nullch, FALSE); @@ -922,6 +935,7 @@ Perl_do_eof(pTHX_ GV *gv) (void)PerlIO_ungetc(IoIFP(io),ch); return FALSE; } + if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) { if (PerlIO_get_cnt(IoIFP(io)) < -1) PerlIO_set_cnt(IoIFP(io),-1); @@ -949,11 +963,8 @@ Perl_do_tell(pTHX_ GV *gv) #endif return PerlIO_tell(fp); } - { - dTHR; - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); - } + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS$_IFI); return (Off_t)-1; } @@ -971,11 +982,8 @@ Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence) #endif return PerlIO_seek(fp, pos, whence) >= 0; } - { - dTHR; - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); - } + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS$_IFI); return FALSE; } @@ -988,11 +996,8 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence) if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence); - { - dTHR; - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); - } + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS$_IFI); return (Off_t)-1; } @@ -1041,7 +1046,11 @@ fail_discipline: end = strchr(s+1, ':'); if (!end) end = s+len; +#ifndef PERLIO_LAYERS Perl_croak(aTHX_ "Unknown discipline '%.*s'", end-s, s); +#else + s = end; +#endif } } } @@ -1051,46 +1060,11 @@ fail_discipline: int Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode) { -#ifdef DOSISH -# if defined(atarist) || defined(__MINT__) - if (!PerlIO_flush(fp)) { - if (mode & O_BINARY) - ((FILE*)fp)->_flag |= _IOBIN; - else - ((FILE*)fp)->_flag &= ~ _IOBIN; - return 1; - } - return 0; -# else - if (PerlLIO_setmode(PerlIO_fileno(fp), mode) != -1) { -# if defined(WIN32) && defined(__BORLANDC__) - /* The translation mode of the stream is maintained independent - * of the translation mode of the fd in the Borland RTL (heavy - * digging through their runtime sources reveal). User has to - * set the mode explicitly for the stream (though they don't - * document this anywhere). GSAR 97-5-24 - */ - PerlIO_seek(fp,0L,0); - if (mode & O_BINARY) - ((FILE*)fp)->flags |= _F_BIN; - else - ((FILE*)fp)->flags &= ~ _F_BIN; -# endif - return 1; - } - else - return 0; -# endif -#else -# if defined(USEMYBINMODE) - if (my_binmode(fp, iotype, mode) != FALSE) - return 1; - else - return 0; -# else - return 1; -# endif -#endif + /* The old body of this is now in non-LAYER part of perlio.c + * This is a stub for any XS code which might have been calling it. + */ + char *name = (O_BINARY != O_TEXT && !(mode & O_BINARY)) ? ":crlf" : ":raw"; + return PerlIO_binmode(aTHX_ fp, iotype, mode, name); } #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) @@ -1168,11 +1142,8 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) } switch (SvTYPE(sv)) { case SVt_NULL: - { - dTHR; - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(); - } + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(); return TRUE; case SVt_IV: if (SvIOK(sv)) { @@ -1186,12 +1157,14 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) } /* FALL THROUGH */ default: -#if 0 - /* XXX Fix this when the I/O disciplines arrive. XXX */ - if (DO_UTF8(sv)) - sv_utf8_downgrade(sv, FALSE); -#endif - tmps = SvPV(sv, len); + if (PerlIO_isutf8(fp)) { + tmps = SvPVutf8(sv, len); + } + else { + if (DO_UTF8(sv)) + sv_utf8_downgrade(sv, FALSE); + tmps = SvPV(sv, len); + } break; } /* To detect whether the process is about to overstep its @@ -1303,7 +1276,6 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, STRLEN n_a; if (sp > mark) { - dTHR; New(401,PL_Argv, sp - mark + 1, char*); a = PL_Argv; while (++mark <= sp) { @@ -1316,11 +1288,11 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, if (*PL_Argv[0] != '/') /* will execvp use PATH? */ TAINT_ENV(); /* testing IFS here is overkill, probably */ if (really && *(tmps = SvPV(really, n_a))) - PerlProc_execvp(tmps,PL_Argv); + PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv)); else - PerlProc_execvp(PL_Argv[0],PL_Argv); + PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv)); if (ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", + Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno)); if (do_report) { int e = errno; @@ -1451,11 +1423,10 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) goto doshell; } { - dTHR; int e = errno; if (ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", + Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno)); if (do_report) { PerlLIO_write(fd, (void*)&e, sizeof(int)); @@ -1472,7 +1443,6 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) I32 Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) { - dTHR; register I32 val; register I32 val2; register I32 tot = 0; @@ -1530,7 +1500,7 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) } break; #endif -/* +/* XXX Should we make lchown() directly available from perl? For now, we'll let Configure test for HAS_LCHOWN, but do nothing in the core. @@ -1757,7 +1727,6 @@ Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective) I32 Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp) { - dTHR; key_t key; I32 n, flags; @@ -1790,7 +1759,6 @@ Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp) I32 Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) { - dTHR; SV *astr; char *a; I32 id, n, cmd, infosize, getinfo; @@ -1915,7 +1883,6 @@ I32 Perl_do_msgsnd(pTHX_ SV **mark, SV **sp) { #ifdef HAS_MSG - dTHR; SV *mstr; char *mbuf; I32 id, msize, flags; @@ -1938,7 +1905,6 @@ I32 Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) { #ifdef HAS_MSG - dTHR; SV *mstr; char *mbuf; long mtype; @@ -1955,7 +1921,7 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) flags = SvIVx(*++mark); SvPV_force(mstr, len); mbuf = SvGROW(mstr, sizeof(long)+msize+1); - + SETERRNO(0,0); ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags); if (ret >= 0) { @@ -1976,7 +1942,6 @@ I32 Perl_do_semop(pTHX_ SV **mark, SV **sp) { #ifdef HAS_SEM - dTHR; SV *opstr; char *opbuf; I32 id; @@ -2001,7 +1966,6 @@ I32 Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) { #ifdef HAS_SHM - dTHR; SV *mstr; char *mbuf, *shm; I32 id, mpos, msize; @@ -2056,3 +2020,149 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) #endif /* SYSV IPC */ +/* +=for apidoc start_glob + +Function called by C to spawn a glob (or do the glob inside +perl on VMS). This code used to be inline, but now perl uses C +this glob starter is only used by miniperl during the build proccess. +Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up. + +=cut +*/ + +PerlIO * +Perl_start_glob (pTHX_ SV *tmpglob, IO *io) +{ + SV *tmpcmd = NEWSV(55, 0); + PerlIO *fp; + ENTER; + SAVEFREESV(tmpcmd); +#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */ + /* since spawning off a process is a real performance hit */ + { +#include +#include +#include +#include + char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'}; + char vmsspec[NAM$C_MAXRSS+1]; + char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp; + char tmpfnam[L_tmpnam] = "SYS$SCRATCH:"; + $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;"); + PerlIO *tmpfp; + STRLEN i; + struct dsc$descriptor_s wilddsc + = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + struct dsc$descriptor_vs rsdsc + = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt}; + unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0; + + /* We could find out if there's an explicit dev/dir or version + by peeking into lib$find_file's internal context at + ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb + but that's unsupported, so I don't want to do it now and + have it bite someone in the future. */ + strcat(tmpfnam,PerlLIO_tmpnam(NULL)); + cp = SvPV(tmpglob,i); + for (; i; i--) { + if (cp[i] == ';') hasver = 1; + if (cp[i] == '.') { + if (sts) hasver = 1; + else sts = 1; + } + if (cp[i] == '/') { + hasdir = isunix = 1; + break; + } + if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') { + hasdir = 1; + break; + } + } + if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) { + Stat_t st; + if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode)) + ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL); + else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL); + if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer); + while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt, + &dfltdsc,NULL,NULL,NULL))&1)) { + end = rstr + (unsigned long int) *rslt; + if (!hasver) while (*end != ';') end--; + *(end++) = '\n'; *end = '\0'; + for (cp = rstr; *cp; cp++) *cp = _tolower(*cp); + if (hasdir) { + if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1); + begin = rstr; + } + else { + begin = end; + while (*(--begin) != ']' && *begin != '>') ; + ++begin; + } + ok = (PerlIO_puts(tmpfp,begin) != EOF); + } + if (cxt) (void)lib$find_file_end(&cxt); + if (ok && sts != RMS$_NMF && + sts != RMS$_DNF && sts != RMS$_FNF) ok = 0; + if (!ok) { + if (!(sts & 1)) { + SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts); + } + PerlIO_close(tmpfp); + fp = NULL; + } + else { + PerlIO_rewind(tmpfp); + IoTYPE(io) = IoTYPE_RDONLY; + IoIFP(io) = fp = tmpfp; + IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */ + } + } + } +#else /* !VMS */ +#ifdef MACOS_TRADITIONAL + sv_setpv(tmpcmd, "glob "); + sv_catsv(tmpcmd, tmpglob); + sv_catpv(tmpcmd, " |"); +#else +#ifdef DOSISH +#ifdef OS2 + sv_setpv(tmpcmd, "for a in "); + sv_catsv(tmpcmd, tmpglob); + sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |"); +#else +#ifdef DJGPP + sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */ + sv_catsv(tmpcmd, tmpglob); +#else + sv_setpv(tmpcmd, "perlglob "); + sv_catsv(tmpcmd, tmpglob); + sv_catpv(tmpcmd, " |"); +#endif /* !DJGPP */ +#endif /* !OS2 */ +#else /* !DOSISH */ +#if defined(CSH) + sv_setpvn(tmpcmd, PL_cshname, PL_cshlen); + sv_catpv(tmpcmd, " -cf 'set nonomatch; glob "); + sv_catsv(tmpcmd, tmpglob); + sv_catpv(tmpcmd, "' 2>/dev/null |"); +#else + sv_setpv(tmpcmd, "echo "); + sv_catsv(tmpcmd, tmpglob); +#if 'z' - 'a' == 25 + sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|"); +#else + sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|"); +#endif +#endif /* !CSH */ +#endif /* !DOSISH */ +#endif /* MACOS_TRADITIONAL */ + (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd), + FALSE, O_RDONLY, 0, Nullfp); + fp = IoIFP(io); +#endif /* !VMS */ + LEAVE; + return fp; +} diff --git a/doop.c b/doop.c index b75ffaa..3b0ddc1 100644 --- a/doop.c +++ b/doop.c @@ -1,6 +1,6 @@ /* doop.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -21,41 +21,27 @@ #endif #endif -#define HALF_UTF8_UPGRADE(start,end) \ - STMT_START { \ - if ((start)<(end)) { \ - U8* NeWsTr; \ - STRLEN LeN = (end) - (start); \ - NeWsTr = bytes_to_utf8(start, &LeN); \ - Safefree(start); \ - (start) = NeWsTr; \ - (end) = (start) + LeN; \ - } \ - } STMT_END - STATIC I32 S_do_trans_simple(pTHX_ SV *sv) { - dTHR; U8 *s; U8 *d; U8 *send; U8 *dstart; I32 matches = 0; - I32 sutf = SvUTF8(sv); STRLEN len; short *tbl; I32 ch; tbl = (short*)cPVOP->op_pv; if (!tbl) - Perl_croak(aTHX_ "panic: do_trans"); + Perl_croak(aTHX_ "panic: do_trans_simple"); s = (U8*)SvPV(sv, len); send = s + len; /* First, take care of non-UTF8 input strings, because they're easy */ - if (!sutf) { + if (!SvUTF8(sv)) { while (s < send) { if ((ch = tbl[*s]) >= 0) { matches++; @@ -72,18 +58,15 @@ S_do_trans_simple(pTHX_ SV *sv) Newz(0, d, len*2+1, U8); dstart = d; while (s < send) { - I32 ulen; + STRLEN ulen; short c; ulen = 1; /* Need to check this, otherwise 128..255 won't match */ - c = utf8_to_uv_chk(s, &ulen, 0); + c = utf8_to_uv(s, send - s, &ulen, 0); if (c < 0x100 && (ch = tbl[(short)c]) >= 0) { matches++; - if (ch < 0x80) - *d++ = ch; - else - d = uv_to_utf8(d,ch); + d = uv_to_utf8(d, ch); s += ulen; } else { /* No match -> copy */ @@ -92,8 +75,7 @@ S_do_trans_simple(pTHX_ SV *sv) } } *d = '\0'; - sv_setpvn(sv, (const char*)dstart, d - dstart); - Safefree(dstart); + sv_setpvn(sv, (char*)dstart, d - dstart); SvUTF8_on(sv); SvSETMAGIC(sv); return matches; @@ -102,37 +84,33 @@ S_do_trans_simple(pTHX_ SV *sv) STATIC I32 S_do_trans_count(pTHX_ SV *sv)/* SPC - OK */ { - dTHR; U8 *s; U8 *send; I32 matches = 0; - I32 hasutf = SvUTF8(sv); STRLEN len; short *tbl; tbl = (short*)cPVOP->op_pv; if (!tbl) - Perl_croak(aTHX_ "panic: do_trans"); + Perl_croak(aTHX_ "panic: do_trans_count"); s = (U8*)SvPV(sv, len); send = s + len; - while (s < send) { - if (hasutf && *s & 0x80) - s += UTF8SKIP(s); - else { - UV c; - I32 ulen; - ulen = 1; - if (hasutf) - c = utf8_to_uv_chk(s,&ulen, 0); - else - c = *s; - if (c < 0x100 && tbl[c] >= 0) + if (!SvUTF8(sv)) + while (s < send) { + if (tbl[*s++] >= 0) matches++; - s += ulen; - } - } + } + else + while (s < send) { + UV c; + STRLEN ulen; + c = utf8_to_uv(s, send - s, &ulen, 0); + if (c < 0x100 && tbl[c] >= 0) + matches++; + s += ulen; + } return matches; } @@ -140,11 +118,11 @@ S_do_trans_count(pTHX_ SV *sv)/* SPC - OK */ STATIC I32 S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */ { - dTHR; U8 *s; U8 *send; U8 *d; - I32 hasutf = SvUTF8(sv); + U8 *dstart; + I32 isutf8; I32 matches = 0; STRLEN len; short *tbl; @@ -152,66 +130,109 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */ tbl = (short*)cPVOP->op_pv; if (!tbl) - Perl_croak(aTHX_ "panic: do_trans"); + Perl_croak(aTHX_ "panic: do_trans_complex"); s = (U8*)SvPV(sv, len); + isutf8 = SvUTF8(sv); send = s + len; - d = s; - if (PL_op->op_private & OPpTRANS_SQUASH) { - U8* p = send; - - while (s < send) { - if (hasutf && *s & 0x80) - s += UTF8SKIP(s); - else { - if ((ch = tbl[*s]) >= 0) { + if (!isutf8) { + dstart = d = s; + if (PL_op->op_private & OPpTRANS_SQUASH) { + U8* p = send; + while (s < send) { + if ((ch = tbl[*s]) >= 0) { *d = ch; matches++; - if (p == d - 1 && *p == *d) - matches--; - else - p = d++; - } - else if (ch == -1) /* -1 is unmapped character */ - *d++ = *s; /* -2 is delete character */ - s++; - } + if (p != d - 1 || *p != *d) + p = d++; + } + else if (ch == -1) /* -1 is unmapped character */ + *d++ = *s; + else if (ch == -2) /* -2 is delete character */ + matches++; + s++; + } } - } - else { - while (s < send) { - if (hasutf && *s & 0x80) - s += UTF8SKIP(s); - else { + else { + while (s < send) { if ((ch = tbl[*s]) >= 0) { - *d = ch; matches++; - d++; - } - else if (ch == -1) /* -1 is unmapped character */ - *d++ = *s; /* -2 is delete character */ - s++; - } + *d++ = ch; + } + else if (ch == -1) /* -1 is unmapped character */ + *d++ = *s; + else if (ch == -2) /* -2 is delete character */ + matches++; + s++; + } } + SvCUR_set(sv, d - dstart); + } + else { /* isutf8 */ + Newz(0, d, len*2+1, U8); + dstart = d; + + if (PL_op->op_private & OPpTRANS_SQUASH) { + U8* p = send; + UV pch = 0xfeedface; + while (s < send) { + STRLEN len; + UV comp = utf8_to_uv_simple(s, &len); + + if (comp > 0xff) + d = uv_to_utf8(d, comp); /* always unmapped */ + else if ((ch = tbl[comp]) >= 0) { + matches++; + if (ch != pch) { + d = uv_to_utf8(d, ch); + pch = ch; + } + s += len; + continue; + } + else if (ch == -1) /* -1 is unmapped character */ + d = uv_to_utf8(d, comp); + else if (ch == -2) /* -2 is delete character */ + matches++; + s += len; + pch = 0xfeedface; + } + } + else { + while (s < send) { + STRLEN len; + UV comp = utf8_to_uv_simple(s, &len); + if (comp > 0xff) + d = uv_to_utf8(d, comp); /* always unmapped */ + else if ((ch = tbl[comp]) >= 0) { + d = uv_to_utf8(d, ch); + matches++; + } + else if (ch == -1) { /* -1 is unmapped character */ + d = uv_to_utf8(d, comp); + } + else if (ch == -2) /* -2 is delete character */ + matches++; + s += len; + } + } + *d = '\0'; + sv_setpvn(sv, (char*)dstart, d - dstart); + SvUTF8_on(sv); } - matches += send - d; /* account for disappeared chars */ - *d = '\0'; - SvCUR_set(sv, d - (U8*)SvPVX(sv)); SvSETMAGIC(sv); - return matches; } STATIC I32 S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */ { - dTHR; U8 *s; U8 *send; U8 *d; U8 *start; - U8 *dstart; + U8 *dstart, *dend; I32 matches = 0; STRLEN len; @@ -222,11 +243,19 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */ UV extra = none + 1; UV final; UV uv; - I32 isutf; - I32 howmany; + I32 isutf8; + U8 hibit = 0; - isutf = SvUTF8(sv); s = (U8*)SvPV(sv, len); + isutf8 = SvUTF8(sv); + if (!isutf8) { + U8 *t = s, *e = s + len; + while (t < e) + if ((hibit = UTF8_IS_CONTINUED(*t++))) + break; + if (hibit) + s = bytes_to_utf8(s, &len); + } send = s + len; start = s; @@ -235,41 +264,46 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */ final = SvUV(*svp); /* d needs to be bigger than s, in case e.g. upgrading is required */ - Newz(0, d, len*2+1, U8); + New(0, d, len*3+UTF8_MAXLEN, U8); + dend = d + len * 3; dstart = d; + while (s < send) { if ((uv = swash_fetch(rv, s)) < none) { s += UTF8SKIP(s); matches++; - if ((uv & 0x80) && !isutf++) - HALF_UTF8_UPGRADE(dstart,d); d = uv_to_utf8(d, uv); } else if (uv == none) { - int i; - i = UTF8SKIP(s); - if (i > 1 && !isutf++) - HALF_UTF8_UPGRADE(dstart,d); + int i = UTF8SKIP(s); while(i--) *d++ = *s++; } else if (uv == extra) { - int i; - i = UTF8SKIP(s); + int i = UTF8SKIP(s); s += i; matches++; - if (i > 1 && !isutf++) - HALF_UTF8_UPGRADE(dstart,d); d = uv_to_utf8(d, final); } else s += UTF8SKIP(s); + + if (d >= dend) { + STRLEN clen = d - dstart; + STRLEN nlen = dend - dstart + len + UTF8_MAXLEN; + Renew(dstart, nlen+UTF8_MAXLEN, U8); + d = dstart + clen; + dend = dstart + nlen; + } } *d = '\0'; - sv_setpvn(sv, (const char*)dstart, d - dstart); + sv_setpvn(sv, (char*)dstart, d - dstart); SvSETMAGIC(sv); - if (isutf) - SvUTF8_on(sv); + SvUTF8_on(sv); + if (hibit) + Safefree(start); + if (!isutf8 && !(PL_hints & HINT_UTF8)) + sv_utf8_downgrade(sv, TRUE); return matches; } @@ -277,9 +311,8 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */ STATIC I32 S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */ { - dTHR; U8 *s; - U8 *send; + U8 *start, *send; I32 matches = 0; STRLEN len; @@ -288,10 +321,17 @@ S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */ SV** svp = hv_fetch(hv, "NONE", 4, FALSE); UV none = svp ? SvUV(*svp) : 0x7fffffff; UV uv; + U8 hibit = 0; s = (U8*)SvPV(sv, len); - if (!SvUTF8(sv)) - s = bytes_to_utf8(s, &len); + if (!SvUTF8(sv)) { + U8 *t = s, *e = s + len; + while (t < e) + if ((hibit = !UTF8_IS_ASCII(*t++))) + break; + if (hibit) + start = s = bytes_to_utf8(s, &len); + } send = s + len; while (s < send) { @@ -299,6 +339,8 @@ S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */ matches++; s += UTF8SKIP(s); } + if (hibit) + Safefree(start); return matches; } @@ -306,9 +348,8 @@ S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */ STATIC I32 S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */ { - dTHR; U8 *s; - U8 *send; + U8 *start, *send; U8 *d; I32 matches = 0; I32 squash = PL_op->op_private & OPpTRANS_SQUASH; @@ -321,41 +362,45 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */ UV final; UV uv; STRLEN len; - U8 *dst; - I32 isutf = SvUTF8(sv); + U8 *dstart, *dend; + I32 isutf8; + U8 hibit = 0; s = (U8*)SvPV(sv, len); + isutf8 = SvUTF8(sv); + if (!isutf8) { + U8 *t = s, *e = s + len; + while (t < e) + if ((hibit = !UTF8_IS_ASCII(*t++))) + break; + if (hibit) + s = bytes_to_utf8(s, &len); + } send = s + len; + start = s; svp = hv_fetch(hv, "FINAL", 5, FALSE); if (svp) final = SvUV(*svp); - Newz(0, d, len*2+1, U8); - dst = d; + New(0, d, len*3+UTF8_MAXLEN, U8); + dend = d + len * 3; + dstart = d; if (squash) { UV puv = 0xfeedface; while (s < send) { - if (SvUTF8(sv)) - uv = swash_fetch(rv, s); - else { - U8 tmpbuf[2]; - uv = *s++; - if (uv < 0x80) - tmpbuf[0] = uv; - else { - tmpbuf[0] = (( uv >> 6) | 0xc0); - tmpbuf[1] = (( uv & 0x3f) | 0x80); - } - uv = swash_fetch(rv, tmpbuf); + uv = swash_fetch(rv, s); + + if (d >= dend) { + STRLEN clen = d - dstart, nlen = dend - dstart + len; + Renew(dstart, nlen+UTF8_MAXLEN, U8); + d = dstart + clen; + dend = dstart + nlen; } - if (uv < none) { matches++; if (uv != puv) { - if ((uv & 0x80) && !isutf++) - HALF_UTF8_UPGRADE(dst,d); d = uv_to_utf8(d, uv); puv = uv; } @@ -363,9 +408,9 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */ continue; } else if (uv == none) { /* "none" is unmapped character */ - I32 ulen; - *d++ = (U8)utf8_to_uv_chk(s, &ulen, 0); - s += ulen; + int i = UTF8SKIP(s); + while(i--) + *d++ = *s++; puv = 0xfeedface; continue; } @@ -384,18 +429,12 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */ } else { while (s < send) { - if (SvUTF8(sv)) - uv = swash_fetch(rv, s); - else { - U8 tmpbuf[2]; - uv = *s++; - if (uv < 0x80) - tmpbuf[0] = uv; - else { - tmpbuf[0] = (( uv >> 6) | 0xc0); - tmpbuf[1] = (( uv & 0x3f) | 0x80); - } - uv = swash_fetch(rv, tmpbuf); + uv = swash_fetch(rv, s); + if (d >= dend) { + STRLEN clen = d - dstart, nlen = dend - dstart + len; + Renew(dstart, nlen+UTF8_MAXLEN, U8); + d = dstart + clen; + dend = dstart + nlen; } if (uv < none) { matches++; @@ -404,9 +443,9 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */ continue; } else if (uv == none) { /* "none" is unmapped character */ - I32 ulen; - *d++ = (U8)utf8_to_uv_chk(s, &ulen, 0); - s += ulen; + int i = UTF8SKIP(s); + while(i--) + *d++ = *s++; continue; } else if (uv == extra && !del) { @@ -419,12 +458,13 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */ s += UTF8SKIP(s); } } - if (dst) - sv_usepvn(sv, (char*)dst, d - dst); - else { - *d = '\0'; - SvCUR_set(sv, d - (U8*)SvPVX(sv)); - } + *d = '\0'; + sv_setpvn(sv, (char*)dstart, d - dstart); + SvUTF8_on(sv); + if (hibit) + Safefree(start); + if (!isutf8 && !(PL_hints & HINT_UTF8)) + sv_utf8_downgrade(sv, TRUE); SvSETMAGIC(sv); return matches; @@ -433,7 +473,6 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */ I32 Perl_do_trans(pTHX_ SV *sv) { - dTHR; STRLEN len; I32 hasutf = (PL_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)); @@ -501,8 +540,6 @@ Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **s } if (items-- > 0) { - char *s; - sv_setpv(sv, ""); if (*mark) sv_catsv(sv, *mark); @@ -510,10 +547,9 @@ Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **s } else sv_setpv(sv,""); - len = delimlen; - if (len) { + if (delimlen) { for (; items > 0; items--,mark++) { - sv_catpvn(sv,delim,len); + sv_catsv(sv,del); sv_catsv(sv,*mark); } } @@ -550,9 +586,8 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ Perl_croak(aTHX_ "Illegal number of bits in vec"); - if (SvUTF8(sv)) { + if (SvUTF8(sv)) (void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE); - } offset *= size; /* turn into bit offset */ len = (offset + size + 7) / 8; /* required number of bytes */ @@ -585,7 +620,6 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) } #ifdef UV_IS_QUAD else if (size == 64) { - dTHR; if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ WARN_PORTABLE, "Bit vector size > 32 non-portable"); @@ -655,7 +689,6 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) s[offset + 3]; #ifdef UV_IS_QUAD else if (size == 64) { - dTHR; if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ WARN_PORTABLE, "Bit vector size > 32 non-portable"); @@ -743,7 +776,6 @@ Perl_do_vecset(pTHX_ SV *sv) } #ifdef UV_IS_QUAD else if (size == 64) { - dTHR; if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ WARN_PORTABLE, "Bit vector size > 32 non-portable"); @@ -766,7 +798,6 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv) { STRLEN len; char *s; - dTHR; if (SvTYPE(sv) == SVt_PVAV) { register I32 i; @@ -799,15 +830,15 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv) char *send = s + len; char *start = s; s = send - 1; - while ((*s & 0xc0) == 0x80) - --s; - if (UTF8SKIP(s) != send - s && ckWARN_d(WARN_UTF8)) - Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); - sv_setpvn(astr, s, send - s); - *s = '\0'; - SvCUR_set(sv, s - start); - SvNIOK_off(sv); - SvUTF8_on(astr); + while (s > start && UTF8_IS_CONTINUATION(*s)) + s--; + if (utf8_to_uv_simple((U8*)s, 0)) { + sv_setpvn(astr, s, send - s); + *s = '\0'; + SvCUR_set(sv, s - start); + SvNIOK_off(sv); + SvUTF8_on(astr); + } } else sv_setpvn(astr, "", 0); @@ -828,7 +859,6 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv) I32 Perl_do_chomp(pTHX_ register SV *sv) { - dTHR; register I32 count; STRLEN len; char *s; @@ -906,7 +936,6 @@ Perl_do_chomp(pTHX_ register SV *sv) void Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) { - dTHR; /* just for taint */ #ifdef LIBERAL register long *dl; register long *ll; @@ -927,7 +956,7 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) if (left_utf && !right_utf) sv_utf8_upgrade(right); - if (!left_utf && right_utf) + else if (!left_utf && right_utf) sv_utf8_upgrade(left); if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv))) @@ -964,15 +993,15 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) char *dcsave = dc; STRLEN lulen = leftlen; STRLEN rulen = rightlen; - I32 ulen; + STRLEN ulen; switch (optype) { case OP_BIT_AND: while (lulen && rulen) { - luc = utf8_to_uv_chk((U8*)lc, &ulen, 0); + luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); lc += ulen; lulen -= ulen; - ruc = utf8_to_uv_chk((U8*)rc, &ulen, 0); + ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); rc += ulen; rulen -= ulen; duc = luc & ruc; @@ -984,10 +1013,10 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) break; case OP_BIT_XOR: while (lulen && rulen) { - luc = utf8_to_uv_chk((U8*)lc, &ulen, 0); + luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); lc += ulen; lulen -= ulen; - ruc = utf8_to_uv_chk((U8*)rc, &ulen, 0); + ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); rc += ulen; rulen -= ulen; duc = luc ^ ruc; @@ -996,10 +1025,10 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) goto mop_up_utf; case OP_BIT_OR: while (lulen && rulen) { - luc = utf8_to_uv_chk((U8*)lc, &ulen, 0); + luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); lc += ulen; lulen -= ulen; - ruc = utf8_to_uv_chk((U8*)rc, &ulen, 0); + ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); rc += ulen; rulen -= ulen; duc = luc | ruc; diff --git a/dump.c b/dump.c index ad0a21f..5bc7349 100644 --- a/dump.c +++ b/dump.c @@ -1,6 +1,6 @@ /* dump.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -29,7 +29,6 @@ Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) void Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) { - dTHR; PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), ""); PerlIO_vprintf(file, pat, *args); } @@ -37,7 +36,6 @@ Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) void Perl_dump_all(pTHX) { - dTHR; PerlIO_setlinebuf(Perl_debug_log); if (PL_main_root) op_dump(PL_main_root); @@ -47,7 +45,6 @@ Perl_dump_all(pTHX) void Perl_dump_packsubs(pTHX_ HV *stash) { - dTHR; I32 i; HE *entry; @@ -275,6 +272,8 @@ Perl_sv_peek(pTHX_ SV *sv) if (SvOOK(sv)) Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX(sv)-SvIVX(sv), SvIVX(sv), 0, 127)); Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX(sv), SvCUR(sv), SvLEN(sv), 127)); + if (SvUTF8(sv)) + Perl_sv_catpvf(aTHX_ t, " [UTF8]"); SvREFCNT_dec(tmp); } } @@ -369,7 +368,6 @@ Perl_pmop_dump(pTHX_ PMOP *pm) void Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) { - dTHR; Perl_dump_indent(aTHX_ level, file, "{\n"); level++; if (o->op_seq) @@ -457,6 +455,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) } else if (o->op_type == OP_ENTERSUB || o->op_type == OP_RV2SV || + o->op_type == OP_GVSV || o->op_type == OP_RV2AV || o->op_type == OP_RV2HV || o->op_type == OP_RV2GV || @@ -768,7 +767,6 @@ Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv) void Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) { - dTHR; SV *d; char *s; U32 flags; @@ -822,6 +820,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,"); if (CvCLONE(sv)) sv_catpv(d, "CLONE,"); if (CvCLONED(sv)) sv_catpv(d, "CLONED,"); + if (CvCONST(sv)) sv_catpv(d, "CONST,"); if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,"); if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,"); break; diff --git a/emacs/cperl-mode.el b/emacs/cperl-mode.el index 383d164..ff16b03 100644 --- a/emacs/cperl-mode.el +++ b/emacs/cperl-mode.el @@ -7083,7 +7083,6 @@ Currently it is tuned to C and Perl syntax." found-bad found))) (not not-found))) - ;;; Getting help (defvar cperl-have-help-regexp ;;(concat "\\(" diff --git a/emacs/ptags b/emacs/ptags index 54770a0..1054ac1 100755 --- a/emacs/ptags +++ b/emacs/ptags @@ -21,7 +21,7 @@ if test ! -z "$OS2_SHELL"; then alias find=gnufind; fi # Move autogenerated less-informative files to the end: # Hard to do embed.h and embedvar.h in one sweep: -topfiles="`echo ' ' *.y *.c *.h ' ' | sed 's/ / /g' | sed 's/ embedvar\.h\|embed\.h\|obj\(pp\|XSUB\)\.h\|\(globals\|perlapi\)\.c / /g'`" +topfiles="`echo ' ' *.y *.c *.h ' ' | sed 's/ / /g' | sed 's/ embedvar\.h\|embed\.h\|perlapi\.h\|obj\(pp\|XSUB\)\.h\|\(globals\|perlapi\)\.c / /g'`" subdirs="`find ./* -maxdepth 0 -type d`" subdirfiles="`find $subdirs -name '*.[cy]' -print | sort`" subdirfiles1="`find $subdirs -name '*.[hH]' -print | sort`" @@ -99,7 +99,7 @@ perl -w014pe 'if (s/^(S_ # 1: First group }' TAGS.tmp > TAGS.tm1 && mv TAGS.tm1 TAGS.tmp etags -o TAGS.tmp -a -D -l none -r '/#define.*\t\(Perl_.*\)/\1/' embed.h -etags -o TAGS.tmp -a globals.c embedvar.h objXSUB.h perlapi.c +etags -o TAGS.tmp -a globals.c embedvar.h objXSUB.h perlapi.c perlapi.h # The above processes created a lot of descriptions with an # an explicitly specified tag. Such descriptions have higher diff --git a/embed.h b/embed.h index 50a9d9e..414a642 100644 --- a/embed.h +++ b/embed.h @@ -68,6 +68,7 @@ #endif #define amagic_call Perl_amagic_call #define Gv_AMupdate Perl_Gv_AMupdate +#define gv_handler Perl_gv_handler #define append_elem Perl_append_elem #define append_list Perl_append_list #define apply Perl_apply @@ -542,6 +543,7 @@ #define ref Perl_ref #define refkids Perl_refkids #define regdump Perl_regdump +#define regclass_swash Perl_regclass_swash #define pregexec Perl_pregexec #define pregfree Perl_pregfree #define pregcomp Perl_pregcomp @@ -597,6 +599,7 @@ #define save_pptr Perl_save_pptr #define save_vptr Perl_save_vptr #define save_re_context Perl_save_re_context +#define save_padsv Perl_save_padsv #define save_sptr Perl_save_sptr #define save_svref Perl_save_svref #define save_threadsv Perl_save_threadsv @@ -701,6 +704,7 @@ #define sv_tainted Perl_sv_tainted #define sv_unmagic Perl_sv_unmagic #define sv_unref Perl_sv_unref +#define sv_unref_flags Perl_sv_unref_flags #define sv_untaint Perl_sv_untaint #define sv_upgrade Perl_sv_upgrade #define sv_usepvn Perl_sv_usepvn @@ -725,12 +729,13 @@ #define utilize Perl_utilize #define utf16_to_utf8 Perl_utf16_to_utf8 #define utf16_to_utf8_reversed Perl_utf16_to_utf8_reversed +#define utf8_length Perl_utf8_length #define utf8_distance Perl_utf8_distance #define utf8_hop Perl_utf8_hop #define utf8_to_bytes Perl_utf8_to_bytes #define bytes_to_utf8 Perl_bytes_to_utf8 +#define utf8_to_uv_simple Perl_utf8_to_uv_simple #define utf8_to_uv Perl_utf8_to_uv -#define utf8_to_uv_chk Perl_utf8_to_uv_chk #define uv_to_utf8 Perl_uv_to_utf8 #define vivify_defelem Perl_vivify_defelem #define vivify_ref Perl_vivify_ref @@ -744,7 +749,8 @@ #define watch Perl_watch #define whichsig Perl_whichsig #define yyerror Perl_yyerror -#if defined(USE_PURE_BISON) +#ifdef USE_PURE_BISON +#define yylex_r Perl_yylex_r #define yylex Perl_yylex #else #define yylex Perl_yylex @@ -816,6 +822,7 @@ #define sv_utf8_encode Perl_sv_utf8_encode #define sv_utf8_decode Perl_sv_utf8_decode #define sv_force_normal Perl_sv_force_normal +#define sv_force_normal_flags Perl_sv_force_normal_flags #define tmps_grow Perl_tmps_grow #define sv_rvweaken Perl_sv_rvweaken #define magic_killbackrefs Perl_magic_killbackrefs @@ -989,7 +996,6 @@ #define regbranch S_regbranch #define reguni S_reguni #define regclass S_regclass -#define regclassutf8 S_regclassutf8 #define regcurly S_regcurly #define reg_node S_reg_node #define regpiece S_regpiece @@ -1019,13 +1025,14 @@ #define regrepeat_hard S_regrepeat_hard #define regtry S_regtry #define reginclass S_reginclass -#define reginclassutf8 S_reginclassutf8 #define regcppush S_regcppush #define regcppop S_regcppop #define regcp_set_to S_regcp_set_to #define cache_re S_cache_re #define reghop S_reghop +#define reghop3 S_reghop3 #define reghopmaybe S_reghopmaybe +#define reghopmaybe3 S_reghopmaybe3 #define find_byclass S_find_byclass #endif #if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT) @@ -1082,6 +1089,10 @@ # if defined(DEBUGGING) #define del_sv S_del_sv # endif +# if !defined(NV_PRESERVES_UV) +#define sv_2inuv_non_preserve S_sv_2inuv_non_preserve +#define sv_2iuv_non_preserve S_sv_2iuv_non_preserve +# endif #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #define check_uni S_check_uni @@ -1134,6 +1145,7 @@ #define isa_lookup S_isa_lookup #endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) +#define stdize_locale S_stdize_locale #define mess_alloc S_mess_alloc # if defined(LEAKTEST) #define xstat S_xstat @@ -1550,6 +1562,7 @@ #endif #define amagic_call(a,b,c,d) Perl_amagic_call(aTHX_ a,b,c,d) #define Gv_AMupdate(a) Perl_Gv_AMupdate(aTHX_ a) +#define gv_handler(a,b) Perl_gv_handler(aTHX_ a,b) #define append_elem(a,b,c) Perl_append_elem(aTHX_ a,b,c) #define append_list(a,b,c) Perl_append_list(aTHX_ a,b,c) #define apply(a,b,c) Perl_apply(aTHX_ a,b,c) @@ -2003,6 +2016,7 @@ #define ref(a,b) Perl_ref(aTHX_ a,b) #define refkids(a,b) Perl_refkids(aTHX_ a,b) #define regdump(a) Perl_regdump(aTHX_ a) +#define regclass_swash(a,b,c) Perl_regclass_swash(aTHX_ a,b,c) #define pregexec(a,b,c,d,e,f,g) Perl_pregexec(aTHX_ a,b,c,d,e,f,g) #define pregfree(a) Perl_pregfree(aTHX_ a) #define pregcomp(a,b,c) Perl_pregcomp(aTHX_ a,b,c) @@ -2058,6 +2072,7 @@ #define save_pptr(a) Perl_save_pptr(aTHX_ a) #define save_vptr(a) Perl_save_vptr(aTHX_ a) #define save_re_context() Perl_save_re_context(aTHX) +#define save_padsv(a) Perl_save_padsv(aTHX_ a) #define save_sptr(a) Perl_save_sptr(aTHX_ a) #define save_svref(a) Perl_save_svref(aTHX_ a) #define save_threadsv(a) Perl_save_threadsv(aTHX_ a) @@ -2068,7 +2083,7 @@ #define scalarvoid(a) Perl_scalarvoid(aTHX_ a) #define scan_bin(a,b,c) Perl_scan_bin(aTHX_ a,b,c) #define scan_hex(a,b,c) Perl_scan_hex(aTHX_ a,b,c) -#define scan_num(a) Perl_scan_num(aTHX_ a) +#define scan_num(a,b) Perl_scan_num(aTHX_ a,b) #define scan_oct(a,b,c) Perl_scan_oct(aTHX_ a,b,c) #define scope(a) Perl_scope(aTHX_ a) #define screaminstr(a,b,c,d,e,f) Perl_screaminstr(aTHX_ a,b,c,d,e,f) @@ -2160,6 +2175,7 @@ #define sv_tainted(a) Perl_sv_tainted(aTHX_ a) #define sv_unmagic(a,b) Perl_sv_unmagic(aTHX_ a,b) #define sv_unref(a) Perl_sv_unref(aTHX_ a) +#define sv_unref_flags(a,b) Perl_sv_unref_flags(aTHX_ a,b) #define sv_untaint(a) Perl_sv_untaint(aTHX_ a) #define sv_upgrade(a,b) Perl_sv_upgrade(aTHX_ a,b) #define sv_usepvn(a,b,c) Perl_sv_usepvn(aTHX_ a,b,c) @@ -2184,12 +2200,13 @@ #define utilize(a,b,c,d,e) Perl_utilize(aTHX_ a,b,c,d,e) #define utf16_to_utf8(a,b,c,d) Perl_utf16_to_utf8(aTHX_ a,b,c,d) #define utf16_to_utf8_reversed(a,b,c,d) Perl_utf16_to_utf8_reversed(aTHX_ a,b,c,d) +#define utf8_length(a,b) Perl_utf8_length(aTHX_ a,b) #define utf8_distance(a,b) Perl_utf8_distance(aTHX_ a,b) #define utf8_hop(a,b) Perl_utf8_hop(aTHX_ a,b) #define utf8_to_bytes(a,b) Perl_utf8_to_bytes(aTHX_ a,b) #define bytes_to_utf8(a,b) Perl_bytes_to_utf8(aTHX_ a,b) -#define utf8_to_uv(a,b) Perl_utf8_to_uv(aTHX_ a,b) -#define utf8_to_uv_chk(a,b,c) Perl_utf8_to_uv_chk(aTHX_ a,b,c) +#define utf8_to_uv_simple(a,b) Perl_utf8_to_uv_simple(aTHX_ a,b) +#define utf8_to_uv(a,b,c,d) Perl_utf8_to_uv(aTHX_ a,b,c,d) #define uv_to_utf8(a,b) Perl_uv_to_utf8(aTHX_ a,b) #define vivify_defelem(a) Perl_vivify_defelem(aTHX_ a) #define vivify_ref(a,b) Perl_vivify_ref(aTHX_ a,b) @@ -2201,7 +2218,8 @@ #define watch(a) Perl_watch(aTHX_ a) #define whichsig(a) Perl_whichsig(aTHX_ a) #define yyerror(a) Perl_yyerror(aTHX_ a) -#if defined(USE_PURE_BISON) +#ifdef USE_PURE_BISON +#define yylex_r(a,b) Perl_yylex_r(aTHX_ a,b) #define yylex(a,b) Perl_yylex(aTHX_ a,b) #else #define yylex() Perl_yylex(aTHX) @@ -2269,6 +2287,7 @@ #define sv_utf8_encode(a) Perl_sv_utf8_encode(aTHX_ a) #define sv_utf8_decode(a) Perl_sv_utf8_decode(aTHX_ a) #define sv_force_normal(a) Perl_sv_force_normal(aTHX_ a) +#define sv_force_normal_flags(a,b) Perl_sv_force_normal_flags(aTHX_ a,b) #define tmps_grow(a) Perl_tmps_grow(aTHX_ a) #define sv_rvweaken(a) Perl_sv_rvweaken(aTHX_ a) #define magic_killbackrefs(a,b) Perl_magic_killbackrefs(aTHX_ a,b) @@ -2436,48 +2455,48 @@ # endif #endif #if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT) -#define reg(a,b) S_reg(aTHX_ a,b) -#define reganode(a,b) S_reganode(aTHX_ a,b) -#define regatom(a) S_regatom(aTHX_ a) -#define regbranch(a,b) S_regbranch(aTHX_ a,b) -#define reguni(a,b,c) S_reguni(aTHX_ a,b,c) -#define regclass() S_regclass(aTHX) -#define regclassutf8() S_regclassutf8(aTHX) +#define reg(a,b,c) S_reg(aTHX_ a,b,c) +#define reganode(a,b,c) S_reganode(aTHX_ a,b,c) +#define regatom(a,b) S_regatom(aTHX_ a,b) +#define regbranch(a,b,c) S_regbranch(aTHX_ a,b,c) +#define reguni(a,b,c,d) S_reguni(aTHX_ a,b,c,d) +#define regclass(a) S_regclass(aTHX_ a) #define regcurly(a) S_regcurly(aTHX_ a) -#define reg_node(a) S_reg_node(aTHX_ a) -#define regpiece(a) S_regpiece(aTHX_ a) -#define reginsert(a,b) S_reginsert(aTHX_ a,b) -#define regoptail(a,b) S_regoptail(aTHX_ a,b) -#define regtail(a,b) S_regtail(aTHX_ a,b) +#define reg_node(a,b) S_reg_node(aTHX_ a,b) +#define regpiece(a,b) S_regpiece(aTHX_ a,b) +#define reginsert(a,b,c) S_reginsert(aTHX_ a,b,c) +#define regoptail(a,b,c) S_regoptail(aTHX_ a,b,c) +#define regtail(a,b,c) S_regtail(aTHX_ a,b,c) #define regwhite(a,b) S_regwhite(aTHX_ a,b) -#define nextchar() S_nextchar(aTHX) +#define nextchar(a) S_nextchar(aTHX_ a) #define dumpuntil(a,b,c,d,e) S_dumpuntil(aTHX_ a,b,c,d,e) #define put_byte(a,b) S_put_byte(aTHX_ a,b) -#define scan_commit(a) S_scan_commit(aTHX_ a) -#define cl_anything(a) S_cl_anything(aTHX_ a) +#define scan_commit(a,b) S_scan_commit(aTHX_ a,b) +#define cl_anything(a,b) S_cl_anything(aTHX_ a,b) #define cl_is_anything(a) S_cl_is_anything(aTHX_ a) -#define cl_init(a) S_cl_init(aTHX_ a) -#define cl_init_zero(a) S_cl_init_zero(aTHX_ a) +#define cl_init(a,b) S_cl_init(aTHX_ a,b) +#define cl_init_zero(a,b) S_cl_init_zero(aTHX_ a,b) #define cl_and(a,b) S_cl_and(aTHX_ a,b) -#define cl_or(a,b) S_cl_or(aTHX_ a,b) -#define study_chunk(a,b,c,d,e) S_study_chunk(aTHX_ a,b,c,d,e) -#define add_data(a,b) S_add_data(aTHX_ a,b) -#define regpposixcc(a) S_regpposixcc(aTHX_ a) -#define checkposixcc() S_checkposixcc(aTHX) +#define cl_or(a,b,c) S_cl_or(aTHX_ a,b,c) +#define study_chunk(a,b,c,d,e,f) S_study_chunk(aTHX_ a,b,c,d,e,f) +#define add_data(a,b,c) S_add_data(aTHX_ a,b,c) +#define regpposixcc(a,b) S_regpposixcc(aTHX_ a,b) +#define checkposixcc(a) S_checkposixcc(aTHX_ a) #endif #if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT) #define regmatch(a) S_regmatch(aTHX_ a) #define regrepeat(a,b) S_regrepeat(aTHX_ a,b) #define regrepeat_hard(a,b,c) S_regrepeat_hard(aTHX_ a,b,c) #define regtry(a,b) S_regtry(aTHX_ a,b) -#define reginclass(a,b) S_reginclass(aTHX_ a,b) -#define reginclassutf8(a,b) S_reginclassutf8(aTHX_ a,b) +#define reginclass(a,b,c) S_reginclass(aTHX_ a,b,c) #define regcppush(a) S_regcppush(aTHX_ a) #define regcppop() S_regcppop(aTHX) #define regcp_set_to(a) S_regcp_set_to(aTHX_ a) #define cache_re(a) S_cache_re(aTHX_ a) #define reghop(a,b) S_reghop(aTHX_ a,b) +#define reghop3(a,b,c) S_reghop3(aTHX_ a,b,c) #define reghopmaybe(a,b) S_reghopmaybe(aTHX_ a,b) +#define reghopmaybe3(a,b,c) S_reghopmaybe3(aTHX_ a,b,c) #define find_byclass(a,b,c,d,e,f) S_find_byclass(aTHX_ a,b,c,d,e,f) #endif #if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT) @@ -2534,6 +2553,10 @@ # if defined(DEBUGGING) #define del_sv(a) S_del_sv(aTHX_ a) # endif +# if !defined(NV_PRESERVES_UV) +#define sv_2inuv_non_preserve(a,b) S_sv_2inuv_non_preserve(aTHX_ a,b) +#define sv_2iuv_non_preserve(a,b) S_sv_2iuv_non_preserve(aTHX_ a,b) +# endif #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #define check_uni() S_check_uni(aTHX) @@ -2586,6 +2609,7 @@ #define isa_lookup(a,b,c,d) S_isa_lookup(aTHX_ a,b,c,d) #endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) +#define stdize_locale(a) S_stdize_locale(aTHX_ a) #define mess_alloc() S_mess_alloc(aTHX) # if defined(LEAKTEST) #define xstat(a) S_xstat(aTHX_ a) @@ -3009,6 +3033,8 @@ #define amagic_call Perl_amagic_call #define Perl_Gv_AMupdate CPerlObj::Perl_Gv_AMupdate #define Gv_AMupdate Perl_Gv_AMupdate +#define Perl_gv_handler CPerlObj::Perl_gv_handler +#define gv_handler Perl_gv_handler #define Perl_append_elem CPerlObj::Perl_append_elem #define append_elem Perl_append_elem #define Perl_append_list CPerlObj::Perl_append_list @@ -3849,6 +3875,8 @@ #define pad_swipe Perl_pad_swipe #define Perl_peep CPerlObj::Perl_peep #define peep Perl_peep +#define Perl_start_glob CPerlObj::Perl_start_glob +#define start_glob Perl_start_glob #if defined(PERL_OBJECT) #define Perl_construct CPerlObj::Perl_construct #define Perl_destruct CPerlObj::Perl_destruct @@ -3924,6 +3952,8 @@ #define refkids Perl_refkids #define Perl_regdump CPerlObj::Perl_regdump #define regdump Perl_regdump +#define Perl_regclass_swash CPerlObj::Perl_regclass_swash +#define regclass_swash Perl_regclass_swash #define Perl_pregexec CPerlObj::Perl_pregexec #define pregexec Perl_pregexec #define Perl_pregfree CPerlObj::Perl_pregfree @@ -4032,6 +4062,8 @@ #define save_vptr Perl_save_vptr #define Perl_save_re_context CPerlObj::Perl_save_re_context #define save_re_context Perl_save_re_context +#define Perl_save_padsv CPerlObj::Perl_save_padsv +#define save_padsv Perl_save_padsv #define Perl_save_sptr CPerlObj::Perl_save_sptr #define save_sptr Perl_save_sptr #define Perl_save_svref CPerlObj::Perl_save_svref @@ -4236,6 +4268,8 @@ #define sv_unmagic Perl_sv_unmagic #define Perl_sv_unref CPerlObj::Perl_sv_unref #define sv_unref Perl_sv_unref +#define Perl_sv_unref_flags CPerlObj::Perl_sv_unref_flags +#define sv_unref_flags Perl_sv_unref_flags #define Perl_sv_untaint CPerlObj::Perl_sv_untaint #define sv_untaint Perl_sv_untaint #define Perl_sv_upgrade CPerlObj::Perl_sv_upgrade @@ -4280,6 +4314,8 @@ #define utf16_to_utf8 Perl_utf16_to_utf8 #define Perl_utf16_to_utf8_reversed CPerlObj::Perl_utf16_to_utf8_reversed #define utf16_to_utf8_reversed Perl_utf16_to_utf8_reversed +#define Perl_utf8_length CPerlObj::Perl_utf8_length +#define utf8_length Perl_utf8_length #define Perl_utf8_distance CPerlObj::Perl_utf8_distance #define utf8_distance Perl_utf8_distance #define Perl_utf8_hop CPerlObj::Perl_utf8_hop @@ -4288,10 +4324,10 @@ #define utf8_to_bytes Perl_utf8_to_bytes #define Perl_bytes_to_utf8 CPerlObj::Perl_bytes_to_utf8 #define bytes_to_utf8 Perl_bytes_to_utf8 +#define Perl_utf8_to_uv_simple CPerlObj::Perl_utf8_to_uv_simple +#define utf8_to_uv_simple Perl_utf8_to_uv_simple #define Perl_utf8_to_uv CPerlObj::Perl_utf8_to_uv #define utf8_to_uv Perl_utf8_to_uv -#define Perl_utf8_to_uv_chk CPerlObj::Perl_utf8_to_uv_chk -#define utf8_to_uv_chk Perl_utf8_to_uv_chk #define Perl_uv_to_utf8 CPerlObj::Perl_uv_to_utf8 #define uv_to_utf8 Perl_uv_to_utf8 #define Perl_vivify_defelem CPerlObj::Perl_vivify_defelem @@ -4318,7 +4354,9 @@ #define whichsig Perl_whichsig #define Perl_yyerror CPerlObj::Perl_yyerror #define yyerror Perl_yyerror -#if defined(USE_PURE_BISON) +#ifdef USE_PURE_BISON +#define Perl_yylex_r CPerlObj::Perl_yylex_r +#define yylex_r Perl_yylex_r #define Perl_yylex CPerlObj::Perl_yylex #define yylex Perl_yylex #else @@ -4449,6 +4487,8 @@ #define sv_utf8_decode Perl_sv_utf8_decode #define Perl_sv_force_normal CPerlObj::Perl_sv_force_normal #define sv_force_normal Perl_sv_force_normal +#define Perl_sv_force_normal_flags CPerlObj::Perl_sv_force_normal_flags +#define sv_force_normal_flags Perl_sv_force_normal_flags #define Perl_tmps_grow CPerlObj::Perl_tmps_grow #define tmps_grow Perl_tmps_grow #define Perl_sv_rvweaken CPerlObj::Perl_sv_rvweaken @@ -4751,8 +4791,6 @@ #define reguni S_reguni #define S_regclass CPerlObj::S_regclass #define regclass S_regclass -#define S_regclassutf8 CPerlObj::S_regclassutf8 -#define regclassutf8 S_regclassutf8 #define S_regcurly CPerlObj::S_regcurly #define regcurly S_regcurly #define S_reg_node CPerlObj::S_reg_node @@ -4809,8 +4847,6 @@ #define regtry S_regtry #define S_reginclass CPerlObj::S_reginclass #define reginclass S_reginclass -#define S_reginclassutf8 CPerlObj::S_reginclassutf8 -#define reginclassutf8 S_reginclassutf8 #define S_regcppush CPerlObj::S_regcppush #define regcppush S_regcppush #define S_regcppop CPerlObj::S_regcppop @@ -4821,8 +4857,12 @@ #define cache_re S_cache_re #define S_reghop CPerlObj::S_reghop #define reghop S_reghop +#define S_reghop3 CPerlObj::S_reghop3 +#define reghop3 S_reghop3 #define S_reghopmaybe CPerlObj::S_reghopmaybe #define reghopmaybe S_reghopmaybe +#define S_reghopmaybe3 CPerlObj::S_reghopmaybe3 +#define reghopmaybe3 S_reghopmaybe3 #define S_find_byclass CPerlObj::S_find_byclass #define find_byclass S_find_byclass #endif @@ -4927,6 +4967,12 @@ #define S_del_sv CPerlObj::S_del_sv #define del_sv S_del_sv # endif +# if !defined(NV_PRESERVES_UV) +#define S_sv_2inuv_non_preserve CPerlObj::S_sv_2inuv_non_preserve +#define sv_2inuv_non_preserve S_sv_2inuv_non_preserve +#define S_sv_2iuv_non_preserve CPerlObj::S_sv_2iuv_non_preserve +#define sv_2iuv_non_preserve S_sv_2iuv_non_preserve +# endif #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #define S_check_uni CPerlObj::S_check_uni @@ -5019,6 +5065,8 @@ #define isa_lookup S_isa_lookup #endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) +#define S_stdize_locale CPerlObj::S_stdize_locale +#define stdize_locale S_stdize_locale #define S_mess_alloc CPerlObj::S_mess_alloc #define mess_alloc S_mess_alloc # if defined(LEAKTEST) diff --git a/embed.pl b/embed.pl index 9e05b1b..7b83635 100755 --- a/embed.pl +++ b/embed.pl @@ -1376,6 +1376,7 @@ START_EXTERN_C # include "pp_proto.h" Ap |SV* |amagic_call |SV* left|SV* right|int method|int dir Ap |bool |Gv_AMupdate |HV* stash +Ap |CV* |gv_handler |HV* stash|I32 id p |OP* |append_elem |I32 optype|OP* head|OP* tail p |OP* |append_list |I32 optype|LISTOP* first|LISTOP* last p |I32 |apply |I32 type|SV** mark|SV** sp @@ -1441,7 +1442,7 @@ Afnp |int |fprintf_nocontext|PerlIO* stream|const char* fmt|... #endif p |void |cv_ckproto |CV* cv|GV* gv|char* p p |CV* |cv_clone |CV* proto -Ap |SV* |cv_const_sv |CV* cv +Apd |SV* |cv_const_sv |CV* cv p |SV* |op_const_sv |OP* o|CV* cv Ap |void |cv_undef |CV* cv Ap |void |cx_dump |PERL_CONTEXT* cs @@ -1563,11 +1564,11 @@ Ap |HV* |gv_stashpvn |const char* name|U32 namelen|I32 create Apd |HV* |gv_stashsv |SV* sv|I32 create Apd |void |hv_clear |HV* tb Ap |void |hv_delayfree_ent|HV* hv|HE* entry -Apd |SV* |hv_delete |HV* tb|const char* key|U32 klen|I32 flags +Apd |SV* |hv_delete |HV* tb|const char* key|I32 klen|I32 flags Apd |SV* |hv_delete_ent |HV* tb|SV* key|I32 flags|U32 hash -Apd |bool |hv_exists |HV* tb|const char* key|U32 klen +Apd |bool |hv_exists |HV* tb|const char* key|I32 klen Apd |bool |hv_exists_ent |HV* tb|SV* key|U32 hash -Apd |SV** |hv_fetch |HV* tb|const char* key|U32 klen|I32 lval +Apd |SV** |hv_fetch |HV* tb|const char* key|I32 klen|I32 lval Apd |HE* |hv_fetch_ent |HV* tb|SV* key|I32 lval|U32 hash Ap |void |hv_free_ent |HV* hv|HE* entry Apd |I32 |hv_iterinit |HV* tb @@ -1578,7 +1579,7 @@ Apd |SV* |hv_iternextsv |HV* hv|char** key|I32* retlen Apd |SV* |hv_iterval |HV* tb|HE* entry Ap |void |hv_ksplit |HV* hv|IV newmax Apd |void |hv_magic |HV* hv|GV* gv|int how -Apd |SV** |hv_store |HV* tb|const char* key|U32 klen|SV* val \ +Apd |SV** |hv_store |HV* tb|const char* key|I32 klen|SV* val \ |U32 hash Apd |HE* |hv_store_ent |HV* tb|SV* key|SV* val|U32 hash Apd |void |hv_undef |HV* tb @@ -1626,7 +1627,7 @@ Ap |bool |is_uni_xdigit_lc|U32 c Ap |U32 |to_uni_upper_lc|U32 c Ap |U32 |to_uni_title_lc|U32 c Ap |U32 |to_uni_lower_lc|U32 c -Ap |int |is_utf8_char |U8 *p +Ap |STRLEN |is_utf8_char |U8 *p Ap |bool |is_utf8_string |U8 *s|STRLEN len Ap |bool |is_utf8_alnum |U8 *p Ap |bool |is_utf8_alnumc |U8 *p @@ -1761,7 +1762,7 @@ Ap |OP* |newANONHASH |OP* o Ap |OP* |newANONSUB |I32 floor|OP* proto|OP* block Ap |OP* |newASSIGNOP |I32 flags|OP* left|I32 optype|OP* right Ap |OP* |newCONDOP |I32 flags|OP* expr|OP* trueop|OP* falseop -Apd |void |newCONSTSUB |HV* stash|char* name|SV* sv +Apd |CV* |newCONSTSUB |HV* stash|char* name|SV* sv Ap |void |newFORM |I32 floor|OP* o|OP* block Ap |OP* |newFOROP |I32 flags|char* label|line_t forline \ |OP* sclr|OP* expr|OP*block|OP*cont @@ -1801,7 +1802,7 @@ Apd |SV* |newSVuv |UV u Apd |SV* |newSVnv |NV n Apd |SV* |newSVpv |const char* s|STRLEN len Apd |SV* |newSVpvn |const char* s|STRLEN len -Apd |SV* |newSVpvn_share |const char* s|STRLEN len|U32 hash +Apd |SV* |newSVpvn_share |const char* s|I32 len|U32 hash Afpd |SV* |newSVpvf |const char* pat|... Ap |SV* |vnewSVpvf |const char* pat|va_list* args Apd |SV* |newSVrv |SV* rv|const char* classname @@ -1828,6 +1829,7 @@ p |void |pad_free |PADOFFSET po p |void |pad_reset p |void |pad_swipe |PADOFFSET po p |void |peep |OP* o +dopM |PerlIO*|start_glob |SV* pattern|IO *io #if defined(PERL_OBJECT) Aox |void |Perl_construct Aox |void |Perl_destruct @@ -1852,9 +1854,9 @@ Apd |HV* |get_hv |const char* name|I32 create Apd |CV* |get_cv |const char* name|I32 create Ap |int |init_i18nl10n |int printwarn Ap |int |init_i18nl14n |int printwarn -Ap |void |new_collate |const char* newcoll -Ap |void |new_ctype |const char* newctype -Ap |void |new_numeric |const char* newcoll +Ap |void |new_collate |char* newcoll +Ap |void |new_ctype |char* newctype +Ap |void |new_numeric |char* newcoll Ap |void |set_numeric_local Ap |void |set_numeric_radix Ap |void |set_numeric_standard @@ -1871,6 +1873,7 @@ Ap |void |push_scope p |OP* |ref |OP* o|I32 type p |OP* |refkids |OP* o|I32 type Ap |void |regdump |regexp* r +Ap |SV* |regclass_swash |struct regnode *n|bool doinit|SV **initsvp Ap |I32 |pregexec |regexp* prog|char* stringarg \ |char* strend|char* strbeg|I32 minend \ |SV* screamer|U32 nosave @@ -1933,6 +1936,7 @@ Ap |SV* |save_scalar |GV* gv Ap |void |save_pptr |char** pptr Ap |void |save_vptr |void* pptr Ap |void |save_re_context +Ap |void |save_padsv |PADOFFSET off Ap |void |save_sptr |SV** sptr Ap |SV* |save_svref |SV** sptr Ap |SV** |save_threadsv |PADOFFSET i @@ -1941,10 +1945,10 @@ p |OP* |scalar |OP* o p |OP* |scalarkids |OP* o p |OP* |scalarseq |OP* o p |OP* |scalarvoid |OP* o -Ap |NV |scan_bin |char* start|I32 len|I32* retlen -Ap |NV |scan_hex |char* start|I32 len|I32* retlen -Ap |char* |scan_num |char* s -Ap |NV |scan_oct |char* start|I32 len|I32* retlen +Ap |NV |scan_bin |char* start|STRLEN len|STRLEN* retlen +Ap |NV |scan_hex |char* start|STRLEN len|STRLEN* retlen +Ap |char* |scan_num |char* s|YYSTYPE *lvalp +Ap |NV |scan_oct |char* start|STRLEN len|STRLEN* retlen p |OP* |scope |OP* o Ap |char* |screaminstr |SV* bigsv|SV* littlesv|I32 start_shift \ |I32 end_shift|I32 *state|I32 last @@ -2041,6 +2045,7 @@ Ap |void |sv_taint |SV* sv Ap |bool |sv_tainted |SV* sv Apd |int |sv_unmagic |SV* sv|int type Apd |void |sv_unref |SV* sv +Apd |void |sv_unref_flags |SV* sv|U32 flags Ap |void |sv_untaint |SV* sv Apd |bool |sv_upgrade |SV* sv|U32 mt Apd |void |sv_usepvn |SV* sv|char* ptr|STRLEN len @@ -2070,12 +2075,13 @@ p |void |unshare_hek |HEK* hek p |void |utilize |int aver|I32 floor|OP* version|OP* id|OP* arg Ap |U8* |utf16_to_utf8 |U8* p|U8 *d|I32 bytelen|I32 *newlen Ap |U8* |utf16_to_utf8_reversed|U8* p|U8 *d|I32 bytelen|I32 *newlen -Ap |I32 |utf8_distance |U8 *a|U8 *b +Ap |STRLEN |utf8_length |U8* s|U8 *e +Ap |IV |utf8_distance |U8 *a|U8 *b Ap |U8* |utf8_hop |U8 *s|I32 off ApM |U8* |utf8_to_bytes |U8 *s|STRLEN *len ApM |U8* |bytes_to_utf8 |U8 *s|STRLEN *len -Ap |UV |utf8_to_uv |U8 *s|I32* retlen -Ap |UV |utf8_to_uv_chk |U8 *s|I32* retlen|bool checking +Ap |UV |utf8_to_uv_simple|U8 *s|STRLEN* retlen +Ap |UV |utf8_to_uv |U8 *s|STRLEN curlen|STRLEN* retlen|U32 flags Ap |U8* |uv_to_utf8 |U8 *d|UV uv p |void |vivify_defelem |SV* sv p |void |vivify_ref |SV* sv|U32 to_what @@ -2089,7 +2095,8 @@ Ap |void |vwarner |U32 err|const char* pat|va_list* args p |void |watch |char** addr Ap |I32 |whichsig |char* sig p |int |yyerror |char* s -#if defined(USE_PURE_BISON) +#ifdef USE_PURE_BISON +p |int |yylex_r |YYSTYPE *lvalp|int *lcharp p |int |yylex |YYSTYPE *lvalp|int *lcharp #else p |int |yylex @@ -2167,6 +2174,7 @@ ApdM |bool |sv_utf8_downgrade|SV *sv|bool fail_ok ApdM |void |sv_utf8_encode |SV *sv Ap |bool |sv_utf8_decode |SV *sv Ap |void |sv_force_normal|SV *sv +Ap |void |sv_force_normal_flags|SV *sv|U32 flags Ap |void |tmps_grow |I32 n Apd |SV* |sv_rvweaken |SV *sv p |int |magic_killbackrefs|SV *sv|MAGIC *mg @@ -2353,40 +2361,39 @@ s |int |dooneliner |char *cmd|char *filename #endif #if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT) -s |regnode*|reg |I32|I32 * -s |regnode*|reganode |U8|U32 -s |regnode*|regatom |I32 * -s |regnode*|regbranch |I32 *|I32 -s |void |reguni |UV|char *|I32* -s |regnode*|regclass -s |regnode*|regclassutf8 +s |regnode*|reg |struct RExC_state_t*|I32|I32 * +s |regnode*|reganode |struct RExC_state_t*|U8|U32 +s |regnode*|regatom |struct RExC_state_t*|I32 * +s |regnode*|regbranch |struct RExC_state_t*|I32 *|I32 +s |void |reguni |struct RExC_state_t*|UV|char *|STRLEN* +s |regnode*|regclass |struct RExC_state_t* s |I32 |regcurly |char * -s |regnode*|reg_node |U8 -s |regnode*|regpiece |I32 * -s |void |reginsert |U8|regnode * -s |void |regoptail |regnode *|regnode * -s |void |regtail |regnode *|regnode * +s |regnode*|reg_node |struct RExC_state_t*|U8 +s |regnode*|regpiece |struct RExC_state_t*|I32 * +s |void |reginsert |struct RExC_state_t*|U8|regnode * +s |void |regoptail |struct RExC_state_t*|regnode *|regnode * +s |void |regtail |struct RExC_state_t*|regnode *|regnode * s |char*|regwhite |char *|char * -s |char*|nextchar +s |char*|nextchar |struct RExC_state_t* s |regnode*|dumpuntil |regnode *start|regnode *node \ |regnode *last|SV* sv|I32 l s |void |put_byte |SV* sv|int c -s |void |scan_commit |struct scan_data_t *data -s |void |cl_anything |struct regnode_charclass_class *cl +s |void |scan_commit |struct RExC_state_t*|struct scan_data_t *data +s |void |cl_anything |struct RExC_state_t*|struct regnode_charclass_class *cl s |int |cl_is_anything |struct regnode_charclass_class *cl -s |void |cl_init |struct regnode_charclass_class *cl -s |void |cl_init_zero |struct regnode_charclass_class *cl +s |void |cl_init |struct RExC_state_t*|struct regnode_charclass_class *cl +s |void |cl_init_zero |struct RExC_state_t*|struct regnode_charclass_class *cl s |void |cl_and |struct regnode_charclass_class *cl \ |struct regnode_charclass_class *and_with -s |void |cl_or |struct regnode_charclass_class *cl \ +s |void |cl_or |struct RExC_state_t*|struct regnode_charclass_class *cl \ |struct regnode_charclass_class *or_with -s |I32 |study_chunk |regnode **scanp|I32 *deltap \ +s |I32 |study_chunk |struct RExC_state_t*|regnode **scanp|I32 *deltap \ |regnode *last|struct scan_data_t *data \ |U32 flags -s |I32 |add_data |I32 n|char *s +s |I32 |add_data |struct RExC_state_t*|I32 n|char *s rs |void|re_croak2 |const char* pat1|const char* pat2|... -s |I32 |regpposixcc |I32 value -s |void |checkposixcc +s |I32 |regpposixcc |struct RExC_state_t*|I32 value +s |void |checkposixcc |struct RExC_state_t* #endif #if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT) @@ -2394,14 +2401,15 @@ s |I32 |regmatch |regnode *prog s |I32 |regrepeat |regnode *p|I32 max s |I32 |regrepeat_hard |regnode *p|I32 max|I32 *lp s |I32 |regtry |regexp *prog|char *startpos -s |bool |reginclass |regnode *p|I32 c -s |bool |reginclassutf8 |regnode *f|U8* p +s |bool |reginclass |regnode *n|U8 *p|bool do_utf8sv_is_utf8 s |CHECKPOINT|regcppush |I32 parenfloor s |char*|regcppop s |char*|regcp_set_to |I32 ss s |void |cache_re |regexp *prog s |U8* |reghop |U8 *pos|I32 off +s |U8* |reghop3 |U8 *pos|I32 off|U8 *lim s |U8* |reghopmaybe |U8 *pos|I32 off +s |U8* |reghopmaybe3 |U8 *pos|I32 off|U8 *lim s |char* |find_byclass |regexp * prog|regnode *c|char *s|char *strend|char *startpos|I32 norun #endif @@ -2461,6 +2469,10 @@ s |void |sv_del_backref |SV *sv # if defined(DEBUGGING) s |void |del_sv |SV *p # endif +# if !defined(NV_PRESERVES_UV) +s |int |sv_2inuv_non_preserve |SV *sv|I32 numtype +s |int |sv_2iuv_non_preserve |SV *sv|I32 numtype +# endif #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) @@ -2520,6 +2532,7 @@ s |SV*|isa_lookup |HV *stash|const char *name|int len|int level #endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) +s |char* |stdize_locale |char* locs s |SV* |mess_alloc # if defined(LEAKTEST) s |void |xstat |int diff --git a/embedvar.h b/embedvar.h index 729389c..fddcd12 100644 --- a/embedvar.h +++ b/embedvar.h @@ -70,8 +70,7 @@ #define PL_modcount (vTHX->Tmodcount) #define PL_na (vTHX->Tna) #define PL_nrs (vTHX->Tnrs) -#define PL_ofs (vTHX->Tofs) -#define PL_ofslen (vTHX->Tofslen) +#define PL_ofs_sv (vTHX->Tofs_sv) #define PL_op (vTHX->Top) #define PL_opsave (vTHX->Topsave) #define PL_protect (vTHX->Tprotect) @@ -341,8 +340,7 @@ #define PL_origargv (PERL_GET_INTERP->Iorigargv) #define PL_origenviron (PERL_GET_INTERP->Iorigenviron) #define PL_origfilename (PERL_GET_INTERP->Iorigfilename) -#define PL_ors (PERL_GET_INTERP->Iors) -#define PL_orslen (PERL_GET_INTERP->Iorslen) +#define PL_ors_sv (PERL_GET_INTERP->Iors_sv) #define PL_osname (PERL_GET_INTERP->Iosname) #define PL_pad_reset_pending (PERL_GET_INTERP->Ipad_reset_pending) #define PL_padix (PERL_GET_INTERP->Ipadix) @@ -621,8 +619,7 @@ #define PL_origargv (vTHX->Iorigargv) #define PL_origenviron (vTHX->Iorigenviron) #define PL_origfilename (vTHX->Iorigfilename) -#define PL_ors (vTHX->Iors) -#define PL_orslen (vTHX->Iorslen) +#define PL_ors_sv (vTHX->Iors_sv) #define PL_osname (vTHX->Iosname) #define PL_pad_reset_pending (vTHX->Ipad_reset_pending) #define PL_padix (vTHX->Ipadix) @@ -775,8 +772,7 @@ #define PL_modcount (aTHXo->interp.Tmodcount) #define PL_na (aTHXo->interp.Tna) #define PL_nrs (aTHXo->interp.Tnrs) -#define PL_ofs (aTHXo->interp.Tofs) -#define PL_ofslen (aTHXo->interp.Tofslen) +#define PL_ofs_sv (aTHXo->interp.Tofs_sv) #define PL_op (aTHXo->interp.Top) #define PL_opsave (aTHXo->interp.Topsave) #define PL_protect (aTHXo->interp.Tprotect) @@ -1038,8 +1034,7 @@ #define PL_origargv (aTHXo->interp.Iorigargv) #define PL_origenviron (aTHXo->interp.Iorigenviron) #define PL_origfilename (aTHXo->interp.Iorigfilename) -#define PL_ors (aTHXo->interp.Iors) -#define PL_orslen (aTHXo->interp.Iorslen) +#define PL_ors_sv (aTHXo->interp.Iors_sv) #define PL_osname (aTHXo->interp.Iosname) #define PL_pad_reset_pending (aTHXo->interp.Ipad_reset_pending) #define PL_padix (aTHXo->interp.Ipadix) @@ -1319,8 +1314,7 @@ #define PL_Iorigargv PL_origargv #define PL_Iorigenviron PL_origenviron #define PL_Iorigfilename PL_origfilename -#define PL_Iors PL_ors -#define PL_Iorslen PL_orslen +#define PL_Iors_sv PL_ors_sv #define PL_Iosname PL_osname #define PL_Ipad_reset_pending PL_pad_reset_pending #define PL_Ipadix PL_padix @@ -1469,8 +1463,7 @@ #define PL_modcount (aTHX->Tmodcount) #define PL_na (aTHX->Tna) #define PL_nrs (aTHX->Tnrs) -#define PL_ofs (aTHX->Tofs) -#define PL_ofslen (aTHX->Tofslen) +#define PL_ofs_sv (aTHX->Tofs_sv) #define PL_op (aTHX->Top) #define PL_opsave (aTHX->Topsave) #define PL_protect (aTHX->Tprotect) @@ -1606,8 +1599,7 @@ #define PL_Tmodcount PL_modcount #define PL_Tna PL_na #define PL_Tnrs PL_nrs -#define PL_Tofs PL_ofs -#define PL_Tofslen PL_ofslen +#define PL_Tofs_sv PL_ofs_sv #define PL_Top PL_op #define PL_Topsave PL_opsave #define PL_Tprotect PL_protect diff --git a/epoc/config.sh b/epoc/config.sh index ee65ee3..c155ce4 100644 --- a/epoc/config.sh +++ b/epoc/config.sh @@ -78,6 +78,7 @@ cppsymbols='' crosscompile='define' cryptlib='' csh='csh' +d__fwalk='undef' d_Gconvert='epoc_gcvt((x),(n),(b))' d_PRIEUldbl='undef' d_PRIFUldbl='undef' @@ -138,6 +139,7 @@ d_eunice='undef' d_fchmod='undef' d_fchown='undef' d_fcntl='undef' +d_fcntl_can_lock='undef' d_fd_macros='undef' d_fd_set='define' d_fds_bits='undef' @@ -152,6 +154,7 @@ d_fseeko='undef' d_fsetpos='define' d_fstatfs='define' d_fstatvfs='undef' +d_fsync='undef' d_ftello='undef' d_ftime='undef' d_getespwnam='undef' @@ -169,6 +172,7 @@ d_getnbyaddr='undef' d_getnbyname='undef' d_getnent='undef' d_getnetprotos='define' +d_getpagsz='undef' d_getpbyname='define' d_getpbynumber='define' d_getpent='undef' @@ -271,6 +275,7 @@ d_rmdir='define' d_safebcpy='undef' d_safemcpy='undef' d_sanemcmp='define' +d_sbrkproto='undef' d_sched_yield='undef' d_scm_rights='undef' d_seekdir='define' @@ -324,6 +329,8 @@ d_statfsflags='define' d_statvfs='undef' d_stdio_cnt_lval='define' d_stdio_ptr_lval='define' +d_stdio_ptr_lval_sets_cnt='undef' +d_stdio_ptr_lval_nochange_cnt='undef' d_stdio_stream_array='undef' d_stdiobase='undef' d_stdstdio='undef' @@ -334,7 +341,9 @@ d_strerrm='strerror(e)' d_strerror='define' d_strtod='define' d_strtol='define' +d_strtoq='undef' d_strtoul='define' +d_strtouq='undef' d_strtoull='undef' d_strxfrm='define' d_suidsafe='undef' @@ -566,6 +575,7 @@ mydomain='.gmx.de' myhostname='dragon' myuname='' n='-n' +need_va_copy='undef' netdb_hlen_type='int' netdb_host_type='const char *' netdb_name_type='const char *' @@ -973,3 +983,6 @@ i_prot='undef' d_SCNfldbl='undef' d_perl_otherlibdirs='undef' nvsize='16' +issymlink='' + + diff --git a/epoc/epoc.c b/epoc/epoc.c index a2691f3..b9bc652 100644 --- a/epoc/epoc.c +++ b/epoc/epoc.c @@ -101,7 +101,6 @@ do_aspawn( pTHX_ SV *really,SV **mark,SV **sp) { int do_spawn (pTHX_ SV *really,SV **mark,SV **sp) { - dTHR; int rc; char **a,*cmd,**ptr, *cmdline, **argv, *p2; STRLEN n_a; diff --git a/epoc/epocish.c b/epoc/epocish.c index 4963a2e5..a0557cc 100644 --- a/epoc/epocish.c +++ b/epoc/epocish.c @@ -33,8 +33,12 @@ epoc_spawn( char *cmd, char *cmdline) { /* Workaround for defect atof(), see java defect list for epoc */ - double epoc_atof( const char* str) { + double epoc_atof( char* str) { TReal64 aRes; + + while (TChar( *str).IsSpace()) { + str++; + } TLex lex( _L( str)); TInt err = lex.Val( aRes, TChar( '.')); diff --git a/ext/B/B.pm b/ext/B/B.pm index 50364fa..591b581 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -9,12 +9,17 @@ package B; use XSLoader (); require Exporter; @ISA = qw(Exporter); + +# walkoptree_slow comes from B.pm (you are there), +# walkoptree comes from B.xs @EXPORT_OK = qw(minus_c ppname save_BEGINs class peekop cast_I32 cstring cchar hash threadsv_names - main_root main_start main_cv svref_2object opnumber amagic_generation - walkoptree walkoptree_slow walkoptree_exec walksymtable + main_root main_start main_cv svref_2object opnumber + amagic_generation + walkoptree_slow walkoptree walkoptree_exec walksymtable parents comppadlist sv_undef compile_stats timing_info begin_av init_av end_av); + sub OPf_KIDS (); use strict; @B::SV::ISA = 'B::OBJECT'; @@ -185,7 +190,7 @@ sub walksymtable { *glob = "*main::".$prefix.$sym; if ($sym =~ /::$/) { $sym = $prefix . $sym; - if ($sym ne "main::" && &$recurse($sym)) { + if ($sym ne "main::" && $sym ne "::" && &$recurse($sym)) { walksymtable(\%glob, $method, $recurse, $sym); } } else { @@ -531,6 +536,8 @@ This method returns TRUE if the GP field of the GV is NULL. =item CvFLAGS +=item const_sv + =back =head2 B::HV METHODS diff --git a/ext/B/B.xs b/ext/B/B.xs index f1f0e65..ec9e578 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -1229,6 +1229,12 @@ U16 CvFLAGS(cv) B::CV cv +MODULE = B PACKAGE = B::CV PREFIX = cv_ + +B::SV +cv_const_sv(cv) + B::CV cv + MODULE = B PACKAGE = B::HV PREFIX = Hv diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm index d0c8159..dac9417 100644 --- a/ext/B/B/C.pm +++ b/ext/B/B/C.pm @@ -1020,7 +1020,6 @@ sub output_all { print <<"EOT"; static int $init_name() { - dTHR; dTARG; djSP; EOT @@ -1338,7 +1337,7 @@ sub should_save # Now see if current package looks like an OO class this is probably too strong. foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE)) { - if ($package->can($m)) + if (UNIVERSAL::can($package, $m)) { warn "$package has method $m: saving package\n";#debug return mark_package($package); @@ -1368,7 +1367,7 @@ sub walkpackages if ($sym =~ /::$/) { $sym = $prefix . $sym; - if ($sym ne "main::" && &$recurse($sym)) + if ($sym ne "main::" && $sym ne "::" && &$recurse($sym)) { walkpackages(\%glob, $recurse, $sym); } diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm index 5c5c5eb..b0a5eae 100644 --- a/ext/B/B/Deparse.pm +++ b/ext/B/B/Deparse.pm @@ -17,7 +17,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber CVf_METHOD CVf_LOCKED CVf_LVALUE PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); -$VERSION = 0.591; +$VERSION = 0.60; use strict; # Changes between 0.50 and 0.51: @@ -83,6 +83,12 @@ use strict; # - added support for Chip's OP_METHOD_NAMED # - added support for Ilya's OPpTARGET_MY optimization # - elided arrows before `()' subscripts when possible +# Changes between 0.59 and 0.60 +# - support for method attribues was added +# - some warnings fixed +# - separate recognition of constant subs +# - rewrote continue block handling, now recoginizing for loops +# - added more control of expanding control structures # Todo: # - finish tr/// changes @@ -93,8 +99,8 @@ use strict; # - left/right context # - recognize `use utf8', `use integer', etc # - treat top-level block specially for incremental output -# - interpret in high bit chars in string as utf8 \x{...} (when?) -# - copy comments (look at real text with $^P?) +# - interpret high bit chars in string as utf8 \x{...} (when?) +# - copy comments (look at real text with $^P?) # - avoid semis in one-statement blocks # - associativity of &&=, ||=, ?: # - ',' => '=>' (auto-unquote?) @@ -108,7 +114,6 @@ use strict; # - version using op_next instead of op_first/sibling? # - avoid string copies (pass arrays, one big join?) # - auto-apply `-u'? -# - while{} with one-statement continue => for(; XXX; XXX) {}? # - -uPackage:: descend recursively? # - here-docs? # - ? @@ -357,6 +362,8 @@ sub new { $self->{'unquote'} = 1; } elsif (substr($arg, 0, 2) eq "-s") { $self->style_opts(substr $arg, 2); + } elsif ($arg =~ /^-x(\d)$/) { + $self->{'expand'} = $1; } } return $self; @@ -393,6 +400,7 @@ sub deparse { my $self = shift; my($op, $cx) = @_; # cluck if class($op) eq "NULL"; +# cluck unless $op; # return $self->$ {\("pp_" . $op->name)}($op, $cx); my $meth = "pp_" . $op->name; return $self->$meth($op, $cx); @@ -446,6 +454,11 @@ sub deparse_sub { # skip leavesub return $proto . "{\n\t" . $self->deparse($cv->ROOT->first, 0) . "\n\b}\n"; + } + my $sv = $cv->const_sv; + if ($$sv) { + # uh-oh. inlinable sub... format it differently + return $proto . "{ " . const($sv) . " }\n"; } else { # XSUB? return $proto . "{}\n"; } @@ -679,70 +692,69 @@ sub pp_entertry { # see also leavetry return "XXX"; } -# leave and scope/lineseq should probably share code -sub pp_leave { +sub lineseq { my $self = shift; - my($op, $cx) = @_; - my ($kid, $expr); - my @exprs; - local($self->{'curstash'}) = $self->{'curstash'}; - $kid = $op->first->sibling; # skip enter - if (is_miniwhile($kid)) { - my $top = $kid->first; - my $name = $top->name; - if ($name eq "and") { - $name = "while"; - } elsif ($name eq "or") { - $name = "until"; - } else { # no conditional -> while 1 or until 0 - return $self->deparse($top->first, 1) . " while 1"; - } - my $cond = $top->first; - my $body = $cond->sibling->first; # skip lineseq - $cond = $self->deparse($cond, 1); - $body = $self->deparse($body, 1); - return "$body $name $cond"; - } - for (; !null($kid); $kid = $kid->sibling) { + my(@ops) = @_; + my($expr, @exprs); + for (my $i = 0; $i < @ops; $i++) { $expr = ""; - if (is_state $kid) { - $expr = $self->deparse($kid, 0); - $kid = $kid->sibling; - last if null $kid; + if (is_state $ops[$i]) { + $expr = $self->deparse($ops[$i], 0); + $i++; + last if $i > $#ops; } - $expr .= $self->deparse($kid, 0); + if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and + $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3) + { + push @exprs, $expr . $self->for_loop($ops[$i], 0); + $i++; + next; + } + $expr .= $self->deparse($ops[$i], 0); push @exprs, $expr if length $expr; } - if ($cx > 0) { # inside an expression - return "do { " . join(";\n", @exprs) . " }"; - } else { - return join(";\n", @exprs) . ";"; - } + return join(";\n", @exprs); } -sub pp_scope { - my $self = shift; - my($op, $cx) = @_; - my ($kid, $expr); - my @exprs; - for ($kid = $op->first; !null($kid); $kid = $kid->sibling) { - $expr = ""; - if (is_state $kid) { - $expr = $self->deparse($kid, 0); - $kid = $kid->sibling; - last if null $kid; +sub scopeop { + my($real_block, $self, $op, $cx) = @_; + my $kid; + my @kids; + local($self->{'curstash'}) = $self->{'curstash'} if $real_block; + if ($real_block) { + $kid = $op->first->sibling; # skip enter + if (is_miniwhile($kid)) { + my $top = $kid->first; + my $name = $top->name; + if ($name eq "and") { + $name = "while"; + } elsif ($name eq "or") { + $name = "until"; + } else { # no conditional -> while 1 or until 0 + return $self->deparse($top->first, 1) . " while 1"; + } + my $cond = $top->first; + my $body = $cond->sibling->first; # skip lineseq + $cond = $self->deparse($cond, 1); + $body = $self->deparse($body, 1); + return "$body $name $cond"; } - $expr .= $self->deparse($kid, 0); - push @exprs, $expr if length $expr; + } else { + $kid = $op->first; + } + for (; !null($kid); $kid = $kid->sibling) { + push @kids, $kid; } if ($cx > 0) { # inside an expression, (a do {} while for lineseq) - return "do { " . join(";\n", @exprs) . " }"; + return "do { " . $self->lineseq(@kids) . " }"; } else { - return join(";\n", @exprs) . ";"; + return $self->lineseq(@kids) . ";"; } } -sub pp_lineseq { pp_scope(@_) } +sub pp_scope { scopeop(0, @_); } +sub pp_lineseq { scopeop(0, @_); } +sub pp_leave { scopeop(1, @_); } # The BEGIN {} is used here because otherwise this code isn't executed # when you run B::Deparse on itself. @@ -1380,11 +1392,14 @@ sub logop { my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_; my $left = $op->first; my $right = $op->first->sibling; - if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b} + if ($cx == 0 and is_scope($right) and $blockname + and $self->{'expand'} < 7) + { # if ($a) {$b} $left = $self->deparse($left, 1); $right = $self->deparse($right, 0); return "$blockname ($left) {\n\t$right\n\b}\cK"; - } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a + } elsif ($cx == 0 and $blockname and not $self->{'parens'} + and $self->{'expand'} < 7) { # $b if $a $right = $self->deparse($right, 1); $left = $self->deparse($left, 1); return "$right $blockname $left"; @@ -1675,7 +1690,8 @@ sub pp_cond_expr { my $false = $true->sibling; my $cuddle = $self->{'cuddle'}; unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and - (is_scope($false) || is_ifelse_cont($false))) { + (is_scope($false) || is_ifelse_cont($false)) + and $self->{'expand'} < 7) { $cond = $self->deparse($cond, 8); $true = $self->deparse($true, 8); $false = $self->deparse($false, 8); @@ -1704,20 +1720,24 @@ sub pp_cond_expr { return $head . join($cuddle, "", @elsifs) . $false; } -sub pp_leaveloop { +sub loop_common { my $self = shift; - my($op, $cx) = @_; + my($op, $cx, $init) = @_; my $enter = $op->first; my $kid = $enter->sibling; local($self->{'curstash'}) = $self->{'curstash'}; my $head = ""; my $bare = 0; + my $body; + my $cond = undef; if ($kid->name eq "lineseq") { # bare or infinite loop if (is_state $kid->last) { # infinite $head = "for (;;) "; # shorter than while (1) + $cond = ""; } else { $bare = 1; } + $body = $kid; } elsif ($enter->name eq "enteriter") { # foreach my $ary = $enter->first->sibling; # first was pushmark my $var = $ary->sibling; @@ -1749,62 +1769,60 @@ sub pp_leaveloop { $var = "\$" . $self->deparse($var, 1); } $head = "foreach $var ($ary) "; - $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER + $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER } elsif ($kid->name eq "null") { # while/until $kid = $kid->first; - my $name = {"and" => "while", "or" => "until"} - ->{$kid->name}; - $head = "$name (" . $self->deparse($kid->first, 1) . ") "; - $kid = $kid->first->sibling; + my $name = {"and" => "while", "or" => "until"}->{$kid->name}; + $cond = $self->deparse($kid->first, 1); + $head = "$name ($cond) "; + $body = $kid->first->sibling; } elsif ($kid->name eq "stub") { # bare and empty return "{;}"; # {} could be a hashref } - # The third-to-last kid is the continue block if the pointer used - # by `next BLOCK' points to its first OP, which happens to be the - # the op_next of the head of the _previous_ statement. - # Unless it's a bare loop, in which case it's last, since there's - # no unstack or extra nextstate. - # Except if the previous head isn't null but the first kid is - # (because it's a nulled out nextstate in a scope), in which - # case the head's next is advanced past the null but the nextop's - # isn't, so we need to try nextop->next. - my $precont; - my $cont = $kid->first; - if ($bare) { - while (!null($cont->sibling)) { - $precont = $cont; - $cont = $cont->sibling; - } - } else { - while (!null($cont->sibling->sibling->sibling)) { - $precont = $cont; - $cont = $cont->sibling; + # If there isn't a continue block, then the next pointer for the loop + # will point to the unstack, which is kid's penultimate child, except + # in a bare loop, when it will point to the leaveloop. When neither of + # these conditions hold, then the third-to-last child in the continue + # block (or the last in a bare loop). + my $cont_start = $enter->nextop; + my $cont; + if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) { + if ($bare) { + $cont = $body->last; + } else { + $cont = $body->first; + while (!null($cont->sibling->sibling->sibling)) { + $cont = $cont->sibling; + } + } + my $state = $body->first; + my $cuddle = $self->{'cuddle'}; + my @states; + for (; $$state != $$cont; $state = $state->sibling) { + push @states, $state; + } + $body = $self->lineseq(@states); + if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) { + $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") "; + $cont = "\cK"; + } else { + $cont = $cuddle . "continue {\n\t" . + $self->deparse($cont, 0) . "\n\b}\cK"; } - } - if ($precont and $ {$precont->next} == $ {$enter->nextop} - || $ {$precont->next} == $ {$enter->nextop->next} ) - { - my $state = $kid->first; - my $cuddle = $self->{'cuddle'}; - my($expr, @exprs); - for (; $$state != $$cont; $state = $state->sibling) { - $expr = ""; - if (is_state $state) { - $expr = $self->deparse($state, 0); - $state = $state->sibling; - last if null $state; - } - $expr .= $self->deparse($state, 0); - push @exprs, $expr if $expr; - } - $kid = join(";\n", @exprs); - $cont = $cuddle . "continue {\n\t" . - $self->deparse($cont, 0) . "\n\b}\cK"; } else { $cont = "\cK"; - $kid = $self->deparse($kid, 0); + $body = $self->deparse($body, 0); } - return $head . "{\n\t" . $kid . "\n\b}" . $cont; + return $head . "{\n\t" . $body . "\n\b}" . $cont; +} + +sub pp_leaveloop { loop_common(@_, "") } + +sub for_loop { + my $self = shift; + my($op, $cx) = @_; + my $init = $self->deparse($op, 1); + return $self->loop_common($op->sibling, $cx, $init); } sub pp_leavetry { @@ -2851,8 +2869,8 @@ B::Deparse - Perl compiler backend to produce perl code =head1 SYNOPSIS -B B<-MO=Deparse>[B<,-u>I][B<,-p>][B<,-q>][B<,-l>][B<,-s>I] - I +B B<-MO=Deparse>[B<,-u>I][B<,-p>][B<,-q>][B<,-l>] + [B<,-s>I][B<,-x>I] I =head1 DESCRIPTION @@ -2997,6 +3015,55 @@ file is compiled as a main program. =back +=item B<-x>I + +Expand conventional syntax constructions into equivalent ones that expose +their internal operation. I should be a digit, with higher values +meaning more expansion. As with B<-q>, this actually involves turning off +special cases in B::Deparse's normal operations. + +If I is at least 3, for loops will be translated into equivalent +while loops with continue blocks; for instance + + for ($i = 0; $i < 10; ++$i) { + print $i; + } + +turns into + + $i = 0; + while ($i < 10) { + print $i; + } continue { + ++$i + } + +Note that in a few cases this translation can't be perfectly carried back +into the source code -- if the loop's initializer declares a my variable, +for instance, it won't have the correct scope outside of the loop. + +If I is at least 7, if statements will be translated into equivalent +expressions using C<&&>, C and C; for instance + + print 'hi' if $nice; + if ($nice) { + print 'hi'; + } + if ($nice) { + print 'hi'; + } else { + print 'bye'; + } + +turns into + + $nice and print 'hi'; + $nice and do { print 'hi' }; + $nice ? do { print 'hi' } : do { print 'bye' }; + +Long sequences of elsifs will turn into nested ternary operators, which +B::Deparse doesn't know how to indent nicely. + =back =head1 USING B::Deparse AS A MODULE @@ -3043,7 +3110,7 @@ See the 'to do' list at the beginning of the module file. =head1 AUTHOR -Stephen McCamant , based on an earlier +Stephen McCamant , based on an earlier version by Malcolm Beattie , with contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons. diff --git a/ext/B/B/Lint.pm b/ext/B/B/Lint.pm index ed0d07d..094b3cf 100644 --- a/ext/B/B/Lint.pm +++ b/ext/B/B/Lint.pm @@ -116,7 +116,7 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk. =cut use strict; -use B qw(walkoptree_slow main_root walksymtable svref_2object parents +use B qw(walkoptree main_root walksymtable svref_2object parents OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY ); @@ -277,12 +277,12 @@ sub B::GV::lintcv { return if !$$cv || $done_cv{$$cv}++; my $root = $cv->ROOT; #warn " root = $root (0x$$root)\n";#debug - walkoptree_slow($root, "lint") if $$root; + walkoptree($root, "lint") if $$root; } sub do_lint { my %search_pack; - walkoptree_slow(main_root, "lint") if ${main_root()}; + walkoptree(main_root, "lint") if ${main_root()}; # Now do subs in main no strict qw(vars refs); diff --git a/ext/B/B/Terse.pm b/ext/B/B/Terse.pm index 66b5cfc..a7a071e 100644 --- a/ext/B/B/Terse.pm +++ b/ext/B/B/Terse.pm @@ -1,6 +1,6 @@ package B::Terse; use strict; -use B qw(peekop class walkoptree_slow walkoptree_exec +use B qw(peekop class walkoptree walkoptree_exec walkoptree_slow main_start main_root cstring svref_2object); use B::Asmdata qw(@specialsv_name); diff --git a/ext/ByteLoader/ByteLoader.xs b/ext/ByteLoader/ByteLoader.xs index d3b4351..05b795c 100644 --- a/ext/ByteLoader/ByteLoader.xs +++ b/ext/ByteLoader/ByteLoader.xs @@ -77,7 +77,6 @@ bl_read(struct byteloader_fdata *data, char *buf, size_t size, size_t n) static I32 byteloader_filter(pTHXo_ int idx, SV *buf_sv, int maxlen) { - dTHR; OP *saveroot = PL_main_root; OP *savestart = PL_main_start; struct byteloader_state bstate; diff --git a/ext/ByteLoader/byterun.c b/ext/ByteLoader/byterun.c index 19f1f6b..3e12790 100644 --- a/ext/ByteLoader/byterun.c +++ b/ext/ByteLoader/byterun.c @@ -54,7 +54,6 @@ bset_obj_store(pTHXo_ struct byteloader_state *bstate, void *obj, I32 ix) void byterun(pTHXo_ register struct byteloader_state *bstate) { - dTHR; register int insn; U32 ix; SV *specialsv_list[6]; diff --git a/ext/DB_File/Changes b/ext/DB_File/Changes index ad54382..eda270d 100644 --- a/ext/DB_File/Changes +++ b/ext/DB_File/Changes @@ -292,7 +292,45 @@ the updates to the documentation and writing DB_File::Lock (available on CPAN). -1.73 27th April 2000 +1.73 31st May 2000 * Added support in version.c for building with threaded Perl. + * Berkeley DB 3.1 has reenabled support for null keys. The test + harness has been updated to reflect this. + +1.74 10th December 2000 + + * A "close" call in DB_File.xs needed parenthesised to stop win32 from + thinking it was one of its macros. + + * Updated dbinfo to support Berkeley DB 3.1 file format changes. + + * DB_File.pm & the test hasness now use the warnings pragma (when + available). + + * Included Perl core patch 7703 -- size argument for hash_cb is different + for Berkeley DB 3.x + + * Included Perl core patch 7801 -- Give __getBerkeleyDBInfo the ANSI C + treatment. + + * @a = () produced the warning 'Argument "" isn't numeric in entersub' + This has been fixed. Thanks to Edward Avis for spotting this bug. + + * Added note about building under Linux. Included patches. + + * Included Perl core patch 8068 -- fix for bug 20001013.009 + When run with warnings enabled "$hash{XX} = undef " produced an + "Uninitialized value" warning. This has been fixed. + +1.75 17th December 2000 + + * Fixed perl core patch 7703 + + * Added suppport to allow DB_File to be built with Berkeley DB 3.2 -- + btree_compare, btree_prefix and hash_cb needed to be changed. + + * Updated dbinfo to support Berkeley DB 3.2 file format changes. + + diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index a1ec0e6..c830216 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -1,8 +1,8 @@ # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (Paul.Marquess@btinternet.com) -# last modified 26th April 2000 -# version 1.73 +# last modified 17th December 2000 +# version 1.75 # # Copyright (c) 1995-2000 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or @@ -13,6 +13,7 @@ package DB_File::HASHINFO ; require 5.003 ; +use warnings; use strict; use Carp; require Tie::Hash; @@ -104,6 +105,7 @@ sub CLEAR { my $self = shift ; $self->NotHere("CLEAR") } package DB_File::RECNOINFO ; +use warnings; use strict ; @DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ; @@ -121,6 +123,7 @@ sub TIEHASH package DB_File::BTREEINFO ; +use warnings; use strict ; @DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ; @@ -140,6 +143,7 @@ sub TIEHASH package DB_File ; +use warnings; use strict; use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO $db_version $use_XSLoader @@ -147,7 +151,7 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO use Carp; -$VERSION = "1.73" ; +$VERSION = "1.75" ; #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; $DB_BTREE = new DB_File::BTREEINFO ; @@ -271,7 +275,7 @@ sub TIEARRAY sub CLEAR { my $self = shift; - my $key = "" ; + my $key = 0 ; my $value = "" ; my $status = $self->seq($key, $value, R_FIRST()); my @keys; @@ -665,6 +669,7 @@ This example shows how to create a database, add key/value pairs to the database, delete keys/value pairs and finally how to enumerate the contents of the database. + use warnings ; use strict ; use DB_File ; use vars qw( %h $k $v ) ; @@ -715,6 +720,7 @@ This script shows how to override the default sorting algorithm that BTREE uses. Instead of using the normal lexical ordering, a case insensitive compare function will be used. + use warnings ; use strict ; use DB_File ; @@ -783,6 +789,7 @@ There are some difficulties in using the tied hash interface if you want to manipulate a BTREE database with duplicate keys. Consider this code: + use warnings ; use strict ; use DB_File ; @@ -837,6 +844,7 @@ and the API in general. Here is the script above rewritten using the C API method. + use warnings ; use strict ; use DB_File ; @@ -908,6 +916,7 @@ particular value occurred in the BTREE. So assuming the database created above, we can use C like this: + use warnings ; use strict ; use DB_File ; @@ -957,6 +966,7 @@ returns 0. Otherwise the method returns a non-zero value. Assuming the database from the previous example: + use warnings ; use strict ; use DB_File ; @@ -995,6 +1005,7 @@ Otherwise the method returns a non-zero value. Again assuming the existence of the C database + use warnings ; use strict ; use DB_File ; @@ -1039,6 +1050,7 @@ the use of the R_CURSOR flag with seq: In the example script below, the C sub uses this feature to find and print the first matching key/value pair given a partial key. + use warnings ; use strict ; use DB_File ; use Fcntl ; @@ -1143,6 +1155,7 @@ Here is a simple example that uses RECNO (if you are using a version of Perl earlier than 5.004_57 this example won't work -- see L for a workaround). + use warnings ; use strict ; use DB_File ; @@ -1232,6 +1245,7 @@ Here is a more complete example that makes use of some of the methods described above. It also makes use of the API interface directly (see L). + use warnings ; use strict ; use vars qw(@h $H $file $i) ; use DB_File ; @@ -1583,6 +1597,7 @@ the database and have them removed when you read from the database. As I'm sure you have already guessed, this is a problem that DBM Filters can fix very easily. + use warnings ; use strict ; use DB_File ; @@ -1625,6 +1640,7 @@ when reading. Here is a DBM Filter that does it: + use warnings ; use strict ; use DB_File ; my %hash ; @@ -1791,6 +1807,7 @@ Here is a snippet of code that is loosely based on Tom Christiansen's I script (available from your nearest CPAN archive in F). + use warnings ; use strict ; use DB_File ; use Fcntl ; @@ -1947,6 +1964,7 @@ You will encounter this particular error message when you have the C pragma (or the full strict pragma) in your script. Consider this script: + use warnings ; use strict ; use DB_File ; use vars qw(%x) ; diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index cb8fd80..fa3bb33 100644 --- a/ext/DB_File/DB_File.xs +++ b/ext/DB_File/DB_File.xs @@ -3,8 +3,8 @@ DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess - last modified 27th April 2000 - version 1.73 + last modified 17 December 2000 + version 1.75 All comments/suggestions/problems are welcome @@ -83,6 +83,13 @@ Rewrote push 1.72 - No change to DB_File.xs 1.73 - No change to DB_File.xs + 1.74 - A call to open needed parenthesised to stop it clashing + with a win32 macro. + Added Perl core patches 7703 & 7801. + 1.75 - Fixed Perl core patch 7703. + Added suppport to allow DB_File to be built with + Berkeley DB 3.2 -- btree_compare, btree_prefix and hash_cb + needed to be changed. */ @@ -128,6 +135,10 @@ # include #endif +#ifdef CAN_PROTOTYPE +extern void __getBerkeleyDBInfo(void); +#endif + #ifndef pTHX # define pTHX # define pTHX_ @@ -159,6 +170,10 @@ # define BERKELEY_DB_1_OR_2 #endif +#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2) +# define AT_LEAST_DB_3_2 +#endif + /* map version 2 features & constants onto their version 1 equivalent */ #ifdef DB_Prefix_t @@ -244,6 +259,7 @@ typedef db_recno_t recno_t; #else /* db version 1.x */ +#define BERKELEY_DB_1 #define BERKELEY_DB_1_OR_2 typedef union INFO { @@ -473,6 +489,19 @@ u_int flags ; static int +#ifdef AT_LEAST_DB_3_2 + +#ifdef CAN_PROTOTYPE +btree_compare(DB * db, const DBT *key1, const DBT *key2) +#else +btree_compare(db, key1, key2) +DB * db ; +const DBT * key1 ; +const DBT * key2 ; +#endif /* CAN_PROTOTYPE */ + +#else /* Berkeley DB < 3.2 */ + #ifdef CAN_PROTOTYPE btree_compare(const DBT *key1, const DBT *key2) #else @@ -480,6 +509,9 @@ btree_compare(key1, key2) const DBT * key1 ; const DBT * key2 ; #endif + +#endif + { #ifdef dTHX dTHX; @@ -529,6 +561,19 @@ const DBT * key2 ; } static DB_Prefix_t +#ifdef AT_LEAST_DB_3_2 + +#ifdef CAN_PROTOTYPE +btree_prefix(DB * db, const DBT *key1, const DBT *key2) +#else +btree_prefix(db, key1, key2) +Db * db ; +const DBT * key1 ; +const DBT * key2 ; +#endif + +#else /* Berkeley DB < 3.2 */ + #ifdef CAN_PROTOTYPE btree_prefix(const DBT *key1, const DBT *key2) #else @@ -536,6 +581,8 @@ btree_prefix(key1, key2) const DBT * key1 ; const DBT * key2 ; #endif + +#endif { #ifdef dTHX dTHX; @@ -584,13 +631,35 @@ const DBT * key2 ; return (retval) ; } + +#ifdef BERKELEY_DB_1 +# define HASH_CB_SIZE_TYPE size_t +#else +# define HASH_CB_SIZE_TYPE u_int32_t +#endif + static DB_Hash_t +#ifdef AT_LEAST_DB_3_2 + #ifdef CAN_PROTOTYPE -hash_cb(const void *data, size_t size) +hash_cb(DB * db, const void *data, u_int32_t size) +#else +hash_cb(db, data, size) +DB * db ; +const void * data ; +HASH_CB_SIZE_TYPE size ; +#endif + +#else /* Berkeley DB < 3.2 */ + +#ifdef CAN_PROTOTYPE +hash_cb(const void *data, HASH_CB_SIZE_TYPE size) #else hash_cb(data, size) const void * data ; -size_t size ; +HASH_CB_SIZE_TYPE size ; +#endif + #endif { #ifdef dTHX @@ -1266,7 +1335,7 @@ SV * sv ; Flags |= DB_TRUNCATE ; #endif - status = RETVAL->dbp->open(RETVAL->dbp, name, NULL, RETVAL->type, + status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type, Flags, mode) ; /* printf("open returned %d %s\n", status, db_strerror(status)) ; */ diff --git a/ext/DB_File/dbinfo b/ext/DB_File/dbinfo index 701ac61..5a4df15 100644 --- a/ext/DB_File/dbinfo +++ b/ext/DB_File/dbinfo @@ -4,10 +4,10 @@ # a database file # # Author: Paul Marquess -# Version: 1.02 -# Date 20th August 1999 +# Version: 1.03 +# Date 17th September 2000 # -# Copyright (c) 1998 Paul Marquess. All rights reserved. +# Copyright (c) 1998-2000 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. @@ -28,7 +28,8 @@ my %Data = 4 => "Unknown", 5 => "2.0.0 -> 2.3.0", 6 => "2.3.1 -> 2.7.7", - 7 => "3.0.0 or greater", + 7 => "3.0.x", + 8 => "3.1.x or greater", } }, 0x061561 => { @@ -40,14 +41,17 @@ my %Data = 3 => "1.86", 4 => "2.0.0 -> 2.1.0", 5 => "2.2.6 -> 2.7.7", - 6 => "3.0.0 or greater", + 6 => "3.0.x", + 7 => "3.1.x or greater", } }, 0x042253 => { Type => "Queue", Versions => { - 1 => "3.0.0 or greater", + 1 => "3.0.x", + 2 => "3.1.x", + 3 => "3.2.x or greater", } }, ) ; @@ -86,7 +90,7 @@ else { die "not a Berkeley DB database file.\n" } my $type = $Data{$magic} ; -my $magic = sprintf "%06X", $magic ; +$magic = sprintf "%06X", $magic ; my $ver_string = "Unknown" ; $ver_string = $type->{Versions}{$version} diff --git a/ext/DB_File/typemap b/ext/DB_File/typemap index 41a24f4..55439ee 100644 --- a/ext/DB_File/typemap +++ b/ext/DB_File/typemap @@ -1,8 +1,8 @@ # typemap for Perl 5 interface to Berkeley # # written by Paul Marquess -# last modified 7th September 1999 -# version 1.71 +# last modified 10th December 2000 +# version 1.74 # #################################### DB SECTION # @@ -29,9 +29,10 @@ T_dbtkeydatum T_dbtdatum ckFilter($arg, filter_store_value, \"filter_store_value\"); DBT_clear($var) ; - $var.data = SvPV($arg, PL_na); - $var.size = (int)PL_na; - + if (SvOK($arg)) { + $var.data = SvPV($arg, PL_na); + $var.size = (int)PL_na; + } OUTPUT diff --git a/ext/DB_File/version.c b/ext/DB_File/version.c index f3e2c94..6e55b2e 100644 --- a/ext/DB_File/version.c +++ b/ext/DB_File/version.c @@ -17,6 +17,8 @@ Support for Berkeley DB 2/3's backward compatability mode. 1.72 - No change. 1.73 - Added support for threading + 1.74 - Added Perl core patch 7801. + */ @@ -27,7 +29,11 @@ #include void +#ifdef CAN_PROTOTYPE +__getBerkeleyDBInfo(void) +#else __getBerkeleyDBInfo() +#endif { #ifdef dTHX dTHX; diff --git a/ext/Devel/DProf/DProf.xs b/ext/Devel/DProf/DProf.xs index 7167a00..8f28c6e 100644 --- a/ext/Devel/DProf/DProf.xs +++ b/ext/Devel/DProf/DProf.xs @@ -3,11 +3,6 @@ #include "perl.h" #include "XSUB.h" -/* For older Perls */ -#ifndef dTHR -# define dTHR int dummy_thr -#endif /* dTHR */ - /*#define DBG_SUB 1 */ /*#define DBG_TIMER 1 */ @@ -388,7 +383,6 @@ prof_mark(pTHX_ opcode ptype) static void test_time(pTHX_ clock_t *r, clock_t *u, clock_t *s) { - dTHR; CV *cv = perl_get_cv("Devel::DProf::NONESUCH_noxs", FALSE); int i, j, k = 0; HV *oldstash = PL_curstash; diff --git a/ext/Devel/Peek/Peek.xs b/ext/Devel/Peek/Peek.xs index e5fc8ae..312f5f8 100644 --- a/ext/Devel/Peek/Peek.xs +++ b/ext/Devel/Peek/Peek.xs @@ -140,6 +140,7 @@ struct mstats_buffer void _fill_mstats(struct mstats_buffer *b, int level) { + dTHX; b->buffer.nfree = b->buf; b->buffer.ntotal = b->buf + _NBUCKETS; b->buffer.bucket_mem_size = b->buf + 2*_NBUCKETS; @@ -151,6 +152,7 @@ _fill_mstats(struct mstats_buffer *b, int level) void fill_mstats(SV *sv, int level) { + dTHX; int nbuckets; struct mstats_buffer buf; @@ -166,6 +168,7 @@ fill_mstats(SV *sv, int level) void _mstats_to_hv(HV *hv, struct mstats_buffer *b, int level) { + dTHX; SV **svp; int type; diff --git a/ext/DynaLoader/DynaLoader_pm.PL b/ext/DynaLoader/DynaLoader_pm.PL index b7b45d8..266c9d0 100644 --- a/ext/DynaLoader/DynaLoader_pm.PL +++ b/ext/DynaLoader/DynaLoader_pm.PL @@ -1,4 +1,3 @@ - use Config; sub to_string { @@ -12,7 +11,7 @@ unlink "DynaLoader.pm" if -f "DynaLoader.pm"; open OUT, ">DynaLoader.pm" or die $!; print OUT <<'EOT'; -# Generated from DynaLoader.pm.PL (resolved %Config::Config values) +# Generated from DynaLoader.pm.PL package DynaLoader; @@ -28,11 +27,15 @@ package DynaLoader; # # Tim.Bunce@ig.co.uk, August 1994 -$VERSION = "1.04"; # avoid typo warning +use vars qw($VERSION *AUTOLOAD); + +$VERSION = 1.04; # avoid typo warning require AutoLoader; *AUTOLOAD = \&AutoLoader::AUTOLOAD; +use Config; + # The following require can't be removed during maintenance # releases, sadly, because of the risk of buggy code that does # require Carp; Carp::croak "..."; without brackets dying @@ -40,7 +43,6 @@ require AutoLoader; # We'll let those bugs get found on the development track. require Carp if $] < 5.00450; - # enable debug/trace messages from DynaLoader perl code $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; @@ -71,48 +73,112 @@ print OUT <<'EOT'; # (VMS support by Charles Bailey ) # See dl_expandspec() for more details. Should be harmless but # inefficient to define on systems that don't need it. -$do_expand = $Is_VMS = $^O eq 'VMS'; +$Is_VMS = $^O eq 'VMS'; +$do_expand = $Is_VMS; $Is_MacOS = $^O eq 'MacOS'; @dl_require_symbols = (); # names of symbols we need @dl_resolve_using = (); # names of files to link with @dl_library_path = (); # path to look for files -#@dl_librefs = (); # things we have loaded -#@dl_modules = (); # Modules we have loaded +@dl_librefs = (); # things we have loaded +@dl_modules = (); # Modules we have loaded # This is a fix to support DLD's unfortunate desire to relink -lc @dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs"; -# Initialise @dl_library_path with the 'standard' library path -# for this platform as determined by Configure +EOT -# push(@dl_library_path, split(' ', $Config::Config{'libpth'}); +my $cfg_dl_library_path = <<'EOT'; +push(@dl_library_path, split(' ', $Config::Config{libpth})); EOT -print OUT "push(\@dl_library_path, split(' ', ", - to_string($Config::Config{'libpth'}), "));\n"; +sub dquoted_comma_list { + join(", ", map {qq("$_")} @_); +} -print OUT <<'EOT'; +if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS}) { + eval $cfg_dl_library_path; + if (!$ENV{PERL_BUILD_EXPAND_ENV_VARS}) { + my $dl_library_path = dquoted_comma_list(@dl_library_path); + print OUT <\]]/ && -d $_) { push(@dirs, $_); next; } diff --git a/ext/DynaLoader/dl_aix.xs b/ext/DynaLoader/dl_aix.xs index d6acc68..89b8439 100644 --- a/ext/DynaLoader/dl_aix.xs +++ b/ext/DynaLoader/dl_aix.xs @@ -11,6 +11,8 @@ * on statup... It can probably be trimmed more. */ +#define PERLIO_NOT_STDIO 0 + /* * @(#)dlfcn.c 1.5 revision of 93/02/14 20:14:17 * This is an unpublished work copyright (c) 1992 Helios Software GmbH @@ -87,14 +89,6 @@ # define FREAD(p,s,n,ldptr) fread(p,s,n,IOPTR(ldptr)) #endif -/* If using PerlIO, redefine these macros from */ -#ifdef USE_PERLIO -#undef FSEEK -#undef FREAD -#define FSEEK(ldptr,o,p) PerlIO_seek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr)+o):o,p) -#define FREAD(p,s,n,ldptr) PerlIO_read(IOPTR(ldptr),p,s*n) -#endif - /* * We simulate dlopen() et al. through a call to load. Because AIX has * no call to find an exported symbol we read the loader section of the @@ -532,11 +526,7 @@ static int readExports(ModulePtr mp) } /* This first case is a hack, since it assumes that the 3rd parameter to FREAD is 1. See the redefinition of FREAD above to see how this works. */ -#ifdef USE_PERLIO - if (FREAD(ldbuf, sh.s_size, 1, ldp) != sh.s_size) { -#else if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) { -#endif errvalid++; strcpy(errbuf, "readExports: cannot read loader section"); safefree(ldbuf); diff --git a/ext/Encode/Encode.pm b/ext/Encode/Encode.pm index 8ba7232..1f4ffb1 100644 --- a/ext/Encode/Encode.pm +++ b/ext/Encode/Encode.pm @@ -22,6 +22,10 @@ require Exporter; off_utf8 utf_to_utf encodings + utf8_decode + utf8_encode + utf8_upgrade + utf8_downgrade ); bootstrap Encode (); @@ -340,9 +344,9 @@ sub from_to return length($_[0] = $string); } -my %encoding = ( Unicode => bless({},'Encode::Unicode'), - 'iso10646-1' => bless({},'Encode::iso10646_1'), - ); +# The global hash is declared in XS code +$encoding{Unicode} = bless({},'Encode::Unicode'); +$encoding{'iso10646-1'} = bless({},'Encode::iso10646_1'); sub encodings { @@ -378,6 +382,7 @@ sub loadEncoding last unless $type eq '#'; } $class .= ('::'.(($type eq 'E') ? 'Escape' : 'Table')); + #warn "Loading $file"; return $class->read($fh,$name,$type); } else @@ -407,13 +412,20 @@ sub getEncoding package Encode::Unicode; -# Dummy package that provides the encode interface +# Dummy package that provides the encode interface but leaves data +# as UTF-8 encoded. It is here so that from_to() works. sub name { 'Unicode' } -sub toUnicode { $_[1] } +sub toUnicode +{ + my ($obj,$str,$chk) = @_; + Encode::utf8_upgrade($str); + $_[1] = '' if $chk; + return $str; +} -sub fromUnicode { $_[1] } +*fromUnicode = \&toUnicode; package Encode::Table; @@ -532,7 +544,9 @@ sub fromUnicode return $str; } -package Encode::iso10646_1;# +package Encode::iso10646_1; +# Encoding is 16-bit network order Unicode +# Used for X font encodings sub name { 'iso10646-1' } @@ -546,6 +560,7 @@ sub toUnicode $uni .= chr($code); } $_[1] = $str if $chk; + Encode::utf8_upgrade($uni); return $uni; } @@ -568,6 +583,7 @@ sub fromUnicode return $str; } + package Encode::Escape; use Carp; diff --git a/ext/Encode/Encode.xs b/ext/Encode/Encode.xs index c231bba..a7acd88 100644 --- a/ext/Encode/Encode.xs +++ b/ext/Encode/Encode.xs @@ -1,6 +1,11 @@ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +#define U8 U8 +#include "encode.h" +#include "iso8859.h" +#include "EBCDIC.h" +#include "Symbols.h" #define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) { \ Perl_croak(aTHX_ "panic_unimplemented"); \ @@ -9,8 +14,469 @@ UNIMPLEMENTED(_encoded_utf8_to_bytes, I32) UNIMPLEMENTED(_encoded_bytes_to_utf8, I32) +#ifdef USE_PERLIO +/* Define an encoding "layer" in the perliol.h sense. + The layer defined here "inherits" in an object-oriented sense from the + "perlio" layer with its PerlIOBuf_* "methods". + The implementation is particularly efficient as until Encode settles down + there is no point in tryint to tune it. + + The layer works by overloading the "fill" and "flush" methods. + + "fill" calls "SUPER::fill" in perl terms, then calls the encode OO perl API + to convert the encoded data to UTF-8 form, then copies it back to the + buffer. The "base class's" read methods then see the UTF-8 data. + + "flush" transforms the UTF-8 data deposited by the "base class's write + method in the buffer back into the encoded form using the encode OO perl API, + then copies data back into the buffer and calls "SUPER::flush. + + Note that "flush" is _also_ called for read mode - we still do the (back)-translate + so that the the base class's "flush" sees the correct number of encoded chars + for positioning the seek pointer. (This double translation is the worst performance + issue - particularly with all-perl encode engine.) + +*/ + + +#include "perliol.h" + +typedef struct +{ + PerlIOBuf base; /* PerlIOBuf stuff */ + SV * bufsv; + SV * enc; +} PerlIOEncode; + + +IV +PerlIOEncode_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len) +{ + PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode); + dTHX; + dSP; + IV code; + code = PerlIOBuf_pushed(f,mode,Nullch,0); + ENTER; + SAVETMPS; + PUSHMARK(sp); + XPUSHs(sv_2mortal(newSVpv("Encode",0))); + XPUSHs(sv_2mortal(newSVpvn(arg,len))); + PUTBACK; + if (perl_call_method("getEncoding",G_SCALAR) != 1) + return -1; + SPAGAIN; + e->enc = POPs; + PUTBACK; + if (!SvROK(e->enc)) + return -1; + SvREFCNT_inc(e->enc); + FREETMPS; + LEAVE; + PerlIOBase(f)->flags |= PERLIO_F_UTF8; + return code; +} + +IV +PerlIOEncode_popped(PerlIO *f) +{ + PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode); + dTHX; + if (e->enc) + { + SvREFCNT_dec(e->enc); + e->enc = Nullsv; + } + if (e->bufsv) + { + SvREFCNT_dec(e->bufsv); + e->bufsv = Nullsv; + } + return 0; +} + +STDCHAR * +PerlIOEncode_get_base(PerlIO *f) +{ + PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode); + dTHX; + if (!e->base.bufsiz) + e->base.bufsiz = 1024; + if (!e->bufsv) + { + e->bufsv = newSV(e->base.bufsiz); + sv_setpvn(e->bufsv,"",0); + } + e->base.buf = (STDCHAR *)SvPVX(e->bufsv); + if (!e->base.ptr) + e->base.ptr = e->base.buf; + if (!e->base.end) + e->base.end = e->base.buf; + if (e->base.ptr < e->base.buf || e->base.ptr > e->base.buf+SvLEN(e->bufsv)) + { + Perl_warn(aTHX_ " ptr %p(%p)%p", + e->base.buf,e->base.ptr,e->base.buf+SvLEN(e->bufsv)); + abort(); + } + if (SvLEN(e->bufsv) < e->base.bufsiz) + { + SSize_t poff = e->base.ptr - e->base.buf; + SSize_t eoff = e->base.end - e->base.buf; + e->base.buf = (STDCHAR *)SvGROW(e->bufsv,e->base.bufsiz); + e->base.ptr = e->base.buf + poff; + e->base.end = e->base.buf + eoff; + } + if (e->base.ptr < e->base.buf || e->base.ptr > e->base.buf+SvLEN(e->bufsv)) + { + Perl_warn(aTHX_ " ptr %p(%p)%p", + e->base.buf,e->base.ptr,e->base.buf+SvLEN(e->bufsv)); + abort(); + } + return e->base.buf; +} + +IV +PerlIOEncode_fill(PerlIO *f) +{ + PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode); + dTHX; + dSP; + IV code; + code = PerlIOBuf_fill(f); + if (code == 0) + { + SV *uni; + STRLEN len; + char *s; + /* Set SV that is the buffer to be buf..ptr */ + SvCUR_set(e->bufsv, e->base.end - e->base.buf); + SvUTF8_off(e->bufsv); + ENTER; + SAVETMPS; + PUSHMARK(sp); + XPUSHs(e->enc); + XPUSHs(e->bufsv); + XPUSHs(&PL_sv_yes); + PUTBACK; + if (perl_call_method("toUnicode",G_SCALAR) != 1) + code = -1; + SPAGAIN; + uni = POPs; + PUTBACK; + /* Now get translated string (forced to UTF-8) and copy back to buffer + don't use sv_setsv as that may "steal" PV from returned temp + and so free() our known-large-enough buffer. + sv_setpvn() should do but let us do it long hand. + */ + s = SvPVutf8(uni,len); + if (s != SvPVX(e->bufsv)) + { + e->base.buf = (STDCHAR *)SvGROW(e->bufsv,len); + Move(s,e->base.buf,len,char); + SvCUR_set(e->bufsv,len); + } + SvUTF8_on(e->bufsv); + e->base.end = e->base.buf+len; + e->base.ptr = e->base.buf; + FREETMPS; + LEAVE; + } + return code; +} + +IV +PerlIOEncode_flush(PerlIO *f) +{ + PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode); + IV code = 0; + dTHX; + if (e->bufsv && (PerlIOBase(f)->flags & (PERLIO_F_RDBUF|PERLIO_F_WRBUF))) + { + dSP; + SV *str; + char *s; + STRLEN len; + SSize_t left = 0; + if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) + { + /* This is really just a flag to see if we took all the data, if + we did PerlIOBase_flush avoids a seek to lower layer. + Need to revisit if we start getting clever with unreads or seeks-in-buffer + */ + left = e->base.end - e->base.ptr; + } + ENTER; + SAVETMPS; + PUSHMARK(sp); + XPUSHs(e->enc); + SvCUR_set(e->bufsv, e->base.ptr - e->base.buf); + SvUTF8_on(e->bufsv); + XPUSHs(e->bufsv); + XPUSHs(&PL_sv_yes); + PUTBACK; + if (perl_call_method("fromUnicode",G_SCALAR) != 1) + code = -1; + SPAGAIN; + str = POPs; + PUTBACK; + s = SvPV(str,len); + if (s != SvPVX(e->bufsv)) + { + e->base.buf = (STDCHAR *)SvGROW(e->bufsv,len); + Move(s,e->base.buf,len,char); + SvCUR_set(e->bufsv,len); + } + SvUTF8_off(e->bufsv); + e->base.ptr = e->base.buf+len; + /* restore end != ptr as inequality is used by PerlIOBuf_flush in read case */ + e->base.end = e->base.ptr + left; + FREETMPS; + LEAVE; + if (PerlIOBuf_flush(f) != 0) + code = -1; + } + return code; +} + +IV +PerlIOEncode_close(PerlIO *f) +{ + PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode); + IV code = PerlIOBase_close(f); + dTHX; + if (e->bufsv) + { + SvREFCNT_dec(e->bufsv); + e->bufsv = Nullsv; + } + e->base.buf = NULL; + e->base.ptr = NULL; + e->base.end = NULL; + PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF); + return code; +} + +Off_t +PerlIOEncode_tell(PerlIO *f) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + /* Unfortunately the only way to get a postion is to back-translate, + the UTF8-bytes we have buf..ptr and adjust accordingly. + But we will try and save any unread data in case stream + is un-seekable. + */ + if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF) && b->ptr < b->end) + { + Size_t count = b->end - b->ptr; + PerlIO_push(f,&PerlIO_pending,"r",Nullch,0); + /* Save what we have left to read */ + PerlIOSelf(f,PerlIOBuf)->bufsiz = count; + PerlIO_unread(f,b->ptr,count); + /* There isn't any unread data - we just saved it - so avoid the lower seek */ + b->end = b->ptr; + /* Flush ourselves - now one layer down, + this does the back translate and adjusts position + */ + PerlIO_flush(PerlIONext(f)); + /* Set position of the saved data */ + PerlIOSelf(f,PerlIOBuf)->posn = b->posn; + } + else + { + PerlIO_flush(f); + } + return b->posn; +} + +PerlIO_funcs PerlIO_encode = { + "encoding", + sizeof(PerlIOEncode), + PERLIO_K_BUFFERED, + PerlIOBase_fileno, + PerlIOBuf_fdopen, + PerlIOBuf_open, + PerlIOBuf_reopen, + PerlIOEncode_pushed, + PerlIOEncode_popped, + PerlIOBuf_read, + PerlIOBuf_unread, + PerlIOBuf_write, + PerlIOBuf_seek, + PerlIOEncode_tell, + PerlIOEncode_close, + PerlIOEncode_flush, + PerlIOEncode_fill, + PerlIOBase_eof, + PerlIOBase_error, + PerlIOBase_clearerr, + PerlIOBuf_setlinebuf, + PerlIOEncode_get_base, + PerlIOBuf_bufsiz, + PerlIOBuf_get_ptr, + PerlIOBuf_get_cnt, + PerlIOBuf_set_ptrcnt, +}; +#endif + +void +Encode_Define(pTHX_ encode_t *enc) +{ + HV *hash = get_hv("Encode::encoding",GV_ADD|GV_ADDMULTI); + HV *stash = gv_stashpv("Encode::XS", TRUE); + SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash); + hv_store(hash,enc->name,strlen(enc->name),sv,0); +} + void call_failure (SV *routine, U8* done, U8* dest, U8* orig) {} +static SV * +encode_method(pTHX_ encode_t *enc, encpage_t *dir, SV *src, int check) +{ + STRLEN slen; + U8 *s = (U8 *) SvPV(src,slen); + SV *dst = sv_2mortal(newSV(2*slen+1)); + if (slen) + { + U8 *d = (U8 *) SvGROW(dst, 2*slen+1); + STRLEN dlen = SvLEN(dst); + int code; + while ((code = do_encode(dir,s,&slen,d,dlen,&dlen,!check))) + { + SvCUR_set(dst,dlen); + SvPOK_on(dst); + + if (code == ENCODE_FALLBACK) + break; + + switch(code) + { + case ENCODE_NOSPACE: + { + STRLEN need = (slen) ? (SvLEN(dst)*SvCUR(src)/slen) : (dlen + UTF8_MAXLEN); + if (need <= SvLEN(dst)) + need += UTF8_MAXLEN; + d = (U8 *) SvGROW(dst, need); + dlen = SvLEN(dst); + slen = SvCUR(src); + break; + } + + case ENCODE_NOREP: + if (dir == enc->f_utf8) + { + if (!check && ckWARN_d(WARN_UTF8)) + { + STRLEN clen; + UV ch = utf8_to_uv(s+slen,(SvCUR(src)-slen),&clen,0); + Perl_warner(aTHX_ WARN_UTF8, "\"\\x{%x}\" does not map to %s", ch, enc->name); + /* FIXME: Skip over the character, copy in replacement and continue + * but that is messy so for now just fail. + */ + return &PL_sv_undef; + } + else + { + return &PL_sv_undef; + } + } + else + { + /* UTF-8 is supposed to be "Universal" so should not happen */ + Perl_croak(aTHX_ "%s '%.*s' does not map to UTF-8", + enc->name, (SvCUR(src)-slen),s+slen); + } + break; + + case ENCODE_PARTIAL: + if (!check && ckWARN_d(WARN_UTF8)) + { + Perl_warner(aTHX_ WARN_UTF8, "Partial %s character", + (dir == enc->f_utf8) ? "UTF-8" : enc->name); + } + return &PL_sv_undef; + + default: + Perl_croak(aTHX_ "Unexpected code %d converting %s %s", + code, (dir == enc->f_utf8) ? "to" : "from",enc->name); + return &PL_sv_undef; + } + } + SvCUR_set(dst,dlen); + SvPOK_on(dst); + if (check) + { + if (slen < SvCUR(src)) + { + Move(s+slen,s,SvCUR(src)-slen,U8); + } + SvCUR_set(src,SvCUR(src)-slen); + } + } + return dst; +} + +MODULE = Encode PACKAGE = Encode PREFIX = sv_ + +void +valid_utf8(sv) +SV * sv +CODE: + { + STRLEN len; + char *s = SvPV(sv,len); + if (!SvUTF8(sv) || is_utf8_string((U8*)s,len)) + XSRETURN_YES; + else + XSRETURN_NO; + } + +void +sv_utf8_encode(sv) +SV * sv + +bool +sv_utf8_decode(sv) +SV * sv + +void +sv_utf8_upgrade(sv) +SV * sv + +bool +sv_utf8_downgrade(sv,failok=0) +SV * sv +bool failok + +MODULE = Encode PACKAGE = Encode::XS PREFIX = Encode_ + +PROTOTYPES: ENABLE + +void +Encode_toUnicode(obj,src,check = 0) +SV * obj +SV * src +int check +CODE: + { + encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj))); + ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check); + SvUTF8_on(ST(0)); + XSRETURN(1); + } + +void +Encode_fromUnicode(obj,src,check = 0) +SV * obj +SV * src +int check +CODE: + { + encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj))); + sv_utf8_upgrade(src); + ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check); + XSRETURN(1); + } + MODULE = Encode PACKAGE = Encode PROTOTYPES: ENABLE @@ -182,7 +648,7 @@ _is_utf8(sv, ...) { SV * check = items == 2 ? ST(1) : Nullsv; if (SvPOK(sv)) { - RETVAL = SvUTF8(sv); + RETVAL = SvUTF8(sv) ? 1 : 0; if (RETVAL && SvTRUE(check) && !is_utf8_string((U8*)SvPVX(sv), SvCUR(sv))) @@ -239,3 +705,12 @@ _utf_to_utf(sv, from, to, ...) OUTPUT: RETVAL +BOOT: +{ +#ifdef USE_PERLIO + PerlIO_define_layer(&PerlIO_encode); +#endif +#include "iso8859.def" +#include "EBCDIC.def" +#include "Symbols.def" +} diff --git a/ext/Encode/Encode/EncodeFormat.pod b/ext/Encode/Encode/EncodeFormat.pod new file mode 100644 index 0000000..d83b128 --- /dev/null +++ b/ext/Encode/Encode/EncodeFormat.pod @@ -0,0 +1,164 @@ +=head1 NAME + +EncodeFormat - the format of encoding tables of the Encode extension + +=head1 DESCRIPTION + +I + +Space would prohibit precompiling into Tcl every possible encoding +algorithm, so many encodings are stored on disk as dynamically-loadable +encoding files. This behavior also allows the user to create additional +encoding files that can be loaded using the same mechanism. These +encoding files contain information about the tables and/or escape +sequences used to map between an external encoding and Unicode. The +external encoding may consist of single-byte, multi-byte, or double-byte +characters. + +Each dynamically-loadable encoding is represented as a text file. The +initial line of the file, beginning with a ``#'' symbol, is a comment +that provides a human-readable description of the file. The next line +identifies the type of encoding file. It can be one of the following +letters: + +=over 4 + +=item [1] B + +A single-byte encoding, where one character is always one byte long in +the encoding. An example is B, used by many European languages. + +=item [2] B + +A double-byte encoding, where one character is always two bytes long in the +encoding. An example is B, used for Chinese text. + +=item [3] B + +A multi-byte encoding, where one character may be either one or two +bytes long. Certain bytes are a lead bytes, indicating that another +byte must follow and that together the two bytes represent one +character. Other bytes are not lead bytes and represent themselves. +An example is B, used by many Japanese computers. + +=item [4] B + +An escape-sequence encoding, specifying that certain sequences of +bytes do not represent characters, but commands that describe how +following bytes should be interpreted. + +=back + +The rest of the lines in the file depend on the type. + +Cases [1], [2], and [3] are collectively referred to as table-based +encoding files. The lines in a table-based encoding file are in the +same format as this example taken from the B encoding (this +is not the complete file): + + # Encoding file: shiftjis, multi-byte + M + 003F 0 40 + 00 + 0000000100020003000400050006000700080009000A000B000C000D000E000F + 0010001100120013001400150016001700180019001A001B001C001D001E001F + 0020002100220023002400250026002700280029002A002B002C002D002E002F + 0030003100320033003400350036003700380039003A003B003C003D003E003F + 0040004100420043004400450046004700480049004A004B004C004D004E004F + 0050005100520053005400550056005700580059005A005B005C005D005E005F + 0060006100620063006400650066006700680069006A006B006C006D006E006F + 0070007100720073007400750076007700780079007A007B007C007D203E007F + 0080000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000FF61FF62FF63FF64FF65FF66FF67FF68FF69FF6AFF6BFF6CFF6DFF6EFF6F + FF70FF71FF72FF73FF74FF75FF76FF77FF78FF79FF7AFF7BFF7CFF7DFF7EFF7F + FF80FF81FF82FF83FF84FF85FF86FF87FF88FF89FF8AFF8BFF8CFF8DFF8EFF8F + FF90FF91FF92FF93FF94FF95FF96FF97FF98FF99FF9AFF9BFF9CFF9DFF9EFF9F + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 81 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 300030013002FF0CFF0E30FBFF1AFF1BFF1FFF01309B309C00B4FF4000A8FF3E + FFE3FF3F30FD30FE309D309E30034EDD30053006300730FC20152010FF0F005C + 301C2016FF5C2026202520182019201C201DFF08FF0930143015FF3BFF3DFF5B + FF5D30083009300A300B300C300D300E300F30103011FF0B221200B100D70000 + 00F7FF1D2260FF1CFF1E22662267221E22342642264000B0203220332103FFE5 + FF0400A200A3FF05FF03FF06FF0AFF2000A72606260525CB25CF25CE25C725C6 + 25A125A025B325B225BD25BC203B301221922190219121933013000000000000 + 000000000000000000000000000000002208220B2286228722822283222A2229 + 000000000000000000000000000000002227222800AC21D221D4220022030000 + 0000000000000000000000000000000000000000222022A52312220222072261 + 2252226A226B221A223D221D2235222B222C0000000000000000000000000000 + 212B2030266F266D266A2020202100B6000000000000000025EF000000000000 + +The third line of the file is three numbers. The first number is the +fallback character (in base 16) to use when converting from UTF-8 to +this encoding. The second number is a B<1> if this file represents +the encoding for a symbol font, or B<0> otherwise. The last number +(in base 10) is how many pages of data follow. + +Subsequent lines in the example above are pages that describe how to +map from the encoding into 2-byte Unicode. The first line in a page +identifies the page number. Following it are 256 double-byte numbers, +arranged as 16 rows of 16 numbers. Given a character in the encoding, +the high byte of that character is used to select which page, and the +low byte of that character is used as an index to select one of the +double-byte numbers in that page - the value obtained being the +corresponding Unicode character. By examination of the example above, +one can see that the characters 0x7E and 0x8163 in B map to +203E and 2026 in Unicode, respectively. + +Following the first page will be all the other pages, each in the same +format as the first: one number identifying the page followed by 256 +double-byte Unicode characters. If a character in the encoding maps +to the Unicode character 0000, it means that the character doesn't +actually exist. If all characters on a page would map to 0000, that +page can be omitted. + +Case [4] is the escape-sequence encoding file. The lines in an this +type of file are in the same format as this example taken from the +B encoding: + + # Encoding file: iso2022-jp, escape-driven + E + init {} + final {} + iso8859-1 \\x1b(B + jis0201 \\x1b(J + jis0208 \\x1b$@ + jis0208 \\x1b$B + jis0212 \\x1b$(D + gb2312 \\x1b$A + ksc5601 \\x1b$(C + +In the file, the first column represents an option and the second +column is the associated value. B is a string to emit or expect +before the first character is converted, while B is a string to +emit or expect after the last character. All other options are names +of table-based encodings; the associated value is the escape-sequence +that marks that encoding. Tcl syntax is used for the values; in the +above example, for instance, ``B<{}>'' represents the empty string and +``B<\\x1b>'' represents character 27. + +B +When B encounters an encoding I that has not +been loaded, it attempts to load an encoding file called +IB<.enc> from the B subdirectory of each directory +specified in the library path B<$tcl_libPath>. If the encoding file +exists, but is malformed, an error message will be left in I. + +=head1 KEYWORDS + +utf, encoding, convert + +=head1 COPYRIGHT + + # Copyright (c) 1997-1998 Sun Microsystems, Inc. + # See the file "license.terms" for information on usage and redistribution + # of this file, and for a DISCLAIMER OF ALL WARRANTIES. + # RCS: @(#) $Id: Encoding.3,v 1.7 1999/10/13 00:32:05 hobbs Exp $ diff --git a/ext/Encode/Encode/ascii.enc b/ext/Encode/Encode/ascii.enc index e0320b8..284a9f5 100644 --- a/ext/Encode/Encode/ascii.enc +++ b/ext/Encode/Encode/ascii.enc @@ -9,7 +9,7 @@ S 0040004100420043004400450046004700480049004A004B004C004D004E004F 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F -0070007100720073007400750076007700780079007A007B007C007D007E0000 +0070007100720073007400750076007700780079007A007B007C007D007E007F 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 diff --git a/ext/Encode/Encode/cp1006.enc b/ext/Encode/Encode/cp1006.enc new file mode 100644 index 0000000..3ba00dd --- /dev/null +++ b/ext/Encode/Encode/cp1006.enc @@ -0,0 +1,20 @@ +# Encoding file: cp1006, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +0080008100820083008400850086008700880089008A008B008C008D008E008F +0090009100920093009400950096009700980099009A009B009C009D009E009F +00A006F006F106F206F306F406F506F606F706F806F9060C061B00AD061FFE81 +FE8DFE8EFE8EFE8FFE91FB56FB58FE93FE95FE97FB66FB68FE99FE9BFE9DFE9F +FB7AFB7CFEA1FEA3FEA5FEA7FEA9FB84FEABFEADFB8CFEAFFB8AFEB1FEB3FEB5 +FEB7FEB9FEBBFEBDFEBFFEC1FEC5FEC9FECAFECBFECCFECDFECEFECFFED0FED1 +FED3FED5FED7FED9FEDBFB92FB94FEDDFEDFFEE0FEE1FEE3FB9EFEE5FEE7FE85 +FEEDFBA6FBA8FBA9FBAAFE80FE89FE8AFE8BFEF1FEF2FEF3FBB0FBAEFE7CFE7D diff --git a/ext/Encode/Encode/cp1047.enc b/ext/Encode/Encode/cp1047.enc new file mode 100644 index 0000000..8956fa4 --- /dev/null +++ b/ext/Encode/Encode/cp1047.enc @@ -0,0 +1,20 @@ +# Encoding file: cp1047 (EBCDIC), single-byte +S +006F 0 1 +00 +0000000100020003009C00090086007F0097008D008E000B000C000D000E000F +0010001100120013009D000A00080087001800190092008F001C001D001E001F +0080008100820083008400850017001B00880089008A008B008C000500060007 +0090009100160093009400950096000400980099009A009B00140015009E001A +002000A000E200E400E000E100E300E500E700F100A2002E003C0028002B007C +002600E900EA00EB00E800ED00EE00EF00EC00DF00210024002A0029003B005E +002D002F00C200C400C000C100C300C500C700D100A6002C0025005F003E003F +00F800C900CA00CB00C800CD00CE00CF00CC0060003A002300400027003D0022 +00D800610062006300640065006600670068006900AB00BB00F000FD00FE00B1 +00B0006A006B006C006D006E006F00700071007200AA00BA00E600B800C600A4 +00B5007E0073007400750076007700780079007A00A100BF00D0005B00DE00AE +00AC00A300A500B700A900A700B600BC00BD00BE00DD00A800AF005D00B400D7 +007B00410042004300440045004600470048004900AD00F400F600F200F300F5 +007D004A004B004C004D004E004F00500051005200B900FB00FC00F900FA00FF +005C00F70053005400550056005700580059005A00B200D400D600D200D300D5 +003000310032003300340035003600370038003900B300DB00DC00D900DA009F diff --git a/ext/Encode/Encode/cp37.enc b/ext/Encode/Encode/cp37.enc new file mode 100644 index 0000000..94d8c33 --- /dev/null +++ b/ext/Encode/Encode/cp37.enc @@ -0,0 +1,20 @@ +# Encoding file: cp37 (EBCDIC), single-byte +S +006F 0 1 +00 +0000000100020003009C00090086007F0097008D008E000B000C000D000E000F +0010001100120013009D008500080087001800190092008F001C001D001E001F +00800081008200830084000A0017001B00880089008A008B008C000500060007 +0090009100160093009400950096000400980099009A009B00140015009E001A +002000A000E200E400E000E100E300E500E700F100A2002E003C0028002B007C +002600E900EA00EB00E800ED00EE00EF00EC00DF00210024002A0029003B00AC +002D002F00C200C400C000C100C300C500C700D100A6002C0025005F003E003F +00F800C900CA00CB00C800CD00CE00CF00CC0060003A002300400027003D0022 +00D800610062006300640065006600670068006900AB00BB00F000FD00FE00B1 +00B0006A006B006C006D006E006F00700071007200AA00BA00E600B800C600A4 +00B5007E0073007400750076007700780079007A00A100BF00D000DD00DE00AE +005E00A300A500B700A900A700B600BC00BD00BE005B005D00AF00A800B400D7 +007B00410042004300440045004600470048004900AD00F400F600F200F300F5 +007D004A004B004C004D004E004F00500051005200B900FB00FC00F900FA00FF +005C00F70053005400550056005700580059005A00B200D400D600D200D300D5 +003000310032003300340035003600370038003900B300DB00DC00D900DA009F diff --git a/ext/Encode/Encode/cp424.enc b/ext/Encode/Encode/cp424.enc new file mode 100644 index 0000000..3b0c23e --- /dev/null +++ b/ext/Encode/Encode/cp424.enc @@ -0,0 +1,20 @@ +# Encoding file: cp424, single-byte +S +003F 0 1 +00 +0000000100020003009C00090086007F0097008D008E000B000C000D000E000F +0010001100120013009D008500080087001800190092008F001C001D001E001F +00800081008200830084000A0017001B00880089008A008B008C000500060007 +0090009100160093009400950096000400980099009A009B00140015009E001A +002005D005D105D205D305D405D505D605D705D800A2002E003C0028002B007C +002605D905DA05DB05DC05DD05DE05DF05E005E100210024002A0029003B00AC +002D002F05E205E305E405E505E605E705E805E900A6002C0025005F003E003F +000005EA0000000000A000000000000020170060003A002300400027003D0022 +000000610062006300640065006600670068006900AB00BB00000000000000B1 +00B0006A006B006C006D006E006F00700071007200000000000000B8000000A4 +00B5007E0073007400750076007700780079007A0000000000000000000000AE +005E00A300A500B700A900A700B600BC00BD00BE005B005D00AF00A800B400D7 +007B00410042004300440045004600470048004900AD00000000000000000000 +007D004A004B004C004D004E004F00500051005200B900000000000000000000 +005C00F70053005400550056005700580059005A00B200000000000000000000 +003000310032003300340035003600370038003900B30000000000000000009F diff --git a/ext/Encode/Encode/cp856.enc b/ext/Encode/Encode/cp856.enc new file mode 100644 index 0000000..cab493c --- /dev/null +++ b/ext/Encode/Encode/cp856.enc @@ -0,0 +1,20 @@ +# Encoding file: cp856, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +05D005D105D205D305D405D505D605D705D805D905DA05DB05DC05DD05DE05DF +05E005E105E205E305E405E505E605E705E805E905EA000000A3000000D70000 +00000000000000000000000000000000000000AE00AC00BD00BC000000AB00BB +2591259225932502252400000000000000A9256325512557255D00A200A52510 +25142534252C251C2500253C00000000255A25542569256625602550256C00A4 +0000000000000000000000000000000000002518250C2588258400A600002580 +00000000000000000000000000B5000000000000000000000000000000AF00B4 +00AD00B1201700BE00B600A700F700B800B000A800B700B900B300B225A000A0 diff --git a/ext/Encode/Encode/gsm0338.enc b/ext/Encode/Encode/gsm0338.enc new file mode 100644 index 0000000..bf09e70 --- /dev/null +++ b/ext/Encode/Encode/gsm0338.enc @@ -0,0 +1,20 @@ +# Encoding file: GSM 03.38, single-byte +S +003F 0 1 +00 +004000A3002400A500E800E900F900EC00F200E7000A00D800F8000D00C500E5 +0394005F03A60393039B03A903A003A803A30398039E00A000C600E600DF00C9 +002000210022002300A400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +00A1004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A00C400D600D100DC00A7 +00BF006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A00E400F600F100FC00E0 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 diff --git a/ext/Encode/Encode/iso8859-10.enc b/ext/Encode/Encode/iso8859-10.enc new file mode 100644 index 0000000..934b3b9 --- /dev/null +++ b/ext/Encode/Encode/iso8859-10.enc @@ -0,0 +1,20 @@ +# Encoding file: iso8859-10, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +0080008100820083008400850086008700880089008A008B008C008D008E008F +0090009100920093009400950096009700980099009A009B009C009D009E009F +00A0010401120122012A0128013600A7013B011001600166017D00AD016A014A +00B0010501130123012B0129013700B7013C011101610167017E2015016B014B +010000C100C200C300C400C500C6012E010C00C9011800CB011600CD00CE00CF +00D00145014C00D300D400D500D6016800D8017200DA00DB00DC00DD00DE00DF +010100E100E200E300E400E500E6012F010D00E9011900EB011700ED00EE00EF +00F00146014D00F300F400F500F6016900F8017300FA00FB00FC00FD00FE0138 diff --git a/ext/Encode/Encode/iso8859-13.enc b/ext/Encode/Encode/iso8859-13.enc new file mode 100644 index 0000000..b7edcaf --- /dev/null +++ b/ext/Encode/Encode/iso8859-13.enc @@ -0,0 +1,20 @@ +# Encoding file: iso8859-13, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +0080008100820083008400850086008700880089008A008B008C008D008E008F +0090009100920093009400950096009700980099009A009B009C009D009E009F +00A0201D00A200A300A4201E00A600A700D800A9015600AB00AC00AD00AE00C6 +00B000B100B200B3201C00B500B600B700F800B9015700BB00BC00BD00BE00E6 +0104012E0100010600C400C501180112010C00C90179011601220136012A013B +01600143014500D3014C00D500D600D701720141015A016A00DC017B017D00DF +0105012F0101010700E400E501190113010D00E9017A011701230137012B013C +01610144014600F3014D00F500F600F701730142015B016B00FC017C017E2019 diff --git a/ext/Encode/Encode/iso8859-14.enc b/ext/Encode/Encode/iso8859-14.enc new file mode 100644 index 0000000..a65ba05 --- /dev/null +++ b/ext/Encode/Encode/iso8859-14.enc @@ -0,0 +1,20 @@ +# Encoding file: iso8859-14, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +0080008100820083008400850086008700880089008A008B008C008D008E008F +0090009100920093009400950096009700980099009A009B009C009D009E009F +00A01E021E0300A3010A010B1E0A00A71E8000A91E821E0B1EF200AD00AE0178 +1E1E1E1F012001211E401E4100B61E561E811E571E831E601EF31E841E851E61 +00C000C100C200C300C400C500C600C700C800C900CA00CB00CC00CD00CE00CF +017400D100D200D300D400D500D61E6A00D800D900DA00DB00DC00DD017600DF +00E000E100E200E300E400E500E600E700E800E900EA00EB00EC00ED00EE00EF +017500F100F200F300F400F500F61E6B00F800F900FA00FB00FC00FD017700FF diff --git a/ext/Encode/Encode/iso8859-15.enc b/ext/Encode/Encode/iso8859-15.enc new file mode 100644 index 0000000..823af46 --- /dev/null +++ b/ext/Encode/Encode/iso8859-15.enc @@ -0,0 +1,20 @@ +# Encoding file: iso8859-15, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +0080008100820083008400850086008700880089008A008B008C008D008E008F +0090009100920093009400950096009700980099009A009B009C009D009E009F +00A000A100A200A320AC00A5016000A7016100A900AA00AB00AC00AD00AE00AF +00B000B100B200B3017D00B500B600B7017E00B900BA00BB01520153017800BF +00C000C100C200C300C400C500C600C700C800C900CA00CB00CC00CD00CE00CF +00D000D100D200D300D400D500D600D700D800D900DA00DB00DC00DD00DE00DF +00E000E100E200E300E400E500E600E700E800E900EA00EB00EC00ED00EE00EF +00F000F100F200F300F400F500F600F700F800F900FA00FB00FC00FD00FE00FF diff --git a/ext/Encode/Encode/iso8859-16.enc b/ext/Encode/Encode/iso8859-16.enc new file mode 100644 index 0000000..1936b97 --- /dev/null +++ b/ext/Encode/Encode/iso8859-16.enc @@ -0,0 +1,20 @@ +# Encoding file: iso8859-16, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +0080008100820083008400850086008700880089008A008B008C008D008E008F +0090009100920093009400950096009700980099009A009B009C009D009E009F +00A001040105014120AC00AB016000A7016100A90218201E017900AD017A017B +00B000B1010C0142017D201D00B600B7017E010D021900BB015201530178017C +00C000C100C2010200C4010600C600C700C800C900CA00CB00CC00CD00CE00CF +0110014300D200D300D4015000D6015A017000D900DA00DB00DC0118021A00DF +00E000E100E2010300E4010700E600E700E800E900EA00EB00EC00ED00EE00EF +0111014400F200F300F4015100F6015B017100F900FA00FB00FC0119021B00FF diff --git a/ext/Encode/Encode/posix-bc.enc b/ext/Encode/Encode/posix-bc.enc new file mode 100644 index 0000000..8b533a4 --- /dev/null +++ b/ext/Encode/Encode/posix-bc.enc @@ -0,0 +1,20 @@ +# Encoding file: posix-bc (EBCDIC), single-byte +S +006F 0 1 +00 +0000000100020003009C00090086007F0097008D008E000B000C000D000E000F +0010001100120013009D000A00080087001800190092008F001C001D001E001F +0080008100820083008400850017001B00880089008A008B008C000500060007 +0090009100160093009400950096000400980099009A009B00140015009E001A +002000A000E200E400E000E100E300E500E700F10060002E003C0028002B007C +002600E900EA00EB00E800ED00EE00EF00EC00DF00210024002A0029003B009F +002D002F00C200C400C000C100C300C500C700D1005E002C0025005F003E003F +00F800C900CA00CB00C800CD00CE00CF00CC00A8003A002300400027003D0022 +00D800610062006300640065006600670068006900AB00BB00F000FD00FE00B1 +00B0006A006B006C006D006E006F00700071007200AA00BA00E600B800C600A4 +00B500AF0073007400750076007700780079007A00A100BF00D000DD00DE00AE +00A200A300A500B700A900A700B600BC00BD00BE00AC005B005C005D00B400D7 +00F900410042004300440045004600470048004900AD00F400F600F200F300F5 +00A6004A004B004C004D004E004F00500051005200B900FB00FC00DB00FA00FF +00D900F70053005400550056005700580059005A00B200D400D600D200D300D5 +003000310032003300340035003600370038003900B3007B00DC007D00DA007E diff --git a/ext/Encode/Makefile.PL b/ext/Encode/Makefile.PL index 329937e..4b1ec95 100644 --- a/ext/Encode/Makefile.PL +++ b/ext/Encode/Makefile.PL @@ -1,7 +1,25 @@ use ExtUtils::MakeMaker; + +my %tables = (iso8859 => ['ascii.enc', 'cp1250.enc'], + EBCDIC => ['cp1047.enc','cp37.enc','posix-bc.enc'], + Symbols => ['symbol.enc','dingbats.enc'], + ); + +opendir(ENC,'Encode'); +while (defined(my $file = readdir(ENC))) + { + if ($file =~ /iso8859.*\.enc/) + { + push(@{$tables{iso8859}},$file); + } + } +closedir(ENC); + + WriteMakefile( NAME => "Encode", VERSION_FROM => 'Encode.pm', + OBJECT => '$(O_FILES)', 'dist' => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', @@ -9,3 +27,84 @@ WriteMakefile( }, MAN3PODS => {}, ); + +package MY; + + +sub post_initialize +{ + my ($self) = @_; + my %o; + # Find existing O_FILES + foreach my $f (@{$self->{'O_FILES'}}) + { + $o{$f} = 1; + } + my $x = $self->{'OBJ_EXT'}; + # Add the table O_FILES + foreach my $e (keys %tables) + { + $o{$e.$x} = 1; + } + # Reset the variable + $self->{'O_FILES'} = [sort keys %o]; + my @files; + foreach my $table (keys %tables) + { + foreach my $ext (qw($(OBJ_EXT) .c .h .def)) + { + push (@files,$table.$ext); + } + } + $self->{'clean'}{'FILES'} .= join(' ',@files); + return ''; +} + +sub postamble +{ + my $self = shift; + my $dir = $self->catdir($self->curdir,'Encode'); + my $str = "# Encode$(OBJ_EXT) depends on .h and .def files not .c files - but all written by compile\n"; + $str .= 'Encode$(OBJ_EXT) :'; + my @rules; + foreach my $table (keys %tables) + { + $str .= " $table.c"; + } + $str .= "\n\n"; + foreach my $table (keys %tables) + { + my $numlines = 1; + my $lengthsofar = length($str); + my $continuator = ''; + $str .= "$table.c : compile Makefile.PL"; + foreach my $file (@{$tables{$table}}) + { + $str .= $continuator.' '.$self->catfile($dir,$file); + if ( length($str)-$lengthsofar > 128*$numlines ) + { + $continuator .= " \\\n\t"; + $numlines++; + } else { + $continuator = ''; + } + } + $numlines = 1; + $lengthsofar = length($str); + $continuator = ''; + $str .= "\n\t\$(PERL) compile \$\@"; + foreach my $file (@{$tables{$table}}) + { + $str .= $continuator.' '.$self->catfile($dir,$file); + if ( length($str)-$lengthsofar > 128*$numlines ) + { + $continuator .= "\n\t\$(PERL) compile \$\@"; + $numlines++; + } else { + $continuator = ''; + } + } + $str .= "\n\n"; + } + return $str; +} diff --git a/ext/Encode/compile b/ext/Encode/compile new file mode 100755 index 0000000..b890a04 --- /dev/null +++ b/ext/Encode/compile @@ -0,0 +1,530 @@ +#!../../perl -w +BEGIN { @INC = '../../lib' }; +use strict; + +sub encode_U +{ + # UTF-8 encode long hand - only covers part of perl's range + my $uv = shift; + if ($uv < 0x80) + { + return chr($uv) + } + if ($uv < 0x800) + { + return chr(($uv >> 6) | 0xC0). + chr(($uv & 0x3F) | 0x80); + } + return chr(($uv >> 12) | 0xE0). + chr((($uv >> 6) & 0x3F) | 0x80). + chr(($uv & 0x3F) | 0x80); +} + +sub encode_S +{ + # encode single byte + my ($ch,$page) = @_; + return chr($ch); +} + +sub encode_D +{ + # encode double byte MS byte first + my ($ch,$page) = @_; + return chr($page).chr($ch); +} + +sub encode_M +{ + # encode Multi-byte - single for 0..255 otherwise double + my ($ch,$page) = @_; + return &encode_D if $page; + return &encode_S; +} + +# Win32 does not expand globs on command line +eval "\@ARGV = map(glob(\$_),\@ARGV)" if ($^O eq 'MSWin32'); + +my $cname = shift(@ARGV); +chmod(0666,$cname) if -f $cname && !-w $cname; +open(C,">$cname") || die "Cannot open $cname:$!"; +my $dname = $cname; +$dname =~ s/(\.[^\.]*)?$/.def/; + +my ($doC,$doEnc,$doUcm); + +if ($cname =~ /\.(c|xs)$/) + { + $doC = 1; + chmod(0666,$dname) if -f $cname && !-w $dname; + open(D,">$dname") || die "Cannot open $dname:$!"; + my $hname = $cname; + $hname =~ s/(\.[^\.]*)?$/.h/; + chmod(0666,$hname) if -f $cname && !-w $hname; + open(H,">$hname") || die "Cannot open $hname:$!"; + + foreach my $fh (\*C,\*D,\*H) + { + print $fh <<"END"; +/* + !!!!!!! DO NOT EDIT THIS FILE !!!!!!! + This file was autogenerated by: + $^X $0 $cname @ARGV +*/ +END + } + + if ($cname =~ /(\w+)\.xs$/) + { + print C "#include \n"; + print C "#include \n"; + print C "#include \n"; + print C "#define U8 U8\n"; + } + print C "#include \"encode.h\"\n"; + } +elsif ($cname =~ /\.enc$/) + { + $doEnc = 1; + } +elsif ($cname =~ /\.ucm$/) + { + $doUcm = 1; + } + +my %encoding; +my %strings; + +sub cmp_name +{ + if ($a =~ /^.*-(\d+)/) + { + my $an = $1; + if ($b =~ /^.*-(\d+)/) + { + my $r = $an <=> $1; + return $r if $r; + } + } + return $a cmp $b; +} + +foreach my $enc (sort cmp_name @ARGV) + { + my ($name,$sfx) = $enc =~ /^.*?([\w-]+)\.(enc|ucm)$/; + if (open(E,$enc)) + { + if ($sfx eq 'enc') + { + compile_enc(\*E,lc($name),\*C); + } + else + { + compile_ucm(\*E,lc($name),\*C); + } + } + else + { + warn "Cannot open $enc for $name:$!"; + } + } + +if ($doC) + { + foreach my $enc (sort cmp_name keys %encoding) + { + my $sym = "${enc}_encoding"; + $sym =~ s/\W+/_/g; + print C "encode_t $sym = \n"; + print C " {",join(',',"\"$enc\"",@{$encoding{$enc}}),"};\n\n"; + } + + foreach my $enc (sort cmp_name keys %encoding) + { + my $sym = "${enc}_encoding"; + $sym =~ s/\W+/_/g; + print H "extern encode_t $sym;\n"; + print D " Encode_Define(aTHX_ &$sym);\n"; + } + + if ($cname =~ /(\w+)\.xs$/) + { + my $mod = $1; + print C "\nMODULE = Encode::$mod\tPACKAGE = Encode::$mod\n\n"; + print C "BOOT:\n{\n"; + print C "#include \"$dname\"\n"; + print C "}\n"; + } + close(D); + close(H); + } +close(C); + + +sub compile_ucm +{ + my ($fh,$name,$ch) = @_; + my $e2u = {}; + my $u2e = {}; + my $cs; + my %attr; + while (<$fh>) + { + s/#.*$//; + last if /^\s*CHARMAP\s*$/i; + if (/^\s*<(\w+)>\s+"?([^"]*)"?\s*$/i) + { + $attr{$1} = $2; + } + } + if (!defined($cs = $attr{'code_set_name'})) + { + warn "No in $name\n"; + } + else + { + # $name = lc($cs); + } + my $erep; + my $urep; + if (exists $attr{'subchar'}) + { + my @byte = $attr{'subchar'} =~ /^\s*(?:\\x([0-9a-f]+))+\s*$/; + $erep = join('',map(hex($_),@byte)); + } + warn "Scanning $name ($cs)\n"; + my $nfb = 0; + my $hfb = 0; + while (<$fh>) + { + s/#.*$//; + last if /^\s*END\s+CHARMAP\s*$/i; + next if /^\s*$/; + my ($u,@byte) = /^\s+(?:\\x([0-9a-f]+))+\s*(\|[0-3]|)\s*$/i; + my $fb = pop(@byte); + if (defined($u)) + { + my $uch = encode_U(hex($u)); + my $ech = join('',map(chr(hex($_)),@byte)); + if (length($fb)) + { + $fb = substr($fb,1); + $hfb++; + } + else + { + $nfb++; + $fb = '0'; + } + # $fb is fallback flag + # 0 - round trip safe + # 1 - fallback for unicode -> enc + # 2 - skip sub-char mapping + # 3 - fallback enc -> unicode + enter($u2e,$uch,$ech,$u2e,$fb+0) if ($fb =~ /[01]/); + enter($e2u,$ech,$uch,$e2u,$fb+0) if ($fb =~ /[03]/); + } + else + { + warn $_; + } + + } + if ($nfb && $hfb) + { + die "$nfb entries without fallback, $hfb entries with\n"; + } + if ($doC) + { + output($ch,$name.'_utf8',$e2u); + output($ch,'utf8_'.$name,$u2e); + $encoding{$name} = [$e2u->{Cname},$u2e->{Cname}, + outstring($ch,$e2u->{Cname}.'_def',$erep),length($erep)]; + } + elsif ($doEnc) + { + output_enc($ch,$name,$e2u); + } + elsif ($doUcm) + { + output_ucm($ch,$name,$u2e); + } +} + +sub compile_enc +{ + my ($fh,$name,$ch) = @_; + my $e2u = {}; + my $u2e = {}; + + my $type; + while ($type = <$fh>) + { + last if $type !~ /^\s*#/; + } + chomp($type); + return if $type eq 'E'; + my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>)); + warn "$type encoded $name\n"; + my $rep = ''; + { + my $v = hex($def); + no strict 'refs'; + $rep = &{"encode_$type"}($v & 0xFF, ($v >> 8) & 0xffe); + } + while ($pages--) + { + my $line = <$fh>; + chomp($line); + my $page = hex($line); + my $ch = 0; + for (my $i = 0; $i < 16; $i++) + { + my $line = <$fh>; + for (my $j = 0; $j < 16; $j++) + { + no strict 'refs'; + my $ech = &{"encode_$type"}($ch,$page); + my $val = hex(substr($line,0,4,'')); + if ($val || (!$ch && !$page)) + { + my $uch = encode_U($val); + enter($e2u,$ech,$uch,$e2u,0); + enter($u2e,$uch,$ech,$u2e,0); + } + else + { + # No character at this position + # enter($e2u,$ech,undef,$e2u); + } + $ch++; + } + } + } + if ($doC) + { + output($ch,$name.'_utf8',$e2u); + output($ch,'utf8_'.$name,$u2e); + $encoding{$name} = [$e2u->{Cname},$u2e->{Cname}, + outstring($ch,$e2u->{Cname}.'_def',$rep),length($rep)]; + } + elsif ($doEnc) + { + output_enc($ch,$name,$e2u); + } + elsif ($doUcm) + { + output_ucm($ch,$name,$u2e); + } +} + +sub enter +{ + my ($a,$s,$d,$t,$fb) = @_; + $t = $a if @_ < 4; + my $b = substr($s,0,1); + my $e = $a->{$b}; + unless ($e) + { # 0 1 2 3 4 5 + $e = [$b,$b,'',{},length($s),0,$fb]; + $a->{$b} = $e; + } + if (length($s) > 1) + { + enter($e->[3],substr($s,1),$d,$t,$fb); + } + else + { + $e->[2] = $d; + $e->[3] = $t; + $e->[5] = length($d); + } +} + +sub outstring +{ + my ($fh,$name,$s) = @_; + my $sym = $strings{$s}; + unless ($sym) + { + foreach my $o (keys %strings) + { + my $i = index($o,$s); + if ($i >= 0) + { + $sym = $strings{$o}; + $sym .= sprintf("+0x%02x",$i) if ($i); + return $sym; + } + } + $strings{$s} = $sym = $name; + printf $fh "\nstatic const U8 %s[%d] =\n",$name,length($s); + # Do in chunks of 16 chars to constrain line length + # Assumes ANSI C adjacent string litteral concatenation + while (length($s)) + { + my $c = substr($s,0,16,''); + print $fh '"',join('',map(sprintf('\x%02x',ord($_)),split(//,$c))),'"'; + print $fh "\n" if length($s); + } + printf $fh ";\n"; + } + return $sym; +} + +sub process +{ + my ($name,$a) = @_; + $name =~ s/\W+/_/g; + $a->{Cname} = $name; + my @keys = grep(ref($a->{$_}),sort keys %$a); + my $l; + my @ent; + foreach my $b (@keys) + { + my ($s,$f,$out,$t,$end) = @{$a->{$b}}; + if (defined($l) && + ord($b) == ord($a->{$l}[1])+1 && + $a->{$l}[3] == $a->{$b}[3] && + $a->{$l}[4] == $a->{$b}[4] && + $a->{$l}[5] == $a->{$b}[5] && + $a->{$l}[6] == $a->{$b}[6] + # && length($a->{$l}[2]) < 16 + ) + { + my $i = ord($b)-ord($a->{$l}[0]); + $a->{$l}[1] = $b; + $a->{$l}[2] .= $a->{$b}[2]; + } + else + { + $l = $b; + push(@ent,$b); + } + if (exists $t->{Cname}) + { + $t->{'Forward'} = 1 if $t != $a; + } + else + { + process(sprintf("%s_%02x",$name,ord($s)),$t); + } + } + if (ord($keys[-1]) < 255) + { + my $t = chr(ord($keys[-1])+1); + $a->{$t} = [$t,chr(255),undef,$a,0,0]; + push(@ent,$t); + } + $a->{'Entries'} = \@ent; +} + +sub outtable +{ + my ($fh,$a) = @_; + my $name = $a->{'Cname'}; + # String tables + foreach my $b (@{$a->{'Entries'}}) + { + next unless $a->{$b}[5]; + my $s = ord($a->{$b}[0]); + my $e = ord($a->{$b}[1]); + outstring($fh,sprintf("%s__%02x_%02x",$name,$s,$e),$a->{$b}[2]); + } + if ($a->{'Forward'}) + { + print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n"; + } + $a->{'Done'} = 1; + foreach my $b (@{$a->{'Entries'}}) + { + my ($s,$e,$out,$t,$end,$l) = @{$a->{$b}}; + outtable($fh,$t) unless $t->{'Done'}; + } + print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"] = {\n"; + foreach my $b (@{$a->{'Entries'}}) + { + my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}}; + my $sc = ord($s); + my $ec = ord($e); + $end |= 0x80 if $fb; + print $fh "{"; + if ($l) + { + printf $fh outstring($fh,'',$out); + } + else + { + print $fh "0"; + } + print $fh ",",$t->{Cname}; + printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec; + } + print $fh "};\n"; +} + +sub output +{ + my ($fh,$name,$a) = @_; + process($name,$a); + # Sub-tables + outtable($fh,$a); +} + +sub output_enc +{ + my ($fh,$name,$a) = @_; + foreach my $b (sort keys %$a) + { + my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}}; + } +} + +sub decode_U +{ + my $s = shift; + +} + + +sub output_ucm_page +{ + my ($fh,$a,$t,$pre) = @_; + # warn sprintf("Page %x\n",$pre); + foreach my $b (sort keys %$t) + { + my ($s,$e,$out,$n,$end,$l,$fb) = @{$t->{$b}}; + die "oops $s $e" unless $s eq $e; + my $u = ord($s); + if ($n != $a && $n != $t) + { + output_ucm_page($fh,$a,$n,(($pre|($u &0x3F)) << 6)&0xFFFF); + } + elsif (length($out)) + { + if ($pre) + { + $u = $pre|($u &0x3f); + } + printf $fh " ",$u; + foreach my $c (split(//,$out)) + { + printf $fh "\\x%02X",ord($c); + } + printf $fh " |%d\n",($fb ? 1 : 0); + } + else + { + warn join(',',@{$t->{$b}},$a,$t); + } + } +} + +sub output_ucm +{ + my ($fh,$name,$a) = @_; + print $fh "CHARMAP\n"; + output_ucm_page($fh,$a,$a,0); + print $fh "END CHARMAP\n"; +} + diff --git a/ext/Encode/encengine.c b/ext/Encode/encengine.c new file mode 100644 index 0000000..513ef9a --- /dev/null +++ b/ext/Encode/encengine.c @@ -0,0 +1,164 @@ +/* +Data structures for encoding transformations. + +Perl works internally in either a native 'byte' encoding or +in UTF-8 encoded Unicode. We have no immediate need for a "wchar_t" +representation. When we do we can use utf8_to_uv(). + +Most character encodings are either simple byte mappings or +variable length multi-byte encodings. UTF-8 can be viewed as a +rather extreme case of the latter. + +So to solve an important part of perl's encode needs we need to solve the +"multi-byte -> multi-byte" case. The simple byte forms are then just degenerate +case. (Where one of multi-bytes will usually be UTF-8.) + +The other type of encoding is a shift encoding where a prefix sequence +determines what subsequent bytes mean. Such encodings have state. + +We also need to handle case where a character in one encoding has to be +represented as multiple characters in the other. e.g. letter+diacritic. + +The process can be considered as pseudo perl: + +my $dst = ''; +while (length($src)) + { + my $size = $count($src); + my $in_seq = substr($src,0,$size,''); + my $out_seq = $s2d_hash{$in_seq}; + if (defined $out_seq) + { + $dst .= $out_seq; + } + else + { + # an error condition + } + } +return $dst; + +That has the following components: + &src_count - a "rule" for how many bytes make up the next character in the + source. + %s2d_hash - a mapping from input sequences to output sequences + +The problem with that scheme is that it does not allow the output +character repertoire to affect the characters considered from the +input. + +So we use a "trie" representation which can also be considered +a state machine: + +my $dst = ''; +my $seq = \@s2d_seq; +my $next = \@s2d_next; +while (length($src)) + { + my $byte = $substr($src,0,1,''); + my $out_seq = $seq->[$byte]; + if (defined $out_seq) + { + $dst .= $out_seq; + } + else + { + # an error condition + } + ($next,$seq) = @$next->[$byte] if $next; + } +return $dst; + +There is now a pair of data structures to represent everything. +It is valid for output sequence at a particular point to +be defined but zero length, that just means "don't know yet". +For the single byte case there is no 'next' so new tables will be the same as +the original tables. For a multi-byte case a prefix byte will flip to the tables +for the next page (adding nothing to the output), then the tables for the page +will provide the actual output and set tables back to original base page. + +This scheme can also handle shift encodings. + +A slight enhancement to the scheme also allows for look-ahead - if +we add a flag to re-add the removed byte to the source we could handle + a" -> ä + ab -> a (and take b back please) + +*/ + +#include +#include +#define U8 U8 +#include "encode.h" + +int +do_encode(encpage_t *enc, const U8 *src, STRLEN *slen, U8 *dst, STRLEN dlen, STRLEN *dout, int approx) +{ + const U8 *s = src; + const U8 *send = s+*slen; + const U8 *last = s; + U8 *d = dst; + U8 *dend = d+dlen; + int code = 0; + while (s < send) + { + encpage_t *e = enc; + U8 byte = *s; + while (byte > e->max) + e++; + if (byte >= e->min && e->slen && (approx || !(e->slen & 0x80))) + { + const U8 *cend = s + (e->slen & 0x7f); + if (cend <= send) + { + STRLEN n; + if ((n = e->dlen)) + { + const U8 *out = e->seq+n*(byte - e->min); + U8 *oend = d+n; + if (dst) + { + if (oend <= dend) + { + while (d < oend) + *d++ = *out++; + } + else + { + /* Out of space */ + code = ENCODE_NOSPACE; + break; + } + } + else + d = oend; + } + enc = e->next; + s++; + if (s == cend) + { + if (approx && (e->slen & 0x80)) + code = ENCODE_FALLBACK; + last = s; + } + } + else + { + /* partial source character */ + code = ENCODE_PARTIAL; + break; + } + } + else + { + /* Cannot represent */ + code = ENCODE_NOREP; + break; + } + } + *slen = last - src; + *dout = d - dst; + return code; +} + + diff --git a/ext/Encode/encode.h b/ext/Encode/encode.h new file mode 100644 index 0000000..853ad04 --- /dev/null +++ b/ext/Encode/encode.h @@ -0,0 +1,40 @@ +#ifndef ENCODE_H +#define ENCODE_H +#ifndef U8 +typedef unsigned char U8; +#endif + +typedef struct encpage_s encpage_t; + +struct encpage_s +{ + const U8 *seq; + encpage_t *next; + U8 min; + U8 max; + U8 dlen; + U8 slen; +}; + +typedef struct encode_s encode_t; +struct encode_s +{ + const char *name; + encpage_t *t_utf8; + encpage_t *f_utf8; + const U8 *rep; + int replen; +}; + +#ifdef U8 +extern int do_encode(encpage_t *enc, const U8 *src, STRLEN *slen, + U8 *dst, STRLEN dlen, STRLEN *dout, int approx); + +extern void Encode_DefineEncoding(encode_t *enc); +#endif + +#define ENCODE_NOSPACE 1 +#define ENCODE_PARTIAL 2 +#define ENCODE_NOREP 3 +#define ENCODE_FALLBACK 4 +#endif diff --git a/ext/Errno/Errno_pm.PL b/ext/Errno/Errno_pm.PL index 0666b2a..3e34b90 100644 --- a/ext/Errno/Errno_pm.PL +++ b/ext/Errno/Errno_pm.PL @@ -2,9 +2,7 @@ use ExtUtils::MakeMaker; use Config; use strict; -use vars qw($VERSION); - -$VERSION = "1.111"; +our $VERSION = "1.111"; my %err = (); @@ -29,6 +27,12 @@ sub process_file { warn "Cannot open '$file'"; return; } + } elsif ($Config{gccversion} ne '') { + # With the -dM option, gcc outputs every #define it finds + unless(open(FH,"$Config{cc} -E -dM $file |")) { + warn "Cannot open '$file'"; + return; + } } else { unless(open(FH,"< $file")) { # This file could be a temporary file created by cppstdin @@ -79,6 +83,10 @@ sub get_files { } elsif ($^O eq 'vmesa') { # OS/390 C compiler doesn't generate #file or #line directives $file{'../../vmesa/errno.h'} = 1; + } elsif ($^O eq 'linux') { + # Some Linuxes have weird errno.hs which generate + # no #file or #line directives + $file{'/usr/include/errno.h'} = 1; } else { open(CPPI,"> errno.c") or die "Cannot open errno.c"; @@ -175,7 +183,7 @@ sub write_errno_pm { # package Errno; -use vars qw(\@EXPORT_OK \%EXPORT_TAGS \@ISA \$VERSION \%errno \$AUTOLOAD); +our (\@EXPORT_OK,\%EXPORT_TAGS,\@ISA,\$VERSION,\%errno,\$AUTOLOAD); use Exporter (); use Config; use strict; diff --git a/ext/Fcntl/Fcntl.pm b/ext/Fcntl/Fcntl.pm index 92103a1..c68dda1 100644 --- a/ext/Fcntl/Fcntl.pm +++ b/ext/Fcntl/Fcntl.pm @@ -201,7 +201,7 @@ sub S_ISENFMT { ( $_[0] & _S_IFMT() ) == S_IFENFMT() } sub AUTOLOAD { (my $constname = $AUTOLOAD) =~ s/.*:://; - my $val = constant($constname, 0); + my $val = constant($constname); if ($! != 0) { if ($! =~ /Invalid/ || $!{EINVAL}) { $AutoLoader::AUTOLOAD = $AUTOLOAD; diff --git a/ext/Fcntl/Fcntl.xs b/ext/Fcntl/Fcntl.xs index b597e03..21029b2 100644 --- a/ext/Fcntl/Fcntl.xs +++ b/ext/Fcntl/Fcntl.xs @@ -40,13 +40,13 @@ not_here(char *s) return -1; } -static double -constant(char *name, int arg) +static IV +constant(char *name) { errno = 0; - switch (*name) { + switch (*(name++)) { case '_': - if (strEQ(name, "_S_IFMT")) /* Yes, on name _S_IFMT return S_IFMT. */ + if (strEQ(name, "S_IFMT")) /* Yes, on name _S_IFMT return S_IFMT. */ #ifdef S_IFMT return S_IFMT; #else @@ -54,218 +54,219 @@ constant(char *name, int arg) #endif break; case 'F': - if (strnEQ(name, "F_", 2)) { - if (strEQ(name, "F_ALLOCSP")) + if (*name == '_') { + name++; + if (strEQ(name, "ALLOCSP")) #ifdef F_ALLOCSP return F_ALLOCSP; #else goto not_there; #endif - if (strEQ(name, "F_ALLOCSP64")) + if (strEQ(name, "ALLOCSP64")) #ifdef F_ALLOCSP64 return F_ALLOCSP64; #else goto not_there; #endif - if (strEQ(name, "F_COMPAT")) + if (strEQ(name, "COMPAT")) #ifdef F_COMPAT return F_COMPAT; #else goto not_there; #endif - if (strEQ(name, "F_DUP2FD")) + if (strEQ(name, "DUP2FD")) #ifdef F_DUP2FD return F_DUP2FD; #else goto not_there; #endif - if (strEQ(name, "F_DUPFD")) + if (strEQ(name, "DUPFD")) #ifdef F_DUPFD return F_DUPFD; #else goto not_there; #endif - if (strEQ(name, "F_EXLCK")) + if (strEQ(name, "EXLCK")) #ifdef F_EXLCK return F_EXLCK; #else goto not_there; #endif - if (strEQ(name, "F_FREESP")) + if (strEQ(name, "FREESP")) #ifdef F_FREESP return F_FREESP; #else goto not_there; #endif - if (strEQ(name, "F_FREESP64")) + if (strEQ(name, "FREESP64")) #ifdef F_FREESP64 return F_FREESP64; #else goto not_there; #endif - if (strEQ(name, "F_FSYNC")) + if (strEQ(name, "FSYNC")) #ifdef F_FSYNC return F_FSYNC; #else goto not_there; #endif - if (strEQ(name, "F_FSYNC64")) + if (strEQ(name, "FSYNC64")) #ifdef F_FSYNC64 return F_FSYNC64; #else goto not_there; #endif - if (strEQ(name, "F_GETFD")) + if (strEQ(name, "GETFD")) #ifdef F_GETFD return F_GETFD; #else goto not_there; #endif - if (strEQ(name, "F_GETFL")) + if (strEQ(name, "GETFL")) #ifdef F_GETFL return F_GETFL; #else goto not_there; #endif - if (strEQ(name, "F_GETLK")) + if (strEQ(name, "GETLK")) #ifdef F_GETLK return F_GETLK; #else goto not_there; #endif - if (strEQ(name, "F_GETLK64")) + if (strEQ(name, "GETLK64")) #ifdef F_GETLK64 return F_GETLK64; #else goto not_there; #endif - if (strEQ(name, "F_GETOWN")) + if (strEQ(name, "GETOWN")) #ifdef F_GETOWN return F_GETOWN; #else goto not_there; #endif - if (strEQ(name, "F_NODNY")) + if (strEQ(name, "NODNY")) #ifdef F_NODNY return F_NODNY; #else goto not_there; #endif - if (strEQ(name, "F_POSIX")) + if (strEQ(name, "POSIX")) #ifdef F_POSIX return F_POSIX; #else goto not_there; #endif - if (strEQ(name, "F_RDACC")) + if (strEQ(name, "RDACC")) #ifdef F_RDACC return F_RDACC; #else goto not_there; #endif - if (strEQ(name, "F_RDDNY")) + if (strEQ(name, "RDDNY")) #ifdef F_RDDNY return F_RDDNY; #else goto not_there; #endif - if (strEQ(name, "F_RDLCK")) + if (strEQ(name, "RDLCK")) #ifdef F_RDLCK return F_RDLCK; #else goto not_there; #endif - if (strEQ(name, "F_RWACC")) + if (strEQ(name, "RWACC")) #ifdef F_RWACC return F_RWACC; #else goto not_there; #endif - if (strEQ(name, "F_RWDNY")) + if (strEQ(name, "RWDNY")) #ifdef F_RWDNY return F_RWDNY; #else goto not_there; #endif - if (strEQ(name, "F_SETFD")) + if (strEQ(name, "SETFD")) #ifdef F_SETFD return F_SETFD; #else goto not_there; #endif - if (strEQ(name, "F_SETFL")) + if (strEQ(name, "SETFL")) #ifdef F_SETFL return F_SETFL; #else goto not_there; #endif - if (strEQ(name, "F_SETLK")) + if (strEQ(name, "SETLK")) #ifdef F_SETLK return F_SETLK; #else goto not_there; #endif - if (strEQ(name, "F_SETLK64")) + if (strEQ(name, "SETLK64")) #ifdef F_SETLK64 return F_SETLK64; #else goto not_there; #endif - if (strEQ(name, "F_SETLKW")) + if (strEQ(name, "SETLKW")) #ifdef F_SETLKW return F_SETLKW; #else goto not_there; #endif - if (strEQ(name, "F_SETLKW64")) + if (strEQ(name, "SETLKW64")) #ifdef F_SETLKW64 return F_SETLKW64; #else goto not_there; #endif - if (strEQ(name, "F_SETOWN")) + if (strEQ(name, "SETOWN")) #ifdef F_SETOWN return F_SETOWN; #else goto not_there; #endif - if (strEQ(name, "F_SHARE")) + if (strEQ(name, "SHARE")) #ifdef F_SHARE return F_SHARE; #else goto not_there; #endif - if (strEQ(name, "F_SHLCK")) + if (strEQ(name, "SHLCK")) #ifdef F_SHLCK return F_SHLCK; #else goto not_there; #endif - if (strEQ(name, "F_UNLCK")) + if (strEQ(name, "UNLCK")) #ifdef F_UNLCK return F_UNLCK; #else goto not_there; #endif - if (strEQ(name, "F_UNSHARE")) + if (strEQ(name, "UNSHARE")) #ifdef F_UNSHARE return F_UNSHARE; #else goto not_there; #endif - if (strEQ(name, "F_WRACC")) + if (strEQ(name, "WRACC")) #ifdef F_WRACC return F_WRACC; #else goto not_there; #endif - if (strEQ(name, "F_WRDNY")) + if (strEQ(name, "WRDNY")) #ifdef F_WRDNY return F_WRDNY; #else goto not_there; #endif - if (strEQ(name, "F_WRLCK")) + if (strEQ(name, "WRLCK")) #ifdef F_WRLCK return F_WRLCK; #else @@ -274,79 +275,79 @@ constant(char *name, int arg) errno = EINVAL; return 0; } - if (strEQ(name, "FAPPEND")) + if (strEQ(name, "APPEND")) #ifdef FAPPEND return FAPPEND; #else goto not_there; #endif - if (strEQ(name, "FASYNC")) + if (strEQ(name, "ASYNC")) #ifdef FASYNC return FASYNC; #else goto not_there; #endif - if (strEQ(name, "FCREAT")) + if (strEQ(name, "CREAT")) #ifdef FCREAT return FCREAT; #else goto not_there; #endif - if (strEQ(name, "FD_CLOEXEC")) + if (strEQ(name, "D_CLOEXEC")) #ifdef FD_CLOEXEC return FD_CLOEXEC; #else goto not_there; #endif - if (strEQ(name, "FDEFER")) + if (strEQ(name, "DEFER")) #ifdef FDEFER return FDEFER; #else goto not_there; #endif - if (strEQ(name, "FDSYNC")) + if (strEQ(name, "DSYNC")) #ifdef FDSYNC return FDSYNC; #else goto not_there; #endif - if (strEQ(name, "FEXCL")) + if (strEQ(name, "EXCL")) #ifdef FEXCL return FEXCL; #else goto not_there; #endif - if (strEQ(name, "FLARGEFILE")) + if (strEQ(name, "LARGEFILE")) #ifdef FLARGEFILE return FLARGEFILE; #else goto not_there; #endif - if (strEQ(name, "FNDELAY")) + if (strEQ(name, "NDELAY")) #ifdef FNDELAY return FNDELAY; #else goto not_there; #endif - if (strEQ(name, "FNONBLOCK")) + if (strEQ(name, "NONBLOCK")) #ifdef FNONBLOCK return FNONBLOCK; #else goto not_there; #endif - if (strEQ(name, "FRSYNC")) + if (strEQ(name, "RSYNC")) #ifdef FRSYNC return FRSYNC; #else goto not_there; #endif - if (strEQ(name, "FSYNC")) + if (strEQ(name, "SYNC")) #ifdef FSYNC return FSYNC; #else goto not_there; #endif - if (strEQ(name, "FTRUNC")) + if (strEQ(name, "TRUNC")) #ifdef FTRUNC return FTRUNC; #else @@ -354,28 +355,29 @@ constant(char *name, int arg) #endif break; case 'L': - if (strnEQ(name, "LOCK_", 5)) { + if (strnEQ(name, "OCK_", 4)) { /* We support flock() on systems which don't have it, so always supply the constants. */ - if (strEQ(name, "LOCK_SH")) + name += 4; + if (strEQ(name, "SH")) #ifdef LOCK_SH return LOCK_SH; #else return 1; #endif - if (strEQ(name, "LOCK_EX")) + if (strEQ(name, "EX")) #ifdef LOCK_EX return LOCK_EX; #else return 2; #endif - if (strEQ(name, "LOCK_NB")) + if (strEQ(name, "NB")) #ifdef LOCK_NB return LOCK_NB; #else return 4; #endif - if (strEQ(name, "LOCK_UN")) + if (strEQ(name, "UN")) #ifdef LOCK_UN return LOCK_UN; #else @@ -385,188 +387,189 @@ constant(char *name, int arg) goto not_there; break; case 'O': - if (strnEQ(name, "O_", 2)) { - if (strEQ(name, "O_ACCMODE")) + if (name[0] == '_') { + name++; + if (strEQ(name, "ACCMODE")) #ifdef O_ACCMODE return O_ACCMODE; #else goto not_there; #endif - if (strEQ(name, "O_APPEND")) + if (strEQ(name, "APPEND")) #ifdef O_APPEND return O_APPEND; #else goto not_there; #endif - if (strEQ(name, "O_ASYNC")) + if (strEQ(name, "ASYNC")) #ifdef O_ASYNC return O_ASYNC; #else goto not_there; #endif - if (strEQ(name, "O_BINARY")) + if (strEQ(name, "BINARY")) #ifdef O_BINARY return O_BINARY; #else goto not_there; #endif - if (strEQ(name, "O_CREAT")) + if (strEQ(name, "CREAT")) #ifdef O_CREAT return O_CREAT; #else goto not_there; #endif - if (strEQ(name, "O_DEFER")) + if (strEQ(name, "DEFER")) #ifdef O_DEFER return O_DEFER; #else goto not_there; #endif - if (strEQ(name, "O_DIRECT")) + if (strEQ(name, "DIRECT")) #ifdef O_DIRECT return O_DIRECT; #else goto not_there; #endif - if (strEQ(name, "O_DIRECTORY")) + if (strEQ(name, "DIRECTORY")) #ifdef O_DIRECTORY return O_DIRECTORY; #else goto not_there; #endif - if (strEQ(name, "O_DSYNC")) + if (strEQ(name, "DSYNC")) #ifdef O_DSYNC return O_DSYNC; #else goto not_there; #endif - if (strEQ(name, "O_EXCL")) + if (strEQ(name, "EXCL")) #ifdef O_EXCL return O_EXCL; #else goto not_there; #endif - if (strEQ(name, "O_EXLOCK")) + if (strEQ(name, "EXLOCK")) #ifdef O_EXLOCK return O_EXLOCK; #else goto not_there; #endif - if (strEQ(name, "O_LARGEFILE")) + if (strEQ(name, "LARGEFILE")) #ifdef O_LARGEFILE return O_LARGEFILE; #else goto not_there; #endif - if (strEQ(name, "O_NDELAY")) + if (strEQ(name, "NDELAY")) #ifdef O_NDELAY return O_NDELAY; #else goto not_there; #endif - if (strEQ(name, "O_NOCTTY")) + if (strEQ(name, "NOCTTY")) #ifdef O_NOCTTY return O_NOCTTY; #else goto not_there; #endif - if (strEQ(name, "O_NOFOLLOW")) + if (strEQ(name, "NOFOLLOW")) #ifdef O_NOFOLLOW return O_NOFOLLOW; #else goto not_there; #endif - if (strEQ(name, "O_NOINHERIT")) + if (strEQ(name, "NOINHERIT")) #ifdef O_NOINHERIT return O_NOINHERIT; #else goto not_there; #endif - if (strEQ(name, "O_NONBLOCK")) + if (strEQ(name, "NONBLOCK")) #ifdef O_NONBLOCK return O_NONBLOCK; #else goto not_there; #endif - if (strEQ(name, "O_RANDOM")) + if (strEQ(name, "RANDOM")) #ifdef O_RANDOM return O_RANDOM; #else goto not_there; #endif - if (strEQ(name, "O_RAW")) + if (strEQ(name, "RAW")) #ifdef O_RAW return O_RAW; #else goto not_there; #endif - if (strEQ(name, "O_RDONLY")) + if (strEQ(name, "RDONLY")) #ifdef O_RDONLY return O_RDONLY; #else goto not_there; #endif - if (strEQ(name, "O_RDWR")) + if (strEQ(name, "RDWR")) #ifdef O_RDWR return O_RDWR; #else goto not_there; #endif - if (strEQ(name, "O_RSYNC")) + if (strEQ(name, "RSYNC")) #ifdef O_RSYNC return O_RSYNC; #else goto not_there; #endif - if (strEQ(name, "O_SEQUENTIAL")) + if (strEQ(name, "SEQUENTIAL")) #ifdef O_SEQUENTIAL return O_SEQUENTIAL; #else goto not_there; #endif - if (strEQ(name, "O_SHLOCK")) + if (strEQ(name, "SHLOCK")) #ifdef O_SHLOCK return O_SHLOCK; #else goto not_there; #endif - if (strEQ(name, "O_SYNC")) + if (strEQ(name, "SYNC")) #ifdef O_SYNC return O_SYNC; #else goto not_there; #endif - if (strEQ(name, "O_TEMPORARY")) + if (strEQ(name, "TEMPORARY")) #ifdef O_TEMPORARY return O_TEMPORARY; #else goto not_there; #endif - if (strEQ(name, "O_TEXT")) + if (strEQ(name, "TEXT")) #ifdef O_TEXT return O_TEXT; #else goto not_there; #endif - if (strEQ(name, "O_TRUNC")) + if (strEQ(name, "TRUNC")) #ifdef O_TRUNC return O_TRUNC; #else goto not_there; #endif - if (strEQ(name, "O_WRONLY")) + if (strEQ(name, "WRONLY")) #ifdef O_WRONLY return O_WRONLY; #else goto not_there; #endif - if (strEQ(name, "O_ALIAS")) + if (strEQ(name, "ALIAS")) #ifdef O_ALIAS return O_ALIAS; #else goto not_there; #endif - if (strEQ(name, "O_RSRC")) + if (strEQ(name, "RSRC")) #ifdef O_RSRC return O_RSRC; #else @@ -576,171 +579,171 @@ constant(char *name, int arg) goto not_there; break; case 'S': - switch (name[1]) { + switch (*(name++)) { case '_': - if (strEQ(name, "S_ISUID")) + if (strEQ(name, "ISUID")) #ifdef S_ISUID return S_ISUID; #else goto not_there; #endif - if (strEQ(name, "S_ISGID")) + if (strEQ(name, "ISGID")) #ifdef S_ISGID return S_ISGID; #else goto not_there; #endif - if (strEQ(name, "S_ISVTX")) + if (strEQ(name, "ISVTX")) #ifdef S_ISVTX return S_ISVTX; #else goto not_there; #endif - if (strEQ(name, "S_ISTXT")) + if (strEQ(name, "ISTXT")) #ifdef S_ISTXT return S_ISTXT; #else goto not_there; #endif - if (strEQ(name, "S_IFREG")) + if (strEQ(name, "IFREG")) #ifdef S_IFREG return S_IFREG; #else goto not_there; #endif - if (strEQ(name, "S_IFDIR")) + if (strEQ(name, "IFDIR")) #ifdef S_IFDIR return S_IFDIR; #else goto not_there; #endif - if (strEQ(name, "S_IFLNK")) + if (strEQ(name, "IFLNK")) #ifdef S_IFLNK return S_IFLNK; #else goto not_there; #endif - if (strEQ(name, "S_IFSOCK")) + if (strEQ(name, "IFSOCK")) #ifdef S_IFSOCK return S_IFSOCK; #else goto not_there; #endif - if (strEQ(name, "S_IFBLK")) + if (strEQ(name, "IFBLK")) #ifdef S_IFBLK return S_IFBLK; #else goto not_there; #endif - if (strEQ(name, "S_IFCHR")) + if (strEQ(name, "IFCHR")) #ifdef S_IFCHR return S_IFCHR; #else goto not_there; #endif - if (strEQ(name, "S_IFIFO")) + if (strEQ(name, "IFIFO")) #ifdef S_IFIFO return S_IFIFO; #else goto not_there; #endif - if (strEQ(name, "S_IFWHT")) + if (strEQ(name, "IFWHT")) #ifdef S_IFWHT return S_IFWHT; #else goto not_there; #endif - if (strEQ(name, "S_ENFMT")) + if (strEQ(name, "ENFMT")) #ifdef S_ENFMT return S_ENFMT; #else goto not_there; #endif - if (strEQ(name, "S_IRUSR")) + if (strEQ(name, "IRUSR")) #ifdef S_IRUSR return S_IRUSR; #else goto not_there; #endif - if (strEQ(name, "S_IWUSR")) + if (strEQ(name, "IWUSR")) #ifdef S_IWUSR return S_IWUSR; #else goto not_there; #endif - if (strEQ(name, "S_IXUSR")) + if (strEQ(name, "IXUSR")) #ifdef S_IXUSR return S_IXUSR; #else goto not_there; #endif - if (strEQ(name, "S_IRWXU")) + if (strEQ(name, "IRWXU")) #ifdef S_IRWXU return S_IRWXU; #else goto not_there; #endif - if (strEQ(name, "S_IRGRP")) + if (strEQ(name, "IRGRP")) #ifdef S_IRGRP return S_IRGRP; #else goto not_there; #endif - if (strEQ(name, "S_IWGRP")) + if (strEQ(name, "IWGRP")) #ifdef S_IWGRP return S_IWGRP; #else goto not_there; #endif - if (strEQ(name, "S_IXGRP")) + if (strEQ(name, "IXGRP")) #ifdef S_IXGRP return S_IXGRP; #else goto not_there; #endif - if (strEQ(name, "S_IRWXG")) + if (strEQ(name, "IRWXG")) #ifdef S_IRWXG return S_IRWXG; #else goto not_there; #endif - if (strEQ(name, "S_IROTH")) + if (strEQ(name, "IROTH")) #ifdef S_IROTH return S_IROTH; #else goto not_there; #endif - if (strEQ(name, "S_IWOTH")) + if (strEQ(name, "IWOTH")) #ifdef S_IWOTH return S_IWOTH; #else goto not_there; #endif - if (strEQ(name, "S_IXOTH")) + if (strEQ(name, "IXOTH")) #ifdef S_IXOTH return S_IXOTH; #else goto not_there; #endif - if (strEQ(name, "S_IRWXO")) + if (strEQ(name, "IRWXO")) #ifdef S_IRWXO return S_IRWXO; #else goto not_there; #endif - if (strEQ(name, "S_IREAD")) + if (strEQ(name, "IREAD")) #ifdef S_IREAD return S_IREAD; #else goto not_there; #endif - if (strEQ(name, "S_IWRITE")) + if (strEQ(name, "IWRITE")) #ifdef S_IWRITE return S_IWRITE; #else goto not_there; #endif - if (strEQ(name, "S_IEXEC")) + if (strEQ(name, "IEXEC")) #ifdef S_IEXEC return S_IEXEC; #else @@ -748,19 +751,19 @@ constant(char *name, int arg) #endif break; case 'E': - if (strEQ(name, "SEEK_CUR")) + if (strEQ(name, "EK_CUR")) #ifdef SEEK_CUR return SEEK_CUR; #else return 1; #endif - if (strEQ(name, "SEEK_END")) + if (strEQ(name, "EK_END")) #ifdef SEEK_END return SEEK_END; #else return 2; #endif - if (strEQ(name, "SEEK_SET")) + if (strEQ(name, "EK_SET")) #ifdef SEEK_SET return SEEK_SET; #else @@ -780,8 +783,7 @@ not_there: MODULE = Fcntl PACKAGE = Fcntl -double -constant(name,arg) +IV +constant(name) char * name - int arg diff --git a/ext/Filter/Util/Call/Call.pm b/ext/Filter/Util/Call/Call.pm new file mode 100644 index 0000000..694b1b3 --- /dev/null +++ b/ext/Filter/Util/Call/Call.pm @@ -0,0 +1,474 @@ +package Filter::Util::Call ; + +require 5.002 ; +require DynaLoader; +require Exporter; +use Carp ; +use strict; +use vars qw($VERSION @ISA @EXPORT) ; + +@ISA = qw(Exporter DynaLoader); +@EXPORT = qw( filter_add filter_del filter_read filter_read_exact) ; +$VERSION = "1.04" ; + +sub filter_read_exact($) +{ + my ($size) = @_ ; + my ($left) = $size ; + my ($status) ; + + croak ("filter_read_exact: size parameter must be > 0") + unless $size > 0 ; + + # try to read a block which is exactly $size bytes long + while ($left and ($status = filter_read($left)) > 0) { + $left = $size - length $_ ; + } + + # EOF with pending data is a special case + return 1 if $status == 0 and length $_ ; + + return $status ; +} + +sub filter_add($) +{ + my($obj) = @_ ; + + # Did we get a code reference? + my $coderef = (ref $obj eq 'CODE') ; + + # If the parameter isn't already a reference, make it one. + $obj = \$obj unless ref $obj ; + + $obj = bless ($obj, (caller)[0]) unless $coderef ; + + # finish off the installation of the filter in C. + Filter::Util::Call::real_import($obj, (caller)[0], $coderef) ; +} + +bootstrap Filter::Util::Call ; + +1; +__END__ + +=head1 NAME + +Filter::Util::Call - Perl Source Filter Utility Module + +=head1 SYNOPSIS + + use Filter::Util::Call ; + +=head1 DESCRIPTION + +This module provides you with the framework to write I +in Perl. + +A I is implemented as a Perl module. The structure +of the module can take one of two broadly similar formats. To +distinguish between them, the first will be referred to as I and the second as I. + +Here is a skeleton for the I: + + package MyFilter ; + + use Filter::Util::Call ; + + sub import + { + my($type, @arguments) = @_ ; + filter_add([]) ; + } + + sub filter + { + my($self) = @_ ; + my($status) ; + + $status = filter_read() ; + $status ; + } + + 1 ; + +and this is the equivalent skeleton for the I: + + package MyFilter ; + + use Filter::Util::Call ; + + sub import + { + my($type, @arguments) = @_ ; + + filter_add( + sub + { + my($status) ; + $status = filter_read() ; + $status ; + } ) + } + + 1 ; + +To make use of either of the two filter modules above, place the line +below in a Perl source file. + + use MyFilter; + +In fact, the skeleton modules shown above are fully functional I, albeit fairly useless ones. All they does is filter the +source stream without modifying it at all. + +As you can see both modules have a broadly similar structure. They both +make use of the C module and both have an C +method. The difference between them is that the I +requires a I method, whereas the I gets the +equivalent of a I method with the anonymous sub passed to +I. + +To make proper use of the I shown above you need to +have a good understanding of the concept of a I. See +L for more details on the mechanics of I. + +=head2 B + +The following functions are exported by C: + + filter_add() + filter_read() + filter_read_exact() + filter_del() + +=head2 B + +The C method is used to create an instance of the filter. It is +called indirectly by Perl when it encounters the C line +in a source file (See L for more details on +C). + +It will always have at least one parameter automatically passed by Perl +- this corresponds to the name of the package. In the example above it +will be C<"MyFilter">. + +Apart from the first parameter, import can accept an optional list of +parameters. These can be used to pass parameters to the filter. For +example: + + use MyFilter qw(a b c) ; + +will result in the C<@_> array having the following values: + + @_ [0] => "MyFilter" + @_ [1] => "a" + @_ [2] => "b" + @_ [3] => "c" + +Before terminating, the C function must explicitly install the +filter by calling C. + +B + +The function, C, actually installs the filter. It takes one +parameter which should be a reference. The kind of reference used will +dictate which of the two filter types will be used. + +If a CODE reference is used then a I will be assumed. + +If a CODE reference is not used, a I will be assumed. +In a I, the reference can be used to store context +information. The reference will be I into the package by +C. + +See the filters at the end of this documents for examples of using +context information using both I and I. + +=head2 B + +Both the C method used with a I and the +anonymous sub used with a I is where the main +processing for the filter is done. + +The big difference between the two types of filter is that the I uses the object passed to the method to store any context data, +whereas the I uses the lexical variables that are +maintained by the closure. + +Note that the single parameter passed to the I, +C<$self>, is the same reference that was passed to C +blessed into the filter's package. See the example filters later on for +details of using C<$self>. + +Here is a list of the common features of the anonymous sub and the +C method. + +=over 5 + +=item B<$_> + +Although C<$_> doesn't actually appear explicitly in the sample filters +above, it is implicitly used in a number of places. + +Firstly, when either C or the anonymous sub are called, a local +copy of C<$_> will automatically be created. It will always contain the +empty string at this point. + +Next, both C and C will append any +source data that is read to the end of C<$_>. + +Finally, when C or the anonymous sub are finished processing, +they are expected to return the filtered source using C<$_>. + +This implicit use of C<$_> greatly simplifies the filter. + +=item B<$status> + +The status value that is returned by the user's C method or +anonymous sub and the C and C functions take +the same set of values, namely: + + < 0 Error + = 0 EOF + > 0 OK + +=item B and B + +These functions are used by the filter to obtain either a line or block +from the next filter in the chain or the actual source file if there +aren't any other filters. + +The function C takes two forms: + + $status = filter_read() ; + $status = filter_read($size) ; + +The first form is used to request a I, the second requests a +I. + +In line mode, C will append the next source line to the +end of the C<$_> scalar. + +In block mode, C will append a block of data which is <= +C<$size> to the end of the C<$_> scalar. It is important to emphasise +the that C will not necessarily read a block which is +I C<$size> bytes. + +If you need to be able to read a block which has an exact size, you can +use the function C. It works identically to +C in block mode, except it will try to read a block which +is exactly C<$size> bytes in length. The only circumstances when it +will not return a block which is C<$size> bytes long is on EOF or +error. + +It is I important to check the value of C<$status> after I +call to C or C. + +=item B + +The function, C, is used to disable the current filter. It +does not affect the running of the filter. All it does is tell Perl not +to call filter any more. + +See L for details. + +=back + +=head1 EXAMPLES + +Here are a few examples which illustrate the key concepts - as such +most of them are of little practical use. + +The C sub-directory has copies of all these filters +implemented both as I and as I. + +=head2 Example 1: A simple filter. + +Below is a I which is hard-wired to replace all +occurrences of the string C<"Joe"> to C<"Jim">. Not particularly +Useful, but it is the first example and I wanted to keep it simple. + + package Joe2Jim ; + + use Filter::Util::Call ; + + sub import + { + my($type) = @_ ; + + filter_add(bless []) ; + } + + sub filter + { + my($self) = @_ ; + my($status) ; + + s/Joe/Jim/g + if ($status = filter_read()) > 0 ; + $status ; + } + + 1 ; + +Here is an example of using the filter: + + use Joe2Jim ; + print "Where is Joe?\n" ; + +And this is what the script above will print: + + Where is Jim? + +=head2 Example 2: Using the context + +The previous example was not particularly useful. To make it more +general purpose we will make use of the context data and allow any +arbitrary I and I strings to be used. This time we will use a +I. To reflect its enhanced role, the filter is called +C. + + package Subst ; + + use Filter::Util::Call ; + use Carp ; + + sub import + { + croak("usage: use Subst qw(from to)") + unless @_ == 3 ; + my ($self, $from, $to) = @_ ; + filter_add( + sub + { + my ($status) ; + s/$from/$to/ + if ($status = filter_read()) > 0 ; + $status ; + }) + } + 1 ; + +and is used like this: + + use Subst qw(Joe Jim) ; + print "Where is Joe?\n" ; + + +=head2 Example 3: Using the context within the filter + +Here is a filter which a variation of the C filter. As well as +substituting all occurrences of C<"Joe"> to C<"Jim"> it keeps a count +of the number of substitutions made in the context object. + +Once EOF is detected (C<$status> is zero) the filter will insert an +extra line into the source stream. When this extra line is executed it +will print a count of the number of substitutions actually made. +Note that C<$status> is set to C<1> in this case. + + package Count ; + + use Filter::Util::Call ; + + sub filter + { + my ($self) = @_ ; + my ($status) ; + + if (($status = filter_read()) > 0 ) { + s/Joe/Jim/g ; + ++ $$self ; + } + elsif ($$self >= 0) { # EOF + $_ = "print q[Made ${$self} substitutions\n]" ; + $status = 1 ; + $$self = -1 ; + } + + $status ; + } + + sub import + { + my ($self) = @_ ; + my ($count) = 0 ; + filter_add(\$count) ; + } + + 1 ; + +Here is a script which uses it: + + use Count ; + print "Hello Joe\n" ; + print "Where is Joe\n" ; + +Outputs: + + Hello Jim + Where is Jim + Made 2 substitutions + +=head2 Example 4: Using filter_del + +Another variation on a theme. This time we will modify the C +filter to allow a starting and stopping pattern to be specified as well +as the I and I patterns. If you know the I editor, it is +the equivalent of this command: + + :/start/,/stop/s/from/to/ + +When used as a filter we want to invoke it like this: + + use NewSubst qw(start stop from to) ; + +Here is the module. + + package NewSubst ; + + use Filter::Util::Call ; + use Carp ; + + sub import + { + my ($self, $start, $stop, $from, $to) = @_ ; + my ($found) = 0 ; + croak("usage: use Subst qw(start stop from to)") + unless @_ == 5 ; + + filter_add( + sub + { + my ($status) ; + + if (($status = filter_read()) > 0) { + + $found = 1 + if $found == 0 and /$start/ ; + + if ($found) { + s/$from/$to/ ; + filter_del() if /$stop/ ; + } + + } + $status ; + } ) + + } + + 1 ; + +=head1 AUTHOR + +Paul Marquess + +=head1 DATE + +26th January 1996 + +=cut + diff --git a/ext/Filter/Util/Call/Call.xs b/ext/Filter/Util/Call/Call.xs new file mode 100644 index 0000000..c8105d0 --- /dev/null +++ b/ext/Filter/Util/Call/Call.xs @@ -0,0 +1,252 @@ +/* + * Filename : Call.xs + * + * Author : Paul Marquess + * Date : 26th March 2000 + * Version : 1.05 + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifndef PERL_VERSION +# include "patchlevel.h" +# define PERL_REVISION 5 +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION +#endif + +/* defgv must be accessed differently under threaded perl */ +/* DEFSV et al are in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(defgv) +#endif + +#ifndef pTHX +# define pTHX +# define pTHX_ +# define aTHX +# define aTHX_ +#endif + + +/* Internal defines */ +#define PERL_MODULE(s) IoBOTTOM_NAME(s) +#define PERL_OBJECT(s) IoTOP_GV(s) +#define FILTER_ACTIVE(s) IoLINES(s) +#define BUF_OFFSET(sv) IoPAGE_LEN(sv) +#define CODE_REF(sv) IoPAGE(sv) + +#define SET_LEN(sv,len) \ + do { SvPVX(sv)[len] = '\0'; SvCUR_set(sv, len); } while (0) + + + +static int fdebug = 0; +static int current_idx ; + +static I32 +filter_call(pTHX_ int idx, SV *buf_sv, int maxlen) +{ + SV *my_sv = FILTER_DATA(idx); + char *nl = "\n"; + char *p; + char *out_ptr; + int n; + + if (fdebug) + warn("**** In filter_call - maxlen = %d, out len buf = %d idx = %d my_sv = %d [%s]\n", + maxlen, SvCUR(buf_sv), idx, SvCUR(my_sv), SvPVX(my_sv) ) ; + + while (1) { + + /* anything left from last time */ + if (n = SvCUR(my_sv)) { + + out_ptr = SvPVX(my_sv) + BUF_OFFSET(my_sv) ; + + if (maxlen) { + /* want a block */ + if (fdebug) + warn("BLOCK(%d): size = %d, maxlen = %d\n", + idx, n, maxlen) ; + + sv_catpvn(buf_sv, out_ptr, maxlen > n ? n : maxlen ); + if(n <= maxlen) { + BUF_OFFSET(my_sv) = 0 ; + SET_LEN(my_sv, 0) ; + } + else { + BUF_OFFSET(my_sv) += maxlen ; + SvCUR_set(my_sv, n - maxlen) ; + } + return SvCUR(buf_sv); + } + else { + /* want lines */ + if (p = ninstr(out_ptr, out_ptr + n - 1, nl, nl)) { + + sv_catpvn(buf_sv, out_ptr, p - out_ptr + 1); + + n = n - (p - out_ptr + 1); + BUF_OFFSET(my_sv) += (p - out_ptr + 1); + SvCUR_set(my_sv, n) ; + if (fdebug) + warn("recycle %d - leaving %d, returning %d [%s]", + idx, n, SvCUR(buf_sv), SvPVX(buf_sv)) ; + + return SvCUR(buf_sv); + } + else /* no EOL, so append the complete buffer */ + sv_catpvn(buf_sv, out_ptr, n) ; + } + + } + + + SET_LEN(my_sv, 0) ; + BUF_OFFSET(my_sv) = 0 ; + + if (FILTER_ACTIVE(my_sv)) + { + dSP ; + int count ; + + if (fdebug) + warn("gonna call %s::filter\n", PERL_MODULE(my_sv)) ; + + ENTER ; + SAVETMPS; + + SAVEINT(current_idx) ; /* save current idx */ + current_idx = idx ; + + SAVESPTR(DEFSV) ; /* save $_ */ + /* make $_ use our buffer */ + DEFSV = sv_2mortal(newSVpv("", 0)) ; + + PUSHMARK(sp) ; + + if (CODE_REF(my_sv)) { + /* if (SvROK(PERL_OBJECT(my_sv)) && SvTYPE(SvRV(PERL_OBJECT(my_sv))) == SVt_PVCV) { */ + count = perl_call_sv((SV*)PERL_OBJECT(my_sv), G_SCALAR); + } + else { + XPUSHs((SV*)PERL_OBJECT(my_sv)) ; + + PUTBACK ; + + count = perl_call_method("filter", G_SCALAR); + } + + SPAGAIN ; + + if (count != 1) + croak("Filter::Util::Call - %s::filter returned %d values, 1 was expected \n", + PERL_MODULE(my_sv), count ) ; + + n = POPi ; + + if (fdebug) + warn("status = %d, length op buf = %d [%s]\n", + n, SvCUR(DEFSV), SvPVX(DEFSV) ) ; + if (SvCUR(DEFSV)) + sv_setpvn(my_sv, SvPVX(DEFSV), SvCUR(DEFSV)) ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + } + else + n = FILTER_READ(idx + 1, my_sv, maxlen) ; + + if (n <= 0) + { + /* Either EOF or an error */ + + if (fdebug) + warn ("filter_read %d returned %d , returning %d\n", idx, n, + (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n); + + /* PERL_MODULE(my_sv) ; */ + /* PERL_OBJECT(my_sv) ; */ + filter_del(filter_call); + + /* If error, return the code */ + if (n < 0) + return n ; + + /* return what we have so far else signal eof */ + return (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n; + } + + } +} + + + +MODULE = Filter::Util::Call PACKAGE = Filter::Util::Call + +REQUIRE: 1.924 +PROTOTYPES: ENABLE + +#define IDX current_idx + +int +filter_read(size=0) + int size + CODE: + { + SV * buffer = DEFSV ; + + RETVAL = FILTER_READ(IDX + 1, buffer, size) ; + } + OUTPUT: + RETVAL + + + + +void +real_import(object, perlmodule, coderef) + SV * object + char * perlmodule + int coderef + PPCODE: + { + SV * sv = newSV(1) ; + + (void)SvPOK_only(sv) ; + filter_add(filter_call, sv) ; + + PERL_MODULE(sv) = savepv(perlmodule) ; + PERL_OBJECT(sv) = (GV*) newSVsv(object) ; + FILTER_ACTIVE(sv) = TRUE ; + BUF_OFFSET(sv) = 0 ; + CODE_REF(sv) = coderef ; + + SvCUR_set(sv, 0) ; + + } + +void +filter_del() + CODE: + FILTER_ACTIVE(FILTER_DATA(IDX)) = FALSE ; + + + +void +unimport(...) + PPCODE: + filter_del(filter_call); + + +BOOT: + /* temporary hack to control debugging in toke.c */ + if (fdebug) + filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0"); + + diff --git a/ext/Filter/Util/Call/Makefile.PL b/ext/Filter/Util/Call/Makefile.PL new file mode 100644 index 0000000..030dbc2 --- /dev/null +++ b/ext/Filter/Util/Call/Makefile.PL @@ -0,0 +1,7 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Filter::Util::Call', + VERSION_FROM => 'Call.pm', + MAN3PODS => {}, # Pods will be built by installman. +); diff --git a/ext/GDBM_File/GDBM_File.pm b/ext/GDBM_File/GDBM_File.pm index ab866ee..fe87dd0 100644 --- a/ext/GDBM_File/GDBM_File.pm +++ b/ext/GDBM_File/GDBM_File.pm @@ -59,7 +59,7 @@ use XSLoader (); GDBM_WRITER ); -$VERSION = "1.03"; +$VERSION = "1.04"; sub AUTOLOAD { my($constname); diff --git a/ext/GDBM_File/GDBM_File.xs b/ext/GDBM_File/GDBM_File.xs index 13123ef..b4d3b3d 100644 --- a/ext/GDBM_File/GDBM_File.xs +++ b/ext/GDBM_File/GDBM_File.xs @@ -56,7 +56,7 @@ not_here(char *s) static void output_datum(pTHX_ SV *arg, char *str, int size) { -#if !defined(MYMALLOC) || (defined(MYMALLOC) && defined(PERL_POLLUTE_MALLOC) && !defined(LEAKTEST)) +#if (!defined(MYMALLOC) || (defined(MYMALLOC) && defined(PERL_POLLUTE_MALLOC))) && !defined(LEAKTEST) sv_usepvn(arg, str, size); #else sv_setpvn(arg, str, size); diff --git a/ext/GDBM_File/typemap b/ext/GDBM_File/typemap index 4f79ae3..1dd0630 100644 --- a/ext/GDBM_File/typemap +++ b/ext/GDBM_File/typemap @@ -19,8 +19,14 @@ T_DATUM_K $var.dsize = (int)PL_na; T_DATUM_V ckFilter($arg, filter_store_value, \"filter_store_value\"); - $var.dptr = SvPV($arg, PL_na); - $var.dsize = (int)PL_na; + if (SvOK($arg)) { + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; + } + else { + $var.dptr = \"\"; + $var.dsize = 0; + } OUTPUT T_DATUM_K output_datum(aTHX_ $arg, $var.dptr, $var.dsize); diff --git a/ext/IO/IO.xs b/ext/IO/IO.xs index 1b79cfd..13b198c 100644 --- a/ext/IO/IO.xs +++ b/ext/IO/IO.xs @@ -59,9 +59,9 @@ io_blocking(InputStream f, int block) if (RETVAL >= 0) { int mode = RETVAL; #ifdef O_NONBLOCK - /* POSIX style */ + /* POSIX style */ #if defined(O_NDELAY) && O_NDELAY != O_NONBLOCK - /* Ooops has O_NDELAY too - make sure we don't + /* Ooops has O_NDELAY too - make sure we don't * get SysV behaviour by mistake. */ /* E.g. In UNICOS and UNICOS/mk a F_GETFL returns an O_NDELAY @@ -86,7 +86,7 @@ io_blocking(InputStream f, int block) } } #else - /* Standard POSIX */ + /* Standard POSIX */ RETVAL = RETVAL & O_NONBLOCK ? 0 : 1; if ((block == 0) && !(mode & O_NONBLOCK)) { @@ -103,11 +103,11 @@ io_blocking(InputStream f, int block) if(ret < 0) RETVAL = ret; } -#endif +#endif #else /* Not POSIX - better have O_NDELAY or we can't cope. * for BSD-ish machines this is an acceptable alternative - * for SysV we can't tell "would block" from EOF but that is + * for SysV we can't tell "would block" from EOF but that is * the way SysV is... */ RETVAL = RETVAL & O_NDELAY ? 0 : 1; @@ -141,13 +141,18 @@ fgetpos(handle) InputStream handle CODE: if (handle) { - Fpos_t pos; #ifdef PerlIO - PerlIO_getpos(handle, &pos); + ST(0) = sv_2mortal(newSV(0)); + if (PerlIO_getpos(handle, ST(0)) != 0) { + ST(0) = &PL_sv_undef; + } #else - fgetpos(handle, &pos); + if (fgetpos(handle, &pos)) { + ST(0) = &PL_sv_undef; + } else { + ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); + } #endif - ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); } else { ST(0) = &PL_sv_undef; @@ -159,14 +164,21 @@ fsetpos(handle, pos) InputStream handle SV * pos CODE: - char *p; - STRLEN len; - if (handle && (p = SvPV(pos,len)) && len == sizeof(Fpos_t)) + if (handle) { #ifdef PerlIO - RETVAL = PerlIO_setpos(handle, (Fpos_t*)p); + RETVAL = PerlIO_setpos(handle, pos); #else - RETVAL = fsetpos(handle, (Fpos_t*)p); + char *p; + STRLEN len; + if ((p = SvPV(pos,len)) && len == sizeof(Fpos_t)) { + RETVAL = fsetpos(handle, (Fpos_t*)p); + } + else { + RETVAL = -1; + errno = EINVAL; + } #endif + } else { RETVAL = -1; errno = EINVAL; @@ -202,7 +214,7 @@ new_tmpfile(packname = "IO::File") MODULE = IO PACKAGE = IO::Poll -void +void _poll(timeout,...) int timeout; PPCODE: diff --git a/ext/IO/lib/IO/Handle.pm b/ext/IO/lib/IO/Handle.pm index b6cb410..fb754a6 100644 --- a/ext/IO/lib/IO/Handle.pm +++ b/ext/IO/lib/IO/Handle.pm @@ -110,7 +110,8 @@ or a file descriptor number. =item $io->opened -Returns true if the object is currently a valid file descriptor. +Returns true if the object is currently a valid file descriptor, false +otherwise. =item $io->getline @@ -139,31 +140,37 @@ called C. =item $io->error Returns a true value if the given handle has experienced any errors -since it was opened or since the last call to C. +since it was opened or since the last call to C, or if the +handle is invalid. It only returns false for a valid handle with no +outstanding errors. =item $io->clearerr -Clear the given handle's error indicator. +Clear the given handle's error indicator. Returns -1 if the handle is +invalid, 0 otherwise. =item $io->sync C synchronizes a file's in-memory state with that on the physical medium. C does not operate at the perlio api level, but -operates on the file descriptor, this means that any data held at the -perlio api level will not be synchronized. To synchronize data that is -buffered at the perlio api level you must use the flush method. C -is not implemented on all platforms. See L. +operates on the file descriptor (similar to sysread, sysseek and +systell). This means that any data held at the perlio api level will not +be synchronized. To synchronize data that is buffered at the perlio api +level you must use the flush method. C is not implemented on all +platforms. Returns "0 but true" on success, C on error, C +for an invalid handle. See L. =item $io->flush C causes perl to flush any buffered data at the perlio api level. Any unread data in the buffer will be discarded, and any unwritten data -will be written to the underlying file descriptor. +will be written to the underlying file descriptor. Returns "0 but true" +on success, C on error. =item $io->printflush ( ARGS ) Turns on autoflush, print ARGS and then restores the autoflush status of the -C object. +C object. Returns the return value from print. =item $io->blocking ( [ BOOL ] ) @@ -183,11 +190,18 @@ C and C set the buffering policy for an IO::Handle. The calling sequences for the Perl functions are the same as their C counterparts--including the constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter -specifies a scalar variable to use as a buffer. WARNING: A variable -used as a buffer by C or C must not be modified in any -way until the IO::Handle is closed or C or C is called -again, or memory corruption may result! Note that you need to import -the constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. +specifies a scalar variable to use as a buffer. You should only +change the buffer before any I/O, or immediately after calling flush. + +WARNING: A variable used as a buffer by C or C B in any way until the IO::Handle is closed or C or +C is called again, or memory corruption may result! Remember that +the order of global destruction is undefined, so even if your buffer +variable remains in scope until program termination, it may be undefined +before the file IO::Handle is closed. Note that you need to import the +constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Like C, setbuf +returns nothing. setvbuf returns "0 but true", on success, C on +failure. Lastly, there is a special method for working under B<-T> and setuid/gid scripts: @@ -199,7 +213,8 @@ scripts: Marks the object as taint-clean, and as such data read from it will also be considered taint-clean. Note that this is a very trusting action to take, and appropriate consideration for the data source and potential -vulnerability should be kept in mind. +vulnerability should be kept in mind. Returns 0 on success, -1 if setting +the taint-clean flag failed. (eg invalid handle) =back diff --git a/ext/IO/lib/IO/Seekable.pm b/ext/IO/lib/IO/Seekable.pm index e09d48b..243a971 100644 --- a/ext/IO/lib/IO/Seekable.pm +++ b/ext/IO/lib/IO/Seekable.pm @@ -18,19 +18,69 @@ C does not have a constructor of its own as it is intended to be inherited by other C based objects. It provides methods which allow seeking of the file descriptors. -If the C functions fgetpos() and fsetpos() are available, then -C<$io-Egetpos> returns an opaque value that represents the -current position of the IO::File, and C<$io-Esetpos(POS)> uses -that value to return to a previously visited position. +=over 4 +=item $io->getpos + +Returns an opaque value that represents the current position of the +IO::File, or C if this is not possible (eg an unseekable stream such +as a terminal, pipe or socket). If the fgetpos() function is available in +your C library it is used to implements getpos, else perl emulates getpos +using C's ftell() function. + +=item $io->setpos + +Uses the value of a previous getpos call to return to a previously visited +position. Returns "0 but true" on success, C on failure. + +=back + See L for complete descriptions of each of the following supported C methods, which are just front ends for the corresponding built-in functions: - $io->seek( POS, WHENCE ) - $io->sysseek( POS, WHENCE ) - $io->tell +=over 4 + +=item $io->setpos ( POS, WHENCE ) + +Seek the IO::File to position POS, relative to WHENCE: + +=over 8 + +=item WHENCE=0 (SEEK_SET) + +POS is absolute position. (Seek relative to the start of the file) + +=item WHENCE=1 (SEEK_CUR) + +POS is an offset from the current position. (Seek relative to current) + +=item WHENCE=1 (SEEK_END) + +POS is an offset from the end of the file. (Seek relative to end) + +=back + +The SEEK_* constants can be imported from the C module if you +don't wish to use the numbers C<0> C<1> or C<2> in your code. + +Returns C<1> upon success, C<0> otherwise. + +=item $io->sysseek( POS, WHENCE ) + +Similar to $io->seek, but sets the IO::File's position using the system +call lseek(2) directly, so will confuse most perl IO operators except +sysread and syswrite (see L for full details) + +Returns the new position, or C on failure. A position +of zero is returned as the string C<"0 but true"> + +=item $io->tell + +Returns the IO::File's current position, or -1 on error. +=back + =head1 SEE ALSO L, diff --git a/ext/IO/lib/IO/Select.pm b/ext/IO/lib/IO/Select.pm index e84b54f..1a3a26f 100644 --- a/ext/IO/lib/IO/Select.pm +++ b/ext/IO/lib/IO/Select.pm @@ -56,6 +56,7 @@ sub exists sub _fileno { my($self, $f) = @_; + return unless defined $f; $f = $f->[0] if ref($f) eq 'ARRAY'; ($f =~ /^\d+$/) ? $f : fileno($f); } diff --git a/ext/IPC/SysV/SysV.xs b/ext/IPC/SysV/SysV.xs index 38062e0..4a10eb9 100644 --- a/ext/IPC/SysV/SysV.xs +++ b/ext/IPC/SysV/SysV.xs @@ -203,7 +203,7 @@ ftok(path, id) key_t k = ftok(path, id); ST(0) = k == (key_t) -1 ? &PL_sv_undef : sv_2mortal(newSViv(k)); #else - DIE(PL_no_func, "ftok"); + DIE(aTHX_ PL_no_func, "ftok"); #endif int diff --git a/ext/NDBM_File/NDBM_File.pm b/ext/NDBM_File/NDBM_File.pm index c9ef699..99aae17 100644 --- a/ext/NDBM_File/NDBM_File.pm +++ b/ext/NDBM_File/NDBM_File.pm @@ -10,7 +10,7 @@ require Tie::Hash; use XSLoader (); our @ISA = qw(Tie::Hash); -our $VERSION = "1.03"; +our $VERSION = "1.04"; XSLoader::load 'NDBM_File', $VERSION; diff --git a/ext/NDBM_File/NDBM_File.xs b/ext/NDBM_File/NDBM_File.xs index 49a1db5..c417eb6 100644 --- a/ext/NDBM_File/NDBM_File.xs +++ b/ext/NDBM_File/NDBM_File.xs @@ -1,6 +1,11 @@ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +/* If using the DB3 emulation, ENTER is defined both + * by DB3 and Perl. We drop the Perl definition now. + * See also INSTALL section on DB3. + * -- Stanislav Brabec */ +#undef ENTER #include typedef struct { diff --git a/ext/NDBM_File/typemap b/ext/NDBM_File/typemap index eeb5d59..40b95f2 100644 --- a/ext/NDBM_File/typemap +++ b/ext/NDBM_File/typemap @@ -20,8 +20,14 @@ T_DATUM_K $var.dsize = (int)PL_na; T_DATUM_V ckFilter($arg, filter_store_value, \"filter_store_value\"); - $var.dptr = SvPV($arg, PL_na); - $var.dsize = (int)PL_na; + if (SvOK($arg)) { + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; + } + else { + $var.dptr = \"\"; + $var.dsize = 0; + } T_GDATUM UNIMPLEMENTED OUTPUT diff --git a/ext/ODBM_File/ODBM_File.pm b/ext/ODBM_File/ODBM_File.pm index 732ed60..4244eb9 100644 --- a/ext/ODBM_File/ODBM_File.pm +++ b/ext/ODBM_File/ODBM_File.pm @@ -6,7 +6,7 @@ require Tie::Hash; use XSLoader (); our @ISA = qw(Tie::Hash); -our $VERSION = "1.02"; +our $VERSION = "1.03"; XSLoader::load 'ODBM_File', $VERSION; diff --git a/ext/ODBM_File/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs index 150f2ef..27174ef 100644 --- a/ext/ODBM_File/ODBM_File.xs +++ b/ext/ODBM_File/ODBM_File.xs @@ -3,6 +3,11 @@ #include "XSUB.h" #ifdef I_DBM +/* If using the DB3 emulation, ENTER is defined both + * by DB3 and Perl. We drop the Perl definition now. + * See also INSTALL section on DB3. + * -- Stanislav Brabec */ +# undef ENTER # include #else # ifdef I_RPCSVC_DBM diff --git a/ext/ODBM_File/typemap b/ext/ODBM_File/typemap index 7c23815..096427e 100644 --- a/ext/ODBM_File/typemap +++ b/ext/ODBM_File/typemap @@ -20,8 +20,14 @@ T_DATUM_K $var.dsize = (int)PL_na; T_DATUM_V ckFilter($arg, filter_store_value, \"filter_store_value\"); - $var.dptr = SvPV($arg, PL_na); - $var.dsize = (int)PL_na; + if (SvOK($arg)) { + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; + } + else { + $var.dptr = \"\"; + $var.dsize = 0; + } T_GDATUM UNIMPLEMENTED OUTPUT diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index 841120c..6a5e30d 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -2,18 +2,19 @@ package Opcode; require 5.005_64; +use strict; + our($VERSION, $XS_VERSION, @ISA, @EXPORT_OK); $VERSION = "1.04"; $XS_VERSION = "1.03"; -use strict; use Carp; use Exporter (); use XSLoader (); -@ISA = qw(Exporter); BEGIN { + @ISA = qw(Exporter); @EXPORT_OK = qw( opset ops_to_opset opset_to_ops opset_to_hex invert_opset diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs index e191ec7..04f7c3f 100644 --- a/ext/Opcode/Opcode.xs +++ b/ext/Opcode/Opcode.xs @@ -253,6 +253,12 @@ PPCODE: save_hptr(&PL_defstash); /* save current default stash */ /* the assignment to global defstash changes our sense of 'main' */ PL_defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already */ + if (strNE(HvNAME(PL_defstash),"main")) { + Safefree(HvNAME(PL_defstash)); + HvNAME(PL_defstash) = savepv("main"); /* make it think it's in main:: */ + hv_store(PL_defstash,"_",1,(SV *)PL_defgv,0); /* connect _ to global */ + SvREFCNT_inc((SV *)PL_defgv); /* want to keep _ around! */ + } save_hptr(&PL_curstash); PL_curstash = PL_defstash; diff --git a/ext/POSIX/Makefile.PL b/ext/POSIX/Makefile.PL index 55c5c1f..73bb02d 100644 --- a/ext/POSIX/Makefile.PL +++ b/ext/POSIX/Makefile.PL @@ -2,12 +2,7 @@ use ExtUtils::MakeMaker; use Config; my @libs; if ($^O ne 'MSWin32') { - if ($Config{archname} =~ /RM\d\d\d-svr4/) { - @libs = ('LIBS' => ["-lm -lc -lposix -lcposix"]); - } - else { - @libs = ('LIBS' => ["-lm -lposix -lcposix"]); - } + @libs = ('LIBS' => ["-lm -lposix -lcposix"]); } WriteMakefile( NAME => 'POSIX', diff --git a/ext/POSIX/POSIX.pm b/ext/POSIX/POSIX.pm index 252e5bb..e1e6b28 100644 --- a/ext/POSIX/POSIX.pm +++ b/ext/POSIX/POSIX.pm @@ -734,16 +734,6 @@ sub setbuf { redef "IO::Handle::setbuf()"; } -sub setgid { - usage "setgid(gid)" if @_ != 1; - $( = $_[0]; -} - -sub setuid { - usage "setuid(uid)" if @_ != 1; - $< = $_[0]; -} - sub setvbuf { redef "IO::Handle::setvbuf()"; } diff --git a/ext/POSIX/POSIX.pod b/ext/POSIX/POSIX.pod index 314147c..10199e9 100644 --- a/ext/POSIX/POSIX.pod +++ b/ext/POSIX/POSIX.pod @@ -1008,9 +1008,12 @@ see L. =item setgid -Sets the real group identifier for this process. -Identical to assigning a value to the Perl's builtin C<$)> variable, -see L. +Sets the real group identifier and the effective group identifier for +this process. Similar to assigning a value to the Perl's builtin +C<$)> variable, see L, except that the latter +will change only the real user identifier, and that the setgid() +uses only a single numeric argument, as opposed to a space-separated +list of numbers. =item setjmp @@ -1063,9 +1066,10 @@ setting the session identifier of the current process. =item setuid -Sets the real user identifier for this process. -Identical to assigning a value to the Perl's builtin C<$E> variable, -see L. +Sets the real user identifier and the effective user identifier for +this process. Similar to assigning a value to the Perl's builtin +C<$E> variable, see L, except that the latter +will change only the real user identifier. =item sigaction @@ -1434,7 +1438,9 @@ Returns a name for a temporary file. $tmpfile = POSIX::tmpnam(); -See also L. +For security reasons, which are probably detailed in your system's +documentation for the C library tmpnam() function, this interface +should not be used; instead see L. =item tolower diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index a536671..887fcbc 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -3940,6 +3940,14 @@ pathconf(filename, name) SysRet pause() +SysRet +setgid(gid) + Gid_t gid + +SysRet +setuid(uid) + Uid_t uid + SysRetLong sysconf(name) int name @@ -3947,3 +3955,4 @@ sysconf(name) char * ttyname(fd) int fd + diff --git a/ext/POSIX/hints/svr4.pl b/ext/POSIX/hints/svr4.pl new file mode 100644 index 0000000..07f2cb0 --- /dev/null +++ b/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/ext/POSIX/typemap b/ext/POSIX/typemap index baf9bfc..d54d5d1 100644 --- a/ext/POSIX/typemap +++ b/ext/POSIX/typemap @@ -3,6 +3,7 @@ pid_t T_NV Uid_t T_NV Time_t T_NV Gid_t T_NV +Uid_t T_NV Off_t T_NV Dev_t T_NV NV T_NV diff --git a/ext/SDBM_File/Makefile.PL b/ext/SDBM_File/Makefile.PL index a1debb9..132bdad 100644 --- a/ext/SDBM_File/Makefile.PL +++ b/ext/SDBM_File/Makefile.PL @@ -1,4 +1,5 @@ use ExtUtils::MakeMaker; +use Config; # The existence of the ./sdbm/Makefile.PL file causes MakeMaker # to automatically include Makefile code for the targets @@ -21,18 +22,26 @@ WriteMakefile( sub MY::postamble { if ($^O =~ /MSWin32/ && Win32::IsWin95()) { - # XXX: dmake-specific, like rest of Win95 port - return - ' + if ($Config{'make'} =~ /dmake/i) { + # dmake-specific + return <pagbuf; char *New = twin; register int smax = SPLTMAX; @@ -305,6 +309,23 @@ makroom(register DBM *db, long int hash, int need) * still looking at the page of interest. current page is not updated * here, as sdbm_store will do so, after it inserts the incoming pair. */ + +#if defined(DOSISH) || defined(WIN32) + /* + * Fill hole with 0 if made it. + * (hole is NOT read as 0) + */ + oldtail = lseek(db->pagf, 0L, SEEK_END); + memset(zer, 0, PBLKSIZ); + while (OFF_PAG(newp) > oldtail) { + if (lseek(db->pagf, 0L, SEEK_END) < 0 || + write(db->pagf, zer, PBLKSIZ) < 0) { + + return 0; + } + oldtail += PBLKSIZ; + } +#endif if (hash & (db->hmask + 1)) { if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) diff --git a/ext/SDBM_File/typemap b/ext/SDBM_File/typemap index eeb5d59..40b95f2 100644 --- a/ext/SDBM_File/typemap +++ b/ext/SDBM_File/typemap @@ -20,8 +20,14 @@ T_DATUM_K $var.dsize = (int)PL_na; T_DATUM_V ckFilter($arg, filter_store_value, \"filter_store_value\"); - $var.dptr = SvPV($arg, PL_na); - $var.dsize = (int)PL_na; + if (SvOK($arg)) { + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; + } + else { + $var.dptr = \"\"; + $var.dsize = 0; + } T_GDATUM UNIMPLEMENTED OUTPUT diff --git a/ext/Storable/ChangeLog b/ext/Storable/ChangeLog index 049ce29..92789b5 100644 --- a/ext/Storable/ChangeLog +++ b/ext/Storable/ChangeLog @@ -1,3 +1,50 @@ +Wed Jan 3 10:43:18 MET 2001 Raphael Manfredi + +. Description: + + Removed spurious 'clean' entry in Makefile.PL. + + Added CAN_FLOCK to determine whether we can flock() or not, + by inspecting Perl's configuration parameters, as determined + by Configure. + + Trace offending package when overloading cannot be restored + on a scalar. + + Made context cleanup safer to avoid dup freeing, mostly in the + presence of repeated exceptions during store/retrieve (which can + cause memory leaks anyway, so it's just additional safety, not a + definite fix). + +Sun Nov 5 18:23:48 MET 2000 Raphael Manfredi + +. Description: + + Version 1.0.6. + + Fixed severe "object lost" bug for STORABLE_freeze returns, + when refs to lexicals, taken within the hook, were to be + serialized by Storable. Enhanced the t/recurse.t test to + stress hook a little more with refs to lexicals. + +Thu Oct 26 19:14:38 MEST 2000 Raphael Manfredi + +. Description: + + Version 1.0.5. + + Documented that store() and retrieve() can return undef. + That is, the error reporting is not always made via exceptions, + as the paragraph on error reporting was implying. + + Auto requires module of blessed ref when STORABLE_thaw misses. + When the Storable engine looks for the STORABLE_thaw hook and + does not find it, it now tries to require the package into which + the blessed reference is. + + Just check $^O, in t/lock.t: there's no need to pull the whole + Config module for that. + Fri Sep 29 21:52:29 MEST 2000 Raphael Manfredi . Description: diff --git a/ext/Storable/Makefile.PL b/ext/Storable/Makefile.PL index 7ed71e6..c8151f3 100644 --- a/ext/Storable/Makefile.PL +++ b/ext/Storable/Makefile.PL @@ -1,4 +1,4 @@ -# $Id: Makefile.PL,v 1.0 2000/09/01 19:40:41 ram Exp $ +# $Id: Makefile.PL,v 1.0.1.1 2001/01/03 09:38:39 ram Exp $ # # Copyright (c) 1995-2000, Raphael Manfredi # @@ -6,6 +6,9 @@ # in the README file that comes with the distribution. # # $Log: Makefile.PL,v $ +# Revision 1.0.1.1 2001/01/03 09:38:39 ram +# patch7: removed spurious 'clean' entry +# # Revision 1.0 2000/09/01 19:40:41 ram # Baseline for first official release. # @@ -19,6 +22,5 @@ WriteMakefile( 'MAN3PODS' => {}, 'VERSION_FROM' => 'Storable.pm', 'dist' => { SUFFIX => 'gz', COMPRESS => 'gzip -f' }, - 'clean' => {'FILES' => '*%'}, ); diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm index 76c3209..06c05d4 100644 --- a/ext/Storable/Storable.pm +++ b/ext/Storable/Storable.pm @@ -1,4 +1,4 @@ -;# $Id: Storable.pm,v 1.0 2000/09/01 19:40:41 ram Exp $ +;# $Id: Storable.pm,v 1.0.1.7 2001/01/03 09:39:02 ram Exp $ ;# ;# Copyright (c) 1995-2000, Raphael Manfredi ;# @@ -6,6 +6,21 @@ ;# in the README file that comes with the distribution. ;# ;# $Log: Storable.pm,v $ +;# Revision 1.0.1.7 2001/01/03 09:39:02 ram +;# patch7: added CAN_FLOCK to determine whether we can flock() or not +;# +;# Revision 1.0.1.6 2000/11/05 17:20:25 ram +;# patch6: increased version number +;# +;# Revision 1.0.1.5 2000/10/26 17:10:18 ram +;# patch5: documented that store() and retrieve() can return undef +;# patch5: added paragraph explaining the auto require for thaw hooks +;# +;# Revision 1.0.1.4 2000/10/23 18:02:57 ram +;# patch4: protected calls to flock() for dos platform +;# patch4: added logcarp emulation if they don't have Log::Agent +;# +;# $Log: Storable.pm,v $ ;# Revision 1.0 2000/09/01 19:40:41 ram ;# Baseline for first official release. ;# @@ -26,7 +41,7 @@ package Storable; @ISA = qw(Exporter DynaLoader); use AutoLoader; use vars qw($forgive_me $VERSION); -$VERSION = '1.003'; +$VERSION = '1.007'; *AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr... # @@ -41,6 +56,10 @@ unless (defined @Log::Agent::EXPORT) { require Carp; Carp::croak(@_); } + sub logcarp { + require Carp; + Carp::carp(@_); + } }; } @@ -61,9 +80,25 @@ BEGIN { } sub logcroak; +sub logcarp; sub retrieve_fd { &fd_retrieve } # Backward compatibility +# +# Determine whether locking is possible, but only when needed. +# + +my $CAN_FLOCK; + +sub CAN_FLOCK { + return $CAN_FLOCK if defined $CAN_FLOCK; + require Config; import Config; + return $CAN_FLOCK = + $Config{'d_flock'} || + $Config{'d_fcntl_can_lock'} || + $Config{'d_lockf'}; +} + bootstrap Storable; 1; __END__ @@ -118,6 +153,10 @@ sub _store { open(FILE, ">$file") || logcroak "can't create $file: $!"; binmode FILE; # Archaic systems... if ($use_locking) { + unless (&CAN_FLOCK) { + logcarp "Storable::lock_store: fcntl/flock emulation broken on $^O"; + return undef; + } flock(FILE, LOCK_EX) || logcroak "can't get exclusive lock on $file: $!"; truncate FILE, 0; @@ -234,7 +273,12 @@ sub _retrieve { my $self; my $da = $@; # Could be from exception handler if ($use_locking) { - flock(FILE, LOCK_SH) || logcroak "can't get shared lock on $file: $!"; + unless (&CAN_FLOCK) { + logcarp "Storable::lock_retrieve: fcntl/flock emulation broken on $^O"; + return undef; + } + flock(FILE, LOCK_SH) || + logcroak "can't get shared lock on $file: $!"; # Unlocking will happen when FILE is closed } eval { $self = pretrieve(*FILE) }; # Call C routine @@ -435,6 +479,9 @@ those exceptions. When Storable croaks, it tries to report the error via the C routine from the C package, if it is available. +Normal errors are reported by having store() or retrieve() return C. +Such errors are usually I/O errors (or truncated stream errors at retrieval). + =head1 WIZARDS ONLY =head2 Hooks @@ -514,6 +561,13 @@ and there may be an optional list of references, in the same order you gave them at serialization time, pointing to the deserialized objects (which have been processed courtesy of the Storable engine). +When the Storable engine does not find any C hook routine, +it tries to load the class by requiring the package dynamically (using +the blessed package name), and then re-attempts the lookup. If at that +time the hook cannot be located, the engine croaks. Note that this mechanism +will fail if you define several classes in the same file, but perlmod(1) +warned you. + It is up to you to use these information to populate I the way you want. Returned value: none. diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index 1c412b5..9378001 100644 --- a/ext/Storable/Storable.xs +++ b/ext/Storable/Storable.xs @@ -3,7 +3,7 @@ */ /* - * $Id: Storable.xs,v 1.0 2000/09/01 19:40:41 ram Exp $ + * $Id: Storable.xs,v 1.0.1.6 2001/01/03 09:40:40 ram Exp $ * * Copyright (c) 1995-2000, Raphael Manfredi * @@ -11,6 +11,21 @@ * in the README file that comes with the distribution. * * $Log: Storable.xs,v $ + * Revision 1.0.1.6 2001/01/03 09:40:40 ram + * patch7: prototype and casting cleanup + * patch7: trace offending package when overloading cannot be restored + * patch7: made context cleanup safer to avoid dup freeing + * + * Revision 1.0.1.5 2000/11/05 17:21:24 ram + * patch6: fixed severe "object lost" bug for STORABLE_freeze returns + * + * Revision 1.0.1.4 2000/10/26 17:11:04 ram + * patch5: auto requires module of blessed ref when STORABLE_thaw misses + * + * Revision 1.0.1.3 2000/09/29 19:49:57 ram + * patch3: avoid using "tainted" and "dirty" since Perl remaps them via cpp + * + * $Log: Storable.xs,v $ * Revision 1.0 2000/09/01 19:40:41 ram * Baseline for first official release. * @@ -87,14 +102,21 @@ typedef double NV; /* Older perls lack the NV type */ #endif #ifdef DEBUGME -#ifndef DASSERT -#define DASSERT -#endif -#define TRACEME(x) do { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } while (0) +/* + * TRACEME() will only output things when the $Storable::DEBUGME is true. + */ + +#define TRACEME(x) do { \ + if (SvTRUE(perl_get_sv("Storable::DEBUGME", TRUE))) \ + { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \ +} while (0) #else #define TRACEME(x) #endif +#ifndef DASSERT +#define DASSERT +#endif #ifdef DASSERT #define ASSERT(x,y) do { \ if (!(x)) { \ @@ -235,6 +257,7 @@ typedef struct stcxt { int entry; /* flags recursion */ int optype; /* type of traversal operation */ HV *hseen; /* which objects have been seen, store time */ + AV *hook_seen; /* which SVs were returned by STORABLE_freeze() */ AV *aseen; /* which objects have been seen, retrieve time */ HV *hclass; /* which classnames have been seen, store time */ AV *aclass; /* which classnames have been seen, retrieve time */ @@ -652,7 +675,7 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ #define GETMARK(x) do { \ if (!cxt->fio) \ MBUF_GETC(x); \ - else if ((x = PerlIO_getc(cxt->fio)) == EOF) \ + else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF) \ return (SV *) 0; \ } while (0) @@ -740,14 +763,14 @@ static int store_tied_item(stcxt_t *cxt, SV *sv); static int store_other(stcxt_t *cxt, SV *sv); static int store_blessed(stcxt_t *cxt, SV *sv, int type, HV *pkg); -static int (*sv_store[])() = { - store_ref, /* svis_REF */ - store_scalar, /* svis_SCALAR */ - store_array, /* svis_ARRAY */ - store_hash, /* svis_HASH */ - store_tied, /* svis_TIED */ - store_tied_item, /* svis_TIED_ITEM */ - store_other, /* svis_OTHER */ +static int (*sv_store[])(stcxt_t *cxt, SV *sv) = { + store_ref, /* svis_REF */ + store_scalar, /* svis_SCALAR */ + (int (*)(stcxt_t *cxt, SV *sv)) store_array, /* svis_ARRAY */ + (int (*)(stcxt_t *cxt, SV *sv)) store_hash, /* svis_HASH */ + store_tied, /* svis_TIED */ + store_tied_item, /* svis_TIED_ITEM */ + store_other, /* svis_OTHER */ }; #define SV_STORE(x) (*sv_store[x]) @@ -773,7 +796,7 @@ static SV *retrieve_tied_hash(stcxt_t *cxt); static SV *retrieve_tied_scalar(stcxt_t *cxt); static SV *retrieve_other(stcxt_t *cxt); -static SV *(*sv_old_retrieve[])() = { +static SV *(*sv_old_retrieve[])(stcxt_t *cxt) = { 0, /* SX_OBJECT -- entry unused dynamically */ retrieve_lscalar, /* SX_LSCALAR */ old_retrieve_array, /* SX_ARRAY -- for pre-0.6 binaries */ @@ -814,7 +837,7 @@ static SV *retrieve_overloaded(stcxt_t *cxt); static SV *retrieve_tied_key(stcxt_t *cxt); static SV *retrieve_tied_idx(stcxt_t *cxt); -static SV *(*sv_retrieve[])() = { +static SV *(*sv_retrieve[])(stcxt_t *cxt) = { 0, /* SX_OBJECT -- entry unused dynamically */ retrieve_lscalar, /* SX_LSCALAR */ retrieve_array, /* SX_ARRAY */ @@ -946,6 +969,15 @@ static void init_store_context( */ cxt->hook = newHV(); /* Table where hooks are cached */ + + /* + * The `hook_seen' array keeps track of all the SVs returned by + * STORABLE_freeze hooks for us to serialize, so that they are not + * reclaimed until the end of the serialization process. Each SV is + * only stored once, the first time it is seen. + */ + + cxt->hook_seen = newAV(); /* Lists SVs returned by STORABLE_freeze */ } /* @@ -975,16 +1007,41 @@ static void clean_store_context(stcxt_t *cxt) /* * And now dispose of them... + * + * The surrounding if() protection has been added because there might be + * some cases where this routine is called more than once, during + * exceptionnal events. This was reported by Marc Lehmann when Storable + * is executed from mod_perl, and the fix was suggested by him. + * -- RAM, 20/12/2000 */ - hv_undef(cxt->hseen); - sv_free((SV *) cxt->hseen); + if (cxt->hseen) { + HV *hseen = cxt->hseen; + cxt->hseen = 0; + hv_undef(hseen); + sv_free((SV *) hseen); + } + + if (cxt->hclass) { + HV *hclass = cxt->hclass; + cxt->hclass = 0; + hv_undef(hclass); + sv_free((SV *) hclass); + } - hv_undef(cxt->hclass); - sv_free((SV *) cxt->hclass); + if (cxt->hook) { + HV *hook = cxt->hook; + cxt->hook = 0; + hv_undef(hook); + sv_free((SV *) hook); + } - hv_undef(cxt->hook); - sv_free((SV *) cxt->hook); + if (cxt->hook_seen) { + AV *hook_seen = cxt->hook_seen; + cxt->hook_seen = 0; + av_undef(hook_seen); + sv_free((SV *) hook_seen); + } cxt->entry = 0; cxt->s_dirty = 0; @@ -1039,17 +1096,33 @@ static void clean_retrieve_context(stcxt_t *cxt) ASSERT(cxt->optype & ST_RETRIEVE, ("was performing a retrieve()")); - av_undef(cxt->aseen); - sv_free((SV *) cxt->aseen); + if (cxt->aseen) { + AV *aseen = cxt->aseen; + cxt->aseen = 0; + av_undef(aseen); + sv_free((SV *) aseen); + } - av_undef(cxt->aclass); - sv_free((SV *) cxt->aclass); + if (cxt->aclass) { + AV *aclass = cxt->aclass; + cxt->aclass = 0; + av_undef(aclass); + sv_free((SV *) aclass); + } - hv_undef(cxt->hook); - sv_free((SV *) cxt->hook); + if (cxt->hook) { + HV *hook = cxt->hook; + cxt->hook = 0; + hv_undef(hook); + sv_free((SV *) hook); + } - if (cxt->hseen) - sv_free((SV *) cxt->hseen); /* optional HV, for backward compat. */ + if (cxt->hseen) { + HV *hseen = cxt->hseen; + cxt->hseen = 0; + hv_undef(hseen); + sv_free((SV *) hseen); /* optional HV, for backward compat. */ + } cxt->entry = 0; cxt->s_dirty = 0; @@ -1071,6 +1144,8 @@ stcxt_t *cxt; clean_retrieve_context(cxt); else clean_store_context(cxt); + + ASSERT(!cxt->s_dirty, ("context is clean")); } /* @@ -1223,6 +1298,19 @@ static void pkg_hide( } /* + * pkg_uncache + * + * Discard cached value: a whole fetch loop will be retried at next lookup. + */ +static void pkg_uncache( + HV *cache, + HV *pkg, + char *method) +{ + (void) hv_delete(cache, HvNAME(pkg), strlen(HvNAME(pkg)), G_DISCARD); +} + +/* * pkg_can * * Our own "UNIVERSAL::can", which caches results. @@ -2096,11 +2184,14 @@ static int store_hook( for (i = 1; i < count; i++) { SV **svh; - SV *xsv = ary[i]; + SV *rsv = ary[i]; + SV *xsv; + AV *av_hook = cxt->hook_seen; - if (!SvROK(xsv)) - CROAK(("Item #%d from hook in %s is not a reference", i, class)); - xsv = SvRV(xsv); /* Follow ref to know what to look for */ + if (!SvROK(rsv)) + CROAK(("Item #%d returned by STORABLE_freeze " + "for %s is not a reference", i, class)); + xsv = SvRV(rsv); /* Follow ref to know what to look for */ /* * Look in hseen and see if we have a tag already. @@ -2136,11 +2227,34 @@ static int store_hook( CROAK(("Could not serialize item #%d from hook in %s", i, class)); /* - * Replace entry with its tag (not a real SV, so no refcnt increment) + * It was the first time we serialized `xsv'. + * + * Keep this SV alive until the end of the serialization: if we + * disposed of it right now by decrementing its refcount, and it was + * a temporary value, some next temporary value allocated during + * another STORABLE_freeze might take its place, and we'd wrongly + * assume that new SV was already serialized, based on its presence + * in cxt->hseen. + * + * Therefore, push it away in cxt->hook_seen. */ + av_store(av_hook, AvFILLp(av_hook)+1, SvREFCNT_inc(xsv)); + sv_seen: - SvREFCNT_dec(xsv); + /* + * Dispose of the REF they returned. If we saved the `xsv' away + * in the array of returned SVs, that will not cause the underlying + * referenced SV to be reclaimed. + */ + + ASSERT(SvREFCNT(xsv) > 1, ("SV will survive disposal of its REF")); + SvREFCNT_dec(rsv); /* Dispose of reference */ + + /* + * Replace entry with its tag (not a real SV, so no refcnt increment) + */ + ary[i] = *svh; TRACEME(("listed object %d at 0x%"UVxf" is tag #%"UVuf, i-1, PTR2UV(xsv), PTR2UV(*svh))); @@ -3131,8 +3245,37 @@ static SV *retrieve_hook(stcxt_t *cxt) BLESS(sv, class); hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw"); - if (!hook) - CROAK(("No STORABLE_thaw defined for objects of class %s", class)); + if (!hook) { + /* + * Hook not found. Maybe they did not require the module where this + * hook is defined yet? + * + * If the require below succeeds, we'll be able to find the hook. + * Still, it only works reliably when each class is defined in a + * file of its own. + */ + + SV *psv = newSVpvn("require ", 8); + sv_catpv(psv, class); + + TRACEME(("No STORABLE_thaw defined for objects of class %s", class)); + TRACEME(("Going to require module '%s' with '%s'", class, SvPVX(psv))); + + perl_eval_sv(psv, G_DISCARD); + sv_free(psv); + + /* + * We cache results of pkg_can, so we need to uncache before attempting + * the lookup again. + */ + + pkg_uncache(cxt->hook, SvSTASH(sv), "STORABLE_thaw"); + hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw"); + + if (!hook) + CROAK(("No STORABLE_thaw defined for objects of class %s " + "(even after a \"require %s;\")", class, class)); + } /* * If we don't have an `av' yet, prepare one. @@ -3273,9 +3416,10 @@ static SV *retrieve_overloaded(stcxt_t *cxt) stash = (HV *) SvSTASH (sv); if (!stash || !Gv_AMG(stash)) - CROAK(("Cannot restore overloading on %s(0x%"UVxf")", + CROAK(("Cannot restore overloading on %s(0x%"UVxf") (package %s)", sv_reftype(sv, FALSE), - PTR2UV(sv))); + PTR2UV(sv), + stash ? HvNAME(stash) : "")); SvAMAGIC_on(rv); diff --git a/ext/Sys/Syslog/Syslog.pm b/ext/Sys/Syslog/Syslog.pm index c7ce3de..71f5b82 100644 --- a/ext/Sys/Syslog/Syslog.pm +++ b/ext/Sys/Syslog/Syslog.pm @@ -264,7 +264,9 @@ sub xlate { $name = uc $name; $name = "LOG_$name" unless $name =~ /^LOG_/; $name = "Sys::Syslog::$name"; - eval { &$name } || -1; + # Can't have just eval { &$name } || -1 because some LOG_XXX may be zero. + my $value = eval { &$name }; + defined $value ? $value : -1; } sub connect { @@ -274,8 +276,8 @@ sub connect { ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _) } unless ( $sock_type ) { - my $udp = getprotobyname('udp'); - my $syslog = getservbyname('syslog','udp'); + my $udp = getprotobyname('udp') || croak "getprotobyname failed for udp"; + my $syslog = getservbyname('syslog','udp') || croak "getservbyname failed"; my $this = sockaddr_in($syslog, INADDR_ANY); my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host"); socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!"; diff --git a/ext/Thread/Thread.pm b/ext/Thread/Thread.pm index c752e3d..f8a8a26 100644 --- a/ext/Thread/Thread.pm +++ b/ext/Thread/Thread.pm @@ -21,6 +21,11 @@ Thread - manipulate threads in Perl (EXPERIMENTAL, subject to change) $result = $t->join; $result = $t->eval; $t->detach; + $flags = $t->flags; + + if ($t->done) { + $t->join; + } if($t->equal($another_thread)) { # ... @@ -181,6 +186,17 @@ increasing integer assigned when a thread is created. The main thread of a program will have a tid of zero, while subsequent threads will have tids assigned starting with one. +=item flags + +The C method returns the flags for the thread. This is the +integer value corresponding to the internal flags for the thread, and +the value may not be all that meaningful to you. + +=item done + +The C method returns true if the thread you're checking has +finished, and false otherwise. + =back =head1 LIMITATIONS diff --git a/ext/Thread/Thread.xs b/ext/Thread/Thread.xs index 17e5aef..c117c60 100644 --- a/ext/Thread/Thread.xs +++ b/ext/Thread/Thread.xs @@ -98,7 +98,6 @@ threadstart(void *arg) DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p waiting to start\n", thr)); - /* Don't call *anything* requiring dTHR until after PERL_SET_THX() */ /* * Wait until our creator releases us. If we didn't do this, then * it would be potentially possible for out thread to carry on and @@ -116,7 +115,6 @@ threadstart(void *arg) */ PERL_SET_THX(thr); - /* Only now can we use SvPEEK (which calls sv_newmortal which does dTHR) */ DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p starting at %s\n", thr, SvPEEK(TOPs))); @@ -177,7 +175,7 @@ threadstart(void *arg) Safefree(PL_savestack); Safefree(PL_retstack); Safefree(PL_tmps_stack); - Safefree(PL_ofs); + SvREFCNT_dec(PL_ofs_sv); SvREFCNT_dec(PL_rs); SvREFCNT_dec(PL_nrs); @@ -191,6 +189,7 @@ threadstart(void *arg) Safefree(PL_reg_poscache); MUTEX_LOCK(&thr->mutex); + thr->thr_done = 1; DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: threadstart finishing: state is %u\n", thr, ThrSTATE(thr))); @@ -448,6 +447,14 @@ flags(t) #endif void +done(t) + Thread t + PPCODE: +#ifdef USE_THREADS + PUSHs(t->thr_done ? &PL_sv_yes : &PL_sv_no); +#endif + +void self(classname) char * classname PREINIT: diff --git a/ext/re/Makefile.PL b/ext/re/Makefile.PL index bc31b2c..b8d25bd 100644 --- a/ext/re/Makefile.PL +++ b/ext/re/Makefile.PL @@ -1,12 +1,15 @@ use ExtUtils::MakeMaker; use File::Spec; +use Config; + +my $object = 're_exec$(OBJ_EXT) re_comp$(OBJ_EXT) re$(OBJ_EXT)'; WriteMakefile( NAME => 're', VERSION_FROM => 're.pm', MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', - OBJECT => 're_exec$(OBJ_EXT) re_comp$(OBJ_EXT) re$(OBJ_EXT)', + OBJECT => $object, DEFINE => '-DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG', clean => { FILES => '*$(OBJ_EXT) *.c ../../lib/re.pm' }, ); diff --git a/ext/re/hints/aix.pl b/ext/re/hints/aix.pl new file mode 100644 index 0000000..4fbfefd --- /dev/null +++ b/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/ext/re/re.xs b/ext/re/re.xs index 04a5fdc..25c2a90 100644 --- a/ext/re/re.xs +++ b/ext/re/re.xs @@ -25,7 +25,6 @@ static int oldfl; static void deinstall(pTHX) { - dTHR; PL_regexecp = Perl_regexec_flags; PL_regcompp = Perl_pregcomp; PL_regint_start = Perl_re_intuit_start; @@ -39,7 +38,6 @@ deinstall(pTHX) static void install(pTHX) { - dTHR; PL_colorset = 0; /* Allow reinspection of ENV. */ PL_regexecp = &my_regexec; PL_regcompp = &my_regcomp; diff --git a/fakesdio.h b/fakesdio.h new file mode 100644 index 0000000..4791232 --- /dev/null +++ b/fakesdio.h @@ -0,0 +1,104 @@ +/* + * This is "source level" stdio compatibility mode. + * We try and #define stdio functions in terms of PerlIO. + */ +#define _CANNOT "CANNOT" +#undef FILE +#define FILE PerlIO +#undef clearerr +#undef fclose +#undef fdopen +#undef feof +#undef ferror +#undef fflush +#undef fgetc +#undef fgetpos +#undef fgets +#undef fileno +#undef flockfile +#undef fopen +#undef fprintf +#undef fputc +#undef fputs +#undef fread +#undef freopen +#undef fscanf +#undef fseek +#undef fsetpos +#undef ftell +#undef ftrylockfile +#undef funlockfile +#undef fwrite +#undef getc +#undef getc_unlocked +#undef getw +#undef pclose +#undef popen +#undef putc +#undef putc_unlocked +#undef putw +#undef rewind +#undef setbuf +#undef setvbuf +#undef stderr +#undef stdin +#undef stdout +#undef tmpfile +#undef ungetc +#undef vfprintf +#define fprintf PerlIO_printf +#define stdin PerlIO_stdin() +#define stdout PerlIO_stdout() +#define stderr PerlIO_stderr() +#define tmpfile() PerlIO_tmpfile() +#define fclose(f) PerlIO_close(f) +#define fflush(f) PerlIO_flush(f) +#define fopen(p,m) PerlIO_open(p,m) +#define vfprintf(f,fmt,a) PerlIO_vprintf(f,fmt,a) +#define fgetc(f) PerlIO_getc(f) +#define fputc(c,f) PerlIO_putc(f,c) +#define fputs(s,f) PerlIO_puts(f,s) +#define getc(f) PerlIO_getc(f) +#define getc_unlocked(f) PerlIO_getc(f) +#define putc(c,f) PerlIO_putc(f,c) +#define putc_unlocked(c,f) PerlIO_putc(c,f) +#define ungetc(c,f) PerlIO_ungetc(f,c) +#if 0 +/* return values of read/write need work */ +#define fread(b,s,c,f) PerlIO_read(f,b,(s*c)) +#define fwrite(b,s,c,f) PerlIO_write(f,b,(s*c)) +#else +#define fread(b,s,c,f) _CANNOT fread +#define fwrite(b,s,c,f) _CANNOT fwrite +#endif +#define fseek(f,o,w) PerlIO_seek(f,o,w) +#define ftell(f) PerlIO_tell(f) +#define rewind(f) PerlIO_rewind(f) +#define clearerr(f) PerlIO_clearerr(f) +#define feof(f) PerlIO_eof(f) +#define ferror(f) PerlIO_error(f) +#define fdopen(fd,p) PerlIO_fdopen(fd,p) +#define fileno(f) PerlIO_fileno(f) +#define popen(c,m) my_popen(c,m) +#define pclose(f) my_pclose(f) + +#define fsetpos(f,p) _CANNOT _fsetpos_ +#define fgetpos(f,p) _CANNOT _fgetpos_ + +#define __filbuf(f) _CANNOT __filbuf_ +#define _filbuf(f) _CANNOT _filbuf_ +#define __flsbuf(c,f) _CANNOT __flsbuf_ +#define _flsbuf(c,f) _CANNOT _flsbuf_ +#define getw(f) _CANNOT _getw_ +#define putw(v,f) _CANNOT _putw_ +#if SFIO_VERSION < 20000101L +#define flockfile(f) _CANNOT _flockfile_ +#define ftrylockfile(f) _CANNOT _ftrylockfile_ +#define funlockfile(f) _CANNOT _funlockfile_ +#endif +#define freopen(p,m,f) _CANNOT _freopen_ +#define setbuf(f,b) _CANNOT _setbuf_ +#define setvbuf(f,b,x,s) _CANNOT _setvbuf_ +#define fscanf _CANNOT _fscanf_ +#define fgets(s,n,f) _CANNOT _fgets_ + diff --git a/fix_pl b/fix_pl deleted file mode 100644 index 44c3f52..0000000 --- a/fix_pl +++ /dev/null @@ -1,21 +0,0 @@ -#!perl -# Not fixing perl, but fixing the patchlevel if this perl comes -# from the repository rather than an official release -exit unless -e ".patch"; -open PATCH, ".patch" or die "Couldn't open .patch: $!"; -open PLIN, "patchlevel.h" or die "Couldn't open patchlevel.h : $!"; -open PLOUT, ">patchlevel.new" or die "Couldn't write on patchlevel.new : $!"; -my $pl = ; -chomp ($pl); -$pl =~ s/\D//g; -my $seen=0; -while () { - if (/\t,NULL/ and $seen) { - print PLOUT "\t,\"devel-$pl\"\n"; - } - $seen++ if /local_patches\[\]/; - print PLOUT; -} -close PLOUT; close PLIN; -rename "patchlevel.new", "patchlevel.h" or die "Couldn't rename: $!"; -unlink ".patch"; diff --git a/form.h b/form.h index ca2a0c8..4353b63 100644 --- a/form.h +++ b/form.h @@ -1,6 +1,6 @@ /* form.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -23,4 +23,5 @@ #define FF_NEWLINE 13 #define FF_BLANK 14 #define FF_MORE 15 +#define FF_0DECIMAL 16 diff --git a/global.sym b/global.sym index 0dea03e..2f6f65b 100644 --- a/global.sym +++ b/global.sym @@ -21,6 +21,7 @@ Perl_get_context Perl_set_context Perl_amagic_call Perl_Gv_AMupdate +Perl_gv_handler Perl_apply_attrs_string Perl_avhv_delete_ent Perl_avhv_exists_ent @@ -315,6 +316,7 @@ Perl_pmflag Perl_pop_scope Perl_push_scope Perl_regdump +Perl_regclass_swash Perl_pregexec Perl_pregfree Perl_pregcomp @@ -358,6 +360,7 @@ Perl_save_scalar Perl_save_pptr Perl_save_vptr Perl_save_re_context +Perl_save_padsv Perl_save_sptr Perl_save_svref Perl_save_threadsv @@ -443,6 +446,7 @@ Perl_sv_taint Perl_sv_tainted Perl_sv_unmagic Perl_sv_unref +Perl_sv_unref_flags Perl_sv_untaint Perl_sv_upgrade Perl_sv_usepvn @@ -461,12 +465,13 @@ Perl_unlock_condpair Perl_unsharepvn Perl_utf16_to_utf8 Perl_utf16_to_utf8_reversed +Perl_utf8_length Perl_utf8_distance Perl_utf8_hop Perl_utf8_to_bytes Perl_bytes_to_utf8 +Perl_utf8_to_uv_simple Perl_utf8_to_uv -Perl_utf8_to_uv_chk Perl_uv_to_utf8 Perl_warn Perl_vwarn @@ -527,6 +532,7 @@ Perl_sv_utf8_downgrade Perl_sv_utf8_encode Perl_sv_utf8_decode Perl_sv_force_normal +Perl_sv_force_normal_flags Perl_tmps_grow Perl_sv_rvweaken Perl_newANONATTRSUB diff --git a/gv.c b/gv.c index 768824d..f2931ae 100644 --- a/gv.c +++ b/gv.c @@ -1,6 +1,6 @@ /* gv.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -53,7 +53,6 @@ Perl_gv_IOadd(pTHX_ register GV *gv) GV * Perl_gv_fetchfile(pTHX_ const char *name) { - dTHR; char smallbuf[256]; char *tmpbuf; STRLEN tmplen; @@ -85,7 +84,6 @@ Perl_gv_fetchfile(pTHX_ const char *name) void Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) { - dTHR; register GP *gp; bool doproto = SvTYPE(gv) > SVt_NULL; char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; @@ -227,7 +225,6 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) basestash = gv_stashpvn(packname, packlen, TRUE); gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE); if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { - dTHR; /* just for SvREFCNT_dec */ gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE); if (!gvp || !(gv = *gvp)) Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash)); @@ -247,7 +244,6 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { - dTHR; /* just for ckWARN */ if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); @@ -342,7 +338,6 @@ C apply equally to these functions. GV * Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) { - dTHR; register const char *nend; const char *nsplit = 0; GV* gv; @@ -403,7 +398,6 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) GV* Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) { - dTHR; static char autoload[] = "AUTOLOAD"; static STRLEN autolen = 8; GV* gv; @@ -418,7 +412,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) return Nullgv; cv = GvCV(gv); - if (!CvROOT(cv)) + if (!(CvROOT(cv) || CvXSUB(cv))) return Nullgv; /* @@ -430,6 +424,20 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", HvNAME(stash), (int)len, name); +#ifndef USE_THREADS + if (CvXSUB(cv)) { + /* rather than lookup/init $AUTOLOAD here + * only to have the XSUB do another lookup for $AUTOLOAD + * and split that value on the last '::', + * pass along the same data via some unused fields in the CV + */ + CvSTASH(cv) = stash; + SvPVX(cv) = (char *)name; /* cast to loose constness warning */ + SvCUR(cv) = len; + return gv; + } +#endif + /* * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. * The subroutine's original name may not be "AUTOLOAD", so we don't @@ -525,7 +533,6 @@ Perl_gv_stashsv(pTHX_ SV *sv, I32 create) GV * Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) { - dTHR; register const char *name = nambeg; register GV *gv = 0; GV**gvp; @@ -840,7 +847,6 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) case ',': case '\\': case '/': - case '|': case '\001': /* $^A */ case '\003': /* $^C */ case '\004': /* $^D */ @@ -848,12 +854,20 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) case '\006': /* $^F */ case '\010': /* $^H */ case '\011': /* $^I, NOT \t in EBCDIC */ - case '\017': /* $^O */ case '\020': /* $^P */ case '\024': /* $^T */ if (len > 1) break; goto magicalize; + case '|': + if (len > 1) + break; + sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0); + goto magicalize; + case '\017': /* $^O & $^OPEN */ + if (len > 1 && strNE(name, "\017PEN")) + break; + goto magicalize; case '\023': /* $^S */ if (len > 1) break; @@ -992,7 +1006,6 @@ Perl_gv_efullname(pTHX_ SV *sv, GV *gv) IO * Perl_newIO(pTHX) { - dTHR; IO *io; GV *iogv; @@ -1011,7 +1024,6 @@ Perl_newIO(pTHX) void Perl_gv_check(pTHX_ HV *stash) { - dTHR; register HE *entry; register I32 i; register GV *gv; @@ -1088,7 +1100,6 @@ Perl_gp_ref(pTHX_ GP *gp) void Perl_gp_free(pTHX_ GV *gv) { - dTHR; GP* gp; if (!gv || !(gp = GvGP(gv))) @@ -1149,21 +1160,16 @@ register GV *gv; bool Perl_Gv_AMupdate(pTHX_ HV *stash) { - dTHR; GV* gv; CV* cv; MAGIC* mg=mg_find((SV*)stash,'c'); AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL; AMT amt; STRLEN n_a; -#ifdef OVERLOAD_VIA_HASH - GV** gvp; - HV* hv; -#endif if (mg && amtp->was_ok_am == PL_amagic_generation && amtp->was_ok_sub == PL_sub_generation) - return AMT_AMAGIC(amtp); + return AMT_OVERLOADED(amtp); if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */ int i; for (i=1; i= DESTROY_amg ? cooky : AMG_id2name(i)); + STRLEN l = strlen(cooky); - for (i = 1; i < NofAMmeth; i++) { - SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i])); DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n", cp, HvNAME(stash)) ); /* don't fill the cache while looking up! */ - gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1); + gv = gv_fetchmeth(stash, cooky, l, -1); cv = 0; - if(gv && (cv = GvCV(gv))) { + if (gv && (cv = GvCV(gv))) { if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) { /* GvSV contains the name of the method. */ @@ -1292,14 +1248,17 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))) ); filled = 1; + if (i < DESTROY_amg) + have_ovl = 1; } -#endif amt.table[i]=(CV*)SvREFCNT_inc(cv); } if (filled) { AMT_AMAGIC_on(&amt); + if (have_ovl) + AMT_OVERLOADED_on(&amt); sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT)); - return TRUE; + return have_ovl; } } /* Here we have no table: */ @@ -1309,10 +1268,35 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) return FALSE; } + +CV* +Perl_gv_handler(pTHX_ HV *stash, I32 id) +{ + dTHR; + MAGIC *mg; + AMT *amtp; + + if (!stash) + return Nullcv; + mg = mg_find((SV*)stash,'c'); + if (!mg) { + do_update: + Gv_AMupdate(stash); + mg = mg_find((SV*)stash,'c'); + } + amtp = (AMT*)mg->mg_ptr; + if ( amtp->was_ok_am != PL_amagic_generation + || amtp->was_ok_sub != PL_sub_generation ) + goto do_update; + if (AMT_AMAGIC(amtp)) + return amtp->table[id]; + return Nullcv; +} + + SV* Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { - dTHR; MAGIC *mg; CV *cv; CV **cvp=NULL, **ocvp=NULL; @@ -1493,7 +1477,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (off==-1) off=method; msg = sv_2mortal(Perl_newSVpvf(aTHX_ "Operation `%s': no method found,%sargument %s%s%s%s", - PL_AMG_names[method + assignshift], + AMG_id2name(method + assignshift), (flags & AMGf_unary ? " " : "\n\tleft "), SvAMAGIC(left)? "in overloaded package ": @@ -1522,11 +1506,11 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (!notfound) { DEBUG_o( Perl_deb(aTHX_ "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n", - PL_AMG_names[off], + AMG_id2name(off), method+assignshift==off? "" : " (initially `", method+assignshift==off? "" : - PL_AMG_names[method+assignshift], + AMG_id2name(method+assignshift), method+assignshift==off? "" : "')", flags & AMGf_unary? "" : lr==1 ? " for right argument": " for left argument", @@ -1586,7 +1570,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PUSHs(lr>0? left: right); PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); if (notfound) { - PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0))); + PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0))); } PUSHs((SV*)cv); PUTBACK; @@ -1672,6 +1656,13 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) if (len == 3 && strEQ(name, "SIG")) goto yes; break; + case '\017': /* $^O & $^OPEN */ + if (len == 1 + || (len == 4 && strEQ(name, "\027PEN"))) + { + goto yes; + } + break; case '\027': /* $^W & $^WARNING_BITS */ if (len == 1 || (len == 12 && strEQ(name, "\027ARNING_BITS")) @@ -1715,7 +1706,6 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) case '\010': /* $^H */ case '\011': /* $^I, NOT \t in EBCDIC */ case '\014': /* $^L */ - case '\017': /* $^O */ case '\020': /* $^P */ case '\023': /* $^S */ case '\024': /* $^T */ diff --git a/gv.h b/gv.h index d2234a6..07a04b6 100644 --- a/gv.h +++ b/gv.h @@ -1,6 +1,6 @@ /* gv.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. diff --git a/handy.h b/handy.h index f0e39af..9d7e096 100644 --- a/handy.h +++ b/handy.h @@ -1,6 +1,6 @@ /* handy.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -114,6 +114,10 @@ Null SV pointer. */ +#ifdef I_INTTYPES /* e.g. Linux has int64_t without */ +# include +#endif + typedef I8TYPE I8; typedef U8TYPE U8; typedef I16TYPE I16; @@ -122,17 +126,28 @@ typedef I32TYPE I32; typedef U32TYPE U32; #ifdef PERL_CORE # ifdef HAS_QUAD -# if QUADKIND == QUAD_IS_INT64_T -# include -# ifdef I_INTTYPES /* e.g. Linux has int64_t without */ -# include -# endif -# endif typedef I64TYPE I64; typedef U64TYPE U64; # endif #endif /* PERL_CORE */ +#if defined(HAS_QUAD) && defined(USE_64_BIT_INT) +# ifndef UINT64_C /* usually from */ +# if defined(HAS_LONG_LONG) && QUADKIND == QUAD_IS_LONG_LONG +# define INT64_C(c) CAT2(c,LL) +# define UINT64_C(c) CAT2(c,ULL) +# else +# if LONGSIZE == 8 && QUADKIND == QUAD_IS_LONG +# define INT64_C(c) CAT2(c,L) +# define UINT64_C(c) CAT2(c,UL) +# else +# define INT64_C(c) ((I64TYPE)(c)) +# define UINT64_C(c) ((U64TYPE)(c)) +# endif +# endif +# endif +#endif + /* Mention I8SIZE, U8SIZE, I16SIZE, U16SIZE, I32SIZE, U32SIZE, I64SIZE, and U64SIZE here so that metaconfig pulls them in. */ @@ -448,21 +463,21 @@ Converts the specified character to lowercase. #define isPSXSPC_utf8(c) (isSPACE_utf8(c) ||(c) == '\f') #define isBLANK_utf8(c) isBLANK(c) /* could be wrong */ -#define isALNUM_LC_utf8(p) isALNUM_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isIDFIRST_LC_utf8(p) isIDFIRST_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isALPHA_LC_utf8(p) isALPHA_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isSPACE_LC_utf8(p) isSPACE_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isDIGIT_LC_utf8(p) isDIGIT_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isUPPER_LC_utf8(p) isUPPER_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isLOWER_LC_utf8(p) isLOWER_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isALNUMC_LC_utf8(p) isALNUMC_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isCNTRL_LC_utf8(p) isCNTRL_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isGRAPH_LC_utf8(p) isGRAPH_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isPRINT_LC_utf8(p) isPRINT_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isPUNCT_LC_utf8(p) isPUNCT_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define toUPPER_LC_utf8(p) toUPPER_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define toTITLE_LC_utf8(p) toTITLE_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define toLOWER_LC_utf8(p) toLOWER_LC_uni(utf8_to_uv_chk(p, 0, 0)) +#define isALNUM_LC_utf8(p) isALNUM_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isIDFIRST_LC_utf8(p) isIDFIRST_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isALPHA_LC_utf8(p) isALPHA_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isSPACE_LC_utf8(p) isSPACE_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isDIGIT_LC_utf8(p) isDIGIT_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isUPPER_LC_utf8(p) isUPPER_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isLOWER_LC_utf8(p) isLOWER_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isALNUMC_LC_utf8(p) isALNUMC_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isCNTRL_LC_utf8(p) isCNTRL_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isGRAPH_LC_utf8(p) isGRAPH_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isPRINT_LC_utf8(p) isPRINT_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isPUNCT_LC_utf8(p) isPUNCT_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define toUPPER_LC_utf8(p) toUPPER_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define toTITLE_LC_utf8(p) toTITLE_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define toLOWER_LC_utf8(p) toLOWER_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) #define isPSXSPC_LC_utf8(c) (isSPACE_LC_utf8(c) ||(c) == '\f') #define isBLANK_LC_utf8(c) isBLANK(c) /* could be wrong */ @@ -606,3 +621,14 @@ extern long lastxycount[MAXXCOUNT][MAXYCOUNT]; #else #define StructCopy(s,d,t) Copy(s,d,1,t) #endif + +#ifdef NEED_VA_COPY +# ifdef va_copy +# define Perl_va_copy(s, d) va_copy(d, s) +# elif defined(__va_copy) +# define Perl_va_copy(s, d) __va_copy(d, s) +# else +# define Perl_va_copy(s, d) Copy(s, d, 1, va_list) +# endif +#endif + diff --git a/hints/aix.sh b/hints/aix.sh index cf7e43c..b14aad0 100644 --- a/hints/aix.sh +++ b/hints/aix.sh @@ -130,6 +130,13 @@ case "$cc" in *gcc*) ccdlflags='-Xlinker' ;; *) ccversion=`lslpp -L | grep 'C for AIX Compiler$' | awk '{print $2}'` case "$ccversion" in + '') ccversion=`lslpp -L | grep 'IBM C and C++ Compilers LUM$' | awk '{print $2}'` + ;; + esac + case "$ccversion" in + 3.6.6.0) + optimize='none' + ;; 4.4.0.0|4.4.0.1|4.4.0.2) echo >&4 "*** This C compiler ($ccversion) is outdated." echo >&4 "*** Please upgrade to at least 4.4.0.3." @@ -156,6 +163,20 @@ case "$osvers" in lddlflags="$lddlflags -bhalt:4 -bM:SRE -bI:\$(PERL_INC)/perl.exp -bE:\$(BASEEXT).exp -b noentry -lc" ;; esac +# AIX 4.2 (using latest patchlevels on 20001130) has a broken bind +# library (getprotobyname and getprotobynumber are outversioned by +# the same calls in libc, at least for xlc version 3... +case "`oslevel`" in + 4.2.1.*) # Test for xlc version too, should we? + case "$ccversion" in # Don't know if needed for gcc + 3.1.4.*) # libswanted "bind ... c ..." => "... c bind ..." + set `echo X "$libswanted "| sed -e 's/ bind\( .*\) \([cC]\) / \1 \2 bind /'` + shift + libswanted="$*" + ;; + esac + ;; + esac # This script UU/usethreads.cbu will get 'called-back' by Configure # after it has prompted the user for whether to use threads. diff --git a/hints/cygwin.sh b/hints/cygwin.sh index 7be1735..c57d3f6 100644 --- a/hints/cygwin.sh +++ b/hints/cygwin.sh @@ -25,6 +25,7 @@ libswanted=`echo " $libswanted " | sed -e 's/ c / /g'` libswanted=`echo " $libswanted " | sed -e 's/ m / /g'` libswanted="$libswanted cygipc" test -z "$optimize" && optimize='-O2' +ccflags="$ccflags -DPERL_USE_SAFE_PUTENV" # - otherwise i686-cygwin archname='cygwin' diff --git a/hints/dec_osf.sh b/hints/dec_osf.sh index 07b80ea..ce3a40c 100644 --- a/hints/dec_osf.sh +++ b/hints/dec_osf.sh @@ -70,12 +70,13 @@ case "`$cc -v 2>&1 | grep cc`" in if test "$1" -lt 2 -o \( "$1" -eq 2 -a \( "$2" -lt 95 -o \( "$2" -eq 95 -a "$3" -lt 2 \) \) \); then cat >&4 < # Richard Yeh # +# Deny system's false claims to support mmap() and munmap(); note +# also that Sys V IPC (re)disabled by jhi due to continuing inadequacy +# -- Dominic Dunlop 001111 # Remove dynamic loading libraries from search; enable SysV IPC with # MachTen 4.1.4 and above; define SYSTEM_ALIGN_BYTES for old MT versions # -- Dominic Dunlop 000224 @@ -197,6 +200,11 @@ if test "$d_shm" = ""; then esac fi +# MachTen has stubs for mmap and munmap(), but they just result in the +# caller being killed on the grounds of "Bad system call" +d_mmap=${d_mmap:-undef} +d_munmap=${d_munmap:-undef} + # Get rid of some extra libs which it takes Configure a tediously # long time never to find on MachTen, or which break perl set `echo X "$libswanted "|sed -e 's/ net / /' -e 's/ socket / /' \ @@ -228,6 +236,8 @@ During Configure, you may see the message as well as similar messages concerning \$d_sem and \$d_shm. Select the default answers: MachTen 4.1 appears to provide System V IPC support, but it is incomplete and buggy: perl should be built without it. +Similar considerations apply to memory mapping of files, controlled +by \$d_mmap and \$d_munmap. Similarly, when you see diff --git a/hints/nonstopux.sh b/hints/nonstopux.sh index f93c312..aec05ee 100644 --- a/hints/nonstopux.sh +++ b/hints/nonstopux.sh @@ -9,7 +9,7 @@ case "$cc" in lddlflags='-shared' ldflags='' ;; - '') + *) cc="cc -Xa -Olimit 4096" malloctype="void *" ;; diff --git a/hints/openbsd.sh b/hints/openbsd.sh index 5b79709..2e7a433 100644 --- a/hints/openbsd.sh +++ b/hints/openbsd.sh @@ -43,7 +43,7 @@ OpenBSD.alpha|OpenBSD.mips|OpenBSD.powerpc|OpenBSD.vax) ;; *) # from 2.8 onwards ld=${cc:-cc} - lddlflags="-shared $lddlflags" + lddlflags="-shared -fPIC $lddlflags" ;; esac ;; @@ -95,6 +95,9 @@ case "$openbsd_distribution" in sysman='/usr/share/man/man1' libpth='/usr/lib' glibpth='/usr/lib' + # Local things, however, do go in /usr/local + siteprefix='/usr/local' + siteprefixexp='/usr/local' # Ports installs non-std libs in /usr/local/lib so look there too locincpth='/usr/local/include' loclibpth='/usr/local/lib' diff --git a/hints/solaris_2.sh b/hints/solaris_2.sh index e8175f2..0bf5bab 100644 --- a/hints/solaris_2.sh +++ b/hints/solaris_2.sh @@ -1,35 +1,48 @@ # hints/solaris_2.sh -# Last modified: Tue Apr 13 13:12:49 EDT 1999 +# Last modified: Tue Jan 2 10:16:35 2001 +# Lupe Christoph +# Based on version by: # Andy Dougherty -# Based on input from lots of folks, especially +# Which was based on input from lots of folks, especially # Dean Roehrich +# Additional input from Alan Burlison, Jarkko Hietaniemi, +# and Richard Soderberg. +# +# See README.solaris for additional information. +# +# For consistency with gcc, we do not adopt Sun Marketing's +# removal of the '2.' prefix from the Solaris version number. +# (Configure tries to detect an old fixincludes and needs +# this information.) # If perl fails tests that involve dynamic loading of extensions, and # you are using gcc, be sure that you are NOT using GNU as and ld. One # way to do that is to invoke Configure with -# +# # sh Configure -Dcc='gcc -B/usr/ccs/bin/' # # (Note that the trailing slash is *required*.) # gcc will occasionally emit warnings about "unused prefix", but # these ought to be harmless. See below for more details. - + # See man vfork. usevfork=false d_suidsafe=define # Avoid all libraries in /usr/ucblib. -set `echo $glibpth | sed -e 's@/usr/ucblib@@'` +# /lib is just a symlink to /usr/lib +set `echo $glibpth | sed -e 's@/usr/ucblib@@' -e 's@ /lib @ @'` glibpth="$*" -# Remove bad libraries. -lucb contains incompatible routines. -# -lld doesn't do anything useful. +# Remove unwanted libraries. -lucb contains incompatible routines. +# -lld and -lsec don't do anything useful. -lcrypt does not +# really provide anything we need over -lc, so we drop it, too. # -lmalloc can cause a problem with GNU CC & Solaris. Specifically, # libmalloc.a may allocate memory that is only 4 byte aligned, but # GNU CC on the Sparc assumes that doubles are 8 byte aligned. # Thanks to Hallvard B. Furuseth -set `echo " $libswanted " | sed -e 's@ ld @ @' -e 's@ malloc @ @' -e 's@ ucb @ @'` +set `echo " $libswanted " | sed -e 's@ ld @ @' -e 's@ malloc @ @' -e 's@ ucb @ @' -e 's@ sec @ @' -e 's@ crypt @ @'` libswanted="$*" # Look for architecture name. We want to suggest a useful default. @@ -45,47 +58,35 @@ case "$archname" in ;; esac -cc=${cc:-cc} - -ccversion="`$cc -V 2>&1|head -1|sed 's/^cc: //'`" -case "$ccversion" in -*WorkShop*) ccname=workshop ;; -*) ccversion='' ;; -esac - -cat >UU/workshoplibpth.cbu<<'EOCBU' +cat > UU/workshoplibpth.cbu << 'EOCBU' +# This script UU/workshoplibpth.cbu will get 'called-back' +# by other CBUs this script creates. case "$workshoplibpth_done" in -'') case "$use64bitall" in - "$define"|true|[yY]*) - loclibpth="$loclibpth /usr/lib/sparcv9" - if test -n "$workshoplibs"; then - loclibpth=`echo $loclibpth | sed -e "s% $workshoplibs%%" ` - for lib in $workshoplibs; do - # Logically, it should be sparcv9. - # But the reality fights back, it's v9. - loclibpth="$loclibpth $lib/sparcv9 $lib/v9" - done - fi + '') if test `uname -p` = "sparc"; then + case "$use64bitall" in + "$define"|true|[yY]*) + # add SPARC-specific 64 bit libraries + loclibpth="$loclibpth /usr/lib/sparcv9" + if test -n "$workshoplibs"; then + loclibpth=`echo $loclibpth | sed -e "s% $workshoplibs%%" ` + for lib in $workshoplibs; do + # Logically, it should be sparcv9. + # But the reality fights back, it's v9. + loclibpth="$loclibpth $lib/sparcv9 $lib/v9" + done + fi ;; - *) loclibpth="$loclibpth $workshoplibs" + *) loclibpth="$loclibpth $workshoplibs" ;; esac + else + loclibpth="$loclibpth $workshoplibs" + fi workshoplibpth_done="$define" ;; esac EOCBU -case "$ccname" in -workshop) - cat >try.c < -int main() { return(0); } -EOF - workshoplibs=`cc -### try.c -lsunmath -o try 2>&1|grep " -Y "|sed 's%.* -Y "P,\(.*\)".*%\1%'|tr ':' '\n'|grep '/SUNWspro/'` - . ./UU/workshoplibpth.cbu - ;; -esac - ###################################################### # General sanity testing. See below for excerpts from the Solaris FAQ. # @@ -95,12 +96,12 @@ esac # To: perl5-porters@africa.nicoh.com # Subject: Re: On perl5/solaris/gcc # -# Here's another draft of the perl5/solaris/gcc sanity-checker. +# Here's another draft of the perl5/solaris/gcc sanity-checker. case `type ${cc:-cc}` in */usr/ucb/cc*) cat <&4 -NOTE: Some people have reported problems with /usr/ucb/cc. +NOTE: Some people have reported problems with /usr/ucb/cc. If you have difficulties, please make sure the directory containing your C compiler is before /usr/ucb in your PATH. @@ -158,7 +159,7 @@ if grep GNU make.vers > /dev/null 2>&1; then case "`/usr/bin/ls -lL $tmp`" in ??????s*) cat <&2 - + NOTE: Your PATH points to GNU make, and your GNU make has the set-group-id bit set. You must either rearrange your PATH to put /usr/ccs/bin before the GNU utilities or you must ask your system administrator to disable the @@ -170,31 +171,33 @@ END fi rm -f make.vers -# XXX EXPERIMENTAL A.D. 2/27/1998 -# XXX This script UU/cc.cbu will get 'called-back' by Configure after it -# XXX has prompted the user for the C compiler to use. -cat > UU/cc.cbu <<'EOSH' +cat > UU/cc.cbu <<'EOCBU' +# This script UU/cc.cbu will get 'called-back' by Configure after it +# has prompted the user for the C compiler to use. + # If the C compiler is gcc: # - check the fixed-includes # - check as(1) and ld(1), they should not be GNU # (GNU as and ld 2.8.1 and later are reportedly ok, however.) # If the C compiler is not gcc: +# - Check if it is the Workshop/Forte compiler. +# If it is, prepare for 64 bit and long doubles. # - check as(1) and ld(1), they should not be GNU # (GNU as and ld 2.8.1 and later are reportedly ok, however.) # # Watch out in case they have not set $cc. -# Perl compiled with some combinations of GNU as and ld may not +# Perl compiled with some combinations of GNU as and ld may not # be able to perform dynamic loading of extensions. If you have a # problem with dynamic loading, be sure that you are using the Solaris # /usr/ccs/bin/as and /usr/ccs/bin/ld. You can do that with # sh Configure -Dcc='gcc -B/usr/ccs/bin/' -# (note the trailing slash is required). +# (note the trailing slash is required). # Combinations that are known to work with the following hints: # # gcc-2.7.2, GNU as 2.7, GNU ld 2.7 # egcs-1.0.3, GNU as 2.9.1 and GNU ld 2.9.1 -# --Andy Dougherty +# --Andy Dougherty # Tue Apr 13 17:19:43 EDT 1999 # Get gcc to share its secrets. @@ -207,12 +210,6 @@ if echo "$verbose" | grep '^Reading specs from' >/dev/null 2>&1; then # Using gcc. # - tmp=`echo "$verbose" | grep '^Reading' | - awk '{print $NF}' | sed 's/specs$/include/'` - - # Determine if the fixed-includes look like they'll work. - # Doesn't work anymore for gcc-2.7.2. - # See if as(1) is GNU as(1). GNU as(1) might not work for this job. if echo "$verbose" | grep ' /usr/ccs/bin/as ' >/dev/null 2>&1; then : @@ -277,6 +274,23 @@ else # Not using gcc. # + ccversion="`${cc:-cc} -V 2>&1|sed -n -e '1s/^cc: //p'`" + case "$ccversion" in + *WorkShop*) ccname=workshop ;; + *) ccversion='' ;; + esac + + case "$ccname" in + workshop) + cat >try.c < +int main() { return(0); } +EOM + workshoplibs=`cc -### try.c -lsunmath -o try 2>&1|sed -n '/ -Y /s%.* -Y "P,\(.*\)".*%\1%p'|tr ':' '\n'|grep '/SUNWspro/'` + . ./workshoplibpth.cbu + ;; + esac + # See if as(1) is GNU as(1). GNU might not work for this job. case `as --version < /dev/null 2>&1` in *GNU*) @@ -293,22 +307,12 @@ END # See if ld(1) is GNU ld(1). GNU ld(1) might not work for this job. # ld --version doesn't properly report itself as a GNU tool, # as of ld version 2.6, so we need to be more strict. TWP 9/5/96 - gnu_ld=false - case `ld --version < /dev/null 2>&1` in - *GNU*|ld\ version\ 2*) - gnu_ld=true ;; - *) ;; - esac - if $gnu_ld ; then : + # Sun's ld always emits the "Software Generation Utilities" string. + if ld -V 2>&1 | grep "ld: Software Generation Utilities" >/dev/null 2>&1; then + # Ok, ld is /usr/ccs/bin/ld. + : else - # Try to guess from path - case `type ld | awk '{print $NF}'` in - *gnu*|*GNU*|*FSF*) - gnu_ld=true ;; - esac - fi - if $gnu_ld ; then - cat <&2 + cat <&2 NOTE: You are apparently using GNU ld(1). GNU ld(1) might not build Perl. You should arrange to use /usr/ccs/bin/ld, perhaps by adding /usr/ccs/bin @@ -324,16 +328,16 @@ rm -f try try.c rm -f core # XXX -EOSH +EOCBU cat > UU/usethreads.cbu <<'EOCBU' -# This script UU/usethreads.cbu will get 'called-back' by Configure +# This script UU/usethreads.cbu will get 'called-back' by Configure # after it has prompted the user for whether to use threads. case "$usethreads" in $define|true|[yY]*) ccflags="-D_REENTRANT $ccflags" - # sched_yield is in -lposix4 up to Solaris 2.6, in -lrt starting with Solaris 7 + # sched_yield is in -lposix4 up to Solaris 2.6, in -lrt starting with Solaris 2.7 case `uname -r` in 5.[0-6] | 5.5.1) sched_yield_lib="posix4" ;; *) sched_yield_lib="rt"; @@ -352,12 +356,12 @@ $define|true|[yY]*) cat >try.c <<'EOM' /* Test for sig(set|long)jmp bug. */ #include - + main() { sigjmp_buf env; int ret; - + ret = sigsetjmp(env, 1); if (ret) { return ret == 2; } siglongjmp(env, 2); @@ -379,7 +383,7 @@ esac EOCBU cat > UU/uselargefiles.cbu <<'EOCBU' -# This script UU/uselargefiles.cbu will get 'called-back' by Configure +# This script UU/uselargefiles.cbu will get 'called-back' by Configure # after it has prompted the user for whether to use large files. case "$uselargefiles" in ''|$define|true|[yY]*) @@ -399,21 +403,40 @@ EOCBU # This is truly a mess. case "$usemorebits" in "$define"|true|[yY]*) - use64bitint="$define" - uselongdouble="$define" + use64bitint="$define" + uselongdouble="$define" ;; esac -cat > UU/use64bitall.cbu <<'EOCBU' -# This script UU/use64bitall.cbu will get 'called-back' by Configure +if test `uname -p` = "sparc"; then + cat > UU/use64bitint.cbu <<'EOCBU' +# This script UU/use64bitint.cbu will get 'called-back' by Configure +# after it has prompted the user for whether to use 64 bit integers. +case "$use64bitint" in +"$define"|true|[yY]*) + case "`uname -r`" in + 5.[0-4]) + cat >&4 < UU/use64bitall.cbu <<'EOCBU' +# This script UU/use64bitall.cbu will get 'called-back' by Configure # after it has prompted the user for whether to be maximally 64 bitty. case "$use64bitall-$use64bitall_done" in "$define-"|true-|[yY]*-) case "`uname -r`" in - 5.[1-6]) + 5.[0-6]) cat >&4 <&4 </dev/null" in *gcc*) echo 'main() { return 0; }' > try.c @@ -437,13 +459,16 @@ EOM *"m64 is not supported"*) cat >&4 </dev/null` != X; then ccflags="$ccflags -Wa,`getconf XBS5_LP64_OFF64_CFLAGS 2>/dev/null`" @@ -460,234 +485,47 @@ EOM ldflags="$ldflags `getconf XBS5_LP64_OFF64_LDFLAGS 2>/dev/null`" lddlflags="$lddlflags -G `getconf XBS5_LP64_OFF64_LDFLAGS 2>/dev/null`" ;; - esac + esac libscheck='case "`/usr/bin/file $xxx`" in *64-bit*|*SPARCV9*) ;; *) xxx=/no/64-bit$xxx ;; esac' + use64bitall_done=yes ;; esac EOCBU - -# Actually, we want to run this already now, if so requested, -# because we need to fix up things right now. -case "$use64bitall" in -"$define"|true|[yY]*) - . ./UU/use64bitall.cbu + + # Actually, we want to run this already now, if so requested, + # because we need to fix up things right now. + case "$use64bitall" in + "$define"|true|[yY]*) + # CBUs expect to be run in UU + cd UU; . ./use64bitall.cbu; cd .. ;; -esac + esac +fi cat > UU/uselongdouble.cbu <<'EOCBU' -# This script UU/uselongdouble.cbu will get 'called-back' by Configure +# This script UU/uselongdouble.cbu will get 'called-back' by Configure # after it has prompted the user for whether to use long doubles. -case "$uselongdouble-$uselongdouble_done" in -"$define-"|true-|[yY]*-) - case "$ccname" in - workshop) - libswanted="$libswanted sunmath" - loclibpth="$loclibpth /opt/SUNWspro/lib" - ;; - *) cat >&4 <&4 < /dev/null <<'End_of_Solaris_Notes' - -Here are some notes kindly contributed by Dean Roehrich. - ------ -Generic notes about building Perl5 on Solaris: -- Use /usr/ccs/bin/make. -- If you use GNU make, remove its setgid bit. -- Remove all instances of *ucb* from your path. -- Make sure libucb is not in /usr/lib (it should be in /usr/ucblib). -- Do not use GNU as or GNU ld, or any of GNU binutils or GNU libc. -- Do not use /usr/ucb/cc. -- Do not change Configure's default answers, except for the path names. -- Do not use -lmalloc. -- Do not build on SunOS 4 and expect it to work properly on SunOS 5. -- /dev/fd must be mounted if you want set-uid scripts to work. - - -Here are the gcc-related questions and answers from the Solaris 2 FAQ. Note -the themes: - - run fixincludes - - run fixincludes correctly - - don't use GNU as or GNU ld - -Question 5.7 covers the __builtin_va_alist problem people are always seeing. -Question 6.1.3 covers the GNU as and GNU ld issues which are always biting -people. -Question 6.9 is for those who are still trying to compile Perl4. - -The latest Solaris 2 FAQ can be found in the following locations: - rtfm.mit.edu:/pub/usenet-by-group/comp.sys.sun.admin - ftp.fwi.uva.nl:/pub/solaris - -Perl5 comes with a script in the top-level directory called "myconfig" which -will print a summary of the configuration in your config.sh. My summary for -Solaris 2.4 and gcc 2.6.3 follows. I have also built with gcc 2.7.0 and the -results are identical. This configuration was generated with Configure's -d -option (take all defaults, don't bother prompting me). All tests pass for -Perl5.001, patch.1m. - -Summary of my perl5 (patchlevel 1) configuration: - Platform: - osname=solaris, osver=2.4, archname=sun4-solaris - uname='sunos poplar 5.4 generic_101945-27 sun4d sparc ' - hint=recommended - Compiler: - cc='gcc', optimize='-O', ld='gcc' - cppflags='' - ccflags ='' - ldflags ='' - stdchar='unsigned char', d_stdstdio=define, usevfork=false - voidflags=15, castflags=0, d_casti32=define, d_castneg=define - intsize=4, alignbytes=8, usemymalloc=y, randbits=15 - Libraries: - so=so - libpth=/lib /usr/lib /usr/ccs/lib /usr/local/lib - libs=-lsocket -lnsl -ldl -lm -lc -lcrypt - libc=/usr/lib/libc.so - Dynamic Linking: - dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef - cccdlflags='-fpic', ccdlflags=' ', lddlflags='-G' - - -Dean -roehrich@cray.com -9/7/95 - ------------ - -From: Casper.Dik@Holland.Sun.COM (Casper H.S. Dik - Network Security Engineer) -Subject: Solaris 2 Frequently Asked Questions (FAQ) 1.48 -Date: 25 Jul 1995 12:20:18 GMT - -5.7) Why do I get __builtin_va_alist or __builtin_va_arg_incr undefined? - - You're using gcc without properly installing the gcc fixed - include files. Or you ran fixincludes after installing gcc - w/o moving the gcc supplied varargs.h and stdarg.h files - out of the way and moving them back again later. This often - happens when people install gcc from a binary distribution. - If there's a tmp directory in gcc's include directory, fixincludes - didn't complete. You should have run "just-fixinc" instead. - - Another possible cause is using ``gcc -I/usr/include.'' - -6.1) Where is the C compiler or where can I get one? - - [...] - - 3) Gcc. - - Gcc is available from the GNU archives in source and binary - form. Look in a directory called sparc-sun-solaris2 for - binaries. You need gcc 2.3.3 or later. You should not use - GNU as or GNU ld. Make sure you run just-fixinc if you use - a binary distribution. Better is to get a binary version and - use that to bootstrap gcc from source. - - [...] - - When you install gcc, don't make the mistake of installing - GNU binutils or GNU libc, they are not as capable as their - counterparts you get with Solaris 2.x. - -6.9) I can't get perl 4.036 to compile or run. - - Run Configure, and use the solaris_2_0 hints, *don't* use - the solaris_2_1 hints and don't use the config.sh you may - already have. First you must make sure Configure and make - don't find /usr/ucb/cc. (It must use gcc or the native C - compiler: /opt/SUNWspro/bin/cc) - - Some questions need a special answer. - - Are your system (especially dbm) libraries compiled with gcc? [y] y - - yes: gcc 2.3.3 or later uses the standard calling - conventions, same as Sun's C. - - Any additional cc flags? [ -traditional -Dvolatile=__volatile__ - -I/usr/ucbinclude] -traditional -Dvolatile=__volatile__ - Remove /usr/ucbinclude. - - Any additional libraries? [-lsocket -lnsl -ldbm -lmalloc -lm - -lucb] -lsocket -lnsl -lm - - Don't include -ldbm, -lmalloc and -lucb. - - Perl 5 compiled out of the box. - -7.0) 64-bitness, from Alan Burlison (added by jhi 2000-02-21) - - You need a machine running Solaris 2.7 or above. - - Here's some rules: - - 1. Solaris 2.7 and above will run in either 32 bit or 64 bit mode, - via a reboot. - 2. You can build 64 bit apps whilst running 32 bit mode and vice-versa. - 3. 32 bit apps will run under Solaris running in either 32 or 64 bit mode. - 4. 64 bit apps require Solaris to be running 64 bit mode - 5. It is possible to select the appropriate 32 or 64 bit version of an - app at run-time using isaexec(3). - 6. You can detect the OS mode using "isainfo -v", e.g. - fubar$ isainfo -v # Ultra 30 in 64 bit mode - 64-bit sparcv9 applications - 32-bit sparc applications - 7. To compile 64 bit you need to use the flag "-xarch=v9". - getconf(1) will tell you this, e.g. - fubar$ getconf -a | grep v9 - XBS5_LP64_OFF64_CFLAGS: -xarch=v9 - XBS5_LP64_OFF64_LDFLAGS: -xarch=v9 - XBS5_LP64_OFF64_LINTFLAGS: -xarch=v9 - XBS5_LPBIG_OFFBIG_CFLAGS: -xarch=v9 - XBS5_LPBIG_OFFBIG_LDFLAGS: -xarch=v9 - XBS5_LPBIG_OFFBIG_LINTFLAGS: -xarch=v9 - _XBS5_LP64_OFF64_CFLAGS: -xarch=v9 - _XBS5_LP64_OFF64_LDFLAGS: -xarch=v9 - _XBS5_LP64_OFF64_LINTFLAGS: -xarch=v9 - _XBS5_LPBIG_OFFBIG_CFLAGS: -xarch=v9 - _XBS5_LPBIG_OFFBIG_LDFLAGS: -xarch=v9 - _XBS5_LPBIG_OFFBIG_LINTFLAGS: -xarch=v9 - - > > Now, what should we do, then? Should -Duse64bits in a v9 box cause - > > Perl to compiled in v9 mode? Or should we for compatibility stick - > > with 32 bit builds and let the people in the know to add the -xarch=v9 - > > to ccflags (and ldflags?)? - - > I think the second (explicit) mechanism should be the default. Unless - > you want to allocate more than ~ 4Gb of memory inside Perl, you don't - > need Perl to be a 64-bit app. Put it this way, on a machine running - > Solaris 8, there are 463 executables under /usr/bin, but only 15 of - > those require 64 bit versions - mainly because they invade the kernel - > address space, e.g. adb, kgmon etc. Certainly we don't recommend users - > to build 64 bit apps unless they need the address space. - -End_of_Solaris_Notes - +rm -f try.c try.o try a.out diff --git a/hints/svr4.sh b/hints/svr4.sh index 8109b39..69af6fd 100644 --- a/hints/svr4.sh +++ b/hints/svr4.sh @@ -135,6 +135,22 @@ case "`uname -sm`" in ;; esac +# NCR MP-RAS. Thanks to Doug Hendricks for this info. +# The output of uname -a looks like this +# foo foo 4.0 3.0 3441 Pentium III(TM)-ISA/PCI +# Configure sets osname=svr4.0, osvers=3.0, archname='3441-svr4.0' +case "$myuname" in +*3441*) + # With the NCR High Performance C Compiler R3.0c, miniperl fails + # t/op/regexp.t test 461 unless we compile with optimizie=-g. + # The whole O/S is being phased out, so more detailed probing + # is probably not warranted. + case "$optimize" in + '') optimize='-g' ;; + esac + ;; +esac + # Configure may fail to find lstat() since it's a static/inline function # in on Unisys U6000 SVR4, UnixWare 2.x, and possibly other # SVR4 derivatives. (Though UnixWare has it in /usr/ccs/lib/libc.so.) diff --git a/hints/uts.sh b/hints/uts.sh index 74698db..2bae4b0 100644 --- a/hints/uts.sh +++ b/hints/uts.sh @@ -1,4 +1,18 @@ -ccflags="$ccflags -DCRIPPLED_CC" -d_lstat='define' -usedl='undef' - +archname='s390' +cc='cc -Xa' +cccdlflags='-pic' +d_bincompat3='undef' +d_csh='undef' +d_lstat='define' +d_suidsafe='define' +dlsrc='dl_dlopen.xs' +ld='ld' +lddlflags='-G -z text' +libperl='libperl.so' +libpth='/lib /usr/lib /usr/ccs/lib' +libs='-lsocket -lnsl -ldl -lm' +optimize='undef' +prefix='psf_prefix' +static_ext='none' +dynamic_ext='Fcntl IO Opcode Socket' +useshrplib='define' diff --git a/hints/uwin.sh b/hints/uwin.sh index 0b2cf9d..9141efc 100644 --- a/hints/uwin.sh +++ b/hints/uwin.sh @@ -24,7 +24,7 @@ i_utime=undef # compile/link flags ldflags=-g optimize=-g -static_ext="B Data/Dumper Fcntl IO IPC/SysV Opcode POSIX SDBM_File Socket Storable attrs" +static_ext="B Data/Dumper Fcntl Filter::Util::Call IO IPC/SysV Opcode POSIX SDBM_File Socket Storable attrs" #static_ext=none # dynamic loading needs work usedl=undef diff --git a/hints/vmesa.sh b/hints/vmesa.sh index 2b3dd28..81ab6a4 100644 --- a/hints/vmesa.sh +++ b/hints/vmesa.sh @@ -218,7 +218,7 @@ dynamic_ext='' eagain='EAGAIN' ebcdic='define' exe_ext='' -extensions='Fcntl GDBM_File IO NDBM_File Opcode POSIX Socket Storable IPC/SysV Errno Thread attrs re Data/Dumper' +extensions=' Data/Dumper Errno Fcntl Filter::Util:Call GDBM_File IO NDBM_File Opcode POSIX Socket Storable IPC/SysV Thread attrs re' fpostype='fpos_t' freetype='void' groupstype='gid_t' diff --git a/hv.c b/hv.c index 8a43a19..0e50523 100644 --- a/hv.c +++ b/hv.c @@ -1,6 +1,6 @@ /* hv.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -75,20 +75,27 @@ S_save_hek(pTHX_ const char *str, I32 len, U32 hash) { char *k; register HEK *hek; + bool is_utf8 = FALSE; + + if (len < 0) { + len = -len; + is_utf8 = TRUE; + } New(54, k, HEK_BASESIZE + len + 1, char); hek = (HEK*)k; Copy(str, HEK_KEY(hek), len, char); - *(HEK_KEY(hek) + len) = '\0'; HEK_LEN(hek) = len; HEK_HASH(hek) = hash; + HEK_UTF8(hek) = (char)is_utf8; return hek; } void Perl_unshare_hek(pTHX_ HEK *hek) { - unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek)); + unsharepvn(HEK_KEY(hek),HEK_UTF8(hek)?-HEK_LEN(hek):HEK_LEN(hek), + HEK_HASH(hek)); } #if defined(USE_ITHREADS) @@ -112,9 +119,9 @@ Perl_he_dup(pTHX_ HE *e, bool shared) if (HeKLEN(e) == HEf_SVKEY) HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e))); else if (shared) - HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN(e), HeHASH(e)); + HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e)); else - HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN(e), HeHASH(e)); + HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e)); HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e))); return ret; } @@ -138,19 +145,24 @@ information on how to use this function on tied hashes. */ SV** -Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval) +Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval) { register XPVHV* xhv; register U32 hash; register HE *entry; SV *sv; + bool is_utf8 = FALSE; if (!hv) return 0; + if (klen < 0) { + klen = -klen; + is_utf8 = TRUE; + } + if (SvRMAGICAL(hv)) { if (mg_find((SV*)hv,'P')) { - dTHR; sv = sv_newmortal(); mg_copy((SV*)hv, sv, key, klen); PL_hv_fetch_sv = sv; @@ -194,6 +206,8 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval) continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; return &HeVAL(entry); } #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */ @@ -209,7 +223,7 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval) #endif if (lval) { /* gonna assign to this, so it better be there */ sv = NEWSV(61,0); - return hv_store(hv,key,klen,sv,hash); + return hv_store(hv,key,is_utf8?-klen:klen,sv,hash); } return 0; } @@ -241,13 +255,13 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) STRLEN klen; register HE *entry; SV *sv; + bool is_utf8; if (!hv) return 0; if (SvRMAGICAL(hv)) { if (mg_find((SV*)hv,'P')) { - dTHR; sv = sv_newmortal(); keysv = sv_2mortal(newSVsv(keysv)); mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY); @@ -291,6 +305,7 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) } key = SvPV(keysv, klen); + is_utf8 = (SvUTF8(keysv)!=0); if (!hash) PERL_HASH(hash, key, klen); @@ -303,6 +318,8 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; return entry; } #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */ @@ -361,16 +378,22 @@ information on how to use this function on tied hashes. */ SV** -Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 hash) +Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 hash) { register XPVHV* xhv; register I32 i; register HE *entry; register HE **oentry; + bool is_utf8 = FALSE; if (!hv) return 0; + if (klen < 0) { + klen = -klen; + is_utf8 = TRUE; + } + xhv = (XPVHV*)SvANY(hv); if (SvMAGICAL(hv)) { bool needs_copy; @@ -406,6 +429,8 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 has continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; SvREFCNT_dec(HeVAL(entry)); HeVAL(entry) = val; return &HeVAL(entry); @@ -413,9 +438,9 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 has entry = new_HE(); if (HvSHAREKEYS(hv)) - HeKEY_hek(entry) = share_hek(key, klen, hash); + HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash); else /* gotta do the real thing */ - HeKEY_hek(entry) = save_hek(key, klen, hash); + HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash); HeVAL(entry) = val; HeNEXT(entry) = *oentry; *oentry = entry; @@ -458,13 +483,13 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash) register I32 i; register HE *entry; register HE **oentry; + bool is_utf8; if (!hv) return 0; xhv = (XPVHV*)SvANY(hv); if (SvMAGICAL(hv)) { - dTHR; bool needs_copy; bool needs_store; hv_magic_check (hv, &needs_copy, &needs_store); @@ -489,6 +514,7 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash) } key = SvPV(keysv, klen); + is_utf8 = (SvUTF8(keysv) != 0); if (!hash) PERL_HASH(hash, key, klen); @@ -507,6 +533,8 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash) continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; SvREFCNT_dec(HeVAL(entry)); HeVAL(entry) = val; return entry; @@ -514,9 +542,9 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash) entry = new_HE(); if (HvSHAREKEYS(hv)) - HeKEY_hek(entry) = share_hek(key, klen, hash); + HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash); else /* gotta do the real thing */ - HeKEY_hek(entry) = save_hek(key, klen, hash); + HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash); HeVAL(entry) = val; HeNEXT(entry) = *oentry; *oentry = entry; @@ -543,7 +571,7 @@ will be returned. */ SV * -Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags) +Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags) { register XPVHV* xhv; register I32 i; @@ -552,9 +580,14 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags) register HE **oentry; SV **svp; SV *sv; + bool is_utf8 = FALSE; if (!hv) return Nullsv; + if (klen < 0) { + klen = -klen; + is_utf8 = TRUE; + } if (SvRMAGICAL(hv)) { bool needs_copy; bool needs_store; @@ -594,6 +627,8 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags) continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; *oentry = HeNEXT(entry); if (i && !*oentry) xhv->xhv_fill--; @@ -634,6 +669,7 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) register HE *entry; register HE **oentry; SV *sv; + bool is_utf8; if (!hv) return Nullsv; @@ -667,6 +703,7 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) return Nullsv; key = SvPV(keysv, klen); + is_utf8 = (SvUTF8(keysv) != 0); if (!hash) PERL_HASH(hash, key, klen); @@ -681,6 +718,8 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; *oentry = HeNEXT(entry); if (i && !*oentry) xhv->xhv_fill--; @@ -710,19 +749,24 @@ C is the length of the key. */ bool -Perl_hv_exists(pTHX_ HV *hv, const char *key, U32 klen) +Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen) { register XPVHV* xhv; register U32 hash; register HE *entry; SV *sv; + bool is_utf8 = FALSE; if (!hv) return 0; + if (klen < 0) { + klen = -klen; + is_utf8 = TRUE; + } + if (SvRMAGICAL(hv)) { if (mg_find((SV*)hv,'P')) { - dTHR; sv = sv_newmortal(); mg_copy((SV*)hv, sv, key, klen); magic_existspack(sv, mg_find(sv, 'p')); @@ -756,6 +800,8 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, U32 klen) continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; return TRUE; } #ifdef DYNAMIC_ENV_FETCH /* is it out there? */ @@ -792,13 +838,13 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) STRLEN klen; register HE *entry; SV *sv; + bool is_utf8; if (!hv) return 0; if (SvRMAGICAL(hv)) { if (mg_find((SV*)hv,'P')) { - dTHR; /* just for SvTRUE */ sv = sv_newmortal(); keysv = sv_2mortal(newSVsv(keysv)); mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY); @@ -822,6 +868,7 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) #endif key = SvPV(keysv, klen); + is_utf8 = (SvUTF8(keysv) != 0); if (!hash) PERL_HASH(hash, key, klen); @@ -837,6 +884,8 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; return TRUE; } #ifdef DYNAMIC_ENV_FETCH /* is it out there? */ @@ -1051,8 +1100,8 @@ Perl_newHVhv(pTHX_ HV *ohv) /* Slow way */ hv_iterinit(ohv); while ((entry = hv_iternext(ohv))) { - hv_store(hv, HeKEY(entry), HeKLEN(entry), - SvREFCNT_inc(HeVAL(entry)), HeHASH(entry)); + hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry), + newSVsv(HeVAL(entry)), HeHASH(entry)); } HvRITER(ohv) = hv_riter; HvEITER(ohv) = hv_eiter; @@ -1342,10 +1391,9 @@ Perl_hv_iterkeysv(pTHX_ register HE *entry) { if (HeKLEN(entry) == HEf_SVKEY) return sv_mortalcopy(HeKEY_sv(entry)); - else { + else return sv_2mortal(newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""), - HeKLEN(entry), HeHASH(entry))); - } + HeKLEN_UTF8(entry), HeHASH(entry))); } /* @@ -1422,6 +1470,12 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash) register HE **oentry; register I32 i = 1; I32 found = 0; + bool is_utf8 = FALSE; + + if (len < 0) { + len = -len; + is_utf8 = TRUE; + } /* what follows is the moral equivalent of: if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) { @@ -1439,6 +1493,8 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash) continue; if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; found = 1; if (--HeVAL(entry) == Nullsv) { *oentry = HeNEXT(entry); @@ -1452,11 +1508,8 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash) } UNLOCK_STRTAB_MUTEX; - { - dTHR; - if (!found && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str); - } + if (!found && ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str); } /* get a (constant) string ptr from the global string table @@ -1471,6 +1524,12 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash) register HE **oentry; register I32 i = 1; I32 found = 0; + bool is_utf8 = FALSE; + + if (len < 0) { + len = -len; + is_utf8 = TRUE; + } /* what follows is the moral equivalent of: @@ -1488,12 +1547,14 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash) continue; if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; found = 1; break; } if (!found) { entry = new_HE(); - HeKEY_hek(entry) = save_hek(str, len, hash); + HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash); HeVAL(entry) = Nullsv; HeNEXT(entry) = *oentry; *oentry = entry; diff --git a/hv.h b/hv.h index 08f3bed..5def051 100644 --- a/hv.h +++ b/hv.h @@ -1,6 +1,6 @@ /* hv.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -151,6 +151,8 @@ C. #define HeKEY(he) HEK_KEY(HeKEY_hek(he)) #define HeKEY_sv(he) (*(SV**)HeKEY(he)) #define HeKLEN(he) HEK_LEN(HeKEY_hek(he)) +#define HeKUTF8(he) HEK_UTF8(HeKEY_hek(he)) +#define HeKLEN_UTF8(he) (HeKUTF8(he) ? -HeKLEN(he) : HeKLEN(he)) #define HeVAL(he) (he)->hent_val #define HeHASH(he) HEK_HASH(HeKEY_hek(he)) #define HePV(he,lp) ((HeKLEN(he) == HEf_SVKEY) ? \ @@ -175,6 +177,7 @@ C. #define HEK_HASH(hek) (hek)->hek_hash #define HEK_LEN(hek) (hek)->hek_len #define HEK_KEY(hek) (hek)->hek_key +#define HEK_UTF8(hek) (*(HEK_KEY(hek)+HEK_LEN(hek))) /* calculate HV array allocation */ #if defined(STRANGE_MALLOC) || defined(MYMALLOC) diff --git a/installhtml b/installhtml index bef35e9..b5406c5 100755 --- a/installhtml +++ b/installhtml @@ -1,9 +1,8 @@ -#!./perl -w +#!./perl -Ilib -w # This file should really be extracted from a .PL file -use lib 'lib'; # use source library if present - +use strict; use Config; # for config options in the makefile use Getopt::Long; # for command-line parsing use Cwd; @@ -110,6 +109,8 @@ Chris Hall Ehallc@cs.colorado.eduE =cut +my $usage; + $usage =<:...: --podroot= --htmldir= --htmlroot= --norecurse --recurse @@ -142,6 +143,9 @@ Usage: $0 --help --podpath=:...: --podroot= END_OF_USAGE +my (@libpods, @podpath, $podroot, $htmldir, $htmlroot, $recurse, @splithead, + @splititem, $splitpod, $verbose, $pod2html); + @libpods = (); @podpath = ( "." ); # colon-separated list of directories containing .pod # and .pm files to be converted. @@ -163,8 +167,12 @@ usage("") unless @ARGV; # See vms/descrip_mms.template -> descrip.mms for invokation. if ( $^O eq 'VMS' ) { @ARGV = split(/\s+/,$ARGV[0]); } +use vars qw($opt_htmldir $opt_htmlroot $opt_podroot $opt_splitpod + $opt_verbose $opt_help $opt_podpath $opt_splithead $opt_splititem + $opt_libpods $opt_recurse); + # parse the command-line -$result = GetOptions( qw( +my $result = GetOptions( qw( help podpath=s podroot=s @@ -196,8 +204,8 @@ $splitpod = "$podroot/pod" unless $splitpod; # ignored in the conversion process. these are files that have been # process by splititem or splithead and should not be converted as a # result. -@ignore = (); - +my @ignore = (); +my @splitdirs; # split pods. its important to do this before convert ANY pods because # it may effect some of the links @@ -209,25 +217,25 @@ split_on_item($podroot, \@splitdirs, \@ignore, @splititem); # convert the pod pages found in @poddirs #warn "converting files\n" if $verbose; #warn "\@ignore\t= @ignore\n" if $verbose; -foreach $dir (@podpath) { +foreach my $dir (@podpath) { installdir($dir, $recurse, $podroot, \@splitdirs, \@ignore); } # now go through and create master indices for each pod we split -foreach $dir (@splititem) { +foreach my $dir (@splititem) { print "creating index $htmldir/$dir.html\n" if $verbose; create_index("$htmldir/$dir.html", "$htmldir/$dir"); } -foreach $dir (@splithead) { +foreach my $dir (@splithead) { $dir .= ".pod" unless $dir =~ /(\.pod|\.pm)$/; # let pod2html create the file runpod2html($dir, 1); # now go through and truncate after the index $dir =~ /^(.*?)(\.pod|\.pm)?$/sm; - $file = "$htmldir/$1"; + my $file = "$htmldir/$1"; print "creating index $file.html\n" if $verbose; # read in everything until what would have been the first =head @@ -235,7 +243,7 @@ foreach $dir (@splithead) { open(H, "<$file.html") || die "$0: error opening $file.html for input: $!\n"; $/ = ""; - @data = (); + my @data = (); while () { last if /NAME=/; $_ =~ s{HREF="#(.*)">}{ @@ -251,7 +259,7 @@ foreach $dir (@splithead) { # now rewrite the file open(H, ">$file.html") || die "$0: error opening $file.html for output: $!\n"; - print H "@data\n"; + print H "@data", "\n"; close(H); } @@ -322,6 +330,7 @@ sub create_index { close(IN); # pull out the NAME section + my $name; ($name) = grep(/NAME=/, @filedata); ($lcp1,$lcp2) = ($name =~ m,/H1>\s(\S+)\s[\s-]*(.*?)\s*$,sm); if (defined $lcp1 and $lcp1 eq '

') { # Uninteresting. Try again. @@ -383,7 +392,7 @@ sub split_on_item { print "splitting files by item.\n" if $verbose && $#splititem >= 0; $pwd = getcwd(); my $splitter = absolute_path($pwd, "$splitpod/splitpod"); - foreach $pod (@splititem) { + foreach my $pod (@splititem) { # figure out the directory to split into $pod =~ s,^([^/]*)$,/$1,; $pod =~ m,(.*?)/(.*?)(\.pod)?$,; @@ -443,7 +452,7 @@ sub splitpod { # create list of =head[1-6] sections so that we can rewrite # L<> links as necessary. - %heads = (); + my %heads = (); foreach $i (0..$#poddata) { $heads{htmlize($1)} = 1 if $poddata[$i] =~ /=head[1-6]\s+(.*)/; } @@ -451,7 +460,7 @@ sub splitpod { # create a directory of a similar name and store all the # files in there $pod =~ s,.*/(.*),$1,; # get the last part of the name - $dir = $pod; + my $dir = $pod; $dir =~ s/\.pod//g; push(@$splitdirs, "$poddir/$dir"); mkdir("$poddir/$dir", 0755) || @@ -538,7 +547,7 @@ sub installdir { } # install all the pods we found - foreach $pod (@podlist) { + foreach my $pod (@podlist) { # check if we should ignore it. next if grep($_ eq "$podroot/$pod.pod", @$ignore); @@ -552,7 +561,7 @@ sub installdir { } # install all the .pm files we found - foreach $pm (@pmlist) { + foreach my $pm (@pmlist) { # check if we should ignore it. next if grep($_ eq "$pm.pm", @ignore); diff --git a/installman b/installman index 72c76fd..06f68f5 100755 --- a/installman +++ b/installman @@ -23,19 +23,21 @@ die "Patchlevel of perl ($patchlevel)", my $usage = "Usage: installman --man1dir=/usr/wherever --man1ext=1 --man3dir=/usr/wherever --man3ext=3 + --batchlimit=40 --notify --verbose --silent --help Defaults are: man1dir = $Config{'installman1dir'}; man1ext = $Config{'man1ext'}; man3dir = $Config{'installman3dir'}; man3ext = $Config{'man3ext'}; + batchlimit is maximum number of pod files per invocation of pod2man --notify (or -n) just lists commands that would be executed. --verbose (or -V) report all progress. --silent (or -S) be silent. Only report errors.\n"; my %opts; GetOptions( \%opts, - qw( man1dir=s man1ext=s man3dir=s man3ext=s + qw( man1dir=s man1ext=s man3dir=s man3ext=s batchlimit=i notify n help silent S verbose V)) || die $usage; die $usage if $opts{help}; @@ -48,6 +50,7 @@ $opts{man3dir} = $Config{'installman3dir'} unless defined($opts{man3dir}); $opts{man3ext} = $Config{'man3ext'} unless defined($opts{man3ext}); +$opts{batchlimit} ||= 40; $opts{silent} ||= $opts{S}; $opts{notify} ||= $opts{n}; $opts{verbose} ||= $opts{V} || $opts{notify}; @@ -71,24 +74,12 @@ runpod2man('pod', $opts{man1dir}, $opts{man1ext}); runpod2man('lib', $opts{man3dir}, $opts{man3ext}); # Install the pods embedded in the installed scripts -runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'c2ph'); -runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'h2ph'); -runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'h2xs'); -runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'perlcc'); -runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'perldoc'); -runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'perlbug'); -runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'pl2pm'); -runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'splain'); -runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'dprofpp'); -runpod2man('x2p', $opts{man1dir}, $opts{man1ext}, 's2p'); -runpod2man('x2p', $opts{man1dir}, $opts{man1ext}, 'a2p.pod'); -runpod2man('x2p', $opts{man1dir}, $opts{man1ext}, 'find2perl'); -runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2man'); -runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2html'); -runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2text'); -runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2usage'); -runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'podchecker'); -runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'podselect'); +runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'c2ph', 'h2ph', 'h2xs', + 'perlcc', 'perldoc', 'perlbug', 'pl2pm', 'splain', 'dprofpp'); +runpod2man('x2p', $opts{man1dir}, $opts{man1ext}, 's2p', 'a2p.pod', + 'find2perl'); +runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2man', 'pod2html', + 'pod2text', 'pod2usage', 'podchecker', 'podselect'); # It would probably be better to have this page linked # to the c2ph man page. Or, this one could say ".so man1/c2ph.1", @@ -98,9 +89,9 @@ runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'pstruct'); runpod2man('lib/ExtUtils', $opts{man1dir}, $opts{man1ext}, 'xsubpp'); sub runpod2man { - # $script is script name if we are installing a manpage embedded - # in a script, undef otherwise - my($poddir, $mandir, $manext, $script) = @_; + # @script is scripts names if we are installing manpages embedded + # in scripts, () otherwise + my($poddir, $mandir, $manext, @script) = @_; my($downdir); # can't just use .. when installing xsubpp manpage @@ -109,8 +100,12 @@ sub runpod2man { my($builddir) = Cwd::getcwd(); if ($mandir eq ' ' or $mandir eq '') { - warn "Skipping installation of ", - ($script ? "$poddir/$script man page" : "$poddir man pages"), ".\n"; + if (@script) { + warn "Skipping installation of $poddir/$_ man page.\n" + foreach @script; + } else { + warn "Skipping installation of $poddir man pages.\n"; + } return; } @@ -134,13 +129,14 @@ sub runpod2man { # Make a list of all the .pm and .pod files in the directory. We will # always run pod2man from the lib directory and feed it the full pathname # of the pod. This might be useful for pod2man someday. - if ($script) { - @modpods = ($script); + if (@script) { + @modpods = @script; } else { @modpods = (); File::Find::find(\&lsmodpods, '.'); } + my @to_process; foreach my $mod (@modpods) { my $manpage = $mod; my $tmp; @@ -159,15 +155,25 @@ sub runpod2man { } $tmp = "${mandir}/${manpage}.tmp"; $manpage = "${mandir}/${manpage}.${manext}"; - if (&cmd("$pod2man $mod > $tmp") == 0 && !$opts{notify} && -s $tmp) { - if (rename($tmp, $manpage)) { - $packlist->{$manpage} = { type => 'file' }; - next; + push @to_process, [$mod, $tmp, $manpage]; + } + # Don't do all pods in same command to avoid busting command line limits + while (my @this_batch = splice @to_process, 0, $opts{batchlimit}) { + my $cmd = join " ", $pod2man, map "$$_[0] $$_[1]", @this_batch; + if (&cmd($cmd) == 0 && !$opts{notify}) { + foreach (@this_batch) { + my (undef, $tmp, $manpage) = @$_; + if (-s $tmp) { + if (rename($tmp, $manpage)) { + $packlist->{$manpage} = { type => 'file' }; + next; + } + } + unless ($opts{notify}) { + unlink($tmp); + } } } - unless ($opts{notify}) { - unlink($tmp); - } } chdir "$builddir" || die "Unable to cd back to $builddir directory!\n$!\n"; print " chdir $builddir\n" if $opts{verbose}; diff --git a/installperl b/installperl index 99d376f..f3788cf 100755 --- a/installperl +++ b/installperl @@ -162,8 +162,8 @@ if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; } -x 'suidperl' . $exe_ext|| die "suidperl isn't executable!\n" if $d_dosuid; -f 't/rantests' || $Is_W32 - || warn "WARNING: You've never run 'make test'!!!", - " (Installing anyway.)\n"; + || warn "WARNING: You've never run 'make test' or", + " some tests failed! (Installing anyway.)\n"; if ($Is_W32 or $Is_Cygwin) { my $perldll; diff --git a/intrpvar.h b/intrpvar.h index 07ec33e..e9c3797 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -97,7 +97,7 @@ C. =for apidoc Amn|SV *|PL_DBsingle When Perl is run in debugging mode, with the B<-d> switch, this SV is a -boolean which indicates whether subs are being single-stepped. +boolean which indicates whether subs are being single-stepped. Single-stepping is automatically turned on after every step. This is the C variable which corresponds to Perl's $DB::single variable. See C. @@ -169,8 +169,7 @@ PERLVARI(Ilaststype, I32, OP_STAT) PERLVAR(Imess_sv, SV *) /* XXX shouldn't these be per-thread? --GSAR */ -PERLVAR(Iors, char *) /* output record separator $\ */ -PERLVAR(Iorslen, STRLEN) +PERLVAR(Iors_sv, SV *) /* output record separator $\ */ PERLVAR(Iofmt, char *) /* output format for numbers $# */ /* interpreter atexit processing */ @@ -181,10 +180,10 @@ PERLVARI(Iexitlistlen, I32, 0) /* length of same */ /* =for apidoc Amn|HV*|PL_modglobal -C is a general purpose, interpreter global HV for use by +C is a general purpose, interpreter global HV for use by extensions that need to keep information on a per-interpreter basis. -In a pinch, it can also be used as a symbol table for extensions -to share data among each other. It is a good idea to use keys +In a pinch, it can also be used as a symbol table for extensions +to share data among each other. It is a good idea to use keys prefixed by the package name of the extension that owns the data. =cut diff --git a/iperlsys.h b/iperlsys.h index 59da474..fe03f5c 100644 --- a/iperlsys.h +++ b/iperlsys.h @@ -49,30 +49,11 @@ * */ - /* - Interface for perl stdio functions -*/ - - -/* Clean up (or at least document) the various possible #defines. - This section attempts to match the 5.003_03 Configure variables - onto the 5.003_02 header file values. - I can't figure out where USE_STDIO was supposed to be set. - --AD + Interface for perl stdio functions, or whatever we are Configure-d + to use. */ -#ifndef USE_PERLIO -# define PERLIO_IS_STDIO -#endif - -/* Below is the 5.003_02 stuff. */ -#ifdef USE_STDIO -# ifndef PERLIO_IS_STDIO -# define PERLIO_IS_STDIO -# endif -#else -extern void PerlIO_init (void); -#endif +#include "perlio.h" #ifndef Sighandler_t typedef Signal_t (*Sighandler_t) (int); @@ -80,60 +61,54 @@ typedef Signal_t (*Sighandler_t) (int); #if defined(PERL_IMPLICIT_SYS) -#ifndef PerlIO -typedef struct _PerlIO PerlIO; -#endif - /* IPerlStdIO */ struct IPerlStdIO; struct IPerlStdIOInfo; -typedef PerlIO* (*LPStdin)(struct IPerlStdIO*); -typedef PerlIO* (*LPStdout)(struct IPerlStdIO*); -typedef PerlIO* (*LPStderr)(struct IPerlStdIO*); -typedef PerlIO* (*LPOpen)(struct IPerlStdIO*, const char*, +typedef FILE* (*LPStdin)(struct IPerlStdIO*); +typedef FILE* (*LPStdout)(struct IPerlStdIO*); +typedef FILE* (*LPStderr)(struct IPerlStdIO*); +typedef FILE* (*LPOpen)(struct IPerlStdIO*, const char*, const char*); -typedef int (*LPClose)(struct IPerlStdIO*, PerlIO*); -typedef int (*LPEof)(struct IPerlStdIO*, PerlIO*); -typedef int (*LPError)(struct IPerlStdIO*, PerlIO*); -typedef void (*LPClearerr)(struct IPerlStdIO*, PerlIO*); -typedef int (*LPGetc)(struct IPerlStdIO*, PerlIO*); -typedef char* (*LPGetBase)(struct IPerlStdIO*, PerlIO*); -typedef int (*LPGetBufsiz)(struct IPerlStdIO*, PerlIO*); -typedef int (*LPGetCnt)(struct IPerlStdIO*, PerlIO*); -typedef char* (*LPGetPtr)(struct IPerlStdIO*, PerlIO*); -typedef char* (*LPGets)(struct IPerlStdIO*, PerlIO*, char*, int); -typedef int (*LPPutc)(struct IPerlStdIO*, PerlIO*, int); -typedef int (*LPPuts)(struct IPerlStdIO*, PerlIO*, const char*); -typedef int (*LPFlush)(struct IPerlStdIO*, PerlIO*); -typedef int (*LPUngetc)(struct IPerlStdIO*, PerlIO*,int); -typedef int (*LPFileno)(struct IPerlStdIO*, PerlIO*); -typedef PerlIO* (*LPFdopen)(struct IPerlStdIO*, int, const char*); -typedef PerlIO* (*LPReopen)(struct IPerlStdIO*, const char*, - const char*, PerlIO*); -typedef SSize_t (*LPRead)(struct IPerlStdIO*, PerlIO*, void*, Size_t); -typedef SSize_t (*LPWrite)(struct IPerlStdIO*, PerlIO*, const void*, +typedef int (*LPClose)(struct IPerlStdIO*, FILE*); +typedef int (*LPEof)(struct IPerlStdIO*, FILE*); +typedef int (*LPError)(struct IPerlStdIO*, FILE*); +typedef void (*LPClearerr)(struct IPerlStdIO*, FILE*); +typedef int (*LPGetc)(struct IPerlStdIO*, FILE*); +typedef char* (*LPGetBase)(struct IPerlStdIO*, FILE*); +typedef int (*LPGetBufsiz)(struct IPerlStdIO*, FILE*); +typedef int (*LPGetCnt)(struct IPerlStdIO*, FILE*); +typedef char* (*LPGetPtr)(struct IPerlStdIO*, FILE*); +typedef char* (*LPGets)(struct IPerlStdIO*, FILE*, char*, int); +typedef int (*LPPutc)(struct IPerlStdIO*, FILE*, int); +typedef int (*LPPuts)(struct IPerlStdIO*, FILE*, const char*); +typedef int (*LPFlush)(struct IPerlStdIO*, FILE*); +typedef int (*LPUngetc)(struct IPerlStdIO*, int,FILE*); +typedef int (*LPFileno)(struct IPerlStdIO*, FILE*); +typedef FILE* (*LPFdopen)(struct IPerlStdIO*, int, const char*); +typedef FILE* (*LPReopen)(struct IPerlStdIO*, const char*, + const char*, FILE*); +typedef SSize_t (*LPRead)(struct IPerlStdIO*, void*, Size_t, Size_t, FILE *); +typedef SSize_t (*LPWrite)(struct IPerlStdIO*, const void*, Size_t, Size_t, FILE *); +typedef void (*LPSetBuf)(struct IPerlStdIO*, FILE*, char*); +typedef int (*LPSetVBuf)(struct IPerlStdIO*, FILE*, char*, int, Size_t); -typedef void (*LPSetBuf)(struct IPerlStdIO*, PerlIO*, char*); -typedef int (*LPSetVBuf)(struct IPerlStdIO*, PerlIO*, char*, int, - Size_t); -typedef void (*LPSetCnt)(struct IPerlStdIO*, PerlIO*, int); -typedef void (*LPSetPtrCnt)(struct IPerlStdIO*, PerlIO*, char*, - int); -typedef void (*LPSetlinebuf)(struct IPerlStdIO*, PerlIO*); -typedef int (*LPPrintf)(struct IPerlStdIO*, PerlIO*, const char*, +typedef void (*LPSetCnt)(struct IPerlStdIO*, FILE*, int); +typedef void (*LPSetPtr)(struct IPerlStdIO*, FILE*, char*); +typedef void (*LPSetlinebuf)(struct IPerlStdIO*, FILE*); +typedef int (*LPPrintf)(struct IPerlStdIO*, FILE*, const char*, ...); -typedef int (*LPVprintf)(struct IPerlStdIO*, PerlIO*, const char*, +typedef int (*LPVprintf)(struct IPerlStdIO*, FILE*, const char*, va_list); -typedef long (*LPTell)(struct IPerlStdIO*, PerlIO*); -typedef int (*LPSeek)(struct IPerlStdIO*, PerlIO*, Off_t, int); -typedef void (*LPRewind)(struct IPerlStdIO*, PerlIO*); -typedef PerlIO* (*LPTmpfile)(struct IPerlStdIO*); -typedef int (*LPGetpos)(struct IPerlStdIO*, PerlIO*, Fpos_t*); -typedef int (*LPSetpos)(struct IPerlStdIO*, PerlIO*, +typedef long (*LPTell)(struct IPerlStdIO*, FILE*); +typedef int (*LPSeek)(struct IPerlStdIO*, FILE*, Off_t, int); +typedef void (*LPRewind)(struct IPerlStdIO*, FILE*); +typedef FILE* (*LPTmpfile)(struct IPerlStdIO*); +typedef int (*LPGetpos)(struct IPerlStdIO*, FILE*, Fpos_t*); +typedef int (*LPSetpos)(struct IPerlStdIO*, FILE*, const Fpos_t*); typedef void (*LPInit)(struct IPerlStdIO*); typedef void (*LPInitOSExtras)(struct IPerlStdIO*); -typedef PerlIO* (*LPFdupopen)(struct IPerlStdIO*, PerlIO*); +typedef FILE* (*LPFdupopen)(struct IPerlStdIO*, FILE*); struct IPerlStdIO { @@ -163,7 +138,7 @@ struct IPerlStdIO LPSetBuf pSetBuf; LPSetVBuf pSetVBuf; LPSetCnt pSetCnt; - LPSetPtrCnt pSetPtrCnt; + LPSetPtr pSetPtr; LPSetlinebuf pSetlinebuf; LPPrintf pPrintf; LPVprintf pVprintf; @@ -184,297 +159,181 @@ struct IPerlStdIOInfo struct IPerlStdIO perlStdIOList; }; +/* These do not belong here ... NI-S, 14 Nov 2000 */ + #ifdef USE_STDIO_PTR -# define PerlIO_has_cntptr(f) 1 -# ifdef STDIO_CNT_LVALUE -# define PerlIO_canset_cnt(f) 1 -# ifdef STDIO_PTR_LVALUE -# define PerlIO_fast_gets(f) 1 +# define PerlSIO_has_cntptr(f) 1 +# ifdef STDIO_PTR_LVALUE +# ifdef STDIO_CNT_LVALUE +# define PerlSIO_canset_cnt(f) 1 +# ifdef STDIO_PTR_LVAL_NOCHANGE_CNT +# define PerlSIO_fast_gets(f) 1 +# endif +# else /* STDIO_CNT_LVALUE */ +# define PerlSIO_canset_cnt(f) 0 +# endif +# else /* STDIO_PTR_LVALUE */ +# ifdef STDIO_PTR_LVAL_SETS_CNT +# define PerlSIO_fast_gets(f) 1 # endif -# else -# define PerlIO_canset_cnt(f) 0 # endif #else /* USE_STDIO_PTR */ -# define PerlIO_has_cntptr(f) 0 -# define PerlIO_canset_cnt(f) 0 +# define PerlSIO_has_cntptr(f) 0 +# define PerlSIO_canset_cnt(f) 0 #endif /* USE_STDIO_PTR */ -#ifndef PerlIO_fast_gets -#define PerlIO_fast_gets(f) 0 +#ifndef PerlSIO_fast_gets +#define PerlSIO_fast_gets(f) 0 #endif #ifdef FILE_base -#define PerlIO_has_base(f) 1 +#define PerlSIO_has_base(f) 1 #else -#define PerlIO_has_base(f) 0 +#define PerlSIO_has_base(f) 0 #endif -#define PerlIO_stdin() \ +/* Now take FILE * via function table */ + +#define PerlSIO_stdin \ (*PL_StdIO->pStdin)(PL_StdIO) -#define PerlIO_stdout() \ +#define PerlSIO_stdout \ (*PL_StdIO->pStdout)(PL_StdIO) -#define PerlIO_stderr() \ +#define PerlSIO_stderr \ (*PL_StdIO->pStderr)(PL_StdIO) -#define PerlIO_open(x,y) \ +#define PerlSIO_fopen(x,y) \ (*PL_StdIO->pOpen)(PL_StdIO, (x),(y)) -#define PerlIO_close(f) \ +#define PerlSIO_fclose(f) \ (*PL_StdIO->pClose)(PL_StdIO, (f)) -#define PerlIO_eof(f) \ +#define PerlSIO_feof(f) \ (*PL_StdIO->pEof)(PL_StdIO, (f)) -#define PerlIO_error(f) \ +#define PerlSIO_ferror(f) \ (*PL_StdIO->pError)(PL_StdIO, (f)) -#define PerlIO_clearerr(f) \ +#define PerlSIO_clearerr(f) \ (*PL_StdIO->pClearerr)(PL_StdIO, (f)) -#define PerlIO_getc(f) \ +#define PerlSIO_fgetc(f) \ (*PL_StdIO->pGetc)(PL_StdIO, (f)) -#define PerlIO_get_base(f) \ +#define PerlSIO_get_base(f) \ (*PL_StdIO->pGetBase)(PL_StdIO, (f)) -#define PerlIO_get_bufsiz(f) \ +#define PerlSIO_get_bufsiz(f) \ (*PL_StdIO->pGetBufsiz)(PL_StdIO, (f)) -#define PerlIO_get_cnt(f) \ +#define PerlSIO_get_cnt(f) \ (*PL_StdIO->pGetCnt)(PL_StdIO, (f)) -#define PerlIO_get_ptr(f) \ +#define PerlSIO_get_ptr(f) \ (*PL_StdIO->pGetPtr)(PL_StdIO, (f)) -#define PerlIO_putc(f,c) \ +#define PerlSIO_fputc(f,c) \ (*PL_StdIO->pPutc)(PL_StdIO, (f),(c)) -#define PerlIO_puts(f,s) \ +#define PerlSIO_fputs(f,s) \ (*PL_StdIO->pPuts)(PL_StdIO, (f),(s)) -#define PerlIO_flush(f) \ +#define PerlSIO_fflush(f) \ (*PL_StdIO->pFlush)(PL_StdIO, (f)) -#define PerlIO_gets(s, n, fp) \ +#define PerlSIO_fgets(s, n, fp) \ (*PL_StdIO->pGets)(PL_StdIO, (fp), s, n) -#define PerlIO_ungetc(f,c) \ - (*PL_StdIO->pUngetc)(PL_StdIO, (f),(c)) -#define PerlIO_fileno(f) \ +#define PerlSIO_ungetc(c,f) \ + (*PL_StdIO->pUngetc)(PL_StdIO, (c),(f)) +#define PerlSIO_fileno(f) \ (*PL_StdIO->pFileno)(PL_StdIO, (f)) -#define PerlIO_fdopen(f, s) \ +#define PerlSIO_fdopen(f, s) \ (*PL_StdIO->pFdopen)(PL_StdIO, (f),(s)) -#define PerlIO_reopen(p, m, f) \ +#define PerlSIO_freopen(p, m, f) \ (*PL_StdIO->pReopen)(PL_StdIO, (p), (m), (f)) -#define PerlIO_read(f,buf,count) \ - (SSize_t)(*PL_StdIO->pRead)(PL_StdIO, (f), (buf), (count)) -#define PerlIO_write(f,buf,count) \ - (*PL_StdIO->pWrite)(PL_StdIO, (f), (buf), (count)) -#define PerlIO_setbuf(f,b) \ +#define PerlSIO_fread(buf,sz,count,f) \ + (*PL_StdIO->pRead)(PL_StdIO, (buf), (sz), (count), (f)) +#define PerlSIO_fwrite(buf,sz,count,f) \ + (*PL_StdIO->pWrite)(PL_StdIO, (buf), (sz), (count), (f)) +#define PerlSIO_setbuf(f,b) \ (*PL_StdIO->pSetBuf)(PL_StdIO, (f), (b)) -#define PerlIO_setvbuf(f,b,t,s) \ +#define PerlSIO_setvbuf(f,b,t,s) \ (*PL_StdIO->pSetVBuf)(PL_StdIO, (f),(b),(t),(s)) -#define PerlIO_set_cnt(f,c) \ +#define PerlSIO_set_cnt(f,c) \ (*PL_StdIO->pSetCnt)(PL_StdIO, (f), (c)) -#define PerlIO_set_ptrcnt(f,p,c) \ - (*PL_StdIO->pSetPtrCnt)(PL_StdIO, (f), (p), (c)) -#define PerlIO_setlinebuf(f) \ +#define PerlSIO_set_ptr(f,p) \ + (*PL_StdIO->pSetPtr)(PL_StdIO, (f), (p)) +#define PerlSIO_setlinebuf(f) \ (*PL_StdIO->pSetlinebuf)(PL_StdIO, (f)) -#define PerlIO_printf Perl_fprintf_nocontext -#define PerlIO_stdoutf *PL_StdIO->pPrintf -#define PerlIO_vprintf(f,fmt,a) \ - (*PL_StdIO->pVprintf)(PL_StdIO, (f),(fmt),a) -#define PerlIO_tell(f) \ +#define PerlSIO_printf Perl_fprintf_nocontext +#define PerlSIO_stdoutf *PL_StdIO->pPrintf +#define PerlSIO_vprintf(f,fmt,a) \ + (*PL_StdIO->pVprintf)(PL_StdIO, (f),(fmt),a) +#define PerlSIO_ftell(f) \ (*PL_StdIO->pTell)(PL_StdIO, (f)) -#define PerlIO_seek(f,o,w) \ +#define PerlSIO_fseek(f,o,w) \ (*PL_StdIO->pSeek)(PL_StdIO, (f),(o),(w)) -#define PerlIO_getpos(f,p) \ +#define PerlSIO_fgetpos(f,p) \ (*PL_StdIO->pGetpos)(PL_StdIO, (f),(p)) -#define PerlIO_setpos(f,p) \ +#define PerlSIO_fsetpos(f,p) \ (*PL_StdIO->pSetpos)(PL_StdIO, (f),(p)) -#define PerlIO_rewind(f) \ +#define PerlSIO_rewind(f) \ (*PL_StdIO->pRewind)(PL_StdIO, (f)) -#define PerlIO_tmpfile() \ +#define PerlSIO_tmpfile() \ (*PL_StdIO->pTmpfile)(PL_StdIO) -#define PerlIO_init() \ +#define PerlSIO_init() \ (*PL_StdIO->pInit)(PL_StdIO) #undef init_os_extras #define init_os_extras() \ (*PL_StdIO->pInitOSExtras)(PL_StdIO) -#define PerlIO_fdupopen(f) \ +#define PerlSIO_fdupopen(f) \ (*PL_StdIO->pFdupopen)(PL_StdIO, (f)) #else /* PERL_IMPLICIT_SYS */ -#include "perlsdio.h" -#include "perl.h" -#define PerlIO_fdupopen(f) (f) - -#endif /* PERL_IMPLICIT_SYS */ - -#ifndef PERLIO_IS_STDIO -#ifdef USE_SFIO -#include "perlsfio.h" -#endif /* USE_SFIO */ -#endif /* PERLIO_IS_STDIO */ - -#ifndef EOF -#define EOF (-1) -#endif - -/* This is to catch case with no stdio */ -#ifndef BUFSIZ -#define BUFSIZ 1024 -#endif - -#ifndef SEEK_SET -#define SEEK_SET 0 -#endif - -#ifndef SEEK_CUR -#define SEEK_CUR 1 -#endif - -#ifndef SEEK_END -#define SEEK_END 2 -#endif - -#ifndef PerlIO -struct _PerlIO; -#define PerlIO struct _PerlIO -#endif /* No PerlIO */ - -#ifndef Fpos_t -#define Fpos_t long -#endif - -#ifndef NEXT30_NO_ATTRIBUTE -#ifndef HASATTRIBUTE /* disable GNU-cc attribute checking? */ -#ifdef __attribute__ /* Avoid possible redefinition errors */ -#undef __attribute__ -#endif -#define __attribute__(attr) -#endif -#endif - -#ifndef PerlIO_stdoutf -extern int PerlIO_stdoutf (const char *,...) - __attribute__((__format__ (__printf__, 1, 2))); -#endif -#ifndef PerlIO_puts -extern int PerlIO_puts (PerlIO *,const char *); -#endif -#ifndef PerlIO_open -extern PerlIO * PerlIO_open (const char *,const char *); -#endif -#ifndef PerlIO_close -extern int PerlIO_close (PerlIO *); -#endif -#ifndef PerlIO_eof -extern int PerlIO_eof (PerlIO *); -#endif -#ifndef PerlIO_error -extern int PerlIO_error (PerlIO *); -#endif -#ifndef PerlIO_clearerr -extern void PerlIO_clearerr (PerlIO *); -#endif -#ifndef PerlIO_getc -extern int PerlIO_getc (PerlIO *); -#endif -#ifndef PerlIO_putc -extern int PerlIO_putc (PerlIO *,int); -#endif -#ifndef PerlIO_flush -extern int PerlIO_flush (PerlIO *); -#endif -#ifndef PerlIO_ungetc -extern int PerlIO_ungetc (PerlIO *,int); -#endif -#ifndef PerlIO_fileno -extern int PerlIO_fileno (PerlIO *); -#endif -#ifndef PerlIO_fdopen -extern PerlIO * PerlIO_fdopen (int, const char *); -#endif -#ifndef PerlIO_importFILE -extern PerlIO * PerlIO_importFILE (FILE *,int); -#endif -#ifndef PerlIO_exportFILE -extern FILE * PerlIO_exportFILE (PerlIO *,int); -#endif -#ifndef PerlIO_findFILE -extern FILE * PerlIO_findFILE (PerlIO *); -#endif -#ifndef PerlIO_releaseFILE -extern void PerlIO_releaseFILE (PerlIO *,FILE *); -#endif -#ifndef PerlIO_read -extern SSize_t PerlIO_read (PerlIO *,void *,Size_t); -#endif -#ifndef PerlIO_write -extern SSize_t PerlIO_write (PerlIO *,const void *,Size_t); -#endif -#ifndef PerlIO_setlinebuf -extern void PerlIO_setlinebuf (PerlIO *); -#endif -#ifndef PerlIO_printf -extern int PerlIO_printf (PerlIO *, const char *,...) - __attribute__((__format__ (__printf__, 2, 3))); -#endif -#ifndef PerlIO_sprintf -extern int PerlIO_sprintf (char *, int, const char *,...) - __attribute__((__format__ (__printf__, 3, 4))); -#endif -#ifndef PerlIO_vprintf -extern int PerlIO_vprintf (PerlIO *, const char *, va_list); -#endif -#ifndef PerlIO_tell -extern Off_t PerlIO_tell (PerlIO *); -#endif -#ifndef PerlIO_seek -extern int PerlIO_seek (PerlIO *, Off_t, int); -#endif -#ifndef PerlIO_rewind -extern void PerlIO_rewind (PerlIO *); -#endif -#ifndef PerlIO_has_base -extern int PerlIO_has_base (PerlIO *); -#endif -#ifndef PerlIO_has_cntptr -extern int PerlIO_has_cntptr (PerlIO *); -#endif -#ifndef PerlIO_fast_gets -extern int PerlIO_fast_gets (PerlIO *); -#endif -#ifndef PerlIO_canset_cnt -extern int PerlIO_canset_cnt (PerlIO *); -#endif -#ifndef PerlIO_get_ptr -extern STDCHAR * PerlIO_get_ptr (PerlIO *); -#endif -#ifndef PerlIO_get_cnt -extern int PerlIO_get_cnt (PerlIO *); -#endif -#ifndef PerlIO_set_cnt -extern void PerlIO_set_cnt (PerlIO *,int); -#endif -#ifndef PerlIO_set_ptrcnt -extern void PerlIO_set_ptrcnt (PerlIO *,STDCHAR *,int); -#endif -#ifndef PerlIO_get_base -extern STDCHAR * PerlIO_get_base (PerlIO *); -#endif -#ifndef PerlIO_get_bufsiz -extern int PerlIO_get_bufsiz (PerlIO *); -#endif -#ifndef PerlIO_tmpfile -extern PerlIO * PerlIO_tmpfile (void); -#endif -#ifndef PerlIO_stdin -extern PerlIO * PerlIO_stdin (void); -#endif -#ifndef PerlIO_stdout -extern PerlIO * PerlIO_stdout (void); -#endif -#ifndef PerlIO_stderr -extern PerlIO * PerlIO_stderr (void); -#endif -#ifndef PerlIO_getpos -extern int PerlIO_getpos (PerlIO *,Fpos_t *); -#endif -#ifndef PerlIO_setpos -extern int PerlIO_setpos (PerlIO *,const Fpos_t *); +#define PerlSIO_stdin stdin +#define PerlSIO_stdout stdout +#define PerlSIO_stderr stderr +#define PerlSIO_fopen(x,y) fopen(x,y) +#define PerlSIO_fclose(f) fclose(f) +#define PerlSIO_feof(f) feof(f) +#define PerlSIO_ferror(f) ferror(f) +#define PerlSIO_clearerr(f) clearerr(f) +#define PerlSIO_fgetc(f) fgetc(f) +#if PerlSIO_has_base +#define PerlSIO_get_base(f) FILE_base(f) +#define PerlSIO_get_bufsiz(f) FILE_bufsiz(f) +#else +#define PerlSIO_get_base(f) NULL +#define PerlSIO_get_bufsiz(f) 0 #endif -#ifndef PerlIO_fdupopen -extern PerlIO * PerlIO_fdupopen (PerlIO *); +#ifdef USE_STDIO_PTR +#define PerlSIO_get_cnt(f) FILE_cnt(f) +#define PerlSIO_get_ptr(f) FILE_ptr(f) +#else +#define PerlSIO_get_cnt(f) 0 +#define PerlSIO_get_ptr(f) NULL +#endif +#define PerlSIO_fputc(f,c) fputc(c,f) +#define PerlSIO_fputs(f,s) fputs(s,f) +#define PerlSIO_fflush(f) Fflush(f) +#define PerlSIO_fgets(s, n, fp) fgets(s,n,fp) +#define PerlSIO_ungetc(c,f) ungetc(c,f) +#define PerlSIO_fileno(f) fileno(f) +#define PerlSIO_fdopen(f, s) fdopen(f,s) +#define PerlSIO_freopen(p, m, f) freopen(p,m,f) +#define PerlSIO_fread(buf,sz,count,f) fread(buf,sz,count,f) +#define PerlSIO_fwrite(buf,sz,count,f) fwrite(buf,sz,count,f) +#define PerlSIO_setbuf(f,b) setbuf(f,b) +#define PerlSIO_setvbuf(f,b,t,s) setvbuf(f,b,t,s) +#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) +#define PerlSIO_set_cnt(f,c) FILE_cnt(f) = (c) +#else +#define PerlSIO_set_cnt(f,c) PerlIOProc_abort() #endif +#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) +#define PerlSIO_set_ptr(f,p) FILE_ptr(f) = (p) +#else +#define PerlSIO_set_ptr(f,p) PerlIOProc_abort() +#endif +#define PerlSIO_setlinebuf(f) setlinebuf(f) +#define PerlSIO_printf Perl_fprintf_nocontext +#define PerlSIO_stdoutf *PL_StdIO->pPrintf +#define PerlSIO_vprintf(f,fmt,a) +#define PerlSIO_ftell(f) ftell(f) +#define PerlSIO_fseek(f,o,w) fseek(f,o,w) +#define PerlSIO_fgetpos(f,p) fgetpos(f,p) +#define PerlSIO_fsetpos(f,p) fsetpos(f,p) +#define PerlSIO_rewind(f) rewind(f) +#define PerlSIO_tmpfile() tmpfile() +#define PerlSIO_fdupopen(f) (f) +#endif /* PERL_IMPLICIT_SYS */ /* * Interface for directory functions @@ -552,7 +411,7 @@ struct IPerlDirInfo #define PerlDir_mkdir(name, mode) Mkdir((name), (mode)) #ifdef VMS # define PerlDir_chdir(n) Chdir(((n) && *(n)) ? (n) : "SYS$LOGIN") -#else +#else # define PerlDir_chdir(name) chdir((name)) #endif #define PerlDir_rmdir(name) rmdir((name)) @@ -922,36 +781,36 @@ struct IPerlMemInfo /* Shared memory macros */ #define PerlMemShared_malloc(size) \ - (*PL_MemShared->pMalloc)(PL_Mem, (size)) + (*PL_MemShared->pMalloc)(PL_MemShared, (size)) #define PerlMemShared_realloc(buf, size) \ - (*PL_MemShared->pRealloc)(PL_Mem, (buf), (size)) + (*PL_MemShared->pRealloc)(PL_MemShared, (buf), (size)) #define PerlMemShared_free(buf) \ - (*PL_MemShared->pFree)(PL_Mem, (buf)) + (*PL_MemShared->pFree)(PL_MemShared, (buf)) #define PerlMemShared_calloc(num, size) \ - (*PL_MemShared->pCalloc)(PL_Mem, (num), (size)) + (*PL_MemShared->pCalloc)(PL_MemShared, (num), (size)) #define PerlMemShared_get_lock() \ - (*PL_MemShared->pGetLock)(PL_Mem) + (*PL_MemShared->pGetLock)(PL_MemShared) #define PerlMemShared_free_lock() \ - (*PL_MemShared->pFreeLock)(PL_Mem) + (*PL_MemShared->pFreeLock)(PL_MemShared) #define PerlMemShared_is_locked() \ - (*PL_MemShared->pIsLocked)(PL_Mem) + (*PL_MemShared->pIsLocked)(PL_MemShared) /* Parse tree memory macros */ #define PerlMemParse_malloc(size) \ - (*PL_MemParse->pMalloc)(PL_Mem, (size)) + (*PL_MemParse->pMalloc)(PL_MemParse, (size)) #define PerlMemParse_realloc(buf, size) \ - (*PL_MemParse->pRealloc)(PL_Mem, (buf), (size)) + (*PL_MemParse->pRealloc)(PL_MemParse, (buf), (size)) #define PerlMemParse_free(buf) \ - (*PL_MemParse->pFree)(PL_Mem, (buf)) + (*PL_MemParse->pFree)(PL_MemParse, (buf)) #define PerlMemParse_calloc(num, size) \ - (*PL_MemParse->pCalloc)(PL_Mem, (num), (size)) + (*PL_MemParse->pCalloc)(PL_MemParse, (num), (size)) #define PerlMemParse_get_lock() \ - (*PL_MemParse->pGetLock)(PL_Mem) + (*PL_MemParse->pGetLock)(PL_MemParse) #define PerlMemParse_free_lock() \ - (*PL_MemParse->pFreeLock)(PL_Mem) + (*PL_MemParse->pFreeLock)(PL_MemParse) #define PerlMemParse_is_locked() \ - (*PL_MemParse->pIsLocked)(PL_Mem) + (*PL_MemParse->pIsLocked)(PL_MemParse) #else /* PERL_IMPLICIT_SYS */ @@ -1043,6 +902,7 @@ typedef int (*LPProcSpawnvp)(struct IPerlProc*, int, const char*, const char*const*); typedef int (*LPProcASpawn)(struct IPerlProc*, void*, void**, void**); #endif +typedef int (*LPProcLastHost)(struct IPerlProc*); struct IPerlProc { @@ -1081,6 +941,7 @@ struct IPerlProc LPProcSpawnvp pSpawnvp; LPProcASpawn pASpawn; #endif + LPProcLastHost pLastHost; }; struct IPerlProcInfo @@ -1160,6 +1021,8 @@ struct IPerlProcInfo #define PerlProc_aspawn(m,c,a) \ (*PL_Proc->pASpawn)(PL_Proc, (m), (c), (a)) #endif +#define PerlProc_lasthost() \ + (*PL_Proc->pLastHost)(PL_Proc) #else /* PERL_IMPLICIT_SYS */ @@ -1256,7 +1119,7 @@ typedef int (*LPRecvfrom)(struct IPerlSock*, SOCKET, char*, int, typedef int (*LPSelect)(struct IPerlSock*, int, char*, char*, char*, const struct timeval*); typedef int (*LPSend)(struct IPerlSock*, SOCKET, const char*, int, - int); + int); typedef int (*LPSendto)(struct IPerlSock*, SOCKET, const char*, int, int, const struct sockaddr*, int); typedef void (*LPSethostent)(struct IPerlSock*, int); diff --git a/lib/AnyDBM_File.pm b/lib/AnyDBM_File.pm index 58ffda7..ce85049 100644 --- a/lib/AnyDBM_File.pm +++ b/lib/AnyDBM_File.pm @@ -1,6 +1,7 @@ package AnyDBM_File; use 5.005_64; +our $VERSION = '1.00'; our @ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA; my $mod; diff --git a/lib/CGI.pm b/lib/CGI.pm index fd06f64..6b87054 100644 --- a/lib/CGI.pm +++ b/lib/CGI.pm @@ -107,18 +107,18 @@ unless ($OS) { $OS = $Config::Config{'osname'}; } } -if ($OS=~/Win/i) { +if ($OS =~ /^MSWin/i) { $OS = 'WINDOWS'; -} elsif ($OS=~/vms/i) { +} elsif ($OS =~ /^VMS/i) { $OS = 'VMS'; -} elsif ($OS=~/bsdos/i) { - $OS = 'UNIX'; -} elsif ($OS=~/dos/i) { +} elsif ($OS =~ /^dos/i) { $OS = 'DOS'; -} elsif ($OS=~/^MacOS$/i) { +} elsif ($OS =~ /^MacOS/i) { $OS = 'MACINTOSH'; -} elsif ($OS=~/os2/i) { +} elsif ($OS =~ /^os2/i) { $OS = 'OS2'; +} elsif ($OS =~ /^epoc/i) { + $OS = 'EPOC'; } else { $OS = 'UNIX'; } @@ -135,7 +135,7 @@ $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass; # The path separator is a slash, backslash or semicolon, depending # on the paltform. $SL = { - UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/' + UNIX=>'/', EPOC=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/' }->{$OS}; # This no longer seems to be necessary @@ -3274,7 +3274,7 @@ unless ($TMPDIRECTORY) { @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp", "C:${SL}temp","${SL}tmp","${SL}temp", "${vol}${SL}Temporary Items", - "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH"); + "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH", "C:${SL}system${SL}temp"); unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'}; # this feature was supposed to provide per-user tmpfiles, but @@ -3530,12 +3530,18 @@ have several choices: =over 4 -=item 1. Use another name for the argument, if one is available. For -example, -value is an alias for -values. +=item 1. + +Use another name for the argument, if one is available. +For example, -value is an alias for -values. -=item 2. Change the capitalization, e.g. -Values +=item 2. -=item 3. Put quotes around the argument name, e.g. '-values' +Change the capitalization, e.g. -Values + +=item 3. + +Put quotes around the argument name, e.g. '-values' =back @@ -5669,6 +5675,7 @@ field. The second argument (-src) is also required and specifies the URL =item 3. + The third option (-align, optional) is an alignment type, and may be TOP, BOTTOM or MIDDLE @@ -6102,6 +6109,7 @@ Returns either the remote host name or IP address. if the former is unavailable. =item B + Return the script name as a partial URL, for self-refering scripts. @@ -6220,7 +6228,9 @@ Call B with a non-zero parameter at any point after using CGI.pm in your CGI->nph(1) -=item By using B<-nph> parameters in the B and B statements: +=item By using B<-nph> parameters + +in the B and B statements: print $q->header(-nph=>1); diff --git a/lib/CGI/Apache.pm b/lib/CGI/Apache.pm index dced866..550c6e4 100644 --- a/lib/CGI/Apache.pm +++ b/lib/CGI/Apache.pm @@ -1,4 +1,7 @@ use CGI; + +our $VERSION = '1.00'; + 1; __END__ diff --git a/lib/CGI/Switch.pm b/lib/CGI/Switch.pm index b16b9c0..e754fde 100644 --- a/lib/CGI/Switch.pm +++ b/lib/CGI/Switch.pm @@ -1,4 +1,7 @@ use CGI; + +our $VERSION = '1.00'; + 1; __END__ diff --git a/lib/CPAN.pm b/lib/CPAN.pm index aeb6a57..fce7dc4 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -1,12 +1,11 @@ # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- package CPAN; -$VERSION = '1.57_68RC'; - -# $Id: CPAN.pm,v 1.354 2000/10/08 14:20:57 k Exp $ +$VERSION = '1.59_51'; +# $Id: CPAN.pm,v 1.381 2000/12/01 08:13:05 k Exp $ # only used during development: $Revision = ""; -# $Revision = "[".substr(q$Revision: 1.354 $, 10)."]"; +# $Revision = "[".substr(q$Revision: 1.381 $, 10)."]"; use Carp (); use Config (); @@ -56,7 +55,7 @@ package CPAN; use strict qw(vars); use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term - $Revision $Signal $Cwd $End $Suppress_readline $Frontend + $Revision $Signal $End $Suppress_readline $Frontend $Defaultsite $Have_warned); @CPAN::ISA = qw(CPAN::Debug Exporter); @@ -88,24 +87,24 @@ sub shell { $Suppress_readline = ! -t STDIN unless defined $Suppress_readline; CPAN::Config->load unless $CPAN::Config_loaded++; - CPAN::Index->read_metadata_cache; + my $oprompt = shift || "cpan> "; + my $prompt = $oprompt; + my $commandline = shift || ""; - my $prompt = "cpan> "; local($^W) = 1; unless ($Suppress_readline) { require Term::ReadLine; -# import Term::ReadLine; - $term = Term::ReadLine->new('CPAN Monitor'); + if (! $term + or + $term->ReadLine eq "Term::ReadLine::Stub" + ) { + $term = Term::ReadLine->new('CPAN Monitor'); + } if ($term->ReadLine eq "Term::ReadLine::Gnu") { my $attribs = $term->Attribs; -# $attribs->{completion_entry_function} = -# $attribs->{'list_completion_function'}; $attribs->{attempted_completion_function} = sub { &CPAN::Complete::gnu_cpl; } -# $attribs->{completion_word} = -# [qw(help me somebody to find out how -# to use completion with GNU)]; } else { $readline::rl_completion_function = $readline::rl_completion_function = 'CPAN::Complete::cpl'; @@ -120,9 +119,7 @@ sub shell { # no strict; # I do not recall why no strict was here (2000-09-03) $META->checklock(); - my $getcwd; - $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my $cwd = CPAN->$getcwd(); + my $cwd = CPAN::anycwd(); my $try_detect_readline; $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term; my $rl_avail = $Suppress_readline ? "suppressed" : @@ -141,20 +138,21 @@ ReadLine support %s ) unless $CPAN::Config->{'inhibit_startup_message'} ; my($continuation) = ""; - while () { + SHELLCOMMAND: while () { if ($Suppress_readline) { print $prompt; - last unless defined ($_ = <> ); + last SHELLCOMMAND unless defined ($_ = <> ); chomp; } else { - last unless defined ($_ = $term->readline($prompt)); + last SHELLCOMMAND unless + defined ($_ = $term->readline($prompt, $commandline)); } $_ = "$continuation$_" if $continuation; s/^\s+//; - next if /^$/; + next SHELLCOMMAND if /^$/; $_ = 'h' if /^\s*\?/; if (/^(?:q(?:uit)?|bye|exit)$/i) { - last; + last SHELLCOMMAND; } elsif (s/\\$//s) { chomp; $continuation = $_; @@ -169,14 +167,16 @@ ReadLine support %s eval($eval); warn $@ if $@; $continuation = ""; - $prompt = "cpan> "; + $prompt = $oprompt; } elsif (/./) { my(@line); if ($] < 5.00322) { # parsewords had a bug until recently @line = split; } else { eval { @line = Text::ParseWords::shellwords($_) }; - warn($@), next if $@; + warn($@), next SHELLCOMMAND if $@; + warn("Text::Parsewords could not parse the line [$_]"), + next SHELLCOMMAND unless @line; } $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG; my $command = shift @line; @@ -185,9 +185,12 @@ ReadLine support %s chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!}); $CPAN::Frontend->myprint("\n"); $continuation = ""; - $prompt = "cpan> "; + $prompt = $oprompt; } } continue { + $commandline = ""; # I do want to be able to pass a default to + # shell, but on the second command I see no + # use in that $Signal=0; CPAN::Queue->nullify_queue; if ($try_detect_readline) { @@ -201,10 +204,12 @@ ReadLine support %s require Term::ReadLine; $CPAN::Frontend->myprint("\n$redef subroutines in ". "Term::ReadLine redefined\n"); + @_ = ($oprompt,""); goto &shell; } } } + chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!}); } package CPAN::CacheMgr; @@ -226,6 +231,11 @@ use vars qw($Ua $Thesite $Themethod); package CPAN::Complete; @CPAN::Complete::ISA = qw(CPAN::Debug); +@CPAN::Complete::COMMANDS = sort qw( + ! a b d h i m o q r u autobundle clean dump + make test install force readme reload look + cvs_import ls +) unless @CPAN::Complete::COMMANDS; package CPAN::Index; use vars qw($last_time $date_of_03); @@ -251,8 +261,10 @@ package CPAN::Module; @CPAN::Module::ISA = qw(CPAN::InfoObj); package CPAN::Shell; -use vars qw($AUTOLOAD @ISA); +use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING); @CPAN::Shell::ISA = qw(CPAN::Debug); +$COLOR_REGISTERED ||= 0; +$PRINT_ORNAMENTING ||= 0; #-> sub CPAN::Shell::AUTOLOAD ; sub AUTOLOAD { @@ -279,8 +291,9 @@ For this you just need to type } package CPAN::Tarzip; -use vars qw($AUTOLOAD @ISA); +use vars qw($AUTOLOAD @ISA $BUGHUNTING); @CPAN::Tarzip::ISA = qw(CPAN::Debug); +$BUGHUNTING = 0; # released code must have turned off package CPAN::Queue; @@ -583,6 +596,13 @@ sub DESTROY { &cleanup; # need an eval? } +#-> sub CPAN::anycwd ; +sub anycwd () { + my $getcwd; + $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; + CPAN->$getcwd(); +} + #-> sub CPAN::cwd ; sub cwd {Cwd::cwd();} @@ -592,6 +612,7 @@ sub getcwd {Cwd::getcwd();} #-> sub CPAN::exists ; sub exists { my($mgr,$class,$id) = @_; + CPAN::Config->load unless $CPAN::Config_loaded++; CPAN::Index->reload; ### Carp::croak "exists called without class argument" unless $class; $id ||= ""; @@ -788,9 +809,7 @@ sub entries { return unless defined $dir; $self->debug("reading dir[$dir]") if $CPAN::DEBUG; $dir ||= $self->{ID}; - my $getcwd; - $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my($cwd) = CPAN->$getcwd(); + my($cwd) = CPAN::anycwd(); chdir $dir or Carp::croak("Can't chdir to $dir: $!"); my $dh = DirHandle->new(File::Spec->curdir) or Carp::croak("Couldn't opendir $dir: $!"); @@ -1030,7 +1049,7 @@ EOF my($fh) = FileHandle->new; rename $configpm, "$configpm~" if -f $configpm; open $fh, ">$configpm" or - $CPAN::Frontend->mywarn("Couldn't open >$configpm: $!"); + $CPAN::Frontend->mydie("Couldn't open >$configpm: $!"); $fh->print(qq[$msg\$CPAN::Config = \{\n]); foreach (sort keys %$CPAN::Config) { $fh->print( @@ -1267,21 +1286,40 @@ sub a { $CPAN::Frontend->myprint($self->format_result('Author',@arg)); } -#-> sub CPAN::Shell::local_bundles ; +#-> sub CPAN::Shell::ls ; +sub ls { + my($self,@arg) = @_; + for (@arg) { + $_ = uc $_; + } + for my $a (@arg){ + my $author = $self->expand('Author',$a) or die "No author found for $a"; + $author->ls; + } +} +#-> sub CPAN::Shell::local_bundles ; sub local_bundles { my($self,@which) = @_; my($incdir,$bdir,$dh); foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { - $bdir = MM->catdir($incdir,"Bundle"); - if ($dh = DirHandle->new($bdir)) { # may fail - my($entry); - for $entry ($dh->read) { - next if -d MM->catdir($bdir,$entry); - next unless $entry =~ s/\.pm(?!\n)\Z//; - $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry"); - } - } + my @bbase = "Bundle"; + while (my $bbase = shift @bbase) { + $bdir = MM->catdir($incdir,split /::/, $bbase); + CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG; + if ($dh = DirHandle->new($bdir)) { # may fail + my($entry); + for $entry ($dh->read) { + next if $entry =~ /^\./; # + if (-d MM->catdir($bdir,$entry)){ + push @bbase, "$bbase\::$entry"; + } else { + next unless $entry =~ s/\.pm(?!\n)\Z//; + $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry"); + } + } + } + } } } @@ -1312,10 +1350,14 @@ sub i { for $type (@type) { push @result, $self->expand($type,@args); } - my $result = @result == 1 ? + my $result = @result == 1 ? $result[0]->as_string : - join "", map {$_->as_glimpse} @result; - $result ||= "No objects found of any type for argument @args\n"; + @result == 0 ? + "No objects found of any type for argument @args\n" : + join("", + (map {$_->as_glimpse} @result), + scalar @result, " items found\n", + ); $CPAN::Frontend->myprint($result); } @@ -1358,6 +1400,10 @@ sub o { if (@o_what) { while (@o_what) { my($what) = shift @o_what; + if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) { + $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what}; + next; + } if ( exists $CPAN::DEBUG{$what} ) { $CPAN::DEBUG |= $CPAN::DEBUG{$what}; } elsif ($what =~ /^\d/) { @@ -1499,7 +1545,7 @@ sub _u_r_common { my(@result,$module,%seen,%need,$headerdone, $version_undefs,$version_zeroes); $version_undefs = $version_zeroes = 0; - my $sprintf = "%-25s %9s %9s %s\n"; + my $sprintf = "%s%-25s%s %9s %9s %s\n"; my @expand = $self->expand('Module',@args); my $expand = scalar @expand; if (0) { # Looks like noise to me, was very useful for debugging @@ -1555,15 +1601,31 @@ sub _u_r_common { unless ($headerdone++){ $CPAN::Frontend->myprint("\n"); $CPAN::Frontend->myprint(sprintf( - $sprintf, - "Package namespace", - "installed", - "latest", - "in CPAN file" - )); + $sprintf, + "", + "Package namespace", + "", + "installed", + "latest", + "in CPAN file" + )); } + my $color_on = ""; + my $color_off = ""; + if ( + $COLOR_REGISTERED + && + $CPAN::META->has_inst("Term::ANSIColor") + && + $module->{RO}{description} + ) { + $color_on = Term::ANSIColor::color("green"); + $color_off = Term::ANSIColor::color("reset"); + } $CPAN::Frontend->myprint(sprintf $sprintf, + $color_on, $module->id, + $color_off, $have, $latest, $file); @@ -1653,6 +1715,7 @@ sub expandany { my($self,$s) = @_; CPAN->debug("s[$s]") if $CPAN::DEBUG; if ($s =~ m|/|) { # looks like a file + $s = CPAN::Distribution->normalize($s); return $CPAN::META->instance('CPAN::Distribution',$s); # Distributions spring into existence, not expand } elsif ($s =~ m|^Bundle::|) { @@ -1673,15 +1736,21 @@ sub expand { shift; my($type,@args) = @_; my($arg,@m); + CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG; for $arg (@args) { my($regex,$command); if ($arg =~ m|^/(.*)/$|) { $regex = $1; - } elsif ($arg =~ m/^=/) { - $command = substr($arg,1); + } elsif ($arg =~ m/=/) { + $command = 1; } my $class = "CPAN::$type"; my $obj; + CPAN->debug(sprintf "class[%s]regex[%s]command[%s]", + $class, + defined $regex ? $regex : "UNDEFINED", + $command || "UNDEFINED", + ) if $CPAN::DEBUG; if (defined $regex) { for $obj ( sort @@ -1690,10 +1759,11 @@ sub expand { ) { unless ($obj->id){ # BUG, we got an empty object somewhere + require Data::Dumper; CPAN->debug(sprintf( - "Empty id on obj[%s]%%[%s]", + "Bug in CPAN: Empty id on obj[%s][%s]", $obj, - join(":", %$obj) + Data::Dumper::Dumper($obj) )) if $CPAN::DEBUG; next; } @@ -1712,21 +1782,33 @@ sub expand { ); } } elsif ($command) { - die "leading equal sign in command disabled, ". - "please edit CPAN.pm to enable eval() or ". - "do not use = on argument list"; + die "equal sign in command disabled (immature interface), ". + "you can set + ! \$CPAN::Shell::ADVANCED_QUERY=1 +to enable it. But please note, this is HIGHLY EXPERIMENTAL code +that may go away anytime.\n" + unless $ADVANCED_QUERY; + my($method,$criterion) = $arg =~ /(.+?)=(.+)/; + my($matchcrit) = $criterion =~ m/^~(.+)/; for my $self ( sort {$a->id cmp $b->id} $CPAN::META->all_objects($class) ) { - push @m, $self if eval $command; + my $lhs = $self->$method() or next; # () for 5.00503 + if ($matchcrit) { + push @m, $self if $lhs =~ m/$matchcrit/; + } else { + push @m, $self if $lhs eq $criterion; + } } } else { my($xarg) = $arg; if ( $type eq 'Bundle' ) { $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/; - } + } elsif ($type eq "Distribution") { + $xarg = CPAN::Distribution->normalize($arg); + } if ($CPAN::META->exists($class,$xarg)) { $obj = $CPAN::META->instance($class,$xarg); } elsif ($CPAN::META->exists($class,$arg)) { @@ -1746,22 +1828,33 @@ sub format_result { my($type,@args) = @_; @args = '/./' unless @args; my(@result) = $self->expand($type,@args); - my $result = @result == 1 ? + my $result = @result == 1 ? $result[0]->as_string : - join "", map {$_->as_glimpse} @result; - $result ||= "No objects of type $type found for argument @args\n"; + @result == 0 ? + "No objects of type $type found for argument @args\n" : + join("", + (map {$_->as_glimpse} @result), + scalar @result, " items found\n", + ); $result; } # The only reason for this method is currently to have a reliable # debugging utility that reveals which output is going through which # channel. No, I don't like the colors ;-) + +#-> sub CPAN::Shell::print_ornameted ; sub print_ornamented { my($self,$what,$ornament) = @_; my $longest = 0; - my $ornamenting = 0; # turn the colors on + return unless defined $what; - if ($ornamenting) { + if ($CPAN::Config->{term_is_latin}){ + # courtesy jhi: + $what + =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #}; + } + if ($PRINT_ORNAMENTING) { unless (defined &color) { if ($CPAN::META->has_inst("Term::ANSIColor")) { import Term::ANSIColor "color"; @@ -1789,6 +1882,7 @@ sub print_ornamented { sub myprint { my($self,$what) = @_; + $self->print_ornamented($what, 'bold blue on_yellow'); } @@ -1873,13 +1967,17 @@ sub rematein { push @qcopy, $obj; } elsif ($CPAN::META->exists('CPAN::Author',$s)) { $obj = $CPAN::META->instance('CPAN::Author',$s); - $CPAN::Frontend->myprint( - join "", - "Don't be silly, you can't $meth ", - $obj->fullname, - " ;-)\n" - ); - sleep 2; + if ($meth eq "dump") { + $obj->dump; + } else { + $CPAN::Frontend->myprint( + join "", + "Don't be silly, you can't $meth ", + $obj->fullname, + " ;-)\n" + ); + sleep 2; + } } else { $CPAN::Frontend ->myprint(qq{Warning: Cannot $meth $s, }. @@ -2065,14 +2163,19 @@ sub localize { # Inheritance is not easier to manage than a few if/else branches if ($CPAN::META->has_usable('LWP::UserAgent')) { unless ($Ua) { - $Ua = LWP::UserAgent->new; - my($var); - $Ua->proxy('ftp', $var) - if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy}; - $Ua->proxy('http', $var) - if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy}; - $Ua->no_proxy($var) - if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy}; + eval {$Ua = LWP::UserAgent->new;}; # Why is has_usable still not fit enough? + if ($@) { + $CPAN::Frontent->mywarn("LWP::UserAgent->new dies with $@") + if $CPAN::DEBUG; + } else { + my($var); + $Ua->proxy('ftp', $var) + if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy}; + $Ua->proxy('http', $var) + if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy}; + $Ua->no_proxy($var) + if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy}; + } } } $ENV{ftp_proxy} = $CPAN::Config->{ftp_proxy} if $CPAN::Config->{ftp_proxy}; @@ -2137,7 +2240,7 @@ sub localize { qq{E.g. with 'o conf urllist push ftp://myurl/'}; $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n"); sleep 2; - $CPAN::Frontend->myprint("Cannot fetch $file\n\n"); + $CPAN::Frontend->myprint("Could not fetch $file\n"); } if ($restore) { rename "$aslocal.bak", $aslocal; @@ -2291,7 +2394,7 @@ sub hosthard { $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG; my($f,$funkyftp); - for $f ('lynx','ncftpget','ncftp') { + for $f ('lynx','ncftpget','ncftp','wget') { next unless exists $CPAN::Config->{$f}; $funkyftp = $CPAN::Config->{$f}; next unless defined $funkyftp; @@ -2304,6 +2407,8 @@ sub hosthard { $src_switch = " -source"; } elsif ($f eq "ncftp"){ $src_switch = " -c"; + } elsif ($f eq "wget"){ + $src_switch = " -O -"; } my($chdir) = ""; my($stdout_redir) = " > $asl_ungz"; @@ -2609,6 +2714,7 @@ sub new { }, $class; } +# CPAN::FTP::hasdefault; sub hasdefault { shift->{'hasdefault'} } sub netrc { shift->{'netrc'} } sub protected { shift->{'protected'} } @@ -2656,24 +2762,22 @@ sub cpl { } my @return; if ($pos == 0) { - @return = grep( - /^$word/, - sort qw( - ! a b d h i m o q r u autobundle clean dump - make test install force readme reload look cvs_import - ) - ); + @return = grep /^$word/, @CPAN::Complete::COMMANDS; } elsif ( $line !~ /^[\!abcdhimorutl]/ ) { @return = (); - } elsif ($line =~ /^a\s/) { - @return = cplx('CPAN::Author',$word); + } elsif ($line =~ /^(a|ls)\s/) { + @return = cplx('CPAN::Author',uc($word)); } elsif ($line =~ /^b\s/) { + CPAN::Shell->local_bundles; @return = cplx('CPAN::Bundle',$word); } elsif ($line =~ /^d\s/) { @return = cplx('CPAN::Distribution',$word); } elsif ($line =~ m/^( [mru]|make|clean|dump|test|install|readme|look|cvs_import )\s/x ) { + if ($word =~ /^Bundle::/) { + CPAN::Shell->local_bundles; + } @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word)); } elsif ($line =~ /^i\s/) { @return = cpl_any($word); @@ -2681,6 +2785,9 @@ sub cpl { @return = cpl_reload($word,$line,$pos); } elsif ($line =~ /^o\s/) { @return = cpl_option($word,$line,$pos); + } elsif ($line =~ m/^\S+\s/ ) { + # fallback for future commands and what we have forgotten above + @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word)); } else { @return = (); } @@ -2757,7 +2864,15 @@ sub reload { for ($CPAN::Config->{index_expire}) { $_ = 0.001 unless $_ && $_ > 0.001; } - $CPAN::META->{PROTOCOL} ||= "1.0"; + unless (1 || $CPAN::Have_warned->{readmetadatacache}++) { + # debug here when CPAN doesn't seem to read the Metadata + require Carp; + Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]"); + } + unless ($CPAN::META->{PROTOCOL}) { + $cl->read_metadata_cache; + $CPAN::META->{PROTOCOL} ||= "1.0"; + } if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) { # warn "Setting last_time to 0"; $last_time = 0; # No warning necessary @@ -2846,9 +2961,6 @@ sub rd_authindex { my @lines; return unless defined $index_target; $CPAN::Frontend->myprint("Going to read $index_target\n"); -# my $fh = CPAN::Tarzip->TIEHANDLE($index_target); -# while ($_ = $fh->READLINE) { - # no strict 'refs'; local(*FH); tie *FH, CPAN::Tarzip, $index_target; local($/) = "\n"; @@ -3047,7 +3159,7 @@ sub rd_modlist { Carp::confess($@) if $@; return if $CPAN::Signal; for (keys %$ret) { - my $obj = $CPAN::META->instance(CPAN::Module,$_); + my $obj = $CPAN::META->instance("CPAN::Module",$_); delete $ret->{$_}{modid}; # not needed here, maybe elsewhere $obj->set(%{$ret->{$_}}); return if $CPAN::Signal; @@ -3158,6 +3270,10 @@ sub set { # because of a typo, we do not like it that they are written into # the readonly area and made permanent (at least for a while) and # that is why we do not "allow" other places to call ->set. + unless ($self->id) { + CPAN->debug("Bug? Empty ID, rejecting"); + return; + } my $ro = $self->{RO} = $CPAN::META->{readonly}{$class}{$self->id} ||= {}; @@ -3187,17 +3303,20 @@ sub as_string { # next if m/^(ID|RO)$/; my $extra = ""; if ($_ eq "CPAN_USERID") { - $extra .= " (".$self->author; - my $email; # old perls! - if ($email = $CPAN::META->instance(CPAN::Author, - $self->cpan_userid - )->email) { - $extra .= " <$email>"; - } else { - $extra .= " "; - } - $extra .= ")"; - } + $extra .= " (".$self->author; + my $email; # old perls! + if ($email = $CPAN::META->instance("CPAN::Author", + $self->cpan_userid + )->email) { + $extra .= " <$email>"; + } else { + $extra .= " "; + } + $extra .= ")"; + } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion + push @m, sprintf " %-12s %s\n", $_, $self->fullname; + next; + } next unless defined $self->{RO}{$_}; push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra; } @@ -3221,7 +3340,7 @@ sub as_string { #-> sub CPAN::InfoObj::author ; sub author { my($self) = @_; - $CPAN::META->instance(CPAN::Author,$self->cpan_userid)->fullname; + $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname; } #-> sub CPAN::InfoObj::dump ; @@ -3244,11 +3363,89 @@ sub as_glimpse { } #-> sub CPAN::Author::fullname ; -sub fullname { shift->{RO}{FULLNAME} } +sub fullname { + shift->{RO}{FULLNAME}; +} *name = \&fullname; #-> sub CPAN::Author::email ; -sub email { shift->{RO}{EMAIL} } +sub email { shift->{RO}{EMAIL}; } + +#-> sub CPAN::Author::ls ; +sub ls { + my $self = shift; + my $id = $self->id; + + # adapted from CPAN::Distribution::verifyMD5 ; + my(@chksumfile); + @chksumfile = $self->id =~ /(.)(.)(.*)/; + $chksumfile[1] = join "", @chksumfile[0,1]; + $chksumfile[2] = join "", @chksumfile[1,2]; + push @chksumfile, "CHECKSUMS"; + print join "", map { + sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2]) + } sort { $a->[2] cmp $b->[2] } $self->dir_listing(\@chksumfile); +} + +#-> sub CPAN::Author::dir_listing ; +sub dir_listing { + my $self = shift; + my $chksumfile = shift; + my $lc_want = + MM->catfile($CPAN::Config->{keep_source_where}, + "authors", "id", @$chksumfile); + local($") = "/"; + my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile", + $lc_want,1); + unless ($lc_file) { + $CPAN::Frontend->myprint("Trying $lc_want.gz\n"); + $chksumfile->[-1] .= ".gz"; + $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile", + "$lc_want.gz",1); + if ($lc_file) { + $lc_file =~ s{\.gz(?!\n)\Z}{}; #}; + CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file); + } else { + return; + } + } + + # adapted from CPAN::Distribution::MD5_check_file ; + my $fh = FileHandle->new; + my($cksum); + if (open $fh, $lc_file){ + local($/); + my $eval = <$fh>; + $eval =~ s/\015?\012/\n/g; + close $fh; + my($comp) = Safe->new(); + $cksum = $comp->reval($eval); + if ($@) { + rename $lc_file, "$lc_file.bad"; + Carp::confess($@) if $@; + } + } else { + Carp::carp "Could not open $lc_file for reading"; + } + my(@result,$f); + for $f (sort keys %$cksum) { + if (exists $cksum->{$f}{isdir}) { + my(@dir) = @$chksumfile; + pop @dir; + push @dir, $f, "CHECKSUMS"; + push @result, map { + [$_->[0], $_->[1], "$f/$_->[2]"] + } $self->dir_listing(\@dir); + } else { + push @result, [ + ($cksum->{$f}{"size"}||0), + $cksum->{$f}{"mtime"}||"---", + $f + ]; + } + } + @result; +} package CPAN::Distribution; @@ -3260,6 +3457,19 @@ sub undelay { delete $self->{later}; } +# CPAN::Distribution::normalize +sub normalize { + my($self,$s) = @_; + $s = $self->id unless defined $s; + if ($s =~ tr|/|| == 1) { + return $s if $s =~ m|^N/A|; + $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or + $CPAN::Frontend->mywarn("Strange distribution name [$s]"); + CPAN->debug("s[$s]") if $CPAN::DEBUG; + } + $s; +} + #-> sub CPAN::Distribution::color_cmd_tmps ; sub color_cmd_tmps { my($self) = shift; @@ -3300,15 +3510,27 @@ sub as_string { #-> sub CPAN::Distribution::containsmods ; sub containsmods { my $self = shift; - return if exists $self->{CONTAINSMODS}; + return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS}; + my $dist_id = $self->{ID}; for my $mod ($CPAN::META->all_objects("CPAN::Module")) { my $mod_file = $mod->cpan_file or next; - my $dist_id = $self->{ID} or next; my $mod_id = $mod->{ID} or next; # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]"; # sleep 1; $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id; } + keys %{$self->{CONTAINSMODS}}; +} + +#-> sub CPAN::Distribution::uptodate ; +sub uptodate { + my($self) = @_; + my $c; + foreach $c ($self->containsmods) { + my $obj = CPAN::Shell->expandany($c); + return 0 unless $obj->uptodate; + } + return 1; } #-> sub CPAN::Distribution::called_for ; @@ -3318,6 +3540,22 @@ sub called_for { return $self->{CALLED_FOR}; } +#-> sub CPAN::Distribution::my_chdir ; +sub safe_chdir { + my($self,$todir) = @_; + # we die if we cannot chdir and we are debuggable + Carp::confess("safe_chdir called without todir argument") + unless defined $todir and length $todir; + if (chdir $todir) { + $self->debug(sprintf "changed directory to %s", CPAN::anycwd()) + if $CPAN::DEBUG; + } else { + my $cwd = CPAN::anycwd(); + $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }. + qq{to todir[$todir]: $!}); + } +} + #-> sub CPAN::Distribution::get ; sub get { my($self) = @_; @@ -3327,6 +3565,12 @@ sub get { "Is already unwrapped into directory $self->{'build_dir'}"; $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } + my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible + + # + # Get the file on local disk + # + my($local_file); my($local_wanted) = MM->catfile( @@ -3339,31 +3583,41 @@ sub get { $self->debug("Doing localize") if $CPAN::DEBUG; $local_file = CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted) - or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n"); - return if $CPAN::Signal; + or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n"); + $self->debug("local_file[$local_file]") if $CPAN::DEBUG; $self->{localfile} = $local_file; - $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok - my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok - $self->debug("doing chdir $builddir") if $CPAN::DEBUG; - chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!"); - my $packagedir; + return if $CPAN::Signal; - $self->debug("local_file[$local_file]") if $CPAN::DEBUG; + # + # Check integrity + # if ($CPAN::META->has_inst("MD5")) { $self->debug("MD5 is installed, verifying"); $self->verifyMD5; } else { $self->debug("MD5 is NOT installed"); } + return if $CPAN::Signal; + + # + # Create a clean room and go there + # + $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok + my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok + $self->safe_chdir($builddir); $self->debug("Removing tmp") if $CPAN::DEBUG; File::Path::rmtree("tmp"); mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!"; - chdir "tmp" or $CPAN::Frontend->mydie(qq{Could not chdir to "tmp": $!});; - $self->debug("Changed directory to tmp") if $CPAN::DEBUG; - return if $CPAN::Signal; - if (! $local_file) { - Carp::croak "bad download, can't do anything :-(\n"; - } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){ + if ($CPAN::Signal){ + $self->safe_chdir($sub_wd); + return; + } + $self->safe_chdir("tmp"); + + # + # Unpack the goods + # + if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){ $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file); $self->untar_me($local_file); } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) { @@ -3373,81 +3627,106 @@ sub get { $self->pm2dir_me($local_file); } else { $self->{archived} = "NO"; + $self->safe_chdir($sub_wd); + return; } - my $cwd = File::Spec->updir; - chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "": $!}); - if ($self->{archived} ne 'NO') { - $cwd = File::Spec->catdir(File::Spec->curdir, "tmp"); - chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!}); - # Let's check if the package has its own directory. - my $dh = DirHandle->new(File::Spec->curdir) - or Carp::croak("Couldn't opendir .: $!"); - my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC?? - $dh->close; - my ($distdir,$packagedir); - if (@readdir == 1 && -d $readdir[0]) { + + # we are still in the tmp directory! + # Let's check if the package has its own directory. + my $dh = DirHandle->new(File::Spec->curdir) + or Carp::croak("Couldn't opendir .: $!"); + my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC?? + $dh->close; + my ($distdir,$packagedir); + if (@readdir == 1 && -d $readdir[0]) { $distdir = $readdir[0]; $packagedir = MM->catdir($builddir,$distdir); + $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]") + if $CPAN::DEBUG; -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ". "$packagedir\n"); File::Path::rmtree($packagedir); rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!"); - } else { - my $userid = $self->cpan_userid; - unless ($userid) { - CPAN->debug("no userid? self[$self]"); - $userid = "anon"; - } - my $pragmatic_dir = $userid . '000'; - $pragmatic_dir =~ s/\W_//g; - $pragmatic_dir++ while -d "../$pragmatic_dir"; - $packagedir = MM->catdir($builddir,$pragmatic_dir); - File::Path::mkpath($packagedir); - my($f); - for $f (@readdir) { # is already without "." and ".." - my $to = MM->catdir($packagedir,$f); - rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!"); - } - } - $self->{'build_dir'} = $packagedir; - $cwd = File::Spec->updir; - chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!}); - - $self->debug("Changed directory to .. (self[$self]=[". - $self->as_string."])") if $CPAN::DEBUG; - File::Path::rmtree("tmp"); - if ($CPAN::Config->{keep_source_where} =~ /^no/i ){ - $CPAN::Frontend->myprint("Going to unlink $local_file\n"); - unlink $local_file or Carp::carp "Couldn't unlink $local_file"; - } - my($makefilepl) = MM->catfile($packagedir,"Makefile.PL"); - unless (-f $makefilepl) { + $self->debug(sprintf("renamed distdir[%s] to packagedir[%s] -e[%s]-d[%s]", + $distdir, + $packagedir, + -e $packagedir, + -d $packagedir, + )) if $CPAN::DEBUG; + } else { + my $userid = $self->cpan_userid; + unless ($userid) { + CPAN->debug("no userid? self[$self]"); + $userid = "anon"; + } + my $pragmatic_dir = $userid . '000'; + $pragmatic_dir =~ s/\W_//g; + $pragmatic_dir++ while -d "../$pragmatic_dir"; + $packagedir = MM->catdir($builddir,$pragmatic_dir); + $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG; + File::Path::mkpath($packagedir); + my($f); + for $f (@readdir) { # is already without "." and ".." + my $to = MM->catdir($packagedir,$f); + rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!"); + } + } + if ($CPAN::Signal){ + $self->safe_chdir($sub_wd); + return; + } + + $self->{'build_dir'} = $packagedir; + $self->safe_chdir(File::Spec->updir); + File::Path::rmtree("tmp"); + + my($mpl) = MM->catfile($packagedir,"Makefile.PL"); + my($mpl_exists) = -f $mpl; + unless ($mpl_exists) { + # Steffen's stupid NFS has problems to see an existing + # Makefile.PL such a short time after the directory was + # renamed. Maybe this trick helps + $dh = DirHandle->new($packagedir) + or Carp::croak("Couldn't opendir $packagedir: $!"); + $mpl_exists = grep /^Makefile\.PL$/, $dh->read; + } + unless ($mpl_exists) { + $self->debug(sprintf("makefilepl[%s]anycwd[%s]", + $mpl, + CPAN::anycwd(), + )) if $CPAN::DEBUG; my($configure) = MM->catfile($packagedir,"Configure"); if (-f $configure) { - # do we have anything to do? - $self->{'configure'} = $configure; + # do we have anything to do? + $self->{'configure'} = $configure; } elsif (-f MM->catfile($packagedir,"Makefile")) { - $CPAN::Frontend->myprint(qq{ + $CPAN::Frontend->myprint(qq{ Package comes with a Makefile and without a Makefile.PL. We\'ll try to build it with that Makefile then. }); - $self->{writemakefile} = "YES"; - sleep 2; + $self->{writemakefile} = "YES"; + sleep 2; } else { - my $cf = $self->called_for || "unknown"; - if ($cf =~ m|/|) { - $cf =~ s|.*/||; - $cf =~ s|\W.*||; - } - $cf =~ s|[/\\:]||g; # risk of filesystem damage - $cf = "unknown" unless length($cf); - $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL. - Writing one on our own (calling it $cf)\n}); - $self->{had_no_makefile_pl}++; - my $fh = FileHandle->new(">$makefilepl") - or Carp::croak("Could not open >$makefilepl"); - $fh->print( + my $cf = $self->called_for || "unknown"; + if ($cf =~ m|/|) { + $cf =~ s|.*/||; + $cf =~ s|\W.*||; + } + $cf =~ s|[/\\:]||g; # risk of filesystem damage + $cf = "unknown" unless length($cf); + $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL. + (The test -f "$mpl" returned false.) + Writing one on our own (setting NAME to $cf)\a\n}); + $self->{had_no_makefile_pl}++; + sleep 3; + + # Writing our own Makefile.PL + + my $fh = FileHandle->new; + $fh->open(">$mpl") + or Carp::croak("Could not open >$mpl: $!"); + $fh->print( qq{# This Makefile.PL has been autogenerated by the module CPAN.pm # because there was no Makefile.PL supplied. # Autogenerated on: }.scalar localtime().qq{ @@ -3456,10 +3735,10 @@ use ExtUtils::MakeMaker; WriteMakefile(NAME => q[$cf]); }); - $fh->close; + $fh->close; } - } } + return $self; } @@ -3531,9 +3810,7 @@ Please define it with "o conf shell " my $dist = $self->id; my $dir = $self->dir or $self->get; $dir = $self->dir; - my $getcwd; - $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my $pwd = CPAN->$getcwd(); + my $pwd = CPAN::anycwd(); chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!}); $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); system($CPAN::Config->{'shell'}) == 0 @@ -3567,9 +3844,7 @@ sub cvs_import { my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log, "$cvs_dir", $userid, "v$version"); - my $getcwd; - $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my $pwd = CPAN->$getcwd(); + my $pwd = CPAN::anycwd(); chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!}); $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); @@ -3630,7 +3905,7 @@ sub verifyMD5 { $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } my($lc_want,$lc_file,@local,$basename); - @local = split("/",$self->{ID}); + @local = split("/",$self->id); pop @local; push @local, "CHECKSUMS"; $lc_want = @@ -3647,6 +3922,7 @@ sub verifyMD5 { $lc_file = CPAN::FTP->localize("authors/id/@local", $lc_want,1); unless ($lc_file) { + $CPAN::Frontend->myprint("Trying $lc_want.gz\n"); $local[-1] .= ".gz"; $lc_file = CPAN::FTP->localize("authors/id/@local", "$lc_want.gz",1); @@ -3824,8 +4100,7 @@ sub isa_perl { sub perl { my($self) = @_; my($perl) = MM->file_name_is_absolute($^X) ? $^X : ""; - my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my $pwd = CPAN->$getcwd(); + my $pwd = CPAN::anycwd(); my $candidate = MM->catfile($pwd,$^X); $perl ||= $candidate if MM->maybe_command($candidate); unless ($perl) { @@ -4339,7 +4614,7 @@ sub as_string { #-> sub CPAN::Bundle::contains ; sub contains { my($self) = @_; - my($parsefile) = $self->inst_file; + my($parsefile) = $self->inst_file || ""; my($id) = $self->id; $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG; unless ($parsefile) { @@ -4403,8 +4678,7 @@ sub find_bundle_file { my $manifest = MM->catfile($where,"MANIFEST"); unless (-f $manifest) { require ExtUtils::Manifest; - my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my $cwd = CPAN->$getcwd(); + my $cwd = CPAN::anycwd(); chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!}); ExtUtils::Manifest::mkmanifest(); chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!}); @@ -4439,21 +4713,37 @@ sub find_bundle_file { Carp::croak("Couldn't find a Bundle file in $where"); } -# needs to work slightly different from Module::inst_file because of -# cpan_home/Bundle/ directory. +# needs to work quite differently from Module::inst_file because of +# cpan_home/Bundle/ directory and the possibility that we have +# shadowing effect. As it makes no sense to take the first in @INC for +# Bundles, we parse them all for $VERSION and take the newest. #-> sub CPAN::Bundle::inst_file ; sub inst_file { my($self) = @_; - return $self->{INST_FILE} if - exists $self->{INST_FILE} && $self->{INST_FILE}; my($inst_file); my(@me); @me = split /::/, $self->id; $me[-1] .= ".pm"; - $inst_file = MM->catfile($CPAN::Config->{'cpan_home'}, @me); - return $self->{INST_FILE} = $inst_file if -f $inst_file; - $self->SUPER::inst_file; + my($incdir,$bestv); + foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { + my $bfile = MM->catfile($incdir, @me); + CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG; + next unless -f $bfile; + my $foundv = MM->parse_version($bfile); + if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) { + $self->{INST_FILE} = $bfile; + $self->{INST_VERSION} = $bestv = $foundv; + } + } + $self->{INST_FILE}; +} + +#-> sub CPAN::Bundle::inst_version ; +sub inst_version { + my($self) = @_; + $self->inst_file; # finds INST_VERSION as side effect + $self->{INST_VERSION}; } #-> sub CPAN::Bundle::rematein ; @@ -4564,6 +4854,18 @@ sub install { #-> sub CPAN::Bundle::clean ; sub clean { shift->rematein('clean',@_); } +#-> sub CPAN::Bundle::uptodate ; +sub uptodate { + my($self) = @_; + return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def + my $c; + foreach $c ($self->contains) { + my $obj = CPAN::Shell->expandany($c); + return 0 unless $obj->uptodate; + } + return 1; +} + #-> sub CPAN::Bundle::readme ; sub readme { my($self) = @_; @@ -4579,8 +4881,8 @@ package CPAN::Module; # sub cpan_userid { shift->{RO}{CPAN_USERID} } sub userid { my $self = shift; - return unless exists $self->{RO}{userid}; - $self->{RO}{userid}; + return unless exists $self->{RO}; # should never happen + return $self->{RO}{CPAN_USERID} || $self->{RO}{userid}; } sub description { shift->{RO}{description} } @@ -4624,7 +4926,23 @@ sub as_glimpse { my(@m); my $class = ref($self); $class =~ s/^CPAN:://; - push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID}, + my $color_on = ""; + my $color_off = ""; + if ( + $CPAN::Shell::COLOR_REGISTERED + && + $CPAN::META->has_inst("Term::ANSIColor") + && + $self->{RO}{description} + ) { + $color_on = Term::ANSIColor::color("green"); + $color_off = Term::ANSIColor::color("reset"); + } + push @m, sprintf("%-15s %s%-15s%s (%s)\n", + $class, + $color_on, + $self->id, + $color_off, $self->cpan_file); join "", @m; } @@ -4689,8 +5007,45 @@ sub as_string { $stati{$self->{RO}{stati}} ) if $self->{RO}{statd}; my $local_file = $self->inst_file; - if ($local_file) { - $self->{MANPAGE} ||= $self->manpage_headline($local_file); + unless ($self->{MANPAGE}) { + if ($local_file) { + $self->{MANPAGE} = $self->manpage_headline($local_file); + } else { + # If we have already untarred it, we should look there + my $dist = $CPAN::META->instance('CPAN::Distribution', + $self->cpan_file); + # warn "dist[$dist]"; + # mff=manifest file; mfh=manifest handle + my($mff,$mfh); + if ($dist->{build_dir} and + -f ($mff = MM->catfile($dist->{build_dir}, "MANIFEST")) and + $mfh = FileHandle->new($mff) + ) { + CPAN->debug("mff[$mff]") if $CPAN::DEBUG; + my $lfre = $self->id; # local file RE + $lfre =~ s/::/./g; + $lfre .= "\\.pm\$"; + my($lfl); # local file file + local $/ = "\n"; + my(@mflines) = <$mfh>; + for (@mflines) { + s/^\s+//; + s/\s.*//s; + } + while (length($lfre)>5 and !$lfl) { + ($lfl) = grep /$lfre/, @mflines; + CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG; + $lfre =~ s/.+?\.//; + } + $lfl =~ s/\s.*//; # remove comments + $lfl =~ s/\s+//g; # chomp would maybe be too system-specific + my $lfl_abs = MM->catfile($dist->{build_dir},$lfl); + # warn "lfl_abs[$lfl_abs]"; + if (-f $lfl_abs) { + $self->{MANPAGE} = $self->manpage_headline($lfl_abs); + } + } + } } my($item); for $item (qw/MANPAGE/) { @@ -4744,26 +5099,29 @@ sub cpan_file { } if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){ return $self->{RO}{CPAN_FILE}; - } elsif ( defined $self->userid ) { - my $fullname = $CPAN::META->instance("CPAN::Author", - $self->userid)->fullname; - my $email = $CPAN::META->instance("CPAN::Author", - $self->userid)->email; - unless (defined $fullname && defined $email) { - my $userid = $self->userid; - return sprintf("Contact Author %s (Try 'a %s')", - $userid, - $userid, - ); - } - return "Contact Author $fullname <$email>"; } else { - return "N/A"; + my $userid = $self->userid; + if ( $userid ) { + if ($CPAN::META->exists("CPAN::Author",$userid)) { + my $author = $CPAN::META->instance("CPAN::Author", + $userid); + my $fullname = $author->fullname; + my $email = $author->email; + unless (defined $fullname && defined $email) { + return sprintf("Contact Author %s", + $userid, + ); + } + return "Contact Author $fullname <$email>"; + } else { + return "UserID $userid"; + } + } else { + return "N/A"; + } } } -*name = \&cpan_file; - #-> sub CPAN::Module::cpan_version ; sub cpan_version { my $self = shift; @@ -5087,10 +5445,29 @@ sub DESTROY { # CPAN::Tarzip::untar sub untar { my($class,$file) = @_; + my($prefer) = 0; + if (0) { # makes changing order easier + } elsif ($BUGHUNTING){ + $prefer=2; } elsif (MM->maybe_command($CPAN::Config->{gzip}) - && - MM->maybe_command($CPAN::Config->{'tar'})) { + && + MM->maybe_command($CPAN::Config->{'tar'})) { + # should be default until Archive::Tar is fixed + $prefer = 1; + } elsif ( + $CPAN::META->has_inst("Archive::Tar") + && + $CPAN::META->has_inst("Compress::Zlib") ) { + $prefer = 2; + } else { + $CPAN::Frontend->mydie(qq{ +CPAN.pm needs either both external programs tar and gzip installed or +both the modules Archive::Tar and Compress::Zlib. Neither prerequisite +is available. Can\'t continue. +}); + } + if ($prefer==1) { # 1 => external gzip+tar my($system); my $is_compressed = $class->gtest($file); if ($is_compressed) { @@ -5122,33 +5499,43 @@ sub untar { } else { return 1; } - } elsif ($CPAN::META->has_inst("Archive::Tar") - && - $CPAN::META->has_inst("Compress::Zlib") ) { + } elsif ($prefer==2) { # 2 => modules my $tar = Archive::Tar->new($file,1); my $af; # archive file my @af; - for $af ($tar->list_files) { - if ($af =~ m!^(/|\.\./)!) { - $CPAN::Frontend->mydie("ALERT: Archive contains ". - "illegal member [$af]"); + if ($BUGHUNTING) { + # RCS 1.337 had this code, it turned out unacceptable slow but + # it revealed a bug in Archive::Tar. Code is only here to hunt + # the bug again. It should never be enabled in published code. + # GDGraph3d-0.53 was an interesting case according to Larry + # Virden. + warn(">>>Bughunting code enabled<<< " x 20); + for $af ($tar->list_files) { + if ($af =~ m!^(/|\.\./)!) { + $CPAN::Frontend->mydie("ALERT: Archive contains ". + "illegal member [$af]"); + } + $CPAN::Frontend->myprint("$af\n"); + $tar->extract($af); # slow but effective for finding the bug + return if $CPAN::Signal; } - $CPAN::Frontend->myprint("$af\n"); - push @af, $af; - return if $CPAN::Signal; + } else { + for $af ($tar->list_files) { + if ($af =~ m!^(/|\.\./)!) { + $CPAN::Frontend->mydie("ALERT: Archive contains ". + "illegal member [$af]"); + } + $CPAN::Frontend->myprint("$af\n"); + push @af, $af; + return if $CPAN::Signal; + } + $tar->extract(@af); } - $tar->extract(@af); ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1) if ($^O eq 'MacOS'); return 1; - } else { - $CPAN::Frontend->mydie(qq{ -CPAN.pm needs either both external programs tar and gzip installed or -both the modules Archive::Tar and Compress::Zlib. Neither prerequisite -is available. Can\'t continue. -}); } } @@ -5226,9 +5613,8 @@ sub float2vv { my($self,$n) = @_; my($rev) = int($n); $rev ||= 0; - my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits so that - # architecture cannot - # influnce + my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit + # architecture influence $mantissa ||= 0; $mantissa .= "0" while length($mantissa)%3; my $ret = "v" . $rev; @@ -5310,11 +5696,11 @@ the make processes and deletes excess space according to a simple FIFO mechanism. For extended searching capabilities there's a plugin for CPAN available, -L. C is a full-text search engine that indexes -all documents available in CPAN authors directories. If C -is installed on your system, the interactive shell of will -enable the C, C, C, C, and C commands which send -queries to the WAIT server that has been configured for your +L|CPAN::WAIT>. C is a full-text search engine +that indexes all documents available in CPAN authors directories. If +C is installed on your system, the interactive shell of +CPAN.pm will enable the C, C, C, C, and C commands +which send queries to the WAIT server that has been configured for your installation. All other methods provided are accessible in a programmer style and in an @@ -5333,6 +5719,10 @@ command completion. Once you are on the command line, type 'h' and the rest should be self-explanatory. +The function call C takes two optional arguments, one is the +prompt, the second is the default initial command line (the latter +only works if a real ReadLine interface module is installed). + The most common uses of the interactive modes are =over 2 @@ -5519,6 +5909,12 @@ list of CPAN::Module objects according to the C<@things> arguments given. In scalar context it only returns the first element of the list. +=item expandany(@things) + +Like expand, but returns objects of the appropriate type, i.e. +CPAN::Bundle objects for bundles, CPAN::Module objects for modules and +CPAN::Distribution objects fro distributions. + =item Programming Examples This enables the programmer to do operations that combine @@ -5549,13 +5945,13 @@ all modules that need updating. First a quick and dirty way: perl -e 'use CPAN; CPAN::Shell->r;' -If you don't want to get any output if all modules are up to date, you -can parse the output of above command for the regular expression -//modules are up to date// and decide to mail the output only if it -doesn't match. Ick? +If you don't want to get any output in the case that all modules are +up to date, you can parse the output of above command for the regular +expression //modules are up to date// and decide to mail the output +only if it doesn't match. Ick? If you prefer to do it more in a programmer style in one single -process, maybe something like this suites you better: +process, maybe something like this suits you better: # list all modules on my disk that have newer versions on CPAN for $mod (CPAN::Shell->expand("Module","/./")){ @@ -5581,7 +5977,299 @@ tricks: =back -=head2 Methods in the four Classes +=head2 Methods in the other Classes + +The programming interface for the classes CPAN::Module, +CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered +beta and partially even alpha. In the following paragraphs only those +methods are documented that have proven useful over a longer time and +thus are unlikely to change. + +=over + +=item CPAN::Author::as_glimpse() + +Returns a one-line description of the author + +=item CPAN::Author::as_string() + +Returns a multi-line description of the author + +=item CPAN::Author::email() + +Returns the author's email address + +=item CPAN::Author::fullname() + +Returns the author's name + +=item CPAN::Author::name() + +An alias for fullname + +=item CPAN::Bundle::as_glimpse() + +Returns a one-line description of the bundle + +=item CPAN::Bundle::as_string() + +Returns a multi-line description of the bundle + +=item CPAN::Bundle::clean() + +Recursively runs the C method on all items contained in the bundle. + +=item CPAN::Bundle::contains() + +Returns a list of objects' IDs contained in a bundle. The associated +objects may be bundles, modules or distributions. + +=item CPAN::Bundle::force($method,@args) + +Forces CPAN to perform a task that normally would have failed. Force +takes as arguments a method name to be called and any number of +additional arguments that should be passed to the called method. The +internals of the object get the needed changes so that CPAN.pm does +not refuse to take the action. The C is passed recursively to +all contained objects. + +=item CPAN::Bundle::get() + +Recursively runs the C method on all items contained in the bundle + +=item CPAN::Bundle::inst_file() + +Returns the highest installed version of the bundle in either @INC or +C<$CPAN::Config->{cpan_home}>. Note that this is different from +CPAN::Module::inst_file. + +=item CPAN::Bundle::inst_version() + +Like CPAN::Bundle::inst_file, but returns the $VERSION + +=item CPAN::Bundle::uptodate() + +Returns 1 if the bundle itself and all its members are uptodate. + +=item CPAN::Bundle::install() + +Recursively runs the C method on all items contained in the bundle + +=item CPAN::Bundle::make() + +Recursively runs the C method on all items contained in the bundle + +=item CPAN::Bundle::readme() + +Recursively runs the C method on all items contained in the bundle + +=item CPAN::Bundle::test() + +Recursively runs the C method on all items contained in the bundle + +=item CPAN::Distribution::as_glimpse() + +Returns a one-line description of the distribution + +=item CPAN::Distribution::as_string() + +Returns a multi-line description of the distribution + +=item CPAN::Distribution::clean() + +Changes to the directory where the distribution has been unpacked and +runs C there. + +=item CPAN::Distribution::containsmods() + +Returns a list of IDs of modules contained in a distribution file. +Only works for distributions listed in the 02packages.details.txt.gz +file. This typically means that only the most recent version of a +distribution is covered. + +=item CPAN::Distribution::cvs_import() + +Changes to the directory where the distribution has been unpacked and +runs something like + + cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version + +there. + +=item CPAN::Distribution::dir() + +Returns the directory into which this distribution has been unpacked. + +=item CPAN::Distribution::force($method,@args) + +Forces CPAN to perform a task that normally would have failed. Force +takes as arguments a method name to be called and any number of +additional arguments that should be passed to the called method. The +internals of the object get the needed changes so that CPAN.pm does +not refuse to take the action. + +=item CPAN::Distribution::get() + +Downloads the distribution from CPAN and unpacks it. Does nothing if +the distribution has already been downloaded and unpacked within the +current session. + +=item CPAN::Distribution::install() + +Changes to the directory where the distribution has been unpacked and +runs the external command C there. If C has not +yet been run, it will be run first. A C will be issued in +any case and if this fails, the install will be cancelled. The +cancellation can be avoided by letting C run the C for +you. + +=item CPAN::Distribution::isa_perl() + +Returns 1 if this distribution file seems to be a perl distribution. +Normally this is derived from the file name only, but the index from +CPAN can contain a hint to achieve a return value of true for other +filenames too. + +=item CPAN::Distribution::look() + +Changes to the directory where the distribution has been unpacked and +opens a subshell there. Exiting the subshell returns. + +=item CPAN::Distribution::make() + +First runs the C method to make sure the distribution is +downloaded and unpacked. Changes to the directory where the +distribution has been unpacked and runs the external commands C and C there. + +=item CPAN::Distribution::prereq_pm() + +Returns the hash reference that has been announced by a distribution +as the PREREQ_PM hash in the Makefile.PL. Note: works only after an +attempt has been made to C the distribution. Returns undef +otherwise. + +=item CPAN::Distribution::readme() + +Downloads the README file associated with a distribution and runs it +through the pager specified in C<$CPAN::Config->{pager}>. + +=item CPAN::Distribution::test() + +Changes to the directory where the distribution has been unpacked and +runs C there. + +=item CPAN::Distribution::uptodate() + +Returns 1 if all the modules contained in the distribution are +uptodate. Relies on containsmods. + +=item CPAN::Index::force_reload() + +Forces a reload of all indices. + +=item CPAN::Index::reload() + +Reloads all indices if they have been read more than +C<$CPAN::Config->{index_expire}> days. + +=item CPAN::InfoObj::dump() + +CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution +inherit this method. It prints the data structure associated with an +object. Useful for debugging. Note: the data structure is considered +internal and thus subject to change without notice. + +=item CPAN::Module::as_glimpse() + +Returns a one-line description of the module + +=item CPAN::Module::as_string() + +Returns a multi-line description of the module + +=item CPAN::Module::clean() + +Runs a clean on the distribution associated with this module. + +=item CPAN::Module::cpan_file() + +Returns the filename on CPAN that is associated with the module. + +=item CPAN::Module::cpan_version() + +Returns the latest version of this module available on CPAN. + +=item CPAN::Module::cvs_import() + +Runs a cvs_import on the distribution associated with this module. + +=item CPAN::Module::description() + +Returns a 44 chracter description of this module. Only available for +modules listed in The Module List (CPAN/modules/00modlist.long.html +or 00modlist.long.txt.gz) + +=item CPAN::Module::force($method,@args) + +Forces CPAN to perform a task that normally would have failed. Force +takes as arguments a method name to be called and any number of +additional arguments that should be passed to the called method. The +internals of the object get the needed changes so that CPAN.pm does +not refuse to take the action. + +=item CPAN::Module::get() + +Runs a get on the distribution associated with this module. + +=item CPAN::Module::inst_file() + +Returns the filename of the module found in @INC. The first file found +is reported just like perl itself stops searching @INC when it finds a +module. + +=item CPAN::Module::inst_version() + +Returns the version number of the module in readable format. + +=item CPAN::Module::install() + +Runs an C on the distribution associated with this module. + +=item CPAN::Module::look() + +Changes to the directory where the distribution assoicated with this +module has been unpacked and opens a subshell there. Exiting the +subshell returns. + +=item CPAN::Module::make() + +Runs a C on the distribution associated with this module. + +=item CPAN::Module::manpage_headline() + +If module is installed, peeks into the module's manpage, reads the +headline and returns it. Moreover, if the module has been downloaded +within this session, does the equivalent on the downloaded module even +if it is not installed. + +=item CPAN::Module::readme() + +Runs a C on the distribution associated with this module. + +=item CPAN::Module::test() + +Runs a C on the distribution associated with this module. + +=item CPAN::Module::uptodate() + +Returns 1 if the module is installed and up-to-date. + +=item CPAN::Module::userid() + +Returns the author's ID of the module. + +=back =head2 Cache Manager @@ -5734,6 +6422,8 @@ defined: ('follow' automatically, 'ask' me, or 'ignore') scan_cache controls scanning of cache ('atstart' or 'never') tar location of external program tar + term_is_latin if true internal UTF-8 is translated to ISO-8859-1 + (and nonsense for characters outside latin range) unzip location of external program unzip urllist arrayref to nearby CPAN sites (or equivalent locations) wait_list arrayref to a wait server to try (See CPAN::WAIT) @@ -5821,8 +6511,8 @@ oneliners. =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES -To populate a freshly installed perl with my favorite modules is pretty -easiest by maintaining a private bundle definition file. To get a useful +Populating a freshly installed perl with my favorite modules is pretty +easy if you maintain a private bundle definition file. To get a useful blueprint of a bundle definition file, the command autobundle can be used on the CPAN shell command line. This command writes a bundle definition file for all modules that are installed for the currently running perl @@ -5834,7 +6524,7 @@ Bundle/my_bundle.pm. With a clever bundle file you can then simply say then answer a few questions and then go out for a coffee. -Maintaining a bundle definition file means to keep track of two +Maintaining a bundle definition file means keeping track of two things: dependencies and interactivity. CPAN.pm sometimes fails on calculating dependencies because not all modules define all MakeMaker attributes correctly, so a bundle definition file should specify @@ -5843,7 +6533,7 @@ annoying that many distributions need some interactive configuring. So what I try to accomplish in my private bundle file is to have the packages that need to be configured early in the file and the gentle ones later, so I can go out after a few minutes and leave CPAN.pm -unattained. +untended. =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS @@ -5905,7 +6595,7 @@ the firewall as if it is not there. This is the firewall implemented in the Linux kernel, it allows you to hide a complete network behind one IP address. With this firewall no -special compiling is need as you can access hosts directly. +special compiling is needed as you can access hosts directly. =back @@ -5933,8 +6623,10 @@ Your milage may vary... =over -=item 1) I installed a new version of module X but CPAN keeps saying, - I have the old version installed +=item 1) + +I installed a new version of module X but CPAN keeps saying, +I have the old version installed Most probably you B have the old version installed. This can happen if a module installs itself into a different directory in the @@ -5946,14 +6638,35 @@ many people add this argument permanently by configuring o conf make_install_arg UNINST=1 -=item 2) So why is UNINST=1 not the default? +=item 2) + +So why is UNINST=1 not the default? Because there are people who have their precise expectations about who may install where in the @INC path and who uses which @INC array. In fine tuned environments C can cause damage. -=item 3) When I install bundles or multiple modules with one command - there is too much output to keep track of +=item 3) + +I want to clean up my mess, and install a new perl along with +all modules I have. How do I go about it? + +Run the autobundle command for your old perl and optionally rename the +resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl +with the Configure option prefix, e.g. + + ./Configure -Dprefix=/usr/local/perl-5.6.78.9 + +Install the bundle file you produced in the first step with something like + + cpan> install Bundle::mybundle + +and you're done. + +=item 4) + +When I install bundles or multiple modules with one command +there is too much output to keep track of. You may want to configure something like @@ -5963,8 +6676,9 @@ You may want to configure something like so that STDOUT is captured in a file for later inspection. -=item 4) I am not root, how can I install a module in a personal - directory? +=item 5) + +I am not root, how can I install a module in a personal directory? You will most probably like something like this: @@ -5987,14 +6701,17 @@ or setting the PERL5LIB environment variable. Another thing you should bear in mind is that the UNINST parameter should never be set if you are not root. -=item 5) How to get a package, unwrap it, and make a change before - building it? +=item 6) + +How to get a package, unwrap it, and make a change before building it? look Sybase::Sybperl -=item 6) I installed a Bundle and had a couple of fails. When I - retried, everything resolved nicely. Can this be fixed to work - on first try? +=item 7) + +I installed a Bundle and had a couple of fails. When I +retried, everything resolved nicely. Can this be fixed to work +on first try? The reason for this is that CPAN does not know the dependencies of all modules when it starts out. To decide about the additional items to @@ -6011,12 +6728,38 @@ definition file manually. It is planned to improve the metadata situation for dependencies on CPAN in general, but this will still take some time. -=item 7) In our intranet we have many modules for internal use. How - can I integrate these modules with CPAN.pm but without uploading - the modules to CPAN? +=item 8) + +In our intranet we have many modules for internal use. How +can I integrate these modules with CPAN.pm but without uploading +the modules to CPAN? Have a look at the CPAN::Site module. +=item 9) + +When I run CPAN's shell, I get error msg about line 1 to 4, +setting meta input/output via the /etc/inputrc file. + +Some versions of readline are picky about capitalization in the +/etc/inputrc file and specifically RedHat 6.2 comes with a +/etc/inputrc that contains the word C in lowercase. Change the +occurrences of C to C and the bug should disappear. + +=item 10) + +Some authors have strange characters in their names. + +Internally CPAN.pm uses the UTF-8 charset. If your terminal is +expecting ISO-8859-1 charset, a converter can be activated by setting +term_is_latin to a true value in your config file. One way of doing so +would be + + cpan> ! $CPAN::Config->{term_is_latin}=1 + +Extended support for converters will be made available as soon as perl +becomes stable with regard to charset issues. + =back =head1 BUGS diff --git a/lib/CPAN/FirstTime.pm b/lib/CPAN/FirstTime.pm index 9f8366e..7cf01cd 100644 --- a/lib/CPAN/FirstTime.pm +++ b/lib/CPAN/FirstTime.pm @@ -1,3 +1,4 @@ +# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- package CPAN::Mirrored::By; sub new { @@ -16,7 +17,7 @@ use FileHandle (); use File::Basename (); use File::Path (); use vars qw($VERSION); -$VERSION = substr q$Revision: 1.46 $, 10; +$VERSION = substr q$Revision: 1.51 $, 10; =head1 NAME @@ -174,6 +175,9 @@ disable the cache scanning with 'never'. } while ($ans ne 'atstart' && $ans ne 'never'); $CPAN::Config->{scan_cache} = $ans; + # + # cache_metadata + # print qq{ To considerably speed up the initial CPAN shell startup, it is @@ -189,6 +193,30 @@ is not available, the normal index mechanism will be used. $CPAN::Config->{cache_metadata} = ($ans =~ /^\s*y/i ? 1 : 0); # + # term_is_latin + # + print qq{ + +The next option deals with the charset your terminal supports. In +general CPAN is English speaking territory, thus the charset does not +matter much, but some of the aliens out there who upload their +software to CPAN bear names that are outside the ASCII range. If your +terminal supports UTF-8, you say no to the next question, if it +supports ISO-8859-1 (also known as LATIN1) then you say yes, and if it +supports neither nor, your answer does not matter, you will not be +able to read the names of some authors anyway. If you answer no, nmes +will be output in UTF-8. + +}; + + defined($default = $CPAN::Config->{term_is_latin}) or $default = 1; + do { + $ans = prompt("Your terminal expects ISO-8859-1 (yes/no)?", + ($default ? 'yes' : 'no')); + } while ($ans !~ /^\s*[yn]/i); + $CPAN::Config->{term_is_latin} = ($ans =~ /^\s*y/i ? 1 : 0); + + # # prerequisites_policy # Do we follow PREREQ_PM? # @@ -216,10 +244,11 @@ policy to one of the three values. print qq{ -The CPAN module will need a few external programs to work -properly. Please correct me, if I guess the wrong path for a program. -Don\'t panic if you do not have some of them, just press ENTER for -those. +The CPAN module will need a few external programs to work properly. +Please correct me, if I guess the wrong path for a program. Don\'t +panic if you do not have some of them, just press ENTER for those. To +disable the use of a download program, you can type a space followed +by ENTER. }; @@ -228,7 +257,7 @@ those. my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'}; local $^W = $old_warn; my $progname; - for $progname (qw/gzip tar unzip make lynx ncftpget ncftp ftp/){ + for $progname (qw/gzip tar unzip make lynx wget ncftpget ncftp ftp/){ if ($^O eq 'MacOS') { $CPAN::Config->{$progname} = 'not_here'; next; @@ -286,9 +315,9 @@ those. print qq{ Every Makefile.PL is run by perl in a separate process. Likewise we -run \'make\' and \'make install\' in processes. If you have any parameters -\(e.g. PREFIX, INSTALLPRIVLIB, UNINST or the like\) you want to pass to -the calls, please specify them here. +run \'make\' and \'make install\' in processes. If you have any +parameters \(e.g. PREFIX, LIB, UNINST or the like\) you want to pass +to the calls, please specify them here. If you don\'t understand this question, just press ENTER. @@ -296,13 +325,29 @@ If you don\'t understand this question, just press ENTER. $default = $CPAN::Config->{makepl_arg} || ""; $CPAN::Config->{makepl_arg} = - prompt("Parameters for the 'perl Makefile.PL' command?",$default); + prompt("Parameters for the 'perl Makefile.PL' command? +Typical frequently used settings: + + POLLUTE=1 increasing backwards compatibility + LIB=~/perl non-root users (please see manual for more hints) + +Your choice: ",$default); $default = $CPAN::Config->{make_arg} || ""; - $CPAN::Config->{make_arg} = prompt("Parameters for the 'make' command?",$default); + $CPAN::Config->{make_arg} = prompt("Parameters for the 'make' command? +Typical frequently used setting: + + -j3 dual processor system + +Your choice: ",$default); $default = $CPAN::Config->{make_install_arg} || $CPAN::Config->{make_arg} || ""; $CPAN::Config->{make_install_arg} = - prompt("Parameters for the 'make install' command?",$default); + prompt("Parameters for the 'make install' command? +Typical frequently used setting: + + UNINST=1 to always uninstall potentially conflicting files + +Your choice: ",$default); # # Alarm period @@ -376,8 +421,26 @@ sub conf_sites { } my $loopcount = 0; local $^T = time; + my $overwrite_local = 0; + if ($mby && -f $mby && -M _ <= 60 && -s _ > 0) { + my $mtime = localtime((stat _)[9]); + my $prompt = qq{Found $mby as of $mtime + + I\'d use that as a database of CPAN sites. If that is OK for you, + please answer 'y', but if you want me to get a new database now, + please answer 'n' to the following question. + + Shall I use the local database in $mby?}; + my $ans = prompt($prompt,"y"); + $overwrite_local = 1 unless $ans =~ /^y/i; + } while ($mby) { - if ( ! -f $mby ){ + if ($overwrite_local) { + print qq{Trying to overwrite $mby +}; + $mby = CPAN::FTP->localize($m,$mby,3); + $overwrite_local = 0; + } elsif ( ! -f $mby ){ print qq{You have no $mby I\'m trying to fetch one }; @@ -519,7 +582,8 @@ http: -- that host a CPAN mirror. } } push (@urls, map ("$_ (previous pick)", @previous_urls)); - my $prompt = "Select as many URLs as you like"; + my $prompt = "Select as many URLs as you like, +put them on one line, separated by blanks"; if (@previous_urls) { $default = join (' ', ((scalar @urls) - (scalar @previous_urls) + 1) .. (scalar @urls)); @@ -547,11 +611,15 @@ Please enter your CPAN site:}; $ans =~ s|/?\z|/|; # has to end with one slash $ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file: if ($ans =~ /^\w+:\/./) { - push @urls, $ans unless $seen{$ans}++; + push @urls, $ans unless $seen{$ans}++; } else { - print qq{"$ans" doesn\'t look like an URL at first sight. -I\'ll ignore it for now. You can add it to $INC{'CPAN/MyConfig.pm'} -later if you\'re sure it\'s right.\n}; + printf(qq{"%s" doesn\'t look like an URL at first sight. +I\'ll ignore it for now. +You can add it to your %s +later if you\'re sure it\'s right.\n}, + $ans, + $INC{'CPAN/MyConfig.pm'} || $INC{'CPAN/Config.pm'} || "configuration file", + ); } } } while $ans || !%seen; diff --git a/lib/Carp.pm b/lib/Carp.pm index 43524dd..69d477b 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -1,5 +1,7 @@ package Carp; +our $VERSION = '1.00'; + =head1 NAME carp - warn of errors (from perspective of caller) @@ -68,6 +70,8 @@ $MaxArgLen = 64; # How much of each argument to print. 0 = all. $MaxArgNums = 8; # How many arguments to print. 0 = all. $Verbose = 0; # If true then make shortmess call longmess instead +$CarpInternal{Carp}++; + require Exporter; @ISA = ('Exporter'); @EXPORT = qw(confess croak carp); diff --git a/lib/Carp/Heavy.pm b/lib/Carp/Heavy.pm index 8cfdcb4..b551560 100644 --- a/lib/Carp/Heavy.pm +++ b/lib/Carp/Heavy.pm @@ -1,247 +1,244 @@ +# Carp::Heavy uses some variables in common with Carp. package Carp; =head1 NAME -Carp::Heavy - Carp guts +Carp heavy machinery - no user serviceable parts inside -=head1 SYNOPIS +=cut -(internal use only) +# use strict; # not yet + +# On one line so MakeMaker will see it. +use Carp; our $VERSION = $Carp::VERSION; + +our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxLenArg, $Verbose); + +sub caller_info { + my $i = shift(@_) + 1; + package DB; + my %call_info; + @call_info{ + qw(pack file line sub has_args wantarray evaltext is_require) + } = caller($i); + + unless (defined $call_info{pack}) { + return (); + } + + my $sub_name = Carp::get_subname(\%call_info); + if ($call_info{has_args}) { + # Reuse the @args array to avoid warnings. :-) + local @args = map {Carp::format_arg($_)} @args; + if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show? + $#args = $MaxArgNums; + push @args, '...'; + } + # Push the args onto the subroutine + $sub_name .= '(' . join (',', @args) . ')'; + } + $call_info{sub_name} = $sub_name; + return wantarray() ? %call_info : \%call_info; +} -=head1 DESCRIPTION +# Transform an argument to a function into a string. +sub format_arg { + my $arg = shift; + if (not defined($arg)) { + $arg = 'undef'; + } + elsif (ref($arg)) { + $arg .= ''; # Make it a string; + } + $arg =~ s/'/\\'/g; + $arg = str_len_trim($arg, $MaxLenArg); + + # Quote it? + $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/; + + # The following handling of "control chars" is direct from + # the original code - I think it is broken on Unicode though. + # Suggestions? + $arg =~ s/([[:cntrl:]]|[[^:ascii:]])/sprintf("\\x{%x}",ord($1))/eg; + return $arg; +} -No user-serviceable parts inside. +# Takes an inheritance cache and a package and returns +# an anon hash of known inheritances and anon array of +# inheritances which consequences have not been figured +# for. +sub get_status { + my $cache = shift; + my $pkg = shift; + $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]]; + return @{$cache->{$pkg}}; +} -=cut +# Takes the info from caller() and figures out the name of +# the sub/require/eval +sub get_subname { + my $info = shift; + if (defined($info->{eval})) { + my $eval = $info->{eval}; + if ($info->{is_require}) { + return "require $eval"; + } + else { + $eval =~ s/([\\\'])/\\$1/g; + return str_len_trim($eval, $MaxEvalLen); + } + } -# This package is heavily used. Be small. Be fast. Be good. + return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub}; +} -# Comments added by Andy Wardley 09-Apr-98, based on an -# _almost_ complete understanding of the package. Corrections and -# comments are welcome. +# Figures out what call (from the point of view of the caller) +# the long error backtrace should start at. +sub long_error_loc { + my $i; + my $lvl = $CarpLevel; + { + my $pkg = caller(++$i); + unless(defined($pkg)) { + # This *shouldn't* happen. + if (%Internal) { + local %Internal; + $i = long_error_loc(); + last; + } + else { + # OK, now I am irritated. + return 2; + } + } + redo if $CarpInternal{$pkg}; + redo unless 0 > --$lvl; + redo if $Internal{$pkg}; + } + return $i - 1; +} -# longmess() crawls all the way up the stack reporting on all the function -# calls made. The error string, $error, is originally constructed from the -# arguments passed into longmess() via confess(), cluck() or shortmess(). -# This gets appended with the stack trace messages which are generated for -# each function call on the stack. sub longmess_heavy { - return @_ if ref $_[0]; - my $error = join '', @_; - my $mess = ""; - my $i = 1 + $CarpLevel; - my ($pack,$file,$line,$sub,$hargs,$eval,$require); - my (@a); - # - # crawl up the stack.... - # - while (do { { package DB; @a = caller($i++) } } ) { - # get copies of the variables returned from caller() - ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; - # - # if the $error error string is newline terminated then it - # is copied into $mess. Otherwise, $mess gets set (at the end of - # the 'else' section below) to one of two things. The first time - # through, it is set to the "$error at $file line $line" message. - # $error is then set to 'called' which triggers subsequent loop - # iterations to append $sub to $mess before appending the "$error - # at $file line $line" which now actually reads "called at $file line - # $line". Thus, the stack trace message is constructed: - # - # first time: $mess = $error at $file line $line - # subsequent times: $mess .= $sub $error at $file line $line - # ^^^^^^ - # "called" - if ($error =~ m/\n$/) { - $mess .= $error; - } else { - # Build a string, $sub, which names the sub-routine called. - # This may also be "require ...", "eval '...' or "eval {...}" - if (defined $eval) { - if ($require) { - $sub = "require $eval"; - } else { - $eval =~ s/([\\\'])/\\$1/g; - if ($MaxEvalLen && length($eval) > $MaxEvalLen) { - substr($eval,$MaxEvalLen) = '...'; - } - $sub = "eval '$eval'"; - } - } elsif ($sub eq '(eval)') { - $sub = 'eval {...}'; - } - # if there are any arguments in the sub-routine call, format - # them according to the format variables defined earlier in - # this file and join them onto the $sub sub-routine string - if ($hargs) { - # we may trash some of the args so we take a copy - @a = @DB::args; # must get local copy of args - # don't print any more than $MaxArgNums - if ($MaxArgNums and @a > $MaxArgNums) { - # cap the length of $#a and set the last element to '...' - $#a = $MaxArgNums; - $a[$#a] = "..."; - } - for (@a) { - # set args to the string "undef" if undefined - $_ = "undef", next unless defined $_; - if (ref $_) { - # force reference to string representation - $_ .= ''; - s/'/\\'/g; - } - else { - s/'/\\'/g; - # terminate the string early with '...' if too long - substr($_,$MaxArgLen) = '...' - if $MaxArgLen and $MaxArgLen < length; - } - # 'quote' arg unless it looks like a number - $_ = "'$_'" unless /^-?[\d.]+$/; - # print high-end chars as 'M-' - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - # print remaining control chars as ^ - s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; - } - # append ('all', 'the', 'arguments') to the $sub string - $sub .= '(' . join(', ', @a) . ')'; - } - # here's where the error message, $mess, gets constructed - $mess .= "\t$sub " if $error eq "called"; - $mess .= "$error at $file line $line"; - if (defined &Thread::tid) { - my $tid = Thread->self->tid; - $mess .= " thread $tid" if $tid; - } - $mess .= "\n"; - } - # we don't need to print the actual error message again so we can - # change this to "called" so that the string "$error at $file line - # $line" makes sense as "called at $file line $line". - $error = "called"; - } - $mess || $error; + return @_ if ref($_[0]); # WHAT IS THIS FOR??? + my $i = long_error_loc(); + return ret_backtrace($i, @_); } +# Returns a full stack backtrace starting from where it is +# told. +sub ret_backtrace { + my ($i, @error) = @_; + my $mess; + my $err = join '', @error; + $i++; + + my $tid_msg = ''; + if (defined &Thread::tid) { + my $tid = Thread->self->tid; + $tid_msg = " thread $tid" if $tid; + } + + if ($err =~ /\n$/) { + $mess = $err; + } + else { + my %i = caller_info($i); + $mess = "$err at $i{file} line $i{line}$tid_msg\n"; + } + + while (my %i = caller_info(++$i)) { + $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; + } + + return $mess || $err; +} -# ancestors() returns the complete set of ancestors of a module - -sub ancestors($$); - -sub ancestors($$){ - my( $pack, $href ) = @_; - if( @{"${pack}::ISA"} ){ - my $risa = \@{"${pack}::ISA"}; - my %tree = (); - @tree{@$risa} = (); - foreach my $mod ( @$risa ){ - # visit ancestors - if not already in the gallery - if( ! defined( $$href{$mod} ) ){ - my @ancs = ancestors( $mod, $href ); - @tree{@ancs} = (); - } - } - return ( keys( %tree ) ); - } else { - return (); - } +sub ret_summary { + my ($i, @error) = @_; + my $mess; + my $err = join '', @error; + $i++; + + my $tid_msg = ''; + if (defined &Thread::tid) { + my $tid = Thread->self->tid; + $tid_msg = " thread $tid" if $tid; + } + + my %i = caller_info($i); + return "$err at $i{file} line $i{line}$tid_msg\n"; +} + + +sub short_error_loc { + my $cache; + my $i = 1; + my $lvl = $CarpLevel; + { + my $called = caller($i++); + my $caller = caller($i); + return 0 unless defined($caller); # What happened? + redo if $Internal{$caller}; + redo if $CarpInternal{$called}; + redo if trusts($called, $caller, $cache); + redo if trusts($caller, $called, $cache); + redo unless 0 > --$lvl; + } + return $i - 1; +} + +sub shortmess_heavy { + return longmess_heavy(@_) if $Verbose; + return @_ if ref($_[0]); # WHAT IS THIS FOR??? + my $i = short_error_loc(); + if ($i) { + ret_summary($i, @_); + } + else { + longmess_heavy(@_); + } } +# If a string is too long, trims it with ... +sub str_len_trim { + my $str = shift; + my $max = shift || 0; + if (2 < $max and $max < length($str)) { + substr($str, $max - 3) = '...'; + } + return $str; +} -# shortmess() is called by carp() and croak() to skip all the way up to -# the top-level caller's package and report the error from there. confess() -# and cluck() generate a full stack trace so they call longmess() to -# generate that. In verbose mode shortmess() calls longmess() so -# you always get a stack trace - -sub shortmess_heavy { # Short-circuit &longmess if called via multiple packages - goto &longmess_heavy if $Verbose; - return @_ if ref $_[0]; - my $error = join '', @_; - my ($prevpack) = caller(1); - my $extra = $CarpLevel; - - my @Clans = ( $prevpack ); - my $i = 2; - my ($pack,$file,$line); - # when reporting an error, we want to report it from the context of the - # calling package. So what is the calling package? Within a module, - # there may be many calls between methods and perhaps between sub-classes - # and super-classes, but the user isn't interested in what happens - # inside the package. We start by building a hash array which keeps - # track of all the packages to which the calling package belongs. We - # do this by examining its @ISA variable. Any call from a base class - # method (one of our caller's @ISA packages) can be ignored - my %isa; - - # merge all the caller's @ISA packages and ancestors into %isa. - my @pars = ancestors( $prevpack, \%isa ); - @isa{@pars} = () if @pars; - $isa{$prevpack} = 1; - - # now we crawl up the calling stack and look at all the packages in - # there. For each package, we look to see if it has an @ISA and then - # we see if our caller features in that list. That would imply that - # our caller is a derived class of that package and its calls can also - # be ignored -CALLER: - while (($pack,$file,$line) = caller($i++)) { - - # Chances are, the caller's caller (or its caller...) is already - # in the gallery - if so, ignore this caller. - next if exists( $isa{$pack} ); - - # no: collect this module's ancestors. - my @i = ancestors( $pack, \%isa ); - my %i; - if( @i ){ - @i{@i} = (); - # check whether our representative of one of the clans is - # in this family tree. - foreach my $cl (@Clans){ - if( exists( $i{$cl} ) ){ - # yes: merge all of the family tree into %isa - @isa{@i,$pack} = (); - # and here's where we do some more ignoring... - # if the package in question is one of our caller's - # base or derived packages then we can ignore it (skip it) - # and go onto the next. - next CALLER if exists( $isa{$pack} ); - last; - } - } - } - - # Hey! We've found a package that isn't one of our caller's - # clan....but wait, $extra refers to the number of 'extra' levels - # we should skip up. If $extra > 0 then this is a false alarm. - # We must merge the package into the %isa hash (so we can ignore it - # if it pops up again), decrement $extra, and continue. - if ($extra-- > 0) { - push( @Clans, $pack ); - @isa{@i,$pack} = (); - } - else { - # OK! We've got a candidate package. Time to construct the - # relevant error message and return it. - my $msg; - $msg = "$error at $file line $line"; - if (defined &Thread::tid) { - my $tid = Thread->self->tid; - $mess .= " thread $tid" if $tid; - } - $msg .= "\n"; - return $msg; - } +# Takes two packages and an optional cache. Says whether the +# first inherits from the second. +# +# Recursive versions of this have to work to avoid certain +# possible endless loops, and when following long chains of +# inheritance are less efficient. +sub trusts { + my $child = shift; + my $parent = shift; + my $cache = shift || {}; + my ($known, $partial) = get_status($cache, $child); + # Figure out consequences until we have an answer + while (@$partial and not exists $known->{$parent}) { + my $anc = shift @$partial; + next if exists $known->{$anc}; + $known->{$anc}++; + my ($anc_knows, $anc_partial) = get_status($cache, $anc); + my @found = keys %$anc_knows; + @$known{@found} = (); + push @$partial, @$anc_partial; } + return exists $known->{$parent}; +} - # uh-oh! It looks like we crawled all the way up the stack and - # never found a candidate package. Oh well, let's call longmess - # to generate a full stack trace. We use the magical form of 'goto' - # so that this shortmess() function doesn't appear on the stack - # to further confuse longmess() about it's calling package. - goto &longmess_heavy; +# Takes a package and gives a list of those trusted directly +sub trusts_directly { + my $class = shift; + return @{"$class\::ISA"}; } 1; + diff --git a/lib/Class/Struct.pm b/lib/Class/Struct.pm index ac1fb47..185a8ff 100644 --- a/lib/Class/Struct.pm +++ b/lib/Class/Struct.pm @@ -14,7 +14,7 @@ require Exporter; @ISA = qw(Exporter); @EXPORT = qw(struct); -$VERSION = '0.58'; +$VERSION = '0.59'; ## Tested on 5.002 and 5.003 without class membership tests: my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95); @@ -51,6 +51,20 @@ sub printem { sub DESTROY { } } +sub import { + my $self = shift; + + if ( @_ == 0 ) { + $self->export_to_level( 1, $self, @EXPORT ); + } elsif ( @_ == 1 ) { + # This is admittedly a little bit silly: + # do we ever export anything else than 'struct'...? + $self->export_to_level( 1, $self, @_ ); + } else { + &struct; + } +} + sub struct { # Determine parameter list structure, one of: @@ -76,6 +90,7 @@ sub struct { $class = (caller())[0]; @decls = @_; } + _usage_error() if @decls % 2 == 1; # Ensure we are not, and will not be, a subclass. @@ -242,6 +257,9 @@ Class::Struct - declare struct-like datatypes as Perl classes # declare struct, based on array, implicit class name: struct( ELEMENT_NAME => ELEMENT_TYPE, ... ); + # Declare struct at compile time + use Class::Struct CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]; + use Class::Struct CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... }; package Myobj; use Class::Struct; @@ -262,14 +280,13 @@ Class::Struct - declare struct-like datatypes as Perl classes # hash type accessor: $hash_ref = $obj->h; # reference to whole hash $hash_element_value = $obj->h('x'); # hash element value - $obj->h('x', 'new value'); # assign to hash element + $obj->h('x', 'new value'); # assign to hash element # class type accessor: $element_value = $obj->c; # object reference $obj->c->method(...); # call method of object $obj->c(new My_Other_Class); # assign a new object - =head1 DESCRIPTION C exports a single function, C. @@ -287,7 +304,6 @@ same name in the package. (See Example 2.) Each element's type can be scalar, array, hash, or class. - =head2 The C function The C function has three forms of parameter-list. @@ -326,6 +342,15 @@ element name will be defined as an accessor method unless a method by that name is explicitly defined; in the latter case, a warning is issued if the warning flag (B<-w>) is set. +=head2 Class Creation at Compile Time + +C can create your class at compile time. The main reason +for doing this is obvious, so your class acts like every other class in +Perl. Creating your class at compile time will make the order of events +similar to using any other class ( or Perl module ). + +There is no significant speed gain between compile time and run time +class creation, there is just a new, more standard order of events. =head2 Element Types and Accessor Methods @@ -410,7 +435,6 @@ contents of that hash are passed to the element's own constructor. See Example 3 below for an example of initialization. - =head1 EXAMPLES =over @@ -444,7 +468,6 @@ type C. $t->ru_stime->tv_secs(5); $t->ru_stime->tv_usecs(0); - =item Example 2 An accessor function can be redefined in order to provide @@ -492,7 +515,6 @@ Note that the initializer for a nested struct is specified as an anonymous hash of initializers, which is passed on to the nested struct's constructor. - use Class::Struct; struct Breed => @@ -524,6 +546,9 @@ struct's constructor. =head1 Author and Modification History +Modified by Casey Tweten, 2000-11-08, v0.59. + + Added the ability for compile time class creation. Modified by Damian Conway, 1999-03-05, v0.58. @@ -541,7 +566,6 @@ Modified by Damian Conway, 1999-03-05, v0.58. Previously these were returned as a reference to a reference to the element. - Renamed to C and modified by Jim Miner, 1997-04-02. members() function removed. @@ -553,7 +577,6 @@ Renamed to C and modified by Jim Miner, 1997-04-02. Class name to struct() made optional. Diagnostic checks added. - Originally C by Dean Roehrich. # Template.pm --- struct/member template builder diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 7279591..4a263cd 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -70,7 +70,7 @@ use strict; use Carp; -our $VERSION = '2.03'; +our $VERSION = '2.04'; use base qw/ Exporter /; our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); @@ -99,6 +99,9 @@ unless(defined &cwd) { } } +# set a reasonable (and very safe) default for fastgetcwd, in case it +# isn't redefined later (20001212 rspier) +*fastgetcwd = \&cwd; # By Brandon S. Allbery # @@ -188,7 +191,7 @@ sub chdir_init { } sub chdir { - my $newdir = @? ? shift : ''; # allow for no arg (chdir to HOME dir) + my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir) $newdir =~ s|///*|/|g unless $^O eq 'MSWin32'; chdir_init() unless $chdir_init; return 0 unless CORE::chdir $newdir; @@ -408,7 +411,8 @@ sub _epoc_cwd { *abs_path = \&fast_abs_path; } elsif ($^O eq 'epoc') { - *getcwd = \&_epoc_cwd; + *cwd = \&_epoc_cwd; + *getcwd = \&_epoc_cwd; *fastgetcwd = \&_epoc_cwd; *fastcwd = \&_epoc_cwd; *abs_path = \&fast_abs_path; diff --git a/lib/DirHandle.pm b/lib/DirHandle.pm index 047755d..12ee6c6 100644 --- a/lib/DirHandle.pm +++ b/lib/DirHandle.pm @@ -1,5 +1,7 @@ package DirHandle; +our $VERSION = '1.00'; + =head1 NAME DirHandle - supply object methods for directory handles diff --git a/lib/Dumpvalue.pm b/lib/Dumpvalue.pm index 475f4ff..c8282cf 100644 --- a/lib/Dumpvalue.pm +++ b/lib/Dumpvalue.pm @@ -1,6 +1,7 @@ use 5.005_64; # for (defined ref) and $#$v and our package Dumpvalue; use strict; +our $VERSION = '1.00'; our(%address, $stab, @stab, %stab, %subs); # translate control chars to ^X - Randal Schwartz diff --git a/lib/English.pm b/lib/English.pm index 1ebc3de..77f27c5 100644 --- a/lib/English.pm +++ b/lib/English.pm @@ -1,5 +1,7 @@ package English; +our $VERSION = '1.00'; + require Exporter; @ISA = (Exporter); diff --git a/lib/Env.pm b/lib/Env.pm index d1ee071..eb9187f 100644 --- a/lib/Env.pm +++ b/lib/Env.pm @@ -1,5 +1,7 @@ package Env; +our $VERSION = '1.00'; + =head1 NAME Env - perl module that imports environment variables as scalars or arrays diff --git a/lib/Exporter.pm b/lib/Exporter.pm index 585109e..ad6cdef 100644 --- a/lib/Exporter.pm +++ b/lib/Exporter.pm @@ -2,88 +2,85 @@ package Exporter; require 5.001; -$ExportLevel = 0; -$Verbose ||= 0; -$VERSION = '5.562'; +use strict; +no strict 'refs'; + +our $Debug = 0; +our $ExportLevel = 0; +our $Verbose ||= 0; +our $VERSION = '5.562'; sub export_to_level { require Exporter::Heavy; - goto &heavy_export_to_level; + goto &Exporter::Heavy::heavy_export_to_level; } sub export { require Exporter::Heavy; - goto &heavy_export; + goto &Exporter::Heavy::heavy_export; } sub export_tags { require Exporter::Heavy; - _push_tags((caller)[0], "EXPORT", \@_); + Exporter::Heavy::_push_tags((caller)[0], "EXPORT", \@_); } sub export_ok_tags { require Exporter::Heavy; - _push_tags((caller)[0], "EXPORT_OK", \@_); + Exporter::Heavy::_push_tags((caller)[0], "EXPORT_OK", \@_); } sub import { my $pkg = shift; my $callpkg = caller($ExportLevel); - *exports = *{"$pkg\::EXPORT"}; + + my($exports, $export_cache) = (\@{"$pkg\::EXPORT"}, + \%{"$pkg\::EXPORT"}); # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-( - *fail = *{"$pkg\::EXPORT_FAIL"}; + my($fail) = \@{"$pkg\::EXPORT_FAIL"}; return export $pkg, $callpkg, @_ - if $Verbose or $Debug or @fail > 1; - my $args = @_ or @_ = @exports; + if $Verbose or $Debug or @$fail > 1; + my $args = @_ or @_ = @$exports; - if ($args and not %exports) { - foreach my $sym (@exports, @{"$pkg\::EXPORT_OK"}) { + if ($args and not %$export_cache) { + foreach my $sym (@$exports, @{"$pkg\::EXPORT_OK"}) { $sym =~ s/^&//; - $exports{$sym} = 1; + $export_cache->{$sym} = 1; } } if ($Verbose or $Debug - or grep {/\W/ or $args and not exists $exports{$_} - or @fail and $_ eq $fail[0] + or grep {/\W/ or $args and not exists $export_cache->{$_} + or @$fail and $_ eq $fail->[0] or (@{"$pkg\::EXPORT_OK"} and $_ eq ${"$pkg\::EXPORT_OK"}[0])} @_) { return export $pkg, $callpkg, ($args ? @_ : ()); } - #local $SIG{__WARN__} = sub {require Carp; goto &Carp::carp}; local $SIG{__WARN__} = sub {require Carp; local $Carp::CarpLevel = 1; &Carp::carp}; - foreach $sym (@_) { + foreach my $sym (@_) { # shortcut for the common case of no type character *{"$callpkg\::$sym"} = \&{"$pkg\::$sym"}; } } -1; -# A simple self test harness. Change 'require Carp' to 'use Carp ()' for testing. -# package main; eval(join('',)) or die $@ unless caller; -__END__ -package Test; -$INC{'Exporter.pm'} = 1; -@ISA = qw(Exporter); -@EXPORT = qw(A1 A2 A3 A4 A5); -@EXPORT_OK = qw(B1 B2 B3 B4 B5); -%EXPORT_TAGS = (T1=>[qw(A1 A2 B1 B2)], T2=>[qw(A1 A2 B3 B4)], T3=>[qw(X3)]); -@EXPORT_FAIL = qw(B4); -Exporter::export_ok_tags('T3', 'unknown_tag'); +# Default methods + sub export_fail { - map { "Test::$_" } @_ # edit symbols just as an example + my $self = shift; + @_; } -package main; -$Exporter::Verbose = 1; -#import Test; -#import Test qw(X3); # export ok via export_ok_tags() -#import Test qw(:T1 !A2 /5/ !/3/ B5); -import Test qw(:T2 !B4); -import Test qw(:T2); # should fail + +sub require_version { + require Exporter::Heavy; + goto &Exporter::Heavy::require_version; +} + + 1; + =head1 NAME Exporter - Implements default import method for modules diff --git a/lib/Exporter/Heavy.pm b/lib/Exporter/Heavy.pm index 6647f70..39bce2d 100644 --- a/lib/Exporter/Heavy.pm +++ b/lib/Exporter/Heavy.pm @@ -1,4 +1,12 @@ -package Exporter; +package Exporter::Heavy; + +use strict; +no strict 'refs'; + +# On one line so MakeMaker will see it. +require Exporter; our $VERSION = $Exporter::VERSION; + +our $Verbose; =head1 NAME @@ -41,16 +49,17 @@ sub heavy_export { my($pkg, $callpkg, @imports) = @_; my($type, $sym, $oops); - *exports = *{"${pkg}::EXPORT"}; + my($exports, $export_cache) = (\@{"${pkg}::EXPORT"}, + \%{"${pkg}::EXPORT"}); if (@imports) { - if (!%exports) { - grep(s/^&//, @exports); - @exports{@exports} = (1) x @exports; + if (!%$export_cache) { + s/^&// foreach @$exports; + @{$export_cache}{@$exports} = (1) x @$exports; my $ok = \@{"${pkg}::EXPORT_OK"}; if (@$ok) { - grep(s/^&//, @$ok); - @exports{@$ok} = (1) x @$ok; + s/^&// foreach @$ok; + @{$export_cache}{@$ok} = (1) x @$ok; } } @@ -66,7 +75,7 @@ sub heavy_export { if ($spec =~ s/^://){ if ($spec eq 'DEFAULT'){ - @names = @exports; + @names = @$exports; } elsif ($tagdata = $tagsref->{$spec}) { @names = @$tagdata; @@ -79,7 +88,7 @@ sub heavy_export { } elsif ($spec =~ m:^/(.*)/$:){ my $patn = $1; - @allexports = keys %exports unless @allexports; # only do keys once + @allexports = keys %$export_cache unless @allexports; # only do keys once @names = grep(/$patn/, @allexports); # not anchored by default } else { @@ -100,13 +109,13 @@ sub heavy_export { } foreach $sym (@imports) { - if (!$exports{$sym}) { + if (!$export_cache->{$sym}) { if ($sym =~ m/^\d/) { $pkg->require_version($sym); # If the version number was the only thing specified # then we should act as if nothing was specified: if (@imports == 1) { - @imports = @exports; + @imports = @$exports; last; } # We need a way to emulate 'use Foo ()' but still @@ -115,7 +124,7 @@ sub heavy_export { @imports = (); last; } - } elsif ($sym !~ s/^&// || !$exports{$sym}) { + } elsif ($sym !~ s/^&// || !$export_cache->{$sym}) { require Carp; Carp::carp(qq["$sym" is not exported by the $pkg module]); $oops++; @@ -128,21 +137,23 @@ sub heavy_export { } } else { - @imports = @exports; + @imports = @$exports; } - *fail = *{"${pkg}::EXPORT_FAIL"}; - if (@fail) { - if (!%fail) { + my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"}, + \%{"${pkg}::EXPORT_FAIL"}); + + if (@$fail) { + if (!%$fail_cache) { # Build cache of symbols. Optimise the lookup by adding # barewords twice... both with and without a leading &. - # (Technique could be applied to %exports cache at cost of memory) - my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @fail; + # (Technique could be applied to $export_cache at cost of memory) + my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail; warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Verbose; - @fail{@expanded} = (1) x @expanded; + @{$fail_cache}{@expanded} = (1) x @expanded; } my @failed; - foreach $sym (@imports) { push(@failed, $sym) if $fail{$sym} } + foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} } if (@failed) { @failed = $pkg->export_fail(@failed); foreach $sym (@failed) { @@ -188,24 +199,19 @@ sub heavy_export_to_level sub _push_tags { my($pkg, $var, $syms) = @_; - my $nontag; - *export_tags = \%{"${pkg}::EXPORT_TAGS"}; + my @nontag = (); + my $export_tags = \%{"${pkg}::EXPORT_TAGS"}; push(@{"${pkg}::$var"}, - map { $export_tags{$_} ? @{$export_tags{$_}} : scalar(++$nontag,$_) } - (@$syms) ? @$syms : keys %export_tags); - if ($nontag and $^W) { + map { $export_tags->{$_} ? @{$export_tags->{$_}} + : scalar(push(@nontag,$_),$_) } + (@$syms) ? @$syms : keys %$export_tags); + if (@nontag and $^W) { # This may change to a die one day require Carp; - Carp::carp("Some names are not tags"); + Carp::carp(join(", ", @nontag)." are not tags of $pkg"); } } -# Default methods - -sub export_fail { - my $self = shift; - @_; -} sub require_version { my($self, $wanted) = @_; diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm index 92db8c9..c496aa0 100644 --- a/lib/ExtUtils/Install.pm +++ b/lib/ExtUtils/Install.pm @@ -262,8 +262,22 @@ sub inc_uninstall { } } +sub run_filter { + my ($cmd, $src, $dest) = @_; + local *SRC, *CMD; + open(CMD, "|$cmd >$dest") || die "Cannot fork: $!"; + open(SRC, $src) || die "Cannot open $src: $!"; + my $buf; + my $sz = 1024; + while (my $len = sysread(SRC, $buf, $sz)) { + syswrite(CMD, $buf, $len); + } + close SRC; + close CMD or die "Filter command '$cmd' failed for $src"; +} + sub pm_to_blib { - my($fromto,$autodir) = @_; + my($fromto,$autodir,$pm_filter) = @_; use File::Basename qw(dirname); use File::Copy qw(copy); @@ -286,23 +300,37 @@ sub pm_to_blib { mkpath($autodir,0,0755); foreach (keys %$fromto) { - next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_; - unless (compare($_,$fromto->{$_})){ - print "Skip $fromto->{$_} (unchanged)\n"; + my $dest = $fromto->{$_}; + next if -f $dest && -M $dest < -M $_; + + # When a pm_filter is defined, we need to pre-process the source first + # to determine whether it has changed or not. Therefore, only perform + # the comparison check when there's no filter to be ran. + # -- RAM, 03/01/2001 + + my $need_filtering = defined $pm_filter && length $pm_filter && /\.pm$/; + + if (!$need_filtering && 0 == compare($_,$dest)) { + print "Skip $dest (unchanged)\n"; next; } - if (-f $fromto->{$_}){ - forceunlink($fromto->{$_}); + if (-f $dest){ + forceunlink($dest); + } else { + mkpath(dirname($dest),0,0755); + } + if ($need_filtering) { + run_filter($pm_filter, $_, $dest); + print "$pm_filter <$_ >$dest\n"; } else { - mkpath(dirname($fromto->{$_}),0,0755); + copy($_,$dest); + print "cp $_ $dest\n"; } - copy($_,$fromto->{$_}); my($mode,$atime,$mtime) = (stat)[2,8,9]; - utime($atime,$mtime+$Is_VMS,$fromto->{$_}); - chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$fromto->{$_}); - print "cp $_ $fromto->{$_}\n"; - next unless /\.pm\z/; - autosplit($fromto->{$_},$autodir); + utime($atime,$mtime+$Is_VMS,$dest); + chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$dest); + next unless /\.pm$/; + autosplit($dest,$autodir); } } @@ -392,6 +420,11 @@ no-don't-really-do-it-now switch. pm_to_blib() takes a hashref as the first argument and copies all keys of the hash to the corresponding values efficiently. Filenames with the extension pm are autosplit. Second argument is the autosplit -directory. +directory. If third argument is not empty, it is taken as a filter command +to be ran on each .pm file, the output of the command being what is finally +copied, and the source for auto-splitting. + +You can have an environment variable PERL_INSTALL_ROOT set which will +be prepended as a directory to each installed file (and directory). =cut diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index b22363b..5e2f91d 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -1,9 +1,30 @@ package ExtUtils::Liblist; +@ISA = qw(ExtUtils::Liblist::Kid File::Spec); + +sub lsdir { + shift; + my $rex = qr/$_[1]/; + opendir my $dir, $_[0]; + grep /$rex/, readdir $dir; +} + +sub file_name_is_absolute { + require File::Spec; + shift; + 'File::Spec'->file_name_is_absolute(@_); +} + + +package ExtUtils::Liblist::Kid; + +# This kid package is to be used by MakeMaker. It will not work if +# $self is not a Makemaker. + use 5.005_64; # Broken out of MakeMaker from version 4.11 -our $VERSION = substr q$Revision: 1.25 $, 10; +our $VERSION = substr q$Revision: 1.26 $, 10; use Config; use Cwd 'cwd'; @@ -16,7 +37,7 @@ sub ext { } sub _unix_os2_ext { - my($self,$potential_libs, $verbose) = @_; + my($self,$potential_libs, $verbose, $give_libs) = @_; if ($^O =~ 'os2' and $Config{perllibs}) { # Dynamic libraries are not transitive, so we may need including # the libraries linked against perl.dll again. @@ -24,7 +45,7 @@ sub _unix_os2_ext { $potential_libs .= " " if $potential_libs; $potential_libs .= $Config{perllibs}; } - return ("", "", "", "") unless $potential_libs; + return ("", "", "", "", ($give_libs ? [] : ())) unless $potential_libs; warn "Potential libraries are '$potential_libs':\n" if $verbose; my($so) = $Config{'so'}; @@ -39,6 +60,7 @@ sub _unix_os2_ext { my(@searchpath); # from "-L/path" entries in $potential_libs my(@libpath) = split " ", $Config{'libpth'}; my(@ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen); + my(@libs, %libs_seen); my($fullname, $thislib, $thispth, @fullname); my($pwd) = cwd(); # from Cwd.pm my($found) = 0; @@ -132,6 +154,7 @@ sub _unix_os2_ext { warn "'-l$thislib' found at $fullname\n" if $verbose; my($fullnamedir) = dirname($fullname); push @ld_run_path, $fullnamedir unless $ld_run_path_seen{$fullnamedir}++; + push @libs, $fullname unless $libs_seen{$fullname}++; $found++; $found_lib++; @@ -179,19 +202,19 @@ sub _unix_os2_ext { ."No library found for -l$thislib\n" unless $found_lib>0; } - return ('','','','') unless $found; - ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path)); + return ('','','','', ($give_libs ? \@libs : ())) unless $found; + ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path), ($give_libs ? \@libs : ())); } sub _win32_ext { require Text::ParseWords; - my($self, $potential_libs, $verbose) = @_; + my($self, $potential_libs, $verbose, $give_libs) = @_; # If user did not supply a list, we punt. # (caller should probably use the list in $Config{libs}) - return ("", "", "", "") unless $potential_libs; + return ("", "", "", "", ($give_libs ? [] : ())) unless $potential_libs; my $cc = $Config{cc}; my $VC = 1 if $cc =~ /^cl/i; @@ -201,6 +224,7 @@ sub _win32_ext { my $libs = $Config{'perllibs'}; my $libpth = $Config{'libpth'}; my $libext = $Config{'lib_ext'} || ".lib"; + my(@libs, %libs_seen); if ($libs and $potential_libs !~ /:nodefault/i) { # If Config.pm defines a set of default libs, we always @@ -298,6 +322,7 @@ sub _win32_ext { $found++; $found_lib++; push(@extralibs, $fullname); + push @libs, $fullname unless $libs_seen{$fullname}++; last; } @@ -319,10 +344,11 @@ sub _win32_ext { } - return ('','','','') unless $found; + return ('','','','', ($give_libs ? \@libs : ())) unless $found; # make sure paths with spaces are properly quoted @extralibs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @extralibs; + @libs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @libs; $lib = join(' ',@extralibs); # normalize back to backward slashes (to help braindead tools) @@ -331,12 +357,12 @@ sub _win32_ext { $lib =~ s,/,\\,g; warn "Result: $lib\n" if $verbose; - wantarray ? ($lib, '', $lib, '') : $lib; + wantarray ? ($lib, '', $lib, '', ($give_libs ? \@libs : ())) : $lib; } sub _vms_ext { - my($self, $potential_libs,$verbose) = @_; + my($self, $potential_libs,$verbose,$give_libs) = @_; my(@crtls,$crtlstr); my($dbgqual) = $self->{OPTIMIZE} || $Config{'optimize'} || $self->{CCFLAS} || $Config{'ccflags'}; @@ -365,7 +391,7 @@ sub _vms_ext { unless ($potential_libs) { warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose; - return ('', '', $crtlstr, ''); + return ('', '', $crtlstr, '', ($give_libs ? [] : ())); } my(@dirs,@libs,$dir,$lib,%found,@fndlibs,$ldlib); @@ -374,6 +400,7 @@ sub _vms_ext { # List of common Unix library names and there VMS equivalents # (VMS equivalent of '' indicates that the library is automatially # searched by the linker, and should be skipped here.) + my(@flibs, %libs_seen); my %libmap = ( 'm' => '', 'f77' => '', 'F77' => '', 'V77' => '', 'c' => '', 'malloc' => '', 'crypt' => '', 'resolv' => '', 'c_s' => '', 'socket' => '', 'X11' => 'DECW$XLIBSHR', @@ -478,6 +505,7 @@ sub _vms_ext { if ($cand eq 'VAXCCURSE') { unshift @{$found{$ctype}}, $cand; } else { push @{$found{$ctype}}, $cand; } warn "\tFound as $cand (really $test), type $ctype\n" if $verbose > 1; + push @flibs, $name unless $libs_seen{$fullname}++; next LIB; } } @@ -492,7 +520,7 @@ sub _vms_ext { $ldlib = $crtlstr ? "$lib $crtlstr" : $lib; warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose; - wantarray ? ($lib, '', $ldlib, '') : $lib; + wantarray ? ($lib, '', $ldlib, '', ($give_libs ? \@flibs : ())) : $lib; } 1; @@ -507,20 +535,22 @@ ExtUtils::Liblist - determine libraries to use and how to use them C -C +C =head1 DESCRIPTION This utility takes a list of libraries in the form C<-llib1 -llib2 --llib3> and prints out lines suitable for inclusion in an extension +-llib3> and returns lines suitable for inclusion in an extension Makefile. Extra library paths may be included with the form C<-L/another/path> this will affect the searches for all subsequent libraries. -It returns an array of four scalar values: EXTRALIBS, BSLOADLIBS, -LDLOADLIBS, and LD_RUN_PATH. Some of these don't mean anything -on VMS and Win32. See the details about those platform specifics -below. +It returns an array of four or five scalar values: EXTRALIBS, +BSLOADLIBS, LDLOADLIBS, LD_RUN_PATH, and, optionally, a reference to +the array of the filenames of actual libraries. Some of these don't +mean anything unless on Unix. See the details about those platform +specifics below. The list of the filenames is returned only if +$need_names argument is true. Dependent libraries can be linked in one of three ways: diff --git a/lib/ExtUtils/MANIFEST.SKIP b/lib/ExtUtils/MANIFEST.SKIP new file mode 100644 index 0000000..a203d8f --- /dev/null +++ b/lib/ExtUtils/MANIFEST.SKIP @@ -0,0 +1,16 @@ +# Avoid version control files. +\bRCS\b +\bCVS\b +,v$ + +# Avoid Makemaker generated and utility files. +^MANIFEST\. +^Makefile$ +^blib/ +^MakeMaker-\d +^pm_to_blib$ + +# Avoid temp and backup files. +~$ +\.old$ +\#$ diff --git a/lib/ExtUtils/MM_Cygwin.pm b/lib/ExtUtils/MM_Cygwin.pm index a5ba410..abb491f 100644 --- a/lib/ExtUtils/MM_Cygwin.pm +++ b/lib/ExtUtils/MM_Cygwin.pm @@ -1,12 +1,16 @@ package ExtUtils::MM_Cygwin; +use strict; + +our $VERSION = '1.00'; + use Config; #use Cwd; #use File::Basename; require Exporter; -Exporter::import('ExtUtils::MakeMaker', - qw( $Verbose &neatvalue)); +require ExtUtils::MakeMaker; +ExtUtils::MakeMaker->import(qw( $Verbose &neatvalue)); unshift @MM::ISA, 'ExtUtils::MM_Cygwin'; @@ -71,6 +75,8 @@ q[-e 'next if -e $$m{$$_} && -M $$m{$$_} < -M $$_ && -M $$m{$$_} < -M "], push(@m,"\n"); if (%{$self->{MAN1PODS}} || %{$self->{MAN3PODS}}) { + grep { $self->{MAN1PODS}{$_} =~ s/::/./g } keys %{$self->{MAN1PODS}}; + grep { $self->{MAN3PODS}{$_} =~ s/::/./g } keys %{$self->{MAN3PODS}}; push @m, "\t$self->{NOECHO}\$(POD2MAN) \\\n\t"; push @m, join " \\\n\t", %{$self->{MAN1PODS}}, %{$self->{MAN3PODS}}; } diff --git a/lib/ExtUtils/MM_OS2.pm b/lib/ExtUtils/MM_OS2.pm index 430235a..c0c5240 100644 --- a/lib/ExtUtils/MM_OS2.pm +++ b/lib/ExtUtils/MM_OS2.pm @@ -1,12 +1,16 @@ package ExtUtils::MM_OS2; +use strict; + +our $VERSION = '1.00'; + #use Config; #use Cwd; #use File::Basename; require Exporter; -Exporter::import('ExtUtils::MakeMaker', - qw( $Verbose &neatvalue)); +require ExtUtils::MakeMaker; +ExtUtils::MakeMaker->import(qw( $Verbose &neatvalue)); unshift @MM::ISA, 'ExtUtils::MM_OS2'; @@ -34,7 +38,7 @@ $self->{BASEEXT}.def: Makefile.PL ', "DL_VARS" => ', neatvalue($vars), ');\' '); } - if (%{$self->{IMPORTS}}) { + if ($self->{IMPORTS} && %{$self->{IMPORTS}}) { # Make import files (needed for static build) -d 'tmp_imp' or mkdir 'tmp_imp', 0777 or die "Can't mkdir tmp_imp"; open IMP, '>tmpimp.imp' or die "Can't open tmpimp.imp"; @@ -57,7 +61,7 @@ $self->{BASEEXT}.def: Makefile.PL sub static_lib { my($self) = @_; my $old = $self->ExtUtils::MM_Unix::static_lib(); - return $old unless %{$self->{IMPORTS}}; + return $old unless $self->{IMPORTS} && %{$self->{IMPORTS}}; my @chunks = split /\n{2,}/, $old; shift @chunks unless length $chunks[0]; # Empty lines at the start diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 52862c5..d7dd720 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -1,17 +1,19 @@ package ExtUtils::MM_Unix; +use strict; + use Exporter (); use Config; use File::Basename qw(basename dirname fileparse); use DirHandle; use strict; -use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 $Is_Dos $Is_PERL_OBJECT - $Verbose %pm %static $Xsubpp_Version); +our ($Is_Mac,$Is_OS2,$Is_VMS,$Is_Win32,$Is_Dos,$Is_PERL_OBJECT, + $Verbose,%pm,%static,$Xsubpp_Version); -$VERSION = substr q$Revision: 1.12603 $, 10; -# $Id: MM_Unix.pm,v 1.126 1998/06/28 21:32:49 k Exp k $ +our $VERSION = '1.12603'; -Exporter::import('ExtUtils::MakeMaker', qw($Verbose &neatvalue)); +require ExtUtils::MakeMaker; +ExtUtils::MakeMaker->import(qw($Verbose &neatvalue)); $Is_OS2 = $^O eq 'os2'; $Is_Mac = $^O eq 'MacOS'; @@ -264,6 +266,14 @@ sub c_o { my($self) = shift; return '' unless $self->needs_linking(); my(@m); + if (my $cpp = $Config{cpprun}) { + my $cpp_cmd = $self->const_cccmd; + $cpp_cmd =~ s/^CCCMD\s*=\s*\$\(CC\)/$cpp/; + push @m, ' +.c.i: + '. $cpp_cmd . ' $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c > $*.i +'; + } push @m, ' .c$(OBJ_EXT): $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c @@ -580,7 +590,7 @@ MM_VERSION = $ExtUtils::MakeMaker::VERSION for $tmp (qw/ FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT - LDFROM LINKTYPE + LDFROM LINKTYPE PM_FILTER / ) { next unless defined $self->{$tmp}; push @m, "$tmp = $self->{$tmp}\n"; @@ -628,7 +638,7 @@ MAN3PODS = ".join(" \\\n\t", sort keys %{$self->{MAN3PODS}})." # work around a famous dec-osf make(1) feature(?): makemakerdflt: all -.SUFFIXES: .xs .c .C .cpp .cxx .cc \$(OBJ_EXT) +.SUFFIXES: .xs .c .C .cpp .i .cxx .cc \$(OBJ_EXT) # Nick wanted to get rid of .PRECIOUS. I don't remember why. I seem to recall, that # some make implementations will delete the Makefile when we rebuild it. Because @@ -1074,6 +1084,14 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $ldrun = qq{-rpath "$self->{LD_RUN_PATH}"} if ($^O eq 'irix' && $self->{LD_RUN_PATH}); + # For example in AIX the shared objects/libraries from previous builds + # linger quite a while in the shared dynalinker cache even when nobody + # is using them. This is painful if one for instance tries to restart + # a failed build because the link command will fail unnecessarily 'cos + # the shared object/library is 'busy'. + push(@m,' $(RM_F) $@ +'); + push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom. ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)'); push @m, ' @@ -1650,7 +1668,7 @@ sub init_main { unless ($self->{PERL_SRC}){ my($dir); - foreach $dir ($self->updir(),$self->catdir($self->updir(),$self->updir()),$self->catdir($self->updir(),$self->updir(),$self->updir())){ + foreach $dir ($self->updir(),$self->catdir($self->updir(),$self->updir()),$self->catdir($self->updir(),$self->updir(),$self->updir()),$self->catdir($self->updir(),$self->updir(),$self->updir(),$self->updir())){ if ( -f $self->catfile($dir,"config.sh") && @@ -1702,6 +1720,7 @@ from the perl source tree. $self->{PERL_INC} = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now my $perl_h; + no warnings 'uninitialized' ; if (not -f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h")) and not $old){ # Maybe somebody tries to build an extension with an @@ -2455,6 +2474,7 @@ MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} } unless ($libperl && -f $lperl) { # Ilya's code... my $dir = $self->{PERL_SRC} || "$self->{PERL_ARCHLIB}/CORE"; + $dir = "$self->{PERL_ARCHLIB}/.." if $self->{UNINSTALLED_PERL}; $libperl ||= "libperl$self->{LIB_EXT}"; $libperl = "$dir/$libperl"; $lperl ||= "libperl$self->{LIB_EXT}"; @@ -3030,7 +3050,7 @@ sub pm_to_blib { pm_to_blib: $(TO_INST_PM) }.$self->{NOECHO}.q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \ "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \ - -e "pm_to_blib({qw{$(PM_TO_BLIB)}},'}.$autodir.q{')" + -e "pm_to_blib({qw{$(PM_TO_BLIB)}},'}.$autodir.q{','$(PM_FILTER)')" }.$self->{NOECHO}.q{$(TOUCH) $@ }; } @@ -3141,8 +3161,22 @@ realclean purge :: clean push(@m, " $self->{RM_F} \$(INST_DYNAMIC) \$(INST_BOOT)\n"); push(@m, " $self->{RM_F} \$(INST_STATIC)\n"); } - push(@m, " $self->{RM_F} " . join(" ", values %{$self->{PM}}) . "\n") - if keys %{$self->{PM}}; + # Issue a several little RM_F commands rather than risk creating a + # very long command line (useful for extensions such as Encode + # that have many files). + if (keys %{$self->{PM}}) { + my $line = ""; + foreach (values %{$self->{PM}}) { + if (length($line) + length($_) > 80) { + push @m, "\t$self->{RM_F} $line\n"; + $line = $_; + } + else { + $line .= " $_"; + } + } + push @m, "\t$self->{RM_F} $line\n" if $line; + } my(@otherfiles) = ($self->{MAKEFILE}, "$self->{MAKEFILE}.old"); # Makefiles last push(@otherfiles, $attribs{FILES}) if $attribs{FILES}; @@ -3287,8 +3321,9 @@ sub subdir_x { my($self, $subdir) = @_; my(@m); if ($Is_Win32 && Win32::IsWin95()) { - # XXX: dmake-specific, like rest of Win95 port - return <import('$Verbose', '&neatvalue'); =head1 NAME @@ -122,7 +126,7 @@ sub ExtUtils::MM_VMS::makeaperl; sub ExtUtils::MM_VMS::ext; sub ExtUtils::MM_VMS::nicetext; -#use SelfLoader; +our $AUTOLOAD; sub AUTOLOAD { my $code; if (defined fileno(DATA)) { @@ -151,11 +155,12 @@ sub AUTOLOAD { # This isn't really an override. It's just here because ExtUtils::MM_VMS -# appears in @MM::ISA before ExtUtils::Liblist, so if there isn't an ext() +# appears in @MM::ISA before ExtUtils::Liblist::Kid, so if there isn't an ext() # in MM_VMS, then AUTOLOAD is called, and bad things happen. So, we just -# mimic inheritance here and hand off to ExtUtils::Liblist. +# mimic inheritance here and hand off to ExtUtils::Liblist::Kid. sub ext { - ExtUtils::Liblist::ext(@_); + require ExtUtils::Liblist; + ExtUtils::Liblist::Kid::ext(@_); } =back @@ -557,22 +562,23 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision # DLBASE = Basename part of dynamic library. May be just equal BASEEXT. ]; - for $tmp (qw/ + for my $tmp (qw/ FULLEXT VERSION_FROM OBJECT LDFROM / ) { next unless defined $self->{$tmp}; push @m, "$tmp = ",$self->fixpath($self->{$tmp},0),"\n"; } - for $tmp (qw/ + for my $tmp (qw/ BASEEXT PARENT_NAME DLBASE INC DEFINE LINKTYPE / ) { next unless defined $self->{$tmp}; push @m, "$tmp = $self->{$tmp}\n"; } - for $tmp (qw/ XS MAN1PODS MAN3PODS PM /) { - next unless defined $self->{$tmp}; + for my $tmp (qw/ XS MAN1PODS MAN3PODS PM /) { + # Where is the space coming from? --jhi + next unless $self ne " " && defined $self->{$tmp}; my(%tmp,$key); for $key (keys %{$self->{$tmp}}) { $tmp{$self->fixpath($key,0)} = $self->fixpath($self->{$tmp}{$key},0); @@ -580,7 +586,7 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision $self->{$tmp} = \%tmp; } - for $tmp (qw/ C O_FILES H /) { + for my $tmp (qw/ C O_FILES H /) { next unless defined $self->{$tmp}; my(@tmp,$val); for $val (@{$self->{$tmp}}) { @@ -601,7 +607,7 @@ MAN3PODS = ',$self->wraplist(sort keys %{$self->{MAN3PODS}}),' '; - for $tmp (qw/ + for my $tmp (qw/ INST_MAN1DIR INSTALLMAN1DIR MAN1EXT INST_MAN3DIR INSTALLMAN3DIR MAN3EXT /) { next unless defined $self->{$tmp}; @@ -700,7 +706,7 @@ sub cflags { # conflate the ones from $Config{'ccflags'} and $self->{DEFINE} # ($self->{DEFINE} has already been VMSified in constants() above) if ($self->{DEFINE}) { $quals .= $self->{DEFINE}; } - for $type (qw(Def Undef)) { + for my $type (qw(Def Undef)) { my(@terms); while ($quals =~ m:/${type}i?n?e?=([^/]+):ig) { my $term = $1; @@ -826,7 +832,7 @@ pm_to_blib.ts : $(TO_INST_PM) } push(@m,"\t\$(NOECHO) \$(PERL) -e \"print '$line'\" >>.MM_tmp\n") if $line; - push(@m,q[ $(PERL) "-I$(PERL_LIB)" "-MExtUtils::Install" -e "pm_to_blib({split(' ',)},'].$autodir.q[')" <.MM_tmp]); + push(@m,q[ $(PERL) "-I$(PERL_LIB)" "-MExtUtils::Install" -e "pm_to_blib({split(' ',)},'].$autodir.q[','$(PM_FILTER)')" <.MM_tmp]); push(@m,qq[ \$(NOECHO) Delete/NoLog/NoConfirm .MM_tmp; \$(NOECHO) \$(TOUCH) pm_to_blib.ts @@ -1414,7 +1420,7 @@ sub processPL { my $list = ref($self->{PL_FILES}->{$plfile}) ? $self->{PL_FILES}->{$plfile} : [$self->{PL_FILES}->{$plfile}]; - foreach $target (@$list) { + foreach my $target (@$list) { my $vmsplfile = vmsify($plfile); my $vmsfile = vmsify($target); push @m, " @@ -2046,6 +2052,8 @@ Consequently, it hasn't really been tested, and may well be incomplete. =cut +our %olbs; + sub makeaperl { my($self, %attribs) = @_; my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) = @@ -2088,7 +2096,7 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) $linkcmd =~ s/\s+/ /g; # Which *.olb files could we make use of... - local(%olbs); + local(%olbs); # XXX can this be lexical? $olbs{$self->{INST_ARCHAUTODIR}} = "$self->{BASEEXT}\$(LIB_EXT)"; require File::Find; File::Find::find(sub { @@ -2185,6 +2193,7 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) push @optlibs, @$extra; $target = "Perl$Config{'exe_ext'}" unless $target; + my $shrtarget; ($shrtarget,$targdir) = fileparse($target); $shrtarget =~ s/^([^.]*)/$1Shr/; $shrtarget = $targdir . $shrtarget; diff --git a/lib/ExtUtils/MM_Win32.pm b/lib/ExtUtils/MM_Win32.pm index 7f40ff7..80e247d 100644 --- a/lib/ExtUtils/MM_Win32.pm +++ b/lib/ExtUtils/MM_Win32.pm @@ -1,5 +1,7 @@ package ExtUtils::MM_Win32; +our $VERSION = '1.00'; + =head1 NAME ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker @@ -23,8 +25,8 @@ use Config; use File::Basename; require Exporter; -Exporter::import('ExtUtils::MakeMaker', - qw( $Verbose &neatvalue)); +require ExtUtils::MakeMaker; +ExtUtils::MakeMaker->import(qw( $Verbose &neatvalue)); $ENV{EMXSHELL} = 'sh'; # to run `commands` unshift @MM::ISA, 'ExtUtils::MM_Win32'; @@ -596,7 +598,7 @@ pm_to_blib: $(TO_INST_PM) ($NMAKE ? 'qw[ < in all +C<$Config{install*}> values. Note, that in both cases the tilde expansion is done by MakeMaker, not -by perl by default, nor by make. Conflicts between parameters LIB, -PREFIX and the various INSTALL* arguments are resolved so that -XXX +by perl by default, nor by make. + +Conflicts between parameters LIB, +PREFIX and the various INSTALL* arguments are resolved so that: + +=over 4 + +=item * + +setting LIB overrides any setting of INSTALLPRIVLIB, INSTALLARCHLIB, +INSTALLSITELIB, INSTALLSITEARCH (and they are not affected by PREFIX); + +=item * + +without LIB, setting PREFIX replaces the initial C<$Config{prefix}> +part of those INSTALL* arguments, even if the latter are explicitly +set (but are set to still start with C<$Config{prefix}>). + +=back If the user has superuser privileges, and is not working on AFS -(Andrew File System) or relatives, then the defaults for +or relatives, then the defaults for INSTALLPRIVLIB, INSTALLARCHLIB, INSTALLSCRIPT, etc. will be appropriate, and this incantation will be the best: @@ -1145,11 +1161,6 @@ or as NAME=VALUE pairs on the command line: =over 2 -=item AUTHOR - -String containing name (and email address) of package author(s). Is used -in PPD (Perl Package Description) files for PPM (Perl Package Manager). - =item ABSTRACT One line description of the module. Will be included in PPD file. @@ -1160,6 +1171,11 @@ Name of the file that contains the package description. MakeMaker looks for a line in the POD matching /^($package\s-\s)(.*)/. This is typically the first line in the "=head1 NAME" section. $2 becomes the abstract. +=item AUTHOR + +String containing name (and email address) of package author(s). Is used +in PPD (Perl Package Description) files for PPM (Perl Package Manager). + =item BINARY_LOCATION Used when creating PPD files for binary packages. It can be set to a @@ -1409,11 +1425,6 @@ to INSTALLBIN during 'make install' Old name for INST_SCRIPT. Deprecated. Please use INST_SCRIPT if you need to use it. -=item INST_LIB - -Directory where we put library files of this extension while building -it. - =item INST_HTMLLIBDIR Directory to hold the man pages in HTML format at 'make' time @@ -1422,6 +1433,11 @@ Directory to hold the man pages in HTML format at 'make' time Directory to hold the man pages in HTML format at 'make' time +=item INST_LIB + +Directory where we put library files of this extension while building +it. + =item INST_MAN1DIR Directory to hold the man pages at 'make' time @@ -1437,34 +1453,6 @@ Directory, where executable files should be installed during testing. make install will copy the files in INST_SCRIPT to INSTALLSCRIPT. -=item PERL_MALLOC_OK - -defaults to 0. Should be set to TRUE if the extension can work with -the memory allocation routines substituted by the Perl malloc() subsystem. -This should be applicable to most extensions with exceptions of those - -=over - -=item * - -with bugs in memory allocations which are caught by Perl's malloc(); - -=item * - -which interact with the memory allocator in other ways than via -malloc(), realloc(), free(), calloc(), sbrk() and brk(); - -=item * - -which rely on special alignment which is not provided by Perl's malloc(). - -=back - -B Negligence to set this flag in I of loaded extension -nullifies many advantages of Perl's malloc(), such as better usage of -system resources, error detection, memory usage reporting, catchable failure -of memory allocations, etc. - =item LDFROM defaults to "$(OBJECT)" and is used in the ld command to specify @@ -1473,8 +1461,12 @@ specify ld flags) =item LIB -LIB can only be set at C time. It has the effect of +LIB should only be set at C time but is allowed as a +MakeMaker argument. It has the effect of setting both INSTALLPRIVLIB and INSTALLSITELIB to that value regardless any +explicit setting of those arguments (or of PREFIX). +INSTALLARCHLIB and INSTALLSITEARCH are set to the corresponding +architecture subdirectory. =item LIBPERL_A @@ -1527,10 +1519,11 @@ at Configure time. =item MAN3PODS -Hashref of .pm and .pod files. MakeMaker will default this to all - .pod and any .pm files that include POD directives. The files listed -here will be converted to man pages and installed as was requested -at Configure time. +Hashref that assigns to *.pm and *.pod files the files into which the +manpages are to be written. MakeMaker parses all *.pod and *.pm files +for POD directives. Files that contain POD will be the default keys of +the MAN3PODS hashref. These will then be converted to man pages during +C and will be installed during C. =item MAP_TARGET @@ -1578,6 +1571,8 @@ List of object files, defaults to '$(BASEEXT)$(OBJ_EXT)', but can be a long string containing all object files, e.g. "tkpBind.o tkpButton.o tkpCanvas.o" +(Where BASEEXT is the last component of NAME, and OBJ_EXT is $Config{obj_ext}.) + =item OPTIMIZE Defaults to C<-O>. Set it to C<-g> to turn debugging on. The flag is @@ -1594,12 +1589,40 @@ to $(CC). =item PERL_ARCHLIB -Same as above for architecture dependent files. +Same as below, but for architecture dependent files. =item PERL_LIB Directory containing the Perl library to use. +=item PERL_MALLOC_OK + +defaults to 0. Should be set to TRUE if the extension can work with +the memory allocation routines substituted by the Perl malloc() subsystem. +This should be applicable to most extensions with exceptions of those + +=over 4 + +=item * + +with bugs in memory allocations which are caught by Perl's malloc(); + +=item * + +which interact with the memory allocator in other ways than via +malloc(), realloc(), free(), calloc(), sbrk() and brk(); + +=item * + +which rely on special alignment which is not provided by Perl's malloc(). + +=back + +B Negligence to set this flag in I of loaded extension +nullifies many advantages of Perl's malloc(), such as better usage of +system resources, error detection, memory usage reporting, catchable failure +of memory allocations, etc. + =item PERL_SRC Directory containing the Perl source code (use of this should be @@ -1648,6 +1671,31 @@ they contain will be installed in the corresponding location in the library. A libscan() method can be used to alter the behaviour. Defining PM in the Makefile.PL will override PMLIBDIRS. +(Where BASEEXT is the last component of NAME.) + +=item PM_FILTER + +A filter program, in the traditional Unix sense (input from stdin, output +to stdout) that is passed on each .pm file during the build (in the +pm_to_blib() phase). It is empty by default, meaning no filtering is done. + +Great care is necessary when defining the command if quoting needs to be +done. For instance, you would need to say: + + {'PM_FILTER' => 'grep -v \\"^\\#\\"'} + +to remove all the leading coments on the fly during the build. The +extra \\ are necessary, unfortunately, because this variable is interpolated +within the context of a Perl program built on the command line, and double +quotes are what is used with the -e switch to build that command line. The +# is escaped for the Makefile, since what is going to be generated will then +be: + + PM_FILTER = grep -v \"^\#\" + +Without the \\ before the #, we'd have the start of a Makefile comment, +and the macro would be incorrectly defined. + =item POLLUTE Release 5.005 grandfathered old global symbol names by providing preprocessor @@ -1725,6 +1773,7 @@ MakeMaker object. The following lines will be parsed o.k.: ( $VERSION ) = '$Revision: 1.222 $ ' =~ /\$Revision:\s+([^\s]+)/; $FOO::VERSION = '1.10'; *FOO::VERSION = \'1.11'; + our $VERSION = 1.2.3; # new for perl5.6.0 but these will fail: @@ -1732,6 +1781,8 @@ but these will fail: local $VERSION = '1.02'; local $FOO::VERSION = '1.30'; +(Putting C or C on the preceding line will work o.k.) + The file named in VERSION_FROM is not added as a dependency to Makefile. This is not really correct, but it would be a major pain during development to have to rewrite the Makefile for any smallish @@ -1786,6 +1837,8 @@ part of the Makefile. {ANY_TARGET => ANY_DEPENDECY, ...} +(ANY_TARGET must not be given a double-colon rule by MakeMaker.) + =item dist {TARFLAGS => 'cvfF', COMPRESS => 'gzip', SUFFIX => '.gz', @@ -2030,10 +2083,10 @@ ExtUtils::Install, ExtUtils::Embed =head1 AUTHORS Andy Dougherty >, Andreas KEnig ->, Tim Bunce >. -VMS support by Charles Bailey >. OS/2 -support by Ilya Zakharevich >. Contact the -makemaker mailing list C, if -you have any questions. +>, Tim Bunce >. VMS +support by Charles Bailey >. OS/2 support +by Ilya Zakharevich >. + +Send patches and bug reports to >. =cut diff --git a/lib/ExtUtils/Manifest.pm b/lib/ExtUtils/Manifest.pm index 28b7053..030eedf 100644 --- a/lib/ExtUtils/Manifest.pm +++ b/lib/ExtUtils/Manifest.pm @@ -4,11 +4,12 @@ require Exporter; use Config; use File::Find; use File::Copy 'copy'; +use File::Spec::Functions qw(splitpath); use Carp; use strict; -use vars qw($VERSION @ISA @EXPORT_OK - $Is_VMS $Debug $Verbose $Quiet $MANIFEST $found); +our ($VERSION,@ISA,@EXPORT_OK, + $Is_VMS,$Debug,$Verbose,$Quiet,$MANIFEST,$found,$DEFAULT_MSKIP); $VERSION = substr(q$Revision: 1.33 $, 10); @ISA=('Exporter'); @@ -18,10 +19,11 @@ $VERSION = substr(q$Revision: 1.33 $, 10); $Is_VMS = $^O eq 'VMS'; if ($Is_VMS) { require File::Basename } -$Debug = 0; +$Debug = $ENV{PERL_MM_MANIFEST_DEBUG} || 0; $Verbose = 1; $Quiet = 0; $MANIFEST = 'MANIFEST'; +$DEFAULT_MSKIP = (splitpath($INC{"ExtUtils/Manifest.pm"}))[1]."$MANIFEST.SKIP"; # Really cool fix from Ilya :) unless (defined $Config{d_link}) { @@ -160,8 +162,7 @@ sub _maniskip { my @skip ; $mfile ||= "$MANIFEST.SKIP"; local *M; - return $matches unless -f $mfile; - open M, $mfile or return $matches; + open M, $mfile or open M, $DEFAULT_MSKIP or return $matches; while (){ chomp; next if /^#/; @@ -187,13 +188,13 @@ sub manicopy { require File::Basename; my(%dirs,$file); $target = VMS::Filespec::unixify($target) if $Is_VMS; - File::Path::mkpath([ $target ],1,$Is_VMS ? undef : 0755); + File::Path::mkpath([ $target ],! $Quiet,$Is_VMS ? undef : 0755); foreach $file (keys %$read){ $file = VMS::Filespec::unixify($file) if $Is_VMS; if ($file =~ m!/!) { # Ilya, that hurts, I fear, or maybe not? my $dir = File::Basename::dirname($file); $dir = VMS::Filespec::unixify($dir) if $Is_VMS; - File::Path::mkpath(["$target/$dir"],1,$Is_VMS ? undef : 0755); + File::Path::mkpath(["$target/$dir"],! $Quiet,$Is_VMS ? undef : 0755); } cp_if_diff($file, "$target/$file", $how); } @@ -344,15 +345,27 @@ expressions should appear one on each line. Blank lines and lines which start with C<#> are skipped. Use C<\#> if you need a regular expression to start with a sharp character. A typical example: + # Version control files and dirs. \bRCS\b + \bCVS\b + ,v$ + + # Makemaker generated files and dirs. ^MANIFEST\. ^Makefile$ - ~$ - \.html$ - \.old$ ^blib/ ^MakeMaker-\d + # Temp, old and emacs backup files. + ~$ + \.old$ + ^#.*#$ + +If no MANIFEST.SKIP file is found, a default set of skips will be +used, similar to the example above. If you want nothing skipped, +simply make an empty MANIFEST.SKIP file. + + =head1 EXPORT_OK C<&mkmanifest>, C<&manicheck>, C<&filecheck>, C<&fullcheck>, @@ -369,6 +382,10 @@ and a developer version including RCS). C<$ExtUtils::Manifest::Quiet> defaults to 0. If set to a true value, all functions act silently. +C<$ExtUtils::Manifest::Debug> defaults to 0. If set to a true value, +or if PERL_MM_MANIFEST_DEBUG is true, debugging output will be +produced. + =head1 DIAGNOSTICS All diagnostic output is sent to C. @@ -397,12 +414,22 @@ to MANIFEST. $Verbose is set to 1 by default. =back +=head1 ENVIRONMENT + +=over 4 + +=item B + +Turns on debugging + +=back + =head1 SEE ALSO L which has handy targets for most of the functionality. =head1 AUTHOR -Andreas Koenig > +Andreas Koenig > =cut diff --git a/lib/ExtUtils/Mksymlists.pm b/lib/ExtUtils/Mksymlists.pm index c8f41c7..c06b393 100644 --- a/lib/ExtUtils/Mksymlists.pm +++ b/lib/ExtUtils/Mksymlists.pm @@ -49,6 +49,7 @@ sub Mksymlists { } if ($osname eq 'aix') { _write_aix(\%spec); } + elsif ($osname eq 'MacOS'){ _write_aix(\%spec) } elsif ($osname eq 'VMS') { _write_vms(\%spec) } elsif ($osname eq 'os2') { _write_os2(\%spec) } elsif ($osname eq 'MSWin32') { _write_win32(\%spec) } diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap index 9961f2d..c59c3dc 100644 --- a/lib/ExtUtils/typemap +++ b/lib/ExtUtils/typemap @@ -40,7 +40,8 @@ Boolean T_IV double T_DOUBLE SysRet T_SYSRET SysRetLong T_SYSRET -FILE * T_IN +FILE * T_STDIO +PerlIO * T_INOUT FileHandle T_PTROBJ InputStream T_IN InOutStream T_INOUT @@ -55,22 +56,22 @@ T_SVREF if (sv_isa($arg, \"${ntype}\")) $var = (SV*)SvRV($arg); else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") T_AVREF if (sv_isa($arg, \"${ntype}\")) $var = (AV*)SvRV($arg); else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") T_HVREF if (sv_isa($arg, \"${ntype}\")) $var = (HV*)SvRV($arg); else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") T_CVREF if (sv_isa($arg, \"${ntype}\")) $var = (CV*)SvRV($arg); else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") T_SYSRET $var NOT IMPLEMENTED T_UV @@ -113,50 +114,50 @@ T_PTRREF $var = INT2PTR($type,tmp); } else - croak(\"$var is not a reference\") + Perl_croak(aTHX_ \"$var is not a reference\") T_REF_IV_REF if (sv_isa($arg, \"${type}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *($type *) tmp; } else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") T_REF_IV_PTR if (sv_isa($arg, \"${type}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = ($type) tmp; } else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") T_PTROBJ if (sv_derived_from($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type,tmp); } else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") T_PTRDESC if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); - ${type}_desc = (\U${type}_DESC\E*) tmp; + ${type}_desc = (\U${type}_DESC\E*) tmp; $var = ${type}_desc->ptr; } else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") T_REFREF if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *INT2PTR($type,tmp); } else - croak(\"$var is not a reference\") + Perl_croak(aTHX_ \"$var is not a reference\") T_REFOBJ if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *INT2PTR($type,tmp); } else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") T_OPAQUE $var NOT IMPLEMENTED T_OPAQUEPTR @@ -173,6 +174,8 @@ T_ARRAY while (items--) { DO_ARRAY_ELEM; } +T_STDIO + $var = PerlIO_findFILE(IoIFP(sv_2io($arg))) T_IN $var = IoIFP(sv_2io($arg)) T_INOUT @@ -267,6 +270,15 @@ T_ARRAY DO_ARRAY_ELEM } SP += $var.size - 1; +T_STDIO + { + GV *gv = newGVgen("$Package"); + PerlIO *fp = PerlIO_importFILE($var,0); + if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } T_IN { GV *gv = newGVgen("$Package"); diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 1e9ff45..2093633 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -109,7 +109,7 @@ sub Q ; # Global Constants -$XSUBPP_version = "1.9507"; +$XSUBPP_version = "1.9508"; my ($Is_VMS, $SymSet); if ($^O eq 'VMS') { @@ -418,7 +418,7 @@ sub INPUT_handler { $var_init =~ s/"/\\"/g; s/\s+/ /g; - my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s + my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s or blurt("Error: invalid argument declaration '$line'"), next; # Check for duplicate definitions @@ -444,12 +444,9 @@ sub INPUT_handler { $proto_arg[$var_num] = ProtoString($var_type) if $var_num ; - if ($var_addr) { - $var_addr{$var_name} = 1; - $func_args =~ s/\b($var_name)\b/&$1/; - } + $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr; if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/ - or $in_out{$var_name} and $in_out{$var_name} eq 'OUTLIST' + or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/ and $var_init !~ /\S/) { if ($name_printed) { print ";\n"; @@ -494,6 +491,8 @@ sub OUTPUT_handler { } else { &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic); } + delete $in_out{$outarg} # No need to auto-OUTPUT + if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/; } } @@ -859,10 +858,21 @@ print("#line 1 \"$filename\"\n") firstmodule: while (<$FH>) { if (/^=/) { + my $podstartline = $.; do { - next firstmodule if /^=cut\s*$/; + if (/^=cut\s*$/) { + print("/* Skipped embedded POD. */\n"); + printf("#line %d \"$filename\"\n", $. + 1) + if $WantLineNumbers; + next firstmodule + } + } while (<$FH>); - &Exit; + # At this point $. is at end of file so die won't state the start + # of the problem, and as we haven't yet read any lines &death won't + # show the correct line in the message either. + die ("Error: Unterminated pod in $filename, line $podstartline\n") + unless $lastline; } last if ($Module, $Package, $Prefix) = /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; @@ -992,7 +1002,6 @@ while (fetch_para()) { # initialize info arrays undef(%args_match); undef(%var_types); - undef(%var_addr); undef(%defaults); undef($class); undef($static); @@ -1004,7 +1013,7 @@ while (fetch_para()) { undef(@arg_with_types) ; undef($processing_arg_with_types) ; undef(%arg_types) ; - undef(@in_out) ; + undef(@outlist) ; undef(%in_out) ; undef($proto_in_this_xsub) ; undef($scope_in_this_xsub) ; @@ -1070,7 +1079,7 @@ while (fetch_para()) { $orig_args =~ s/\\\s*/ /g; # process line continuations - my %out_vars; + my %only_outlist; if ($process_argtypes and $orig_args =~ /\S/) { my $args = "$orig_args ,"; if ($args =~ /^( (??{ $C_arg }) , )* $ /x) { @@ -1085,10 +1094,10 @@ while (fetch_para()) { next unless length $pre; my $out_type; my $inout_var; - if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST)\s+//) { + if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) { my $type = $1; $out_type = $type if $type ne 'IN'; - $arg =~ s/^(IN|IN_OUTLIST|OUTLIST)\s+//; + $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//; } if (/\W/) { # Has a type push @arg_with_types, $arg; @@ -1096,8 +1105,8 @@ while (fetch_para()) { $arg_types{$name} = $arg; $_ = "$name$default"; } - $out_vars{$_} = 1 if $out_type eq 'OUTLIST'; - push @in_out, $name if $out_type; + $only_outlist{$_} = 1 if $out_type eq "OUTLIST"; + push @outlist, $name if $out_type =~ /OUTLIST$/; $in_out{$name} = $out_type if $out_type; } } else { @@ -1107,11 +1116,11 @@ while (fetch_para()) { } else { @args = split(/\s*,\s*/, $orig_args); for (@args) { - if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST)\s+//) { + if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) { my $out_type = $1; next if $out_type eq 'IN'; - $out_vars{$_} = 1 if $out_type eq 'OUTLIST'; - push @in_out, $name; + $only_outlist{$_} = 1 if $out_type eq "OUTLIST"; + push @outlist, $name if $out_type =~ /OUTLIST$/; $in_out{$_} = $out_type; } } @@ -1135,7 +1144,7 @@ while (fetch_para()) { last; } } - if ($out_vars{$args[$i]}) { + if ($only_outlist{$args[$i]}) { push @args_num, undef; } else { push @args_num, ++$num_args; @@ -1174,6 +1183,7 @@ while (fetch_para()) { # print function header print Q<<"EOF"; +#XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */ #XS(XS_${Full_func_name}) #[[ # dXSARGS; @@ -1324,6 +1334,9 @@ EOF undef %outargs ; process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE"); + &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic) + for grep $in_out{$_} =~ /OUT$/, keys %in_out; + # all OUTPUT done, so now push the return value on the stack if ($gotRETVAL && $RETVAL_code) { print "\t$RETVAL_code\n"; @@ -1360,11 +1373,11 @@ EOF $xsreturn = 1 if $ret_type ne "void"; my $num = $xsreturn; - my $c = @in_out; + my $c = @outlist; print "\tXSprePUSH;" if $c and not $prepush_done; print "\tEXTEND(SP,$c);\n" if $c; $xsreturn += $c; - generate_output($var_types{$_}, $num++, $_, 0, 1) for @in_out; + generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist; # do cleanup process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE") ; @@ -1490,6 +1503,7 @@ print Q<<"EOF"; EOF print Q<<"EOF"; +#XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */ #XS(boot_$Module_cname) EOF diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm index 2432344..75996f2 100644 --- a/lib/File/Basename.pm +++ b/lib/File/Basename.pm @@ -176,7 +176,7 @@ sub fileparse { $dirpath ||= ''; # should always be defined } } - if ($fstype =~ /^MS(DOS|Win32)/i) { + if ($fstype =~ /^MS(DOS|Win32)|epoc/i) { ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s); $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/; } diff --git a/lib/File/CheckTree.pm b/lib/File/CheckTree.pm index ae18777..8b6ae08 100644 --- a/lib/File/CheckTree.pm +++ b/lib/File/CheckTree.pm @@ -1,4 +1,7 @@ package File::CheckTree; + +our $VERSION = '4.1'; + require 5.000; require Exporter; @@ -41,39 +44,8 @@ The routine returns the number of warnings issued. =cut -@ISA = qw(Exporter); -@EXPORT = qw(validate); - -# $RCSfile: validate.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:19 $ - -# The validate routine takes a single multiline string consisting of -# lines containing a filename plus a file test to try on it. (The -# file test may also be a 'cd', causing subsequent relative filenames -# to be interpreted relative to that directory.) After the file test -# you may put '|| die' to make it a fatal error if the file test fails. -# The default is '|| warn'. The file test may optionally have a ! prepended -# to test for the opposite condition. If you do a cd and then list some -# relative filenames, you may want to indent them slightly for readability. -# If you supply your own "die" or "warn" message, you can use $file to -# interpolate the filename. - -# Filetests may be bunched: -rwx tests for all of -r, -w and -x. -# Only the first failed test of the bunch will produce a warning. - -# The routine returns the number of warnings issued. - -# Usage: -# use File::CheckTree; -# $warnings += validate(' -# /vmunix -e || die -# /boot -e || die -# /bin cd -# csh -ex -# csh !-ug -# sh -ex -# sh !-ug -# /usr -d || warn "What happened to $file?\n" -# '); +our @ISA = qw(Exporter); +our @EXPORT = qw(validate); sub validate { local($file,$test,$warnings,$oldwarnings); @@ -94,7 +66,8 @@ sub validate { $this =~ s/(-\w\b)/$1 \$file/g; $this =~ s/-Z/-$one/; $this .= ' || warn' unless $this =~ /\|\|/; - $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || valmess('$2','$1')/; + $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || + valmess('$2','$1')/; $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g; eval $this; last if $warnings > $oldwarnings; @@ -103,47 +76,54 @@ sub validate { $warnings; } +our %Val_Switch = ( + 'r' => sub { "$_[0] is not readable by uid $>." }, + 'w' => sub { "$_[0] is not writable by uid $>." }, + 'x' => sub { "$_[0] is not executable by uid $>." }, + 'o' => sub { "$_[0] is not owned by uid $>." }, + 'R' => sub { "$_[0] is not readable by you." }, + 'W' => sub { "$_[0] is not writable by you." }, + 'X' => sub { "$_[0] is not executable by you." }, + 'O' => sub { "$_[0] is not owned by you." }, + 'e' => sub { "$_[0] does not exist." }, + 'z' => sub { "$_[0] does not have zero size." }, + 's' => sub { "$_[0] does not have non-zero size." }, + 'f' => sub { "$_[0] is not a plain file." }, + 'd' => sub { "$_[0] is not a directory." }, + 'l' => sub { "$_[0] is not a symbolic link." }, + 'p' => sub { "$_[0] is not a named pipe (FIFO)." }, + 'S' => sub { "$_[0] is not a socket." }, + 'b' => sub { "$_[0] is not a block special file." }, + 'c' => sub { "$_[0] is not a character special file." }, + 'u' => sub { "$_[0] does not have the setuid bit set." }, + 'g' => sub { "$_[0] does not have the setgid bit set." }, + 'k' => sub { "$_[0] does not have the sticky bit set." }, + 'T' => sub { "$_[0] is not a text file." }, + 'B' => sub { "$_[0] is not a binary file." }, +); + sub valmess { - local($disposition,$this) = @_; - $file = $cwd . '/' . $file unless $file =~ m|^/|s; + my($disposition,$this) = @_; + my $file = $cwd . '/' . $file unless $file =~ m|^/|s; + + my $ferror; if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) { - $neg = $1; - $tmp = $2; - $tmp eq 'r' && ($mess = "$file is not readable by uid $>."); - $tmp eq 'w' && ($mess = "$file is not writable by uid $>."); - $tmp eq 'x' && ($mess = "$file is not executable by uid $>."); - $tmp eq 'o' && ($mess = "$file is not owned by uid $>."); - $tmp eq 'R' && ($mess = "$file is not readable by you."); - $tmp eq 'W' && ($mess = "$file is not writable by you."); - $tmp eq 'X' && ($mess = "$file is not executable by you."); - $tmp eq 'O' && ($mess = "$file is not owned by you."); - $tmp eq 'e' && ($mess = "$file does not exist."); - $tmp eq 'z' && ($mess = "$file does not have zero size."); - $tmp eq 's' && ($mess = "$file does not have non-zero size."); - $tmp eq 'f' && ($mess = "$file is not a plain file."); - $tmp eq 'd' && ($mess = "$file is not a directory."); - $tmp eq 'l' && ($mess = "$file is not a symbolic link."); - $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO)."); - $tmp eq 'S' && ($mess = "$file is not a socket."); - $tmp eq 'b' && ($mess = "$file is not a block special file."); - $tmp eq 'c' && ($mess = "$file is not a character special file."); - $tmp eq 'u' && ($mess = "$file does not have the setuid bit set."); - $tmp eq 'g' && ($mess = "$file does not have the setgid bit set."); - $tmp eq 'k' && ($mess = "$file does not have the sticky bit set."); - $tmp eq 'T' && ($mess = "$file is not a text file."); - $tmp eq 'B' && ($mess = "$file is not a binary file."); + my($neg,$ftype) = ($1,$2); + + $ferror = $Val_Switch{$tmp}->($file); + if ($neg eq '!') { - $mess =~ s/ is not / should not be / || - $mess =~ s/ does not / should not / || - $mess =~ s/ not / /; + $ferror =~ s/ is not / should not be / || + $ferror =~ s/ does not / should not / || + $ferror =~ s/ not / /; } } else { $this =~ s/\$file/'$file'/g; - $mess = "Can't do $this.\n"; + $ferror = "Can't do $this.\n"; } - die "$mess\n" if $disposition eq 'die'; - warn "$mess\n"; + die "$ferror\n" if $disposition eq 'die'; + warn "$ferror\n"; ++$warnings; } diff --git a/lib/File/DosGlob.pm b/lib/File/DosGlob.pm index d7dea7b..2b4d39a 100644 --- a/lib/File/DosGlob.pm +++ b/lib/File/DosGlob.pm @@ -1,54 +1,59 @@ #!perl -w +# use strict fails +#Can't use string ("main::glob") as a symbol ref while "strict refs" in use at /usr/lib/perl5/5.005/File/DosGlob.pm line 191. + # # Documentation at the __END__ # package File::DosGlob; +our $VERSION = '1.00'; +use strict; + sub doglob { my $cond = shift; my @retval = (); #print "doglob: ", join('|', @_), "\n"; OUTER: - for my $arg (@_) { - local $_ = $arg; + for my $pat (@_) { my @matched = (); my @globdirs = (); my $head = '.'; my $sepchr = '/'; - next OUTER unless defined $_ and $_ ne ''; + my $tail; + next OUTER unless defined $pat and $pat ne ''; # if arg is within quotes strip em and do no globbing - if (/^"(.*)"\z/s) { - $_ = $1; - if ($cond eq 'd') { push(@retval, $_) if -d $_ } - else { push(@retval, $_) if -e $_ } + if ($pat =~ /^"(.*)"\z/s) { + $pat = $1; + if ($cond eq 'd') { push(@retval, $pat) if -d $pat } + else { push(@retval, $pat) if -e $pat } next OUTER; } # wildcards with a drive prefix such as h:*.pm must be changed # to h:./*.pm to expand correctly - if (m|^([A-Za-z]:)[^/\\]|s) { + if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) { substr($_,0,2) = $1 . "./"; } - if (m|^(.*)([\\/])([^\\/]*)\z|s) { - my $tail; + if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) { ($head, $sepchr, $tail) = ($1,$2,$3); #print "div: |$head|$sepchr|$tail|\n"; - push (@retval, $_), next OUTER if $tail eq ''; + push (@retval, $pat), next OUTER if $tail eq ''; if ($head =~ /[*?]/) { @globdirs = doglob('d', $head); push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)), next OUTER if @globdirs; } $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s; - $_ = $tail; + $pat = $tail; } # # If file component has no wildcards, we can avoid opendir - unless (/[*?]/) { + unless ($pat =~ /[*?]/) { $head = '' if $head eq '.'; $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; - $head .= $_; + $head .= $pat; if ($cond eq 'd') { push(@retval,$head) if -d $head } else { push(@retval,$head) if -e $head } next OUTER; @@ -60,14 +65,13 @@ sub doglob { $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; # escape regex metachars but not glob chars - s:([].+^\-\${}[|]):\\$1:g; + $pat =~ s:([].+^\-\${}[|]):\\$1:g; # and convert DOS-style wildcards to regex - s/\*/.*/g; - s/\?/.?/g; + $pat =~ s/\*/.*/g; + $pat =~ s/\?/.?/g; - #print "regex: '$_', head: '$head'\n"; - my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }'; - warn($@), next OUTER if $@; + #print "regex: '$pat', head: '$head'\n"; + my $matchsub = sub { $_[0] =~ m|^$pat\z|is }; INNER: for my $e (@leaves) { next INNER if $e eq '.' or $e eq '..'; @@ -80,7 +84,7 @@ sub doglob { # has a dot *and* name is shorter than 9 chars. # if (index($e,'.') == -1 and length($e) < 9 - and index($_,'\\.') != -1) { + and index($pat,'\\.') != -1) { push(@matched, "$head$e"), next INNER if &$matchsub("$e."); } } @@ -100,8 +104,7 @@ my %iter; my %entries; sub glob { - my $pat = shift; - my $cxix = shift; + my($pat,$cxix) = @_; my @pat; # glob without args defaults to $_ @@ -116,6 +119,52 @@ sub glob { push @pat, $pat; } + # Mike Mestnik: made to do abc{1,2,3} == abc1 abc2 abc3. + # abc3 will be the original {3} (and drop the {}). + # abc1 abc2 will be put in @appendpat. + # This was just the esiest way, not nearly the best. + REHASH: { + my @appendpat = (); + for (@pat) { + # There must be a "," I.E. abc{efg} is not what we want. + while ( /^(.*)(? 'Mac', MSWin32 => 'Win32', os2 => 'OS2', - VMS => 'VMS'); + VMS => 'VMS', + epoc => 'Epoc'); my $module = $module{$^O} || 'Unix'; require "File/Spec/$module.pm"; diff --git a/lib/File/Spec/Epoc.pm b/lib/File/Spec/Epoc.pm new file mode 100644 index 0000000..65d5e1f --- /dev/null +++ b/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/lib/File/Spec/Functions.pm b/lib/File/Spec/Functions.pm index 0036ac1..be65333 100644 --- a/lib/File/Spec/Functions.pm +++ b/lib/File/Spec/Functions.pm @@ -3,7 +3,7 @@ package File::Spec::Functions; use File::Spec; use strict; -use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); +our (@ISA,@EXPORT,@EXPORT_OK,%EXPORT_TAGS,$VERSION); $VERSION = '1.1'; diff --git a/lib/File/Spec/Unix.pm b/lib/File/Spec/Unix.pm index a81c533..4e4cc75 100644 --- a/lib/File/Spec/Unix.pm +++ b/lib/File/Spec/Unix.pm @@ -1,7 +1,7 @@ package File::Spec::Unix; use strict; -use vars qw($VERSION); +our($VERSION); $VERSION = '1.2'; diff --git a/lib/File/Temp.pm b/lib/File/Temp.pm index a351044..2d1a4b2 100644 --- a/lib/File/Temp.pm +++ b/lib/File/Temp.pm @@ -124,7 +124,7 @@ use Carp; use File::Spec 0.8; use File::Path qw/ rmtree /; use Fcntl 1.03; -use Errno qw( EEXIST ENOENT ENOTDIR EINVAL ); +use Errno; require VMS::Stdio if $^O eq 'VMS'; # Need the Symbol package if we are running older perl @@ -166,7 +166,7 @@ Exporter::export_tags('POSIX','mktemp'); # Version number -$VERSION = '0.10'; +$VERSION = '0.11'; # This is a list of characters that can be used in random filenames @@ -443,7 +443,7 @@ sub _gettemp { # Error opening file - abort with error # if the reason was anything but EEXIST - unless ($! == EEXIST) { + unless ($!{EEXIST}) { carp "File::Temp: Could not create temp file $path: $!"; return (); } @@ -473,7 +473,7 @@ sub _gettemp { # Abort with error if the reason for failure was anything # except EEXIST - unless ($! == EEXIST) { + unless ($!{EEXIST}) { carp "File::Temp: Could not create directory $path: $!"; return (); } @@ -881,7 +881,8 @@ is specified. 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. +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() @@ -896,8 +897,11 @@ 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 (for example, Windows NT) the file is marked for -deletion when the program ends (equivalent to setting UNLINK to 1). +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); @@ -978,19 +982,33 @@ sub tempfile { # 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); croak "Error in tempfile() using $template" unless (($fh, $path) = _gettemp($template, "open" => $options{'OPEN'}, "mkdir"=> 0 , - "unlink_on_close" => $options{'UNLINK'}, + "unlink_on_close" => $unlink_on_close, "suffixlen" => length($options{'SUFFIX'}), ) ); # Set up an exit handler that can do whatever is right for the - # system. Do not check return status since this is all done with - # END blocks + # 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 @@ -1731,6 +1749,15 @@ descriptor before passing it to another process. 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 @@ -1743,8 +1770,8 @@ operating system and to help with portability. L, L, L, L -See L for a different implementation of temporary -file handling. +See L and L for different implementations of +temporary file handling. =head1 AUTHOR diff --git a/lib/File/stat.pm b/lib/File/stat.pm index 0cf7a0b..200af4e 100644 --- a/lib/File/stat.pm +++ b/lib/File/stat.pm @@ -4,6 +4,8 @@ use strict; use 5.005_64; our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); +our $VERSION = '1.00'; + BEGIN { use Exporter (); @EXPORT = qw(stat lstat); diff --git a/lib/FileCache.pm b/lib/FileCache.pm index e1c5ec4..78a3e67 100644 --- a/lib/FileCache.pm +++ b/lib/FileCache.pm @@ -1,5 +1,7 @@ package FileCache; +our $VERSION = '1.00'; + =head1 NAME FileCache - keep more files open than the system permits diff --git a/lib/Filter/Simple.pm b/lib/Filter/Simple.pm new file mode 100644 index 0000000..fa883e6 --- /dev/null +++ b/lib/Filter/Simple.pm @@ -0,0 +1,248 @@ +package Filter::Simple; + +use vars qw{ $VERSION }; + +$VERSION = '0.01'; + +use Filter::Util::Call; +use Carp; + +sub import { + my $caller = caller; + my ($class, $filter) = @_; + croak "Usage: use Filter::Simple sub {...}" unless ref $filter eq CODE; + *{"${caller}::import"} = gen_filter_import($caller, $filter); + *{"${caller}::unimport"} = \*filter_unimport; +} + +sub gen_filter_import { + my ($class, $filter) = @_; + return sub { + my ($imported_class, @args) = @_; + filter_add( + sub { + my ($status, $off); + my $data = ""; + while ($status = filter_read()) { + if (m/^\s*no\s+$class\s*;\s*$/) { + $off=1; + last; + } + $data .= $_; + $_ = ""; + } + $_ = $data; + $filter->(@args) unless $status < 0; + $_ .= "no $class;\n" if $off; + return length; + } + ); + } +} + +sub filter_unimport { + filter_del(); +} + +1; + +__END__ + +=head1 NAME + +Filter::Simple - Simplified source filtering + + +=head1 SYNOPSIS + + # in MyFilter.pm: + + package MyFilter; + + use Filter::Simple sub { ... }; + + + # in user's code: + + use MyFilter; + + # this code is filtered + + no MyFilter; + + # this code is not + + +=head1 DESCRIPTION + +=head2 The Problem + +Source filtering is an immensely powerful feature of recent versions of Perl. +It allows one to extend the language itself (e.g. the Switch module), to +simplify the language (e.g. Language::Pythonesque), or to completely recast the +language (e.g. Lingua::Romana::Perligata). Effectively, it allows one to use +the full power of Perl as its own, recursively applied, macro language. + +The excellent Filter::Util::Call module (by Paul Marquess) provides a +usable Perl interface to source filtering, but it is often too powerful +and not nearly as simple as it could be. + +To use the module it is necessary to do the following: + +=over 4 + +=item 1. + +Download, build, and install the Filter::Util::Call module. + +=item 2. + +Set up a module that does a C. + +=item 3. + +Within that module, create an C subroutine. + +=item 4. + +Within the C subroutine do a call to C, passing +it either a subroutine reference. + +=item 5. + +Within the subroutine reference, call C or C +to "prime" $_ with source code data from the source file that will +C your module. Check the status value returned to see if any +source code was actually read in. + +=item 6. + +Process the contents of $_ to change the source code in the desired manner. + +=item 7. + +Return the status value. + +=item 8. + +If the act of unimporting your module (via a C) should cause source +code filtering to cease, create an C subroutine, and have it call +C. Make sure that the call to C or +C in step 5 will not accidentally read past the +C. Effectively this limits source code filters to line-by-line +operation, unless the C subroutine does some fancy +pre-pre-parsing of the source code it's filtering. + +=back + +For example, here is a minimal source code filter in a module named +BANG.pm. It simply converts every occurrence of the sequence C +to the sequence C in any piece of code following a +C statement (until the next C statement, if any): + + package BANG; + + use Filter::Util::Call ; + + sub import { + filter_add( sub { + my $caller = caller; + my ($status, $no_seen, $data); + while ($status = filter_read()) { + if (/^\s*no\s+$caller\s*;\s*$/) { + $no_seen=1; + last; + } + $data .= $_; + $_ = ""; + } + $_ = $data; + s/BANG\s+BANG/die 'BANG' if \$BANG/g + unless $status < 0; + $_ .= "no $class;\n" if $no_seen; + return 1; + }) + } + + sub unimport { + filter_del(); + } + + 1 ; + +Given this level of complexity, it's perhaps not surprising that source +code filtering is still a mystery to most users. + + +=head2 A Solution + +The Filter::Simple module provides a vastly simplified interface to +Filter::Util::Call; one that is sufficient for most common cases. + +Instead of the above process, with Filter::Simple the task of setting up +a source code filter is reduced to: + +=over 4 + +=item 1. + +Set up a module that does a C. + +=item 2. + +Within the anonymous subroutine passed to C, process the +contents of $_ to change the source code in the desired manner. + +=back + +In other words, the previous example, would become: + + package BANG; + + use Filter::Simple sub { + s/BANG\s+BANG/die 'BANG' if \$BANG/g; + }; + + 1 ; + + +=head2 How it works + +The Filter::Simple module exports into the package that Cs it (e.g. +package "BANG" in the above example) two automagically constructed +subroutines -- C and C -- which take care of all the +nasty details. + +In addition, the generated C subroutine passes its own argument +list to the filtering subroutine, so the BANG.pm filter could easily +be made parametric: + + package BANG; + + use Filter::Simple sub { + my ($die_msg, $var_name) = @_; + s/BANG\s+BANG/die '$die_msg' if \${$var_name}/g; + }; + + # and in some user code: + + use BANG "BOOM", "BAM; # "BANG BANG" becomes: die 'BOOM' if $BAM + + +The specified filtering subroutine is called every time a C +is encountered, and passed all the source code following that call, +up to either the next C call or the end of the source file +(whichever occurs first). Currently, any C call must appear +by itself on a separate line, or it is ignored. + + +=head1 AUTHOR + +Damian Conway (damian@conway.org) + +=head1 COPYRIGHT + + Copyright (c) 2000, Damian Conway. All Rights Reserved. + This module is free software. It may be used, redistributed +and/or modified under the terms of the Perl Artistic License + (see http://www.perl.com/perl/misc/Artistic.html) diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index 2bb0548..e933c48 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -2,17 +2,17 @@ package Getopt::Long; -# RCS Status : $Id: GetoptLong.pl,v 2.25 2000-08-28 21:45:17+02 jv Exp $ +# RCS Status : $Id: GetoptLong.pl,v 2.25 2000-08-28 21:45:17+02 jv Exp jv $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Mon Jul 31 21:21:13 2000 -# Update Count : 739 +# Last Modified On: Sat Jan 6 17:12:27 2001 +# Update Count : 748 # Status : Released ################ Copyright ################ -# This program is Copyright 1990,2000 by Johan Vromans. +# This program is Copyright 1990,2001 by Johan Vromans. # This program is free software; you can redistribute it and/or # modify it under the terms of the Perl Artistic License or the # GNU General Public License as published by the Free Software @@ -30,19 +30,24 @@ package Getopt::Long; ################ Module Preamble ################ +use 5.004; + use strict; -BEGIN { - require 5.004; - use Exporter (); - use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - $VERSION = 2.24; +use vars qw($VERSION $VERSION_STRING); +$VERSION = 2.24_02; +$VERSION_STRING = "2.24_02"; + +use Exporter; +use AutoLoader qw(AUTOLOAD); - @ISA = qw(Exporter); +use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); +@ISA = qw(Exporter); +%EXPORT_TAGS = qw(); +BEGIN { + # Init immediately so their contents can be used in the 'use vars' below. @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); - %EXPORT_TAGS = qw(); @EXPORT_OK = qw(); - use AutoLoader qw(AUTOLOAD); } # User visible variables. @@ -143,7 +148,7 @@ sub new { my %atts = @_; # Register the callers package. - my $self = { caller => (caller)[0] }; + my $self = { caller_pkg => (caller)[0] }; bless ($self, $class); @@ -189,7 +194,7 @@ sub getoptions { # Call main routine. my $ret = 0; - $Getopt::Long::caller = $self->{caller}; + $Getopt::Long::caller = $self->{caller_pkg}; eval { $ret = Getopt::Long::GetOptions (@_); }; # Restore saved settings. @@ -210,12 +215,12 @@ __END__ ################ AutoLoading subroutines ################ -# RCS Status : $Id: GetoptLongAl.pl,v 2.29 2000-08-28 21:56:18+02 jv Exp $ +# RCS Status : $Id: GetoptLongAl.pl,v 2.29 2000-08-28 21:56:18+02 jv Exp jv $ # Author : Johan Vromans # Created On : Fri Mar 27 11:50:30 1998 # Last Modified By: Johan Vromans -# Last Modified On: Fri Jul 28 19:12:29 2000 -# Update Count : 97 +# Last Modified On: Tue Dec 26 18:01:16 2000 +# Update Count : 98 # Status : Released sub GetOptions { @@ -321,7 +326,9 @@ sub GetOptions { if ( ! defined $o ) { # empty -> '-' option - $opctl{$linko = $o = ''} = $c; + $linko = $o = ''; + $opctl{''} = $c; + $bopctl{''} = $c if $bundling; } else { # Handle alias names @@ -658,7 +665,8 @@ sub FindOption ($$$$$$$) { print STDERR ("=> find \"$opt\", prefix=\"$prefix\"\n") if $debug; - return (0) unless $opt =~ /^$prefix(.*)$/s; + return 0 unless $opt =~ /^$prefix(.*)$/s; + return 0 if $opt eq "-" && !defined $opctl->{""}; $opt = $+; my ($starter) = $1; @@ -687,7 +695,7 @@ sub FindOption ($$$$$$$) { if ( $bundling && $starter eq '-' ) { # Unbundle single letter option. - $rest = substr ($tryopt, 1); + $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : ""; $tryopt = substr ($tryopt, 0, 1); $tryopt = lc ($tryopt) if $ignorecase > 1; print STDERR ("=> $starter$tryopt unbundled from ", @@ -1553,13 +1561,18 @@ It goes without saying that bundling can be quite confusing. =head2 The lonesome dash -Some applications require the option C<-> (that's a lone dash). This -can be achieved by adding an option specification with an empty name: +Normally, a lone dash C<-> on the command line will not be considered +an option. Option processing will terminate (unless "permute" is +configured) and the dash will be left in C<@ARGV>. + +It is possible to get special treatment for a lone dash. This can be +achieved by adding an option specification with an empty name, for +example: GetOptions ('' => \$stdio); -A lone dash on the command line will now be legal, and set options -variable C<$stdio>. +A lone dash on the command line will now be a legal option, and using +it will set variable C<$stdio>. =head2 Argument call-back diff --git a/lib/I18N/Collate.pm b/lib/I18N/Collate.pm index 64a03a2..d18a5a5 100644 --- a/lib/I18N/Collate.pm +++ b/lib/I18N/Collate.pm @@ -1,5 +1,8 @@ package I18N::Collate; +use strict; +our $VERSION = '1.00'; + =head1 NAME I18N::Collate - compare 8-bit scalar data according to the current locale @@ -112,15 +115,18 @@ use warnings::register; require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(collate_xfrm setlocale LC_COLLATE); -@EXPORT_OK = qw(); +our @ISA = qw(Exporter); +our @EXPORT = qw(collate_xfrm setlocale LC_COLLATE); +our @EXPORT_OK = qw(); use overload qw( fallback 1 cmp collate_cmp ); +our($LOCALE, $C); + +our $please_use_I18N_Collate_even_if_deprecated = 0; sub new { my $new = $_[1]; diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm index e7a071a..066e366 100644 --- a/lib/Math/Complex.pm +++ b/lib/Math/Complex.pm @@ -1414,6 +1414,8 @@ sub stringify_polar { 1; __END__ +=pod + =head1 NAME Math::Complex - complex numbers and associated mathematical functions diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm index 40da9f3..a2846fe 100644 --- a/lib/Net/Ping.pm +++ b/lib/Net/Ping.pm @@ -269,13 +269,13 @@ sub checksum ); $len_msg = length($msg); - $num_short = $len_msg / 2; + $num_short = int($len_msg / 2); $chk = 0; foreach $short (unpack("S$num_short", $msg)) { $chk += $short; } # Add the odd byte in - $chk += unpack("C", substr($msg, $len_msg - 1, 1)) if $len_msg % 2; + $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2; $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement } @@ -369,16 +369,17 @@ sub ping_udp elsif ($nfound) # A packet is waiting { $from_msg = ""; - $from_saddr = recv($self->{"fh"}, $from_msg, 1500, $flags); - ($from_port, $from_ip) = sockaddr_in($from_saddr); - if (($from_ip eq $ip) && # Does the packet check out? - ($from_port == $self->{"port_num"}) && - ($from_msg eq $msg)) - { - $ret = 1; # It's a winner - $done = 1; - } - } + $from_saddr = recv($self->{"fh"}, $from_msg, 1500, $flags) + or last; # For example an unreachable host will make recv() fail. + ($from_port, $from_ip) = sockaddr_in($from_saddr); + if (($from_ip eq $ip) && # Does the packet check out? + ($from_port == $self->{"port_num"}) && + ($from_msg eq $msg)) + { + $ret = 1; # It's a winner + $done = 1; + } + } else # Oops, timed out { $done = 1; @@ -459,6 +460,11 @@ received from the remote host and the received packet contains the same data as the packet that was sent, the remote host is considered reachable. This protocol does not require any special privileges. +It should be borne in mind that, for both tcp and udp ping, a host +will be reported as unreachable if it is not running the +appropriate echo service. For Unix-like systems see L for +more information. + If the "icmp" protocol is specified, the ping() method sends an icmp echo message to the remote host, which is what the UNIX ping program does. If the echoed message is received from the remote host and diff --git a/lib/Net/hostent.pm b/lib/Net/hostent.pm index 6cfde72..0a22389 100644 --- a/lib/Net/hostent.pm +++ b/lib/Net/hostent.pm @@ -2,6 +2,7 @@ package Net::hostent; use strict; use 5.005_64; +our $VERSION = '1.00'; our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); diff --git a/lib/Net/netent.pm b/lib/Net/netent.pm index b21cd04..d5ce22e 100644 --- a/lib/Net/netent.pm +++ b/lib/Net/netent.pm @@ -2,6 +2,7 @@ package Net::netent; use strict; use 5.005_64; +our $VERSION = '1.00'; our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); diff --git a/lib/Net/protoent.pm b/lib/Net/protoent.pm index 6aad940..2c3db88 100644 --- a/lib/Net/protoent.pm +++ b/lib/Net/protoent.pm @@ -2,6 +2,7 @@ package Net::protoent; use strict; use 5.005_64; +our $VERSION = '1.00'; our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); diff --git a/lib/Net/servent.pm b/lib/Net/servent.pm index c892af0..18c7fb5 100644 --- a/lib/Net/servent.pm +++ b/lib/Net/servent.pm @@ -2,6 +2,7 @@ package Net::servent; use strict; use 5.005_64; +our $VERSION = '1.00'; our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); diff --git a/lib/Pod/Checker.pm b/lib/Pod/Checker.pm index 37ed68f..35d0186 100644 --- a/lib/Pod/Checker.pm +++ b/lib/Pod/Checker.pm @@ -150,8 +150,8 @@ C<"">. =item * Unknown command "I" An invalid POD command has been found. Valid are C<=head1>, C<=head2>, -C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>, C<=for>, C<=pod>, -C<=cut> +C<=head3>, C<=head4>, C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>, +C<=for>, C<=pod>, C<=cut> =item * Unknown interior-sequence "I" @@ -355,6 +355,8 @@ my %VALID_COMMANDS = ( 'cut' => 1, 'head1' => 1, 'head2' => 1, + 'head3' => 1, + 'head4' => 1, 'over' => 1, 'back' => 1, 'item' => 1, diff --git a/lib/Pod/Functions.pm b/lib/Pod/Functions.pm index 44619d5..960b847 100644 --- a/lib/Pod/Functions.pm +++ b/lib/Pod/Functions.pm @@ -2,12 +2,16 @@ package Pod::Functions; #:vi:set ts=20 +our $VERSION = '1.00'; + require Exporter; @ISA = qw(Exporter); @EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order); -%Type_Description = ( +our(%Kinds, %Type, %Flavor); + +our %Type_Description = ( 'ARRAY' => 'Functions for real @ARRAYs', 'Binary' => 'Functions for fixed length data or records', 'File' => 'Functions for filehandles, files, or directories', @@ -30,7 +34,7 @@ require Exporter; 'Namespace' => 'Keywords altering or affecting scoping of identifiers', ); -@Type_Order = qw{ +our @Type_Order = qw{ String Regexp Math @@ -57,20 +61,20 @@ while () { chomp; s/#.*//; next unless $_; - ($name, $type, $text) = split " ", $_, 3; + my($name, $type, $text) = split " ", $_, 3; $Type{$name} = $type; $Flavor{$name} = $text; - for $type ( split /[,\s]+/, $type ) { - push @{$Kinds{$type}}, $name; + for my $t ( split /[,\s]+/, $type ) { + push @{$Kinds{$t}}, $name; } } close DATA; unless (caller) { - foreach $type ( @Type_Order ) { - $list = join(", ", sort @{$Kinds{$type}}); - $typedesc = $Type_Description{$type} . ":"; + foreach my $type ( @Type_Order ) { + my $list = join(", ", sort @{$Kinds{$type}}); + my $typedesc = $Type_Description{$type} . ":"; write; } } diff --git a/lib/Pod/Html.pm b/lib/Pod/Html.pm index f70a42b..4316823 100644 --- a/lib/Pod/Html.pm +++ b/lib/Pod/Html.pm @@ -12,7 +12,6 @@ use Config; use Cwd; use File::Spec::Unix; use Getopt::Long; -use Pod::Functions; use locale; # make \w work right in non-ASCII lands diff --git a/lib/Pod/Man.pm b/lib/Pod/Man.pm index 0fdb6d0..84c8f66 100644 --- a/lib/Pod/Man.pm +++ b/lib/Pod/Man.pm @@ -1,5 +1,5 @@ # Pod::Man -- Convert POD data to formatted *roff input. -# $Id: Man.pm,v 1.8 2000/10/10 02:14:31 eagle Exp $ +# $Id: Man.pm,v 1.12 2000/12/25 12:56:12 eagle Exp $ # # Copyright 1999, 2000 by Russ Allbery # @@ -38,7 +38,7 @@ use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION); # Perl core and too many things could munge CVS magic revision strings. # This number should ideally be the same as the CVS revision in podlators, # however. -$VERSION = 1.08; +$VERSION = 1.12; ############################################################################ @@ -279,33 +279,6 @@ sub protect { $_; } -# Given a command and a single argument that may or may not contain double -# quotes, handle double-quote formatting for it. If there are no double -# quotes, just return the command followed by the argument in double quotes. -# If there are double quotes, use an if statement to test for nroff, and for -# nroff output the command followed by the argument in double quotes with -# embedded double quotes doubled. For other formatters, remap paired double -# quotes to `` and ''. -sub switchquotes { - my $command = shift; - local $_ = shift; - my $extra = shift; - s/\\\*\([LR]\"/\"/g; - if (/\"/) { - s/\"/\"\"/g; - my $troff = $_; - $troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g; - s/\"/\"\"/g if $extra; - $troff =~ s/\"/\"\"/g if $extra; - $_ = qq("$_") . ($extra ? " $extra" : ''); - $troff = qq("$troff") . ($extra ? " $extra" : ''); - return ".if n $command $_\n.el $command $troff\n"; - } else { - $_ = qq("$_") . ($extra ? " $extra" : ''); - return "$command $_\n"; - } -} - # Translate a font string into an escape. sub toescape { (length ($_[0]) > 1 ? '\f(' : '\f') . $_[0] } @@ -568,7 +541,7 @@ sub textblock { $text = $self->parse ($text, @_); $text =~ s/\n\s*$/\n/; $self->makespace; - $self->output (protect $self->mapfonts ($text)); + $self->output (protect $self->textmapfonts ($text)); $self->outindex; $$self{NEEDSPACE} = 1; } @@ -661,7 +634,7 @@ sub cmd_head1 { $$self{ITEMS} = 0; $self->output (".PD\n"); } - $self->output (switchquotes ('.SH', $self->mapfonts ($_))); + $self->output ($self->switchquotes ('.SH', $self->mapfonts ($_))); $self->outindex (($_ eq 'NAME') ? () : ('Header', $_)); $$self{NEEDSPACE} = 0; } @@ -675,11 +648,41 @@ sub cmd_head2 { $$self{ITEMS} = 0; $self->output (".PD\n"); } - $self->output (switchquotes ('.Sh', $self->mapfonts ($_))); + $self->output ($self->switchquotes ('.Sh', $self->mapfonts ($_))); $self->outindex ('Subsection', $_); $$self{NEEDSPACE} = 0; } +# Third level heading. +sub cmd_head3 { + my $self = shift; + local $_ = $self->parse (@_); + s/\s+$//; + if ($$self{ITEMS} > 1) { + $$self{ITEMS} = 0; + $self->output (".PD\n"); + } + $self->makespace; + $self->output ($self->switchquotes ('.I', $self->mapfonts ($_))); + $self->outindex ('Subsection', $_); + $$self{NEEDSPACE} = 1; +} + +# Fourth level heading. +sub cmd_head4 { + my $self = shift; + local $_ = $self->parse (@_); + s/\s+$//; + if ($$self{ITEMS} > 1) { + $$self{ITEMS} = 0; + $self->output (".PD\n"); + } + $self->makespace; + $self->output ($self->textmapfonts ($_) . "\n"); + $self->outindex ('Subsection', $_); + $$self{NEEDSPACE} = 1; +} + # Start a list. For indents after the first, wrap the outside indent in .RS # so that hanging paragraph tags will be correct. sub cmd_over { @@ -736,9 +739,9 @@ sub cmd_item { $self->output (".RE\n"); $$self{WEIRDINDENT} = 0; } - $_ = $self->mapfonts ($_); + $_ = $self->textmapfonts ($_); $self->output (".PD 0\n") if ($$self{ITEMS} == 1); - $self->output (switchquotes ('.Ip', $_, $$self{INDENT})); + $self->output ($self->switchquotes ('.Ip', $_, $$self{INDENT})); $self->outindex ($index ? ('Item', $index) : ()); $$self{NEEDSPACE} = 0; $$self{ITEMS}++; @@ -844,18 +847,52 @@ sub buildlink { # At this point, we'll have embedded font codes of the form \f([SE] # where is one of B, I, or F. Turn those into the right font start -# or end codes. B else> should map to \fBsome\f(BIthing\fB -# else\fR. The old pod2man didn't get this right; the second \fB was \fR, -# so nested sequences didn't work right. We take care of this by using -# variables as a combined pointer to our current font sequence, and set each -# to the number of current nestings of start tags for that font. Use them -# as a vector to look up what font sequence to use. +# or end codes. The old pod2man didn't get B else> right; +# after I<> it switched back to normal text rather than bold. We take care +# of this by using variables as a combined pointer to our current font +# sequence, and set each to the number of current nestings of start tags for +# that font. Use them as a vector to look up what font sequence to use. +# +# \fP changes to the previous font, but only one previous font is kept. We +# don't know what the outside level font is; normally it's R, but if we're +# inside a heading it could be something else. So arrange things so that +# the outside font is always the "previous" font and end with \fP instead of +# \fR. Idea from Zack Weinberg. sub mapfonts { my $self = shift; local $_ = shift; my ($fixed, $bold, $italic) = (0, 0, 0); my %magic = (F => \$fixed, B => \$bold, I => \$italic); + my $last = '\fR'; + s { \\f\((.)(.) } { + my $sequence = ''; + my $f; + if ($last ne '\fR') { $sequence = '\fP' } + ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1; + $f = $$self{FONTS}{($fixed && 1) . ($bold && 1) . ($italic && 1)}; + if ($f eq $last) { + ''; + } else { + if ($f ne '\fR') { $sequence .= $f } + $last = $f; + $sequence; + } + }gxe; + $_; +} + +# Unfortunately, there is a bug in Solaris 2.6 nroff (not present in GNU +# groff) where the sequence \fB\fP\f(CW\fP leaves the font set to B rather +# than R, presumably because \f(CW doesn't actually do a font change. To +# work around this, use a separate textmapfonts for text blocks where the +# default font is always R and only use the smart mapfonts for headings. +sub textmapfonts { + my $self = shift; + local $_ = shift; + + my ($fixed, $bold, $italic) = (0, 0, 0); + my %magic = (F => \$fixed, B => \$bold, I => \$italic); s { \\f\((.)(.) } { ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1; $$self{FONTS}{($fixed && 1) . ($bold && 1) . ($italic && 1)}; @@ -1020,6 +1057,44 @@ sub outindex { # Output text to the output device. sub output { print { $_[0]->output_handle } $_[1] } +# Given a command and a single argument that may or may not contain double +# quotes, handle double-quote formatting for it. If there are no double +# quotes, just return the command followed by the argument in double quotes. +# If there are double quotes, use an if statement to test for nroff, and for +# nroff output the command followed by the argument in double quotes with +# embedded double quotes doubled. For other formatters, remap paired double +# quotes to LQUOTE and RQUOTE. +sub switchquotes { + my $self = shift; + my $command = shift; + local $_ = shift; + my $extra = shift; + s/\\\*\([LR]\"/\"/g; + + # We also have to deal with \*C` and \*C', which are used to add the + # quotes around C<> text, since they may expand to " and if they do this + # confuses the .SH macros and the like no end. Expand them ourselves. + # If $extra is set, we're dealing with =item, which in most nroff macro + # sets requires an extra level of quoting of double quotes. + my $c_is_quote = ($$self{LQUOTE} =~ /\"/) || ($$self{RQUOTE} =~ /\"/); + if (/\"/ || ($c_is_quote && /\\\*\(C[\'\`]/)) { + s/\"/\"\"/g; + my $troff = $_; + $troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g; + s/\\\*\(C\`/$$self{LQUOTE}/g; + s/\\\*\(C\'/$$self{RQUOTE}/g; + $troff =~ s/\\\*\(C[\'\`]//g; + s/\"/\"\"/g if $extra; + $troff =~ s/\"/\"\"/g if $extra; + $_ = qq("$_") . ($extra ? " $extra" : ''); + $troff = qq("$troff") . ($extra ? " $extra" : ''); + return ".if n $command $_\n.el $command $troff\n"; + } else { + $_ = qq("$_") . ($extra ? " $extra" : ''); + return "$command $_\n"; + } +} + __END__ .\" These are some extra bits of roff that I don't want to lose track of diff --git a/lib/Pod/Select.pm b/lib/Pod/Select.pm index d86d823..e7c820f 100644 --- a/lib/Pod/Select.pm +++ b/lib/Pod/Select.pm @@ -109,33 +109,39 @@ Some example section specifications follow. =over 4 -=item +=item * + Match the C and C sections and all of their subsections: C -=item +=item * + Match only the C and C subsections of the C section: C -=item +=item * + Match the C subsection of I sections: C -=item +=item * + Match all subsections of C I for C: C -=item +=item * + Match the C section but do I match any of its subsections: C -=item +=item * + Match all top level sections but none of their subsections: C diff --git a/lib/Pod/Text.pm b/lib/Pod/Text.pm index 5a7bab8..5f2dae0 100644 --- a/lib/Pod/Text.pm +++ b/lib/Pod/Text.pm @@ -1,5 +1,5 @@ # Pod::Text -- Convert POD data to formatted ASCII text. -# $Id: Text.pm,v 2.6 2000/10/10 02:13:17 eagle Exp $ +# $Id: Text.pm,v 2.7 2000/11/19 04:47:50 eagle Exp $ # # Copyright 1999, 2000 by Russ Allbery # @@ -37,7 +37,7 @@ use vars qw(@ISA @EXPORT %ESCAPES $VERSION); # Perl core and too many things could munge CVS magic revision strings. # This number should ideally be the same as the CVS revision in podlators, # however. -$VERSION = 2.06; +$VERSION = 2.07; ############################################################################ @@ -173,7 +173,7 @@ sub initialize { $$self{width} = 76 unless defined $$self{width}; # Figure out what quotes we'll be using for C<> text. - $$self{quotes} ||= "'"; + $$self{quotes} ||= '"'; if ($$self{quotes} eq 'none') { $$self{LQUOTE} = $$self{RQUOTE} = ''; } elsif (length ($$self{quotes}) == 1) { @@ -376,6 +376,32 @@ sub cmd_head2 { } } +# Third level heading. +sub cmd_head3 { + my $self = shift; + local $_ = shift; + s/\s+$//; + $_ = $self->interpolate ($_, shift); + if ($$self{alt}) { + $self->output ("\n= $_ =\n\n"); + } else { + $self->output (' ' x ($$self{indent} * 2 / 3 + 0.5) . $_ . "\n\n"); + } +} + +# Third level heading. +sub cmd_head4 { + my $self = shift; + local $_ = shift; + s/\s+$//; + $_ = $self->interpolate ($_, shift); + if ($$self{alt}) { + $self->output ("\n- $_ -\n\n"); + } else { + $self->output (' ' x ($$self{indent} * 3 / 4 + 0.5) . $_ . "\n\n"); + } +} + # Start a list. sub cmd_over { my $self = shift; diff --git a/lib/Pod/Text/Color.pm b/lib/Pod/Text/Color.pm index 10e1d9f..e943216 100644 --- a/lib/Pod/Text/Color.pm +++ b/lib/Pod/Text/Color.pm @@ -1,5 +1,5 @@ # Pod::Text::Color -- Convert POD data to formatted color ASCII text -# $Id: Color.pm,v 0.5 1999/09/20 10:15:16 eagle Exp $ +# $Id: Color.pm,v 0.6 2000/12/25 12:52:39 eagle Exp $ # # Copyright 1999 by Russ Allbery # @@ -26,8 +26,11 @@ use vars qw(@ISA $VERSION); @ISA = qw(Pod::Text); -# Use the CVS revision of this file as its version number. -($VERSION = (split (' ', q$Revision: 0.5 $ ))[1]) =~ s/\.(\d)$/.0$1/; +# Don't use the CVS revision as the version, since this module is also in +# Perl core and too many things could munge CVS magic revision strings. +# This number should ideally be the same as the CVS revision in podlators, +# however. +$VERSION = 0.06; ############################################################################ diff --git a/lib/Pod/Text/Overstrike.pm b/lib/Pod/Text/Overstrike.pm new file mode 100644 index 0000000..c9f0789 --- /dev/null +++ b/lib/Pod/Text/Overstrike.pm @@ -0,0 +1,160 @@ +# Pod::Text::Overstrike -- Convert POD data to formatted overstrike text +# $Id: Overstrike.pm,v 1.1 2000/12/25 12:51:23 eagle Exp $ +# +# Created by Joe Smith 30-Nov-2000 +# (based on Pod::Text::Color by Russ Allbery ) +# +# This program is free software; you can redistribute it and/or modify it +# under the same terms as Perl itself. +# +# This was written because the output from: +# +# pod2text Text.pm > plain.txt; less plain.txt +# +# is not as rich as the output from +# +# pod2man Text.pm | nroff -man > fancy.txt; less fancy.txt +# +# and because both Pod::Text::Color and Pod::Text::Termcap are not device +# independent. + +############################################################################ +# Modules and declarations +############################################################################ + +package Pod::Text::Overstrike; + +require 5.004; + +use Pod::Text (); + +use strict; +use vars qw(@ISA $VERSION); + +@ISA = qw(Pod::Text); + +# Don't use the CVS revision as the version, since this module is also in +# Perl core and too many things could munge CVS magic revision strings. +# This number should ideally be the same as the CVS revision in podlators, +# however. +$VERSION = 1.01; + + +############################################################################ +# Overrides +############################################################################ + +# Make level one headings bold, overridding any existing formatting. +sub cmd_head1 { + my $self = shift; + local $_ = shift; + s/\s+$//; + s/(.)\cH\1//g; + s/_\cH//g; + s/(.)/$1\b$1/g; + $self->SUPER::cmd_head1 ($_); +} + +# Make level two headings bold, overriding any existing formatting. +sub cmd_head2 { + my $self = shift; + local $_ = shift; + s/\s+$//; + s/(.)\cH\1//g; + s/_\cH//g; + s/(.)/$1\b$1/g; + $self->SUPER::cmd_head2 ($_); +} + +# Make level three headings underscored, overriding any existing formatting. +sub cmd_head3 { + my $self = shift; + local $_ = shift; + s/\s+$//; + s/(.)\cH\1//g; + s/_\cH//g; + s/(.)/_\b$1/g; + $self->SUPER::cmd_head3 ($_); +} + +# Fix the various interior sequences. +sub seq_b { local $_ = $_[1]; s/(.)\cH\1//g; s/_\cH//g; s/(.)/$1\b$1/g; $_ } +sub seq_f { local $_ = $_[1]; s/(.)\cH\1//g; s/_\cH//g; s/(.)/_\b$1/g; $_ } +sub seq_i { local $_ = $_[1]; s/(.)\cH\1//g; s/_\cH//g; s/(.)/_\b$1/g; $_ } + +# We unfortunately have to override the wrapping code here, since the normal +# wrapping code gets really confused by all the escape sequences. +sub wrap { + my $self = shift; + local $_ = shift; + my $output = ''; + my $spaces = ' ' x $$self{MARGIN}; + my $width = $$self{width} - $$self{MARGIN}; + while (length > $width) { + if (s/^((?:(?:[^\n]\cH)?[^\n]){0,$width})\s+// + || s/^((?:(?:[^\n]\cH)?[^\n]){$width})//) { + $output .= $spaces . $1 . "\n"; + } else { + last; + } + } + $output .= $spaces . $_; + $output =~ s/\s+$/\n\n/; + $output; +} + +############################################################################ +# Module return value and documentation +############################################################################ + +1; +__END__ + +=head1 NAME + +Pod::Text::Overstrike - Convert POD data to formatted overstrike text + +=head1 SYNOPSIS + + use Pod::Text::Overstrike; + my $parser = Pod::Text::Overstrike->new (sentence => 0, width => 78); + + # Read POD from STDIN and write to STDOUT. + $parser->parse_from_filehandle; + + # Read POD from file.pod and write to file.txt. + $parser->parse_from_file ('file.pod', 'file.txt'); + +=head1 DESCRIPTION + +Pod::Text::Overstrike is a simple subclass of Pod::Text that highlights +output text using overstrike sequences, in a manner similar to nroff. +Characters in bold text are overstruck (character, backspace, character) and +characters in underlined text are converted to overstruck underscores +(underscore, backspace, character). This format was originally designed for +hardcopy terminals and/or lineprinters, yet is readable on softcopy (CRT) +terminals. + +Overstruck text is best viewed by page-at-a-time programs that take +advantage of the terminal's B and I capabilities, such +as the less program on Unix. + +Apart from the overstrike, it in all ways functions like Pod::Text. See +L for details and available options. + +=head1 BUGS + +Currently, the outermost formatting instruction wins, so for example +underlined text inside a region of bold text is displayed as simply bold. +There may be some better approach possible. + +=head1 SEE ALSO + +L, L + +=head1 AUTHOR + +Joe Smith EJoe.Smith@inwap.comE, using the framework created by Russ +Allbery Erra@stanford.eduE. + +=cut diff --git a/lib/Pod/Text/Termcap.pm b/lib/Pod/Text/Termcap.pm index 7e89ec6..333852a 100644 --- a/lib/Pod/Text/Termcap.pm +++ b/lib/Pod/Text/Termcap.pm @@ -1,5 +1,5 @@ # Pod::Text::Termcap -- Convert POD data to ASCII text with format escapes. -# $Id: Termcap.pm,v 0.4 1999/09/20 10:17:45 eagle Exp $ +# $Id: Termcap.pm,v 1.0 2000/12/25 12:52:48 eagle Exp $ # # Copyright 1999 by Russ Allbery # @@ -27,8 +27,11 @@ use vars qw(@ISA $VERSION); @ISA = qw(Pod::Text); -# Use the CVS revision of this file as its version number. -($VERSION = (split (' ', q$Revision: 0.4 $ ))[1]) =~ s/\.(\d)$/.0$1/; +# Don't use the CVS revision as the version, since this module is also in +# Perl core and too many things could munge CVS magic revision strings. +# This number should ideally be the same as the CVS revision in podlators, +# however. +$VERSION = 1.00; ############################################################################ diff --git a/lib/Search/Dict.pm b/lib/Search/Dict.pm index 9a229a7..58c7543 100644 --- a/lib/Search/Dict.pm +++ b/lib/Search/Dict.pm @@ -2,8 +2,11 @@ package Search::Dict; require 5.000; require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(look); +use strict; + +our $VERSION = '1.00'; +our @ISA = qw(Exporter); +our @EXPORT = qw(look); =head1 NAME @@ -30,9 +33,9 @@ If I<$fold> is true, ignore case. =cut sub look { - local(*FH,$key,$dict,$fold) = @_; + my($fh,$key,$dict,$fold) = @_; local($_); - my(@stat) = stat(FH) + my(@stat) = stat($fh) or return -1; my($size, $blksize) = @stat[7,11]; $blksize ||= 8192; @@ -41,10 +44,10 @@ sub look { my($min, $max, $mid) = (0, int($size / $blksize)); while ($max - $min > 1) { $mid = int(($max + $min) / 2); - seek(FH, $mid * $blksize, 0) + seek($fh, $mid * $blksize, 0) or return -1; - if $mid; # probably a partial line - $_ = ; + <$fh> if $mid; # probably a partial line + $_ = <$fh>; chop; s/[^\w\s]//g if $dict; $_ = lc $_ if $fold; @@ -56,19 +59,19 @@ sub look { } } $min *= $blksize; - seek(FH,$min,0) + seek($fh,$min,0) or return -1; - if $min; + <$fh> if $min; for (;;) { - $min = tell(FH); - defined($_ = ) + $min = tell($fh); + defined($_ = <$fh>) or last; chop; s/[^\w\s]//g if $dict; $_ = lc $_ if $fold; last if $_ ge $key; } - seek(FH,$min,0); + seek($fh,$min,0); $min; } diff --git a/lib/SelectSaver.pm b/lib/SelectSaver.pm index 5f56922..08104f4 100644 --- a/lib/SelectSaver.pm +++ b/lib/SelectSaver.pm @@ -1,5 +1,7 @@ package SelectSaver; +our $VERSION = '1.00'; + =head1 NAME SelectSaver - save and restore selected file handle diff --git a/lib/Term/Cap.pm b/lib/Term/Cap.pm index 0954000..6d31ab7 100644 --- a/lib/Term/Cap.pm +++ b/lib/Term/Cap.pm @@ -1,7 +1,9 @@ package Term::Cap; use Carp; -# Last updated: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com +our $VERSION = '1.00'; + +# Last updated: Thu Nov 30 23:34:29 EST 2000 by schwern@pobox.com # TODO: # support Berkeley DB termcaps diff --git a/lib/Term/Complete.pm b/lib/Term/Complete.pm index 445dfca..6cf6a0c 100644 --- a/lib/Term/Complete.pm +++ b/lib/Term/Complete.pm @@ -2,8 +2,10 @@ package Term::Complete; require 5.000; require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(Complete); +use strict; +our @ISA = qw(Exporter); +our @EXPORT = qw(Complete); +our $VERSION = '1.2'; # @(#)complete.pl,v1.2 (me@anywhere.EBay.Sun.COM) 09/23/91 @@ -64,6 +66,7 @@ Wayne Thompson =cut +our($complete, $kill, $erase1, $erase2); CONFIG: { $complete = "\004"; $kill = "\025"; @@ -72,7 +75,7 @@ CONFIG: { } sub Complete { - my($prompt, @cmp_list, $cmp, $test, $l, @match); + my($prompt, @cmp_lst, $cmp, $test, $l, @match); my ($return, $r) = ("", 0); $return = ""; diff --git a/lib/Term/ReadLine.pm b/lib/Term/ReadLine.pm index 8bb8205..491ce79 100644 --- a/lib/Term/ReadLine.pm +++ b/lib/Term/ReadLine.pm @@ -159,22 +159,27 @@ particular used C package). =cut +use strict; + package Term::ReadLine::Stub; -@ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap'; +our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap'; $DB::emacs = $DB::emacs; # To peacify -w +our @rl_term_set; *rl_term_set = \@Term::ReadLine::TermCap::rl_term_set; sub ReadLine {'Term::ReadLine::Stub'} sub readline { my $self = shift; my ($in,$out,$str) = @$self; - print $out $rl_term_set[0], shift, $rl_term_set[1], $rl_term_set[2]; + my $prompt = shift; + print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2]; $self->register_Tk if not $Term::ReadLine::registered and $Term::ReadLine::toloop and defined &Tk::DoOneEvent; #$str = scalar <$in>; $str = $self->get_line; + $str =~ s/^\s*\Q$prompt\E// if ($^O eq 'MacOS'); print $out $rl_term_set[3]; # bug in 5.000: chomping empty string creats length -1: chomp $str if defined $str; @@ -185,7 +190,9 @@ sub addhistory {} sub findConsole { my $console; - if (-e "/dev/tty") { + if ($^O eq 'MacOS') { + $console = "Dev:Console"; + } elsif (-e "/dev/tty") { $console = "/dev/tty"; } elsif (-e "con" or $^O eq 'MSWin32') { $console = "con"; @@ -204,7 +211,7 @@ sub findConsole { } } - $consoleOUT = $console; + my $consoleOUT = $console; $console = "&STDIN" unless defined $console; if (!defined $consoleOUT) { $consoleOUT = defined fileno(STDERR) ? "&STDERR" : "&STDOUT"; @@ -218,19 +225,19 @@ sub new { #local (*FIN, *FOUT); my ($FIN, $FOUT, $ret); if (@_==2) { - ($console, $consoleOUT) = findConsole; + my($console, $consoleOUT) = findConsole; open(FIN, "<$console"); open(FOUT,">$consoleOUT"); #OUT->autoflush(1); # Conflicts with debugger? - $sel = select(FOUT); + my $sel = select(FOUT); $| = 1; # for DB::OUT select($sel); $ret = bless [\*FIN, \*FOUT]; } else { # Filehandles supplied $FIN = $_[2]; $FOUT = $_[3]; #OUT->autoflush(1); # Conflicts with debugger? - $sel = select($FOUT); + my $sel = select($FOUT); $| = 1; # for DB::OUT select($sel); $ret = bless [$FIN, $FOUT]; @@ -262,6 +269,8 @@ sub Features { \%features } package Term::ReadLine; # So late to allow the above code be defined? +our $VERSION = '1.00'; + my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef; if ($which) { if ($which =~ /\bgnu\b/i){ @@ -281,7 +290,7 @@ if ($which) { # To make possible switch off RL in debugger: (Not needed, work done # in debugger). - +our @ISA; if (defined &Term::ReadLine::Gnu::readline) { @ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub); } elsif (defined &Term::ReadLine::Perl::readline) { @@ -294,10 +303,11 @@ package Term::ReadLine::TermCap; # Prompt-start, prompt-end, command-line-start, command-line-end # -- zero-width beautifies to emit around prompt and the command line. -@rl_term_set = ("","","",""); +our @rl_term_set = ("","","",""); # string encoded: -$rl_term_set = ',,,'; +our $rl_term_set = ',,,'; +our $terminal; sub LoadTermCap { return if defined $terminal; @@ -325,8 +335,10 @@ sub ornaments { package Term::ReadLine::Tk; +our($count_handle, $count_DoOne, $count_loop); $count_handle = $count_DoOne = $count_loop = 0; +our($giveup); sub handle {$giveup = 1; $count_handle++} sub Tk_loop { diff --git a/lib/Test.pm b/lib/Test.pm index c18d381..60e9f7e 100644 --- a/lib/Test.pm +++ b/lib/Test.pm @@ -177,9 +177,9 @@ __END__ =head1 DESCRIPTION -L expects to see particular output when it executes -tests. This module aims to make writing proper test scripts just a -little bit easier (and less error prone :-). +L expects to see particular output when it +executes tests. This module aims to make writing proper test scripts just +a little bit easier (and less error prone :-). =head1 TEST TYPES diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index a17bdbf..f438af6 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -1,17 +1,17 @@ +# -*- Mode: cperl; cperl-indent-level: 4 -*- package Test::Harness; use 5.005_64; use Exporter; use Benchmark; use Config; -use FileHandle; use strict; our($VERSION, $verbose, $switches, $have_devel_corestack, $curtest, $columns, @ISA, @EXPORT, @EXPORT_OK); $have_devel_corestack = 0; -$VERSION = "1.1604"; +$VERSION = "1.1607"; $ENV{HARNESS_ACTIVE} = 1; @@ -72,21 +72,20 @@ sub runtests { $ml = "\r$blank\r$leader" if -t STDOUT and not $ENV{HARNESS_NOTTY} and not $verbose; print $leader; - my $fh = new FileHandle; - $fh->open($test) or print "can't open $test. $!\n"; + open(my $fh, $test) or print "can't open $test. $!\n"; my $first = <$fh>; my $s = $switches; $s .= " $ENV{'HARNESS_PERL_SWITCHES'}" if exists $ENV{'HARNESS_PERL_SWITCHES'}; $s .= join " ", q[ "-T"], map {qq["-I$_"]} @INC if $first =~ /^#!.*\bperl.*-\w*T/; - $fh->close or print "can't close $test. $!\n"; + close($fh) or print "can't close $test. $!\n"; my $cmd = ($ENV{'HARNESS_COMPILE_TEST'}) ? "./perl -I../lib ../utils/perlcc $test " . "-run 2>> ./compilelog |" : "$^X $s $test|"; $cmd = "MCR $cmd" if $^O eq 'VMS'; - $fh->open($cmd) or print "can't run $test. $!\n"; + open($fh, $cmd) or print "can't run $test. $!\n"; $ok = $next = $max = 0; @failed = (); my %todo = (); @@ -120,7 +119,7 @@ sub runtests { $ok++; $totok++; } - } elsif (/^ok\s*(\d*)(\s*\#\s*[Ss]kip\S*(?:(?>\s+)(.+))?)?/) { + } elsif (/^ok\s*(\d*) *(\s*\#\s*[Ss]kip\S*(?:(?>\s+)(.+))?)?$/) { $this = $1 if $1 > 0; print "${ml}ok $this/$max" if $ml; $ok++; @@ -137,6 +136,15 @@ sub runtests { $skip_reason = $reason; } $bonus++, $totbonus++ if $todo{$this}; + } elsif (/^ok\s*(\d*)\s*\#([^\r]*)$/) { + $this = $1 if $1 > 0; + print "${ml}ok $this/$max" if $ml; + $ok++; + $totok++; + } else { + # an ok or not ok not matching the 3 cases above... + # just ignore it for compatibility with TEST + next; } if ($this > $next) { # print "Test output counter mismatch [test $this]\n"; @@ -148,9 +156,11 @@ sub runtests { $next = $this; } $next = $this + 1; - } + } elsif (/^Bail out!\s*(.*)/i) { # magic words + die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n"); + } } - $fh->close; # must close to reap child resource values + close($fh); # must close to reap child resource values my $wstatus = $ignore_exitcode ? 0 : $?; # Can trust $? ? my $estatus; $estatus = ($^O eq 'VMS' @@ -249,7 +259,7 @@ sub runtests { } } my $t_total = timediff(new Benchmark, $t_start); - + if ($^O eq 'VMS') { if (defined $old5lib) { $ENV{PERL5LIB} = $old5lib; @@ -452,7 +462,7 @@ script supplies test numbers again. So the following test script ok END -will generate +will generate FAILED tests 1, 3, 6 Failed 3/6 tests, 50.00% okay @@ -467,15 +477,26 @@ script(s). The default value is C<-w>. If the standard output line contains substring C< # Skip> (with variations in spacing and case) after C or C, it is -counted as a skipped test. If the whole testscript succeeds, the -count of skipped tests is included in the generated output. +counted as a skipped test. In no other circumstance is anything +allowed to follow C or C. If the whole testscript +succeeds, the count of skipped tests is included in the generated +output. -C reports the text after C< # Skip(whatever)> as a -reason for skipping. Similarly, one can include a similar explanation -in a C<1..0> line emitted if the test is skipped completely: +C reports the text after C< # Skip\S*\s+> as a reason +for skipping. Similarly, one can include a similar explanation in a +C<1..0> line emitted if the test is skipped completely: 1..0 # Skipped: no leverage found +As an emergency measure, a test script can decide that further tests +are useless (e.g. missing dependencies) and testing should stop +immediately. In that case the test script prints the magic words + + Bail out! + +to standard output. Any message after these words will be displayed by +C as the reason why testing is stopped. + =head1 EXPORT C<&runtests> is exported by Test::Harness per default. @@ -506,6 +527,11 @@ printed in a message similar to the above. If not all tests were successful, the script dies with one of the above messages. +=item C + +If a single subtest decides that further testing will not make sense, +the script dies with this message. + =back =head1 ENVIRONMENT diff --git a/lib/Text/Abbrev.pm b/lib/Text/Abbrev.pm index d4f12d0..08143fe 100644 --- a/lib/Text/Abbrev.pm +++ b/lib/Text/Abbrev.pm @@ -2,6 +2,8 @@ package Text::Abbrev; require 5.005; # Probably works on earlier versions too. require Exporter; +our $VERSION = '1.00'; + =head1 NAME abbrev - create an abbreviation table from a list diff --git a/lib/Text/ParseWords.pm b/lib/Text/ParseWords.pm index 2a6afc3..23eace9 100644 --- a/lib/Text/ParseWords.pm +++ b/lib/Text/ParseWords.pm @@ -214,21 +214,27 @@ demonstrating: =over 4 =item 0 + a simple word =item 1 + multiple spaces are skipped because of our $delim =item 2 + use of quotes to include a space in a word =item 3 + use of a backslash to include a space in a word =item 4 + use of a backslash to remove the special meaning of a double-quote =item 5 + another simple word (note the lack of effect of the backslashed double-quote) diff --git a/lib/Tie/Array.pm b/lib/Tie/Array.pm index e3b85d4..f4c6193 100644 --- a/lib/Tie/Array.pm +++ b/lib/Tie/Array.pm @@ -34,47 +34,43 @@ sub POP $val; } -sub SPLICE -{ - my $obj = shift; - my $sz = $obj->FETCHSIZE; - my $off = (@_) ? shift : 0; - $off += $sz if ($off < 0); - my $len = (@_) ? shift : $sz - $off; - my @result; - for (my $i = 0; $i < $len; $i++) - { - push(@result,$obj->FETCH($off+$i)); - } - if (@_ > $len) - { - # Move items up to make room - my $d = @_ - $len; - my $e = $off+$len; - $obj->EXTEND($sz+$d); - for (my $i=$sz-1; $i >= $e; $i--) - { - my $val = $obj->FETCH($i); - $obj->STORE($i+$d,$val); +sub SPLICE { + my $obj = shift; + my $sz = $obj->FETCHSIZE; + my $off = (@_) ? shift : 0; + $off += $sz if ($off < 0); + my $len = (@_) ? shift : $sz - $off; + $len += $sz - $off if $len < 0; + my @result; + for (my $i = 0; $i < $len; $i++) { + push(@result,$obj->FETCH($off+$i)); } - } - elsif (@_ < $len) - { - # Move items down to close the gap - my $d = $len - @_; - my $e = $off+$len; - for (my $i=$off+$len; $i < $sz; $i++) - { - my $val = $obj->FETCH($i); - $obj->STORE($i-$d,$val); + $off = $sz if $off > $sz; + $len -= $off + $len - $sz if $off + $len > $sz; + if (@_ > $len) { + # Move items up to make room + my $d = @_ - $len; + my $e = $off+$len; + $obj->EXTEND($sz+$d); + for (my $i=$sz-1; $i >= $e; $i--) { + my $val = $obj->FETCH($i); + $obj->STORE($i+$d,$val); + } } - $obj->STORESIZE($sz-$d); - } - for (my $i=0; $i < @_; $i++) - { - $obj->STORE($off+$i,$_[$i]); - } - return @result; + elsif (@_ < $len) { + # Move items down to close the gap + my $d = $len - @_; + my $e = $off+$len; + for (my $i=$off+$len; $i < $sz; $i++) { + my $val = $obj->FETCH($i); + $obj->STORE($i-$d,$val); + } + $obj->STORESIZE($sz-$d); + } + for (my $i=0; $i < @_; $i++) { + $obj->STORE($off+$i,$_[$i]); + } + return @result; } sub EXISTS { diff --git a/lib/Tie/Hash.pm b/lib/Tie/Hash.pm index 2244711..7399d8b 100644 --- a/lib/Tie/Hash.pm +++ b/lib/Tie/Hash.pm @@ -1,5 +1,7 @@ package Tie::Hash; +our $VERSION = '1.00'; + =head1 NAME Tie::Hash, Tie::StdHash - base class definitions for tied hashes diff --git a/lib/Tie/RefHash.pm b/lib/Tie/RefHash.pm index ffa9eb2..8555635 100644 --- a/lib/Tie/RefHash.pm +++ b/lib/Tie/RefHash.pm @@ -1,5 +1,7 @@ package Tie::RefHash; +our $VERSION = '1.21'; + =head1 NAME Tie::RefHash - use references as hash keys @@ -9,17 +11,26 @@ Tie::RefHash - use references as hash keys require 5.004; use Tie::RefHash; tie HASHVARIABLE, 'Tie::RefHash', LIST; + tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST; untie HASHVARIABLE; =head1 DESCRIPTION -This module provides the ability to use references as hash keys if -you first C the hash variable to this module. +This module provides the ability to use references as hash keys if you +first C the hash variable to this module. Normally, only the +keys of the tied hash itself are preserved as references; to use +references as keys in hashes-of-hashes, use Tie::RefHash::Nestable, +included as part of Tie::Hash. It is implemented using the standard perl TIEHASH interface. Please see the C entry in perlfunc(1) and perltie(1) for more information. +The Nestable version works by looking for hash references being stored +and converting them to tied hashes so that they too can have +references as keys. This will happen without warning whenever you +store a reference to one of your own hashes in the tied hash. + =head1 EXAMPLE use Tie::RefHash; @@ -36,6 +47,11 @@ see the C entry in perlfunc(1) and perltie(1) for more information. print ref($_), "\n"; } + tie %h, 'Tie::RefHash::Nestable'; + $h{$a}->{$b} = 1; + for (keys %h, keys %{$h{$a}}) { + print ref($_), "\n"; + } =head1 AUTHOR @@ -68,7 +84,17 @@ sub TIEHASH { sub FETCH { my($s, $k) = @_; - (ref $k) ? $s->[0]{"$k"}[1] : $s->[1]{$k}; + if (ref $k) { + if (defined $s->[0]{"$k"}) { + $s->[0]{"$k"}[1]; + } + else { + undef; + } + } + else { + $s->[1]{$k}; + } } sub STORE { @@ -121,4 +147,16 @@ sub CLEAR { %{$s->[1]} = (); } +package Tie::RefHash::Nestable; +use vars '@ISA'; @ISA = qw(Tie::RefHash); + +sub STORE { + my($s, $k, $v) = @_; + if (ref($v) eq 'HASH' and not tied %$v) { + my @elems = %$v; + tie %$v, ref($s), @elems; + } + $s->SUPER::STORE($k, $v); +} + 1; diff --git a/lib/Tie/Scalar.pm b/lib/Tie/Scalar.pm index 89ad03e..39480c8 100644 --- a/lib/Tie/Scalar.pm +++ b/lib/Tie/Scalar.pm @@ -1,5 +1,7 @@ package Tie::Scalar; +our $VERSION = '1.00'; + =head1 NAME Tie::Scalar, Tie::StdScalar - base class definitions for tied scalars diff --git a/lib/Tie/SubstrHash.pm b/lib/Tie/SubstrHash.pm index 4b18a58..afe5d8d 100644 --- a/lib/Tie/SubstrHash.pm +++ b/lib/Tie/SubstrHash.pm @@ -1,5 +1,7 @@ package Tie::SubstrHash; +our $VERSION = '1.00'; + =head1 NAME Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing @@ -33,6 +35,8 @@ Because the current implementation uses the table and key sizes for the hashing algorithm, there is no means by which to dynamically change the value of any of the initialization parameters. +The hash does not support exists(). + =cut use Carp; @@ -41,12 +45,20 @@ sub TIEHASH { my $pack = shift; my ($klen, $vlen, $tsize) = @_; my $rlen = 1 + $klen + $vlen; - $tsize = findprime($tsize * 1.1); # Allow 10% empty. + $tsize = [$tsize, + findgteprime($tsize * 1.1)]; # Allow 10% empty. $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1]; - $$self[0] x= $rlen * $tsize; + $$self[0] x= $rlen * $tsize->[1]; $self; } +sub CLEAR { + local($self) = @_; + $$self[0] = "\0" x ($$self[4] * $$self[3]->[1]); + $$self[5] = 0; + $$self[6] = -1; +} + sub FETCH { local($self,$key) = @_; local($klen, $vlen, $tsize, $rlen) = @$self[1..4]; @@ -69,8 +81,8 @@ sub FETCH { sub STORE { local($self,$key,$val) = @_; local($klen, $vlen, $tsize, $rlen) = @$self[1..4]; - croak("Table is full") if $$self[5] == $tsize; - croak(qq/Value "$val" is not $vlen characters long./) + croak("Table is full ($tsize->[0] elements)") if $$self[5] > $tsize->[0]; + croak(qq/Value "$val" is not $vlen characters long/) if length($val) != $vlen; my $writeoffset; @@ -129,7 +141,7 @@ sub FIRSTKEY { sub NEXTKEY { local($self) = @_; local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6]; - for (++$iterix; $iterix < $tsize; ++$iterix) { + for (++$iterix; $iterix < $tsize->[1]; ++$iterix) { next unless substr($$self[0], $iterix * $rlen, 1) eq "\2"; $$self[6] = $iterix; return substr($$self[0], $iterix * $rlen + 1, $klen); @@ -138,42 +150,57 @@ sub NEXTKEY { undef; } +sub EXISTS { + croak "Tie::SubstrHash does not support exists()"; +} + sub hashkey { - croak(qq/Key "$key" is not $klen characters long.\n/) + croak(qq/Key "$key" is not $klen characters long/) if length($key) != $klen; $hash = 2; for (unpack('C*', $key)) { $hash = $hash * 33 + $_; &_hashwrap if $hash >= 1e13; } - &_hashwrap if $hash >= $tsize; + &_hashwrap if $hash >= $tsize->[1]; $hash = 1 unless $hash; $hashbase = $hash; } sub _hashwrap { - $hash -= int($hash / $tsize) * $tsize; + $hash -= int($hash / $tsize->[1]) * $tsize->[1]; } sub rehash { $hash += $hashbase; - $hash -= $tsize if $hash >= $tsize; + $hash -= $tsize->[1] if $hash >= $tsize->[1]; } -sub findprime { +# using POSIX::ceil() would be too heavy, and not all platforms have it. +sub ceil { + my $num = shift; + $num = int($num + 1) unless $num == int $num; + return $num; +} + +sub findgteprime { # find the smallest prime integer greater than or equal to use integer; - my $num = shift; - $num++ unless $num % 2; +# It may be sufficient (and more efficient, IF IT IS CORRECT) to use +# $max = 1 + int sqrt $num and calculate it once only, but is it correct? + + my $num = ceil(shift); + return 2 if $num <= 2; - $max = int sqrt $num; + $num++ unless $num % 2; NUM: for (;; $num += 2) { - for ($i = 3; $i <= $max; $i += 2) { - next NUM unless $num % $i; - } - return $num; + my $max = int sqrt $num; + for ($i = 3; $i <= $max; $i += 2) { + next NUM unless $num % $i; + } + return $num; } } diff --git a/lib/Time/Local.pm b/lib/Time/Local.pm index a480884..9c81209 100644 --- a/lib/Time/Local.pm +++ b/lib/Time/Local.pm @@ -2,23 +2,25 @@ package Time::Local; require 5.000; require Exporter; use Carp; +use strict; -@ISA = qw( Exporter ); -@EXPORT = qw( timegm timelocal ); -@EXPORT_OK = qw( timegm_nocheck timelocal_nocheck ); +our $VERSION = '1.00'; +our @ISA = qw( Exporter ); +our @EXPORT = qw( timegm timelocal ); +our @EXPORT_OK = qw( timegm_nocheck timelocal_nocheck ); # Set up constants - $SEC = 1; - $MIN = 60 * $SEC; - $HR = 60 * $MIN; - $DAY = 24 * $HR; +our $SEC = 1; +our $MIN = 60 * $SEC; +our $HR = 60 * $MIN; +our $DAY = 24 * $HR; # Determine breakpoint for rolling century - my $thisYear = (localtime())[5]; - $nextCentury = int($thisYear / 100) * 100; - $breakpoint = ($thisYear + 50) % 100; - $nextCentury += 100 if $breakpoint < 50; + my $ThisYear = (localtime())[5]; + my $NextCentury = int($ThisYear / 100) * 100; + my $Breakpoint = ($ThisYear + 50) % 100; + $NextCentury += 100 if $Breakpoint < 50; -my %options; +our(%Options, %Cheat); sub timegm { my (@date) = @_; @@ -26,11 +28,11 @@ sub timegm { $date[5] -= 1900; } elsif ($date[5] >= 0 && $date[5] < 100) { - $date[5] -= 100 if $date[5] > $breakpoint; - $date[5] += $nextCentury; + $date[5] -= 100 if $date[5] > $Breakpoint; + $date[5] += $NextCentury; } - $ym = pack(C2, @date[5,4]); - $cheat = $cheat{$ym} || &cheat(@date); + my $ym = pack('C2', @date[5,4]); + my $cheat = $Cheat{$ym} || &cheat($ym, @date); $cheat + $date[0] * $SEC + $date[1] * $MIN @@ -39,7 +41,7 @@ sub timegm { } sub timegm_nocheck { - local $options{no_range_check} = 1; + local $Options{no_range_check} = 1; &timegm; } @@ -71,59 +73,61 @@ sub timelocal { $tzsec += $HR if($lt[8]); - $time = $t + $tzsec; - @test = localtime($time + ($tt - $t)); + my $time = $t + $tzsec; + my @test = localtime($time + ($tt - $t)); $time -= $HR if $test[2] != $_[2]; $time; } sub timelocal_nocheck { - local $options{no_range_check} = 1; + local $Options{no_range_check} = 1; &timelocal; } sub cheat { - $year = $_[5]; - $month = $_[4]; - unless ($options{no_range_check}) { + my($ym, @date) = @_; + my($sec, $min, $hour, $day, $month, $year) = @date; + unless ($Options{no_range_check}) { croak "Month '$month' out of range 0..11" if $month > 11 || $month < 0; - croak "Day '$_[3]' out of range 1..31" if $_[3] > 31 || $_[3] < 1; - croak "Hour '$_[2]' out of range 0..23" if $_[2] > 23 || $_[2] < 0; - croak "Minute '$_[1]' out of range 0..59" if $_[1] > 59 || $_[1] < 0; - croak "Second '$_[0]' out of range 0..59" if $_[0] > 59 || $_[0] < 0; + croak "Day '$day' out of range 1..31" if $day > 31 || $day < 1; + croak "Hour '$hour' out of range 0..23" if $hour > 23 || $hour < 0; + croak "Minute '$min' out of range 0..59" if $min > 59 || $min < 0; + croak "Second '$sec' out of range 0..59" if $sec > 59 || $sec < 0; } - $guess = $^T; - @g = gmtime($guess); - $lastguess = ""; - $counter = 0; - while ($diff = $year - $g[5]) { - croak "Can't handle date (".join(", ",@_).")" if ++$counter > 255; + my $guess = $^T; + my @g = gmtime($guess); + my $lastguess = ""; + my $counter = 0; + while (my $diff = $year - $g[5]) { + my $thisguess; + croak "Can't handle date (".join(", ",@date).")" if ++$counter > 255; $guess += $diff * (363 * $DAY); @g = gmtime($guess); if (($thisguess = "@g") eq $lastguess){ - croak "Can't handle date (".join(", ",@_).")"; + croak "Can't handle date (".join(", ",@date).")"; #date beyond this machine's integer limit } $lastguess = $thisguess; } - while ($diff = $month - $g[4]) { - croak "Can't handle date (".join(", ",@_).")" if ++$counter > 255; + while (my $diff = $month - $g[4]) { + my $thisguess; + croak "Can't handle date (".join(", ",@date).")" if ++$counter > 255; $guess += $diff * (27 * $DAY); @g = gmtime($guess); if (($thisguess = "@g") eq $lastguess){ - croak "Can't handle date (".join(", ",@_).")"; + croak "Can't handle date (".join(", ",@date).")"; #date beyond this machine's integer limit } $lastguess = $thisguess; } - @gfake = gmtime($guess-1); #still being sceptic + my @gfake = gmtime($guess-1); #still being sceptic if ("@gfake" eq $lastguess){ - croak "Can't handle date (".join(", ",@_).")"; + croak "Can't handle date (".join(", ",@date).")"; #date beyond this machine's integer limit } $g[3]--; $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAY; - $cheat{$ym} = $guess; + $Cheat{$ym} = $guess; } 1; diff --git a/lib/Time/tm.pm b/lib/Time/tm.pm index fd47ad1..2c308eb 100644 --- a/lib/Time/tm.pm +++ b/lib/Time/tm.pm @@ -1,6 +1,8 @@ package Time::tm; use strict; +our $VERSION = '1.00'; + use Class::Struct qw(struct); struct('Time::tm' => [ map { $_ => '$' } qw{ sec min hour mday mon year wday yday isdst } diff --git a/lib/UNIVERSAL.pm b/lib/UNIVERSAL.pm index f2f1fe9..a66f8d5 100644 --- a/lib/UNIVERSAL.pm +++ b/lib/UNIVERSAL.pm @@ -1,5 +1,7 @@ package UNIVERSAL; +our $VERSION = '1.00'; + # UNIVERSAL should not contain any extra subs/methods beyond those # that it exists to define. The use of Exporter below is a historical # accident that should be fixed sometime. diff --git a/lib/User/grent.pm b/lib/User/grent.pm index 95e4189..fd6fe56 100644 --- a/lib/User/grent.pm +++ b/lib/User/grent.pm @@ -2,6 +2,7 @@ package User::grent; use strict; use 5.005_64; +our $VERSION = '1.00'; our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); diff --git a/lib/User/pwent.pm b/lib/User/pwent.pm index 8c05926..edd5f51 100644 --- a/lib/User/pwent.pm +++ b/lib/User/pwent.pm @@ -1,6 +1,7 @@ package User::pwent; use 5.006; +our $VERSION = '1.00'; use strict; use warnings; diff --git a/lib/Win32.pod b/lib/Win32.pod index 64361f8..842e484 100644 --- a/lib/Win32.pod +++ b/lib/Win32.pod @@ -175,7 +175,9 @@ function. system boot. Resolution is limited to system timer ticks (about 10ms on WinNT and 55ms on Win9X). -=item Win32::InitiateSystemShutdown(MACHINE, MESSAGE, TIMEOUT, FORCECLOSE, REBOOT) +=item Win32::InitiateSystemShutdown + +(MACHINE, MESSAGE, TIMEOUT, FORCECLOSE, REBOOT) [EXT] Shutsdown the specified MACHINE, notifying users with the supplied MESSAGE, within the specified TIMEOUT interval. Forces diff --git a/lib/bytes.pm b/lib/bytes.pm index f2f7e01..3b0268e 100644 --- a/lib/bytes.pm +++ b/lib/bytes.pm @@ -1,5 +1,7 @@ package bytes; +our $VERSION = '1.00'; + $bytes::hint_bits = 0x00000008; sub import { diff --git a/lib/charnames.pm b/lib/charnames.pm index 0ec7ec2..934fafd 100644 --- a/lib/charnames.pm +++ b/lib/charnames.pm @@ -1,4 +1,7 @@ package charnames; + +our $VERSION = '1.00'; + use bytes (); # for $bytes::hint_bits use warnings(); $charnames::hint_bits = 0x20000; diff --git a/lib/constant.pm b/lib/constant.pm index 72ad793..1e07a68 100644 --- a/lib/constant.pm +++ b/lib/constant.pm @@ -28,75 +28,93 @@ my %forbidden = (%keywords, %forced_into_main); sub import { my $class = shift; return unless @_; # Ignore 'use constant;' - my $name = shift; - unless (defined $name) { - require Carp; - Carp::croak("Can't use undef as constant name"); + my %constants = (); + my $multiple = ref $_[0]; + + if ( $multiple ) { + if (ref $_[0] ne 'HASH') { + require Carp; + Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'"); + } + %constants = %{+shift}; + } else { + $constants{+shift} = undef; } - my $pkg = caller; - - # Normal constant name - if ($name =~ /^_?[^\W_0-9]\w*\z/ and !$forbidden{$name}) { - # Everything is okay - - # Name forced into main, but we're not in main. Fatal. - } elsif ($forced_into_main{$name} and $pkg ne 'main') { - require Carp; - Carp::croak("Constant name '$name' is forced into main::"); - - # Starts with double underscore. Fatal. - } elsif ($name =~ /^__/) { - require Carp; - Carp::croak("Constant name '$name' begins with '__'"); - - # Maybe the name is tolerable - } elsif ($name =~ /^[A-Za-z_]\w*\z/) { - # Then we'll warn only if you've asked for warnings - if (warnings::enabled()) { - if ($keywords{$name}) { - warnings::warn("Constant name '$name' is a Perl keyword"); - } elsif ($forced_into_main{$name}) { - warnings::warn("Constant name '$name' is " . - "forced into package main::"); + + foreach my $name ( keys %constants ) { + unless (defined $name) { + require Carp; + Carp::croak("Can't use undef as constant name"); + } + my $pkg = caller; + + # Normal constant name + if ($name =~ /^_?[^\W_0-9]\w*\z/ and !$forbidden{$name}) { + # Everything is okay + + # Name forced into main, but we're not in main. Fatal. + } elsif ($forced_into_main{$name} and $pkg ne 'main') { + require Carp; + Carp::croak("Constant name '$name' is forced into main::"); + + # Starts with double underscore. Fatal. + } elsif ($name =~ /^__/) { + require Carp; + Carp::croak("Constant name '$name' begins with '__'"); + + # Maybe the name is tolerable + } elsif ($name =~ /^[A-Za-z_]\w*\z/) { + # Then we'll warn only if you've asked for warnings + if (warnings::enabled()) { + if ($keywords{$name}) { + warnings::warn("Constant name '$name' is a Perl keyword"); + } elsif ($forced_into_main{$name}) { + warnings::warn("Constant name '$name' is " . + "forced into package main::"); + } else { + # Catch-all - what did I miss? If you get this error, + # please let me know what your constant's name was. + # Write to . Thanks! + warnings::warn("Constant name '$name' has unknown problems"); + } + } + + # Looks like a boolean + # use constant FRED == fred; + } elsif ($name =~ /^[01]?\z/) { + require Carp; + if (@_) { + Carp::croak("Constant name '$name' is invalid"); } else { - # Catch-all - what did I miss? If you get this error, - # please let me know what your constant's name was. - # Write to . Thanks! - warnings::warn("Constant name '$name' has unknown problems"); + Carp::croak("Constant name looks like boolean value"); } - } - # Looks like a boolean - # use constant FRED == fred; - } elsif ($name =~ /^[01]?\z/) { - require Carp; - if (@_) { - Carp::croak("Constant name '$name' is invalid"); } else { - Carp::croak("Constant name looks like boolean value"); + # Must have bad characters + require Carp; + Carp::croak("Constant name '$name' has invalid characters"); } - } else { - # Must have bad characters - require Carp; - Carp::croak("Constant name '$name' has invalid characters"); - } - - { - no strict 'refs'; - my $full_name = "${pkg}::$name"; - $declared{$full_name}++; - if (@_ == 1) { - my $scalar = $_[0]; - *$full_name = sub () { $scalar }; - } elsif (@_) { - my @list = @_; - *$full_name = sub () { @list }; - } else { - *$full_name = sub () { }; + { + no strict 'refs'; + my $full_name = "${pkg}::$name"; + $declared{$full_name}++; + if ($multiple) { + my $scalar = $constants{$name}; + *$full_name = sub () { $scalar }; + } else { + if (@_ == 1) { + my $scalar = $_[0]; + *$full_name = sub () { $scalar }; + } elsif (@_) { + my @list = @_; + *$full_name = sub () { @list }; + } else { + *$full_name = sub () { }; + } + } } } - } 1; @@ -133,6 +151,17 @@ constant - Perl pragma to declare constants print CCODE->("me"); print CHASH->[10]; # compile-time error + # declaring multiple constants at once + use constant { + BUFFER_SIZE => 4096, + ONE_YEAR => 365.2425 * 24 * 60 * 60, + PI => 4 * atan2( 1, 1 ), + DEBUGGING => 0, + ORACLE => 'oracle@cs.indiana.edu', + USERNAME => scalar getpwuid($<), + USERINFO => getpwuid($<), + }; + =head1 DESCRIPTION This will declare a symbol to be a constant with the given scalar @@ -176,14 +205,26 @@ Other as C. As with all C directives, defining a constant happens at compile time. Thus, it's probably not correct to put a constant declaration inside of a conditional statement (like C). +{ use constant ... }>). When defining multiple constants, you +cannot use the values of other constants within the same declaration +scope. This is because the calling package doesn't know about any +constant within that group until I the C statement is +finished. + + use constant { + AGE => 20, + PERSON => { age => AGE }, # Error! + }; + [...] + use constant PERSON => { age => AGE }; # Right Omitting the value for a symbol gives it the value of C in a scalar context or the empty list, C<()>, in a list context. This isn't so nice as it may sound, though, because in this case you must either quote the symbol name, or use a big arrow, (C<=E>), -with nothing to point to. It is probably best to declare these -explicitly. +with nothing to point to. It is also illegal to do when defining +multiple constants at once, you must declare them explicitly. It +is probably best to declare these explicitly. use constant UNICORNS => (); use constant LOGFILE => undef; @@ -206,6 +247,11 @@ Dereferencing constant references incorrectly (such as using an array subscript on a constant hash reference, or vice versa) will be trapped at compile time. +When declaring multiple constants, all constant values will be a scalar. +This is because C can't guess the intent of the programmer +correctly all the time since values must be expressed in scalar context +within a hash ref. + In the rare case in which you need to discover at run time whether a particular constant has been declared via this module, you may use this function to examine the hash C<%constant::declared>. If the given @@ -268,6 +314,9 @@ C 'value'>. Tom Phoenix, EFE, with help from many other folks. +Multiple constant declarations at once added by Casey Tweten, +EFE. + =head1 COPYRIGHT Copyright (C) 1997, 1999 Tom Phoenix diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index 884ea3c..f3e60f5 100755 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -171,7 +171,7 @@ use strict; use 5.005_64; use Carp; -our $VERSION = v1.0; +our $VERSION = 1.0; our $DEBUG; our $VERBOSE; our $PRETTY; diff --git a/lib/filetest.pm b/lib/filetest.pm index b52a9b4..21252f3 100644 --- a/lib/filetest.pm +++ b/lib/filetest.pm @@ -1,5 +1,7 @@ package filetest; +our $VERSION = '1.00'; + =head1 NAME filetest - Perl pragma to control the filetest permission operators diff --git a/lib/ftp.pl b/lib/ftp.pl index aa6a489..3f0af1a 100644 --- a/lib/ftp.pl +++ b/lib/ftp.pl @@ -74,7 +74,7 @@ # No longer call die expect on fatal errors. Just return fail codes. # Changed returns so higher up routines can tell whats happening. # Get expect/accept in correct order for dir listing. -# When ftp_show is set then print hashes every 1k transfered (like ftp). +# When ftp_show is set then print hashes every 1k transferred (like ftp). # Allow for stripping returns out of incoming data. # Save last error in a global string. # diff --git a/lib/integer.pm b/lib/integer.pm index 86afcaf..f019fb3 100644 --- a/lib/integer.pm +++ b/lib/integer.pm @@ -1,5 +1,7 @@ package integer; +our $VERSION = '1.00'; + =head1 NAME integer - Perl pragma to compute arithmetic in integer instead of double diff --git a/lib/less.pm b/lib/less.pm index b3afef0..de0ac8f 100644 --- a/lib/less.pm +++ b/lib/less.pm @@ -1,5 +1,7 @@ package less; +our $VERSION = '0.01'; + =head1 NAME less - perl pragma to request less of something from the compiler diff --git a/lib/lib_pm.PL b/lib/lib_pm.PL index bb02106..66b4944 100644 --- a/lib/lib_pm.PL +++ b/lib/lib_pm.PL @@ -8,10 +8,30 @@ chdir dirname($0); my $file = basename($0, '.PL'); $file =~ s!_(pm)$!.$1!i; -my $Config_archname = defined($Config{'archname'}) ? $Config{'archname'} : ''; -my $Config_ver = defined($Config{'version'}) ? $Config{'version'} : ''; -my @Config_inc_version_list = defined($Config{'inc_version_list'}) ? - reverse split / /, $Config{'inc_version_list'} : (); +my $useConfig; +my $Config_archname; +my $Config_version; +my $Config_inc_version_list; + +# Expand the variables only if explicitly requested because +# otherwise relocating Perl becomes much harder. + +if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS}) { + $useConfig = ''; + $Config_archname = qq('$Config{archname}'); + $Config_version = qq('$Config{version}'); + my @Config_inc_version_list = + reverse split / /, $Config{inc_version_list}; + $Config_inc_version_list = + @Config_inc_version_list ? + qq(@Config_inc_version_list) : q(()); +} else { + $useConfig = 'use Config;'; + $Config_archname = q($Config{archname}); + $Config_version = q($Config{version}); + $Config_inc_version_list = + q(reverse split / /, qw($Config{inc_version_list})); +} open OUT,">$file" or die "Can't create $file: $!"; @@ -26,9 +46,11 @@ package lib; # THIS FILE IS AUTOMATICALLY GENERATED FROM lib_pm.PL. # ANY CHANGES TO THIS FILE WILL BE OVERWRITTEN BY THE NEXT PERL BUILD. -my \$archname = "$Config_archname"; -my \$ver = "$Config_ver"; -my \@inc_version_list = qw(@Config_inc_version_list); +$useConfig + +my \$archname = $Config_archname; +my \$version = $Config_version; +my \@inc_version_list = $Config_inc_version_list; !GROK!THIS! print OUT <<'!NO!SUBS!'; @@ -57,9 +79,9 @@ sub import { } # Put a corresponding archlib directory infront of $_ if it # looks like $_ has an archlib directory below it. - unshift(@INC, "$_/$archname") if -d "$_/$archname/auto"; - unshift(@INC, "$_/$ver") if -d "$_/$ver"; - unshift(@INC, "$_/$ver/$archname") if -d "$_/$ver/$archname"; + unshift(@INC, "$_/$archname") if -d "$_/$archname/auto"; + unshift(@INC, "$_/$version") if -d "$_/$version"; + unshift(@INC, "$_/$version/$archname") if -d "$_/$version/$archname"; } # remove trailing duplicates @@ -74,9 +96,9 @@ sub unimport { my %names; foreach (@_) { ++$names{$_}; - ++$names{"$_/$archname"} if -d "$_/$archname/auto"; - ++$names{"$_/$ver"} if -d "$_/$ver"; - ++$names{"$_/$ver/$archname"} if -d "$_/$ver/$archname"; + ++$names{"$_/$archname"} if -d "$_/$archname/auto"; + ++$names{"$_/$version"} if -d "$_/$version"; + ++$names{"$_/$version/$archname"} if -d "$_/$version/$archname"; } # Remove ALL instances of each named directory. diff --git a/lib/locale.pm b/lib/locale.pm index 6314aca..3e5054c 100644 --- a/lib/locale.pm +++ b/lib/locale.pm @@ -1,5 +1,7 @@ package locale; +our $VERSION = '1.00'; + =head1 NAME locale - Perl pragma to use and avoid POSIX locales for built-in operations diff --git a/lib/open.pm b/lib/open.pm index cdd20ac..1e073c2 100644 --- a/lib/open.pm +++ b/lib/open.pm @@ -1,23 +1,45 @@ package open; +use Carp; $open::hint_bits = 0x20000; +use vars qw(%layers @layers); + +# Populate hash in non-PerlIO case +%layers = (crlf => 1, raw => 0) unless (@layers); + +our $VERSION = '1.00'; + sub import { shift; die "`use open' needs explicit list of disciplines" unless @_; $^H |= $open::hint_bits; + my ($in,$out) = split(/\0/,(${^OPEN} || '\0')); + my @in = split(/\s+/,$in); + my @out = split(/\s+/,$out); while (@_) { my $type = shift; - if ($type =~ /^(IN|OUT)\z/s) { - my $discp = shift; - unless ($discp =~ /^\s*:(raw|crlf)\s*\z/s) { - die "Unknown discipline '$discp'"; + my $discp = shift; + my @val; + foreach my $layer (split(/\s+:?/,$discp)) { + unless(exists $layers{$layer}) { + croak "Unknown discipline layer '$layer'"; } - $^H{"open_$type"} = $discp; + push(@val,":$layer"); + if ($layer =~ /^(crlf|raw)$/) { + $^H{"open_$type"} = $layer; + } + } + if ($type eq 'IN') { + $in = join(' ',@val); + } + elsif ($type eq 'OUT') { + $out = join(' ',@val); } else { - die "Unknown discipline class '$type'"; + croak "Unknown discipline class '$type'"; } } + ${^OPEN} = join('\0',$in,$out); } 1; diff --git a/lib/overload.pm b/lib/overload.pm index 2b0b99d..69092a0 100644 --- a/lib/overload.pm +++ b/lib/overload.pm @@ -1,5 +1,7 @@ package overload; +our $VERSION = '1.00'; + $overload::hint_bits = 0x20000; sub nil {} diff --git a/lib/perl5db.pl b/lib/perl5db.pl index fb6d683..63b4381 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -25,7 +25,7 @@ $header = "perl5db.pl version $VERSION"; # if caller() is called from the package DB, it provides some # additional data. # -# The array @{$main::{'_<'.$filename} is the line-by-line contents of +# The array @{$main::{'_<'.$filename}} is the line-by-line contents of # $filename. # # The hash %{'_<'.$filename} contains breakpoints and action (it is @@ -401,6 +401,12 @@ if ($notty) { $console = "/dev/tty"; } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') { $console = "con"; + } elsif ($^O eq 'MacOS') { + if ($MacPerl::Version !~ /MPW/) { + $console = "Dev:Console:Perl Debug"; # Separate window for application + } else { + $console = "Dev:Console"; + } } else { $console = "sys\$command"; } diff --git a/lib/perlio.pm b/lib/perlio.pm new file mode 100644 index 0000000..48acfbb --- /dev/null +++ b/lib/perlio.pm @@ -0,0 +1,87 @@ +package perlio; +1; +__END__ + +=head1 NAME + +perlio - perl pragma to configure C level IO + +=head1 SYNOPSIS + + Shell: + PERLIO=perlio perl .... + + print "Have ",join(',',keys %perlio::layers),"\n"; + print "Using ",join(',',@perlio::layers),"\n"; + + +=head1 DESCRIPTION + +Mainly a Place holder for now. + +The C<%perlio::layers> hash is a record of the available "layers" that may be pushed +onto a C stream. + +The C<@perlio::layers> array is the current set of layers that are used when +a new C stream is opened. The C code looks are the array each time +a stream is opened so the "stack" can be manipulated by messing with the array : + + pop(@perlio::layers); + push(@perlio::layers,$perlio::layers{'stdio'}); + +The values if both the hash and the array are perl objects, of class C +which are created by the C code in C. As yet there is nothing useful you +can do with the objects at the perl level. + +There are three layers currently defined: + +=over 4 + +=item unix + +Low level layer which calls C, C and C etc. + +=item stdio + +Layer which calls C, C and C/C etc. +Note that as this is "real" stdio it will ignore any layers beneath it and +got straight to the operating system via the C library as usual. + +=item perlio + +This is a re-implementation of "stdio-like" buffering written as a PerlIO "layer". +As such it will call whatever layer is below it for its operations. + +=back + +=head2 Defaults and how to override them + +If C found out how to do "fast" IO using system's stdio, then +the default layers are : + + unix stdio + +Otherwise the default layers are + + unix perlio + +(STDERR will have just unix in this case as that is optimal way to make it +"unbuffered" - do not add a buffering layer!) + +The default may change once perlio has been better tested and tuned. + +The default can be overridden by setting the environment variable PERLIO +to a space separated list of layers (unix is always pushed first). +This can be used to see the effect of/bugs in the various layers e.g. + + cd .../perl/t + PERLIO=stdio ./perl harness + PERLIO=perlio ./perl harness + +=head1 AUTHOR + +Nick Ing-Simmons Enick@ing-simmons.netE + +=cut + + diff --git a/lib/strict.pm b/lib/strict.pm index 042227f..8afb9a3 100644 --- a/lib/strict.pm +++ b/lib/strict.pm @@ -37,6 +37,14 @@ use symbolic references (see L). $file = "STDOUT"; print $file "Hi!"; # error; note: no comma after $file +There is one exception to this rule: + + $bar = \&{'foo'}; + &$bar; + +is allowed so that C would not break under stricture. + + =item C This generates a compile-time error if you access a variable that wasn't diff --git a/lib/subs.pm b/lib/subs.pm index aa332a6..e5a9aa8 100644 --- a/lib/subs.pm +++ b/lib/subs.pm @@ -1,5 +1,7 @@ package subs; +our $VERSION = '1.00'; + =head1 NAME subs - Perl pragma to predeclare sub names diff --git a/lib/unicode/Is/Alnum.pl b/lib/unicode/Is/Alnum.pl index 94f9a5c..a0aac62 100644 --- a/lib/unicode/Is/Alnum.pl +++ b/lib/unicode/Is/Alnum.pl @@ -6,13 +6,23 @@ return <<'END'; 0041 005a 0061 007a 00aa +00b2 00b3 00b5 -00ba +00b9 00ba +00bc 00be 00c0 00d6 00d8 00f6 00f8 021f 0222 0233 0250 02ad +02b0 02b8 +02bb 02c1 +02d0 02d1 +02e0 02e4 +02ee +0300 034e +0360 0362 +037a 0386 0388 038a 038c @@ -21,38 +31,57 @@ return <<'END'; 03d0 03d7 03da 03f3 0400 0481 +0483 0486 +0488 0489 048c 04c4 04c7 04c8 04cb 04cc 04d0 04f5 04f8 04f9 0531 0556 +0559 0561 0587 +0591 05a1 +05a3 05b9 +05bb 05bd +05bf +05c1 05c2 +05c4 05d0 05ea 05f0 05f2 0621 063a -0641 064a +0640 0655 0660 0669 -0671 06d3 -06d5 +0670 06d3 +06d5 06e8 +06ea 06ed 06f0 06fc -0710 -0712 072c -0780 07a5 +0710 072c +0730 074a +0780 07b0 +0901 0903 0905 0939 -093d -0950 -0958 0961 +093c 094d +0950 0954 +0958 0963 0966 096f +0981 0983 0985 098c 098f 0990 0993 09a8 09aa 09b0 09b2 09b6 09b9 +09bc +09be 09c4 +09c7 09c8 +09cb 09cd +09d7 09dc 09dd -09df 09e1 +09df 09e3 09e6 09f1 +09f4 09f9 +0a02 0a05 0a0a 0a0f 0a10 0a13 0a28 @@ -60,10 +89,14 @@ return <<'END'; 0a32 0a33 0a35 0a36 0a38 0a39 +0a3c +0a3e 0a42 +0a47 0a48 +0a4b 0a4d 0a59 0a5c 0a5e -0a66 0a6f -0a72 0a74 +0a66 0a74 +0a81 0a83 0a85 0a8b 0a8d 0a8f 0a91 @@ -71,20 +104,27 @@ return <<'END'; 0aaa 0ab0 0ab2 0ab3 0ab5 0ab9 -0abd +0abc 0ac5 +0ac7 0ac9 +0acb 0acd 0ad0 0ae0 0ae6 0aef +0b01 0b03 0b05 0b0c 0b0f 0b10 0b13 0b28 0b2a 0b30 0b32 0b33 0b36 0b39 -0b3d +0b3c 0b43 +0b47 0b48 +0b4b 0b4d +0b56 0b57 0b5c 0b5d 0b5f 0b61 0b66 0b6f +0b82 0b83 0b85 0b8a 0b8e 0b90 0b92 0b95 @@ -95,36 +135,60 @@ return <<'END'; 0ba8 0baa 0bae 0bb5 0bb7 0bb9 -0be7 0bef +0bbe 0bc2 +0bc6 0bc8 +0bca 0bcd +0bd7 +0be7 0bf2 +0c01 0c03 0c05 0c0c 0c0e 0c10 0c12 0c28 0c2a 0c33 0c35 0c39 +0c3e 0c44 +0c46 0c48 +0c4a 0c4d +0c55 0c56 0c60 0c61 0c66 0c6f +0c82 0c83 0c85 0c8c 0c8e 0c90 0c92 0ca8 0caa 0cb3 0cb5 0cb9 +0cbe 0cc4 +0cc6 0cc8 +0cca 0ccd +0cd5 0cd6 0cde 0ce0 0ce1 0ce6 0cef +0d02 0d03 0d05 0d0c 0d0e 0d10 0d12 0d28 0d2a 0d39 +0d3e 0d43 +0d46 0d48 +0d4a 0d4d +0d57 0d60 0d61 0d66 0d6f +0d82 0d83 0d85 0d96 0d9a 0db1 0db3 0dbb 0dbd 0dc0 0dc6 -0e01 0e30 -0e32 0e33 -0e40 0e45 +0dca +0dcf 0dd4 +0dd6 +0dd8 0ddf +0df2 0df3 +0e01 0e3a +0e40 0e4e 0e50 0e59 0e81 0e82 0e84 @@ -137,22 +201,33 @@ return <<'END'; 0ea5 0ea7 0eaa 0eab -0ead 0eb0 -0eb2 0eb3 -0ebd +0ead 0eb9 +0ebb 0ebd 0ec0 0ec4 +0ec6 +0ec8 0ecd 0ed0 0ed9 0edc 0edd 0f00 -0f20 0f29 -0f40 0f47 +0f18 0f19 +0f20 0f33 +0f35 +0f37 +0f39 +0f3e 0f47 0f49 0f6a -0f88 0f8b +0f71 0f84 +0f86 0f8b +0f90 0f97 +0f99 0fbc +0fc6 1000 1021 1023 1027 1029 102a +102c 1032 +1036 1039 1040 1049 -1050 1055 +1050 1059 10a0 10c5 10d0 10f6 1100 1159 @@ -183,18 +258,18 @@ return <<'END'; 1318 131e 1320 1346 1348 135a -1369 1371 +1369 137c 13a0 13f4 1401 166c 166f 1676 1681 169a 16a0 16ea -1780 17b3 +16ee 16f0 +1780 17d3 17e0 17e9 1810 1819 -1820 1842 -1844 1877 -1880 18a8 +1820 1877 +1880 18a9 1e00 1e9b 1ea0 1ef9 1f00 1f15 @@ -216,7 +291,10 @@ return <<'END'; 1fe0 1fec 1ff2 1ff4 1ff6 1ffc -207f +2070 +2074 2079 +207f 2089 +20d0 20e3 2102 2107 210a 2113 @@ -228,12 +306,25 @@ return <<'END'; 212a 212d 212f 2131 2133 2139 -3006 +2153 2183 +2460 249b +24ea +2776 2793 +3005 3007 +3021 302f +3031 3035 +3038 303a 3041 3094 +3099 309a +309d 309e 30a1 30fa +30fc 30fe 3105 312c 3131 318e +3192 3195 31a0 31b7 +3220 3229 +3280 3289 3400 4db5 4e00 9fa5 a000 a48c @@ -241,8 +332,7 @@ ac00 d7a3 f900 fa2d fb00 fb06 fb13 fb17 -fb1d -fb1f fb28 +fb1d fb28 fb2a fb36 fb38 fb3c fb3e @@ -253,15 +343,14 @@ fbd3 fd3d fd50 fd8f fd92 fdc7 fdf0 fdfb +fe20 fe23 fe70 fe72 fe74 fe76 fefc ff10 ff19 ff21 ff3a ff41 ff5a -ff66 ff6f -ff71 ff9d -ffa0 ffbe +ff66 ffbe ffc2 ffc7 ffca ffcf ffd2 ffd7 diff --git a/lib/unicode/Is/Alpha.pl b/lib/unicode/Is/Alpha.pl index de5046f..13dc003 100644 --- a/lib/unicode/Is/Alpha.pl +++ b/lib/unicode/Is/Alpha.pl @@ -12,6 +12,14 @@ return <<'END'; 00f8 021f 0222 0233 0250 02ad +02b0 02b8 +02bb 02c1 +02d0 02d1 +02e0 02e4 +02ee +0300 034e +0360 0362 +037a 0386 0388 038a 038c @@ -20,36 +28,54 @@ return <<'END'; 03d0 03d7 03da 03f3 0400 0481 +0483 0486 +0488 0489 048c 04c4 04c7 04c8 04cb 04cc 04d0 04f5 04f8 04f9 0531 0556 +0559 0561 0587 +0591 05a1 +05a3 05b9 +05bb 05bd +05bf +05c1 05c2 +05c4 05d0 05ea 05f0 05f2 0621 063a -0641 064a -0671 06d3 -06d5 +0640 0655 +0670 06d3 +06d5 06e8 +06ea 06ed 06fa 06fc -0710 -0712 072c -0780 07a5 +0710 072c +0730 074a +0780 07b0 +0901 0903 0905 0939 -093d -0950 -0958 0961 +093c 094d +0950 0954 +0958 0963 +0981 0983 0985 098c 098f 0990 0993 09a8 09aa 09b0 09b2 09b6 09b9 +09bc +09be 09c4 +09c7 09c8 +09cb 09cd +09d7 09dc 09dd -09df 09e1 +09df 09e3 09f0 09f1 +0a02 0a05 0a0a 0a0f 0a10 0a13 0a28 @@ -57,9 +83,14 @@ return <<'END'; 0a32 0a33 0a35 0a36 0a38 0a39 +0a3c +0a3e 0a42 +0a47 0a48 +0a4b 0a4d 0a59 0a5c 0a5e -0a72 0a74 +0a70 0a74 +0a81 0a83 0a85 0a8b 0a8d 0a8f 0a91 @@ -67,18 +98,25 @@ return <<'END'; 0aaa 0ab0 0ab2 0ab3 0ab5 0ab9 -0abd +0abc 0ac5 +0ac7 0ac9 +0acb 0acd 0ad0 0ae0 +0b01 0b03 0b05 0b0c 0b0f 0b10 0b13 0b28 0b2a 0b30 0b32 0b33 0b36 0b39 -0b3d +0b3c 0b43 +0b47 0b48 +0b4b 0b4d +0b56 0b57 0b5c 0b5d 0b5f 0b61 +0b82 0b83 0b85 0b8a 0b8e 0b90 0b92 0b95 @@ -89,32 +127,56 @@ return <<'END'; 0ba8 0baa 0bae 0bb5 0bb7 0bb9 +0bbe 0bc2 +0bc6 0bc8 +0bca 0bcd +0bd7 +0c01 0c03 0c05 0c0c 0c0e 0c10 0c12 0c28 0c2a 0c33 0c35 0c39 +0c3e 0c44 +0c46 0c48 +0c4a 0c4d +0c55 0c56 0c60 0c61 +0c82 0c83 0c85 0c8c 0c8e 0c90 0c92 0ca8 0caa 0cb3 0cb5 0cb9 +0cbe 0cc4 +0cc6 0cc8 +0cca 0ccd +0cd5 0cd6 0cde 0ce0 0ce1 +0d02 0d03 0d05 0d0c 0d0e 0d10 0d12 0d28 0d2a 0d39 +0d3e 0d43 +0d46 0d48 +0d4a 0d4d +0d57 0d60 0d61 +0d82 0d83 0d85 0d96 0d9a 0db1 0db3 0dbb 0dbd 0dc0 0dc6 -0e01 0e30 -0e32 0e33 -0e40 0e45 +0dca +0dcf 0dd4 +0dd6 +0dd8 0ddf +0df2 0df3 +0e01 0e3a +0e40 0e4e 0e81 0e82 0e84 0e87 0e88 @@ -126,19 +188,30 @@ return <<'END'; 0ea5 0ea7 0eaa 0eab -0ead 0eb0 -0eb2 0eb3 -0ebd +0ead 0eb9 +0ebb 0ebd 0ec0 0ec4 +0ec6 +0ec8 0ecd 0edc 0edd 0f00 -0f40 0f47 +0f18 0f19 +0f35 +0f37 +0f39 +0f3e 0f47 0f49 0f6a -0f88 0f8b +0f71 0f84 +0f86 0f8b +0f90 0f97 +0f99 0fbc +0fc6 1000 1021 1023 1027 1029 102a -1050 1055 +102c 1032 +1036 1039 +1050 1059 10a0 10c5 10d0 10f6 1100 1159 @@ -174,10 +247,9 @@ return <<'END'; 166f 1676 1681 169a 16a0 16ea -1780 17b3 -1820 1842 -1844 1877 -1880 18a8 +1780 17d3 +1820 1877 +1880 18a9 1e00 1e9b 1ea0 1ef9 1f00 1f15 @@ -200,6 +272,7 @@ return <<'END'; 1ff2 1ff4 1ff6 1ffc 207f +20d0 20e3 2102 2107 210a 2113 @@ -211,9 +284,14 @@ return <<'END'; 212a 212d 212f 2131 2133 2139 -3006 +3005 3006 +302a 302f +3031 3035 3041 3094 +3099 309a +309d 309e 30a1 30fa +30fc 30fe 3105 312c 3131 318e 31a0 31b7 @@ -224,8 +302,7 @@ ac00 d7a3 f900 fa2d fb00 fb06 fb13 fb17 -fb1d -fb1f fb28 +fb1d fb28 fb2a fb36 fb38 fb3c fb3e @@ -236,14 +313,13 @@ fbd3 fd3d fd50 fd8f fd92 fdc7 fdf0 fdfb +fe20 fe23 fe70 fe72 fe74 fe76 fefc ff21 ff3a ff41 ff5a -ff66 ff6f -ff71 ff9d -ffa0 ffbe +ff66 ffbe ffc2 ffc7 ffca ffcf ffd2 ffd7 diff --git a/lib/unicode/Is/Blank.pl b/lib/unicode/Is/Blank.pl new file mode 100644 index 0000000..8642921 --- /dev/null +++ b/lib/unicode/Is/Blank.pl @@ -0,0 +1,12 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.301. +# Any changes made here will be lost! +return <<'END'; +0009 +0020 +00a0 +1680 +2000 200b +202f +3000 +END diff --git a/lib/unicode/Is/DCmedial.pl b/lib/unicode/Is/DCmedial.pl new file mode 100644 index 0000000..8778a75 --- /dev/null +++ b/lib/unicode/Is/DCmedial.pl @@ -0,0 +1,59 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.301. +# Any changes made here will be lost! +return <<'END'; +fb55 +fb59 +fb5d +fb61 +fb65 +fb69 +fb6d +fb71 +fb75 +fb79 +fb7d +fb81 +fb91 +fb95 +fb99 +fb9d +fba3 +fba9 +fbad +fbd6 +fbe7 +fbe9 +fbff +fcdf fcf4 +fd34 fd3b +fe71 +fe77 +fe79 +fe7b +fe7d +fe7f +fe8c +fe92 +fe98 +fe9c +fea0 +fea4 +fea8 +feb4 +feb8 +febc +fec0 +fec4 +fec8 +fecc +fed0 +fed4 +fed8 +fedc +fee0 +fee4 +fee8 +feec +fef4 +END diff --git a/lib/unicode/Is/Graph.pl b/lib/unicode/Is/Graph.pl index 40d3506..238cc56 100644 --- a/lib/unicode/Is/Graph.pl +++ b/lib/unicode/Is/Graph.pl @@ -3,7 +3,7 @@ # Any changes made here will be lost! return <<'END'; 0021 007e -00a0 021f +00a1 021f 0222 0233 0250 02ad 02b0 02ee @@ -239,7 +239,7 @@ return <<'END'; 1361 137c 13a0 13f4 1401 1676 -1680 169c +1681 169c 16a0 16f0 1780 17dc 17e0 17e9 @@ -265,10 +265,8 @@ return <<'END'; 1fdd 1fef 1ff2 1ff4 1ff6 1ffe -2000 2008 -200b -2010 2029 -202f 2046 +2010 2027 +2030 2046 2048 204d 2070 2074 208e @@ -304,7 +302,7 @@ return <<'END'; 2e9b 2ef3 2f00 2fd5 2ff0 2ffb -3000 303a +3001 303a 303e 303f 3041 3094 3099 309e @@ -330,6 +328,7 @@ a4b5 a4c0 a4c2 a4c4 a4c6 ac00 d7a3 +e000 f8ff f900 fa2d fb00 fb06 fb13 fb17 @@ -360,4 +359,6 @@ ffda ffdc ffe0 ffe6 ffe8 ffee fffc fffd +f0000 ffffd +100000 10fffd END diff --git a/lib/unicode/Is/Print.pl b/lib/unicode/Is/Print.pl index c3adba6..1229a28 100644 --- a/lib/unicode/Is/Print.pl +++ b/lib/unicode/Is/Print.pl @@ -266,7 +266,7 @@ return <<'END'; 1ff2 1ff4 1ff6 1ffe 2000 200b -2010 2029 +2010 2027 202f 2046 2048 204d 2070 @@ -329,6 +329,7 @@ a4b5 a4c0 a4c2 a4c4 a4c6 ac00 d7a3 +e000 f8ff f900 fa2d fb00 fb06 fb13 fb17 @@ -359,4 +360,6 @@ ffda ffdc ffe0 ffe6 ffe8 ffee fffc fffd +f0000 ffffd +100000 10fffd END diff --git a/lib/unicode/Is/Punct.pl b/lib/unicode/Is/Punct.pl index 9e088ba..97330ec 100644 --- a/lib/unicode/Is/Punct.pl +++ b/lib/unicode/Is/Punct.pl @@ -8,45 +8,45 @@ return <<'END'; 003a 003b 003f 0040 005b 005d -005f -007b -007d -00a1 -00ab -00ad -00b7 -00bb -00bf -037e -0387 +005f +007b +007d +00a1 +00ab +00ad +00b7 +00bb +00bf +037e +0387 055a 055f 0589 058a -05be -05c0 -05c3 +05be +05c0 +05c3 05f3 05f4 -060c -061b -061f +060c +061b +061f 066a 066d -06d4 +06d4 0700 070d 0964 0965 -0970 -0df4 -0e4f +0970 +0df4 +0e4f 0e5a 0e5b 0f04 0f12 0f3a 0f3d -0f85 +0f85 104a 104f -10fb +10fb 1361 1368 166d 166e 169b 169c 16eb 16ed 17d4 17da -17dc +17dc 1800 180a 2010 2027 2030 2043 @@ -58,14 +58,14 @@ return <<'END'; 3001 3003 3008 3011 3014 301f -3030 -30fb +3030 +30fb fd3e fd3f fe30 fe44 fe49 fe52 fe54 fe61 -fe63 -fe68 +fe63 +fe68 fe6a fe6b ff01 ff03 ff05 ff0a @@ -73,8 +73,8 @@ ff0c ff0f ff1a ff1b ff1f ff20 ff3b ff3d -ff3f -ff5b -ff5d +ff3f +ff5b +ff5d ff61 ff65 END diff --git a/lib/unicode/Is/Space.pl b/lib/unicode/Is/Space.pl index 1625dce..9971082 100644 --- a/lib/unicode/Is/Space.pl +++ b/lib/unicode/Is/Space.pl @@ -3,12 +3,11 @@ # Any changes made here will be lost! return <<'END'; 0009 000d -0020 -0085 -00a0 -1680 +0020 +00a0 +1680 2000 200b 2028 2029 -202f -3000 +202f +3000 END diff --git a/lib/unicode/Is/SpacePerl.pl b/lib/unicode/Is/SpacePerl.pl new file mode 100644 index 0000000..2bb74de --- /dev/null +++ b/lib/unicode/Is/SpacePerl.pl @@ -0,0 +1,14 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.301. +# Any changes made here will be lost! +return <<'END'; +0009 000a +000c 000d +0020 +00a0 +1680 +2000 200b +2028 2029 +202f +3000 +END diff --git a/lib/unicode/Is/Word.pl b/lib/unicode/Is/Word.pl index 1c76c60..6ea32e6 100644 --- a/lib/unicode/Is/Word.pl +++ b/lib/unicode/Is/Word.pl @@ -7,13 +7,23 @@ return <<'END'; 005f 0061 007a 00aa +00b2 00b3 00b5 -00ba +00b9 00ba +00bc 00be 00c0 00d6 00d8 00f6 00f8 021f 0222 0233 0250 02ad +02b0 02b8 +02bb 02c1 +02d0 02d1 +02e0 02e4 +02ee +0300 034e +0360 0362 +037a 0386 0388 038a 038c @@ -22,38 +32,57 @@ return <<'END'; 03d0 03d7 03da 03f3 0400 0481 +0483 0486 +0488 0489 048c 04c4 04c7 04c8 04cb 04cc 04d0 04f5 04f8 04f9 0531 0556 +0559 0561 0587 +0591 05a1 +05a3 05b9 +05bb 05bd +05bf +05c1 05c2 +05c4 05d0 05ea 05f0 05f2 0621 063a -0641 064a +0640 0655 0660 0669 -0671 06d3 -06d5 +0670 06d3 +06d5 06e8 +06ea 06ed 06f0 06fc -0710 -0712 072c -0780 07a5 +0710 072c +0730 074a +0780 07b0 +0901 0903 0905 0939 -093d -0950 -0958 0961 +093c 094d +0950 0954 +0958 0963 0966 096f +0981 0983 0985 098c 098f 0990 0993 09a8 09aa 09b0 09b2 09b6 09b9 +09bc +09be 09c4 +09c7 09c8 +09cb 09cd +09d7 09dc 09dd -09df 09e1 +09df 09e3 09e6 09f1 +09f4 09f9 +0a02 0a05 0a0a 0a0f 0a10 0a13 0a28 @@ -61,10 +90,14 @@ return <<'END'; 0a32 0a33 0a35 0a36 0a38 0a39 +0a3c +0a3e 0a42 +0a47 0a48 +0a4b 0a4d 0a59 0a5c 0a5e -0a66 0a6f -0a72 0a74 +0a66 0a74 +0a81 0a83 0a85 0a8b 0a8d 0a8f 0a91 @@ -72,20 +105,27 @@ return <<'END'; 0aaa 0ab0 0ab2 0ab3 0ab5 0ab9 -0abd +0abc 0ac5 +0ac7 0ac9 +0acb 0acd 0ad0 0ae0 0ae6 0aef +0b01 0b03 0b05 0b0c 0b0f 0b10 0b13 0b28 0b2a 0b30 0b32 0b33 0b36 0b39 -0b3d +0b3c 0b43 +0b47 0b48 +0b4b 0b4d +0b56 0b57 0b5c 0b5d 0b5f 0b61 0b66 0b6f +0b82 0b83 0b85 0b8a 0b8e 0b90 0b92 0b95 @@ -96,36 +136,60 @@ return <<'END'; 0ba8 0baa 0bae 0bb5 0bb7 0bb9 -0be7 0bef +0bbe 0bc2 +0bc6 0bc8 +0bca 0bcd +0bd7 +0be7 0bf2 +0c01 0c03 0c05 0c0c 0c0e 0c10 0c12 0c28 0c2a 0c33 0c35 0c39 +0c3e 0c44 +0c46 0c48 +0c4a 0c4d +0c55 0c56 0c60 0c61 0c66 0c6f +0c82 0c83 0c85 0c8c 0c8e 0c90 0c92 0ca8 0caa 0cb3 0cb5 0cb9 +0cbe 0cc4 +0cc6 0cc8 +0cca 0ccd +0cd5 0cd6 0cde 0ce0 0ce1 0ce6 0cef +0d02 0d03 0d05 0d0c 0d0e 0d10 0d12 0d28 0d2a 0d39 +0d3e 0d43 +0d46 0d48 +0d4a 0d4d +0d57 0d60 0d61 0d66 0d6f +0d82 0d83 0d85 0d96 0d9a 0db1 0db3 0dbb 0dbd 0dc0 0dc6 -0e01 0e30 -0e32 0e33 -0e40 0e45 +0dca +0dcf 0dd4 +0dd6 +0dd8 0ddf +0df2 0df3 +0e01 0e3a +0e40 0e4e 0e50 0e59 0e81 0e82 0e84 @@ -138,22 +202,33 @@ return <<'END'; 0ea5 0ea7 0eaa 0eab -0ead 0eb0 -0eb2 0eb3 -0ebd +0ead 0eb9 +0ebb 0ebd 0ec0 0ec4 +0ec6 +0ec8 0ecd 0ed0 0ed9 0edc 0edd 0f00 -0f20 0f29 -0f40 0f47 +0f18 0f19 +0f20 0f33 +0f35 +0f37 +0f39 +0f3e 0f47 0f49 0f6a -0f88 0f8b +0f71 0f84 +0f86 0f8b +0f90 0f97 +0f99 0fbc +0fc6 1000 1021 1023 1027 1029 102a +102c 1032 +1036 1039 1040 1049 -1050 1055 +1050 1059 10a0 10c5 10d0 10f6 1100 1159 @@ -184,18 +259,18 @@ return <<'END'; 1318 131e 1320 1346 1348 135a -1369 1371 +1369 137c 13a0 13f4 1401 166c 166f 1676 1681 169a 16a0 16ea -1780 17b3 +16ee 16f0 +1780 17d3 17e0 17e9 1810 1819 -1820 1842 -1844 1877 -1880 18a8 +1820 1877 +1880 18a9 1e00 1e9b 1ea0 1ef9 1f00 1f15 @@ -217,7 +292,10 @@ return <<'END'; 1fe0 1fec 1ff2 1ff4 1ff6 1ffc -207f +2070 +2074 2079 +207f 2089 +20d0 20e3 2102 2107 210a 2113 @@ -229,12 +307,25 @@ return <<'END'; 212a 212d 212f 2131 2133 2139 -3006 +2153 2183 +2460 249b +24ea +2776 2793 +3005 3007 +3021 302f +3031 3035 +3038 303a 3041 3094 +3099 309a +309d 309e 30a1 30fa +30fc 30fe 3105 312c 3131 318e +3192 3195 31a0 31b7 +3220 3229 +3280 3289 3400 4db5 4e00 9fa5 a000 a48c @@ -242,8 +333,7 @@ ac00 d7a3 f900 fa2d fb00 fb06 fb13 fb17 -fb1d -fb1f fb28 +fb1d fb28 fb2a fb36 fb38 fb3c fb3e @@ -254,15 +344,14 @@ fbd3 fd3d fd50 fd8f fd92 fdc7 fdf0 fdfb +fe20 fe23 fe70 fe72 fe74 fe76 fefc ff10 ff19 ff21 ff3a ff41 ff5a -ff66 ff6f -ff71 ff9d -ffa0 ffbe +ff66 ffbe ffc2 ffc7 ffca ffcf ffd2 ffd7 diff --git a/lib/unicode/distinct.pm b/lib/unicode/distinct.pm new file mode 100644 index 0000000..6471ac8 --- /dev/null +++ b/lib/unicode/distinct.pm @@ -0,0 +1,35 @@ +package unicode:distinct; + +our $VERSION = '0.01'; + +$unicode::distinct::hint_bits = 0x01000000; + +sub import { + $^H |= $unicode::distinct::hint_bits; +} + +sub unimport { + $^H &= ~$unicode::distinct::hint_bits; +} + +1; +__END__ + +=head1 NAME + +unicode::distinct - Perl pragma to strictly distinguish UTF8 data and non-UTF data. + +=head1 SYNOPSIS + + use unicode::distinct; + no unicode::distinct; + +=head1 DESCRIPTION + + *NOT YET* + +=head1 SEE ALSO + +L, L + +=cut diff --git a/lib/unicode/mktables.PL b/lib/unicode/mktables.PL index 37b6e84..82b35ef 100755 --- a/lib/unicode/mktables.PL +++ b/lib/unicode/mktables.PL @@ -16,18 +16,31 @@ mkdir "To", 0755; @todo = ( # typical - ['IsWord', '$cat =~ /^L[ulot]|^Nd/ or $code eq "005F"', ''], - ['IsAlnum', '$cat =~ /^L[ulot]|^Nd/', ''], - ['IsAlpha', '$cat =~ /^L[ulot]/', ''], - ['IsSpace', 'White space', $PropData], + # 005F: SPACING UNDERSCROE + ['IsWord', '$cat =~ /^[LMN]/ or $code eq "005F"', ''], + ['IsAlnum', '$cat =~ /^[LMN]/', ''], + ['IsAlpha', '$cat =~ /^[LM]/', ''], + # 0009: HORIZONTAL TABULATION + # 000A: LINE FEED + # 000B: VERTICAL TABULATION + # 000C: FORM FEED + # 000D: CARRIAGE RETURN + # 0020: SPACE + ['IsSpace', '$cat =~ /^Z/ || + $code =~ /^(0009|000A|000B|000C|000D)$/', ''], + ['IsSpacePerl', + '$cat =~ /^Z/ || + $code =~ /^(0009|000A|000C|000D)$/', ''], + ['IsBlank', '$cat =~ /^Z[^lp]$/ || $code eq "0009"', ''], ['IsDigit', '$cat =~ /^Nd$/', ''], ['IsUpper', '$cat =~ /^L[ut]$/', ''], ['IsLower', '$cat =~ /^Ll$/', ''], - ['IsASCII', 'hex $code <= 127', ''], + ['IsASCII', '$code le "007f"', ''], ['IsCntrl', '$cat =~ /^C/', ''], - ['IsGraph', '$cat =~ /^[^C]/ and ($cat !~ /^Z/ and $code ne "0020" or chr(hex $code) !~ /^\s/)', ''], - ['IsPrint', '$cat =~ /^[^C]/', ''], - ['IsPunct', 'Punctuation', $PropData], + ['IsGraph', '$cat =~ /^([LMNPS]|Co)/', ''], + ['IsPrint', '$cat =~ /^([LMNPS]|Co|Zs)/', ''], + ['IsPunct', '$cat =~ /^P/', ''], + # 003[0-9]: DIGIT ZERO..NINE, 00[46][1-6]: A..F, a..f ['IsXDigit', '$code =~ /^00(3[0-9]|[46][1-6])$/', ''], ['ToUpper', '$up', '$up'], ['ToLower', '$down', '$down'], @@ -145,7 +158,7 @@ mkdir "To", 0755; ['IsDCfont', '$decomp =~ /^/', ''], ['IsDCnoBreak', '$decomp =~ /^/', ''], ['IsDCinitial', '$decomp =~ /^/', ''], - ['IsDCinital', '$decomp =~ /^/', ''], + ['IsDCmedial', '$decomp =~ /^/', ''], ['IsDCfinal', '$decomp =~ /^/', ''], ['IsDCisolated', '$decomp =~ /^/', ''], ['IsDCcircle', '$decomp =~ /^/', ''], diff --git a/lib/unicode/syllables.txt b/lib/unicode/syllables.txt index 40e946e..bc8bc23 100644 --- a/lib/unicode/syllables.txt +++ b/lib/unicode/syllables.txt @@ -1,1329 +1,1329 @@ -################################################################################ -# -# V: as "u" in "but" (often represented with schwa or small uppercase lambda) -# U: as "oo" in "fool" -# I: as "ea" in "meat" -# A: as "a" in "father" -# E: as "a" in "hate" -# C: the consonant form having no vowel element -# O: as "o" in "note" -# -# Vowel identifiers are assumed short, doubled identifiers are considered long -# (following Cushitic rules). Dipthong syllables are identified with "W" as -# per Ethiopic and Canadian syllabary character names. -# -# -# WV WVV WU WUU WI WII WA WAA WAI WAAI WE WEE WC WO WOO -# -# V VV U UU I II A AA AI AAI E EE C O OO -# -################################################################################ - -# -# Ethiopic -# -1200; HA; V -1201; HU; U -1202; HI; I -1203; HAA; A -1204; HEE; E -1205; HE; C -1206; HO; O -1208; LA; V -1209; LU; U -120A; LI; I -120B; LAA; A -120C; LEE; E -120D; LE; C -120E; LO; O -120F; LWA; WA -1210; HHA; V -1211; HHU; U -1212; HHI; I -1213; HHAA; A -1214; HHEE; E -1215; HHE; C -1216; HHO; O -1217; HHWA; WA -1218; MA; V -1219; MU; U -121A; MI; I -121B; MAA; A -121C; MEE; E -121D; ME; C -121E; MO; O -121F; MWA; WA -1220; SZA; V -1221; SZU; U -1222; SZI; I -1223; SZAA; A -1224; SZEE; E -1225; SZE; C -1226; SZO; O -1227; SZWA; WA -1228; RA; V -1229; RU; U -122A; RI; I -122B; RAA; A -122C; REE; E -122D; RE; C -122E; RO; O -122F; RWA; WA -1230; SA; V -1231; SU; U -1232; SI; I -1233; SAA; A -1234; SEE; E -1235; SE; C -1236; SO; O -1237; SWA; WA -1238; SHA; V -1239; SHU; U -123A; SHI; I -123B; SHAA; A -123C; SHEE; E -123D; SHE; C -123E; SHO; O -123F; SHWA; WA -1240; QA; V -1241; QU; U -1242; QI; I -1243; QAA; A -1244; QEE; E -1245; QE; C -1246; QO; O -1248; QWA; WV -124A; QWI; WI -124B; QWAA; WA -124C; QWEE; WE -124D; QWE; WC -1250; QHA; V -1251; QHU; U -1252; QHI; I -1253; QHAA; A -1254; QHEE; E -1255; QHE; C -1256; QHO; O -1258; QHWA; WV -125A; QHWI; WI -125B; QHWAA; WA -125C; QHWEE; WE -125D; QHWE; WC -1260; BA; V -1261; BU; U -1262; BI; I -1263; BAA; A -1264; BEE; E -1265; BE; C -1266; BO; O -1267; BWA; WA -1268; VA; V -1269; VU; U -126A; VI; I -126B; VAA; A -126C; VEE; E -126D; VE; C -126E; VO; O -126F; VWA; WA -1270; TA; V -1271; TU; U -1272; TI; I -1273; TAA; A -1274; TEE; E -1275; TE; C -1276; TO; O -1277; TWA; WA -1278; CA; V -1279; CU; U -127A; CI; I -127B; CAA; A -127C; CEE; E -127D; CE; C -127E; CO; O -127F; CWA; WA -1280; XA; V -1281; XU; U -1282; XI; I -1283; XAA; A -1284; XEE; E -1285; XE; C -1286; XO; O -1288; XWA; WV -128A; XWI; WI -128B; XWAA; WA -128C; XWEE; WE -128D; XWE; WC -1290; NA; V -1291; NU; U -1292; NI; I -1293; NAA; A -1294; NEE; E -1295; NE; C -1296; NO; O -1297; NWA; WA -1298; NYA; V -1299; NYU; U -129A; NYI; I -129B; NYAA; A -129C; NYEE; E -129D; NYE; C -129E; NYO; O -129F; NYWA; WA -12A0; GLOTTAL A; V -12A1; GLOTTAL U; U -12A2; GLOTTAL I; I -12A3; GLOTTAL AA; A -12A4; GLOTTAL EE; E -12A5; GLOTTAL E; C -12A6; GLOTTAL O; O -12A7; GLOTTAL WA; WA -12A8; KA; V -12A9; KU; U -12AA; KI; I -12AB; KAA; A -12AC; KEE; E -12AD; KE; C -12AE; KO; O -12B0; KWA; WV -12B2; KWI; WI -12B3; KWAA; WA -12B4; KWEE; WE -12B5; KWE; WC -12B8; KXA; V -12B9; KXU; U -12BA; KXI; I -12BB; KXAA; A -12BC; KXEE; E -12BD; KXE; C -12BE; KXO; O -12C0; KXWA; WV -12C2; KXWI; WI -12C3; KXWAA; WA -12C4; KXWEE; WE -12C5; KXWE; WC -12C8; WA; V -12C9; WU; U -12CA; WI; I -12CB; WAA; A -12CC; WEE; E -12CD; WE; C -12CE; WO; O -12D0; PHARYNGEAL A; V -12D1; PHARYNGEAL U; U -12D2; PHARYNGEAL I; I -12D3; PHARYNGEAL AA; A -12D4; PHARYNGEAL EE; E -12D5; PHARYNGEAL E; C -12D6; PHARYNGEAL O; O -12D8; ZA; V -12D9; ZU; U -12DA; ZI; I -12DB; ZAA; A -12DC; ZEE; E -12DD; ZE; C -12DE; ZO; O -12DF; ZWA; WA -12E0; ZHA; V -12E1; ZHU; U -12E2; ZHI; I -12E3; ZHAA; A -12E4; ZHEE; E -12E5; ZHE; C -12E6; ZHO; O -12E7; ZHWA; WA -12E8; YA; V -12E9; YU; U -12EA; YI; I -12EB; YAA; A -12EC; YEE; E -12ED; YE; C -12EE; YO; O -12F0; DA; V -12F1; DU; U -12F2; DI; I -12F3; DAA; A -12F4; DEE; E -12F5; DE; C -12F6; DO; O -12F7; DWA; WA -12F8; DDA; V -12F9; DDU; U -12FA; DDI; I -12FB; DDAA; A -12FC; DDEE; E -12FD; DDE; C -12FE; DDO; O -12FF; DDWA; WA -1300; JA; V -1301; JU; U -1302; JI; I -1303; JAA; A -1304; JEE; E -1305; JE; C -1306; JO; O -1307; JWA; WA -1308; GA; V -1309; GU; U -130A; GI; I -130B; GAA; A -130C; GEE; E -130D; GE; C -130E; GO; O -1310; GWA; WV -1312; GWI; WI -1313; GWAA; WA -1314; GWEE; WE -1315; GWE; WC -1318; GGA; V -1319; GGU; U -131A; GGI; I -131B; GGAA; A -131C; GGEE; E -131D; GGE; C -131E; GGO; O -1320; THA; V -1321; THU; U -1322; THI; I -1323; THAA; A -1324; THEE; E -1325; THE; C -1326; THO; O -1327; THWA; WA -1328; CHA; V -1329; CHU; U -132A; CHI; I -132B; CHAA; A -132C; CHEE; E -132D; CHE; C -132E; CHO; O -132F; CHWA; WA -1330; PHA; V -1331; PHU; U -1332; PHI; I -1333; PHAA; A -1334; PHEE; E -1335; PHE; C -1336; PHO; O -1337; PHWA; WA -1338; TSA; V -1339; TSU; U -133A; TSI; I -133B; TSAA; A -133C; TSEE; E -133D; TSE; C -133E; TSO; O -133F; TSWA; WA -1340; TZA; V -1341; TZU; U -1342; TZI; I -1343; TZAA; A -1344; TZEE; E -1345; TZE; C -1346; TZO; O -1348; FA; V -1349; FU; U -134A; FI; I -134B; FAA; A -134C; FEE; E -134D; FE; C -134E; FO; O -134F; FWA; WA -1350; PA; V -1351; PU; U -1352; PI; I -1353; PAA; A -1354; PEE; E -1355; PE; C -1356; PO; O -1357; PWA; WA -# -# Cherokee -# -13A0; A; A -13A1; E; E -13A2; I; I -13A3; O; O -13A4; U; U -13A5; V; V -13A6; GA; A -13A7; KA; A -13A8; GE; E -13A9; GI; I -13AA; GO; O -13AB; GU; U -13AC; GV; V -13AD; HA; A -13AE; HE; E -13AF; HI; I -13B0; HO; O -13B1; HU; U -13B2; HV; V -13B3; LA; A -13B4; LE; E -13B5; LI; I -13B6; LO; O -13B7; LU; U -13B8; LV; V -13B9; MA; A -13BA; ME; E -13BB; MI; I -13BC; MO; O -13BD; MU; U -13BE; NA; A -13BF; HNA; A -13C0; NAH; C -13C1; NE; E -13C2; NI; I -13C3; NO; O -13C4; NU; U -13C5; NV; V -13C6; QUA; A -13C7; QUE; E -13C8; QUI; I -13C9; QUO; O -13CA; QUU; U -13CB; QUV; V -13CC; SA; A -13CD; S; C -13CE; SE; E -13CF; SI; I -13D0; SO; O -13D1; SU; U -13D2; SV; V -13D3; DA; A -13D4; TA; A -13D5; DE; E -13D6; TE; E -13D7; DI; I -13D8; TI; I -13D9; DO; O -13DA; DU; U -13DB; DV; V -13DC; DLA; A -13DD; TLA; A -13DE; TLE; E -13DF; TLI; I -13E0; TLO; O -13E1; TLU; U -13E2; TLV; V -13E3; TSA; A -13E4; TSE; E -13E5; TSI; I -13E6; TSO; O -13E7; TSU; U -13E8; TSV; V -13E9; WA; A -13EA; WE; E -13EB; WI; I -13EC; WO; O -13ED; WU; U -13EE; WV; V -13EF; YA; A -13F0; YE; E -13F1; YI; I -13F2; YO; O -13F3; YU; U -13F4; YV; V -# -# 1400 Unified Canadian Aboriginal Syllabics 167F -# -1401; E; E -1402; AAI; AAI -1403; I; I -1404; II; II -1405; O; O -1406; OO; OO -1407; Y-CREE OO; OO -1408; CARRIER EE; EE -1409; CARRIER I; I -140A; A; A -140B; AA; AA -140C; WE; WE -140D; WEST-CREE WE; WE -140E; WI; WI -140F; WEST-CREE WI; WI -1410; WII; WII -1411; WEST-CREE WII; WII -1412; WO; WO -1413; WEST-CREE WO; WO -1414; WOO; WOO -1415; WEST-CREE WOO; WOO -1416; NASKAPI WOO; WOO -1417; WA; WA -1418; WEST-CREE WA; WA -1419; WAA; WAA -141A; WEST-CREE WAA; WAA -141B; NASKAPI WAA; WAA -141C; AI; AI -141D; Y-CREE W; C -142B; EN; C -142C; IN; C -142D; ON; C -142E; AN; C -142F; PE; E -1430; PAAI; AAI -1431; PI; I -1432; PII; II -1433; PO; O -1434; POO; OO -1435; Y-CREE POO; OO -1436; CARRIER HEE; EE -1437; CARRIER HI; I -1438; PA; A -1439; PAA; AA -143A; PWE; WE -143B; WEST-CREE PWE; WE -143C; PWI; WI -143D; WEST-CREE PWI; WI -143E; PWII; WII -143F; WEST-CREE PWII; WII -1440; PWO; WO -1441; WEST-CREE PWO; WO -1442; PWOO; WOO -1443; WEST-CREE PWOO; WOO -1444; PWA; WA -1445; WEST-CREE PWA; WA -1446; PWAA; WAA -1447; WEST-CREE PWAA; WAA -1448; Y-CREE PWAA; WAA -1449; P; C -144A; WEST-CREE P; C -144B; CARRIER H; C -144C; TE; E -144D; TAAI; AAI -144E; TI; I -144F; TII; II -1450; TO; O -1451; TOO; OO -1452; Y-CREE TOO; OO -1453; CARRIER DEE; EE -1454; CARRIER DI; I -1455; TA; A -1456; TAA; AA -1457; TWE; WE -1458; WEST-CREE TWE; WE -1459; TWI; WI -145A; WEST-CREE TWI; WI -145B; TWII; WII -145C; WEST-CREE TWII; WII -145D; TWO; WO -145E; WEST-CREE TWO; WO -145F; TWOO; WOO -1460; WEST-CREE TWOO; WOO -1461; TWA; WA -1462; WEST-CREE TWA; WA -1463; TWAA; WAA -1464; WEST-CREE TWAA; WAA -1465; NASKAPI TWAA; WAA -1466; T; C -1467; TTE; E -1468; TTI; I -1469; TTO; O -146A; TTA; A -146B; KE; E -146C; KAAI; AAI -146D; KI; I -146E; KII; II -146F; KO; O -1470; KOO; OO -1471; Y-CREE KOO; OO -1472; KA; A -1473; KAA; AA -1474; KWE; WE -1475; WEST-CREE KWE; WE -1476; KWI; WI -1477; WEST-CREE KWI; WI -1478; KWII; WII -1479; WEST-CREE KWII; WII -147A; KWO; WO -147B; WEST-CREE KWO; WO -147C; KWOO; WOO -147D; WEST-CREE KWOO; WOO -147E; KWA; WA -147F; WEST-CREE KWA; WA -1480; KWAA; WAA -1481; WEST-CREE KWAA; WAA -1482; NASKAPI KWAA; WAA -1483; K; C -1484; KW; WC -1485; SOUTH-SLAVEY KEH; C -1486; SOUTH-SLAVEY KIH; C -1487; SOUTH-SLAVEY KOH; C -1488; SOUTH-SLAVEY KAH; C -1489; CE; E -148A; CAAI; AAI -148B; CI; I -148C; CII; II -148D; CO; O -148E; COO; OO -148F; Y-CREE COO; OO -1490; CA; A -1491; CAA; AA -1492; CWE; WE -1493; WEST-CREE CWE; WE -1494; CWI; WI -1495; WEST-CREE CWI; WI -1496; CWII; WII -1497; WEST-CREE CWII; WII -1498; CWO; WO -1499; WEST-CREE CWO; WO -149A; CWOO; WOO -149B; WEST-CREE CWOO; WOO -149C; CWA; WA -149D; WEST-CREE CWA; WA -149E; CWAA; WAA -149F; WEST-CREE CWAA; WAA -14A0; NASKAPI CWAA; WAA -14A1; C; C -14A2; SAYISI TH; -14A3; ME; E -14A4; MAAI; AAI -14A5; MI; I -14A6; MII; II -14A7; MO; O -14A8; MOO; OO -14A9; Y-CREE MOO; OO -14AA; MA; A -14AB; MAA; AA -14AC; MWE; WE -14AD; WEST-CREE MWE; WE -14AE; MWI; WI -14AF; WEST-CREE MWI; WI -14B0; MWII; WII -14B1; WEST-CREE MWII; WII -14B2; MWO; WO -14B3; WEST-CREE MWO; WO -14B4; MWOO; WOO -14B5; WEST-CREE MWOO; WOO -14B6; MWA; WA -14B7; WEST-CREE MWA; WA -14B8; MWAA; WAA -14B9; WEST-CREE MWAA; WAA -14BA; NASKAPI MWAA; WAA -14BB; M; C -14BC; WEST-CREE M; C -14BD; MH; C -14BE; ATHAPASCAN M; C -14BF; SAYISI M; C -14C0; NE; E -14C1; NAAI; AAI -14C2; NI; I -14C3; NII; II -14C4; NO; O -14C5; NOO; OO -14C6; Y-CREE NOO; OO -14C7; NA; A -14C8; NAA; AA -14C9; NWE; WE -14CA; WEST-CREE NWE; WE -14CB; NWA; WA -14CC; WEST-CREE NWA; WA -14CD; NWAA; WAA -14CE; WEST-CREE NWAA; WAA -14CF; NASKAPI NWAA; WAA -14D0; N; C -14D1; CARRIER NG; C -14D2; NH; C -14D3; LE; E -14D4; LAAI; AAI -14D5; LI; I -14D6; LII; II -14D7; LO; O -14D8; LOO; OO -14D9; Y-CREE LOO; OO -14DA; LA; A -14DB; LAA; AA -14DC; LWE; WE -14DD; WEST-CREE LWE; WE -14DE; LWI; WI -14DF; WEST-CREE LWI; WI -14E0; LWII; WII -14E1; WEST-CREE LWII; WII -14E2; LWO; WO -14E3; WEST-CREE LWO; WO -14E4; LWOO; WOO -14E5; WEST-CREE LWOO; WOO -14E6; LWA; WA -14E7; WEST-CREE LWA; WA -14E8; LWAA; WAA -14E9; WEST-CREE LWAA; WAA -14EA; L; C -14EB; WEST-CREE L; C -14EC; MEDIAL L; C -14ED; SE; E -14EE; SAAI; AAI -14EF; SI; I -14F0; SII; II -14F1; SO; O -14F2; SOO; OO -14F3; Y-CREE SOO; OO -14F4; SA; A -14F5; SAA; AA -14F6; SWE; WE -14F7; WEST-CREE SWE; WE -14F8; SWI; WI -14F9; WEST-CREE SWI; WI -14FA; SWII; WII -14FB; WEST-CREE SWII; WII -14FC; SWO; WO -14FD; WEST-CREE SWO; WO -14FE; SWOO; WOO -14FF; WEST-CREE SWOO; WOO -1500; SWA; WA -1501; WEST-CREE SWA; WA -1502; SWAA; WAA -1503; WEST-CREE SWAA; WAA -1504; NASKAPI SWAA; WAA -1505; S; C -1506; ATHAPASCAN S; C -1507; SW; WC -1508; BLACKFOOT S; C -1509; MOOSE-CREE SK;C -150A; NASKAPI SKW; C -150B; NASKAPI S-W; C -150C; NASKAPI SPWA; WA -150D; NASKAPI STWA; WA -150E; NASKAPI SKWA; WA -150F; NASKAPI SCWA; WA -1510; SHE; E -1511; SHI; I -1512; SHII; II -1513; SHO; O -1514; SHOO; OO -1515; SHA; A -1516; SHAA; AA -1517; SHWE; WE -1518; WEST-CREE SHWE; WE -1519; SHWI; WI -151A; WEST-CREE SHWI; WI -151B; SHWII; WII -151C; WEST-CREE SHWII; WII -151D; SHWO; WO -151E; WEST-CREE SHWO; WO -151F; SHWOO; WOO -1520; WEST-CREE SHWOO; WOO -1521; SHWA; WA -1522; WEST-CREE SHWA; WA -1523; SHWAA; WAA -1524; WEST-CREE SHWAA; WAA -1525; SH; C -1526; YE; E -1527; YAAI; AAI -1528; YI; I -1529; YII; II -152A; YO; O -152B; YOO; OO -152C; Y-CREE YOO; OO -152D; YA; A -152E; YAA; AA -152F; YWE; WE -1530; WEST-CREE YWE; WE -1531; YWI; WI -1532; WEST-CREE YWI; WI -1533; YWII; WII -1534; WEST-CREE YWII; WII -1535; YWO; WO -1536; WEST-CREE YWO; WO -1537; YWOO; WOO -1538; WEST-CREE YWOO; WOO -1539; YWA; WA -153A; WEST-CREE YWA; WA -153B; YWAA; WAA -153C; WEST-CREE YWAA; WAA -153D; NASKAPI YWAA; WAA -153E; Y; C -153F; BIBLE-CREE Y; C -1540; WEST-CREE Y; C -1541; SAYISI YI; I -1542; RE; E -1543; R-CREE RE; E -1544; WEST-CREE LE; E -1545; RAAI; AAI -1546; RI; I -1547; RII; II -1548; RO; O -1549; ROO; OO -154A; WEST-CREE LO; O -154B; RA; A -154C; RAA; AA -154D; WEST-CREE LA; A -154E; RWAA; WAA -154F; WEST-CREE RWAA; WAA -1550; R; C -1551; WEST-CREE R; C -1552; MEDIAL R; C -1553; FE; E -1554; FAAI; AAI -1555; FI; I -1556; FII; II -1557; FO; O -1558; FOO; OO -1559; FA; A -155A; FAA; AA -155B; FWAA; WAA -155C; WEST-CREE FWAA; WAA -155D; F; C -155E; THE; E -155F; N-CREE THE; E -1560; THI; I -1561; N-CREE THI; I -1562; THII; II -1563; N-CREE THII; II -1564; THO; O -1565; THOO; OO -1566; THA; A -1567; THAA; AA -1568; THWAA; WAA -1569; WEST-CREE THWAA; WAA -156A; TH; C -156B; TTHE; E -156C; TTHI; I -156D; TTHO; O -156E; TTHA; A -156F; TTH; C -1570; TYE; E -1571; TYI; I -1572; TYO; O -1573; TYA; A -1574; NUNAVIK HE; E -1575; NUNAVIK HI; I -1576; NUNAVIK HII; II -1577; NUNAVIK HO; O -1578; NUNAVIK HOO; OO -1579; NUNAVIK HA; A -157A; NUNAVIK HAA; AA -157B; NUNAVIK H; C -157C; NUNAVUT H; C -157D; HK; C -157E; QAAI; AAI -157F; QI; I -1580; QII; II -1581; QO; O -1582; QOO; OO -1583; QA; A -1584; QAA; AA -1585; Q; C -1586; TLHE; E -1587; TLHI; I -1588; TLHO; O -1589; TLHA; A -158A; WEST-CREE RE; E -158B; WEST-CREE RI; I -158C; WEST-CREE RO; O -158D; WEST-CREE RA; A -158E; NGAAI; AAI -158F; NGI; I -1590; NGII; II -1591; NGO; O -1592; NGOO; OO -1593; NGA; A -1594; NGAA; AA -1595; NG; C -1596; NNG; C -1597; SAYISI SHE; E -1598; SAYISI SHI; I -1599; SAYISI SHO; O -159A; SAYISI SHA; A -159B; WOODS-CREE THE; E -159C; WOODS-CREE THI; I -159D; WOODS-CREE THO; O -159E; WOODS-CREE THA; A -159F; WOODS-CREE TH; C -15A0; LHI; I -15A1; LHII; II -15A2; LHO; O -15A3; LHOO; OO -15A4; LHA; A -15A5; LHAA; AA -15A6; LH; C -15A7; TH-CREE THE; E -15A8; TH-CREE THI; I -15A9; TH-CREE THII; II -15AA; TH-CREE THO; O -15AB; TH-CREE THOO; OO -15AC; TH-CREE THA; A -15AD; TH-CREE THAA; AA -15AE; TH-CREE TH; C -15AF; AIVILIK B; C -15B0; BLACKFOOT E; E -15B1; BLACKFOOT I; I -15B2; BLACKFOOT O; O -15B3; BLACKFOOT A; A -15B4; BLACKFOOT WE; E -15B5; BLACKFOOT WI; I -15B6; BLACKFOOT WO; O -15B7; BLACKFOOT WA; A -15B8; BLACKFOOT NE; E -15B9; BLACKFOOT NI; I -15BA; BLACKFOOT NO; O -15BB; BLACKFOOT NA; A -15BC; BLACKFOOT KE; E -15BD; BLACKFOOT KI; I -15BE; BLACKFOOT KO; O -15BF; BLACKFOOT KA; A -15C0; SAYISI HE; E -15C1; SAYISI HI; I -15C2; SAYISI HO; O -15C3; SAYISI HA; A -15C4; CARRIER GHU; U -15C5; CARRIER GHO; O -15C6; CARRIER GHE; E -15C7; CARRIER GHEE; EE -15C8; CARRIER GHI; I -15C9; CARRIER GHA; A -15CA; CARRIER RU; U -15CB; CARRIER RO; O -15CC; CARRIER RE; E -15CD; CARRIER REE; EE -15CE; CARRIER RI; I -15CF; CARRIER RA; A -15D0; CARRIER WU; U -15D1; CARRIER WO; O -15D2; CARRIER WE; E -15D3; CARRIER WEE; EE -15D4; CARRIER WI; I -15D5; CARRIER WA; A -15D6; CARRIER HWU; WU -15D7; CARRIER HWO; WO -15D8; CARRIER HWE; WE -15D9; CARRIER HWEE; WEE -15DA; CARRIER HWI; WI -15DB; CARRIER HWA; WA -15DC; CARRIER THU; U -15DD; CARRIER THO; O -15DE; CARRIER THE; E -15DF; CARRIER THEE; EE -15E0; CARRIER THI; I -15E1; CARRIER THA; A -15E2; CARRIER TTU; U -15E3; CARRIER TTO; O -15E4; CARRIER TTE; E -15E5; CARRIER TTEE; EE -15E6; CARRIER TTI; I -15E7; CARRIER TTA; A -15E8; CARRIER PU; U -15E9; CARRIER PO; O -15EA; CARRIER PE; E -15EB; CARRIER PEE; EE -15EC; CARRIER PI; I -15ED; CARRIER PA; A -15EE; CARRIER P; -15EF; CARRIER GU; U -15F0; CARRIER GO; O -15F1; CARRIER GE; E -15F2; CARRIER GEE; EE -15F3; CARRIER GI; I -15F4; CARRIER GA; A -15F5; CARRIER KHU; U -15F6; CARRIER KHO; O -15F7; CARRIER KHE; E -15F8; CARRIER KHEE; EE -15F9; CARRIER KHI; I -15FA; CARRIER KHA; A -15FB; CARRIER KKU; U -15FC; CARRIER KKO; O -15FD; CARRIER KKE; E -15FE; CARRIER KKEE; EE -15FF; CARRIER KKI; I -1600; CARRIER KKA; A -1601; CARRIER KK; -1602; CARRIER NU; U -1603; CARRIER NO; O -1604; CARRIER NE; E -1605; CARRIER NEE; EE -1606; CARRIER NI; I -1607; CARRIER NA; A -1608; CARRIER MU; U -1609; CARRIER MO; O -160A; CARRIER ME; E -160B; CARRIER MEE; EE -160C; CARRIER MI; I -160D; CARRIER MA; A -160E; CARRIER YU; U -160F; CARRIER YO; O -1610; CARRIER YE; E -1611; CARRIER YEE; EE -1612; CARRIER YI; I -1613; CARRIER YA; A -1614; CARRIER JU; U -1615; SAYISI JU; U -1616; CARRIER JO; O -1617; CARRIER JE; E -1618; CARRIER JEE; EE -1619; CARRIER JI; I -161A; SAYISI JI; I -161B; CARRIER JA; A -161C; CARRIER JJU; U -161D; CARRIER JJO; O -161E; CARRIER JJE; E -161F; CARRIER JJEE; EE -1620; CARRIER JJI; I -1621; CARRIER JJA; A -1622; CARRIER LU; U -1623; CARRIER LO; O -1624; CARRIER LE; E -1625; CARRIER LEE; EE -1626; CARRIER LI; I -1627; CARRIER LA; A -1628; CARRIER DLU; U -1629; CARRIER DLO; O -162A; CARRIER DLE; E -162B; CARRIER DLEE; EE -162C; CARRIER DLI; I -162D; CARRIER DLA; A -162E; CARRIER LHU; U -162F; CARRIER LHO; O -1630; CARRIER LHE; E -1631; CARRIER LHEE; EE -1632; CARRIER LHI; I -1633; CARRIER LHA; A -1634; CARRIER TLHU; U -1635; CARRIER TLHO; O -1636; CARRIER TLHE; E -1637; CARRIER TLHEE; EE -1638; CARRIER TLHI; I -1639; CARRIER TLHA; A -163A; CARRIER TLU; U -163B; CARRIER TLO; O -163C; CARRIER TLE; E -163D; CARRIER TLEE; EE -163E; CARRIER TLI; I -163F; CARRIER TLA; A -1640; CARRIER ZU; U -1641; CARRIER ZO; O -1642; CARRIER ZE; E -1643; CARRIER ZEE; EE -1644; CARRIER ZI; I -1645; CARRIER ZA; A -1646; CARRIER Z; -1647; CARRIER INITIAL Z; -1648; CARRIER DZU; U -1649; CARRIER DZO; O -164A; CARRIER DZE; E -164B; CARRIER DZEE; EE -164C; CARRIER DZI; I -164D; CARRIER DZA; A -164E; CARRIER SU; U -164F; CARRIER SO; O -1650; CARRIER SE; E -1651; CARRIER SEE; EE -1652; CARRIER SI; I -1653; CARRIER SA; A -1654; CARRIER SHU; U -1655; CARRIER SHO; O -1656; CARRIER SHE; E -1657; CARRIER SHEE; EE -1658; CARRIER SHI; I -1659; CARRIER SHA; A -165A; CARRIER SH; -165B; CARRIER TSU; U -165C; CARRIER TSO; O -165D; CARRIER TSE; E -165E; CARRIER TSEE; EE -165F; CARRIER TSI; I -1660; CARRIER TSA; A -1661; CARRIER CHU; U -1662; CARRIER CHO; O -1663; CARRIER CHE; E -1664; CARRIER CHEE; EE -1665; CARRIER CHI; I -1666; CARRIER CHA; A -1667; CARRIER TTSU; U -1668; CARRIER TTSO; O -1669; CARRIER TTSE; E -166A; CARRIER TTSEE; EE -166B; CARRIER TTSI; I -166C; CARRIER TTSA; A -166F; QAI; AI -1670; NGAI; AI -1671; NNGI; I -1672; NNGII; II -1673; NNGO; O -1674; NNGOO; OO -1675; NNGA; A -1676; NNGAA; AA -# -# Katakana -# -30A1; SMALL A; A -30A2; A; A -30A3; SMALL I; I -30A4; I; I -30A5; SMALL U; U -30A6; U; U -30A7; SMALL E; E -30A8; E; E -30A9; SMALL O; O -30AA; O; O -30AB; KA; A -30AC; GA; A -30AD; KI; I -30AE; GI; I -30AF; KU; U -30B0; GU; U -30B1; KE; E -30B2; GE; E -30B3; KO; O -30B4; GO; O -30B5; SA; A -30B6; ZA; A -30B7; SI; I -30B8; ZI; I -30B9; SU; U -30BA; ZU; U -30BB; SE; E -30BC; ZE; E -30BD; SO; O -30BE; ZO; O -30BF; TA; A -30C0; DA; A -30C1; TI; I -30C2; DI; I -30C3; SMALL TU; U -30C4; TU; U -30C5; DU; U -30C6; TE; E -30C7; DE; E -30C8; TO; O -30C9; DO; O -30CA; NA; A -30CB; NI; I -30CC; NU; U -30CD; NE; E -30CE; NO; O -30CF; HA; A -30D0; BA; A -30D1; PA; A -30D2; HI; I -30D3; BI; I -30D4; PI; I -30D5; HU; U -30D6; BU; U -30D7; PU; U -30D8; HE; E -30D9; BE; E -30DA; PE; E -30DB; HO; O -30DC; BO; O -30DD; PO; O -30DE; MA; A -30DF; MI; I -30E0; MU; U -30E1; ME; E -30E2; MO; O -30E3; SMALL YA; A -30E4; YA; A -30E5; SMALL YU; U -30E6; YU; U -30E7; SMALL YO; O -30E8; YO; O -30E9; RA; A -30EA; RI; I -30EB; RU; U -30EC; RE; E -30ED; RO; O -30EE; SMALL WA; A -30EF; WA; A -30F0; WI; I -30F1; WE; E -30F2; WO; O -30F3; N; C -30F4; VU; U -30F5; SMALL KA; A -30F6; SMALL KE; E -30F7; VA; A -30F8; VI; I -30F9; VE; E -30FA; VO; O -32D0; CIRCLED KATAKANA A; A -32D1; CIRCLED KATAKANA I; I -32D2; CIRCLED KATAKANA U; U -32D3; CIRCLED KATAKANA E; E -32D4; CIRCLED KATAKANA O; O -32D5; CIRCLED KATAKANA KA; A -32D6; CIRCLED KATAKANA KI; I -32D7; CIRCLED KATAKANA KU; U -32D8; CIRCLED KATAKANA KE; E -32D9; CIRCLED KATAKANA KO; O -32DA; CIRCLED KATAKANA SA; A -32DB; CIRCLED KATAKANA SI; I -32DC; CIRCLED KATAKANA SU; U -32DD; CIRCLED KATAKANA SE; E -32DE; CIRCLED KATAKANA SO; O -32DF; CIRCLED KATAKANA TA; A -32E0; CIRCLED KATAKANA TI; I -32E1; CIRCLED KATAKANA TU; U -32E2; CIRCLED KATAKANA TE; E -32E3; CIRCLED KATAKANA TO; O -32E4; CIRCLED KATAKANA NA; A -32E5; CIRCLED KATAKANA NI; I -32E6; CIRCLED KATAKANA NU; U -32E7; CIRCLED KATAKANA NE; E -32E8; CIRCLED KATAKANA NO; O -32E9; CIRCLED KATAKANA HA; A -32EA; CIRCLED KATAKANA HI; I -32EB; CIRCLED KATAKANA HU; U -32EC; CIRCLED KATAKANA HE; E -32ED; CIRCLED KATAKANA HO; O -32EE; CIRCLED KATAKANA MA; A -32EF; CIRCLED KATAKANA MI; I -32F0; CIRCLED KATAKANA MU; U -32F1; CIRCLED KATAKANA ME; E -32F2; CIRCLED KATAKANA MO; O -32F3; CIRCLED KATAKANA YA; A -32F4; CIRCLED KATAKANA YU; U -32F5; CIRCLED KATAKANA YO; O -32F6; CIRCLED KATAKANA RA; A -32F7; CIRCLED KATAKANA RI; I -32F8; CIRCLED KATAKANA RU; U -32F9; CIRCLED KATAKANA RE; E -32FA; CIRCLED KATAKANA RO; O -32FB; CIRCLED KATAKANA WA; A -32FC; CIRCLED KATAKANA WI; I -32FD; CIRCLED KATAKANA WE; E -32FE; CIRCLED KATAKANA WO; O -# -# Katakana -# -FF66; HALFWIDTH WO; O -FF67; HALFWIDTH SMALL A; A -FF68; HALFWIDTH SMALL I; I -FF69; HALFWIDTH SMALL U; U -FF6A; HALFWIDTH SMALL E; E -FF6B; HALFWIDTH SMALL O; O -FF6C; HALFWIDTH SMALL YA; A -FF6D; HALFWIDTH SMALL YU; U -FF6E; HALFWIDTH SMALL YO; O -FF6F; HALFWIDTH SMALL TU; U -FF71; HALFWIDTH A; A -FF72; HALFWIDTH I; I -FF73; HALFWIDTH U; U -FF74; HALFWIDTH E; E -FF75; HALFWIDTH O; O -FF76; HALFWIDTH KA; A -FF77; HALFWIDTH KI; I -FF78; HALFWIDTH KU; U -FF79; HALFWIDTH KE; E -FF7A; HALFWIDTH KO; O -FF7B; HALFWIDTH SA; A -FF7C; HALFWIDTH SI; I -FF7D; HALFWIDTH SU; U -FF7E; HALFWIDTH SE; E -FF7F; HALFWIDTH SO; O -FF80; HALFWIDTH TA; A -FF81; HALFWIDTH TI; I -FF82; HALFWIDTH TU; U -FF83; HALFWIDTH TE; E -FF84; HALFWIDTH TO; O -FF85; HALFWIDTH NA; A -FF86; HALFWIDTH NI; I -FF87; HALFWIDTH NU; U -FF88; HALFWIDTH NE; E -FF89; HALFWIDTH NO; O -FF8A; HALFWIDTH HA; A -FF8B; HALFWIDTH HI; I -FF8C; HALFWIDTH HU; U -FF8D; HALFWIDTH HE; E -FF8E; HALFWIDTH HO; O -FF8F; HALFWIDTH MA; A -FF90; HALFWIDTH MI; I -FF91; HALFWIDTH MU; U -FF92; HALFWIDTH ME; E -FF93; HALFWIDTH MO; O -FF94; HALFWIDTH YA; A -FF95; HALFWIDTH YU; U -FF96; HALFWIDTH YO; O -FF97; HALFWIDTH RA; A -FF98; HALFWIDTH RI; I -FF99; HALFWIDTH RU; U -FF9A; HALFWIDTH RE; E -FF9B; HALFWIDTH RO; O -FF9C; HALFWIDTH WA; A -FF9D; HALFWIDTH N; C -# -# Hiragana -# -3041; SMALL A; A -3042; A; A -3043; SMALL I; I -3044; I; I -3045; SMALL U; U -3046; U; U -3047; SMALL E; E -3048; E; E -3049; SMALL O; O -304A; O; O -304B; KA; A -304C; GA; A -304D; KI; I -304E; GI; I -304F; KU; U -3050; GU; U -3051; KE; E -3052; GE; E -3053; KO; O -3054; GO; O -3055; SA; A -3056; ZA; A -3057; SI; I -3058; ZI; I -3059; SU; U -305A; ZU; U -305B; SE; E -305C; ZE; E -305D; SO; O -305E; ZO; O -305F; TA; A -3060; DA; A -3061; TI; I -3062; DI; I -3063; SMALL TU; U -3064; TU; U -3065; DU; U -3066; TE; E -3067; DE; E -3068; TO; O -3069; DO; O -306A; NA; A -306B; NI; I -306C; NU; U -306D; NE; E -306E; NO; O -306F; HA; A -3070; BA; A -3071; PA; A -3072; HI; I -3073; BI; I -3074; PI; I -3075; HU; U -3076; BU; U -3077; PU; U -3078; HE; E -3079; BE; E -307A; PE; E -307B; HO; O -307C; BO; O -307D; PO; O -307E; MA; A -307F; MI; I -3080; MU; U -3081; ME; E -3082; MO; O -3083; SMALL YA; A -3084; YA; A -3085; SMALL YU; U -3086; YU; U -3087; SMALL YO; O -3088; YO; O -3089; RA; A -308A; RI; I -308B; RU; U -308C; RE; E -308D; RO; O -308E; SMALL WA; A -308F; WA; A -3090; WI; I -3091; WE; E -3092; WO; O -3093; N; N -3094; VU; U +################################################################################ +# +# V: as "u" in "but" (often represented with schwa or small uppercase lambda) +# U: as "oo" in "fool" +# I: as "ea" in "meat" +# A: as "a" in "father" +# E: as "a" in "hate" +# C: the consonant form having no vowel element +# O: as "o" in "note" +# +# Vowel identifiers are assumed short, doubled identifiers are considered long +# (following Cushitic rules). Dipthong syllables are identified with "W" as +# per Ethiopic and Canadian syllabary character names. +# +# +# WV WVV WU WUU WI WII WA WAA WAI WAAI WE WEE WC WO WOO +# +# V VV U UU I II A AA AI AAI E EE C O OO +# +################################################################################ + +# +# Ethiopic +# +1200; HA; V +1201; HU; U +1202; HI; I +1203; HAA; A +1204; HEE; E +1205; HE; C +1206; HO; O +1208; LA; V +1209; LU; U +120A; LI; I +120B; LAA; A +120C; LEE; E +120D; LE; C +120E; LO; O +120F; LWA; WA +1210; HHA; V +1211; HHU; U +1212; HHI; I +1213; HHAA; A +1214; HHEE; E +1215; HHE; C +1216; HHO; O +1217; HHWA; WA +1218; MA; V +1219; MU; U +121A; MI; I +121B; MAA; A +121C; MEE; E +121D; ME; C +121E; MO; O +121F; MWA; WA +1220; SZA; V +1221; SZU; U +1222; SZI; I +1223; SZAA; A +1224; SZEE; E +1225; SZE; C +1226; SZO; O +1227; SZWA; WA +1228; RA; V +1229; RU; U +122A; RI; I +122B; RAA; A +122C; REE; E +122D; RE; C +122E; RO; O +122F; RWA; WA +1230; SA; V +1231; SU; U +1232; SI; I +1233; SAA; A +1234; SEE; E +1235; SE; C +1236; SO; O +1237; SWA; WA +1238; SHA; V +1239; SHU; U +123A; SHI; I +123B; SHAA; A +123C; SHEE; E +123D; SHE; C +123E; SHO; O +123F; SHWA; WA +1240; QA; V +1241; QU; U +1242; QI; I +1243; QAA; A +1244; QEE; E +1245; QE; C +1246; QO; O +1248; QWA; WV +124A; QWI; WI +124B; QWAA; WA +124C; QWEE; WE +124D; QWE; WC +1250; QHA; V +1251; QHU; U +1252; QHI; I +1253; QHAA; A +1254; QHEE; E +1255; QHE; C +1256; QHO; O +1258; QHWA; WV +125A; QHWI; WI +125B; QHWAA; WA +125C; QHWEE; WE +125D; QHWE; WC +1260; BA; V +1261; BU; U +1262; BI; I +1263; BAA; A +1264; BEE; E +1265; BE; C +1266; BO; O +1267; BWA; WA +1268; VA; V +1269; VU; U +126A; VI; I +126B; VAA; A +126C; VEE; E +126D; VE; C +126E; VO; O +126F; VWA; WA +1270; TA; V +1271; TU; U +1272; TI; I +1273; TAA; A +1274; TEE; E +1275; TE; C +1276; TO; O +1277; TWA; WA +1278; CA; V +1279; CU; U +127A; CI; I +127B; CAA; A +127C; CEE; E +127D; CE; C +127E; CO; O +127F; CWA; WA +1280; XA; V +1281; XU; U +1282; XI; I +1283; XAA; A +1284; XEE; E +1285; XE; C +1286; XO; O +1288; XWA; WV +128A; XWI; WI +128B; XWAA; WA +128C; XWEE; WE +128D; XWE; WC +1290; NA; V +1291; NU; U +1292; NI; I +1293; NAA; A +1294; NEE; E +1295; NE; C +1296; NO; O +1297; NWA; WA +1298; NYA; V +1299; NYU; U +129A; NYI; I +129B; NYAA; A +129C; NYEE; E +129D; NYE; C +129E; NYO; O +129F; NYWA; WA +12A0; GLOTTAL A; V +12A1; GLOTTAL U; U +12A2; GLOTTAL I; I +12A3; GLOTTAL AA; A +12A4; GLOTTAL EE; E +12A5; GLOTTAL E; C +12A6; GLOTTAL O; O +12A7; GLOTTAL WA; WA +12A8; KA; V +12A9; KU; U +12AA; KI; I +12AB; KAA; A +12AC; KEE; E +12AD; KE; C +12AE; KO; O +12B0; KWA; WV +12B2; KWI; WI +12B3; KWAA; WA +12B4; KWEE; WE +12B5; KWE; WC +12B8; KXA; V +12B9; KXU; U +12BA; KXI; I +12BB; KXAA; A +12BC; KXEE; E +12BD; KXE; C +12BE; KXO; O +12C0; KXWA; WV +12C2; KXWI; WI +12C3; KXWAA; WA +12C4; KXWEE; WE +12C5; KXWE; WC +12C8; WA; V +12C9; WU; U +12CA; WI; I +12CB; WAA; A +12CC; WEE; E +12CD; WE; C +12CE; WO; O +12D0; PHARYNGEAL A; V +12D1; PHARYNGEAL U; U +12D2; PHARYNGEAL I; I +12D3; PHARYNGEAL AA; A +12D4; PHARYNGEAL EE; E +12D5; PHARYNGEAL E; C +12D6; PHARYNGEAL O; O +12D8; ZA; V +12D9; ZU; U +12DA; ZI; I +12DB; ZAA; A +12DC; ZEE; E +12DD; ZE; C +12DE; ZO; O +12DF; ZWA; WA +12E0; ZHA; V +12E1; ZHU; U +12E2; ZHI; I +12E3; ZHAA; A +12E4; ZHEE; E +12E5; ZHE; C +12E6; ZHO; O +12E7; ZHWA; WA +12E8; YA; V +12E9; YU; U +12EA; YI; I +12EB; YAA; A +12EC; YEE; E +12ED; YE; C +12EE; YO; O +12F0; DA; V +12F1; DU; U +12F2; DI; I +12F3; DAA; A +12F4; DEE; E +12F5; DE; C +12F6; DO; O +12F7; DWA; WA +12F8; DDA; V +12F9; DDU; U +12FA; DDI; I +12FB; DDAA; A +12FC; DDEE; E +12FD; DDE; C +12FE; DDO; O +12FF; DDWA; WA +1300; JA; V +1301; JU; U +1302; JI; I +1303; JAA; A +1304; JEE; E +1305; JE; C +1306; JO; O +1307; JWA; WA +1308; GA; V +1309; GU; U +130A; GI; I +130B; GAA; A +130C; GEE; E +130D; GE; C +130E; GO; O +1310; GWA; WV +1312; GWI; WI +1313; GWAA; WA +1314; GWEE; WE +1315; GWE; WC +1318; GGA; V +1319; GGU; U +131A; GGI; I +131B; GGAA; A +131C; GGEE; E +131D; GGE; C +131E; GGO; O +1320; THA; V +1321; THU; U +1322; THI; I +1323; THAA; A +1324; THEE; E +1325; THE; C +1326; THO; O +1327; THWA; WA +1328; CHA; V +1329; CHU; U +132A; CHI; I +132B; CHAA; A +132C; CHEE; E +132D; CHE; C +132E; CHO; O +132F; CHWA; WA +1330; PHA; V +1331; PHU; U +1332; PHI; I +1333; PHAA; A +1334; PHEE; E +1335; PHE; C +1336; PHO; O +1337; PHWA; WA +1338; TSA; V +1339; TSU; U +133A; TSI; I +133B; TSAA; A +133C; TSEE; E +133D; TSE; C +133E; TSO; O +133F; TSWA; WA +1340; TZA; V +1341; TZU; U +1342; TZI; I +1343; TZAA; A +1344; TZEE; E +1345; TZE; C +1346; TZO; O +1348; FA; V +1349; FU; U +134A; FI; I +134B; FAA; A +134C; FEE; E +134D; FE; C +134E; FO; O +134F; FWA; WA +1350; PA; V +1351; PU; U +1352; PI; I +1353; PAA; A +1354; PEE; E +1355; PE; C +1356; PO; O +1357; PWA; WA +# +# Cherokee +# +13A0; A; A +13A1; E; E +13A2; I; I +13A3; O; O +13A4; U; U +13A5; V; V +13A6; GA; A +13A7; KA; A +13A8; GE; E +13A9; GI; I +13AA; GO; O +13AB; GU; U +13AC; GV; V +13AD; HA; A +13AE; HE; E +13AF; HI; I +13B0; HO; O +13B1; HU; U +13B2; HV; V +13B3; LA; A +13B4; LE; E +13B5; LI; I +13B6; LO; O +13B7; LU; U +13B8; LV; V +13B9; MA; A +13BA; ME; E +13BB; MI; I +13BC; MO; O +13BD; MU; U +13BE; NA; A +13BF; HNA; A +13C0; NAH; C +13C1; NE; E +13C2; NI; I +13C3; NO; O +13C4; NU; U +13C5; NV; V +13C6; QUA; A +13C7; QUE; E +13C8; QUI; I +13C9; QUO; O +13CA; QUU; U +13CB; QUV; V +13CC; SA; A +13CD; S; C +13CE; SE; E +13CF; SI; I +13D0; SO; O +13D1; SU; U +13D2; SV; V +13D3; DA; A +13D4; TA; A +13D5; DE; E +13D6; TE; E +13D7; DI; I +13D8; TI; I +13D9; DO; O +13DA; DU; U +13DB; DV; V +13DC; DLA; A +13DD; TLA; A +13DE; TLE; E +13DF; TLI; I +13E0; TLO; O +13E1; TLU; U +13E2; TLV; V +13E3; TSA; A +13E4; TSE; E +13E5; TSI; I +13E6; TSO; O +13E7; TSU; U +13E8; TSV; V +13E9; WA; A +13EA; WE; E +13EB; WI; I +13EC; WO; O +13ED; WU; U +13EE; WV; V +13EF; YA; A +13F0; YE; E +13F1; YI; I +13F2; YO; O +13F3; YU; U +13F4; YV; V +# +# 1400 Unified Canadian Aboriginal Syllabics 167F +# +1401; E; E +1402; AAI; AAI +1403; I; I +1404; II; II +1405; O; O +1406; OO; OO +1407; Y-CREE OO; OO +1408; CARRIER EE; EE +1409; CARRIER I; I +140A; A; A +140B; AA; AA +140C; WE; WE +140D; WEST-CREE WE; WE +140E; WI; WI +140F; WEST-CREE WI; WI +1410; WII; WII +1411; WEST-CREE WII; WII +1412; WO; WO +1413; WEST-CREE WO; WO +1414; WOO; WOO +1415; WEST-CREE WOO; WOO +1416; NASKAPI WOO; WOO +1417; WA; WA +1418; WEST-CREE WA; WA +1419; WAA; WAA +141A; WEST-CREE WAA; WAA +141B; NASKAPI WAA; WAA +141C; AI; AI +141D; Y-CREE W; C +142B; EN; C +142C; IN; C +142D; ON; C +142E; AN; C +142F; PE; E +1430; PAAI; AAI +1431; PI; I +1432; PII; II +1433; PO; O +1434; POO; OO +1435; Y-CREE POO; OO +1436; CARRIER HEE; EE +1437; CARRIER HI; I +1438; PA; A +1439; PAA; AA +143A; PWE; WE +143B; WEST-CREE PWE; WE +143C; PWI; WI +143D; WEST-CREE PWI; WI +143E; PWII; WII +143F; WEST-CREE PWII; WII +1440; PWO; WO +1441; WEST-CREE PWO; WO +1442; PWOO; WOO +1443; WEST-CREE PWOO; WOO +1444; PWA; WA +1445; WEST-CREE PWA; WA +1446; PWAA; WAA +1447; WEST-CREE PWAA; WAA +1448; Y-CREE PWAA; WAA +1449; P; C +144A; WEST-CREE P; C +144B; CARRIER H; C +144C; TE; E +144D; TAAI; AAI +144E; TI; I +144F; TII; II +1450; TO; O +1451; TOO; OO +1452; Y-CREE TOO; OO +1453; CARRIER DEE; EE +1454; CARRIER DI; I +1455; TA; A +1456; TAA; AA +1457; TWE; WE +1458; WEST-CREE TWE; WE +1459; TWI; WI +145A; WEST-CREE TWI; WI +145B; TWII; WII +145C; WEST-CREE TWII; WII +145D; TWO; WO +145E; WEST-CREE TWO; WO +145F; TWOO; WOO +1460; WEST-CREE TWOO; WOO +1461; TWA; WA +1462; WEST-CREE TWA; WA +1463; TWAA; WAA +1464; WEST-CREE TWAA; WAA +1465; NASKAPI TWAA; WAA +1466; T; C +1467; TTE; E +1468; TTI; I +1469; TTO; O +146A; TTA; A +146B; KE; E +146C; KAAI; AAI +146D; KI; I +146E; KII; II +146F; KO; O +1470; KOO; OO +1471; Y-CREE KOO; OO +1472; KA; A +1473; KAA; AA +1474; KWE; WE +1475; WEST-CREE KWE; WE +1476; KWI; WI +1477; WEST-CREE KWI; WI +1478; KWII; WII +1479; WEST-CREE KWII; WII +147A; KWO; WO +147B; WEST-CREE KWO; WO +147C; KWOO; WOO +147D; WEST-CREE KWOO; WOO +147E; KWA; WA +147F; WEST-CREE KWA; WA +1480; KWAA; WAA +1481; WEST-CREE KWAA; WAA +1482; NASKAPI KWAA; WAA +1483; K; C +1484; KW; WC +1485; SOUTH-SLAVEY KEH; C +1486; SOUTH-SLAVEY KIH; C +1487; SOUTH-SLAVEY KOH; C +1488; SOUTH-SLAVEY KAH; C +1489; CE; E +148A; CAAI; AAI +148B; CI; I +148C; CII; II +148D; CO; O +148E; COO; OO +148F; Y-CREE COO; OO +1490; CA; A +1491; CAA; AA +1492; CWE; WE +1493; WEST-CREE CWE; WE +1494; CWI; WI +1495; WEST-CREE CWI; WI +1496; CWII; WII +1497; WEST-CREE CWII; WII +1498; CWO; WO +1499; WEST-CREE CWO; WO +149A; CWOO; WOO +149B; WEST-CREE CWOO; WOO +149C; CWA; WA +149D; WEST-CREE CWA; WA +149E; CWAA; WAA +149F; WEST-CREE CWAA; WAA +14A0; NASKAPI CWAA; WAA +14A1; C; C +14A2; SAYISI TH; +14A3; ME; E +14A4; MAAI; AAI +14A5; MI; I +14A6; MII; II +14A7; MO; O +14A8; MOO; OO +14A9; Y-CREE MOO; OO +14AA; MA; A +14AB; MAA; AA +14AC; MWE; WE +14AD; WEST-CREE MWE; WE +14AE; MWI; WI +14AF; WEST-CREE MWI; WI +14B0; MWII; WII +14B1; WEST-CREE MWII; WII +14B2; MWO; WO +14B3; WEST-CREE MWO; WO +14B4; MWOO; WOO +14B5; WEST-CREE MWOO; WOO +14B6; MWA; WA +14B7; WEST-CREE MWA; WA +14B8; MWAA; WAA +14B9; WEST-CREE MWAA; WAA +14BA; NASKAPI MWAA; WAA +14BB; M; C +14BC; WEST-CREE M; C +14BD; MH; C +14BE; ATHAPASCAN M; C +14BF; SAYISI M; C +14C0; NE; E +14C1; NAAI; AAI +14C2; NI; I +14C3; NII; II +14C4; NO; O +14C5; NOO; OO +14C6; Y-CREE NOO; OO +14C7; NA; A +14C8; NAA; AA +14C9; NWE; WE +14CA; WEST-CREE NWE; WE +14CB; NWA; WA +14CC; WEST-CREE NWA; WA +14CD; NWAA; WAA +14CE; WEST-CREE NWAA; WAA +14CF; NASKAPI NWAA; WAA +14D0; N; C +14D1; CARRIER NG; C +14D2; NH; C +14D3; LE; E +14D4; LAAI; AAI +14D5; LI; I +14D6; LII; II +14D7; LO; O +14D8; LOO; OO +14D9; Y-CREE LOO; OO +14DA; LA; A +14DB; LAA; AA +14DC; LWE; WE +14DD; WEST-CREE LWE; WE +14DE; LWI; WI +14DF; WEST-CREE LWI; WI +14E0; LWII; WII +14E1; WEST-CREE LWII; WII +14E2; LWO; WO +14E3; WEST-CREE LWO; WO +14E4; LWOO; WOO +14E5; WEST-CREE LWOO; WOO +14E6; LWA; WA +14E7; WEST-CREE LWA; WA +14E8; LWAA; WAA +14E9; WEST-CREE LWAA; WAA +14EA; L; C +14EB; WEST-CREE L; C +14EC; MEDIAL L; C +14ED; SE; E +14EE; SAAI; AAI +14EF; SI; I +14F0; SII; II +14F1; SO; O +14F2; SOO; OO +14F3; Y-CREE SOO; OO +14F4; SA; A +14F5; SAA; AA +14F6; SWE; WE +14F7; WEST-CREE SWE; WE +14F8; SWI; WI +14F9; WEST-CREE SWI; WI +14FA; SWII; WII +14FB; WEST-CREE SWII; WII +14FC; SWO; WO +14FD; WEST-CREE SWO; WO +14FE; SWOO; WOO +14FF; WEST-CREE SWOO; WOO +1500; SWA; WA +1501; WEST-CREE SWA; WA +1502; SWAA; WAA +1503; WEST-CREE SWAA; WAA +1504; NASKAPI SWAA; WAA +1505; S; C +1506; ATHAPASCAN S; C +1507; SW; WC +1508; BLACKFOOT S; C +1509; MOOSE-CREE SK;C +150A; NASKAPI SKW; C +150B; NASKAPI S-W; C +150C; NASKAPI SPWA; WA +150D; NASKAPI STWA; WA +150E; NASKAPI SKWA; WA +150F; NASKAPI SCWA; WA +1510; SHE; E +1511; SHI; I +1512; SHII; II +1513; SHO; O +1514; SHOO; OO +1515; SHA; A +1516; SHAA; AA +1517; SHWE; WE +1518; WEST-CREE SHWE; WE +1519; SHWI; WI +151A; WEST-CREE SHWI; WI +151B; SHWII; WII +151C; WEST-CREE SHWII; WII +151D; SHWO; WO +151E; WEST-CREE SHWO; WO +151F; SHWOO; WOO +1520; WEST-CREE SHWOO; WOO +1521; SHWA; WA +1522; WEST-CREE SHWA; WA +1523; SHWAA; WAA +1524; WEST-CREE SHWAA; WAA +1525; SH; C +1526; YE; E +1527; YAAI; AAI +1528; YI; I +1529; YII; II +152A; YO; O +152B; YOO; OO +152C; Y-CREE YOO; OO +152D; YA; A +152E; YAA; AA +152F; YWE; WE +1530; WEST-CREE YWE; WE +1531; YWI; WI +1532; WEST-CREE YWI; WI +1533; YWII; WII +1534; WEST-CREE YWII; WII +1535; YWO; WO +1536; WEST-CREE YWO; WO +1537; YWOO; WOO +1538; WEST-CREE YWOO; WOO +1539; YWA; WA +153A; WEST-CREE YWA; WA +153B; YWAA; WAA +153C; WEST-CREE YWAA; WAA +153D; NASKAPI YWAA; WAA +153E; Y; C +153F; BIBLE-CREE Y; C +1540; WEST-CREE Y; C +1541; SAYISI YI; I +1542; RE; E +1543; R-CREE RE; E +1544; WEST-CREE LE; E +1545; RAAI; AAI +1546; RI; I +1547; RII; II +1548; RO; O +1549; ROO; OO +154A; WEST-CREE LO; O +154B; RA; A +154C; RAA; AA +154D; WEST-CREE LA; A +154E; RWAA; WAA +154F; WEST-CREE RWAA; WAA +1550; R; C +1551; WEST-CREE R; C +1552; MEDIAL R; C +1553; FE; E +1554; FAAI; AAI +1555; FI; I +1556; FII; II +1557; FO; O +1558; FOO; OO +1559; FA; A +155A; FAA; AA +155B; FWAA; WAA +155C; WEST-CREE FWAA; WAA +155D; F; C +155E; THE; E +155F; N-CREE THE; E +1560; THI; I +1561; N-CREE THI; I +1562; THII; II +1563; N-CREE THII; II +1564; THO; O +1565; THOO; OO +1566; THA; A +1567; THAA; AA +1568; THWAA; WAA +1569; WEST-CREE THWAA; WAA +156A; TH; C +156B; TTHE; E +156C; TTHI; I +156D; TTHO; O +156E; TTHA; A +156F; TTH; C +1570; TYE; E +1571; TYI; I +1572; TYO; O +1573; TYA; A +1574; NUNAVIK HE; E +1575; NUNAVIK HI; I +1576; NUNAVIK HII; II +1577; NUNAVIK HO; O +1578; NUNAVIK HOO; OO +1579; NUNAVIK HA; A +157A; NUNAVIK HAA; AA +157B; NUNAVIK H; C +157C; NUNAVUT H; C +157D; HK; C +157E; QAAI; AAI +157F; QI; I +1580; QII; II +1581; QO; O +1582; QOO; OO +1583; QA; A +1584; QAA; AA +1585; Q; C +1586; TLHE; E +1587; TLHI; I +1588; TLHO; O +1589; TLHA; A +158A; WEST-CREE RE; E +158B; WEST-CREE RI; I +158C; WEST-CREE RO; O +158D; WEST-CREE RA; A +158E; NGAAI; AAI +158F; NGI; I +1590; NGII; II +1591; NGO; O +1592; NGOO; OO +1593; NGA; A +1594; NGAA; AA +1595; NG; C +1596; NNG; C +1597; SAYISI SHE; E +1598; SAYISI SHI; I +1599; SAYISI SHO; O +159A; SAYISI SHA; A +159B; WOODS-CREE THE; E +159C; WOODS-CREE THI; I +159D; WOODS-CREE THO; O +159E; WOODS-CREE THA; A +159F; WOODS-CREE TH; C +15A0; LHI; I +15A1; LHII; II +15A2; LHO; O +15A3; LHOO; OO +15A4; LHA; A +15A5; LHAA; AA +15A6; LH; C +15A7; TH-CREE THE; E +15A8; TH-CREE THI; I +15A9; TH-CREE THII; II +15AA; TH-CREE THO; O +15AB; TH-CREE THOO; OO +15AC; TH-CREE THA; A +15AD; TH-CREE THAA; AA +15AE; TH-CREE TH; C +15AF; AIVILIK B; C +15B0; BLACKFOOT E; E +15B1; BLACKFOOT I; I +15B2; BLACKFOOT O; O +15B3; BLACKFOOT A; A +15B4; BLACKFOOT WE; E +15B5; BLACKFOOT WI; I +15B6; BLACKFOOT WO; O +15B7; BLACKFOOT WA; A +15B8; BLACKFOOT NE; E +15B9; BLACKFOOT NI; I +15BA; BLACKFOOT NO; O +15BB; BLACKFOOT NA; A +15BC; BLACKFOOT KE; E +15BD; BLACKFOOT KI; I +15BE; BLACKFOOT KO; O +15BF; BLACKFOOT KA; A +15C0; SAYISI HE; E +15C1; SAYISI HI; I +15C2; SAYISI HO; O +15C3; SAYISI HA; A +15C4; CARRIER GHU; U +15C5; CARRIER GHO; O +15C6; CARRIER GHE; E +15C7; CARRIER GHEE; EE +15C8; CARRIER GHI; I +15C9; CARRIER GHA; A +15CA; CARRIER RU; U +15CB; CARRIER RO; O +15CC; CARRIER RE; E +15CD; CARRIER REE; EE +15CE; CARRIER RI; I +15CF; CARRIER RA; A +15D0; CARRIER WU; U +15D1; CARRIER WO; O +15D2; CARRIER WE; E +15D3; CARRIER WEE; EE +15D4; CARRIER WI; I +15D5; CARRIER WA; A +15D6; CARRIER HWU; WU +15D7; CARRIER HWO; WO +15D8; CARRIER HWE; WE +15D9; CARRIER HWEE; WEE +15DA; CARRIER HWI; WI +15DB; CARRIER HWA; WA +15DC; CARRIER THU; U +15DD; CARRIER THO; O +15DE; CARRIER THE; E +15DF; CARRIER THEE; EE +15E0; CARRIER THI; I +15E1; CARRIER THA; A +15E2; CARRIER TTU; U +15E3; CARRIER TTO; O +15E4; CARRIER TTE; E +15E5; CARRIER TTEE; EE +15E6; CARRIER TTI; I +15E7; CARRIER TTA; A +15E8; CARRIER PU; U +15E9; CARRIER PO; O +15EA; CARRIER PE; E +15EB; CARRIER PEE; EE +15EC; CARRIER PI; I +15ED; CARRIER PA; A +15EE; CARRIER P; +15EF; CARRIER GU; U +15F0; CARRIER GO; O +15F1; CARRIER GE; E +15F2; CARRIER GEE; EE +15F3; CARRIER GI; I +15F4; CARRIER GA; A +15F5; CARRIER KHU; U +15F6; CARRIER KHO; O +15F7; CARRIER KHE; E +15F8; CARRIER KHEE; EE +15F9; CARRIER KHI; I +15FA; CARRIER KHA; A +15FB; CARRIER KKU; U +15FC; CARRIER KKO; O +15FD; CARRIER KKE; E +15FE; CARRIER KKEE; EE +15FF; CARRIER KKI; I +1600; CARRIER KKA; A +1601; CARRIER KK; +1602; CARRIER NU; U +1603; CARRIER NO; O +1604; CARRIER NE; E +1605; CARRIER NEE; EE +1606; CARRIER NI; I +1607; CARRIER NA; A +1608; CARRIER MU; U +1609; CARRIER MO; O +160A; CARRIER ME; E +160B; CARRIER MEE; EE +160C; CARRIER MI; I +160D; CARRIER MA; A +160E; CARRIER YU; U +160F; CARRIER YO; O +1610; CARRIER YE; E +1611; CARRIER YEE; EE +1612; CARRIER YI; I +1613; CARRIER YA; A +1614; CARRIER JU; U +1615; SAYISI JU; U +1616; CARRIER JO; O +1617; CARRIER JE; E +1618; CARRIER JEE; EE +1619; CARRIER JI; I +161A; SAYISI JI; I +161B; CARRIER JA; A +161C; CARRIER JJU; U +161D; CARRIER JJO; O +161E; CARRIER JJE; E +161F; CARRIER JJEE; EE +1620; CARRIER JJI; I +1621; CARRIER JJA; A +1622; CARRIER LU; U +1623; CARRIER LO; O +1624; CARRIER LE; E +1625; CARRIER LEE; EE +1626; CARRIER LI; I +1627; CARRIER LA; A +1628; CARRIER DLU; U +1629; CARRIER DLO; O +162A; CARRIER DLE; E +162B; CARRIER DLEE; EE +162C; CARRIER DLI; I +162D; CARRIER DLA; A +162E; CARRIER LHU; U +162F; CARRIER LHO; O +1630; CARRIER LHE; E +1631; CARRIER LHEE; EE +1632; CARRIER LHI; I +1633; CARRIER LHA; A +1634; CARRIER TLHU; U +1635; CARRIER TLHO; O +1636; CARRIER TLHE; E +1637; CARRIER TLHEE; EE +1638; CARRIER TLHI; I +1639; CARRIER TLHA; A +163A; CARRIER TLU; U +163B; CARRIER TLO; O +163C; CARRIER TLE; E +163D; CARRIER TLEE; EE +163E; CARRIER TLI; I +163F; CARRIER TLA; A +1640; CARRIER ZU; U +1641; CARRIER ZO; O +1642; CARRIER ZE; E +1643; CARRIER ZEE; EE +1644; CARRIER ZI; I +1645; CARRIER ZA; A +1646; CARRIER Z; +1647; CARRIER INITIAL Z; +1648; CARRIER DZU; U +1649; CARRIER DZO; O +164A; CARRIER DZE; E +164B; CARRIER DZEE; EE +164C; CARRIER DZI; I +164D; CARRIER DZA; A +164E; CARRIER SU; U +164F; CARRIER SO; O +1650; CARRIER SE; E +1651; CARRIER SEE; EE +1652; CARRIER SI; I +1653; CARRIER SA; A +1654; CARRIER SHU; U +1655; CARRIER SHO; O +1656; CARRIER SHE; E +1657; CARRIER SHEE; EE +1658; CARRIER SHI; I +1659; CARRIER SHA; A +165A; CARRIER SH; +165B; CARRIER TSU; U +165C; CARRIER TSO; O +165D; CARRIER TSE; E +165E; CARRIER TSEE; EE +165F; CARRIER TSI; I +1660; CARRIER TSA; A +1661; CARRIER CHU; U +1662; CARRIER CHO; O +1663; CARRIER CHE; E +1664; CARRIER CHEE; EE +1665; CARRIER CHI; I +1666; CARRIER CHA; A +1667; CARRIER TTSU; U +1668; CARRIER TTSO; O +1669; CARRIER TTSE; E +166A; CARRIER TTSEE; EE +166B; CARRIER TTSI; I +166C; CARRIER TTSA; A +166F; QAI; AI +1670; NGAI; AI +1671; NNGI; I +1672; NNGII; II +1673; NNGO; O +1674; NNGOO; OO +1675; NNGA; A +1676; NNGAA; AA +# +# Katakana +# +30A1; SMALL A; A +30A2; A; A +30A3; SMALL I; I +30A4; I; I +30A5; SMALL U; U +30A6; U; U +30A7; SMALL E; E +30A8; E; E +30A9; SMALL O; O +30AA; O; O +30AB; KA; A +30AC; GA; A +30AD; KI; I +30AE; GI; I +30AF; KU; U +30B0; GU; U +30B1; KE; E +30B2; GE; E +30B3; KO; O +30B4; GO; O +30B5; SA; A +30B6; ZA; A +30B7; SI; I +30B8; ZI; I +30B9; SU; U +30BA; ZU; U +30BB; SE; E +30BC; ZE; E +30BD; SO; O +30BE; ZO; O +30BF; TA; A +30C0; DA; A +30C1; TI; I +30C2; DI; I +30C3; SMALL TU; U +30C4; TU; U +30C5; DU; U +30C6; TE; E +30C7; DE; E +30C8; TO; O +30C9; DO; O +30CA; NA; A +30CB; NI; I +30CC; NU; U +30CD; NE; E +30CE; NO; O +30CF; HA; A +30D0; BA; A +30D1; PA; A +30D2; HI; I +30D3; BI; I +30D4; PI; I +30D5; HU; U +30D6; BU; U +30D7; PU; U +30D8; HE; E +30D9; BE; E +30DA; PE; E +30DB; HO; O +30DC; BO; O +30DD; PO; O +30DE; MA; A +30DF; MI; I +30E0; MU; U +30E1; ME; E +30E2; MO; O +30E3; SMALL YA; A +30E4; YA; A +30E5; SMALL YU; U +30E6; YU; U +30E7; SMALL YO; O +30E8; YO; O +30E9; RA; A +30EA; RI; I +30EB; RU; U +30EC; RE; E +30ED; RO; O +30EE; SMALL WA; A +30EF; WA; A +30F0; WI; I +30F1; WE; E +30F2; WO; O +30F3; N; C +30F4; VU; U +30F5; SMALL KA; A +30F6; SMALL KE; E +30F7; VA; A +30F8; VI; I +30F9; VE; E +30FA; VO; O +32D0; CIRCLED KATAKANA A; A +32D1; CIRCLED KATAKANA I; I +32D2; CIRCLED KATAKANA U; U +32D3; CIRCLED KATAKANA E; E +32D4; CIRCLED KATAKANA O; O +32D5; CIRCLED KATAKANA KA; A +32D6; CIRCLED KATAKANA KI; I +32D7; CIRCLED KATAKANA KU; U +32D8; CIRCLED KATAKANA KE; E +32D9; CIRCLED KATAKANA KO; O +32DA; CIRCLED KATAKANA SA; A +32DB; CIRCLED KATAKANA SI; I +32DC; CIRCLED KATAKANA SU; U +32DD; CIRCLED KATAKANA SE; E +32DE; CIRCLED KATAKANA SO; O +32DF; CIRCLED KATAKANA TA; A +32E0; CIRCLED KATAKANA TI; I +32E1; CIRCLED KATAKANA TU; U +32E2; CIRCLED KATAKANA TE; E +32E3; CIRCLED KATAKANA TO; O +32E4; CIRCLED KATAKANA NA; A +32E5; CIRCLED KATAKANA NI; I +32E6; CIRCLED KATAKANA NU; U +32E7; CIRCLED KATAKANA NE; E +32E8; CIRCLED KATAKANA NO; O +32E9; CIRCLED KATAKANA HA; A +32EA; CIRCLED KATAKANA HI; I +32EB; CIRCLED KATAKANA HU; U +32EC; CIRCLED KATAKANA HE; E +32ED; CIRCLED KATAKANA HO; O +32EE; CIRCLED KATAKANA MA; A +32EF; CIRCLED KATAKANA MI; I +32F0; CIRCLED KATAKANA MU; U +32F1; CIRCLED KATAKANA ME; E +32F2; CIRCLED KATAKANA MO; O +32F3; CIRCLED KATAKANA YA; A +32F4; CIRCLED KATAKANA YU; U +32F5; CIRCLED KATAKANA YO; O +32F6; CIRCLED KATAKANA RA; A +32F7; CIRCLED KATAKANA RI; I +32F8; CIRCLED KATAKANA RU; U +32F9; CIRCLED KATAKANA RE; E +32FA; CIRCLED KATAKANA RO; O +32FB; CIRCLED KATAKANA WA; A +32FC; CIRCLED KATAKANA WI; I +32FD; CIRCLED KATAKANA WE; E +32FE; CIRCLED KATAKANA WO; O +# +# Katakana +# +FF66; HALFWIDTH WO; O +FF67; HALFWIDTH SMALL A; A +FF68; HALFWIDTH SMALL I; I +FF69; HALFWIDTH SMALL U; U +FF6A; HALFWIDTH SMALL E; E +FF6B; HALFWIDTH SMALL O; O +FF6C; HALFWIDTH SMALL YA; A +FF6D; HALFWIDTH SMALL YU; U +FF6E; HALFWIDTH SMALL YO; O +FF6F; HALFWIDTH SMALL TU; U +FF71; HALFWIDTH A; A +FF72; HALFWIDTH I; I +FF73; HALFWIDTH U; U +FF74; HALFWIDTH E; E +FF75; HALFWIDTH O; O +FF76; HALFWIDTH KA; A +FF77; HALFWIDTH KI; I +FF78; HALFWIDTH KU; U +FF79; HALFWIDTH KE; E +FF7A; HALFWIDTH KO; O +FF7B; HALFWIDTH SA; A +FF7C; HALFWIDTH SI; I +FF7D; HALFWIDTH SU; U +FF7E; HALFWIDTH SE; E +FF7F; HALFWIDTH SO; O +FF80; HALFWIDTH TA; A +FF81; HALFWIDTH TI; I +FF82; HALFWIDTH TU; U +FF83; HALFWIDTH TE; E +FF84; HALFWIDTH TO; O +FF85; HALFWIDTH NA; A +FF86; HALFWIDTH NI; I +FF87; HALFWIDTH NU; U +FF88; HALFWIDTH NE; E +FF89; HALFWIDTH NO; O +FF8A; HALFWIDTH HA; A +FF8B; HALFWIDTH HI; I +FF8C; HALFWIDTH HU; U +FF8D; HALFWIDTH HE; E +FF8E; HALFWIDTH HO; O +FF8F; HALFWIDTH MA; A +FF90; HALFWIDTH MI; I +FF91; HALFWIDTH MU; U +FF92; HALFWIDTH ME; E +FF93; HALFWIDTH MO; O +FF94; HALFWIDTH YA; A +FF95; HALFWIDTH YU; U +FF96; HALFWIDTH YO; O +FF97; HALFWIDTH RA; A +FF98; HALFWIDTH RI; I +FF99; HALFWIDTH RU; U +FF9A; HALFWIDTH RE; E +FF9B; HALFWIDTH RO; O +FF9C; HALFWIDTH WA; A +FF9D; HALFWIDTH N; C +# +# Hiragana +# +3041; SMALL A; A +3042; A; A +3043; SMALL I; I +3044; I; I +3045; SMALL U; U +3046; U; U +3047; SMALL E; E +3048; E; E +3049; SMALL O; O +304A; O; O +304B; KA; A +304C; GA; A +304D; KI; I +304E; GI; I +304F; KU; U +3050; GU; U +3051; KE; E +3052; GE; E +3053; KO; O +3054; GO; O +3055; SA; A +3056; ZA; A +3057; SI; I +3058; ZI; I +3059; SU; U +305A; ZU; U +305B; SE; E +305C; ZE; E +305D; SO; O +305E; ZO; O +305F; TA; A +3060; DA; A +3061; TI; I +3062; DI; I +3063; SMALL TU; U +3064; TU; U +3065; DU; U +3066; TE; E +3067; DE; E +3068; TO; O +3069; DO; O +306A; NA; A +306B; NI; I +306C; NU; U +306D; NE; E +306E; NO; O +306F; HA; A +3070; BA; A +3071; PA; A +3072; HI; I +3073; BI; I +3074; PI; I +3075; HU; U +3076; BU; U +3077; PU; U +3078; HE; E +3079; BE; E +307A; PE; E +307B; HO; O +307C; BO; O +307D; PO; O +307E; MA; A +307F; MI; I +3080; MU; U +3081; ME; E +3082; MO; O +3083; SMALL YA; A +3084; YA; A +3085; SMALL YU; U +3086; YU; U +3087; SMALL YO; O +3088; YO; O +3089; RA; A +308A; RI; I +308B; RU; U +308C; RE; E +308D; RO; O +308E; SMALL WA; A +308F; WA; A +3090; WI; I +3091; WE; E +3092; WO; O +3093; N; N +3094; VU; U diff --git a/lib/utf8.pm b/lib/utf8.pm index 6d6c0eb..f06b893 100644 --- a/lib/utf8.pm +++ b/lib/utf8.pm @@ -4,6 +4,8 @@ if (ord('A') != 193) { # make things more pragmatic for EBCDIC folk $utf8::hint_bits = 0x00800000; +our $VERSION = '1.00'; + sub import { $^H |= $utf8::hint_bits; $enc{caller()} = $_[1] if $_[1]; diff --git a/lib/vars.pm b/lib/vars.pm index 0ace551..d39f197 100644 --- a/lib/vars.pm +++ b/lib/vars.pm @@ -2,6 +2,8 @@ package vars; require 5.002; +our $VERSION = '1.00'; + # The following require can't be removed during maintenance # releases, sadly, because of the risk of buggy code that does # require Carp; Carp::croak "..."; without brackets dying @@ -10,6 +12,7 @@ require 5.002; require Carp if $] < 5.00450; use warnings::register; +require strict; sub import { my $callpack = caller; @@ -26,6 +29,8 @@ sub import { Carp::croak("Can't declare individual elements of hash or array"); } elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) { warnings::warn("No need to declare built-in vars"); + } elsif ( $^H &= strict::bits('vars') ) { + Carp::croak("'$ch$sym' is not a valid variable name under strict vars"); } } *{"${callpack}::$sym"} = diff --git a/lib/warnings.pm b/lib/warnings.pm index 2517239..e341641 100644 --- a/lib/warnings.pm +++ b/lib/warnings.pm @@ -5,6 +5,8 @@ package warnings; +our $VERSION = '1.00'; + =head1 NAME warnings - Perl pragma to control optional warnings @@ -39,7 +41,7 @@ warnings - Perl pragma to control optional warnings If no import list is supplied, all possible warnings are either enabled or disabled. -A number of functions are provided to assist module authors. +A number of functions are provided to assist module authors. =over 4 @@ -295,7 +297,7 @@ sub bits { $mask |= $DeadBits{$word} if $fatal ; } else - { croak("unknown warnings category '$word'")} + { croak("unknown warnings category '$word'")} } return $mask ; @@ -341,13 +343,13 @@ sub __chk unless defined $offset; } else { - $category = (caller(1))[0] ; + $category = (caller(1))[0] ; $offset = $Offsets{$category}; croak("package '$category' not registered for warnings") unless defined $offset ; } - my $this_pkg = (caller(1))[0] ; + my $this_pkg = (caller(1))[0] ; my $i = 2 ; my $pkg ; @@ -361,11 +363,11 @@ sub __chk for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) { last if $pkg ne $this_pkg ; } - $i = 2 + $i = 2 if !$pkg || $pkg eq $this_pkg ; } - my $callers_bitmask = (caller($i))[9] ; + my $callers_bitmask = (caller($i))[9] ; return ($callers_bitmask, $offset, $i) ; } @@ -390,7 +392,7 @@ sub warn my $message = pop ; my ($callers_bitmask, $offset, $i) = __chk(@_) ; local $Carp::CarpLevel = $i ; - croak($message) + croak($message) if vec($callers_bitmask, $offset+1, 1) || vec($callers_bitmask, $Offsets{'all'}+1, 1) ; carp($message) ; @@ -405,12 +407,12 @@ sub warnif my ($callers_bitmask, $offset, $i) = __chk(@_) ; local $Carp::CarpLevel = $i ; - return + return unless defined $callers_bitmask && (vec($callers_bitmask, $offset, 1) || vec($callers_bitmask, $Offsets{'all'}, 1)) ; - croak($message) + croak($message) if vec($callers_bitmask, $offset+1, 1) || vec($callers_bitmask, $Offsets{'all'}+1, 1) ; diff --git a/lib/warnings/register.pm b/lib/warnings/register.pm index f98075a..d40da36 100644 --- a/lib/warnings/register.pm +++ b/lib/warnings/register.pm @@ -1,5 +1,7 @@ package warnings::register ; +our $VERSION = '1.00'; + =pod =head1 NAME diff --git a/makedef.pl b/makedef.pl index a02a298..6a30fc6 100644 --- a/makedef.pl +++ b/makedef.pl @@ -73,7 +73,8 @@ if ($PLATFORM eq 'aix') { } elsif ($PLATFORM eq 'win32') { $CCTYPE = "MSVC" unless defined $CCTYPE; - foreach ($thrdvar_h, $intrpvar_h, $perlvars_h, $global_sym, $pp_sym, $globvar_sym) { + foreach ($thrdvar_h, $intrpvar_h, $perlvars_h, $global_sym, + $pp_sym, $globvar_sym, $perlio_sym) { s!^!..\\!; } } @@ -87,7 +88,7 @@ unless ($PLATFORM eq 'win32') { } if ($PLATFORM eq 'os2') { $CONFIG_ARGS = $1 if /^(?:config_args)='(.+)'$/; - $ARCHNAME = $1 if /^(?:archname)='(.+)'$/; + $ARCHNAME = $1 if /^(?:archname)='(.+)'$/; } } close(CFG); @@ -96,12 +97,9 @@ unless ($PLATFORM eq 'win32') { open(CFG,$config_h) || die "Cannot open $config_h: $!\n"; while () { $define{$1} = 1 if /^\s*#\s*define\s+(MYMALLOC)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(USE_5005THREADS)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(USE_ITHREADS)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(USE_PERLIO)\b/; $define{$1} = 1 if /^\s*#\s*define\s+(MULTIPLICITY)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(PERL_IMPLICIT_SYS)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(PERL_BINCOMPAT_5005)\b/; + $define{$1} = 1 if /^\s*#\s*define\s+(PERL_\w+)\b/; + $define{$1} = 1 if /^\s*#\s*define\s+(USE_\w+)\b/; } close(CFG); @@ -134,7 +132,7 @@ if ($define{PERL_OBJECT}) { if ($PLATFORM eq 'win32') { warn join(' ',keys %define)."\n"; - print "LIBRARY Perl56\n"; + print "LIBRARY Perl57\n"; print "DESCRIPTION 'Perl interpreter'\n"; print "EXPORTS\n"; if ($define{PERL_IMPLICIT_SYS}) { @@ -145,16 +143,7 @@ if ($PLATFORM eq 'win32') { elsif ($PLATFORM eq 'os2') { ($v = $]) =~ s/(\d\.\d\d\d)(\d\d)$/$1_$2/; $v .= '-thread' if $ARCHNAME =~ /-thread/; - #$sum = 0; - #for (split //, $v) { - # $sum = ($sum * 33) + ord; - # $sum &= 0xffffff; - #} - #$sum += $sum >> 5; - #$sum &= 0xffff; - #$sum = printf '%X', $sum; ($dll = $define{PERL_DLL}) =~ s/\.dll$//i; - # print STDERR "'$dll' <= '$define{PERL_DLL}'\n"; print <<"---EOP---"; LIBRARY '$dll' INITINSTANCE TERMINSTANCE DESCRIPTION '\@#perl5-porters\@perl.org:$v#\@ Perl interpreter' @@ -314,7 +303,6 @@ elsif ($PLATFORM eq 'os2') { unless ($define{'DEBUGGING'}) { skip_symbols [qw( - Perl_deb Perl_deb_growlevel Perl_debop Perl_debprofdump @@ -572,6 +560,8 @@ while () { if ($PLATFORM eq 'win32') { foreach my $symbol (qw( + setuid + setgid boot_DynaLoader Perl_init_os_extras Perl_thread_create @@ -579,35 +569,6 @@ if ($PLATFORM eq 'win32') { RunPerl win32_errno win32_environ - win32_stdin - win32_stdout - win32_stderr - win32_ferror - win32_feof - win32_strerror - win32_fprintf - win32_printf - win32_vfprintf - win32_vprintf - win32_fread - win32_fwrite - win32_fopen - win32_fdopen - win32_freopen - win32_fclose - win32_fputs - win32_fputc - win32_ungetc - win32_getc - win32_fileno - win32_clearerr - win32_fflush - win32_ftell - win32_fseek - win32_fgetpos - win32_fsetpos - win32_rewind - win32_tmpfile win32_abort win32_fstat win32_stat @@ -678,17 +639,6 @@ if ($PLATFORM eq 'win32') { win32_getenv win32_putenv win32_perror - win32_setbuf - win32_setvbuf - win32_flushall - win32_fcloseall - win32_fgets - win32_gets - win32_fgetc - win32_putc - win32_puts - win32_getchar - win32_putchar win32_malloc win32_calloc win32_realloc @@ -720,6 +670,47 @@ if ($PLATFORM eq 'win32') { win32_getpid win32_crypt win32_dynaload + + win32_stdin + win32_stdout + win32_stderr + win32_ferror + win32_feof + win32_strerror + win32_fprintf + win32_printf + win32_vfprintf + win32_vprintf + win32_fread + win32_fwrite + win32_fopen + win32_fdopen + win32_freopen + win32_fclose + win32_fputs + win32_fputc + win32_ungetc + win32_getc + win32_fileno + win32_clearerr + win32_fflush + win32_ftell + win32_fseek + win32_fgetpos + win32_fsetpos + win32_rewind + win32_tmpfile + win32_setbuf + win32_setvbuf + win32_flushall + win32_fcloseall + win32_fgets + win32_gets + win32_fgetc + win32_putc + win32_puts + win32_getchar + win32_putchar )) { try_symbol($symbol); @@ -797,3 +788,38 @@ perl_destruct perl_free perl_parse perl_run +PerlIO_define_layer +PerlIOBuf_set_ptrcnt +PerlIOBuf_get_cnt +PerlIOBuf_get_ptr +PerlIOBuf_bufsiz +PerlIOBuf_setlinebuf +PerlIOBase_clearerr +PerlIOBase_error +PerlIOBase_eof +PerlIOBuf_tell +PerlIOBuf_seek +PerlIOBuf_write +PerlIOBuf_unread +PerlIOBuf_read +PerlIOBuf_reopen +PerlIOBuf_open +PerlIOBuf_fdopen +PerlIOBase_fileno +PerlIOBuf_pushed +PerlIOBuf_fill +PerlIOBuf_flush +PerlIOBase_close +PerlIO_define_layer +PerlIO_pending +PerlIO_unread +PerlIO_push +PerlIO_apply_layers +perlsio_binmode +PerlIO_binmode +PerlIO_init +PerlIO_tmpfile +PerlIO_setpos +PerlIO_getpos +PerlIO_vsprintf +PerlIO_sprintf diff --git a/malloc.c b/malloc.c index 7584000..0f668cd 100644 --- a/malloc.c +++ b/malloc.c @@ -146,9 +146,15 @@ # Fatal error reporting function croak(format, arg) warn(idem) + exit(1) + # Fatal error reporting function + croak2(format, arg1, arg2) warn2(idem) + exit(1) + # Error reporting function warn(format, arg) fprintf(stderr, idem) + # Error reporting function + warn2(format, arg1, arg2) fprintf(stderr, idem) + # Locking/unlocking for MT operation MALLOC_LOCK MUTEX_LOCK(&PL_malloc_mutex) MALLOC_UNLOCK MUTEX_UNLOCK(&PL_malloc_mutex) @@ -234,7 +240,12 @@ # include "perl.h" # if defined(PERL_IMPLICIT_CONTEXT) # define croak Perl_croak_nocontext +# define croak2 Perl_croak_nocontext # define warn Perl_warn_nocontext +# define warn2 Perl_warn_nocontext +# else +# define croak2 croak +# define warn2 warn # endif #else # ifdef PERL_FOR_X2P @@ -274,9 +285,15 @@ # ifndef croak /* make depend */ # define croak(mess, arg) (warn((mess), (arg)), exit(1)) # endif +# ifndef croak2 /* make depend */ +# define croak2(mess, arg1, arg2) (warn2((mess), (arg1), (arg2)), exit(1)) +# endif # ifndef warn # define warn(mess, arg) fprintf(stderr, (mess), (arg)) # endif +# ifndef warn2 +# define warn2(mess, arg1) fprintf(stderr, (mess), (arg1), (arg2)) +# endif # ifdef DEBUG_m # undef DEBUG_m # endif @@ -441,6 +458,11 @@ union overhead { double strut; /* alignment problems */ #endif struct { +/* + * Keep the ovu_index and ovu_magic in this order, having a char + * field first gives alignment indigestion in some systems, such as + * MachTen. + */ u_char ovu_index; /* bucket # */ u_char ovu_magic; /* magic number */ #ifdef RCHECK @@ -838,11 +860,7 @@ static void* get_from_bigger_buckets(int bucket, MEM_SIZE size); static union overhead *getpages (MEM_SIZE needed, int *nblksp, int bucket); static int getpages_adjacent(MEM_SIZE require); -#if defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE) - -# ifndef BIG_SIZE -# define BIG_SIZE (1<<16) /* 64K */ -# endif +#ifdef PERL_CORE #ifdef I_MACH_CTHREADS # undef MUTEX_LOCK @@ -851,18 +869,66 @@ static int getpages_adjacent(MEM_SIZE require); # define MUTEX_UNLOCK(m) STMT_START { if (*m) mutex_unlock(*m); } STMT_END #endif +#ifndef BITS_IN_PTR +# define BITS_IN_PTR (8*PTRSIZE) +#endif + +/* + * nextf[i] is the pointer to the next free block of size 2^i. The + * smallest allocatable block is 8 bytes. The overhead information + * precedes the data area returned to the user. + */ +#define NBUCKETS (BITS_IN_PTR*BUCKETS_PER_POW2 + 1) +static union overhead *nextf[NBUCKETS]; + +#if defined(PURIFY) && !defined(USE_PERL_SBRK) +# define USE_PERL_SBRK +#endif + +#ifdef USE_PERL_SBRK +# define sbrk(a) Perl_sbrk(a) +Malloc_t Perl_sbrk (int size); +#else +# ifndef HAS_SBRK_PROTO /* usually takes care of this */ +extern Malloc_t sbrk(int); +# endif +#endif + +#ifdef DEBUGGING_MSTATS +/* + * nmalloc[i] is the difference between the number of mallocs and frees + * for a given block size. + */ +static u_int nmalloc[NBUCKETS]; +static u_int sbrk_slack; +static u_int start_slack; +#else /* !( defined DEBUGGING_MSTATS ) */ +# define sbrk_slack 0 +#endif + +static u_int goodsbrk; + +# ifdef PERL_EMERGENCY_SBRK + +# ifndef BIG_SIZE +# define BIG_SIZE (1<<16) /* 64K */ +# endif + static char *emergency_buffer; static MEM_SIZE emergency_buffer_size; +static int no_mem; /* 0 if the last request for more memory succeeded. + Otherwise the size of the failing request. */ static Malloc_t emergency_sbrk(MEM_SIZE size) { MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<= BIG_SIZE) { - /* Give the possibility to recover: */ + if (size >= BIG_SIZE && (!no_mem || (size < no_mem))) { + /* Give the possibility to recover, but avoid an infinite cycle. */ MALLOC_UNLOCK; - croak("Out of memory during \"large\" request for %i bytes", size); + no_mem = size; + croak2("Out of memory during \"large\" request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack)); } if (emergency_buffer_size >= rsize) { @@ -910,55 +976,15 @@ emergency_sbrk(MEM_SIZE size) } do_croak: MALLOC_UNLOCK; - croak("Out of memory during request for %i bytes", size); + croak("Out of memory during request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack)); /* NOTREACHED */ return Nullch; } -#else /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */ +# else /* !defined(PERL_EMERGENCY_SBRK) */ # define emergency_sbrk(size) -1 -#endif /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */ - -#ifndef BITS_IN_PTR -# define BITS_IN_PTR (8*PTRSIZE) -#endif - -/* - * nextf[i] is the pointer to the next free block of size 2^i. The - * smallest allocatable block is 8 bytes. The overhead information - * precedes the data area returned to the user. - */ -#define NBUCKETS (BITS_IN_PTR*BUCKETS_PER_POW2 + 1) -static union overhead *nextf[NBUCKETS]; - -#if defined(PURIFY) && !defined(USE_PERL_SBRK) -# define USE_PERL_SBRK -#endif - -#ifdef USE_PERL_SBRK -#define sbrk(a) Perl_sbrk(a) -Malloc_t Perl_sbrk (int size); -#else -#ifdef DONT_DECLARE_STD -#ifdef I_UNISTD -#include -#endif -#else -extern Malloc_t sbrk(int); -#endif -#endif - -#ifdef DEBUGGING_MSTATS -/* - * nmalloc[i] is the difference between the number of mallocs and frees - * for a given block size. - */ -static u_int nmalloc[NBUCKETS]; -static u_int sbrk_slack; -static u_int start_slack; -#endif - -static u_int goodsbrk; +# endif +#endif /* ifdef PERL_CORE */ #ifdef DEBUGGING #undef ASSERT @@ -1035,7 +1061,32 @@ Perl_malloc(register size_t nbytes) { dTHX; if (!PL_nomemok) { - PerlIO_puts(PerlIO_stderr(),"Out of memory!\n"); +#if defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC) + PerlIO_puts(PerlIO_stderr(),"Out of memory!\n"); +#else + char buff[80]; + char *eb = buff + sizeof(buff) - 1; + char *s = eb; + size_t n = nbytes; + + PerlIO_puts(PerlIO_stderr(),"Out of memory during request for "); +#if defined(DEBUGGING) || defined(RCHECK) + n = size; +#endif + *s = 0; + do { + *--s = '0' + (n % 10); + } while (n /= 10); + PerlIO_puts(PerlIO_stderr(),s); + PerlIO_puts(PerlIO_stderr()," bytes, total sbrk() is "); + s = eb; + n = goodsbrk + sbrk_slack; + do { + *--s = '0' + (n % 10); + } while (n /= 10); + PerlIO_puts(PerlIO_stderr(),s); + PerlIO_puts(PerlIO_stderr()," bytes!\n"); +#endif /* defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC) */ my_exit(1); } } @@ -1343,6 +1394,9 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) sbrked_remains = require - needed; last_op = cp; } +#if !defined(PLAIN_MALLOC) && !defined(NO_FANCY_MALLOC) + no_mem = 0; +#endif last_sbrk_top = cp + require; #ifdef DEBUGGING_MSTATS goodsbrk += require; diff --git a/mg.c b/mg.c index bec0a82..99600a4 100644 --- a/mg.c +++ b/mg.c @@ -1,6 +1,6 @@ /* mg.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -16,11 +16,6 @@ #define PERL_IN_MG_C #include "perl.h" -/* XXX If this causes problems, set i_unistd=undef in the hint file. */ -#ifdef I_UNISTD -# include -#endif - #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) # ifndef NGROUPS # define NGROUPS 32 @@ -44,7 +39,6 @@ struct magic_state { STATIC void S_save_magic(pTHX_ I32 mgs_ix, SV *sv) { - dTHR; MGS* mgs; assert(SvMAGICAL(sv)); @@ -96,7 +90,6 @@ Do magic after a value is retrieved from the SV. See C. int Perl_mg_get(pTHX_ SV *sv) { - dTHR; I32 mgs_ix; MAGIC* mg; MAGIC** mgp; @@ -139,7 +132,6 @@ Do magic after a value is assigned to the SV. See C. int Perl_mg_set(pTHX_ SV *sv) { - dTHR; I32 mgs_ix; MAGIC* mg; MAGIC* nextmg; @@ -200,7 +192,7 @@ Perl_mg_size(pTHX_ SV *sv) { MAGIC* mg; I32 len; - + for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; if (vtbl && vtbl->svt_len) { @@ -269,6 +261,8 @@ MAGIC* Perl_mg_find(pTHX_ SV *sv, int type) { MAGIC* mg; + if (!sv) + return 0; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { if (mg->mg_type == type) return mg; @@ -339,7 +333,6 @@ Perl_mg_free(pTHX_ SV *sv) U32 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register REGEXP *rx; if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { @@ -348,14 +341,13 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) else /* @- */ return rx->lastparen; } - + return (U32)-1; } int Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register I32 paren; register I32 s; register I32 i; @@ -374,6 +366,11 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) i = t; else /* @- */ i = s; + + if (i > 0 && DO_UTF8(PL_reg_sv)) { + char *b = rx->subbeg; + i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i)); + } sv_setiv(sv,i); } } @@ -383,7 +380,6 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg) { - dTHR; Perl_croak(aTHX_ PL_no_modify); /* NOT REACHED */ return 0; @@ -392,7 +388,6 @@ Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg) U32 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register I32 paren; register I32 i; register REGEXP *rx; @@ -403,7 +398,7 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) case '5': case '6': case '7': case '8': case '9': case '&': if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { - paren = atoi(mg->mg_ptr); + paren = atoi(mg->mg_ptr); /* $& is in [0] */ getparen: if (paren <= rx->nparens && (s1 = rx->startp[paren]) != -1 && @@ -411,17 +406,15 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) { i = t1 - s1; getlen: - if (i > 0 && (PL_curpm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) { - char *s = rx->subbeg + s1; + if (i > 0 && DO_UTF8(PL_reg_sv)) { + char *s = rx->subbeg + s1; char *send = rx->subbeg + t1; - i = 0; - while (s < send) { - s += UTF8SKIP(s); - i++; - } + + i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send); } - if (i >= 0) - return i; + if (i < 0) + Perl_croak(aTHX_ "panic: magic_len: %d", i); + return i; } } return 0; @@ -456,10 +449,6 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) } } return 0; - case ',': - return (STRLEN)PL_ofslen; - case '\\': - return (STRLEN)PL_orslen; } magic_get(sv,mg); if (!SvPOK(sv) && SvNIOK(sv)) { @@ -474,7 +463,6 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register I32 paren; register char *s; register I32 i; @@ -498,7 +486,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) #ifdef MACOS_TRADITIONAL { char msg[256]; - + sv_setnv(sv,(double)gMacPerl_OSErr); sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : ""); } @@ -563,15 +551,22 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) else sv_setsv(sv, &PL_sv_undef); break; - case '\017': /* ^O */ - sv_setpv(sv, PL_osname); + case '\017': /* ^O & ^OPEN */ + if (*(mg->mg_ptr+1) == '\0') + sv_setpv(sv, PL_osname); + else if (strEQ(mg->mg_ptr, "\017PEN")) { + if (!PL_compiling.cop_io) + sv_setsv(sv, &PL_sv_undef); + else { + sv_setsv(sv, PL_compiling.cop_io); + } + } break; case '\020': /* ^P */ sv_setiv(sv, (IV)PL_perldb); break; case '\023': /* ^S */ { - dTHR; if (PL_lex_state != LEX_NOTPARSING) (void)SvOK_off(sv); else if (PL_in_eval) @@ -596,10 +591,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } else if (PL_compiling.cop_warnings == pWARN_ALL) { sv_setpvn(sv, WARN_ALLstring, WARNsize) ; - } + } else { sv_setsv(sv, PL_compiling.cop_warnings); - } + } SvPOK_only(sv); } else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS")) @@ -614,7 +609,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj)); * XXX Does the new way break anything? */ - paren = atoi(mg->mg_ptr); + paren = atoi(mg->mg_ptr); /* $& is in [0] */ getparen: if (paren <= rx->nparens && (s1 = rx->startp[paren]) != -1 && @@ -633,7 +628,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) PL_tainted = FALSE; } sv_setpvn(sv, s, i); - if ((PL_curpm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) + if (DO_UTF8(PL_reg_sv)) SvUTF8_on(sv); else SvUTF8_off(sv); @@ -725,10 +720,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); break; case ',': - sv_setpvn(sv,PL_ofs,PL_ofslen); break; case '\\': - sv_setpvn(sv,PL_ors,PL_orslen); break; case '#': sv_setpv(sv,PL_ofmt); @@ -895,7 +888,6 @@ Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) #if defined(VMS) Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); #else - dTHR; if (PL_localizing) { HE* entry; STRLEN n_a; @@ -936,12 +928,8 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) cur += len+1; } FreeEnvironmentStrings(envv); -# else -# ifdef __CYGWIN__ - I32 i; - for (i = 0; environ[i]; i++) - safesysfree(environ[i]); # else +#ifdef USE_ENVIRON_ARRAY # ifndef PERL_USE_SAFE_PUTENV I32 i; @@ -951,10 +939,10 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) for (i = 0; environ[i]; i++) safesysfree(environ[i]); # endif /* PERL_USE_SAFE_PUTENV */ -# endif /* __CYGWIN__ */ environ[0] = Nullch; +#endif /* USE_ENVIRON_ARRAY */ # endif /* WIN32 */ # endif /* PERL_IMPLICIT_SYS */ #endif /* VMS */ @@ -1009,7 +997,6 @@ Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register char *s; I32 i; SV** svp; @@ -1126,7 +1113,7 @@ Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) hv_ksplit((HV*)LvTARG(sv), SvIV(sv)); } return 0; -} +} /* caller is responsible for stack switching/cleanup */ STATIC int @@ -1137,7 +1124,7 @@ S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val) PUSHMARK(SP); EXTEND(SP, n); PUSHs(SvTIED_obj(sv, mg)); - if (n > 1) { + if (n > 1) { if (mg->mg_ptr) { if (mg->mg_len >= 0) PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len))); @@ -1205,7 +1192,7 @@ Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) U32 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) -{ +{ dSP; U32 retval = 0; @@ -1267,12 +1254,11 @@ int Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg) { return magic_methpack(sv,mg,"EXISTS"); -} +} int Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) { - dTHR; OP *o; I32 i; GV* gv; @@ -1291,7 +1277,6 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg) { - dTHR; sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase); return 0; } @@ -1299,7 +1284,6 @@ Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) { - dTHR; av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase); return 0; } @@ -1308,11 +1292,10 @@ int Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) { SV* lsv = LvTARG(sv); - + if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) { mg = mg_find(lsv, 'g'); if (mg && mg->mg_len >= 0) { - dTHR; I32 i = mg->mg_len; if (DO_UTF8(lsv)) sv_pos_b2u(lsv, &i); @@ -1331,10 +1314,9 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) SSize_t pos; STRLEN len; STRLEN ulen = 0; - dTHR; mg = 0; - + if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) mg = mg_find(lsv, 'g'); if (!mg) { @@ -1435,14 +1417,20 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) { STRLEN len; char *tmps = SvPV(sv,len); - sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len); + if (DO_UTF8(sv)) { + sv_utf8_upgrade(LvTARG(sv)); + sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len); + SvUTF8_on(LvTARG(sv)); + } + else + sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len); + return 0; } int Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) { - dTHR; TAINT_IF((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */ return 0; @@ -1451,7 +1439,6 @@ Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg) { - dTHR; if (PL_localizing) { if (PL_localizing == 1) mg->mg_len <<= 1; @@ -1510,7 +1497,6 @@ Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) targ = AvARRAY(av)[LvTARGOFF(sv)]; } if (targ && targ != &PL_sv_undef) { - dTHR; /* just for SvREFCNT_dec */ /* somebody else defined it for us */ SvREFCNT_dec(LvTARG(sv)); LvTARG(sv) = SvREFCNT_inc(targ); @@ -1541,7 +1527,6 @@ Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg) void Perl_vivify_defelem(pTHX_ SV *sv) { - dTHR; /* just for SvREFCNT_inc and SvREFCNT_dec*/ MAGIC *mg; SV *value = Nullsv; @@ -1665,7 +1650,6 @@ Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register char *s; I32 i; STRLEN len; @@ -1714,12 +1698,20 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_inplace = Nullch; break; case '\017': /* ^O */ - if (PL_osname) - Safefree(PL_osname); - if (SvOK(sv)) - PL_osname = savepv(SvPV(sv,len)); - else - PL_osname = Nullch; + if (*(mg->mg_ptr+1) == '\0') { + if (PL_osname) + Safefree(PL_osname); + if (SvOK(sv)) + PL_osname = savepv(SvPV(sv,len)); + else + PL_osname = Nullch; + } + else if (strEQ(mg->mg_ptr, "\017PEN")) { + if (!PL_compiling.cop_io) + PL_compiling.cop_io = newSVsv(sv); + else + sv_setsv(PL_compiling.cop_io,sv); + } break; case '\020': /* ^P */ PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); @@ -1737,7 +1729,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (*(mg->mg_ptr+1) == '\0') { if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); - PL_dowarn = (PL_dowarn & ~G_WARN_ON) + PL_dowarn = (PL_dowarn & ~G_WARN_ON) | (i ? G_WARN_ON : G_WARN_OFF) ; } } @@ -1833,21 +1825,24 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_rs = SvREFCNT_inc(PL_nrs); break; case '\\': - if (PL_ors) - Safefree(PL_ors); + if (PL_ors_sv) + SvREFCNT_dec(PL_ors_sv); if (SvOK(sv) || SvGMAGICAL(sv)) { - s = SvPV(sv,PL_orslen); - PL_ors = savepvn(s,PL_orslen); + PL_ors_sv = newSVsv(sv); } else { - PL_ors = Nullch; - PL_orslen = 0; + PL_ors_sv = Nullsv; } break; case ',': - if (PL_ofs) - Safefree(PL_ofs); - PL_ofs = savepv(SvPV(sv, PL_ofslen)); + if (PL_ofs_sv) + SvREFCNT_dec(PL_ofs_sv); + if (SvOK(sv) || SvGMAGICAL(sv)) { + PL_ofs_sv = newSVsv(sv); + } + else { + PL_ofs_sv = Nullsv; + } break; case '#': if (PL_ofmt) @@ -2043,7 +2038,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (PL_origargv[i] == s + 1 #ifdef OS2 || PL_origargv[i] == s + 2 -#endif +#endif ) { ++s; @@ -2056,7 +2051,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (PL_origenviron && (PL_origenviron[0] == s + 1 #ifdef OS2 || (PL_origenviron[0] == s + 9 && (s += 8)) -#endif +#endif )) { my_setenv("NoNe SuCh", Nullch); /* force copy of environment */ @@ -2105,7 +2100,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_mutexfree(pTHX_ SV *sv, MAGIC *mg) { - dTHR; DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": magic_mutexfree 0x%"UVxf"\n", PTR2UV(thr), PTR2UV(sv));) @@ -2159,7 +2153,7 @@ Perl_sighandler(int sig) #if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT) PERL_SET_THX(aTHXo); /* fake TLS, see above */ #endif - + if (PL_savestack_ix + 15 <= PL_savestack_max) flags |= 1; if (PL_markstack_ptr < PL_markstack_max - 2) @@ -2180,7 +2174,7 @@ Perl_sighandler(int sig) o_save_i = PL_savestack_ix; SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags); } - if (flags & 4) + if (flags & 4) PL_markstack_ptr++; /* Protect mark. */ if (flags & 8) { PL_retstack_ix++; @@ -2189,7 +2183,7 @@ Perl_sighandler(int sig) if (flags & 16) PL_scopestack_ix += 1; /* sv_2cv is too complicated, try a simpler variant first: */ - if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig])) + if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig])) || SvTYPE(cv) != SVt_PVCV) cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE); @@ -2223,16 +2217,16 @@ Perl_sighandler(int sig) cleanup: if (flags & 1) PL_savestack_ix -= 8; /* Unprotect save in progress. */ - if (flags & 4) + if (flags & 4) PL_markstack_ptr--; - if (flags & 8) + if (flags & 8) PL_retstack_ix--; if (flags & 16) PL_scopestack_ix -= 1; if (flags & 64) SvREFCNT_dec(sv); PL_op = myop; /* Apparently not needed... */ - + PL_Sv = tSv; /* Restore global temporaries. */ PL_Xpv = tXpv; return; @@ -2246,7 +2240,6 @@ cleanup: static void restore_magic(pTHXo_ void *p) { - dTHR; MGS* mgs = SSPTR(PTR2IV(p), MGS*); SV* sv = mgs->mgs_sv; @@ -2288,7 +2281,6 @@ restore_magic(pTHXo_ void *p) static void unwind_handler_stack(pTHXo_ void *p) { - dTHR; U32 flags = *(U32*)p; if (flags & 1) diff --git a/mg.h b/mg.h index ad50f5a..0048803 100644 --- a/mg.h +++ b/mg.h @@ -1,6 +1,6 @@ /* mg.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. diff --git a/minimod.pl b/minimod.pl index 8efbd31..18b9c07 100644 --- a/minimod.pl +++ b/minimod.pl @@ -59,7 +59,7 @@ sub writemain{ my($mname, $cname); ($mname = $pname) =~ s!/!::!g; ($cname = $pname) =~ s!/!__!g; - print "EXTERN_C void boot_${cname} (CV* cv);\n"; + print "EXTERN_C void boot_${cname} (pTHX_ CV* cv);\n"; } my ($tail1,$tail2) = ( $tail =~ /\A(.*\n)(\s*\}.*)\Z/s ); diff --git a/nostdio.h b/nostdio.h index 256a638..fa7ba99 100644 --- a/nostdio.h +++ b/nostdio.h @@ -1,8 +1,13 @@ -/* This is an 1st attempt to stop other include files pulling +/* + * Strong denial of stdio - make all stdio calls (we can think of) errors + */ +/* This is an 1st attempt to stop other include files pulling in real . A more ambitious set of possible symbols can be found in sfio.h (inside an _cplusplus gard). + It is completely pointless as we have already included it ourselves. */ + #if !defined(_STDIO_H) && !defined(FILE) && !defined(_STDIO_INCLUDED) && !defined(__STDIO_LOADED) #define _STDIO_H #define _STDIO_INCLUDED @@ -13,14 +18,98 @@ struct _FILE; #define _CANNOT "CANNOT" -#undef stdin -#undef stdout -#undef stderr -#undef getc -#undef putc #undef clearerr -#undef fflush +#undef fclose +#undef fdopen #undef feof #undef ferror +#undef fflush +#undef fgetc +#undef fgetpos +#undef fgets #undef fileno +#undef flockfile +#undef fopen +#undef fprintf +#undef fputc +#undef fputs +#undef fread +#undef freopen +#undef fscanf +#undef fseek +#undef fsetpos +#undef ftell +#undef ftrylockfile +#undef funlockfile +#undef fwrite +#undef getc +#undef getc_unlocked +#undef getw +#undef pclose +#undef popen +#undef putc +#undef putc_unlocked +#undef putw +#undef rewind +#undef setbuf +#undef setvbuf +#undef stderr +#undef stdin +#undef stdout +#undef tmpfile +#undef ungetc +#undef vfprintf +#define fprintf _CANNOT _fprintf_ +#define stdin _CANNOT _stdin_ +#define stdout _CANNOT _stdout_ +#define stderr _CANNOT _stderr_ +#ifndef OS2 +#define tmpfile() _CANNOT _tmpfile_ +#endif +#define fclose(f) _CANNOT _fclose_ +#define fflush(f) _CANNOT _fflush_ +#define fopen(p,m) _CANNOT _fopen_ +#define freopen(p,m,f) _CANNOT _freopen_ +#define setbuf(f,b) _CANNOT _setbuf_ +#define setvbuf(f,b,x,s) _CANNOT _setvbuf_ +#define fscanf _CANNOT _fscanf_ +#define vfprintf(f,fmt,a) _CANNOT _vfprintf_ +#define fgetc(f) _CANNOT _fgetc_ +#define fgets(s,n,f) _CANNOT _fgets_ +#define fputc(c,f) _CANNOT _fputc_ +#define fputs(s,f) _CANNOT _fputs_ +#define getc(f) _CANNOT _getc_ +#define putc(c,f) _CANNOT _putc_ +#ifndef OS2 +#define ungetc(c,f) _CANNOT _ungetc_ +#endif +#define fread(b,s,c,f) _CANNOT _fread_ +#define fwrite(b,s,c,f) _CANNOT _fwrite_ +#define fgetpos(f,p) _CANNOT _fgetpos_ +#define fseek(f,o,w) _CANNOT _fseek_ +#define fsetpos(f,p) _CANNOT _fsetpos_ +#define ftell(f) _CANNOT _ftell_ +#define rewind(f) _CANNOT _rewind_ +#define clearerr(f) _CANNOT _clearerr_ +#define feof(f) _CANNOT _feof_ +#define ferror(f) _CANNOT _ferror_ +#define __filbuf(f) _CANNOT __filbuf_ +#define __flsbuf(c,f) _CANNOT __flsbuf_ +#define _filbuf(f) _CANNOT _filbuf_ +#define _flsbuf(c,f) _CANNOT _flsbuf_ +#define fdopen(fd,p) _CANNOT _fdopen_ +#define fileno(f) _CANNOT _fileno_ +#if SFIO_VERSION < 20000101L +#define flockfile(f) _CANNOT _flockfile_ +#define ftrylockfile(f) _CANNOT _ftrylockfile_ +#define funlockfile(f) _CANNOT _funlockfile_ +#endif +#define getc_unlocked(f) _CANNOT _getc_unlocked_ +#define putc_unlocked(c,f) _CANNOT _putc_unlocked_ +#define popen(c,m) _CANNOT _popen_ +#define getw(f) _CANNOT _getw_ +#define putw(v,f) _CANNOT _putw_ +#ifndef OS2 +#define pclose(f) _CANNOT _pclose_ +#endif diff --git a/objXSUB.h b/objXSUB.h index bc04f03..60c6e90 100644 --- a/objXSUB.h +++ b/objXSUB.h @@ -35,6 +35,10 @@ #define Perl_Gv_AMupdate pPerl->Perl_Gv_AMupdate #undef Gv_AMupdate #define Gv_AMupdate Perl_Gv_AMupdate +#undef Perl_gv_handler +#define Perl_gv_handler pPerl->Perl_gv_handler +#undef gv_handler +#define gv_handler Perl_gv_handler #undef Perl_apply_attrs_string #define Perl_apply_attrs_string pPerl->Perl_apply_attrs_string #undef apply_attrs_string @@ -1259,6 +1263,10 @@ #define Perl_regdump pPerl->Perl_regdump #undef regdump #define regdump Perl_regdump +#undef Perl_regclass_swash +#define Perl_regclass_swash pPerl->Perl_regclass_swash +#undef regclass_swash +#define regclass_swash Perl_regclass_swash #undef Perl_pregexec #define Perl_pregexec pPerl->Perl_pregexec #undef pregexec @@ -1433,6 +1441,10 @@ #define Perl_save_re_context pPerl->Perl_save_re_context #undef save_re_context #define save_re_context Perl_save_re_context +#undef Perl_save_padsv +#define Perl_save_padsv pPerl->Perl_save_padsv +#undef save_padsv +#define save_padsv Perl_save_padsv #undef Perl_save_sptr #define Perl_save_sptr pPerl->Perl_save_sptr #undef save_sptr @@ -1777,6 +1789,10 @@ #define Perl_sv_unref pPerl->Perl_sv_unref #undef sv_unref #define sv_unref Perl_sv_unref +#undef Perl_sv_unref_flags +#define Perl_sv_unref_flags pPerl->Perl_sv_unref_flags +#undef sv_unref_flags +#define sv_unref_flags Perl_sv_unref_flags #undef Perl_sv_untaint #define Perl_sv_untaint pPerl->Perl_sv_untaint #undef sv_untaint @@ -1853,6 +1869,10 @@ #define Perl_utf16_to_utf8_reversed pPerl->Perl_utf16_to_utf8_reversed #undef utf16_to_utf8_reversed #define utf16_to_utf8_reversed Perl_utf16_to_utf8_reversed +#undef Perl_utf8_length +#define Perl_utf8_length pPerl->Perl_utf8_length +#undef utf8_length +#define utf8_length Perl_utf8_length #undef Perl_utf8_distance #define Perl_utf8_distance pPerl->Perl_utf8_distance #undef utf8_distance @@ -1869,14 +1889,14 @@ #define Perl_bytes_to_utf8 pPerl->Perl_bytes_to_utf8 #undef bytes_to_utf8 #define bytes_to_utf8 Perl_bytes_to_utf8 +#undef Perl_utf8_to_uv_simple +#define Perl_utf8_to_uv_simple pPerl->Perl_utf8_to_uv_simple +#undef utf8_to_uv_simple +#define utf8_to_uv_simple Perl_utf8_to_uv_simple #undef Perl_utf8_to_uv #define Perl_utf8_to_uv pPerl->Perl_utf8_to_uv #undef utf8_to_uv #define utf8_to_uv Perl_utf8_to_uv -#undef Perl_utf8_to_uv_chk -#define Perl_utf8_to_uv_chk pPerl->Perl_utf8_to_uv_chk -#undef utf8_to_uv_chk -#define utf8_to_uv_chk Perl_utf8_to_uv_chk #undef Perl_uv_to_utf8 #define Perl_uv_to_utf8 pPerl->Perl_uv_to_utf8 #undef uv_to_utf8 @@ -1901,7 +1921,7 @@ #define Perl_whichsig pPerl->Perl_whichsig #undef whichsig #define whichsig Perl_whichsig -#if defined(USE_PURE_BISON) +#ifdef USE_PURE_BISON #else #endif #if defined(MYMALLOC) @@ -2130,6 +2150,10 @@ #define Perl_sv_force_normal pPerl->Perl_sv_force_normal #undef sv_force_normal #define sv_force_normal Perl_sv_force_normal +#undef Perl_sv_force_normal_flags +#define Perl_sv_force_normal_flags pPerl->Perl_sv_force_normal_flags +#undef sv_force_normal_flags +#define sv_force_normal_flags Perl_sv_force_normal_flags #undef Perl_tmps_grow #define Perl_tmps_grow pPerl->Perl_tmps_grow #undef tmps_grow @@ -2276,6 +2300,8 @@ #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) # if defined(DEBUGGING) # endif +# if !defined(NV_PRESERVES_UV) +# endif #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #if 0 diff --git a/op.c b/op.c index 84a1df9..379b0b9 100644 --- a/op.c +++ b/op.c @@ -1,6 +1,6 @@ /* op.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -107,13 +107,12 @@ S_no_bareword_allowed(pTHX_ OP *o) PADOFFSET Perl_pad_allocmy(pTHX_ char *name) { - dTHR; PADOFFSET off; SV *sv; if (!(PL_in_my == KEY_our || isALPHA(name[1]) || - (PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) || + (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) || (name[1] == '_' && (int)strlen(name) > 2))) { if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { @@ -238,7 +237,6 @@ STATIC PADOFFSET S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval, U32 flags) { - dTHR; CV *cv; I32 off; SV *sv; @@ -385,7 +383,6 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, PADOFFSET Perl_pad_findmy(pTHX_ char *name) { - dTHR; I32 off; I32 pendoff = 0; SV *sv; @@ -448,7 +445,6 @@ Perl_pad_findmy(pTHX_ char *name) void Perl_pad_leavemy(pTHX_ I32 fill) { - dTHR; I32 off; SV **svp = AvARRAY(PL_comppad_name); SV *sv; @@ -468,7 +464,6 @@ Perl_pad_leavemy(pTHX_ I32 fill) PADOFFSET Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) { - dTHR; SV *sv; I32 retval; @@ -520,7 +515,6 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) SV * Perl_pad_sv(pTHX_ PADOFFSET po) { - dTHR; #ifdef USE_THREADS DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n", @@ -537,7 +531,6 @@ Perl_pad_sv(pTHX_ PADOFFSET po) void Perl_pad_free(pTHX_ PADOFFSET po) { - dTHR; if (!PL_curpad) return; if (AvARRAY(PL_comppad) != PL_curpad) @@ -565,7 +558,6 @@ Perl_pad_free(pTHX_ PADOFFSET po) void Perl_pad_swipe(pTHX_ PADOFFSET po) { - dTHR; if (AvARRAY(PL_comppad) != PL_curpad) Perl_croak(aTHX_ "panic: pad_swipe curpad"); if (!po) @@ -595,7 +587,6 @@ void Perl_pad_reset(pTHX) { #ifdef USE_BROKEN_PAD_RESET - dTHR; register I32 po; if (AvARRAY(PL_comppad) != PL_curpad) @@ -624,7 +615,6 @@ Perl_pad_reset(pTHX) PADOFFSET Perl_find_threadsv(pTHX_ const char *name) { - dTHR; char *p; PADOFFSET key; SV **svp; @@ -853,6 +843,8 @@ S_cop_free(pTHX_ COP* cop) #endif if (! specialWARN(cop->cop_warnings)) SvREFCNT_dec(cop->cop_warnings); + if (! specialCopIO(cop->cop_io)) + SvREFCNT_dec(cop->cop_io); } STATIC void @@ -909,7 +901,6 @@ STATIC OP * S_scalarboolean(pTHX_ OP *o) { if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { - dTHR; if (ckWARN(WARN_SYNTAX)) { line_t oldline = CopLINE(PL_curcop); @@ -1005,10 +996,7 @@ Perl_scalarvoid(pTHX_ OP *o) || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_SETSTATE || o->op_targ == OP_DBSTATE))) - { - dTHR; PL_curcop = (COP*)o; /* for warning below */ - } /* assumes no premature commitment */ want = o->op_flags & OPf_WANT; @@ -1125,12 +1113,17 @@ Perl_scalarvoid(pTHX_ OP *o) if (cSVOPo->op_private & OPpCONST_STRICT) no_bareword_allowed(o); else { - dTHR; if (ckWARN(WARN_VOID)) { useless = "a constant"; if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) useless = 0; else if (SvPOK(sv)) { + /* perl4's way of mixing documentation and code + (before the invention of POD) was based on a + trick to mix nroff and perl code. The trick was + built upon these three nroff macros being used in + void context. The pink camel has the details in + the script wrapman near page 319. */ if (strnEQ(SvPVX(sv), "di", 2) || strnEQ(SvPVX(sv), "ds", 2) || strnEQ(SvPVX(sv), "ig", 2)) @@ -1194,11 +1187,8 @@ Perl_scalarvoid(pTHX_ OP *o) } break; } - if (useless) { - dTHR; - if (ckWARN(WARN_VOID)) - Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless); - } + if (useless && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless); return o; } @@ -1299,7 +1289,6 @@ Perl_scalarseq(pTHX_ OP *o) o->op_type == OP_LEAVE || o->op_type == OP_LEAVETRY) { - dTHR; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) { scalarvoid(kid); @@ -1330,7 +1319,6 @@ S_modkids(pTHX_ OP *o, I32 type) OP * Perl_mod(pTHX_ OP *o, I32 type) { - dTHR; OP *kid; STRLEN n_a; @@ -1348,6 +1336,31 @@ Perl_mod(pTHX_ OP *o, I32 type) PL_modcount++; return o; case OP_CONST: + if (o->op_private & (OPpCONST_BARE) && + !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) { + SV *sv = ((SVOP*)o)->op_sv; + GV *gv; + + /* Could be a filehandle */ + if (gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO)) { + OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv)); + op_free(o); + o = gvio; + } else { + /* OK, it's a sub */ + OP* enter; + gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV); + + enter = newUNOP(OP_ENTERSUB,0, + newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, gv) + )); + enter->op_private |= OPpLVAL_INTRO; + op_free(o); + o = enter; + } + break; + } if (!(o->op_private & (OPpCONST_ARYBASE))) goto nomod; if (PL_eval_start && PL_eval_start->op_type == OP_CONST) { @@ -1965,7 +1978,6 @@ Perl_sawparens(pTHX_ OP *o) OP * Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) { - dTHR; OP *o; if (ckWARN(WARN_MISC) && @@ -2052,7 +2064,6 @@ Perl_save_hints(pTHX) int Perl_block_start(pTHX_ int full) { - dTHR; int retval = PL_savestack_ix; SAVEI32(PL_comppad_name_floor); @@ -2075,13 +2086,17 @@ Perl_block_start(pTHX_ int full) PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; SAVEFREESV(PL_compiling.cop_warnings) ; } + SAVESPTR(PL_compiling.cop_io); + if (! specialCopIO(PL_compiling.cop_io)) { + PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ; + SAVEFREESV(PL_compiling.cop_io) ; + } return retval; } OP* Perl_block_end(pTHX_ I32 floor, OP *seq) { - dTHR; int needblockscope = PL_hints & HINT_BLOCK_SCOPE; OP* retval = scalarseq(seq); LEAVE_SCOPE(floor); @@ -2109,7 +2124,6 @@ S_newDEFSVOP(pTHX) void Perl_newPROG(pTHX_ OP *o) { - dTHR; if (PL_in_eval) { if (PL_eval_root) return; @@ -2154,10 +2168,9 @@ Perl_localize(pTHX_ OP *o, I32 lex) if (o->op_flags & OPf_PARENS) list(o); else { - dTHR; if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') { char *s; - for (s = PL_bufptr; *s && (isALNUM(*s) || (*s & 0x80) || strchr("@$%, ",*s)); s++) ; + for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ; if (*s == ';' || *s == '=') Perl_warner(aTHX_ WARN_PARENTHESIS, "Parentheses missing around \"%s\" list", @@ -2192,7 +2205,6 @@ Perl_jmaybe(pTHX_ OP *o) OP * Perl_fold_constants(pTHX_ register OP *o) { - dTHR; register OP *curop; I32 type = o->op_type; SV *sv; @@ -2268,13 +2280,11 @@ Perl_fold_constants(pTHX_ register OP *o) if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK && type != OP_NEGATE) { - IV iv = SvIV(sv); - if ((NV)iv == SvNV(sv)) { - SvREFCNT_dec(sv); - sv = newSViv(iv); - } - else - SvIOK_off(sv); /* undo SvIV() damage */ +#ifdef PERL_PRESERVE_IVUV + /* Only bother to attempt to fold to IV if + most operators will benefit */ + SvIV_please(sv); +#endif } return newSVOP(OP_CONST, 0, sv); } @@ -2310,7 +2320,6 @@ Perl_fold_constants(pTHX_ register OP *o) OP * Perl_gen_constant_list(pTHX_ register OP *o) { - dTHR; register OP *curop; I32 oldtmps_floor = PL_tmps_floor; @@ -2437,6 +2446,8 @@ Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) if (type == OP_LIST) { /* already a PUSHMARK there */ first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; ((LISTOP*)last)->op_first->op_sibling = first; + if (!(first->op_flags & OPf_PARENS)) + last->op_flags &= ~OPf_PARENS; } else { if (!(last->op_flags & OPf_KIDS)) { @@ -2621,7 +2632,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) SV* transv = 0; U8* tend = t + tlen; U8* rend = r + rlen; - I32 ulen; + STRLEN ulen; U32 tfirst = 1; U32 tlast = 0; I32 tdiff; @@ -2639,8 +2650,9 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) I32 to_utf = o->op_private & OPpTRANS_TO_UTF; if (complement) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; U8** cp; + I32* cl; UV nextmin = 0; New(1109, cp, tlen, U8*); i = 0; @@ -2656,7 +2668,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) qsort(cp, i, sizeof(U8*), utf8compare); for (j = 0; j < i; j++) { U8 *s = cp[j]; - UV val = utf8_to_uv_chk(s, &ulen, 0); + I32 cur = j < i ? cp[j+1] - s : tend - s; + UV val = utf8_to_uv(s, cur, &ulen, 0); s += ulen; diff = val - nextmin; if (diff > 0) { @@ -2669,7 +2682,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } } if (*s == 0xff) - val = utf8_to_uv_chk(s+1, &ulen, 0); + val = utf8_to_uv(s+1, cur - 1, &ulen, 0); if (val >= nextmin) nextmin = val + 1; } @@ -2696,10 +2709,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) while (t < tend || tfirst <= tlast) { /* see if we need more "t" chars */ if (tfirst > tlast) { - tfirst = (I32)utf8_to_uv_chk(t, &ulen, 0); + tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0); t += ulen; if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */ - tlast = (I32)utf8_to_uv_chk(++t, &ulen, 0); + t++; + tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0); t += ulen; } else @@ -2709,10 +2723,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) /* now see if we need more "r" chars */ if (rfirst > rlast) { if (r < rend) { - rfirst = (I32)utf8_to_uv_chk(r, &ulen, 0); + rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0); r += ulen; if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */ - rlast = (I32)utf8_to_uv_chk(++r, &ulen, 0); + r++; + rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0); r += ulen; } else @@ -2850,7 +2865,6 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) OP * Perl_newPMOP(pTHX_ I32 type, I32 flags) { - dTHR; PMOP *pmop; NewOp(1101, pmop, 1, PMOP); @@ -2877,7 +2891,6 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) OP * Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) { - dTHR; PMOP *pm; LOGOP *rcop; I32 repl_has_vars = 0; @@ -2897,7 +2910,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) p = SvPV(pat, plen); pm->op_pmflags |= PMf_SKIPWHITE; } - if ((PL_hints & HINT_UTF8) || (SvUTF8(pat) && !(PL_hints & HINT_BYTE))) + if ((PL_hints & HINT_UTF8) || DO_UTF8(pat)) pm->op_pmdynflags |= PMdf_UTF8; pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm); if (strEQ("\\s+", pm->op_pmregexp->precomp)) @@ -3068,7 +3081,6 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) { - dTHR; #ifdef USE_ITHREADS GvIN_PAD_on(gv); return newPADOP(type, flags, SvREFCNT_inc(gv)); @@ -3097,7 +3109,6 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) void Perl_package(pTHX_ OP *o) { - dTHR; SV *sv; save_hptr(&PL_curstash); @@ -3359,7 +3370,6 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } if (list_assignment(left)) { - dTHR; OP *curop; PL_modcount = 0; @@ -3500,7 +3510,6 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) OP * Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) { - dTHR; U32 seq = intro_my(); register COP *cop; @@ -3531,6 +3540,10 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->cop_warnings = PL_curcop->cop_warnings ; else cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ; + if (specialCopIO(PL_curcop->cop_io)) + cop->cop_io = PL_curcop->cop_io; + else + cop->cop_io = newSVsv(PL_curcop->cop_io) ; if (PL_copline == NOLINE) @@ -3589,7 +3602,6 @@ Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) STATIC OP * S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) { - dTHR; LOGOP *logop; OP *o; OP *first = *firstp; @@ -3701,7 +3713,6 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) OP * Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) { - dTHR; LOGOP *logop; OP *start; OP *o; @@ -3755,7 +3766,6 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) OP * Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) { - dTHR; LOGOP *range; OP *flip; OP *flop; @@ -3802,7 +3812,6 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) OP * Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) { - dTHR; OP* listop; OP* o; int once = block && block->op_flags & OPf_SPECIAL && @@ -3858,7 +3867,6 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) OP * Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont) { - dTHR; OP *redo; OP *next = 0; OP *listop; @@ -3899,7 +3907,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * if (cont) { next = LINKLIST(cont); - loopflags |= OPpLOOP_CONTINUE; } if (expr) { OP *unstack = newOP(OP_UNSTACK, 0); @@ -4052,7 +4059,6 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo OP* Perl_newLOOPEX(pTHX_ I32 type, OP *label) { - dTHR; OP *o; STRLEN n_a; @@ -4079,7 +4085,6 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) void Perl_cv_undef(pTHX_ CV *cv) { - dTHR; #ifdef USE_THREADS if (CvMUTEXP(cv)) { MUTEX_DESTROY(CvMUTEXP(cv)); @@ -4112,6 +4117,10 @@ Perl_cv_undef(pTHX_ CV *cv) CvGV(cv) = Nullgv; SvREFCNT_dec(CvOUTSIDE(cv)); CvOUTSIDE(cv) = Nullcv; + if (CvCONST(cv)) { + SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); + CvCONST_off(cv); + } if (CvPADLIST(cv)) { /* may be during global destruction */ if (SvREFCNT(CvPADLIST(cv))) { @@ -4185,7 +4194,6 @@ S_cv_dump(pTHX_ CV *cv) STATIC CV * S_cv_clone2(pTHX_ CV *proto, CV *outside) { - dTHR; AV* av; I32 ix; AV* protopadlist = CvPADLIST(proto); @@ -4312,6 +4320,15 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) #endif LEAVE; + + if (CvCONST(cv)) { + SV* const_sv = op_const_sv(CvSTART(cv), cv); + assert(const_sv); + /* constant sub () { $x } closing over $x - see lib/constant.pm */ + SvREFCNT_dec(cv); + cv = newCONSTSUB(CvSTASH(proto), 0, const_sv); + } + return cv; } @@ -4328,8 +4345,6 @@ Perl_cv_clone(pTHX_ CV *proto) void Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) { - dTHR; - if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { SV* msg = sv_newmortal(); SV* name = Nullsv; @@ -4350,12 +4365,25 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) } } +static void const_sv_xsub(pTHXo_ CV* cv); + +/* +=for apidoc cv_const_sv + +If C is a constant sub eligible for inlining. returns the constant +value returned by the sub. Otherwise, returns NULL. + +Constant subs can be created with C or as described in +L. + +=cut +*/ SV * Perl_cv_const_sv(pTHX_ CV *cv) { - if (!cv || !SvPOK(cv) || SvCUR(cv)) + if (!cv || !CvCONST(cv)) return Nullsv; - return op_const_sv(CvSTART(cv), cv); + return (SV*)CvXSUBANY(cv).any_ptr; } SV * @@ -4374,8 +4402,12 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv) if (sv && o->op_next == o) return sv; - if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK) - continue; + if (o->op_next != o) { + if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK) + continue; + if (type == OP_DBSTATE) + continue; + } if (type == OP_LEAVESUB || type == OP_RETURN) break; if (sv) @@ -4385,7 +4417,17 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv) else if ((type == OP_PADSV || type == OP_CONST) && cv) { AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]); sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv; - if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1)) + if (!sv) + return Nullsv; + if (CvCONST(cv)) { + /* We get here only from cv_clone2() while creating a closure. + Copy the const value here instead of in cv_clone2 so that + SvREADONLY_on doesn't lead to problems when leaving + scope. + */ + sv = newSVsv(sv); + } + if (!SvREADONLY(sv) && SvREFCNT(sv) > 1) return Nullsv; } else @@ -4419,7 +4461,6 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) CV * Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { - dTHR; STRLEN n_a; char *name; char *aname; @@ -4427,6 +4468,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch; register CV *cv=0; I32 ix; + SV *const_sv; name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch; if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) { @@ -4465,12 +4507,17 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) SvREFCNT_dec(PL_compcv); cv = PL_compcv = NULL; PL_sub_generation++; - goto noblock; + goto done; } - if (!name || GvCVGEN(gv)) - cv = Nullcv; - else if ((cv = GvCV(gv))) { + cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv); + + if (!block || !ps || *ps || attrs) + const_sv = Nullsv; + else + const_sv = op_const_sv(block, Nullcv); + + if (cv) { bool exists = CvROOT(cv) || CvXSUB(cv); /* if the subroutine doesn't exist and wasn't pre-declared * with a prototype, assume it will be AUTOLOADed, @@ -4480,8 +4527,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) cv_ckproto(cv, gv, ps); /* already defined (or promised)? */ if (exists || GvASSUMECV(gv)) { - SV* const_sv; - bool const_changed = TRUE; if (!block && !attrs) { /* just a "sub foo;" when &foo is already defined */ SAVEFREESV(PL_compcv); @@ -4490,24 +4535,42 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) /* ahem, death to those who redefine active sort subs */ if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv)) Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name); - if (!block) - goto withattrs; - if ((const_sv = cv_const_sv(cv))) - const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv)); - if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE)) - { - line_t oldline = CopLINE(PL_curcop); - CopLINE_set(PL_curcop, PL_copline); - Perl_warner(aTHX_ WARN_REDEFINE, - const_sv ? "Constant subroutine %s redefined" - : "Subroutine %s redefined", name); - CopLINE_set(PL_curcop, oldline); + if (block) { + if (ckWARN(WARN_REDEFINE) + || (CvCONST(cv) + && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv)))) + { + line_t oldline = CopLINE(PL_curcop); + CopLINE_set(PL_curcop, PL_copline); + Perl_warner(aTHX_ WARN_REDEFINE, + CvCONST(cv) ? "Constant subroutine %s redefined" + : "Subroutine %s redefined", name); + CopLINE_set(PL_curcop, oldline); + } + SvREFCNT_dec(cv); + cv = Nullcv; } - SvREFCNT_dec(cv); - cv = Nullcv; } } - withattrs: + if (const_sv) { + SvREFCNT_inc(const_sv); + if (cv) { + assert(!CvROOT(cv) && !CvCONST(cv)); + sv_setpv((SV*)cv, ""); /* prototype is "" */ + CvXSUBANY(cv).any_ptr = const_sv; + CvXSUB(cv) = const_sv_xsub; + CvCONST_on(cv); + } + else { + GvCV(gv) = Nullcv; + cv = newCONSTSUB(NULL, name, const_sv); + } + op_free(block); + SvREFCNT_dec(PL_compcv); + PL_compcv = NULL; + PL_sub_generation++; + goto done; + } if (attrs) { HV *stash; SV *rcv; @@ -4591,12 +4654,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } } - if (!block) { - noblock: - PL_copline = NOLINE; - LEAVE_SCOPE(floor); - return cv; - } + if (!block) + goto done; if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad)) av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv); @@ -4635,6 +4694,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PL_curpad[ix] = Nullsv; } } + assert(!CvCONST(cv)); + if (ps && !*ps && op_const_sv(block, cv)) + CvCONST_on(cv); } else { AV *av = newAV(); /* Will be @_ */ @@ -4750,10 +4812,10 @@ eligible for inlining at compile-time. =cut */ -void +CV * Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) { - dTHR; + CV* cv; ENTER; @@ -4774,15 +4836,14 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) #endif } - newATTRSUB( - start_subparse(FALSE, 0), - newSVOP(OP_CONST, 0, newSVpv(name,0)), - newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ - Nullop, - newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) - ); + cv = newXS(name, const_sv_xsub, __FILE__); + CvXSUBANY(cv).any_ptr = sv; + CvCONST_on(cv); + sv_setpv((SV*)cv, ""); /* prototype is "" */ LEAVE; + + return cv; } /* @@ -4796,7 +4857,6 @@ Used by C to hook up XSUBs as Perl subs. CV * Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) { - dTHR; GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); register CV *cv; @@ -4814,7 +4874,10 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) line_t oldline = CopLINE(PL_curcop); if (PL_copline != NOLINE) CopLINE_set(PL_curcop, PL_copline); - Perl_warner(aTHX_ WARN_REDEFINE, "Subroutine %s redefined",name); + Perl_warner(aTHX_ WARN_REDEFINE, + CvCONST(cv) ? "Constant subroutine %s redefined" + : "Subroutine %s redefined" + ,name); CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); @@ -4895,7 +4958,6 @@ done: void Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) { - dTHR; register CV *cv; char *name; GV *gv; @@ -4993,8 +5055,6 @@ Perl_oopsAV(pTHX_ OP *o) OP * Perl_oopsHV(pTHX_ OP *o) { - dTHR; - switch (o->op_type) { case OP_PADSV: case OP_PADAV: @@ -5291,7 +5351,6 @@ Perl_ck_gvconst(pTHX_ register OP *o) OP * Perl_ck_rvconst(pTHX_ register OP *o) { - dTHR; SVOP *kid = (SVOP*)cUNOPo->op_first; o->op_private |= (PL_hints & HINT_STRICT_REFS); @@ -5392,6 +5451,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) #else kid->op_sv = SvREFCNT_inc(gv); #endif + kid->op_private = 0; kid->op_ppaddr = PL_ppaddr[OP_GV]; } } @@ -5401,7 +5461,6 @@ Perl_ck_rvconst(pTHX_ register OP *o) OP * Perl_ck_ftst(pTHX_ OP *o) { - dTHR; I32 type = o->op_type; if (o->op_flags & OPf_REF) { @@ -5439,7 +5498,6 @@ Perl_ck_ftst(pTHX_ OP *o) OP * Perl_ck_fun(pTHX_ OP *o) { - dTHR; register OP *kid; OP **tokid; OP *sibl; @@ -5764,7 +5822,6 @@ Perl_ck_lfun(pTHX_ OP *o) OP * Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ { - dTHR; if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) { switch (cUNOPo->op_first->op_type) { case OP_RV2AV: @@ -6135,7 +6192,6 @@ Perl_ck_sort(pTHX_ OP *o) STATIC void S_simplify_sort(pTHX_ OP *o) { - dTHR; register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ OP *k; int reversed; @@ -6269,7 +6325,6 @@ Perl_ck_join(pTHX_ OP *o) OP * Perl_ck_subr(pTHX_ OP *o) { - dTHR; OP *prev = ((cUNOPo->op_first->op_sibling) ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first; OP *o2 = prev->op_sibling; @@ -6484,7 +6539,6 @@ Perl_ck_substr(pTHX_ OP *o) void Perl_peep(pTHX_ register OP *o) { - dTHR; register OP* oldop = 0; STRLEN n_a; OP *last_composite = Nullop; @@ -6520,7 +6574,7 @@ Perl_peep(pTHX_ register OP *o) PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP); if (SvPADTMP(cSVOPo->op_sv)) { /* If op_sv is already a PADTMP then it is being used by - * another pad, so make a copy. */ + * some pad, so make a copy. */ sv_setsv(PL_curpad[ix],cSVOPo->op_sv); SvREADONLY_on(PL_curpad[ix]); SvREFCNT_dec(cSVOPo->op_sv); @@ -6529,6 +6583,8 @@ Perl_peep(pTHX_ register OP *o) SvREFCNT_dec(PL_curpad[ix]); SvPADTMP_on(cSVOPo->op_sv); PL_curpad[ix] = cSVOPo->op_sv; + /* XXX I don't know how this isn't readonly already. */ + SvREADONLY_on(PL_curpad[ix]); } cSVOPo->op_sv = Nullsv; o->op_targ = ix; @@ -6646,8 +6702,14 @@ Perl_peep(pTHX_ register OP *o) case OP_ENTERLOOP: o->op_seq = PL_op_seqmax++; + while (cLOOP->op_redoop->op_type == OP_NULL) + cLOOP->op_redoop = cLOOP->op_redoop->op_next; peep(cLOOP->op_redoop); + while (cLOOP->op_nextop->op_type == OP_NULL) + cLOOP->op_nextop = cLOOP->op_nextop->op_next; peep(cLOOP->op_nextop); + while (cLOOP->op_lastop->op_type == OP_NULL) + cLOOP->op_lastop = cLOOP->op_lastop->op_next; peep(cLOOP->op_lastop); break; @@ -6655,6 +6717,9 @@ Perl_peep(pTHX_ register OP *o) case OP_MATCH: case OP_SUBST: o->op_seq = PL_op_seqmax++; + while (cPMOP->op_pmreplstart && + cPMOP->op_pmreplstart->op_type == OP_NULL) + cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next; peep(cPMOP->op_pmreplstart); break; @@ -6696,6 +6761,8 @@ Perl_peep(pTHX_ register OP *o) svp = cSVOPx_svp(((BINOP*)o)->op_last); if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) { key = SvPV(sv, keylen); + if (SvUTF8(sv)) + keylen = -keylen; lexname = newSVpvn_share(key, keylen, 0); SvREFCNT_dec(sv); *svp = lexname; @@ -6714,6 +6781,8 @@ Perl_peep(pTHX_ register OP *o) if (!fields || !GvHV(*fields)) break; key = SvPV(*svp, keylen); + if (SvUTF8(*svp)) + keylen = -keylen; indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); if (!indsvp) { Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s", @@ -6779,6 +6848,8 @@ Perl_peep(pTHX_ register OP *o) key_op = (SVOP*)key_op->op_sibling) { svp = cSVOPx_svp(key_op); key = SvPV(*svp, keylen); + if (SvUTF8(*svp)) + keylen = -keylen; indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); if (!indsvp) { Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" " @@ -6843,3 +6914,15 @@ Perl_peep(pTHX_ register OP *o) } LEAVE; } + +#include "XSUB.h" + +/* Efficient sub that returns a constant scalar value. */ +static void +const_sv_xsub(pTHXo_ CV* cv) +{ + dXSARGS; + EXTEND(sp, 1); + ST(0) = (SV*)XSANY.any_ptr; + XSRETURN(1); +} diff --git a/op.h b/op.h index 55b85a5..7dc118e 100644 --- a/op.h +++ b/op.h @@ -1,6 +1,6 @@ /* op.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -139,9 +139,6 @@ Deprecated. Use C instead. /* Private for OP_REPEAT */ #define OPpREPEAT_DOLIST 64 /* List replication. */ -/* Private for OP_LEAVELOOP */ -#define OPpLOOP_CONTINUE 64 /* a continue block is present */ - /* Private for OP_RV2?V, OP_?ELEM */ #define OPpDEREF (32|64) /* Want ref to something: */ #define OPpDEREF_AV 32 /* Want ref to AV. */ @@ -250,6 +247,9 @@ struct pmop { #define PMdf_USED 0x01 /* pm has been used once already */ #define PMdf_TAINTED 0x02 /* pm compiled from tainted pattern */ #define PMdf_UTF8 0x04 /* pm compiled from utf8 data */ +#define PMdf_DYN_UTF8 0x08 + +#define PMdf_CMP_UTF8 (PMdf_UTF8|PMdf_DYN_UTF8) #define PMf_RETAINT 0x0001 /* taint $1 etc. if target tainted */ #define PMf_ONCE 0x0002 /* use pattern only once per reset */ diff --git a/opcode.pl b/opcode.pl index 43d98ae..22bffb8 100755 --- a/opcode.pl +++ b/opcode.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl +chmod 0666, "opcode.h", "opnames.h"; unlink "opcode.h", "opnames.h"; open(OC, ">opcode.h") || die "Can't create opcode.h: $!\n"; open(ON, ">opnames.h") || die "Can't create opnames.h: $!\n"; @@ -56,7 +57,9 @@ for (@ops) { } print ON "\t", &tab(3,"OP_max"), "\n"; print ON "} opcode;\n"; -print ON "\n#define MAXO ", scalar @ops, "\n\n"; +print ON "\n#define MAXO ", scalar @ops, "\n"; +print ON "#define OP_phoney_INPUT_ONLY -1\n"; +print ON "#define OP_phoney_OUTPUT_ONLY -2\n\n"; # Emit op names and descriptions. diff --git a/opnames.h b/opnames.h index ba28f68..16b2f02 100644 --- a/opnames.h +++ b/opnames.h @@ -359,6 +359,8 @@ typedef enum opcode { } opcode; #define MAXO 351 +#define OP_phoney_INPUT_ONLY -1 +#define OP_phoney_OUTPUT_ONLY -2 #define OP_IS_SOCKET(op) \ diff --git a/os2/OS2/ExtAttr/Makefile.PL b/os2/OS2/ExtAttr/Makefile.PL index 3568028..0b8837f 100644 --- a/os2/OS2/ExtAttr/Makefile.PL +++ b/os2/OS2/ExtAttr/Makefile.PL @@ -4,7 +4,7 @@ use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'OS2::ExtAttr', 'VERSION_FROM' => 'ExtAttr.pm', # finds $VERSION - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' diff --git a/os2/OS2/PrfDB/Makefile.PL b/os2/OS2/PrfDB/Makefile.PL index 3952168..2d4a6a7 100644 --- a/os2/OS2/PrfDB/Makefile.PL +++ b/os2/OS2/PrfDB/Makefile.PL @@ -4,7 +4,7 @@ use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'OS2::PrfDB', 'VERSION_FROM' => 'PrfDB.pm', # finds $VERSION - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' diff --git a/os2/OS2/Process/Makefile.PL b/os2/OS2/Process/Makefile.PL index d324063..9c97ad0 100644 --- a/os2/OS2/Process/Makefile.PL +++ b/os2/OS2/Process/Makefile.PL @@ -4,7 +4,7 @@ use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'OS2::Process', VERSION_FROM=> 'Process.pm', - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' diff --git a/os2/OS2/REXX/DLL/Makefile.PL b/os2/OS2/REXX/DLL/Makefile.PL index fe2403d..fb91688 100644 --- a/os2/OS2/REXX/DLL/Makefile.PL +++ b/os2/OS2/REXX/DLL/Makefile.PL @@ -3,7 +3,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'OS2::DLL', VERSION => '0.01', - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', PERL_MALLOC_OK => 1, ); diff --git a/os2/OS2/REXX/Makefile.PL b/os2/OS2/REXX/Makefile.PL index 6648b2c..178ef7b 100644 --- a/os2/OS2/REXX/Makefile.PL +++ b/os2/OS2/REXX/Makefile.PL @@ -3,7 +3,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'OS2::REXX', VERSION => '0.22', - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', PERL_MALLOC_OK => 1, ); diff --git a/os2/OS2/REXX/REXX.xs b/os2/OS2/REXX/REXX.xs index 1dc20d3..b196ea1 100644 --- a/os2/OS2/REXX/REXX.xs +++ b/os2/OS2/REXX/REXX.xs @@ -46,7 +46,6 @@ static long incompartment; static SV* exec_in_REXX(pTHX_ char *cmd, char * handlerName, RexxFunctionHandler *handler) { - dTHR; HMODULE hRexx, hRexxAPI; BYTE buf[200]; LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING, diff --git a/os2/os2.c b/os2/os2.c index c324cf2..7fe8113 100644 --- a/os2/os2.c +++ b/os2/os2.c @@ -21,6 +21,8 @@ #include #include +#define PERLIO_NOT_STDIO 0 + #include "EXTERN.h" #include "perl.h" @@ -375,7 +377,6 @@ spawn_sighandler(int sig) static int result(pTHX_ int flag, int pid) { - dTHR; int r, status; Signal_t (*ihand)(); /* place to save signal during system() */ Signal_t (*qhand)(); /* place to save signal during system() */ @@ -467,7 +468,6 @@ static ULONG os2_mytype; int do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) { - dTHR; int trueflag = flag; int rc, pass = 1; char *tmps; @@ -605,8 +605,9 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) char *scr = find_script(PL_Argv[0], TRUE, NULL, 0); if (scr) { - FILE *file; - char *s = 0, *s1; + PerlIO *file; + SSize_t rd; + char *s = 0, *s1, *s2; int l; l = strlen(scr); @@ -622,14 +623,18 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) Safefree(scr); scr = scrbuf; - file = fopen(scr, "r"); + file = PerlIO_open(scr, "r"); PL_Argv[0] = scr; if (!file) goto panic_file; - if (!fgets(buf, sizeof buf, file)) { /* Empty... */ + rd = PerlIO_read(file, buf, sizeof buf-1); + buf[rd]='\0'; + if ((s2 = strchr(buf, '\n')) != NULL) *++s2 = '\0'; + + if (!rd) { /* Empty... */ buf[0] = 0; - fclose(file); + PerlIO_close(file); /* Special case: maybe from -Zexe build, so there is an executable around (contrary to documentation, DosQueryAppType sometimes (?) @@ -648,7 +653,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) } else goto longbuf; } - if (fclose(file) != 0) { /* Failure */ + if (PerlIO_close(file) != 0) { /* Failure */ panic_file: Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s", scr, Strerror(errno)); @@ -818,7 +823,6 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) int do_spawn3(pTHX_ char *cmd, int execf, int flag) { - dTHR; register char **a; register char *s; char flags[10]; @@ -946,7 +950,6 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag) int os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp) { - dTHR; register char **a; int rc; int flag = P_WAIT, flag_set = 0; @@ -984,21 +987,18 @@ os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp) int os2_do_spawn(pTHX_ char *cmd) { - dTHR; return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0); } int do_spawn_nowait(pTHX_ char *cmd) { - dTHR; return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0); } bool Perl_do_exec(pTHX_ char *cmd) { - dTHR; do_spawn3(aTHX_ cmd, EXECF_EXEC, 0); return FALSE; } @@ -1006,7 +1006,6 @@ Perl_do_exec(pTHX_ char *cmd) bool os2exec(pTHX_ char *cmd) { - dTHR; return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0); } @@ -1163,10 +1162,13 @@ tcp1(char *name, int arg) ((void (*)(int)) fcn) (arg); } +#ifndef HAS_GETHOSTENT /* Older versions of EMX did not have it... */ void * gethostent() { return tcp0("GETHOSTENT"); } void * getnetent() { return tcp0("GETNETENT"); } void * getprotoent() { return tcp0("GETPROTOENT"); } void * getservent() { return tcp0("GETSERVENT"); } +#endif + void sethostent(x) { tcp1("SETHOSTENT", x); } void setnetent(x) { tcp1("SETNETENT", x); } void setprotoent(x) { tcp1("SETPROTOENT", x); } @@ -1367,7 +1369,6 @@ os2error(int rc) char * os2_execname(pTHX) { - dTHR; char buf[300], *p; if (_execname(buf, sizeof buf) != 0) diff --git a/os2/os2ish.h b/os2/os2ish.h index c9719e6..dccd932 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -155,7 +155,6 @@ extern int rc; Perl_croak_nocontext("panic: COND_DESTROY, rc=%i", rc); \ } STMT_END /*#define THR ((struct thread *) TlsGetValue(PL_thr_key)) -#define dTHR struct thread *thr = THR */ #ifdef USE_SLOW_THREAD_SPECIFIC diff --git a/patchlevel.h b/patchlevel.h index b9d0dc4..5030553 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -70,7 +70,7 @@ #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT) static char *local_patches[] = { NULL - ,"DEVEL7368" + ,"DEVEL8341" ,NULL }; diff --git a/perl.c b/perl.c index cb2cb14..4911e79 100644 --- a/perl.c +++ b/perl.c @@ -1,6 +1,6 @@ /* perl.c * - * Copyright (c) 1987-2000 Larry Wall + * Copyright (c) 1987-2001 Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -157,7 +157,7 @@ perl_construct(pTHXx) #ifdef MULTIPLICITY init_interp(); - PL_perl_destruct_level = 1; + PL_perl_destruct_level = 1; #else if (PL_perl_destruct_level > 0) init_interp(); @@ -298,7 +298,6 @@ Shuts down a Perl interpreter. See L. void perl_destruct(pTHXx) { - dTHR; int destruct_level; /* 0=none, 1=full, 2=full with checks */ I32 last_sv_count; HV *hv; @@ -344,7 +343,7 @@ perl_destruct(pTHXx) DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: detaching thread %p\n", t)); ThrSETSTATE(t, THRf_R_DETACHED); - /* + /* * We unlock threads_mutex and t->mutex in the opposite order * from which we locked them just so that DETACH won't * deadlock if it panics. It's only a breach of good style @@ -434,7 +433,7 @@ perl_destruct(pTHXx) if (destruct_level == 0){ DEBUG_P(debprofdump()); - + /* The exit() function will do everything that needs doing. */ return; } @@ -474,11 +473,11 @@ perl_destruct(pTHXx) /* magical thingies */ - Safefree(PL_ofs); /* $, */ - PL_ofs = Nullch; + SvREFCNT_dec(PL_ofs_sv); /* $, */ + PL_ofs_sv = Nullsv; - Safefree(PL_ors); /* $\ */ - PL_ors = Nullch; + SvREFCNT_dec(PL_ors_sv); /* $\ */ + PL_ors_sv = Nullsv; SvREFCNT_dec(PL_rs); /* $/ */ PL_rs = Nullsv; @@ -603,6 +602,9 @@ perl_destruct(pTHXx) if (!specialWARN(PL_compiling.cop_warnings)) SvREFCNT_dec(PL_compiling.cop_warnings); PL_compiling.cop_warnings = Nullsv; + if (!specialCopIO(PL_compiling.cop_io)) + SvREFCNT_dec(PL_compiling.cop_io); + PL_compiling.cop_io = Nullsv; #ifdef USE_ITHREADS Safefree(CopFILE(&PL_compiling)); CopFILE(&PL_compiling) = Nullch; @@ -724,7 +726,7 @@ perl_destruct(pTHXx) Safefree(PL_psig_name); nuke_stacks(); PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */ - + DEBUG_P(debprofdump()); #ifdef USE_THREADS MUTEX_DESTROY(&PL_strtab_mutex); @@ -783,10 +785,18 @@ perl_free(pTHXx) #if defined(PERL_OBJECT) PerlMem_free(this); #else -# if defined(PERL_IMPLICIT_SYS) && defined(WIN32) +# if defined(WIN32) +# if defined(PERL_IMPLICIT_SYS) void *host = w32_internal_host; + if (PerlProc_lasthost()) { + PerlIO_cleanup(); + } PerlMem_free(aTHXx); win32_delete_internal_host(host); +#else + PerlIO_cleanup(); + PerlMem_free(aTHXx); +#endif # else PerlMem_free(aTHXx); # endif @@ -813,7 +823,6 @@ Tells a Perl interpreter to parse a Perl script. See L. int perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) { - dTHR; I32 oldscope; int ret; dJMPENV; @@ -836,7 +845,7 @@ setuid perl scripts securely.\n"); PL_origargv = argv; PL_origargc = argc; -#if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */ +#ifdef USE_ENVIRON_ARRAY PL_origenviron = environ; #endif @@ -915,7 +924,6 @@ S_vparse_body(pTHX_ va_list args) STATIC void * S_parse_body(pTHX_ char **env, XSINIT_t xsinit) { - dTHR; int argc = PL_origargc; char **argv = PL_origargv; char *scriptname = NULL; @@ -986,7 +994,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #ifdef MACOS_TRADITIONAL /* ignore -e for Dev:Pseudo argument */ if (argv[1] && !strcmp(argv[1], "Dev:Pseudo")) - break; + break; #endif if (PL_euid != PL_uid || PL_egid != PL_gid) Perl_croak(aTHX_ "No -e allowed in setuid scripts"); @@ -1267,7 +1275,7 @@ print \" \\@INC:\\n @INC\\n\";"); # else SOCKSinit(argv[0]); # endif -#endif +#endif init_predump_symbols(); /* init_postdump_symbols not currently designed to be called */ @@ -1346,7 +1354,6 @@ Tells a Perl interpreter to run. See L. int perl_run(pTHXx) { - dTHR; I32 oldscope; int ret = 0; dJMPENV; @@ -1414,8 +1421,6 @@ S_vrun_body(pTHX_ va_list args) STATIC void * S_run_body(pTHX_ I32 oldscope) { - dTHR; - DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n", PL_sawampersand ? "Enabling" : "Omitting")); @@ -1434,7 +1439,7 @@ S_run_body(pTHX_ I32 oldscope) my_exit(0); } if (PERLDB_SINGLE && PL_DBsingle) - sv_setiv(PL_DBsingle, 1); + sv_setiv(PL_DBsingle, 1); if (PL_initav) call_list(oldscope, PL_initav); } @@ -1474,10 +1479,8 @@ Perl_get_sv(pTHX_ const char *name, I32 create) #ifdef USE_THREADS if (name[1] == '\0' && !isALPHA(name[0])) { PADOFFSET tmp = find_threadsv(name); - if (tmp != NOT_IN_PAD) { - dTHR; + if (tmp != NOT_IN_PAD) return THREADSV(tmp); - } } #endif /* USE_THREADS */ gv = gv_fetchpv(name, create, SVt_PV); @@ -1569,7 +1572,7 @@ Performs a callback to the specified Perl sub. See L. I32 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv) - + /* See G_* flags in cop.h */ /* null terminated arg list */ { @@ -1694,15 +1697,15 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) { register PERL_CONTEXT *cx; I32 gimme = GIMME_V; - + ENTER; SAVETMPS; - + push_return(Nullop); PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); PUSHEVAL(cx, 0, 0); PL_eval_root = PL_op; /* Only needed so that goto works right. */ - + PL_in_eval = EVAL_INEVAL; if (flags & G_KEEPERR) PL_in_eval |= EVAL_KEEPERR; @@ -1797,8 +1800,6 @@ S_vcall_body(pTHX_ va_list args) STATIC void S_call_body(pTHX_ OP *myop, int is_eval) { - dTHR; - if (PL_op == myop) { if (is_eval) PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */ @@ -1821,7 +1822,7 @@ Tells Perl to C the string in the SV. I32 Perl_eval_sv(pTHX_ SV *sv, I32 flags) - + /* See G_* flags in cop.h */ { dSP; @@ -2025,13 +2026,12 @@ NULL char * Perl_moreswitches(pTHX_ char *s) { - I32 numlen; + STRLEN numlen; U32 rschar; switch (*s) { case '0': { - dTHR; numlen = 0; /* disallow underscores */ rschar = (U32)scan_oct(s, 4, &numlen); SvREFCNT_dec(PL_nrs); @@ -2095,7 +2095,7 @@ Perl_moreswitches(pTHX_ char *s) #ifdef DEBUGGING forbid_setid("-D"); if (isALPHA(s[1])) { - static char debopts[] = "psltocPmfrxuLHXDS"; + static char debopts[] = "psltocPmfrxuLHXDST"; char *d; for (s++; *s && (d = strchr(debopts,*s)); s++) @@ -2107,7 +2107,6 @@ Perl_moreswitches(pTHX_ char *s) } PL_debug |= 0x80000000; #else - dTHR; if (ckWARN_d(WARN_DEBUGGING)) Perl_warner(aTHX_ WARN_DEBUGGING, "Recompile perl with -DDEBUGGING to use -D switch\n"); @@ -2117,7 +2116,7 @@ Perl_moreswitches(pTHX_ char *s) return s; } case 'h': - usage(PL_origargv[0]); + usage(PL_origargv[0]); PerlProc_exit(0); case 'i': if (PL_inplace) @@ -2159,24 +2158,23 @@ Perl_moreswitches(pTHX_ char *s) case 'l': PL_minus_l = TRUE; s++; - if (PL_ors) - Safefree(PL_ors); + if (PL_ors_sv) { + SvREFCNT_dec(PL_ors_sv); + PL_ors_sv = Nullsv; + } if (isDIGIT(*s)) { - PL_ors = savepv("\n"); - PL_orslen = 1; + PL_ors_sv = newSVpvn("\n",1); numlen = 0; /* disallow underscores */ - *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen); + *SvPVX(PL_ors_sv) = (char)scan_oct(s, 3 + (*s == '0'), &numlen); s += numlen; } else { - dTHR; if (RsPARA(PL_nrs)) { - PL_ors = "\n\n"; - PL_orslen = 2; + PL_ors_sv = newSVpvn("\n\n",2); + } + else { + PL_ors_sv = newSVsv(PL_nrs); } - else - PL_ors = SvPV(PL_nrs, PL_orslen); - PL_ors = savepvn(PL_ors, PL_orslen); } return s; case 'M': @@ -2261,7 +2259,7 @@ Perl_moreswitches(pTHX_ char *s) #endif PerlIO_printf(PerlIO_stdout(), - "\n\nCopyright 1987-2000, Larry Wall\n"); + "\n\nCopyright 1987-2001, Larry Wall\n"); #ifdef MACOS_TRADITIONAL PerlIO_printf(PerlIO_stdout(), "\nMacOS port Copyright (c) 1991-2000, Matthias Neeracher\n"); @@ -2329,16 +2327,16 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); PerlProc_exit(0); case 'w': if (! (PL_dowarn & G_WARN_ALL_MASK)) - PL_dowarn |= G_WARN_ON; + PL_dowarn |= G_WARN_ON; s++; return s; case 'W': - PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; + PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; PL_compiling.cop_warnings = pWARN_ALL ; s++; return s; case 'X': - PL_dowarn = G_WARN_ALL_OFF; + PL_dowarn = G_WARN_ALL_OFF; PL_compiling.cop_warnings = pWARN_NONE ; s++; return s; @@ -2484,7 +2482,6 @@ S_init_interp(pTHX) STATIC void S_init_main_stash(pTHX) { - dTHR; GV *gv; /* Note that strtab is a rather special HV. Assumptions are made @@ -2496,7 +2493,7 @@ S_init_main_stash(pTHX) #endif HvSHAREKEYS_off(PL_strtab); /* mandatory */ hv_ksplit(PL_strtab, 512); - + PL_curstash = PL_defstash = newHV(); PL_curstname = newSVpvn("main",4); gv = gv_fetchpv("main::",TRUE, SVt_PVHV); @@ -2528,8 +2525,6 @@ S_init_main_stash(pTHX) STATIC void S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) { - dTHR; - *fdscript = -1; if (PL_e_script) { @@ -2719,7 +2714,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd) check_okay = fstatvfs(fd, &stfs) == 0; on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID); # endif /* fstatvfs */ - + # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ defined(PERL_MOUNT_NOSUID) && \ defined(HAS_FSTATFS) && \ @@ -2789,7 +2784,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd) fclose(mtab); # endif /* getmntent+hasmntopt */ - if (!check_okay) + if (!check_okay) Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename); return on_nosuid; } @@ -2823,7 +2818,6 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) */ #ifdef DOSUID - dTHR; char *s, *s2; if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */ @@ -3021,7 +3015,6 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #else /* !DOSUID */ if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */ #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW - dTHR; PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */ if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID) || @@ -3046,7 +3039,7 @@ S_find_beginning(pTHX) forbid_setid("-x"); #ifdef MACOS_TRADITIONAL /* Since the Mac OS does not honor !# arguments for us, we do it ourselves */ - + while (PL_doextract || gMacPerl_AlwaysExtract) { if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) { if (!gMacPerl_AlwaysExtract) @@ -3060,7 +3053,7 @@ S_find_beginning(pTHX) /* Pater peccavi, file does not have #! */ PerlIO_rewind(PL_rsfp); - + break; } #else @@ -3112,7 +3105,6 @@ S_forbid_setid(pTHX_ char *s) void Perl_init_debugger(pTHX) { - dTHR; HV *ostash = PL_curstash; PL_curstash = PL_debstash; @@ -3123,11 +3115,11 @@ Perl_init_debugger(pTHX) PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV)); sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */ PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV))); - sv_setiv(PL_DBsingle, 0); + sv_setiv(PL_DBsingle, 0); PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV))); - sv_setiv(PL_DBtrace, 0); + sv_setiv(PL_DBtrace, 0); PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV))); - sv_setiv(PL_DBsignal, 0); + sv_setiv(PL_DBsignal, 0); PL_curstash = ostash; } @@ -3180,7 +3172,6 @@ Perl_init_stacks(pTHX) STATIC void S_nuke_stacks(pTHX) { - dTHR; while (PL_curstackinfo->si_next) PL_curstackinfo = PL_curstackinfo->si_next; while (PL_curstackinfo) { @@ -3217,7 +3208,6 @@ S_init_lexer(pTHX) STATIC void S_init_predump_symbols(pTHX) { - dTHR; GV *tmpgv; IO *io; @@ -3257,7 +3247,6 @@ S_init_predump_symbols(pTHX) STATIC void S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env) { - dTHR; char *s; SV *sv; GV* tmpgv; @@ -3319,7 +3308,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register GvMULTI_on(PL_envgv); hv = GvHVn(PL_envgv); hv_magic(hv, PL_envgv, 'E'); -#if !defined( VMS) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) /* VMS doesn't have environ array */ +#ifdef USE_ENVIRON_ARRAY /* Note that if the supplied env parameter is actually a copy of the global environ then it may now point to free'd memory if the environment has been modified since. To avoid this @@ -3404,7 +3393,7 @@ S_init_perllib(pTHX) Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl); if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) incpush(SvPVX(privdir), TRUE, FALSE); - + SvREFCNT_dec(privdir); } if (!PL_tainting) @@ -3413,7 +3402,7 @@ S_init_perllib(pTHX) #ifndef PRIVLIB_EXP # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" #endif -#if defined(WIN32) +#if defined(WIN32) incpush(PRIVLIB_EXP, TRUE, FALSE); #else incpush(PRIVLIB_EXP, FALSE, FALSE); @@ -3483,7 +3472,7 @@ S_init_perllib(pTHX) #endif #ifndef PERLLIB_MANGLE # define PERLLIB_MANGLE(s,n) (s) -#endif +#endif STATIC void S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) @@ -3559,7 +3548,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) #define PERL_ARCH_FMT "/%s" #endif /* .../version/archname if -d .../version/archname */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT PERL_ARCH_FMT, + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT PERL_ARCH_FMT, libdir, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION, ARCHNAME); @@ -3637,6 +3626,7 @@ S_init_main_thread(pTHX) thr->tid = 0; thr->next = thr; thr->prev = thr; + thr->thr_done = 0; MUTEX_UNLOCK(&PL_threads_mutex); #ifdef HAVE_THREAD_INTERN @@ -3651,8 +3641,9 @@ S_init_main_thread(pTHX) PERL_SET_THX(thr); /* - * These must come after the SET_THR because sv_setpvn does - * SvTAINT and the taint fields require dTHR. + * These must come after the thread self setting + * because sv_setpvn does SvTAINT and the taint + * fields thread selfness being set. */ PL_toptarget = NEWSV(0,0); sv_upgrade(PL_toptarget, SVt_PVFM); @@ -3680,7 +3671,6 @@ S_init_main_thread(pTHX) void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) { - dTHR; SV *atsv; line_t oldline = CopLINE(PL_curcop); CV *cv; @@ -3785,8 +3775,6 @@ S_call_list_body(pTHX_ CV *cv) void Perl_my_exit(pTHX_ U32 status) { - dTHR; - DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n", thr, (unsigned long) status)); switch (status) { @@ -3822,7 +3810,7 @@ Perl_my_failure_exit(pTHX) if (errno & 255) STATUS_POSIX_SET(errno); else { - exitstatus = STATUS_POSIX >> 8; + exitstatus = STATUS_POSIX >> 8; if (exitstatus & 255) STATUS_POSIX_SET(exitstatus); else @@ -3835,7 +3823,6 @@ Perl_my_failure_exit(pTHX) STATIC void S_my_exit_jump(pTHX) { - dTHR; register PERL_CONTEXT *cx; I32 gimme; SV **newsp; diff --git a/perl.h b/perl.h index b655e04..6a545e6 100644 --- a/perl.h +++ b/perl.h @@ -1,6 +1,6 @@ /* perl.h * - * Copyright (c) 1987-2000, Larry Wall + * Copyright (c) 1987-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -183,7 +183,7 @@ class CPerlObj; struct perl_thread; # define pTHX register struct perl_thread *thr # define aTHX thr -# define dTHR dNOOP +# define dTHR dNOOP /* only backward compatibility */ # define dTHXa(a) pTHX = (struct perl_thread*)a # else # ifndef MULTIPLICITY @@ -303,7 +303,7 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); #endif #define WITH_THX(s) STMT_START { dTHX; s; } STMT_END -#define WITH_THR(s) STMT_START { dTHR; s; } STMT_END +#define WITH_THR(s) WITH_THX(s) /* * SOFT_CAST can be used for args to prototyped functions to retain some @@ -496,12 +496,16 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); # include #endif - /* Use all the "standard" definitions? */ #if defined(STANDARD_C) && defined(I_STDLIB) # include #endif +/* If this causes problems, set i_unistd=undef in the hint file. */ +#ifdef I_UNISTD +# include +#endif + #ifdef PERL_MICRO /* Last chance to export Perl_my_swap */ # define MYSWAP #endif @@ -709,10 +713,47 @@ typedef struct perl_mstats perl_mstats_t; #endif #include -#ifdef HAS_SOCKET -# ifdef I_NET_ERRNO -# include + +#if defined(WIN32) && (defined(PERL_OBJECT) || defined(PERL_IMPLICIT_SYS) || defined(PERL_CAPI)) +# define WIN32SCK_IS_STDSCK /* don't pull in custom wsock layer */ +#endif + +#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */ +# include +# if defined(USE_SOCKS) && defined(I_SOCKS) +# if !defined(INCLUDE_PROTOTYPES) +# define INCLUDE_PROTOTYPES /* for */ +# define PERL_SOCKS_NEED_PROTOTYPES +# endif +# ifdef USE_THREADS +# define PERL_USE_THREADS /* store our value */ +# undef USE_THREADS # endif +# include +# ifdef USE_THREADS +# undef USE_THREADS /* socks.h does this on its own */ +# endif +# ifdef PERL_USE_THREADS +# define USE_THREADS /* restore our value */ +# undef PERL_USE_THREADS +# endif +# ifdef PERL_SOCKS_NEED_PROTOTYPES /* keep cpp space clean */ +# undef INCLUDE_PROTOTYPES +# undef PERL_SOCKS_NEED_PROTOTYPES +# endif +# endif +# ifdef I_NETDB +# include +# endif +# ifndef ENOTSOCK +# ifdef I_NET_ERRNO +# include +# endif +# endif +#endif + +#ifdef SETERRNO +# undef SETERRNO /* SOCKS might have defined this */ #endif #ifdef VMS @@ -1043,6 +1084,11 @@ typedef UVTYPE UV; #define IV_DIG (BIT_DIGITS(IVSIZE * 8)) #define UV_DIG (BIT_DIGITS(UVSIZE * 8)) +/* We like our integers to stay integers. */ +#ifndef NO_PERL_PRESERVE_IVUV +#define PERL_PRESERVE_IVUV +#endif + /* * The macros INT2PTR and NUM2PTR are (despite their names) * bi-directional: they will convert int/float to or from pointers. @@ -1075,6 +1121,9 @@ typedef UVTYPE UV; #endif #ifdef USE_LONG_DOUBLE +# if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE == DOUBLESIZE +# define LONG_DOUBLE_EQUALS_DOUBLE +# endif # if !(defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE)) # undef USE_LONG_DOUBLE /* Ouch! */ # endif @@ -1440,6 +1489,7 @@ struct perl_mstats { UV *bucket_available_size; UV nbuckets; }; +struct RExC_state_t; typedef MEM_SIZE STRLEN; @@ -1626,6 +1676,9 @@ typedef struct ptr_tbl PTR_TBL_t; # else # if defined(MACOS_TRADITIONAL) # include "macos/macish.h" +# ifndef NO_ENVIRON_ARRAY +# define NO_ENVIRON_ARRAY +# endif # else # include "unixish.h" # endif @@ -2105,6 +2158,7 @@ Gid_t getegid (void); # else # define DEBUG_S(a) # endif +#define DEBUG_T(a) if (PL_debug & (1<<17)) a #else #define DEB(a) #define DEBUG(a) @@ -2125,6 +2179,7 @@ Gid_t getegid (void); #define DEBUG_X(a) #define DEBUG_D(a) #define DEBUG_S(a) +#define DEBUG_T(a) #endif #define YYMAXDEPTH 300 @@ -2195,8 +2250,12 @@ char *crypt (const char*, const char*); # ifndef getenv char *getenv (const char*); # endif /* !getenv */ -# if !defined(EPOC) && !(defined(__hpux) && defined(_FILE_OFFSET_BITS) && _FILE_OFFSET_BITS == 64) && !defined(HAS_LSEEK_PROTO) +# if !defined(HAS_LSEEK_PROTO) && !defined(EPOC) && !defined(__hpux) +# ifdef _FILE_OFFSET_BITS +# if _FILE_OFFSET_BITS == 64 Off_t lseek (int,Off_t,int); +# endif +# endif # endif # endif /* !DONT_DECLARE_STD */ char *getlogin (void); @@ -2639,6 +2698,7 @@ enum { /* pass one of these to get_vtbl */ #define HINT_FILETEST_ACCESS 0x00400000 #define HINT_UTF8 0x00800000 +#define HINT_UTF8_DISTINCT 0x01000000 /* Various states of an input record separator SV (rs, nrs) */ #define RsSNARF(sv) (! SvOK(sv)) @@ -2658,10 +2718,6 @@ typedef char* (CPERLscope(*re_intuit_start_t)) (pTHX_ regexp *prog, SV *sv, typedef SV* (CPERLscope(*re_intuit_string_t)) (pTHX_ regexp *prog); typedef void (CPERLscope(*regfree_t)) (pTHX_ struct regexp* r); -#ifdef USE_PURE_BISON -int Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp); -#endif - typedef void (*DESTRUCTORFUNC_NOCONTEXT_t) (void*); typedef void (*DESTRUCTORFUNC_t) (pTHXo_ void*); typedef void (*SVFUNC_t) (pTHXo_ SV*); @@ -3005,46 +3061,53 @@ enum { to_sv_amg, to_av_amg, to_hv_amg, to_gv_amg, to_cv_amg, iter_amg, - max_amg_code + DESTROY_amg, max_amg_code /* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */ }; #define NofAMmeth max_amg_code +#define AMG_id2name(id) ((char*)PL_AMG_names[id]+1) #ifdef DOINIT EXTCONST char * PL_AMG_names[NofAMmeth] = { - "fallback", "abs", /* "fallback" should be the first. */ - "bool", "nomethod", - "\"\"", "0+", - "+", "+=", - "-", "-=", - "*", "*=", - "/", "/=", - "%", "%=", - "**", "**=", - "<<", "<<=", - ">>", ">>=", - "&", "&=", - "|", "|=", - "^", "^=", - "<", "<=", - ">", ">=", - "==", "!=", - "<=>", "cmp", - "lt", "le", - "gt", "ge", - "eq", "ne", - "!", "~", - "++", "--", - "atan2", "cos", - "sin", "exp", - "log", "sqrt", - "x", "x=", - ".", ".=", - "=", "neg", - "${}", "@{}", - "%{}", "*{}", - "&{}", "<>", + /* Names kept in the symbol table. fallback => "()", the rest has + "(" prepended. The only other place in perl which knows about + this convention is AMG_id2name (used for debugging output and + 'nomethod' only), the only other place which has it hardwired is + overload.pm. */ + "()", "(abs", /* "fallback" should be the first. */ + "(bool", "(nomethod", + "(\"\"", "(0+", + "(+", "(+=", + "(-", "(-=", + "(*", "(*=", + "(/", "(/=", + "(%", "(%=", + "(**", "(**=", + "(<<", "(<<=", + "(>>", "(>>=", + "(&", "(&=", + "(|", "(|=", + "(^", "(^=", + "(<", "(<=", + "(>", "(>=", + "(==", "(!=", + "(<=>", "(cmp", + "(lt", "(le", + "(gt", "(ge", + "(eq", "(ne", + "(!", "(~", + "(++", "(--", + "(atan2", "(cos", + "(sin", "(exp", + "(log", "(sqrt", + "(x", "(x=", + "(.", "(.=", + "(=", "(neg", + "(${}", "(@{}", + "(%{}", "(*{}", + "(&{}", "(<>", + "DESTROY", }; #else EXTCONST char * PL_AMG_names[NofAMmeth]; @@ -3072,10 +3135,15 @@ typedef struct am_table_short AMTS; #define AMGfallYES 3 #define AMTf_AMAGIC 1 +#define AMTf_OVERLOADED 2 #define AMT_AMAGIC(amt) ((amt)->flags & AMTf_AMAGIC) #define AMT_AMAGIC_on(amt) ((amt)->flags |= AMTf_AMAGIC) #define AMT_AMAGIC_off(amt) ((amt)->flags &= ~AMTf_AMAGIC) +#define AMT_OVERLOADED(amt) ((amt)->flags & AMTf_OVERLOADED) +#define AMT_OVERLOADED_on(amt) ((amt)->flags |= AMTf_OVERLOADED) +#define AMT_OVERLOADED_off(amt) ((amt)->flags &= ~AMTf_OVERLOADED) +#define StashHANDLER(stash,meth) gv_handler((stash),CAT2(meth,_amg)) /* * some compilers like to redefine cos et alia as faster @@ -3140,16 +3208,10 @@ typedef struct am_table_short AMTS; #ifdef USE_LOCALE_NUMERIC #define SET_NUMERIC_STANDARD() \ - STMT_START { \ - if (! PL_numeric_standard) \ - set_numeric_standard(); \ - } STMT_END + set_numeric_standard(); #define SET_NUMERIC_LOCAL() \ - STMT_START { \ - if (! PL_numeric_local) \ - set_numeric_local(); \ - } STMT_END + set_numeric_local(); #define IS_NUMERIC_RADIX(c) \ ((PL_hints & HINT_LOCALE) && \ @@ -3157,11 +3219,11 @@ typedef struct am_table_short AMTS; #define STORE_NUMERIC_LOCAL_SET_STANDARD() \ bool was_local = (PL_hints & HINT_LOCALE) && PL_numeric_local; \ - if (!was_local) SET_NUMERIC_STANDARD(); + if (was_local) SET_NUMERIC_STANDARD(); #define STORE_NUMERIC_STANDARD_SET_LOCAL() \ - bool was_standard = !(PL_hints & HINT_LOCALE) || PL_numeric_standard; \ - if (!was_standard) SET_NUMERIC_LOCAL(); + bool was_standard = (PL_hints & HINT_LOCALE) && PL_numeric_standard; \ + if (was_standard) SET_NUMERIC_LOCAL(); #define RESTORE_NUMERIC_LOCAL() \ if (was_local) SET_NUMERIC_LOCAL(); @@ -3191,6 +3253,9 @@ typedef struct am_table_short AMTS; # if !defined(Strtol) && defined(HAS_STRTOLL) # define Strtol strtoll # endif +# if !defined(Strtol) && defined(HAS_STRTOQ) +# define Strtol strtoq +# endif /* is there atoq() anywhere? */ #endif #if !defined(Strtol) && defined(HAS_STRTOL) @@ -3402,6 +3467,10 @@ typedef struct am_table_short AMTS; # include /* setproctitle() in some FreeBSDs */ #endif +#ifndef EXEC_ARGV_CAST +#define EXEC_ARGV_CAST(x) x +#endif + /* and finally... */ #define PERL_PATCHLEVEL_H_IMPLICIT #include "patchlevel.h" diff --git a/perlapi.c b/perlapi.c index 39a13ba..bb32970 100755 --- a/perlapi.c +++ b/perlapi.c @@ -85,6 +85,13 @@ Perl_Gv_AMupdate(pTHXo_ HV* stash) return ((CPerlObj*)pPerl)->Perl_Gv_AMupdate(stash); } +#undef Perl_gv_handler +CV* +Perl_gv_handler(pTHXo_ HV* stash, I32 id) +{ + return ((CPerlObj*)pPerl)->Perl_gv_handler(stash, id); +} + #undef Perl_apply_attrs_string void Perl_apply_attrs_string(pTHXo_ char *stashpv, CV *cv, char *attrstr, STRLEN len) @@ -936,7 +943,7 @@ Perl_hv_delayfree_ent(pTHXo_ HV* hv, HE* entry) #undef Perl_hv_delete SV* -Perl_hv_delete(pTHXo_ HV* tb, const char* key, U32 klen, I32 flags) +Perl_hv_delete(pTHXo_ HV* tb, const char* key, I32 klen, I32 flags) { return ((CPerlObj*)pPerl)->Perl_hv_delete(tb, key, klen, flags); } @@ -950,7 +957,7 @@ Perl_hv_delete_ent(pTHXo_ HV* tb, SV* key, I32 flags, U32 hash) #undef Perl_hv_exists bool -Perl_hv_exists(pTHXo_ HV* tb, const char* key, U32 klen) +Perl_hv_exists(pTHXo_ HV* tb, const char* key, I32 klen) { return ((CPerlObj*)pPerl)->Perl_hv_exists(tb, key, klen); } @@ -964,7 +971,7 @@ Perl_hv_exists_ent(pTHXo_ HV* tb, SV* key, U32 hash) #undef Perl_hv_fetch SV** -Perl_hv_fetch(pTHXo_ HV* tb, const char* key, U32 klen, I32 lval) +Perl_hv_fetch(pTHXo_ HV* tb, const char* key, I32 klen, I32 lval) { return ((CPerlObj*)pPerl)->Perl_hv_fetch(tb, key, klen, lval); } @@ -1041,7 +1048,7 @@ Perl_hv_magic(pTHXo_ HV* hv, GV* gv, int how) #undef Perl_hv_store SV** -Perl_hv_store(pTHXo_ HV* tb, const char* key, U32 klen, SV* val, U32 hash) +Perl_hv_store(pTHXo_ HV* tb, const char* key, I32 klen, SV* val, U32 hash) { return ((CPerlObj*)pPerl)->Perl_hv_store(tb, key, klen, val, hash); } @@ -1327,7 +1334,7 @@ Perl_to_uni_lower_lc(pTHXo_ U32 c) } #undef Perl_is_utf8_char -int +STRLEN Perl_is_utf8_char(pTHXo_ U8 *p) { return ((CPerlObj*)pPerl)->Perl_is_utf8_char(p); @@ -1743,10 +1750,10 @@ Perl_newCONDOP(pTHXo_ I32 flags, OP* expr, OP* trueop, OP* falseop) } #undef Perl_newCONSTSUB -void +CV* Perl_newCONSTSUB(pTHXo_ HV* stash, char* name, SV* sv) { - ((CPerlObj*)pPerl)->Perl_newCONSTSUB(stash, name, sv); + return ((CPerlObj*)pPerl)->Perl_newCONSTSUB(stash, name, sv); } #undef Perl_newFORM @@ -2017,7 +2024,7 @@ Perl_newSVpvn(pTHXo_ const char* s, STRLEN len) #undef Perl_newSVpvn_share SV* -Perl_newSVpvn_share(pTHXo_ const char* s, STRLEN len, U32 hash) +Perl_newSVpvn_share(pTHXo_ const char* s, I32 len, U32 hash) { return ((CPerlObj*)pPerl)->Perl_newSVpvn_share(s, len, hash); } @@ -2237,21 +2244,21 @@ Perl_init_i18nl14n(pTHXo_ int printwarn) #undef Perl_new_collate void -Perl_new_collate(pTHXo_ const char* newcoll) +Perl_new_collate(pTHXo_ char* newcoll) { ((CPerlObj*)pPerl)->Perl_new_collate(newcoll); } #undef Perl_new_ctype void -Perl_new_ctype(pTHXo_ const char* newctype) +Perl_new_ctype(pTHXo_ char* newctype) { ((CPerlObj*)pPerl)->Perl_new_ctype(newctype); } #undef Perl_new_numeric void -Perl_new_numeric(pTHXo_ const char* newcoll) +Perl_new_numeric(pTHXo_ char* newcoll) { ((CPerlObj*)pPerl)->Perl_new_numeric(newcoll); } @@ -2312,6 +2319,13 @@ Perl_regdump(pTHXo_ regexp* r) ((CPerlObj*)pPerl)->Perl_regdump(r); } +#undef Perl_regclass_swash +SV* +Perl_regclass_swash(pTHXo_ struct regnode *n, bool doinit, SV **initsvp) +{ + return ((CPerlObj*)pPerl)->Perl_regclass_swash(n, doinit, initsvp); +} + #undef Perl_pregexec I32 Perl_pregexec(pTHXo_ regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, U32 nosave) @@ -2615,6 +2629,13 @@ Perl_save_re_context(pTHXo) ((CPerlObj*)pPerl)->Perl_save_re_context(); } +#undef Perl_save_padsv +void +Perl_save_padsv(pTHXo_ PADOFFSET off) +{ + ((CPerlObj*)pPerl)->Perl_save_padsv(off); +} + #undef Perl_save_sptr void Perl_save_sptr(pTHXo_ SV** sptr) @@ -2638,28 +2659,28 @@ Perl_save_threadsv(pTHXo_ PADOFFSET i) #undef Perl_scan_bin NV -Perl_scan_bin(pTHXo_ char* start, I32 len, I32* retlen) +Perl_scan_bin(pTHXo_ char* start, STRLEN len, STRLEN* retlen) { return ((CPerlObj*)pPerl)->Perl_scan_bin(start, len, retlen); } #undef Perl_scan_hex NV -Perl_scan_hex(pTHXo_ char* start, I32 len, I32* retlen) +Perl_scan_hex(pTHXo_ char* start, STRLEN len, STRLEN* retlen) { return ((CPerlObj*)pPerl)->Perl_scan_hex(start, len, retlen); } #undef Perl_scan_num char* -Perl_scan_num(pTHXo_ char* s) +Perl_scan_num(pTHXo_ char* s, YYSTYPE *lvalp) { - return ((CPerlObj*)pPerl)->Perl_scan_num(s); + return ((CPerlObj*)pPerl)->Perl_scan_num(s, lvalp); } #undef Perl_scan_oct NV -Perl_scan_oct(pTHXo_ char* start, I32 len, I32* retlen) +Perl_scan_oct(pTHXo_ char* start, STRLEN len, STRLEN* retlen) { return ((CPerlObj*)pPerl)->Perl_scan_oct(start, len, retlen); } @@ -3220,6 +3241,13 @@ Perl_sv_unref(pTHXo_ SV* sv) ((CPerlObj*)pPerl)->Perl_sv_unref(sv); } +#undef Perl_sv_unref_flags +void +Perl_sv_unref_flags(pTHXo_ SV* sv, U32 flags) +{ + ((CPerlObj*)pPerl)->Perl_sv_unref_flags(sv, flags); +} + #undef Perl_sv_untaint void Perl_sv_untaint(pTHXo_ SV* sv) @@ -3350,8 +3378,15 @@ Perl_utf16_to_utf8_reversed(pTHXo_ U8* p, U8 *d, I32 bytelen, I32 *newlen) return ((CPerlObj*)pPerl)->Perl_utf16_to_utf8_reversed(p, d, bytelen, newlen); } +#undef Perl_utf8_length +STRLEN +Perl_utf8_length(pTHXo_ U8* s, U8 *e) +{ + return ((CPerlObj*)pPerl)->Perl_utf8_length(s, e); +} + #undef Perl_utf8_distance -I32 +IV Perl_utf8_distance(pTHXo_ U8 *a, U8 *b) { return ((CPerlObj*)pPerl)->Perl_utf8_distance(a, b); @@ -3378,18 +3413,18 @@ Perl_bytes_to_utf8(pTHXo_ U8 *s, STRLEN *len) return ((CPerlObj*)pPerl)->Perl_bytes_to_utf8(s, len); } -#undef Perl_utf8_to_uv +#undef Perl_utf8_to_uv_simple UV -Perl_utf8_to_uv(pTHXo_ U8 *s, I32* retlen) +Perl_utf8_to_uv_simple(pTHXo_ U8 *s, STRLEN* retlen) { - return ((CPerlObj*)pPerl)->Perl_utf8_to_uv(s, retlen); + return ((CPerlObj*)pPerl)->Perl_utf8_to_uv_simple(s, retlen); } -#undef Perl_utf8_to_uv_chk +#undef Perl_utf8_to_uv UV -Perl_utf8_to_uv_chk(pTHXo_ U8 *s, I32* retlen, bool checking) +Perl_utf8_to_uv(pTHXo_ U8 *s, STRLEN curlen, STRLEN* retlen, U32 flags) { - return ((CPerlObj*)pPerl)->Perl_utf8_to_uv_chk(s, retlen, checking); + return ((CPerlObj*)pPerl)->Perl_utf8_to_uv(s, curlen, retlen, flags); } #undef Perl_uv_to_utf8 @@ -3439,7 +3474,7 @@ Perl_whichsig(pTHXo_ char* sig) { return ((CPerlObj*)pPerl)->Perl_whichsig(sig); } -#if defined(USE_PURE_BISON) +#ifdef USE_PURE_BISON #else #endif #if defined(MYMALLOC) @@ -3854,6 +3889,13 @@ Perl_sv_force_normal(pTHXo_ SV *sv) ((CPerlObj*)pPerl)->Perl_sv_force_normal(sv); } +#undef Perl_sv_force_normal_flags +void +Perl_sv_force_normal_flags(pTHXo_ SV *sv, U32 flags) +{ + ((CPerlObj*)pPerl)->Perl_sv_force_normal_flags(sv, flags); +} + #undef Perl_tmps_grow void Perl_tmps_grow(pTHXo_ I32 n) @@ -4068,6 +4110,8 @@ Perl_sys_intern_init(pTHXo) #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) # if defined(DEBUGGING) # endif +# if !defined(NV_PRESERVES_UV) +# endif #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #if 0 diff --git a/perlapi.h b/perlapi.h index 2d210ee..a856dde 100755 --- a/perlapi.h +++ b/perlapi.h @@ -420,10 +420,8 @@ START_EXTERN_C #define PL_origenviron (*Perl_Iorigenviron_ptr(aTHXo)) #undef PL_origfilename #define PL_origfilename (*Perl_Iorigfilename_ptr(aTHXo)) -#undef PL_ors -#define PL_ors (*Perl_Iors_ptr(aTHXo)) -#undef PL_orslen -#define PL_orslen (*Perl_Iorslen_ptr(aTHXo)) +#undef PL_ors_sv +#define PL_ors_sv (*Perl_Iors_sv_ptr(aTHXo)) #undef PL_osname #define PL_osname (*Perl_Iosname_ptr(aTHXo)) #undef PL_pad_reset_pending @@ -712,10 +710,8 @@ START_EXTERN_C #define PL_na (*Perl_Tna_ptr(aTHXo)) #undef PL_nrs #define PL_nrs (*Perl_Tnrs_ptr(aTHXo)) -#undef PL_ofs -#define PL_ofs (*Perl_Tofs_ptr(aTHXo)) -#undef PL_ofslen -#define PL_ofslen (*Perl_Tofslen_ptr(aTHXo)) +#undef PL_ofs_sv +#define PL_ofs_sv (*Perl_Tofs_sv_ptr(aTHXo)) #undef PL_op #define PL_op (*Perl_Top_ptr(aTHXo)) #undef PL_opsave diff --git a/perlio.c b/perlio.c index a88daa5..72efa36 100644 --- a/perlio.c +++ b/perlio.c @@ -7,7 +7,6 @@ * */ - #define VOIDUSED 1 #ifdef PERL_MICRO # include "uconfig.h" @@ -15,31 +14,103 @@ # include "config.h" #endif -#define PERLIO_NOT_STDIO 0 +#define PERLIO_NOT_STDIO 0 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO) -#define PerlIO FILE +/* #define PerlIO FILE */ #endif /* - * This file provides those parts of PerlIO abstraction - * which are not #defined in iperlsys.h. - * Which these are depends on various Configure #ifdef's + * This file provides those parts of PerlIO abstraction + * which are not #defined in perlio.h. + * Which these are depends on various Configure #ifdef's */ #include "EXTERN.h" #define PERL_IN_PERLIO_C #include "perl.h" -#if !defined(PERL_IMPLICIT_SYS) +#undef PerlMemShared_calloc +#define PerlMemShared_calloc(x,y) calloc(x,y) +#undef PerlMemShared_free +#define PerlMemShared_free(x) free(x) + +int +perlsio_binmode(FILE *fp, int iotype, int mode) +{ +/* This used to be contents of do_binmode in doio.c */ +#ifdef DOSISH +# if defined(atarist) || defined(__MINT__) + if (!fflush(fp)) { + if (mode & O_BINARY) + ((FILE*)fp)->_flag |= _IOBIN; + else + ((FILE*)fp)->_flag &= ~ _IOBIN; + return 1; + } + return 0; +# else + dTHX; + if (PerlLIO_setmode(fileno(fp), mode) != -1) { +# if defined(WIN32) && defined(__BORLANDC__) + /* The translation mode of the stream is maintained independent + * of the translation mode of the fd in the Borland RTL (heavy + * digging through their runtime sources reveal). User has to + * set the mode explicitly for the stream (though they don't + * document this anywhere). GSAR 97-5-24 + */ + fseek(fp,0L,0); + if (mode & O_BINARY) + fp->flags |= _F_BIN; + else + fp->flags &= ~ _F_BIN; +# endif + return 1; + } + else + return 0; +# endif +#else +# if defined(USEMYBINMODE) + if (my_binmode(fp, iotype, mode) != FALSE) + return 1; + else + return 0; +# else + return 1; +# endif +#endif +} + +#ifndef PERLIO_LAYERS +int +PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) +{ + if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw")) + { + return 0; + } + Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names); + /* NOTREACHED */ + return -1; +} + +int +PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names) +{ + return perlsio_binmode(fp,iotype,mode); +} + +#endif + -#ifdef PERLIO_IS_STDIO +#ifdef PERLIO_IS_STDIO void PerlIO_init(void) { - /* Does nothing (yet) except force this file to be included + /* Does nothing (yet) except force this file to be included in perl binary. That allows this file to force inclusion - of other functions that may be required by loadable - extensions e.g. for FileHandle::tmpfile + of other functions that may be required by loadable + extensions e.g. for FileHandle::tmpfile */ } @@ -57,7 +128,7 @@ PerlIO_tmpfile(void) #undef HAS_FSETPOS #undef HAS_FGETPOS -/* This section is just to make sure these functions +/* This section is just to make sure these functions get pulled in from libsfio.a */ @@ -71,364 +142,2992 @@ PerlIO_tmpfile(void) void PerlIO_init(void) { - /* Force this file to be included in perl binary. Which allows - * this file to force inclusion of other functions that may be - * required by loadable extensions e.g. for FileHandle::tmpfile + /* Force this file to be included in perl binary. Which allows + * this file to force inclusion of other functions that may be + * required by loadable extensions e.g. for FileHandle::tmpfile */ /* Hack * sfio does its own 'autoflush' on stdout in common cases. - * Flush results in a lot of lseek()s to regular files and + * Flush results in a lot of lseek()s to regular files and * lot of small writes to pipes. */ sfset(sfstdout,SF_SHARE,0); } #else /* USE_SFIO */ +/*======================================================================================*/ +/* Implement all the PerlIO interface ourselves. + */ -/* Implement all the PerlIO interface using stdio. - - this should be only file to include -*/ +#include "perliol.h" -#undef PerlIO_stderr -PerlIO * -PerlIO_stderr(void) +/* We _MUST_ have if we are using lseek() and may have large files */ +#ifdef I_UNISTD +#include +#endif +#ifdef HAS_MMAP +#include +#endif + +#include "XSUB.h" + +void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2))); + +void +PerlIO_debug(const char *fmt,...) { - return (PerlIO *) stderr; + dTHX; + static int dbg = 0; + va_list ap; + va_start(ap,fmt); + if (!dbg) + { + char *s = PerlEnv_getenv("PERLIO_DEBUG"); + if (s && *s) + dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666); + else + dbg = -1; + } + if (dbg > 0) + { + dTHX; + SV *sv = newSVpvn("",0); + char *s; + STRLEN len; + s = CopFILE(PL_curcop); + if (!s) + s = "(none)"; + Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop)); + Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap); + + s = SvPV(sv,len); + PerlLIO_write(dbg,s,len); + SvREFCNT_dec(sv); + } + va_end(ap); } -#undef PerlIO_stdin +/*--------------------------------------------------------------------------------------*/ + +/* Inner level routines */ + +/* Table of pointers to the PerlIO structs (malloc'ed) */ +PerlIO *_perlio = NULL; +#define PERLIO_TABLE_SIZE 64 + PerlIO * -PerlIO_stdin(void) +PerlIO_allocate(pTHX) { - return (PerlIO *) stdin; + /* Find a free slot in the table, allocating new table as necessary */ + PerlIO **last; + PerlIO *f; + last = &_perlio; + while ((f = *last)) + { + int i; + last = (PerlIO **)(f); + for (i=1; i < PERLIO_TABLE_SIZE; i++) + { + if (!*++f) + { + return f; + } + } + } + f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO)); + if (!f) + { + return NULL; + } + *last = f; + return f+1; } -#undef PerlIO_stdout -PerlIO * -PerlIO_stdout(void) +void +PerlIO_cleantable(pTHX_ PerlIO **tablep) +{ + PerlIO *table = *tablep; + if (table) + { + int i; + PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0])); + for (i=PERLIO_TABLE_SIZE-1; i > 0; i--) + { + PerlIO *f = table+i; + if (*f) + { + PerlIO_close(f); + } + } + PerlMemShared_free(table); + *tablep = NULL; + } +} + +HV *PerlIO_layer_hv; +AV *PerlIO_layer_av; + +void +PerlIO_cleanup() { - return (PerlIO *) stdout; + dTHX; + PerlIO_cleantable(aTHX_ &_perlio); } -#undef PerlIO_fast_gets -int -PerlIO_fast_gets(PerlIO *f) +void +PerlIO_pop(PerlIO *f) { -#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) - return 1; -#else + dTHX; + PerlIOl *l = *f; + if (l) + { + PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name); + (*l->tab->Popped)(f); + *f = l->next; + PerlMemShared_free(l); + } +} + +/*--------------------------------------------------------------------------------------*/ +/* XS Interface for perl code */ + +XS(XS_perlio_import) +{ + dXSARGS; + GV *gv = CvGV(cv); + char *s = GvNAME(gv); + STRLEN l = GvNAMELEN(gv); + PerlIO_debug("%.*s\n",(int) l,s); + XSRETURN_EMPTY; +} + +XS(XS_perlio_unimport) +{ + dXSARGS; + GV *gv = CvGV(cv); + char *s = GvNAME(gv); + STRLEN l = GvNAMELEN(gv); + PerlIO_debug("%.*s\n",(int) l,s); + XSRETURN_EMPTY; +} + +SV * +PerlIO_find_layer(const char *name, STRLEN len) +{ + dTHX; + SV **svp; + SV *sv; + if ((SSize_t) len <= 0) + len = strlen(name); + svp = hv_fetch(PerlIO_layer_hv,name,len,0); + if (svp && (sv = *svp) && SvROK(sv)) + return *svp; + return NULL; +} + + +static int +perlio_mg_set(pTHX_ SV *sv, MAGIC *mg) +{ + if (SvROK(sv)) + { + IO *io = GvIOn((GV *)SvRV(sv)); + PerlIO *ifp = IoIFP(io); + PerlIO *ofp = IoOFP(io); + AV *av = (AV *) mg->mg_obj; + Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp); + } return 0; -#endif } -#undef PerlIO_has_cntptr -int -PerlIO_has_cntptr(PerlIO *f) +static int +perlio_mg_get(pTHX_ SV *sv, MAGIC *mg) { -#if defined(USE_STDIO_PTR) - return 1; -#else + if (SvROK(sv)) + { + IO *io = GvIOn((GV *)SvRV(sv)); + PerlIO *ifp = IoIFP(io); + PerlIO *ofp = IoOFP(io); + AV *av = (AV *) mg->mg_obj; + Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp); + } return 0; -#endif } -#undef PerlIO_canset_cnt -int -PerlIO_canset_cnt(PerlIO *f) +static int +perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg) { -#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) - return 1; -#else + Perl_warn(aTHX_ "clear %"SVf,sv); return 0; -#endif } -#undef PerlIO_set_cnt +static int +perlio_mg_free(pTHX_ SV *sv, MAGIC *mg) +{ + Perl_warn(aTHX_ "free %"SVf,sv); + return 0; +} + +MGVTBL perlio_vtab = { + perlio_mg_get, + perlio_mg_set, + NULL, /* len */ + NULL, + perlio_mg_free +}; + +XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) +{ + dXSARGS; + SV *sv = SvRV(ST(1)); + AV *av = newAV(); + MAGIC *mg; + int count = 0; + int i; + sv_magic(sv, (SV *)av, '~', NULL, 0); + SvRMAGICAL_off(sv); + mg = mg_find(sv,'~'); + mg->mg_virtual = &perlio_vtab; + mg_magical(sv); + Perl_warn(aTHX_ "attrib %"SVf,sv); + for (i=2; i < items; i++) + { + STRLEN len; + const char *name = SvPV(ST(i),len); + SV *layer = PerlIO_find_layer(name,len); + if (layer) + { + av_push(av,SvREFCNT_inc(layer)); + } + else + { + ST(count) = ST(i); + count++; + } + } + SvREFCNT_dec(av); + XSRETURN(count); +} + void -PerlIO_set_cnt(PerlIO *f, int cnt) +PerlIO_define_layer(PerlIO_funcs *tab) { dTHX; - if (cnt < -1 && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d\n",cnt); -#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) - FILE_cnt(f) = cnt; -#else - Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system"); + HV *stash = gv_stashpv("perlio::Layer", TRUE); + SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash); + hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0); +} + +PerlIO_funcs * +PerlIO_default_layer(I32 n) +{ + dTHX; + SV **svp; + SV *layer; + PerlIO_funcs *tab = &PerlIO_stdio; + int len; + if (!PerlIO_layer_hv) + { + const char *s = PerlEnv_getenv("PERLIO"); + newXS("perlio::import",XS_perlio_import,__FILE__); + newXS("perlio::unimport",XS_perlio_unimport,__FILE__); +#if 0 + newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__); +#endif + PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI); + PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI); + PerlIO_define_layer(&PerlIO_unix); + PerlIO_define_layer(&PerlIO_perlio); + PerlIO_define_layer(&PerlIO_stdio); + PerlIO_define_layer(&PerlIO_crlf); +#ifdef HAS_MMAP + PerlIO_define_layer(&PerlIO_mmap); #endif + av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0))); + if (s) + { + while (*s) + { + while (*s && isSPACE((unsigned char)*s)) + s++; + if (*s) + { + const char *e = s; + SV *layer; + while (*e && !isSPACE((unsigned char)*e)) + e++; + if (*s == ':') + s++; + layer = PerlIO_find_layer(s,e-s); + if (layer) + { + PerlIO_debug("Pushing %.*s\n",(e-s),s); + av_push(PerlIO_layer_av,SvREFCNT_inc(layer)); + } + else + Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s); + s = e; + } + } + } + } + len = av_len(PerlIO_layer_av); + if (len < 1) + { + if (O_BINARY != O_TEXT) + { + av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_crlf.name,0))); + } + else + { + if (PerlIO_stdio.Set_ptrcnt) + { + av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0))); + } + else + { + av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0))); + } + } + len = av_len(PerlIO_layer_av); + } + if (n < 0) + n += len+1; + svp = av_fetch(PerlIO_layer_av,n,0); + if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer)))) + { + tab = INT2PTR(PerlIO_funcs *, SvIV(layer)); + } + /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */ + return tab; +} + +#define PerlIO_default_top() PerlIO_default_layer(-1) +#define PerlIO_default_btm() PerlIO_default_layer(0) + +void +PerlIO_stdstreams() +{ + if (!_perlio) + { + dTHX; + PerlIO_allocate(aTHX); + PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT); + PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT); + PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT); + } +} + +PerlIO * +PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len) +{ + dTHX; + PerlIOl *l = NULL; + l = PerlMemShared_calloc(tab->size,sizeof(char)); + if (l) + { + Zero(l,tab->size,char); + l->next = *f; + l->tab = tab; + *f = l; + PerlIO_debug("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)"); + if ((*l->tab->Pushed)(f,mode,arg,len) != 0) + { + PerlIO_pop(f); + return NULL; + } + } + return f; +} + +int +PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) +{ + if (names) + { + const char *s = names; + while (*s) + { + while (isSPACE(*s)) + s++; + if (*s == ':') + s++; + if (*s) + { + const char *e = s; + const char *as = Nullch; + const char *ae = Nullch; + int count = 0; + while (*e && *e != ':' && !isSPACE(*e)) + { + if (*e == '(') + { + if (!as) + as = e; + count++; + } + else if (*e == ')') + { + if (as && --count == 0) + ae = e; + } + e++; + } + if (e > s) + { + if ((e - s) == 3 && strncmp(s,"raw",3) == 0) + { + /* Pop back to bottom layer */ + if (PerlIONext(f)) + { + PerlIO_flush(f); + while (PerlIONext(f)) + { + PerlIO_pop(f); + } + } + } + else if ((e - s) == 4 && strncmp(s,"utf8",4) == 0) + { + PerlIOBase(f)->flags |= PERLIO_F_UTF8; + } + else if ((e - s) == 5 && strncmp(s,"bytes",5) == 0) + { + PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; + } + else + { + STRLEN len = ((as) ? as : e)-s; + SV *layer = PerlIO_find_layer(s,len); + if (layer) + { + PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer))); + if (tab) + { + len = (as) ? (ae-(as++)-1) : 0; + if (!PerlIO_push(f,tab,mode,as,len)) + return -1; + } + } + else + Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)len,s); + } + } + s = e; + } + } + } + return 0; +} + + + +/*--------------------------------------------------------------------------------------*/ +/* Given the abstraction above the public API functions */ + +int +PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) +{ + PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", + f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)"); + if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY))) + { + PerlIO *top = f; + PerlIOl *l; + while (l = *top) + { + if (PerlIOBase(top)->tab == &PerlIO_crlf) + { + PerlIO_flush(top); + PerlIOBase(top)->flags &= ~PERLIO_F_CRLF; + break; + } + top = PerlIONext(top); + } + } + return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE; +} + +#undef PerlIO__close +int +PerlIO__close(PerlIO *f) +{ + return (*PerlIOBase(f)->tab->Close)(f); +} + +#undef PerlIO_fdupopen +PerlIO * +PerlIO_fdupopen(pTHX_ PerlIO *f) +{ + char buf[8]; + int fd = PerlLIO_dup(PerlIO_fileno(f)); + PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf)); + if (new) + { + Off_t posn = PerlIO_tell(f); + PerlIO_seek(new,posn,SEEK_SET); + } + return new; +} + +#undef PerlIO_close +int +PerlIO_close(PerlIO *f) +{ + int code = (*PerlIOBase(f)->tab->Close)(f); + while (*f) + { + PerlIO_pop(f); + } + return code; +} + +#undef PerlIO_fileno +int +PerlIO_fileno(PerlIO *f) +{ + return (*PerlIOBase(f)->tab->Fileno)(f); +} + + + +#undef PerlIO_fdopen +PerlIO * +PerlIO_fdopen(int fd, const char *mode) +{ + PerlIO_funcs *tab = PerlIO_default_top(); + if (!_perlio) + PerlIO_stdstreams(); + return (*tab->Fdopen)(tab,fd,mode); +} + +#undef PerlIO_open +PerlIO * +PerlIO_open(const char *path, const char *mode) +{ + PerlIO_funcs *tab = PerlIO_default_top(); + if (!_perlio) + PerlIO_stdstreams(); + return (*tab->Open)(tab,path,mode); +} + +#undef PerlIO_reopen +PerlIO * +PerlIO_reopen(const char *path, const char *mode, PerlIO *f) +{ + if (f) + { + PerlIO_flush(f); + if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0) + { + if ((*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0) == 0) + return f; + } + return NULL; + } + else + return PerlIO_open(path,mode); +} + +#undef PerlIO_read +SSize_t +PerlIO_read(PerlIO *f, void *vbuf, Size_t count) +{ + return (*PerlIOBase(f)->tab->Read)(f,vbuf,count); +} + +#undef PerlIO_unread +SSize_t +PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count) +{ + return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count); +} + +#undef PerlIO_write +SSize_t +PerlIO_write(PerlIO *f, const void *vbuf, Size_t count) +{ + return (*PerlIOBase(f)->tab->Write)(f,vbuf,count); } -#undef PerlIO_set_ptrcnt -void -PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt) +#undef PerlIO_seek +int +PerlIO_seek(PerlIO *f, Off_t offset, int whence) +{ + return (*PerlIOBase(f)->tab->Seek)(f,offset,whence); +} + +#undef PerlIO_tell +Off_t +PerlIO_tell(PerlIO *f) +{ + return (*PerlIOBase(f)->tab->Tell)(f); +} + +#undef PerlIO_flush +int +PerlIO_flush(PerlIO *f) +{ + if (f) + { + return (*PerlIOBase(f)->tab->Flush)(f); + } + else + { + PerlIO **table = &_perlio; + int code = 0; + while ((f = *table)) + { + int i; + table = (PerlIO **)(f++); + for (i=1; i < PERLIO_TABLE_SIZE; i++) + { + if (*f && PerlIO_flush(f) != 0) + code = -1; + f++; + } + } + return code; + } +} + +#undef PerlIO_fill +int +PerlIO_fill(PerlIO *f) +{ + return (*PerlIOBase(f)->tab->Fill)(f); +} + +#undef PerlIO_isutf8 +int +PerlIO_isutf8(PerlIO *f) +{ + return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0; +} + +#undef PerlIO_eof +int +PerlIO_eof(PerlIO *f) +{ + return (*PerlIOBase(f)->tab->Eof)(f); +} + +#undef PerlIO_error +int +PerlIO_error(PerlIO *f) +{ + return (*PerlIOBase(f)->tab->Error)(f); +} + +#undef PerlIO_clearerr +void +PerlIO_clearerr(PerlIO *f) +{ + if (f && *f) + (*PerlIOBase(f)->tab->Clearerr)(f); +} + +#undef PerlIO_setlinebuf +void +PerlIO_setlinebuf(PerlIO *f) +{ + (*PerlIOBase(f)->tab->Setlinebuf)(f); +} + +#undef PerlIO_has_base +int +PerlIO_has_base(PerlIO *f) +{ + if (f && *f) + { + return (PerlIOBase(f)->tab->Get_base != NULL); + } + return 0; +} + +#undef PerlIO_fast_gets +int +PerlIO_fast_gets(PerlIO *f) +{ + if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) + { + PerlIO_funcs *tab = PerlIOBase(f)->tab; + return (tab->Set_ptrcnt != NULL); + } + return 0; +} + +#undef PerlIO_has_cntptr +int +PerlIO_has_cntptr(PerlIO *f) +{ + if (f && *f) + { + PerlIO_funcs *tab = PerlIOBase(f)->tab; + return (tab->Get_ptr != NULL && tab->Get_cnt != NULL); + } + return 0; +} + +#undef PerlIO_canset_cnt +int +PerlIO_canset_cnt(PerlIO *f) +{ + if (f && *f) + { + PerlIOl *l = PerlIOBase(f); + return (l->tab->Set_ptrcnt != NULL); + } + return 0; +} + +#undef PerlIO_get_base +STDCHAR * +PerlIO_get_base(PerlIO *f) +{ + return (*PerlIOBase(f)->tab->Get_base)(f); +} + +#undef PerlIO_get_bufsiz +int +PerlIO_get_bufsiz(PerlIO *f) +{ + return (*PerlIOBase(f)->tab->Get_bufsiz)(f); +} + +#undef PerlIO_get_ptr +STDCHAR * +PerlIO_get_ptr(PerlIO *f) +{ + PerlIO_funcs *tab = PerlIOBase(f)->tab; + if (tab->Get_ptr == NULL) + return NULL; + return (*tab->Get_ptr)(f); +} + +#undef PerlIO_get_cnt +int +PerlIO_get_cnt(PerlIO *f) +{ + PerlIO_funcs *tab = PerlIOBase(f)->tab; + if (tab->Get_cnt == NULL) + return 0; + return (*tab->Get_cnt)(f); +} + +#undef PerlIO_set_cnt +void +PerlIO_set_cnt(PerlIO *f,int cnt) +{ + (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt); +} + +#undef PerlIO_set_ptrcnt +void +PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt) +{ + PerlIO_funcs *tab = PerlIOBase(f)->tab; + if (tab->Set_ptrcnt == NULL) + { + dTHX; + Perl_croak(aTHX_ "PerlIO buffer snooping abuse"); + } + (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt); +} + +/*--------------------------------------------------------------------------------------*/ +/* "Methods" of the "base class" */ + +IV +PerlIOBase_fileno(PerlIO *f) +{ + return PerlIO_fileno(PerlIONext(f)); +} + +char * +PerlIO_modestr(PerlIO *f,char *buf) +{ + char *s = buf; + IV flags = PerlIOBase(f)->flags; + if (flags & PERLIO_F_APPEND) + { + *s++ = 'a'; + if (flags & PERLIO_F_CANREAD) + { + *s++ = '+'; + } + } + else if (flags & PERLIO_F_CANREAD) + { + *s++ = 'r'; + if (flags & PERLIO_F_CANWRITE) + *s++ = '+'; + } + else if (flags & PERLIO_F_CANWRITE) + { + *s++ = 'w'; + if (flags & PERLIO_F_CANREAD) + { + *s++ = '+'; + } + } +#if O_TEXT != O_BINARY + if (!(flags & PERLIO_F_CRLF)) + *s++ = 'b'; +#endif + *s = '\0'; + return buf; +} + +IV +PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +{ + PerlIOl *l = PerlIOBase(f); + const char *omode = mode; + char temp[8]; + PerlIO_funcs *tab = PerlIOBase(f)->tab; + l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE| + PERLIO_F_TRUNCATE|PERLIO_F_APPEND); + if (tab->Set_ptrcnt != NULL) + l->flags |= PERLIO_F_FASTGETS; + if (mode) + { + switch (*mode++) + { + case 'r': + l->flags |= PERLIO_F_CANREAD; + break; + case 'a': + l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE; + break; + case 'w': + l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE; + break; + default: + errno = EINVAL; + return -1; + } + while (*mode) + { + switch (*mode++) + { + case '+': + l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE; + break; + case 'b': + l->flags &= ~PERLIO_F_CRLF; + break; + case 't': + l->flags |= PERLIO_F_CRLF; + break; + default: + errno = EINVAL; + return -1; + } + } + } + else + { + if (l->next) + { + l->flags |= l->next->flags & + (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND); + } + } +#if 0 + PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n", + f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)", + l->flags,PerlIO_modestr(f,temp)); +#endif + return 0; +} + +IV +PerlIOBase_popped(PerlIO *f) +{ + return 0; +} + +SSize_t +PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count) +{ + Off_t old = PerlIO_tell(f); + SSize_t done; + PerlIO_push(f,&PerlIO_pending,"r",Nullch,0); + done = PerlIOBuf_unread(f,vbuf,count); + PerlIOSelf(f,PerlIOBuf)->posn = old - done; + return done; +} + +IV +PerlIOBase_noop_ok(PerlIO *f) +{ + return 0; +} + +IV +PerlIOBase_noop_fail(PerlIO *f) +{ + return -1; +} + +IV +PerlIOBase_close(PerlIO *f) +{ + IV code = 0; + PerlIO *n = PerlIONext(f); + if (PerlIO_flush(f) != 0) + code = -1; + if (n && (*PerlIOBase(n)->tab->Close)(n) != 0) + code = -1; + PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN); + return code; +} + +IV +PerlIOBase_eof(PerlIO *f) +{ + if (f && *f) + { + return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0; + } + return 1; +} + +IV +PerlIOBase_error(PerlIO *f) +{ + if (f && *f) + { + return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0; + } + return 1; +} + +void +PerlIOBase_clearerr(PerlIO *f) +{ + if (f && *f) + { + PerlIO *n = PerlIONext(f); + PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF); + if (n) + PerlIO_clearerr(n); + } +} + +void +PerlIOBase_setlinebuf(PerlIO *f) +{ + +} + +/*--------------------------------------------------------------------------------------*/ +/* Bottom-most level for UNIX-like case */ + +typedef struct +{ + struct _PerlIO base; /* The generic part */ + int fd; /* UNIX like file descriptor */ + int oflags; /* open/fcntl flags */ +} PerlIOUnix; + +int +PerlIOUnix_oflags(const char *mode) +{ + int oflags = -1; + switch(*mode) + { + case 'r': + oflags = O_RDONLY; + if (*++mode == '+') + { + oflags = O_RDWR; + mode++; + } + break; + + case 'w': + oflags = O_CREAT|O_TRUNC; + if (*++mode == '+') + { + oflags |= O_RDWR; + mode++; + } + else + oflags |= O_WRONLY; + break; + + case 'a': + oflags = O_CREAT|O_APPEND; + if (*++mode == '+') + { + oflags |= O_RDWR; + mode++; + } + else + oflags |= O_WRONLY; + break; + } + if (*mode == 'b') + { + oflags |= O_BINARY; + oflags &= ~O_TEXT; + mode++; + } + else if (*mode == 't') + { + oflags |= O_TEXT; + oflags &= ~O_BINARY; + mode++; + } + /* Always open in binary mode */ + oflags |= O_BINARY; + if (*mode || oflags == -1) + { + errno = EINVAL; + oflags = -1; + } + return oflags; +} + +IV +PerlIOUnix_fileno(PerlIO *f) +{ + return PerlIOSelf(f,PerlIOUnix)->fd; +} + +PerlIO * +PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode) +{ + dTHX; + PerlIO *f = NULL; + if (*mode == 'I') + mode++; + if (fd >= 0) + { + int oflags = PerlIOUnix_oflags(mode); + if (oflags != -1) + { + PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix); + s->fd = fd; + s->oflags = oflags; + PerlIOBase(f)->flags |= PERLIO_F_OPEN; + } + } + return f; +} + +PerlIO * +PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode) +{ + dTHX; + PerlIO *f = NULL; + int oflags = PerlIOUnix_oflags(mode); + if (oflags != -1) + { + int fd = PerlLIO_open3(path,oflags,0666); + if (fd >= 0) + { + PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix); + s->fd = fd; + s->oflags = oflags; + PerlIOBase(f)->flags |= PERLIO_F_OPEN; + } + } + return f; +} + +int +PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f) +{ + PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix); + int oflags = PerlIOUnix_oflags(mode); + if (PerlIOBase(f)->flags & PERLIO_F_OPEN) + (*PerlIOBase(f)->tab->Close)(f); + if (oflags != -1) + { + dTHX; + int fd = PerlLIO_open3(path,oflags,0666); + if (fd >= 0) + { + s->fd = fd; + s->oflags = oflags; + PerlIOBase(f)->flags |= PERLIO_F_OPEN; + return 0; + } + } + return -1; +} + +SSize_t +PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count) +{ + dTHX; + int fd = PerlIOSelf(f,PerlIOUnix)->fd; + if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) + return 0; + while (1) + { + SSize_t len = PerlLIO_read(fd,vbuf,count); + if (len >= 0 || errno != EINTR) + { + if (len < 0) + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + else if (len == 0 && count != 0) + PerlIOBase(f)->flags |= PERLIO_F_EOF; + return len; + } + } +} + +SSize_t +PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count) +{ + dTHX; + int fd = PerlIOSelf(f,PerlIOUnix)->fd; + while (1) + { + SSize_t len = PerlLIO_write(fd,vbuf,count); + if (len >= 0 || errno != EINTR) + { + if (len < 0) + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + return len; + } + } +} + +IV +PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence) +{ + dTHX; + Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence); + PerlIOBase(f)->flags &= ~PERLIO_F_EOF; + return (new == (Off_t) -1) ? -1 : 0; +} + +Off_t +PerlIOUnix_tell(PerlIO *f) +{ + dTHX; + Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR); + return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR); +} + +IV +PerlIOUnix_close(PerlIO *f) +{ + dTHX; + int fd = PerlIOSelf(f,PerlIOUnix)->fd; + int code = 0; + while (PerlLIO_close(fd) != 0) + { + if (errno != EINTR) + { + code = -1; + break; + } + } + if (code == 0) + { + PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; + } + return code; +} + +PerlIO_funcs PerlIO_unix = { + "unix", + sizeof(PerlIOUnix), + PERLIO_K_RAW, + PerlIOUnix_fileno, + PerlIOUnix_fdopen, + PerlIOUnix_open, + PerlIOUnix_reopen, + PerlIOBase_pushed, + PerlIOBase_noop_ok, + PerlIOUnix_read, + PerlIOBase_unread, + PerlIOUnix_write, + PerlIOUnix_seek, + PerlIOUnix_tell, + PerlIOUnix_close, + PerlIOBase_noop_ok, /* flush */ + PerlIOBase_noop_fail, /* fill */ + PerlIOBase_eof, + PerlIOBase_error, + PerlIOBase_clearerr, + PerlIOBase_setlinebuf, + NULL, /* get_base */ + NULL, /* get_bufsiz */ + NULL, /* get_ptr */ + NULL, /* get_cnt */ + NULL, /* set_ptrcnt */ +}; + +/*--------------------------------------------------------------------------------------*/ +/* stdio as a layer */ + +typedef struct +{ + struct _PerlIO base; + FILE * stdio; /* The stream */ +} PerlIOStdio; + +IV +PerlIOStdio_fileno(PerlIO *f) +{ + dTHX; + return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio); +} + +char * +PerlIOStdio_mode(const char *mode,char *tmode) +{ + char *ret = tmode; + while (*mode) + { + *tmode++ = *mode++; + } + if (O_BINARY != O_TEXT) + { + *tmode++ = 'b'; + } + *tmode = '\0'; + return ret; +} + +PerlIO * +PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode) +{ + dTHX; + PerlIO *f = NULL; + int init = 0; + char tmode[8]; + if (*mode == 'I') + { + init = 1; + mode++; + } + if (fd >= 0) + { + FILE *stdio = NULL; + if (init) + { + switch(fd) + { + case 0: + stdio = PerlSIO_stdin; + break; + case 1: + stdio = PerlSIO_stdout; + break; + case 2: + stdio = PerlSIO_stderr; + break; + } + } + else + { + stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode)); + } + if (stdio) + { + PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio); + s->stdio = stdio; + } + } + return f; +} + +#undef PerlIO_importFILE +PerlIO * +PerlIO_importFILE(FILE *stdio, int fl) +{ + dTHX; + PerlIO *f = NULL; + if (stdio) + { + PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio); + s->stdio = stdio; + } + return f; +} + +PerlIO * +PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode) +{ + dTHX; + PerlIO *f = NULL; + FILE *stdio = PerlSIO_fopen(path,mode); + if (stdio) + { + char tmode[8]; + PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self, + (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0), + PerlIOStdio); + s->stdio = stdio; + } + return f; +} + +int +PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f) +{ + dTHX; + PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio); + char tmode[8]; + FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio); + if (!s->stdio) + return -1; + s->stdio = stdio; + return 0; +} + +SSize_t +PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count) +{ + dTHX; + FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio; + SSize_t got = 0; + if (count == 1) + { + STDCHAR *buf = (STDCHAR *) vbuf; + /* Perl is expecting PerlIO_getc() to fill the buffer + * Linux's stdio does not do that for fread() + */ + int ch = PerlSIO_fgetc(s); + if (ch != EOF) + { + *buf = ch; + got = 1; + } + } + else + got = PerlSIO_fread(vbuf,1,count,s); + return got; +} + +SSize_t +PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count) +{ + dTHX; + FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio; + STDCHAR *buf = ((STDCHAR *)vbuf)+count-1; + SSize_t unread = 0; + while (count > 0) + { + int ch = *buf-- & 0xff; + if (PerlSIO_ungetc(ch,s) != ch) + break; + unread++; + count--; + } + return unread; +} + +SSize_t +PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count) +{ + dTHX; + return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio); +} + +IV +PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence) +{ + dTHX; + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + return PerlSIO_fseek(stdio,offset,whence); +} + +Off_t +PerlIOStdio_tell(PerlIO *f) +{ + dTHX; + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + return PerlSIO_ftell(stdio); +} + +IV +PerlIOStdio_close(PerlIO *f) +{ + dTHX; +#ifdef HAS_SOCKET + int optval, optlen = sizeof(int); +#endif + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + return( +#ifdef HAS_SOCKET + (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ? + PerlSIO_fclose(stdio) : + close(PerlIO_fileno(f)) +#else + PerlSIO_fclose(stdio) +#endif + ); + +} + +IV +PerlIOStdio_flush(PerlIO *f) +{ + dTHX; + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) + { + return PerlSIO_fflush(stdio); + } + else + { +#if 0 + /* FIXME: This discards ungetc() and pre-read stuff which is + not right if this is just a "sync" from a layer above + Suspect right design is to do _this_ but not have layer above + flush this layer read-to-read + */ + /* Not writeable - sync by attempting a seek */ + int err = errno; + if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0) + errno = err; +#endif + } + return 0; +} + +IV +PerlIOStdio_fill(PerlIO *f) +{ + dTHX; + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + int c; + /* fflush()ing read-only streams can cause trouble on some stdio-s */ + if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) + { + if (PerlSIO_fflush(stdio) != 0) + return EOF; + } + c = PerlSIO_fgetc(stdio); + if (c == EOF || PerlSIO_ungetc(c,stdio) != c) + return EOF; + return 0; +} + +IV +PerlIOStdio_eof(PerlIO *f) +{ + dTHX; + return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio); +} + +IV +PerlIOStdio_error(PerlIO *f) +{ + dTHX; + return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio); +} + +void +PerlIOStdio_clearerr(PerlIO *f) +{ + dTHX; + PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio); +} + +void +PerlIOStdio_setlinebuf(PerlIO *f) +{ + dTHX; +#ifdef HAS_SETLINEBUF + PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio); +#else + PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0); +#endif +} + +#ifdef FILE_base +STDCHAR * +PerlIOStdio_get_base(PerlIO *f) +{ + dTHX; + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + return PerlSIO_get_base(stdio); +} + +Size_t +PerlIOStdio_get_bufsiz(PerlIO *f) +{ + dTHX; + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + return PerlSIO_get_bufsiz(stdio); +} +#endif + +#ifdef USE_STDIO_PTR +STDCHAR * +PerlIOStdio_get_ptr(PerlIO *f) +{ + dTHX; + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + return PerlSIO_get_ptr(stdio); +} + +SSize_t +PerlIOStdio_get_cnt(PerlIO *f) +{ + dTHX; + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + return PerlSIO_get_cnt(stdio); +} + +void +PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt) +{ + dTHX; + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + if (ptr != NULL) + { +#ifdef STDIO_PTR_LVALUE + PerlSIO_set_ptr(stdio,ptr); +#ifdef STDIO_PTR_LVAL_SETS_CNT + if (PerlSIO_get_cnt(stdio) != (cnt)) + { + dTHX; + assert(PerlSIO_get_cnt(stdio) == (cnt)); + } +#endif +#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT)) + /* Setting ptr _does_ change cnt - we are done */ + return; +#endif +#else /* STDIO_PTR_LVALUE */ + PerlProc_abort(); +#endif /* STDIO_PTR_LVALUE */ + } +/* Now (or only) set cnt */ +#ifdef STDIO_CNT_LVALUE + PerlSIO_set_cnt(stdio,cnt); +#else /* STDIO_CNT_LVALUE */ +#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT)) + PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt)); +#else /* STDIO_PTR_LVAL_SETS_CNT */ + PerlProc_abort(); +#endif /* STDIO_PTR_LVAL_SETS_CNT */ +#endif /* STDIO_CNT_LVALUE */ +} + +#endif + +PerlIO_funcs PerlIO_stdio = { + "stdio", + sizeof(PerlIOStdio), + PERLIO_K_BUFFERED, + PerlIOStdio_fileno, + PerlIOStdio_fdopen, + PerlIOStdio_open, + PerlIOStdio_reopen, + PerlIOBase_pushed, + PerlIOBase_noop_ok, + PerlIOStdio_read, + PerlIOStdio_unread, + PerlIOStdio_write, + PerlIOStdio_seek, + PerlIOStdio_tell, + PerlIOStdio_close, + PerlIOStdio_flush, + PerlIOStdio_fill, + PerlIOStdio_eof, + PerlIOStdio_error, + PerlIOStdio_clearerr, + PerlIOStdio_setlinebuf, +#ifdef FILE_base + PerlIOStdio_get_base, + PerlIOStdio_get_bufsiz, +#else + NULL, + NULL, +#endif +#ifdef USE_STDIO_PTR + PerlIOStdio_get_ptr, + PerlIOStdio_get_cnt, +#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT))) + PerlIOStdio_set_ptrcnt +#else /* STDIO_PTR_LVALUE */ + NULL +#endif /* STDIO_PTR_LVALUE */ +#else /* USE_STDIO_PTR */ + NULL, + NULL, + NULL +#endif /* USE_STDIO_PTR */ +}; + +#undef PerlIO_exportFILE +FILE * +PerlIO_exportFILE(PerlIO *f, int fl) +{ + FILE *stdio; + PerlIO_flush(f); + stdio = fdopen(PerlIO_fileno(f),"r+"); + if (stdio) + { + PerlIOStdio *s = PerlIOSelf(PerlIO_push(f,&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio); + s->stdio = stdio; + } + return stdio; +} + +#undef PerlIO_findFILE +FILE * +PerlIO_findFILE(PerlIO *f) +{ + PerlIOl *l = *f; + while (l) + { + if (l->tab == &PerlIO_stdio) + { + PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio); + return s->stdio; + } + l = *PerlIONext(&l); + } + return PerlIO_exportFILE(f,0); +} + +#undef PerlIO_releaseFILE +void +PerlIO_releaseFILE(PerlIO *p, FILE *f) +{ +} + +/*--------------------------------------------------------------------------------------*/ +/* perlio buffer layer */ + +IV +PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + b->posn = PerlIO_tell(PerlIONext(f)); + return PerlIOBase_pushed(f,mode,arg,len); +} + +PerlIO * +PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode) +{ + dTHX; + PerlIO_funcs *tab = PerlIO_default_btm(); + int init = 0; + PerlIO *f; + if (*mode == 'I') + { + init = 1; + mode++; + } +#if O_BINARY != O_TEXT + /* do something about failing setmode()? --jhi */ + PerlLIO_setmode(fd, O_BINARY); +#endif + f = (*tab->Fdopen)(tab,fd,mode); + if (f) + { + PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf); + if (init && fd == 2) + { + /* Initial stderr is unbuffered */ + PerlIOBase(f)->flags |= PERLIO_F_UNBUF; + } +#if 0 + PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n", + self->name,f,fd,mode,PerlIOBase(f)->flags); +#endif + } + return f; +} + +PerlIO * +PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode) +{ + PerlIO_funcs *tab = PerlIO_default_btm(); + PerlIO *f = (*tab->Open)(tab,path,mode); + if (f) + { + PerlIO_push(f,self,mode,Nullch,0); + } + return f; +} + +int +PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f) +{ + PerlIO *next = PerlIONext(f); + int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next); + if (code = 0) + code = (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0); + return code; +} + +/* This "flush" is akin to sfio's sync in that it handles files in either + read or write state +*/ +IV +PerlIOBuf_flush(PerlIO *f) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + int code = 0; + if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) + { + /* write() the buffer */ + STDCHAR *buf = b->buf; + STDCHAR *p = buf; + int count; + PerlIO *n = PerlIONext(f); + while (p < b->ptr) + { + count = PerlIO_write(n,p,b->ptr - p); + if (count > 0) + { + p += count; + } + else if (count < 0 || PerlIO_error(n)) + { + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + code = -1; + break; + } + } + b->posn += (p - buf); + } + else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) + { + STDCHAR *buf = PerlIO_get_base(f); + /* Note position change */ + b->posn += (b->ptr - buf); + if (b->ptr < b->end) + { + /* We did not consume all of it */ + if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0) + { + b->posn = PerlIO_tell(PerlIONext(f)); + } + } + } + b->ptr = b->end = b->buf; + PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF); + /* FIXME: Is this right for read case ? */ + if (PerlIO_flush(PerlIONext(f)) != 0) + code = -1; + return code; +} + +IV +PerlIOBuf_fill(PerlIO *f) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + PerlIO *n = PerlIONext(f); + SSize_t avail; + /* FIXME: doing the down-stream flush is a bad idea if it causes + pre-read data in stdio buffer to be discarded + but this is too simplistic - as it skips _our_ hosekeeping + and breaks tell tests. + if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) + { + } + */ + if (PerlIO_flush(f) != 0) + return -1; + + if (!b->buf) + PerlIO_get_base(f); /* allocate via vtable */ + + b->ptr = b->end = b->buf; + if (PerlIO_fast_gets(n)) + { + /* Layer below is also buffered + * We do _NOT_ want to call its ->Read() because that will loop + * till it gets what we asked for which may hang on a pipe etc. + * Instead take anything it has to hand, or ask it to fill _once_. + */ + avail = PerlIO_get_cnt(n); + if (avail <= 0) + { + avail = PerlIO_fill(n); + if (avail == 0) + avail = PerlIO_get_cnt(n); + else + { + if (!PerlIO_error(n) && PerlIO_eof(n)) + avail = 0; + } + } + if (avail > 0) + { + STDCHAR *ptr = PerlIO_get_ptr(n); + SSize_t cnt = avail; + if (avail > b->bufsiz) + avail = b->bufsiz; + Copy(ptr,b->buf,avail,STDCHAR); + PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail); + } + } + else + { + avail = PerlIO_read(n,b->ptr,b->bufsiz); + } + if (avail <= 0) + { + if (avail == 0) + PerlIOBase(f)->flags |= PERLIO_F_EOF; + else + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + return -1; + } + b->end = b->buf+avail; + PerlIOBase(f)->flags |= PERLIO_F_RDBUF; + return 0; +} + +SSize_t +PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + STDCHAR *buf = (STDCHAR *) vbuf; + if (f) + { + if (!b->ptr) + PerlIO_get_base(f); + if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) + return 0; + while (count > 0) + { + SSize_t avail = PerlIO_get_cnt(f); + SSize_t take = (count < avail) ? count : avail; + if (take > 0) + { + STDCHAR *ptr = PerlIO_get_ptr(f); + Copy(ptr,buf,take,STDCHAR); + PerlIO_set_ptrcnt(f,ptr+take,(avail -= take)); + count -= take; + buf += take; + } + if (count > 0 && avail <= 0) + { + if (PerlIO_fill(f) != 0) + break; + } + } + return (buf - (STDCHAR *) vbuf); + } + return 0; +} + +SSize_t +PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count) +{ + const STDCHAR *buf = (const STDCHAR *) vbuf+count; + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + SSize_t unread = 0; + SSize_t avail; + if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) + PerlIO_flush(f); + if (!b->buf) + PerlIO_get_base(f); + if (b->buf) + { + if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) + { + avail = (b->ptr - b->buf); + } + else + { + avail = b->bufsiz; + b->end = b->buf + avail; + b->ptr = b->end; + PerlIOBase(f)->flags |= PERLIO_F_RDBUF; + b->posn -= b->bufsiz; + } + if (avail > (SSize_t) count) + avail = count; + if (avail > 0) + { + b->ptr -= avail; + buf -= avail; + if (buf != b->ptr) + { + Copy(buf,b->ptr,avail,STDCHAR); + } + count -= avail; + unread += avail; + PerlIOBase(f)->flags &= ~ PERLIO_F_EOF; + } + } + return unread; +} + +SSize_t +PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + const STDCHAR *buf = (const STDCHAR *) vbuf; + Size_t written = 0; + if (!b->buf) + PerlIO_get_base(f); + if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) + return 0; + while (count > 0) + { + SSize_t avail = b->bufsiz - (b->ptr - b->buf); + if ((SSize_t) count < avail) + avail = count; + PerlIOBase(f)->flags |= PERLIO_F_WRBUF; + if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) + { + while (avail > 0) + { + int ch = *buf++; + *(b->ptr)++ = ch; + count--; + avail--; + written++; + if (ch == '\n') + { + PerlIO_flush(f); + break; + } + } + } + else + { + if (avail) + { + Copy(buf,b->ptr,avail,STDCHAR); + count -= avail; + buf += avail; + written += avail; + b->ptr += avail; + } + } + if (b->ptr >= (b->buf + b->bufsiz)) + PerlIO_flush(f); + } + if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) + PerlIO_flush(f); + return written; +} + +IV +PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence) +{ + IV code; + if ((code = PerlIO_flush(f)) == 0) + { + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + PerlIOBase(f)->flags &= ~PERLIO_F_EOF; + code = PerlIO_seek(PerlIONext(f),offset,whence); + if (code == 0) + { + b->posn = PerlIO_tell(PerlIONext(f)); + } + } + return code; +} + +Off_t +PerlIOBuf_tell(PerlIO *f) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + Off_t posn = b->posn; + if (b->buf) + posn += (b->ptr - b->buf); + return posn; +} + +IV +PerlIOBuf_close(PerlIO *f) +{ + dTHX; + IV code = PerlIOBase_close(f); + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + if (b->buf && b->buf != (STDCHAR *) &b->oneword) + { + PerlMemShared_free(b->buf); + } + b->buf = NULL; + b->ptr = b->end = b->buf; + PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF); + return code; +} + +void +PerlIOBuf_setlinebuf(PerlIO *f) +{ + if (f) + { + PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF; + } +} + +STDCHAR * +PerlIOBuf_get_ptr(PerlIO *f) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + if (!b->buf) + PerlIO_get_base(f); + return b->ptr; +} + +SSize_t +PerlIOBuf_get_cnt(PerlIO *f) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + if (!b->buf) + PerlIO_get_base(f); + if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) + return (b->end - b->ptr); + return 0; +} + +STDCHAR * +PerlIOBuf_get_base(PerlIO *f) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + if (!b->buf) + { + dTHX; + if (!b->bufsiz) + b->bufsiz = 4096; + b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR)); + if (!b->buf) + { + b->buf = (STDCHAR *)&b->oneword; + b->bufsiz = sizeof(b->oneword); + } + b->ptr = b->buf; + b->end = b->ptr; + } + return b->buf; +} + +Size_t +PerlIOBuf_bufsiz(PerlIO *f) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + if (!b->buf) + PerlIO_get_base(f); + return (b->end - b->buf); +} + +void +PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + if (!b->buf) + PerlIO_get_base(f); + b->ptr = ptr; + if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) + { + dTHX; + assert(PerlIO_get_cnt(f) == cnt); + assert(b->ptr >= b->buf); + } + PerlIOBase(f)->flags |= PERLIO_F_RDBUF; +} + +PerlIO_funcs PerlIO_perlio = { + "perlio", + sizeof(PerlIOBuf), + PERLIO_K_BUFFERED, + PerlIOBase_fileno, + PerlIOBuf_fdopen, + PerlIOBuf_open, + PerlIOBuf_reopen, + PerlIOBuf_pushed, + PerlIOBase_noop_ok, + PerlIOBuf_read, + PerlIOBuf_unread, + PerlIOBuf_write, + PerlIOBuf_seek, + PerlIOBuf_tell, + PerlIOBuf_close, + PerlIOBuf_flush, + PerlIOBuf_fill, + PerlIOBase_eof, + PerlIOBase_error, + PerlIOBase_clearerr, + PerlIOBuf_setlinebuf, + PerlIOBuf_get_base, + PerlIOBuf_bufsiz, + PerlIOBuf_get_ptr, + PerlIOBuf_get_cnt, + PerlIOBuf_set_ptrcnt, +}; + +/*--------------------------------------------------------------------------------------*/ +/* Temp layer to hold unread chars when cannot do it any other way */ + +IV +PerlIOPending_fill(PerlIO *f) +{ + /* Should never happen */ + PerlIO_flush(f); + return 0; +} + +IV +PerlIOPending_close(PerlIO *f) +{ + /* A tad tricky - flush pops us, then we close new top */ + PerlIO_flush(f); + return PerlIO_close(f); +} + +IV +PerlIOPending_seek(PerlIO *f, Off_t offset, int whence) +{ + /* A tad tricky - flush pops us, then we seek new top */ + PerlIO_flush(f); + return PerlIO_seek(f,offset,whence); +} + + +IV +PerlIOPending_flush(PerlIO *f) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + if (b->buf && b->buf != (STDCHAR *) &b->oneword) + { + dTHX; + PerlMemShared_free(b->buf); + b->buf = NULL; + } + PerlIO_pop(f); + return 0; +} + +void +PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt) +{ + if (cnt <= 0) + { + PerlIO_flush(f); + } + else + { + PerlIOBuf_set_ptrcnt(f,ptr,cnt); + } +} + +IV +PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len) +{ + IV code = PerlIOBase_pushed(f,mode,arg,len); + PerlIOl *l = PerlIOBase(f); + /* Our PerlIO_fast_gets must match what we are pushed on, + or sv_gets() etc. get muddled when it changes mid-string + when we auto-pop. + */ + l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) | + (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8)); + return code; +} + +SSize_t +PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count) +{ + SSize_t avail = PerlIO_get_cnt(f); + SSize_t got = 0; + if (count < avail) + avail = count; + if (avail > 0) + got = PerlIOBuf_read(f,vbuf,avail); + if (got < count) + got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got); + return got; +} + + +PerlIO_funcs PerlIO_pending = { + "pending", + sizeof(PerlIOBuf), + PERLIO_K_BUFFERED, + PerlIOBase_fileno, + NULL, + NULL, + NULL, + PerlIOPending_pushed, + PerlIOBase_noop_ok, + PerlIOPending_read, + PerlIOBuf_unread, + PerlIOBuf_write, + PerlIOPending_seek, + PerlIOBuf_tell, + PerlIOPending_close, + PerlIOPending_flush, + PerlIOPending_fill, + PerlIOBase_eof, + PerlIOBase_error, + PerlIOBase_clearerr, + PerlIOBuf_setlinebuf, + PerlIOBuf_get_base, + PerlIOBuf_bufsiz, + PerlIOBuf_get_ptr, + PerlIOBuf_get_cnt, + PerlIOPending_set_ptrcnt, +}; + + + +/*--------------------------------------------------------------------------------------*/ +/* crlf - translation + On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries + to hand back a line at a time and keeping a record of which nl we "lied" about. + On write translate "\n" to CR,LF + */ + +typedef struct +{ + PerlIOBuf base; /* PerlIOBuf stuff */ + STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */ +} PerlIOCrlf; + +IV +PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len) +{ + IV code; + PerlIOBase(f)->flags |= PERLIO_F_CRLF; + code = PerlIOBuf_pushed(f,mode,arg,len); +#if 0 + PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n", + f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)", + PerlIOBase(f)->flags); +#endif + return code; +} + + +SSize_t +PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count) +{ + PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf); + if (c->nl) + { + *(c->nl) = 0xd; + c->nl = NULL; + } + if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) + return PerlIOBuf_unread(f,vbuf,count); + else + { + const STDCHAR *buf = (const STDCHAR *) vbuf+count; + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + SSize_t unread = 0; + if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) + PerlIO_flush(f); + if (!b->buf) + PerlIO_get_base(f); + if (b->buf) + { + if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) + { + b->end = b->ptr = b->buf + b->bufsiz; + PerlIOBase(f)->flags |= PERLIO_F_RDBUF; + b->posn -= b->bufsiz; + } + while (count > 0 && b->ptr > b->buf) + { + int ch = *--buf; + if (ch == '\n') + { + if (b->ptr - 2 >= b->buf) + { + *--(b->ptr) = 0xa; + *--(b->ptr) = 0xd; + unread++; + count--; + } + else + { + buf++; + break; + } + } + else + { + *--(b->ptr) = ch; + unread++; + count--; + } + } + } + return unread; + } +} + +SSize_t +PerlIOCrlf_get_cnt(PerlIO *f) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + if (!b->buf) + PerlIO_get_base(f); + if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) + { + PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf); + if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl) + { + STDCHAR *nl = b->ptr; + scan: + while (nl < b->end && *nl != 0xd) + nl++; + if (nl < b->end && *nl == 0xd) + { + test: + if (nl+1 < b->end) + { + if (nl[1] == 0xa) + { + *nl = '\n'; + c->nl = nl; + } + else + { + /* Not CR,LF but just CR */ + nl++; + goto scan; + } + } + else + { + /* Blast - found CR as last char in buffer */ + if (b->ptr < nl) + { + /* They may not care, defer work as long as possible */ + return (nl - b->ptr); + } + else + { + int code; + dTHX; + b->ptr++; /* say we have read it as far as flush() is concerned */ + b->buf++; /* Leave space an front of buffer */ + b->bufsiz--; /* Buffer is thus smaller */ + code = PerlIO_fill(f); /* Fetch some more */ + b->bufsiz++; /* Restore size for next time */ + b->buf--; /* Point at space */ + b->ptr = nl = b->buf; /* Which is what we hand off */ + b->posn--; /* Buffer starts here */ + *nl = 0xd; /* Fill in the CR */ + if (code == 0) + goto test; /* fill() call worked */ + /* CR at EOF - just fall through */ + } + } + } + } + return (((c->nl) ? (c->nl+1) : b->end) - b->ptr); + } + return 0; +} + +void +PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf); + IV flags = PerlIOBase(f)->flags; + if (!b->buf) + PerlIO_get_base(f); + if (!ptr) + { + if (c->nl) + ptr = c->nl+1; + else + { + ptr = b->end; + if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd) + ptr--; + } + ptr -= cnt; + } + else + { + /* Test code - delete when it works ... */ + STDCHAR *chk; + if (c->nl) + chk = c->nl+1; + else + { + chk = b->end; + if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd) + chk--; + } + chk -= cnt; + + if (ptr != chk) + { + dTHX; + Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d", + ptr, chk, flags, c->nl, b->end, cnt); + } + } + if (c->nl) + { + if (ptr > c->nl) + { + /* They have taken what we lied about */ + *(c->nl) = 0xd; + c->nl = NULL; + ptr++; + } + } + b->ptr = ptr; + PerlIOBase(f)->flags |= PERLIO_F_RDBUF; +} + +SSize_t +PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count) +{ + if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) + return PerlIOBuf_write(f,vbuf,count); + else + { + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + const STDCHAR *buf = (const STDCHAR *) vbuf; + const STDCHAR *ebuf = buf+count; + if (!b->buf) + PerlIO_get_base(f); + if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) + return 0; + while (buf < ebuf) + { + STDCHAR *eptr = b->buf+b->bufsiz; + PerlIOBase(f)->flags |= PERLIO_F_WRBUF; + while (buf < ebuf && b->ptr < eptr) + { + if (*buf == '\n') + { + if ((b->ptr + 2) > eptr) + { + /* Not room for both */ + PerlIO_flush(f); + break; + } + else + { + *(b->ptr)++ = 0xd; /* CR */ + *(b->ptr)++ = 0xa; /* LF */ + buf++; + if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) + { + PerlIO_flush(f); + break; + } + } + } + else + { + int ch = *buf++; + *(b->ptr)++ = ch; + } + if (b->ptr >= eptr) + { + PerlIO_flush(f); + break; + } + } + } + if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) + PerlIO_flush(f); + return (buf - (STDCHAR *) vbuf); + } +} + +IV +PerlIOCrlf_flush(PerlIO *f) +{ + PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf); + if (c->nl) + { + *(c->nl) = 0xd; + c->nl = NULL; + } + return PerlIOBuf_flush(f); +} + +PerlIO_funcs PerlIO_crlf = { + "crlf", + sizeof(PerlIOCrlf), + PERLIO_K_BUFFERED|PERLIO_K_CANCRLF, + PerlIOBase_fileno, + PerlIOBuf_fdopen, + PerlIOBuf_open, + PerlIOBuf_reopen, + PerlIOCrlf_pushed, + PerlIOBase_noop_ok, /* popped */ + PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */ + PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */ + PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */ + PerlIOBuf_seek, + PerlIOBuf_tell, + PerlIOBuf_close, + PerlIOCrlf_flush, + PerlIOBuf_fill, + PerlIOBase_eof, + PerlIOBase_error, + PerlIOBase_clearerr, + PerlIOBuf_setlinebuf, + PerlIOBuf_get_base, + PerlIOBuf_bufsiz, + PerlIOBuf_get_ptr, + PerlIOCrlf_get_cnt, + PerlIOCrlf_set_ptrcnt, +}; + +#ifdef HAS_MMAP +/*--------------------------------------------------------------------------------------*/ +/* mmap as "buffer" layer */ + +typedef struct +{ + PerlIOBuf base; /* PerlIOBuf stuff */ + Mmap_t mptr; /* Mapped address */ + Size_t len; /* mapped length */ + STDCHAR *bbuf; /* malloced buffer if map fails */ +} PerlIOMmap; + +static size_t page_size = 0; + +IV +PerlIOMmap_map(PerlIO *f) { dTHX; -#ifdef FILE_bufsiz - STDCHAR *e = FILE_base(f) + FILE_bufsiz(f); - int ec = e - ptr; - if (ptr > e + 1 && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Setting ptr %p > end+1 %p\n", ptr, e + 1); - if (cnt != ec && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d, ptr implies %d\n",cnt,ec); -#endif -#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) - FILE_ptr(f) = ptr; + PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap); + PerlIOBuf *b = &m->base; + IV flags = PerlIOBase(f)->flags; + IV code = 0; + if (m->len) + abort(); + if (flags & PERLIO_F_CANREAD) + { + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + int fd = PerlIO_fileno(f); + struct stat st; + code = fstat(fd,&st); + if (code == 0 && S_ISREG(st.st_mode)) + { + SSize_t len = st.st_size - b->posn; + if (len > 0) + { + Off_t posn; + if (!page_size) { +#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE)) + { + SETERRNO(0,SS$_NORMAL); +# ifdef _SC_PAGESIZE + page_size = sysconf(_SC_PAGESIZE); +# else + page_size = sysconf(_SC_PAGE_SIZE); +# endif + if ((long)page_size < 0) { + if (errno) { + SV *error = ERRSV; + char *msg; + STRLEN n_a; + (void)SvUPGRADE(error, SVt_PV); + msg = SvPVx(error, n_a); + Perl_croak(aTHX_ "panic: sysconf: %s", msg); + } + else + Perl_croak(aTHX_ "panic: sysconf: pagesize unknown"); + } + } #else - Perl_croak(aTHX_ "Cannot set 'ptr' of FILE * on this system"); +# ifdef HAS_GETPAGESIZE + page_size = getpagesize(); +# else +# if defined(I_SYS_PARAM) && defined(PAGESIZE) + page_size = PAGESIZE; /* compiletime, bad */ +# endif +# endif #endif -#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) - FILE_cnt(f) = cnt; -#else - Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system"); + if ((IV)page_size <= 0) + Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size); + } + if (b->posn < 0) + { + /* This is a hack - should never happen - open should have set it ! */ + b->posn = PerlIO_tell(PerlIONext(f)); + } + posn = (b->posn / page_size) * page_size; + len = st.st_size - posn; + m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn); + if (m->mptr && m->mptr != (Mmap_t) -1) + { +#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL) + madvise(m->mptr, len, MADV_SEQUENTIAL); +#endif +#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED) + madvise(m->mptr, len, MADV_WILLNEED); #endif + PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF; + b->end = ((STDCHAR *)m->mptr) + len; + b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn); + b->ptr = b->buf; + m->len = len; + } + else + { + b->buf = NULL; + } + } + else + { + PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF; + b->buf = NULL; + b->ptr = b->end = b->ptr; + code = -1; + } + } + } + return code; } -#undef PerlIO_get_cnt -int -PerlIO_get_cnt(PerlIO *f) +IV +PerlIOMmap_unmap(PerlIO *f) { -#ifdef FILE_cnt - return FILE_cnt(f); -#else - dTHX; - Perl_croak(aTHX_ "Cannot get 'cnt' of FILE * on this system"); - return -1; -#endif + PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap); + PerlIOBuf *b = &m->base; + IV code = 0; + if (m->len) + { + if (b->buf) + { + code = munmap(m->mptr, m->len); + b->buf = NULL; + m->len = 0; + m->mptr = NULL; + if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0) + code = -1; + } + b->ptr = b->end = b->buf; + PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF); + } + return code; } -#undef PerlIO_get_bufsiz -int -PerlIO_get_bufsiz(PerlIO *f) +STDCHAR * +PerlIOMmap_get_base(PerlIO *f) { -#ifdef FILE_bufsiz - return FILE_bufsiz(f); -#else - dTHX; - Perl_croak(aTHX_ "Cannot get 'bufsiz' of FILE * on this system"); - return -1; -#endif + PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap); + PerlIOBuf *b = &m->base; + if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) + { + /* Already have a readbuffer in progress */ + return b->buf; + } + if (b->buf) + { + /* We have a write buffer or flushed PerlIOBuf read buffer */ + m->bbuf = b->buf; /* save it in case we need it again */ + b->buf = NULL; /* Clear to trigger below */ + } + if (!b->buf) + { + PerlIOMmap_map(f); /* Try and map it */ + if (!b->buf) + { + /* Map did not work - recover PerlIOBuf buffer if we have one */ + b->buf = m->bbuf; + } + } + b->ptr = b->end = b->buf; + if (b->buf) + return b->buf; + return PerlIOBuf_get_base(f); } -#undef PerlIO_get_ptr -STDCHAR * -PerlIO_get_ptr(PerlIO *f) +SSize_t +PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count) { -#ifdef FILE_ptr - return FILE_ptr(f); -#else - dTHX; - Perl_croak(aTHX_ "Cannot get 'ptr' of FILE * on this system"); - return NULL; -#endif + PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap); + PerlIOBuf *b = &m->base; + if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) + PerlIO_flush(f); + if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count)) + { + b->ptr -= count; + PerlIOBase(f)->flags &= ~ PERLIO_F_EOF; + return count; + } + if (m->len) + { + /* Loose the unwritable mapped buffer */ + PerlIO_flush(f); + /* If flush took the "buffer" see if we have one from before */ + if (!b->buf && m->bbuf) + b->buf = m->bbuf; + if (!b->buf) + { + PerlIOBuf_get_base(f); + m->bbuf = b->buf; + } + } +return PerlIOBuf_unread(f,vbuf,count); } -#undef PerlIO_get_base -STDCHAR * -PerlIO_get_base(PerlIO *f) +SSize_t +PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count) { -#ifdef FILE_base - return FILE_base(f); -#else - dTHX; - Perl_croak(aTHX_ "Cannot get 'base' of FILE * on this system"); - return NULL; -#endif + PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap); + PerlIOBuf *b = &m->base; + if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) + { + /* No, or wrong sort of, buffer */ + if (m->len) + { + if (PerlIOMmap_unmap(f) != 0) + return 0; + } + /* If unmap took the "buffer" see if we have one from before */ + if (!b->buf && m->bbuf) + b->buf = m->bbuf; + if (!b->buf) + { + PerlIOBuf_get_base(f); + m->bbuf = b->buf; + } + } + return PerlIOBuf_write(f,vbuf,count); } -#undef PerlIO_has_base -int -PerlIO_has_base(PerlIO *f) +IV +PerlIOMmap_flush(PerlIO *f) { -#ifdef FILE_base - return 1; -#else - return 0; -#endif + PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap); + PerlIOBuf *b = &m->base; + IV code = PerlIOBuf_flush(f); + /* Now we are "synced" at PerlIOBuf level */ + if (b->buf) + { + if (m->len) + { + /* Unmap the buffer */ + if (PerlIOMmap_unmap(f) != 0) + code = -1; + } + else + { + /* We seem to have a PerlIOBuf buffer which was not mapped + * remember it in case we need one later + */ + m->bbuf = b->buf; + } + } + return code; } -#undef PerlIO_puts -int -PerlIO_puts(PerlIO *f, const char *s) +IV +PerlIOMmap_fill(PerlIO *f) { - return fputs(s,f); + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + IV code = PerlIO_flush(f); + if (code == 0 && !b->buf) + { + code = PerlIOMmap_map(f); + } + if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) + { + code = PerlIOBuf_fill(f); + } + return code; } -#undef PerlIO_open -PerlIO * -PerlIO_open(const char *path, const char *mode) +IV +PerlIOMmap_close(PerlIO *f) { - return fopen(path,mode); + PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap); + PerlIOBuf *b = &m->base; + IV code = PerlIO_flush(f); + if (m->bbuf) + { + b->buf = m->bbuf; + m->bbuf = NULL; + b->ptr = b->end = b->buf; + } + if (PerlIOBuf_close(f) != 0) + code = -1; + return code; } -#undef PerlIO_fdopen -PerlIO * -PerlIO_fdopen(int fd, const char *mode) + +PerlIO_funcs PerlIO_mmap = { + "mmap", + sizeof(PerlIOMmap), + PERLIO_K_BUFFERED, + PerlIOBase_fileno, + PerlIOBuf_fdopen, + PerlIOBuf_open, + PerlIOBuf_reopen, + PerlIOBuf_pushed, + PerlIOBase_noop_ok, + PerlIOBuf_read, + PerlIOMmap_unread, + PerlIOMmap_write, + PerlIOBuf_seek, + PerlIOBuf_tell, + PerlIOBuf_close, + PerlIOMmap_flush, + PerlIOMmap_fill, + PerlIOBase_eof, + PerlIOBase_error, + PerlIOBase_clearerr, + PerlIOBuf_setlinebuf, + PerlIOMmap_get_base, + PerlIOBuf_bufsiz, + PerlIOBuf_get_ptr, + PerlIOBuf_get_cnt, + PerlIOBuf_set_ptrcnt, +}; + +#endif /* HAS_MMAP */ + +void +PerlIO_init(void) { - return fdopen(fd,mode); + if (!_perlio) + { +#ifndef WIN32 + atexit(&PerlIO_cleanup); +#endif + } } -#undef PerlIO_reopen -PerlIO * -PerlIO_reopen(const char *name, const char *mode, PerlIO *f) +#undef PerlIO_stdin +PerlIO * +PerlIO_stdin(void) { - return freopen(name,mode,f); + if (!_perlio) + PerlIO_stdstreams(); + return &_perlio[1]; } -#undef PerlIO_close -int -PerlIO_close(PerlIO *f) +#undef PerlIO_stdout +PerlIO * +PerlIO_stdout(void) { - return fclose(f); + if (!_perlio) + PerlIO_stdstreams(); + return &_perlio[2]; } -#undef PerlIO_eof -int -PerlIO_eof(PerlIO *f) +#undef PerlIO_stderr +PerlIO * +PerlIO_stderr(void) { - return feof(f); + if (!_perlio) + PerlIO_stdstreams(); + return &_perlio[3]; } +/*--------------------------------------------------------------------------------------*/ + #undef PerlIO_getname char * PerlIO_getname(PerlIO *f, char *buf) { -#ifdef VMS - return fgetname(f,buf); -#else dTHX; Perl_croak(aTHX_ "Don't know how to get file name"); return NULL; -#endif -} - -#undef PerlIO_getc -int -PerlIO_getc(PerlIO *f) -{ - return fgetc(f); -} - -#undef PerlIO_error -int -PerlIO_error(PerlIO *f) -{ - return ferror(f); } -#undef PerlIO_clearerr -void -PerlIO_clearerr(PerlIO *f) -{ - clearerr(f); -} -#undef PerlIO_flush -int -PerlIO_flush(PerlIO *f) -{ - return Fflush(f); -} +/*--------------------------------------------------------------------------------------*/ +/* Functions which can be called on any kind of PerlIO implemented + in terms of above +*/ -#undef PerlIO_fileno -int -PerlIO_fileno(PerlIO *f) +#undef PerlIO_getc +int +PerlIO_getc(PerlIO *f) { - return fileno(f); + STDCHAR buf[1]; + SSize_t count = PerlIO_read(f,buf,1); + if (count == 1) + { + return (unsigned char) buf[0]; + } + return EOF; } -#undef PerlIO_setlinebuf -void -PerlIO_setlinebuf(PerlIO *f) +#undef PerlIO_ungetc +int +PerlIO_ungetc(PerlIO *f, int ch) { -#ifdef HAS_SETLINEBUF - setlinebuf(f); -#else -# ifdef __BORLANDC__ /* Borland doesn't like NULL size for _IOLBF */ - setvbuf(f, Nullch, _IOLBF, BUFSIZ); -# else - setvbuf(f, Nullch, _IOLBF, 0); -# endif -#endif + if (ch != EOF) + { + STDCHAR buf = ch; + if (PerlIO_unread(f,&buf,1) == 1) + return ch; + } + return EOF; } #undef PerlIO_putc -int +int PerlIO_putc(PerlIO *f, int ch) { - return putc(ch,f); -} - -#undef PerlIO_ungetc -int -PerlIO_ungetc(PerlIO *f, int ch) -{ - return ungetc(ch,f); + STDCHAR buf = ch; + return PerlIO_write(f,&buf,1); } -#undef PerlIO_read -SSize_t -PerlIO_read(PerlIO *f, void *buf, Size_t count) +#undef PerlIO_puts +int +PerlIO_puts(PerlIO *f, const char *s) { - return fread(buf,1,count,f); + STRLEN len = strlen(s); + return PerlIO_write(f,s,len); } -#undef PerlIO_write -SSize_t -PerlIO_write(PerlIO *f, const void *buf, Size_t count) +#undef PerlIO_rewind +void +PerlIO_rewind(PerlIO *f) { - return fwrite1(buf,1,count,f); + PerlIO_seek(f,(Off_t)0,SEEK_SET); + PerlIO_clearerr(f); } #undef PerlIO_vprintf -int -PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap) -{ - return vfprintf(f,fmt,ap); -} - -#undef PerlIO_tell -Off_t -PerlIO_tell(PerlIO *f) -{ -#if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64) - return ftello(f); -#else - return ftell(f); -#endif -} - -#undef PerlIO_seek int -PerlIO_seek(PerlIO *f, Off_t offset, int whence) +PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap) { -#if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64) - return fseeko(f,offset,whence); + dTHX; + SV *sv = newSVpvn("",0); + char *s; + STRLEN len; +#ifdef NEED_VA_COPY + va_list apc; + Perl_va_copy(ap, apc); + sv_vcatpvf(sv, fmt, &apc); #else - return fseek(f,offset,whence); + sv_vcatpvf(sv, fmt, &ap); #endif -} - -#undef PerlIO_rewind -void -PerlIO_rewind(PerlIO *f) -{ - rewind(f); + s = SvPV(sv,len); + return PerlIO_write(f,s,len); } #undef PerlIO_printf -int +int PerlIO_printf(PerlIO *f,const char *fmt,...) { va_list ap; int result; va_start(ap,fmt); - result = vfprintf(f,fmt,ap); + result = PerlIO_vprintf(f,fmt,ap); va_end(ap); return result; } #undef PerlIO_stdoutf -int +int PerlIO_stdoutf(const char *fmt,...) { va_list ap; @@ -443,93 +3142,114 @@ PerlIO_stdoutf(const char *fmt,...) PerlIO * PerlIO_tmpfile(void) { - return tmpfile(); -} - -#undef PerlIO_importFILE -PerlIO * -PerlIO_importFILE(FILE *f, int fl) -{ - return f; -} - -#undef PerlIO_exportFILE -FILE * -PerlIO_exportFILE(PerlIO *f, int fl) -{ + /* I have no idea how portable mkstemp() is ... */ +#if defined(WIN32) || !defined(HAVE_MKSTEMP) + dTHX; + PerlIO *f = NULL; + FILE *stdio = PerlSIO_tmpfile(); + if (stdio) + { + PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio); + s->stdio = stdio; + } return f; -} - -#undef PerlIO_findFILE -FILE * -PerlIO_findFILE(PerlIO *f) -{ +#else + dTHX; + SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0); + int fd = mkstemp(SvPVX(sv)); + PerlIO *f = NULL; + if (fd >= 0) + { + f = PerlIO_fdopen(fd,"w+"); + if (f) + { + PerlIOBase(f)->flags |= PERLIO_F_TEMP; + } + PerlLIO_unlink(SvPVX(sv)); + SvREFCNT_dec(sv); + } return f; +#endif } -#undef PerlIO_releaseFILE -void -PerlIO_releaseFILE(PerlIO *p, FILE *f) -{ -} - -void -PerlIO_init(void) -{ - /* Does nothing (yet) except force this file to be included - in perl binary. That allows this file to force inclusion - of other functions that may be required by loadable - extensions e.g. for FileHandle::tmpfile - */ -} +#undef HAS_FSETPOS +#undef HAS_FGETPOS #endif /* USE_SFIO */ #endif /* PERLIO_IS_STDIO */ +/*======================================================================================*/ +/* Now some functions in terms of above which may be needed even if + we are not in true PerlIO mode + */ + #ifndef HAS_FSETPOS #undef PerlIO_setpos int -PerlIO_setpos(PerlIO *f, const Fpos_t *pos) +PerlIO_setpos(PerlIO *f, SV *pos) { - return PerlIO_seek(f,*pos,0); + dTHX; + if (SvOK(pos)) + { + STRLEN len; + Off_t *posn = (Off_t *) SvPV(pos,len); + if (f && len == sizeof(Off_t)) + return PerlIO_seek(f,*posn,SEEK_SET); + } + errno = EINVAL; + return -1; } #else -#ifndef PERLIO_IS_STDIO #undef PerlIO_setpos int -PerlIO_setpos(PerlIO *f, const Fpos_t *pos) +PerlIO_setpos(PerlIO *f, SV *pos) { + dTHX; + if (SvOK(pos)) + { + STRLEN len; + Fpos_t *fpos = (Fpos_t *) SvPV(pos,len); + if (f && len == sizeof(Fpos_t)) + { #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) - return fsetpos64(f, pos); + return fsetpos64(f, fpos); #else - return fsetpos(f, pos); + return fsetpos(f, fpos); #endif + } + } + errno = EINVAL; + return -1; } #endif -#endif #ifndef HAS_FGETPOS #undef PerlIO_getpos int -PerlIO_getpos(PerlIO *f, Fpos_t *pos) +PerlIO_getpos(PerlIO *f, SV *pos) { - *pos = PerlIO_tell(f); - return 0; + dTHX; + Off_t posn = PerlIO_tell(f); + sv_setpvn(pos,(char *)&posn,sizeof(posn)); + return (posn == (Off_t)-1) ? -1 : 0; } #else -#ifndef PERLIO_IS_STDIO #undef PerlIO_getpos int -PerlIO_getpos(PerlIO *f, Fpos_t *pos) +PerlIO_getpos(PerlIO *f, SV *pos) { + dTHX; + Fpos_t fpos; + int code; #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) - return fgetpos64(f, pos); + code = fgetpos64(f, &fpos); #else - return fgetpos(f, pos); + code = fgetpos(f, &fpos); #endif + sv_setpvn(pos,(char *)&fpos,sizeof(fpos)); + return code; } #endif -#endif #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF) @@ -550,7 +3270,7 @@ vfprintf(FILE *fd, char *pat, char *args) #endif #ifndef PerlIO_vsprintf -int +int PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap) { int val = vsprintf(s, fmt, ap); @@ -559,7 +3279,8 @@ PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap) if (strlen(s) >= (STRLEN)n) { dTHX; - PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n"); + (void)PerlIO_puts(Perl_error_log, + "panic: sprintf overflow - memory corrupted!\n"); my_exit(1); } } @@ -568,7 +3289,7 @@ PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap) #endif #ifndef PerlIO_sprintf -int +int PerlIO_sprintf(char *s, int n, const char *fmt,...) { va_list ap; @@ -580,5 +3301,4 @@ PerlIO_sprintf(char *s, int n, const char *fmt,...) } #endif -#endif /* !PERL_IMPLICIT_SYS */ diff --git a/perlio.h b/perlio.h index e699a3e..b144b24 100644 --- a/perlio.h +++ b/perlio.h @@ -1 +1,337 @@ -#include "iperlsys.h" +#ifndef _PERLIO_H +#define _PERLIO_H +/* + Interface for perl to IO functions. + There is a hierachy of Configure determined #define controls: + USE_STDIO - forces PerlIO_xxx() to be #define-d onto stdio functions. + This is used for x2p subdirectory and for conservative + builds - "just like perl5.00X used to be". + This dominates over the others. + + USE_PERLIO - The primary Configure variable that enables PerlIO. + If USE_PERLIO is _NOT_ set + then USE_STDIO above will be set to be conservative. + If USE_PERLIO is set + then there are two modes determined by USE_SFIO: + + USE_SFIO - If set causes PerlIO_xxx() to be #define-d onto sfio functions. + A backward compatability mode for some specialist applications. + + If USE_SFIO is not set then PerlIO_xxx() are real functions + defined in perlio.c which implement extra functionality + required for utf8 support. + + One further note - the table-of-functions scheme controlled + by PERL_IMPLICIT_SYS turns on USE_PERLIO so that iperlsys.h can + #define PerlIO_xxx() to go via the function table, without having + to #undef them from (say) stdio forms. + +*/ + +#if defined(PERL_IMPLICIT_SYS) +#ifndef USE_PERLIO +# define USE_PERLIO +#endif +#endif + +#ifndef USE_PERLIO +# define USE_STDIO +#endif + +#ifdef USE_STDIO +# ifndef PERLIO_IS_STDIO +# define PERLIO_IS_STDIO +# endif +#endif + +/* -------------------- End of Configure controls ---------------------------- */ + +/* + * Although we may not want stdio to be used including here + * avoids issues where stdio.h has strange side effects + */ +#include + +#if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64) +#define ftell ftello +#endif + +#if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64) +#define fseek fseeko +#endif + +#ifdef PERLIO_IS_STDIO +/* #define PerlIO_xxxx() as equivalent stdio function */ +#include "perlsdio.h" +#else /* PERLIO_IS_STDIO */ +#ifdef USE_SFIO +/* #define PerlIO_xxxx() as equivalent sfio function */ +#include "perlsfio.h" +#endif /* USE_SFIO */ +#endif /* PERLIO_IS_STDIO */ + +#ifndef PerlIO +/* ----------- PerlIO implementation ---------- */ +/* PerlIO not #define-d to something else - define the implementation */ + +typedef struct _PerlIO PerlIOl; +typedef struct _PerlIO_funcs PerlIO_funcs; +typedef PerlIOl *PerlIO; +#define PerlIO PerlIO +#define PERLIO_LAYERS 1 + +extern void PerlIO_define_layer (PerlIO_funcs *tab); +extern SV * PerlIO_find_layer (const char *name, STRLEN len); +extern PerlIO * PerlIO_push (PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len); +extern void PerlIO_pop (PerlIO *f); + +#endif /* PerlIO */ + +/* ----------- End of implementation choices ---------- */ + +#ifndef PERLIO_IS_STDIO +/* Not using stdio _directly_ as PerlIO */ + +/* We now need to determine what happens if source trys to use stdio. + * There are three cases based on PERLIO_NOT_STDIO which XS code + * can set how it wants. + */ + +#ifdef PERL_CORE +/* Make a choice for perl core code + - currently this is set to try and catch lingering raw stdio calls. + This is a known issue with some non UNIX ports which still use + "native" stdio features. +*/ +#ifndef PERLIO_NOT_STDIO +#define PERLIO_NOT_STDIO 1 +#endif +#else +#ifndef PERLIO_NOT_STDIO +#define PERLIO_NOT_STDIO 0 +#endif +#endif + +#ifdef PERLIO_NOT_STDIO +#if PERLIO_NOT_STDIO +/* + * PERLIO_NOT_STDIO #define'd as 1 + * Case 1: Strong denial of stdio - make all stdio calls (we can think of) errors + */ +#include "nostdio.h" +#else /* if PERLIO_NOT_STDIO */ +/* + * PERLIO_NOT_STDIO #define'd as 0 + * Case 2: Declares that both PerlIO and stdio can be used + */ +#endif /* if PERLIO_NOT_STDIO */ +#else /* ifdef PERLIO_NOT_STDIO */ +/* + * PERLIO_NOT_STDIO not defined + * Case 3: Try and fake stdio calls as PerlIO calls + */ +#include "fakesdio.h" +#endif /* ifndef PERLIO_NOT_STDIO */ +#endif /* PERLIO_IS_STDIO */ + +#define specialCopIO(sv) ((sv) != Nullsv) + +/* ----------- fill in things that have not got #define'd ---------- */ + +#ifndef Fpos_t +#define Fpos_t Off_t +#endif + +#ifndef EOF +#define EOF (-1) +#endif + +/* This is to catch case with no stdio */ +#ifndef BUFSIZ +#define BUFSIZ 1024 +#endif + +#ifndef SEEK_SET +#define SEEK_SET 0 +#endif + +#ifndef SEEK_CUR +#define SEEK_CUR 1 +#endif + +#ifndef SEEK_END +#define SEEK_END 2 +#endif + +/* --------------------- Now prototypes for functions --------------- */ + +START_EXTERN_C + +#ifndef NEXT30_NO_ATTRIBUTE +#ifndef HASATTRIBUTE /* disable GNU-cc attribute checking? */ +#ifdef __attribute__ /* Avoid possible redefinition errors */ +#undef __attribute__ +#endif +#define __attribute__(attr) +#endif +#endif + +#ifndef PerlIO_init +extern void PerlIO_init (void); +#endif +#ifndef PerlIO_stdoutf +extern int PerlIO_stdoutf (const char *,...) + __attribute__((__format__ (__printf__, 1, 2))); +#endif +#ifndef PerlIO_puts +extern int PerlIO_puts (PerlIO *,const char *); +#endif +#ifndef PerlIO_open +extern PerlIO * PerlIO_open (const char *,const char *); +#endif +#ifndef PerlIO_close +extern int PerlIO_close (PerlIO *); +#endif +#ifndef PerlIO_eof +extern int PerlIO_eof (PerlIO *); +#endif +#ifndef PerlIO_error +extern int PerlIO_error (PerlIO *); +#endif +#ifndef PerlIO_clearerr +extern void PerlIO_clearerr (PerlIO *); +#endif +#ifndef PerlIO_getc +extern int PerlIO_getc (PerlIO *); +#endif +#ifndef PerlIO_putc +extern int PerlIO_putc (PerlIO *,int); +#endif +#ifndef PerlIO_flush +extern int PerlIO_flush (PerlIO *); +#endif +#ifndef PerlIO_ungetc +extern int PerlIO_ungetc (PerlIO *,int); +#endif +#ifndef PerlIO_fileno +extern int PerlIO_fileno (PerlIO *); +#endif +#ifndef PerlIO_fdopen +extern PerlIO * PerlIO_fdopen (int, const char *); +#endif +#ifndef PerlIO_importFILE +extern PerlIO * PerlIO_importFILE (FILE *,int); +#endif +#ifndef PerlIO_exportFILE +extern FILE * PerlIO_exportFILE (PerlIO *,int); +#endif +#ifndef PerlIO_findFILE +extern FILE * PerlIO_findFILE (PerlIO *); +#endif +#ifndef PerlIO_releaseFILE +extern void PerlIO_releaseFILE (PerlIO *,FILE *); +#endif +#ifndef PerlIO_read +extern SSize_t PerlIO_read (PerlIO *,void *,Size_t); +#endif +#ifndef PerlIO_write +extern SSize_t PerlIO_write (PerlIO *,const void *,Size_t); +#endif +#ifndef PerlIO_setlinebuf +extern void PerlIO_setlinebuf (PerlIO *); +#endif +#ifndef PerlIO_printf +extern int PerlIO_printf (PerlIO *, const char *,...) + __attribute__((__format__ (__printf__, 2, 3))); +#endif +#ifndef PerlIO_sprintf +extern int PerlIO_sprintf (char *, int, const char *,...) + __attribute__((__format__ (__printf__, 3, 4))); +#endif +#ifndef PerlIO_vprintf +extern int PerlIO_vprintf (PerlIO *, const char *, va_list); +#endif +#ifndef PerlIO_tell +extern Off_t PerlIO_tell (PerlIO *); +#endif +#ifndef PerlIO_seek +extern int PerlIO_seek (PerlIO *, Off_t, int); +#endif +#ifndef PerlIO_rewind +extern void PerlIO_rewind (PerlIO *); +#endif +#ifndef PerlIO_has_base +extern int PerlIO_has_base (PerlIO *); +#endif +#ifndef PerlIO_has_cntptr +extern int PerlIO_has_cntptr (PerlIO *); +#endif +#ifndef PerlIO_fast_gets +extern int PerlIO_fast_gets (PerlIO *); +#endif +#ifndef PerlIO_canset_cnt +extern int PerlIO_canset_cnt (PerlIO *); +#endif +#ifndef PerlIO_get_ptr +extern STDCHAR * PerlIO_get_ptr (PerlIO *); +#endif +#ifndef PerlIO_get_cnt +extern int PerlIO_get_cnt (PerlIO *); +#endif +#ifndef PerlIO_set_cnt +extern void PerlIO_set_cnt (PerlIO *,int); +#endif +#ifndef PerlIO_set_ptrcnt +extern void PerlIO_set_ptrcnt (PerlIO *,STDCHAR *,int); +#endif +#ifndef PerlIO_get_base +extern STDCHAR * PerlIO_get_base (PerlIO *); +#endif +#ifndef PerlIO_get_bufsiz +extern int PerlIO_get_bufsiz (PerlIO *); +#endif +#ifndef PerlIO_tmpfile +extern PerlIO * PerlIO_tmpfile (void); +#endif +#ifndef PerlIO_stdin +extern PerlIO * PerlIO_stdin (void); +#endif +#ifndef PerlIO_stdout +extern PerlIO * PerlIO_stdout (void); +#endif +#ifndef PerlIO_stderr +extern PerlIO * PerlIO_stderr (void); +#endif +#ifndef PerlIO_getpos +extern int PerlIO_getpos (PerlIO *,SV *); +#endif +#ifndef PerlIO_setpos +extern int PerlIO_setpos (PerlIO *,SV *); +#endif +#ifndef PerlIO_fdupopen +extern PerlIO * PerlIO_fdupopen (pTHX_ PerlIO *); +#endif +#if !defined(PerlIO_modestr) && !defined(PERLIO_IS_STDIO) +extern char *PerlIO_modestr (PerlIO *,char *buf); +#endif +#ifndef PerlIO_isutf8 +extern int PerlIO_isutf8 (PerlIO *); +#endif +#ifndef PerlIO_apply_layers +extern int PerlIO_apply_layers (pTHX_ PerlIO *f, const char *mode, const char *names); +#endif +#ifndef PerlIO_binmode +extern int PerlIO_binmode (pTHX_ PerlIO *f, int iotype, int omode, const char *names); +#endif + +#ifndef PERLIO_IS_STDIO + +extern void PerlIO_cleanup(void); + +extern void PerlIO_debug(const char *fmt,...); + +#endif + +END_EXTERN_C + +#endif /* _PERLIO_H */ diff --git a/perliol.h b/perliol.h new file mode 100644 index 0000000..04c7071 --- /dev/null +++ b/perliol.h @@ -0,0 +1,150 @@ +#ifndef _PERLIOL_H +#define _PERLIOL_H + +struct _PerlIO_funcs +{ + char * name; + Size_t size; + IV kind; + IV (*Fileno)(PerlIO *f); + PerlIO * (*Fdopen)(PerlIO_funcs *tab, int fd, const char *mode); + PerlIO * (*Open)(PerlIO_funcs *tab, const char *path, const char *mode); + int (*Reopen)(const char *path, const char *mode, PerlIO *f); + IV (*Pushed)(PerlIO *f,const char *mode,const char *arg,STRLEN len); + IV (*Popped)(PerlIO *f); + /* Unix-like functions - cf sfio line disciplines */ + SSize_t (*Read)(PerlIO *f, void *vbuf, Size_t count); + SSize_t (*Unread)(PerlIO *f, const void *vbuf, Size_t count); + SSize_t (*Write)(PerlIO *f, const void *vbuf, Size_t count); + IV (*Seek)(PerlIO *f, Off_t offset, int whence); + Off_t (*Tell)(PerlIO *f); + IV (*Close)(PerlIO *f); + /* Stdio-like buffered IO functions */ + IV (*Flush)(PerlIO *f); + IV (*Fill)(PerlIO *f); + IV (*Eof)(PerlIO *f); + IV (*Error)(PerlIO *f); + void (*Clearerr)(PerlIO *f); + void (*Setlinebuf)(PerlIO *f); + /* Perl's snooping functions */ + STDCHAR * (*Get_base)(PerlIO *f); + Size_t (*Get_bufsiz)(PerlIO *f); + STDCHAR * (*Get_ptr)(PerlIO *f); + SSize_t (*Get_cnt)(PerlIO *f); + void (*Set_ptrcnt)(PerlIO *f,STDCHAR *ptr,SSize_t cnt); +}; + +/*--------------------------------------------------------------------------------------*/ +/* Kind values */ +#define PERLIO_K_RAW 0x00000001 +#define PERLIO_K_BUFFERED 0x00000002 +#define PERLIO_K_CANCRLF 0x00000004 +#define PERLIO_K_FASTGETS 0x00000008 + +/*--------------------------------------------------------------------------------------*/ +struct _PerlIO +{ + PerlIOl * next; /* Lower layer */ + PerlIO_funcs * tab; /* Functions for this layer */ + IV flags; /* Various flags for state */ +}; + +/*--------------------------------------------------------------------------------------*/ + +/* Flag values */ +#define PERLIO_F_EOF 0x00000100 +#define PERLIO_F_CANWRITE 0x00000200 +#define PERLIO_F_CANREAD 0x00000400 +#define PERLIO_F_ERROR 0x00000800 +#define PERLIO_F_TRUNCATE 0x00001000 +#define PERLIO_F_APPEND 0x00002000 +#define PERLIO_F_CRLF 0x00004000 +#define PERLIO_F_UTF8 0x00008000 +#define PERLIO_F_UNBUF 0x00010000 +#define PERLIO_F_WRBUF 0x00020000 +#define PERLIO_F_RDBUF 0x00040000 +#define PERLIO_F_LINEBUF 0x00080000 +#define PERLIO_F_TEMP 0x00100000 +#define PERLIO_F_OPEN 0x00200000 +#define PERLIO_F_FASTGETS 0x00400000 + +#define PerlIOBase(f) (*(f)) +#define PerlIOSelf(f,type) ((type *)PerlIOBase(f)) +#define PerlIONext(f) (&(PerlIOBase(f)->next)) + +/*--------------------------------------------------------------------------------------*/ + +extern PerlIO_funcs PerlIO_unix; +extern PerlIO_funcs PerlIO_perlio; +extern PerlIO_funcs PerlIO_stdio; +extern PerlIO_funcs PerlIO_crlf; +/* The EXT is need for Cygwin -- but why only for _pending? --jhi */ +EXT PerlIO_funcs PerlIO_pending; +#ifdef HAS_MMAP +extern PerlIO_funcs PerlIO_mmap; +#endif + +extern PerlIO *PerlIO_allocate(pTHX); + +#if O_BINARY != O_TEXT +#define PERLIO_STDTEXT "t" +#else +#define PERLIO_STDTEXT "" +#endif + +/*--------------------------------------------------------------------------------------*/ +/* Generic, or stub layer functions */ + +extern IV PerlIOBase_fileno (PerlIO *f); +extern IV PerlIOBase_pushed (PerlIO *f, const char *mode,const char *arg,STRLEN len); +extern IV PerlIOBase_popped (PerlIO *f); +extern SSize_t PerlIOBase_unread (PerlIO *f, const void *vbuf, Size_t count); +extern IV PerlIOBase_eof (PerlIO *f); +extern IV PerlIOBase_error (PerlIO *f); +extern void PerlIOBase_clearerr (PerlIO *f); +extern IV PerlIOBase_flush (PerlIO *f); +extern IV PerlIOBase_fill (PerlIO *f); +extern IV PerlIOBase_close (PerlIO *f); +extern void PerlIOBase_setlinebuf(PerlIO *f); + +extern IV PerlIOBase_noop_ok (PerlIO *f); +extern IV PerlIOBase_noop_fail (PerlIO *f); + +/*--------------------------------------------------------------------------------------*/ +/* perlio buffer layer + As this is reasonably generic its struct and "methods" are declared here + so they can be used to "inherit" from it. +*/ + +typedef struct +{ + struct _PerlIO base; /* Base "class" info */ + STDCHAR * buf; /* Start of buffer */ + STDCHAR * end; /* End of valid part of buffer */ + STDCHAR * ptr; /* Current position in buffer */ + Off_t posn; /* Offset of buf into the file */ + Size_t bufsiz; /* Real size of buffer */ + IV oneword; /* Emergency buffer */ +} PerlIOBuf; + +extern PerlIO * PerlIOBuf_fdopen (PerlIO_funcs *self, int fd, const char *mode); +extern PerlIO * PerlIOBuf_open (PerlIO_funcs *self, const char *path, const char *mode); +extern int PerlIOBuf_reopen (const char *path, const char *mode, PerlIO *f); +extern SSize_t PerlIOBuf_read (PerlIO *f, void *vbuf, Size_t count); +extern SSize_t PerlIOBuf_unread (PerlIO *f, const void *vbuf, Size_t count); +extern SSize_t PerlIOBuf_write (PerlIO *f, const void *vbuf, Size_t count); +extern IV PerlIOBuf_seek (PerlIO *f, Off_t offset, int whence); +extern Off_t PerlIOBuf_tell (PerlIO *f); +extern IV PerlIOBuf_close (PerlIO *f); +extern IV PerlIOBuf_flush (PerlIO *f); +extern IV PerlIOBuf_fill (PerlIO *f); +extern void PerlIOBuf_setlinebuf (PerlIO *f); +extern STDCHAR *PerlIOBuf_get_base (PerlIO *f); +extern Size_t PerlIOBuf_bufsiz (PerlIO *f); +extern STDCHAR *PerlIOBuf_get_ptr (PerlIO *f); +extern SSize_t PerlIOBuf_get_cnt (PerlIO *f); +extern void PerlIOBuf_set_ptrcnt (PerlIO *f, STDCHAR *ptr, SSize_t cnt); + +/*--------------------------------------------------------------------------------------*/ + +#endif /* _PERLIOL_H */ diff --git a/perlsdio.h b/perlsdio.h index c4a1179..fd990c0 100644 --- a/perlsdio.h +++ b/perlsdio.h @@ -1,25 +1,23 @@ -/* - * Although we may not want stdio to be used including here - * avoids issues where stdio.h has strange side effects - */ -#include - #ifdef PERLIO_IS_STDIO /* + * This file #define-s the PerlIO_xxx abstraction onto stdio functions. * Make this as close to original stdio as possible. */ -#define PerlIO FILE +#define PerlIO FILE #define PerlIO_stderr() stderr #define PerlIO_stdout() stdout #define PerlIO_stdin() stdin +#define PerlIO_fdupopen(f) (f) +#define PerlIO_isutf8(f) 0 + #define PerlIO_printf fprintf #define PerlIO_stdoutf printf -#define PerlIO_vprintf(f,fmt,a) vfprintf(f,fmt,a) +#define PerlIO_vprintf(f,fmt,a) vfprintf(f,fmt,a) #define PerlIO_write(f,buf,count) fwrite1(buf,1,count,f) #define PerlIO_open fopen #define PerlIO_fdopen fdopen -#define PerlIO_reopen freopen +#define PerlIO_reopen freopen #define PerlIO_close(f) fclose(f) #define PerlIO_puts(f,s) fputs(s,f) #define PerlIO_putc(f,c) fputc(c,f) @@ -43,10 +41,12 @@ (feof(f) ? EOF : getc(f)) # define PerlIO_read(f,buf,count) \ (feof(f) ? 0 : (SSize_t)fread(buf,1,count,f)) +# define PerlIO_tell(f) ftell(f) #else -# define PerlIO_ungetc(f,c) ungetc(c,f) # define PerlIO_getc(f) getc(f) +# define PerlIO_ungetc(f,c) ungetc(c,f) # define PerlIO_read(f,buf,count) (SSize_t)fread(buf,1,count,f) +# define PerlIO_tell(f) ftell(f) #endif #define PerlIO_eof(f) feof(f) #define PerlIO_getname(f,b) fgetname(f,b) @@ -54,33 +54,20 @@ #define PerlIO_fileno(f) fileno(f) #define PerlIO_clearerr(f) clearerr(f) #define PerlIO_flush(f) Fflush(f) -#define PerlIO_tell(f) ftell(f) -#if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64) -#define ftell ftello -#endif #if defined(VMS) && !defined(__DECC) - /* Old VAXC RTL doesn't reset EOF on seek; Perl folk seem to expect this */ -# define PerlIO_seek(f,o,w) (((f) && (*f) && ((*f)->_flag &= ~_IOEOF)),fseek(f,o,w)) +/* Old VAXC RTL doesn't reset EOF on seek; Perl folk seem to expect this */ +#define PerlIO_seek(f,o,w) (((f) && (*f) && ((*f)->_flag &= ~_IOEOF)),fseek(f,o,w)) #else # define PerlIO_seek(f,o,w) fseek(f,o,w) #endif -#if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64) -#define fseek fseeko -#endif -#ifdef HAS_FGETPOS -#define PerlIO_getpos(f,p) fgetpos(f,p) -#endif -#ifdef HAS_FSETPOS -#define PerlIO_setpos(f,p) fsetpos(f,p) -#endif #define PerlIO_rewind(f) rewind(f) #define PerlIO_tmpfile() tmpfile() -#define PerlIO_importFILE(f,fl) (f) -#define PerlIO_exportFILE(f,fl) (f) -#define PerlIO_findFILE(f) (f) -#define PerlIO_releaseFILE(p,f) ((void) 0) +#define PerlIO_importFILE(f,fl) (f) +#define PerlIO_exportFILE(f,fl) (f) +#define PerlIO_findFILE(f) (f) +#define PerlIO_releaseFILE(p,f) ((void) 0) #ifdef HAS_SETLINEBUF #define PerlIO_setlinebuf(f) setlinebuf(f); @@ -91,26 +78,36 @@ /* Now our interface to Configure's FILE_xxx macros */ #ifdef USE_STDIO_PTR -#define PerlIO_has_cntptr(f) 1 -#define PerlIO_get_ptr(f) FILE_ptr(f) -#define PerlIO_get_cnt(f) FILE_cnt(f) +#define PerlIO_has_cntptr(f) 1 +#define PerlIO_get_ptr(f) FILE_ptr(f) +#define PerlIO_get_cnt(f) FILE_cnt(f) #ifdef STDIO_CNT_LVALUE -#define PerlIO_canset_cnt(f) 1 +#define PerlIO_canset_cnt(f) 1 +#define PerlIO_set_cnt(f,c) (FILE_cnt(f) = (c)) #ifdef STDIO_PTR_LVALUE -#define PerlIO_fast_gets(f) 1 +#ifdef STDIO_PTR_LVAL_NOCHANGE_CNT +#define PerlIO_fast_gets(f) 1 #endif -#define PerlIO_set_cnt(f,c) (FILE_cnt(f) = (c)) -#else -#define PerlIO_canset_cnt(f) 0 +#endif /* STDIO_PTR_LVALUE */ +#else /* STDIO_CNT_LVALUE */ +#define PerlIO_canset_cnt(f) 0 #define PerlIO_set_cnt(f,c) abort() #endif #ifdef STDIO_PTR_LVALUE -#define PerlIO_set_ptrcnt(f,p,c) (FILE_ptr(f) = (p), PerlIO_set_cnt(f,c)) +#ifdef STDIO_PTR_LVAL_NOCHANGE_CNT +#define PerlIO_set_ptrcnt(f,p,c) STMT_START {FILE_ptr(f) = (p), PerlIO_set_cnt(f,c);} STMT_END +#else +#ifdef STDIO_PTR_LVAL_SETS_CNT +/* assert() may pre-process to ""; potential syntax error (FILE_ptr(), ) */ +#define PerlIO_set_ptrcnt(f,p,c) STMT_START {FILE_ptr(f) = (p); assert(FILE_cnt(f) == (c));} STMT_END +#define PerlIO_fast_gets(f) 1 #else #define PerlIO_set_ptrcnt(f,p,c) abort() #endif +#endif +#endif #else /* USE_STDIO_PTR */ @@ -124,209 +121,18 @@ #endif /* USE_STDIO_PTR */ #ifndef PerlIO_fast_gets -#define PerlIO_fast_gets(f) 0 +#define PerlIO_fast_gets(f) 0 #endif #ifdef FILE_base -#define PerlIO_has_base(f) 1 -#define PerlIO_get_base(f) FILE_base(f) -#define PerlIO_get_bufsiz(f) FILE_bufsiz(f) +#define PerlIO_has_base(f) 1 +#define PerlIO_get_base(f) FILE_base(f) +#define PerlIO_get_bufsiz(f) FILE_bufsiz(f) #else #define PerlIO_has_base(f) 0 #define PerlIO_get_base(f) (abort(),(void *)0) #define PerlIO_get_bufsiz(f) (abort(),0) #endif -#else /* PERLIO_IS_STDIO */ -#ifdef PERL_CORE -#ifndef PERLIO_NOT_STDIO -#define PERLIO_NOT_STDIO 1 -#endif -#endif -#ifdef PERLIO_NOT_STDIO -#if PERLIO_NOT_STDIO -/* - * Strong denial of stdio - make all stdio calls (we can think of) errors - */ -#include "nostdio.h" -#undef fprintf -#undef tmpfile -#undef fclose -#undef fopen -#undef vfprintf -#undef fgetc -#undef fputc -#undef fputs -#undef ungetc -#undef fread -#undef fwrite -#undef fgetpos -#undef fseek -#undef fsetpos -#undef ftell -#undef rewind -#undef fdopen -#undef popen -#undef pclose -#undef getw -#undef putw -#undef freopen -#undef setbuf -#undef setvbuf -#undef fscanf -#undef fgets -#undef getc_unlocked -#undef putc_unlocked -#define fprintf _CANNOT _fprintf_ -#define stdin _CANNOT _stdin_ -#define stdout _CANNOT _stdout_ -#define stderr _CANNOT _stderr_ -#define tmpfile() _CANNOT _tmpfile_ -#define fclose(f) _CANNOT _fclose_ -#define fflush(f) _CANNOT _fflush_ -#define fopen(p,m) _CANNOT _fopen_ -#define freopen(p,m,f) _CANNOT _freopen_ -#define setbuf(f,b) _CANNOT _setbuf_ -#define setvbuf(f,b,x,s) _CANNOT _setvbuf_ -#define fscanf _CANNOT _fscanf_ -#define vfprintf(f,fmt,a) _CANNOT _vfprintf_ -#define fgetc(f) _CANNOT _fgetc_ -#define fgets(s,n,f) _CANNOT _fgets_ -#define fputc(c,f) _CANNOT _fputc_ -#define fputs(s,f) _CANNOT _fputs_ -#define getc(f) _CANNOT _getc_ -#define putc(c,f) _CANNOT _putc_ -#define ungetc(c,f) _CANNOT _ungetc_ -#define fread(b,s,c,f) _CANNOT _fread_ -#define fwrite(b,s,c,f) _CANNOT _fwrite_ -#define fgetpos(f,p) _CANNOT _fgetpos_ -#define fseek(f,o,w) _CANNOT _fseek_ -#define fsetpos(f,p) _CANNOT _fsetpos_ -#define ftell(f) _CANNOT _ftell_ -#define rewind(f) _CANNOT _rewind_ -#define clearerr(f) _CANNOT _clearerr_ -#define feof(f) _CANNOT _feof_ -#define ferror(f) _CANNOT _ferror_ -#define __filbuf(f) _CANNOT __filbuf_ -#define __flsbuf(c,f) _CANNOT __flsbuf_ -#define _filbuf(f) _CANNOT _filbuf_ -#define _flsbuf(c,f) _CANNOT _flsbuf_ -#define fdopen(fd,p) _CANNOT _fdopen_ -#define fileno(f) _CANNOT _fileno_ -#if SFIO_VERSION < 20000101L -#define flockfile(f) _CANNOT _flockfile_ -#define ftrylockfile(f) _CANNOT _ftrylockfile_ -#define funlockfile(f) _CANNOT _funlockfile_ -#endif -#define getc_unlocked(f) _CANNOT _getc_unlocked_ -#define putc_unlocked(c,f) _CANNOT _putc_unlocked_ -#define popen(c,m) _CANNOT _popen_ -#define getw(f) _CANNOT _getw_ -#define putw(v,f) _CANNOT _putw_ -#define pclose(f) _CANNOT _pclose_ - -#else /* if PERLIO_NOT_STDIO */ -/* - * PERLIO_NOT_STDIO defined as 0 - * Declares that both PerlIO and stdio can be used - */ -#endif /* if PERLIO_NOT_STDIO */ -#else /* ifdef PERLIO_NOT_STDIO */ -/* - * PERLIO_NOT_STDIO not defined - * This is "source level" stdio compatibility mode. - */ -#include "nostdio.h" -#undef FILE -#define FILE PerlIO -#undef fprintf -#undef tmpfile -#undef fclose -#undef fopen -#undef vfprintf -#undef fgetc -#undef getc_unlocked -#undef fputc -#undef putc_unlocked -#undef fputs -#undef ungetc -#undef fread -#undef fwrite -#undef fgetpos -#undef fseek -#undef fsetpos -#undef ftell -#undef rewind -#undef fdopen -#undef popen -#undef pclose -#undef getw -#undef putw -#undef freopen -#undef setbuf -#undef setvbuf -#undef fscanf -#undef fgets -#define fprintf PerlIO_printf -#define stdin PerlIO_stdin() -#define stdout PerlIO_stdout() -#define stderr PerlIO_stderr() -#define tmpfile() PerlIO_tmpfile() -#define fclose(f) PerlIO_close(f) -#define fflush(f) PerlIO_flush(f) -#define fopen(p,m) PerlIO_open(p,m) -#define vfprintf(f,fmt,a) PerlIO_vprintf(f,fmt,a) -#define fgetc(f) PerlIO_getc(f) -#define fputc(c,f) PerlIO_putc(f,c) -#define fputs(s,f) PerlIO_puts(f,s) -#define getc(f) PerlIO_getc(f) -#ifdef getc_unlocked -#undef getc_unlocked -#endif -#define getc_unlocked(f) PerlIO_getc(f) -#define putc(c,f) PerlIO_putc(f,c) -#ifdef putc_unlocked -#undef putc_unlocked -#endif -#define putc_unlocked(c,f) PerlIO_putc(c,f) -#define ungetc(c,f) PerlIO_ungetc(f,c) -#if 0 -/* return values of read/write need work */ -#define fread(b,s,c,f) PerlIO_read(f,b,(s*c)) -#define fwrite(b,s,c,f) PerlIO_write(f,b,(s*c)) -#else -#define fread(b,s,c,f) _CANNOT fread -#define fwrite(b,s,c,f) _CANNOT fwrite -#endif -#define fgetpos(f,p) PerlIO_getpos(f,p) -#define fseek(f,o,w) PerlIO_seek(f,o,w) -#define fsetpos(f,p) PerlIO_setpos(f,p) -#define ftell(f) PerlIO_tell(f) -#define rewind(f) PerlIO_rewind(f) -#define clearerr(f) PerlIO_clearerr(f) -#define feof(f) PerlIO_eof(f) -#define ferror(f) PerlIO_error(f) -#define fdopen(fd,p) PerlIO_fdopen(fd,p) -#define fileno(f) PerlIO_fileno(f) -#define popen(c,m) my_popen(c,m) -#define pclose(f) my_pclose(f) - -#define __filbuf(f) _CANNOT __filbuf_ -#define _filbuf(f) _CANNOT _filbuf_ -#define __flsbuf(c,f) _CANNOT __flsbuf_ -#define _flsbuf(c,f) _CANNOT _flsbuf_ -#define getw(f) _CANNOT _getw_ -#define putw(v,f) _CANNOT _putw_ -#if SFIO_VERSION < 20000101L -#define flockfile(f) _CANNOT _flockfile_ -#define ftrylockfile(f) _CANNOT _ftrylockfile_ -#define funlockfile(f) _CANNOT _funlockfile_ -#endif -#define freopen(p,m,f) _CANNOT _freopen_ -#define setbuf(f,b) _CANNOT _setbuf_ -#define setvbuf(f,b,x,s) _CANNOT _setvbuf_ -#define fscanf _CANNOT _fscanf_ -#define fgets(s,n,f) _CANNOT _fgets_ -#endif /* ifdef PERLIO_NOT_STDIO */ #endif /* PERLIO_IS_STDIO */ diff --git a/perlsfio.h b/perlsfio.h index d0f6471..de7e9ac 100644 --- a/perlsfio.h +++ b/perlsfio.h @@ -5,7 +5,7 @@ /* sfio 2000 changed _stdopen to _stdfdopen */ #if SFIO_VERSION >= 20000101L -#define _stdopen _stdfdopen +#define _stdopen _stdfdopen #endif extern Sfio_t* _stdopen _ARG_((int, const char*)); @@ -16,9 +16,11 @@ extern int _stdprintf _ARG_((const char*, ...)); #define PerlIO_stdout() sfstdout #define PerlIO_stdin() sfstdin +#define PerlIO_isutf8(f) 0 + #define PerlIO_printf sfprintf #define PerlIO_stdoutf _stdprintf -#define PerlIO_vprintf(f,fmt,a) sfvprintf(f,fmt,a) +#define PerlIO_vprintf(f,fmt,a) sfvprintf(f,fmt,a) #define PerlIO_read(f,buf,count) sfread(f,buf,count) #define PerlIO_write(f,buf,count) sfwrite(f,buf,count) #define PerlIO_open(path,mode) sfopen(NULL,path,mode) @@ -35,7 +37,12 @@ extern int _stdprintf _ARG_((const char*, ...)); #define PerlIO_fileno(f) sffileno(f) #define PerlIO_clearerr(f) sfclrerr(f) #define PerlIO_flush(f) sfsync(f) +#if 0 +/* This breaks tests */ +#define PerlIO_tell(f) sfseek(f,0,1|SF_SHARE) +#else #define PerlIO_tell(f) sftell(f) +#endif #define PerlIO_seek(f,o,w) sfseek(f,o,w) #define PerlIO_rewind(f) (void) sfseek((f),0L,0) #define PerlIO_tmpfile() sftmp(0) @@ -49,15 +56,15 @@ extern int _stdprintf _ARG_((const char*, ...)); /* Now our interface to equivalent of Configure's FILE_xxx macros */ -#define PerlIO_has_cntptr(f) 1 +#define PerlIO_has_cntptr(f) 1 #define PerlIO_get_ptr(f) ((f)->next) #define PerlIO_get_cnt(f) ((f)->endr - (f)->next) -#define PerlIO_canset_cnt(f) 1 -#define PerlIO_fast_gets(f) 1 -#define PerlIO_set_ptrcnt(f,p,c) ((f)->next = (unsigned char *)(p)) -#define PerlIO_set_cnt(f,c) 1 +#define PerlIO_canset_cnt(f) 1 +#define PerlIO_fast_gets(f) 1 +#define PerlIO_set_ptrcnt(f,p,c) STMT_START {(f)->next = (unsigned char *)(p); assert(PerlIO_get_cnt(f) == (c));} STMT_END +#define PerlIO_set_cnt(f,c) STMT_START {(f)->next = (f)->endr - (c);} STMT_END -#define PerlIO_has_base(f) 1 +#define PerlIO_has_base(f) 1 #define PerlIO_get_base(f) ((f)->data) #define PerlIO_get_bufsiz(f) ((f)->endr - (f)->data) diff --git a/perly.c b/perly.c index d03d3de..2b5108f 100644 --- a/perly.c +++ b/perly.c @@ -1747,7 +1747,7 @@ case 35: break; case 37: #line 269 "perly.y" -{ (void)scan_num("1"); yyval.opval = yylval.opval; } +{ (void)scan_num("1", &yylval); yyval.opval = yylval.opval; } break; case 39: #line 274 "perly.y" diff --git a/perly.y b/perly.y index 5170b36..74802f4 100644 --- a/perly.y +++ b/perly.y @@ -1,6 +1,6 @@ /* perly.y * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -266,7 +266,7 @@ nexpr : /* NULL */ ; texpr : /* NULL means true */ - { (void)scan_num("1"); $$ = yylval.opval; } + { (void)scan_num("1", &yylval); $$ = yylval.opval; } | expr ; diff --git a/pod/Makefile.SH b/pod/Makefile.SH index ae6262c..58ce9be 100644 --- a/pod/Makefile.SH +++ b/pod/Makefile.SH @@ -64,6 +64,7 @@ POD2HTML = pod2html \ --libpods=perlfunc:perlguts:perlvar:perlrun:perlop PERL = ../miniperl +PERLILIB = $(PERL) -I../lib REALPERL = ../perl all: $(CONVERTERS) man @@ -73,7 +74,9 @@ converters: $(CONVERTERS) regen_pods: perlmodlib.pod toc buildtoc: buildtoc.PL perl.pod ../MANIFEST - $(PERL) -I ../lib buildtoc.PL + $(PERLILIB) buildtoc.PL + +perltoc.pod: buildtoc man: pod2man $(MAN) @@ -82,7 +85,7 @@ html: pod2html $(HTML) tex: pod2latex $(TEX) toc: buildtoc - $(PERL) -I../lib buildtoc + $(PERLILIB) buildtoc .SUFFIXES: .pm .pod diff --git a/pod/buildtoc.PL b/pod/buildtoc.PL index 3819308..f2dba95 100644 --- a/pod/buildtoc.PL +++ b/pod/buildtoc.PL @@ -154,12 +154,16 @@ if (-d "pod") { perlamiga perlcygwin perldos + perlepoc perlhpux perlmachten + perlmpeix perlos2 perlos390 perlposix-bc + perlsolaris perlvms + perlvos perlwin32 ); @@ -168,12 +172,16 @@ if (-d "pod") { perlamiga perlcygwin perldos + perlepoc perlhpux perlmachten + perlmpeix perlos2 perlos390 perlposix-bc + perlsolaris perlvms + perlvos perlwin32 ); for (@ARCHPODS) { s/$/.pod/ } @@ -328,7 +336,7 @@ podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] ); Here should be listed all the extra programs' documentation, but they don't all have manual pages yet: - =over + =over 4 =item a2p @@ -381,13 +389,13 @@ sub podset { } if (s/^=head1 (.*)/=item $1/) { unhead2(); - output "=over\n\n" unless $inhead1; + output "=over 4\n\n" unless $inhead1; $inhead1 = 1; output $_; nl(); next; } if (s/^=head2 (.*)/=item $1/) { unitem(); - output "=over\n\n" unless $inhead2; + output "=over 4\n\n" unless $inhead2; $inhead2 = 1; output $_; nl(); next; } @@ -399,7 +407,7 @@ sub podset { s/\s+$//; next if /^[\d.]+$/; next if $pod eq 'perlmodlib' && /^ftp:/; - ##print "=over\n\n" unless $initem; + ##print "=over 4\n\n" unless $initem; output ", " if $initem; $initem = 1; s/\.$//; diff --git a/pod/perl.pod b/pod/perl.pod index 946d6f2..4e08cc8 100644 --- a/pod/perl.pod +++ b/pod/perl.pod @@ -108,12 +108,16 @@ For ease of access, the Perl manual has been split up into several sections: perlamiga Perl notes for Amiga perlcygwin Perl notes for Cygwin perldos Perl notes for DOS + perlepoc Perl notes for EPOC perlhpux Perl notes for HP-UX perlmachten Perl notes for Power MachTen + perlmpeix Perl notes for MPE/iX perlos2 Perl notes for OS/2 perlos390 Perl notes for OS/390 perlposix-bc Perl notes for POSIX-BC + perlsolaris Perl notes for Solaris perlvms Perl notes for VMS + perlvos Perl notes for Stratus VOS perlwin32 Perl notes for Windows (If you're intending to read these straight through for the first time, @@ -187,58 +191,85 @@ But wait, there's more... Begun in 1993 (see L), Perl version 5 is nearly a complete rewrite that provides the following additional benefits: -=over +=over 4 -=item * modularity and reusability using innumerable modules +=item * + +modularity and reusability using innumerable modules Described in L, L, and L. -=item * embeddable and extensible +=item * + +embeddable and extensible Described in L, L, L, L, L, and L. -=item * roll-your-own magic variables (including multiple simultaneous DBM implementations) +=item * + +roll-your-own magic variables (including multiple simultaneous DBM implementations) Described in L and L. -=item * subroutines can now be overridden, autoloaded, and prototyped +=item * + +subroutines can now be overridden, autoloaded, and prototyped Described in L. -=item * arbitrarily nested data structures and anonymous functions +=item * + +arbitrarily nested data structures and anonymous functions Described in L, L, L, and L. -=item * object-oriented programming +=item * + +object-oriented programming Described in L, L, and L. -=item * compilability into C code or Perl bytecode +=item * + +compilability into C code or Perl bytecode Described in L and L. -=item * support for light-weight processes (threads) +=item * + +support for light-weight processes (threads) Described in L and L. -=item * support for internationalization, localization, and Unicode +=item * + +support for internationalization, localization, and Unicode Described in L and L. -=item * lexical scoping +=item * + +lexical scoping Described in L. -=item * regular expression enhancements +=item * + +regular expression enhancements Described in L, with additional examples in L. -=item * enhanced debugger and interactive Perl environment, with integrated editor support +=item * + +enhanced debugger and interactive Perl environment, +with integrated editor support Described in L. -=item * POSIX 1003.1 compliant library +=item * + +POSIX 1003.1 compliant library Described in L. diff --git a/pod/perl5004delta.pod b/pod/perl5004delta.pod index 8cec3ab..429cba9 100644 --- a/pod/perl5004delta.pod +++ b/pod/perl5004delta.pod @@ -24,7 +24,10 @@ problems. See the F file in the distribution for details. C<%ENV = ()> and C<%ENV = @list> now work as expected (except on VMS where it generates a fatal error). -=head2 "Can't locate Foo.pm in @INC" error now lists @INC +=head2 Change to "Can't locate Foo.pm in @INC" error + +The error "Can't locate Foo.pm in @INC" now lists the contents of @INC +for easier debugging. =head2 Compilation option: Binary compatibility with 5.003 @@ -198,7 +201,7 @@ hole was just plugged. The new restrictions when tainting include: -=over +=over 4 =item No glob() or <*> @@ -258,7 +261,7 @@ the F file for how to use it. =head2 New and changed syntax -=over +=over 4 =item $coderef->(PARAMS) @@ -276,7 +279,7 @@ S{FOO}->($bar) >>>. =head2 New and changed builtin constants -=over +=over 4 =item __PACKAGE__ @@ -289,7 +292,7 @@ into strings. =head2 New and changed builtin variables -=over +=over 4 =item $^E @@ -322,7 +325,7 @@ there is no C long name for this variable. =head2 New and changed builtin functions -=over +=over 4 =item delete on slices @@ -544,7 +547,7 @@ subroutine: The C package automatically contains the following methods that are inherited by all other classes: -=over +=over 4 =item isa(CLASS) @@ -593,7 +596,7 @@ have C available as a plain subroutine in the current package. See L for other kinds of tie()s. -=over +=over 4 =item TIEHANDLE classname, LIST @@ -687,7 +690,7 @@ install the optional module Devel::Peek.) Three new compilation flags are recognized by malloc.c. (They have no effect if perl is compiled with system malloc().) -=over +=over 4 =item -DPERL_EMERGENCY_SBRK @@ -779,7 +782,7 @@ See F in the perl distribution. Six new pragmatic modules exist: -=over +=over 4 =item use autouse MODULE => qw(sub1 sub2 sub3) @@ -979,7 +982,7 @@ those who need trigonometric functions only for real numbers. There have been quite a few changes made to DB_File. Here are a few of the highlights: -=over +=over 4 =item * @@ -1045,7 +1048,7 @@ For example, you can now say =head2 pod2html -=over +=over 4 =item Sends converted HTML to standard output @@ -1058,7 +1061,7 @@ Use the B<--outfile=FILENAME> option to write to a file. =head2 xsubpp -=over +=over 4 =item C XSUBs now default to returning nothing @@ -1083,7 +1086,7 @@ XSUB's return type is really C. =head1 C Language API Changes -=over +=over 4 =item C and C @@ -1124,7 +1127,7 @@ which can be more efficient. See L for details. Many of the base and library pods were updated. These new pods are included in section 1: -=over +=over 4 =item L @@ -1177,7 +1180,7 @@ increasing order of desperation): (X) A very fatal error (nontrappable). (A) An alien error message (not generated by Perl). -=over +=over 4 =item "my" variable %s masks earlier declaration in same scope @@ -1429,7 +1432,7 @@ assigning to it and when evaluating its argument, while C<@foo{&bar}> behaves like a list when you assign to it, and provides a list context to its subscript, which can do weird things if you're expecting only one subscript. -=item Stub found while resolving method `%s' overloading `%s' in package `%s' +=item Stub found while resolving method `%s' overloading `%s' in %s (P) Overloading resolution over @ISA tree may be broken by importing stubs. Stubs should never be implicitly created, but explicit calls to C diff --git a/pod/perl5005delta.pod b/pod/perl5005delta.pod index b133c0d..4b50f40 100644 --- a/pod/perl5005delta.pod +++ b/pod/perl5005delta.pod @@ -63,11 +63,15 @@ the new features in this release. =over 4 -=item Core sources now require ANSI C compiler +=item * + +Core sources now require ANSI C compiler An ANSI C compiler is now B to build perl. See F. -=item All Perl global variables must now be referenced with an explicit prefix +=item * + +All Perl global variables must now be referenced with an explicit prefix All Perl global variables that are visible for use by extensions now have a C prefix. New extensions should C refer to perl globals @@ -87,7 +91,9 @@ support may cease in a future release. See L. -=item Enabling threads has source compatibility issues +=item * + +Enabling threads has source compatibility issues Perl built with threading enabled requires extensions to use the new C macro to initialize the handle to access per-thread data. @@ -525,7 +531,7 @@ The hints files for most Unix platforms have seen incremental improvements. =head2 New Modules -=over +=over 4 =item B @@ -596,7 +602,7 @@ Various pragmata to control behavior of regular expressions. =head2 Changes in existing modules -=over +=over 4 =item Benchmark @@ -702,7 +708,7 @@ L gives a tutorial on threads. =head1 New Diagnostics -=over +=over 4 =item Ambiguous call resolved as CORE::%s(), qualify as such or use & @@ -859,7 +865,7 @@ are outside the range which can be represented by integers internally. One possible workaround is to force Perl to use magical string increment by prepending "0" to your numbers. -=item Recursive inheritance detected while looking for method '%s' in package '%s' +=item Recursive inheritance detected while looking for method '%s' %s (F) More than 100 levels of inheritance were encountered while invoking a method. Probably indicates an unintended loop in your inheritance hierarchy. @@ -916,7 +922,7 @@ fix the problem can be found in L. =head1 Obsolete Diagnostics -=over +=over 4 =item Can't mktemp() diff --git a/pod/perl56delta.pod b/pod/perl56delta.pod index 9f30314..fc0d668 100644 --- a/pod/perl56delta.pod +++ b/pod/perl56delta.pod @@ -786,7 +786,7 @@ regardless of whether or not the array has been used or declared already. The fatal error has been downgraded to an optional warning: Possible unintended interpolation of @example in string - + This warns you that C<"fred@example.com"> is going to turn into C if you don't backslash the C<@>. See http://www.plover.com/~mjd/perl/at-error.html for more details @@ -1837,7 +1837,8 @@ run in compile-only mode. Since this is typically not the expected behavior, END blocks are not executed anymore when the C<-c> switch is used, or if compilation fails. -See L for how to run things when the compile phase ends. +See L for how to run things when the compile +phase ends. =head2 Potential to leak DATA filehandles @@ -2630,9 +2631,12 @@ but still allowed it. In Perl 5.6.0 and later, C<"$$1"> always means C<"${$1}">. -=item delete(), values() and C<\(%h)> operate on aliases to values, not copies +=item delete(), each(), values() and C<\(%h)> + +operate on aliases to values, not copies -delete(), each(), values() and hashes in a list context return the actual +delete(), each(), values() and hashes (e.g. C<\(%h)>) +in a list context return the actual values in the hash, instead of copies (as they used to in earlier versions). Typical idioms for using these constructs copy the returned values, but this can make a significant difference when @@ -2782,7 +2786,7 @@ See L for further information about that. =head2 Compatible C Source API Changes -=over +=over 4 =item C is now C @@ -2912,7 +2916,9 @@ include the following: =item The DB module -=item The regular expression constructs C<(?{ code })> and C<(??{ code })> +=item The regular expression code constructs: + +C<(?{ code })> and C<(??{ code })> =back diff --git a/pod/perlapi.pod b/pod/perlapi.pod index 98abdc1..f5596e2 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -287,6 +287,19 @@ Returns the stash of the CV. =for hackers Found in file cv.h +=item cv_const_sv + +If C is a constant sub eligible for inlining. returns the constant +value returned by the sub. Otherwise, returns NULL. + +Constant subs can be created with C or as described in +L. + + SV* cv_const_sv(CV* cv) + +=for hackers +Found in file op.c + =item dMARK Declare a stack marker variable, C, for the XSUB. See C and @@ -748,7 +761,7 @@ hash and returned to the caller. The C is the length of the key. The C value will normally be zero; if set to G_DISCARD then NULL will be returned. - SV* hv_delete(HV* tb, const char* key, U32 klen, I32 flags) + SV* hv_delete(HV* tb, const char* key, I32 klen, I32 flags) =for hackers Found in file hv.c @@ -770,7 +783,7 @@ Found in file hv.c Returns a boolean indicating whether the specified hash key exists. The C is the length of the key. - bool hv_exists(HV* tb, const char* key, U32 klen) + bool hv_exists(HV* tb, const char* key, I32 klen) =for hackers Found in file hv.c @@ -796,7 +809,7 @@ dereferencing it to a C. See L for more information on how to use this function on tied hashes. - SV** hv_fetch(HV* tb, const char* key, U32 klen, I32 lval) + SV** hv_fetch(HV* tb, const char* key, I32 klen, I32 lval) =for hackers Found in file hv.c @@ -907,7 +920,7 @@ the call, and decrementing it if the function returned NULL. See L for more information on how to use this function on tied hashes. - SV** hv_store(HV* tb, const char* key, U32 klen, SV* val, U32 hash) + SV** hv_store(HV* tb, const char* key, I32 klen, SV* val, U32 hash) =for hackers Found in file hv.c @@ -1032,7 +1045,8 @@ Found in file scope.h =item looks_like_number Test if an the content of an SV looks like a number (or is a -number). +number). C and C are treated as numbers (so will not +issue a non-numeric warning), even if your atof() doesn't grok them. I32 looks_like_number(SV* sv) @@ -1162,7 +1176,7 @@ Found in file handy.h Creates a constant sub equivalent to Perl C which is eligible for inlining at compile-time. - void newCONSTSUB(HV* stash, char* name, SV* sv) + CV* newCONSTSUB(HV* stash, char* name, SV* sv) =for hackers Found in file op.c @@ -1270,7 +1284,7 @@ The idea here is that as string table is used for shared hash keys these strings will have SvPVX == HeKEY and hash lookup will avoid string compare. - SV* newSVpvn_share(const char* s, STRLEN len, U32 hash) + SV* newSVpvn_share(const char* s, I32 len, U32 hash) =for hackers Found in file sv.c @@ -1430,7 +1444,7 @@ Found in file perl.c =item PL_DBsingle When Perl is run in debugging mode, with the B<-d> switch, this SV is a -boolean which indicates whether subs are being single-stepped. +boolean which indicates whether subs are being single-stepped. Single-stepping is automatically turned on after every step. This is the C variable which corresponds to Perl's $DB::single variable. See C. @@ -1474,10 +1488,10 @@ Found in file intrpvar.h =item PL_modglobal -C is a general purpose, interpreter global HV for use by +C is a general purpose, interpreter global HV for use by extensions that need to keep information on a per-interpreter basis. -In a pinch, it can also be used as a symbol table for extensions -to share data among each other. It is a good idea to use keys +In a pinch, it can also be used as a symbol table for extensions +to share data among each other. It is a good idea to use keys prefixed by the package name of the extension that owns the data. HV* PL_modglobal @@ -2421,6 +2435,15 @@ Type flag for blessed scalars. See C. =for hackers Found in file sv.h +=item SvUOK + +Returns a boolean indicating whether the SV contains an unsigned integer. + + void SvUOK(SV* sv) + +=for hackers +Found in file sv.h + =item SvUPGRADE Used to upgrade an SV to a more complex form. Uses C to @@ -2559,8 +2582,9 @@ Found in file sv.c =item sv_catsv -Concatenates the string from SV C onto the end of the string in SV -C. Handles 'get' magic, but not 'set' magic. See C. +Concatenates the string from SV C onto the end of the string in +SV C. Modifies C but not C. Handles 'get' magic, but +not 'set' magic. See C. void sv_catsv(SV* dsv, SV* ssv) @@ -3050,13 +3074,29 @@ Found in file sv.c Unsets the RV status of the SV, and decrements the reference count of whatever was being referenced by the RV. This can almost be thought of -as a reversal of C. See C. +as a reversal of C. This is C with the C +being zero. See C. void sv_unref(SV* sv) =for hackers Found in file sv.c +=item sv_unref_flags + +Unsets the RV status of the SV, and decrements the reference count of +whatever was being referenced by the RV. This can almost be thought of +as a reversal of C. The C argument can contain +C to force the reference count to be decremented +(otherwise the decrementing is conditional on the reference count being +different from one or the reference being a readonly SV). +See C. + + void sv_unref_flags(SV* sv, U32 flags) + +=for hackers +Found in file sv.c + =item sv_upgrade Upgrade an SV to a more complex form. Use C. See @@ -3190,6 +3230,44 @@ string, false otherwise. =for hackers Found in file utf8.c +=item utf8_distance + +Returns the number of UTF8 characters between the UTF-8 pointers C +and C. + +WARNING: use only if you *know* that the pointers point inside the +same UTF-8 buffer. + + IV utf8_distance(U8 *a, U8 *b) + +=for hackers +Found in file utf8.c + +=item utf8_hop + +Return the UTF-8 pointer C displaced by C characters, either +forward or backward. + +WARNING: do not use the following unless you *know* C is within +the UTF-8 data pointed to by C *and* that on entry C is aligned +on the first byte of character or just after the last byte of a character. + + U8* utf8_hop(U8 *s, I32 off) + +=for hackers +Found in file utf8.c + +=item utf8_length + +Return the length of the UTF-8 char encoded string C in characters. +Stops at C (inclusive). If C s> or if the scan would end +up past C, croaks. + + STRLEN utf8_length(U8* s, U8 *e) + +=for hackers +Found in file utf8.c + =item utf8_to_bytes Converts a string C of length C from UTF8 into byte encoding. @@ -3205,32 +3283,35 @@ Found in file utf8.c =item utf8_to_uv Returns the character value of the first character in the string C -which is assumed to be in UTF8 encoding; C will be set to the -length, in bytes, of that character, and the pointer C will be -advanced to the end of the character. +which is assumed to be in UTF8 encoding and no longer than C; +C will be set to the length, in bytes, of that character. -If C does not point to a well-formed UTF8 character, an optional UTF8 -warning is produced. +If C does not point to a well-formed UTF8 character, the behaviour +is dependent on the value of C: if it contains UTF8_CHECK_ONLY, +it is assumed that the caller will raise a warning, and this function +will silently just set C to C<-1> and return zero. If the +C does not contain UTF8_CHECK_ONLY, warnings about +malformations will be given, C will be set to the expected +length of the UTF-8 character in bytes, and zero will be returned. - U8* s utf8_to_uv(I32 *retlen) +The C can also contain various flags to allow deviations from +the strict UTF-8 encoding (see F). + + U8* s utf8_to_uv(STRLEN curlen, STRLEN *retlen, U32 flags) =for hackers Found in file utf8.c -=item utf8_to_uv_chk +=item utf8_to_uv_simple Returns the character value of the first character in the string C which is assumed to be in UTF8 encoding; C will be set to the -length, in bytes, of that character, and the pointer C will be -advanced to the end of the character. +length, in bytes, of that character. -If C does not point to a well-formed UTF8 character, the behaviour -is dependent on the value of C: if this is true, it is -assumed that the caller will raise a warning, and this function will -set C to C<-1> and return. If C is not true, an optional UTF8 -warning is produced. +If C does not point to a well-formed UTF8 character, zero is +returned and retlen is set, if possible, to -1. - U8* s utf8_to_uv_chk(I32 *retlen, I32 checking) + U8* s utf8_to_uv_simple(STRLEN *retlen) =for hackers Found in file utf8.c diff --git a/pod/perldebguts.pod b/pod/perldebguts.pod index 742423b..20cc546 100644 --- a/pod/perldebguts.pod +++ b/pod/perldebguts.pod @@ -23,7 +23,7 @@ frame was called with are copied to the @DB::args array. The general mechanisms is enabled by calling Perl with the B<-d> switch, the following additional features are enabled (cf. L): -=over +=over 4 =item * @@ -402,7 +402,7 @@ shorter than 7 chars. The fields of interest which may appear in the last line are -=over +=over 4 =item C I C I @@ -693,7 +693,7 @@ Devel::Peek module. Here is some explanation of that format: -=over +=over 4 =item C @@ -840,7 +840,7 @@ per glob - for glob name, and glob stringification magic. Here are explanations for other Is above: -=over +=over 4 =item C<717> @@ -894,7 +894,7 @@ these categories. If warn() string starts with -=over +=over 4 =item C diff --git a/pod/perldebtut.pod b/pod/perldebtut.pod index 2916897..ece5848 100644 --- a/pod/perldebtut.pod +++ b/pod/perldebtut.pod @@ -495,7 +495,7 @@ And a print to show what values we're currently using: DB<1> p $deg, $num f33.3 - + We can put another break point on any line beginning with a colon, we'll use line 17 as that's just as we come out of the subroutine, and we'd like to pause there later on: @@ -538,7 +538,7 @@ it for inspection. In this case though, we simply continue down to line 29: DB<4> c 29 main::f2c(temp:29): return $c; - + And have a look at the return value: DB<5> p $c @@ -616,7 +616,7 @@ the DEBUGGING flag for this one: floating `'$ at 4..2147483647 (checking floating) stclass `EXACTF ' anchored(BOL) minlen 4 Omitting $` $& $' support. - + EXECUTING... Freeing REx: `^pe(a)*rl$' @@ -656,7 +656,7 @@ script from the command-line, try something like this: > perl -d my_cgi.pl -nodebug -Of course 'L' and L will tell you more. +Of course L and L will tell you more. =head1 GUIs diff --git a/pod/perldebug.pod b/pod/perldebug.pod index faff39b..01f35e1 100644 --- a/pod/perldebug.pod +++ b/pod/perldebug.pod @@ -82,7 +82,7 @@ recursively, unlike the real C function in Perl. See L if you'd like to do this yourself. The output format is governed by multiple options described under -L<"Options">. +L<"Configurable Options">. =item V [pkg [vars]] @@ -308,8 +308,8 @@ For historical reasons, the C<=value> is optional, but defaults to 1 only where it is safe to do so--that is, mostly for Boolean options. It is always better to assign a specific value using C<=>. The C