diff options
author | Mark Murray <markm@FreeBSD.org> | 2002-03-16 20:14:30 +0000 |
---|---|---|
committer | Mark Murray <markm@FreeBSD.org> | 2002-03-16 20:14:30 +0000 |
commit | fc75d0664419eb8c8f264d8f298df2cd155c8966 (patch) | |
tree | 4cf1274fa3ca68f7ecf6a3051e0c2243e378afc5 /contrib/perl5 | |
parent | 8947993a910c7e5d244200623325b9fcb54a9eee (diff) | |
download | src-fc75d0664419eb8c8f264d8f298df2cd155c8966.tar.gz src-fc75d0664419eb8c8f264d8f298df2cd155c8966.zip |
Vendor import Perl 5.6.1
Notes
Notes:
svn path=/vendor/perl5/dist/; revision=92442
Diffstat (limited to 'contrib/perl5')
822 files changed, 62339 insertions, 23765 deletions
diff --git a/contrib/perl5/AUTHORS b/contrib/perl5/AUTHORS index f978b51bd895..331f3aff2443 100644 --- a/contrib/perl5/AUTHORS +++ b/contrib/perl5/AUTHORS @@ -1,120 +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@slipper.ip.lu -doug Doug MacEachern dougm@pobox.com -doughera Andy Dougherty doughera@lafcol.lafayette.edu -gbarr Graham Barr gbarr@ti.com -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 -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@media.mit.edu -jvromans Johan Vromans jvromans@squirrel.nl -k Andreas Koenig andreas.koenig@franz.ww.tu-berlin.de -kjahds Kenneth Albanowski kjahds@kjahds.com -krishna Krishna Sethuraman krishna@sgi.com -kstar Kurt D. Starsinic kstar@isinet.com -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 -mike Mike Stok mike@stok.co.uk -millert Todd Miller millert@openbsd.org -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 -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 -spider Spider Boardman spider@Orb.Nashua.NH.US -smccam Stephen McCamant smccam@uclink4.berkeley.edu -sugalskd Dan Sugalski sugalskd@osshe.edu -sundstrom David Sundstrom sunds@asictest.sc.ti.com -tchrist Tom Christiansen tchrist@perl.com -thomas.dorner Dorner Thomas Thomas.Dorner@start.de -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 - -PUMPKING gsar -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 vms,vmesa,posixbc -filespec kjahds -freebsd roberto -hpux okamoto,jhi -irix scotth,krishna,jfs,kstar -jpl gibreel -linux kjahds,kstar -locale jhi,domo -lynxos lynxos -machten domo -mm makemaker -mvs pvhp -netbsd jhi -openbsd millert -os2 ilya -plan9 lutherl -posix-bc thomas.dorner -powerux tom.horsley -qnx allen -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 <aaron@iglou.com> +Abigail <abigail@foad.org> +Achim Bohnet <ach@mpe.mpg.de> +Adam Krolnik <adamk@gypsy.cyrix.com> +Akim Demaille <akim@epita.fr> +Alan Burlison <Alan.Burlison@uk.sun.com> +Alan Champion <achampio@lehman.com> +Alan Harder <Alan.Harder@Ebay.Sun.COM> +Alan Modra +Albert Chin-A-Young <china@thewrittenword.com> +Albert Dvornik <bert@genscan.com> +Alexander Smishlajev <als@turnhere.com> +Allen Smith <easmith@beatrice.rutgers.edu> +Ambrose Kofi Laing +Andreas Klussmann <andreas@infosys.heitec.de> +Andreas König <a.koenig@mind.de> +Andreas Schwab <schwab@suse.de> +Andrew Bettison <andrewb@zip.com.au> +Andrew Cohen <cohen@andy.bu.edu> +Andrew M. Langmead <aml@world.std.com> +Andrew Pimlott <pimlott@abel.math.harvard.edu> +Andrew Vignaux <ajv@nz.sangacorp.com> +Andrew Wilcox <awilcox@maine.com> +Andy Dougherty <doughera@lafayette.edu> +Anno Siegel <anno4000@lublin.zrz.tu-berlin.de> +Anthony David <adavid@netinfo.com.au> +Anton Berezin <tobez@tobez.org> +Art Green <Art_Green@mercmarine.com> +Artur <artur@vogon-solutions.com> +Barrie Slaymaker <barries@slaysys.com> +Barry Friedman +Ben Tilly <ben_tilly@hotmail.com> +Benjamin Low <b.d.low@unsw.edu.au> +Benjamin Stuhl <sho_pi@hotmail.com> +Benjamin Sugars <bsugars@canoe.ca> +Bernard Quatermass <bernard@quatermass.co.uk> +Bill Campbell <bill@celestial.com> +Bill Glicker <billg@burrelles.com> +Billy Constantine <wdconsta@cs.adelaide.edu.au> +Blair Zajac <bzajac@geostaff.com> +Boyd Gerber <gerberb@zenez.com> +Brad Appleton <bradapp@enteract.com> +Brad Howerter <bhower@wgc.woodward.com> +Brad Hughes <brad@tgsmc.com> +Brad Lanam <bll@gentoo.com> +Brent B. Powers <powers@ml.com> +Brian Callaghan <callagh@itginc.com> +Brian Clarke <clarke@appliedmeta.com> +Brian Grossman +Brian Harrison <brie@corp.home.net> +Brian Jepson <bjepson@home.com> +Brian Katzung +Brian Reichert <reichert@internet.com> +Brian S. Cashman <bsc@umich.edu> +Bruce Barnett <barnett@grymoire.crd.ge.com> +Bruce J. Keeler <bkeelerx@iwa.dp.intel.com> +Bruce P. Schuck <bruce@aps.org> +Bud Huff <BAHUFF@us.oracle.com> +Byron Brummer <byron@omix.com> +Calle Dybedahl <calle@lysator.liu.se> +Carl M. Fongheiser <cmf@ins.infonet.net> +Carl Witty <cwitty@newtonlabs.com> +Cary D. Renzema <caryr@mxim.com> +Casey R. Tweten <crt@kiski.net> +Castor Fu +Chaim Frenkel <chaimf@pobox.com> +Charles Bailey <bailey@newman.upenn.edu> +Charles F. Randall <crandall@free.click-n-call.com> +Charles Lane <lane@DUPHY4.Physics.Drexel.Edu> +Charles Wilson <cwilson@ece.gatech.edu> +Chip Salzenberg <chip@pobox.com> +Chris Faylor <cgf@bbc.com> +Chris Nandor <pudge@pobox.com> +Chris Wick <cwick@lmc.com> +Christian Kirsch <ck@held.mind.de> +Christopher Chan-Nui <channui@austin.ibm.com> +Christopher Davis <ckd@loiosh.kei.com> +Chuck D. Phillips <cdp@hpescdp.fc.hp.com> +Chuck Phillips <cdp@fc.hp.com> +Chunhui Teng <cteng@nortel.ca> +Clark Cooper <coopercc@netheaven.com> +Clinton Pierce <cpierce1@ford.com> +Colin Kuskie <ckuskie@cadence.com> +Conrad Augustin +Conrad E. Kimball <cek@tblv021.ca.boeing.com> +Craig A. Berry <craig.berry@psinetcs.com> +Craig Milo Rogers <Rogers@ISI.EDU> +Dale Amon <amon@vnl.com> +Damian Conway <damian@cs.monash.edu.au> +Damon Atkins <Damon.Atkins@nabaus.com.au> +Dan Boorstein <dan_boo@bellsouth.net> +Dan Carson <dbc@tc.fluke.COM> +Dan Schmidt <dfan@harmonixmusic.com> +Dan Sugalski <dan@sidhe.org> +Daniel Chetlin <daniel@chetlin.com> +Daniel Grisinger <dgris@dimensional.com> +Daniel Muiño <dmuino@afip.gov.ar> +Daniel S. Lewart <lewart@vadds.cvm.uiuc.edu> +Daniel Yacob <dmulholl@cs.indiana.edu> +Danny R. Faught <faught@mailhost.rsn.hp.com> +Danny Sadinoff <sadinoff@olf.com> +Darrell Kindred <dkindred+@cmu.edu> +Darrell Schiebel <drs@nrao.edu> +Darren/Torin/Who Ever... <torin@daft.com> +Dave Bianchi +Dave Hartnoll <Dave_Hartnoll@3b2.com> +Dave Nelson <David.Nelson@bellcow.com> +Dave Schweisguth <dcs@neutron.chem.yale.edu> +David Billinghurst <David.Billinghurst@riotinto.com.au> +David Campbell +David Couture +David Denholm <denholm@conmat.phys.soton.ac.uk> +David Dyck <dcd@tc.fluke.com> +David F. Haertig <dfh@dwroll.lucent.com> +David Filo +David Glasser <me@davidglasser.net> +David Hammen <hammen@gothamcity.jsc.nasa.gov> +David J. Fiander <davidf@mks.com> +David Kerry <davidk@tor.securecomputing.com> +David Muir Sharnoff <muir@idiom.com> +David R. Favor <dfavor@austin.ibm.com> +David Sparks <daves@ActiveState.com> +David Starks-Browning <dstarks@rc.tudelft.nl> +David Sundstrom <sunds@asictest.sc.ti.com> +Davin Milun <milun@cs.Buffalo.EDU> +Dean Roehrich <roehrich@cray.com> +Dennis Marsa <dennism@cyrix.com> +dive <dive@ender.com> +Dominic Dunlop <domo@computer.org> +Dominique Dumont <Dominique_Dumont@grenoble.hp.com> +Doug Campbell <soup@ampersand.com> +Doug MacEachern <dougm@covalent.net> +Douglas E. Wegscheid <wegscd@whirlpool.com> +Douglas Lankshear <dougl@activestate.com> +Dov Grobgeld <dov@Orbotech.Co.IL> +Drago Goricanec <drago@raptor.otsd.ts.fujitsu.co.jp> +Ed Mooring <mooring@Lynx.COM> +Ed Peschko <epeschko@den-mdev1> +Elaine -HFB- Ashton <elaine@chaos.wustl.edu> +Eric Arnold <eric.arnold@sun.com> +Eric Bartley <bartley@icd.cc.purdue.edu> +Eric E. Coe <Eric.Coe@oracle.com> +Eric Fifer <egf7@columbia.edu> +Erich Rickheit +Eryq <eryq@zeegee.com> +Etienne Grossman <etienne@isr.isr.ist.utl.pt> +Eugene Alterman <Eugene.Alterman@bremer-inc.com> +Fabien Tassin <tassin@eerie.fr> +Felix Gallo <fgallo@etoys.com> +Florent Guillaume +Frank Crawford +Frank Ridderbusch <Frank.Ridderbusch@pdb.siemens.de> +Frank Tobin <ftobin@uiuc.edu> +François Désarménien <desar@club-internet.fr> +Fréderic Chauveau <fmc@pasteur.fr> +G. Del Merritt <del@intranetics.com> +Gabe Schaffer +Gary Clark <GaryC@mail.jeld-wen.com> +Gary Ng <71564.1743@compuserve.com> +Gerben Wierda <G.C.Th.Wierda@AWT.nl> +Gerd Knops <gerti@BITart.com> +Giles Lean <giles@nemeton.com.au> +Gisle Aas <gisle@aas.no> +Gordon J. Miller <gjm@cray.com> +Grace Lee <grace@hal.com> +Graham Barr <gbarr@pobox.com> +Graham TerMarsch <grahamt@ActiveState.com> +Greg Bacon <gbacon@itsc.uah.edu> +Greg Chapman <glc@well.com> +Greg Earle +Greg Kuperberg +Greg Seibert <seibert@Lynx.COM> +Greg Ward <gward@ase.com> +Gregory Martin Pfeil <pfeilgm@technomadic.org> +Guenter Schmidt <gsc@bruker.de> +Guido Flohr <gufl0000@stud.uni-sb.de> +Gurusamy Sarathy <gsar@activestate.com> +Gustaf Neumann +Guy Decoux <decoux@moulon.inra.fr> +H.J. Lu <hjl@nynexst.com> +H.Merijn Brand <h.m.brand@hccnet.nl> +Hal Pomeranz <pomeranz@netcom.com> +Hallvard B Furuseth <h.b.furuseth@usit.uio.no> +Hannu Napari <Hannu.Napari@hut.fi> +Hans Mulder <hansmu@xs4all.nl> +Hans de Graaff <J.J.deGraaff@twi.tudelft.nl> +Harold O Morris <hom00@utsglobal.com> +Harry Edmon <harry@atmos.washington.edu> +Helmut Jarausch <jarausch@numa1.igpm.rwth-aachen.de> +Henrik Tougaard <ht.000@foa.dk> +Hershel Walters <walters@smd4d.wes.army.mil> +Holger Bechtold +Horst von Brand <vonbrand@sleipnir.valparaiso.cl> +Hubert Feyrer <hubert.feyrer@informatik.fh-regensburg.de> +Hugo van der Sanden <hv@crypt0.demon.co.uk> +Hunter Kelly <retnuh@zule.pixar.com> +Huw Rogers <count0@gremlin.straylight.co.jp> +Ian Maloney <ian.malonet@ubs.com> +Ian Phillipps <ian@dial.pipex.com> +Ignasi Roca <ignasi.roca@fujitsu.siemens.es> +Ilya Sandler <Ilya.Sandler@etak.com> +Ilya Zakharevich <ilya@math.ohio-state.edu> +Inaba Hiroto <inaba@st.rim.or.jp> +Irving Reid <irving@tor.securecomputing.com> +J. David Blackstone <jdb@dfwnet.sbms.sbc.com> +J. van Krieken <John.van.Krieken@ATComputing.nl> +JD Laub <jdl@access-health.com> +JT McDuffie <jt@kpc.com> +Jack Shirazi <JackS@GemStone.com> +Jacqui Caren <Jacqui.Caren@ig.co.uk> +Jake Hamby <jehamby@lightside.com> +James FitzGibbon <james@ican.net> +Jamshid Afshar +Jan D. <jan.djarv@mbox200.swipnet.se> +Jan Dubois <jand@activestate.com> +Jan Pazdziora <adelton@fi.muni.cz> +Jan-Erik Karlsson <trg@privat.utfors.se> +Jan-Pieter Cornet <johnpc@xs4all.nl> +Jared Rhine <jared@organic.com> +Jarkko Hietaniemi <jhi@iki.fi> +Jason A. Smith <smithj4@rpi.edu> +Jason Shirk +Jason Stewart <jasons@cs.unm.edu> +Jason Varsoke <jjv@caesun10.msd.ray.com> +Jay Rogers <jay@rgrs.com> +Jeff Bouis +Jeff McDougal <jmcdo@cris.com> +Jeff Okamoto <okamoto@corp.hp.com> +Jeff Pinyan <japhy@pobox.com> +Jeff Urlwin <jurlwin@access.digex.net> +Jeffrey Friedl <jfriedl@yahoo-inc.com> +Jeffrey S. Haemer <jsh@woodcock.boulder.qms.com> +Jens Hamisch <jens@Strawberry.COM> +Jens T. Berger Thielemann <jensthi@ifi.uio.no> +Jens Thomsen <jens@fiend.cis.com> +Jens-Uwe Mager <jum@helios.de> +Jeremy D. Zawodny <jzawodn@wcnet.org> +Jerome Abela <abela@hsc.fr> +Jim Anderson <jander@ml.com> +Jim Avera <avera@hal.com> +Jim Balter +Jim Meyering <meyering@asic.sc.ti.com> +Jim Miner <jfm@winternet.com> +Jim Richardson +Joachim Huober +Jochen Wiedmann <joe@ispsoft.de> +Joe Buehler <jbuehler@hekimian.com> +Joe Smith <jsmith@inwap.com> +Joel Rosi-Schwartz <j.schwartz@agonet.it> +Joerg Porath <Joerg.Porath@informatik.tu-chemnitz.de> +Joergen Haegg +Johan Holtman +Johan Vromans <jvromans@squirrel.nl> +Johann Klasek <jk@auto.tuwien.ac.at> +John Bley <jbb6@acpub.duke.edu> +John Borwick <jhborwic@unity.ncsu.edu> +John Cerney <j-cerney1@ti.com> +John D Groenveld <groenvel@cse.psu.edu> +John Hasstedt <John.Hasstedt@sunysb.edu> +John Hughes <john@AtlanTech.COM> +John L. Allen <allen@grumman.com> +John Macdonald <jmm@revenge.elegant.com> +John Nolan <jpnolan@Op.Net> +John Peacock <jpeacock@rowman.com> +John Pfuntner <pfuntner@vnet.ibm.com> +John Rowe +John Salinas <jsalinas@cray.com> +John Stoffel <jfs@fluent.com> +John Tobey <jtobey@john-edwin-tobey.org> +Jon Orwant <orwant@oreilly.com> +Jonathan Biggar <jon@sems.com> +Jonathan D Johnston <jdjohnston2@juno.com> +Jonathan Fine <jfine@borders.com> +Jonathan I. Kamens <jik@kamens.brookline.ma.us> +Jonathan Roy <roy@idle.com> +Joseph N. Hall <joseph@cscaper.com> +Joseph S. Myers <jsm28@hermes.cam.ac.uk> +Joshua Pritikin <joshua.pritikin@db.com> +Juan Gallego <Little.Boss@physics.mcgill.ca> +Julian Yip <julian@imoney.com> +Justin Banks <justinb@cray.com> +Ka-Ping Yee <kpyee@aw.sgi.com> +Karl Glazebrook <kgb@aaossz.aao.GOV.AU> +Karl Heuer <kwzh@gnu.org> +Karl Simon Berg <karl@it.kth.se> +Karsten Sperling <spiff@phreax.net> +Kaveh Ghazi <ghazi@caip.rutgers.edu> +Keith Neufeld <neufeld@fast.pvi.org> +Keith Thompson <kst@cts.com> +Ken Estes <estes@ms.com> +Ken Fox <kfox@ford.com> +Ken MacLeod <ken@bitsko.slc.ut.us> +Ken Shan <ken@digitas.harvard.edu> +Kenneth Albanowski <kjahds@kjahds.com> +Kenneth Duda <kjd@cisco.com> +Keong Lim <Keong.Lim@sr.com.au> +Kevin O'Gorman <kevin.kosman@nrc.com> +Kevin White <klwhite@magnus.acs.ohio-state.edu> +Kim Frutiger +Kragen Sitaker <kragen@dnaco.net> +Krishna Sethuraman <krishna@sgi.com> +Kurt D. Starsinic <kstar@smithrenaud.com> +Kyriakos Georgiou +Larry Parmelee <parmelee@CS.Cornell.EDU> +Larry Schuler +Larry Schwimmer <rosebud@cyclone.Stanford.EDU> +Larry W. Virden <lvirden@cas.org> +Larry Wall <larry@wall.org> +Lars Hecking <lhecking@nmrc.ucc.ie> +Laszlo Molnar <laszlo.molnar@eth.ericsson.se> +Len Johnson <lenjay@ibm.net> +Les Peters <lpeters@aol.net> +Lincoln D. Stein <lstein@cshl.org> +Lionel Cons <lionel.cons@cern.ch> +Luca Fini +Lupe Christoph <lupe@lupe-christoph.de> +Luther Huffman <lutherh@stratcom.com> +M. J. T. Guy <mjtg@cam.ac.uk> +Major Sébastien <sebastien.major@crdp.ac-caen.fr> +Makoto MATSUSHITA <matusita@ics.es.osaka-u.ac.jp> +Malcolm Beattie <mbeattie@sable.ox.ac.uk> +Marc Lehmann <pcg@goof.com> +Marc Paquette <Marc.Paquette@Softimage.COM> +Marcel Grunauer <marcel@codewerk.com> +Mark A Biggar <mab@wdl.loral.com> +Mark Bixby <mark@bixby.org> +Mark Dickinson <dickins3@fas.harvard.edu> +Mark Hanson +Mark K Trettin <mkt@lucent.com> +Mark Kaehny <kaehny@execpc.com> +Mark Kettenis <kettenis@wins.uva.nl> +Mark Klein <mklein@dis.com> +Mark Knutsen <knutsen@pilot.njin.net> +Mark Kvale <kvale@phy.ucsf.edu> +Mark Leighton Fisher <fisherm@tce.com> +Mark Murray <mark@grondar.za> +Mark P. Lutz <mark.p.lutz@boeing.com> +Mark Pease <peasem@primenet.com> +Mark Pizzolato <mark@infocomm.com> +Mark R. Levinson <mrl@isc.upenn.edu> +Mark-Jason Dominus <mjd@plover.com> +Martijn Koster <mak@excitecorp.com> +Martin J. Bligh <mbligh@sequent.com> +Martin Jost <Martin.Jost@icn.siemens.de> +Martin Lichtin <lichtin@bivio.com> +Martin Plechsmid <plechsmi@karlin.mff.cuni.cz> +Marty Lucich <marty@netcom.com> +Martyn Pearce <martyn@inpharmatica.co.uk> +Masahiro KAJIURA <masahiro.kajiura@toshiba.co.jp> +Mathias Koerber <mathias@dnssec1.singnet.com.sg> +Matt Kimball +Matthew Black <black@csulb.edu> +Matthew Green <mrg@splode.eterna.com.au> +Matthew T Harden <mthard@mthard1.monsanto.com> +Matthias Ulrich Neeracher <neeri@iis.ee.ethz.ch> +Matthias Urlichs <smurf@noris.net> +Maurizio Loreti <maurizio.loreti@pd.infn.it> +Michael Cook <mcook@cognex.com> +Michael De La Rue <mikedlr@tardis.ed.ac.uk> +Michael Engel <engel@nms1.cc.huji.ac.il> +Michael G Schwern <schwern@pobox.com> +Michael H. Moran <mhm@austin.ibm.com> +Michael Mahan <mahanm@nextwork.rose-hulman.edu> +Michael Stevens <mstevens@globnix.org> +Michele Sardo +Mik Firestone <fireston@lexmark.com> +Mike Fletcher <fletch@phydeaux.org> +Mike Hopkirk <hops@sco.com> +Mike Rogers +Mike Stok <mike@stok.co.uk> +Mike W Ellwood <mwe@rl.ac.uk> +Milton Hankins <webtools@uewrhp03.msd.ray.com> +Milton L. Hankins <mlh@swl.msd.ray.com> +Molnar Laszlo <molnarl@cdata.tvnet.hu> +Murray Nesbitt <mjn@pathcom.com> +Nathan Kurz <nate@valleytel.net> +Nathan Torkington <gnat@frii.com> +Neale Ferguson <neale@VMA.TABNSW.COM.AU> +Neil Bowers <neilb@cre.canon.co.uk> +Nicholas Clark <nick@ccl4.org> +Nick Duffek +Nick Gianniotis +Nick Ing-Simmons <nick@ing-simmons.net> +Norbert Pueschel <pueschel@imsdd.meb.uni-bonn.de> +Norton T. Allen <allen@huarp.harvard.edu> +Olaf Flebbe <o.flebbe@science-computing.de> +Olaf Titz <olaf@bigred.inka.de> +Ollivier Robert <roberto@keltia.freenix.fr> +Owen Taylor <owt1@cornell.edu> +Patrick Hayes <Patrick.Hayes.CAP_SESA@renault.fr> +Patrick O'Brien <pdo@cs.umd.edu> +Paul A Sand <pas@unh.edu> +Paul David Fardy <pdf@morgan.ucs.mun.ca> +Paul Green <Paul_Green@stratus.com> +Paul Hoffman <phoffman@proper.com> +Paul Holser <Paul.Holser.pholser@nortelnetworks.com> +Paul Johnson <paul@pjcj.net> +Paul Marquess <Paul.Marquess@btinternet.com> +Paul Moore <Paul.Moore@uk.origin-it.com> +Paul Rogers <Paul.Rogers@Central.Sun.COM> +Paul Saab <ps@yahoo-inc.com> +Paul Schinder <schinder@pobox.com> +Pete Peterson <petersonp@genrad.com> +Peter Chines <pchines@nhgri.nih.gov> +Peter Gordon <peter@valor.com> +Peter Haworth <pmh@edison.ioppublishing.com> +Peter J. Farley III <pjfarley@banet.net> +Peter Jaspers-Fayer +Peter Prymmer <pvhp@forte.com> +Peter Scott <Peter@PSDT.com> +Peter Wolfe <wolfe@teloseng.com> +Peter van Heusden <pvh@junior.uwc.ac.za> +Petter Reinholdtsen <pere@hungry.com> +Phil Lobbes <phil@finchcomputer.com> +Philip Hazel <ph10@cus.cam.ac.uk> +Philip Newton <pne@cpan.org> +Piers Cawley <pdcawley@bofh.org.uk> +Piotr Klaban <makler@oryl.man.torun.pl> +Prymmer/Kahn <pvhp@best.com> +Quentin Fennessy <quentin@arrakeen.amd.com> +Radu Greab <radu@netsoft.ro> +Ralf S. Engelschall <rse@engelschall.com> +Randal L. Schwartz <merlyn@stonehenge.com> +Randy J. Ray <rjray@redhat.com> +Raphael Manfredi <Raphael.Manfredi@pobox.com> +Raymund Will <ray@caldera.de> +Rex Dieter <rdieter@math.unl.edu> +Rich Morin <rdm@cfcl.com> +Rich Salz <rsalz@bbn.com> +Richard A. Wells <Rwells@uhs.harvard.edu> +Richard Foley <Richard.Foley@m.dasa.de> +Richard L. England <richard_england@mentorg.com> +Richard L. Maus, Jr. <rmaus@monmouth.com> +Richard Soderberg <rs@crystalflame.net> +Richard Yeh <rcyeh@cco.caltech.edu> +Rick Delaney <rick@consumercontact.com> +Rick Pluta +Rickard Westman +Rob Henderson <robh@cs.indiana.edu> +Robert Partington <rjp@riffraff.plig.net> +Robert Sanders <Robert.Sanders@linux.org> +Robert Spier <rspier@pobox.com> +Robin Barker <rmb1@cise.npl.co.uk> +Robin Houston <robin@kitsite.com> +Rocco Caputo <troc@netrus.net> +Roderick Schertler <roderick@argon.org> +Rodger Anderson <rodger@boi.hp.com> +Ronald F. Guilmette <rfg@monkeys.com> +Ronald J. Kimball <rjk@linguist.dartmouth.edu> +Ruben Schattevoy <schattev@imb-jena.de> +Rujith S. de Silva <desilva@netbox.com> +Russ Allbery <rra@stanford.edu> +Russell Fulton <russell@ccu1.auckland.ac.nz> +Russell Mosemann +Ryan Herbert <rherbert@sycamorehq.com> +SAKAI Kiyotaka <ksakai@netwk.ntt-at.co.jp> +Samuli Kärkkäinen <skarkkai@woods.iki.fi> +Scott Gifford <sgifford@tir.com> +Scott Henry <scotth@sgi.com> +Sean Robinson <robinson_s@sc.maricopa.edu> +Sean Sheedy <seans@ncube.com> +Sebastien Barre <Sebastien.Barre@utc.fr> +Shigeya Suzuki <shigeya@foretune.co.jp> +Shimpei Yamashita <shimpei@socrates.patnet.caltech.edu> +Shishir Gundavaram <shishir@ruby.ora.com> +Simon Cozens <simon@cozens.net> +Simon Leinen +Simon Parsons <S.Parsons@ftel.co.uk> +Slaven Rezic <eserte@cs.tu-berlin.de> +Spider Boardman <spider@orb.nashua.nh.us> +Stephane Payrard <stef@francenet.fr> +Stephanie Beals <bealzy@us.ibm.com> +Stephen McCamant <alias@mcs.com> +Stephen O. Lidie <lusol@turkey.cc.Lehigh.EDU> +Stephen P. Potter <spp@ds.net> +Stephen Zander <gibreel@pobox.com> +Steve A Fink <sfink@cs.berkeley.edu> +Steve Kelem <steve.kelem@xilinx.com> +Steve McDougall <swmcd@world.std.com> +Steve Nielsen <spn@enteract.com> +Steve Pearlmutter +Steve Vinoski +Steven Hirsch <hirschs@btv.ibm.com> +Steven Knight <knight@theopera.baldmt.citilink.com> +Steven Morlock <newspost@morlock.net> +Steven N. Hirsch <hirschs@stargate.btv.ibm.com> +Steven Parkes <parkes@sierravista.com> +Sven Verdoolaege <skimo@breughel.ufsia.ac.be> +SynaptiCAD, Inc. <sales@syncad.com> +Taro KAWAGISHI +Ted Ashton <ashted@southern.edu> +Ted Law <tedlaw@cibcwg.com> +Teun Burgers <burgers@ecn.nl> +Thad Floryan <thad@thadlabs.com> +Thomas Bowditch <bowditch@inmet.com> +Thomas Conté <tom@fr.uu.net> +Thomas Dorner <Thomas.Dorner@start.de> +Thomas Kofler +Thomas König +Tim Adye <T.J.Adye@rl.ac.uk> +Tim Ayers <tayers@bridge.com> +Tim Bunce <Tim.Bunce@ig.co.uk> +Tim Conrow <tim@spindrift.srl.caltech.edu> +Tim Freeman <tfreeman@infoseek.com> +Tim Jenness <t.jenness@jach.hawaii.edu> +Tim Mooney <mooney@dogbert.cc.ndsu.NoDak.edu> +Tim Witham <twitham@pcocd2.intel.com> +Timur I. Bakeyev <bsdi@listserv.bat.ru> +Tkil <tkil@reptile.scrye.com> +Todd C. Miller <Todd.Miller@courtesan.com> +Tom Bates <tom_bates@att.net> +Tom Christiansen <tchrist@perl.com> +Tom Horsley <Tom.Horsley@mail.ccur.com> +Tom Hughes <tom@compton.nu> +Tom Phoenix <rootbeer@teleport.com> +Tom Spindler <dogcow@isi.net> +Tony Camas +Tony Cook <tony@develop-help.com> +Tony Sanders <sanders@bsdi.com> +Tor Lillqvist <tml@hemuli.tte.vtt.fi> +Trevor Blackwell <tlb@viaweb.com> +Tuomas J. Lukka <tjl@lukka.student.harvard.edu> +Tye McQueen <tye@metronet.com> +Ulrich Kunitz <kunitz@mai-koeln.com> +Ulrich Pfeifer <pfeifer@wait.de> +Vadim Konovalov <vkonovalov@lucent.com> +Valeriy E. Ushakov <uwe@ptc.spbu.ru> +Vishal Bhatia <vishal@deja.com> +Vlad Harchev <hvv@hippo.ru> +Vladimir Alexiev <vladimir@cs.ualberta.ca> +W. Phillip Moore <wpm@ms.com> +Warren Hyde <whyde@pezz.sps.mot.com> +Warren Jones <wjones@tc.fluke.com> +Wayne Berke <berke@panix.com> +Wayne Scott <wscott@ichips.intel.com> +Wayne Thompson <Wayne.Thompson@Ebay.sun.com> +Wilfredo Sánchez <wsanchez@apple.com> +William J. Middleton <William.Middleton@oslo.mobil.telenor.no> +William Mann <wmann@avici.com> +William R Ward <hermit@BayView.COM> +William Setzer <William_Setzer@ncsu.edu> +Winfried König <win@in.rhein-main.de> +Wolfgang Laun <Wolfgang.Laun@alcatel.at> +Yary Hluchan +Yasushi Nakajima <sey@jkc.co.jp> +Yitzchak Scott-Thoennes <sthoenna@efn.org> +Yutaka OIWA <oiwa@is.s.u-tokyo.ac.jp> +Yutao Feng +Zachary Miller <zcmiller@simon.er.usgs.gov> diff --git a/contrib/perl5/Changes b/contrib/perl5/Changes index 69498211964c..725d2915be51 100644 --- a/contrib/perl5/Changes +++ b/contrib/perl5/Changes @@ -5,76 +5,7 @@ patches posted to the perl5-porters mailing list. Patches for each individual change may also be obtained through ftp and rsync--see perlhack.pod for the details. - - --------------- - CAST AND CREW - --------------- - -To give due honor to those who have made Perl what is is today, -here are some of the more common names in the Changes file, and their -current addresses (as of February 2000): - - Gisle Aas <gisle@aas.no> - Abigail <abigail@delanet.com> - Kenneth Albanowski <kjahds@kjahds.com> - Russ Allbery <rra@stanford.edu> - Brad Appleton <bradapp@enteract.com> - Greg Bacon <gbacon@itsc.uah.edu> - Robin Barker <rmb1@cise.npl.co.uk> - Vishal Bhatia <vishal@gol.com> - Spider Boardman <spider@orb.nashua.nh.us> - Tom Christiansen <tchrist@perl.com> - Mark-Jason Dominus <mjd@plover.com> - Jan Dubois <jand@activestate.com> - Dominic Dunlop <domo@computer.org> - Eric Fifer <efifer@sanwaint.com> - Hallvard B Furuseth <h.b.furuseth@usit.uio.no> - M. J. T. Guy <mjtg@cus.cam.ac.uk> - Jarkko Hietaniemi <jhi@iki.fi> - Tom Hughes <tom@compton.nu> - Nick Ing-Simmons <nik@tiuk.ti.com> - Andreas Koenig <a.koenig@mind.de> - Douglas Lankshear <dougl@activestate.com> - Doug MacEachern <dougm@opengroup.org> - Raphael Manfredi <Raphael.Manfredi@st.com> - Paul Marquess <Paul.Marquess@btinternet.com> - Stephen McCamant <alias@mcs.com> - Laszlo Molnar <laszlo.molnar@eth.ericsson.se> - Hans Mulder <hansmu@xs4all.nl> - Chris Nandor <pudge@pobox.com> - Matthias Neeracher <neeri@iis.ee.ethz.ch> - Jeff Okamoto <okamoto@hpcc123.corp.hp.com> - Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de> - Tom Phoenix <rootbeer@teleport.com> - Joshua Pritikin <joshua.pritikin@db.com> - Peter Prymmer <pvhp@forte.com> - Norbert Pueschel <pueschel@imsdd.meb.uni-bonn.de> - Dean Roehrich <roehrich@cray.com> - Hugo van der Sanden <hv@crypt0.demon.co.uk> - Michael G Schwern <schwern@pobox.com> - Roderick Schertler <roderick@argon.org> - Kurt D. Starsinic <kstar@chapin.edu> - Benjamin Stuhl <sho_pi@hotmail.com> - Dan Sugalski <sugalskd@osshe.edu> - Nathan Torkington <gnat@frii.com> - Larry W. Virden <lvirden@cas.org> - Johan Vromans <jvromans@squirrel.nl> - Ilya Zakharevich <ilya@math.ohio-state.edu> - -And the Keepers of the Patch Pumpkin: - - Charles Bailey <bailey@newman.upenn.edu> - Graham Barr <gbarr@ti.com> - Malcolm Beattie <mbeattie@sable.ox.ac.uk> - Tim Bunce <Tim.Bunce@ig.co.uk> - Andy Dougherty <doughera@lafcol.lafayette.edu> - Gurusamy Sarathy <gsar@activestate.com> - Chip Salzenberg <chip@perl.com> - -And, of course, the Author of Perl: - - Larry Wall <larry@wall.org> - +[The "CAST AND CREW" list has been moved to AUTHORS.] NOTE: Each change entry shows the change number; who checked it into the repository; when; description of the change; which branch the change @@ -87,6 +18,7324 @@ indicator: +> branched (from elsewhere) !> merged changes (from elsewhere) +The Message-Ids in the change entries refer to the email messages sent +to the perl5-porters mailing list. You can retrieve the messages for +example from http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/ + +This file contains only changes that affect the maint-5.6 branch. +Cross-references to changes imported from other branches (principally, +the mainline) are indicated by change numbers. Detailed log entries +corresponding to these change numbers are available in the Changes +file in the latest development release. + + +-------------- +Version v5.6.1 +-------------- + +____________________________________________________________________________ +[ 9651] By: gsar on 2001/04/09 03:11:19 + Log: update Changes, patchlevel.h &c. + Branch: maint-5.6/perl + ! Changes patchlevel.h pod/perldelta.pod pod/perlhist.pod + ! pod/perltoc.pod +____________________________________________________________________________ +[ 9649] By: gsar on 2001/04/09 02:35:43 + Log: tweak perldelta as suggested by Jarkko + Branch: maint-5.6/perl + ! pod/perldelta.pod +____________________________________________________________________________ +[ 9646] By: gsar on 2001/04/09 00:48:04 + Log: add note about ithreads and Thread.pm (too many people are + confused by the fact that Thread.pm is built and installed + under non-5005threads but doesn't work) + Branch: maint-5.6/perl + ! ext/Thread/Thread.pm ext/Thread/Thread.xs +____________________________________________________________________________ +[ 9645] By: gsar on 2001/04/09 00:19:03 + Log: update perldelta.pod for changes in 5.6.1 + Branch: maint-5.6/perl + ! Changes pod/perldelta.pod +____________________________________________________________________________ +[ 9640] By: gsar on 2001/04/08 19:20:46 + Log: integrate change#9634 from mainline + + Fix the perlmodlib generation (didn't understand separate .pod + files; didn't understand -- as the name-thing separator). + Update the CPAN mirrors list. + Branch: maint-5.6/perl + ! pod/perlmodlib.pod + !> pod/perlmodlib.PL +____________________________________________________________________________ +[ 9639] By: gsar on 2001/04/08 18:57:31 + Log: on windows, many of the README.* pods were being copied to the wrong + location + Branch: maint-5.6/perl + ! win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 9638] By: gsar on 2001/04/08 18:38:25 + Log: update to latest JPL from the anoncvs repository + Branch: maint-5.6/perl + + jpl/ChangeLog jpl/README.JUST-JNI jpl/docs/Tutorial.pod + ! MANIFEST jpl/JNI/JNI.pm jpl/JNI/JNI.xs jpl/JNI/Makefile.PL + ! jpl/PerlInterpreter/PerlInterpreter.h jpl/README +____________________________________________________________________________ +[ 9632] By: gsar on 2001/04/08 16:36:06 + Log: add $Tie::RefHash::VERSION + Branch: maint-5.6/perl + ! lib/Tie/RefHash.pm +____________________________________________________________________________ +[ 9624] By: gsar on 2001/04/08 06:08:17 + Log: test in t/pod/* were busted + + these tests are still not enabled in t/{harness,TEST} + Branch: maint-5.6/perl + ! lib/Pod/Find.pm t/pod/emptycmd.t t/pod/find.t t/pod/for.t + ! t/pod/headings.t t/pod/include.t t/pod/included.t t/pod/lref.t + ! t/pod/multiline_items.t t/pod/nested_items.t + ! t/pod/nested_seqs.t t/pod/oneline_cmds.t t/pod/pod2usage.t + ! t/pod/poderrs.t t/pod/podselect.t t/pod/special_seqs.t +____________________________________________________________________________ +[ 9623] By: gsar on 2001/04/08 03:37:01 + Log: integrate change#9470 from mainline + + Subject: Re: [ID 20010215.006] Bad arg length for Socket::unpack_sockaddr_un, length is 14 ... + Branch: maint-5.6/perl + !> ext/Socket/Socket.xs +____________________________________________________________________________ +[ 9605] By: gsar on 2001/04/07 11:52:40 + Log: can't optimize away scope entry if tr/// is present + Branch: maint-5.6/perl + ! op.c t/op/tr.t +____________________________________________________________________________ +[ 9597] By: gsar on 2001/04/06 18:06:35 + Log: integrate change#9464 from mainline (addendum to change#8313) + + Subject: [PATCH @9452] Better peep()ing for foreach() loops + Branch: maint-5.6/perl + !> op.c +____________________________________________________________________________ +[ 9595] By: gsar on 2001/04/06 14:57:17 + Log: add a low-impact fix to accomodate darwin-ism + Branch: maint-5.6/perl + ! ext/Errno/Errno_pm.PL +____________________________________________________________________________ +[ 9594] By: jhi on 2001/04/06 14:55:14 + Log: Integrate changes #9528,9593 from mainline into maintperl; + tweaking the editor/IDE/shell list. + Branch: maint-5.6/perl + !> pod/perlfaq3.pod +____________________________________________________________________________ +[ 9592] By: gsar on 2001/04/06 14:45:18 + Log: integrate change#9477 from mainline (base.pm doc tweak) + + missing doc entry for fmod() + Branch: maint-5.6/perl + ! lib/Math/BigFloat.pm + !> lib/base.pm +____________________________________________________________________________ +[ 9587] By: gsar on 2001/04/06 07:31:30 + Log: add README.macos (from Chris Nandor) + + tyop in change#9555 + Branch: maint-5.6/perl + + README.macos + ! MANIFEST pod/buildtoc.PL pod/perl.pod pod/perlfaq9.pod + ! win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 9586] By: gsar on 2001/04/06 07:08:54 + Log: fixes for Math::BigFloat bugs; add fmod() (from John Peacock) + Branch: maint-5.6/perl + ! lib/Math/BigFloat.pm t/lib/bigfltpm.t +____________________________________________________________________________ +[ 9585] By: gsar on 2001/04/06 06:58:44 + Log: integrate changes#9555,9556,9563..9567,9570..9575,9577..9578 + from mainline + + Subject: [PATCH] Base64 update to perlfaq9.pod + + Subject: [PATCH AUTHORS] Housekeeping + + Subject: Re: Not OK: perl v5.6.1 +fools-gold on darwin 1.3 (UNINSTALLED) + Mac OS X (Darwin) has extra pwent fields. + + Subject: [PATCH B::*] print control-character vars readably + Needs EBCDICification. + + Subject: [PATCH B::Deparse] lexical variables with ridiculously long names that are used in list assignments + + Subject: [PATCH B::*] cope with SVf_IVisUV, and cope with $^^ and friends + + Subject: [PATCH B::Deparse] "${foo}bar", "${foo}[1]" etc. + + Subject: [PATCH B::Deparse] binmode is no longer an UNOP + + Subject: [PATCH B::Deparse] regex quoting, and a minor milestone + + Subject: [PATCH B::Deparse] suppress "unintialized value" warnings + + Subject: bleadperl / hex ignores variable length and/or tr doesn't null terminate ( with patch) + + Subject: patch for t/op/oct.t that shows need for patch supplied with bug 20010404.009, (bugs in hex and oct) + + FreeBSD hints tweak from Anton Berezin. + + Subject: [PATCH foolperl & bleadperl] README.vms update + + Subject: Re: [PATCH foolperl & bleadperl] README.vms update + Branch: maint-5.6/perl + !> AUTHORS README.vms ext/B/B.pm ext/B/B/Concise.pm + !> ext/B/B/Debug.pm ext/B/B/Deparse.pm ext/B/B/Terse.pm + !> hints/freebsd.sh pod/perlfaq9.pod pp.c t/op/oct.t t/op/pwent.t +____________________________________________________________________________ +[ 9584] By: gsar on 2001/04/06 04:09:00 + Log: keep eval"" CVs alive until the end of the statement in which + they're called; this avoids a coredump ensuing from search for + lexicals in code such as: + + sub bug { + my $s = @_; + eval q[sub { eval 'sub { &$s }' }]; + } + bug("x")->()->(); + + this code still doesn't work as intended (as it has remained + since time immemorial), but it doesn't provoke a coredump anymore + Branch: maint-5.6/perl + ! embed.h embed.pl global.sym objXSUB.h perlapi.c + ! pod/perlguts.pod pp_ctl.c proto.h scope.c scope.h sv.c +____________________________________________________________________________ +[ 9551] By: gsar on 2001/04/05 00:18:34 + Log: tr/// doesn't null-terminate the result in some situations + (from Gisle Aas) + Branch: maint-5.6/perl + ! doop.c t/op/tr.t +____________________________________________________________________________ +[ 9550] By: gsar on 2001/04/04 20:04:17 + Log: B::Deparse fix for ${^FOO} and documentation for PVX() method + (from Robin Houston) + Branch: maint-5.6/perl + ! ext/B/B.pm ext/B/B/Deparse.pm +____________________________________________________________________________ +[ 9548] By: gsar on 2001/04/04 18:51:49 + Log: integrate changes#9460,9462,9482,9521,9522 + + Subject: PATCH: B::Debug should show LOOP-specific fields + + Subject: B::Deparse precedence bug. (Patch included.) + + Subject: Re: [ID 20010330.003] O=Deparse,-p does not preserve "operational semantics" + + Subject: [PATCH B::Concise] @stash_array = split(/pat/, str); + + Subject: [PATCH B::Concise] padname values may have bogus SvCUR + Branch: maint-5.6/perl + !> ext/B/B.pm ext/B/B.xs ext/B/B/Concise.pm ext/B/B/Debug.pm + !> ext/B/B/Deparse.pm ext/B/B/Showlex.pm +____________________________________________________________________________ +[ 9547] By: gsar on 2001/04/04 18:49:16 + Log: s/djSP/dSP/ + Branch: maint-5.6/perl + ! ext/Thread/Thread.xs +____________________________________________________________________________ +[ 9545] By: gsar on 2001/04/04 18:38:52 + Log: integrate change#8837 from mainline + + Subject: [patch] -Wall cleanup round 2 + Branch: maint-5.6/perl + !> ext/B/B.xs ext/Data/Dumper/Dumper.xs ext/Devel/DProf/DProf.xs + !> ext/Devel/Peek/Peek.xs ext/Fcntl/Fcntl.xs + !> ext/File/Glob/Glob.xs ext/GDBM_File/GDBM_File.xs ext/IO/IO.xs + !> ext/IPC/SysV/SysV.xs ext/Opcode/Opcode.xs ext/POSIX/POSIX.xs + !> ext/SDBM_File/SDBM_File.xs +____________________________________________________________________________ +[ 9544] By: gsar on 2001/04/04 17:49:57 + Log: "double" should be "NV"; standard typemap is missing entry + for NV + Branch: maint-5.6/perl + ! ext/B/B.xs ext/B/B/C.pm lib/ExtUtils/typemap +____________________________________________________________________________ +[ 9539] By: gsar on 2001/04/04 03:01:14 + Log: another tweak needed for SunOS 4.1.x build (from Mike Guy) + Branch: maint-5.6/perl + ! Makefile.SH +____________________________________________________________________________ +[ 9538] By: gsar on 2001/04/04 01:00:38 + Log: fflush() is a macro on SunOS 4.1.x, so provide a wrapper + for use with _fwalk() (fix for change#7705) + Branch: maint-5.6/perl + ! util.c +____________________________________________________________________________ +[ 9533] By: gsar on 2001/04/03 14:30:07 + Log: better fix for change#9517 to accomodate UNC paths like + \\server\share\foo, and paths with trailing backslash + like c:\this\ + Branch: maint-5.6/perl + ! utils/perldoc.PL x2p/find2perl.PL x2p/s2p.PL +____________________________________________________________________________ +[ 9530] By: gsar on 2001/04/03 04:56:41 + Log: accomodate VMS "mailbox overflow" quirk in testsuite (from + Craig Berry) + Branch: maint-5.6/perl + ! t/lib/socket.t +____________________________________________________________________________ +[ 9524] By: gsar on 2001/04/03 01:09:12 + Log: EPOC fix for lib/io_udp.t failure (from Olaf Flebbe) + Branch: maint-5.6/perl + ! pp_sys.c +____________________________________________________________________________ +[ 9517] By: gsar on 2001/04/02 19:52:21 + Log: many of the utilities interpolate literal paths within doublequotes + (fails on dosish platforms where path contains backslashes) + Branch: maint-5.6/perl + ! utils/perldoc.PL x2p/find2perl.PL x2p/s2p.PL +____________________________________________________________________________ +[ 9516] By: gsar on 2001/04/02 05:49:37 + Log: a foolish release + Branch: maint-5.6/perl + ! Changes patchlevel.h pod/perldelta.pod pod/perlhist.pod + ! pod/perltoc.pod +____________________________________________________________________________ +[ 9515] By: gsar on 2001/04/02 05:04:29 + Log: add missing changelog summaries + Branch: maint-5.6/perl + ! Changes +____________________________________________________________________________ +[ 9514] By: gsar on 2001/04/02 04:07:13 + Log: add some notes about gutsy threading matters + Branch: maint-5.6/perl + ! pod/perlguts.pod +____________________________________________________________________________ +[ 9513] By: gsar on 2001/04/02 03:25:21 + Log: add more prominent caveat notices about experimental features + Branch: maint-5.6/perl + ! pod/perlfork.pod pod/perlunicode.pod +____________________________________________________________________________ +[ 9512] By: gsar on 2001/04/02 02:54:33 + Log: integrate changes#9479,9509 from mainline + + [PATCH] File::Glob stuff for Mac OS + + [PATH bsd_glob.c perl@9472] Shut up gcc warning in bsd_glob.c + Branch: maint-5.6/perl + !> ext/File/Glob/Glob.pm ext/File/Glob/bsd_glob.c + !> t/lib/glob-basic.t t/lib/glob-case.t t/lib/glob-global.t + !> t/lib/glob-taint.t +____________________________________________________________________________ +[ 9511] By: gsar on 2001/04/02 02:38:24 + Log: README.win32 tweaks; add a note about alternative location for + getting a gcc-2.95.2 that will build perl properly on windows + Branch: maint-5.6/perl + ! README.win32 +____________________________________________________________________________ +[ 9507] By: jhi on 2001/04/01 19:24:01 + Log: Integrate changes #9378,9458,9469,9475,9489,9490,9505,9506 + from mainline to maintperl: pod tweaks. + Branch: maint-5.6/perl + !> pod/perldebug.pod pod/perldiag.pod pod/perlfaq1.pod + !> pod/perlguts.pod pod/perlhack.pod pod/perlop.pod + !> pod/perlvar.pod +____________________________________________________________________________ +[ 9501] By: gsar on 2001/04/01 07:21:57 + Log: fix the perlembed notes on multiple interpreters + + fix ExtUtils::Embed to work passably on Windows + Branch: maint-5.6/perl + ! lib/ExtUtils/Embed.pm pod/perlembed.pod +____________________________________________________________________________ +[ 9496] By: gsar on 2001/03/31 23:22:28 + Log: various nits identified by the Borland 5.5 compiler; remove suppression + of a few warnings + Branch: maint-5.6/perl + ! ext/File/Glob/bsd_glob.c sv.c win32/win32.h +____________________________________________________________________________ +[ 9495] By: gsar on 2001/03/31 21:03:08 + Log: avoid redefinition warnings under Borland 5.02 + Branch: maint-5.6/perl + ! win32/makefile.mk +____________________________________________________________________________ +[ 9494] By: gsar on 2001/03/31 20:18:59 + Log: nits spotted by Borland compiler + Branch: maint-5.6/perl + ! utf8.h win32/win32.h +____________________________________________________________________________ +[ 9493] By: gsar on 2001/03/31 20:18:05 + Log: fix a broken workaround for Borland compiler in change#4739 + (caused weird "short reads" on DATA, which caused op/misc.t to fail) + Branch: maint-5.6/perl + ! toke.c +____________________________________________________________________________ +[ 9491] By: gsar on 2001/03/31 17:01:56 + Log: Cwd::chdir() doesn't set $ENV{PWD} correctly on windows when the + directory is relative (need to fetch the full path name *before* + the chdir!) + + this is a followup patch for change#6749 + Branch: maint-5.6/perl + ! lib/Cwd.pm +____________________________________________________________________________ +[ 9426] By: gsar on 2001/03/29 00:28:04 + Log: dmake can only handle == and != in comparisons; support building + with Borland's VCL libraries (from Vadim Konovalov) + Branch: maint-5.6/perl + ! win32/makefile.mk +____________________________________________________________________________ +[ 9416] By: jhi on 2001/03/28 18:06:07 + Log: Integrate change #9409 from mainline to maintperl. + + Yet another tweak on AIX dynaloading. + Branch: maint-5.6/perl + !> ext/DynaLoader/dl_aix.xs ext/DynaLoader/hints/aix.pl +____________________________________________________________________________ +[ 9415] By: gsar on 2001/03/28 17:13:01 + Log: integrate changes#9377,9385,9401 from mainline + + Subject: RE: 5.6.0 BUG: Lexical warnings aren't lexical + + If directory entries compare equal case-insensitively, + retry case-sensitively. + + Subject: [PATCH] B::Terse and warnings + Branch: maint-5.6/perl + !> ext/B/B.pm ext/B/B/Terse.pm ext/File/Glob/bsd_glob.c gv.c + !> t/pragma/warn/perl +____________________________________________________________________________ +[ 9312] By: gsar on 2001/03/23 16:25:25 + Log: add execute bit to files with shebang lines in the repository; + avoid clobbering execute bit in Porting/makerel + Branch: maint-5.6/perl + ! (edit 144 files) +____________________________________________________________________________ +[ 9306] By: jhi on 2001/03/23 12:51:36 + Log: There are AIXes without /usr/include/load.h, + patch from H.Merijn Brand. + Branch: maint-5.6/perl + ! ext/DynaLoader/hints/aix.pl +____________________________________________________________________________ +[ 9299] By: gsar on 2001/03/22 16:53:45 + Log: back out changes#7532,7521 for now (appears to have problems + on IRIX) + Branch: maint-5.6/perl + ! ext/POSIX/POSIX.pm ext/POSIX/POSIX.pod ext/POSIX/POSIX.xs + ! ext/POSIX/typemap pod/perlvar.pod +____________________________________________________________________________ +[ 9292] By: gsar on 2001/03/22 07:12:00 + Log: integrate changes#8306,8532 from mainline (missing USE_PURE_BISON + fixes) + Branch: maint-5.6/perl + !> embed.h embed.pl objXSUB.h perlapi.c perly.y proto.h toke.c +____________________________________________________________________________ +[ 9290] By: jhi on 2001/03/22 05:57:01 + Log: Move MacOS Classic higher in the list of supported platforms. + Branch: maint-5.6/perl + ! pod/perlport.pod +____________________________________________________________________________ +[ 9289] By: gsar on 2001/03/22 05:35:04 + Log: revert part of change#6438 for compatibility (av_reify() + appears to be needed to implement av_splice()ish things + in XS) + Branch: maint-5.6/perl + ! embed.pl global.sym objXSUB.h perlapi.c +____________________________________________________________________________ +[ 9288] By: gsar on 2001/03/22 03:09:19 + Log: update copyright year + Branch: maint-5.6/perl + ! EXTERN.h INTERN.h README av.c av.h cop.h cv.h deb.c doio.c + ! doop.c dump.c form.h gv.c gv.h handy.h hv.c hv.h mg.c mg.h + ! op.c op.h perl.c perl.h perlio.c perly.y pp.c pp.h pp_ctl.c + ! pp_hot.c pp_sys.c regcomp.c regexec.c run.c scope.c sv.c sv.h + ! toke.c utf8.c utf8.h util.c util.h x2p/EXTERN.h x2p/INTERN.h + ! x2p/a2p.c x2p/a2p.h x2p/a2p.y x2p/a2py.c x2p/hash.c x2p/hash.h + ! x2p/proto.h x2p/str.c x2p/str.h x2p/util.c x2p/util.h + ! x2p/walk.c +____________________________________________________________________________ +[ 9286] By: gsar on 2001/03/21 19:49:54 + Log: makefile.mk tweak + Branch: maint-5.6/perl + ! win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 9283] By: jhi on 2001/03/21 17:17:35 + Log: Integrate change #9282 from mainline into maintperl, + 4-arg UTF-8 substr(). + Branch: maint-5.6/perl + !> pp.c +____________________________________________________________________________ +[ 9281] By: gsar on 2001/03/21 17:03:14 + Log: makefile.mk defaults to GCC, not BORLAND (as mentioned in README.win32) + Branch: maint-5.6/perl + ! win32/makefile.mk +____________________________________________________________________________ +[ 9280] By: gsar on 2001/03/21 17:01:20 + Log: some tweaks to change#9278 (fork() emulation should be enabled + by setting BUILD_FLAVOR instead of changing the defaults) + Branch: maint-5.6/perl + ! win32/makefile.mk +____________________________________________________________________________ +[ 9279] By: gsar on 2001/03/21 16:47:19 + Log: integrate change#9271 from mainline; a tweak to Glob.pm docs + Branch: maint-5.6/perl + ! ext/File/Glob/Glob.pm + !> lib/Cwd.pm +____________________________________________________________________________ +[ 9278] By: jhi on 2001/03/21 14:35:10 + Log: Subject: [PATCH: 5.6.1-trial3] Borland C++ for Win32 fixes + From: "Vadim Konovalov" <watman@inbox.ru> + Date: Wed, 21 Mar 2001 01:53:51 +0300 + Message-ID: <004101c0b190$a749ea20$f7c030d4@vad> + Branch: maint-5.6/perl + ! win32/makefile.mk win32/win32sck.c +____________________________________________________________________________ +[ 9277] By: jhi on 2001/03/21 13:58:28 + Log: Integrate change #9270 from mainline to maintperl: + continued 4-arg UTF-8 substr() fixing. + Branch: maint-5.6/perl + !> pp.c t/op/substr.t +____________________________________________________________________________ +[ 9266] By: gsar on 2001/03/20 19:16:43 + Log: VMS piping fixes (from Charles Lane) + Branch: maint-5.6/perl + ! vms/vms.c vms/vmspipe.com +____________________________________________________________________________ +[ 9265] By: gsar on 2001/03/20 17:53:52 + Log: cut-n-paste goof in change#9264 + Branch: maint-5.6/perl + ! ext/File/Glob/Glob.xs +____________________________________________________________________________ +[ 9264] By: gsar on 2001/03/20 17:43:47 + Log: do alphabetical sorting by default (for csh compatibility); + bsd_glob() does ASCII sort by default as usual, unless + GLOB_ALPHASORT was specified + Branch: maint-5.6/perl + ! ext/File/Glob/Changes ext/File/Glob/Glob.pm + ! ext/File/Glob/Glob.xs ext/File/Glob/bsd_glob.c + ! ext/File/Glob/bsd_glob.h +____________________________________________________________________________ +[ 9263] By: gsar on 2001/03/20 16:40:08 + Log: integrate change#9255 from mainline (unicode fix) + + substr($bytestr, i, n, $charstr) + Branch: maint-5.6/perl + !> Todo-5.6 pp.c t/op/substr.t +____________________________________________________________________________ +[ 9262] By: gsar on 2001/03/20 15:57:41 + Log: revert the leak fix in change#9142 (problem needs a more experimental + fix unsuitable for 5.6.1) + Branch: maint-5.6/perl + ! scope.c +____________________________________________________________________________ +[ 9260] By: jhi on 2001/03/20 14:05:46 + Log: Subject: [PATCH perl-5.6.1-TRIAL3/run.c] printf warning + From: Robin Barker <rmb1@cise.npl.co.uk> + Date: Tue, 20 Mar 2001 10:12:04 GMT + Message-Id: <200103201012.KAA04738@tempest.npl.co.uk> + Branch: maint-5.6/perl + ! run.c +____________________________________________________________________________ +[ 9259] By: jhi on 2001/03/20 14:04:39 + Log: Subject: [MacPerl-Porters] [PATCH] POSIX, File::Path (Mac OS) for 5.6.1 and 5.7 + From: Chris Nandor <pudge@pobox.com> + Date: Tue, 20 Mar 2001 00:40:56 -0500 + Message-Id: <p05010401b6dc9d57a62d@[10.0.1.107]> + Branch: maint-5.6/perl + ! ext/POSIX/POSIX.xs lib/File/Path.pm +____________________________________________________________________________ +[ 9256] By: jhi on 2001/03/20 04:43:12 + Log: Subject: [PATCH: 5.6.1-trial3] test fixes and installation cleanliness for OS/390 + From: Peter Prymmer <pvhp@forte.com> + Date: Mon, 19 Mar 2001 16:43:13 -0800 (PST) + Message-ID: <Pine.OSF.4.10.10103191627310.162127-100000@aspara.forte.com> + Branch: maint-5.6/perl + ! installperl t/comp/proto.t t/comp/require.t t/op/regmesg.t +____________________________________________________________________________ +[ 9250] By: jhi on 2001/03/19 21:18:00 + Log: A more robust solution for the 64bitall AIX dynaloading + problem, from Jens-Uwe Mager. + Branch: maint-5.6/perl + ! ext/DynaLoader/dl_aix.xs ext/DynaLoader/hints/aix.pl +____________________________________________________________________________ +[ 9247] By: jhi on 2001/03/19 19:59:53 + Log: 64-bit AIX dynaloading problem (see #9244) idea + from Jens-Uwe Mager. + Branch: maint-5.6/perl + ! ext/DynaLoader/dl_aix.xs +____________________________________________________________________________ +[ 9245] By: jhi on 2001/03/19 19:05:19 + Log: Integrate change #9243 from mainline into maintperl. + + Subject: [PATCH perl-5.6.1-TRIAL3/README.vmesa] bad =item paragraphs + Branch: maint-5.6/perl + !> README.vmesa +____________________________________________________________________________ +[ 9244] By: jhi on 2001/03/19 19:03:15 + Log: Get 64bitall AIX building, but still does not test okay: + dynaloading anything fails, for example for op/defins: + Can't load '../lib/auto/File/Glob/Glob.so' for module File::Glob: loadbind: A system call received a parameter that is not valid. at ../lib/XSLoader.pm line 75. at ../lib/File/Glob.pm line 99 + (update: fixed by #9247,9250) + Branch: maint-5.6/perl + ! hints/aix.sh +____________________________________________________________________________ +[ 9241] By: gsar on 2001/03/19 17:34:46 + Log: VMSify tests (from Charles Lane) + Branch: maint-5.6/perl + ! t/lib/filehand.t t/lib/texttabs.t +____________________________________________________________________________ +[ 9239] By: gsar on 2001/03/19 09:23:17 + Log: this is 5.6.1-trial3 + Branch: maint-5.6/perl + ! Changes +____________________________________________________________________________ +[ 9238] By: gsar on 2001/03/19 08:47:04 + Log: some new symbols are only available under ithreads + Branch: maint-5.6/perl + ! makedef.pl +____________________________________________________________________________ +[ 9237] By: gsar on 2001/03/19 08:42:28 + Log: update patchlevel.h, Changes, &c. + Branch: maint-5.6/perl + ! Changes patchlevel.h pod/perlhist.pod + !> AUTHORS +____________________________________________________________________________ +[ 9236] By: gsar on 2001/03/19 08:17:49 + Log: integrate changes#8068,8717 from mainline + + [PATCH 5.7.0@8047] RE: [ID 20001013.009] DB_File issues warning when setting element to undef + + [PATCH CPAN 1.59_51] warning message (not!) + Branch: maint-5.6/perl + !> ext/GDBM_File/GDBM_File.pm ext/GDBM_File/typemap + !> ext/NDBM_File/NDBM_File.pm ext/NDBM_File/typemap + !> ext/ODBM_File/ODBM_File.pm ext/ODBM_File/typemap + !> ext/SDBM_File/SDBM_File.pm ext/SDBM_File/typemap lib/CPAN.pm + !> t/lib/gdbm.t t/lib/ndbm.t t/lib/odbm.t t/lib/sdbm.t +____________________________________________________________________________ +[ 9235] By: gsar on 2001/03/19 08:07:09 + Log: integrate changes#8617,8713,8715,8716,8721,8953,8963 from mainline + + [PATCH] Add missing CV flags to dump.c + + Re: [patch] Re: PL_ptr_table + + Fixup non-ithread build after 8713 + + Generated files form 8713 etc. + + Correct the correction :-( + + Documenting coderef @INC (Re: CPAN "make this script work" feature) + + Subject: Re: sync sync sync: have I missed any patches? + Replace djSP with dSP. + Branch: maint-5.6/perl + !> cop.h doio.c doop.c dump.c embed.h embed.pl ext/B/B/C.pm + !> ext/B/B/CC.pm global.sym objXSUB.h perl.c perlapi.c + !> pod/perlhack.pod pp.c pp.h pp_ctl.c pp_hot.c pp_sys.c proto.h + !> sv.c sv.h win32/perlhost.h +____________________________________________________________________________ +[ 9234] By: gsar on 2001/03/19 07:22:05 + Log: revert the change#9090 integrate for now (change looks somewhat + incomplete in that [ha]v_exists() need something similar; lacks + tests; &c.) + Branch: maint-5.6/perl + ! hv.c +____________________________________________________________________________ +[ 9233] By: gsar on 2001/03/19 07:10:01 + Log: some refcounts were incorrect in perl_clone(); avoid hang in global + destruction when there are unreferenced scalars (SvREFCNT==0) + Branch: maint-5.6/perl + ! sv.c +____________________________________________________________________________ +[ 9232] By: jhi on 2001/03/19 05:11:02 + Log: Regen api and toc. + Branch: maint-5.6/perl + ! pod/perlapi.pod pod/perltoc.pod +____________________________________________________________________________ +[ 9231] By: jhi on 2001/03/19 04:06:03 + Log: Integrate changes in #9070,9072,9101 from mainline into maintperl, + add a lost line in pp.c:pp_chop(), update to new op/chop. + + Clarify the description differentiating for and while; inspired by + + Subject: [ID 20010306.004] || != named unary operator + + The $Is_MacOS needs to be declared. + Branch: maint-5.6/perl + ! pp.c t/op/chop.t + !> lib/ExtUtils/Manifest.pm pod/perlop.pod pod/perlsyn.pod +____________________________________________________________________________ +[ 9230] By: jhi on 2001/03/19 03:48:16 + Log: Integrate changes #7971(perlio),8982,9061,9062,9068,9069, + 9079,9083,9089,9090,9091 from mainline to maintperl. + + Quieten some noise in Win32 builds + + Fixes the bugs 20010221.005 and 20010221.008: "the taint checker..." + + The perlretut was still talking about the old \p and \P + definitions. + + More tweakage on the Unicode character class descriptions. + + Subject: Re: [ID 20010305.012] chop() against list assignment returns char chopped from el zero + + Subject: 'no *POSIX' Patch speeding up make on BS2000 + + Subject: [PATCH] perldata.pod here-doc docs + + Add /sbin and /usr/sbin to the list of directories scanned + for setuid programs. Takes care of bug id 20010309.003. + + Subject: Re: [ID 19990808.001] [PATCH] FETCH triggered on exists() + + In op/stat #35 better to scan all the potential directories + for setuids, not just the first one. + Branch: maint-5.6/perl + ! Makefile.SH + !> doio.c hv.c lib/unicode/mktables.PL makedepend.SH perl.h + !> pod/perldata.pod pod/perlretut.pod pp.c t/op/chop.t + !> t/op/stat.t toke.c win32/win32.h +____________________________________________________________________________ +[ 9229] By: jhi on 2001/03/19 02:31:50 + Log: Subject: [MacPerl-Porters] [PATCH] Portability fixes for Mac OS / maint-5.6 + From: Chris Nandor <pudge@pobox.com> + Date: Sat, 10 Mar 2001 14:22:19 -0500 + Message-Id: <p0501042db6cf0a8d0b63@[10.0.1.177]> + Branch: maint-5.6/perl + ! ext/B/defsubs_h.PL ext/DynaLoader/dl_mac.xs + ! ext/Errno/Errno_pm.PL lib/ExtUtils/Manifest.pm perlsfio.h + ! t/lib/b.t t/lib/errno.t +____________________________________________________________________________ +[ 9228] By: jhi on 2001/03/19 02:29:59 + Log: Integrate changes #9113,9122 from mainline into maintperl. + + Subject: [PATCH: perl@9092, dist-3.0@70] OS/390 mydomain last gasp before silly guess (was Re: What do I need to build EBCDIC perl?) + Branch: maint-5.6/perl + !> Configure README.os390 hints/os390.sh +____________________________________________________________________________ +[ 9227] By: jhi on 2001/03/19 02:22:35 + Log: Integrate #9115,9121,9128,9163,9171,9174,9175 from mainline + into maintperl. + + Subject: Re: [ID 20010305.005] "use integer" doesn't make rand() return integers + + Forgot to check-in the larger part of #9120, duh. + + Subject: Another patch for integer.pm POD + + h2ph strictness and cleanliness from Kurt Starsinic. + + Borland filename case problem. + + h2ph strictness and cleanliness from Kurt Starsinic. + + Subject: [PATCH] the uncontroversial doc patches + Branch: maint-5.6/perl + +> win32/sncfnmcs.pl + !> MANIFEST README.os2 README.win32 ext/GDBM_File/GDBM_File.pm + !> ext/GDBM_File/GDBM_File.xs lib/integer.pm + !> pod/perl5005delta.pod pod/perldebtut.pod pod/perlfunc.pod + !> pod/perlhack.pod pod/perllexwarn.pod pod/perllocale.pod + !> pod/perllol.pod pod/perlmod.pod pod/perlmodlib.pod + !> pod/perlport.pod pod/perlrun.pod pod/perltoc.pod + !> pod/perlxs.pod pod/perlxstut.pod utils/h2ph.PL +____________________________________________________________________________ +[ 9226] By: jhi on 2001/03/19 02:10:21 + Log: Integrate changes #9207,9214 from mainline into maintperl. + + podchecker relaxations: =over has an *optional* number after it, + and whitespace in L<> is okay. + Branch: maint-5.6/perl + !> lib/Pod/Checker.pm lib/Pod/ParseUtils.pm pod/perlpod.pod + !> t/pod/poderrs.xr +____________________________________________________________________________ +[ 9224] By: jhi on 2001/03/19 02:06:11 + Log: Integrate change #9223 from mainline to maintperl. + + Document -Dmksymlinks. + Branch: maint-5.6/perl + !> INSTALL +____________________________________________________________________________ +[ 9222] By: jhi on 2001/03/19 01:15:35 + Log: The -Dmksymlinks wasn't working for maintperl. + Branch: maint-5.6/perl + ! Configure +____________________________________________________________________________ +[ 9219] By: gsar on 2001/03/19 00:16:55 + Log: remove duplicated tests + Branch: maint-5.6/perl + ! t/op/re_tests +____________________________________________________________________________ +[ 9208] By: jhi on 2001/03/18 20:12:12 + Log: Integrate changes #8128,9132 from mainline into maintperl, + Tie::SubstrHash fixes. + Branch: maint-5.6/perl + !> lib/Tie/SubstrHash.pm t/lib/tie-substrhash.t +____________________________________________________________________________ +[ 9197] By: gsar on 2001/03/18 12:15:57 + Log: more thorough cleaning of arenas--keep going until no more + SvREFCNT_dec()s occur (this fixes the problem that causes the + pesky "Scalars leaked" warnings) + Branch: maint-5.6/perl + ! embed.pl perl.c proto.h sv.c t/op/sort.t +____________________________________________________________________________ +[ 9168] By: jhi on 2001/03/15 14:13:22 + Log: Integrate changes #9120,9167 from mainline to maintperl. + + Subject: [PATCH 5.6.1] OS/2 docs + + Subject: [PATCH 5.6.1] perldoc + Branch: maint-5.6/perl + !> os2/Changes utils/perldoc.PL +____________________________________________________________________________ +[ 9162] By: gsar on 2001/03/15 00:56:53 + Log: avoid warnings + Branch: maint-5.6/perl + ! t/op/magic.t +____________________________________________________________________________ +[ 9161] By: gsar on 2001/03/15 00:52:09 + Log: clearing of $ENV{PERL_DESTRUCT_LEVEL} interferes with purify + results + Branch: maint-5.6/perl + ! t/op/magic.t +____________________________________________________________________________ +[ 9154] By: gsar on 2001/03/14 17:48:18 + Log: PerlIO_stdoutf() wasn't properly supported under PERL_IMPLICIT_SYS + (caused Storable 1.0.10 to break on windows) + Branch: maint-5.6/perl + ! embed.h embed.pl global.sym globals.c iperlsys.h objXSUB.h + ! perlapi.c proto.h +____________________________________________________________________________ +[ 9152] By: gsar on 2001/03/14 07:29:40 + Log: back out changes#9012,9010,9009 and parts of change#9016 + (causes ABRs under purify, and some prerequisites don't + seem to be there in 5.6.x) + Branch: maint-5.6/perl + ! doop.c op.c t/op/tr.t toke.c +____________________________________________________________________________ +[ 9142] By: gsar on 2001/03/14 03:20:48 + Log: fix another memory leak reported by purify (tie callbacks that + croak can leak when wiping out magic) + Branch: maint-5.6/perl + ! scope.c +____________________________________________________________________________ +[ 9138] By: gsar on 2001/03/14 01:18:00 + Log: remove squelch controls for "Scalars leaked" messages in most places + (these are now cured) + Branch: maint-5.6/perl + ! t/comp/proto.t t/op/lex_assign.t t/op/local.t t/op/pat.t + ! t/op/regexp.t t/pragma/strict-vars t/pragma/warn/op + ! t/pragma/warn/regcomp t/pragma/warn/toke t/pragma/warnings.t +____________________________________________________________________________ +[ 9137] By: gsar on 2001/03/14 00:57:04 + Log: fix leak in pregcomp() when RE fails to compile (e.g. m/\\/) + Branch: maint-5.6/perl + ! regcomp.c +____________________________________________________________________________ +[ 9133] By: gsar on 2001/03/13 22:46:20 + Log: integrate change#9067 from mainline + + Re: [PATCH: 5.6.1 trial2] DynaLoading for OS/390 build option + Branch: maint-5.6/perl + !> lib/ExtUtils/MM_Unix.pm +____________________________________________________________________________ +[ 9131] By: gsar on 2001/03/13 22:30:42 + Log: make the error text look more consistent in hints/hpux.sh + Branch: maint-5.6/perl + ! hints/hpux.sh +____________________________________________________________________________ +[ 9116] By: gsar on 2001/03/13 00:55:53 + Log: Win32::GetCwd() returns C: instead of C:\ in the root directory + under ithreads + Branch: maint-5.6/perl + ! win32/perlhost.h +____________________________________________________________________________ +[ 9108] By: gsar on 2001/03/12 10:21:31 + Log: fix memory leak in C<sub X { sub {} }> arising from a refcount + loop between the outer sub and the inner prototype anonsub + + this also enables closures returned by subroutines that + subsequently get redefined to work without generating coredumps :) + + completely removed the free_closures() hack--it shouldn't be + needed anymore + Branch: maint-5.6/perl + + t/op/anonsub.t + ! MANIFEST embed.h embed.pl op.c op.h pod/perlapi.pod pp_ctl.c + ! proto.h sv.c +____________________________________________________________________________ +[ 9076] By: jhi on 2001/03/07 22:59:39 + Log: Integrate change #7784 from mainline into maintperl. + + Subject: [PATCH 5.7.0] lexicals not recognized in a run-time (?{}) + Branch: maint-5.6/perl + !> pp_ctl.c t/op/pat.t +____________________________________________________________________________ +[ 9064] By: gsar on 2001/03/07 06:29:24 + Log: fix memory leak in pack("Bb",...) + Branch: maint-5.6/perl + ! perl.c +____________________________________________________________________________ +[ 9055] By: jhi on 2001/03/06 02:21:26 + Log: Integrate the change #9054 from mainline: + retract the PMOP cleanup patch pending further investigation. + Branch: maint-5.6/perl + !> op.c op.h +____________________________________________________________________________ +[ 9050] By: jhi on 2001/03/05 21:44:29 + Log: Integrate changes #9033 and #9044 from mainline into maintperl, + Sarathy's fix for ID 20010301.005. + Branch: maint-5.6/perl + !> op.c op.h +____________________________________________________________________________ +[ 9030] By: jhi on 2001/03/05 13:46:49 + Log: Subject: [PATCH 5.6.1] OS/2 cleanup + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Mon, 5 Mar 2001 02:29:44 -0500 + Message-ID: <20010305022944.A10117@math.ohio-state.edu> + Branch: maint-5.6/perl + + os2/os2add.sym + ! MANIFEST lib/ExtUtils/MM_OS2.pm lib/ExtUtils/MM_Unix.pm + ! makedef.pl os2/Changes os2/Makefile.SHs + ! os2/OS2/REXX/Makefile.PL os2/OS2/REXX/REXX.pm + ! os2/OS2/REXX/REXX.xs os2/OS2/REXX/t/rx_cmprt.t os2/os2.c + ! os2/os2.sym os2/os2ish.h +____________________________________________________________________________ +[ 9028] By: gsar on 2001/03/05 09:58:38 + Log: various nits in MM_Unix.pm found by disabling SelfLoader + Branch: maint-5.6/perl + ! lib/ExtUtils/MM_Unix.pm +____________________________________________________________________________ +[ 9026] By: jhi on 2001/03/05 02:14:59 + Log: Integrate change #9025 from mainline to maintperl, + retract \N{U+HHHH}. + Branch: maint-5.6/perl + !> lib/charnames.pm pod/perldiag.pod pod/perlretut.pod + !> t/lib/charnames.t toke.c +____________________________________________________________________________ +[ 9019] By: jhi on 2001/03/04 18:18:43 + Log: Integrate changes #9017 and 9018 from mainline into maintperl. + + \N{U+HHHH} fix. + + pattern in G_ARRAY context + Branch: maint-5.6/perl + !> pp_hot.c t/op/pat.t toke.c +____________________________________________________________________________ +[ 9016] By: jhi on 2001/03/04 17:41:22 + Log: Integrate changes #9013,9014,9015 from mainline into maintperl. + + Tweak the get*ent() OS/2 prototypes. + + Add the \N{U+HHHH} syntax. + + More tr/// UTF-8 fixes from Inaba Hiroto. + Branch: maint-5.6/perl + !> doop.c lib/charnames.pm os2/os2.c pod/perldiag.pod + !> pod/perlretut.pod t/lib/charnames.t t/op/tr.t toke.c +____________________________________________________________________________ +[ 9012] By: gsar on 2001/03/04 06:26:14 + Log: avoid warning (nit in change#9009) + Branch: maint-5.6/perl + ! toke.c +____________________________________________________________________________ +[ 9011] By: gsar on 2001/03/04 06:15:24 + Log: lib/charnames.t fails in 5.6.x because of older Unicode + data + + TODO: need to revisit this after updating lib/unicode/... + Branch: maint-5.6/perl + ! t/lib/charnames.t +____________________________________________________________________________ +[ 9010] By: gsar on 2001/03/04 06:08:36 + Log: change#9009 breaks build (no "didrange" variable in 5.6.x) + Branch: maint-5.6/perl + ! toke.c +____________________________________________________________________________ +[ 9009] By: jhi on 2001/03/03 19:27:20 + Log: Integrate change #9008 from mainline to maintperl, + UTF-8 tr/// fixes from Inaba Hiroto. + Branch: maint-5.6/perl + !> doop.c op.c t/op/tr.t toke.c +____________________________________________________________________________ +[ 9006] By: jhi on 2001/03/03 18:58:06 + Log: Subject: [PATCH 5.6.1] More robust Math::Complex + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Sat, 3 Mar 2001 12:51:50 -0500 + Message-ID: <20010303125150.A2147@math.ohio-state.edu> + + Be more robust in our quest for the infinite. + Branch: maint-5.6/perl + ! lib/Math/Complex.pm +____________________________________________________________________________ +[ 9005] By: jhi on 2001/03/03 17:55:50 + Log: The #8982 modified for perl 5.6.x, from Radu Greab. + Branch: maint-5.6/perl + ! doio.c +____________________________________________________________________________ +[ 9003] By: jhi on 2001/03/03 17:15:52 + Log: Integrate change #9002 from mainline to maintperl. + + Subject: [perl-5.6.x, perl-current] accept for EPOC + Branch: maint-5.6/perl + !> pp_sys.c +____________________________________________________________________________ +[ 8999] By: jhi on 2001/03/03 17:09:28 + Log: Subject: [PATCH 5.6.1] syslog.t + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Sat, 3 Mar 2001 02:11:17 -0500 + Message-ID: <20010303021116.A11897@math.ohio-state.edu> + Branch: maint-5.6/perl + ! t/lib/syslog.t +____________________________________________________________________________ +[ 8998] By: jhi on 2001/03/03 17:07:50 + Log: Subject: Re: [PATCH 5.7.0] compiling on OS/2: 5.6.1 too + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Sat, 3 Mar 2001 01:53:52 -0500 + Message-ID: <20010303015352.A11741@math.ohio-state.edu> + Branch: maint-5.6/perl + ! opcode.pl os2/os2.c +____________________________________________________________________________ +[ 8997] By: jhi on 2001/03/03 17:03:30 + Log: Subject: [PATCH 5.6.1] compiling on OS/2 + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Sat, 3 Mar 2001 01:59:59 -0500 + Message-ID: <20010303015959.B11741@math.ohio-state.edu> + Branch: maint-5.6/perl + ! hints/os2.sh +____________________________________________________________________________ +[ 8995] By: jhi on 2001/03/03 00:35:22 + Log: Integrate changes #8099,8218,8220,8221,8227,8304,8317, + 8318,8320,8337,8503,8877,8890,8903,8971 from mainline + to maintperl. + + Subject: Re: [ID 20000328.039] [PATCH] Eliminate Configure use of /tmp + + Add Configure option -Dmksymlinks which will create a symlink + forest if the current/build differs from the source directory. + (8218,8220,8221,8317,8318,8971) + + Subject: Re: A Configure option like 'otherlibdirs' but for *pre*pending? + (Document APPLLIB_EXP in INSTALL.) + + If running byacc write-enable also perly.h. + + DB3 NDBM/ODBM emulation tweaks from Stanislav Brabec <utx@penguin.cz>. + + Subject: [PATCH 5.7.1/Configure] failure to set src='.' + + Sanity check for conflicting thread flavours. + + Fix the sys/fcntl.h problem reported by Peter Prymmer. + + Add few CPUs/architectures to the Cppsym scan, + add -perlio to archname if so selected (modified 8890) + + Be more helpful for devel builders, suggested by John L. Allen. + (admittedly pointless change for maintperl, but the usedevel + code is there already) + Branch: maint-5.6/perl + !> Configure INSTALL Makefile.SH Porting/Glossary + !> Porting/config.sh Porting/config_H config_h.SH embed.pl + !> epoc/config.sh ext/NDBM_File/NDBM_File.xs + !> ext/ODBM_File/ODBM_File.xs t/io/fs.t warnings.pl + !> win32/config.bc win32/config.gc win32/config.vc +____________________________________________________________________________ +[ 8993] By: jhi on 2001/03/02 23:22:12 + Log: Regenerate various files for maint. + Branch: maint-5.6/perl + ! Porting/Glossary Porting/config.sh Porting/config_H objXSUB.h + ! perlapi.c pod/perlapi.pod pod/perltoc.pod proto.h +____________________________________________________________________________ +[ 8991] By: jhi on 2001/03/02 21:00:08 + Log: Retract the #8742 part of #8986, backward compat. + Branch: maint-5.6/perl + ! embed.pl +____________________________________________________________________________ +[ 8990] By: jhi on 2001/03/02 20:40:07 + Log: Retract the #8919 part of #8987, not applicable to the 5.6 branch. + Branch: maint-5.6/perl + ! hv.c +____________________________________________________________________________ +[ 8987] By: jhi on 2001/03/02 19:43:40 + Log: Integrate changes #8784,8839,8843,8847,8849,8859,8866, + 8873,8874,8876,8879,8901,8902,8908,8913,8918,8919,8946,8947,8948, + 8950,8952,8955 from mainline to maintperl. + + Subject: [PATCH: perl@8773] small fixups to perlclib.pod + + Put to rest the 20010205.001, the email address checking (not) regex. + + fork() not everywhere, cleanup temp files. + + The #8843 wasn't quite right: %Config needs to imported. + + Subject: [PATCH perl@8841] glob-basic.t, runenv.t fix-ups + (#8849: the glob-basic hunk needed massaging as it depended + on Schwern's large-scale (unintegrated) patches) + + Skip the Perl_sys_intern_clear and Perl_sys_intern_init. + + Upgrade to CGI.pm 2.752, from Lincoln Stein. + (Note: there were some conflicts due to EBCDIC and EPOC + patches, in general I preferred the repository code.) + (When 2.753 comes out, we need to synchronize.) + + Subject: [PATCH] fix for charnames above FFFF + + Subject: [patch perl@8841] One URL update and a possible OS Version snag for perlport.pod + + If no sfio, no -lsfio. + + Run run/*.t also in minitest. + + Subject: [PATCH perl 5.7.0] malloc message address offset + + Subject: [PATCH 5.7.0] don't zero CvFLAGS before checking for CvCONST! + + Subject: fix for parameter -Dm (for perl@8867) + + Subject: [PATCH: perl@8892] was Re: hashing order difference? + (make the test more portable) + + Subject: Re: [PATCH] fix for charnames above FFFF + + Subject: Re: I'm losing the war... + (hv_store() not working correctly in ENV_IS_CASELESS case.) + + Subject: Modified README.bs2000 + + Subject: [PATCH: perl@8935] -Dt padsv($var) + + Subject: [PATCH: perl@8890] small fix in pod/perlop.pod + + Subject: PATCH: extra tests to check on negative float to unsigned cast + + Subject: [PATCH] XPUSH[insp] was Re: progress + + Subject: Re: Compile with perlcc.. + Branch: maint-5.6/perl + !> (integrate 36 files) +____________________________________________________________________________ +[ 8986] By: jhi on 2001/03/02 18:51:25 + Log: Integrate changes #8689,8697,8724,8726,8731,8742,8754,8755, + 8763,8767,8770,8772,8795,8796,8813,8822,8823 from mainline + to maintperl. + + Subject: Re: [PATCH lots of pod/] s/chop/chomp/g + + Subject: [DOC PATCH] overload.pm nits + + Add header for LIB$ prototypes (C. Berry) + + Convert fwrite()s to sockets to write()s, since some socket stacks + don't take kindly to stdio. + Ignore "expected" SS$_NOLOGNAM when doing internal LNM lookups + (for often optional LNMs) + Correct a few typos + (C. Bailey) + + Subject: [PATCH: 5.6.1 trial2 && perl@8671] provide EBCDIC CGI::Util::escape() and test + + De-cut-and-pasto. + + Subject: Re: [PATCH embed.pl] Forgot to add ./lib to @INC for File::Glob + + Upgrade to Text-Tabs+Wrap-2001.0131 from David Muir Sharnoff. + + Upgrade to CPAN 1.59_54, from Andreas König. + + Bogus shebang. + + Subject: [PATCH] Document makepatch in Porting/patching + + UTF-8 documentation. + + Subject: Re: [PATCH] pod/perlclib.pod - Replacements for C library functions + + Sort the MANIFEST. + + Subject: [ID 20010210.002] perldiag doesn't include the "Scalars leaked" message + + Subject: [PATCH @8807] toke.c cleanup: scan_str() + + Subject: [PATCH perl.c] Fixing PERL5OPT (was Re: Warnings, strict, and CPAN) + + Add run/*.t to testables. + + TODO: integrate #8784. + Branch: maint-5.6/perl + +> pod/perlclib.pod t/lib/cgi-esc.t t/run/runenv.t + !> (integrate 28 files) +____________________________________________________________________________ +[ 8984] By: jhi on 2001/03/02 16:00:17 + Log: Integrate changes #8978,8979,8980,8981,8983 from mainline. + + perlfaq1 reworded to suggest 5.6.0 or 5.005_03, or POSSIBLY + 5.004_05, and mention the suidperl August 2000 security problem. + (#8978,#8981) + + Subject: [ID 20010301.004] Technically speaking in perldata + + Subject: [PATCH] File::Copy for bleadperl, maintperl + + Subject: [PATCH 5.7.0/5.6.0+] VMS piping ... cleanup at interpreter exit + + (The #8982, fix for 20010221.005 and 20010221.008, + would be nice too but it didn't integrate cleanly.) + Branch: maint-5.6/perl + !> lib/File/Copy.pm pod/perldata.pod pod/perlfaq1.pod vms/vms.c +____________________________________________________________________________ +[ 8974] By: gsar on 2001/03/01 16:28:21 + Log: fix for bugid 20010226.008 + + the problem was that some of the pointers (PL_last_lop and + PL_last_uni specifically) into the lex buffers weren't correctly + being invalidated when the buffer changed; this would leave the + pointers pointing at an arbitrary location in the buffer if + the buffer didn't need to be reallocated, or point into freed + memory if the buffer had to be realloced + + TODO item for bugdb maintainers: check other seemingly random + parser-related bugs--they might be cured by this + Branch: maint-5.6/perl + ! toke.c +____________________________________________________________________________ +[ 8960] By: jhi on 2001/02/27 22:51:33 + Log: Subject: [PATCH perl@8958 and 5.6.1-trial2] configure.com bug fixing spree + From: "Craig A. Berry" <craigberry@mac.com> + Date: Tue, 27 Feb 2001 16:11:44 -0600 + Message-Id: <5.0.2.1.0.20010227150548.02a200f8@exchi01> + Branch: maint-5.6/perl + ! configure.com vms/descrip_mms.template +____________________________________________________________________________ +[ 8957] By: jhi on 2001/02/27 06:15:07 + Log: Subject: [5.6.x] EPOC additions + From: Olaf Flebbe <O.Flebbe@science-computing.de> + Date: Mon, 26 Feb 2001 23:33:46 +0100 (CET) + Message-ID: <Pine.LNX.4.02.10102262333040.3736-100000@milkyway.science-computing.de> + Branch: maint-5.6/perl + ! AUTHORS README.epoc epoc/createpkg.pl pp_sys.c +____________________________________________________________________________ +[ 8945] By: jhi on 2001/02/26 14:19:53 + Log: Integrate the t/op/sprintf.t parts of #7909 and #8944 from mainline + to maintperl, listing the known failures on the tests 129 and 130. + Branch: maint-5.6/perl + !> t/op/sprintf.t +____________________________________________________________________________ +[ 8917] By: jhi on 2001/02/23 20:27:51 + Log: Integrate change #8916 from mainline, + do away with USE_WIN32_RTL_ENV. + Branch: maint-5.6/perl + !> perl.c util.c win32/win32.c win32/win32.h win32/win32iop.h +____________________________________________________________________________ +[ 8911] By: jhi on 2001/02/23 04:20:02 + Log: Integrate changes #8896,8897,8898,8906,8907,8908 from mainline. + + Duplicated environment freeing, File::Temp 0.12, + op/append portability (EBCDIC) tweak. + Branch: maint-5.6/perl + !> lib/File/Temp.pm perl.c t/lib/ftmp-mktemp.t t/lib/ftmp-posix.t + !> t/op/append.t +____________________________________________________________________________ +[ 8910] By: jhi on 2001/02/23 02:07:33 + Log: Integrate change #8909 from mainline, a better Borland + putenv() workaround. + Branch: maint-5.6/perl + !> perl.c +____________________________________________________________________________ +[ 8900] By: jhi on 2001/02/23 01:18:02 + Log: Integrate changes #8898,8899 from mainline, environ handling. + Branch: maint-5.6/perl + !> perl.c +____________________________________________________________________________ +[ 8894] By: gsar on 2001/02/22 19:06:18 + Log: integrate changes#6162,6163 from mainline (missing leak fixes!) + + fix memory leak in method call optimization (change#3768); + made C<eval "$x->foo()"> leak + + fix memory leak in C<eval "BEGIN {}"> (bug in change#4579) + Branch: maint-5.6/perl + !> op.c +____________________________________________________________________________ +[ 8886] By: jhi on 2001/02/22 12:49:24 + Log: Integrate changes #8883,8884 from mainline to maintperl. + + Subject: [patch: perl@8867] embed.{h|pl} need not mention ebcdic_control ... + Subject: Re: File::Temp::_gettemp warning + Branch: maint-5.6/perl + !> embed.h embed.pl lib/File/Temp.pm +____________________________________________________________________________ +[ 8885] By: jhi on 2001/02/22 12:43:59 + Log: Based on + + Subject: [ID 20010222.001] POSIX.xs IV vs NV bug + From: schwab@suse.de + Date: Thu, 22 Feb 2001 13:08:09 +0100 + Message-Id: <200102221208.f1MC89H09364@sykes.suse.de> + + but the fix done slightly differently because the other + half was already done in #8664. + Branch: maint-5.6/perl + ! ext/POSIX/POSIX.xs +____________________________________________________________________________ +[ 8882] By: jhi on 2001/02/21 19:41:33 + Log: Integrate change #8881 from mainlin to maintperl. + + Subject: [PATCH - perl8585] glob-in-eval memory leak fix + Branch: maint-5.6/perl + !> op.c +____________________________________________________________________________ +[ 8871] By: jhi on 2001/02/21 14:07:29 + Log: Integrate change #8868 from pureperl to maintperl. + + Fixed reference count loop caused by sv_magic. + Branch: maint-5.6/perl + !> sv.c +____________________________________________________________________________ +[ 8863] By: jhi on 2001/02/20 20:55:11 + Log: Integrate change #8860,8861 from mainline into maintperl. + + "pseudo-literal j" + + Subject: [PATCH: 5.6.1 trial2 && perl@8807] workaround VMS I/O problem in Test.pm for bug ID 20010213.009 + Branch: maint-5.6/perl + !> lib/Test.pm pod/perlop.pod +____________________________________________________________________________ +[ 8856] By: jhi on 2001/02/20 17:33:16 + Log: Integrate change #8848 from mainline to maintperl: ?DBM_File cleanup. + Branch: maint-5.6/perl + !> ext/GDBM_File/GDBM_File.pm ext/NDBM_File/NDBM_File.pm + !> ext/ODBM_File/ODBM_File.pm ext/SDBM_File/SDBM_File.pm + !> t/lib/gdbm.t t/lib/ndbm.t t/lib/odbm.t t/lib/sdbm.t +____________________________________________________________________________ +[ 8855] By: jhi on 2001/02/20 17:32:13 + Log: Integrate pureperl changes #8844,8845,8850 to maintperl. + + Fixed %^H scoping bug + + Removed GV <-> CV refcount loop + + Removed %ENV refcount loop + Branch: maint-5.6/perl + !> gv.c op.c perl.c pp.c scope.c +____________________________________________________________________________ +[ 8854] By: jhi on 2001/02/20 17:25:06 + Log: Subject: Addition to readme.win32 for Borland C++ compilers + Date: Tue, 20 Feb 2001 02:15:25 +0300 + From: "Vadim Konovalov" <watman@inbox.ru> + Message-ID: <011c01c09aca$93bbbec0$367b55c2@vad> + + Document Borland compiler misbehaviour. + Branch: maint-5.6/perl + ! README.win32 +____________________________________________________________________________ +[ 8853] By: jhi on 2001/02/20 17:22:25 + Log: The assimilation of ebcdic.c didn't quite work at the first try, + patches from Thomas Dorner. + Branch: maint-5.6/perl + ! handy.h util.c +____________________________________________________________________________ +[ 8852] By: jhi on 2001/02/20 17:20:15 + Log: Subject: [PATCH] More Mac OS patches for maint-5.6 + From: Chris Nandor <pudge@pobox.com> + Date: Tue, 20 Feb 2001 08:32:45 -0500 + Message-Id: <p05010403b6b81ee8dca0@[10.0.1.177]> + Branch: maint-5.6/perl + ! makedef.pl mg.c +____________________________________________________________________________ +[ 8831] By: jhi on 2001/02/18 19:14:20 + Log: Integrate change #8827 from mainline. + + UTF8 tweaks. + Branch: maint-5.6/perl + !> sv.c utf8.c +____________________________________________________________________________ +[ 8818] By: jhi on 2001/02/18 02:24:50 + Log: FAQ nit from Chris Fedde. + Branch: maint-5.6/perl + ! pod/perlfaq4.pod +____________________________________________________________________________ +[ 8810] By: jhi on 2001/02/15 13:35:08 + Log: Upgrade to podlators 1.08, from Russ Allbery. + Branch: maint-5.6/perl + ! lib/Pod/Man.pm lib/Pod/Text.pm +____________________________________________________________________________ +[ 8809] By: jhi on 2001/02/15 13:26:38 + Log: (accidentally empty check-in) + Branch: maint-5.6/perl + ! lib/Test/Harness.pm +____________________________________________________________________________ +[ 8808] By: jhi on 2001/02/15 13:23:47 + Log: Subject: [PATCH 5.6.1-TRIAL2] perldoc.PL using install directories + From: Russ Allbery <rra@stanford.edu> + Date: 14 Feb 2001 10:15:41 -0800 + Message-ID: <ylzofpf7w2.fsf@windlord.stanford.edu> + + perldoc was hardcoding $Config{installscript}, which breaks + when install* isn't where Perl ends up (such as with AFS). + + Use $Config{scriptdir} instead. + Branch: maint-5.6/perl + ! utils/perldoc.PL +____________________________________________________________________________ +[ 8806] By: jhi on 2001/02/14 14:25:31 + Log: Integrate changes #8803,8804,8805 from mainline. + + Duplicate environment for JPL so that JDK 1.2/1.3 don't get upset. + + Don't skip too much of the locale error message if no environ array, + from Chris Nandor. + + More MacOS Classic fixes from Chris Nandor. + Branch: maint-5.6/perl + !> doop.c lib/Cwd.pm perl.c perl.h util.c +____________________________________________________________________________ +[ 8801] By: jhi on 2001/02/13 17:55:19 + Log: Integrate change #8792 from mainline. + + Subject: buncha MacPerl patches for bleadperl + From: Chris Nandor <pudge@pobox.com> + Date: Tue, 13 Feb 2001 00:02:43 -0500 + Message-Id: <p05010404b6ae6f85e07a@[10.0.1.177]> + Branch: maint-5.6/perl + !> lib/AutoLoader.pm lib/AutoSplit.pm lib/ExtUtils/MakeMaker.pm + !> lib/File/Basename.pm makedef.pl perl.c pp_ctl.c + !> t/lib/basename.t toke.c util.h +____________________________________________________________________________ +[ 8800] By: jhi on 2001/02/13 17:46:43 + Log: When doing that Fpos_t used in PerlIO_getpos proto needs + to be forced to Off_t. + + Subject: [ID 20010201.009] 5.6.1-TRIAL2 sfio build fails + From: nick@ccl4.org + Date: Thu, 1 Feb 2001 12:01:04 +0000 + Message-Id: <20010201120103.E11401@plum.flirble.org> + Branch: maint-5.6/perl + ! iperlsys.h perlio.c +____________________________________________________________________________ +[ 8799] By: jhi on 2001/02/13 16:52:51 + Log: Duplex duplex hunk hunk. + Branch: maint-5.6/perl + ! Makefile.SH +____________________________________________________________________________ +[ 8794] By: jhi on 2001/02/13 14:26:51 + Log: Integrate change #8793 from mainline, FAQ updates. + Branch: maint-5.6/perl + !> pod/perlfaq5.pod pod/perlfaq6.pod pod/perlfaq9.pod +____________________________________________________________________________ +[ 8791] By: jhi on 2001/02/13 14:10:39 + Log: Integrate change #8790 from mainline. + + environ array wrongly assumed in Perl_init_i18nl10n(), + Branch: maint-5.6/perl + !> util.c +____________________________________________________________________________ +[ 8789] By: jhi on 2001/02/13 13:58:07 + Log: Integrate changes #8373,8487,8544,8783 from mainline. + + Synchronize the EBCDIC platforms (os390,posix-bc,vmesa): + hints files, the dynaloading, assimilate ebcdic into util.c. + Branch: maint-5.6/perl + - ebcdic.c + ! MANIFEST hints/posix-bc.sh + !> Makefile.SH embed.h embed.pl ext/DynaLoader/dl_dllload.xs + !> handy.h hints/os390.sh hints/vmesa.sh installperl objXSUB.h + !> perlapi.c proto.h util.c +____________________________________________________________________________ +[ 8786] By: jhi on 2001/02/13 05:54:34 + Log: Subject: perl@8671 on posix-bc aka BS2000 Posix (small Patch included!) + From: Dorner Thomas <Thomas.Dorner@start.de> + Date: Mon, 12 Feb 2001 15:06:26 +0100 + Message-ID: <6727B1DACFCDD311A757009027CA8D69010A8853@Ex02.inhouse.start.de> + Branch: maint-5.6/perl + ! Makefile.SH +____________________________________________________________________________ +[ 8782] By: jhi on 2001/02/13 02:00:07 + Log: Add OpenBSD to the list of 5.6.1-okay platforms. + Branch: maint-5.6/perl + ! pod/perlport.pod +____________________________________________________________________________ +[ 8781] By: jhi on 2001/02/13 01:58:44 + Log: OpenBSD hints update for 5.6.1-TRIAL2 from Todd C. Miller. + Branch: maint-5.6/perl + ! hints/openbsd.sh +____________________________________________________________________________ +[ 8780] By: jhi on 2001/02/13 01:57:33 + Log: Synchronize the regexp tests between maintperl and mainline. + Branch: maint-5.6/perl + !> t/op/re_tests +____________________________________________________________________________ +[ 8777] By: jhi on 2001/02/13 00:17:54 + Log: Subject: Re: [ID 20010212.006] Core dump with /((?:hard|soft)cover)?/ + From: Hugo <hv@crypt.compulink.co.uk> + Date: Tue, 13 Feb 2001 00:11:11 +0000 + Message-Id: <200102130011.AAA14310@crypt.compulink.co.uk> + Branch: maint-5.6/perl + ! regcomp.c t/op/re_tests +____________________________________________________________________________ +[ 8776] By: jhi on 2001/02/12 23:25:52 + Log: Add VOS to the list of 5.6.1 known-to-be-working platforms. + Branch: maint-5.6/perl + ! pod/perlport.pod +____________________________________________________________________________ +[ 8775] By: jhi on 2001/02/12 23:04:28 + Log: VOS updates for 5.6-TRIAL2 from Paul Green. + Branch: maint-5.6/perl + ! README.vos vos/Changes vos/build.cm vos/config.alpha.def + ! vos/config.alpha.h vos/config.ga.def vos/config.ga.h + ! vos/configure_perl.cm +____________________________________________________________________________ +[ 8758] By: jhi on 2001/02/10 18:01:17 + Log: Integrate changes #8701,8704,8756 from pureperl to maintperl. + + Fixed UMRs and leak in Perl_pmtrans() + + Several leaks an UMRs fixed, mainly in the area of Perl_pmtrans and + associated UTFied tr/// code. Also fixed scoping leak of + PL_reg_start_tmp. + + newATTRSUB leaks when an attempt to redefine the active sort sub is + made. + Branch: maint-5.6/perl + !> op.c regcomp.c +____________________________________________________________________________ +[ 8748] By: jhi on 2001/02/09 18:31:34 + Log: Integrate changes #8673,8674,8676 from maintperl into mainline, + plus manual tweakage. + + Sync the perlfaq2 between mainline and maintperl. + Branch: maint-5.6/perl + ! pod/perlfaq2.pod + Branch: perl + !> pod/perlfaq2.pod +____________________________________________________________________________ +[ 8746] By: jhi on 2001/02/09 18:03:43 + Log: Integrate changes #8699,8708,8709,8744,8745 from mainline. + + Subject: perlfaq2, re: perlmongers + + Subject: Re: [PATCH pod/[bt]ootc?.pod] Adding mention of useful CPAN modules + + Subject: [PATCH pod/perlmodlib.PL 5.6.1-TRIAL2] Up to date CPAN mirror list + + Subject: [ID 20010205.001] typo in perlfaq9 + + Subject: [ID 20010208.002] unordered explanation in perlcall + Branch: maint-5.6/perl + !> pod/perlapi.pod pod/perlboot.pod pod/perlcall.pod + !> pod/perlfaq2.pod pod/perlfaq9.pod pod/perlmodlib.PL + !> pod/perlobj.pod pod/perltoot.pod pod/perltootc.pod +____________________________________________________________________________ +[ 8740] By: jhi on 2001/02/09 17:03:46 + Log: Subject: [PATCH perl-current] perlfaq3.pod, URL for vile + From: "Brendan O'Dea" <bod@compusol.com.au> + Date: Sun, 4 Feb 2001 11:17:56 +1100 + Message-ID: <20010204111756.A16301@compusol.com.au> + Branch: maint-5.6/perl + ! pod/perlfaq3.pod +____________________________________________________________________________ +[ 8739] By: jhi on 2001/02/09 17:01:59 + Log: Subject: [PATCH: perl-5.6.1-TRIAL2] installhtml change to build prettier html files + From: "Indy Singh" <indy@nusphere.com> + Date: Fri, 2 Feb 2001 15:09:59 -0500 + Message-ID: <02b601c08d54$23fd3560$d24b7018@cr637287a> + + Html files will be generated with a header to make them look + a little less bare. + Branch: maint-5.6/perl + ! installhtml +____________________________________________________________________________ +[ 8738] By: jhi on 2001/02/09 16:58:48 + Log: Subject: [PATCH: perl-5.6.1-TRIAL2] Win32 Makefile change to move html directory + From: "Indy Singh" <indy@nusphere.com> + Date: Fri, 2 Feb 2001 15:08:23 -0500 + Message-ID: <02b501c08d53$ec354550$d24b7018@cr637287a> + + Html files will be installed in a more logical and easier to + find directory. E.g. c:\perl\html instead of c:\perl\lib\pod\html + Branch: maint-5.6/perl + ! win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 8736] By: jhi on 2001/02/09 16:42:31 + Log: Latin nit from Philip Newton. + Branch: maint-5.6/perl + ! README.hpux +____________________________________________________________________________ +[ 8733] By: jhi on 2001/02/09 15:35:47 + Log: Subject: Re: [PATCH: 5.6.1 trial 2 && perl@8671] some coded char set issues in perlre.pod + From: Prymmer/Kahn <pvhp@best.com> + Date: Thu, 8 Feb 2001 21:21:22 -0800 (PST) + Message-ID: <Pine.BSF.4.21.0102082048360.1499-100000@shell8.ba.best.com> + Branch: maint-5.6/perl + ! pod/perlre.pod +____________________________________________________________________________ +[ 8732] By: jhi on 2001/02/09 15:26:17 + Log: Rename README.posix-bc to README.bs2000 (to avoid the + confusion of a "perlposix-bc.pod"), add a few missing + arch pods, regen toc. + Branch: maint-5.6/perl + +> README.bs2000 + - README.posix-bc + ! MANIFEST pod/buildtoc.PL pod/perl.pod pod/perlport.pod + ! pod/perltoc.pod win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 8728] By: jhi on 2001/02/09 14:46:06 + Log: Subject: [PATCH: 5.6.1 trial 2 && perl@8671] podify README.vmesa + From: Peter Prymmer <pvhp@forte.com> + Date: Thu, 8 Feb 2001 13:00:30 -0800 (PST) + Message-ID: <Pine.OSF.4.10.10102081246030.445810-100000@aspara.forte.com> + Branch: maint-5.6/perl + ! README.vmesa win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 8727] By: jhi on 2001/02/09 14:33:25 + Log: Integrate change #8712 from mainline. + + [PATCH: perl-5.6.1 trial2 && perl@8671] VMS specific simplification for Pod::Find + Branch: maint-5.6/perl + !> lib/Pod/Find.pm +____________________________________________________________________________ +[ 8725] By: jhi on 2001/02/09 04:56:47 + Log: Add NonStopUX to the list of 5.6.1-proven platforms. + Branch: maint-5.6/perl + ! pod/perlport.pod +____________________________________________________________________________ +[ 8723] By: jhi on 2001/02/09 03:29:29 + Log: Integrate change #8722 from mainline. + + The Im() function wasn't returning zero for non-Math::Complex + arguments. The bug reported by John Gamble. + Branch: maint-5.6/perl + !> lib/Math/Complex.pm +____________________________________________________________________________ +[ 8703] By: gsar on 2001/02/06 02:29:37 + Log: $(MAKE) distclean doesn't clean up properly on windows + Branch: maint-5.6/perl + ! win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 8702] By: gsar on 2001/02/06 01:00:46 + Log: tweak change#8659 to keep it simple + Branch: maint-5.6/perl + ! utils/perldoc.PL +____________________________________________________________________________ +[ 8701] By: gsar on 2001/02/05 22:45:41 + Log: change#8693 was missing testsuite changes + Branch: maint-5.6/perl + !> t/lib/db-btree.t t/lib/db-hash.t t/lib/db-recno.t +____________________________________________________________________________ +[ 8695] By: gsar on 2001/02/05 03:27:34 + Log: thread.h tweak to enable 5005threads on HP-UX 10.20 with DCE threads + Branch: maint-5.6/perl + ! thread.h +____________________________________________________________________________ +[ 8693] By: gsar on 2001/02/04 22:38:49 + Log: integrate changes#7801,8068,8094,8108,8196 from mainline (DB_File + changes) + Branch: maint-5.6/perl + !> ext/DB_File/Changes ext/DB_File/DB_File.pm + !> ext/DB_File/DB_File.xs ext/DB_File/dbinfo ext/DB_File/typemap + !> ext/DB_File/version.c +____________________________________________________________________________ +[ 8687] By: jhi on 2001/02/03 17:11:42 + Log: HP-UX thread patches from Merijn H. Brand. + Branch: maint-5.6/perl + ! README.hpux hints/hpux.sh +____________________________________________________________________________ +[ 8682] By: jhi on 2001/02/03 05:52:11 + Log: IRIX hints fix from Scott Henry, get Configure -Dcc="cc -64 -mips3" + to work correctly. + Branch: maint-5.6/perl + ! hints/irix_6.sh +____________________________________________________________________________ +[ 8681] By: jhi on 2001/02/03 05:47:33 + Log: perlport tweaks from Peter Prymmer and Chris Nandor. + Branch: maint-5.6/perl + ! pod/perlport.pod +____________________________________________________________________________ +[ 8680] By: jhi on 2001/02/02 21:39:49 + Log: perlport update from Peter Prymmer. + Branch: maint-5.6/perl + ! pod/perlport.pod +____________________________________________________________________________ +[ 8678] By: gsar on 2001/02/02 16:02:12 + Log: note about bincompat, slightly modified (from Lupe Christoph) + Branch: maint-5.6/perl + ! README.solaris +____________________________________________________________________________ +[ 8677] By: jhi on 2001/02/02 15:46:20 + Log: Supported platforms updates. + Branch: maint-5.6/perl + ! pod/perlport.pod +____________________________________________________________________________ +[ 8676] By: jhi on 2001/02/02 03:41:26 + Log: A couple more perlfaq2 tweaks. + Branch: maint-5.6/perl + ! pod/perlfaq2.pod +____________________________________________________________________________ +[ 8675] By: jhi on 2001/02/02 03:17:44 + Log: Misedit in #8661. + Branch: maint-5.6/perl + ! Configure +____________________________________________________________________________ +[ 8674] By: jhi on 2001/02/02 03:14:38 + Log: Damien again. + Branch: maint-5.6/perl + ! pod/perlfaq2.pod +____________________________________________________________________________ +[ 8673] By: jhi on 2001/02/02 03:12:40 + Log: perlfaq update from Elaine Ashton. + Branch: maint-5.6/perl + ! pod/perlfaq2.pod +____________________________________________________________________________ +[ 8672] By: jhi on 2001/02/02 03:07:08 + Log: UTF-8 s/// patch from Inaba Hiroto. + Branch: maint-5.6/perl + ! pp_ctl.c pp_hot.c +____________________________________________________________________________ +[ 8669] By: jhi on 2001/02/01 21:57:02 + Log: Subject: Re: [PATCH perl5.6.1-TRIAL2] long C<=item>s in perlmodlib.pod + From: Robin Barker <rmb1@cise.npl.co.uk> + Date: Thu, 1 Feb 2001 16:59:05 GMT + Message-Id: <200102011659.QAA01274@tempest.npl.co.uk> + Branch: maint-5.6/perl + ! pod/perlmodlib.PL +____________________________________________________________________________ +[ 8667] By: gsar on 2001/02/01 16:59:11 + Log: add ppaddr as one of the compatibility symbols under -DPERL_POLLUTE + Branch: maint-5.6/perl + ! embed.pl embedvar.h +____________________________________________________________________________ +[ 8666] By: gsar on 2001/02/01 16:34:51 + Log: add missing entries to win32/config.?c + Branch: maint-5.6/perl + ! win32/config.bc win32/config.gc win32/config.vc + ! win32/config_H.bc win32/config_H.gc win32/config_H.vc +____________________________________________________________________________ +[ 8665] By: jhi on 2001/02/01 14:58:51 + Log: Subject: Re: [ID 20010201.006] bad pointer from perlfunc to perlmod + From: "Stephen P. Potter" <spp@spotter.yi.org> + Date: Thu, 01 Feb 2001 10:45:46 -0500 + Message-Id: <200102011545.KAA31479@spotter.yi.org> + Branch: maint-5.6/perl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 8664] By: gsar on 2001/02/01 14:52:37 + Log: need to use INT2PTR instead of a straight cast or ia64 fails + posix.t (from Brendan O'Dea <bod@compusol.com.au>) + Branch: maint-5.6/perl + ! ext/POSIX/POSIX.xs +____________________________________________________________________________ +[ 8663] By: jhi on 2001/02/01 14:09:13 + Log: Allow the float to be fuzzier. + Branch: maint-5.6/perl + ! t/lib/peek.t +____________________________________________________________________________ +[ 8662] By: jhi on 2001/02/01 13:59:00 + Log: Subject: [PATCH perl5.6.1-TRIAL2] long C<=item>s in perlmodlib.pod + From: Robin Barker <rmb1@cise.npl.co.uk> + Date: Thu, 1 Feb 2001 13:05:39 GMT + Message-Id: <200102011305.NAA26160@tempest.npl.co.uk> + Branch: maint-5.6/perl + ! pod/perlmodlib.pod +____________________________________________________________________________ +[ 8661] By: jhi on 2001/02/01 13:57:38 + Log: Subject: [PATCH] Re: v5.6.1 trial2 is available + Date: Thu, 01 Feb 2001 14:15:41 +0100 + From: "H.Merijn Brand" <h.m.brand@hccnet.nl> + Message-Id: <20010201141104.303F.H.M.BRAND@hccnet.nl> + + Have the $ccflags in the gcc version test (strange, this change + is claimed to be have been integrated already) + Branch: maint-5.6/perl + ! Configure +____________________________________________________________________________ +[ 8660] By: jhi on 2001/02/01 13:44:10 + Log: Integrate changes #7950,7964,7962 from mainline. + + Find the stdchar signedness using cpp, should fix some of + the Solaris compiler warnings reported by Alan Burlison. + Branch: maint-5.6/perl + !> Configure config_h.SH +____________________________________________________________________________ +[ 8659] By: jhi on 2001/02/01 05:35:32 + Log: Subject: [PATCH 5.6.1-TRIAL? and 5.7.?] perldoc uses unescaped backslashes in filenames + From: Jan Dubois <JanD@ActiveState.com> + Date: Wed, 31 Jan 2001 21:17:03 -0800 + Message-ID: <8qrh7t069jt32m98sap53l9dfoge0vjrle@4ax.com> + Branch: maint-5.6/perl + ! utils/perldoc.PL +____________________________________________________________________________ +[ 8658] By: jhi on 2001/02/01 04:33:17 + Log: Integrate the README.os390 and README.posix-bc parts of mainline + changes #8373,8486, 8544,8556. (The hints/os390.sh,Makefile.SH, + installperl parts were taken care of by #8657.) + Branch: maint-5.6/perl + !> README.os390 README.posix-bc +____________________________________________________________________________ +[ 8657] By: jhi on 2001/02/01 04:29:21 + Log: Subject: [PATCH: 5.6.1 trial2] DynaLoading for OS/390 build option + From: Peter Prymmer <pvhp@forte.com> + Date: Wed, 31 Jan 2001 18:18:11 -0800 (PST) + Message-ID: <Pine.OSF.4.10.10101311815560.336633-100000@aspara.forte.com> + Branch: maint-5.6/perl + + ext/DynaLoader/dl_dllload.xs + ! MANIFEST Makefile.SH hints/os390.sh installperl +____________________________________________________________________________ +[ 8656] By: jhi on 2001/02/01 04:25:45 + Log: Subject: [PATCH: 5.6.1 trial2]Not OK: perl v5.6.1 +v5.6.1-TRIAL2 on os390 05.00 (UNINSTALLED) + From: Peter Prymmer <pvhp@forte.com> + Date: Wed, 31 Jan 2001 15:26:57 -0800 (PST) + Message-ID: <Pine.OSF.4.10.10101311523101.336633-100000@aspara.forte.com> + Branch: maint-5.6/perl + ! lib/Math/BigInt.pm lib/bigint.pl t/lib/b.t t/pragma/sub_lval.t +____________________________________________________________________________ +[ 8655] By: jhi on 2001/02/01 04:14:47 + Log: Subject: [ID 20010131.066] Not OK: perl v5.6.1 +v5.6.1-TRIAL2 on os2 2.40 (UNINSTALLED) + From: troc@netrus.net + Date: Wed, 31 Jan 2001 22:31:26 -0500 + Message-Id: <200102010331.WAA117.85@rocco.homenet> + Branch: maint-5.6/perl + ! os2/os2.c +____________________________________________________________________________ +[ 8654] By: jhi on 2001/02/01 04:12:52 + Log: Solaris 2.7 i386 #defines SP in /usr/include/sys/reg.h + as reported by Alan Burlison. + Branch: maint-5.6/perl + ! pp.h +____________________________________________________________________________ +[ 8653] By: jhi on 2001/02/01 04:05:12 + Log: Subject: [ID 20010131.042] Not OK: perl v5.6.1 +v5.6.1-TRIAL2 on VMS_AXP V7.2-1 + From: dsugalski@northernlight.com + Date: Wed, 31 Jan 2001 18:54:11 -0500 + Message-Id: <01013118541126@monsoon.stratus.northernlight.com> + Branch: maint-5.6/perl + ! configure.com +____________________________________________________________________________ +[ 8652] By: jhi on 2001/02/01 04:03:11 + Log: Misplaced #endif. + + Subject: [perl-5-6-1-trial2] patches for EPOC + From: Olaf Flebbe <O.Flebbe@science-computing.de> + Date: Wed, 31 Jan 2001 23:15:34 +0100 (CET) + Message-ID: <Pine.LNX.4.02.10101312314470.5682-100000@milkyway.science-computing.de> + Branch: maint-5.6/perl + ! epoc/epocish.c +____________________________________________________________________________ +[ 8651] By: jhi on 2001/02/01 04:00:25 + Log: Integrate changes #8647,8648,8650 from mainline. + + Macrofy a magic UTF-8 test. + + Protect PL_numeric_radix_sv with USE_NUMERIC_LOCALE. + + Watch out for cross compiling for EPOC (usually done on linux). + Branch: maint-5.6/perl + !> ext/Errno/Errno_pm.PL sv.c utf8.c utf8.h +____________________________________________________________________________ +[ 8649] By: gsar on 2001/02/01 00:46:00 + Log: perl_clone() wants to clone PL_numeric_radix_sv (fix for change#8626) + Branch: maint-5.6/perl + ! sv.c +____________________________________________________________________________ +[ 8646] By: gsar on 2001/01/31 15:55:12 + Log: update Changes + Branch: maint-5.6/perl + ! Changes +____________________________________________________________________________ +[ 8645] By: gsar on 2001/01/31 15:10:14 + Log: Configure tweak suggested by Peter Prymmer + Branch: maint-5.6/perl + ! Configure +____________________________________________________________________________ +[ 8644] By: gsar on 2001/01/31 15:06:32 + Log: more files need to be writable in the source distribution + Branch: maint-5.6/perl + ! Porting/makerel +____________________________________________________________________________ +[ 8643] By: jhi on 2001/01/31 14:59:46 + Log: Integrate changes #8258,8278,8279 from mainline. + + Make the large file tests more robust/talkative. + Branch: maint-5.6/perl + !> t/lib/syslfs.t t/op/lfs.t +____________________________________________________________________________ +[ 8642] By: gsar on 2001/01/31 14:53:48 + Log: integrate changes#8311,8334 from mainline + + Add a new MakeMaker variable PM_FILTER that defines a Unix + filter to be run on each .pm during the pm_to_blib() phase, + a fixed version of + Subject: PATCH (blead 8269) ExtUtils::MakeMaker + + Subject: PATCH 5.6.1 & blead 8327 -- workaround for t/io/fs.t + Apparently, the glibc2.2 + linux 2.4.0 + NFS combination prevent + accurate reading of the "atime". + Branch: maint-5.6/perl + !> lib/ExtUtils/Install.pm lib/ExtUtils/MM_Unix.pm + !> lib/ExtUtils/MM_VMS.pm lib/ExtUtils/MM_Win32.pm + !> lib/ExtUtils/MakeMaker.pm t/io/fs.t +____________________________________________________________________________ +[ 8641] By: jhi on 2001/01/31 14:46:37 + Log: Upgrade to Getopt::Long 2.25, from Johan Vromans. + Branch: maint-5.6/perl + ! lib/Getopt/Long.pm +____________________________________________________________________________ +[ 8640] By: gsar on 2001/01/31 14:40:24 + Log: make regen_all + Branch: maint-5.6/perl + ! patchlevel.h pod/perlmodlib.pod pod/perltoc.pod +____________________________________________________________________________ +[ 8639] By: gsar on 2001/01/31 14:37:25 + Log: refresh windows config files + Branch: maint-5.6/perl + ! win32/Makefile win32/config_H.bc win32/config_H.gc + ! win32/config_H.vc win32/makefile.mk +____________________________________________________________________________ +[ 8638] By: gsar on 2001/01/31 14:28:10 + Log: makefile tweaks for windows: introduce a bulk-switch to enable + same options as ActivePerl; sync changes with makefile.mk + Branch: maint-5.6/perl + ! win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 8636] By: jhi on 2001/01/31 02:38:32 + Log: Integrate changes #7884,8122,8155,8197,8213[just to /nolog part, + no perlio],8257,8380,8479,8515 from mainline. + + Subject: [PATCH perl@7795 (and earlier)] VMS test cleanup + + Subject: Re: [ID 20001214.011] Unreachable value in a search list logical name + Subject: [PATCH perl@8133] fix-up for VMS extensions + + In VMS embedded perls couldn't access the statically built Socket. + + Subject: [patch: perl@8211]VMS: add -Duseperlio capacity to configure.com (8213) + + Further VMS piping fixes from Charles Lane. + + Subject: [PATCH] make t/op/misc.t work on VMS + + Add tracing for debugging extensions builds in VMS. + + Subject: [PATCH perl@8506] typo in last week's configure.com frenzy + Branch: maint-5.6/perl + !> configure.com doio.c t/op/misc.t vms/descrip_mms.template + !> vms/ext/DCLsym/Makefile.PL vms/ext/Stdio/Makefile.PL + !> vms/test.com vms/vms.c vms/vmsish.h vms/vmspipe.com +____________________________________________________________________________ +[ 8635] By: jhi on 2001/01/31 01:46:41 + Log: Integrate change #7732 from mainline. + + Sparc 64-bit pack() fix from Jens Hamisch. + Branch: maint-5.6/perl + !> pp.c +____________________________________________________________________________ +[ 8634] By: jhi on 2001/01/31 01:41:16 + Log: One spot missing from #8626. + Branch: maint-5.6/perl + ! sv.c +____________________________________________________________________________ +[ 8633] By: jhi on 2001/01/31 00:49:17 + Log: Integrate change #7495 from mainline. + + Subject: [PATCH: perl@7483] generalize AIX ccversion hack for re extension + Branch: maint-5.6/perl + !> MANIFEST ext/re/Makefile.PL +____________________________________________________________________________ +[ 8632] By: jhi on 2001/01/30 23:38:49 + Log: Integrate change #8396 from mainline. + + Subject: [PATCH] add SO_REUSEPORT to export list in Socket.pm for + better multicast support (resend) + Branch: maint-5.6/perl + !> ext/Socket/Socket.pm +____________________________________________________________________________ +[ 8631] By: jhi on 2001/01/30 23:28:03 + Log: Integrate changes #7514,7813,8113,8144,8397,8398,8490 from mainline. + + More AIX lore. (7514, ext/re/hints/aix.pl) + + Subject: Re: [PATCH bleadperl] Re: Not OK: perl5.7.0 +DEVEL7706 +Duseperlio on AIX4.[23] + + Subject: Re: [PATCH bleadperl] Re: Not OK: perl5.7.0 +DEVEL7706 +Duseperlio on AIX4.[23] (7813, strictly speaking not yet necessary, but harmless and goes well with #8490) + + Subject: [ID 20001214.002] Net::Ping patch + + Subject: [patch perl@8133] Typo in my Net::Ping doc patch :( + + Subject: [PATCH] add ReusePort option to IO::Socket::INET for better multicast support (resend) + + Add ReuseAddr as a (preferred) alias for Reuse as we now + also have ReusePort. + + Subject: [PATCH: perl@8482] minor typos in some dl_$foo.xs files + Branch: maint-5.6/perl + +> ext/re/hints/aix.pl + !> ext/DynaLoader/dl_aix.xs ext/DynaLoader/dl_dlopen.xs + !> ext/IO/lib/IO/Socket/INET.pm lib/Net/Ping.pm +____________________________________________________________________________ +[ 8630] By: jhi on 2001/01/30 23:03:59 + Log: Integrate changes #8215,8587 from mainline: missing pod nits. + + read() documentation tweak for 20001121.004. + + Subject: [ID 20010128.003] [PATCH] perlre.pod buglet + Branch: maint-5.6/perl + !> pod/perlfunc.pod pod/perlre.pod +____________________________________________________________________________ +[ 8629] By: jhi on 2001/01/30 22:41:57 + Log: Integrate change #8098 from mainline. + + fastgetcwd is defined using a glob alias on a $^O dependent basis + and there was no default assignment or perl subroutine. + Branch: maint-5.6/perl + !> lib/Cwd.pm +____________________________________________________________________________ +[ 8628] By: jhi on 2001/01/30 21:58:52 + Log: Integrate change #7866 from mainline. + + File::Temp 0.11. + Branch: maint-5.6/perl + !> lib/File/Temp.pm t/lib/ftmp-tempfile.t +____________________________________________________________________________ +[ 8627] By: jhi on 2001/01/30 21:39:44 + Log: Integrate changes #8075,8086,8228 from mainline. + + Darwin is not Windows. (8075,8086) + + Subject: [PATCH 5.6.1-TRIAL1 and @8223]; was Re: Perlbug 20000322.006 status +update + Branch: maint-5.6/perl + !> lib/CGI.pm lib/Pod/Select.pm lib/Text/ParseWords.pm + !> pod/perl.pod pod/perl5004delta.pod pod/perl5005delta.pod + !> pod/perldiag.pod pod/perlembed.pod pod/perlfaq4.pod + !> pod/perllocale.pod pod/perlmodlib.pod pod/perlretut.pod +____________________________________________________________________________ +[ 8626] By: jhi on 2001/01/30 21:22:11 + Log: Integrate with tweakery the change #8625 from mainline, + the multibyte decimal separator fix ("fa_IR locale failure"). + Branch: maint-5.6/perl + ! embedvar.h perlapi.h + !> intrpvar.h perl.c perl.h sv.c util.c +____________________________________________________________________________ +[ 8624] By: gsar on 2001/01/30 20:17:03 + Log: regen_headers + Branch: maint-5.6/perl + ! Makefile.SH pod/perlintern.pod +____________________________________________________________________________ +[ 8623] By: gsar on 2001/01/30 19:42:34 + Log: backout change#7431 and its dependents (causes spurious rebuilds + of autogenerated files) + + fix benign b.t failure + Branch: maint-5.6/perl + ! Makefile.SH t/lib/b.t +____________________________________________________________________________ +[ 8621] By: gsar on 2001/01/30 19:24:47 + Log: integrate changes#8259,8442,8444,8445,8448,8449,8451,8455 + from mainline + + Subject: podlators 1.06 released + + Subject: [PATCH @8436] Eliminate op_children + + (Replaced by #8448) Traces of op_children (cleanup of #8442) + + (Replaced by #8448) More op_children traces (cleanup of #8442). + + Subject: [PATCH #3 @8436] Re: Eliminate op_children + Replace #8444 and #8445. + + Under 5.005 threads and debugging crashed in Debian 2.2 Linux/x86 + at the setting of the ofs_sv in new_struct_thread() as the + thr->Tofs_sv (PL_ofs_sv) was still 0xabab.... (this is what + uninitialized fields are, uh, initialized with), + SvREFCNT_inc()ing that invited a core dump. + + podlators 1.07, from Russ Allbery. + + Subject: [PATCH] regcomp.c old feature removal + From: mjd@plover.com + Date: 16 Jan 2001 14:43:18 -0000 + Message-ID: <20010116144318.7140.qmail@plover.com> + Branch: maint-5.6/perl + +> lib/Pod/Text/Overstrike.pm + !> MANIFEST bytecode.pl ext/B/B.xs ext/B/B/Asmdata.pm + !> ext/B/B/Bytecode.pm ext/B/B/C.pm ext/B/B/Concise.pm + !> ext/B/B/Debug.pm ext/ByteLoader/byterun.c + !> ext/ByteLoader/byterun.h lib/Pod/Man.pm lib/Pod/Text/Color.pm + !> lib/Pod/Text/Termcap.pm op.c op.h pod/pod2text.PL regcomp.c + !> util.c +____________________________________________________________________________ +[ 8620] By: gsar on 2001/01/30 18:48:32 + Log: integrate changes#8243,8254,8255,8313,8314,8363,8383,8390,8416, + 8417,8418,8419,8424,8427,8430,8441,8563 from mainline (TODO: b.t + now fails one test) + + Subject: [PATCH] lvalue AUTOLOAD. No, really. + + Subject: [PATCH] Interesting syntax idea + Make opens + bareword assigns do typeglob assigns. + + Tests for #8254. + + Subject: [PATCH @8269] Continue blocks and B::Deparse + Make the peephole optimizer to bypass more null ops and + and rewrite the deparse handling of continue blocks. + + Subject: Re: [PATCH @8269] Continue blocks and B::Deparse + Doc tweak on #8313. + + Subject: [PATCH @8344] Fix spurious GVSV OPpOUR_INTRO + + Subject: [PATCH @8382] Remove FileHandle/IO dependence in t/io/openpid.t + + Subject: [PATCH perl@8269] Opcode.XS, fix memory leak + + Subject: RE: [PATCH] [ID 20001223.002] lvalues in list context + Replace 10000 with RETVAL_MAX, and compute RETVAL_MAX + according to the platform. + + Subject: [PATCH @8404] Consolidated lvalue sub changes + + Subject: Re: [PATCH] [ID 20001223.002] lvalues in list context + + Rename RETVAL_MAX to RETURN_UNLIMITED_NUMBER. + + Subject: B::Concise -- an improved replacement for B::Terse + + The B::Terse drop-in replacement wasn't quite drop-in. + + The LVRET macro needed an aTHX. + + Use the /^Perl_/-less form of is_lvalue_sub(). + + Subject: [PATCH @8545] [ID 20000808.005] OP_REFGEN as an lvalue + Branch: maint-5.6/perl + +> ext/B/B/Concise.pm + !> (integrate 27 files) +____________________________________________________________________________ +[ 8616] By: jhi on 2001/01/30 18:20:58 + Log: Integrate partly the change #8615 from mainline, the t/op/each.t + part isn't applicable to maintperl. + + UTF-8 nit from Inaba Hiroto. + Branch: maint-5.6/perl + !> pod/perlapi.pod utf8.c +____________________________________________________________________________ +[ 8613] By: gsar on 2001/01/30 16:39:59 + Log: make it possible to run the tests outside the source tree + (there's still a dependency on ../lib being the library + location) + Branch: maint-5.6/perl + ! t/base/term.t t/io/tell.t t/lib/dprof/V.pm t/op/flip.t +____________________________________________________________________________ +[ 8612] By: gsar on 2001/01/30 16:31:12 + Log: perldoc nit on windows + Branch: maint-5.6/perl + ! utils/perldoc.PL +____________________________________________________________________________ +[ 8611] By: gsar on 2001/01/30 16:22:54 + Log: canonicalize paths when doing chdir() on windows (or Cwd::getcwd() + gets weird results) + Branch: maint-5.6/perl + ! win32/vdir.h +____________________________________________________________________________ +[ 8610] By: gsar on 2001/01/30 16:12:45 + Log: avoid uninitialized value warnings + Branch: maint-5.6/perl + ! win32/bin/search.pl +____________________________________________________________________________ +[ 8609] By: gsar on 2001/01/30 16:08:01 + Log: support for -Dusethreads build under HP-UX 10.20 and DCE threads + library (11.0 and later have pthreads but 10.x don't) + Branch: maint-5.6/perl + ! hints/hpux.sh thread.h +____________________________________________________________________________ +[ 8608] By: gsar on 2001/01/30 15:48:55 + Log: perl's internal variables are not for public consumption, + move their docs from perlapi.pod to perlintern.pod + Branch: maint-5.6/perl + ! intrpvar.h perlapi.c pod/perlapi.pod pod/perlintern.pod + ! thrdvar.h +____________________________________________________________________________ +[ 8607] By: gsar on 2001/01/30 15:44:27 + Log: mistakenly branched perl56delta.pod, revert + Branch: maint-5.6/perl + - pod/perl56delta.pod + !> pod/perldelta.pod +____________________________________________________________________________ +[ 8606] By: gsar on 2001/01/30 14:20:24 + Log: integrate changes#7984,7987,8010 from mainline (gets rid of + dTHR which has been a noop for a while now, except for the + compatibility definition in thread.h) + Branch: maint-5.6/perl + !> (integrate 45 files) +____________________________________________________________________________ +[ 8605] By: jhi on 2001/01/30 05:43:58 + Log: Mark the UTF-8 APIs as experimental. + Branch: maint-5.6/perl + ! embed.pl pod/perlapi.pod +____________________________________________________________________________ +[ 8604] By: jhi on 2001/01/30 05:38:40 + Log: Nits from earlier integrates. + Branch: maint-5.6/perl + ! lib/Carp/Heavy.pm + !> sv.c +____________________________________________________________________________ +[ 8603] By: jhi on 2001/01/30 05:27:26 + Log: Regenerate Porting files. + Branch: maint-5.6/perl + ! Porting/Glossary Porting/config.sh Porting/config_H +____________________________________________________________________________ +[ 8602] By: jhi on 2001/01/30 05:14:59 + Log: Integrate changes #7891,8034,8078,8110,8111,8112,8277,8291, + 8310,8339,8447,8492,8493,8505,8525: documentation changes. + + Subject: Re: perlfaq style changes + + Subject: DOC PATCH 5.6.0: -s return value incompletely documented + + Subject: [PATCH] docs on NaN + + Subject: [patch] perlfaq7 + + Subject: [ID 20001214.003] [PATCH bleadperl] POSIX::tmpnam() is dangerous + + Subject: [PATCH] Re: [ID 20001013.006] XS subs are not define()ed + + Subject: [PATCH] open() example in perlfunc.pod + + Podify README.mpeix (a new version from the web) + + Subject: [PATCH 5.[67].1]; as Re: [PATCH 5.6.1-TRIAL1 and @8223]; was Re: Perlbug 20000322.006 status update + + Subject: [PATCH] format and rewording in perlfaq.pod + + Subject: [PATCH] API Variable documentation + + Memory management calls documentation. + + Subject: [PATCH: perl@8482] README.vms URL updates + + Subject: Minor typos in perlfaq2.pod + + Subject: [PATCH] pod/perlvar.pod + Branch: maint-5.6/perl + +> pod/perl56delta.pod + ! pod/buildtoc.PL pod/perl.pod pod/perltoc.pod + !> README.amiga README.epoc README.mpeix README.vms + !> ext/POSIX/POSIX.pod lib/CPAN.pm lib/Carp/Heavy.pm + !> lib/Win32.pod pod/perlapi.pod pod/perlfaq.pod pod/perlfaq1.pod + !> pod/perlfaq2.pod pod/perlfaq6.pod pod/perlfaq7.pod + !> pod/perlfunc.pod pod/perlop.pod pod/perlrequick.pod + !> pod/perlvar.pod thrdvar.h +____________________________________________________________________________ +[ 8601] By: jhi on 2001/01/30 04:38:35 + Log: Integrate changes #8036,8096,8253 from mainline: + hints changes. + + Subject: [ID 20001207.004] [PATCH 5.6.0 and 5.7.x] add NCR MP-RAS support + Subject: [8095] HP-UX 11.00 / cc / 64bitint & 64bitall / perlio + + Output the (apparent) version of gcc in Tru64. + Branch: maint-5.6/perl + +> ext/POSIX/hints/svr4.pl + !> MANIFEST ext/POSIX/Makefile.PL hints/dec_osf.sh hints/hpux.sh + !> hints/svr4.sh t/lib/bigfltpm.t +____________________________________________________________________________ +[ 8600] By: jhi on 2001/01/30 04:04:01 + Log: Integrate changes #7863,7868,7875,7876,7888,8384,8480 from mainline: + locale fixes. + + sprintf() does not taint since print() does not. (7863,7875,7876,7888) + + Debian allows /usr/bin/locale to exist without any locales. (7868) + + Allow the locale test needing POSIX and the taint test + needing IPC::SysV to run under 'minitest' (basically, + bail out if loading the extension fails). (8384) + + Cleanup the locale.t output (8480) + Branch: maint-5.6/perl + !> pod/perllocale.pod sv.c t/op/misc.t t/op/taint.t + !> t/pragma/locale.t +____________________________________________________________________________ +[ 8599] By: jhi on 2001/01/30 03:51:04 + Log: Missing generated files from #8598. + Branch: maint-5.6/perl + ! embed.h global.sym objXSUB.h perlapi.c proto.h +____________________________________________________________________________ +[ 8598] By: jhi on 2001/01/30 03:41:54 + Log: Integrate change #8555 from mainline, manually integrate parts + of changes 8452 and 8583. + + Subject: [PATCH] utf8.c documentation (8452) + + No point in checking the length if the pointer is bogus. (8555) + + Introduce bytes_from_utf8() and implement sv_eq() using it, + tr/// did not handle UTF-8 ranges, \ before a raw UTF-8 character + produced "Malformed UTF-8 character" warning, "\x{100}\N{CENT SIGN}" + was malformed. (8583) + Branch: maint-5.6/perl + ! embed.pl t/lib/charnames.t t/op/tr.t toke.c + !> pod/perlapi.pod sv.c utf8.c +____________________________________________________________________________ +[ 8597] By: gsar on 2001/01/30 02:37:26 + Log: get PERL_OBJECT build going again on windows + Branch: maint-5.6/perl + ! embed.h embed.pl global.sym objXSUB.h perlapi.c + ! pod/perlapi.pod proto.h sv.c +____________________________________________________________________________ +[ 8586] By: gsar on 2001/01/29 13:43:44 + Log: make the BOM detection code not call tell() until it has to + (meant to fix esoteric compatibility issues where PL_rsfp + is overridden) + Branch: maint-5.6/perl + ! toke.c +____________________________________________________________________________ +[ 8580] By: jhi on 2001/01/28 05:16:25 + Log: Revert the change to sv_2pv() done by #8054: Someone who + did SvNV_set() on a scalar that also happened to be POK, + followed by sv_2pv() won't get the right coercion anymore. + [Sarathy] + Branch: maint-5.6/perl + ! sv.c +____________________________________________________________________________ +[ 8579] By: jhi on 2001/01/28 05:15:04 + Log: Remove the #8084 effect: do not allow -Q to be interpreted + as -&Q(), this is too much wiggle room. + Branch: maint-5.6/perl + ! toke.c +____________________________________________________________________________ +[ 8578] By: jhi on 2001/01/28 05:12:45 + Log: Needed bits of #8439 (should have been in #8576), + mainly for lval substr(). + Branch: maint-5.6/perl + ! mg.c pp.c pp_hot.c +____________________________________________________________________________ +[ 8577] By: jhi on 2001/01/28 05:02:46 + Log: A missing check-in. + Branch: maint-5.6/perl + ! utf8.c +____________________________________________________________________________ +[ 8576] By: jhi on 2001/01/28 04:26:18 + Log: Integrate changes #8425,8436,8439,8517 from mainline. + The 8439 was not truly integrated because it had too many + dependencies on the development branch and because it introduced + concepts too bold for a maintenance branch (such as the qu operator). + + Subject: [PATCH perl@8342] -Wformat + + Tighten some of the UTF-8 tests a bit. + + More UTF-8 patches from Inaba Hiroto. (8439, but only partly) + - The substr lval was still not okay. + - Now pp_stringify and sv_setsv copies source's UTF8 flag + even if IN_BYTE. pp_stringify is called from fold_constants + at optimization phase and "\x{100}" was made SvUTF8_off under + use bytes (the bytes pragma is for "byte semantics" and not + for "do not produce UTF8 data") + Branch: maint-5.6/perl + ! t/lib/charnames.t t/op/substr.t toke.c + !> sv.c t/pragma/utf8.t +____________________________________________________________________________ +[ 8575] By: jhi on 2001/01/28 04:01:51 + Log: Integrate changes #8378,8379,8385,8386,8405 from mainline. + + Subject: One more patch for UTF8 (UTF-8 fixes for 'x' and tr////) + + Subject: [ID 20001230.003] UTF-8 tr still hurts + + Test cases for #8385 (from Simon's "torture.pl") + + Start fixing UTF-8 lval substr() (8405) + Branch: maint-5.6/perl + !> doop.c embed.h embed.pl mg.c op.c pod/perlapi.pod pp.c proto.h + !> regcomp.c regexec.c t/op/substr.t t/op/tr.t toke.c utf8.c +____________________________________________________________________________ +[ 8574] By: jhi on 2001/01/28 03:09:06 + Log: Integrate changes #8328,8329,8330,8331,8332,8341,8343,8377 + from mainline. + + UTF-8 cleanup. + + Subject: [PATCH perl@8327] strings with \x{..} in the middle are corrupted + + "\x{FF}\xFF" was broken. + + Tests for #8329 and #8330. + + Add a note about EBCDIC versus UTF-8 to a potential problem spot. + + IRIX compiler noticed that the bof initialization might be + bypassed by control flow. + + Make explicit our assumption that (for now) "\x{80}" produces UTF-8. + Branch: maint-5.6/perl + !> doop.c op.c pp.c pp_ctl.c pp_hot.c pp_sys.c regcomp.c + !> regexec.c sv.c t/op/bop.t toke.c utf8.c +____________________________________________________________________________ +[ 8572] By: jhi on 2001/01/28 02:04:49 + Log: Integrate changes #8267,8272[perlio],8274,8298,8300,8303, + 8305,8323,8324 from mainline. The 8267,8272, and 8298 were + not really integrated but instead salvaged by hand + (they had too many dependencies on the development release + to be cleanly integratable). + + Subject: more UTF8 test suites and an UTF8 patch + + Tweak for MULTIPLICITY/USE_PERLIO + + Signedness nit. + + Turn SvUTF8 off if not required in pp_chr and pp_stringify. + + Use the UTF8_XXX macros in is_utf8_char(). + + Rewrite pp_concat() in terms of sv_catsv(). The . operator + should now be UTF-8-proof. + + Subject: [PATCH perl@8269] scanning two hex-constants + fails on EBCDIC environment (script length.t) + + Add some Unicode chop() tests. + Branch: maint-5.6/perl + ! doop.c mg.c pp.c pp_hot.c toke.c utf8.c + !> sv.c t/op/chop.t utf8.h +____________________________________________________________________________ +[ 8571] By: jhi on 2001/01/28 00:35:59 + Log: Integrate changes #8090,8093[perlio,only the sv.c tweak], + 8245,8247,8248,8249,8250,8251,8260,8263,8264,8265 from mainline. + + Subject: [PATCH] Re: Breadperl & Tk (sv_utf8_upgrade fixes) + + The maxiters upper limit sanity check (guarding against + non-progress) assumed bytes instead of characters in s/// + and split(). + + Signedness nit. + + sv_catsv() rewrite (8248,8249,8251,8260,8263,8264,8265) + join() should now be UTF-8-proof. + + More split // UTF-8 tests. (8250) + Branch: maint-5.6/perl + !> doop.c hv.c pp.c pp_hot.c sv.c t/op/join.t utf8.c utf8.h + !> util.c +____________________________________________________________________________ +[ 8570] By: jhi on 2001/01/27 22:15:46 + Log: Integrate changes #7941,7943,7944,7958,7967,7995,7996,7998, + 8004,8005,8023,8024,8028,8030,8031,8033,8039,8042,8052[perlio], + 8053[perlio],8054[perlio,+sv.c(-PerlIO_isutf8),+require.t], + 8084,8204,8244,8333 from mainline. + + For -Q where Q might be a one-letter sub name one does no more + get a warning about an unknown filetest (7941,7943,7944,8084). + + Subject: Re: [ID 20001130.011] expression parsing bug ? + + Make uv_to_utf8() to zero-terminate its output buffer. + + Split off t/op/length.t (7995) + + Split off t/op/utf8decode.t (7996) + + Remove an unnecessary 'use utf8' from the utf8.t (7998) + + Split off t/op/concat.t (8004) + + Split off t/op/ver.t (8005) + + Document utf8_length(), utf8_distance(), and utf8_hop(). + + Document utf8_to_uv() better. + + Introduce macros for UTF8 decoding (8028,8033). + + Add test for reverse() (8030,8031). + + Subject: [PATCH] Re: ebcdic <-> ascii tables interjected in uv <-> utf8 considered harmful (8039,8333) + + Do not return the Unicode replacement character on UTF-8 + decoding failure. + + Typo/thinko in S_scan_const() - seeing high bit sets has_utf8 + not this_utf8 i.e. the output string has one, but don't mess + with source assumption. (8052,8053) + + Tweak t/comp/require.t to add a 'use bytes' to permit its dubious + writing of BOM to a non-utf8 stream. Fix SvPVutf8() - sv_2pv() + was not expecting to be called with something that was already + SvPOK() - (we just fossiked with SvUTF8 bit). Fix that and also + just use the SvPV macro in sv_2pvutf8() to avoid the issue/overhead. + (8054) + + Recode the naughty binary bytes in utf8decode.t using the \xHH. + + Make some panic messages a bit more logical. + Branch: maint-5.6/perl + +> t/op/concat.t t/op/length.t t/op/reverse.t t/op/utf8decode.t + !> MANIFEST doop.c embed.pl lib/ExtUtils/Liblist.pm op.c + !> pod/perlapi.pod pod/perldiag.pod pp.c pp_hot.c regcomp.c + !> regexec.c sv.c t/comp/require.t t/op/misc.t t/op/ver.t + !> t/pragma/utf8.t t/pragma/warn/toke t/pragma/warn/utf8 toke.c + !> utf8.c utf8.h +____________________________________________________________________________ +[ 8569] By: jhi on 2001/01/27 19:16:43 + Log: Integrate changes #7750 from perlio and #8566 from mainline. + Branch: maint-5.6/perl + !> regexec.c sv.c +____________________________________________________________________________ +[ 8568] By: jhi on 2001/01/27 18:06:51 + Log: Integrate changes #7355[-doio.c],7691,7744,7753[perlio], + 7783,7790[perlio],7869,7871,7872,7911,7916,7932, + 7935[-perlio.c],7936,7959,7965 from mainline. + + Change the "big byte" error message to "Wide character". + (7355, the croak-if-wide-chars-in-print part ignored) + + Use UINT64_C(). + + Introduce Perl_utf8_length(). + + diff -se shows these as different (7753, forgotten check-ins) + + Subject: [PATCH] doop.c - UTF8 tr/// + + If we use (aTHX_ ...) then put Perl_ on the front. + + Make utf8_length() and utf8_distance() to be less forgiving + about bad UTF-8. + + Test line numbers are different with utf8. + + No need to scan till infinity, 13 is enough. (7872,7911) + + Subject: [PATCH] Tokeniser debugging + + Subject: Re: question about retlen in utf8.c:Perl_utf8_to_uv() + + Subject: [PATCH perl@7930] toke.c perlio.c -Wformat nits (only toke.c) + + Be more careful in Perl_sv_utf8_downgrade(). + + Use DO_UTF8(). + + Raw zero bytes in text files confuse at least GNU patch 2.1. + Branch: maint-5.6/perl + !> doop.c embed.h embed.pl global.sym handy.h objXSUB.h op.c + !> perl.c perl.h perlapi.c pod/perlapi.pod pod/perldiag.pod + !> pod/perlrun.pod proto.h scope.h sv.c t/op/re_tests + !> t/pragma/utf8.t toke.c utf8.c utf8.h +____________________________________________________________________________ +[ 8553] By: jhi on 2001/01/26 15:19:39 + Log: Integrate change #7792 from perlio (multiplicity fix), + fix the AV leak in regex DEBUGGING (tiny part of the + polymorphic regexp patch #8143). + Branch: maint-5.6/perl + ! regcomp.c + !> scope.h +____________________________________________________________________________ +[ 8551] By: jhi on 2001/01/26 02:33:19 + Log: Integrate changes #7760,7815,7870,7873,7874,7877,7878,7879,7881, + 7937,7938,7939,7940,7968,7969,8403,8414,8510 from mainline. + + Subject: [PATCH 5.7.0] The first step in removing recursion from the REx engine + + Subject: [PATCH 5.7.0] Overeager visited-positions optimizations + + Message nit. + + BOUND regex opcodes (\b, \B) could try to scan zero length UTF-8. + + Debug dump of ANYOFUTF8 was garbage (data from ANYOF). + + (the cleanup of unused submatches in regtry() and regcppop()) + + Fix for 20001130.008 and 20001130.010, the PL_regnpar wasn't + stored and restored, and thusly was trounced by the utf8 swash + routines. + + use utf8 not required to use \x{}. + + Removed two more tests that make no sense in UTF-8 since the test + data is not in UTF-8. + + Get the three different space character classes right under utf8. + + Implement ANYOFUTF8 regprop() dumping. + + Subject: Re: [ID 20001029.005] Regex error: "cd. (A. Tw)" !~ /\((\w\. \w+)\)/ + + Document the regex context pushing/popping a bit better. + Branch: maint-5.6/perl + +> lib/unicode/Is/Blank.pl lib/unicode/Is/SpacePerl.pl + !> MANIFEST lib/unicode/mktables.PL pod/perlre.pod regcomp.c + !> regexec.c scope.h t/op/pat.t t/op/re_tests t/op/regexp.t + !> t/op/regmesg.t utf8.c +____________________________________________________________________________ +[ 8549] By: jhi on 2001/01/25 15:22:28 + Log: Undo 6475: { use utf8; chr(128..255) } is better off producing bytes. + Branch: maint-5.6/perl + ! pod/perlfunc.pod pp.c t/pragma/utf8.t +____________________________________________________________________________ +[ 8548] By: jhi on 2001/01/25 15:02:55 + Log: Integrate changes #7997,8063,8492,8547 from mainline. + + Subject: Re: STRLEN - what? + + Subject: [PATCH] perlguts.pod + + Memory management calls documentation. + + Layout using tabulator is not a good idea in a pod. + Branch: maint-5.6/perl + !> pod/perlguts.pod +____________________________________________________________________________ +[ 8546] By: jhi on 2001/01/25 14:31:12 + Log: Integrate changes #8188,8189,8208,8209,8210,8212,8374,8388 + from mainline. + + Subject: [DOC PATCH: perl@7953] update list of lang. sensitive editors/IDES + + Subject: [DOC PATCH: perl@8150, 5.6.1-TRIAL1] update list of lang. sensitive editors/IDES + + More Win32 editor/IDE/shell hints. + + More Win32 Perling. + + Yet another editor edit. + + Edit edit edit. + + IDE/editor section tweaking. + + Few more IDE/editor nits from p5p. + Branch: maint-5.6/perl + !> pod/perlfaq3.pod +____________________________________________________________________________ +[ 8543] By: jhi on 2001/01/25 03:52:08 + Log: Integrate change #8462,8469 from mainline. + + In VMS Perl subversion (perl -V) is undef. + Branch: maint-5.6/perl + !> configure.com +____________________________________________________________________________ +[ 8542] By: jhi on 2001/01/25 03:44:55 + Log: Integrate changes #7835,7850,8315,8316 from mainline. + + Solaris hints. + Branch: maint-5.6/perl + !> hints/solaris_2.sh +____________________________________________________________________________ +[ 8541] By: jhi on 2001/01/25 03:39:28 + Log: Integrate #8336 from mainline. + Branch: maint-5.6/perl + !> hv.c +____________________________________________________________________________ +[ 8540] By: jhi on 2001/01/25 03:23:50 + Log: Retract #8539. + Branch: maint-5.6/perl + ! pod/perlfaq3.pod +____________________________________________________________________________ +[ 8539] By: jhi on 2001/01/25 03:21:55 + Log: (Retracted by #8540.) + Branch: maint-5.6/perl + ! pod/perlfaq3.pod +____________________________________________________________________________ +[ 8538] By: jhi on 2001/01/25 03:14:07 + Log: Subject: [re-patch: 5.6.1-TRIAL1] was Re: [PATCH 5.6.1-TRIAL1]VMS buildpatches + From: Peter Prymmer <pvhp@forte.com> + Date: Mon, 18 Dec 2000 13:10:35 -0800 (PST) + Message-ID: <Pine.OSF.4.10.10012181249310.410192-100000@aspara.forte.com> + + The VMS bits. + Branch: maint-5.6/perl + ! configure.com vms/descrip_mms.template +____________________________________________________________________________ +[ 8537] By: jhi on 2001/01/25 03:06:09 + Log: Integrate #7710,7824,7973 from mainline. + Branch: maint-5.6/perl + !> Configure Porting/Glossary Porting/config.sh Porting/config_H + !> config_h.SH configure.com epoc/config.sh hints/aix.sh malloc.c + !> regcomp.c sv.c vos/config.alpha.def vos/config.alpha.h + !> vos/config.ga.def vos/config.ga.h win32/config.bc + !> win32/config.gc win32/config.vc +____________________________________________________________________________ +[ 8536] By: jhi on 2001/01/24 13:50:20 + Log: Revert the edits made by me so far to the 5.6 branch since + the TRIAL1 since I did edits when I should have been using + integrates. Bad programmer. (Will integrate them properly later.) + Undoes #8347, #8349, #8350, #8351, #8353, #8355, #8376, #8463, #8470. + The #8353 will not be reapplied at least for now since + the UTF-8 hash keys need more thinking. + (The patches #8347, #8354, #8454, #8473 were okay since they + were original edits made specifically for the 5.6.1-TRIAL1.) + Branch: maint-5.6/perl + ! Configure Porting/Glossary Porting/config.sh Porting/config_H + ! config_h.SH configure.com embed.pl epoc/config.sh hints/aix.sh + ! hints/solaris_2.sh hv.c hv.h malloc.c perlapi.c + ! pod/perlapi.pod pod/perlfaq3.pod proto.h regcomp.c sv.c + ! t/op/each.t vms/descrip_mms.template vos/config.alpha.def + ! vos/config.alpha.h vos/config.ga.def vos/config.ga.h + ! win32/config.bc win32/config.gc win32/config.vc +____________________________________________________________________________ +[ 8473] By: gsar on 2001/01/18 11:42:31 + Log: unsubmitted trial1 change + Branch: maint-5.6/perl + ! Changes +____________________________________________________________________________ +[ 8470] By: jhi on 2001/01/18 04:16:00 + Log: Subject: [PATCH: perl@8453] Re: subversion undef on VMS (was Re: [ID 20001218.033] Not OK: perl v5.6.1 +v5.6.1-TRIAL1 on VMS_AXP V7.2-1) + From: Peter Prymmer <pvhp@forte.com> + Date: Wed, 17 Jan 2001 13:07:11 -0800 (PST) + Message-ID: <Pine.OSF.4.10.10101171255380.289071-100000@aspara.forte.com> + Replace #8463. + Branch: maint-5.6/perl + ! configure.com +____________________________________________________________________________ +[ 8463] By: jhi on 2001/01/17 06:12:42 + Log: (Replaced by #8470) + + Subject: subversion undef on VMS (was Re: [ID 20001218.033] Not OK: perl v5.6.1 +v5.6.1-TRIAL1 on VMS_AXP V7.2-1) + From: "Craig A. Berry" <craigberry@mac.com> + Date: Tue, 16 Jan 2001 23:38:46 -0600 + Message-Id: <p04330103b68ad8cfcbfd@[172.16.52.1]> + Branch: maint-5.6/perl + ! configure.com +____________________________________________________________________________ +[ 8454] By: jhi on 2001/01/16 16:12:39 + Log: Subject: [PATCH: perl-5.6.1-TRIAL1] Win32 Makefile fixes - v2 + From: "Indy Singh" <indy@nusphere.com> + Date: Wed, 10 Jan 2001 20:17:49 -0500 + Message-ID: <003001c07b6c$524630b0$00957018@roadhog> + Branch: maint-5.6/perl + ! win32/Makefile +____________________________________________________________________________ +[ 8376] By: jhi on 2001/01/09 04:32:32 + Log: integrate changes #7775, #8316, #8316 from mainline + Branch: maint-5.6/perl + ! hints/solaris_2.sh +____________________________________________________________________________ +[ 8357] By: jhi on 2001/01/07 21:16:09 + Log: Update the EPOC cross SDK URL. + Branch: maint-5.6/perl + ! README.epoc +____________________________________________________________________________ +[ 8355] By: jhi on 2001/01/06 20:27:15 + Log: integrate change #8336 from mainline + + Scoping of %^H still broken in both perl@8269 and perl-5.6.1-TRIAL1 + Branch: maint-5.6/perl + ! hv.c +____________________________________________________________________________ +[ 8354] By: jhi on 2001/01/06 20:24:29 + Log: Subject: [PATCH 5.6.1-TRIAL1 and @8223]; was Re: Perlbug 20000322.006 status update + From: Robin Barker <rmb1@cise.npl.co.uk> + Date: Fri, 22 Dec 2000 12:17:38 GMT + Message-Id: <200012221217.MAA21332@tempest.npl.co.uk> + + The patch reformats some long =item lines so they give + correct output via pod2man | nroff -man + + Subject: [PATCH 5.[67].1]; as Re: [PATCH 5.6.1-TRIAL1 and @8223]; was Re: Perlbug 20000322.006 status update + From: Robin Barker <rmb1@cise.npl.co.uk> + Date: Tue, 2 Jan 2001 15:35:03 GMT + Message-Id: <200101021535.PAA15161@tempest.npl.co.uk> + + Here is a _further_ patch which corrects a few more errors: + * an empty C<=item> in CPAN.pm + * patching the wrong file (pod/perlamiga.pod not README.amiga) + * leaving empty C<=item>s which formatted incorrectly + * over long C<=item>s revealed by latest patch to Pod::Man + Branch: maint-5.6/perl + ! README.amiga lib/CGI.pm lib/CPAN.pm lib/Pod/Select.pm + ! lib/Text/ParseWords.pm lib/Win32.pod pod/perl.pod + ! pod/perl5004delta.pod pod/perl5005delta.pod pod/perlapi.pod + ! pod/perldelta.pod pod/perldiag.pod pod/perlembed.pod + ! pod/perlfaq4.pod pod/perllocale.pod pod/perlmodlib.pod + ! pod/perlrequick.pod pod/perlretut.pod pod/perlsub.pod +____________________________________________________________________________ +[ 8353] By: jhi on 2001/01/06 20:21:10 + Log: integrate changes #7980, 8056, 8057 from mainline + + UTF-8 hash keys. + Branch: maint-5.6/perl + ! embed.h embed.pl hv.c hv.h perlapi.c proto.h t/op/each.t +____________________________________________________________________________ +[ 8352] By: jhi on 2001/01/06 20:18:44 + Log: Forgotten from #8438. + Branch: maint-5.6/perl + ! epoc/epocish.h +____________________________________________________________________________ +[ 8351] By: jhi on 2001/01/06 20:18:12 + Log: Forgotten from #8347. + Branch: maint-5.6/perl + ! config_h.SH +____________________________________________________________________________ +[ 8350] By: jhi on 2001/01/06 20:00:19 + Log: Thinko in #8347. + Branch: maint-5.6/perl + ! regcomp.c +____________________________________________________________________________ +[ 8349] By: jhi on 2001/01/06 18:05:30 + Log: Copy the FAQ3 IDE section from the development branch, + changes originally by Peter Prymmer. + Branch: maint-5.6/perl + ! pod/perlfaq3.pod +____________________________________________________________________________ +[ 8348] By: jhi on 2001/01/06 18:03:02 + Log: EPOC updates for TRIAL1. + + Subject: [5.6.1 trial1] EPOC update + From: Olaf Flebbe <O.Flebbe@science-computing.de> + Date: Sun, 31 Dec 2000 16:04:52 +0100 (CET) + Message-ID: <Pine.LNX.4.02.10012311603040.14097-100000@milkyway.science-computing.de> + + Subject: epoc patch2 for perl-5.6.1-trial1 + From: Olaf Flebbe <O.Flebbe@science-computing.de> + Date: Sat, 6 Jan 2001 13:55:53 +0100 (CET) + Message-ID: <Pine.LNX.4.02.10101061355220.26469-100000@milkyway.science-computing.de> + Branch: maint-5.6/perl + ! README.epoc epoc/config.sh epoc/createpkg.pl epoc/epoc.c + ! epoc/epocish.c +____________________________________________________________________________ +[ 8347] By: jhi on 2001/01/06 17:29:10 + Log: integrate changes #7710,7824,7973 from mainline, + plus VMS nits from Peter Prymmer and Dan Sugalski. + + 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. + + Add HAS_SBRK_PROTO. + + Fixes for signedness warnings noticed by VMSperlers. + Branch: maint-5.6/perl + ! Configure Porting/Glossary Porting/config.sh Porting/config_H + ! configure.com epoc/config.sh hints/aix.sh malloc.c regcomp.c + ! sv.c vms/descrip_mms.template vos/config.alpha.def + ! vos/config.alpha.h vos/config.ga.def vos/config.ga.h + ! win32/config.bc win32/config.gc win32/config.vc + +____________________________________________________________________________ +[ 8182] By: gsar on 2000/12/18 09:53:47 + Log: delete spurious files + Branch: maint-5.6/perl + - lib/CGI/eg/make_links.pl lib/CGI/eg/wilogo.gif vos/config.def + - vos/config.h vos/config_h.SH_orig +____________________________________________________________________________ +[ 8181] By: gsar on 2000/12/18 09:46:08 + Log: regen perltoc + Branch: maint-5.6/perl + ! pod/buildtoc.PL pod/perl.pod pod/perlapi.pod pod/perltoc.pod +____________________________________________________________________________ +[ 8180] By: gsar on 2000/12/18 09:20:27 + Log: integrate changes#7924..7926,7946,7952 from mainline + + A test works better if it has the right 1..$n output. + + All the core library users of Class::Struct seem to be + using "use Class::Struct 'struct';" instead of the bare + "use Class::Struct;", which isn't documented in Class::Struct. + This can't be right. + + Make the Class::Struct import() wiser. + + Upgrade to CPAN 1.59_51, from Andreas König. + + Subject: Re: long shell lines + Split overly long shell command lines. + Branch: maint-5.6/perl + !> lib/CPAN.pm lib/CPAN/FirstTime.pm lib/ExtUtils/MM_Unix.pm + !> lib/File/stat.pm t/lib/class-struct.t +____________________________________________________________________________ +[ 8179] By: gsar on 2000/12/18 08:55:54 + Log: integrate changes#7889,7890,7900,7903,7904,7907,7910,7917, + 7918,7919,7988,8907 from mainline (various) + + Subject: [ID 20001127.004] White space problem in perlamiga.pod + + Subject: [PATCH perl@7825] Re: [ID 20001122.006] weird behaviour of $| + + Subject: [PATCH] perlcc.PL cleanups + + Subject: [PATCH] Updating perltie.pod for arrays + + Subject: [ID 20001128.002] what's the point of example code if it is buggy? + Subject: Re: [PATCH] Updating perltie.pod for arrays + Subject: Re: [PATCH] Updating perltie.pod for arrays + + One more perltie.pod nit from Casey R. Tweten. + + Subject: [PATCH] $^O win32 -> MSWin32 + plus similar nits for vms, err, VMS, and UNICOS. + + Subject: Re: Minor suggestion for Sys::Syslog [PATCH] + More checking in case someone has broken their services or + protocol databases. + + Make "use Class::Struct 'struct';" work again (broken by #7617); + add a test for Class::Struct. + + Integrate the "skip" messages to explain(). + + Subject: [PATCH: perl@8892] treat unicoding and null bytes in op/append.t + Branch: maint-5.6/perl + +> t/lib/class-struct.t + !> MANIFEST README.amiga ext/Sys/Syslog/Syslog.pm gv.c + !> lib/Class/Struct.pm pod/perlipc.pod pod/perltie.pod + !> t/lib/syslfs.t t/op/lfs.t utils/perlcc.PL +____________________________________________________________________________ +[ 8178] By: gsar on 2000/12/18 08:16:30 + Log: avoid redefinition warnings on windows due to sys/socket.h getting + #included before win32.h + Branch: maint-5.6/perl + ! win32/include/sys/socket.h +____________________________________________________________________________ +[ 8177] By: gsar on 2000/12/18 05:24:04 + Log: make regen_headers; fix POSIX.xs problems; remove outdated + code from sys/socket.h that makes build fail now + Branch: maint-5.6/perl + ! ext/POSIX/POSIX.xs global.sym objXSUB.h perlapi.c + ! pod/perlapi.pod + !> win32/include/sys/socket.h +____________________________________________________________________________ +[ 8176] By: gsar on 2000/12/18 05:20:17 + Log: update Changes + Branch: maint-5.6/perl + ! Changes patchlevel.h +____________________________________________________________________________ +[ 8175] By: gsar on 2000/12/18 04:57:48 + Log: integrate changes#7643,7646..7649,7651..7654,7658,7659, + 7661..7665,7667..7669,7671,7673,7676,7677,7681..7683, + 7689..7697,7699..7701,7703,7705,7714,7715,7718..7723, + 7725,7726,7729..7732,7737,7748,7749,7758,7759,7761,7773, + 7775,7776,7782,7785..7787,7804,7807,7808,7810,7811,7816, + 7823,7825,7838 + + Subject: Re: [PATCH] README.solaris + + Add getpagesize() probing, on non-UNIX guess 'undef'. + + Simplify the getpagesize() unit by dropping the + pagesize probe since it's nowadays slightly more + complicated because of sysconf(). (Note: if some + platform really needs the -lPW for getpagesize, + I just broke it.) + TODO: a new pagesize unit. + + Subject: [PATCH] fwd: Re: [ID 20001105.011] Perl 5.6.0 documentation glitch + + MachTen doesn't really do mmap() and munmap(). + Subject: [PATCHES Bleadperl] Re: PerlIO - what all of you can all do. + + More README.solaris updates from Andy Dougherty. + + Copy the s// information of README.hpux also to the perlrun. + + Add HAS_FSYNC, lack noticed by Nicholas Clark. + + Add a metaconfig unit for fsync. + + Subject: [ID 20001112.004] man perlfunc omits tell()'s error return + + Many subdocumented return values of the IO extension now documented. + ungetc and write still left subdocumented. + Subject: [PATCH] (was Re: IO::Handle::ungetc) + + Document tell() on special streams. + + Subject: [ID 20001112.006] IO::Seekable::getpos doesn't check for fgetpos() failure + + Subject: [ID 20001112.007] sfio's sftell isn't ftell + + Couple of tests from #7660 salvaged. + + Tweak the definition of the bit complement on UTF-8 data: + if none of the characters in the string are > 0xff, + the result is a complemented byte string, not a (UTF-8) + char string. Based on the summary in + Subject: Re: [ID 20000918.005] ~ on wide chars + This should give us the maximum backward (pre-char string) + compatibility and utf8 compatibility. The other alternative + would be to limit the bit complement to be always byte only, + taking the least significant byte of the chars. + + Cleanup messy #ifdef. + + Typos in #7667. + + Declare reg_data like reg_substr_data. + + Placate nervous compilers that see longer than ints switch()ing. + + Remove the new two tests of lib/io_xs for now, they seem to + fail under perlio on some platforms. + + Subject: Re: [ID 20001112.008] perlio.c's PerlIO_getpos ingores error return + + Subject: [ID 20001113.003] utf8_to_uv on malformed utf returns wrong values + + Subject: tiny typo in perl5db.pl + + Subject: some additions for makefiles for win32 (for perl@7674) + + Hoist the duplicated socket/netdb include logic to perl.h; + undef SETERRNO in case SOCKS has defined it. Based on: + Subject: [ID 20001114.002] Code-Cleanups concerning SOCKS5 and Solaris + + Regen Configure. + + Defined INT64_C() and UINT64_C() unless defined by <inttypes.h> + (a macro to define signed and unsigned integer constants). + + Use UINT64_C(). + Subject: [ID 20001114.006] 5.7.0-7680 Solaris 8, 64 bit, utf8 patch + + Use u_int32_t for the size of hash_cb(), not size_t. + Subject: [ID 20001114.003] Solaris 8, 64 Bit DB_file patch + + Quit utf8_to_uv() instantly if curlen == 0. + + Subject: [PATCH: perl@7674] updates to README.os390 + + Subject: [PATCH: perl@7674 + Scott-Thoennes] hush warnings about malformed EBCDIC text + + EBCDIC tweaks. + Subject: [PATCH: perl@7674 ++] fixes for warnings and regmesg (reprise) + + Linenumber fix. + + SOCKS has its own USE_THREADS, based on + Subject: [ID 20001114.002] et. al. bugfix followup + + UINT64_C() work continues. + + Detypo. + + The type of the hash_cb() size argument is tricky. + + Add fwalk() probe to the configuration files and regen perltoc. + + Subject: perllocale.pod changes + + Avoid an infinite loop in VMS when utils scripts are run + with no arguments, from Charles Lane. + + Subject: Re: Bug in Carp::Heavy/5.6.0? + + For Solaris use64bitall the stdchar needs a little bit of help. + + The long double hints can be here or there. + + Test tweak for the open pragma. + + Also the 64bitall hints can be either here or there. + + As surmised the #7719 wasn't a good move. + + Subject: Fix for 20000409.001 + + Subject: Fix for 20000815.006 + It's really 20000518.006. + + Subject: [PATCH 5.6.0 README.win32] very minor typos + + Subject: Fix for README.amiga (20000323.033) + + Explain in more detail the {} syntax ambiguousity. + Subject: [PATCH] Re: [ID 20001117.003] map { "$_", 1} @array is syntax error + + Sparc 64-bit pack() fix from Jens Hamisch. + + Upgrade to CPAN.pm 1.58_93 (the RC1 for 1.59), from Andreas König. + + Subject: podlators 1.05 available + + Subject: [ID 20001118.006] [PATCH] perl@7707 djgpp/config.over, hints/dos_djgpp.sh and Storable.pm + + Subject: [perl 7711: EPOC] updates + + Make certain MacOS Classic has NO_ENVIRON_ARRAY. + + Miraculous typo. + + sysseek() instead of seek(). + + Solaris hints tweaks. + + Assume SOCKS is broken in all 64bitall platforms, not just Solaris. + This may be overly harsh but until proven otherwise, we think this + way, or until we have a simple test for Configure (having to start + up servers is does not count as simple) to check for the problems. + + Remove the shared object before attempting to create + (by linking) a new one. E.g. in AIX not removing + becomes quite painful if one tries to do more than one + build in the same tree (an interrupted build, for example), + since the AIX' shared dynaloader seemingly keeps the shared + objects open and therefore 'busy' for quite a while, even when + nobody is using the objects, leading into link failures. + + Subject: [ID 20001120.010] typo in lib/Cwd.pm broke Cwd::chdir + + Subject: DOC PATCH 5.6.0 perlreftut + + Subject: [PATCH: perl@7777] add system locale testing for VMS + + Subject: [PATCH] Test.pm POD peculiarity + + Subject: [ID 20001120.002] [PATCH] io_sock.t fails without 'localhost' + + Subject: [ID 20001120.003] [PATCH] io_udp.t fails without 'localhost' + + Subject: Re: perl@7777 + Detypoing. + + Subject: [PATCH: perl@7777] make VMS' test.com tail compatible w/ unix + + Go ahead and #include <unistd.h> in perl.h. + + Subject: [PATCH perl@7795] small cleanup task for test suite + + Subject: Re: av.c patch (having slight problems) + unshift() speedup. + + Reach back one higher up when searching for PERL_SRC. + Branch: maint-5.6/perl + +> lib/File/Spec/Epoc.pm + !> (integrate 88 files) +____________________________________________________________________________ +[ 8174] By: gsar on 2000/12/18 03:53:09 + Log: integrate changes#7602,7604..7611,7614,7616..7619,7621..7623, + 7625..7629,7631..7634,7637,7639,7642 from mainline + + Fix for the tie-refhash string table leaks. + + Subject: [patch perl@7595] VMS configure.com tweak + + More careful detection of how well NVs and UVs mix. + Subject: [PATCH] Re: NV preserving UV (wasRe: [ID 20001007.002] Not OK: perl v5.7.0 +DEVEL7158 on armv4l-linux-64int 2.2.17-rmk1 (UNINSTALLED)) + Added some SIGFPE paranoia. + + Forgot to bump the line numbers in #7601. + + Subject: PATCH std stdio for (Free)BSD + + Deleting $ENV{PATH} in VMS is not recommendable. + + Locale buglets. + Subject: RE: Locales support (setlocale) fixes + + Do not test UTF-8 locales since that the tests would require + polymorphic regexen. + + Subject: [PATCH bleadperl] Re: Patch 7533 prevents malloc.c from compiling on MachTen + + A missing aTHX_. + + Subject: [ID 20001108.013] spelling + + Subject: [PATCH] Class::Struct at compile time + + Make deleting for %ENV work for (newer versions of) VMS, + from Craig A. Berry. + + Forgot from #7618. + + More VMS moves on environment handling, from Charles Lane. + + Remove unused extra arguments. + + Typo in an ifndef. + Subject: Re: [PATCH 5.7.0] better messages from malloc() + + Subject: [PATCH: perl@7613] updates to Porting/pumpkin.pod + All except the "cow orker" change. + + The generated boot_* headers are wrong. Pickier compiler, + such as KAI C++ will refuse to compile the resulting perlmain. + Subject: [ID 20001109.005] Bug in minimod.pl, perl 5.6.0 + + There's no =head3. + + Disable only the tests 99 and 166 for UTF-8 locales. + + Missing dTHXs. + Subject: RE: perl@7595 builds not on cygwin + + Subject: Re: bash -c exit and linux hints + + Various doc oddball characters. + Subject: [ID 20001106.004] Perl 5.6.0 bugs + + Subject: [PATCH] IO::Seekable pod + + Amdahl UTS hints updates. + Subject: [ID 20001109.016] Trouble going from 5.4 to 5.6 + + Explain better why certain regex tests are skipped. + Subject: Re: tests skipped: unknown reason + + Subject: [PATCH] README.solaris + + Subject: [PATCH perl@7638] cygwin port + Branch: maint-5.6/perl + +> README.solaris + !> (integrate 26 files) +____________________________________________________________________________ +[ 8173] By: gsar on 2000/12/18 03:37:02 + Log: integrate changes#7472,7474..7478,7481,7485,7489,7493,7494,7496, + 7497,7499..7503,7505..7507,7509..7513,7515..7523,7526..7534, + 7536,7540,7542,7544..7546,7549,7553,7556,7557,7559,7561..7563, + 7565,7568..7572,7576,7578..7589,9592..7594,7596..7601 from mainline + + Better create a true mailing list for the repository keepers. + + Subject: [ID 20001027.007] uniq array in perlfaq + + De-quoted-unreadable to ISO Latin 1. + (There's one ISO-2022-JP name in Changes5.004.) + + Have only one master list of AUTHORS, drop unmaintained MAINTAIN. + + The #7476 needs a MANIFEST change, too. + + Add also emailless people. + + UTF-8 decoder tweak. + + Make \x{...} consistently produce UTF-8. + Subject: Re: \x{...} is confused + + Subject: [Chris Winters <cwinters@intes.net>] patch to ExtUtils::Manifest + + Add a perlbug flag, -A, to avoid acknowledgement messages. + Subject: PATCH (Re: [ID 20001030.008] OK: perl v5.7.0 +DEVEL7445 on i586-linux 2.2.16 (UNINSTALLED)) + + Use Errno magic. + Subject: [ID 20001030.009] [PATCH] ftmp-mktemp failing + + Subject: [PATCH: perl@7483] CRLF fix for cgi-function.t tests + + Subject: [PATCH: perl@7483] fix coded control chars in cgi-html.t + + Subject: [ID 20001030.001] 5.7.0-7489: Null-Pointer reference in mg.c + + Be more lenient on bad UTF-8 when doing bit arithmetics. + Subject: Re: [ID 20000918.005] ~ on wide chars + (The ord() part of the patch skipped.) + + Subject: perlfaq style changes + + AUTHORS tweaks. + + Whitespace style tweak. Was originally going to see to + Subject: PATCH (Re: PerlIO - Configure tweak for Linux/glibc?) + but that had already been taken care of. + + The compiler is either gcc or cc, from Tom Bates. + + The osname has been lowercased by now, from Tom Bates. + + The NonStop-UX libraries have a novel way to say NaN. + + printf UVs the correct way, noticed by Robin Barker. + + Subject: [PATCH] startperl to respect versiononly + + AUTHORS updates. + + Subject: [ID 20001031.004] Uninitialized auto variable in regcomp.c + + Subject: [ID 20001101.001] Net::Ping icmp odd $bytes + + Subject: [ID 20001005.004] doc bug: perlsec misleading re file output + + Generalize the Camel wording. + Subject: Re: perlfaq style changes + + Subject: [ID 20001005.006] Documentation -- description of qr// + + C.pm part of + Subject: [ID 20001010.001] [Daniel.Stutz@astaro.de: perlcc and C.pm in perl-5.7.0] + + Locale warning explanation tweak. + + Subject: [ID 20000904.004] perlsec Manual Page Incorrect Doing "Safe Backticks" + + Make the POSIX::setuid and POSIX::setgid to really call setuid() + and setgid() because they were just changing $< and $( which means + only changing the real uid/gid, as opposed to changing both + real and effective ids. (The alternative way could have been + in POSIX.pm to change $> and $), too, but making a direct call + to the C API feels cleaner.) Fixes the bug + Subject: [ID 20000904.005] POSIX::setuid() Doesn't Call setuid() + + Expand %Config variables and %ENV variables only if + so requested during build time using the + PERL_BUILD_EXPAND_CONFIG_VARS and PERL_BUILD_EXPAND_ENV_VARS. + Not expanding makes relocating distributions easier. + + More tweaking on the #7522 theme. + + Test::Harness revealed buglets in the new DynaLoader. + Subject: [ID 20001102.001] Not OK: perl v5.7.0 +DEVEL7523 on i686-linux 2.2.16a (UNINSTALLED) + + Add Tie::RefHash::Nestable (lives in Tie/RefHash.pm), + fix a autovivification bug in Tie::RefHash, add tests for both. + Subject: Re: Tie::RefHash: use hash refs as keys in nested hashes + + Detpyo. + + recv() can fail and return undef. + Subject: [ID 20001102.003] Net::Ping patch: "Bad arg lenght" error appears if host is unreachable + + Fix the problem discussed in + Subject: [ID 20001015.004] Fwd: Tie::SubstrHash -- bug & fix (all Perl versions) + originally from Linc Madison. Also Andreas König's comments + taken into account. Some other problems with Tie::SubstrHash + fixed: didn't croak when the table exceeded the requested number + of entries (as documented) but instead when the number of entries + exceeded the size of the table, a croak() had an unnecessary \n, + didn't have a CLEAR method, documented that there is no exists(). + Didn't fix to be strict-proof because the module uses &foo; and + dynamic scope. Added a test script exercizing both first tamely + the basic functionality, and then the failure cases reported by + Linc Madison. + + Subject: [PATCH] Perl@7504, vms/gen_shrfls.pl + + The #7521 touched things it shouldn't have. + + Subject: [PATCH 5.7.0] better messages from malloc() + + Subject: Re: README.aix + + Add FCNTL_CAN_LOCK. + Subject: Re: [ID 20001030.011] Not OK: perl v5.7.0 +DEVEL7481 on VMS_AXP V7.1 (UNINSTALLED) + Subject: Re: [ID 20001030.011] Not OK: perl v5.7.0 +DEVEL7481 on VMS_AXP V7.1 (UNINSTALLED) + + Locale tweakery. Add test case for bug id 20000809.003 to op/misc, + create a "fast path" for locale name probing using "locale -a" + if available, squash finally hopefully the s?printf resetting + the numeric locale (since, IIUC perllocale, it never shouldn't). + + More Changes tweakery. + + Dying is too strict here, better just skip. + + Subject: Locales support (setlocale) fixes + Modified quite a bit to be more portable. + + Configure would use a bad $myuname from an old config.sh. + Subject: [PATCH 5.6.1-to-be and 5.7.x] Very old Configure myuname bug + + Fix for + Subject: [ID 20001004.006] undef is never tainted + An undef read from a slurped file was not tainted. + + Fix for + Subject: [ID 20001004.007] taint propogation is inconsistent + The culprit was sv_setsv() which was rather blindly + propagating taint, which lead to behaviour where if + a tainted anon hash value was seen all the hash values + from then on at that level became tainted, or at any + upper levels in the case of nested anon hashes. + + Test tweak: show also the failed locales. + Subject: [ID 20001105.001] Not OK: perl v5.7.0 +DEVEL7523 on i86pc-solaris 2.8 + + A fix of sorts for 20000329.026, a better error message + for a missing "use charnames" when using the \N{...}. + + Subject: [Corrected/tested PATCH] Re: [ID 20001102.008] Not OK: perl v5.7.0 +DEVEL7503 on i686-linux 2.2.16 + + Add =pod to be tidy. + + Fix for bug id 19990615.008, pos() unset during s///ge. + + Add a note for future generations about bug id 20000229.006. + + Use -dM for gcc (the suggested patch did it only for Linux, + but I think it can be generalized). + Subject: Re: connect and $!{EINPROGRESS} pb (was [ID 20001030.010] [PATCH] io_multihomed.t failing) + + opmini.o can linger from Configures past. + + Document that the evaled syntax errors cause scalar leaks. + + Fix for + Subject: [ID 20000728.005] perl -P broken + (hopefully). The fix is also not complete, it seems to break + BOM swallowing for libc5 systems, but until someone figures + out a way to do this without ftell(), this will do. + + AUTHORS updates. + + Subject: Re: rsync'ed patches vs. rsync'ed source + + Admit that the test leaks scalars. + + Sanitize the environment further. + + VOS updates from Paul Green. + + Document %ENV = () portability issues. + + Make the stdio test program of 7427 less noisy while being + compiled so that Digital UNIX wouldn't get both + d_stdio_ptr_lval_nochange_cnt and d_stdio_ptr_lval_sets_cnt + undefined. This makes perlio happy. + + glibc5 detection by __GNU_LIBRARY__. + + %ENV note tweaks from Dan Sugalski. + + Varargs don't always work too well if one puts an unsigned + char on the stack and pop an unsigned quad off the stack. + Subject: Re: [ID 20001103.002] Not OK: perl v5.7.0 +DEVEL7523 on os2-64int-ld-2.30 (UNINSTALLED) + + Subject: Pod updates + + Fake support of holey files in win/dosish platforms. + Subject: SDBM_File under MS-Windows95/98 does not work correctly. (APR#1302) + + A doc addition for bug id 20001105.019, beware \p. + + Tweak #7587. + + Subject: [PATCH perl@7573] configure.com and st-lock.t changes for + + perlhack updates from H.Merijn Brand. + + Subject: [PATCH perl@7573] cygwin port + Synchronize with Cygwin 1.1.5. + + Bad thinko in #7581 (I used the test program with the expanded + values as-is). + + Make perlbug not insist on dumping to a file when stdout isn't a tty. + Subject: [PATCH] perlbug.PL + + Overrideable keys, each, pop, push, shift, splice, unshift. + Subject: [PATCH] prototyped functions that should be overrideable + + Try to avoid flockless and emulationless places. + Branch: maint-5.6/perl + +> t/lib/tie-refhash.t t/lib/tie-substrhash.t + - MAINTAIN + !> (integrate 111 files) +____________________________________________________________________________ +[ 8171] By: gsar on 2000/12/18 02:49:24 + Log: integrate changes#7447,7448,7450,7454,7456,7457,7460,7462, + 7465..7471 from mainline + + Remains of the old UTF-8 API, utf8_to_uv_chk(): didn't link + in platforms that strictly require all the symbols being present + at link time. + + Subject: [PATCH: perl@7446] restore missing d_stdio_cnt_lval to VMS + + Subject: [ID 20001025.011] [PATCH] t/io/open.t perl@7369[ 7350] breaks VMS perl + + Subject: [ID 20001026.006] C<use integer; $x += 1> gives uninitialized warning + + Subject: [PATCH] todo + + Subject: [ID 20001027.002] Patch 7380 followup - Perl_modfl *must* be defined + + Use $sort, $uniq (and $tr) consistently as wondered + by Nicholas Clark. + + Too enthusiastic editing in #7460. + + The reëntrant version shouldn't be needed unless USE_PURE_BISON. + + Upgrade to CPAN 1.58_55. + Subject: CPAN.pm status + + Subject: [ID 20001027.005] Nit in perlos2.pod - space needs deleted on line 118 + + Make target reordering to avoid pointless re-makes. + Subject: Re: Total re-make of 'make okfile' after 7451 ? + + Subject: [ID 20001027.010] [PATCH] Add info on building CPAN modules to README.dos + + Subject: DOC PATCH 5.6.0 + + Add the repository doc by Malcolm, Sarathy, and by Simon, + name as suggested by Michael Bletzinger <mbletzin@ncsa.uiuc.edu>. + Branch: maint-5.6/perl + +> Porting/repository.pod + !> Configure MANIFEST Makefile.SH README.dos README.os2 + !> config_h.SH configure.com embed.h embed.pl handy.h lib/CPAN.pm + !> lib/CPAN/FirstTime.pm perl.h pod/perlfunc.pod pod/perltodo.pod + !> pp.c proto.h t/io/open.t t/op/assignwarn.t toke.c +____________________________________________________________________________ +[ 8169] By: gsar on 2000/12/18 02:33:34 + Log: integrate changes#7416,7417,7420..7422,7424,7426..7429,7431..7433, + 7435..7441,7445 from mainline + + Make the UTF-8 decoding stricter and more verbose when + malformation happens. This involved adding an argument + to utf8_to_uv_chk(), which involved changing its prototype, + and prefer STRLEN over I32 for the UTF-8 length, which as + a domino effect necessitated changing the prototypes of + scan_bin(), scan_oct(), scan_hex(), and reg_uni(). + The stricter UTF-8 decoding checking uses Markus Kuhn's + UTF-8 Decode Stress Tester from + http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt + + Run vms/vms_yfix.pl, should have done that after changing + perly.c in #7382. + + Subject: [PATCH 5.7.0] static linking with uninstalled perl + + (Replaced by #7440.) + Subject: Re: [ID 20001022.001] Not OK: perl v5.7.0 +DEVEL7368 on i686-linux 2.2.16 + + Fix the bug ID 20001024.005, the bug introduced by #7416. + + Subject: Re: [ID 20001023.003] PATCH perlfaq5 [perl-current] + + Fix the bug reported in + From: andreas.koenig@anima.de (Andreas J. Koenig) + Also make is_utf8_char() stricter. + + Missed the header file changes from #7425. + + Check if stdio supports tweaking lval and cnt simultaneously. + Subject: PATCH (Re: PerlIO - Configure tweak for Linux/glibc?) + + Stratus VOS updates from Paul Green. + + Podify README.epoc and README.vos. + + Add targets to Makefile.SH, most importantly + 'regen_all' which also remembers to update vms/perly*. + + Subject: Minor update to find2perl, for portability + + Subject: patch 7416 breaks sv.c on AIX and HP-UX (patch included) + + Subject: [ID 20001024.007] [PATCH] "Dump local *FH" causes SEGV + + Rename UTF8LEN() to be UNISKIP(), too confusing to have + UTF8LEN() and UTF8SKIP(). + + Allow poking holes at the UTF-8 decoding strictness. + + Continue the internal UTF-8 API tweaking. + Rename utf8_to_uv_chk() back to utf8_to_uv() because it's + used much more than the simpler API, now called utf8_to_uv_simple(). + Still not quite happy with API, too much partial duplication + of functionality. + + A new version of making the syslog test more robust. + (Replaces #7421.) + Subject: Re: [ID 20001022.001] Not OK: perl v5.7.0 +DEVEL7368 on i686-linux 2.2.16 + + buildtoc target tweaks. + + Integrate with vmsperl #7430 by Charles Bailey: + + Cleanup from prior patch (Charles Lane?): + - improve handling of MFDs in Basename and Path + - default to no xsubpp line # munging when building debug images + Branch: maint-5.6/perl + +> vos/config.alpha.def vos/config.alpha.h vos/config.ga.def + +> vos/config.ga.h vos/configure_perl.cm vos/install_perl.cm + !> (integrate 67 files) +____________________________________________________________________________ +[ 8168] By: gsar on 2000/12/18 02:05:49 + Log: integrate changes#7512,7733 from mainline (regex bugfixes) + + Subject: [ID 20001031.004] Uninitialized auto variable in regcomp.c + From: Martin Husemann <martin@duskware.de> + + Subject: [PATCH 5.7.0] restore match data on backtracing + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Branch: maint-5.6/perl + !> regcomp.c regexec.c t/op/re_tests +____________________________________________________________________________ +[ 8167] By: gsar on 2000/12/18 01:55:22 + Log: integrate changes#7858,7986 from mainline + + C<foreach my $x ...> in pseudo-fork()ed process may diddle + parent's memory; fix it by keeping track of the actual pad + offset rather than a raw pointer (this change is probably also + relevant to non-ithreads case to avoid fallout from reallocs of + the pad array, but is currently only enabled for the ithreads + case in the interests of minimal disruption to existing "well + tested" code) + + fix open(FOO, ">&MYSOCK") failure under Windows 9x (problem is + due to the notorious GetFileType() bug in Windows 9x, which fstat() + tickles) + Branch: maint-5.6/perl + !> embed.h embed.pl global.sym objXSUB.h perlapi.c pp_ctl.c + !> proto.h scope.c scope.h sv.c t/op/fork.t win32/perlhost.h + !> win32/win32.c win32/win32.h win32/win32sck.c +____________________________________________________________________________ +[ 8166] By: gsar on 2000/12/18 01:52:59 + Log: integrate changes#7626,7632,7717,7738,7814,7817,7902,7912,7915 + from mainline (xsubpp and ExtUtils::LibList fixups, various + other small items) + + The generated boot_* headers are wrong. Pickier compiler, + such as KAI C++ will refuse to compile the resulting perlmain. + Subject: [ID 20001109.005] Bug in minimod.pl, perl 5.6.0 + + Various doc oddball characters. + Subject: [ID 20001106.004] Perl 5.6.0 bugs + + Subject: [PATCH] Re: 20001101.003 PDL + + Subject: [PATCH 5.7.0] etags broken again + + Subject: [PATCH 5.7.0] Liblist finally works + + Subject: [PATCH 5.7.0] Liblist returns found libraries + + Subject: [PATCH] Re: 5.6 bug: split /^/ implies /m modifier (from CLPM) + + Subject: [PATCH 5.7.0] OUT keyword for xsubpp + + Subject: Re: [PATCH 5.7.0] OUT keyword for xsubpp + OUT keyword nits. + Subject: Re: [PATCH 5.7.0] OUT keyword for xsubpp + OUT and IN_OUT documentation. + Branch: maint-5.6/perl + !> emacs/cperl-mode.el emacs/ptags lib/ExtUtils/Liblist.pm + !> lib/ExtUtils/MM_VMS.pm lib/ExtUtils/MakeMaker.pm + !> lib/ExtUtils/xsubpp lib/unicode/syllables.txt minimod.pl + !> pod/perlfunc.pod pod/perlxs.pod pod/perlxstut.pod t/op/split.t + !> win32/bin/search.pl +____________________________________________________________________________ +[ 8165] By: gsar on 2000/12/18 01:28:45 + Log: integrate changes#7533,7563,7611,7623 from mainline (various + malloc.c embellishments) + Branch: maint-5.6/perl + !> malloc.c pod/perldiag.pod +____________________________________________________________________________ +[ 8164] By: gsar on 2000/12/18 01:23:33 + Log: integrate changes#7419,7806,8129 from mainline (various h2xs + fixups) + Branch: maint-5.6/perl + !> utils/h2xs.PL +____________________________________________________________________________ +[ 8163] By: gsar on 2000/12/18 01:17:50 + Log: integrate changes#7493,7599,7803 from mainline (various perlbug + fixups) + Branch: maint-5.6/perl + !> Makefile.SH utils/perlbug.PL +____________________________________________________________________________ +[ 8162] By: gsar on 2000/12/18 00:25:43 + Log: always export Perl_deb() (it is required by re.xs whether + Perl is built with or without -DDEBUGGING) + Branch: maint-5.6/perl + ! makedef.pl +____________________________________________________________________________ +[ 8161] By: gsar on 2000/12/18 00:23:38 + Log: integrate change#7414 from mainline + + Undo the basename() part of #7412 since the lib/basename + tests would need upgrading too. + + squelch two tests in tr.t that rely on tr/// paranoia change + that's not in 5.6.x + Branch: maint-5.6/perl + ! t/op/tr.t + !> lib/File/Basename.pm +____________________________________________________________________________ +[ 8160] By: gsar on 2000/12/18 00:05:30 + Log: missing change in previous integrate + Branch: maint-5.6/perl + !> README.aix +____________________________________________________________________________ +[ 8159] By: gsar on 2000/12/18 00:03:38 + Log: integrate changes#7205..7210,7212,7214..7219,7222,7223,7225,7226, + 7228,7230..7241,7243,7346,7347,7350..7354,7356,7358..7360,7362, + 7363,7365..7368,7370..7374,7376..7386,7391,7393..7399,7404..7408, + 7410..7413 from mainline + + Introduce the man[24-8] variables, from Andy Dougherty. + + Upgrade to CPAN 1.58, from Andreas König. + + An updated EBCDIC tr patch. + Subject: Re: [PATCH: perl@7181] op/tr tests on OS/390 + + Subject: [PATCH] 5.6.0 & 5.7.1, VMS fixes + + Two thirds of + Subject: Proposed patches, Install.pm getopts.pl termcap.pl + The Install.pm changes will be submitted separately because + they need some work and discussion still. + + The Install.pm third of + Subject: Proposed patches, Install.pm getopts.pl termcap.pl + + Subject: [PATCH: perl@7181] was: Re: off to a bad start on fixing regression tests + + Subject: [PATCH 5.7.0] IVs in mtats + + Subject: [PATCH 5.7.0] Perl API for mstats + + Ilya implemented the memory profiling API. + + In Amdahl UTS "struct sv" is defined by a system header, + <ksync.h>. + + Slight tweak of the code to appease Amdahl UTS cc. + + Amdahl UTS doesn't seem to do dynaloading. + + Use UTF8SKIP(), from Simon Cozens. + + Thinko in #7222. + + op/sprintf.t patch for OS/390 (and any other host with limited + floating-point exponent length) + Subject: Re: [ID 20001006.014] Not OK: perl v5.7.0 +DEVEL7158 on os390 05.00 (UNINSTALLED) [PATCH bleadperl] + + Tweak #7225. + Subject: Re: [ID 20001006.014] Not OK: perl v5.7.0 +DEVEL7158 on os390 05.00 (UNINSTALLED) [PATCH bleadperl] + + Subject: RFC: a (temporary?) way around utf8.pm for EBCDIC + + Needs to be conditional on SunOS 4. + Subject: [Pach 5.7.0@7229] Removing -ldb from the core build + + Test cases for bug id 20000323.056 (the bug seems to be fixed). + + Add test for bug id 20000427.003 (which seems to have + been fixed) (also duplicate as 20000427.004, though + with a higher severity). Move one utf8 from op/append + to pragma/utf8, tag the tests with bug ids. + + Document FNCASE=y as discussed in the bug 20000902.009. + + split() utf8 fixes. Should fix both 20001014.001 and 20000426.003. + The problem was that rx->minlen was in chars while pp_split() + thought it would be in bytes. + + Make ~(chr(a).chr(b)) eq chr(~a).chr(~b) on utf8. + Subject: [PATCH] Re: [ID 20000918.005] ~ on wide chars + + Fix few quad issues, which for example broke chr(~chr(~0)) for UTF8. + + Fix a couple of compiler-noted nits in #7235. + + Tweak the test of #7235. + + One more ~utf8 tweak. + + -w cleanup. + Subject: Re: Problems with bleadperl + + Subject: small pod patch + + Subject: [PATCH perlguts.pod] Document offset hack + + Add Charles Lane. + + Add the capability to include/exclude branches. + + Subject: [ID 20001016.012] [PATCHes Included]OK: perl v5.7.0 on dos-djgpp djgpp + + Detect early whether the std streams have gone bad. + Subject: PATCH (was Re: [ID 20001016.007] Not OK: perl v5.7.0 +DEVEL7228 on i586-linux 2.2.16 (UNINSTALLED)) + + More IoTYPE sprinkling. + + Workaround for a sfio bug where the stream error indicator + is not cleared as documented. + Subject: PATCH (was Re: [ID 20001016.007] Not OK: perl v5.7.0 +DEVEL7228 on i586-linux 2.2.16 (UNINSTALLED)) + + Clarify documentation on 'use bytes'. + Subject: Re: What does 'use bytes' "mean" ? + + Show the failed remote port, instead of the failing line number. + Subject: [PATCH 5.6.1 Debugger] More diagnostics + + Make Cwd more bulletproof in chrooted environments. + Subject: [ID 20001018.001] Fix for Cwd.pm (chroot) + + Subject: Pod patch for Devel::Peek + + Subject: Re: [ID 20001013.008] perl 5.6.0 on AIX 4.3.2 w/GCC 2.95.2 + + Borland C fstat() never saw the fd as writable. + Subject: fix for Borland's weak "stat" (perl@7211) + + Missing change from #7362. + + Subject: [PATCH 5.7.0] Re: [ID 20001018.008] flip-flop bug when there's no <FH> + + Add the test case for the bug id 20000730.004 which seems + to have been fixed by now. + + Fix of sorts for bug id 20000901.092. There seems to be no trace + of a 'pmshort' anywhere in the B, so the offending line was simply + removed. + + Subject: Re: [ID 20001013.008] perl 5.6.0 on AIX w/GCC + + Subject: PATCH do_print has 2 PerlIO_error()s + + NonStop-UX patches from Tom Bates <tom.bates@compaq.com> + + Typo noted by Mark Lutz. + + Subject: PATCH CR+LF should be "\cM\cJ" in perlop + + In the latest compiler builds cccdlflags must not become -fpic, + from Wilfredo Sánchez. + + Subject: [PATCH] Perl 5.6.0/5.7.0, vms/gen_shrfls.pl update + + Subject: [PATCH] Perl 5.6.0/5.7.0 enable DProf test for VMS + + SOCKS function redefinitions need prototypes, too, otherwise + for example 32 bit versus 64 bit differences cause a lot of + problems. Part of + Subject: [ID 20001016.017] [jens: 5.7.0 Solaris 8, 64 Bit, Workshop 6.0 Compiler] + + Portability tweak on #7377. + Subject: Re: [nick@cow.org.uk: [ID 20001020.004] Not OK: perl v5.7.0 +DEVEL7368 on i386-freebsd-64all 4.1-stable (UNINSTALLED)] + + Don't write double values through long double pointers, + based on a part of + Subject: [ID 20001016.017] [jens: 5.7.0 Solaris 8, 64 Bit, Workshop 6.0 Compiler] + + Reëntrancy fix. + Subject: [PATCH perl@7229] Rentrant parser and yylex() + + Make scan_num() reëntrant, as suggested in + Subject: [PATCH perl@7229] Rentrant parser and yylex() + + Fix for ID 20001020.006, concatenating an unset submatch + with utf8 resulted in "Modification of a read-only value". + + Fix for ID 20000915.011, IO::Select warning for an undefined fd. + + The #7383 was right only in the context of the original bug report, + not in more general case. + + Update Changes. + + Testcases for a #7383,#7385 related bug. + Subject: PATCH Re: [ID 20001020.006] "$2$utf8" == modification of read-only-variable + + Subject: [PATCH@blead Tie/Array.pm] Re: [ID 20001020.002] Tie::Array SPLICE method is buggy + + Tweak the Is* definitions of Unicode character classes + to better match the official categorizations; embrace + the official categorizations; add the combining marks + as alpha (and -numeric); fix DCinital (a typo and edito) + to be DCmedial. + + Hints tweak from Anton Berezin. + + Subject: installman go-faster stripes + Subject: Re: installman go-faster stripes + + Subject: [ID 20001021.003] updated hints/openbsd.sh + + Subject: [PATCH bleadperl] -MO=C falls over on package <none> + + Subject: PATCH $Config::Config{ldlibpthname} in ext/DynaLoader/DynaLoader_pm.PL + + Subject: [PATCH] Re: [ID 20000121.007] XXX documentation in man ExtUtils::MakeMaker + + Doc patch. + Subject: [ID 19991128.002] \&{'foo'} not caught by strict refs + + Retract #7404 with a patch from Robin Barker, via Andy Dougherty. + + Subject: Re: [ID 20001021.005] SEGV with regex match + + Subject: Re: [20000731.007] potential syntax error not detected [PATCH] + + The change #7187 was not so good on VMS. + Subject: [PATCH perl@7369] VMS perldoc.PL fix for double quoted temp filename + + Subject: [PATCH: perl@7386] miscellaneous typos in 3 pods + + Miscellaneous MacOS Classic library updates from Matthias Neeracher. + + Document PERL_INSTALL_ROOT of #7210. + Branch: maint-5.6/perl + +> README.aix hints/nonstopux.sh lib/unicode/Is/DCmedial.pl + +> t/lib/tie-splice.t + - lib/unicode/Is/DCinital.pl + !> (integrate 112 files) +____________________________________________________________________________ +[ 8156] By: gsar on 2000/12/17 22:49:13 + Log: integrate changes#7069..7077,7079,7081..7087,7090,7092,7093, + 7096..7104,7109..7117,7119..7124,7126,7128,7129,7133,7134, + 7136..7139,7141..7146,7148,7149,7151,7153..7155,7157,7158, + 7160,7161,7164,7165,7169..7178,7180..7191,7193..7197,7199, + 7201,7204 from mainline + + Remove vestiges of tr//CU. + Subject: [ID 20000912.009] perlunicode.pod still mentions tr///CU + Subject: Re: [ID 20000912.009] perlunicode.pod still mentions tr///CU + + The return value of setlocale must be copied away. + Subject: [ID 20000913.001] Heap corruption in Perl_init_i18nl10n + + Allow chop() and chomp() to be overridden. + Subject: [PATCH] Re: [ID 20000911.006] I can override glob but not chop? + + Hints optimization. + Subject: Minor nit + + Subject: [PATCH] de-wall t/README + + Subject: Re: Two advertising clauses need to be removed + + Batch of UTF-8 patches from Simon Cozens. + + Fix for a parsing bug, not for the original bug. + Subject: Re: [ID 20000910.005] Another segfault with regexes. + + Compilation warnings and an error. + + Subject: File::Find 5.7.0 POD nits + + Subject: [PATCH perl-5.7.0] continued -Wformat support + + The one that got away. + + Subject: Re: perl@7078 + + UTF8-encoded version of 256 is 0xc4 0x80; test that a char is + convertable to bytes by checking it doesn't go above 0xc3 + Subject: Re: perl@7078 + + Replace #7084 with + Subject: Re: perl@7078 + + We don't need to count the high bit bytes, a boolean is enough. + + Subject: [PATCH] utf8.c apidoc + + Subject: Re: perl@7078 + + Botched the #7090 check-in. + + Fix for the charnames.t failures from Spider Boardman. + + Re-instate Perl_utf8_to_uv without checking parameter - added in change 7075. + i.e. rename Simon's function to Perl_utf8_to_uv_chk, change all calls to it + to use new name and add Perl_utf8_to_uv() as a wrapper which calls it passing + 0 to checking to get the warning. + + Subject: [PATCH] Nits in perlmod.pod + + Subject: Re: Trapping by opmask sets strange parser state [PATCH] + + Subject: Re: unicode support and perl [ID 20000901.097] + + Subject: Re: unicode support and perl [ID 20000901.097] + + Subject: [PATCH perl@7065] another VMS my_fwrite() fix for Storable + + Subject: [PATCH] Re: [ID 20000915.010] Infinite loop with -MO=Deparse + + Subject: [ID 20000917.002] 5.7.0 and blead@7095 make html makes man + + Subject: [PATCH@blead] Fix some recursion in overload.pm + + s/Robin Parker/Robin Barker/ + + Subject: [PATCH] Fix aliasing of tied filehandles + + Subject: Re: [ID 20000912.008] substr replacement of tainted data (bug) + + Subject: Re: [PATCH 5.005_64 missed] + + SOCK_DGRAM and listen() do not mix as reported in + Subject: [ID 20000930.001] Bug in perl 5.00503 IO::Socket + The patch for 5.7.0+ had to be reengineered, though. + + Subject: DOC PATCH 5.6.0 + + Subject: [PATCH 5.7.0] Minor optimization in re_intuit_start + + Document the issue (is not a syntax error, kind of) + Subject: Re: [ID 20000901.011] the list (1,,3) ought to be a syntax error + + Subject: [ID 20000928.002] perlcc & ByteCode.pm option mismatch + Did not apply cleanly, manual intervention was needed. + + Subject: [PATCH] DLL not restartabke with threaded perl + + Inside require() $^S was always left undefined. + Subject: Re: Tiny 2-byte change to fix debugger's eval bug + + Subject: [PATCH pod/perlop.pod] Documentation glitch in magic autoincrement. + + OpenBSD flags tweak from Todd C. Miller, tweaked some more by Abigail. + + Regen headers. + + Subject: [PATCH 5.7.0] Epoc update + + Introduce NO_ENVIRON_ARRAY (and USE_ENVIRON_ARRAY) defines + as suggested by Olaf Flebbe and Nick Clark. + + Subject: [ID 20000915.007] Not OK: perl v5.7.0 +DEVEL7092 on os2-64int-ld 2.30 '(UNINSTALLED)' + + Misplaced else. + + Scale down the VMS message boxes, by Charles Lane. + Fix for ID 20000903.009, workaround at + http://www.xray.mpe.mpg.de/mailing-lists/vmsperl/2000-09/msg00039.html + + Subject: [ID 20001003.006] B::Debug not -w clean + + Test harness update to sync with the new perlcc, + from Simon Cozens. + + One remaining nit less at the VMS mailbox sizing. + + Subject: [PATCH: 7131] PWPASSWD problem for passwd less pwd's + + It is possible to have no hosts database at all. Pointed out in + Subject: [PATCH: 7131] PWPASSWD problem for passwd less pwd's + + Subject: [PATCH 5.7.0] h2xs not working + Subject: [PATCH 5.7.0] h2xs not documenting the created module + + Subject: [PATCH] 5.6.0 & 5.7.0 VMS TZ fix for VMS6.2 and earlier + + Subject: perlhack.pod Patch for Externals Tools + + Subject: [PATCH perlrun.pod] Re: [ID 20000930.002] perlrun nor perldelta mention -s modification + + Subject: Re: [PATCH 5.7.0] h2xs not documenting the created module + + Enable disabling scripts installation by Configure -Uinstallscripts, + suggested by H. Merijn Brand. + + Code around the stat-on-a-pipe-returns-a-mode-of-zero bug + reported several times by Dominic Dunlop, for example in + ID 20000315.008. Patch from Dominic. Patch affects at + least MachTen, and possibly other oldish BSDs. Should not + break non-broken platforms (tested on LinuxPPC). + + Regen toc. + + Subject: Re: Questions about Tie::Array and perl modules + Bug reported and fix suggested by Philip D Crow <pcrow@hertz.com>. + + Patch from Simon Cozens to avoid using utf8 routines in EBCDIC. + + Tweak #7153. + + IO::Handle->syswrite() did not handle length omission + like CORE::syswrite() does. + Subject: [Fwd] IO::Handle, syswrite and arguments + The original patch from andrew@ugh.net.au. + + Also the $ccflags is needed for the C compiler check. + Subject: Configure (check for C-compiler) + + Eliminate $Is_VMS code from the test. + Subject: Re: [ID 20001004.005] Not OK: perl v5.7.0 +DEVEL7129 on VMS_AXP V7.1 + + Fix bug in #7157 (s/cflags/ccflags); moved the -o foo + as the first option of cc/ld because of ultrapicky compilers + (e.g. OS/390 R2.5) + + Change the version number of Tie::Handle in the core to 4.0, + the (unrelated) Tie::Handle in CPAN will remain at 3.0. + Subject: Note on Tie::Handle + + UTF8ize split() so that the cloned substrings get the UTF8 + flag of the original scalar. Problem reported by Simon Cozens. + + save_re_context() could reset PL_curcop to freed memory, causing core + dumps in code such as C<use CGI::Carp; use something_that_calls_die;> + + Subject: PATCH 5.6 perldebguts grammar cleanup + + Add a todo note about overloadable assertions. + + on Windows, LoadLibrary() could load an extension DLL multiple + times if forward slashes are used in the path + + on Windows, cwd strings in the environment should be of the + form =X:=X:\foo instead of =X=X:\foo\ + + on Windows, avoid potential exception (could happen if MSVCRT isn't + being used) when closing a socket handle + + avoid nonportable example code + + Windows9x doesn't support link(), despite what Config.pm + might think + + pod nit + + Change #7160 had a nasty typo. + + Warn about unknown scripts. + Subject: Re: ideas? patches? [PATCH bleadperl] + + on Windows, clean targets might not work under some flavors of the shell + + tweak for change#7173 + + Make eq work again with utf8 (disabling the upgrading + should no more be necessary since the copies of the + scalars are upgraded, not the scalars themselves). + Takes care of ID 20001009.001. (The claimed length() + bug in 20001009.001 seems bogus to me.) + + Subject: [PATCH: perl@7159] various VMS cleanup issues + CXX configure + + Upgrade to CGI.pm 2.74, from Lincoln Stein. + + Upgrade to podlators 1.04, from Russ Allbery. + + Subject: [PATCH 5.6.0] Re: [ID 20001009.004] SEGV from sprintf in a thread + + Quote the temp file name, needed in Win32 because the + default name unfortunately contains spaces, shouldn't + hurt elsewhere. + Subject: FW: perldoc fails if $TEMP contains spaces + + Subject: RE: [ID 19990803.001] README.win32 suggestions + + Subject: [ID 20000720.004] ExtUtils::MakeMaker finds wrong version of perl + + Subject: Re: utf8 concat, mg_get + + Subject: [PATCH: perl@7181] perlebcdic.pod updates and corrections + + Subject: [PATCH: perl@7181] op/tr tests on OS/390 + + Subject: [PATCH: perl@7181] ver.t v string tests for os/390 + + Use the versiononly instead of the installscripts, + retract the changes 7146 and 7147. + + Reapply Andy's patch and regen Configure. + + Add the test case for #7190, from the original bug report + by Andreas König. + + Remove duplicated code. + + SvPV() (via mg_get() of sv_2pv()) can update the UTF8ness of the SVs. + + restore change#7202 + Branch: maint-5.6/perl + !> (integrate 121 files) +____________________________________________________________________________ +[ 8153] By: gsar on 2000/12/17 21:23:05 + Log: integrate changes#7017..7019,7021..7025,7027..7036,7038,7039, + 7041..7044,7046..7048,7050..7061,7063,7066..7067,7069..7074 + from mainline + + Document the SvIOK_.*UV(). + + Update Unicode todo list. + + Guard against bad string->int conversion for quads. + + Subject: small apidoc fix + + Subject: [PATCH] Tie::StdHandle did not know about 3-arg open + + Subject: [PATCH] Tied filehandle documentation + + Subject: [PATCH] Modernize Opcode.pm documentation + + Make Data::Dumper (non-XS) to work with changed semantics of ref(). + Subject: Re: Undocumented(?) change to "ref" semantics in 5.7.0 + [applied even though said semantics didn't change in 5.6.x] + + Subject: [PATCH@7014] \G in non-/g is well-defined now ... right? + + Subject: Re: [ID 20000905.001] Assertion failed: file "toke.c", line 202 + + Fix the URL, but the server is still missing in action. + Subject: [ID 20000905.002] perlfaq1.pod URL error + + Subject: [ID 20000903.001] \w in utf8-strings + + Fix the ccversion detection for 5.1 and beyond. + Subject: [ID 20000907.007] Not OK: perl v5.7.0 +devel-7030 on alpha-dec_osf 4.0f + + Subject: [PATCH 5.7.0] perl5db.pl [Was: Re: Debugger question] + + Subject: [ID 20000904.008] Tiny fix for perldiag + + Subject: Re: [ID 20000906.004] segfault with bad perl statement + + Subject: Re: [ID 20000907.007] Not OK: perl v5.7.0 +devel-7030 on alpha-dec_osf 4.0f + + Subject: [ID 20000908.002] perlipc documentation bug. + + Subject: [PATCH lib/Benchmark.pm] + + Re-allow vec() for characters > 255. + Subject: [PATCH] Re: [ID 20000907.005] Not OK: perl v5.7.0 +devel-7030 on alpha-dec_osf-perlio 4.0f (UNINSTALLED) + + Do away with memory models cruft. Sorry, PDP users. + + Continue #7041. + + Subject: [PATCH (or RFC): 5.7.0] make the ran_tests intermediate file 8.3 friendly + + Subject: [PATCH: 5.7.0] proper setting for isnan for DECC 5.3 + + Upgrade to CPAN 1.57_65, from Andreas König. + + Upgrade to podlators-1.03 (Pod::Man 1.07 and Pod::Text 2.05), + by Russ Allbery. + + Silence t/pod/*.t about alternate quote-mappings now implemented + by Pod::Text, from Brad Appleton. + + Modern Borland C now seems to have anon unions for info.wProcessorArchitecture + Subject: borland C++ win32.c tweak + + C<@a = @b = split(...)> optimization coredumps under ithreads + (missed a spot when fixing up op_pmreplroot hack for ithreads) + + Document the SvUTF8*(). + + Subject: [PATCH] Perl 5.6.0, 5.7.0 ... vms/test.com to eliminate spurious NL's in test output + + Subject: RE: [Patch 5.7.0] Removing -ldb from the core build + + Do in VMS as the #7054 does. + + Subject: [patch] perlfunc.pod -- POSIX::sigpause should be POSIX::pause + + Subject: [ID 20000911.008] Not OK: perl v5.7.0 +DEVEL7048 on os2-64int-ld 2.30 (UNINSTALLED) + + Subject: [patch: perl@7045] vms updates + + Test for the #7049. + Subject: Re: [PATCH] Re: [ID 20000910.001] Not OK: perl v5.7.0 +DEVEL7044 on i686-linux 2.2.16-raid (UNINSTALLED) + + Break up the myconfig lines a bit. + Subject: perlbug/perl -V output format + + Subject: [ID 20000911.011] misplaced typemap in perlxs.pod + + The #7054 truncated Configure badly. + + change#6327 didn't quite go all the way to enable USE_SOCKETS_AS_HANDLES + initialization in all the threads on Windows + + Allow for whitespace between "#" and "line" in cpp output. + Subject: [PATCH] Re: Problems compiling bleadperl on Unicos 9 + + Remove vestiges of tr//CU. + Subject: [ID 20000912.009] perlunicode.pod still mentions tr///CU + + The return value of setlocale must be copied away. + Subject: [ID 20000913.001] Heap corruption in Perl_init_i18nl10n + + Allow chop() and chomp() to be overridden. + Subject: [PATCH] Re: [ID 20000911.006] I can override glob but not chop? + + Hints optimization. + Subject: Minor nit + + Subject: [PATCH] de-wall t/README + + Subject: Re: Two advertising clauses need to be removed + Branch: maint-5.6/perl + !> (integrate 75 files) +____________________________________________________________________________ +[ 8152] By: gsar on 2000/12/17 20:30:11 + Log: integrate changes#6945,6947,6949..6954,6956,6958,6959,6961, + 6964..6972,6977..6981..6984,6987,6988,6991,6994,6997, + 6999..7001,7003..7005,7007,7009,7011,7012 from mainline + + Don't attach -ld to the archname if pointless. + + Document UNTIE in a very minimalistic way. + + POSIX doesn't report long double values under -Duselongdouble + when the long doubles are "real" (bigger than doubles). + + More author updates. + + Try to deduce NV_MAX. Really should be Configure fodder. + + :: not allowed in pathnames, change to . + Subject: [PATCH perl@6938] cygwin port + + Forget about NV_MAX (#6951). Various floating point tweaks, + ideas from Eric Fifer, Yitzchak, Alan, and Spider. + + Move the Solaris 7 scan to use64bitall, make the + failure to find 64-bot sparc libc to mention the + possibility of being in an intel, from Lupe and Alan. + + Regen perltoc. + + AUTHORS tweaks, from Peter Prymmer. + + More address tweaking. + + Small tweaks all over. + + File::Temp patches from Andreas König, + + Subject: [PATCH perl@6962] 2 more vms.c fix-ups and status + + Subject: CPAN.pm beta 1.57_57 for the core + + Part of the solution. + Subject: Re: [ID 20000807.004] [PATCH] conditional breakpoints leak memory + + Subject: [PATCH@6961] Fix misleading example in perlretut.pod + + Subject: [PATCH lib/overload.pm] Sanaty checking of arguments to overload::constant + + Add the overload warnings to perldiag. + + Drop unused argument. + Subject: Re: [ID 20000831.034] overload::constant and number of arguments. + + Subject: Nit in Configure (bleadperl@6961) + + Update to PodParser 1.18, from Brad Appleton. + + Subject: [ID 20000901.017] [PATCH] Basic test failure in an untidy world + + Subject: [PATCH: 6948] add SCNfldbl to configure.com + + Document UNTIE. Also tweak implementation to suppress the 'inner references' + warning when UNTIE exists and instead pass the cound of extra references to + the UNTIE method. + + Rename the PRIElfbl, PRIX64, etc, to be PRIEUfldbl, PRIXU64, + so that case-ignoring systems like DCL can tell them from + PRIefldbl and PRIx64. Apply Merijn's ccversion patches. + + Subject: Re: [PATCH lib/overload.pm] Sanaty checking of arguments to overload::constant + + Feature ordering tweak. + + Regen perltoc. + + Subject: [PATCH] Fix vec() / utf8 (was Re: bitvec ops still broken with utf8 -- or not?) + + Subject: Re: [PATCH perl@6962] 2 more vms.c fix-ups and status + + Subject: http:// in L<> + + Detypo. + + change#6791 accidentally clobbered change#6710, put it back + + Only the first line, thank you very much. + + Subject: [PATCH: 6996] minimal removal of 8 bit chrs from perlebcdic.pod + plus rework the http: spots as suggested by Tom Christiansen, + plus regen perltoc. + + Undo part of change 6489 which looks like a bulk edit which + changed _all_ gv_efullname3() calls to gv_efullname4() calls. + The supressing of main:: on return from select() is undesirable. + + Apparently avoiding the swapping is too costly. + + Various Configure nits by Philip Newton, + plus the ebcdic one by me. + + Make certain cc is set before trying to run it. + + If overloaded %{} etc. return the object do not loop. + Thus sub deref { $_[0] } functions if object is wanted type. + + Update perlhist. + + More %{} and other deref special casing - do not pass to 'nomethod'. + Branch: maint-5.6/perl + !> (integrate 59 files) +____________________________________________________________________________ +[ 8151] By: gsar on 2000/12/17 19:14:38 + Log: integrate changes#6903,6905..6907,6909,6911..6913,6915,6917,6918, + 6920..6926,6928..6930,6934..6937,6939,6940,6942..6944 from mainline + + Subject: [PATCH perl@6889] Chuck Lane's OpenVMS piping improvements + + Make the epsilon to be relative, not absolute. + + Put back the flags dump as reasoned in + Subject: Re: [PATCH] Glob dumping + + Introduce ccname to keep track of what compiler kind of we have. + + Subject: Re: [ID 20000829.020] perl -e 'package; print __PACKAGE__' core dumps + + Put back the slice accidentally removed by #6907. + + Reset archname and archname64 always, forcing them be + recomputed at each Configure run, make Configure and + the hints files agree on the naming of largefiles variables. + + Don't say "Perl 5.0 source kit". + + Subject: [PATCH] fix misc cast warnings + + Subject: typos in pods + + NVs not necessarily doubles, as pointed out by Yitzchak. + + Subject: [PATCH 6889] add a few ldbl formats to configure.com + + Subject: [ID 20000830.036] [DOC] chom?p %hash not documented + + Better options for rsync. + + Subject: [PATCH perl@6889] fix Storable on VMS by fixing my_fwrite() + + Subject: Re: not OK, 6919 on Alpha VMS V 7.1 w/ DECC 6.0-001 + + Subject: [PATCH] Re: UNTIE method + + A better fix for the Socket building problem from Craig Berry. + + Retract the dummy test, skip the security tests (instead of failing), + explain what the warnings mean. + + Heap decorruption. + Subject: [PATCH] Fix for miniperl coredump on Solaris with -Duselongdouble + + Update to Unicode 3.0.1. + + Missed one Unicode file. + + Subject: Re: typos in pods + + The #6929 was too skimpy. + + sscanf() may be the only way to read long doubles from strings. + + Reveal Borland's isnan. + Subject: build with BC++ tweak + + Issue useful diagnostic on unknown pod commands. + Subject: [PATCH lib/Pod/Man.pm] Re: [ID 20000830.048] + + Subject: [PATCH] Re: [ID 20000830.048] Not OK: perl v5.7.0 +DEVEL6938 on i686-linux 2.2.13 + + Clarify the third case of ftmp-security warnings. + + Make -Dusemorebits find long doubles in Solaris. + + Wrap the test in eval. + Branch: maint-5.6/perl + +> lib/unicode/BidiMirr.txt lib/unicode/CaseFold.txt + +> lib/unicode/PropList.txt lib/unicode/README.perl + +> lib/unicode/UCD301.html lib/unicode/UCDFF301.html + +> lib/unicode/Unicode.301 vms/vmspipe.com + - lib/unicode/Props.txt lib/unicode/UCD300.html + - lib/unicode/Unicode.300 lib/unicode/Unicode3.html + !> (integrate 305 files) +____________________________________________________________________________ +[ 8146] By: gsar on 2000/12/17 18:09:08 + Log: update Changes + Branch: maint-5.6/perl + ! Changes +____________________________________________________________________________ +[ 7899] By: gsar on 2000/11/28 06:32:55 + Log: reintegrate files missed by change#7895 + Branch: maint-5.6/perl + +> ext/ByteLoader/bytecode.h utils/Makefile + - utils/perlbc.PL +____________________________________________________________________________ +[ 7897] By: gsar on 2000/11/27 18:22:47 + Log: can't integrate these two files, for some reason + Branch: maint-5.6/perl + - ext/ByteLoader/bytecode.h utils/Makefile +____________________________________________________________________________ +[ 7895] By: gsar on 2000/11/27 18:11:21 + Log: integrate changes#6763..6766,6770,6773,6775..6776,6778,6780, + 6782..6791,6793..6814,6816,6818..6822,6824..6830,6838..6849, + 6757..6890,6892..6901 from mainline + + Bytecompiler patches from Benjamin Stuhl. + + More bytecompiler. + + Subject: [PATCH blead] B:: missing dependency + + Subject: [PATCH: 6757] configure.com updates and syslog build + + Long double Gconvert fixes from Yitzchak Scott-Thoennes + and Spider Boardman. + + Subject: [PATCH blead] nextchar() abuse misses an optimisation + + Long double fixes from Spider Boardman. + + Make the selection of NVff et al stricter. + + cSVOPo_*v things index into the current PL_curpad + under ithreads, which is different from the curpad + used by the XSUB. (In other words, the code as-is + before this patch wouldn't work under ithreads.) + + Be portable. + + VMS MMS (make) wants null action. + + Mac and other portability updates from Chris Nandor. + + Storable support, v-version fixes. + Subject: CPAN.pm beta for testing available + + Portability fix from Hugo van der Sanden. + + Bad makefile. + + Subject: [ID 20000823.004] [PATCH 5.6.0+] Pod::Html is too self-contained + + Subject: [PATCH] (Mac OS X): Don't #define environ unless PERL_CORE + + Subject: [PATCH] Re: [ID 20000821.008] Negitive numbers with vec dumps core + + Replace #6705 with a minimal doc patch. + Subject: [PATCH 5.6.0] replace change #6705 + + Drop the separate perlbc, perlcc -b should be enough. + + installperl couldn't tell whether it had run tests or not. + Subject: [PATCH] Re: installperl and t/TEST + + Add silencer flags to installperl. + Subject: [PATCH] Making installperl silent. + + Make "make install" by default silent. A new "install-verbose" + target is verbose. + + More liberal parsing of version numbers. + Subject: Re: CPAN.pm beta for testing available + + Create directories in silence. + Subject: [PATCH] Another silencer for MakeMaker + + DOS patches and portability/porting notes, from Tim Jenness. + + Make installman to recognize the silence flag -S. + + Actually do something with the silencer option. + + Continue silencing. + + Show the doc file, not the temp file. + + Regen perltoc. + + Subject: [PATCH] More silencing of installman. + + Better wording for the vec lvalue diagnostic. + Subject: Re: [PATCH] Re: [ID 20000821.008] Negitive numbers with vec dumps core + + Subject: [PATCH: 6805] several more tweaks to configure.com + + Subject: [PATCH perl@6805, 5.6.0, 5.005_03] prevent rare Perl hang on VMS + + Missing parts of + Subject: [PATCH: 6789] some endl fixes for VMS wackiness + + Subject: [ID 20000824.029] MakeMaker manifypods fails on DJGPP systems + (applied slightly modified) + + installperl --verbose and --silent. + Subject: Re: [PATCH] More silencing of installman. + + Add install-silent target. + + AIX 4.3.3 has SOCKS in libc with a differently named init routine, + the problem reported in + Subject: [ID 20000825.007] Building stable 5.6.0 on AIX 4.3.3 using SOCKS + + Tweak the sfio/useperlio logic, hopefully as wished in + Subject: [ID 20000825.004] Not OK: perl v5.7.0 +SUIDMAIL +DEVEL6804 on i586-linux 2.2.12 (UNINSTALLED) + + One forgotten file from #6816. + + Subject: [PATCH @6820] installman under -w and strict (was Re: [PATCH] More silencing of installman.) + + Remove duplicately applied patch shards. + Subject: [ID 20000825.012] [PATCH@6822] t/lib/cgi-html.t produces ugly cruft during 'make test' + + Support preserving extremely big/small angles. + + Subject: Re: [ID 20000825.019] Not OK: perl v5.7.0 +SUIDMAIL +DEVEL6820 on alpha-dec_osf 5.1 (UNINSTALLED) + + Subject: [PATCH] installation not quite silent yet. + + Update the test count. + + Use UVxf, PTR2UV, NVff. + + Document PTR2XX and INT2PTR. + + no-install target a la make -n. + Subject: [PATCH] make no-install (was Re: [PATCH] installation not quite silent yet.) + + grep -e isn't portable. + Subject: [ID 20000825.027] let me (perlbug@perl.com) know how I blew it + + Can't get the test to reliably work thanks to the + inaccurateness of floating point. "Resolves" bug ids + 20000826.003, 20000826.009, 20000826.010, + + Subject: installman buglet + + DJGPP update from Laszlo Molnar. + + Subject: MM_Unix.pm LD_RUN_PATH niggles on Solaris + + Passing -R in ldflags makes now it to appear in the default + for lddlflags, just like with -L. + Subject: Re: MM_Unix.pm LD_RUN_PATH niggles on Solaris + + Test nit. + + Use the actual thread type, not the pointer-to-struct. + + Provice virtual $Config{ccflags_nolargefiles} etc. + + display_format used as a class method without arguments was broken, + reported in + Subject: Math::Complex->display_format() sets style to 'Math::Complex' + + Subject: [ID 20000828.006] dir name "0" not safe with Cwd.pm + + Subject: [ID 20000828.009] Not OK: perl v5.7.0 +SUIDMAIL +DEVEL6855 on i586-linux 2.2.12 (UNINSTALLED) + + Subject: [PATCH@6855] _Minor_ change to overload.pm pod + + opmini.o may be left around if a build is interrupted. + + Typo in #6858. + + Fix for ID 20000828.001, long doubles were not formatted + correctly (showed up in $], which stopped installing perl). + + An attempt to fix the problem reported in + Subject: Building perl@6856 using gcc/AIX 4.3.3 + I can't test this properly since the gcc installation I have + access to seems to be botched (gcc is calling the AIX cpp, + a losing proposition...) + + Add -ld to archname on long tr...double platforms. + + Subject: hv.h Doc Patch + + Potential cruft. + + Subject: [PATCH bleedperl@6856] warnings fixes + + -S is the silent flag, -s is the strip flag. + Subject: [PATCH] Re: [PATCH] make no-install + + Take out the SUIDMAIL thing, that will not be + a problem in 5.7.*. + + Subject: [PATCH bleedperl@6866] spellings + + Subject: [PATCH] Re: files not cleaned even by veryclean + + Use minimal @INC in tests, most of the time just '../lib', + so that we simply can't pick up stuff from other Perls than + the one we are testing. Pointed out by + Subject: Re: [PATCH: 6757] make new Storable tests forgiving of places where not built + + Update to Getopt::Long 2.24, from Johan Vromans. + + Fix for thinko in #6848. + Subject: Compiler error in ext/Thread/Thread.c (bleadperl@6866) + + Patches all over for people and the files they (hopefully) care about. + + Subject: Net::protoent does not export 'getproto' + + Missed a change in #6869. + + Subject: [PATCH] Warnings in B::Deparse + + Subject: [PATCH] Glob dumping + + Disable one of the tests for now. + + Disabling the one test is a bit tricky. + + Don't forget to tidy up. + + The #6881 removed one dump line. + + Subject: Re: [ID 20000525.003] perldoc fails when Makefile.PL is in cwd + + Under usethreads the dumped variable is IN_PAD. + Subject: Re: [PATCH] Glob dumping + + Subject: [ID 20000829.026] [PATCH 6868] File::Temp + + Subject: [ID 20000829.022] [PATCH 6868] Minor nit in installhtml + + Subject: [ID 20000829.023] [PATCH 6868] perlbug@perl.com --> perlbug@perl.org + + Regen Configure for #6894. + + Subject: [PATCH: 6889] updates to perlebcdic.pod + + Undo namespace pollution of #6878. + Subject: Re: Net::protoent does not export 'getproto' + + Admit that we are leaking scalars. + + Subject: [PATCH 5.6.0] [ID 20000608.006] panic: magic_killbackrefs with blessed global weakrefs + Branch: maint-5.6/perl + !> (integrate 271 files) +____________________________________________________________________________ +[ 7894] By: gsar on 2000/11/27 16:00:34 + Log: a couple of nits + Branch: maint-5.6/perl + ! MANIFEST pp_sys.c +____________________________________________________________________________ +[ 7893] By: gsar on 2000/11/27 15:10:56 + Log: integrate changes#6666..6678,6680..6682,6684..6691,6699..6733, + 6740..6745,6747..6757,6760 + + Subject: Re: [ID 20000816.006] [PATCH @6655] Shell.pm, bug fix, strict and OO Interface + + Subject: [PATCH(2) @6655] Re: perldebut.pod - spelling + + Doc nits spotted by Richard Soderberg. + + move WNOHANG definition to where other such things are + + Make $Config{byteorder} more magical so that it is + dynamically computed: nice for 'fat binaries'. + Subject: [PATCH]: default byteorder + + Subject: [PATCH] Cwd.pm now uses strict + + Subject: Re: [PATCH]Re: Questions about Math::BigFloat + + Get -DLEAKTEST to compile (not necessarily to work, mind) + Subject: [ID 20000724.006] -DLEAKTEST problem + + perldebtut 1.10 from Richard Foley, plus Celsius and Fahrenheit. + + Add perlebcdic from Peter Prymmer, regen toc. + + Don't propose using modules built for 5.005 if no binary + compatibility with 5.005 is attempted. + + Do not use prototyping here. + Subject: [ID 20000817.016] [PATCH] Peek.xs + + Document what the backtick returns if the command fails. + + Add byteorder to the myconfig output. + + Introduce NVef, NVff, and NVgf, use the middle one. + (helps for lib/peek + Linux + long doubles) Reported in + Subject: [ID 20000814.005] Not OK: perl v5.6.0 on i686-linux-64int 2.2.13 + Use NVs in POSIX math, not doubles. + Subject: [ID 20000817.014] POSIX & modfl + + Subject: [PATCH 5.6.0+] newSVrv() memory leak + + The byteorder code in #6671 was wrong. + + Fix the lib/complex failure of + Subject: [ID 20000814.005] Not OK: perl v5.6.0 on i686-linux-64int 2.2.13 + Linux long double accuracy issue: something that + when printed with %g looks like "2" but int() of it is 1. + + Propagate new Configure vars. + + Unbuffer the output. + + Subject: [PATCH] perltrap.pod spring cleaning + + Subject: [PATCH] perlfunc.pod -- clarifying sprintf array argument issues + Subject: [ID 20000817.018] behaviour change 5.5.3 -> 5.6.0 re "Modification of a read-only value" + + Tiny Getopt::Long patch from Johan Vromans. + + Document code point which makes if (defined %stash::) to work + (noted by Spider Boardman). + + Subject: [PATCH perl@6698] cygwin port + + Document the NDBM_File and ODBM_File as SDBM_File + was documented in #6417. + + The new tests were missing from #6415. + + Add [[:blank:]] as suggested in + Subject: [ID 20000716.024] [=cc=] / [:blank:] + (the [=cc=] has already been taken care of by #6439 + so the whole bug report can be closed) + and make [[:space:]] to be equivalent to isspace(3) + (as opposed to \s, which is isSPACE()). The difference + is that now [[:space:]] matches the mythical vertical tab, + while \s doesn't. + + Don't eat leading os from index entries. + Subject: Re: [ID 20000810.006] Pod::Man Ate My 'O'! + + Subject: [PATCH 5.6.0+] fix for Win32::DomainName + + Typo in pp_complement(). + Subject: [PATCH perl-current] Deparse + + Add warnif(), check warnings further up the stack, + all the warnings functions now can take an optional object reference. + Subject: [PATCH bleedperl@6691] warnings pragma update + + Fix a core dump in lib/selfloader under -DDEBUGGING. + Subject: PATCH @6698 for [ID 20000817.007] Not OK: perl v5.7.0 +SUIDMAIL +DEVEL6676 on alpha-dec_osf 4.0f (UNINSTALLED) + + Subject: [PATCH 5.6.0+] fix for Win32::GetFullPathName and Win32::GetShortPathName + + Subject: [PATCH: 6698] tidy up the temp files left by peek tests on VMS + + Subject: [PATCH: 6698] was Re: [PATCH: 6640] VMS Makefile.SH update (fwd) + Put back the long double avoidance code to POSIX.xs + because VMS seems to need it still. + + Introduce a 'veryclean' target that is like 'distclean' + but also removes *~ and *.orig. + + Subject: [ID 20000817.023] endianness description in perlfunc.pod + + Subject: [PATCH perl@6698] File::Temp fix-ups for OpenVMS + + Let's try #6717 again. + + UTF8 concat fixes. + Subject: [PATCH @6713] Re: [ID 20000815.006] latest patched perl core dumps + + pp_open() could pass an uninitialized filename down to do_open9(). + + Subject: Re: [ID 20000819.002] Not OK: perl v5.7.0 +SUIDMAIL +DEVEL6707 on i686-linux 2.2.5-16 (UNINSTALLED) + + Update to CGI 2.72, from Lincoln Stein. + + Subject: [PATCH] Silence MakeMaker (Was: installman) + + Use temporary directory instead of current directory. + Subject: Re: [ID 20000816.011] Test failure in lib/ftmp-security.t + + Document odd vs even subreleases and -Dusedevel. + + The veryclean target needs to clobber. + + Use File::Spec->tmpdir(). + + Document the number of exponent digits. + + Mention perlebcdic and perlposix-bc. + + s/this one/the 5.6.0 release/ + + The #6724 is here. + + The correct cleaning order is an art. + + small tweaks for change#6705: avoid C++ style comments in C code; + use Perl's malloc API rather than the low level system one + + Array context keeps slithering in. + + Subject: Re: 5.7.0 getting really close, new snapshot: perldelta, Storable + + Subject: [PATCH] os2.c fix for use64bitint + + Update to Pod::LaTeX 0.53. + Subject: [PATCH] lib/Pod/LaTeX.pm updates + + Document the endianness of Alpha more precisely. + + Subject: RE: [PATCH perl@6736] t/pragma/warn/9enabled assumes stdout buffered + + Rename the macro argument because some preprocessors + can't tell the difference and expand arguments also inside + double quoted strings. + + free TLS slot properly on Windows + + use Cwd 'chdir' didn't set $ENV{PWD} correctly on Windows + + Unicos/mk requires elaborate paranoia. + + Tweak the floating point output routine preferences. + + Also under djgpp the timestamps are funky. + + Apply some PodParser 1.18 patches; the Pod/Find.pm + patches cannot be applied since #6712 conflicts. + + Use PodParser 1.18 new test. + + A pod nit. + Subject: [PATCH] pod/perlre.pod (was Re: [ID 20000821.007] $&, $1, etc. disappear when sub returns) + + Be verydeepclean. + Branch: maint-5.6/perl + +> pod/perlebcdic.pod + !> (integrate 106 files) +____________________________________________________________________________ +[ 7887] By: gsar on 2000/11/27 14:13:05 + Log: integrate changes#6613..6616,6620..6665 from mainline + + VMS configure.com update continues. + + Subject: Test fails / warnings with perl-current #6612 + + Subject: [PATCH] @+, @- readonly (was Re: @<punct> interpolating in "") + + Subject: Re: [ID 20000807.003] [PATCH] Debugger treatment of condition "0" + + For now remove the mail code. + + Subject: Re: [PATCH] @+, @- readonly + + Subject: warning: storage class after type is obsolescent + + Subject: sfio2000 + + Subject: Re: File::Temp problems on VMS in bleedperl + + README.os2 update. + Subject: Re: [PATCH perl-current] Make op/sprintf.t more comprehensive, + + Make the user to give up his firstborn, err, to knowingly + verify installing an unstable developer release. Also bump + the release to 5.7.0, but leave a patch tag in the local + patches saying that this is not yet the real thing. + + Update (kinda) to Test 1.14, from Joshua Pritikin. + + make ok etc also for win32. + + Subject: [ID 20000815.005] [PATCH] perldoc not looking in the right place for script pod + + Don't blow limited stacks, a lower number is enough to + tickle the lookbehind limit. + + Use -Dusedevel; regen Configure and the respective Porting stuff. + + Subject: [PATCH] debugger exit code should reflect user exit code + + Subject: [PATCH perl@6620] cygwin port + + Missed a file from #6638. + + Subject: [PATCH] for t/lib/peek.t (was Re: [ID 20000814.005] Not OK: perl v5.6.0 on i686-linux-64int 2.2.13) + + magic callbacks all need to have same type signature + + Subject: [ID 20000815.014] [PATCH] INSTALL doesn't mention 64 bit support. + + Fix a dependency problem. + Subject: [PATCH: 6640] VMS Makefile.SH update + + The numeric locale was reset to "C" by s?printf and never restored. + Subject: [ID 20000809.003] setlocale(LC_NUMERIC...) produces different results in 5.005 and 5.6 + No test since adding the failing example to locale.t + does not fail -- probably because the locale settings are so + thoroughly tweaked by that time. Running the example standalone + does fail, though. UPDATE: test case added at change #7540. + + Subject: [ID 20000324.040] minor fix to perlhpux.pod + + Update to CPAN 1.57. + + Subject: [PATCH] Cwd::_backtick_pwd does not check return value + + Change the perlbug address to perl.org since it's more forgiving. + + Change the regx compilation error markers to use = instead of < + since pod makes using the latter quite messy. Reported in + ID 20000814.006 by Abigail and in + Subject: Unknown escape E<> ? + + Update to perldebtut 1.9, from Richard Foley. + + check that the number pseudo children doesn't exceed + MAXIMUM_WAIT_OBJECTS, which is currently 64 (avoids overflowing + the WaitForMultipleObjects() limit that would cause wait() + to crash) + wait() and waitpid() could potentially be rewritten to use + more than one thread to do the waiting to eliminate this + limitation + + change#6328 could make close(SOCKET) return false on windows + when it shouldn't + + pod nit seen in passing + + on windows, the return values from wait() and waitpid() don't + match those of pseudo-pids + + waitpid() now handles externally spawned pids correctly; + fixes for backtick/wait/waitpid failures on Windows 9x + these changes make the pid returned by process functions on + Windows 9x always positive by clearing the high bit (which + is always set on Win9x); pseudo-process PIDs are likewise + always negative now on Win9x (just as on NT/2000) + + trailing new %ENV entries weren't being pushed into the real + environment of subprocesses on Windows + + Tweak the regex compilation errors once more. + + avoid warnings from dense compiler + + add "ok" targets from change#6632 in makefile.mk + Branch: maint-5.6/perl + - lib/Pod/PlainText.pm vms/configure.com + !> (integrate 66 files) +____________________________________________________________________________ +[ 7885] By: gsar on 2000/11/27 13:53:18 + Log: integrate changes#6540..6541,6546..6549,6552..6554,6557..6606, + 6610..6611 from mainline + + Make regular expression parse error messages easier to understand. + Subject: Re: enhanced(?) regex error messages + + Tiny tidying on report_evil_fh(). + + Subject: Re: enhanced(?) regex error messages + plus Capitalize the error messages, plus perldiag them. + + Subject: Patch against 5.6.0 to allow "-d:Module=arg,arg,arg" + + Document here-doc better. + + Subject: [ID 20000807.003] [PATCH] Debugger treatment of condition "0" + + Subject: [PATCH] Re: [ID 20000807.008] Double reads considered evil? (deja vu) + Do away with array context, from Daniel Chetlin <daniel@chetlin.com> + (either perlbug or p5p ate the original), plus regen + perlapi and perltoc. + + Regen global.sym. + + Double check that we have a dirhandle. + + Subject: Re: enhanced(?) regex error messages + (plus two small patches sent privately) + (this still seems to leave few test failures) + + warn is a macro, avoid using at a variable to avoid warnings + in some configurations; readdir.t is too conservative in + estimating number of *.t's + + Get back into sync with Jeffrey on the enhanced regex warnings. + + Subject: [PATCH 5.6.0] cygwin port + + Zero entries were skipped, fix from Adrian Goalby + <argoalby@yahoo.co.uk> + + Subject: Remove dead entry in perldiag + + Amend the description of Perl6. + Subject: [PATCH Perl-5.6.0] perlfaq1.pod + + detypo + + It's the 2ndO'ROSSC. + + Revert the sv.c part of #6559, a better fix is needed. + + Iterating perl6 description. + + Update to Term::ANSIColor 1.03, from Russ Allbery. + + Update to Getopt::Long 2.23_05, from Johan Vromans. + + Small AUTHORS and MAINTAIN updates. Could do with big updates. + + Update to Pod::Parser 1.17, from Brad Appleton. + + Update to CPAN 1.56, from Andreas König. + + Update to CGI 2.70, from Lincoln Stein. + + Put back the std @INC thing. + + Fixes to looking-like-number to keep behaviour as it was in 5.005_03. + Subject: Re: [ID 20000810.002] $a["1foo"] same as $a[0] + + Document the IO::Select timeout. + + sleep(1) does not necessarily return 1. + Subject: [PATCH bleadperl] op/lex_assign.t + + Subject: debugger "d" command doesnt check line number + + B::Deparse didn't do sub attributes. + Subject: B::Deparse was Re: [ID 20000808.005] refs to returned lvalues are lvalues?? + + Preprocessing and postprocessing for File::Find. + Subject: Patch to Find::File.pm to allow alphabetical results + + Subject: Re: [ID 20000809.005] trouble with long string and /m modifier - uninitialized value + + Subject: Re: [ID 20000809.006] Debugger lost the ability to see $1 et al + + Subject: Re: [ID 20000730.003] utf8::length() bad + + Subject: Getting perlio and threads to compile + (the Solaris version changes in Configure skipped) + + Tests for #6589. + Subject: Re: B::Deparse was Re: [ID 20000808.005] refs to returned lvalues are lvalues?? + + Add Perl debugging tutorial, regen toc. + Subject: perldebtut.pod + + Add a few missing files, update MANIFEST. + + Rewrite of vms/subconfigure.com as configure.com, + from Peter Prymmer and the vmsperl crew. + + Should have deleted this in #6603. + + Fix the test for 5005threads. + + Fix-n-skip the tests under 5005threads. + + Subject: [PATCH] t/op/regmesg.t fails if REG_INFTY set + + Upgrade to CGI 2.71, from Lincoln Stein. + Branch: maint-5.6/perl + +> lib/CGI/eg/make_links.pl lib/CGI/eg/wilogo.gif + +> lib/Pod/PlainText.pm pod/perldebtut.pod t/lib/gol-oo.t + +> t/op/regmesg.t t/pod/find.t vms/configure.com + - vms/subconfigure.com + ! lib/lib.pm + !> (integrate 115 files) +____________________________________________________________________________ +[ 7883] By: gsar on 2000/11/27 11:50:46 + Log: integrate changes#6469..6484,6486..6501,6504..6505,6507..6509, + 6511..6513,6515..6523,6525..6536 + + The swallow_bom() saga continues. The #23 of require.t + (UTF16-LE) still fails (silently, no output) but the #22 + (UTF16-BE) seems to be working now. The root of the + failure may be in sv_gets(): is it UTF-16LE-aware, + especially when it comes to line endings? + + Document the problem with -P in HP-UX and its workaround. + + Subject: [PATCH] allow non-variable as lhs of non-updating tr/// + (aka ID 20000730.002) + + Subject: fix and question re: waitpid() under win32 + + Make the safety catch for buggy gccs work with triple version + numbers like 2.95.2. Reported in + Subject: [ID 20000731.005] Perl 5.6.0 "Configure" fails to recognize gcc 2.95.2 + + In Digital UNIX warn if gcc explicitly chosen because even + 2.95.2 is known to cause problems. + + Make chr() for values >127 to create utf8 when under utf8. + + various syntax errors and such (not fixed: comp/require.t#22 coredump + on Windows) + + Stash away the largefiles flags and libswanted. + + BOM patching from Simon Cozens. + + If gccosandvers is equal to osname, clear gccosandvers. + + Make p4desc to skip non-mainperl branches by default. + + Subject: [Proposed PATCH] Let Perl define QUAD_MIN and _MAX itself + + The test from this + Subject: Re: [ID 20000411.002] qw() gives different results in 5.6 to previous versions + + In new BSDs changes to argv[] do not show up in ps(1) output, + instead one must use setproctitle(). This was already addressed + by change #6457, but the below has a new variant for FreeBSD 4.0 + or later, and the matter is also documented more. + + FreeBSD 3.* updates from + Subject: [ID 20000801.007] setting $0 on FreeBSD 4.x does not get reflected in /bin/ps + + regen_headers, regen perltoc. + + Document in one place the memory abstractions used in Perl core. + + memcpy has n o in it, as pinted ut by Sarathy. + + Remove the extraneous "main::" prefix from all the + "opened only for", "on closed", and "never opened" warnings. + + The name of a filehandle does not have <these>. + + The tr utf8 patching continues. + + The new setproctitle() feature is available only in + bleeding edge FreeBSD. From Paul Saab. + + Subject: [PATCH bleadperl] [ID 20000731.010] regex error + + Dump UVs as UVs in Data::Dumper. + + detypo #6494 + + Document the IVdf UVuf UVof UVxf. + + require.t needs binmode() to work on windows + + Generate OP_IS_SOCKET() and OP_IS_FILETEST() macros + that are hopefully soon put into use. + + Allow "no Module;" even if there is no 'unimport'. + + Better skip message for the test; one of the two problems in + Subject: [ID 20000224.003] Not OK: perl v5.5.660 on i86pc-solaris 2.7 + + The subtest 4 may fail also on VOBS, as pointed out + by Nick Ing-Simmons in November 1999, bug id 19991124.003 + (but the failure in that bug report isn't the subtest 4). + + Be more informative on what is skipped and why, + also repeat the list at the end. + + Add a URL for FSF. + + Subject: [PATCH] sv.h documentation - SvLEN + + Subject: [PATCH bleadperl] [ID 20000803.001] further regexp counting problems + + Subject: [PATCH perl-current] Comings and goings in op/sprintf.t + + Subject: [PATCH] bad cppsymbols on os2 + Configure question + + Subject: [ID 20000802.002] [PATCH] memory pseudo-leak in sv_dump + + Subject: [ID 20000802.004] Tests op/grent.t and op/pwent.t fail unnecessarily + mention the idea of @( and @) + + This is 6512. Really. + + Subject: [ID 19990721.004] Documentation bug in perlfunc + + Subject: Minor tweak to perlvar.pod + + In the warnings call filehandles consistently so; + add "unopened" warning for stat(). + + After the #6519 a warning about stat() is just that, + not about a filetest, which now have their own warning. + + Subject: [ID 20000804.002] configure.gnu and arguments with whitespace characters + + Subject: Re: Array vs. List context + + Subject: New perlcc, take 2 + + Weed buglets pointed out by + Subject: Re: [ID 20000803.005] miniperl aborts during Perl make + + gcc versions might have (parentheses) in them. + + Subject: [ID 20000724.004] Perl interpreter segfault when using built-in flock + + Essential prototype changes were missing from #6527. + Also make report_evil_fh() more bomb-proof. + + Zap lib/Sys directory when cleaning up. + + Change the Policy policy: now -Dprefix= with an existing + Policy.sh and prefix == siteprefix == vendorprefix, then all + of them follow along the new prefix. + Subject: Re: [ID 20000508.002] -Dprefix completely broken [PATCH] + + Continue fixing the io warnings. This also + sort of fixes bug ID 20000802.003: the core dump + is no more. Whether the current behaviour is correct + (giving a warning: "Not a format reference"), is another matter. + + Have symbols for the IoTYPEs. + + Subject: [PATCH] perlfunc.pod use documentation (5.6.0) + + Document a bit that UDP is not what you might think. + Subject: Re: IO::Socket::INET bug sending large UDP packets/fragmentation + tr memory corruption fix from Simon Cozens. + + Plug the security hole described in the Aug 05 2000 bugtraq message + "sperl 5.00503 (and newer ;) exploit" by Michal Zalewski. + The security hole exists only in suidperls, which isn't + installed or even built by default. + Branch: maint-5.6/perl + !> (integrate 71 files) +____________________________________________________________________________ +[ 7882] By: gsar on 2000/11/27 10:25:36 + Log: integrate changes#6439..6444,6446..6453,6455..6457,6460..6465,6467..6468 + from mainline + + Make the unimplemented POSIX regex features [[.cc.]] and [[=c=]] + to be fatal errors (instead of by default ignoring them, and + ignoring with a bug: even though -w gave an error, the opening [ + was left in) Reported in: + + Subject: [PATCH: perl@6409] bug fix for munchconfig (turned up by CXX) + + Subject: [PATCH] split /^/ + + MacOS nits from Matthias Neeracher. + + More split() doc and test patches from Mike Guy. + + Allow "sub AUTOLOAD;" to stop AUTOLOAD inheritance, + from Graham Barr in the module list. + + docfix from Peter Scott <Peter@PSDT.com>. + + File::Temp patches for VMS and OS/2 from Tim Jenness. + + open() wariness in perlbug. + + Subject: [PATCH] minor doc change - perlguts + + Subject: Minor doc patch: handy.h + + Be wary of close()s, too. + + Further File::Temp patches from Yitzchak Scott-Thoennes + and Craig A. Berry. + + Subject: [PATCH] fixes bug 20000508.004 + + Subject: [ID 19990709.002] [DOCUMENTATION PATCH] perldiag + + Allow "no AutoLoader;", based on change #6444, + suggested by Graham Barr. + + Use setproctitle() if available to modify $0. + + Warn if the version of the operating system used to compile gcc + differs from the current version of the operating system. + Also display the gcc compilation os and version in myconfig. + Inspiration from + + Tiny fixes for #6460. + + The problem described in this + Subject: [ID 20000322.018] named chars aren't magical enough + has been fixed in perl 5.6.0 but just in case added a test + to keep it away. (The report from Joseph Hall.) + + Tune the comments and hopefully stop a memory leak. + + Subject: UTF8 concat + (with a memory leak fixed, plus a few casts added) + This also seems to help for + Subject: [ID 20000716.015] join UTF8 weirdness + + Do not upgrade SVs into utf8 just because they participate + in eq or cmp. Reported and fix suggested in + Subject: [ID 20000720.009] sv_eq UTF8 bug + + Fix the HALF_UPGRADE() macro introduced in #6263. + + Find green threads before native threads. + Subject: Re: Patch to jpl/JNI/Makefile.PL + Branch: maint-5.6/perl + !> (integrate 30 files) +____________________________________________________________________________ +[ 7846] By: gsar on 2000/11/24 00:55:57 + Log: integrate changes#6415..6418,6420..6438 from mainline + + Fix the bitvector ops for utf8 (tricky since past 7 bits + the utf8 'characters' can be more than one octet). + + MPE/ix updates for perl 5.6.0 from Mark Bixby. + + Subject: SDBM_File documentation + + Detypo. + + Decutandpasto. + + Send all installperl messages to STDERR and be -w clean. + + Out-of-date note removed. + + Protect against "wild next"s, that is, callbacks doing "next" + instead of "return". + + Use STDOUT consistently. + + The output might have been produced in the wrong order. + + A missing 'break' after the [[:space:]] switch case. + + Add tests for + [ID 19991110.003] another matching finding by pcre author + which has already been fixed by some patch, as verified in + + Documentation to explain the behaviour of map(). + + Add an optimization for map-maps-a-list-element-to-more-list-elements + case, but add also notes explaining the relationship of this + patch and the earlier notes by Sarathy. + + Subject: [ID 20000716.023] syslog test fails without sockets + + Subject: Re: [PATCH] [ID 20000716.011] strangeness with split($_ =~ m/.../) + Test cases for #6431. + + File::Spec::VMS fixup for tmpdir from Craig Berry. + + Make the "uninit variable" warning to say "concat or string" + or "join or string" when in concat or join . + + Get UTF16 BOMs working. Patch from + Subject: Re: [ID 20000719.001] Problem with bleadperl of 7/18/00 + + Subject: [PATCH] Make large file tests deal with SIGXFSZ + + Subject: [ID 20000724.003] Documentation changes for perllocale.pod + + Subject: [PATCH] av.c apidoc + Branch: maint-5.6/perl + !> (integrate 43 files) +____________________________________________________________________________ +[ 7845] By: gsar on 2000/11/24 00:20:45 + Log: integrate changes#6406..6414 from mainline + + Merge perlhacktut into perlhack, update perlguts. + + Fix AutoSplit to use File::Spec the right way in VMS, + from Peter Prymmer. + + The bug report + [ID 19991110.002] minimal matching discrepancy found by pcre author + seems to have been fixed (though differently from what was suggested + in the report) in 5.6.0. Add tests to keep the bug from reappearing. + + thinko fix in vms/descrip_mms.template, the win32.pod in lib, + not in pod, from Peter Prymmer + + Subject: [docpatch] Re: [ID 19991002.011] perldoc -f shift + From: Hugo <hv@crypt.compulink.co.uk> + Date: Fri, 14 Jul 2000 23:05:20 +0100 + Message-Id: <200007142205.XAA17882@crypt.compulink.co.uk> + + Didn't anymore apply, but that point still could use another fix. + + lib/b test fixes from Peter Prymmer. + + More docs for sv functions. + + perlvms.pod whitespace cleanup to keep pod utils happy. + + another VMS build tweak from Peter Prymmer + Branch: maint-5.6/perl + !> embed.pl lib/AutoSplit.pm pod/perlapi.pod pod/perlfunc.pod + !> pod/perlguts.pod pod/perlhack.pod sv.c t/lib/b.t t/op/re_tests + !> vms/descrip_mms.template vms/perlvms.pod +____________________________________________________________________________ +[ 7799] By: gsar on 2000/11/22 01:02:56 + Log: some lib_pm.PL changes snuck in via change#7772 + Branch: maint-5.6/perl + ! Makefile.SH +____________________________________________________________________________ +[ 7781] By: gsar on 2000/11/20 19:02:55 + Log: type mismatch due to faulty integration + Branch: maint-5.6/perl + ! toke.c win32/Makefile +____________________________________________________________________________ +[ 7780] By: gsar on 2000/11/20 17:31:55 + Log: integrate changes#6392,6394..6399,6401..6404 + + The {multiplier} of a fixed substring was overlooked which + caused a wrong initial search offset for that substring. + + Subject: [PATCH 5.6.0] Re: [ID 20000613.001] Regex works in v5.005_03 but fails in v5.06 + From: Hugo <hv@crypt.compulink.co.uk> + Message-Id: <200007131827.TAA14487@crypt.compulink.co.uk> + Date: Thu, 13 Jul 2000 19:27:13 +0100 + + Fix the BOM bug: not a byteorder bug, a signedness bug. + + Replace change #6337 with a better one. + + Subject: Re: [PATCH] [ID 20000701.002] Regular Expressions Not Unsetting $1 Vars When Backtracking + From: Hugo <hv@crypt.compulink.co.uk> + Date: Fri, 14 Jul 2000 04:16:20 +0100 + Message-Id: <200007140316.EAA15857@crypt.compulink.co.uk> + + MakeMaker should not remove editor backups (*~) on `make clean` + by default (completes change#6383) + + move new variables to the end of the interpreter structure (for + bincompat in code that doesn't #include XSUB.h) + + rename totally bletcherous SvLOCK() thingy (doesn't do what the + name suggests anyway) + + various cleanups (typos, misformatted code, and small bugs) + + typecasts needed for change#6394 + + typos in change#6399, regen headers + + inconsistent types needs casts + + PERL_OBJECT build tweaks + Branch: maint-5.6/perl + !> MANIFEST doop.c embed.h embed.pl embedvar.h + !> ext/IPC/SysV/Makefile.PL global.sym intrpvar.h + !> lib/ExtUtils/MM_Unix.pm mg.c op.c perlapi.h pod/perlapi.pod + !> pp.c proto.h regcomp.c regexec.c sv.h t/op/re_tests thread.h + !> toke.c util.c +____________________________________________________________________________ +[ 7779] By: gsar on 2000/11/20 17:06:29 + Log: integrate changes#6376..6378,6380,6383,6385..6388,6391 + + Cosmetics and perldelta. + + Fix nits noticed by Boston.pm. + + Do the cc sanity check both before the hints and + after the cc selction. + + get sprintf.t to adjust properly for 3-digit exponents + + don't clobber *.orig files on *clean targets + + fix bugs in processing %v-*d and similar format specs (from + Avi Finkel <avi@finkel.org>) + + sprintf test tweaks (from Dominic Dunlop) + + new selfloader.t in change#6183 doesn't close DATA handles, + and thus fails to clean up tmp files on dosish platforms + + typos (spotted by Peter Prymmer) + + typo fix from Craig Berry + Branch: maint-5.6/perl + !> Configure Makefile.SH config_h.SH ext/IPC/SysV/Makefile.PL + !> pod/perldelta.pod pod/perlre.pod sv.c t/lib/english.t + !> t/lib/selfloader.t t/op/sprintf.t vms/subconfigure.com + !> x2p/Makefile.SH +____________________________________________________________________________ +[ 7778] By: gsar on 2000/11/20 16:46:51 + Log: integrate changes#6340..6342,6348,6354,6356,6357,6371,6372,6375 + + Subject: Re: format bug report [Patch] + From: "H.Merijn Brand" <h.m.brand@hccnet.nl> + Date: Wed, 05 Jul 2000 13:12:52 +0200 + Message-Id: <20000705130745.67BF.H.M.BRAND@hccnet.nl> + + Subject: Re: format bug report [Patch] + From: "H.Merijn Brand" <h.m.brand@hccnet.nl> + Date: Wed, 05 Jul 2000 14:10:01 +0200 + Message-Id: <20000705140837.73C2.H.M.BRAND@hccnet.nl> + + Subject: Re: [ID 20000704.002] [PATCH] memory leak with debug / anon subs + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Message-Id: <E13AbRE-00009T-00@libra.cus.cam.ac.uk> + Date: Fri, 07 Jul 2000 17:57:16 +0100 + + Subject: [ID 20000710.002] fatal error or memory loss when deleting symbols in evaled code with syntax errors + To: perl5-porters@perl.org + From: Karsten Sperling <spiff@phreax.net> + Date: Mon, 10 Jul 2000 15:12:52 +0200 + Message-Id: <200007101315.e6ADFrg21041@chthon.perl.com> + + README.posix-bc podified from Thomas Dorner. + + Subject: [PATCH perl-current] Make op/sprintf.t more comprehensive, take2 + From: Dominic Dunlop <domo@computer.org> + Date: Tue, 11 Jul 2000 12:27:33 +0200 + Message-Id: <p04320405b590a14d4650@[192.168.1.4]> + + Typo in #6341. + + Fix for + Subject: [ID 20000711.005] spurious uninit warning with msgrcv() + From: Roderick Schertler <roderick@argon.org> + Date: Tue, 11 Jul 2000 13:55:05 -0400 + Message-Id: <200007111755.NAA05077@jones.argon.org> + + Minor cleanups on the booklist. + + Reintroduce perlbook (updated for Mk III), introduce perlposix-bc, + regen perltoc. + + windows build tweaks (op/sprintf.t still fails tests 120-121, 149) + Branch: maint-5.6/perl + +> pod/perlbook.pod + !> MANIFEST README.posix-bc doio.c lib/Symbol.pm pod/Makefile.SH + !> pod/buildtoc.PL pod/perl.pod pod/perlfaq2.pod pod/perltoc.pod + !> pp_hot.c t/op/sprintf.t t/op/write.t toke.c win32/win32sck.c +____________________________________________________________________________ +[ 7772] By: gsar on 2000/11/20 13:06:23 + Log: integrate changes#6315..6319,6321..6331,6333..6338 + + Integrate with Sarathy, preliminary fix for unicos + alignment problems in [ID 20000612.002] Perl problem on Cray system. + + some debugger output does not go to the socket when RemotePort is set + + winsock cleanup never done on Windows (leads to handle leaks) + + fix UNC path handling on Windows under ithreads, and chdir() + return value when given a non-existent directory + + Autogenerate pod/Makefile and pod/buildtoc. + buildtoc also checks whether the existin pods are + mentioned in MANIFEST and perl.pod, and vice versa. + (None of the thusly found discrepancies fixed yet.) + roffitall also needs to be autogenerated similarly but it + seems so badly out of date that I didn't touch it yet. + + Config is being used. + + Add =head1 NAMEs so that buildtoc is happy. + (The CGI::Util nit reported to Lincoln.) + + Fix complaints of buildtoc. + + Fix the alignment problem in Crays ([ID 20000612.002]). + + Remove perlbook, update perlfaq book listing, + rearrange perl.pod, regenerate perltoc. + + Fix a nit spotted by 64bit IRIX compilation: a (64-bit) pointer + was cast to an unsigned (32-bit) integer with wild abandon. + + winsock options weren't being set in all threads under ithreads + (caused send()s from second and subsequent threads to fail) + + accept() leaks memory on windows due to incorrect ordering of + closesocket() and fclose() calls + + Reorder perl.pod once more. + + More POSIX.pod tweaks. + + Sprinkle ldlibpath. + + Precedence goof, fix based on + Subject: [PATCH 5.6.0] op/taint.t continues on failed shmget() + From: Hugo <hv@crypt.compulink.co.uk> + Date: Tue, 11 Jul 2000 12:52:38 +0100 + Message-Id: <200007111152.MAA05488@crypt.compulink.co.uk> + + Subject: PATCH perlguts.pod: Document D and d magic types + From: mjd@plover.com + Date: 5 Jul 2000 18:01:51 -0000 + Message-ID: <20000705180151.29413.qmail@plover.com> + + Subject: [ID 20000705.002] problem with perl 5.6.0 on NetBSD/sparc + From: Hubert Feyrer <feyrer@rfhs8012.fh-regensburg.de> + Date: Wed, 5 Jul 2000 14:56:43 +0200 (MET DST) + Message-Id: <Pine.GSO.4.10.10007051452330.29215-100000@rfhpc8320.fh-regensburg.de> + + Subject: [PATCH cfgperl] $& segfaults if you trick it + From: simon@brecon.co.uk (Simon Cozens) + Date: 7 Jul 2000 11:26:09 GMT + Message-ID: <slrn8mbfif.ead.simon@justanother.perlhacker.org> + + Subject: [PATCH] [ID 20000701.002] Regular Expressions Not Unsetting $1 Vars When Backtracking + From: Hugo <hv@crypt.compulink.co.uk> + Date: Tue, 11 Jul 2000 12:44:50 +0100 + Message-Id: <200007111144.MAA04446@crypt.compulink.co.uk> + + Subject: [PATCH] Re: "%#p" format specifier: document and test or not? + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Date: Tue, 11 Jul 2000 13:50:51 +0100 + Message-Id: <E13BzUx-00033c-00@libra.cus.cam.ac.uk> + Branch: maint-5.6/perl + +> ext/DynaLoader/hints/netbsd.pl lib/Win32.pod pod/Makefile.SH + +> pod/buildtoc.PL + - pod/Makefile pod/Win32.pod pod/buildtoc pod/perlbook.pod + !> (integrate 26 files) +____________________________________________________________________________ +[ 7771] By: gsar on 2000/11/20 12:31:42 + Log: integrate changes#6283..6285,6291,6294..6300,6302..6304,6306..6307, + 6310,6311,6314 + + Subject: [PATCH bleedperl] File::Spec 0.82 beta + From: Barrie Slaymaker <barries@jester.slaysys.com> + Date: Wed, 28 Jun 2000 11:35:29 -0400 + Message-Id: <200006281535.LAA21095@jester.slaysys.com> + + tweak perlembed for multiplicity/usethreads sanity; correct notes + about Windows + + localize %INC in a Safe compartment so that use/require work + (many other magic globals probably need similar treatment) + + dounwind() may cause POPSUB() to diddle the wrong PL_curpad + when @_ is modified, causing coredumps + + slurp mode fix in change#4736 still not quite right + + Point to perlipc for more SysV IPC examples. + + Elaborate POSIX.pod. Still needs work. + + fix ~320 byte memory leak (psig_{ptr,name} tables were never freed) + + fix large memory leak that has been around for ever, masked by + -DPURIFY (most of the arenas were never freed!) + + fix memory leak on Windows (PL_sys_intern contents were never + freed) + + PERL_OBJECT build tweak + + adjust change#6299 + + remove rel2abs prototypes (from Barrie Slaymaker) + + missing perldiag entry for unpack("w",...) diagnostic (from + Andreas Koenig) + + better diagnostic on Frob->stuff() when Frob:: doesn't exist + (from Richard Soderberg <rs@oregonnet.com>) + + Win32 patches for cfgperl from Sarathy. + + b.t fails under OS/2 (from Yitzchak Scott-Thoennes) + + More POSIX.pod embellishment. + + tyop in change#6306 + Branch: maint-5.6/perl + !> (integrate 44 files) +____________________________________________________________________________ +[ 7770] By: gsar on 2000/11/20 11:51:00 + Log: integrate changes#6268..6282 from cfgperl branch + + Subject: [PATCH perl-current] Make op/sprintf.t more comprehensive + From: Dominic Dunlop <domo@computer.org> + Date: Thu, 29 Jun 2000 12:32:39 +0200 + Message-Id: <p04320403b580cc1338db@[192.168.1.4]> + + Regen headers for #6261 (and update embed.pl for this) and #6267, + silence few compiler warnings. + + Subject: PATCH (Re: [ID 20000612.004] Should regression tests fail if user doesn't build XS extensions?) + From: Nicholas Clark <nick@talking.bollo.cx> + Date: Fri, 23 Jun 2000 16:21:15 +0100 + Message-ID: <20000623162115.A19894@Bagpuss.unfortu.net> + + Subject: PATCH pod/perltie.pod + From: Ian Phillipps <Ian.Phillipps@iname.com> + Date: Fri, 16 Jun 2000 00:17:19 +0100 + Message-ID: <20000616001719.A17108@homer.diplex.co.uk> + (only the first hunk, the second hunk had already been done + by some other patch) + + Subject: [ID 20000614.005] [patch] Tweak to Net::Ping docs + From: Tom Phoenix <rootbeer@redcat.com> + Received: (qmail 6398 invoked by uid 508); 15 Jun 2000 00:30:54 -0000 + Date: Wed, 14 Jun 2000 17:30:37 -0700 (PDT) + + Subject: [PATCH] xsub attributes + From: Doug MacEachern <dougm@covalent.net> + Date: Wed, 14 Jun 2000 15:09:22 -0700 (PDT) + Message-ID: <Pine.LNX.4.10.10006141456050.340-100000@mojo.covalent.net> + + Subject: [ID 20000614.003] 5.6.0 File/Glob.pm incompatibility + From: Andy Dougherty <doughera@lafayette.edu> + Date: Wed, 14 Jun 2000 13:33:32 -0400 (EDT) + Message-Id: <Pine.SOL.4.10.10006141332220.3643-100000@maxwell.phys.lafayette.edu> + + Subject: [PATCH] 5.6.0 lib/Pod/{Html,Man,Text}.pm + From: "Daniel S. Lewart" <d-lewart@uiuc.edu> + Date: Tue, 13 Jun 2000 02:43:48 -0500 + Message-ID: <20000613024347.A28388@staff2.cso.uiuc.edu> + + Subject: [PATCH] Re: eval documentation: context + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Date: Mon, 12 Jun 2000 15:07:29 +0100 + Message-Id: <E131UsD-0002ke-00@ursa.cus.cam.ac.uk> + + Subject: [PATCH] Re: [ID 20000612.001] map {chop; $_} (Literals problem) + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Date: Mon, 12 Jun 2000 14:55:59 +0100 + Message-Id: <E131Uh5-0002cj-00@ursa.cus.cam.ac.uk> + + Subject: [ID 20000609.002] Text::Wrap::wrap does not handle multiline strings properly + From: "Milton L. Hankins" <mlh@swl.msd.ray.com> + Date: Fri, 09 Jun 2000 12:39:27 -0400 + Message-Id: <39411DBF.A04BB1A@swl.msd.ray.com> + (plus update the version "number" of Text::Wrap) + + Subject: [ID 20000602.002] [PATCH] perlsub.pod: ambiguous usage of "closure" + From: Tim Ayers <tayers@bridge.com> + Date: Thu, 08 Jun 2000 08:11:06 +0200 + Message-id: <393F38FA.9B5F4C7D@m.dasa.de> + [resent by Richard Foley, Message-Id probably wrong] + + Subject: Re: backwards compatibility in h2xs and makemaker [PATCH] + From: rspier@pobox.com (Robert Spier) + Date: Wed, 7 Jun 2000 12:47:37 -0400 (EDT) + Message-ID: <14654.31913.845602.610277@rls.cx> + + Subject: [PATCH 5.6.0] utils/h2xs.PL + From: "Daniel S. Lewart" <d-lewart@uiuc.edu> + Date: Wed, 7 Jun 2000 04:02:04 -0500 + Message-ID: <20000607040201.A22568@staff1.cso.uiuc.edu> + + Subject: [PATCH 5.6.0]ITHREADs for VMS + From: Dan Sugalski <dan@sidhe.org> + Date: Tue, 06 Jun 2000 11:59:50 -0400 + Message-Id: <4.3.2.7.0.20000606115752.01c82220@24.8.96.48> + Branch: maint-5.6/perl + !> (integrate 31 files) +____________________________________________________________________________ +[ 7769] By: gsar on 2000/11/20 11:29:06 + Log: integrate changes#6261..6266 from cfgperl + + Subject: Re: [PATCH cfgperl] BOMs away! + From: simon@brecon.co.uk (Simon Cozens) + Date: 17 Jun 2000 11:49:57 GMT + Message-ID: <slrn8kmpf5.8pl.simon@justanother.perlhacker.org> + + Subject: 5.6.0 Patch for EPOC + From: Olaf Flebbe <o.flebbe@gmx.de> + Date: Tue, 13 Jun 2000 22:59:29 +0200 (MEST) + Message-ID: <23449.960929969@www11.gmx.net> + + tr fixes from Simon Cozens + + Subject: [ID 20000628.004] Re: Problem compiling perl? [BSDI-Support-Request #71232] + From: Marty Lucich <marty@netcom.com> + Date: Wed, 28 Jun 2000 14:16:05 -0700 (PDT) + Message-Id: <200006282116.OAA11148@netcom.com> + ccdlflags update (the BSD/OS 4.1 part had already been taken + care of by #6141). + + Subject: Re: [ID 20000628.006] POSIX::STRERR_FILENO typo + From: sthoenna@efn.org (Yitzchak Scott-Thoennes) + Date: Wed, 28 Jun 2000 17:50:12 -0700 + Message-ID: <E1pW5gzkg2kV092yn@efn.org> + + Subject: [PATCH 5.6.0] cygwin port + Message-ID: <779F20BCCE5AD31186A50008C75D997917173C@silldn_mail1.sanwaint.com> + From: "Fifer, Eric" <EFifer@sanwaint.com> + Date: Thu, 29 Jun 2000 12:58:29 +0100 + Branch: maint-5.6/perl + !> README.epoc cygwin/Makefile.SHs doop.c epoc/config.sh + !> epoc/createpkg.pl epoc/epocish.c epoc/epocish.h + !> ext/POSIX/POSIX.pm ext/POSIX/POSIX.pod ext/POSIX/POSIX.xs + !> hints/bsdos.sh pod/perldiag.pod t/comp/require.t toke.c +____________________________________________________________________________ +[ 7768] By: gsar on 2000/11/20 11:13:44 + Log: integrate changes#6252..6256,6259..6260 + + Paranoia tweak on #6249. + Subject: Re: [PATCH 5.6.0 IPC/Open3.pm] Allow the use of numeric fd's + From: Ronald J Kimball <rjk@linguist.dartmouth.edu> + Date: Sun, 25 Jun 2000 23:43:12 -0400 + Message-ID: <20000625234312.B74147@linguist.dartmouth.edu> + + Subject: tr///, help wanted. + From: simon@brecon.co.uk (Simon Cozens) + Date: 28 Jun 2000 11:29:04 GMT + Message-ID: <slrn8ljoc0.fbd.simon@justanother.perlhacker.org> + + small thinko tweaks + + tweaks from Simon Conzes to further fix tr/// under utf8 + + perlnewmod was missing from MANIFEST. + + Subject: Re: [PATCH] pack('U',$foo) doesn't UTF8 + From: simon@brecon.co.uk (Simon Cozens) + Date: 17 Jun 2000 11:56:44 GMT + Message-ID: <slrn8kmprs.8pl.simon@justanother.perlhacker.org> + pack U0, pack C0 + Branch: maint-5.6/perl + !> MANIFEST doop.c embed.h embed.pl embedvar.h global.sym + !> lib/Exporter.pm lib/IPC/Open3.pm objXSUB.h op.c + !> pod/perlfunc.pod pp.c pp_proto.h proto.h sv.c t/op/my_stash.t + !> t/op/pack.t t/op/tr.t t/pragma/constant.t t/pragma/warn/op +____________________________________________________________________________ +[ 7767] By: gsar on 2000/11/20 10:51:38 + Log: integrate change#6250 from cfgperl + + Subject: Re: [PATCH] support 'my __PACKAGE__ $obj = ...' + From: Doug MacEachern <dougm@covalent.net> + Date: Tue, 27 Jun 2000 14:17:28 -0700 (PDT) + Message-ID: <Pine.LNX.4.10.10006271412340.7587-100000@mojo.covalent.net> + Branch: maint-5.6/perl + +> t/op/my_stash.t + !> MANIFEST embed.pl global.sym proto.h toke.c +____________________________________________________________________________ +[ 7766] By: gsar on 2000/11/20 10:48:34 + Log: integrate changes#6240,6242..6246,6248,6249 from cfgperl + + Subject: [ID 20000626.007] h2xs man page contains trailing garbage + From: Nicholas Clark <nick@Bagpuss.unfortu.net> + Date: Mon, 26 Jun 2000 18:40:14 +0100 + Message-Id: <200006261740.SAA02740@Bagpuss.unfortu.net> + + Subject: [PATCH] bytes<->utf8 fixes + From: simon@brecon.co.uk (Simon Cozens) + Date: 26 Jun 2000 04:55:45 GMT + Message-ID: <slrn8ldoih.fbd.simon@justanother.perlhacker.org> + + Subject: [PATCH] is_utf8_string + From: simon@brecon.co.uk (Simon Cozens) + Date: 26 Jun 2000 02:25:59 GMT + Message-ID: <slrn8ldfpn.h5k.simon@justanother.perlhacker.org> + + Subject: [PATCH] avoid mg_ptr in '*' magic + From: Doug MacEachern <dougm@covalent.net> + Date: Sun, 25 Jun 2000 11:16:08 -0700 (PDT) + Message-ID: <Pine.LNX.4.10.10006251045190.461-100000@mojo.covalent.net> + + Subject: [ID 20000624.001] PERL_DL_DEBUG=1 DynaLoader message appears to be wrong + From: Nicholas Clark <nick@Bagpuss.unfortu.net> + Date: Sat, 24 Jun 2000 13:06:20 +0100 + Message-Id: <200006241206.NAA03771@Bagpuss.unfortu.net> + + Allow for standalone testing. + + Subject: DOC PATCH 5.6.0: perlfunc/sprintf does not contain an example + From: Mark-Jason Dominus <mjd@plover.com> + Date: Tue, 27 Jun 2000 22:36:42 -0400 + Message-ID: <20000628023642.12166.qmail@plover.com> + + Subject: Re: [PATCH 5.6.0 IPC/Open3.pm] Allow the use of numeric fd's + From: Frank Tobin <ftobin@uiuc.edu> + Date: Sun, 25 Jun 2000 19:00:58 -0500 (CDT) + Message-ID: <Pine.BSF.4.21.0006251855340.20487-100000@srh0902.urh.uiuc.edu> + Branch: maint-5.6/perl + !> embed.h embed.pl embedvar.h ext/DynaLoader/DynaLoader_pm.PL + !> global.sym gv.c lib/IPC/Open3.pm objXSUB.h perlapi.c perlapi.h + !> pod/perlapi.pod pod/perlfunc.pod pod/perlintern.pod pp_proto.h + !> proto.h sv.c t/lib/filefunc.t t/lib/filespec.t t/lib/peek.t + !> utf8.c utils/h2xs.PL +____________________________________________________________________________ +[ 7765] By: gsar on 2000/11/20 10:29:13 + Log: integrate change#6239 from cfgperl + + Configure maintenance. Sever some dependency cycles, + separate gccversion from the cc unit, + address [ID 20000623.006] Configure script patch for using gcc on AIX + (but solve it a little bit differently), + unduplex some accidentally duplicated units, + suggest using gcc if no cc available + (p5p thread: "Solaris configure: counterproposal", 1999-09) + Branch: maint-5.6/perl + !> Configure Todo-5.6 config_h.SH +____________________________________________________________________________ +[ 7764] By: gsar on 2000/11/20 10:25:55 + Log: integrate changes#6233..6238 from cfgperl + + Subject: PATCH 5.6.0: Document OPf_SPECIAL flag in regcomp op nodes + From: Mark-Jason Dominus <mjd@plover.com> + Date: Fri, 16 Jun 2000 20:53:04 -0400 + Message-ID: <20000617005304.8008.qmail@plover.com> + + Prefer C:/temp in Win32 as File::Spec->tmpdir to /tmp + because when run as services (Win32ese for daemons) + no environment variables are set and tmpdir ends up as /tmp, + which is ambiguous. + Subject:[ID 20000616.002] File::Spec->tmpdir broken when running as service + From: matt@sergeant.org + Date: 16 Jun 2000 16:30:43 -0000 + Message-Id: <20000616163043.26398.qmail@mail.sergeant.org> + + The thread begun by + Subject: [ID 20000616.001] Typo on line 390 of .../hints/solaris_2.sh + From: Kevin.Ruscoe@ubsw.com + Date: Fri, 16 Jun 2000 16:38:51 +0100 + Message-Id: <H000019b03c300d6@MHS> + + Tweak embed.pl, regen headers. + + Subject: [PATCH 5.6.0] XS module loading fixup for VMS + From: Dan Sugalski <dan@sidhe.org> + Date: Fri, 23 Jun 2000 17:00:00 -0400 + Message-Id: <4.3.2.7.0.20000623165934.00c93d10@24.8.96.48> + Branch: maint-5.6/perl + !> (integrate 27 files) +____________________________________________________________________________ +[ 7763] By: gsar on 2000/11/20 10:08:08 + Log: s/perl56delta/perldelta/g + Branch: maint-5.6/perl + ! pod/Makefile +____________________________________________________________________________ +[ 7762] By: gsar on 2000/11/20 10:04:00 + Log: integrate changes#6225,6229,6231,6232 from cfgperl + + Add source code filenames to apidoc. + From: simon@brecon.co.uk (Simon Cozens) + Subject: [PATCH embed.pl] Source X-ref + Date: 22 Jun 2000 02:18:49 GMT + Message-ID: <slrn8l2ts8.h5k.simon@justanother.perlhacker.org> + + Subject: README.hpux version 0.6.1 + Date: Tue, 20 Jun 2000 15:25:51 -0700 (PDT) + From: Jeff Okamoto <okamoto@xfiles.intercon.hp.com> + Message-Id: <200006202225.PAA26205@xfiles.intercon.hp.com> + + Subject: [PATCH 5.6.0] cygwin port + From: "Fifer, Eric" <EFifer@sanwaint.com> + Date: Tue, 20 Jun 2000 14:30:58 +0100 + Message-ID: <779F20BCCE5AD31186A50008C75D9979171734@silldn_mail1.sanwaint.com> + + Subject: PATCH: pod/perlutil.pod - utilities packaged with the Perl distribution + From: simon@brecon.co.uk (Simon Cozens) + Date: 19 Jun 2000 15:18:27 GMT + Message-ID: <slrn8ksee3.cp9.simon@justanother.perlhacker.org> + + plus update pod/Makefile and regenerate perltoc + Branch: maint-5.6/perl + +> pod/perlutil.pod + !> MANIFEST README.cygwin README.hpux Todo-5.6 embed.pl + !> lib/File/Find.pm pod/Makefile pod/perltoc.pod pod/roffitall +____________________________________________________________________________ +[ 7344] By: gsar on 2000/10/16 09:30:21 + Log: integrate change#6220 from cfgperl + + Win32 patches from Benjamin Stuhl. + Branch: maint-5.6/perl + !> makedef.pl win32/win32.h +____________________________________________________________________________ +[ 7343] By: gsar on 2000/10/16 08:32:19 + Log: integrate changes#6221,6222 from cfgperl + + Remove tr///CU (the feature is to be obsoleted by better interfaces). + From: simon@brecon.co.uk (Simon Cozens) + Subject: [PATCH] Eliminate tr///[CU][CU] + Date: 23 Jun 2000 11:05:40 GMT + Message-ID: <slrn8l6h44.h5k.simon@justanother.perlhacker.org> + + doc typo fix + Subject: [PATCH] documentation typo in lib/Pod/Usage.pm + From: Ian Phillipps <Ian.Phillipps@iname.com> + Date: Fri, 23 Jun 2000 10:40:58 +0100 + Message-ID: <20000623104058.A22791@homer.diplex.co.uk> + Branch: maint-5.6/perl + !> doop.c embed.pl lib/Pod/Usage.pm pod/perlop.pod toke.c utf8.c +____________________________________________________________________________ +[ 7342] By: gsar on 2000/10/16 08:28:08 + Log: integrate change#6217 from cfgperl (in part) + + Rename the fdpid locking and integrate with Sarathy. + Branch: maint-5.6/perl + !> Configure config_h.SH doio.c embed.h embed.pl embedvar.h + !> global.sym gv.c intrpvar.h objXSUB.h perl.c perlapi.h pp.c + !> pp_ctl.c proto.h sv.h util.c util.h vmesa/vmesa.c + !> win32/win32.c +____________________________________________________________________________ +[ 7341] By: gsar on 2000/10/16 08:23:39 + Log: integrate changes#6214..6216 from mainline + + @_ can't have junk in it even in the non-USE_ITHREADS case because + caller() wants to populate @DB::args with it (causes a coredump + in Carp::confess()) + + tweak comment about @DB::args + + be more optimal about clearing @_ + Branch: maint-5.6/perl + !> av.h cop.h pp_ctl.c t/op/runlevel.t +____________________________________________________________________________ +[ 7340] By: gsar on 2000/10/16 08:20:37 + Log: integrate changes#6207..6210 from cfgperl + + Subject: [PATCH 5.6.0] Threadsafe patches + From: Dan Sugalski <dan@sidhe.org> + To: perl5-porters@perl.org + Date: Mon, 08 May 2000 18:08:13 -0400 + Message-Id: <4.3.1.0.20000508180729.02182de0@24.8.96.48> + + Regen headers for #6207. + + Lock PL_fdpid against race conditions, based on: + Subject: [PATCH 5.6.0]subprocess fixup for threads + From: Dan Sugalski <dan@sidhe.org> + To: perl5-porters@perl.org + Date: Tue, 11 Apr 2000 17:02:32 -0400 + Message-Id: <4.3.0.20000411170218.01d2f580@24.8.96.48> + + Mopup for #6207 and #6209. + Branch: maint-5.6/perl + !> doio.c embed.h embed.pl global.sym gv.c intrpvar.h objXSUB.h + !> perl.c pp.c pp_ctl.c proto.h sv.h util.c vmesa/vmesa.c + !> win32/win32.c +____________________________________________________________________________ +[ 7339] By: gsar on 2000/10/16 08:14:34 + Log: integrate change#6203 from cfgperl + + perldiag should refer to perlos2.pod not README.os2 + Branch: maint-5.6/perl + !> pod/perldiag.pod +____________________________________________________________________________ +[ 7338] By: gsar on 2000/10/16 08:11:42 + Log: integrate change#6201 from mainline + + Perl_eval_pv() leaks 4 bytes every time it is called because it + does a PUSHMARK that's never ever POPMARKed; in general, only + Perl_call_[sp]v() need a PUSHMARK for incoming arguments; + Perl_eval_[sp]v() don't because they don't take any incoming + arguments (this leak has been around since the original version + of perl_eval_pv() in 5.003_97e) + Branch: maint-5.6/perl + !> perl.c +____________________________________________________________________________ +[ 7337] By: gsar on 2000/10/16 08:08:47 + Log: integrate changes#6197..6200 from cfgperl + + Subject: [ID 20000602.005] [PATCH]5.6.0 (DOC) tiny change to perlsyn.pod + From: John Borwick <jhborwic@unity.ncsu.edu> + Date: Fri, 2 Jun 2000 14:35:03 -0400 (EDT) + Message-Id: <Pine.GSO.4.21.0006021420290.11432-100000@eos00du.eos.ncsu.edu> + + Subject: [PATCH 5.6.0]VMS fixups so we can build with MULTIPLICITY + From: Dan Sugalski <dan@sidhe.org> + To: vmsperl@perl.org, perl5-porters@perl.org + Date: Fri, 02 Jun 2000 16:00:41 -0400 + Message-Id: <4.3.2.7.0.20000602155951.01f02b20@24.8.96.48> + Message-Id: <4.3.2.7.0.20000602164011.01ec8c30@24.8.96.48> + + Subject: [PATCH 5.6.0]Make perl's malloc work on VMS + From: Dan Sugalski <dan@sidhe.org> + To: perl5-porters@perl.org, vmsperl@perl.org + Date: Fri, 02 Jun 2000 17:30:51 -0400 + Message-Id: <4.3.2.7.0.20000602173021.01f03570@24.8.96.48> + + Update to cperl-mode.el 4.31 from + ftp://ftp.math.ohio-state.edu/pub/users/ilya/cperl-mode.el + Subject: A couple of notes + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + To: Mailing list Perl5 <perl5-porters@perl.org> + Date: Sat, 3 Jun 2000 23:33:32 -0400 + Message-ID: <20000603233332.A6790@monk.mps.ohio-state.edu> + Branch: maint-5.6/perl + !> emacs/cperl-mode.el embed.h embed.pl embedvar.h + !> ext/POSIX/POSIX.xs global.sym objXSUB.h perlapi.c perlapi.h + !> pod/perlapi.pod pod/perlintern.pod pod/perlsyn.pod proto.h + !> vms/descrip_mms.template vms/gen_shrfls.pl vms/vms.c + !> vms/vmsish.h +____________________________________________________________________________ +[ 7336] By: gsar on 2000/10/16 08:03:46 + Log: integrate changes#6194,6195 from mainline + + fix small eval"" memory leaks under USE_ITHREADS + + fix yet another eval"" leak under USE_ITHREADS + Branch: maint-5.6/perl + !> cop.h embed.h embed.pl objXSUB.h op.c perl.c perlapi.c perly.c + !> perly_c.diff pp_ctl.c proto.h scope.c scope.h sv.c toke.c + !> vms/perly_c.vms +____________________________________________________________________________ +[ 7335] By: gsar on 2000/10/16 08:02:15 + Log: integrate changes#6190,6191 from mainline + + submit missing embed.pl change + + vec() loses numericalness (modified version of patch suggested + by Robin Barker) + Branch: maint-5.6/perl + !> doop.c embed.pl t/op/vec.t +____________________________________________________________________________ +[ 7334] By: gsar on 2000/10/16 08:01:03 + Log: integrate change#6189 from mainline + + counting tr/// corrupts later operation (from M.J.T Guy) + Branch: maint-5.6/perl + !> doop.c t/op/tr.t +____________________________________________________________________________ +[ 7333] By: gsar on 2000/10/16 07:59:07 + Log: integrate changes#6183..6188 from mainline + + SelfLoader can lose $@ in AUTOLOAD() (from Nicholas Clark + <nick@ccl4.org>) + + tweak for change#6127 + + remove incorrect documentation about implicit split to @_ in + list context, which never really worked in perl 5 (from + M.J.T. Guy) + + further qualify references to "alphanumeric" (from Wolfgang Laun + <wolfgang.laun@alcatel.at>) + + replace pod2latex with the one in Pod-LaTeX v0.52 from CPAN + (from Tim Jenness <t.jenness@jach.hawaii.edu>) + + h2xs tweaks + Branch: maint-5.6/perl + +> lib/Pod/LaTeX.pm t/lib/selfloader.t + !> AUTHORS MAINTAIN MANIFEST ext/Devel/Peek/Peek.pm handy.h + !> lib/SelfLoader.pm perl.c pod/perlapi.pod pod/perldata.pod + !> pod/perlfaq6.pod pod/perlfaq9.pod pod/perlfunc.pod + !> pod/perllocale.pod pod/perlre.pod pod/perltrap.pod + !> pod/pod2latex.PL utils/h2xs.PL +____________________________________________________________________________ +[ 7332] By: gsar on 2000/10/16 07:53:52 + Log: integrate change#6179 from mainline + + buggy modulus on UVs introduced by change#3378 (resulted in + 4063328477 % 65535 amounting to 27406, instead of 27407) + Branch: maint-5.6/perl + !> pp.c t/op/arith.t +____________________________________________________________________________ +[ 7331] By: gsar on 2000/10/16 07:52:49 + Log: integrate changes#6176,6177,6178,6182 from cfgperl + + Single-quoted utf8 patch from Simon Cozens. + + Substitution utf8 patch from Simon Cozens. + + Be cleaner. + + Be Cleaner Part Deux. + Branch: maint-5.6/perl + !> Makefile.SH pp_hot.c toke.c +____________________________________________________________________________ +[ 7330] By: gsar on 2000/10/16 07:41:36 + Log: integrate change#6172 from mainline + + fix buggy multiline matching of C<"a\nxb\n" =~ /(?!\A)x/m> + (from Ilya Zakharevich) + Branch: maint-5.6/perl + !> regexec.c t/op/re_tests +____________________________________________________________________________ +[ 7329] By: gsar on 2000/10/16 07:40:25 + Log: integrate change#6171 from mainline + + scalar() doesn't force scalar context when used in void context + (from Simon Cozens) + Branch: maint-5.6/perl + !> op.c t/op/wantarray.t +____________________________________________________________________________ +[ 7328] By: gsar on 2000/10/16 07:39:33 + Log: integrate change#6170 from mainline + + change#6142 needs tweaks to tests to work where there's no + symlink() (from Helmut Jarausch <jarausch@igpm.rwth-aachen.de>) + Branch: maint-5.6/perl + !> t/lib/filefind.t +____________________________________________________________________________ +[ 7327] By: gsar on 2000/10/16 07:35:34 + Log: integrate changes#6166..6168 from cfgperl + + Introduce HAS_GETESPWNAM, HAS_GETPRPWNAM, and I_PROT + in case somebody wants to write an extension for more + shadow database interfaces. + + tweak todo + + Tweak NV_PRESERVES_UV*, vms/subconfigure.com left untouched. + Branch: maint-5.6/perl + !> Configure Porting/Glossary Porting/config.sh Porting/config_H + !> Todo-5.6 config_h.SH epoc/config.sh perl.h pp_sys.c toke.c + !> vms/subconfigure.com vos/config.def vos/config.h vos/config.pl + !> vos/config_h.SH_orig win32/config.bc win32/config.gc + !> win32/config.vc win32/config_H.bc win32/config_H.gc + !> win32/config_H.vc win32/config_h.PL win32/config_sh.PL +____________________________________________________________________________ +[ 7326] By: gsar on 2000/10/16 07:29:05 + Log: integrate changes#6157,6159..6161,6164 from cfgperl + + Regen Configure to jive with #6149. + + Upgrade to File::Temp 0.08 from Tim Jenness via CPAN. + + Changes for the File::Temp 0.08 (change #6159) test suite + to fit better into the Perl distribution test framework. + + Add autogeneration of perlmodlib.pod and the new perlnewmod.pod, + both from Simon Cozens. + + detypo + Branch: maint-5.6/perl + +> pod/perlmodlib.PL pod/perlnewmod.pod + !> AUTHORS Configure MAINTAIN MANIFEST config_h.SH + !> lib/File/Temp.pm pod/Makefile pod/perl.pod pod/perlmodlib.pod + !> pod/perltoc.pod t/lib/ftmp-mktemp.t t/lib/ftmp-posix.t + !> t/lib/ftmp-security.t t/lib/ftmp-tempfile.t +____________________________________________________________________________ +[ 7325] By: gsar on 2000/10/16 07:25:13 + Log: integrate change#6158 from vmsperl + + Add fallback to tmpfile for use in cases where user's relying on + ACLs on SYS$SCRATCH to permit file creation. (based on Charles + Lane's patch) + Branch: maint-5.6/perl + !> vms/vms.c vms/vmsish.h +____________________________________________________________________________ +[ 7324] By: gsar on 2000/10/16 07:20:50 + Log: integrate changes#6153..6155 from mainline + + prettier Test::Harness output on failed tests (from Nicholas Clark + <nick@Bagpuss.uk.boo.com>) + + avoid type mismatch warning + + small bug in change#6144; remove random \xA0 character that snuck + in via change#6145 + Branch: maint-5.6/perl + !> lib/AutoSplit.pm lib/ExtUtils/xsubpp lib/Test/Harness.pm + !> perl.c +____________________________________________________________________________ +[ 7323] By: gsar on 2000/10/16 07:18:47 + Log: integrate changes#6151,6152 from mainline + + fix accidental pessimization in RE optimizer (from Ilya Zakharevich) + + cosmetic fixups of RE debug output (from Ilya Zakharevich) + Branch: maint-5.6/perl + !> regexec.c +____________________________________________________________________________ +[ 7322] By: gsar on 2000/10/16 07:17:25 + Log: integrate changes#6146..6150 from mainline + + doc typo + + add a make entry to Config.pm so "perl -V:make" works on VMS + (from Peter Prymmer) + + close open file before chmod() (from Rocco Caputo <troc@netrus.net>) + + OS/2 tweaks for usethreads build (from Rocco Caputo + <troc@netrus.net>) + + perlrequick.pod updates (from Mark Kvale <kvale@phy.ucsf.edu>) + Branch: maint-5.6/perl + !> Configure hints/os2.sh lib/ExtUtils/MM_Unix.pm lib/warnings.pm + !> makedef.pl os2/Makefile.SHs os2/OS2/REXX/t/rx_dllld.t + !> os2/OS2/REXX/t/rx_objcall.t os2/OS2/REXX/t/rx_tievar.t + !> os2/OS2/REXX/t/rx_tieydb.t os2/os2.c os2/os2ish.h perl.c + !> pod/perlrequick.pod util.c vms/subconfigure.com warnings.h + !> warnings.pl x2p/a2p.h +____________________________________________________________________________ +[ 7321] By: gsar on 2000/10/16 07:14:02 + Log: integrate changes#6143..6145 from mainline + + MacOS support, part 1 (from Matthias Neeracher + <neeri@iis.ee.ethz.ch>) + + MacOS support, part 2: make AutoSplit use File::Spec instead + of assuming Unixisms; *UNTESTED on Unix* (from Matthias Neeracher + <neeri@iis.ee.ethz.ch>) + + make xsubpp skip embedded pod (from Matthias Neeracher + <neeri@iis.ee.ethz.ch>) + Branch: maint-5.6/perl + +> ext/DynaLoader/dl_mac.xs + !> MANIFEST ext/DB_File/Makefile.PL ext/NDBM_File/Makefile.PL + !> ext/POSIX/POSIX.xs lib/AutoSplit.pm lib/ExtUtils/MakeMaker.pm + !> lib/ExtUtils/xsubpp mg.c perl.c perlsfio.h pod/perlfaq4.pod + !> pp_ctl.c proto.h toke.c util.c util.h +____________________________________________________________________________ +[ 7320] By: gsar on 2000/10/16 07:12:13 + Log: integrate changes#6141,6142 from mainline + + BSD/OS (bsdi) hints update by Timur I. Bakeyev and Todd C. Miller, + forwarded by Peter Seebach from the bsdi-users mailing list. + p5p Message-Id: <200005280543.AAA24519@guild.plethora.net> + + File::Find fails to chdir when chasing symlinks (from + Helmut Jarausch <jarausch@igpm.rwth-aachen.de>) + Branch: maint-5.6/perl + !> hints/bsdos.sh lib/File/Find.pm t/lib/filefind.t +____________________________________________________________________________ +[ 7319] By: gsar on 2000/10/16 07:04:30 + Log: integrate change#6139 from mainline + + revise mktables.PL for bugs and newness in Unicode 3.0 + (from James Bence <jbence@amgen.com>) + Branch: maint-5.6/perl + +> (branch 30 files) + !> (integrate 49 files) +____________________________________________________________________________ +[ 7318] By: gsar on 2000/10/16 07:01:01 + Log: integrate changes#6137,6138 from mainline + + fix bogus redeclaration warning for "our" variables in different + scopes + + add note about the handling of negative indices to tied arrays + (from Michael G Schwern <schwern@pobox.com>) + Branch: maint-5.6/perl + !> op.c pod/perltie.pod t/pragma/strict-vars +____________________________________________________________________________ +[ 7317] By: gsar on 2000/10/16 06:58:46 + Log: integrate changes#6127..6136 from mainline + + call_method(...,G_EVAL) can longjmp() out if the method probing + failed (from Gisle Aas) + + new perlxstut example for passing/returning refs to arrays + (from David Lowe <dlowe@pootpoot.com>) + + VMS test harness tweak (from Jesper Naur <jesper.naur@post.tele.dk>) + + fix places that mean C<"word" character> but say C<alphanumeric + character> + + avoid warnings in POSIX.pm (from Barrie Slaymaker) + + warnings::enabled() doesn't fall back to looking at $^W if + caller isn't using lexical warnings (from Paul Marquess) + + elide bogus test in change#6132 + + make Test::Harness use wait.h/WCOREDUMP if available + (from Ben Tilly <ben_tilly@hotmail.com>) + + enable Test::Harness to dynamically determine column width etc. + (from Rob Napier <rnapier@employees.org>) + + random pod typos (from Peter Scott <Peter@PSDT.com>) + Branch: maint-5.6/perl + !> cop.h ext/Devel/Peek/Peek.pm ext/POSIX/POSIX.pm + !> lib/Test/Harness.pm perl.c pod/perldebguts.pod + !> pod/perlfunc.pod pod/perlre.pod pod/perlretut.pod + !> pod/perlxstut.pod pp_ctl.c t/pragma/warn/9enabled vms/test.com +____________________________________________________________________________ +[ 7316] By: gsar on 2000/10/16 06:53:23 + Log: integrate change#6126 from mainline + + change#2879 broke rvalue autovivification of magicals such as + ${$num} (reworked variant of patch suggested by Simon Cozens) + Branch: maint-5.6/perl + !> embed.h embed.pl gv.c pod/perlapi.pod pod/perlintern.pod pp.c + !> pp_hot.c proto.h t/op/gv.t +____________________________________________________________________________ +[ 7315] By: gsar on 2000/10/16 06:51:38 + Log: integrate changes#6123,6125 from mainline + + clarify gotcha with #line directives (from Rocco Caputo + <troc@netrus.net>) + + enable propagating exception objects via Perl_croak() in XS code + (from Gisle Aas) + Branch: maint-5.6/perl + !> pod/perldebug.pod pod/perlsyn.pod util.c +____________________________________________________________________________ +[ 7314] By: gsar on 2000/10/16 06:49:28 + Log: integrate change#6122 from mainline + + downgrade fatal error on C<"foo@nosucharray.com"> to optional + warning (from Mark-Jason Dominus) + Branch: maint-5.6/perl + !> lib/ExtUtils/typemap pod/perldelta.pod pod/perlsub.pod + !> pod/perltrap.pod t/base/lex.t t/pragma/strict-vars + !> t/pragma/strict.t t/pragma/warn/toke t/pragma/warnings.t + !> toke.c +____________________________________________________________________________ +[ 7313] By: gsar on 2000/10/16 06:46:54 + Log: integrate changes#6112..6121 from vmsperl + + Check for existence of file before trying to delete + + Ugly workaround for version-specific RTL error + + Urk -- undo previous removal of vmsish 'exit' change + + Add bounds checking for several strings (Charles Lane) + + Miscellaneous cosmetic fixes (Charles Lane) + + Treat sockets as special in sys(read|write) (Charles Lane et al.) + + Regularize distinction between RMS$_DNF and RMS$_DIR (Craig Berry) + Flatten case labels in switch statements uniformly (Charles Bailey) + + Quiet error messages in vmsish.t (Charles Lane) + + Add missing escape (Charles Lane) + + Allow eliminate_macros() and fixpath() to handle space-delimited + lists (based on fixes by Craig Berry) + Branch: maint-5.6/perl + !> lib/ExtUtils/MM_VMS.pm lib/File/Spec/VMS.pm t/op/lex_assign.t + !> vms/ext/vmsish.pm vms/ext/vmsish.t vms/test.com vms/vms.c + !> vms/vmsish.h +____________________________________________________________________________ +[ 7312] By: gsar on 2000/10/16 06:41:18 + Log: integrate changes#6107,6110 from cfgperl + + Tweak the todo list. + + todo tweak + Branch: maint-5.6/perl + !> Todo-5.6 +____________________________________________________________________________ +[ 7311] By: gsar on 2000/10/16 06:38:38 + Log: integrate changes#6104,6108 from mainline + + PL_sys_intern was being initialized too late on windows + + reenable fake signal handling on Windows, bugs and all + Branch: maint-5.6/perl + !> embed.h embed.pl global.sym makedef.pl mg.c objXSUB.h perl.c + !> perl.h perlapi.c pod/perlapi.pod proto.h win32/perlhost.h + !> win32/win32.c +____________________________________________________________________________ +[ 7310] By: gsar on 2000/10/16 06:36:03 + Log: integrate changes#6095,6097..6103 from cfgperl + + Introduce NV_PRESERVED_BITS. Not yet used anywhere but + might be useful in future. + + Add a note about possible compilation problems from Allen Smith. + + Add a note about other, yet unsupported, shadow password APIs. + + Tweaks for the cc bugs from Allen Smith. + + More compilation tweakery from Allen Smith. + + Hints and test tweaks for Unicos. + + The test suite tweak in #6101 wasn't quite right. + + Test tweaking for Unicos continues. + Branch: maint-5.6/perl + !> Configure Porting/Glossary Porting/config.sh Porting/config_H + !> config_h.SH hints/irix_6.sh hints/unicos.sh pp_sys.c t/lib/b.t + !> t/lib/complex.t t/op/64bitint.t +____________________________________________________________________________ +[ 7309] By: gsar on 2000/10/16 06:29:41 + Log: integrate changes#6093,6094 from mainline + + fork() failure to create pseudo process sets errno=EAGAIN and returns + undef on windows (from Clinton Pierce <clintp@geeksalad.org>) + + cygwin update (from Eric Fifer <efifer@sanwaint.com>) + Branch: maint-5.6/perl + !> README.cygwin cygwin/Makefile.SHs cygwin/cygwin.c + !> hints/cygwin.sh pp_sys.c sv.c win32/perlhost.h +____________________________________________________________________________ +[ 7308] By: gsar on 2000/10/16 06:27:29 + Log: integrate change#6092 from cfgperl + + Regen perltoc with the fixed buildtoc. + Branch: maint-5.6/perl + !> pod/perltoc.pod +____________________________________________________________________________ +[ 7307] By: gsar on 2000/10/16 06:26:40 + Log: integrate changes#6089,6090 from mainline + + buildtoc tweak to fix newline lossage + + concat doesn't preserve utf8-ness, and doesn't invalidate + [NI]OK; added tests for both + Branch: maint-5.6/perl + !> perl.c pod/buildtoc pp_hot.c sv.c t/op/substr.t +____________________________________________________________________________ +[ 7306] By: gsar on 2000/10/16 06:24:05 + Log: integrate change#6088 from cfgperl + + Remove HAS_SETSPENT, HAS_GETSPENT, HAS_ENDSPENT, + because we do not use those. The HAS_GETSPNAM remains, + though, because we still do use that. + Branch: maint-5.6/perl + !> Configure Porting/Glossary Porting/config.sh Porting/config_H + !> config_h.SH epoc/config.sh hints/machten.sh pod/perltoc.pod + !> pp_sys.c vms/subconfigure.com vos/config.def vos/config.h + !> vos/config_h.SH_orig win32/config.bc win32/config.gc + !> win32/config.vc win32/config_H.bc win32/config_H.gc + !> win32/config_H.vc win32/config_h.PL win32/config_sh.PL +____________________________________________________________________________ +[ 7305] By: gsar on 2000/10/16 06:15:52 + Log: integrate changes#6084,6085,6087 from mainline + + substr() does not preserve utf8-ness (from Stefan Eissing + <Eissing@medicaldataservice.de>); added tests + + repeat operator (x) doesn't preserve utf8-ness + + reverse() and quotemeta() weren't preserving utf8-ness; add tests + Branch: maint-5.6/perl + !> pp.c sv.c t/op/quotemeta.t t/op/substr.t toke.c +____________________________________________________________________________ +[ 7304] By: gsar on 2000/10/16 06:13:10 + Log: integrate changes#6077..6083 from mainline + + avoid warnings in diagnostics.pm; pod tweaks (from Peter Prymmer + and Tom Phoenix) + + workaround for CRT bug in chdir() (from Charles Lane, via + Peter Prymmer) + + remove outdated kludge in Carp (NULLs are permitted in diagnostics + now) + + add File::Temp v0.08 from CPAN, with small tweaks to testsuite + (from Tim Jenness <t.jenness@jach.hawaii.edu>) + + better default perlbug categories for ok reports (from Richard Foley) + + peek.t non-portable to ithreads + + note about undocumented caller() return value (from M.J.T. Guy); + yet another peek.t tweak + Branch: maint-5.6/perl + +> lib/File/Temp.pm t/lib/ftmp-mktemp.t t/lib/ftmp-posix.t + +> t/lib/ftmp-security.t t/lib/ftmp-tempfile.t + !> AUTHORS MAINTAIN MANIFEST iperlsys.h lib/Carp/Heavy.pm + !> lib/diagnostics.pm pod/perlfunc.pod pod/perlrun.pod + !> pod/perltie.pod t/lib/peek.t utils/perlbug.PL vms/vms.c + !> vms/vmsish.h +____________________________________________________________________________ +[ 7303] By: gsar on 2000/10/16 06:03:18 + Log: integrate changes#6011,6016,6033,6035..6039,6047..6052,6054..6059, + 6073..6075 from cfgperl (pp_sys.c manually merged due to conflicts) + + &HUGE_VAL is not defined, it exists. + + Do not warn that an infinity does not look like a number. + + Rewrite the pwent/spent logic to be a little bit more clearer. + + Continue on the pwent/spent case. + + Correct Freudian slip. + + Use HUGE_VALL if applicable. + + pwent/spent #ifdef imbalance. + + Infinite problems. + + Call getspnam() only iff needd. + + Test both the scalar and list contexts. + + Use setxxent()/endxxent(). + + Complex tweakery. + + Unicos hint tweak. + + Be more forgiving in POSIX about HUGE_VALL. + + Detypo. + + The search of infinity continues, this time simplified. + + The logic of choosing strtol/strtoul/strtoll/strtoull was wrong + in natively 64-bit platforms where a long is a quad (no need + for long longs). Also added bias for IVs. + + Complex tweaks. + + Introduce t/lib/peek.t. + + Make the test more portable. + Branch: maint-5.6/perl + +> t/lib/peek.t + ! pp_sys.c + !> MANIFEST ext/POSIX/POSIX.xs hints/unicos.sh + !> lib/Math/Complex.pm sv.c t/lib/complex.t t/op/grent.t + !> t/op/pwent.t toke.c util.c +____________________________________________________________________________ +[ 7302] By: gsar on 2000/10/16 05:03:37 + Log: integrate changes#6066..6071 from mainline + + s/END/CHECK/ + + replace direct call to sighandler() with (*PL_sighandlerp)() + + note about values() + + File::Spec compatibility update (from Barrie Slaymaker + <barries@slaysys.com>) + + remove misleading comment (from M.J.T. Guy) + + misformatted perllocal.pod (from Tim Jenness + <t.jenness@jach.hawaii.edu>) + Branch: maint-5.6/perl + !> lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MM_Win32.pm + !> lib/File/Spec.pm lib/File/Spec/Mac.pm lib/File/Spec/Unix.pm + !> lib/File/Spec/VMS.pm lib/File/Spec/Win32.pm perl.c + !> pod/perlfunc.pod t/lib/anydbm.t win32/win32.c +____________________________________________________________________________ +[ 7301] By: gsar on 2000/10/16 05:00:08 + Log: integrate changes#6061..6063 from mainline + + change#5921 neglected to make eq honor "use bytes" + + additional tests for utf8.t + + tokeq() could read unallocated field in argument + Branch: maint-5.6/perl + !> sv.c t/pragma/utf8.t toke.c +____________________________________________________________________________ +[ 7300] By: gsar on 2000/10/16 04:56:54 + Log: integrate changes#6046,6048,6057,6058 from mainline + + libscheck has insufficient checks for n32 libs (from + Albert Chin-A-Young <china@thewrittenword.com>) + + add note about how $( doesn't interpolate in REs (from + Philip Newton <newton@ficus.frogspace.net>) + + fix broken parsing of /\x{ab}/ + + printf(...) should be PerlIO_printf(PerlIO_stdout(), ...) + (spotted by Donald Kinzer <dkinzer@premia.com>) + Branch: maint-5.6/perl + !> hints/irix_6.sh perl.c pod/perlop.pod regcomp.c + !> t/pragma/utf8.t +____________________________________________________________________________ +[ 7299] By: gsar on 2000/10/16 04:52:50 + Log: integrate change#6044 from mainline + + change#3798 broke the meaning of "\0_7_7", tr/\0_// etc.; fix it + such that underscores are only ignored in literal numbers, + "\x{...}", and hex/oct argument + Branch: maint-5.6/perl + !> perl.c pp.c regcomp.c t/op/oct.t toke.c util.c +____________________________________________________________________________ +[ 7298] By: gsar on 2000/10/16 04:50:53 + Log: integrate changes#6027..6043 from mainline + + podlators-1.02 update (from Russ Allbery) + + Pod::Man generates groff-incompatible macro definition (from + Tom Christiansen) + + add CGI.pm v2.66 (from Lincoln Stein) + + introduce @LAST_MATCH_START and @LAST_MATCH_END, English aliases + for @- and @+ (from Johan Vromans) + + small nits in diagnostics.pm (from Robin Barker) + + whitespace adjustments + + missing files in MANIFEST + + cpio 2.4.2 on Linux creates directories in 0700 mode, adjust makerel + to compensate + + remove outdated perltrap entry (from Peter Scott <Peter@PSDT.com>) + + perlretut revisions (from Mark Kvale <kvale@phy.ucsf.edu>) + Branch: maint-5.6/perl + +> lib/CGI/Util.pm t/lib/cgi-pretty.t + !> MANIFEST Porting/makerel lib/CGI.pm lib/CGI/Carp.pm + !> lib/CGI/Cookie.pm lib/CGI/Pretty.pm lib/CGI/Push.pm + !> lib/English.pm lib/Pod/Man.pm lib/Pod/Text.pm + !> lib/diagnostics.pm pod/perldiag.pod pod/perlretut.pod + !> pod/perltrap.pod pod/perlvar.pod pp_sys.c t/lib/cgi-function.t + !> t/lib/cgi-html.t t/lib/cgi-request.t +____________________________________________________________________________ +[ 7297] By: gsar on 2000/10/16 04:44:30 + Log: integrate change#6025 from mainline + + Is{Alnum,Alpha,Word} don't match titlecase + TODO: IsSpace is defined recursively! + (both spotted by Larry) + Branch: maint-5.6/perl + !> lib/unicode/Is/Alnum.pl lib/unicode/Is/Alpha.pl + !> lib/unicode/Is/Word.pl lib/unicode/mktables.PL +____________________________________________________________________________ +[ 7296] By: gsar on 2000/10/16 04:39:30 + Log: integrate change#6023 from mainline + + debugger stomps on $. (from M.J.T. Guy) + Branch: maint-5.6/perl + !> lib/perl5db.pl +____________________________________________________________________________ +[ 7295] By: gsar on 2000/10/16 04:38:02 + Log: integrate change#6022 from mainline + + unbalanced LEAVE after perl_clone(...,0) (from Doug MacEachern) + Branch: maint-5.6/perl + !> sv.c +____________________________________________________________________________ +[ 7294] By: gsar on 2000/10/16 04:37:05 + Log: integrate changes#6018..6021 from mainline + + make lib/syslog.t portable to systems that don't have _PATH_LOG, + make _PATH_LOG() return "" if unavailable + + windows portability tweaks + + test tweak + + remove Win2K issue in pod (fixed by change#6020) + Branch: maint-5.6/perl + !> README.win32 ext/File/Glob/Glob.pm ext/Sys/Syslog/Syslog.pm + !> ext/Sys/Syslog/Syslog.xs pod/perldelta.pod t/lib/b.t + !> t/lib/open3.t t/lib/syslog.t win32/win32.h +____________________________________________________________________________ +[ 7293] By: gsar on 2000/10/16 04:20:00 + Log: integrate changes#6013..6015 from mainline + + tweak change#5945 to display correct switch name in diagnostic + + glob() loading File::Glob behind the scenes may cause syntax errors + + tweak test for portability + Branch: maint-5.6/perl + !> op.c perl.c pod/perldiag.pod t/lib/b.t +____________________________________________________________________________ +[ 7292] By: gsar on 2000/10/16 04:18:11 + Log: integrate changes#6005..6010 from mainline, cfgperl + + perldoc might fail via "use blib" (from Hugo van der Sanden) + + Regen Configure. + + note about compile failures and END blocks (from M.J.T. Guy) + + VMS config tweak (from Craig A. Berry <craig.berry@metamorgs.com>) + + (change#6009 integrated earlier in change#7255) + + clarify note about shadow password support (from + gellyfish@gellyfish.com) + Branch: maint-5.6/perl + !> Configure Porting/Glossary Porting/config.sh Porting/config_H + !> config_h.SH installperl pod/perldelta.pod pod/perlfunc.pod + !> pod/perlmod.pod utils/perldoc.PL vms/subconfigure.com +____________________________________________________________________________ +[ 7291] By: gsar on 2000/10/16 04:12:03 + Log: integrate changes#6002,6003 from mainline + + destructive sv_setsv() can lose UV-ness from source, causing + numeric promotions/comparisons to fail to do the right thing + + allow REG_EXPAND_SZ keys in Windows registry (from + John Clayton <John.Clayton@barclayscapital.com>) + Branch: maint-5.6/perl + !> sv.c win32/win32.c +____________________________________________________________________________ +[ 7290] By: gsar on 2000/10/16 04:10:19 + Log: integrate change#6001 from mainline + + support additional library locations via $Config{otherlibdirs} + (from Andy Dougherty) + Branch: maint-5.6/perl + !> Configure INSTALL Porting/Glossary Porting/config.sh + !> Porting/config_H config_h.SH epoc/config.sh perl.c + !> vms/subconfigure.com vos/config.def vos/config_h.SH_orig + !> win32/config.bc win32/config.gc win32/config.vc +____________________________________________________________________________ +[ 7289] By: gsar on 2000/10/16 04:08:28 + Log: integrate change#5999 from mainline + + fix line renumbering bug in C<eval qq[#line 10 "X"\nwarn]> + Branch: maint-5.6/perl + !> t/pragma/warn/toke toke.c +____________________________________________________________________________ +[ 7288] By: gsar on 2000/10/16 04:07:01 + Log: integrate changes#5997,5998 from cfgperl + + Preserve $!. + + Try to get "Inf" by using &POSIX::HUGE_VAL in sprintf. + Branch: maint-5.6/perl + !> lib/Math/Complex.pm +____________________________________________________________________________ +[ 7287] By: gsar on 2000/10/16 04:04:37 + Log: integrate change#5995 from mainline + + fixes for bugs in C<use warnings qw(FATAL all)> (from Paul Marquess) + Branch: maint-5.6/perl + !> mg.c t/pragma/warn/7fatal warnings.h warnings.pl +____________________________________________________________________________ +[ 7286] By: gsar on 2000/10/16 04:03:21 + Log: integrate change#5994 from mainline + + fix for missed accounting for null byte in pack("Z",...) (from + M.J.T. Guy) + Branch: maint-5.6/perl + !> pp.c t/op/pack.t +____________________________________________________________________________ +[ 7285] By: gsar on 2000/10/16 04:02:11 + Log: integrate changes#5989..5993 from mainline + + qw(a\\b) must be parsed like 'a\\b', i.e., backslash escapes + itself and no other (from Tom Hughes) + + use $ENV{LIB} to search for libs under Visual C compiler + on Windows (from Jochen Wiedmann <joe@ispsoft.de>) + + posix-bc patches (from Dorner Thomas <Thomas.Dorner@start.de>) + + pod nit (from Simon Cozens) + + various minor tweaks seen on p5p + Branch: maint-5.6/perl + !> README.posix-bc hints/posix-bc.sh lib/ExtUtils/Liblist.pm + !> lib/perl5db.pl pod/perlipc.pod pod/perlop.pod pod/perlvar.pod + !> t/op/array.t toke.c +____________________________________________________________________________ +[ 7284] By: gsar on 2000/10/16 03:59:00 + Log: integrate changes#5978..5988 from mainline + + sync version numbers in File::Spec with the ones on CPAN + (from Barrie Slaymaker) + + under useithreads, constant pad entries could inadvertantly be + shared across threads (from Eric Blood <eblood@xmission.com>); + added Eric's test case to testsuite + + allow Configure -S to run non-interactively (spotted by Greg Hudson + <ghudson@mit.edu>) + + rename File::Glob::glob() to File::Glob::bsd_glob() to avoid + prototype mismatch with CORE::glob(); update pod and tests to + suit (File::Glob::glob() is still available for backward + compatibility, but should be considered deprecated) + + avoid error in IO::Socket::INET when given an unknown service name + with a port number (from Brian Raven <brianr@ssprdmh01.liffe.com>) + + numeric conversion of non-number in change#3378 tramples on + OOK offset, causing segfaults + + attributes::reftype() doesn't work on tied argument + + forked child may not exit correctly if it failed to open + /dev/console (from Graham Barr) + + add regular expressions tutorial and quick-start guide (from + Mark Kvale <kvale@phy.ucsf.edu>) + + B::Bytecode tweaks (from Simon Cozens <simon@brecon.co.uk>) + + s/HTMLSCRIPTPOD/HTMLSCRIPTPODS/ (from Paul Sharpe + <paul@miraclefish.com>) + Branch: maint-5.6/perl + +> pod/perlrequick.pod pod/perlretut.pod + !> AUTHORS Configure MAINTAIN MANIFEST ext/B/B/Bytecode.pm + !> ext/B/B/Disassembler.pm ext/File/Glob/Glob.pm + !> ext/IO/lib/IO/Socket/INET.pm ext/Sys/Syslog/Syslog.pm + !> lib/ExtUtils/MakeMaker.pm lib/File/Spec/Functions.pm + !> lib/File/Spec/Mac.pm lib/File/Spec/OS2.pm + !> lib/File/Spec/Unix.pm lib/File/Spec/VMS.pm + !> lib/File/Spec/Win32.pm op.c sv.c t/lib/glob-basic.t + !> t/lib/glob-case.t t/lib/glob-taint.t t/op/misc.t xsutils.c +____________________________________________________________________________ +[ 7283] By: gsar on 2000/10/16 03:52:14 + Log: integrate change#5977 from mainline + + autoquote barewords followed by newline and arrow properly + (variant of fix suggested by Rick Delaney and M.J.T. Guy) + Branch: maint-5.6/perl + !> t/pragma/warn/toke toke.c +____________________________________________________________________________ +[ 7282] By: gsar on 2000/10/16 03:50:48 + Log: integrate change#5976 from mainline + + DB_File v1.73 update (from Paul Marquess) + Branch: maint-5.6/perl + !> ext/DB_File/Changes ext/DB_File/DB_File.pm + !> ext/DB_File/DB_File.xs ext/DB_File/version.c +____________________________________________________________________________ +[ 7281] By: gsar on 2000/10/16 03:49:14 + Log: integrate change#5975 from mainline + + allow sort() reentrancy (variant of patch suggested by + Hugo van der Sanden) + Branch: maint-5.6/perl + !> pp_ctl.c t/op/sort.t +____________________________________________________________________________ +[ 7280] By: gsar on 2000/10/16 03:48:22 + Log: integrate change#5974 from mainline + + change#4197 somehow missed initializing PL_errors, meaning + syntax error queueing wasn't working outside eval"" at all; + also fixed eval"" to localize PL_error_count, so that compile-time + eval's don't clobber the error state of the outer context + Branch: maint-5.6/perl + !> lib/Math/Complex.pm perl.c pp_ctl.c t/pragma/warn/op + !> t/pragma/warn/toke +____________________________________________________________________________ +[ 7279] By: gsar on 2000/10/16 03:46:21 + Log: integrate change#5973 from mainline + + fix for failure to match $foo =~ /(?i)/ (from Ilya Zakharevich) + Branch: maint-5.6/perl + !> regcomp.c regexec.c t/op/re_tests +____________________________________________________________________________ +[ 7278] By: gsar on 2000/10/16 03:44:54 + Log: integrate change#5971 from cfgperl + + Unicos tweaks from Mark P. Lutz. + Branch: maint-5.6/perl + !> hints/unicos.sh lib/Math/Complex.pm +____________________________________________________________________________ +[ 7277] By: gsar on 2000/10/16 03:42:59 + Log: integrate changes#5966..5970 from mainline + + add testsuite for B backends, fix bug in B::Deparse (from + Simon Cozens <simon@brecon.co.uk>) + + improved docs on the warn_uninit diagnostic (from David Glasser + and Simon Cozens) + + tolerate spaces in group names in test on solaris (from David Boyce + <dsb@boyski.com>) + + fix Sys::Syslog breakage on domain sockets (from Tom Hughes) + + Data::Dumper fumbles negative numbers on 32-bit platforms where + IV is >32bits + Branch: maint-5.6/perl + +> t/lib/b.t t/lib/syslog.t + !> MANIFEST ext/B/B/Deparse.pm ext/B/B/Stash.pm + !> ext/Data/Dumper/Dumper.xs ext/Sys/Syslog/Syslog.pm + !> pod/perldiag.pod t/lib/dumper.t t/op/groups.t +____________________________________________________________________________ +[ 7276] By: gsar on 2000/10/16 03:39:30 + Log: integrate change#5965 from mainline + + avoid "will not stay shared" warnings for our variables (from + Robin Barker) + Branch: maint-5.6/perl + !> op.c t/pragma/warn/op +____________________________________________________________________________ +[ 7275] By: gsar on 2000/10/16 03:38:18 + Log: integrate change#5964 from mainline + + reformat to 72 columns (again) + Branch: maint-5.6/perl + !> pod/perldiag.pod +____________________________________________________________________________ +[ 7274] By: gsar on 2000/10/16 03:36:58 + Log: integrate change#5963 from mainline + + patch from Larry to make (\&) prototype work; added tests for + the same + Branch: maint-5.6/perl + !> op.c t/comp/proto.t +____________________________________________________________________________ +[ 7273] By: gsar on 2000/10/16 03:35:51 + Log: integrate changes#5956..5962 from mainline + + better diagnostics on failed tests (from Ilya Zakharevich) + + pod nits (from A. C. Yardley <yardley@tanet.net>) + + change#3569 deleted some essential code, revert; avoid use of + atexit() to make DynaLoader work properly on AIX under mod_perl + (from Jens-Uwe Mager <jum@helios.de>) + + doubled words in pods (from Simon Cozens + <simon.p.cozens@jp.pwcglobal.com>) + + better INSTALL notes on Solaris issues (from Dominic Dunlop) + + recognize our, CHECK and INIT in cperl-mode (from Doug MacEachern) + + updated README.hpux (from Jeff Okamoto) + Branch: maint-5.6/perl + !> INSTALL README.hpux emacs/cperl-mode.el + !> ext/DynaLoader/dl_aix.xs pod/perldebguts.pod pod/perldelta.pod + !> pod/perlfaq5.pod pod/perlfork.pod pod/perlfunc.pod + !> pod/perlipc.pod pod/perllexwarn.pod pod/perllocale.pod + !> pod/perlmod.pod pod/perlmodlib.pod pod/perlnumber.pod + !> pod/perlopentut.pod pod/perltodo.pod pod/perltootc.pod + !> t/op/lex_assign.t +____________________________________________________________________________ +[ 7272] By: gsar on 2000/10/16 03:31:22 + Log: integrate change#5955 from mainline + + longstanding bug exposed by change#3307: sort arguments weren't + compiled with the right wantarray context (ensuing runtime lookup + via block_gimme() was getting the incidental context of the + sort() itself) + Branch: maint-5.6/perl + !> op.c t/op/sort.t +____________________________________________________________________________ +[ 7271] By: gsar on 2000/10/16 03:29:11 + Log: integrate changes#5933,5935,5940..5944,5946,5951,5952 from cfgperl + branch + + Flatten the cpp jungle doing the nosuid checking. + + Do not assume sign propagation. (from M.J.T. Guy) + + Various Unicos 10.0.0.6 fixes. (from Mark Lutz) + + Add HAS_FREXPL, HAS_ISNAN, HAS_ISNANL, and HAS_MODFL. + Now pp_ncmp() returns undef is either operand is a NaN. + + On second thoughts frexp() does have two arguments. + + Document that tr() is not tr(1). + + Be more robust on "extreme" (large absolute value) + arguments. Originally reported by Daniel Connelly + as a problem with asinh() on large negative arguments, + asinh() used to bail out because an argument to log() + ended up being zero. Ilya Zakharevich proposed using + Taylor's series in such cases, which for such large + arguments is a very good approximation. + + Undo "use integer" addition from 64bitint as it seems + to break most of the subtests in Digital UNIX; + Unicos needs to find another way. + Branch: maint-5.6/perl + !> (integrate 29 files) +____________________________________________________________________________ +[ 7270] By: gsar on 2000/10/16 03:09:44 + Log: integrate changes#5948,5949,5950 from mainline + + typo in vars.pm that leads to cryptic message (from Piotr + Piatkowski <kompas@kompas.usr.onet.pl>) + + make perldoc use the pod2man from the same version (from + M.J.T. Guy) + + reformat perldiag to avoid long lines + Branch: maint-5.6/perl + !> lib/vars.pm pod/perldiag.pod utils/perldoc.PL +____________________________________________________________________________ +[ 7269] By: gsar on 2000/10/16 03:05:54 + Log: integrate change#5947 from mainline + + use &dl_error rather than &dl_load_file as the guard for calling + boot_DynaLoader() (meant to fix dl_error() redefined warnings in + statically built perl) + Branch: maint-5.6/perl + !> ext/DynaLoader/DynaLoader_pm.PL ext/DynaLoader/XSLoader_pm.PL +____________________________________________________________________________ +[ 7268] By: gsar on 2000/10/16 03:04:48 + Log: integrate change#5945 from mainline + + make module name mandatory after -M switch; reorder perldiag + alphabetically (from Mark-Jason Dominus) + Branch: maint-5.6/perl + !> perl.c pod/perldiag.pod +____________________________________________________________________________ +[ 7267] By: gsar on 2000/10/16 03:03:01 + Log: integrate change#5939 from mainline + + more pod nits (from Larry Virden) + Branch: maint-5.6/perl + !> README.win32 pod/perlsub.pod pod/perlsyn.pod + !> pod/perlthrtut.pod pod/perltoc.pod pod/perltodo.pod + !> pod/perlxs.pod pod/perlxstut.pod vms/perlvms.pod +____________________________________________________________________________ +[ 7266] By: gsar on 2000/10/16 03:01:39 + Log: integrate change#5938 from mainline + + Consolidated B::Deparse fixes (from Stephen McCamant) + Branch: maint-5.6/perl + !> ext/B/B/Deparse.pm +____________________________________________________________________________ +[ 7265] By: gsar on 2000/10/16 03:00:43 + Log: integrate change#5936 from mainline + + additional tests for change#7263 (from Paul Marquess) + Branch: maint-5.6/perl + !> t/pragma/warn/2use t/pragma/warn/3both t/pragma/warn/4lint + !> t/pragma/warn/5nolint t/pragma/warn/6default +____________________________________________________________________________ +[ 7264] By: gsar on 2000/10/16 02:58:34 + Log: integrate change#5934 from mainline + + propagate lexical warnings from surrounding scope correctly + within string eval() (from Paul Marquess) + Branch: maint-5.6/perl + !> pp_ctl.c t/pragma/warn/pp_ctl +____________________________________________________________________________ +[ 7263] By: gsar on 2000/10/16 02:56:53 + Log: integrate change#5932 from mainline + + add rsignal(), whichsig() and do_join() to public API list + (mod_perl uses them to good advantage) + Branch: maint-5.6/perl + !> embed.pl global.sym objXSUB.h perlapi.c proto.h +____________________________________________________________________________ +[ 7262] By: gsar on 2000/10/16 02:55:53 + Log: integrate change#5931 from mainline + + fix RE brokenness on refs/overloaded things (from Ilya Zakharevich) + Branch: maint-5.6/perl + !> pp_hot.c regexec.c t/op/pat.t +____________________________________________________________________________ +[ 7261] By: gsar on 2000/10/16 02:55:01 + Log: integrate change#5930 from mainline + + small os390 tweaks (from Peter Prymmer) + Branch: maint-5.6/perl + !> config_h.SH makedepend.SH +____________________________________________________________________________ +[ 7260] By: gsar on 2000/10/16 02:54:10 + Log: integrate change#5929 from mainline + + pod nits + Branch: maint-5.6/perl + !> pod/perlguts.pod +____________________________________________________________________________ +[ 7259] By: gsar on 2000/10/16 02:52:55 + Log: integrate change#5927 from mainline + + arrange for next() to resume at the unstack op rather than the + loop conditional, so that scope cleanup happens correctly + (from Stephen McCamant) + Branch: maint-5.6/perl + !> op.c pp_ctl.c t/op/misc.t +____________________________________________________________________________ +[ 7258] By: gsar on 2000/10/16 02:51:38 + Log: integrate change#5926 from mainline + + on windows, reserve 16M of stack rather than 128M (allows more + threads to run concurrently) + Branch: maint-5.6/perl + !> win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 7257] By: gsar on 2000/10/16 02:50:37 + Log: integrate change#5925 from mainline + + POSIX-BC tweak (from Ignasi Roca <ignasi.roca@fujitsu.siemens.es>) + Branch: maint-5.6/perl + !> toke.c +____________________________________________________________________________ +[ 7256] By: gsar on 2000/10/16 02:49:36 + Log: integrate change#5924 from mainline + + avoid using uninitialized memory in require version check + Branch: maint-5.6/perl + !> pp_ctl.c universal.c +____________________________________________________________________________ +[ 7255] By: gsar on 2000/10/16 02:48:03 + Log: integrate changes#5923,5928,6009 from mainline + + IO::Poll bugs fixed (from Lincoln Stein <lstein@cshl.org>) + Branch: maint-5.6/perl + !> ext/IO/lib/IO/Poll.pm t/lib/io_poll.t +____________________________________________________________________________ +[ 7254] By: gsar on 2000/10/16 02:44:46 + Log: integrate change#5922 from mainline + + commentary about IoTYPE() (from Nathan Torkington) + Branch: maint-5.6/perl + !> sv.h +____________________________________________________________________________ +[ 7253] By: gsar on 2000/10/16 02:43:49 + Log: integrate change#5921 from mainline + + make eq unicode-aware (from Gisle Aas); fix bogus tests revealed + Branch: maint-5.6/perl + !> sv.c t/lib/charnames.t t/pragma/utf8.t +____________________________________________________________________________ +[ 7252] By: gsar on 2000/10/16 02:42:31 + Log: integrate change#5920 from mainline + + Larry's fix for buggy propagation of utf8-ness in join(); add test + Branch: maint-5.6/perl + !> doop.c t/op/ver.t +____________________________________________________________________________ +[ 7251] By: gsar on 2000/10/16 02:41:14 + Log: integrate changes#5915..5919 from mainline + + various (pod tweaks &c) + Branch: maint-5.6/perl + !> (integrate 33 files) +____________________________________________________________________________ +[ 7250] By: gsar on 2000/10/16 02:38:16 + Log: integrate change#5914 from mainline + + caller() wasn't returning the right number of elements for + eval {...} + Branch: maint-5.6/perl + !> pp_ctl.c t/pragma/warn/9enabled +____________________________________________________________________________ +[ 7249] By: gsar on 2000/10/16 02:37:02 + Log: integrate change#5913 from mainline + + pod nit: $yday range for localtime/gmtime is 0..364 not 1..365 + (from Mark-Jason Dominus) + Branch: maint-5.6/perl + !> pod/perlfunc.pod +____________________________________________________________________________ +[ 7248] By: gsar on 2000/10/16 02:35:58 + Log: integrate change#5912 from mainline + + fix totally broken caching in UNIVERSAL::isa() (from + Nick Ing-Simmons) + Branch: maint-5.6/perl + !> t/op/universal.t universal.c +____________________________________________________________________________ +[ 7247] By: gsar on 2000/10/16 02:34:27 + Log: integrate changes#5910,5911 from mainline + + typo in pod + + add linebreak properties from unicode/LineBrk.txt (from + Dave Hartnoll <Dave_Hartnoll@3b2.com>) + Branch: maint-5.6/perl + +> (branch 29 files) + !> ext/Thread/Thread.pm lib/unicode/mktables.PL +____________________________________________________________________________ +[ 7246] By: gsar on 2000/10/16 02:33:29 + Log: integrate change#5909 from mainline + + mode argument to do_binmode() should be file mode, not boolean + Branch: maint-5.6/perl + !> pp_sys.c +____________________________________________________________________________ +[ 7245] By: gsar on 2000/10/16 02:31:04 + Log: integrate change#5908 from mainline + + introduce illegal symbols into null package so that + gv_fetchpv(...,TRUE) always returns a valid GV even when the + symbol is trapped by strictures (avoids coredumps) + Branch: maint-5.6/perl + !> embedvar.h gv.c intrpvar.h perl.c perlapi.h + !> t/pragma/strict-vars +____________________________________________________________________________ +[ 7242] By: gsar on 2000/10/16 02:26:51 + Log: integrate changes#5905,5906,5907,6064 from mainline + + printf/sprintf didn't get quad types right under use64bitint + Branch: maint-5.6/perl + !> pp_sys.c sv.c t/op/64bitint.t +____________________________________________________________________________ +[ 5902] By: gsar on 2000/03/28 01:59:14 + Log: create maint-5.6 branch + Branch: maint-5.6/perl + +> (branch 1611 files) +____________________________________________________________________________ +[ 5900] By: gsar on 2000/03/23 05:42:43 + Log: three guesses on what this is :-) + Branch: perl + ! Changes -------------- Version v5.6.0 @@ -664,7 +7913,7 @@ ____________________________________________________________________________ ____________________________________________________________________________ [ 5802] By: jhi on 2000/03/18 17:11:07 Log: Configure nits: rewording from Sarathy (aka #5796), - and installation directories patch from Robin Parker. + and installation directories patch from Robin Barker. Branch: cfgperl ! Configure Porting/Glossary Porting/config.sh Porting/config_H ! config_h.SH vos/config.h vos/config_h.SH_orig @@ -2841,7 +10090,7 @@ ____________________________________________________________________________ ____________________________________________________________________________ [ 5440] By: jhi on 2000/03/02 17:48:15 Log: Confusion over uselargefiles.cbu and uselfs.cbu (the first one - is the correct one), spotted by Robin Parker. + is the correct one), spotted by Robin Barker. Branch: cfgperl ! Configure config_h.SH hints/aix.sh hints/hpux.sh Branch: metaconfig/U/perl @@ -12365,7 +19614,7 @@ ____________________________________________________________________________ ____________________________________________________________________________ [ 4045] By: jhi on 1999/08/29 15:18:38 Log: Fix scalar gmtime (and localtime) in quad environments, - bug reported by Robin Parker. + bug reported by Robin Barker. From: Robin Barker <rmb1@cise.npl.co.uk> To: jhi@iki.fi @@ -13319,7 +20568,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?= <desar@club-internet.fr> + From: François Désarménien <desar@club-internet.fr> 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/contrib/perl5/Changes5.004 b/contrib/perl5/Changes5.004 index d0601663ecf5..2d578b43ab7c 100644 --- a/contrib/perl5/Changes5.004 +++ b/contrib/perl5/Changes5.004 @@ -8031,7 +8031,7 @@ This release is beta candidate #5: Our last, best hope for a beta. From: Chip Salzenberg Files: pp_hot.c - Title: "Fix grep() with refs in array context" + Title: "Fix grep() with refs in list context" From: Chip Salzenberg Files: pp.c diff --git a/contrib/perl5/Configure b/contrib/perl5/Configure index 3e7ac45a8660..05ce5ea64732 100755 --- a/contrib/perl5/Configure +++ b/contrib/perl5/Configure @@ -20,10 +20,10 @@ # $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $ # -# Generated on Wed Mar 22 19:13:31 EET 2000 [metaconfig 3.0 PL70] -# (with additional metaconfig patches by perlbug@perl.com) +# Generated on Tue Mar 13 05:21:04 EET 2001 [metaconfig 3.0 PL70] +# (with additional metaconfig patches by perlbug@perl.org) -cat >/tmp/c1$$ <<EOF +cat >c1$$ <<EOF ARGGGHHHH!!!!! SCO csh still thinks true is false. Write to SCO today and tell them that next @@ -34,18 +34,18 @@ we'd have to do is go in and swap the && and || tokens, wherever they are.) [End of diatribe. We now return you to your regularly scheduled programming...] EOF -cat >/tmp/c2$$ <<EOF +cat >c2$$ <<EOF OOPS! You naughty creature! You didn't run Configure with sh! I will attempt to remedy the situation by running sh for you... EOF -true || cat /tmp/c1$$ /tmp/c2$$ +true || cat c1$$ c2$$ true || exec sh $0 $argv:q -(exit $?0) || cat /tmp/c2$$ +(exit $?0) || cat c2$$ (exit $?0) || exec sh $0 $argv:q -rm -f /tmp/c1$$ /tmp/c2$$ +rm -f c1$$ c2$$ : compute my invocation name me=$0 @@ -160,9 +160,12 @@ esac test -d UU || mkdir UU cd UU && rm -f ./* +ccname='' +ccversion='' ccsymbols='' cppccsymbols='' cppsymbols='' +perllibs='' dynamic_ext='' extensions='' known_extensions='' @@ -288,7 +291,6 @@ bincompat5005='' d_bincompat5005='' byteorder='' cc='' -gccversion='' ccflags='' cppflags='' ldflags='' @@ -306,6 +308,7 @@ cppminus='' cpprun='' cppstdin='' crosscompile='' +d__fwalk='' d_access='' d_accessx='' d_alarm='' @@ -343,10 +346,10 @@ d_endnent='' d_endpent='' d_endpwent='' d_endsent='' -d_endspent='' d_fchmod='' d_fchown='' d_fcntl='' +d_fcntl_can_lock='' d_fd_macros='' d_fd_set='' d_fds_bits='' @@ -355,15 +358,18 @@ d_flexfnam='' d_flock='' d_fork='' d_fpos64_t='' +d_frexpl='' d_fs_data_s='' d_fseeko='' d_fsetpos='' d_fstatfs='' +d_fsync='' d_ftello='' d_ftime='' d_gettimeod='' d_Gconvert='' d_getcwd='' +d_getespwnam='' d_getfsstat='' d_getgrent='' d_getgrps='' @@ -382,6 +388,7 @@ d_getnbyaddr='' d_getnbyname='' d_getnent='' d_getnetprotos='' +d_getpagsz='' d_getpent='' d_getpgid='' d_getpgrp2='' @@ -392,10 +399,10 @@ d_getprior='' d_getpbyname='' d_getpbynumber='' d_getprotoprotos='' +d_getprpwnam='' d_getpwent='' d_getsent='' d_getservprotos='' -d_getspent='' d_getspnam='' d_getsbyname='' d_getsbyport='' @@ -406,6 +413,8 @@ d_iconv='' d_inetaton='' d_int64_t='' d_isascii='' +d_isnan='' +d_isnanl='' d_killpg='' d_lchown='' d_ldbl_dig='' @@ -435,6 +444,7 @@ d_mkstemps='' d_mktime='' d_mmap='' mmaptype='' +d_modfl='' d_mprotect='' d_msg='' d_msgctl='' @@ -468,6 +478,7 @@ d_rmdir='' d_safebcpy='' d_safemcpy='' d_sanemcmp='' +d_sbrkproto='' d_select='' d_sem='' d_semctl='' @@ -497,7 +508,6 @@ d_setrgid='' d_setruid='' d_setsent='' d_setsid='' -d_setspent='' d_setvbuf='' d_sfio='' usesfio='' @@ -522,6 +532,7 @@ d_sockpair='' sockethdr='' socketlib='' d_socklen_t='' +d_socks5_init='' d_sqrtl='' d_statblks='' d_statfs_f_flags='' @@ -530,6 +541,8 @@ d_fstatvfs='' d_statvfs='' d_stdio_cnt_lval='' d_stdio_ptr_lval='' +d_stdio_ptr_lval_nochange_cnt='' +d_stdio_ptr_lval_sets_cnt='' d_stdiobase='' d_stdstdio='' stdio_base='' @@ -595,6 +608,8 @@ fflushNULL='' fflushall='' fpossize='' fpostype='' +gccosandvers='' +gccversion='' gidformat='' gidsign='' gidsize='' @@ -636,6 +651,7 @@ i_netinettcp='' i_niin='' i_sysin='' i_poll='' +i_prot='' i_pthread='' d_pwage='' d_pwchange='' @@ -705,6 +721,7 @@ installusrbinperl='' intsize='' longsize='' shortsize='' +issymlink='' libc='' ldlibpthname='' libperl='' @@ -722,18 +739,20 @@ libsfiles='' libsfound='' libspath='' lns='' -d_PRIEldbl='' -d_PRIFldbl='' -d_PRIGldbl='' +d_PRIEUldbl='' +d_PRIFUldbl='' +d_PRIGUldbl='' d_PRIeldbl='' d_PRIfldbl='' d_PRIgldbl='' -sPRIEldbl='' -sPRIFldbl='' -sPRIGldbl='' +d_SCNfldbl='' +sPRIEUldbl='' +sPRIFUldbl='' +sPRIGUldbl='' sPRIeldbl='' sPRIfldbl='' sPRIgldbl='' +sSCNfldbl='' lseeksize='' lseektype='' make_set_make='' @@ -751,12 +770,6 @@ installman3dir='' man3dir='' man3direxp='' man3ext='' -huge='' -large='' -medium='' -models='' -small='' -split='' modetype='' multiarch='' mydomain='' @@ -777,6 +790,8 @@ hostcat='' passcat='' orderlib='' ranlib='' +d_perl_otherlibdirs='' +otherlibdirs='' package='' spackage='' pager='' @@ -792,6 +807,7 @@ perl5='' perladmin='' perlpath='' d_nv_preserves_uv='' +d_nv_preserves_uv_bits='' i16size='' i16type='' i32size='' @@ -815,6 +831,13 @@ u8type='' uvsize='' uvtype='' ivdformat='' +nvEUformat='' +nvFUformat='' +nvGUformat='' +nveformat='' +nvfformat='' +nvgformat='' +uvXUformat='' uvoformat='' uvuformat='' uvxformat='' @@ -826,13 +849,13 @@ privlib='' privlibexp='' prototype='' ptrsize='' -d_PRIX64='' +d_PRIXU64='' d_PRId64='' d_PRIi64='' d_PRIo64='' d_PRIu64='' d_PRIx64='' -sPRIX64='' +sPRIXU64='' sPRId64='' sPRIi64='' sPRIo64='' @@ -893,6 +916,9 @@ uidtype='' archname64='' use64bitall='' use64bitint='' +ccflags_uselargefiles='' +ldflags_uselargefiles='' +libswanted_uselargefiles='' uselargefiles='' uselongdouble='' usemorebits='' @@ -926,10 +952,13 @@ vendorlibexp='' usevendorprefix='' vendorprefix='' vendorprefixexp='' +versiononly='' defvoidused='' voidflags='' pm_apiversion='' xs_apiversion='' +yacc='' +yaccflags='' CONFIG='' define='define' @@ -947,6 +976,9 @@ if test -f /etc/unixtovms.exe; then fi i_whoami='' +ccname='' +ccversion='' +perllibs='' : set useposix=false in your hint file to disable the POSIX extension. useposix=true : set useopcode=false in your hint file to disable the Opcode extension. @@ -955,6 +987,7 @@ useopcode=true _exe='' : Extra object files, if any, needed on this platform. archobjs='' +archname='' : Possible local include directories to search. : Set locincpth to "" in a hint file to defeat local include searches. locincpth="/usr/local/include /opt/local/include /usr/gnu/include" @@ -971,8 +1004,7 @@ loclibpth="/usr/local/lib /opt/local/lib /usr/gnu/lib" loclibpth="$loclibpth /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib" : general looking path for locating libraries -glibpth="/usr/lib/large /lib /usr/lib $xlibpth" -glibpth="$glibpth /lib/large /usr/lib/small /lib/small" +glibpth="/lib /usr/lib $xlibpth" glibpth="$glibpth /usr/ccs/lib /usr/ucblib /usr/local/lib" test -f /usr/shlib/libc.so && glibpth="/usr/shlib $glibpth" test -f /shlib/libc.so && glibpth="/shlib $glibpth" @@ -986,6 +1018,10 @@ plibpth='' libswanted='' : some systems want to use only the non-versioned libso:s ignore_versioned_solibs='' +archname64='' +ccflags_uselargefiles='' +ldflags_uselargefiles='' +libswanted_uselargefiles='' : set usemultiplicity on the Configure command line to enable multiplicity. : set usesocks on the Configure command line to enable socks. : set usethreads on the Configure command line to enable threads. @@ -1040,7 +1076,7 @@ case "$sh" in $me: Fatal Error: I can't find a Bourne Shell anywhere. Usually it's in /bin/sh. How did you even get this far? -Please contact me (Perl Maintainers) at perlbug@perl.com and +Please contact me (Perl Maintainers) at perlbug@perl.org and we'll try to straighten this all out. EOM exit 1 @@ -1339,10 +1375,15 @@ esac case "$fastread$alldone" in yescont|yesexit) ;; *) - if test ! -t 0; then - echo "Say 'sh Configure', not 'sh <Configure'" - exit 1 - fi + case "$extractsh" in + true) ;; + *) + if test ! -t 0; then + echo "Say 'sh Configure', not 'sh <Configure'" + exit 1 + fi + ;; + esac ;; esac @@ -1393,6 +1434,7 @@ case "$src" in */*) src=`echo $0 | sed -e 's%/[^/][^/]*$%%'` case "$src" in /*) ;; + .) ;; *) src=`cd ../$src && pwd` ;; esac ;; @@ -1576,7 +1618,7 @@ THIS PACKAGE SEEMS TO BE INCOMPLETE. You have the option of continuing the configuration process, despite the distinct possibility that your kit is damaged, by typing 'y'es. If you do, don't blame me if something goes wrong. I advise you to type 'n'o -and contact the author (perlbug@perl.com). +and contact the author (perlbug@perl.org). EOM echo $n "Continue? [n] $c" >&4 @@ -1739,6 +1781,43 @@ persist across sessions for $package. You may safely delete it if you wish. EOF +xversion=`awk '/define[ ]+PERL_VERSION/ {print $3}' $rsrc/patchlevel.h` +case "$usedevel" in +$define|true|[yY]*) ;; +*) case "$xversion" in + *[13579]) + cat >&4 <<EOH +*** WHOA THERE!!! *** + + This is an UNSTABLE DEVELOPMENT release. + The version of this $package distribution is $xversion, that is, odd, + (as opposed to even) and that signifies a development release. + If you want a maintenance release, you want an even-numbered version. + + Do ***NOT*** install this into production use. + Data corruption and crashes are possible. + + It is most seriously suggested that you do not continue any further + unless you want to help in developing and debugging Perl. + + If you *still* want to build perl, you can answer 'y' now, + or pass -Dusedevel to Configure. + +EOH + rp='Do you really want to continue?' + dflt='n' + . ./myread + case "$ans" in + [yY]) echo >&4 "Okay, continuing." ;; + *) echo >&4 "Okay, bye." + exit 1 + ;; + esac + ;; + esac + ;; +esac + : general instructions needman=true firsttime=true @@ -1801,7 +1880,7 @@ Much effort has been expended to ensure that this shell script will run on any Unix system. If despite that it blows up on yours, your best bet is to edit Configure and run it again. If you can't run Configure for some reason, you'll have to generate a config.sh file by hand. Whatever problems you -have, let me (perlbug@perl.com) know how I blew it. +have, let me (perlbug@perl.org) know how I blew it. This installation script affects things in two ways: @@ -1887,6 +1966,7 @@ uniq trylist=" Mcc ar +bison byacc cpp csh @@ -1986,6 +2066,7 @@ test) *) if `sh -c "PATH= test true" >/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 @@ -2022,6 +2103,66 @@ FOO ;; esac +cat <<EOS >checkcc +$startsh +EOS +cat <<'EOSC' >>checkcc +case "$cc" in +'') ;; +*) $rm -f try try.* + $cat >try.c <<EOM +int main(int argc, char *argv[]) { + return 0; +} +EOM + if $cc -o try $ccflags try.c; then + : + else + echo "Uh-oh, the C compiler '$cc' doesn't seem to be working." >&4 + despair=yes + trygcc=yes + case "$cc" in + *gcc*) trygcc=no ;; + esac + case "`$cc -v -c try.c 2>&1`" in + *gcc*) trygcc=no ;; + esac + if $test X"$trygcc" = Xyes; then + if gcc -o try -c try.c; then + echo " " + echo "You seem to have a working gcc, though." >&4 + rp="Would you like to use it?" + dflt=y + if $test -f myread; then + . ./myread + else + if $test -f UU/myread; then + . ./UU/myread + else + echo "Cannot find myread, sorry. Aborting." >&2 + exit 1 + fi + fi + case "$ans" in + [yY]*) cc=gcc; ccname=gcc; ccflags=''; despair=no ;; + esac + fi + fi + if $test X"$despair" = Xyes; then + $cat >&4 <<EOM +You need to find a working C compiler. +Either (purchase and) install the C compiler supplied by your OS vendor, +or for a free C compiler try http://gcc.gnu.org/ +I cannot continue any further, aborting. +EOM + exit 1 + fi + fi + $rm -f try try.* + ;; +esac +EOSC + : determine whether symbolic links are supported echo " " $touch blurfl @@ -2034,6 +2175,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/cond.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 @@ -2136,7 +2364,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" @@ -2154,6 +2385,7 @@ if test -f config.sh; then ;; esac fi +. ./UU/checkcc if test ! -f config.sh; then $cat <<EOM @@ -2164,7 +2396,7 @@ EOM (cd $src/hints; ls -C *.sh) | $sed 's/\.sh/ /g' >&4 dflt='' : Half the following guesses are probably wrong... If you have better - : tests or hints, please send them to perlbug@perl.com + : tests or hints, please send them to perlbug@perl.org : The metaconfig authors would also appreciate a copy... $test -f /irix && osname=irix $test -f /xenix && osname=sco_xenix @@ -2300,6 +2532,7 @@ EOM esac ;; next*) osname=next ;; + nonstop-ux) osname=nonstopux ;; POSIX-BC | posix-bc ) osname=posix-bc osvers="$3" ;; @@ -2541,7 +2774,6 @@ cd UU ;; esac test "$override" && . ./optdef.sh -myuname="$newmyuname" : Restore computed paths for file in $loclist $trylist; do @@ -2702,6 +2934,19 @@ EOM ;; esac +case "$useithreads$use5005threads" in +"$define$define") + $cat >&4 <<EOM + +You cannot have both the ithreads and the 5.005 threads enabled +at the same time. Disabling the 5.005 threads since they are +much less stable than the ithreads. + +EOM + use5005threads="$undef" + ;; +esac + case "$d_oldpthreads" in '') : Configure tests would be welcome here. For now, assume undef. val="$undef" ;; @@ -2758,170 +3003,6 @@ esac set usemultiplicity eval $setvar -: determine where manual pages are on this system -echo " " -case "$sysman" in -'') - syspath='/usr/man/man1 /usr/man/mann /usr/man/manl /usr/man/local/man1' - syspath="$syspath /usr/man/u_man/man1 /usr/share/man/man1" - syspath="$syspath /usr/catman/u_man/man1 /usr/man/l_man/man1" - syspath="$syspath /usr/local/man/u_man/man1 /usr/local/man/l_man/man1" - syspath="$syspath /usr/man/man.L /local/man/man1 /usr/local/man/man1" - sysman=`./loc . /usr/man/man1 $syspath` - ;; -esac -if $test -d "$sysman"; then - echo "System manual is in $sysman." >&4 -else - echo "Could not find manual pages in source form." >&4 -fi - -: see what memory models we can support -case "$models" in -'') - $cat >pdp11.c <<'EOP' -int main() { -#ifdef pdp11 - exit(0); -#else - exit(1); -#endif -} -EOP - ( cc -o pdp11 pdp11.c ) >/dev/null 2>&1 - if $test -f pdp11 && ./pdp11 2>/dev/null; then - dflt='unsplit split' - else - tans=`./loc . X /lib/small /lib/large /usr/lib/small /usr/lib/large /lib/medium /usr/lib/medium /lib/huge` - case "$tans" in - X) dflt='none';; - *) if $test -d /lib/small || $test -d /usr/lib/small; then - dflt='small' - else - dflt='' - fi - if $test -d /lib/medium || $test -d /usr/lib/medium; then - dflt="$dflt medium" - fi - if $test -d /lib/large || $test -d /usr/lib/large; then - dflt="$dflt large" - fi - if $test -d /lib/huge || $test -d /usr/lib/huge; then - dflt="$dflt huge" - fi - esac - fi;; -*) dflt="$models";; -esac -$cat <<EOM - -Some systems have different model sizes. On most systems they are called -small, medium, large, and huge. On the PDP11 they are called unsplit and -split. If your system doesn't support different memory models, say "none". -If you wish to force everything to one memory model, say "none" here and -put the appropriate flags later when it asks you for other cc and ld flags. -Venix systems may wish to put "none" and let the compiler figure things out. -(In the following question multiple model names should be space separated.) - -The default for most systems is "none". - -EOM -rp="Which memory models are supported?" -. ./myread -models="$ans" - -case "$models" in -none) - small='' - medium='' - large='' - huge='' - unsplit='' - split='' - ;; -*split) - case "$split" in - '') if $contains '\-i' $sysman/ld.1 >/dev/null 2>&1 || \ - $contains '\-i' $sysman/cc.1 >/dev/null 2>&1; then - dflt='-i' - else - dflt='none' - fi;; - *) dflt="$split";; - esac - rp="What flag indicates separate I and D space?" - . ./myread - tans="$ans" - case "$tans" in - none) tans='';; - esac - split="$tans" - unsplit='';; -*large*|*small*|*medium*|*huge*) - case "$models" in - *large*) - case "$large" in - '') dflt='-Ml';; - *) dflt="$large";; - esac - rp="What flag indicates large model?" - . ./myread - tans="$ans" - case "$tans" in - none) tans=''; - esac - large="$tans";; - *) large='';; - esac - case "$models" in - *huge*) case "$huge" in - '') dflt='-Mh';; - *) dflt="$huge";; - esac - rp="What flag indicates huge model?" - . ./myread - tans="$ans" - case "$tans" in - none) tans=''; - esac - huge="$tans";; - *) huge="$large";; - esac - case "$models" in - *medium*) case "$medium" in - '') dflt='-Mm';; - *) dflt="$medium";; - esac - rp="What flag indicates medium model?" - . ./myread - tans="$ans" - case "$tans" in - none) tans=''; - esac - medium="$tans";; - *) medium="$large";; - esac - case "$models" in - *small*) case "$small" in - '') dflt='none';; - *) dflt="$small";; - esac - rp="What flag indicates small model?" - . ./myread - tans="$ans" - case "$tans" in - none) tans=''; - esac - small="$tans";; - *) small='';; - esac - ;; -*) - echo "Unrecognized memory models--you may have to edit Makefile.SH" >&4 - ;; -esac -$rm -f pdp11.* pdp11 - : make some quick guesses about what we are up against echo " " $echo $n "Hmm... $c" @@ -2939,7 +3020,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..." @@ -2978,12 +3059,15 @@ EOI ;; esac : Detect OS2. The p_ variable is set above in the Head.U unit. +: Note that this also -- wrongly -- detects e.g. dos-djgpp, which also uses +: semicolon as a patch separator case "$p_" in :) ;; *) $cat <<'EOI' I have the feeling something is not exactly right, however...don't tell me... lemme think...does HAL ring a bell?...no, of course, you're only running OS/2! +(Or you may be running DOS with DJGPP.) EOI echo exit 0 >os2 ;; @@ -3014,57 +3098,21 @@ chmod +x bsd usg v7 osf1 eunice xenix venix os2 $eunicefix bsd usg v7 osf1 eunice xenix venix os2 $rm -f foo -: see if we need a special compiler -echo " " -if ./usg; then - case "$cc" in - '') case "$Mcc" in - /*) dflt='Mcc';; - *) case "$large" in - -M*) dflt='cc';; - *) if $contains '\-M' $sysman/cc.1 >/dev/null 2>&1 ; then - if $contains '\-M' $sysman/cpp.1 >/dev/null 2>&1; then - dflt='cc' - else - dflt='cc -M' - fi - else - dflt='cc' - fi;; - esac;; - esac;; - *) dflt="$cc";; - esac - case "$dflt" in - *M*) $cat <<'EOM' -On some older systems the default C compiler will not resolve multiple global -references that happen to have the same name. On some such systems the "Mcc" -command may be used to force these to be resolved. On other systems a "cc -M" -command is required. (Note that the -M flag on other systems indicates a -memory model to use!) If you have the Gnu C compiler, you might wish to use -that instead. - -EOM - ;; - esac - rp="Use which C compiler?" - . ./myread - cc="$ans" -else - case "$cc" in - '') dflt=cc;; - *) dflt="$cc";; - esac - rp="Use which C compiler?" - . ./myread - cc="$ans" -fi +case "$cc" in +'') dflt=cc;; +*) dflt="$cc";; +esac +rp="Use which C compiler?" +. ./myread +cc="$ans" : Look for a hint-file generated 'call-back-unit'. Now that the : user has specified the compiler, we may need to set or change some : other defaults. if $test -f cc.cbu; then . ./cc.cbu fi +. ./checkcc + echo " " echo "Checking for GNU cc in disguise and/or its version number..." >&4 $cat >gccvers.c <<EOM @@ -3080,11 +3128,12 @@ int main() { exit(0); } EOM -if $cc $ldflags -o gccvers gccvers.c; then +if $cc -o gccvers $ccflags $ldflags gccvers.c; then gccversion=`./gccvers` case "$gccversion" in '') echo "You are not using GNU cc." ;; *) echo "You are using GNU cc $gccversion." + ccname=gcc ;; esac else @@ -3102,6 +3151,188 @@ $rm -f gccvers* case "$gccversion" in 1*) cpp=`./loc gcc-cpp $cpp $pth` ;; esac +case "$gccversion" in +'') gccosandvers='' ;; +*) gccshortvers=`echo "$gccversion"|sed 's/ .*//'` + gccosandvers=`$cc -v 2>&1|grep '/specs$'|sed "s!.*/[^-/]*-[^-/]*-\([^-/]*\)/$gccshortvers/specs!\1!"` + gccshortvers='' + case "$gccosandvers" in + $osname) gccosandvers='' ;; # linux gccs seem to have no linux osvers, grr + $osname$osvers) ;; # looking good + $osname*) cat <<EOM >&4 + +*** WHOA THERE!!! *** + + Your gcc has not been compiled for the exact release of + your operating system ($gccosandvers versus $osname$osvers). + + In general it is a good idea to keep gcc synchronized with + the operating system because otherwise serious problems + may ensue when trying to compile software, like Perl. + + I'm trying to be optimistic here, though, and will continue. + If later during the configuration and build icky compilation + problems appear (headerfile conflicts being the most common + manifestation), I suggest reinstalling the gcc to match + your operating system release. + +EOM + ;; + *) gccosandvers='' ;; # failed to parse, better be silent + esac + ;; +esac +case "$ccname" in +'') ccname="$cc" ;; +esac + +: see how we invoke the C preprocessor +echo " " +echo "Now, how can we feed standard input to your C preprocessor..." >&4 +cat <<'EOT' >testcpp.c +#define ABC abc +#define XYZ xyz +ABC.XYZ +EOT +cd .. +if test ! -f cppstdin; then + if test "X$osname" = "Xaix" -a "X$gccversion" = X; then + # AIX cc -E doesn't show the absolute headerfile + # locations but we'll cheat by using the -M flag. + echo 'cat >.$$.c; rm -f .$$.u; '"$cc"' ${1+"$@"} -M -c .$$.c 2>/dev/null; test -s .$$.u && awk '"'"'$2 ~ /\.h$/ { print "# 0 \""$2"\"" }'"'"' .$$.u; rm -f .$$.o .$$.u; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' > cppstdin + else + echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin + fi +else + echo "Keeping your $hint cppstdin wrapper." +fi +chmod 755 cppstdin +wrapper=`pwd`/cppstdin +ok='false' +cd UU + +if $test "X$cppstdin" != "X" && \ + $cppstdin $cppminus <testcpp.c >testcpp.out 2>&1 && \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 +then + echo "You used to use $cppstdin $cppminus so we'll use that again." + case "$cpprun" in + '') echo "But let's see if we can live without a wrapper..." ;; + *) + if $cpprun $cpplast <testcpp.c >testcpp.out 2>&1 && \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 + then + echo "(And we'll use $cpprun $cpplast to preprocess directly.)" + ok='true' + else + echo "(However, $cpprun $cpplast does not work, let's see...)" + fi + ;; + esac +else + case "$cppstdin" in + '') ;; + *) + echo "Good old $cppstdin $cppminus does not seem to be of any help..." + ;; + esac +fi + +if $ok; then + : nothing +elif echo 'Maybe "'"$cc"' -E" will work...'; \ + $cc -E <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Yup, it does." + x_cpp="$cc -E" + x_minus=''; +elif echo 'Nope...maybe "'"$cc"' -E -" will work...'; \ + $cc -E - <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Yup, it does." + x_cpp="$cc -E" + x_minus='-'; +elif echo 'Nope...maybe "'"$cc"' -P" will work...'; \ + $cc -P <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Yipee, that works!" + x_cpp="$cc -P" + x_minus=''; +elif echo 'Nope...maybe "'"$cc"' -P -" will work...'; \ + $cc -P - <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "At long last!" + x_cpp="$cc -P" + x_minus='-'; +elif echo 'No such luck, maybe "'$cpp'" will work...'; \ + $cpp <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "It works!" + x_cpp="$cpp" + x_minus=''; +elif echo 'Nixed again...maybe "'$cpp' -" will work...'; \ + $cpp - <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Hooray, it works! I was beginning to wonder." + x_cpp="$cpp" + x_minus='-'; +elif echo 'Uh-uh. Time to get fancy. Trying a wrapper...'; \ + $wrapper <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + x_cpp="$wrapper" + x_minus='' + echo "Eureka!" +else + dflt='' + rp="No dice. I can't find a C preprocessor. Name one:" + . ./myread + x_cpp="$ans" + x_minus='' + $x_cpp <testcpp.c >testcpp.out 2>&1 + if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "OK, that will do." >&4 + else +echo "Sorry, I can't get that to work. Go find one and rerun Configure." >&4 + exit 1 + fi +fi + +case "$ok" in +false) + cppstdin="$x_cpp" + cppminus="$x_minus" + cpprun="$x_cpp" + cpplast="$x_minus" + set X $x_cpp + shift + case "$1" in + "$cpp") + echo "Perhaps can we force $cc -E using a wrapper..." + if $wrapper <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 + then + echo "Yup, we can." + cppstdin="$wrapper" + cppminus=''; + else + echo "Nope, we'll have to live without it..." + fi + ;; + esac + case "$cpprun" in + "$wrapper") + cpprun='' + cpplast='' + ;; + esac + ;; +esac + +case "$cppstdin" in +"$wrapper"|'cppstdin') ;; +*) $rm -f $wrapper;; +esac +$rm -f testcpp.c testcpp.out : decide how portable to be. Allow command line overrides. case "$d_portable" in @@ -3169,7 +3400,7 @@ esac case "$fn" in *\(*) - expr $fn : '.*(\(.*\)).*' | tr ',' $trnl >getfile.ok + expr $fn : '.*(\(.*\)).*' | $tr ',' $trnl >getfile.ok fn=`echo $fn | sed 's/(.*)//'` ;; esac @@ -3268,6 +3499,7 @@ while test "$type"; do true) case "$ansexp" in /*) value="$ansexp" ;; + [a-zA-Z]:/*) value="$ansexp" ;; *) redo=true case "$already" in @@ -3395,7 +3627,7 @@ if $test -f /bin/mips && /bin/mips; then /bsd43 #endif EOCP - if $cc -E usr.c > usr.out && $contains / usr.out >/dev/null 2>&1; then + if cc -E usr.c > usr.out && $contains / usr.out >/dev/null 2>&1; then dflt='/bsd43/usr/include' incpath='/bsd43' mips_type='BSD 4.3' @@ -3428,154 +3660,6 @@ y) fn=d/ ;; esac -: see how we invoke the C preprocessor -echo " " -echo "Now, how can we feed standard input to your C preprocessor..." >&4 -cat <<'EOT' >testcpp.c -#define ABC abc -#define XYZ xyz -ABC.XYZ -EOT -cd .. -if test ! -f cppstdin; then - if test "X$osname" = "Xaix" -a "X$gccversion" = X; then - # AIX cc -E doesn't show the absolute headerfile - # locations but we'll cheat by using the -M flag. - echo 'cat >.$$.c; rm -f .$$.u; '"$cc"' ${1+"$@"} -M -c .$$.c 2>/dev/null; test -s .$$.u && awk '"'"'$2 ~ /\.h$/ { print "# 0 \""$2"\"" }'"'"' .$$.u; rm -f .$$.o .$$.u; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' > cppstdin - else - echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin - fi -else - echo "Keeping your $hint cppstdin wrapper." -fi -chmod 755 cppstdin -wrapper=`pwd`/cppstdin -ok='false' -cd UU - -if $test "X$cppstdin" != "X" && \ - $cppstdin $cppminus <testcpp.c >testcpp.out 2>&1 && \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 -then - echo "You used to use $cppstdin $cppminus so we'll use that again." - case "$cpprun" in - '') echo "But let's see if we can live without a wrapper..." ;; - *) - if $cpprun $cpplast <testcpp.c >testcpp.out 2>&1 && \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 - then - echo "(And we'll use $cpprun $cpplast to preprocess directly.)" - ok='true' - else - echo "(However, $cpprun $cpplast does not work, let's see...)" - fi - ;; - esac -else - case "$cppstdin" in - '') ;; - *) - echo "Good old $cppstdin $cppminus does not seem to be of any help..." - ;; - esac -fi - -if $ok; then - : nothing -elif echo 'Maybe "'"$cc"' -E" will work...'; \ - $cc -E <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Yup, it does." - x_cpp="$cc -E" - x_minus=''; -elif echo 'Nope...maybe "'"$cc"' -E -" will work...'; \ - $cc -E - <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Yup, it does." - x_cpp="$cc -E" - x_minus='-'; -elif echo 'Nope...maybe "'"$cc"' -P" will work...'; \ - $cc -P <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Yipee, that works!" - x_cpp="$cc -P" - x_minus=''; -elif echo 'Nope...maybe "'"$cc"' -P -" will work...'; \ - $cc -P - <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "At long last!" - x_cpp="$cc -P" - x_minus='-'; -elif echo 'No such luck, maybe "'$cpp'" will work...'; \ - $cpp <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "It works!" - x_cpp="$cpp" - x_minus=''; -elif echo 'Nixed again...maybe "'$cpp' -" will work...'; \ - $cpp - <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Hooray, it works! I was beginning to wonder." - x_cpp="$cpp" - x_minus='-'; -elif echo 'Uh-uh. Time to get fancy. Trying a wrapper...'; \ - $wrapper <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - x_cpp="$wrapper" - x_minus='' - echo "Eureka!" -else - dflt='' - rp="No dice. I can't find a C preprocessor. Name one:" - . ./myread - x_cpp="$ans" - x_minus='' - $x_cpp <testcpp.c >testcpp.out 2>&1 - if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "OK, that will do." >&4 - else -echo "Sorry, I can't get that to work. Go find one and rerun Configure." >&4 - exit 1 - fi -fi - -case "$ok" in -false) - cppstdin="$x_cpp" - cppminus="$x_minus" - cpprun="$x_cpp" - cpplast="$x_minus" - set X $x_cpp - shift - case "$1" in - "$cpp") - echo "Perhaps can we force $cc -E using a wrapper..." - if $wrapper <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 - then - echo "Yup, we can." - cppstdin="$wrapper" - cppminus=''; - else - echo "Nope, we'll have to live without it..." - fi - ;; - esac - case "$cpprun" in - "$wrapper") - cpprun='' - cpplast='' - ;; - esac - ;; -esac - -case "$cppstdin" in -"$wrapper"|'cppstdin') ;; -*) $rm -f $wrapper;; -esac -$rm -f testcpp.c testcpp.out - : Set private lib path case "$plibpth" in '') if ./mips; then @@ -3882,8 +3966,8 @@ for thisincl in $inclwanted; do if $test -d $thisincl; then if $test x$thisincl != x$usrinc; then case "$dflt" in - *$thisincl*);; - *) dflt="$dflt -I$thisincl";; + *" -I$thisincl "*);; + *) dflt="$dflt -I$thisincl ";; esac fi fi @@ -3919,6 +4003,7 @@ esac case "$dflt" in ''|' ') dflt=none;; esac + $cat <<EOH Your C compiler may want other flags. For this question you should include @@ -4051,7 +4136,7 @@ $cat > try.c <<'EOF' #include <stdio.h> int main() { printf("Ok\n"); exit(0); } EOF -set X $cc $optimize $ccflags -o try $ldflags try.c $libs +set X $cc -o try $optimize $ccflags $ldflags try.c $libs shift $cat >try.msg <<'EOM' I've tried to compile and run the following simple program: @@ -4070,8 +4155,8 @@ and I got the following output: EOM dflt=y -if sh -c "$cc $optimize $ccflags -o try $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 ;; @@ -4182,12 +4267,12 @@ esac' compile=' mc_file=$1; shift; -$cc $optimize $ccflags $ldflags -o ${mc_file} $* ${mc_file}.c $libs > /dev/null 2>&1;' +$cc -o ${mc_file} $optimize $ccflags $ldflags $* ${mc_file}.c $libs > /dev/null 2>&1;' : define a shorthand compile call for compilations that should be ok. compile_ok=' mc_file=$1; shift; -$cc $optimize $ccflags $ldflags -o ${mc_file} $* ${mc_file}.c $libs;' +$cc -o ${mc_file} $optimize $ccflags $ldflags $* ${mc_file}.c $libs;' : check for lengths of integral types echo " " @@ -4592,6 +4677,601 @@ case "$use64bitall" in ;; esac +echo " " +echo "Checking for GNU C Library..." >&4 +cat >gnulibc.c <<EOM +#include <stdio.h> +int main() +{ +#ifdef __GLIBC__ + exit(0); +#else + exit(1); +#endif +} +EOM +set gnulibc +if eval $compile_ok && ./gnulibc; then + val="$define" + echo "You are using the GNU C Library" +else + val="$undef" + echo "You are not using the GNU C Library" +fi +$rm -f gnulibc* +set d_gnulibc +eval $setvar + +: see if nm is to be used to determine whether a symbol is defined or not +case "$usenm" in +'') + dflt='' + case "$d_gnulibc" in + "$define") + echo " " + echo "nm probably won't work on the GNU C Library." >&4 + dflt=n + ;; + esac + case "$dflt" in + '') + if $test "$osname" = aix -a ! -f /lib/syscalls.exp; then + echo " " + echo "Whoops! This is an AIX system without /lib/syscalls.exp!" >&4 + echo "'nm' won't be sufficient on this sytem." >&4 + dflt=n + fi + ;; + esac + case "$dflt" in + '') dflt=`$egrep 'inlibc|csym' $rsrc/Configure | wc -l 2>/dev/null` + if $test $dflt -gt 20; then + dflt=y + else + dflt=n + fi + ;; + esac + ;; +*) + case "$usenm" in + true|$define) dflt=y;; + *) dflt=n;; + esac + ;; +esac +$cat <<EOM + +I can use $nm to extract the symbols from your C libraries. This +is a time consuming task which may generate huge output on the disk (up +to 3 megabytes) but that should make the symbols extraction faster. The +alternative is to skip the 'nm' extraction part and to compile a small +test program instead to determine whether each symbol is present. If +you have a fast C compiler and/or if your 'nm' output cannot be parsed, +this may be the best solution. + +You probably shouldn't let me use 'nm' if you are using the GNU C Library. + +EOM +rp="Shall I use $nm to extract C symbols from the libraries?" +. ./myread +case "$ans" in +[Nn]*) usenm=false;; +*) usenm=true;; +esac + +runnm=$usenm +case "$reuseval" in +true) runnm=false;; +esac + +: nm options which may be necessary +case "$nm_opt" in +'') if $test -f /mach_boot; then + nm_opt='' # Mach + elif $test -d /usr/ccs/lib; then + nm_opt='-p' # Solaris (and SunOS?) + elif $test -f /dgux; then + nm_opt='-p' # DG-UX + elif $test -f /lib64/rld; then + nm_opt='-p' # 64-bit Irix + else + nm_opt='' + fi;; +esac + +: nm options which may be necessary for shared libraries but illegal +: for archive libraries. Thank you, Linux. +case "$nm_so_opt" in +'') case "$myuname" in + *linux*) + if $nm --help | $grep 'dynamic' > /dev/null 2>&1; then + nm_so_opt='--dynamic' + fi + ;; + esac + ;; +esac + +case "$runnm" in +true) +: get list of predefined functions in a handy place +echo " " +case "$libc" in +'') libc=unknown + case "$libs" in + *-lc_s*) libc=`./loc libc_s$_a $libc $libpth` + esac + ;; +esac +libnames=''; +case "$libs" in +'') ;; +*) for thislib in $libs; do + case "$thislib" in + -lc|-lc_s) + : Handle C library specially below. + ;; + -l*) + thislib=`echo $thislib | $sed -e 's/^-l//'` + if try=`./loc lib$thislib.$so.'*' X $libpth`; $test -f "$try"; then + : + elif try=`./loc lib$thislib.$so X $libpth`; $test -f "$try"; then + : + elif try=`./loc lib$thislib$_a X $libpth`; $test -f "$try"; then + : + elif try=`./loc $thislib$_a X $libpth`; $test -f "$try"; then + : + elif try=`./loc lib$thislib X $libpth`; $test -f "$try"; then + : + elif try=`./loc $thislib X $libpth`; $test -f "$try"; then + : + elif try=`./loc Slib$thislib$_a X $xlibpth`; $test -f "$try"; then + : + else + try='' + fi + libnames="$libnames $try" + ;; + *) libnames="$libnames $thislib" ;; + esac + done + ;; +esac +xxx=normal +case "$libc" in +unknown) + set /lib/libc.$so + for xxx in $libpth; do + $test -r $1 || set $xxx/libc.$so + : The messy sed command sorts on library version numbers. + $test -r $1 || \ + set `echo blurfl; echo $xxx/libc.$so.[0-9]* | \ + tr ' ' $trnl | egrep -v '\.[A-Za-z]*$' | $sed -e ' + h + s/[0-9][0-9]*/0000&/g + s/0*\([0-9][0-9][0-9][0-9][0-9]\)/\1/g + G + s/\n/ /' | \ + $sort | $sed -e 's/^.* //'` + eval set \$$# + done + $test -r $1 || set /usr/ccs/lib/libc.$so + $test -r $1 || set /lib/libsys_s$_a + ;; +*) + set blurfl + ;; +esac +if $test -r "$1"; then + echo "Your (shared) C library seems to be in $1." + libc="$1" +elif $test -r /lib/libc && $test -r /lib/clib; then + echo "Your C library seems to be in both /lib/clib and /lib/libc." + xxx=apollo + libc='/lib/clib /lib/libc' + if $test -r /lib/syslib; then + echo "(Your math library is in /lib/syslib.)" + libc="$libc /lib/syslib" + fi +elif $test -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then + echo "Your C library seems to be in $libc, as you said before." +elif $test -r $incpath/usr/lib/libc$_a; then + libc=$incpath/usr/lib/libc$_a; + echo "Your C library seems to be in $libc. That's fine." +elif $test -r /lib/libc$_a; then + libc=/lib/libc$_a; + echo "Your C library seems to be in $libc. You're normal." +else + if tans=`./loc libc$_a blurfl/dyick $libpth`; $test -r "$tans"; then + : + elif tans=`./loc libc blurfl/dyick $libpth`; $test -r "$tans"; then + libnames="$libnames "`./loc clib blurfl/dyick $libpth` + elif tans=`./loc clib blurfl/dyick $libpth`; $test -r "$tans"; then + : + elif tans=`./loc Slibc$_a blurfl/dyick $xlibpth`; $test -r "$tans"; then + : + elif tans=`./loc Mlibc$_a blurfl/dyick $xlibpth`; $test -r "$tans"; then + : + else + tans=`./loc Llibc$_a blurfl/dyick $xlibpth` + fi + if $test -r "$tans"; then + echo "Your C library seems to be in $tans, of all places." + libc=$tans + else + libc='blurfl' + fi +fi +if $test $xxx = apollo -o -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then + dflt="$libc" + cat <<EOM + +If the guess above is wrong (which it might be if you're using a strange +compiler, or your machine supports multiple models), you can override it here. + +EOM +else + dflt='' + echo $libpth | $tr ' ' $trnl | $sort | $uniq > libpath + cat >&4 <<EOM +I can't seem to find your C library. I've looked in the following places: + +EOM + $sed 's/^/ /' libpath + cat <<EOM + +None of these seems to contain your C library. I need to get its name... + +EOM +fi +fn=f +rp='Where is your C library?' +. ./getfile +libc="$ans" + +echo " " +echo $libc $libnames | $tr ' ' $trnl | $sort | $uniq > libnames +set X `cat libnames` +shift +xxx=files +case $# in 1) xxx=file; esac +echo "Extracting names from the following $xxx for later perusal:" >&4 +echo " " +$sed 's/^/ /' libnames >&4 +echo " " +$echo $n "This may take a while...$c" >&4 + +for file in $*; do + case $file in + *$so*) $nm $nm_so_opt $nm_opt $file 2>/dev/null;; + *) $nm $nm_opt $file 2>/dev/null;; + esac +done >libc.tmp + +$echo $n ".$c" +$grep fprintf libc.tmp > libc.ptf +xscan='eval "<libc.ptf $com >libc.list"; $echo $n ".$c" >&4' +xrun='eval "<libc.tmp $com >libc.list"; echo "done" >&4' +xxx='[ADTSIW]' +if com="$sed -n -e 's/__IO//' -e 's/^.* $xxx *_[_.]*//p' -e 's/^.* $xxx *//p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e 's/^__*//' -e 's/^\([a-zA-Z_0-9$]*\).*xtern.*/\1/p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e '/|UNDEF/d' -e '/FUNC..GL/s/^.*|__*//p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e 's/^.* D __*//p' -e 's/^.* D //p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e 's/^_//' -e 's/^\([a-zA-Z_0-9]*\).*xtern.*text.*/\1/p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$grep '|' | $sed -n -e '/|COMMON/d' -e '/|DATA/d' \ + -e '/ file/d' -e 's/^\([^ ]*\).*/\1/p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p' -e 's/^.*|FUNC |WEAK .*|//p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e 's/^__//' -e '/|Undef/d' -e '/|Proc/s/ .*//p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e 's/^.*|Proc .*|Text *| *//p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e '/Def. Text/s/.* \([^ ]*\)\$/\1/p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e 's/^[-0-9a-f ]*_\(.*\)=.*/\1/p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e 's/.*\.text n\ \ \ \.//p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="sed -n -e 's/^__.*//' -e 's/[ ]*D[ ]*[0-9]*.*//p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +else + $nm -p $* 2>/dev/null >libc.tmp + $grep fprintf libc.tmp > libc.ptf + if com="$sed -n -e 's/^.* [ADTSIW] *_[_.]*//p' -e 's/^.* [ADTSIW] //p'";\ + eval $xscan; $contains '^fprintf$' libc.list >/dev/null 2>&1 + then + nm_opt='-p' + eval $xrun + else + echo " " + echo "$nm didn't seem to work right. Trying $ar instead..." >&4 + com='' + if $ar t $libc > libc.tmp && $contains '^fprintf$' libc.tmp >/dev/null 2>&1; then + for thisname in $libnames $libc; do + $ar t $thisname >>libc.tmp + done + $sed -e "s/\\$_o\$//" < libc.tmp > libc.list + echo "Ok." >&4 + elif test "X$osname" = "Xos2" && $ar tv $libc > libc.tmp; then + # Repeat libc to extract forwarders to DLL entries too + for thisname in $libnames $libc; do + $ar tv $thisname >>libc.tmp + # Revision 50 of EMX has bug in $ar. + # it will not extract forwarders to DLL entries + # Use emximp which will extract exactly them. + emximp -o tmp.imp $thisname \ + 2>/dev/null && \ + $sed -e 's/^\([_a-zA-Z0-9]*\) .*$/\1/p' \ + < tmp.imp >>libc.tmp + $rm tmp.imp + done + $sed -e "s/\\$_o\$//" -e 's/^ \+//' < libc.tmp > libc.list + echo "Ok." >&4 + else + echo "$ar didn't seem to work right." >&4 + echo "Maybe this is a Cray...trying bld instead..." >&4 + if bld t $libc | $sed -e 's/.*\///' -e "s/\\$_o:.*\$//" > libc.list + then + for thisname in $libnames; do + bld t $libnames | \ + $sed -e 's/.*\///' -e "s/\\$_o:.*\$//" >>libc.list + $ar t $thisname >>libc.tmp + done + echo "Ok." >&4 + else + echo "That didn't work either. Giving up." >&4 + exit 1 + fi + fi + fi +fi +nm_extract="$com" +if $test -f /lib/syscalls.exp; then + echo " " + echo "Also extracting names from /lib/syscalls.exp for good ole AIX..." >&4 + $sed -n 's/^\([^ ]*\)[ ]*syscall[0-9]*$/\1/p' /lib/syscalls.exp >>libc.list +fi +;; +esac +$rm -f libnames libpath + +: is a C symbol defined? +csym='tlook=$1; +case "$3" in +-v) tf=libc.tmp; tc=""; tdc="";; +-a) tf=libc.tmp; tc="[0]"; tdc="[]";; +*) tlook="^$1\$"; tf=libc.list; tc="()"; tdc="()";; +esac; +tx=yes; +case "$reuseval-$4" in +true-) ;; +true-*) tx=no; eval "tval=\$$4"; case "$tval" in "") tx=yes;; esac;; +esac; +case "$tx" in +yes) + case "$runnm" in + true) + if $contains $tlook $tf >/dev/null 2>&1; + then tval=true; + else tval=false; + fi;; + *) + echo "int main() { extern short $1$tdc; printf(\"%hd\", $1$tc); }" > t.c; + if $cc -o t $optimize $ccflags $ldflags t.c $libs >/dev/null 2>&1; + then tval=true; + else tval=false; + fi; + $rm -f t t.c;; + esac;; +*) + case "$tval" in + $define) tval=true;; + *) tval=false;; + esac;; +esac; +eval "$2=$tval"' + +: define an is-in-libc? function +inlibc='echo " "; td=$define; tu=$undef; +sym=$1; var=$2; eval "was=\$$2"; +tx=yes; +case "$reuseval$was" in +true) ;; +true*) tx=no;; +esac; +case "$tx" in +yes) + set $sym tres -f; + eval $csym; + case "$tres" in + true) + echo "$sym() found." >&4; + case "$was" in $undef) . ./whoa; esac; eval "$var=\$td";; + *) + echo "$sym() NOT found." >&4; + case "$was" in $define) . ./whoa; esac; eval "$var=\$tu";; + esac;; +*) + case "$was" in + $define) echo "$sym() found." >&4;; + *) echo "$sym() NOT found." >&4;; + esac;; +esac' + +: see if sqrtl exists +set sqrtl d_sqrtl +eval $inlibc + +case "$ccflags" in +*-DUSE_LONG_DOUBLE*|*-DUSE_MORE_BITS*) uselongdouble="$define" ;; +esac + +case "$uselongdouble" in +$define|true|[yY]*) dflt='y';; +*) dflt='n';; +esac +cat <<EOM + +Perl can be built to take advantage of long doubles which +(if available) may give more accuracy and range for floating point numbers. + +If this doesn't make any sense to you, just accept the default '$dflt'. +EOM +rp='Try to use long doubles if available?' +. ./myread +case "$ans" in +y|Y) val="$define" ;; +*) val="$undef" ;; +esac +set uselongdouble +eval $setvar + +case "$uselongdouble" in +true|[yY]*) uselongdouble="$define" ;; +esac + +case "$uselongdouble" in +$define) +: Look for a hint-file generated 'call-back-unit'. If the +: user has specified that long doubles should be used, +: we may need to set or change some other defaults. + if $test -f uselongdouble.cbu; then + echo "Your platform has some specific hints for long doubles, using them..." + . ./uselongdouble.cbu + else + $cat <<EOM +(Your platform doesn't have any specific hints for long doubles.) +EOM + fi + ;; +esac + +case "$uselongdouble:$d_sqrtl" in +$define:$undef) + $cat <<EOM >&4 + +*** You requested the use of long doubles but you do not seem to have +*** the mathematic functions for long doubles. I'm disabling the use +*** of long doubles. + +EOM + uselongdouble=$undef + ;; +esac + +: check for length of double +echo " " +case "$doublesize" in +'') + echo "Checking to see how big your double precision numbers are..." >&4 + $cat >try.c <<'EOCP' +#include <stdio.h> +int main() +{ + printf("%d\n", (int)sizeof(double)); + exit(0); +} +EOCP + set try + if eval $compile_ok; then + doublesize=`./try` + echo "Your double is $doublesize bytes long." + else + dflt='8' + echo "(I can't seem to compile the test program. Guessing...)" + rp="What is the size of a double precision number (in bytes)?" + . ./myread + doublesize="$ans" + fi + ;; +esac +$rm -f try.c try + +: check for long doubles +echo " " +echo "Checking to see if you have long double..." >&4 +echo 'int main() { long double x = 7.0; }' > try.c +set try +if eval $compile; then + val="$define" + echo "You have long double." +else + val="$undef" + echo "You do not have long double." +fi +$rm try.* +set d_longdbl +eval $setvar + +: check for length of long double +case "${d_longdbl}${longdblsize}" in +$define) + echo " " + echo "Checking to see how big your long doubles are..." >&4 + $cat >try.c <<'EOCP' +#include <stdio.h> +int main() +{ + printf("%d\n", sizeof(long double)); +} +EOCP + set try + set try + if eval $compile; then + longdblsize=`./try$exe_ext` + echo "Your long doubles are $longdblsize bytes long." + else + dflt='8' + echo " " + echo "(I can't seem to compile the test program. Guessing...)" >&4 + rp="What is the size of a long double (in bytes)?" + . ./myread + longdblsize="$ans" + fi + if $test "X$doublesize" = "X$longdblsize"; then + echo "(That isn't any different from an ordinary double.)" + fi + ;; +esac +$rm -f try.* try + : determine the architecture name echo " " if xxx=`./loc arch blurfl $pth`; $test -f "$xxx"; then @@ -4646,12 +5326,19 @@ $define) esac ;; esac -case "$use64bitint" in -$define) +case "$use64bitint$use64bitall" in +*"$define"*) case "$archname64" in '') + echo "This architecture is naturally 64-bit, not changing architecture name." >&4 ;; *) + case "$use64bitint" in + "$define") echo "64 bit integers selected." >&4 ;; + esac + case "$use64bitall" in + "$define") echo "Maximal 64 bitness selected." >&4 ;; + esac case "$archname" in *-$archname64*) echo "...and architecture name already has $archname64." >&4 ;; @@ -4662,6 +5349,37 @@ $define) ;; esac esac +case "$uselongdouble" in +$define) + echo "Long doubles selected." >&4 + case "$longdblsize" in + $doublesize) + "...but long doubles are equal to doubles, not changing architecture name." >&4 + ;; + *) + case "$archname" in + *-ld*) echo "...and architecture name already has -ld." >&4 + ;; + *) archname="$archname-ld" + echo "...setting architecture name to $archname." >&4 + ;; + esac + ;; + esac + ;; +esac +case "$useperlio" in +$define) + echo "Perlio selected." >&4 + case "$archname" in + *-perlio*) echo "...and architecture name already has -perlio." >&4 + ;; + *) archname="$archname-perlio" + echo "...setting architecture name to $archname." >&4 + ;; + esac + ;; +esac : determine root of directory hierarchy where package will be installed. case "$prefix" in @@ -4795,10 +5513,7 @@ else api_version=0 api_subversion=0 fi -$echo $n "(You have $package revision $revision" $c -$echo $n " patchlevel $patchlevel" $c -test 0 -eq "$subversion" || $echo $n " subversion $subversion" $c -echo ".)" +$echo "(You have $package version $patchlevel subversion $subversion.)" case "$osname" in dos|vms) : XXX Should be a Configure test for double-dots in filenames. @@ -5245,6 +5960,108 @@ echo "Your system uses $freetype free(), it would seem." >&4 $rm -f malloc.[co] $cat <<EOM +After $package is installed, you may wish to install various +add-on modules and utilities. Typically, these add-ons will +be installed under $prefix with the rest +of this package. However, you may wish to install such add-ons +elsewhere under a different prefix. + +If you do not wish to put everything under a single prefix, that's +ok. You will be prompted for the individual locations; this siteprefix +is only used to suggest the defaults. + +The default should be fine for most people. + +EOM +fn=d~+ +rp='Installation prefix to use for add-on modules and utilities?' +: XXX Here might be another good place for an installstyle setting. +case "$siteprefix" in +'') dflt=$prefix ;; +*) dflt=$siteprefix ;; +esac +. ./getfile +: XXX Prefixit unit does not yet support siteprefix and vendorprefix +oldsiteprefix='' +case "$siteprefix" in +'') ;; +*) case "$ans" in + "$prefix") ;; + *) oldsiteprefix="$prefix";; + esac + ;; +esac +siteprefix="$ans" +siteprefixexp="$ansexp" + +: determine where site specific libraries go. +: Usual default is /usr/local/lib/perl5/site_perl/$version +: The default "style" setting is made in installstyle.U +: XXX No longer works with Prefixit stuff. +prog=`echo $package | $sed 's/-*[0-9.]*$//'` +case "$sitelib" in +'') case "$installstyle" in + *lib/perl5*) dflt=$siteprefix/lib/$package/site_$prog/$version ;; + *) dflt=$siteprefix/lib/site_$prog/$version ;; + esac + ;; +*) dflt="$sitelib" + ;; +esac +$cat <<EOM + +The installation process will create a directory for +site-specific extensions and modules. Most users find it convenient +to place all site-specific files in this directory rather than in the +main distribution directory. + +EOM +fn=d~+ +rp='Pathname for the site-specific library files?' +. ./getfile +sitelib="$ans" +sitelibexp="$ansexp" +sitelib_stem=`echo "$sitelibexp" | sed "s,/$version$,,"` +: Change installation prefix, if necessary. +if $test X"$prefix" != X"$installprefix"; then + installsitelib=`echo $sitelibexp | $sed "s#^$prefix#$installprefix#"` +else + installsitelib="$sitelibexp" +fi + +: determine where site specific architecture-dependent libraries go. +: sitelib default is /usr/local/lib/perl5/site_perl/$version +: sitearch default is /usr/local/lib/perl5/site_perl/$version/$archname +: sitelib may have an optional trailing /share. +case "$sitearch" in +'') dflt=`echo $sitelib | $sed 's,/share$,,'` + dflt="$dflt/$archname" + ;; +*) dflt="$sitearch" + ;; +esac +set sitearch sitearch none +eval $prefixit +$cat <<EOM + +The installation process will also create a directory for +architecture-dependent site-specific extensions and modules. + +EOM +fn=d~+ +rp='Pathname for the site-specific architecture-dependent library files?' +. ./getfile +sitearch="$ans" +sitearchexp="$ansexp" +: Change installation prefix, if necessary. +if $test X"$prefix" != X"$installprefix"; then + installsitearch=`echo $sitearchexp | sed "s#^$prefix#$installprefix#"` +else + installsitearch="$sitearchexp" +fi + +$cat <<EOM + The installation process will also create a directory for vendor-supplied add-ons. Vendors who supply perl with their system may find it convenient to place all vendor-supplied files in this @@ -5363,6 +6180,41 @@ else installvendorarch="$vendorarchexp" fi +: Final catch-all directories to search +$cat <<EOM + +Lastly, you can have perl look in other directories for extensions and +modules in addition to those already specified. +These directories will be searched after + $sitearch + $sitelib +EOM +test X"$vendorlib" != "X" && echo ' ' $vendorlib +test X"$vendorarch" != "X" && echo ' ' $vendorarch +echo ' ' +case "$otherlibdirs" in +''|' ') dflt='none' ;; +*) dflt="$otherlibdirs" ;; +esac +$cat <<EOM +Enter a colon-separated set of extra paths to include in perl's @INC +search path, or enter 'none' for no extra paths. + +EOM + +rp='Colon-separated list of additional directories for perl to search?' +. ./myread +case "$ans" in +' '|''|none) otherlibdirs=' ' ;; +*) otherlibdirs="$ans" ;; +esac +case "$otherlibdirs" in +' ') val=$undef ;; +*) val=$define ;; +esac +set d_perl_otherlibdirs +eval $setvar + : Cruising for prototypes echo " " echo "Checking out function prototypes..." >&4 @@ -5446,90 +6298,18 @@ case "$perl5" in *) echo "Using $perl5." ;; esac -$cat <<EOM - -After $package is installed, you may wish to install various -add-on modules and utilities. Typically, these add-ons will -be installed under $prefix with the rest -of this package. However, you may wish to install such add-ons -elsewhere under a different prefix. - -If you do not wish to put everything under a single prefix, that's -ok. You will be prompted for the individual locations; this siteprefix -is only used to suggest the defaults. - -The default should be fine for most people. - -EOM -fn=d~+ -rp='Installation prefix to use for add-on modules and utilities?' -: XXX Here might be another good place for an installstyle setting. -case "$siteprefix" in -'') dflt=$prefix ;; -*) dflt=$siteprefix ;; -esac -. ./getfile -: XXX Prefixit unit does not yet support siteprefix and vendorprefix -oldsiteprefix='' -case "$siteprefix" in -'') ;; -*) case "$ans" in - "$prefix") ;; - *) oldsiteprefix="$prefix";; - esac - ;; -esac -siteprefix="$ans" -siteprefixexp="$ansexp" - -: determine where site specific libraries go. -: Usual default is /usr/local/lib/perl5/site_perl/$version -: The default "style" setting is made in installstyle.U -: XXX No longer works with Prefixit stuff. -prog=`echo $package | $sed 's/-*[0-9.]*$//'` -case "$sitelib" in -'') case "$installstyle" in - *lib/perl5*) dflt=$siteprefix/lib/$package/site_$prog/$version ;; - *) dflt=$siteprefix/lib/site_$prog/$version ;; - esac - ;; -*) dflt="$sitelib" - ;; -esac -$cat <<EOM - -The installation process will create a directory for -site-specific extensions and modules. Most users find it convenient -to place all site-specific files in this directory rather than in the -main distribution directory. - -EOM -fn=d~+ -rp='Pathname for the site-specific library files?' -. ./getfile -sitelib="$ans" -sitelibexp="$ansexp" -sitelib_stem=`echo "$sitelibexp" | sed "s,/$version$,,"` -: Change installation prefix, if necessary. -if $test X"$prefix" != X"$installprefix"; then - installsitelib=`echo $sitelibexp | $sed "s#^$prefix#$installprefix#"` -else - installsitelib="$sitelibexp" -fi - : Determine list of previous versions to include in @INC $cat > getverlist <<EOPL #!$perl5 -w use File::Basename; \$api_versionstring = "$api_versionstring"; \$version = "$version"; -\$sitelib = "$sitelib"; +\$stem = "$sitelib_stem"; \$archname = "$archname"; EOPL $cat >> getverlist <<'EOPL' # Can't have leading @ because metaconfig interprets it as a command! ;@inc_version_list=(); -$stem=dirname($sitelib); # XXX Redo to do opendir/readdir? if (-d $stem) { chdir($stem); @@ -5582,6 +6362,13 @@ esac case "$dflt" in ''|' ') dflt=none ;; esac +case "$dflt" in +5.005) case "$bincompat5005" in + $define|true|[yY]*) ;; + *) dflt=none ;; + esac + ;; +esac $cat <<'EOM' In order to ease the process of upgrading, this version of perl @@ -5636,468 +6423,10 @@ fi set installusrbinperl eval $setvar -echo " " -echo "Checking for GNU C Library..." >&4 -cat >gnulibc.c <<EOM -#include <stdio.h> -int main() -{ -#ifdef __GLIBC__ - exit(0); -#else - exit(1); -#endif -} -EOM -set gnulibc -if eval $compile_ok && ./gnulibc; then - val="$define" - echo "You are using the GNU C Library" -else - val="$undef" - echo "You are not using the GNU C Library" -fi -$rm -f gnulibc* -set d_gnulibc -eval $setvar - -: see if nm is to be used to determine whether a symbol is defined or not -case "$usenm" in -'') - dflt='' - case "$d_gnulibc" in - "$define") - echo " " - echo "nm probably won't work on the GNU C Library." >&4 - dflt=n - ;; - esac - case "$dflt" in - '') - if $test "$osname" = aix -a ! -f /lib/syscalls.exp; then - echo " " - echo "Whoops! This is an AIX system without /lib/syscalls.exp!" >&4 - echo "'nm' won't be sufficient on this sytem." >&4 - dflt=n - fi - ;; - esac - case "$dflt" in - '') dflt=`$egrep 'inlibc|csym' $rsrc/Configure | wc -l 2>/dev/null` - if $test $dflt -gt 20; then - dflt=y - else - dflt=n - fi - ;; - esac - ;; -*) - case "$usenm" in - true|$define) dflt=y;; - *) dflt=n;; - esac - ;; -esac -$cat <<EOM - -I can use $nm to extract the symbols from your C libraries. This -is a time consuming task which may generate huge output on the disk (up -to 3 megabytes) but that should make the symbols extraction faster. The -alternative is to skip the 'nm' extraction part and to compile a small -test program instead to determine whether each symbol is present. If -you have a fast C compiler and/or if your 'nm' output cannot be parsed, -this may be the best solution. - -You probably shouldn't let me use 'nm' if you are using the GNU C Library. - -EOM -rp="Shall I use $nm to extract C symbols from the libraries?" -. ./myread -case "$ans" in -[Nn]*) usenm=false;; -*) usenm=true;; -esac - -runnm=$usenm -case "$reuseval" in -true) runnm=false;; -esac - -: nm options which may be necessary -case "$nm_opt" in -'') if $test -f /mach_boot; then - nm_opt='' # Mach - elif $test -d /usr/ccs/lib; then - nm_opt='-p' # Solaris (and SunOS?) - elif $test -f /dgux; then - nm_opt='-p' # DG-UX - elif $test -f /lib64/rld; then - nm_opt='-p' # 64-bit Irix - else - nm_opt='' - fi;; -esac - -: nm options which may be necessary for shared libraries but illegal -: for archive libraries. Thank you, Linux. -case "$nm_so_opt" in -'') case "$myuname" in - *linux*) - if $nm --help | $grep 'dynamic' > /dev/null 2>&1; then - nm_so_opt='--dynamic' - fi - ;; - esac - ;; -esac - -case "$runnm" in -true) -: get list of predefined functions in a handy place -echo " " -case "$libc" in -'') libc=unknown - case "$libs" in - *-lc_s*) libc=`./loc libc_s$_a $libc $libpth` - esac - ;; -esac -libnames=''; -case "$libs" in -'') ;; -*) for thislib in $libs; do - case "$thislib" in - -lc|-lc_s) - : Handle C library specially below. - ;; - -l*) - thislib=`echo $thislib | $sed -e 's/^-l//'` - if try=`./loc lib$thislib.$so.'*' X $libpth`; $test -f "$try"; then - : - elif try=`./loc lib$thislib.$so X $libpth`; $test -f "$try"; then - : - elif try=`./loc lib$thislib$_a X $libpth`; $test -f "$try"; then - : - elif try=`./loc $thislib$_a X $libpth`; $test -f "$try"; then - : - elif try=`./loc lib$thislib X $libpth`; $test -f "$try"; then - : - elif try=`./loc $thislib X $libpth`; $test -f "$try"; then - : - elif try=`./loc Slib$thislib$_a X $xlibpth`; $test -f "$try"; then - : - else - try='' - fi - libnames="$libnames $try" - ;; - *) libnames="$libnames $thislib" ;; - esac - done - ;; -esac -xxx=normal -case "$libc" in -unknown) - set /lib/libc.$so - for xxx in $libpth; do - $test -r $1 || set $xxx/libc.$so - : The messy sed command sorts on library version numbers. - $test -r $1 || \ - set `echo blurfl; echo $xxx/libc.$so.[0-9]* | \ - tr ' ' $trnl | egrep -v '\.[A-Za-z]*$' | $sed -e ' - h - s/[0-9][0-9]*/0000&/g - s/0*\([0-9][0-9][0-9][0-9][0-9]\)/\1/g - G - s/\n/ /' | \ - sort | $sed -e 's/^.* //'` - eval set \$$# - done - $test -r $1 || set /usr/ccs/lib/libc.$so - $test -r $1 || set /lib/libsys_s$_a - ;; -*) - set blurfl - ;; -esac -if $test -r "$1"; then - echo "Your (shared) C library seems to be in $1." - libc="$1" -elif $test -r /lib/libc && $test -r /lib/clib; then - echo "Your C library seems to be in both /lib/clib and /lib/libc." - xxx=apollo - libc='/lib/clib /lib/libc' - if $test -r /lib/syslib; then - echo "(Your math library is in /lib/syslib.)" - libc="$libc /lib/syslib" - fi -elif $test -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then - echo "Your C library seems to be in $libc, as you said before." -elif $test -r $incpath/usr/lib/libc$_a; then - libc=$incpath/usr/lib/libc$_a; - echo "Your C library seems to be in $libc. That's fine." -elif $test -r /lib/libc$_a; then - libc=/lib/libc$_a; - echo "Your C library seems to be in $libc. You're normal." -else - if tans=`./loc libc$_a blurfl/dyick $libpth`; $test -r "$tans"; then - : - elif tans=`./loc libc blurfl/dyick $libpth`; $test -r "$tans"; then - libnames="$libnames "`./loc clib blurfl/dyick $libpth` - elif tans=`./loc clib blurfl/dyick $libpth`; $test -r "$tans"; then - : - elif tans=`./loc Slibc$_a blurfl/dyick $xlibpth`; $test -r "$tans"; then - : - elif tans=`./loc Mlibc$_a blurfl/dyick $xlibpth`; $test -r "$tans"; then - : - else - tans=`./loc Llibc$_a blurfl/dyick $xlibpth` - fi - if $test -r "$tans"; then - echo "Your C library seems to be in $tans, of all places." - libc=$tans - else - libc='blurfl' - fi -fi -if $test $xxx = apollo -o -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then - dflt="$libc" - cat <<EOM - -If the guess above is wrong (which it might be if you're using a strange -compiler, or your machine supports multiple models), you can override it here. - -EOM -else - dflt='' - echo $libpth | tr ' ' $trnl | sort | uniq > libpath - cat >&4 <<EOM -I can't seem to find your C library. I've looked in the following places: - -EOM - $sed 's/^/ /' libpath - cat <<EOM - -None of these seems to contain your C library. I need to get its name... - -EOM -fi -fn=f -rp='Where is your C library?' -. ./getfile -libc="$ans" - -echo " " -echo $libc $libnames | tr ' ' $trnl | sort | uniq > libnames -set X `cat libnames` -shift -xxx=files -case $# in 1) xxx=file; esac -echo "Extracting names from the following $xxx for later perusal:" >&4 -echo " " -$sed 's/^/ /' libnames >&4 -echo " " -$echo $n "This may take a while...$c" >&4 - -for file in $*; do - case $file in - *$so*) $nm $nm_so_opt $nm_opt $file 2>/dev/null;; - *) $nm $nm_opt $file 2>/dev/null;; - esac -done >libc.tmp - -$echo $n ".$c" -$grep fprintf libc.tmp > libc.ptf -xscan='eval "<libc.ptf $com >libc.list"; $echo $n ".$c" >&4' -xrun='eval "<libc.tmp $com >libc.list"; echo "done" >&4' -xxx='[ADTSIW]' -if com="$sed -n -e 's/__IO//' -e 's/^.* $xxx *_[_.]*//p' -e 's/^.* $xxx *//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^__*//' -e 's/^\([a-zA-Z_0-9$]*\).*xtern.*/\1/p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e '/|UNDEF/d' -e '/FUNC..GL/s/^.*|__*//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^.* D __*//p' -e 's/^.* D //p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^_//' -e 's/^\([a-zA-Z_0-9]*\).*xtern.*text.*/\1/p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$grep '|' | $sed -n -e '/|COMMON/d' -e '/|DATA/d' \ - -e '/ file/d' -e 's/^\([^ ]*\).*/\1/p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p' -e 's/^.*|FUNC |WEAK .*|//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^__//' -e '/|Undef/d' -e '/|Proc/s/ .*//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^.*|Proc .*|Text *| *//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e '/Def. Text/s/.* \([^ ]*\)\$/\1/p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^[-0-9a-f ]*_\(.*\)=.*/\1/p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/.*\.text n\ \ \ \.//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="sed -n -e 's/^__.*//' -e 's/[ ]*D[ ]*[0-9]*.*//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -else - $nm -p $* 2>/dev/null >libc.tmp - $grep fprintf libc.tmp > libc.ptf - if com="$sed -n -e 's/^.* [ADTSIW] *_[_.]*//p' -e 's/^.* [ADTSIW] //p'";\ - eval $xscan; $contains '^fprintf$' libc.list >/dev/null 2>&1 - then - nm_opt='-p' - eval $xrun - else - echo " " - echo "$nm didn't seem to work right. Trying $ar instead..." >&4 - com='' - if $ar t $libc > libc.tmp && $contains '^fprintf$' libc.tmp >/dev/null 2>&1; then - for thisname in $libnames $libc; do - $ar t $thisname >>libc.tmp - done - $sed -e "s/\\$_o\$//" < libc.tmp > libc.list - echo "Ok." >&4 - elif test "X$osname" = "Xos2" && $ar tv $libc > libc.tmp; then - # Repeat libc to extract forwarders to DLL entries too - for thisname in $libnames $libc; do - $ar tv $thisname >>libc.tmp - # Revision 50 of EMX has bug in $ar. - # it will not extract forwarders to DLL entries - # Use emximp which will extract exactly them. - emximp -o tmp.imp $thisname \ - 2>/dev/null && \ - $sed -e 's/^\([_a-zA-Z0-9]*\) .*$/\1/p' \ - < tmp.imp >>libc.tmp - $rm tmp.imp - done - $sed -e "s/\\$_o\$//" -e 's/^ \+//' < libc.tmp > libc.list - echo "Ok." >&4 - else - echo "$ar didn't seem to work right." >&4 - echo "Maybe this is a Cray...trying bld instead..." >&4 - if bld t $libc | $sed -e 's/.*\///' -e "s/\\$_o:.*\$//" > libc.list - then - for thisname in $libnames; do - bld t $libnames | \ - $sed -e 's/.*\///' -e "s/\\$_o:.*\$//" >>libc.list - $ar t $thisname >>libc.tmp - done - echo "Ok." >&4 - else - echo "That didn't work either. Giving up." >&4 - exit 1 - fi - fi - fi -fi -nm_extract="$com" -if $test -f /lib/syscalls.exp; then - echo " " - echo "Also extracting names from /lib/syscalls.exp for good ole AIX..." >&4 - $sed -n 's/^\([^ ]*\)[ ]*syscall[0-9]*$/\1/p' /lib/syscalls.exp >>libc.list -fi -;; -esac -$rm -f libnames libpath - : see if dld is available set dld.h i_dld eval $inhdr -: is a C symbol defined? -csym='tlook=$1; -case "$3" in --v) tf=libc.tmp; tc=""; tdc="";; --a) tf=libc.tmp; tc="[0]"; tdc="[]";; -*) tlook="^$1\$"; tf=libc.list; tc="()"; tdc="()";; -esac; -tx=yes; -case "$reuseval-$4" in -true-) ;; -true-*) tx=no; eval "tval=\$$4"; case "$tval" in "") tx=yes;; esac;; -esac; -case "$tx" in -yes) - case "$runnm" in - true) - if $contains $tlook $tf >/dev/null 2>&1; - then tval=true; - else tval=false; - fi;; - *) - echo "int main() { extern short $1$tdc; printf(\"%hd\", $1$tc); }" > t.c; - if $cc $optimize $ccflags $ldflags -o t t.c $libs >/dev/null 2>&1; - then tval=true; - else tval=false; - fi; - $rm -f t t.c;; - esac;; -*) - case "$tval" in - $define) tval=true;; - *) tval=false;; - esac;; -esac; -eval "$2=$tval"' - -: define an is-in-libc? function -inlibc='echo " "; td=$define; tu=$undef; -sym=$1; var=$2; eval "was=\$$2"; -tx=yes; -case "$reuseval$was" in -true) ;; -true*) tx=no;; -esac; -case "$tx" in -yes) - set $sym tres -f; - eval $csym; - case "$tres" in - true) - echo "$sym() found." >&4; - case "$was" in $undef) . ./whoa; esac; eval "$var=\$td";; - *) - echo "$sym() NOT found." >&4; - case "$was" in $define) . ./whoa; esac; eval "$var=\$tu";; - esac;; -*) - case "$was" in - $define) echo "$sym() found." >&4;; - *) echo "$sym() NOT found." >&4;; - esac;; -esac' - : see if dlopen exists xxx_runnm="$runnm" runnm=false @@ -6173,13 +6502,13 @@ EOM hpux) dflt='+z' ;; next) dflt='none' ;; irix*) dflt='-KPIC' ;; - svr4*|esix*|solaris) dflt='-KPIC' ;; + svr4*|esix*|solaris|nonstopux) dflt='-KPIC' ;; sunos) dflt='-pic' ;; *) dflt='none' ;; esac ;; *) case "$osname" in - svr4*|esix*|solaris) dflt='-fPIC' ;; + svr4*|esix*|solaris|nonstopux) dflt='-fPIC' ;; *) dflt='-fpic' ;; esac ;; esac ;; @@ -6255,7 +6584,7 @@ EOM next) dflt='none' ;; solaris) dflt='-G' ;; sunos) dflt='-assert nodefinitions' ;; - svr4*|esix*) dflt="-G $ldflags" ;; + svr4*|esix*|nonstopux) dflt="-G $ldflags" ;; *) dflt='none' ;; esac ;; @@ -6269,7 +6598,7 @@ EOM esac for thisflag in $ldflags; do case "$thisflag" in - -L*) + -L*|-R*) case " $dflt " in *" $thisflag "*) ;; *) dflt="$dflt $thisflag" ;; @@ -6330,7 +6659,7 @@ $undef) ;; *) case "$useshrplib" in '') case "$osname" in - svr4*|dgux|dynixptx|esix|powerux|beos|cygwin*) + svr4*|nonstopux|dgux|dynixptx|esix|powerux|beos|cygwin*) dflt=y also='Building a shared libperl is required for dynamic loading to work on your system.' ;; @@ -6444,7 +6773,7 @@ case "$shrpdir" in *) $cat >&4 <<EOM WARNING: Use of the shrpdir variable for the installation location of the shared $libperl is not supported. It was never documented and -will not work in this version. Let me (perlbug@perl.com) +will not work in this version. Let me (perlbug@perl.org) know of any problems this may cause. EOM @@ -6535,6 +6864,24 @@ case "$ldlibpthname" in none) ldlibpthname='' ;; esac +: determine where manual pages are on this system +echo " " +case "$sysman" in +'') + syspath='/usr/man/man1 /usr/man/mann /usr/man/manl /usr/man/local/man1' + syspath="$syspath /usr/man/u_man/man1 /usr/share/man/man1" + syspath="$syspath /usr/catman/u_man/man1 /usr/man/l_man/man1" + syspath="$syspath /usr/local/man/u_man/man1 /usr/local/man/l_man/man1" + syspath="$syspath /usr/man/man.L /local/man/man1 /usr/local/man/man1" + sysman=`./loc . /usr/man/man1 $syspath` + ;; +esac +if $test -d "$sysman"; then + echo "System manual is in $sysman." >&4 +else + echo "Could not find manual pages in source form." >&4 +fi + : determine where manual pages go set man1dir man1dir none eval $prefixit @@ -6901,18 +7248,23 @@ case "$myhostname" in /[ ]$myhostname[ . ]/p" > hosts } tmp_re="[ . ]" - $test x`$awk "/[0-9].*[ ]$myhostname$tmp_re/ { sum++ } + if $test -f hosts; then + $test x`$awk "/[0-9].*[ ]$myhostname$tmp_re/ { sum++ } END { print sum }" hosts` = x1 || tmp_re="[ ]" - dflt=.`$awk "/[0-9].*[ ]$myhostname$tmp_re/ {for(i=2; i<=NF;i++) print \\\$i}" \ - hosts | $sort | $uniq | \ - $sed -n -e "s/$myhostname\.\([-a-zA-Z0-9_.]\)/\1/p"` - case `$echo X$dflt` in - X*\ *) echo "(Several hosts in /etc/hosts matched hostname)" + dflt=.`$awk "/[0-9].*[ ]$myhostname$tmp_re/ {for(i=2; i<=NF;i++) print \\\$i}" \ + hosts | $sort | $uniq | \ + $sed -n -e "s/$myhostname\.\([-a-zA-Z0-9_.]\)/\1/p"` + case `$echo X$dflt` in + X*\ *) echo "(Several hosts in the database matched hostname)" + dflt=. + ;; + X.) echo "(You do not have fully-qualified names in the hosts database)" + ;; + esac + else + echo "(I cannot locate a hosts database anywhere)" dflt=. - ;; - X.) echo "(You do not have fully-qualified names in /etc/hosts)" - ;; - esac + fi case "$dflt" in .) tans=`./loc resolv.conf X /etc /usr/etc` @@ -6939,6 +7291,11 @@ case "$myhostname" in esac ;; esac + case "$dflt$osname" in + .os390) echo "(Attempting domain name extraction from //'SYS1.TCPPARMS(TCPDATA)')" + dflt=.`awk '/^DOMAINORIGIN/ {print $2}' "//'SYS1.TCPPARMS(TCPDATA)'" 2>/dev/null` + ;; + esac case "$dflt" in .) echo "(Lost all hope -- silly guess then)" dflt='.uucp' @@ -7028,7 +7385,7 @@ $cat <<EOM If you or somebody else will be maintaining perl at your site, please fill in the correct e-mail address here so that they may be contacted if necessary. Currently, the "perlbug" program included with perl -will send mail to this address in addition to perlbug@perl.com. You may +will send mail to this address in addition to perlbug@perl.org. You may enter "none" for no administrator. EOM @@ -7040,6 +7397,25 @@ rp='Perl administrator e-mail address' . ./myread perladmin="$ans" +: determine whether to only install version-specific parts. +echo " " +$cat <<EOM +Do you want to install only the version-specific parts of the perl +distribution? Usually you do *not* want to do this. +EOM +case "$versiononly" in +"$define"|[Yy]*|true) dflt='y' ;; +*) dflt='n'; +esac +rp="Do you want to install only the version-specific parts of perl?" +. ./myread +case "$ans" in +[yY]*) val="$define";; +*) val="$undef" ;; +esac +set versiononly +eval $setvar + : figure out how to guarantee perl startup case "$startperl" in '') @@ -7054,7 +7430,10 @@ want to share those scripts and perl is not in a standard place a shell by starting the script with a single ':' character. EOH - dflt="$binexp/perl" + case "$versiononly" in + "$define") dflt="$binexp/perl$version";; + *) dflt="$binexp/perl";; + esac rp='What shall I put after the #! to start up perl ("none" to not use #!)?' . ./myread case "$ans" in @@ -7147,37 +7526,6 @@ else installscript="$scriptdirexp" fi -: determine where site specific architecture-dependent libraries go. -: sitelib default is /usr/local/lib/perl5/site_perl/$version -: sitearch default is /usr/local/lib/perl5/site_perl/$version/$archname -: sitelib may have an optional trailing /share. -case "$sitearch" in -'') dflt=`echo $sitelib | $sed 's,/share$,,'` - dflt="$dflt/$archname" - ;; -*) dflt="$sitearch" - ;; -esac -set sitearch sitearch none -eval $prefixit -$cat <<EOM - -The installation process will also create a directory for -architecture-dependent site-specific extensions and modules. - -EOM -fn=d~+ -rp='Pathname for the site-specific architecture-dependent library files?' -. ./getfile -sitearch="$ans" -sitearchexp="$ansexp" -: Change installation prefix, if necessary. -if $test X"$prefix" != X"$installprefix"; then - installsitearch=`echo $sitearchexp | sed "s#^$prefix#$installprefix#"` -else - installsitearch="$sitearchexp" -fi - : determine where add-on public executables go case "$sitebin" in '') dflt=$siteprefix/bin ;; @@ -7195,67 +7543,6 @@ else installsitebin="$sitebinexp" fi -: see if sqrtl exists -set sqrtl d_sqrtl -eval $inlibc - -case "$ccflags" in -*-DUSE_LONG_DOUBLE*|*-DUSE_MORE_BITS*) uselongdouble="$define" ;; -esac - -case "$uselongdouble" in -$define|true|[yY]*) dflt='y';; -*) dflt='n';; -esac -cat <<EOM - -Perl can be built to take advantage of long doubles which -(if available) may give more accuracy and range for floating point numbers. - -If this doesn't make any sense to you, just accept the default '$dflt'. -EOM -rp='Try to use long doubles if available?' -. ./myread -case "$ans" in -y|Y) val="$define" ;; -*) val="$undef" ;; -esac -set uselongdouble -eval $setvar - -case "$uselongdouble" in -true|[yY]*) uselongdouble="$define" ;; -esac - -case "$uselongdouble" in -$define) -: Look for a hint-file generated 'call-back-unit'. If the -: user has specified that long doubles should be used, -: we may need to set or change some other defaults. - if $test -f uselongdouble.cbu; then - echo "Your platform has some specific hints for long doubles, using them..." - . ./uselongdouble.cbu - else - $cat <<EOM -(Your platform doesn't have any specific hints for long doubles.) -EOM - fi - ;; -esac - -case "$uselongdouble:$d_sqrtl" in -$define:$undef) - $cat <<EOM >&4 - -*** You requested the use of long doubles but you do not seem to have -*** the mathematic functions for long doubles. I'm disabling the use -*** of long doubles. - -EOM - uselongdouble=$undef - ;; -esac - case "$useperlio" in $define|true|[yY]*) dflt='y';; *) dflt='n';; @@ -7315,82 +7602,6 @@ fi set qgcvt d_qgcvt eval $inlibc -: check for length of double -echo " " -case "$doublesize" in -'') - echo "Checking to see how big your double precision numbers are..." >&4 - $cat >try.c <<'EOCP' -#include <stdio.h> -int main() -{ - printf("%d\n", (int)sizeof(double)); - exit(0); -} -EOCP - set try - if eval $compile_ok; then - doublesize=`./try` - echo "Your double is $doublesize bytes long." - else - dflt='8' - echo "(I can't seem to compile the test program. Guessing...)" - rp="What is the size of a double precision number (in bytes)?" - . ./myread - doublesize="$ans" - fi - ;; -esac -$rm -f try.c try - -: check for long doubles -echo " " -echo "Checking to see if you have long double..." >&4 -echo 'int main() { long double x = 7.0; }' > try.c -set try -if eval $compile; then - val="$define" - echo "You have long double." -else - val="$undef" - echo "You do not have long double." -fi -$rm try.* -set d_longdbl -eval $setvar - -: check for length of long double -case "${d_longdbl}${longdblsize}" in -$define) - echo " " - echo "Checking to see how big your long doubles are..." >&4 - $cat >try.c <<'EOCP' -#include <stdio.h> -int main() -{ - printf("%d\n", sizeof(long double)); -} -EOCP - set try - set try - if eval $compile; then - longdblsize=`./try$exe_ext` - echo "Your long doubles are $longdblsize bytes long." - else - dflt='8' - echo " " - echo "(I can't seem to compile the test program. Guessing...)" >&4 - rp="What is the size of a long double (in bytes)?" - . ./myread - longdblsize="$ans" - fi - if $test "X$doublesize" = "X$longdblsize"; then - echo "(That isn't any different from an ordinary double.)" - fi - ;; -esac -$rm -f try.* try - echo " " if $test X"$d_longdbl" = X"$define"; then @@ -7412,7 +7623,7 @@ EOCP case "$yyy" in 123.456) sPRIfldbl='"f"'; sPRIgldbl='"g"'; sPRIeldbl='"e"'; - sPRIFldbl='"F"'; sPRIGldbl='"G"'; sPRIEldbl='"E"'; + sPRIFUldbl='"F"'; sPRIGUldbl='"G"'; sPRIEUldbl='"E"'; echo "We will use %f." ;; esac @@ -7434,7 +7645,7 @@ EOCP case "$yyy" in 123.456) sPRIfldbl='"llf"'; sPRIgldbl='"llg"'; sPRIeldbl='"lle"'; - sPRIFldbl='"llF"'; sPRIGldbl='"llG"'; sPRIEldbl='"llE"'; + sPRIFUldbl='"llF"'; sPRIGUldbl='"llG"'; sPRIEUldbl='"llE"'; echo "We will use %llf." ;; esac @@ -7456,7 +7667,7 @@ EOCP case "$yyy" in 123.456) sPRIfldbl='"Lf"'; sPRIgldbl='"Lg"'; sPRIeldbl='"Le"'; - sPRIFldbl='"LF"'; sPRIGldbl='"LG"'; sPRIEldbl='"LE"'; + sPRIFUldbl='"LF"'; sPRIGUldbl='"LG"'; sPRIEUldbl='"LE"'; echo "We will use %Lf." ;; esac @@ -7478,7 +7689,7 @@ EOCP case "$yyy" in 123.456) sPRIfldbl='"lf"'; sPRIgldbl='"lg"'; sPRIeldbl='"le"'; - sPRIFldbl='"lF"'; sPRIGldbl='"lG"'; sPRIEldbl='"lE"'; + sPRIFUldbl='"lF"'; sPRIGUldbl='"lG"'; sPRIEUldbl='"lE"'; echo "We will use %lf." ;; esac @@ -7487,6 +7698,8 @@ fi if $test X"$sPRIfldbl" = X; then echo "Cannot figure out how to print long doubles." >&4 +else + sSCNfldbl=$sPRIfldbl # expect consistency fi $rm -f try try.* @@ -7495,28 +7708,29 @@ fi # d_longdbl case "$sPRIfldbl" in '') d_PRIfldbl="$undef"; d_PRIgldbl="$undef"; d_PRIeldbl="$undef"; - d_PRIFldbl="$undef"; d_PRIGldbl="$undef"; d_PRIEldbl="$undef"; + d_PRIFUldbl="$undef"; d_PRIGUldbl="$undef"; d_PRIEUldbl="$undef"; + d_SCNfldbl="$undef"; ;; *) d_PRIfldbl="$define"; d_PRIgldbl="$define"; d_PRIeldbl="$define"; - d_PRIFldbl="$define"; d_PRIGldbl="$define"; d_PRIEldbl="$define"; + d_PRIFUldbl="$define"; d_PRIGUldbl="$define"; d_PRIEUldbl="$define"; + d_SCNfldbl="$define"; ;; esac : Check how to convert floats to strings. -if test "X$d_Gconvert" = X; then - echo " " - echo "Checking for an efficient way to convert floats to strings." - echo " " > try.c - case "$uselongdouble" in - "$define") echo "#define USE_LONG_DOUBLE" >>try.c ;; - esac - case "$d_longdbl" in - "$define") echo "#define HAS_LONG_DOUBLE" >>try.c ;; - esac - case "$d_PRIgldbl" in - "$define") echo "#define HAS_PRIgldbl" >>try.c ;; - esac - $cat >>try.c <<EOP +echo " " +echo "Checking for an efficient way to convert floats to strings." +echo " " > try.c +case "$uselongdouble" in +"$define") echo "#define USE_LONG_DOUBLE" >>try.c ;; +esac +case "$d_longdbl" in +"$define") echo "#define HAS_LONG_DOUBLE" >>try.c ;; +esac +case "$d_PRIgldbl" in +"$define") echo "#define HAS_PRIgldbl" >>try.c ;; +esac +$cat >>try.c <<EOP #ifdef TRY_gconvert #define Gconvert(x,n,t,b) gconvert((x),(n),(t),(b)) char *myname = "gconvert"; @@ -7611,49 +7825,62 @@ int main() Gconvert((DOUBLETYPE)-100000.0, 8, 0, buf); checkit("-100000", buf); + Gconvert((DOUBLETYPE)123.456, 8, 0, buf); + checkit("123.456", buf); + exit(0); } EOP - case "$d_Gconvert" in - gconvert*) xxx_list='gconvert gcvt sprintf' ;; - gcvt*) xxx_list='gcvt gconvert sprintf' ;; - sprintf*) xxx_list='sprintf gconvert gcvt' ;; - *) xxx_list='gconvert gcvt sprintf' ;; - esac - - case "$d_longdbl$uselongdouble$d_qgcvt" in - "$define$define$define") xxx_list="`echo $xxx_list|sed 's/gcvt/qgcvt gcvt/'`" ;; - esac +case "$d_Gconvert" in +gconvert*) xxx_list='gconvert gcvt sprintf' ;; +gcvt*) xxx_list='gcvt gconvert sprintf' ;; +sprintf*) xxx_list='sprintf gconvert gcvt' ;; +*) xxx_list='gconvert gcvt sprintf' ;; +esac + +case "$d_longdbl$uselongdouble$d_PRIgldbl" in +"$define$define$define") + # for long doubles prefer first qgcvt, then sprintf + xxx_list="`echo $xxx_list|sed s/sprintf//`" + xxx_list="sprintf $xxx_list" + case "$d_qgcvt" in + "$define") xxx_list="qgcvt $xxx_list" ;; + esac + ;; +esac - for xxx_convert in $xxx_list; do - echo "Trying $xxx_convert..." - $rm -f try try$_o - set try -DTRY_$xxx_convert - if eval $compile; then - echo "$xxx_convert() found." >&4 - if ./try; then - echo "I'll use $xxx_convert to convert floats into a string." >&4 - break; - else - echo "...But $xxx_convert didn't work as I expected." - fi +for xxx_convert in $xxx_list; do + echo "Trying $xxx_convert..." + $rm -f try try$_o + set try -DTRY_$xxx_convert + if eval $compile; then + echo "$xxx_convert() found." >&4 + if ./try; then + echo "I'll use $xxx_convert to convert floats into a string." >&4 + break; else - echo "$xxx_convert NOT found." >&4 + echo "...But $xxx_convert didn't work as I expected." fi - done - - case "$xxx_convert" in - gconvert) d_Gconvert='gconvert((x),(n),(t),(b))' ;; - gcvt) d_Gconvert='gcvt((x),(n),(b))' ;; - qgcvt) d_Gconvert='qgcvt((x),(n),(b))' ;; - *) case "$uselongdouble$d_longdbl$d_PRIgldbl" in - "$define$define$define") - d_Gconvert="sprintf((b),\"%.*$sPRIgldbl\",(n),(x))" ;; - *) d_Gconvert='sprintf((b),"%.*g",(n),(x))' ;; - esac - ;; - esac -fi + else + echo "$xxx_convert NOT found." >&4 + fi +done + +case "$xxx_convert" in +gconvert) d_Gconvert='gconvert((x),(n),(t),(b))' ;; +gcvt) d_Gconvert='gcvt((x),(n),(b))' ;; +qgcvt) d_Gconvert='qgcvt((x),(n),(b))' ;; +*) case "$uselongdouble$d_longdbl$d_PRIgldbl" in + "$define$define$define") + d_Gconvert="sprintf((b),\"%.*\"$sPRIgldbl,(n),(x))" ;; + *) d_Gconvert='sprintf((b),"%.*g",(n),(x))' ;; + esac + ;; +esac + +: see if _fwalk exists +set fwalk d__fwalk +eval $inlibc : Initialize h_fcntl h_fcntl=false @@ -7686,15 +7913,15 @@ int main() { EOCP : check sys/file.h first, no particular reason here if $test `./findhdr sys/file.h` && \ - $cc $cppflags -DI_SYS_FILE -o access access.c >/dev/null 2>&1 ; then + $cc -o access $cppflags -DI_SYS_FILE access.c >/dev/null 2>&1 ; then h_sysfile=true; echo "<sys/file.h> defines the *_OK access constants." >&4 elif $test `./findhdr fcntl.h` && \ - $cc $cppflags -DI_FCNTL -o access access.c >/dev/null 2>&1 ; then + $cc -o access $cppflags -DI_FCNTL access.c >/dev/null 2>&1 ; then h_fcntl=true; echo "<fcntl.h> defines the *_OK access constants." >&4 elif $test `./findhdr unistd.h` && \ - $cc $cppflags -DI_UNISTD -o access access.c >/dev/null 2>&1 ; then + $cc -o access $cppflags -DI_UNISTD access.c >/dev/null 2>&1 ; then echo "<unistd.h> defines the *_OK access constants." >&4 else echo "I can't find the four *_OK access constants--I'll use mine." >&4 @@ -7784,10 +8011,10 @@ int main() exit(1); } EOP - if $cc -DTRY_BSD_PGRP $ccflags $ldflags -o set set.c $libs >/dev/null 2>&1 && ./set; then + if $cc -o set -DTRY_BSD_PGRP $ccflags $ldflags set.c $libs >/dev/null 2>&1 && ./set; then echo "You have to use getpgrp(pid) instead of getpgrp()." >&4 val="$define" - elif $cc $ccflags $ldflags -o set set.c $libs >/dev/null 2>&1 && ./set; then + elif $cc -o set $ccflags $ldflags set.c $libs >/dev/null 2>&1 && ./set; then echo "You have to use getpgrp() instead of getpgrp(pid)." >&4 val="$undef" else @@ -7846,10 +8073,10 @@ int main() exit(1); } EOP - if $cc -DTRY_BSD_PGRP $ccflags $ldflags -o set set.c $libs >/dev/null 2>&1 && ./set; then + if $cc -o set -DTRY_BSD_PGRP $ccflags $ldflags set.c $libs >/dev/null 2>&1 && ./set; then echo 'You have to use setpgrp(pid,pgrp) instead of setpgrp().' >&4 val="$define" - elif $cc $ccflags $ldflags -o set set.c $libs >/dev/null 2>&1 && ./set; then + elif $cc -o set $ccflags $ldflags set.c $libs >/dev/null 2>&1 && ./set; then echo 'You have to use setpgrp() instead of setpgrp(pid,pgrp).' >&4 val="$undef" else @@ -8401,8 +8628,8 @@ EOM : Call the object file tmp-dyna.o in case dlext=o. if $cc $ccflags $cccdlflags -c dyna.c > /dev/null 2>&1 && mv dyna${_o} tmp-dyna${_o} > /dev/null 2>&1 && - $ld $lddlflags -o dyna.$dlext tmp-dyna${_o} > /dev/null 2>&1 && - $cc $ccflags -o fred $ldflags $cccdlflags $ccdlflags fred.c $libs > /dev/null 2>&1; then + $ld -o dyna.$dlext $lddlflags tmp-dyna${_o} > /dev/null 2>&1 && + $cc -o fred $ccflags $ldflags $cccdlflags $ccdlflags fred.c $libs > /dev/null 2>&1; then xxx=`./fred` case $xxx in 1) echo "Test program failed using dlopen." >&4 @@ -8481,10 +8708,6 @@ eval $inlibc set endservent d_endsent eval $inlibc -: see if endspent exists -set endspent d_endspent -eval $inlibc - : Locate the flags for 'open()' echo " " $cat >open3.c <<'EOCP' @@ -8645,8 +8868,12 @@ int main() int ret; close(pd[1]); /* Parent reads from pd[0] */ close(pu[0]); /* Parent writes (blocking) to pu[1] */ +#ifdef F_SETFL if (-1 == fcntl(pd[0], F_SETFL, MY_O_NONBLOCK)) exit(1); +#else + exit(4); +#endif signal(SIGALRM, blech); alarm(5); if ((ret = read(pd[0], buf, 1)) > 0) /* Nothing to read! */ @@ -8693,6 +8920,7 @@ EOCP 1) echo "Could not perform non-blocking setting!";; 2) echo "I did a successful read() for something that was not there!";; 3) echo "Hmm... non-blocking I/O does not seem to be working!";; + 4) echo "Could not find F_SETFL!";; *) echo "Something terribly wrong happened during testing.";; esac rd_nodata=`$cat try.ret` @@ -8758,6 +8986,54 @@ eval $inlibc set fcntl d_fcntl eval $inlibc +echo " " +: See if fcntl-based locking works. +$cat >try.c <<'EOCP' +#include <stdlib.h> +#include <unistd.h> +#include <fcntl.h> +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 @@ -9064,6 +9340,10 @@ $rm -f try.* try set d_fpos64_t eval $setvar +: see if frexpl exists +set frexpl d_frexpl +eval $inlibc + hasstruct='varname=$1; struct=$2; shift; shift; while $test $# -ge 2; do case "$1" in @@ -9130,6 +9410,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 @@ -9141,6 +9425,10 @@ esac set getcwd d_getcwd eval $inlibc +: see if getespwnam exists +set getespwnam d_getespwnam +eval $inlibc + : see if getfsstat exists set getfsstat d_getfsstat @@ -9285,6 +9573,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 @@ -9319,6 +9611,10 @@ echo " " set d_getprotoprotos getprotoent $i_netdb netdb.h eval $hasproto +: see if getprpwnam exists +set getprpwnam d_getprpwnam +eval $inlibc + : see if getpwent exists set getpwent d_getpwent eval $inlibc @@ -9341,10 +9637,6 @@ echo " " set d_getservprotos getservent $i_netdb netdb.h eval $hasproto -: see if getspent exists -set getspent d_getspent -eval $inlibc - : see if getspnam exists set getspnam d_getspnam eval $inlibc @@ -9554,6 +9846,14 @@ set d_isascii eval $setvar $rm -f isascii* +: see if isnan exists +set isnan d_isnan +eval $inlibc + +: see if isnanl exists +set isnanl d_isnanl +eval $inlibc + : see if killpg exists set killpg d_killpg eval $inlibc @@ -9636,7 +9936,7 @@ echo 'int main() { long long x = 7; return 0; }' > try.c set try if eval $compile; then val="$define" - echo "You have have long long." + echo "You have long long." else val="$undef" echo "You do not have long long." @@ -9773,6 +10073,10 @@ esac +: see if modfl exists +set modfl d_modfl +eval $inlibc + : see if mprotect exists set mprotect d_mprotect eval $inlibc @@ -9935,6 +10239,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 @@ -10113,31 +10448,64 @@ 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 <<EOP >try.c #include <stdio.h> +#include <sys/types.h> +#include <signal.h> +#ifdef SIGFPE +$volatile int bletched = 0; +$signal_t blech(s) int s; { bletched = 1; } +#endif int main() { - $uvtype k = ($uvtype)~0, l; + $uvtype u = 0; $nvtype d; - l = k; - d = ($nvtype)l; - l = ($uvtype)d; - if (l == k) - printf("preserve\n"); + int n = 8 * $uvsize; + int i; +#ifdef SIGFPE + signal(SIGFPE, blech); +#endif + + for (i = 0; i < n; i++) { + u = u << 1 | ($uvtype)1; + 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 == n) ? -n : i)); exit(0); } EOP set try + +d_nv_preserves_uv="$undef" 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" - ;; + 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 @@ -10655,6 +11023,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 @@ -10972,10 +11345,6 @@ eval $inlibc set setsid d_setsid eval $inlibc -: see if setspent exists -set setspent d_setspent -eval $inlibc - : see if setvbuf exists set setvbuf d_setvbuf eval $inlibc @@ -11004,24 +11373,29 @@ $define) *) dflt='n';; esac echo "$package can use the sfio library, but it is experimental." + case "$useperlio" in + "$undef") + echo "For sfio also the PerlIO abstraction layer is needed." + echo "Earlier you said you wouldn't want that." + ;; + esac rp="You seem to have sfio available, do you want to try using it?" . ./myread case "$ans" in - y|Y) ;; + y|Y) echo "Ok, turning on both sfio and PerlIO, then." + useperlio="$define" + val="$define" + ;; *) echo "Ok, avoiding sfio this time. I'll use stdio instead." val="$undef" - : Remove sfio from list of libraries to use - set `echo X $libs | $sed -e 's/-lsfio / /' -e 's/-lsfio$//'` - shift - libs="$*" - echo "libs = $libs" >&4 ;; esac ;; *) case "$usesfio" in true|$define|[yY]*) - echo "Sorry, cannot find sfio on this machine" >&4 - echo "Ignoring your setting of usesfio=$usesfio" >&4 + echo "Sorry, cannot find sfio on this machine." >&4 + echo "Ignoring your setting of usesfio=$usesfio." >&4 + val="$undef" ;; esac ;; @@ -11032,6 +11406,16 @@ case "$d_sfio" in $define) usesfio='true';; *) usesfio='false';; esac +case "$d_sfio" in +$define) ;; +*) : Remove sfio from list of libraries to use + set `echo X $libs | $sed -e 's/-lsfio / /' -e 's/-lsfio$//'` + shift + libs="$*" + echo "libs = $libs" >&4 +;; +esac + : see if shmctl exists set shmctl d_shmctl @@ -11190,6 +11574,10 @@ set d_sigsetjmp eval $setvar $rm -f try.c try +: see if socks5_init exists +set socks5_init d_socks5_init +eval $inlibc + : see if sys/stat.h is available set sys/stat.h i_sysstat eval $inhdr @@ -11243,7 +11631,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)' @@ -11283,6 +11692,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 <<EOP @@ -11332,6 +11742,93 @@ esac set d_stdio_cnt_lval eval $setvar + +: test whether setting _ptr sets _cnt as a side effect +d_stdio_ptr_lval_sets_cnt="$undef" +d_stdio_ptr_lval_nochange_cnt="$undef" +case "$d_stdio_ptr_lval$d_stdstdio" in +$define$define) + echo "Checking to see what happens if we set the stdio ptr..." >&4 +$cat >try.c <<EOP +#include <stdio.h> +/* 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 <sys/types.h> +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 <stdio.h>\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 @@ -11496,6 +11993,9 @@ EOM #ifdef __hpux #define strtoll __strtoll #endif +#ifdef __EMX__ +#define strtoll _strtoll +#endif #include <stdio.h> extern long long int strtoll(char *s, char **, int); static int bad = 0; @@ -11522,7 +12022,8 @@ int main() { EOCP set try if eval $compile; then - case "`./try`" in + yyy=`./try` + case "$yyy" in ok) echo "Your strtoll() seems to be working okay." ;; *) cat <<EOM >&4 Your strtoll() doesn't seem to be working okay. @@ -11530,6 +12031,9 @@ EOM d_strtoll="$undef" ;; esac + else + echo "(I can't seem to compile the test program--assuming it doesn't)" + d_strtoll="$undef" fi ;; esac @@ -11780,37 +12284,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 @@ -12418,14 +12891,14 @@ val=$undef set tebcdic if eval $compile_ok; then if ./tebcdic; then - echo "You have EBCDIC." >&4 + echo "You seem to speak EBCDIC." >&4 val="$define" else - echo "Nope, no EBCDIC, probably ASCII or some ISO Latin." >&4 + echo "Nope, no EBCDIC, probably ASCII or some ISO Latin. Or UTF8." >&4 fi else echo "I'm unable to compile the test program." >&4 - echo "I'll assume ASCII or some ISO Latin." >&4 + echo "I'll assume ASCII or some ISO Latin. Or UTF8." >&4 fi $rm -f tebcdic.c tebcdic set ebcdic @@ -12833,7 +13306,7 @@ EOCP case "$yyy" in 12345678901) sPRId64='"d"'; sPRIi64='"i"'; sPRIu64='"u"'; - sPRIo64='"o"'; sPRIx64='"x"'; sPRIX64='"X"'; + sPRIo64='"o"'; sPRIx64='"x"'; sPRIXU64='"X"'; echo "We will use %d." ;; esac @@ -12855,7 +13328,7 @@ EOCP case "$yyy" in 12345678901) sPRId64='"ld"'; sPRIi64='"li"'; sPRIu64='"lu"'; - sPRIo64='"lo"'; sPRIx64='"lx"'; sPRIX64='"lX"'; + sPRIo64='"lo"'; sPRIx64='"lx"'; sPRIXU64='"lX"'; echo "We will use %ld." ;; esac @@ -12878,7 +13351,7 @@ EOCP case "$yyy" in 12345678901) sPRId64=PRId64; sPRIi64=PRIi64; sPRIu64=PRIu64; - sPRIo64=PRIo64; sPRIx64=PRIx64; sPRIX64=PRIX64; + sPRIo64=PRIo64; sPRIx64=PRIx64; sPRIXU64=PRIXU64; echo "We will use the C9X style." ;; esac @@ -12890,7 +13363,7 @@ if $test X"$sPRId64" = X -a X"$quadtype" = X"long long"; then #include <sys/types.h> #include <stdio.h> int main() { - long long q = 12345678901LL; /* AIX cc requires the LL prefix. */ + long long q = 12345678901LL; /* AIX cc requires the LL suffix. */ printf("%lld\n", q); } EOCP @@ -12900,7 +13373,7 @@ EOCP case "$yyy" in 12345678901) sPRId64='"lld"'; sPRIi64='"lli"'; sPRIu64='"llu"'; - sPRIo64='"llo"'; sPRIx64='"llx"'; sPRIX64='"llX"'; + sPRIo64='"llo"'; sPRIx64='"llx"'; sPRIXU64='"llX"'; echo "We will use the %lld style." ;; esac @@ -12922,7 +13395,7 @@ EOCP case "$yyy" in 12345678901) sPRId64='"Ld"'; sPRIi64='"Li"'; sPRIu64='"Lu"'; - sPRIo64='"Lo"'; sPRIx64='"Lx"'; sPRIX64='"LX"'; + sPRIo64='"Lo"'; sPRIx64='"Lx"'; sPRIXU64='"LX"'; echo "We will use %Ld." ;; esac @@ -12944,7 +13417,7 @@ EOCP case "$yyy" in 12345678901) sPRId64='"qd"'; sPRIi64='"qi"'; sPRIu64='"qu"'; - sPRIo64='"qo"'; sPRIx64='"qx"'; sPRIX64='"qX"'; + sPRIo64='"qo"'; sPRIx64='"qx"'; sPRIXU64='"qX"'; echo "We will use %qd." ;; esac @@ -12961,10 +13434,10 @@ fi case "$sPRId64" in '') d_PRId64="$undef"; d_PRIi64="$undef"; d_PRIu64="$undef"; - d_PRIo64="$undef"; d_PRIx64="$undef"; d_PRIX64="$undef"; + d_PRIo64="$undef"; d_PRIx64="$undef"; d_PRIXU64="$undef"; ;; *) d_PRId64="$define"; d_PRIi64="$define"; d_PRIu64="$define"; - d_PRIo64="$define"; d_PRIx64="$define"; d_PRIX64="$define"; + d_PRIo64="$define"; d_PRIx64="$define"; d_PRIXU64="$define"; ;; esac @@ -12977,18 +13450,21 @@ if $test X"$ivsize" = X8; then uvuformat="$sPRIu64" uvoformat="$sPRIo64" uvxformat="$sPRIx64" + uvXUformat="$sPRIXU64" else if $test X"$ivsize" = X"$longsize"; then ivdformat='"ld"' uvuformat='"lu"' uvoformat='"lo"' uvxformat='"lx"' + uvXUformat='"lX"' else if $test X"$ivsize" = X"$intsize"; then ivdformat='"d"' uvuformat='"u"' uvoformat='"o"' uvxformat='"x"' + uvXUformat='"X"' else : far out if $test X"$ivsize" = X"$shortsize"; then @@ -12996,11 +13472,28 @@ else uvuformat='"hu"' uvoformat='"ho"' uvxformat='"hx"' + uvXUformat='"hX"' fi fi fi fi +if $test X"$uselongdouble" = X"$define" -a X"$d_longdbl" = X"$define" -a X"$d_PRIgldbl" = X"$define"; then + nveformat="$sPRIeldbl" + nvfformat="$sPRIfldbl" + nvgformat="$sPRIgldbl" + nvEUformat="$sPRIEUldbl" + nvFUformat="$sPRIFUldbl" + nvGUformat="$sPRIGUldbl" +else + nveformat='"e"' + nvfformat='"f"' + nvgformat='"g"' + nvEUformat='"E"' + nvFUformat='"F"' + nvGUformat='"G"' +fi + case "$ivdformat" in '') echo "$0: Fatal: failed to find format strings, cannot continue." >& 4 exit 1 @@ -13279,12 +13772,15 @@ case "$pager" in dflt='' case "$pg" in /*) dflt=$pg;; + [a-zA-Z]:/*) dflt=$pg;; esac case "$more" in /*) dflt=$more;; + [a-zA-Z]:/*) dflt=$more;; esac case "$less" in /*) dflt=$less;; + [a-zA-Z]:/*) dflt=$less;; esac case "$dflt" in '') dflt=/usr/ucb/more;; @@ -13357,13 +13853,13 @@ $cc $ccflags -c bar1.c >/dev/null 2>&1 $cc $ccflags -c bar2.c >/dev/null 2>&1 $cc $ccflags -c foo.c >/dev/null 2>&1 $ar rc bar$_a bar2$_o bar1$_o >/dev/null 2>&1 -if $cc $ccflags $ldflags -o foobar foo$_o bar$_a $libs > /dev/null 2>&1 && +if $cc -o foobar $ccflags $ldflags foo$_o bar$_a $libs > /dev/null 2>&1 && ./foobar >/dev/null 2>&1; then echo "$ar appears to generate random libraries itself." orderlib=false ranlib=":" elif $ar ts bar$_a >/dev/null 2>&1 && - $cc $ccflags $ldflags -o foobar foo$_o bar$_a $libs > /dev/null 2>&1 && + $cc -o foobar $ccflags $ldflags foo$_o bar$_a $libs > /dev/null 2>&1 && ./foobar >/dev/null 2>&1; then echo "a table of contents needs to be added with '$ar ts'." orderlib=false @@ -13854,6 +14350,10 @@ $rm -f try try.* set d_socklen_t eval $setvar +: see if this is a socks.h system +set socks.h i_socks +eval $inhdr + : check for type of the size argument to socket calls case "$d_socket" in "$define") @@ -13861,7 +14361,6 @@ case "$d_socket" in Checking to see what type is the last argument of accept(). EOM - hdrs="$define sys/types.h $d_socket sys/socket.h" yyy='' case "$d_socklen_t" in "$define") yyy="$yyy socklen_t" @@ -13870,10 +14369,19 @@ EOM for xxx in $yyy; do case "$socksizetype" in '') try="extern int accept(int, struct sockaddr *, $xxx *);" - if ./protochk "$try" $hdrs; then - echo "Your system accepts '$xxx *' for the last argument of accept()." - socksizetype="$xxx" - fi + case "$usesocks" in + "$define") + if ./protochk "$try" $i_systypes sys/types.h $d_socket sys/socket.h literal '#define INCLUDE_PROTOTYPES' $i_socks socks.h.; then + echo "Your system accepts '$xxx *' for the last argument of accept()." + socksizetype="$xxx" + fi + ;; + *) if ./protochk "$try" $i_systypes sys/types.h $d_socket sys/socket.h; then + echo "Your system accepts '$xxx *' for the last argument of accept()." + socksizetype="$xxx" + fi + ;; + esac ;; esac done @@ -13934,13 +14442,15 @@ $rm -f ssize ssize.* : see what type of char stdio uses. echo " " -if $contains 'unsigned.*char.*_ptr;' `./findhdr stdio.h` >/dev/null 2>&1 ; then +echo '#include <stdio.h>' | $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 +else echo "Your stdio uses signed chars." >&4 stdchar="char" fi +$rm -f stdioh : see if time exists echo " " @@ -14090,6 +14600,37 @@ case "$uidsign" in ;; esac +: determine compiler compiler +case "$yacc" in +'') + dflt=yacc;; +*) + dflt="$yacc";; +esac +echo " " +comp='yacc' +if $test -f "$byacc"; then + dflt="$byacc" + comp="byacc or $comp" +fi +if $test -f "$bison"; then + comp="$comp or bison -y" +fi +rp="Which compiler compiler ($comp) shall I use?" +. ./myread +yacc="$ans" +case "$yacc" in +*bis*) + case "$yacc" in + *-y*) ;; + *) + yacc="$yacc -y" + echo "(Adding -y option to bison to get yacc-compatible behaviour.)" + ;; + esac + ;; +esac + : see if dbm.h is available : see if dbmclose exists set dbmclose d_dbmclose @@ -14264,14 +14805,18 @@ eval $inhdr set poll.h i_poll eval $inhdr +: see if this is a prot.h system +set prot.h i_prot +eval $inhdr + echo " " $echo "Guessing which symbols your C compiler and preprocessor define..." >&4 $cat <<'EOSH' > Cppsym.know a29k ABI64 aegis AES_SOURCE AIX AIX32 AIX370 AIX41 AIX42 AIX43 AIX_SOURCE aixpc ALL_SOURCE -alliant alpha am29000 AM29000 amiga AMIGAOS AMIX -ansi ANSI_C_SOURCE apollo ardent atarist att386 att3b BeOS -BIG_ENDIAN BIT_MSF bsd BSD bsd43 bsd4_2 bsd4_3 BSD4_3 bsd4_4 +alliant alpha am29000 AM29000 AMD64 amiga AMIGAOS AMIX +ansi ANSI_C_SOURCE apollo ardent ARM32 atarist att386 att3b +BeOS BIG_ENDIAN BIT_MSF bsd BSD bsd43 bsd4_2 bsd4_3 BSD4_3 bsd4_4 BSD_4_3 BSD_4_4 BSD_NET2 BSD_TIME BSD_TYPES BSDCOMPAT bsdi bull c cadmus clipper CMU COFF COMPILER_VERSION concurrent convex cpu cray CRAY CRAYMPP ctix CX_UX @@ -14284,7 +14829,7 @@ hp200 hp300 hp700 HP700 hp800 hp9000 hp9000s200 hp9000s300 hp9000s400 hp9000s500 hp9000s700 hp9000s800 hp9k8 hp_osf hppa hpux HPUX_SOURCE i186 i286 i386 i486 i586 i686 i8086 i80960 i860 I960 -iAPX286 ibm ibm032 ibmesa IBMR2 ibmrt ILP32 ILP64 +IA64 iAPX286 ibm ibm032 ibmesa IBMR2 ibmrt ILP32 ILP64 INLINE_INTRINSICS INTRINSICS INT64 interdata is68k ksr1 LANGUAGE_C LARGE_FILE_API LARGEFILE64_SOURCE LARGEFILE_SOURCE LFS64_LARGEFILE LFS_LARGEFILE @@ -14300,7 +14845,7 @@ mert MiNT mips MIPS_FPSET MIPS_ISA MIPS_SIM MIPS_SZINT MIPS_SZLONG MIPS_SZPTR MIPSEB MIPSEL MODERN_C motorola mpeix MSDOS MTXINU MULTIMAX mvs MVS n16 ncl_el ncl_mr NetBSD news1500 news1700 news1800 news1900 news3700 -news700 news800 news900 NeXT NLS ns16000 ns32000 +news700 news800 news900 NeXT NLS nonstopux ns16000 ns32000 ns32016 ns32332 ns32k nsc32000 OCS88 OEMVS OpenBSD os OS2 OS390 osf OSF1 OSF_SOURCE pa_risc PA_RISC1_1 PA_RISC2_0 PARAGON parisc @@ -14308,7 +14853,7 @@ pc532 pdp11 PGC PIC plexus PORTAR posix POSIX1B_SOURCE POSIX2_SOURCE POSIX4_SOURCE POSIX_C_SOURCE POSIX_SOURCE POWER PROTOTYPES PWB pyr QNX R3000 REENTRANT RES Rhapsody RISC6000 -riscix riscos RT scs SCO sequent sgi SGI_SOURCE sinix +riscix riscos RT S390 SA110 scs SCO sequent sgi SGI_SOURCE SH3 sinix SIZE_INT SIZE_LONG SIZE_PTR SOCKET_SOURCE SOCKETS_SOURCE sony sony_news sonyrisc sparc sparclite spectrum stardent stdc STDC_EXT stratos sun sun3 sun386 @@ -14316,6 +14861,7 @@ Sun386i svr3 svr4 SVR4_2 SVR4_SOURCE svr5 SX system SYSTYPE_BSD SYSTYPE_BSD43 SYSTYPE_BSD44 SYSTYPE_SVR4 SYSTYPE_SVR5 SYSTYPE_SYSV SYSV SYSV3 SYSV4 SYSV5 sysV68 sysV88 Tek4132 Tek4300 titan +TM3200 TM5400 TM5600 tower tower32 tower32_200 tower32_600 tower32_700 tower32_800 tower32_850 tss u370 u3b u3b2 u3b20 u3b200 u3b20d u3b5 @@ -14332,8 +14878,9 @@ $osname EOSH ./tr '[a-z]' '[A-Z]' < Cppsym.know > Cppsym.a ./tr '[A-Z]' '[a-z]' < Cppsym.know > Cppsym.b -$cat Cppsym.a Cppsym.b | $tr ' ' $trnl | sort | uniq > Cppsym.know -$rm -f Cppsym.a Cppsym.b +$cat Cppsym.know > Cppsym.c +$cat Cppsym.a Cppsym.b Cppsym.c | $tr ' ' $trnl | $sort | $uniq > Cppsym.know +$rm -f Cppsym.a Cppsym.b Cppsym.c cat <<EOSH > Cppsym $startsh if $test \$# -gt 0; then @@ -14372,8 +14919,9 @@ cat <<EOSH >> Cppsym.try ccflags="$ccflags" case "$osname-$gccversion" in irix-) ccflags="\$ccflags -woff 1178" ;; +os2-*) ccflags="\$ccflags -Zlinker /PM:VIO" ;; esac -$cc $optimize \$ccflags $ldflags -o try try.c $libs && ./try$exe_ext +$cc -o try $optimize \$ccflags $ldflags try.c $libs && ./try$exe_ext EOSH chmod +x Cppsym.try $eunicefix Cppsym.try @@ -14427,7 +14975,7 @@ if $test -z ccsym.raw; then else if $test -s ccsym.com; then echo "Your C compiler and pre-processor define these symbols:" - $sed -e 's/\(.*\)=.*/\1/' ccsym.com + $sed -e 's/\(..*\)=.*/\1/' ccsym.com also='also ' symbols='ones' cppccsymbols=`$cat ccsym.com` @@ -14437,7 +14985,7 @@ else if $test -s ccsym.cpp; then $test "$also" && echo " " echo "Your C pre-processor ${also}defines the following symbols:" - $sed -e 's/\(.*\)=.*/\1/' ccsym.cpp + $sed -e 's/\(..*\)=.*/\1/' ccsym.cpp also='further ' cppsymbols=`$cat ccsym.cpp` cppsymbols=`echo $cppsymbols` @@ -14446,14 +14994,14 @@ else if $test -s ccsym.own; then $test "$also" && echo " " echo "Your C compiler ${also}defines the following cpp symbols:" - $sed -e 's/\(.*\)=1/\1/' ccsym.own - $sed -e 's/\(.*\)=.*/\1/' ccsym.own | $uniq >>Cppsym.true + $sed -e 's/\(..*\)=1/\1/' ccsym.own + $sed -e 's/\(..*\)=.*/\1/' ccsym.own | $uniq >>Cppsym.true ccsymbols=`$cat ccsym.own` ccsymbols=`echo $ccsymbols` $test "$silent" || sleep 1 fi fi -$rm -f ccsym* +$rm -f ccsym* Cppsym.* : see if this is a termio system val="$undef" @@ -14514,10 +15062,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 @@ -14835,6 +15379,12 @@ for xxx in $known_extensions ; do true|$define|y) avail_ext="$avail_ext $xxx" ;; esac ;; + Sys/Syslog|sys/syslog) + : XXX syslog requires socket + case "$d_socket" in + true|$define|y) avail_ext="$avail_ext $xxx" ;; + esac + ;; Thread|thread) case "$usethreads" in true|$define|y) avail_ext="$avail_ext $xxx" ;; @@ -14981,6 +15531,25 @@ set X $dynamic_ext $static_ext $nonxs_ext shift extensions="$*" +: Remove libraries needed only for extensions +: The appropriate ext/Foo/Makefile.PL will add them back in, if necessary. +: The exception is SunOS 4.x, which needs them. +case "${osname}X${osvers}" in +sunos*X4*) + perllibs="$libs" + ;; +*) case "$usedl" in + $define|true|[yY]*) + set X `echo " $libs " | sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` + shift + perllibs="$*" + ;; + *) perllibs="$libs" + ;; + esac + ;; +esac + : Remove build directory name from cppstdin so it can be used from : either the present location or the final installed location. echo " " @@ -15092,7 +15661,10 @@ cc='$cc' cccdlflags='$cccdlflags' ccdlflags='$ccdlflags' ccflags='$ccflags' +ccflags_uselargefiles='$ccflags_uselargefiles' +ccname='$ccname' ccsymbols='$ccsymbols' +ccversion='$ccversion' cf_by='$cf_by' cf_email='$cf_email' cf_time='$cf_time' @@ -15119,10 +15691,10 @@ crosscompile='$crosscompile' cryptlib='$cryptlib' csh='$csh' d_Gconvert='$d_Gconvert' -d_PRIEldbl='$d_PRIEldbl' -d_PRIFldbl='$d_PRIFldbl' -d_PRIGldbl='$d_PRIGldbl' -d_PRIX64='$d_PRIX64' +d_PRIEUldbl='$d_PRIEUldbl' +d_PRIFUldbl='$d_PRIFUldbl' +d_PRIGUldbl='$d_PRIGUldbl' +d_PRIXU64='$d_PRIXU64' d_PRId64='$d_PRId64' d_PRIeldbl='$d_PRIeldbl' d_PRIfldbl='$d_PRIfldbl' @@ -15131,6 +15703,8 @@ d_PRIi64='$d_PRIi64' 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' @@ -15172,12 +15746,12 @@ d_endnent='$d_endnent' d_endpent='$d_endpent' d_endpwent='$d_endpwent' d_endsent='$d_endsent' -d_endspent='$d_endspent' d_eofnblk='$d_eofnblk' d_eunice='$d_eunice' d_fchmod='$d_fchmod' 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' @@ -15187,14 +15761,17 @@ d_flock='$d_flock' d_fork='$d_fork' d_fpathconf='$d_fpathconf' d_fpos64_t='$d_fpos64_t' +d_frexpl='$d_frexpl' d_fs_data_s='$d_fs_data_s' 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' +d_getespwnam='$d_getespwnam' d_getfsstat='$d_getfsstat' d_getgrent='$d_getgrent' d_getgrps='$d_getgrps' @@ -15210,6 +15787,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' @@ -15219,12 +15797,12 @@ d_getpgrp='$d_getpgrp' d_getppid='$d_getppid' d_getprior='$d_getprior' d_getprotoprotos='$d_getprotoprotos' +d_getprpwnam='$d_getprpwnam' d_getpwent='$d_getpwent' d_getsbyname='$d_getsbyname' d_getsbyport='$d_getsbyport' d_getsent='$d_getsent' d_getservprotos='$d_getservprotos' -d_getspent='$d_getspent' d_getspnam='$d_getspnam' d_gettimeod='$d_gettimeod' d_gnulibc='$d_gnulibc' @@ -15236,6 +15814,8 @@ d_index='$d_index' d_inetaton='$d_inetaton' d_int64_t='$d_int64_t' d_isascii='$d_isascii' +d_isnan='$d_isnan' +d_isnanl='$d_isnanl' d_killpg='$d_killpg' d_lchown='$d_lchown' d_ldbl_dig='$d_ldbl_dig' @@ -15262,6 +15842,7 @@ d_mkstemp='$d_mkstemp' d_mkstemps='$d_mkstemps' d_mktime='$d_mktime' d_mmap='$d_mmap' +d_modfl='$d_modfl' d_mprotect='$d_mprotect' d_msg='$d_msg' d_msg_ctrunc='$d_msg_ctrunc' @@ -15278,6 +15859,7 @@ d_munmap='$d_munmap' d_mymalloc='$d_mymalloc' d_nice='$d_nice' d_nv_preserves_uv='$d_nv_preserves_uv' +d_nv_preserves_uv_bits='$d_nv_preserves_uv_bits' d_off64_t='$d_off64_t' d_old_pthread_create_joinable='$d_old_pthread_create_joinable' d_oldpthreads='$d_oldpthreads' @@ -15285,6 +15867,7 @@ d_oldsock='$d_oldsock' d_open3='$d_open3' d_pathconf='$d_pathconf' d_pause='$d_pause' +d_perl_otherlibdirs='$d_perl_otherlibdirs' d_phostname='$d_phostname' d_pipe='$d_pipe' d_poll='$d_poll' @@ -15308,6 +15891,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' @@ -15341,7 +15925,6 @@ d_setrgid='$d_setrgid' d_setruid='$d_setruid' d_setsent='$d_setsent' d_setsid='$d_setsid' -d_setspent='$d_setspent' d_setvbuf='$d_setvbuf' d_sfio='$d_sfio' d_shm='$d_shm' @@ -15355,6 +15938,7 @@ d_sigsetjmp='$d_sigsetjmp' d_socket='$d_socket' d_socklen_t='$d_socklen_t' d_sockpair='$d_sockpair' +d_socks5_init='$d_socks5_init' d_sqrtl='$d_sqrtl' d_statblks='$d_statblks' d_statfs_f_flags='$d_statfs_f_flags' @@ -15362,6 +15946,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' @@ -15441,6 +16027,7 @@ freetype='$freetype' full_ar='$full_ar' full_csh='$full_csh' full_sed='$full_sed' +gccosandvers='$gccosandvers' gccversion='$gccversion' gidformat='$gidformat' gidsign='$gidsign' @@ -15455,7 +16042,6 @@ h_fcntl='$h_fcntl' h_sysfile='$h_sysfile' hint='$hint' hostcat='$hostcat' -huge='$huge' i16size='$i16size' i16type='$i16type' i32size='$i32size' @@ -15492,6 +16078,7 @@ i_neterrno='$i_neterrno' i_netinettcp='$i_netinettcp' i_niin='$i_niin' i_poll='$i_poll' +i_prot='$i_prot' i_pthread='$i_pthread' i_pwd='$i_pwd' i_rpcsvcdbm='$i_rpcsvcdbm' @@ -15564,15 +16151,16 @@ installvendorarch='$installvendorarch' installvendorbin='$installvendorbin' installvendorlib='$installvendorlib' intsize='$intsize' +issymlink='$issymlink' ivdformat='$ivdformat' ivsize='$ivsize' ivtype='$ivtype' known_extensions='$known_extensions' ksh='$ksh' -large='$large' ld='$ld' lddlflags='$lddlflags' ldflags='$ldflags' +ldflags_uselargefiles='$ldflags_uselargefiles' ldlibpthname='$ldlibpthname' less='$less' lib_ext='$lib_ext' @@ -15585,6 +16173,7 @@ libsfiles='$libsfiles' libsfound='$libsfound' libspath='$libspath' libswanted='$libswanted' +libswanted_uselargefiles='$libswanted_uselargefiles' line='$line' lint='$lint' lkflags='$lkflags' @@ -15613,11 +16202,9 @@ man1ext='$man1ext' man3dir='$man3dir' man3direxp='$man3direxp' man3ext='$man3ext' -medium='$medium' mips_type='$mips_type' mkdir='$mkdir' mmaptype='$mmaptype' -models='$models' modetype='$modetype' more='$more' multiarch='$multiarch' @@ -15636,6 +16223,12 @@ nm_opt='$nm_opt' nm_so_opt='$nm_so_opt' nonxs_ext='$nonxs_ext' nroff='$nroff' +nvEUformat='$nvEUformat' +nvFUformat='$nvFUformat' +nvGUformat='$nvGUformat' +nveformat='$nveformat' +nvfformat='$nvfformat' +nvgformat='$nvgformat' nvsize='$nvsize' nvtype='$nvtype' o_nonblock='$o_nonblock' @@ -15645,6 +16238,7 @@ optimize='$optimize' orderlib='$orderlib' osname='$osname' osvers='$osvers' +otherlibdirs='$otherlibdirs' package='$package' pager='$pager' passcat='$passcat' @@ -15653,6 +16247,7 @@ path_sep='$path_sep' perl5='$perl5' perl='$perl' perladmin='$perladmin' +perllibs='$perllibs' perlpath='$perlpath' pg='$pg' phostname='$phostname' @@ -15678,10 +16273,10 @@ revision='$revision' rm='$rm' rmail='$rmail' runnm='$runnm' -sPRIEldbl='$sPRIEldbl' -sPRIFldbl='$sPRIFldbl' -sPRIGldbl='$sPRIGldbl' -sPRIX64='$sPRIX64' +sPRIEUldbl='$sPRIEUldbl' +sPRIFUldbl='$sPRIFUldbl' +sPRIGUldbl='$sPRIGUldbl' +sPRIXU64='$sPRIXU64' sPRId64='$sPRId64' sPRIeldbl='$sPRIeldbl' sPRIfldbl='$sPRIfldbl' @@ -15690,6 +16285,7 @@ sPRIi64='$sPRIi64' sPRIo64='$sPRIo64' sPRIu64='$sPRIu64' sPRIx64='$sPRIx64' +sSCNfldbl='$sSCNfldbl' sched_yield='$sched_yield' scriptdir='$scriptdir' scriptdirexp='$scriptdirexp' @@ -15724,7 +16320,6 @@ sizesize='$sizesize' sizetype='$sizetype' sleep='$sleep' smail='$smail' -small='$small' so='$so' sockethdr='$sockethdr' socketlib='$socketlib' @@ -15732,7 +16327,6 @@ socksizetype='$socksizetype' sort='$sort' spackage='$spackage' spitshell='$spitshell' -split='$split' src='$src' ssizetype='$ssizetype' startperl='$startperl' @@ -15797,6 +16391,7 @@ usevendorprefix='$usevendorprefix' usevfork='$usevfork' usrinc='$usrinc' uuname='$uuname' +uvXUformat='$uvXUformat' uvoformat='$uvoformat' uvsize='$uvsize' uvtype='$uvtype' @@ -15812,10 +16407,13 @@ vendorlibexp='$vendorlibexp' vendorprefix='$vendorprefix' vendorprefixexp='$vendorprefixexp' version='$version' +versiononly='$versiononly' vi='$vi' voidflags='$voidflags' xlibpth='$xlibpth' xs_apiversion='$xs_apiversion' +yacc='$yacc' +yaccflags='$yaccflags' zcat='$zcat' zip='$zip' EOT @@ -15830,9 +16428,9 @@ echo "CONFIGDOTSH=true" >>config.sh : propagate old symbols if $test -f UU/config.sh; then - <UU/config.sh sort | uniq >UU/oldconfig.sh + <UU/config.sh $sort | $uniq >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 @@ -15906,7 +16504,7 @@ EOM . UU/myread case "$ans" in y*) - $make depend && echo "Now you must run a $make." + $make depend && echo "Now you must run '$make'." ;; *) echo "You must run '$make depend' then '$make'." diff --git a/contrib/perl5/EXTERN.h b/contrib/perl5/EXTERN.h index 897fae63b078..148055148503 100644 --- a/contrib/perl5/EXTERN.h +++ b/contrib/perl5/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/contrib/perl5/INSTALL b/contrib/perl5/INSTALL index 552c8702013b..dbf6cb5ca182 100644 --- a/contrib/perl5/INSTALL +++ b/contrib/perl5/INSTALL @@ -6,7 +6,7 @@ Install - Build and Installation guide for perl5. First, make sure you are installing an up-to-date version of Perl. If you didn't get your Perl source from CPAN, check the latest version at -<URL:http://www.perl.com/CPAN/src/>. +<URL:http://www.cpan.org/src/>. The basic steps to build and install perl5 on a Unix system with all the defaults are: @@ -24,6 +24,15 @@ with all the defaults are: Each of these is explained in further detail below. +B<NOTE>: starting from the release 5.6.0 Perl will use a version +scheme where even-numbered subreleases (like 5.6) are stable +maintenance releases and odd-numbered subreleases (like 5.7) are +unstable development releases. Development releases should not be +used in production environments. Fixes and new features are first +carefully tested in development releases and only if they prove +themselves to be worthy will they be migrated to the maintenance +releases. + The above commands will install Perl to /usr/local or /opt, depending on the platform. If that's not okay with you, use @@ -76,7 +85,7 @@ extensions that have not been updated for the new naming convention with: perl Makefile.PL POLLUTE=1 - + Alternatively, you can enable CPP symbol pollution wholesale by building perl itself with: @@ -113,8 +122,42 @@ currently installed modules. =head1 WARNING: This version requires a compiler that supports ANSI C. -If you find that your C compiler is not ANSI-capable, try obtaining -GCC, available from GNU mirrors worldwide (e.g. ftp://ftp.gnu.org/pub/gnu). +Most C compilers are now ANSI-compliant. However, a few current +computers are delivered with an older C compiler expressly for +rebuilding the system kernel, or for some other historical reason. +Alternatively, you may have an old machine which was shipped before +ANSI compliance became widespread. Such compilers are not suitable +for building Perl. + +If you find that your default C compiler is not ANSI-capable, but you +know that an ANSI-capable compiler is installed on your system, you +can tell F<Configure> to use the correct compiler by means of the +C<-Dcc=> command-line option -- see L<"gcc">. + +If do not have an ANSI-capable compiler there are several avenues open +to you: + +=over 4 + +=item * + +You may try obtaining GCC, available from GNU mirrors worldwide, +listed at <URL:http://www.gnu.org/order/ftp.html>. If, rather than +building gcc from source code, you locate a binary version configured +for your platform, be sure that it is compiled for the version of the +operating system that you are using. + +=item * + +You may purchase a commercial ANSI C compiler from your system +supplier or elsewhere. (Or your organization may already have +licensed such software -- ask your colleagues to find out how to +access it.) If there is a README file for your system in the Perl +distribution (for example, F<README.hpux>), it may contain advice on +suitable compilers. + +=item * + Another alternative may be to use a tool like ansi2knr to convert the sources back to K&R style, but there is no guarantee this route will get you anywhere, since the prototypes are not the only ANSI features used @@ -125,9 +168,11 @@ run, you may have to run it on a platform where GCC is available, and move the sources back to the platform without GCC. If you succeed in automatically converting the sources to a K&R compatible -form, be sure to email perlbug@perl.com to let us know the steps you +form, be sure to email perlbug@perl.org to let us know the steps you followed. This will enable us to officially support this option. +=back + Although Perl can be compiled using a C++ compiler, the Configure script does not work with some C++ compilers. @@ -219,6 +264,28 @@ For more help on Configure switches, run: sh Configure -h +=head2 Building Perl outside of the source directory + +Sometimes it is desirable to build Perl in a directory different from +where the sources are, for example if you want to keep your sources +read-only, or if you want to share the sources between different binary +architectures. + +Starting from Perl 5.6.1 you can do this (if your file system supports +symbolic links) by + + mkdir /tmp/perl/build/directory + cd /tmp/perl/build/directory + sh /path/to/perl/source/Configure -Dmksymlinks ... + +This will create in /tmp/perl/build/directory a tree of symbolic links +pointing to files in /path/to/perl/source. The original files are left +unaffected. After Configure has finished you can just say + + make all test + +and Perl will be built and tested, all in /tmp/perl/build/directory. + =head2 Common Configure options Configure supports a number of useful options. Run B<Configure -h> to @@ -291,7 +358,14 @@ output, you can run sh Configure -des -For my Solaris system, I usually use +Note: for development releases (odd subreleases, like 5.7, as opposed +to maintenance releases which have even subreleases, like 5.6) +if you want to use Configure -d, you will also need to supply -Dusedevel +to Configure, because the default answer to the question "do you really +want to Configure a development version?" is "no". The -Dusedevel +skips that sanity check. + +For example for my Solaris system, I usually use sh Configure -Dprefix=/opt/perl -Doptimize='-xpentium -xO4' -des @@ -461,9 +535,26 @@ network. One way to do that would be something like As a final catch-all, Configure also offers an $otherlibdirs variable. This variable contains a colon-separated list of additional -directories to add to @INC. By default, it will be set to -$prefix/site_perl if Configure detects that you have 5.004-era modules -installed there. However, you can set it to anything you like. +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<first>, +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 @@ -634,6 +725,52 @@ or by Eventually (by perl v5.6.0) this internal confusion ought to disappear, and these options may disappear as well. +=head2 64 bit support. + +If your platform does not have 64 bits natively, but can simulate them with +compiler flags and/or C<long long> or C<int64_t>, you can build a perl that +uses 64 bits. + +There are actually two modes of 64-bitness: the first one is achieved +using Configure -Duse64bitint and the second one using Configure +-Duse64bitall. The difference is that the first one is minimal and +the second one maximal. The first works in more places than the second. + +The C<use64bitint> does only as much as is required to get 64-bit +integers into Perl (this may mean, for example, using "long longs") +while your memory may still be limited to 2 gigabytes (because your +pointers could still be 32-bit). Note that the name C<64bitint> does +not imply that your C compiler will be using 64-bit C<int>s (it might, +but it doesn't have to): the C<use64bitint> means that you will be +able to have 64 bits wide scalar values. + +The C<use64bitall> goes all the way by attempting to switch also +integers (if it can), longs (and pointers) to being 64-bit. This may +create an even more binary incompatible Perl than -Duse64bitint: the +resulting executable may not run at all in a 32-bit box, or you may +have to reboot/reconfigure/rebuild your operating system to be 64-bit +aware. + +Natively 64-bit systems like Alpha and Cray need neither -Duse64bitint +nor -Duse64bitall. + + NOTE: 64-bit support is still experimental on most platforms. + Existing support only covers the LP64 data model. In particular, the + LLP64 data model is not yet supported. 64-bit libraries and system + APIs on many platforms have not stabilized--your mileage may vary. + +=head2 Long doubles + +In some systems you may be able to use long doubles to enhance the +range and precision of your double precision floating point numbers +(that is, Perl's numbers). Use Configure -Duselongdouble to enable +this support (if it is available). + +=head2 "more bits" + +You can "Configure -Dusemorebits" to turn on both the 64-bit support +and the long double support. + =head2 Selecting File IO mechanisms Previous versions of perl used the standard IO mechanisms as defined in @@ -665,7 +802,7 @@ extension modules or external libraries may not work. This configuration exists to allow these issues to be worked on. This option requires the 'sfio' package to have been built and installed. -A (fairly old) version of sfio is in CPAN. +The latest sfio is available from http://www.research.att.com/sw/tools/sfio/ You select this option by @@ -682,9 +819,6 @@ Configure should detect this problem and warn you about problems with _exit vs. exit. If you have this problem, the fix is to go back to your sfio sources and correct iffe's guess about atexit. -There also might be a more recent release of Sfio that fixes your -problem. - =item 2. Normal stdio IO, but with all IO going through calls to the PerlIO @@ -703,6 +837,13 @@ detect sfio, then this will be the default suggested by Configure. =back +=head2 SOCKS + +Perl can be configured to be 'socksified', that is, to use the SOCKS +TCP/IP proxy protocol library. SOCKS is used to give applications +access to transport layer network proxies. Perl supports only SOCKS +Version 5. You can find more about SOCKS from http://www.socks.nec.com/ + =head2 Dynamic Loading By default, Configure will compile perl to use dynamic loading if @@ -1029,6 +1170,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 <db.h>' >>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. @@ -1295,36 +1469,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 @@ -1333,18 +1477,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, @@ -1518,6 +1650,23 @@ to include the GNU utils before running Configure, or specify the vendor-supplied utilities explicitly to Configure, for example by Configure -Dar=/bin/ar. +=item THIS PACKAGE SEEMS TO BE INCOMPLETE + +The F<Configure> program has not been able to find all the files which +make up the complete Perl distribution. You may have a damaged source +archive file (in which case you may also have seen messages such as +C<gzip: stdin: unexpected end of file> and C<tar: Unexpected EOF on +archive file>), or you may have obtained a structurally-sound but +incomplete archive. In either case, try downloading again from the +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. + +=item invalid token: ## + +You are using a non-ANSI-compliant C compiler. See L<WARNING: This +version requires a compiler that supports ANSI C>. + =item Miscellaneous Some additional things that have been reported for either perl4 or perl5: @@ -1616,6 +1765,51 @@ test, it does not necessarily mean you have a broken perl. This test tries to exercise the regular expression subsystem quite thoroughly, and may well be far more demanding than your normal usage. +=item Test failures from lib/ftmp-security saying "system possibly insecure" + +Firstly, test failures from the ftmp-security are not necessarily +serious or indicative of a real security threat. That being said, +they bear investigating. + +The tests may fail for the following reasons. Note that each of the +tests is run both in the building directory and the temporary +directory, as returned by File::Spec->tmpdir(). + +(1) If the directory the tests are being run is owned by somebody else +than the user running the tests, or root (uid 0). This failure can +happen if the Perl source code distribution is unpacked in a way that +the user ids in the distribution package are used as-is. Some tar +programs do this. + +(2) If the directory the test are being run in is writable by group +or by other (remember: with UNIX/POSIX semantics, write access to +a directory means the right to add/remove files in that directory), +and there is no sticky bit set in the directory. 'Sticky bit' is +a feature used in some UNIXes to give extra protection to files: if +the bit is on a directory, no one but the owner (or the root) can remove +that file even if the permissions of the directory would allow file +removal by others. This failure can happen if the permissions in the +directory simply are a bit too liberal for the tests' liking. This +may or may not be a real problem: it depends on the permissions policy +used on this particular directory/project/system/site. This failure +can also happen if the system either doesn't support the sticky bit +(this is the case with many non-UNIX platforms: in principle the +File::Temp should know about these platforms and skip the tests), or +if the system supports the sticky bit but for some reason or reasons +it is not being used. This is for example the case with HP-UX: as of +HP-UX release 11.00, the sticky bit is very much supported, but HP-UX +doesn't use it on its /tmp directory as shipped. Also as with the +permissions, some local policy might dictate that the stickiness is +not used. + +(3) If the system supports the POSIX 'chown giveaway' feature and if +any of the parent directories of the temporary file back to the root +directory are 'unsafe', using the definitions given above in (1) and +(2). + +See the documentation for the File::Temp module for more information +about the various security aspects. + =back =head1 make install @@ -1654,12 +1848,17 @@ anything, you can run make install will install the following: + binaries + perl, perl5.nnn where nnn is the current release number. This will be a link to perl. suidperl, sperl5.nnn If you requested setuid emulation. a2p awk-to-perl translator + + scripts + cppstdin This is used by perl -P, if your cc -E can't read from stdin. c2ph, pstruct Scripts for handling C structures in header files. @@ -1672,13 +1871,21 @@ make install will install the following: pl2pm Convert Perl 4 .pl files to Perl 5 .pm modules pod2html, Converters from perl's pod documentation format pod2latex, to other useful formats. - pod2man, and - pod2text + pod2man, + pod2text, + pod2checker, + pod2select, + pod2usage splain Describe Perl warnings and errors dprofpp Perl code profile post-processor - library files in $privlib and $archlib specified to + library files + + in $privlib and $archlib specified to Configure, usually under /usr/local/lib/perl5/. + + documentation + man pages in $man1dir, usually /usr/local/man/man1. module man pages in $man3dir, usually /usr/local/man/man3. @@ -1687,11 +1894,28 @@ make install will install the following: Installperl will also create the directories listed above in L<"Installation Directories">. -Perl's *.h header files and the libperl.a library are also installed +Perl's *.h header files and the libperl library are also installed under $archlib so that any user may later build new modules, run the optional Perl compiler, or embed the perl interpreter into another program even if the Perl source is no longer available. +Sometimes you only want to install the version-specific parts of the perl +installation. For example, you may wish to install a newer version of +perl alongside an already installed production version of perl without +disabling installation of new modules for the production version. +To only install the version-specific parts of the perl installation, run + + Configure -Dversiononly + +or answer 'y' to the appropriate Configure prompt. Alternatively, +you can just manually run + + ./perl installperl -v + +and skip installman altogether. +See also L<"Maintaining completely separate versions"> for another +approach. + =head1 Coexistence with earlier versions of perl5 In general, you can usually safely upgrade from one version of Perl (e.g. @@ -1878,7 +2102,7 @@ available in TeX format. Type If you have difficulty building perl, and none of the advice in this file helps, and careful reading of the error message and the relevant manual pages on your system doesn't help either, then you should send a message -to either the comp.lang.perl.misc newsgroup or to perlbug@perl.com with +to either the comp.lang.perl.misc newsgroup or to perlbug@perl.org with an accurate description of your problem. Please include the output of the ./myconfig shell script that comes with diff --git a/contrib/perl5/INTERN.h b/contrib/perl5/INTERN.h index 286cc46fd8c4..1b35c135020e 100644 --- a/contrib/perl5/INTERN.h +++ b/contrib/perl5/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/contrib/perl5/MANIFEST b/contrib/perl5/MANIFEST index 0a4ed093a107..05e3cbcb0c8e 100644 --- a/contrib/perl5/MANIFEST +++ b/contrib/perl5/MANIFEST @@ -12,7 +12,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 Policy_sh.SH Hold site-wide preferences between Configure runs. @@ -30,24 +29,28 @@ 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 README.amiga Notes about AmigaOS port README.apollo Notes about Apollo DomainOS port README.beos Notes about BeOS port +README.bs2000 Notes about BS2000 POSIX port README.cygwin Notes about Cygwin port README.dos Notes about dos/djgpp port README.epoc Notes about EPOC port README.hpux Notes about HP-UX port README.hurd Notes about GNU/Hurd port README.machten Notes about Power MachTen port +README.macos Notes about Mac OS (Classic) README.mint Notes about Atari MiNT port README.mpeix Notes about MPE/iX port README.os2 Notes about OS/2 port 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 @@ -69,8 +72,8 @@ configure.com Configure-equivalent for VMS configure.gnu Crude emulation of GNU configure cop.h Control operator header cv.h Code value header -cygwin/cygwin.c Additional code for Cygwin port cygwin/Makefile.SHs Shared library generation for Cygwin port +cygwin/cygwin.c Additional code for Cygwin port cygwin/ld2.in ld wrapper template for Cygwin port cygwin/perlld.in dll generator template for Cygwin port deb.c Debugging routines @@ -83,7 +86,6 @@ doio.c I/O operations doop.c Support code for various operations dosish.h Some defines for MS/DOSish machines dump.c Debugging output -ebcdic.c EBCDIC support routines eg/ADB An adb wrapper to put in your crash dir eg/README Intro to example perl scripts eg/cgi/RunMeFirst Setup script for CGI examples @@ -170,6 +172,7 @@ ext/B/B/Bblock.pm Compiler basic block analysis support ext/B/B/Bytecode.pm Compiler Bytecode backend ext/B/B/C.pm Compiler C backend ext/B/B/CC.pm Compiler CC backend +ext/B/B/Concise.pm Compiler Concise backend ext/B/B/Debug.pm Compiler Debug backend ext/B/B/Deparse.pm Compiler Deparse backend ext/B/B/Disassembler.pm Compiler Disassembler backend @@ -235,9 +238,11 @@ ext/DynaLoader/XSLoader_pm.PL Simple XS Loader perl module ext/DynaLoader/dl_aix.xs AIX implementation ext/DynaLoader/dl_beos.xs BeOS implementation ext/DynaLoader/dl_dld.xs GNU dld style implementation +ext/DynaLoader/dl_dllload.xs S/390 dllload() style implementation ext/DynaLoader/dl_dlopen.xs BSD/SunOS4&5 dlopen() style implementation ext/DynaLoader/dl_dyld.xs NeXT/Apple dyld implementation ext/DynaLoader/dl_hpux.xs HP-UX implementation +ext/DynaLoader/dl_mac.xs MacOS implementation ext/DynaLoader/dl_mpeix.xs MPE/iX implementation ext/DynaLoader/dl_next.xs NeXT implementation ext/DynaLoader/dl_none.xs Stub implementation @@ -246,6 +251,7 @@ ext/DynaLoader/dl_vms.xs VMS implementation ext/DynaLoader/dlutils.c Dynamic loader utilities for dl_*.xs files ext/DynaLoader/hints/aix.pl Hint for DynaLoader for named architecture ext/DynaLoader/hints/linux.pl Hint for DynaLoader for named architecture +ext/DynaLoader/hints/netbsd.pl Hint for DynaLoader for named architecture ext/DynaLoader/hints/openbsd.pl Hint for DynaLoader for named architecture ext/Errno/ChangeLog Errno perl module change log ext/Errno/Errno_pm.PL Errno perl module create script @@ -300,8 +306,8 @@ ext/NDBM_File/NDBM_File.xs NDBM extension external subroutines ext/NDBM_File/hints/cygwin.pl Hint for NDBM_File for named architecture ext/NDBM_File/hints/dec_osf.pl Hint for NDBM_File for named architecture ext/NDBM_File/hints/dynixptx.pl Hint for NDBM_File for named architecture -ext/NDBM_File/hints/solaris.pl Hint for NDBM_File for named architecture ext/NDBM_File/hints/sco.pl Hint for NDBM_File for named architecture +ext/NDBM_File/hints/solaris.pl Hint for NDBM_File for named architecture ext/NDBM_File/hints/svr4.pl Hint for NDBM_File for named architecture ext/NDBM_File/typemap NDBM extension interface types ext/ODBM_File/Makefile.PL ODBM extension makefile writer @@ -333,6 +339,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 @@ -366,9 +373,9 @@ ext/SDBM_File/typemap SDBM extension interface types 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/Sys/Hostname/Makefile.PL Sys::Hostname extension makefile writer ext/Sys/Hostname/Hostname.pm Sys::Hostname extension Perl module ext/Sys/Hostname/Hostname.xs Sys::Hostname extension external subroutines +ext/Sys/Hostname/Makefile.PL Sys::Hostname extension makefile writer ext/Sys/Syslog/Makefile.PL Sys::Syslog extension makefile writer ext/Sys/Syslog/Syslog.pm Sys::Syslog extension Perl module ext/Sys/Syslog/Syslog.xs Sys::Syslog extension external subroutines @@ -402,6 +409,7 @@ 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 @@ -478,6 +486,7 @@ hints/newsos4.sh Hints for named architecture hints/next_3.sh Hints for named architecture hints/next_3_0.sh Hints for named architecture hints/next_4.sh Hints for named architecture +hints/nonstopux.sh Hints for named architecture hints/openbsd.sh Hints for named architecture hints/opus.sh Hints for named architecture hints/os2.sh Hints for named architecture @@ -516,6 +525,7 @@ installman Perl script to install man pages for pods installperl Perl script to do "make install" dirty work intrpvar.h Variables held in each interpreter instance iperlsys.h Perl's interface to the system +jpl/ChangeLog Java/Perl Lingo change log jpl/JNI/Changes Java Native Interface changes jpl/JNI/Closer.java Java Native Interface example jpl/JNI/JNI.pm Java Native Interface module @@ -543,12 +553,14 @@ jpl/PerlInterpreter/PerlInterpreter.c Perl interpreter abstraction jpl/PerlInterpreter/PerlInterpreter.h Perl interpreter abstraction jpl/PerlInterpreter/PerlInterpreter.java Perl interpreter abstraction jpl/README JPL instructions +jpl/README.JUST-JNI JPL instructions jpl/SETVARS.PL JPL setup jpl/Sample/Makefile.PL JPL sample makefile generator jpl/Sample/Sample.jpl JPL sample jpl/Test/Makefile.PL JPL tests makefile generator jpl/Test/Test.jpl JPL tests jpl/bin/jpl JPL compiler +jpl/docs/Tutorial.pod Perl and Java Tutorial jpl/get_jdk/README Instructions for using get_jdk.pl jpl/get_jdk/get_jdk.pl JDK download tool jpl/get_jdk/jdk_hosts JDK availability list @@ -567,6 +579,7 @@ lib/CGI/Fast.pm Support for FastCGI (persistent server process) lib/CGI/Pretty.pm Output nicely formatted HTML lib/CGI/Push.pm Support for server push lib/CGI/Switch.pm Simple interface for multiple server types +lib/CGI/Util.pm Utility functions lib/CPAN.pm Interface to Comprehensive Perl Archive Network lib/CPAN/FirstTime.pm Utility for creating CPAN config files lib/CPAN/Nox.pm Runs CPAN while avoiding compiled extensions @@ -610,12 +623,14 @@ 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 lib/File/Spec/Unix.pm portable operations on Unix file names lib/File/Spec/VMS.pm portable operations on VMS file names lib/File/Spec/Win32.pm portable operations on Win32 file names +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 @@ -639,6 +654,7 @@ lib/Pod/Find.pm used by pod/splitpod lib/Pod/Functions.pm used by pod/splitpod lib/Pod/Html.pm Convert POD data to HTML lib/Pod/InputObjects.pm Pod-Parser - define objects for input streams +lib/Pod/LaTeX.pm Convert POD data to LaTeX lib/Pod/Man.pm Convert POD data to *roff lib/Pod/ParseUtils.pm Pod-Parser - pod utility functions lib/Pod/Parser.pm Pod-Parser - define base class for parsing POD @@ -646,6 +662,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 @@ -677,6 +694,7 @@ lib/Time/tm.pm Internal object for Time::{gm,local}time lib/UNIVERSAL.pm Base class for ALL classes lib/User/grent.pm By-name interface to Perl's builtin getgr* lib/User/pwent.pm By-name interface to Perl's builtin getpw* +lib/Win32.pod Documentation for Win32 extras lib/abbrev.pl An abbreviation table builder lib/assert.pl assertion and panic with stack trace lib/attributes.pm For "sub foo : attrlist" @@ -734,9 +752,11 @@ lib/timelocal.pl Perl library supporting inverse of localtime, gmtime lib/unicode/ArabLink.pl Unicode character database lib/unicode/ArabLnkGrp.pl Unicode character database lib/unicode/ArabShap.txt Unicode character database +lib/unicode/BidiMirr.txt Unicode character database lib/unicode/Bidirectional.pl Unicode character database lib/unicode/Block.pl Unicode character database lib/unicode/Blocks.txt Unicode character database +lib/unicode/CaseFold.txt Unicode character database lib/unicode/Category.pl Unicode character database lib/unicode/CombiningClass.pl Unicode character database lib/unicode/CompExcl.txt Unicode character database @@ -833,29 +853,41 @@ lib/unicode/Index.txt Unicode character database lib/unicode/Is/ASCII.pl Unicode character database lib/unicode/Is/Alnum.pl Unicode character database lib/unicode/Is/Alpha.pl Unicode character database +lib/unicode/Is/BidiAL.pl Unicode character database lib/unicode/Is/BidiAN.pl Unicode character database lib/unicode/Is/BidiB.pl Unicode character database +lib/unicode/Is/BidiBN.pl Unicode character database lib/unicode/Is/BidiCS.pl Unicode character database lib/unicode/Is/BidiEN.pl Unicode character database lib/unicode/Is/BidiES.pl Unicode character database lib/unicode/Is/BidiET.pl Unicode character database lib/unicode/Is/BidiL.pl Unicode character database +lib/unicode/Is/BidiLRE.pl Unicode character database +lib/unicode/Is/BidiLRO.pl Unicode character database +lib/unicode/Is/BidiNSM.pl Unicode character database lib/unicode/Is/BidiON.pl Unicode character database +lib/unicode/Is/BidiPDF.pl Unicode character database lib/unicode/Is/BidiR.pl Unicode character database +lib/unicode/Is/BidiRLE.pl Unicode character database +lib/unicode/Is/BidiRLO.pl Unicode character database lib/unicode/Is/BidiS.pl Unicode character database lib/unicode/Is/BidiWS.pl Unicode character database +lib/unicode/Is/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 lib/unicode/Is/Cn.pl Unicode character database lib/unicode/Is/Cntrl.pl Unicode character database lib/unicode/Is/Co.pl Unicode character database +lib/unicode/Is/Cs.pl Unicode character database lib/unicode/Is/DCcircle.pl Unicode character database lib/unicode/Is/DCcompat.pl Unicode character database lib/unicode/Is/DCfinal.pl Unicode character database lib/unicode/Is/DCfont.pl Unicode character database -lib/unicode/Is/DCinital.pl Unicode character database +lib/unicode/Is/DCfraction.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 @@ -869,6 +901,35 @@ lib/unicode/Is/DecoCompat.pl Unicode character database lib/unicode/Is/Digit.pl Unicode character database lib/unicode/Is/Graph.pl Unicode character database lib/unicode/Is/L.pl Unicode character database +lib/unicode/Is/LbrkAI.pl Unicode character database +lib/unicode/Is/LbrkAL.pl Unicode character database +lib/unicode/Is/LbrkB2.pl Unicode character database +lib/unicode/Is/LbrkBA.pl Unicode character database +lib/unicode/Is/LbrkBB.pl Unicode character database +lib/unicode/Is/LbrkBK.pl Unicode character database +lib/unicode/Is/LbrkCB.pl Unicode character database +lib/unicode/Is/LbrkCL.pl Unicode character database +lib/unicode/Is/LbrkCM.pl Unicode character database +lib/unicode/Is/LbrkCR.pl Unicode character database +lib/unicode/Is/LbrkEX.pl Unicode character database +lib/unicode/Is/LbrkGL.pl Unicode character database +lib/unicode/Is/LbrkHY.pl Unicode character database +lib/unicode/Is/LbrkID.pl Unicode character database +lib/unicode/Is/LbrkIN.pl Unicode character database +lib/unicode/Is/LbrkIS.pl Unicode character database +lib/unicode/Is/LbrkLF.pl Unicode character database +lib/unicode/Is/LbrkNS.pl Unicode character database +lib/unicode/Is/LbrkNU.pl Unicode character database +lib/unicode/Is/LbrkOP.pl Unicode character database +lib/unicode/Is/LbrkPO.pl Unicode character database +lib/unicode/Is/LbrkPR.pl Unicode character database +lib/unicode/Is/LbrkQU.pl Unicode character database +lib/unicode/Is/LbrkSA.pl Unicode character database +lib/unicode/Is/LbrkSG.pl Unicode character database +lib/unicode/Is/LbrkSP.pl Unicode character database +lib/unicode/Is/LbrkSY.pl Unicode character database +lib/unicode/Is/LbrkXX.pl Unicode character database +lib/unicode/Is/LbrkZW.pl Unicode character database lib/unicode/Is/Ll.pl Unicode character database lib/unicode/Is/Lm.pl Unicode character database lib/unicode/Is/Lo.pl Unicode character database @@ -877,34 +938,54 @@ lib/unicode/Is/Lt.pl Unicode character database lib/unicode/Is/Lu.pl Unicode character database lib/unicode/Is/M.pl Unicode character database lib/unicode/Is/Mc.pl Unicode character database +lib/unicode/Is/Me.pl Unicode character database lib/unicode/Is/Mirrored.pl Unicode character database lib/unicode/Is/Mn.pl Unicode character database lib/unicode/Is/N.pl Unicode character database lib/unicode/Is/Nd.pl Unicode character database +lib/unicode/Is/Nl.pl Unicode character database lib/unicode/Is/No.pl Unicode character database lib/unicode/Is/P.pl Unicode character database +lib/unicode/Is/Pc.pl Unicode character database lib/unicode/Is/Pd.pl Unicode character database lib/unicode/Is/Pe.pl Unicode character database +lib/unicode/Is/Pf.pl Unicode character database +lib/unicode/Is/Pi.pl Unicode character database lib/unicode/Is/Po.pl Unicode character database lib/unicode/Is/Print.pl Unicode character database lib/unicode/Is/Ps.pl Unicode character database lib/unicode/Is/Punct.pl Unicode character database lib/unicode/Is/S.pl Unicode character database lib/unicode/Is/Sc.pl Unicode character database +lib/unicode/Is/Sk.pl Unicode character database lib/unicode/Is/Sm.pl Unicode character database lib/unicode/Is/So.pl Unicode character database lib/unicode/Is/Space.pl Unicode character database +lib/unicode/Is/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 +lib/unicode/Is/SylAI.pl Unicode character database lib/unicode/Is/SylC.pl Unicode character database lib/unicode/Is/SylE.pl Unicode character database +lib/unicode/Is/SylEE.pl Unicode character database lib/unicode/Is/SylI.pl Unicode character database +lib/unicode/Is/SylII.pl Unicode character database +lib/unicode/Is/SylN.pl Unicode character database lib/unicode/Is/SylO.pl Unicode character database +lib/unicode/Is/SylOO.pl Unicode character database lib/unicode/Is/SylU.pl Unicode character database lib/unicode/Is/SylV.pl Unicode character database lib/unicode/Is/SylWA.pl Unicode character database +lib/unicode/Is/SylWAA.pl Unicode character database lib/unicode/Is/SylWC.pl Unicode character database lib/unicode/Is/SylWE.pl Unicode character database +lib/unicode/Is/SylWEE.pl Unicode character database lib/unicode/Is/SylWI.pl Unicode character database +lib/unicode/Is/SylWII.pl Unicode character database +lib/unicode/Is/SylWO.pl Unicode character database +lib/unicode/Is/SylWOO.pl Unicode character database +lib/unicode/Is/SylWU.pl Unicode character database lib/unicode/Is/SylWV.pl Unicode character database lib/unicode/Is/Syllable.pl Unicode character database lib/unicode/Is/Upper.pl Unicode character database @@ -922,17 +1003,18 @@ lib/unicode/Name.pl Unicode character database lib/unicode/Names.txt Unicode character database lib/unicode/NamesList.html Unicode character database lib/unicode/Number.pl Unicode character database -lib/unicode/Props.txt Unicode character database +lib/unicode/PropList.txt Unicode character database lib/unicode/README.Ethiopic Unicode character database +lib/unicode/README.perl Unicode character database lib/unicode/ReadMe.txt Unicode character database info lib/unicode/SpecCase.txt Unicode character database lib/unicode/To/Digit.pl Unicode character database lib/unicode/To/Lower.pl Unicode character database lib/unicode/To/Title.pl Unicode character database lib/unicode/To/Upper.pl Unicode character database -lib/unicode/UCD300.html Unicode character database -lib/unicode/Unicode.300 Unicode character database -lib/unicode/Unicode3.html 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/mktables.PL Unicode character database generator lib/unicode/syllables.txt Unicode character database lib/utf8.pm Pragma to control Unicode support @@ -991,12 +1073,12 @@ os2/OS2/Process/Makefile.PL system() constants in a module os2/OS2/Process/Process.pm system() constants in a module os2/OS2/Process/Process.xs system() constants in a module os2/OS2/REXX/Changes DLL access module -os2/OS2/REXX/MANIFEST DLL access module os2/OS2/REXX/DLL/Changes DLL access module os2/OS2/REXX/DLL/DLL.pm DLL access module os2/OS2/REXX/DLL/DLL.xs DLL access module os2/OS2/REXX/DLL/MANIFEST DLL access module os2/OS2/REXX/DLL/Makefile.PL DLL access module +os2/OS2/REXX/MANIFEST DLL access module os2/OS2/REXX/Makefile.PL DLL access module os2/OS2/REXX/REXX.pm DLL access module os2/OS2/REXX/REXX.xs DLL access module @@ -1015,6 +1097,7 @@ os2/dl_os2.c Addon for dl_open os2/dlfcn.h Addon for dl_open os2/os2.c Additional code for OS/2 os2/os2.sym Additional symbols to export +os2/os2add.sym Overriding symbols to export os2/os2ish.h Header for OS/2 os2/os2thread.h pthread-like typedefs os2/perl2cmd.pl Corrects installed binaries under OS/2 @@ -1050,27 +1133,29 @@ plan9/plan9.c Plan9 port: Plan9-specific C routines plan9/plan9ish.h Plan9 port: Plan9-specific C header file plan9/setup.rc Plan9 port: script for easy build+install plan9/versnum Plan9 port: script to print version number -pod/Makefile Make pods into something else -pod/Win32.pod Documentation for Win32 extras -pod/buildtoc generate perltoc.pod +pod/Makefile.SH generate Makefile whichs makes pods into something else +pod/buildtoc.PL generate buildtoc which generates perltoc.pod pod/checkpods.PL Tool to check for common errors in pods -pod/perl.pod Top level perl man page +pod/perl.pod Top level perl documentation pod/perl5004delta.pod Changes from 5.003 to 5.004 pod/perl5005delta.pod Changes from 5.004 to 5.005 pod/perlapi.pod Perl API documentation (autogenerated) pod/perlapio.pod IO API info -pod/perlbook.pod Book info +pod/perlbook.pod Perl book information pod/perlboot.pod Beginner's Object-oriented Tutorial pod/perlbot.pod Object-oriented Bag o' Tricks pod/perlcall.pod Callback info +pod/perlclib.pod Internal replacements for standard C library functions pod/perlcompile.pod Info on using the Compiler suite pod/perldata.pod Data structure info pod/perldbmfilter.pod Info about DBM Filters pod/perldebguts.pod Debugger guts info +pod/perldebtut.pod Perl debugging tutorial pod/perldebug.pod Debugger info pod/perldelta.pod Changes since last version pod/perldiag.pod Diagnostic info pod/perldsc.pod Data Structures Cookbook +pod/perlebcdic.pod Considerations for running Perl on EBCDIC platforms pod/perlembed.pod Embedding info pod/perlfaq.pod Frequently Asked Questions, Top Level pod/perlfaq1.pod Frequently Asked Questions, Part 1 @@ -1096,7 +1181,9 @@ pod/perllocale.pod Locale support info pod/perllol.pod How to use lists of lists pod/perlmod.pod Module mechanism info pod/perlmodinstall.pod Installing CPAN Modules +pod/perlmodlib.PL Generate pod/perlmodlib.pod pod/perlmodlib.pod Module policy info +pod/perlnewmod.pod Preparing a new module for distribution pod/perlnumber.pod Semantics of numbers and numeric operations pod/perlobj.pod Object info pod/perlop.pod Operator info @@ -1106,6 +1193,8 @@ pod/perlport.pod Portability guide pod/perlre.pod Regular expression info pod/perlref.pod References info pod/perlreftut.pod Mark's references tutorial +pod/perlrequick.pod Quick start guide for Perl regular expressions +pod/perlretut.pod Tutorial for Perl regular expressions pod/perlrun.pod Execution info pod/perlsec.pod Security info pod/perlstyle.pod Style info @@ -1119,6 +1208,7 @@ pod/perltoot.pod Tom's object-oriented tutorial pod/perltootc.pod Tom's object-oriented tutorial (more on class data) pod/perltrap.pod Trap info pod/perlunicode.pod Unicode support info +pod/perlutil.pod Accompanying utilities explained pod/perlvar.pod Variable info pod/perlxs.pod XS api info pod/perlxstut.pod XS tutorial @@ -1202,17 +1292,21 @@ t/lib/ansicolor.t See if Term::ANSIColor works t/lib/anydbm.t See if AnyDBM_File works t/lib/attrs.t See if attrs works with C<sub : attrs> t/lib/autoloader.t See if AutoLoader works +t/lib/b.t See if B backends work t/lib/basename.t See if File::Basename works t/lib/bigfloat.t See if bigfloat.pl works t/lib/bigfltpm.t See if BigFloat.pm works t/lib/bigint.t See if bigint.pl works t/lib/bigintpm.t See if BigInt.pm works +t/lib/cgi-esc.t See if CGI.pm works t/lib/cgi-form.t See if CGI.pm works t/lib/cgi-function.t See if CGI.pm works t/lib/cgi-html.t See if CGI.pm works +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 @@ -1236,8 +1330,8 @@ 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/english.t See if English works -t/lib/env.t See if Env works t/lib/env-array.t See if Env works for arrays +t/lib/env.t See if Env works t/lib/errno.t See if Errno works t/lib/fatal.t See if Fatal works t/lib/fields.t See if base/fields works @@ -1249,6 +1343,10 @@ 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/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 +t/lib/ftmp-security.t See if File::Temp works +t/lib/ftmp-tempfile.t See if File::Temp works t/lib/gdbm.t See if GDBM_File works t/lib/getopt.t See if Getopt::Std and Getopt::Long work t/lib/glob-basic.t See if File::Glob works @@ -1258,6 +1356,7 @@ t/lib/glob-taint.t See if File::Glob works t/lib/gol-basic.t See if Getopt::Long works t/lib/gol-compat.t See if Getopt::Long works t/lib/gol-linkage.t See if Getopt::Long works +t/lib/gol-oo.t See if Getopt::Long works t/lib/h2ph.h Test header file for h2ph t/lib/h2ph.pht Generated output from h2ph.h by h2ph, for comparison t/lib/h2ph.t See if h2ph works like it should @@ -1284,6 +1383,7 @@ t/lib/open2.t See if IPC::Open2 works t/lib/open3.t See if IPC::Open3 works t/lib/ops.t See if Opcode works t/lib/parsewords.t See if Text::ParseWords works +t/lib/peek.t See if Devel::Peek works t/lib/ph.t See if h2ph works t/lib/posix.t See if POSIX works t/lib/safe1.t See if Safe works @@ -1291,21 +1391,27 @@ t/lib/safe2.t See if Safe works t/lib/sdbm.t See if SDBM_File works t/lib/searchdict.t See if Search::Dict works t/lib/selectsaver.t See if SelectSaver works +t/lib/selfloader.t See if SelfLoader works t/lib/socket.t See if Socket works t/lib/soundex.t See if Soundex works t/lib/symbol.t See if Symbol works t/lib/syslfs.t See if large files work for sysio +t/lib/syslog.t See if Sys::Syslog works t/lib/textfill.t See if Text::Wrap::fill works 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 +t/op/anonsub.t See if anonymous subroutines work t/op/append.t See if . works t/op/args.t See if operations on @_ work t/op/arith.t See if arithmetic works @@ -1319,6 +1425,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 @@ -1347,6 +1454,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 @@ -1357,6 +1465,7 @@ t/op/method.t See if method calls work t/op/misc.t See if miscellaneous bugs have been fixed t/op/mkdir.t See if mkdir works t/op/my.t See if lexical scoping works +t/op/my_stash.t See if my Package works t/op/nothr5005.t local @_ test which does not work under use5005threads t/op/numconvert.t See if accessing fields does not change numeric values t/op/oct.t See if oct and hex work @@ -1376,7 +1485,9 @@ t/op/recurse.t See if deep recursion works t/op/ref.t See if refs and objects work 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 @@ -1399,12 +1510,14 @@ 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 t/op/write.t See if write works t/pod/emptycmd.t Test empty pod directives t/pod/emptycmd.xr Expected results for emptycmd.t +t/pod/find.t See if Pod::Find works t/pod/for.t Test =for directive t/pod/for.xr Expected results for for.t t/pod/headings.t Test =head directives @@ -1432,7 +1545,7 @@ t/pod/podselect.xr Expected results for podselect.t t/pod/special_seqs.t Test "special" interior sequences t/pod/special_seqs.xr Expected results for emptycmd.t t/pod/testcmp.pl Module to compare output against expected results -t/pod/testp2pt.pl Module to test Pod::PlainText for a given file +t/pod/testp2pt.pl Module to test Pod::Text for a given file t/pod/testpchk.pl Module to test Pod::Checker for a given file t/pragma/constant.t See if compile-time constants work t/pragma/diagnostics.t See if diagnostics.pm works @@ -1444,8 +1557,8 @@ t/pragma/strict-refs Tests of "use strict 'refs'" for strict.t t/pragma/strict-subs Tests of "use strict 'subs'" for strict.t t/pragma/strict-vars Tests of "use strict 'vars'" for strict.t t/pragma/strict.t See if strictures work -t/pragma/subs.t See if subroutine pseudo-importation works t/pragma/sub_lval.t See if lvalue subroutines work +t/pragma/subs.t See if subroutine pseudo-importation works t/pragma/utf8.t See if utf8 operations work t/pragma/warn/1global Tests of global warnings for warnings.t t/pragma/warn/2use Tests for "use warnings" for warnings.t @@ -1481,6 +1594,7 @@ t/pragma/warn/universal Tests for universal.c for warnings.t t/pragma/warn/utf8 Tests for utf8.c for warnings.t t/pragma/warn/util Tests for util.c for warnings.t t/pragma/warnings.t See if warning controls work +t/run/runenv.t Test if perl honors its environment variables. taint.c Tainting code thrdvar.h Per-thread variables thread.h Threading header @@ -1496,7 +1610,6 @@ utils/c2ph.PL program to translate dbx stabs to perl utils/dprofpp.PL Perl code profile post-processor utils/h2ph.PL A thing to turn C .h files into perl .ph files utils/h2xs.PL Program to make .xs files from C header files -utils/perlbc.PL Front-end for byte compiler utils/perlbug.PL A simple tool to submit a bug report utils/perlcc.PL Front-end for compiler utils/perldoc.PL A simple tool to find & display perl's documentation @@ -1533,19 +1646,22 @@ vms/perly_c.vms perly.c with fixed declarations for global syms vms/perly_h.vms perly.h with fixed declarations for global syms vms/sockadapt.c glue for SockshShr socket support vms/sockadapt.h glue for SockshShr socket support -vms/subconfigure.com performs compiler checks and writes config.sh, config.h, and descrip.mms vms/test.com DCL driver for regression tests vms/vms.c VMS-specific C code for Perl core vms/vms_yfix.pl convert Unix perly.[ch] to VMS perly_[ch].vms vms/vmsish.h VMS-specific C header for Perl core +vms/vmspipe.com VMS-specific piped command helper script 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 @@ -1579,6 +1695,7 @@ win32/perlhost.h Perl "host" implementation win32/perllib.c Win32 port win32/pod.mak Win32 port win32/runperl.c Win32 port +win32/sncfnmcs.pl Win32 port win32/splittree.pl Win32 port win32/vdir.h Perl "host" virtual directory manager win32/vmem.h Perl "host" memory manager diff --git a/contrib/perl5/Makefile.SH b/contrib/perl5/Makefile.SH index 285269de442b..ac5ade430283 100755 --- a/contrib/perl5/Makefile.SH +++ b/contrib/perl5/Makefile.SH @@ -26,6 +26,7 @@ esac linklibperl='$(LIBPERL)' shrpldflags='$(LDDLFLAGS)' ldlibpth='' +DPERL_EXTERNAL_GLOB='-DPERL_EXTERNAL_GLOB' case "$useshrplib" in true) # Prefix all runs of 'miniperl' and 'perl' with @@ -70,12 +71,17 @@ true) *) shrpldflags="$shrpldflags -b noentry" ;; esac - shrpldflags="$shrpldflags $ldflags $libs $cryptlib" + shrpldflags="$shrpldflags $ldflags $perllibs $cryptlib" linklibperl="-L $archlibexp/CORE -L `pwd | sed 's/\/UU$//'` -lperl" ;; hpux*) linklibperl="-L `pwd | sed 's/\/UU$//'` -Wl,+s -Wl,+b$archlibexp/CORE -lperl" ;; + os390*) + shrpldflags='-W l,dll' + linklibperl='libperl.x' + DPERL_EXTERNAL_GLOB='' + ;; esac case "$ldlibpthname" in '') ;; @@ -117,6 +123,24 @@ for f in $nonxs_ext; do nonxs_list="$nonxs_list ext/$f/pm_to_blib" done +# Handle the usage of different yaccs in posix-bc (During Configure we +# us yacc for perly.y and byacc for a2p.y. The makefiles must use the +# same configuration for run_byacc!): +case "$osname" in + posix-bc) + byacc=$yacc + ;; +esac + +# Handle the usage of different yaccs in posix-bc (During Configure we +# us yacc for perly.y and byacc for a2p.y. The makefiles must use the +# same configuration for run_byacc!): +case "$osname" in + posix-bc) + byacc=$yacc + ;; +esac + echo "Extracting Makefile (with variable substitutions)" $spitshell >Makefile <<!GROK!THIS! # Makefile.SH @@ -134,11 +158,11 @@ LD = $ld LDFLAGS = $ldflags CLDFLAGS = $ldflags -SMALL = $small -LARGE = $large $split mallocsrc = $mallocsrc mallocobj = $mallocobj LNS = $lns +# NOTE: some systems don't grok "cp -f". XXX Configure test needed? +CPS = $cp RMS = rm -f ranlib = $ranlib @@ -176,7 +200,7 @@ nonxs_ext = $nonxs_list ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) -libs = $libs $cryptlib +libs = $perllibs $cryptlib public = perl $suidperl utilities translators @@ -206,11 +230,12 @@ SHELL = $sh # how to tr(anslate) newlines TRNL = '$trnl' +!GROK!THIS! # not used by Makefile but by installperl; -# mentioned here so that metaconfig picks it up -INSTALL_USR_BIN_PERL = $installusrbinperl +# mentioned here so that metaconfig picks these up +# $installusrbinperl +# $versiononly -!GROK!THIS! ## In the following dollars and backticks do not need the extra backslash. $spitshell >>Makefile <<'!NO!SUBS!' @@ -222,19 +247,21 @@ private = preplibrary lib/ExtUtils/Miniperl.pm lib/Config.pm # Files to be built with variable substitution before miniperl # is available. sh = Makefile.SH cflags.SH config_h.SH makeaperl.SH makedepend.SH \ - makedir.SH myconfig.SH writemain.SH + makedir.SH myconfig.SH writemain.SH pod/Makefile.SH shextract = Makefile cflags config.h makeaperl makedepend \ - makedir myconfig writemain + makedir myconfig writemain pod/Makefile # Files to be built with variable substitution after miniperl is # available. Dependencies handled manually below (for now). pl = pod/pod2html.PL pod/pod2latex.PL pod/pod2man.PL pod/pod2text.PL \ - pod/pod2usage.PL pod/podchecker.PL pod/podselect.PL + pod/pod2usage.PL pod/podchecker.PL pod/podselect.PL \ + pod/buildtoc.PL plextract = pod/pod2html pod/pod2latex pod/pod2man pod/pod2text \ - pod/pod2usage pod/podchecker pod/podselect + pod/pod2usage pod/podchecker pod/podselect \ + pod/buildtoc addedbyconf = UU $(shextract) $(plextract) pstruct @@ -297,14 +324,18 @@ utilities: miniperl lib/Config.pm $(plextract) FORCE # Apparently some makes require an action for the FORCE target. FORCE: @sh -c true +!NO!SUBS! -opmini$(OBJ_EXT): op.c - $(RMS) opmini.c - $(LNS) op.c opmini.c - $(CCCMD) $(PLDLFLAGS) -DPERL_EXTERNAL_GLOB opmini.c - $(RMS) opmini.c +$spitshell >>Makefile <<!GROK!THIS! +opmini\$(OBJ_EXT): op.c config.h + \$(RMS) opmini.c + \$(CPS) op.c opmini.c + \$(CCCMD) \$(PLDLFLAGS) $DPERL_EXTERNAL_GLOB opmini.c + \$(RMS) opmini.c -miniperlmain$(OBJ_EXT): miniperlmain.c +!GROK!THIS! +$spitshell >>Makefile <<'!NO!SUBS!' +miniperlmain$(OBJ_EXT): miniperlmain.c patchlevel.h $(CCCMD) $(PLDLFLAGS) $*.c perlmain.c: miniperlmain.c config.sh $(FIRSTMAKEFILE) @@ -333,7 +364,7 @@ esac case "$osname" in aix) $spitshell >>Makefile <<!GROK!THIS! -LIBS = $libs +LIBS = $perllibs # In AIX we need to change this for building Perl itself from # its earlier definition (which is for building external # extensions *after* Perl has been built and installed) @@ -403,7 +434,7 @@ $(LIBPERL): $& perl$(OBJ_EXT) $(obj) $(LIBPERLEXPORT) case "$useshrplib" in true) $spitshell >>Makefile <<'!NO!SUBS!' - $(LD) $(SHRPLDFLAGS) -o $@ perl$(OBJ_EXT) $(obj) + $(LD) -o $@ $(SHRPLDFLAGS) perl$(OBJ_EXT) $(obj) !NO!SUBS! case "$osname" in aix) @@ -458,7 +489,7 @@ miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL) opmini$(OBJ_EXT) *) $spitshell >>Makefile <<'!NO!SUBS!' miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL) opmini$(OBJ_EXT) - $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) -o miniperl \ + $(LDLIBPTH) $(CC) $(CLDFLAGS) -o miniperl \ miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) $(LLIBPERL) $(libs) $(LDLIBPTH) ./miniperl -w -Ilib -MExporter -e '<?>' || $(MAKE) minitest !NO!SUBS! @@ -468,16 +499,16 @@ miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL) opmini$(OBJ_EXT) $spitshell >>Makefile <<'!NO!SUBS!' perl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT) - $(SHRPENV) $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) + $(SHRPENV) $(LDLIBPTH) $(CC) -o perl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) pureperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT) - $(SHRPENV) $(LDLIBPTH) purify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) + $(SHRPENV) $(LDLIBPTH) purify $(CC) -o pureperl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) purecovperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT) - $(SHRPENV) $(LDLIBPTH) purecov $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o purecovperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) + $(SHRPENV) $(LDLIBPTH) purecov $(CC) -o purecovperl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) quantperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT) - $(SHRPENV) $(LDLIBPTH) quantify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) + $(SHRPENV) $(LDLIBPTH) quantify $(CC) -o quantperl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) # This version, if specified in Configure, does ONLY those scripts which need # set-id emulation. Suidperl must be setuid root. It contains the "taint" @@ -485,7 +516,7 @@ quantperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs # has been invoked correctly. suidperl: $& sperl$(OBJ_EXT) perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT) - $(SHRPENV) $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o suidperl perlmain$(OBJ_EXT) sperl$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) + $(SHRPENV) $(LDLIBPTH) $(CC) -o suidperl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) sperl$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) !NO!SUBS! @@ -493,7 +524,7 @@ fi $spitshell >>Makefile <<'!NO!SUBS!' -sperl$(OBJ_EXT): perl.c perly.h patchlevel.h $(h) +sperl$(OBJ_EXT): perl.c $(h) $(RMS) sperl.c $(LNS) perl.c sperl.c $(CCCMD) -DIAMSUID sperl.c @@ -531,15 +562,25 @@ extra.pods: miniperl -@rm -f extra.pods -@for x in `grep -l '^=[a-z]' README.* | grep -v README.vms` ; do \ nx=`echo $$x | sed -e "s/README\.//"`; \ - $(LNS) ../$$x "pod/perl"$$nx".pod" ; \ + cd pod ; $(LNS) ../$$x "perl"$$nx".pod" ; cd .. ; \ echo "pod/perl"$$nx".pod" >> extra.pods ; \ done - -@test -f vms/perlvms.pod && $(LNS) ../vms/perlvms.pod pod/perlvms.pod && echo "pod/perlvms.pod" >> extra.pods + -@test -f vms/perlvms.pod && cd pod && $(LNS) ../vms/perlvms.pod perlvms.pod && cd .. && echo "pod/perlvms.pod" >> extra.pods install-strip: $(MAKE) STRIPFLAGS=-s install -install: all install.perl install.man +install: + $(MAKE) install.perl install.man STRIPFLAGS=$(STRIPFLAGS) + +install-verbose: + $(MAKE) install.perl install.man STRIPFLAGS=$(STRIPFLAGS) INSTALLFLAGS=-V + +install-silent: + $(MAKE) install.perl install.man STRIPFLAGS=$(STRIPFLAGS) INSTALLFLAGS=-S + +no-install: + $(MAKE) install.perl install.man STRIPFLAGS=$(STRIPFLAGS) INSTALLFLAGS=-n install.perl: all installperl if [ -n "$(COMPILE)" ]; \ @@ -549,15 +590,15 @@ install.perl: all installperl cd ../pod; $(MAKE) compile; \ else :; \ fi - $(LDLIBPTH) ./perl installperl $(STRIPFLAGS) + $(LDLIBPTH) ./perl installperl $(INSTALLFLAGS) $(STRIPFLAGS) install.man: all installman - $(LDLIBPTH) ./perl installman + $(LDLIBPTH) ./perl installman $(INSTALLFLAGS) # XXX Experimental. Hardwired values, but useful for testing. # Eventually Configure could ask for some of these values. install.html: all installhtml - -@test -f README.vms && $(LNS) ../README.vms vms/README_vms.pod + -@test -f README.vms && cd vms && $(LNS) ../README.vms README_vms.pod && cd .. $(LDLIBPTH) ./perl installhtml \ --podroot=. --podpath=. --recurse \ --htmldir=$(privlib)/html \ @@ -577,7 +618,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 @@ -624,7 +665,8 @@ AUTOGEN_FILES = keywords.h opcode.h opnames.h pp_proto.h pp.sym proto.h \ pod/perlintern.pod pod/perlapi.pod \ objXSUB.h perlapi.h perlapi.c ext/ByteLoader/byterun.h \ ext/ByteLoader/byterun.c ext/B/B/Asmdata.pm regnodes.h \ - warnings.h lib/warnings.pm + warnings.h lib/warnings.pm \ + vms/perly_c.vms vms/perly_h.vms regen_headers: FORCE -$(CHMOD_W) $(AUTOGEN_FILES) @@ -635,6 +677,14 @@ regen_headers: FORCE -perl regcomp.pl -perl warnings.pl +regen_pods: FORCE + -cd pod; $(LDLIBPTH) make regen_pods + +regen_vms: FORCE + -perl vms/vms_yfix.pl perly.c perly.h vms/perly_c.vms vms/perly_h.vms + +regen_all: regen_headers regen_pods regen_vms + # Extensions: # Names added to $(dynamic_ext) or $(static_ext) or $(nonxs_ext) will # automatically get built. There should ordinarily be no need to change @@ -659,23 +709,29 @@ n_dummy $(nonxs_ext): miniperl preplibrary $(DYNALOADER) FORCE clean: _tidy _mopup -realclean: _cleaner _mopup +realclean: _realcleaner _mopup @echo "Note that make realclean does not delete config.sh or Policy.sh" -clobber: _cleaner _mopup +_clobber: rm -f config.sh cppstdin Policy.sh +clobber: _realcleaner _mopup _clobber + distclean: clobber +# Like distclean but also removes emacs backups and *.orig. +veryclean: _verycleaner _mopup _clobber + -@rm -f Obsolete Wanted + # Do not 'make _mopup' directly. _mopup: rm -f *$(OBJ_EXT) *$(LIB_EXT) all perlmain.c -@test -f extra.pods && rm -f `cat extra.pods` -@test -f vms/README_vms.pod && rm -f vms/README_vms.pod - -rm -f perl.exp ext.libs extra.pods + -rm -f perl.exp ext.libs extra.pods opmini.o -rm -f perl.export perl.dll perl.libexp perl.map perl.def -rm -f perl.loadmap miniperl.loadmap perl.prelmap miniperl.prelmap - rm -f perl suidperl miniperl $(LIBPERL) + rm -f perl suidperl miniperl $(LIBPERL) libperl.* microperl # Do not 'make _tidy' directly. _tidy: @@ -687,16 +743,17 @@ _tidy: done rm -f testcompile compilelog -# Do not 'make _cleaner' directly. -_cleaner: +_cleaner1: -cd os2; rm -f Makefile - -cd pod; $(LDLIBPTH) $(MAKE) realclean - -cd utils; $(LDLIBPTH) $(MAKE) realclean - -cd x2p; $(LDLIBPTH) $(MAKE) realclean + -cd pod; $(LDLIBPTH) $(MAKE) $(CLEAN) + -cd utils; $(LDLIBPTH) $(MAKE) $(CLEAN) + -cd x2p; $(LDLIBPTH) $(MAKE) $(CLEAN) -@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) $(nonxs_ext) ; do \ - $(LDLIBPTH) sh ext/util/make_ext realclean $$x MAKE=$(MAKE) ; \ + $(LDLIBPTH) sh ext/util/make_ext $(CLEAN) $$x MAKE=$(MAKE) ; \ done - rm -f *.orig */*.orig *~ */*~ core core.*perl.*.? *perl.core t/core t/core.perl.*.? t/*perl.core t/misctmp* t/tmp* t/c t/perl .?*.c so_locations $(LIBPERL_NONSHR) $(MINIPERL_NONSHR) + +_cleaner2: + rm -f core core.*perl.*.? *perl.core t/core t/core.perl.*.? t/*perl.core t/misctmp* t/forktmp* t/tmp* t/c t/perl t/rantests .?*.c so_locations $(LIBPERL_NONSHR) $(MINIPERL_NONSHR) rm -rf $(addedbyconf) rm -f $(FIRSTMAKEFILE) $(FIRSTMAKEFILE).old rm -f $(private) @@ -705,14 +762,23 @@ _cleaner: rm -f h2ph.man pstruct rm -rf .config rm -f testcompile compilelog - -rmdir lib/B lib/Data lib/IO/Socket lib/IO + -rmdir lib/B lib/Data lib/IO/Socket lib/IO lib/Sys lib/Thread + +_realcleaner: + @$(LDLIBPTH) $(MAKE) _cleaner1 CLEAN=realclean + @$(LDLIBPTH) $(MAKE) _cleaner2 + +_verycleaner: + @$(LDLIBPTH) $(MAKE) _cleaner1 CLEAN=veryclean + @$(LDLIBPTH) $(MAKE) _cleaner2 + -rm -f *~ *.orig */*~ */*.orig */*/*~ */*/*.orig # The following lint has practically everything turned on. Unfortunately, # you have to wade through a lot of mumbo jumbo that can't be suppressed. # If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message # for that spot. -lint: perly.c $(c) +lint: $(c) lint $(lintflags) $(defs) perly.c $(c) > perl.fuzz # Need to unset during recursion to go out of loop. @@ -750,6 +816,7 @@ test check: test-prep else \ cd t && PERL_SKIP_TTY_TEST=1 $(LDLIBPTH) ./perl TEST; \ fi + @echo "Ran tests" > t/rantests utest ucheck: test-prep if (true </dev/tty) >/dev/null 2>&1; then \ @@ -768,7 +835,7 @@ minitest: miniperl lib/re.pm @echo "You may see some irrelevant test failures if you have been unable" @echo "to build lib/Config.pm." - cd t && (rm -f perl$(EXE_EXT); $(LNS) ../miniperl$(EXE_EXT) perl$(EXE_EXT)) \ - && $(LDLIBPTH) ./perl TEST base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t </dev/tty + && $(LDLIBPTH) ./perl TEST base/*.t comp/*.t cmd/*.t run/*.t io/*.t op/*.t pragma/*.t </dev/tty # Handy way to run perlbug -ok without having to install and run the # installed perlbug. We don't re-run the tests here - we trust the user. @@ -780,12 +847,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 @@ -896,6 +975,7 @@ os390|posix-bc) 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|^static void __YY_YACC_MAIN.*BS2000.*|/*static main deleted*/|' \ -e 's/y\.tab/a2p/g' a2p.c >a2p.tmp && mv a2p.tmp a2p.c xxx="$xxx a2p.c" fi diff --git a/contrib/perl5/Policy_sh.SH b/contrib/perl5/Policy_sh.SH index 0d9c1dfbc758..fec18b938572 100755 --- a/contrib/perl5/Policy_sh.SH +++ b/contrib/perl5/Policy_sh.SH @@ -7,18 +7,33 @@ $startsh # # This file was produced by running the Policy_sh.SH script, which # gets its values from config.sh, which is generally produced by -# running Configure. The Policy.sh file gets overwritten each time -# Configure is run. Any variables you add to Policy.sh will be lost -# unless you copy Policy.sh somewhere else before running Configure. +# running Configure. # # The idea here is to distill in one place the common site-wide # "policy" answers (such as installation directories) that are # to be "sticky". If you keep the file Policy.sh around in # the same directory as you are building Perl, then Configure will # (by default) load up the Policy.sh file just before the -# platform-specific hints file. +# platform-specific hints file and rewrite it at the end. +# +# The sequence of events is as follows: +# A: If you are NOT re-using an old config.sh: +# 1. At start-up, Configure loads up the defaults from the +# os-specific hints/osname_osvers.sh file and any previous +# Policy.sh file. +# 2. At the end, Configure runs Policy_sh.SH, which creates +# Policy.sh, overwriting a previous Policy.sh if necessary. +# +# B: If you are re-using an old config.sh: +# 1. At start-up, Configure loads up the defaults from config.sh, +# ignoring any previous Policy.sh file. +# 2. At the end, Configure runs Policy_sh.SH, which creates +# Policy.sh, overwriting a previous Policy.sh if necessary. +# +# Thus the Policy.sh file gets overwritten each time +# Configure is run. Any variables you add to Policy.sh will be lost +# unless you copy Policy.sh somewhere else before running Configure. # - # Allow Configure command-line overrides; usually these won't be # needed, but something like -Dprefix=/test/location can be quite # useful for testing out new versions. @@ -37,16 +52,37 @@ esac case "\$prefix" in '') prefix='$prefix' ;; esac + +# By default, the next three are the same as \$prefix. +# If the user changes \$prefix, and previously \$siteprefix was the +# same as \$prefix, then change \$siteprefix as well. +# Use similar logic for \$vendorprefix and \$installprefix. + case "\$siteprefix" in -'') siteprefix='$siteprefix' ;; +'') if test "$siteprefix" = "$prefix"; then + siteprefix="\$prefix" + else + siteprefix='$siteprefix' + fi + ;; esac case "\$vendorprefix" in -'') vendorprefix='$vendorprefix' ;; +'') if test "$vendorprefix" = "$prefix"; then + vendorprefix="\$prefix" + else + vendorprefix='$vendorprefix' + fi + ;; esac # Where installperl puts things. case "\$installprefix" in -'') installprefix='$installprefix' ;; +'') if test "$installprefix" = "$prefix"; then + installprefix="\$prefix" + else + installprefix='$installprefix' + fi + ;; esac # Installation directives. Note that each one comes in three flavors. diff --git a/contrib/perl5/Porting/Contract b/contrib/perl5/Porting/Contract index cc91af26bca8..2b619fd0ff49 100644 --- a/contrib/perl5/Porting/Contract +++ b/contrib/perl5/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/contrib/perl5/Porting/Glossary b/contrib/perl5/Porting/Glossary index cc66d7041bdd..d32c0a678950 100644 --- a/contrib/perl5/Porting/Glossary +++ b/contrib/perl5/Porting/Glossary @@ -174,7 +174,8 @@ cat (Loc.U): cc (cc.U): This variable holds the name of a command to execute a C compiler which can resolve multiple global references that happen to have the same - name. Usual values are 'cc', 'Mcc', 'cc -M', and 'gcc'. + name. Usual values are 'cc' and 'gcc'. + Fervent ANSI compilers may be called 'c89'. AIX has xlc. cccdlflags (dlsrc.U): This variable contains any special flags that might need to be @@ -192,12 +193,28 @@ ccflags (ccflags.U): This variable contains any additional C compiler flags desired by the user. It is up to the Makefile to use this. +ccflags_uselargefiles (uselfs.U): + This variable contains the compiler flags needed by large file builds + and added to ccflags by hints files. + +ccname (Checkcc.U): + This can set either by hints files or by Configure. If using + gcc, this is gcc, and if not, usually equal to cc, unimpressive, no? + Some platforms, however, make good use of this by storing the + flavor of the C compiler being used here. For example if using + the Sun WorkShop suite, ccname will be 'workshop'. + ccsymbols (Cppsym.U): The variable contains the symbols defined by the C compiler alone. The symbols defined by cpp or by cc when it calls cpp are not in this list, see cppsymbols and cppccsymbols. The list is a space-separated list of symbol=value tokens. +ccversion (Checkcc.U): + This can set either by hints files or by Configure. If using + a (non-gcc) vendor cc, this variable may contain a version for + the compiler. + cf_by (cf_who.U): Login name of the person who ran the Configure script and answered the questions. This is used to tag both config.sh and config_h.SH. @@ -323,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. @@ -506,10 +527,6 @@ d_endsent (d_endsent.U): This variable conditionally defines HAS_ENDSERVENT if endservent() is available to close whatever was being used for service queries. -d_endspent (d_endspent.U): - This variable conditionally defines HAS_ENDSPENT if endspent() is - available to finalize the scan of SysV shadow password entries. - d_eofnblk (nblock_io.U): This variable conditionally defines EOF_NONBLOCK if EOF can be seen when reading from a non-blocking I/O source. @@ -532,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 @@ -573,6 +594,10 @@ d_fpathconf (d_pathconf.U): d_fpos64_t (d_fpos64_t.U): This symbol will be defined if the C compiler supports fpos64_t. +d_frexpl (d_frexpl.U): + This variable conditionally defines the HAS_FREXPL symbol, which + indicates to the C program that the frexpl() routine is available. + d_fs_data_s (d_fs_data_s.U): This variable conditionally defines the HAS_STRUCT_FS_DATA symbol, which indicates that the struct fs_data is supported. @@ -593,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. @@ -616,6 +645,10 @@ d_getcwd (d_getcwd.U): indicates to the C program that the getcwd() routine is available to get the current working directory. +d_getespwnam (d_getespwnam.U): + This variable conditionally defines HAS_GETESPWNAM if getespwnam() is + available to retrieve enchanced (shadow) password entries by name. + d_getfsstat (d_getfsstat.U): This variable conditionally defines the HAS_GETFSSTAT symbol, which indicates to the C program that the getfsstat() routine is available. @@ -690,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 @@ -735,6 +772,10 @@ d_getprotoprotos (d_getprotoprotos.U): prototypes for the various getproto*() functions. See also netdbtype.U for probing for various netdb types. +d_getprpwnam (d_getprpwnam.U): + This variable conditionally defines HAS_GETPRPWNAM if getprpwnam() is + available to retrieve protected (shadow) password entries by name. + d_getpwent (d_getpwent.U): This variable conditionally defines the HAS_GETPWENT symbol, which indicates to the C program that the getpwent() routine is available @@ -762,10 +803,6 @@ d_getservprotos (d_getservprotos.U): prototypes for the various getserv*() functions. See also netdbtype.U for probing for various netdb types. -d_getspent (d_getspent.U): - This variable conditionally defines HAS_GETSPENT if getspent() is - available to retrieve SysV shadow password entries sequentially. - d_getspnam (d_getspnam.U): This variable conditionally defines HAS_GETSPNAM if getspnam() is available to retrieve SysV shadow password entries by name. @@ -811,6 +848,14 @@ d_isascii (d_isascii.U): This variable conditionally defines the HAS_ISASCII constant, which indicates to the C program that isascii() is available. +d_isnan (d_isnan.U): + This variable conditionally defines the HAS_ISNAN symbol, which + indicates to the C program that the isnan() routine is available. + +d_isnanl (d_isnanl.U): + This variable conditionally defines the HAS_ISNANL symbol, which + indicates to the C program that the isnanl() routine is available. + d_killpg (d_killpg.U): This variable conditionally defines the HAS_KILLPG symbol, which indicates to the C program that the killpg() routine is available @@ -933,6 +978,10 @@ d_mmap (d_mmap.U): This variable conditionally defines HAS_MMAP if mmap() is available to map a file into memory. +d_modfl (d_modfl.U): + This variable conditionally defines the HAS_MODFL symbol, which + indicates to the C program that the modfl() routine is available. + d_mprotect (d_mprotect.U): This variable conditionally defines HAS_MPROTECT if mprotect() is available to modify the access protection of a memory mapped file. @@ -1003,6 +1052,10 @@ d_nv_preserves_uv (perlxv.U): This variable indicates whether a variable of type nvtype can preserve all the bits a variable of type uvtype. +d_nv_preserves_uv_bits (perlxv.U): + This variable indicates how many of bits type uvtype + a variable nvtype can preserve. + d_off64_t (d_off64_t.U): This symbol will be defined if the C compiler supports off64_t. @@ -1036,6 +1089,11 @@ d_pause (d_pause.U): indicates to the C program that the pause() routine is available to suspend a process until a signal is received. +d_perl_otherlibdirs (otherlibdirs.U): + This variable conditionally defines PERL_OTHERLIBDIRS, which + contains a colon-separated set of paths for the perl binary to + include in @INC. See also otherlibdirs. + d_phostname (d_gethname.U): This variable conditionally defines the HAS_PHOSTNAME symbol, which contains the shell command which, when fed to popen(), may be @@ -1061,28 +1119,34 @@ d_PRId64 (quadfio.U): indiciates that stdio has a symbol to print 64-bit decimal numbers. d_PRIeldbl (longdblfio.U): - This variable conditionally defines the PERL_PRIfldlbl symbol, which + This variable conditionally defines the PERL_PRIfldbl symbol, which indiciates that stdio has a symbol to print long doubles. -d_PRIEldbl (longdblfio.U): - This variable conditionally defines the PERL_PRIfldlbl symbol, which +d_PRIEUldbl (longdblfio.U): + This variable conditionally defines the PERL_PRIfldbl symbol, which indiciates that stdio has a symbol to print long doubles. + The 'U' in the name is to separate this from d_PRIeldbl so that even + case-blind systems can see the difference. d_PRIfldbl (longdblfio.U): - This variable conditionally defines the PERL_PRIfldlbl symbol, which + This variable conditionally defines the PERL_PRIfldbl symbol, which indiciates that stdio has a symbol to print long doubles. -d_PRIFldbl (longdblfio.U): - This variable conditionally defines the PERL_PRIfldlbl symbol, which +d_PRIFUldbl (longdblfio.U): + This variable conditionally defines the PERL_PRIfldbl symbol, which indiciates that stdio has a symbol to print long doubles. + The 'U' in the name is to separate this from d_PRIfldbl so that even + case-blind systems can see the difference. d_PRIgldbl (longdblfio.U): - This variable conditionally defines the PERL_PRIfldlbl symbol, which + This variable conditionally defines the PERL_PRIfldbl symbol, which indiciates that stdio has a symbol to print long doubles. -d_PRIGldbl (longdblfio.U): - This variable conditionally defines the PERL_PRIfldlbl symbol, which +d_PRIGUldbl (longdblfio.U): + This variable conditionally defines the PERL_PRIfldbl symbol, which indiciates that stdio has a symbol to print long doubles. + The 'U' in the name is to separate this from d_PRIgldbl so that even + case-blind systems can see the difference. d_PRIi64 (quadfio.U): This variable conditionally defines the PERL_PRIi64 symbol, which @@ -1101,9 +1165,11 @@ d_PRIx64 (quadfio.U): This variable conditionally defines the PERL_PRIx64 symbol, which indiciates that stdio has a symbol to print 64-bit hexadecimal numbers. -d_PRIX64 (quadfio.U): - This variable conditionally defines the PERL_PRIX64 symbol, which +d_PRIXU64 (quadfio.U): + This variable conditionally defines the PERL_PRIXU64 symbol, which indiciates that stdio has a symbol to print 64-bit hExADECimAl numbers. + The 'U' in the name is to separate this from d_PRIx64 so that even + case-blind systems can see the difference. d_pthread_yield (d_pthread_y.U): This variable conditionally defines the HAS_PTHREAD_YIELD @@ -1185,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 @@ -1195,6 +1267,10 @@ d_scm_rights (d_socket.U): which indicates that the SCM_RIGHTS is available. #ifdef is not enough because it may be an enum, glibc has been known to do this. +d_SCNfldbl (longdblfio.U): + This variable conditionally defines the PERL_PRIfldbl symbol, which + indiciates that stdio has a symbol to scan long doubles. + d_seekdir (d_readdir.U): This variable conditionally defines HAS_SEEKDIR if seekdir() is available. @@ -1287,6 +1363,11 @@ d_setprior (d_setprior.U): This variable conditionally defines HAS_SETPRIORITY if setpriority() is available to set a process's priority. +d_setproctitle (d_setproctitle.U): + This variable conditionally defines the HAS_SETPROCTITLE symbol, + which indicates to the C program that the setproctitle() routine + is available. + d_setpwent (d_setpwent.U): This variable conditionally defines the HAS_SETPWENT symbol, which indicates to the C program that the setpwent() routine is available @@ -1330,10 +1411,6 @@ d_setsid (d_setsid.U): This variable conditionally defines HAS_SETSID if setsid() is available to set the process group ID. -d_setspent (d_setspent.U): - This variable conditionally defines HAS_SETSPENT if setspent() is - available to initialize the scan of SysV shadow password entries. - d_setvbuf (d_setvbuf.U): This variable conditionally defines the HAS_SETVBUF symbol, which indicates to the C program that the setvbuf() routine is available @@ -1372,6 +1449,11 @@ d_sigaction (d_sigaction.U): This variable conditionally defines the HAS_SIGACTION symbol, which indicates that the Vr4 sigaction() routine is available. +d_sigprocmask (d_sigprocmask.U): + This variable conditionally defines HAS_SIGPROCMASK + if sigprocmask() is available to examine or change the signal mask + of the calling process. + d_sigsetjmp (d_sigsetjmp.U): This variable conditionally defines the HAS_SIGSETJMP symbol, which indicates that the sigsetjmp() routine is available to @@ -1388,6 +1470,10 @@ d_sockpair (d_socket.U): This variable conditionally defines the HAS_SOCKETPAIR symbol, which indicates that the BSD socketpair() is supported. +d_socks5_init (d_socks5_init.U): + This variable conditionally defines the HAS_SOCKS5_INIT symbol, which + indicates to the C program that the socks5_init() routine is available. + d_sqrtl (d_sqrtl.U): This variable conditionally defines the HAS_SQRTL symbol, which indicates to the C program that the sqrtl() routine is available. @@ -1419,6 +1505,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. @@ -1474,6 +1569,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 @@ -1782,7 +1881,12 @@ full_sed (Loc_sed.U): can share this executable will have the same full pathname to 'sed.' -gccversion (cc.U): +gccosandvers (gccvers.U): + If GNU cc (gcc) is used, this variable the operating system and + version used to compile the gcc. It is set to '' if not gcc, + or if nothing useful can be parsed as the os version. + +gccversion (gccvers.U): If GNU cc (gcc) is used, this variable holds '1' or '2' to indicate whether the compiler is version 1 or 2. This is used in setting some of the default cflags. It is set to '' if not gcc. @@ -1849,12 +1953,6 @@ hostcat (nis.U): On some systems, such as os390, there may be no equivalent command, in which case this variable is unset. -huge (models.U): - This variable contains a flag which will tell the C compiler and loader - to produce a program running with a huge memory model. If the - huge model is not supported, contains the flag to produce large - model programs. It is up to the Makefile to use this. - i16size (perlxv.U): This variable is the size of an I16 in bytes. @@ -1941,6 +2039,10 @@ i_inttypes (i_inttypes.U): This variable conditionally defines the I_INTTYPES symbol, and indicates whether a C program should include <inttypes.h>. +i_libutil (i_libutil.U): + This variable conditionally defines the I_LIBUTIL symbol, and indicates + whether a C program should include <libutil.h>. + i_limits (i_limits.U): This variable conditionally defines the I_LIMITS symbol, and indicates whether a C program may include <limits.h> to get symbols like WORD_BIT @@ -1997,6 +2099,10 @@ i_poll (i_poll.U): This variable conditionally defines the I_POLL symbol, and indicates whether a C program should include <poll.h>. +i_prot (i_prot.U): + This variable conditionally defines the I_PROT symbol, and indicates + whether a C program should include <prot.h>. + i_pthread (i_pthread.U): This variable conditionally defines the I_PTHREAD symbol, and indicates whether a C program should include <pthread.h>. @@ -2342,6 +2448,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 test command to test for a symbolic link + (if they are supported). Typical values include 'test -h' and + 'test -L'. + ivdformat (perlxvf.U): This variable contains the format string used for printing a Perl IV as a signed decimal integer. @@ -2360,11 +2471,6 @@ ksh (Loc.U): This variable is defined but not used by Configure. The value is a plain '' and is not useful. -large (models.U): - This variable contains a flag which will tell the C compiler and loader - to produce a program running with a large memory model. It is up to - the Makefile to use this. - ld (dlsrc.U): This variable indicates the program to be used to link libraries for dynamic loading. On some systems, it is 'ld'. @@ -2381,6 +2487,10 @@ ldflags (ccflags.U): This variable contains any additional C loader flags desired by the user. It is up to the Makefile to use this. +ldflags_uselargefiles (uselfs.U): + This variable contains the loader flags needed by large file builds + and added to ldflags by hints files. + ldlibpthname (libperl.U): This variable holds the name of the shared library search path, often LD_LIBRARY_PATH. To get an empty @@ -2433,6 +2543,12 @@ libswanted (Myinit.U): search. The order is chosen to pick up the c library ahead of ucb or bsd libraries for SVR4. +libswanted_uselargefiles (uselfs.U): + This variable contains the libraries needed by large file builds + and added to ldflags by hints files. It is a space separated list + of the library names without the "lib" prefix or any suffix, just + like libswanted.. + line (Loc.U): This variable is defined but not used by Configure. The value is a plain '' and is not useful. @@ -2578,12 +2694,6 @@ Mcc (Loc.U): full pathname (if any) of the Mcc program. After Configure runs, the value is reset to a plain "Mcc" and is not useful. -medium (models.U): - This variable contains a flag which will tell the C compiler and loader - to produce a program running with a medium memory model. If the - medium model is not supported, contains the flag to produce large - model programs. It is up to the Makefile to use this. - mips_type (usrinc.U): This variable holds the environment type for the mips system. Possible values are "BSD 4.3" and "System V". @@ -2598,11 +2708,6 @@ mmaptype (d_mmap.U): (and simultaneously the type of the first argument). It can be 'void *' or 'caddr_t'. -models (models.U): - This variable contains the list of memory models supported by this - system. Possible component values are none, split, unsplit, small, - medium, large, and huge. The component values are space separated. - modetype (modetype.U): This variable defines modetype to be something like mode_t, int, unsigned short, or whatever type is used to declare file @@ -2649,6 +2754,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. @@ -2695,6 +2809,30 @@ nroff (Loc.U): full pathname (if any) of the nroff program. After Configure runs, the value is reset to a plain "nroff" and is not useful. +nveformat (perlxvf.U): + This variable contains the format string used for printing + a Perl NV using %e-ish floating point format. + +nvEUformat (perlxvf.U): + This variable contains the format string used for printing + a Perl NV using %E-ish floating point format. + +nvfformat (perlxvf.U): + This variable confains the format string used for printing + a Perl NV using %f-ish floating point format. + +nvFUformat (perlxvf.U): + This variable confains the format string used for printing + a Perl NV using %F-ish floating point format. + +nvgformat (perlxvf.U): + This variable contains the format string used for printing + a Perl NV using %g-ish floating point format. + +nvGUformat (perlxvf.U): + This variable contains the format string used for printing + a Perl NV using %G-ish floating point format. + nvsize (perlxv.U): This variable is the size of an NV in bytes. @@ -2741,6 +2879,16 @@ osvers (Oldconfig.U): same for this package, hints files might just be os_4.0 or os_4.1, etc., not keeping separate files for each little release. +otherlibdirs (otherlibdirs.U): + This variable contains a colon-separated set of paths for the perl + binary to search for additional library files or modules. + These directories will be tacked to the end of @INC. + Perl will automatically search below each path for version- + and architecture-specific directories. See inc_version_list + for more details. + A value of ' ' means 'none' and is used to preserve this value + for the next run through Configure. + package (package.U): This variable contains the name of the package being constructed. It is primarily intended for the use of later Configure units. @@ -2792,6 +2940,10 @@ PERL_VERSION (Oldsyms.U): perladmin (perladmin.U): Electronic mail address of the perl5 administrator. +perllibs (End.U): + The list of libraries needed by Perl only (any libraries needed + by extensions only will by dropped, if using dynamic loading). + perlpath (perlpath.U): This variable contains the eventual value of the PERLPATH symbol, which contains the name of the perl interpreter to be used in @@ -3036,6 +3188,10 @@ sig_num_init (sig_name.U): below. A "ZERO" is prepended to the list, and the list is terminated with a plain 0. +sig_size (sig_name.U): + This variable contains the number of elements of the sig_name + and sig_num arrays, excluding the final NULL entry. + signal_t (d_voidsig.U): This variable holds the type of the signal handler (void or int). @@ -3114,11 +3270,6 @@ smail (Loc.U): This variable is defined but not used by Configure. The value is a plain '' and is not useful. -small (models.U): - This variable contains a flag which will tell the C compiler and loader - to produce a program running with a small memory model. It is up to - the Makefile to use this. - so (so.U): This variable holds the extension used to identify shared libraries (also known as shared objects) on the system. Usually set to 'so'. @@ -3148,12 +3299,6 @@ spitshell (spitshell.U): This variable contains the command necessary to spit out a runnable shell on this system. It is either cat or a grep '-v' for # comments. -split (models.U): - This variable contains a flag which will tell the C compiler and loader - to produce a program that will run in separate I and D space, for those - machines that support separation of instruction and data space. It is - up to the Makefile to use this. - sPRId64 (quadfio.U): This variable, if defined, contains the string used by stdio to format 64-bit decimal numbers (format 'd') for output. @@ -3162,25 +3307,31 @@ sPRIeldbl (longdblfio.U): This variable, if defined, contains the string used by stdio to format long doubles (format 'e') for output. -sPRIEldbl (longdblfio.U): +sPRIEUldbl (longdblfio.U): This variable, if defined, contains the string used by stdio to format long doubles (format 'E') for output. + The 'U' in the name is to separate this from sPRIeldbl so that even + case-blind systems can see the difference. sPRIfldbl (longdblfio.U): This variable, if defined, contains the string used by stdio to format long doubles (format 'f') for output. -sPRIFldbl (longdblfio.U): +sPRIFUldbl (longdblfio.U): This variable, if defined, contains the string used by stdio to format long doubles (format 'F') for output. + The 'U' in the name is to separate this from sPRIfldbl so that even + case-blind systems can see the difference. sPRIgldbl (longdblfio.U): This variable, if defined, contains the string used by stdio to format long doubles (format 'g') for output. -sPRIGldbl (longdblfio.U): +sPRIGUldbl (longdblfio.U): This variable, if defined, contains the string used by stdio to format long doubles (format 'G') for output. + The 'U' in the name is to separate this from sPRIgldbl so that even + case-blind systems can see the difference. sPRIi64 (quadfio.U): This variable, if defined, contains the string used by stdio to @@ -3198,15 +3349,21 @@ sPRIx64 (quadfio.U): This variable, if defined, contains the string used by stdio to format 64-bit hexadecimal numbers (format 'x') for output. -sPRIX64 (quadfio.U): +sPRIXU64 (quadfio.U): This variable, if defined, contains the string used by stdio to format 64-bit hExADECimAl numbers (format 'X') for output. + The 'U' in the name is to separate this from sPRIx64 so that even + case-blind systems can see the difference. src (src.U): This variable holds the path to the package source. It is up to the Makefile to use this variable and set VPATH accordingly to find the sources remotely. +sSCNfldbl (longdblfio.U): + This variable, if defined, contains the string used by stdio to + format long doubles (format 'f') for input. + ssizetype (ssizetype.U): This variable defines ssizetype to be something like ssize_t, long or int. It is used by functions that return a count @@ -3521,7 +3678,11 @@ uvuformat (perlxvf.U): uvxformat (perlxvf.U): This variable contains the format string used for printing - a Perl UV as an unsigned hexadecimal integer. + a Perl UV as an unsigned hexadecimal integer in lowercase abcdef. + +uvXUformat (perlxvf.U): + This variable contains the format string used for printing + a Perl UV as an unsigned hexadecimal integer in uppercase ABCDEF. vendorarch (vendorarch.U): This variable contains the value of the PERL_VENDORARCH symbol. @@ -3583,6 +3744,18 @@ version (patchlevel.U): This is suitable for use as a directory name, and hence is filesystem dependent. +versiononly (versiononly.U): + If set, this symbol indicates that only the version-specific + components of a perl installation should be installed. + This may be useful for making a test installation of a new + version without disturbing the existing installation. + Setting versiononly is equivalent to setting installperl's -v option. + In particular, the non-versioned scripts and programs such as + a2p, c2ph, h2xs, pod2*, and perldoc are not installed + (see INSTALL for a more complete list). Nor are the man + pages installed. + Usually, this is undef. + vi (Loc.U): This variable is defined but not used by Configure. The value is a plain '' and is not useful. diff --git a/contrib/perl5/Porting/config.sh b/contrib/perl5/Porting/config.sh index 3f29888e6c68..297a3e269a3a 100644 --- a/contrib/perl5/Porting/config.sh +++ b/contrib/perl5/Porting/config.sh @@ -8,7 +8,7 @@ # Package name : perl5 # Source directory : . -# Configuration time: Tue Mar 21 23:22:20 EET 2000 +# Configuration time: Sat Mar 3 01:13:55 EET 2001 # Configured by : jhi # Target system : osf1 alpha.hut.fi v4.0 878 alpha @@ -35,10 +35,10 @@ api_subversion='0' api_version='5' api_versionstring='5.005' ar='ar' -archlib='/opt/perl/lib/5.6.0/alpha-dec_osf-thread-multi' -archlibexp='/opt/perl/lib/5.6.0/alpha-dec_osf-thread-multi' +archlib='/opt/perl/lib/5.6.1/alpha-dec_osf-thread' +archlibexp='/opt/perl/lib/5.6.1/alpha-dec_osf-thread' archname64='' -archname='alpha-dec_osf-thread-multi' +archname='alpha-dec_osf-thread' archobjs='' awk='awk' baserev='5.0' @@ -46,7 +46,7 @@ bash='' bin='/opt/perl/bin' bincompat5005='undef' binexp='/opt/perl/bin' -bison='' +bison='bison' byacc='byacc' byteorder='12345678' c='\c' @@ -54,12 +54,15 @@ castflags='0' cat='cat' cc='cc' cccdlflags=' ' -ccdlflags=' -Wl,-rpath,/opt/perl/lib/5.6.0/alpha-dec_osf-thread-multi/CORE' +ccdlflags=' -Wl,-rpath,/opt/perl/lib/5.6.1/alpha-dec_osf-thread/CORE' ccflags='-pthread -std -DLANGUAGE_C' +ccflags_uselargefiles='' +ccname='cc' ccsymbols='__alpha=1 __LANGUAGE_C__=1 __osf__=1 __unix__=1 _LONGLONG=1 _SYSTYPE_BSD=1 SYSTYPE_BSD=1 unix=1' +ccversion='V5.6-082' cf_by='jhi' cf_email='yourname@yourhost.yourplace.com' -cf_time='Tue Mar 21 23:22:20 EET 2000' +cf_time='Sat Mar 3 01:13:55 EET 2001' charsize='1' chgrp='' chmod='' @@ -83,10 +86,10 @@ crosscompile='undef' cryptlib='' csh='csh' d_Gconvert='gcvt((x),(n),(b))' -d_PRIEldbl='define' -d_PRIFldbl='define' -d_PRIGldbl='define' -d_PRIX64='define' +d_PRIEUldbl='define' +d_PRIFUldbl='define' +d_PRIGUldbl='define' +d_PRIXU64='define' d_PRId64='define' d_PRIeldbl='define' d_PRIfldbl='define' @@ -95,6 +98,8 @@ d_PRIi64='define' d_PRIo64='define' d_PRIu64='define' d_PRIx64='define' +d_SCNfldbl='define' +d__fwalk='undef' d_access='define' d_accessx='undef' d_alarm='define' @@ -136,12 +141,12 @@ d_endnent='define' d_endpent='define' d_endpwent='define' d_endsent='define' -d_endspent='undef' d_eofnblk='define' 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' @@ -151,14 +156,17 @@ d_flock='define' d_fork='define' d_fpathconf='define' d_fpos64_t='undef' +d_frexpl='define' d_fs_data_s='undef' d_fseeko='undef' d_fsetpos='define' d_fstatfs='define' d_fstatvfs='define' +d_fsync='define' d_ftello='undef' d_ftime='undef' d_getcwd='define' +d_getespwnam='undef' d_getfsstat='define' d_getgrent='define' d_getgrps='define' @@ -174,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' @@ -183,12 +192,12 @@ d_getpgrp='define' d_getppid='define' d_getprior='define' d_getprotoprotos='define' +d_getprpwnam='undef' d_getpwent='define' d_getsbyname='define' d_getsbyport='define' d_getsent='define' d_getservprotos='define' -d_getspent='undef' d_getspnam='undef' d_gettimeod='define' d_gnulibc='undef' @@ -200,6 +209,8 @@ d_index='undef' d_inetaton='define' d_int64_t='undef' d_isascii='define' +d_isnan='define' +d_isnanl='define' d_killpg='define' d_lchown='define' d_ldbl_dig='define' @@ -226,6 +237,7 @@ d_mkstemp='define' d_mkstemps='undef' d_mktime='define' d_mmap='define' +d_modfl='define' d_mprotect='define' d_msg='define' d_msg_ctrunc='define' @@ -242,6 +254,7 @@ d_munmap='define' d_mymalloc='undef' d_nice='define' d_nv_preserves_uv='undef' +d_nv_preserves_uv_bits='53' d_off64_t='undef' d_old_pthread_create_joinable='undef' d_oldpthreads='undef' @@ -249,6 +262,7 @@ d_oldsock='undef' d_open3='define' d_pathconf='define' d_pause='define' +d_perl_otherlibdirs='undef' d_phostname='undef' d_pipe='define' d_poll='define' @@ -272,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' @@ -295,6 +310,7 @@ d_setpgid='define' d_setpgrp2='undef' d_setpgrp='define' d_setprior='define' +d_setproctitle='undef' d_setpwent='define' d_setregid='define' d_setresgid='undef' @@ -304,7 +320,6 @@ d_setrgid='define' d_setruid='define' d_setsent='define' d_setsid='define' -d_setspent='undef' d_setvbuf='define' d_sfio='undef' d_shm='define' @@ -318,6 +333,7 @@ d_sigsetjmp='define' d_socket='define' d_socklen_t='undef' d_sockpair='define' +d_socks5_init='undef' d_sqrtl='define' d_statblks='define' d_statfs_f_flags='define' @@ -325,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' @@ -404,6 +422,7 @@ freetype='void' full_ar='/usr/bin/ar' full_csh='/usr/bin/csh' full_sed='/usr/bin/sed' +gccosandvers='' gccversion='' gidformat='"u"' gidsign='1' @@ -418,7 +437,6 @@ h_fcntl='false' h_sysfile='true' hint='recommended' hostcat='cat /etc/hosts' -huge='' i16size='2' i16type='short' i32size='4' @@ -441,6 +459,7 @@ i_grp='define' i_iconv='define' i_ieeefp='undef' i_inttypes='undef' +i_libutil='undef' i_limits='define' i_locale='define' i_machcthr='undef' @@ -454,6 +473,7 @@ i_neterrno='undef' i_netinettcp='define' i_niin='define' i_poll='define' +i_prot='define' i_pthread='define' i_pwd='define' i_rpcsvcdbm='undef' @@ -509,44 +529,46 @@ inc_version_list=' ' inc_version_list_init='0' incpath='' inews='' -installarchlib='/opt/perl/lib/5.6.0/alpha-dec_osf-thread-multi' +installarchlib='/opt/perl/lib/5.6.1/alpha-dec_osf-thread' installbin='/opt/perl/bin' installman1dir='/opt/perl/man/man1' installman3dir='/opt/perl/man/man3' installprefix='/opt/perl' installprefixexp='/opt/perl' -installprivlib='/opt/perl/lib/5.6.0' +installprivlib='/opt/perl/lib/5.6.1' installscript='/opt/perl/bin' -installsitearch='/opt/perl/lib/site_perl/5.6.0/alpha-dec_osf-thread-multi' +installsitearch='/opt/perl/lib/site_perl/5.6.1/alpha-dec_osf-thread' installsitebin='/opt/perl/bin' -installsitelib='/opt/perl/lib/site_perl/5.6.0' +installsitelib='/opt/perl/lib/site_perl/5.6.1' installstyle='lib' installusrbinperl='define' 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 Fcntl File/Glob GDBM_File IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Sys/Hostname Sys/Syslog Thread attrs re' ksh='' -large='' ld='ld' lddlflags='-shared -expect_unresolved "*" -msym -std -s' ldflags='' +ldflags_uselargefiles='' ldlibpthname='LD_LIBRARY_PATH' less='less' lib_ext='.a' libc='/usr/shlib/libc.so' libperl='libperl.so' libpth='/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc /usr/lib /var/shlib' -libs='-lgdbm -ldbm -ldb -lm -liconv -lpthread -lexc' +libs='-lgdbm -ldbm -ldb -lm -liconv -lutil -lpthread -lexc' libsdirs=' /usr/shlib /usr/ccs/lib' -libsfiles=' libgdbm.so libdbm.a libdb.so libm.so libiconv.so libpthread.so libexc.so' -libsfound=' /usr/shlib/libgdbm.so /usr/ccs/lib/libdbm.a /usr/shlib/libdb.so /usr/shlib/libm.so /usr/shlib/libiconv.so /usr/shlib/libpthread.so /usr/shlib/libexc.so' +libsfiles=' libgdbm.so libdbm.a libdb.so libm.so libiconv.so libutil.a libpthread.so libexc.so' +libsfound=' /usr/shlib/libgdbm.so /usr/ccs/lib/libdbm.a /usr/shlib/libdb.so /usr/shlib/libm.so /usr/shlib/libiconv.so /usr/ccs/lib/libutil.a /usr/shlib/libpthread.so /usr/shlib/libexc.so' libspath=' /usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc /usr/lib /var/shlib' -libswanted='sfio socket bind inet nsl nm gdbm dbm db malloc dld ld sun m cposix posix ndir dir crypt sec ucb BSD x iconv pthread exc' +libswanted='sfio socket bind inet nsl nm gdbm dbm db malloc dld ld sun m cposix posix ndir dir crypt sec ucb BSD x iconv util pthread exc' +libswanted_uselargefiles='' line='' lint='' lkflags='' @@ -575,11 +597,9 @@ man1ext='1' man3dir='/opt/perl/man/man3' man3direxp='/opt/perl/man/man3' man3ext='3' -medium='' mips_type='' mkdir='mkdir' mmaptype='void *' -models='none' modetype='mode_t' more='more' multiarch='undef' @@ -598,6 +618,12 @@ nm_opt='-p' nm_so_opt='' nonxs_ext='Errno' nroff='nroff' +nvEUformat='"E"' +nvFUformat='"F"' +nvGUformat='"G"' +nveformat='"e"' +nvfformat='"f"' +nvgformat='"g"' nvsize='8' nvtype='double' o_nonblock='O_NONBLOCK' @@ -607,6 +633,7 @@ optimize='-O' orderlib='false' osname='dec_osf' osvers='4.0' +otherlibdirs=' ' package='perl5' pager='/c/bin/less' passcat='cat /etc/passwd' @@ -615,6 +642,7 @@ path_sep=':' perl5='/u/vieraat/vieraat/jhi/Perl/bin/perl' perl='' perladmin='yourname@yourhost.yourplace.com' +perllibs='-lm -liconv -lutil -lpthread -lexc' perlpath='/opt/perl/bin/perl' pg='pg' phostname='' @@ -625,8 +653,8 @@ pmake='' pr='' prefix='/opt/perl' prefixexp='/opt/perl' -privlib='/opt/perl/lib/5.6.0' -privlibexp='/opt/perl/lib/5.6.0' +privlib='/opt/perl/lib/5.6.1' +privlibexp='/opt/perl/lib/5.6.1' prototype='define' ptrsize='8' quadkind='2' @@ -640,10 +668,10 @@ revision='5' rm='rm' rmail='' runnm='true' -sPRIEldbl='"E"' -sPRIFldbl='"F"' -sPRIGldbl='"G"' -sPRIX64='"lX"' +sPRIEUldbl='"E"' +sPRIFUldbl='"F"' +sPRIGUldbl='"G"' +sPRIXU64='"lX"' sPRId64='"ld"' sPRIeldbl='"e"' sPRIfldbl='"f"' @@ -652,6 +680,7 @@ sPRIi64='"li"' sPRIo64='"lo"' sPRIu64='"lu"' sPRIx64='"lx"' +sSCNfldbl='"f"' sched_yield='sched_yield()' scriptdir='/opt/perl/bin' scriptdirexp='/opt/perl/bin' @@ -673,20 +702,19 @@ sig_name_init='"ZERO", "HUP", "INT", "QUIT", "ILL", "TRAP", "ABRT", "EMT", "FPE" sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 6 6 16 20 23 23 23 29 48 ' sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 6, 6, 16, 20, 23, 23, 23, 29, 48, 0' signal_t='void' -sitearch='/opt/perl/lib/site_perl/5.6.0/alpha-dec_osf-thread-multi' -sitearchexp='/opt/perl/lib/site_perl/5.6.0/alpha-dec_osf-thread-multi' +sitearch='/opt/perl/lib/site_perl/5.6.1/alpha-dec_osf-thread' +sitearchexp='/opt/perl/lib/site_perl/5.6.1/alpha-dec_osf-thread' sitebin='/opt/perl/bin' sitebinexp='/opt/perl/bin' -sitelib='/opt/perl/lib/site_perl/5.6.0' +sitelib='/opt/perl/lib/site_perl/5.6.1' sitelib_stem='/opt/perl/lib/site_perl' -sitelibexp='/opt/perl/lib/site_perl/5.6.0' +sitelibexp='/opt/perl/lib/site_perl/5.6.1' siteprefix='/opt/perl' siteprefixexp='/opt/perl' sizesize='8' sizetype='size_t' sleep='' smail='' -small='' so='so' sockethdr='' socketlib='' @@ -694,8 +722,7 @@ socksizetype='int' sort='sort' spackage='Perl5' spitshell='cat' -split='' -src='.' +src='/m/fs/work/work/permanent/perl/pp4/maint-5.6/perl' ssizetype='ssize_t' startperl='#!/opt/perl/bin/perl' startsh='#!/bin/sh' @@ -709,7 +736,7 @@ stdio_ptr='((fp)->_ptr)' stdio_stream_array='_iob' strings='/usr/include/string.h' submit='' -subversion='0' +subversion='1' sysman='/usr/man/man1' tail='' tar='' @@ -737,15 +764,15 @@ uidtype='uid_t' uname='uname' uniq='uniq' uquadtype='unsigned long' -use5005threads='undef' +use5005threads='define' use64bitall='define' use64bitint='define' usedl='define' -useithreads='define' +useithreads='undef' uselargefiles='define' uselongdouble='undef' usemorebits='undef' -usemultiplicity='define' +usemultiplicity='undef' usemymalloc='n' usenm='true' useopcode='true' @@ -759,6 +786,7 @@ usevendorprefix='undef' usevfork='false' usrinc='/usr/include' uuname='' +uvXUformat='"lX"' uvoformat='"lo"' uvsize='8' uvtype='unsigned long' @@ -773,31 +801,36 @@ vendorlib_stem='' vendorlibexp='' vendorprefix='' vendorprefixexp='' -version='5.6.0' +version='5.6.1' +versiononly='undef' vi='' voidflags='15' xlibpth='/usr/lib/386 /lib/386' -xs_apiversion='5.6.0' +xs_apiversion='5.6.1' +yacc='/u/vieraat/vieraat/jhi/Perl/bin/byacc' +yaccflags='' zcat='' zip='zip' # Configure command line arguments. -config_arg0='Configure' -config_args='-Dprefix=/opt/perl -Doptimize=-O -Dusethreads -Duse64bitint -Duselargefiles -Dcf_by=yourname -Dcf_email=yourname@yourhost.yourplace.com -Dperladmin=yourname@yourhost.yourplace.com -Dmydomain=.yourplace.com -Dmyhostname=yourhost -dE' -config_argc=11 +config_arg0='./Configure' +config_args='-Dprefix=/opt/perl -Doptimize=-O -Dusethreads -Duse5005threads -Duse64bitint -Duselargefiles -Dcf_by=yourname -Dcf_email=yourname@yourhost.yourplace.com -Dperladmin=yourname@yourhost.yourplace.com -Dmydomain=.yourplace.com -Dmyhostname=yourhost -dE -Dusedevel' +config_argc=13 config_arg1='-Dprefix=/opt/perl' config_arg2='-Doptimize=-O' config_arg3='-Dusethreads' -config_arg4='-Duse64bitint' -config_arg5='-Duselargefiles' -config_arg6='-Dcf_by=yourname' -config_arg7='-Dcf_email=yourname@yourhost.yourplace.com' -config_arg8='-Dperladmin=yourname@yourhost.yourplace.com' -config_arg9='-Dmydomain=.yourplace.com' -config_arg10='-Dmyhostname=yourhost' -config_arg11='-dE' +config_arg4='-Duse5005threads' +config_arg5='-Duse64bitint' +config_arg6='-Duselargefiles' +config_arg7='-Dcf_by=yourname' +config_arg8='-Dcf_email=yourname@yourhost.yourplace.com' +config_arg9='-Dperladmin=yourname@yourhost.yourplace.com' +config_arg10='-Dmydomain=.yourplace.com' +config_arg11='-Dmyhostname=yourhost' +config_arg12='-dE' +config_arg13='-Dusedevel' PERL_REVISION=5 PERL_VERSION=6 -PERL_SUBVERSION=0 +PERL_SUBVERSION=1 PERL_API_REVISION=5 PERL_API_VERSION=5 PERL_API_SUBVERSION=0 diff --git a/contrib/perl5/Porting/config_H b/contrib/perl5/Porting/config_H index c80ebaffe0e3..311fd91524c7 100644 --- a/contrib/perl5/Porting/config_H +++ b/contrib/perl5/Porting/config_H @@ -17,7 +17,7 @@ /* * Package name : perl5 * Source directory : . - * Configuration time: Tue Mar 21 23:22:20 EET 2000 + * Configuration time: Sat Mar 3 01:13:55 EET 2001 * Configured by : jhi * Target system : osf1 alpha.hut.fi v4.0 878 alpha */ @@ -224,17 +224,6 @@ */ #define HAS_GETPGID /**/ -/* 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_GETPGRP2: * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) * routine is available to get the current process group. @@ -489,18 +478,6 @@ */ #define HAS_SETPGID /**/ -/* 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_SETPGRP2: * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) * routine is available to set the current process group. @@ -984,12 +961,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. @@ -1092,8 +1063,8 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "/opt/perl/lib/5.6.0/alpha-dec_osf-thread-multi" /**/ -#define ARCHLIB_EXP "/opt/perl/lib/5.6.0/alpha-dec_osf-thread-multi" /**/ +#define ARCHLIB "/opt/perl/lib/5.6.1/alpha-dec_osf-thread" /**/ +#define ARCHLIB_EXP "/opt/perl/lib/5.6.1/alpha-dec_osf-thread" /**/ /* ARCHNAME: * This symbol holds a string representing the architecture name. @@ -1101,7 +1072,7 @@ * where library files may be held under a private library, for * instance. */ -#define ARCHNAME "alpha-dec_osf-thread-multi" /**/ +#define ARCHNAME "alpha-dec_osf-thread" /**/ /* HAS_ATOLF: * This symbol, if defined, indicates that the atolf routine is @@ -1184,21 +1155,21 @@ * This macro surrounds its token with double quotes. */ #if 42 == 1 -# define CAT2(a,b) a/**/b -# define STRINGIFY(a) "a" +#define CAT2(a,b) a/**/b +#define STRINGIFY(a) "a" /* If you can get stringification with catify, tell me how! */ #endif #if 42 == 42 -# define PeRl_CaTiFy(a, b) a ## b -# define PeRl_StGiFy(a) #a +#define PeRl_CaTiFy(a, b) a ## b +#define PeRl_StGiFy(a) #a /* the additional level of indirection enables these macros to be * used as arguments to other macros. See K&R 2nd ed., page 231. */ -# define CAT2(a,b) PeRl_CaTiFy(a,b) -# define StGiFy(a) PeRl_StGiFy(a) -# define STRINGIFY(a) PeRl_StGiFy(a) +#define CAT2(a,b) PeRl_CaTiFy(a,b) +#define StGiFy(a) PeRl_StGiFy(a) +#define STRINGIFY(a) PeRl_StGiFy(a) #endif #if 42 != 1 && 42 != 42 -#include "Bletch: How does this C preprocessor catenate tokens?" +# include "Bletch: How does this C preprocessor catenate tokens?" #endif /* CPPSTDIN: @@ -1328,23 +1299,30 @@ */ #define HAS_ENDSERVENT /**/ -/* HAS_ENDSPENT: - * This symbol, if defined, indicates that the endspent system call is - * available to finalize the scan of SysV shadow password entries. - */ -/*#define HAS_ENDSPENT / **/ - /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in <sys/types.h> */ #define HAS_FD_SET /**/ +/* FLEXFILENAMES: + * This symbol, if defined, indicates that the system supports filenames + * longer than 14 characters. + */ +#define FLEXFILENAMES /**/ + /* HAS_FPOS64_T: * This symbol will be defined if the C compiler supports fpos64_t. */ /*#define HAS_FPOS64_T / **/ +/* HAS_FREXPL: + * This symbol, if defined, indicates that the frexpl routine is + * available to break a long double floating-point number into + * a normalized fraction and an integral power of 2. + */ +#define HAS_FREXPL /**/ + /* HAS_STRUCT_FS_DATA: * This symbol, if defined, indicates that the struct fs_data * to do statfs() is supported. @@ -1392,6 +1370,12 @@ */ #define HAS_GETCWD /**/ +/* HAS_GETESPWNAM: + * This symbol, if defined, indicates that the getespwnam system call is + * available to retrieve enchanced (shadow) password entries by name. + */ +/*#define HAS_GETESPWNAM / **/ + /* HAS_GETFSSTAT: * This symbol, if defined, indicates that the getfsstat routine is * available to stat filesystems in bulk. @@ -1497,6 +1481,13 @@ */ #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. @@ -1522,6 +1513,12 @@ */ #define HAS_GETPROTO_PROTOS /**/ +/* HAS_GETPRPWNAM: + * This symbol, if defined, indicates that the getprpwnam system call is + * available to retrieve protected (shadow) password entries by name. + */ +/*#define HAS_GETPRPWNAM / **/ + /* HAS_GETPWENT: * This symbol, if defined, indicates that the getpwent routine is * available for sequential access of the passwd database. @@ -1543,12 +1540,6 @@ */ #define HAS_GETSERV_PROTOS /**/ -/* HAS_GETSPENT: - * This symbol, if defined, indicates that the getspent system call is - * available to retrieve SysV shadow password entries sequentially. - */ -/*#define HAS_GETSPENT / **/ - /* HAS_GETSPNAM: * This symbol, if defined, indicates that the getspnam system call is * available to retrieve SysV shadow password entries by name. @@ -1624,6 +1615,25 @@ */ #define HAS_ISASCII /**/ +/* HAS_ISNAN: + * This symbol, if defined, indicates that the isnan routine is + * available to check whether a double is a NaN. + */ +#define HAS_ISNAN /**/ + +/* HAS_ISNANL: + * This symbol, if defined, indicates that the isnanl routine is + * available to check whether a long double is a NaN. + */ +#define HAS_ISNANL /**/ + +/* HAS_LCHOWN: + * This symbol, if defined, indicates that the lchown routine is + * available to operate on a symbolic link (instead of following the + * link). + */ +#define HAS_LCHOWN /**/ + /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's <float.h> * or <limits.h> defines the symbol LDBL_DIG, which is the number @@ -1711,6 +1721,13 @@ #define HAS_MMAP /**/ #define Mmap_t void * /**/ +/* HAS_MODFL: + * This symbol, if defined, indicates that the modfl routine is + * available to split a long double x into a fractional part f and + * an integer part i such that |f| < 1.0 and (f + i) = x. + */ +#define HAS_MODFL /**/ + /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is * available to modify the access protection of a memory mapped file. @@ -1823,6 +1840,12 @@ */ #define HAS_SETPROTOENT /**/ +/* HAS_SETPROCTITLE: + * This symbol, if defined, indicates that the setproctitle routine is + * available to set process title. + */ +/*#define HAS_SETPROCTITLE / **/ + /* HAS_SETPWENT: * This symbol, if defined, indicates that the setpwent routine is * available for initializing sequential access of the passwd database. @@ -1835,12 +1858,6 @@ */ #define HAS_SETSERVENT /**/ -/* HAS_SETSPENT: - * This symbol, if defined, indicates that the setspent system call is - * available to initialize the scan of SysV shadow password entries. - */ -/*#define HAS_SETSPENT / **/ - /* HAS_SETVBUF: * This symbol, if defined, indicates that the setvbuf routine is * available to change buffering on an open stdio stream. @@ -1944,6 +1961,12 @@ /*#define HAS_MSG_PROXY / **/ #define HAS_SCM_RIGHTS /**/ +/* HAS_SOCKS5_INIT: + * This symbol, if defined, indicates that the socks5_init routine is + * available to initialize SOCKS 5. + */ +/*#define HAS_SOCKS5_INIT / **/ + /* HAS_SQRTL: * This symbol, if defined, indicates that the sqrtl routine is * available to do long double square roots. @@ -2006,12 +2029,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: @@ -2279,6 +2313,12 @@ */ /*#define I_INTTYPES / **/ +/* I_LIBUTIL: + * This symbol, if defined, indicates that <libutil.h> exists and + * should be included. + */ +/*#define I_LIBUTIL / **/ + /* I_MACH_CTHREADS: * This symbol, if defined, indicates to the C program that it should * include <mach/cthreads.h>. @@ -2309,6 +2349,12 @@ */ #define I_POLL /**/ +/* I_PROT: + * This symbol, if defined, indicates that <prot.h> exists and + * should be included. + */ +#define I_PROT /**/ + /* I_PTHREAD: * This symbol, if defined, indicates to the C program that it should * include <pthread.h>. @@ -2471,8 +2517,18 @@ * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'g') for output. */ +/* PERL_PRIeldbl: + * This symbol, if defined, contains the string used by stdio to + * format long doubles (format 'e') for output. + */ +/* PERL_SCNfldbl: + * This symbol, if defined, contains the string used by stdio to + * format long doubles (format 'f') for input. + */ #define PERL_PRIfldbl "f" /**/ #define PERL_PRIgldbl "g" /**/ +#define PERL_PRIeldbl "e" /**/ +#define PERL_SCNfldbl "f" /**/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. @@ -2560,6 +2616,16 @@ #define Netdb_name_t const char * /**/ #define Netdb_net_t int /**/ +/* PERL_OTHERLIBDIRS: + * This variable contains a colon-separated set of paths for the perl + * binary to search for additional library files or modules. + * These directories will be tacked to the end of @INC. + * Perl will automatically search below each path for version- + * and architecture-specific directories. See PERL_INC_VERSION_LIST + * for more details. + */ +/*#define PERL_OTHERLIBDIRS " " / **/ + /* IVTYPE: * This symbol defines the C type used for Perl's IV. */ @@ -2623,9 +2689,16 @@ /* U64SIZE: * This symbol contains the sizeof(U64). */ +/* NVSIZE: + * This symbol contains the sizeof(NV). + */ /* NV_PRESERVES_UV: * This symbol, if defined, indicates that a variable of type NVTYPE - * can preserve all the bit of a variable of type UVSIZE. + * can preserve all the bits of a variable of type UVTYPE. + */ +/* NV_PRESERVES_UV_BITS: + * This symbol contains the number of bits a variable of type NVTYPE + * can preserve of a variable of type UVTYPE. */ #define IVTYPE long /**/ #define UVTYPE unsigned long /**/ @@ -2652,7 +2725,9 @@ #define I64SIZE 8 /**/ #define U64SIZE 8 /**/ #endif +#define NVSIZE 8 /**/ #undef NV_PRESERVES_UV +#define NV_PRESERVES_UV_BITS 53 /* IVdf: * This symbol defines the format string used for printing a Perl IV @@ -2668,12 +2743,27 @@ */ /* UVxf: * This symbol defines the format string used for printing a Perl UV - * as an unsigned hexadecimal integer. + * as an unsigned hexadecimal integer in lowercase abcdef. + */ +/* NVef: + * This symbol defines the format string used for printing a Perl NV + * using %e-ish floating point format. + */ +/* NVff: + * This symbol defines the format string used for printing a Perl NV + * using %f-ish floating point format. + */ +/* NVgf: + * This symbol defines the format string used for printing a Perl NV + * using %g-ish floating point format. */ #define IVdf "ld" /**/ #define UVuf "lu" /**/ #define UVof "lo" /**/ #define UVxf "lx" /**/ +#define NVef "e" /**/ +#define NVff "f" /**/ +#define NVgf "g" /**/ /* Pid_t: * This symbol holds the type used to declare process ids in the kernel. @@ -2692,8 +2782,8 @@ * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define PRIVLIB "/opt/perl/lib/5.6.0" /**/ -#define PRIVLIB_EXP "/opt/perl/lib/5.6.0" /**/ +#define PRIVLIB "/opt/perl/lib/5.6.1" /**/ +#define PRIVLIB_EXP "/opt/perl/lib/5.6.1" /**/ /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor @@ -2791,8 +2881,8 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "/opt/perl/lib/site_perl/5.6.0/alpha-dec_osf-thread-multi" /**/ -#define SITEARCH_EXP "/opt/perl/lib/site_perl/5.6.0/alpha-dec_osf-thread-multi" /**/ +#define SITEARCH "/opt/perl/lib/site_perl/5.6.1/alpha-dec_osf-thread" /**/ +#define SITEARCH_EXP "/opt/perl/lib/site_perl/5.6.1/alpha-dec_osf-thread" /**/ /* SITELIB: * This symbol contains the name of the private library for this package. @@ -2814,8 +2904,8 @@ * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ -#define SITELIB "/opt/perl/lib/site_perl/5.6.0" /**/ -#define SITELIB_EXP "/opt/perl/lib/site_perl/5.6.0" /**/ +#define SITELIB "/opt/perl/lib/site_perl/5.6.1" /**/ +#define SITELIB_EXP "/opt/perl/lib/site_perl/5.6.1" /**/ #define SITELIB_STEM "/opt/perl/lib/site_perl" /**/ /* Size_t_size: @@ -2943,7 +3033,7 @@ * be built to use multiplicity. */ #ifndef MULTIPLICITY -#define MULTIPLICITY /**/ +/*#define MULTIPLICITY / **/ #endif /* USE_PERLIO: @@ -2975,8 +3065,8 @@ * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ -/*#define USE_5005THREADS / **/ -#define USE_ITHREADS /**/ +#define USE_5005THREADS /**/ +/*#define USE_ITHREADS / **/ #if defined(USE_5005THREADS) && !defined(USE_ITHREADS) #define USE_THREADS /* until src is revised*/ #endif @@ -3040,7 +3130,7 @@ /* PERL_XS_APIVERSION: * This variable contains the version of the oldest perl binary * compatible with the present perl. perl.c:incpush() and - * lib/lib.pm will automatically search in /opt/perl/lib/site_perl/5.6.0/alpha-dec_osf-thread-multi for older + * lib/lib.pm will automatically search in /opt/perl/lib/site_perl/5.6.1/alpha-dec_osf-thread for older * directories across major versions back to xs_apiversion. * This is only useful if you have a perl library directory tree * structured like the default one. @@ -3059,7 +3149,7 @@ * compatible with the present perl. (That is, pure perl modules * written for pm_apiversion will still work for the current * version). perl.c:incpush() and lib/lib.pm will automatically - * search in /opt/perl/lib/site_perl/5.6.0 for older directories across major versions + * search in /opt/perl/lib/site_perl/5.6.1 for older directories across major versions * back to pm_apiversion. This is only useful if you have a perl * library directory tree structured like the default one. The * versioned site_perl library was introduced in 5.005, so that's @@ -3069,20 +3159,65 @@ * (presumably) be similar. * See the INSTALL file for how this works. */ -#define PERL_XS_APIVERSION "5.6.0" +#define PERL_XS_APIVERSION "5.6.1" #define PERL_PM_APIVERSION "5.005" -/* HAS_LCHOWN: - * This symbol, if defined, indicates that the lchown routine is - * available to operate on a symbolic link (instead of following the - * link). +/* HAS_GETPGRP: + * This symbol, if defined, indicates that the getpgrp routine is + * available to get the current process group. */ -#define HAS_LCHOWN /**/ +/* 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 / **/ -/* FLEXFILENAMES: - * This symbol, if defined, indicates that the system supports filenames - * longer than 14 characters. +/* HAS_SETPGRP: + * This symbol, if defined, indicates that the setpgrp routine is + * available to set the current process group. */ -#define FLEXFILENAMES /**/ +/* 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 /**/ + +/* 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__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 / **/ + +/* 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_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_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 /**/ #endif diff --git a/contrib/perl5/Porting/genlog b/contrib/perl5/Porting/genlog index efb7ef8e108d..e040b9ef2cf4 100755 --- a/contrib/perl5/Porting/genlog +++ b/contrib/perl5/Porting/genlog @@ -20,7 +20,7 @@ use Text::Wrap; $0 =~ s|^.*/||; unless (@ARGV) { die <<USAGE; - $0 [-p \$P4PORT] <change numbers or from..to> + $0 [-p \$P4PORT] [-bi branch_include] [-be branch_exclude] <change numbers or from..to> USAGE } @@ -32,6 +32,11 @@ my %editkind; my $p4port = $ENV{P4PORT} || 'localhost:1666'; +my @branch_include; +my @branch_exclude; +my %branch_include; +my %branch_exclude; + while (@ARGV) { $_ = shift; if (/^(\d+)\.\.(\d+)$/) { @@ -43,6 +48,12 @@ while (@ARGV) { elsif (/^-p(.*)$/) { $p4port = $1 || shift; } + elsif (/^-bi(.*)$/) { + push @branch_include, $1 || shift; + } + elsif (/^-be(.*)$/) { + push @branch_exclude, $1 || shift; + } else { warn "Arguments must be change numbers, ignoring `$_'\n"; } @@ -50,6 +61,9 @@ while (@ARGV) { @changes = sort { $b <=> $a } @changes; +@branch_include{@branch_include} = @branch_include if @branch_include; +@branch_exclude{@branch_exclude} = @branch_exclude if @branch_exclude; + my @desc = `p4 -p $p4port describe -s @changes`; if ($?) { die "$0: `p4 -p $p4port describe -s @changes` failed, status[$?]\n"; @@ -58,6 +72,8 @@ else { chomp @desc; 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); @@ -73,6 +89,12 @@ 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}) { + $skip++; + } $files{$branch} = {} unless exists $files{$branch}; $files{$branch}{$type} = [] unless exists $files{$branch}{$type}; push @{$files{$branch}{$type}}, $file; @@ -83,7 +105,7 @@ else { } } } - next unless $change; + next if not $change or $skip == $nbranch; print "_" x 76, "\n"; printf <<EOT, $change, $who, $date, $time; [%6s] By: %-25s on %9s %9s diff --git a/contrib/perl5/Porting/makerel b/contrib/perl5/Porting/makerel index 4b8c277ebd1d..c519d5d3c2ee 100755 --- a/contrib/perl5/Porting/makerel +++ b/contrib/perl5/Porting/makerel @@ -78,23 +78,29 @@ print "\n"; chdir "$relroot/$reldir" or die $!; print "Setting file permissions...\n"; -system("find . -type f -print | xargs chmod -w"); -system("find . -type d -print | xargs chmod g-s"); -system("find t -name '*.t' -print | xargs chmod +x"); +system("find . -type f -print | xargs chmod a-w"); +system("find . -type d -print | xargs chmod 0755"); + +# the right files should already have the execute bit set +# in the repository, but this is just insurance +system("find t -name '*.t' -print | xargs chmod a+x"); my @exe = qw( Configure + configure.gnu configpm - embed.pl installperl + installhtml installman + embed.pl keywords.pl opcode.pl + warnings.pl perly.fixer t/TEST t/*/*.t *.SH vms/ext/Stdio/test.pl - vms/ext/filespec.t + vms/ext/*.t x2p/*.SH Porting/patchls Porting/makerel @@ -102,20 +108,31 @@ my @exe = qw( system("chmod +x @exe"); my @writables = qw( + keywords.h + opcode.h + opnames.h + pp_proto.h + pp.sym + proto.h embed.h embedvar.h - ext/B/B/Asmdata.pm - ext/ByteLoader/byterun.c - ext/ByteLoader/byterun.h global.sym - keywords.h - lib/warnings.pm + pod/perlintern.pod + pod/perlapi.pod objXSUB.h - opcode.h - pp.sym - pp_proto.h + perlapi.h + perlapi.c + ext/ByteLoader/byterun.h + ext/ByteLoader/byterun.c + ext/B/B/Asmdata.pm regnodes.h warnings.h + lib/warnings.pm + vms/perly_c.vms + vms/perly_h.vms + win32/Makefile + win32/makefile.mk + win32/config_H.bc win32/config_H.bc win32/config_H.gc win32/config_H.vc diff --git a/contrib/perl5/Porting/p4desc b/contrib/perl5/Porting/p4desc index 0bf79da2e004..2d1c9d8219fd 100755 --- a/contrib/perl5/Porting/p4desc +++ b/contrib/perl5/Porting/p4desc @@ -6,7 +6,8 @@ # Gurusamy Sarathy <gsar@activestate.com> # -use vars qw($thisfile $change $file $fnum $h $v $p4port @addfiles); +use vars qw($thisfile $change $file $fnum $h $v $p4port @addfiles + $branches $skip); BEGIN { $0 =~ s|^.*/||; @@ -18,6 +19,9 @@ BEGIN { elsif (/^-p(.*)$/) { $p4port = $1 || ' '; } + elsif (/^-b(.*)$/) { + $branches = $1; + } elsif (/^-v$/) { $v++; } @@ -30,20 +34,28 @@ BEGIN { } unless (@files) { @files = '-'; undef $^I; } @ARGV = @files; + $branches = '//depot/perl/' unless defined $branches; if ($h) { print STDERR <<USAGE; Usage: $0 [-p \$P4PORT] [-v] [-h] [files] - -p host:port p4 port (e.g. myhost:1666) + -phost:port p4 port (e.g. myhost:1666) -h print this help -v output progress messages + -bbranch(es) which branches to include (regex) + (default: //depot/perl/) + -h show this help A smart 'cat'. When fed the spew from "p4 describe ..." on STDIN, spits it right out on STDOUT, followed by patches for any new files detected in the spew. Can also be used to edit insitu a bunch of files containing said spew. -WARNING: Currently only emits unified diffs. +WARNING 1: Currently only emits unified diffs (diff -u). + +WARNING 2: By default only the changes in the //depot/perl branch +are shown. To include all the branches, supply "-b." arguments +to $0. Examples: p4 describe -du 123 | $0 > change-123.desc @@ -65,14 +77,28 @@ my $cur = m|^Affected files| ... m|^Differences|; # while we are within range if ($cur) { - if (m{^\.\.\. (//depot/.+?#\d+) (add|branch)$}) { - my $newfile = $1; - push @addfiles, $newfile; - warn "$newfile add, revision != 1!\n" unless $newfile =~ /#1$/; + if (m|^\.\.\. |) { + if (m|$branches|) { + if (m{^\.\.\. (//depot/.+?\#\d+) (add|branch)$}) { + my $newfile = $1; + push @addfiles, $newfile; + warn "$newfile add, revision != 1!\n" unless $newfile =~ /#1$/; + } + } else { + push @skipped, "# $_"; + $_ = ''; + } } warn "file [$file] line [$cur] file# [$fnum]\n" if $v; } +if (m|^==== //depot/|) { + $skip = !m|$branches|; + print "# Skipped because not under branches: $branches\n" if $skip; +} + +$_ = "# $_" if $skip; + if (/^Change (\d+) by/) { $_ = "\n\n" . $_ if $change; # start of a new change list $change = $1; @@ -84,6 +110,9 @@ if (/^Change (\d+) by/) { if (eof) { $_ .= newfiles(); + $_ .= join('', "\n", + "# Skipped because not under branches: $branches\n", + @skipped, "\n") if @skipped; } sub newfiles { diff --git a/contrib/perl5/Porting/patching.pod b/contrib/perl5/Porting/patching.pod index 5659f23c60e1..7fd376b1a4d2 100644 --- a/contrib/perl5/Porting/patching.pod +++ b/contrib/perl5/Porting/patching.pod @@ -94,12 +94,7 @@ diffs. Some examples using GNU diff: # show function name in every hunk (safer, more informative) % diff -u -F '^[_a-zA-Z0-9]+ *(' old/file new/file - -=item Directories - -IMPORTANT: Patches should be generated from the source root directory, not -from the directory that the patched file resides in. This ensures that the -maintainer patches the proper file. +=item Derived Files Many files in the distribution are derivative--avoid patching them. Patch the originals instead. Most utilities (like perldoc) are in @@ -120,6 +115,31 @@ If you are submitting patches that affect multiple files then you should backup the entire directory tree (to $source_root.old/ for example). This will allow C<diff -ruN old-dir new-dir> to create all the patches at once. +=item Directories + +IMPORTANT: Patches should be generated from the source root directory, not +from the directory that the patched file resides in. This ensures that the +maintainer patches the proper file. + +For larger patches that are dealing with multiple files or +directories, Johan Vromans has written a powerful utility: makepatch. +See the JV directory on CPAN for the current version. If you have this +program available, it is recommended to create a duplicate of the perl +directory tree against which you are intending to provide a patch and +let makepatch figure out all the changes you made to your copy of the +sources. As perl comes with a MANIFEST file, you need not delete +object files and other derivative files from the two directory trees, +makepatch is smart about them. + +Say, you have created a directory perl-5.7.1@8685/ for the perl you +are taking as the base and a directory perl-5.7.1@8685-withfoo/ where +you have your changes, you would run makepatch as follows: + + makepatch -oldman perl-5.7.1@8685/MANIFEST \ + -newman perl-5.7.1@8685-withfoo/MANIFEST \ + -diff "diff -u" \ + perl-5.7.1@8685 perl-5.7.1@8685-withfoo + =item Try it yourself Just to make sure your patch "works", be sure to apply it to the Perl diff --git a/contrib/perl5/Porting/pumpkin.pod b/contrib/perl5/Porting/pumpkin.pod index 99776b50d2ee..3bc9d09c87ad 100644 --- a/contrib/perl5/Porting/pumpkin.pod +++ b/contrib/perl5/Porting/pumpkin.pod @@ -58,7 +58,7 @@ and 1 is the subversion. For compatibility with the older numbering scheme the composite floating point version number continues to be available as the magic variable $], -and amounts to C<$revision + $version/1000 + $subversion/1000000>. 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<not> to have a system call also update the list of A file called F<README.youros> 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<INSTALL.youros>. 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<perly.fixer> to detect this, but I never completed the task. -If C<perly.c> changes, make sure you run C<perl vms/vms_yfix.pl> to -update the corresponding VMS files. See L<VMS-specific updates>. +If C<perly.c> or C<perly.h> changes, make sure you run C<perl vms/vms_yfix.pl> +to update the corresponding VMS files. This could be taken care of by +the regen_all target in the Unix Makefile. See also +L<VMS-specific updates>. 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<embed.h>, F<keywords.h>, and F<opcode.h> files are all automatically @@ -532,6 +542,10 @@ and effort by manually running C<make regen_headers> 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<global.sym> or F<interp.sym>, 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<perly.y> or F<perly.c>, then you most probably want -to update F<vms/perly_{h,c}.vms> by running C<perl vms/vms_yfix.pl>. +to update F<vms/perly_{h,c}.vms> by running C<perl vms/vms_yfix.pl>, or +by running `make regen_all` which will run that script for you. -The Perl version number appears in several places under F<vms>. -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 @@ -701,6 +715,34 @@ supports dynamic loading, you can also test static loading with You can also hand-tweak your config.h to try out different #ifdef branches. +=head2 Other tests + +=over 4 + +=item CHECK_FORMAT + +To test the correct use of printf-style arguments, C<Configure> with +S<-Dccflags='-DCHECK_FORMAT -Wformat'> and run C<make>. The compiler +will produce warning of incorrect use of format arguments. CHECK_FORMAT +changes perl-defined formats to common formats, so DO NOT USE the executable +produced by this process. + +A more accurate approach is the following commands: + + sh Configure -des -Dccflags=-Wformat ... + make miniperl # without -DCHECK_FORMAT + perl -i.orig -pwe 's/-Wformat/-DCHECK_FORMAT $&/' config.sh + sh Configure -S + make >& make.log # build from correct miniperl + make clean + make miniperl >& mini.log # build miniperl with -DCHECK_FORMAT + perl -nwe 'print if /^\S+:/ and not /^make\b/' mini.log make.log + make clean + +(-Wformat support by Robin Barker.) + +=back + =head1 Running Purify Purify is a commercial tool that is helpful in identifying memory @@ -1325,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/contrib/perl5/README b/contrib/perl5/README index 0925b98018cc..28c5de8b0387 100644 --- a/contrib/perl5/README +++ b/contrib/perl5/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 @@ -22,8 +22,10 @@ Kit, in the file named "Artistic". If not, I'll be glad to provide one. You should also have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software Foundation, - Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA. + along with this program in the file named "Copying". If not, write to the + Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA + 02111-1307, USA or visit their web page on the internet at + http://www.gnu.org/copyleft/gpl.html. For those of you that choose to use the GNU General Public License, my interpretation of the GNU General Public License is that no Perl @@ -70,7 +72,7 @@ corresponding README. 2) Read the manual entries before running perl. 3) IMPORTANT! Help save the world! Communicate any problems and suggested -patches to perlbug@perl.com so we can keep the world in sync. +patches to perlbug@perl.org so we can keep the world in sync. If you have a problem, there's someone else out there who either has had or will have the same problem. It's usually helpful if you send the output of the "myconfig" script in the main perl directory. diff --git a/contrib/perl5/README.Y2K b/contrib/perl5/README.Y2K index 378db15c11a0..be7ff51b68a4 100644 --- a/contrib/perl5/README.Y2K +++ b/contrib/perl5/README.Y2K @@ -21,7 +21,7 @@ Long answer: The question belies a true understanding of the localtime) supply adequate information to determine the year well beyond 2000 (2038 is when trouble strikes for 32-bit machines). The year returned by these functions - when used in an array context is the year minus 1900. For + when used in a list context is the year minus 1900. For years between 1910 and 1999 this happens to be a 2-digit decimal number. To avoid the year 2000 problem simply do not treat the year as a 2-digit number. It isn't. diff --git a/contrib/perl5/Todo b/contrib/perl5/Todo index ba01d33db6f2..eb13f6588e5a 100644 --- a/contrib/perl5/Todo +++ b/contrib/perl5/Todo @@ -47,10 +47,6 @@ Would be nice to have to be used in re-entrant (=multithreaded) code Icky things: the _r API is not standardized and the _r-forms require per-thread data to store their state - memory profiler: turn malloc.c:Perl_get_mstats() into - an extension (Devel::MProf?) that would return the malloc - stats in a nice Perl datastructure (also a simple interface - to return just the grand total would be good) cross-compilation support host vs target: compile in the host, get the executable to the target, get the possible input files to the target, diff --git a/contrib/perl5/Todo-5.6 b/contrib/perl5/Todo-5.6 index 9abeb55ebb7a..71aca9cb0163 100644 --- a/contrib/perl5/Todo-5.6 +++ b/contrib/perl5/Todo-5.6 @@ -1,6 +1,5 @@ Unicode support finish byte <-> utf8 and localencoding <-> utf8 conversions - make substr($bytestr,0,0,$charstr) do the right conversion add Unicode::Map equivivalent to core add support for I/O disciplines - a way to specify disciplines when opening things: @@ -12,7 +11,25 @@ Unicode support eliminate need for "use utf8;" autoload byte.pm when byte:: is seen by the parser check uv_to_utf8() calls for buffer overflow - (see also "Locales", "Regexen", and "Miscellaneous") + make \uXXXX (and \u{XXXX}?) where XXXX are hex digits + to work similarly to Unicode tech reports and Java + notation \uXXXX (and already existing \x{XXXX))? + more than four hexdigits? make also \U+XXXX work? + overloadable regex assertions? e.g. in Thai \b cannot + be deduced by any simple character class boundary rules, + word boundaries must algorithmically computed + + see ext/Encode/Todo for notes and references about proper detection + of malformed UTF-8 + + SCSU? http://www.unicode.org/unicode/reports/tr6/ + Collation? http://www.unicode.org/unicode/reports/tr10/ + Normalization? http://www.unicode.org/unicode/reports/tr15/ + EBCDIC? http://www.unicode.org/unicode/reports/tr16/ + Regexes? http://www.unicode.org/unicode/reports/tr18/ + Case Mappings? http://www.unicode.org/unicode/reports/tr21/ + + See also "Locales", "Regexen", and "Miscellaneous". Multi-threading support "use Thread;" under useithreads @@ -39,17 +56,18 @@ Namespace cleanup API-space: complete the list of things that constitute public api Configure - fix the vicious cyclic multidependency of cc <-> libpth <-> loclibpth - libswanted <-> usethreads <-> use64bitint <-> use64bitall <-> - uselargefiles <-> ... make configuring+building away from source directory work (VPATH et al) this is related to: cross-compilation configuring (see Todo) _r support (see Todo for mode detailed description) POSIX 1003.1 1996 Edition support--realtime stuff: POSIX semaphores, message queues, shared memory, realtime clocks, timers, signals (the metaconfig units mostly already exist for these) + PREFERABLY AS AN EXTENSION UNIX98 support: reader-writer locks, realtime/asynchronous IO + PREFERABLY AS AN EXTENSION IPv6 support: see RFC2292, RFC2553 + PREFERABLY AS AN EXTENSION + there already is Socket6 in CPAN Long doubles figure out where the PV->NV->PV conversion gets it wrong at least @@ -60,6 +78,7 @@ Long doubles 64-bit support Configure probe for quad_t, uquad_t, and (argh) u_quad_t, they might be in some systems the only thing working as quadtype and uquadtype. + more pain: long_long, u_long_long. Locales deprecate traditional/legacy locales? @@ -67,15 +86,16 @@ Locales figure out how to support Unicode locales suggestion: integrate the IBM Classes for Unicode (ICU) http://oss.software.ibm.com/developerworks/opensource/icu/project/ - and check out also the Locale Converter: + ICU is "portable, open-source Unicode library with: + charset-independent locales (with multiple locales + simultaneously supported in same thread; character + conversions; formatting/parsing for numbers, currencies, + date/time and messages; message catalogs (resources); + transliteration, collation, normalization, and text + boundaries (grapheme, word, line-break))". + Check out also the Locale Converter: http://alphaworks.ibm.com/tech/localeconverter - ICU is "portable, open-source Unicode library with: - charset-independent locales (with multiple locales simultaneously - supported in same thread; character conversions; formatting/parsing - for numbers, currencies, date/time and messages; message catalogs - (resources) ; transliteration, collation, normalization, and text - boundaries (grapheme, word, line-break))". - There is also 'iconv', either from XPG4 or GNU (glibc). + There is also the iconv interface, either from XPG4 or GNU (glibc). iconv is about character set conversions. Either ICU or iconv would be valuable to get integrated into Perl, Configure already probes for libiconv and <iconv.h>. @@ -101,6 +121,9 @@ Regexen this is also a part of the Unicode 3.0: http://www.unicode.org/unicode/uni2book/u2.html executive summary: there are several different levels of 'equivalence' + trie optimization: factor out common suffixes (and prefixes?) + from |-alternating groups (both for exact strings and character + classes, use lookaheads?) approximate matching Security @@ -120,22 +143,27 @@ Win32 stuff work out DLL versioning Miscellaneous + introduce @( and @) because group names can have spaces add new modules (Archive::Tar, Compress::Zlib, CPAN::FTP?) sub-second sleep()? alarm()? time()? (integrate Time::HiRes? Configure doesn't yet probe for usleep/nanosleep/ualarm but the units exist) floating point handling: nans, infinities, fp exception masks, etc. - at least the following interfaces exist: fp_classify(), fp_class(), - class(), isnan(), isinf(), isfinite(), finite(), isnormal(), - ordered(), fp_setmask(), fp_getmask(), fp_setround(), fp_getround(), - ieeefp.h, fp_class.h. There are metaconfig units for most of these. - Search for ifdef __osf__ in pp.c to find a temporary fix that - needs to be done right. + At least the following interfaces exist: fp_classify(), fp_class(), + class(), isinf(), isfinite(), finite(), isnormal(), unordered(), + <ieeefp.h>, <fp_class.h> (there are metaconfig units for all these), + fp_setmask(), fp_getmask(), fp_setround(), fp_getround() + (no metaconfig units yet for these). + Don't forget finitel(), fp_classl(), fp_class_l(), (yes, both do, + unfortunately, exist), and unorderedl(). + PREFERABLY AS AN EXTENSION. + As of 5.6.1 there is cpp macro Perl_isnan(). fix the basic arithmetics (+ - * / %) to preserve IVness/UVness if - both arguments are IVs/UVs + both arguments are IVs/UVs: it sucks that one cannot see + the 'carry flag' (or equivalent) of the CPU from C, + C is too high-level... replace pod2html with new PodtoHtml? (requires other modules from CPAN) automate testing with large parts of CPAN - Unicode collation? http://www.unicode.org/unicode/reports/tr10/ turn Cwd into an XS module? (Configure already probes for getcwd()) mmap for speeding up input? (Configure already probes for the mmap family) sendmsg, recvmsg? (Configure doesn't probe for these but the units exist) @@ -154,3 +182,5 @@ Documentation spot-check all new modules for completeness better docs for pack()/unpack() reorg tutorials vs. reference sections + make roffitall to be dynamical about its pods and libs + diff --git a/contrib/perl5/av.c b/contrib/perl5/av.c index 819887e2ad59..273fed94eb54 100644 --- a/contrib/perl5/av.c +++ b/contrib/perl5/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); } } @@ -661,6 +664,14 @@ Perl_av_len(pTHX_ register AV *av) return AvFILL(av); } +/* +=for apidoc av_fill + +Ensure than an array has a given number of elements, equivalent to +Perl's C<$#array = $fill;>. + +=cut +*/ void Perl_av_fill(pTHX_ register AV *av, I32 fill) { @@ -708,6 +719,14 @@ Perl_av_fill(pTHX_ register AV *av, I32 fill) (void)av_store(av,fill,&PL_sv_undef); } +/* +=for apidoc av_delete + +Deletes the element indexed by C<key> from the array. Returns the +deleted element. C<flags> is currently ignored. + +=cut +*/ SV * Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags) { @@ -758,10 +777,15 @@ Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags) } /* - * This relies on the fact that uninitialized array elements - * are set to &PL_sv_undef. - */ +=for apidoc av_exists + +Returns true if the element indexed by C<key> has been initialized. + +This relies on the fact that uninitialized array elements are set to +C<&PL_sv_undef>. +=cut +*/ bool Perl_av_exists(pTHX_ AV *av, I32 key) { @@ -775,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/contrib/perl5/av.h b/contrib/perl5/av.h index 6b66bfd1b1de..8f130d63c007 100644 --- a/contrib/perl5/av.h +++ b/contrib/perl5/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. @@ -32,8 +32,8 @@ struct xpvav { * real if the array needs to be modified in some way. Functions that * modify fake AVs check both flags to call av_reify() as appropriate. * - * Note that the Perl stack has neither flag set. (Thus, items that go - * on the stack are never refcounted.) + * Note that the Perl stack and @DB::args have neither flag set. (Thus, + * items that go on the stack are never refcounted.) * * These internal details are subject to change any time. AV * manipulations external to perl should not care about any of this. diff --git a/contrib/perl5/bytecode.pl b/contrib/perl5/bytecode.pl index d1e1c708c0dc..4b00e14b9a11 100644 --- a/contrib/perl5/bytecode.pl +++ b/contrib/perl5/bytecode.pl @@ -13,7 +13,7 @@ my @optype= qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP); # Nullsv *must* come first in the following so that the condition # ($$sv == 0) can continue to be used to test (sv == Nullsv). -my @specialsv = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no); +my @specialsv = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE); my (%alias_from, $from, $tos); while (($from, $tos) = each %alias_to) { @@ -82,7 +82,7 @@ print BYTERUN_C $c_header, <<'EOT'; #include "bytecode.h" -static int optype_size[] = { +static const int optype_size[] = { EOT my $i = 0; for ($i = 0; $i < @optype - 1; $i++) { @@ -92,33 +92,27 @@ printf BYTERUN_C " sizeof(%s)\n", $optype[$i], $i; print BYTERUN_C <<'EOT'; }; -static SV *specialsv_list[4]; - -static int bytecode_iv_overflows = 0; -static SV *bytecode_sv; -static XPV bytecode_pv; -static void **bytecode_obj_list; -static I32 bytecode_obj_list_fill = -1; - void * -bset_obj_store(pTHXo_ void *obj, I32 ix) +bset_obj_store(pTHXo_ struct byteloader_state *bstate, void *obj, I32 ix) { - if (ix > bytecode_obj_list_fill) { - if (bytecode_obj_list_fill == -1) - New(666, bytecode_obj_list, ix + 1, void*); - else - Renew(bytecode_obj_list, ix + 1, void*); - bytecode_obj_list_fill = ix; + if (ix > bstate->bs_obj_list_fill) { + Renew(bstate->bs_obj_list, ix + 32, void*); + bstate->bs_obj_list_fill = ix + 31; } - bytecode_obj_list[ix] = obj; + bstate->bs_obj_list[ix] = obj; return obj; } void -byterun(pTHXo_ struct bytestream bs) +byterun(pTHXo_ register struct byteloader_state *bstate) { - dTHR; - int insn; + register int insn; + U32 ix; + SV *specialsv_list[6]; + + BYTECODE_HEADER_CHECK; /* croak if incorrect platform */ + New(666, bstate->bs_obj_list, 32, void*); /* set op objlist */ + bstate->bs_obj_list_fill = 31; EOT @@ -198,13 +192,25 @@ EOT # open(BYTERUN_H, ">ext/ByteLoader/byterun.h") or die "ext/ByteLoader/byterun.h: $!"; print BYTERUN_H $c_header, <<'EOT'; -struct bytestream { - void *data; - int (*pfgetc)(void *); - int (*pfread)(char *, size_t, size_t, void *); - void (*pfreadpv)(U32, void *, XPV *); +struct byteloader_fdata { + SV *datasv; + int next_out; + int idx; }; +struct byteloader_state { + struct byteloader_fdata *bs_fdata; + SV *bs_sv; + void **bs_obj_list; + int bs_obj_list_fill; + XPV bs_pv; + int bs_iv_overflows; +}; + +int bl_getc(struct byteloader_fdata *); +int bl_read(struct byteloader_fdata *, char *, size_t, size_t); +extern void byterun(pTHXo_ struct byteloader_state *); + enum { EOT @@ -233,18 +239,6 @@ for ($i = 0; $i < @optype - 1; $i++) { } printf BYTERUN_H " OPt_%s\t\t/* %d */\n};\n\n", $optype[$i], $i; -print BYTERUN_H <<'EOT'; -extern void byterun(pTHXo_ struct bytestream bs); - -#define INIT_SPECIALSV_LIST STMT_START { \ -EOT -for ($i = 0; $i < @specialsv; $i++) { - print BYTERUN_H "\tPL_specialsv_list[$i] = $specialsv[$i]; \\\n"; -} -print BYTERUN_H <<'EOT'; - } STMT_END -EOT - # # Finish off insn_data and create array initialisers in Asmdata.pm # @@ -294,85 +288,86 @@ nop none none #opcode lvalue argtype flags # ret none none x -ldsv bytecode_sv svindex +ldsv bstate->bs_sv svindex ldop PL_op opindex -stsv bytecode_sv U32 s +stsv bstate->bs_sv U32 s stop PL_op U32 s -ldspecsv bytecode_sv U8 x -newsv bytecode_sv U8 x +stpv bstate->bs_pv.xpv_pv U32 x +ldspecsv bstate->bs_sv U8 x +newsv bstate->bs_sv U8 x newop PL_op U8 x newopn PL_op U8 x newpv none PV -pv_cur bytecode_pv.xpv_cur STRLEN -pv_free bytecode_pv none x -sv_upgrade bytecode_sv char x -sv_refcnt SvREFCNT(bytecode_sv) U32 -sv_refcnt_add SvREFCNT(bytecode_sv) I32 x -sv_flags SvFLAGS(bytecode_sv) U32 -xrv SvRV(bytecode_sv) svindex -xpv bytecode_sv none x -xiv32 SvIVX(bytecode_sv) I32 -xiv64 SvIVX(bytecode_sv) IV64 -xnv SvNVX(bytecode_sv) NV -xlv_targoff LvTARGOFF(bytecode_sv) STRLEN -xlv_targlen LvTARGLEN(bytecode_sv) STRLEN -xlv_targ LvTARG(bytecode_sv) svindex -xlv_type LvTYPE(bytecode_sv) char -xbm_useful BmUSEFUL(bytecode_sv) I32 -xbm_previous BmPREVIOUS(bytecode_sv) U16 -xbm_rare BmRARE(bytecode_sv) U8 -xfm_lines FmLINES(bytecode_sv) I32 -xio_lines IoLINES(bytecode_sv) long -xio_page IoPAGE(bytecode_sv) long -xio_page_len IoPAGE_LEN(bytecode_sv) long -xio_lines_left IoLINES_LEFT(bytecode_sv) long -xio_top_name IoTOP_NAME(bytecode_sv) pvcontents -xio_top_gv *(SV**)&IoTOP_GV(bytecode_sv) svindex -xio_fmt_name IoFMT_NAME(bytecode_sv) pvcontents -xio_fmt_gv *(SV**)&IoFMT_GV(bytecode_sv) svindex -xio_bottom_name IoBOTTOM_NAME(bytecode_sv) pvcontents -xio_bottom_gv *(SV**)&IoBOTTOM_GV(bytecode_sv) svindex -xio_subprocess IoSUBPROCESS(bytecode_sv) short -xio_type IoTYPE(bytecode_sv) char -xio_flags IoFLAGS(bytecode_sv) char -xcv_stash *(SV**)&CvSTASH(bytecode_sv) svindex -xcv_start CvSTART(bytecode_sv) opindex -xcv_root CvROOT(bytecode_sv) opindex -xcv_gv *(SV**)&CvGV(bytecode_sv) svindex -xcv_file CvFILE(bytecode_sv) pvcontents -xcv_depth CvDEPTH(bytecode_sv) long -xcv_padlist *(SV**)&CvPADLIST(bytecode_sv) svindex -xcv_outside *(SV**)&CvOUTSIDE(bytecode_sv) svindex -xcv_flags CvFLAGS(bytecode_sv) U16 -av_extend bytecode_sv SSize_t x -av_push bytecode_sv svindex x -xav_fill AvFILLp(bytecode_sv) SSize_t -xav_max AvMAX(bytecode_sv) SSize_t -xav_flags AvFLAGS(bytecode_sv) U8 -xhv_riter HvRITER(bytecode_sv) I32 -xhv_name HvNAME(bytecode_sv) pvcontents -hv_store bytecode_sv svindex x -sv_magic bytecode_sv char x -mg_obj SvMAGIC(bytecode_sv)->mg_obj svindex -mg_private SvMAGIC(bytecode_sv)->mg_private U16 -mg_flags SvMAGIC(bytecode_sv)->mg_flags U8 -mg_pv SvMAGIC(bytecode_sv) pvcontents x -xmg_stash *(SV**)&SvSTASH(bytecode_sv) svindex -gv_fetchpv bytecode_sv strconst x -gv_stashpv bytecode_sv strconst x -gp_sv GvSV(bytecode_sv) svindex -gp_refcnt GvREFCNT(bytecode_sv) U32 -gp_refcnt_add GvREFCNT(bytecode_sv) I32 x -gp_av *(SV**)&GvAV(bytecode_sv) svindex -gp_hv *(SV**)&GvHV(bytecode_sv) svindex -gp_cv *(SV**)&GvCV(bytecode_sv) svindex -gp_file GvFILE(bytecode_sv) pvcontents -gp_io *(SV**)&GvIOp(bytecode_sv) svindex -gp_form *(SV**)&GvFORM(bytecode_sv) svindex -gp_cvgen GvCVGEN(bytecode_sv) U32 -gp_line GvLINE(bytecode_sv) line_t -gp_share bytecode_sv svindex x -xgv_flags GvFLAGS(bytecode_sv) U8 +pv_cur bstate->bs_pv.xpv_cur STRLEN +pv_free bstate->bs_pv none x +sv_upgrade bstate->bs_sv char x +sv_refcnt SvREFCNT(bstate->bs_sv) U32 +sv_refcnt_add SvREFCNT(bstate->bs_sv) I32 x +sv_flags SvFLAGS(bstate->bs_sv) U32 +xrv SvRV(bstate->bs_sv) svindex +xpv bstate->bs_sv none x +xiv32 SvIVX(bstate->bs_sv) I32 +xiv64 SvIVX(bstate->bs_sv) IV64 +xnv SvNVX(bstate->bs_sv) NV +xlv_targoff LvTARGOFF(bstate->bs_sv) STRLEN +xlv_targlen LvTARGLEN(bstate->bs_sv) STRLEN +xlv_targ LvTARG(bstate->bs_sv) svindex +xlv_type LvTYPE(bstate->bs_sv) char +xbm_useful BmUSEFUL(bstate->bs_sv) I32 +xbm_previous BmPREVIOUS(bstate->bs_sv) U16 +xbm_rare BmRARE(bstate->bs_sv) U8 +xfm_lines FmLINES(bstate->bs_sv) I32 +xio_lines IoLINES(bstate->bs_sv) long +xio_page IoPAGE(bstate->bs_sv) long +xio_page_len IoPAGE_LEN(bstate->bs_sv) long +xio_lines_left IoLINES_LEFT(bstate->bs_sv) long +xio_top_name IoTOP_NAME(bstate->bs_sv) pvcontents +xio_top_gv *(SV**)&IoTOP_GV(bstate->bs_sv) svindex +xio_fmt_name IoFMT_NAME(bstate->bs_sv) pvcontents +xio_fmt_gv *(SV**)&IoFMT_GV(bstate->bs_sv) svindex +xio_bottom_name IoBOTTOM_NAME(bstate->bs_sv) pvcontents +xio_bottom_gv *(SV**)&IoBOTTOM_GV(bstate->bs_sv) svindex +xio_subprocess IoSUBPROCESS(bstate->bs_sv) short +xio_type IoTYPE(bstate->bs_sv) char +xio_flags IoFLAGS(bstate->bs_sv) char +xcv_stash *(SV**)&CvSTASH(bstate->bs_sv) svindex +xcv_start CvSTART(bstate->bs_sv) opindex +xcv_root CvROOT(bstate->bs_sv) opindex +xcv_gv *(SV**)&CvGV(bstate->bs_sv) svindex +xcv_file CvFILE(bstate->bs_sv) pvindex +xcv_depth CvDEPTH(bstate->bs_sv) long +xcv_padlist *(SV**)&CvPADLIST(bstate->bs_sv) svindex +xcv_outside *(SV**)&CvOUTSIDE(bstate->bs_sv) svindex +xcv_flags CvFLAGS(bstate->bs_sv) U16 +av_extend bstate->bs_sv SSize_t x +av_push bstate->bs_sv svindex x +xav_fill AvFILLp(bstate->bs_sv) SSize_t +xav_max AvMAX(bstate->bs_sv) SSize_t +xav_flags AvFLAGS(bstate->bs_sv) U8 +xhv_riter HvRITER(bstate->bs_sv) I32 +xhv_name HvNAME(bstate->bs_sv) pvcontents +hv_store bstate->bs_sv svindex x +sv_magic bstate->bs_sv char x +mg_obj SvMAGIC(bstate->bs_sv)->mg_obj svindex +mg_private SvMAGIC(bstate->bs_sv)->mg_private U16 +mg_flags SvMAGIC(bstate->bs_sv)->mg_flags U8 +mg_pv SvMAGIC(bstate->bs_sv) pvcontents x +xmg_stash *(SV**)&SvSTASH(bstate->bs_sv) svindex +gv_fetchpv bstate->bs_sv strconst x +gv_stashpv bstate->bs_sv strconst x +gp_sv GvSV(bstate->bs_sv) svindex +gp_refcnt GvREFCNT(bstate->bs_sv) U32 +gp_refcnt_add GvREFCNT(bstate->bs_sv) I32 x +gp_av *(SV**)&GvAV(bstate->bs_sv) svindex +gp_hv *(SV**)&GvHV(bstate->bs_sv) svindex +gp_cv *(SV**)&GvCV(bstate->bs_sv) svindex +gp_file GvFILE(bstate->bs_sv) pvindex +gp_io *(SV**)&GvIOp(bstate->bs_sv) svindex +gp_form *(SV**)&GvFORM(bstate->bs_sv) svindex +gp_cvgen GvCVGEN(bstate->bs_sv) U32 +gp_line GvLINE(bstate->bs_sv) line_t +gp_share bstate->bs_sv svindex x +xgv_flags GvFLAGS(bstate->bs_sv) U8 op_next PL_op->op_next opindex op_sibling PL_op->op_sibling opindex op_ppaddr PL_op->op_ppaddr strconst x @@ -384,7 +379,6 @@ op_private PL_op->op_private U8 op_first cUNOP->op_first opindex op_last cBINOP->op_last opindex op_other cLOGOP->op_other opindex -op_children cLISTOP->op_children U32 op_pmreplroot cPMOP->op_pmreplroot opindex op_pmreplrootgv *(SV**)&cPMOP->op_pmreplroot svindex op_pmreplstart cPMOP->op_pmreplstart opindex @@ -399,9 +393,9 @@ op_pv_tr cPVOP->op_pv op_tr_array op_redoop cLOOP->op_redoop opindex op_nextop cLOOP->op_nextop opindex op_lastop cLOOP->op_lastop opindex -cop_label cCOP->cop_label pvcontents -cop_stashpv cCOP pvcontents x -cop_file cCOP pvcontents x +cop_label cCOP->cop_label pvindex +cop_stashpv cCOP pvindex x +cop_file cCOP pvindex x cop_seq cCOP->cop_seq U32 cop_arybase cCOP->cop_arybase I32 cop_line cCOP line_t x @@ -409,3 +403,6 @@ cop_warnings cCOP->cop_warnings svindex main_start PL_main_start opindex main_root PL_main_root opindex curpad PL_curpad svindex x +push_begin PL_beginav svindex x +push_init PL_initav svindex x +push_end PL_endav svindex x diff --git a/contrib/perl5/cflags.SH b/contrib/perl5/cflags.SH index ec6dc3570e48..d2152557375f 100755 --- a/contrib/perl5/cflags.SH +++ b/contrib/perl5/cflags.SH @@ -129,8 +129,8 @@ for file do fi : Can we perhaps use $ansi2knr here - echo "$cc -c -DPERL_CORE $ccflags $optimize $perltype $large $split" - eval "$also "'"$cc -DPERL_CORE -c $ccflags $optimize $perltype $large $split"' + echo "$cc -c -DPERL_CORE $ccflags $optimize $perltype" + eval "$also "'"$cc -DPERL_CORE -c $ccflags $optimize $perltype"' . $TOP/config.sh diff --git a/contrib/perl5/config_h.SH b/contrib/perl5/config_h.SH index 70f220ec91e7..ae7f337a62a7 100755 --- a/contrib/perl5/config_h.SH +++ b/contrib/perl5/config_h.SH @@ -238,17 +238,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_getpgid HAS_GETPGID /**/ -/* 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_GETPGRP2: * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) * routine is available to get the current process group. @@ -503,18 +492,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_setpgid HAS_SETPGID /**/ -/* 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_SETPGRP2: * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) * routine is available to set the current process group. @@ -998,12 +975,6 @@ sed <<!GROK!THIS! >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. @@ -1198,21 +1169,21 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- * This macro surrounds its token with double quotes. */ #if $cpp_stuff == 1 -# define CAT2(a,b) a/**/b -# define STRINGIFY(a) "a" +#define CAT2(a,b) a/**/b +#define STRINGIFY(a) "a" /* If you can get stringification with catify, tell me how! */ #endif #if $cpp_stuff == 42 -# define PeRl_CaTiFy(a, b) a ## b -# define PeRl_StGiFy(a) #a +#define PeRl_CaTiFy(a, b) a ## b +#define PeRl_StGiFy(a) #a /* the additional level of indirection enables these macros to be * used as arguments to other macros. See K&R 2nd ed., page 231. */ -# define CAT2(a,b) PeRl_CaTiFy(a,b) -# define StGiFy(a) PeRl_StGiFy(a) -# define STRINGIFY(a) PeRl_StGiFy(a) +#define CAT2(a,b) PeRl_CaTiFy(a,b) +#define StGiFy(a) PeRl_StGiFy(a) +#define STRINGIFY(a) PeRl_StGiFy(a) #endif #if $cpp_stuff != 1 && $cpp_stuff != 42 -#include "Bletch: How does this C preprocessor catenate tokens?" +# include "Bletch: How does this C preprocessor catenate tokens?" #endif /* CPPSTDIN: @@ -1342,23 +1313,30 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_endsent HAS_ENDSERVENT /**/ -/* HAS_ENDSPENT: - * This symbol, if defined, indicates that the endspent system call is - * available to finalize the scan of SysV shadow password entries. - */ -#$d_endspent HAS_ENDSPENT /**/ - /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in <sys/types.h> */ #$d_fd_set HAS_FD_SET /**/ +/* FLEXFILENAMES: + * This symbol, if defined, indicates that the system supports filenames + * longer than 14 characters. + */ +#$d_flexfnam FLEXFILENAMES /**/ + /* HAS_FPOS64_T: * This symbol will be defined if the C compiler supports fpos64_t. */ #$d_fpos64_t HAS_FPOS64_T /**/ +/* HAS_FREXPL: + * This symbol, if defined, indicates that the frexpl routine is + * available to break a long double floating-point number into + * a normalized fraction and an integral power of 2. + */ +#$d_frexpl HAS_FREXPL /**/ + /* HAS_STRUCT_FS_DATA: * This symbol, if defined, indicates that the struct fs_data * to do statfs() is supported. @@ -1406,6 +1384,12 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_getcwd HAS_GETCWD /**/ +/* HAS_GETESPWNAM: + * This symbol, if defined, indicates that the getespwnam system call is + * available to retrieve enchanced (shadow) password entries by name. + */ +#$d_getespwnam HAS_GETESPWNAM /**/ + /* HAS_GETFSSTAT: * This symbol, if defined, indicates that the getfsstat routine is * available to stat filesystems in bulk. @@ -1511,6 +1495,13 @@ sed <<!GROK!THIS! >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. @@ -1536,6 +1527,12 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_getprotoprotos HAS_GETPROTO_PROTOS /**/ +/* HAS_GETPRPWNAM: + * This symbol, if defined, indicates that the getprpwnam system call is + * available to retrieve protected (shadow) password entries by name. + */ +#$d_getprpwnam HAS_GETPRPWNAM /**/ + /* HAS_GETPWENT: * This symbol, if defined, indicates that the getpwent routine is * available for sequential access of the passwd database. @@ -1557,12 +1554,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_getservprotos HAS_GETSERV_PROTOS /**/ -/* HAS_GETSPENT: - * This symbol, if defined, indicates that the getspent system call is - * available to retrieve SysV shadow password entries sequentially. - */ -#$d_getspent HAS_GETSPENT /**/ - /* HAS_GETSPNAM: * This symbol, if defined, indicates that the getspnam system call is * available to retrieve SysV shadow password entries by name. @@ -1638,6 +1629,25 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_isascii HAS_ISASCII /**/ +/* HAS_ISNAN: + * This symbol, if defined, indicates that the isnan routine is + * available to check whether a double is a NaN. + */ +#$d_isnan HAS_ISNAN /**/ + +/* HAS_ISNANL: + * This symbol, if defined, indicates that the isnanl routine is + * available to check whether a long double is a NaN. + */ +#$d_isnanl HAS_ISNANL /**/ + +/* HAS_LCHOWN: + * This symbol, if defined, indicates that the lchown routine is + * available to operate on a symbolic link (instead of following the + * link). + */ +#$d_lchown HAS_LCHOWN /**/ + /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's <float.h> * or <limits.h> defines the symbol LDBL_DIG, which is the number @@ -1725,6 +1735,13 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- #$d_mmap HAS_MMAP /**/ #define Mmap_t $mmaptype /**/ +/* HAS_MODFL: + * This symbol, if defined, indicates that the modfl routine is + * available to split a long double x into a fractional part f and + * an integer part i such that |f| < 1.0 and (f + i) = x. + */ +#$d_modfl HAS_MODFL /**/ + /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is * available to modify the access protection of a memory mapped file. @@ -1855,12 +1872,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_setsent HAS_SETSERVENT /**/ -/* HAS_SETSPENT: - * This symbol, if defined, indicates that the setspent system call is - * available to initialize the scan of SysV shadow password entries. - */ -#$d_setspent HAS_SETSPENT /**/ - /* HAS_SETVBUF: * This symbol, if defined, indicates that the setvbuf routine is * available to change buffering on an open stdio stream. @@ -1964,6 +1975,12 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- #$d_msg_proxy HAS_MSG_PROXY /**/ #$d_scm_rights HAS_SCM_RIGHTS /**/ +/* HAS_SOCKS5_INIT: + * This symbol, if defined, indicates that the socks5_init routine is + * available to initialize SOCKS 5. + */ +#$d_socks5_init HAS_SOCKS5_INIT /**/ + /* HAS_SQRTL: * This symbol, if defined, indicates that the sqrtl routine is * available to do long double square roots. @@ -2026,12 +2043,23 @@ sed <<!GROK!THIS! >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: @@ -2299,6 +2327,12 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$i_inttypes I_INTTYPES /**/ +/* I_LIBUTIL: + * This symbol, if defined, indicates that <libutil.h> exists and + * should be included. + */ +#$i_libutil I_LIBUTIL /**/ + /* I_MACH_CTHREADS: * This symbol, if defined, indicates to the C program that it should * include <mach/cthreads.h>. @@ -2329,6 +2363,12 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$i_poll I_POLL /**/ +/* I_PROT: + * This symbol, if defined, indicates that <prot.h> exists and + * should be included. + */ +#$i_prot I_PROT /**/ + /* I_PTHREAD: * This symbol, if defined, indicates to the C program that it should * include <pthread.h>. @@ -2491,8 +2531,18 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'g') for output. */ +/* PERL_PRIeldbl: + * This symbol, if defined, contains the string used by stdio to + * format long doubles (format 'e') for output. + */ +/* PERL_SCNfldbl: + * This symbol, if defined, contains the string used by stdio to + * format long doubles (format 'f') for input. + */ #$d_PRIfldbl PERL_PRIfldbl $sPRIfldbl /**/ #$d_PRIgldbl PERL_PRIgldbl $sPRIgldbl /**/ +#$d_PRIeldbl PERL_PRIeldbl $sPRIeldbl /**/ +#$d_SCNfldbl PERL_SCNfldbl $sSCNfldbl /**/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. @@ -2580,6 +2630,16 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- #define Netdb_name_t $netdb_name_type /**/ #define Netdb_net_t $netdb_net_type /**/ +/* PERL_OTHERLIBDIRS: + * This variable contains a colon-separated set of paths for the perl + * binary to search for additional library files or modules. + * These directories will be tacked to the end of @INC. + * Perl will automatically search below each path for version- + * and architecture-specific directories. See PERL_INC_VERSION_LIST + * for more details. + */ +#$d_perl_otherlibdirs PERL_OTHERLIBDIRS "$otherlibdirs" /**/ + /* IVTYPE: * This symbol defines the C type used for Perl's IV. */ @@ -2643,9 +2703,16 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- /* U64SIZE: * This symbol contains the sizeof(U64). */ +/* NVSIZE: + * This symbol contains the sizeof(NV). + */ /* NV_PRESERVES_UV: * This symbol, if defined, indicates that a variable of type NVTYPE - * can preserve all the bit of a variable of type UVSIZE. + * can preserve all the bits of a variable of type UVTYPE. + */ +/* NV_PRESERVES_UV_BITS: + * This symbol contains the number of bits a variable of type NVTYPE + * can preserve of a variable of type UVTYPE. */ #define IVTYPE $ivtype /**/ #define UVTYPE $uvtype /**/ @@ -2672,7 +2739,9 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- #define I64SIZE $i64size /**/ #define U64SIZE $u64size /**/ #endif +#define NVSIZE $nvsize /**/ #$d_nv_preserves_uv NV_PRESERVES_UV +#define NV_PRESERVES_UV_BITS $d_nv_preserves_uv_bits /* IVdf: * This symbol defines the format string used for printing a Perl IV @@ -2688,12 +2757,27 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ /* UVxf: * This symbol defines the format string used for printing a Perl UV - * as an unsigned hexadecimal integer. + * as an unsigned hexadecimal integer in lowercase abcdef. + */ +/* NVef: + * This symbol defines the format string used for printing a Perl NV + * using %e-ish floating point format. + */ +/* NVff: + * This symbol defines the format string used for printing a Perl NV + * using %f-ish floating point format. + */ +/* NVgf: + * This symbol defines the format string used for printing a Perl NV + * using %g-ish floating point format. */ #define IVdf $ivdformat /**/ #define UVuf $uvuformat /**/ #define UVof $uvoformat /**/ #define UVxf $uvxformat /**/ +#define NVef $nveformat /**/ +#define NVff $nvfformat /**/ +#define NVgf $nvgformat /**/ /* Pid_t: * This symbol holds the type used to declare process ids in the kernel. @@ -3092,24 +3176,63 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- #define PERL_XS_APIVERSION "$xs_apiversion" #define PERL_PM_APIVERSION "$pm_apiversion" -/* HAS_LCHOWN: - * This symbol, if defined, indicates that the lchown routine is - * available to operate on a symbolic link (instead of following the - * link). +/* HAS_GETPGRP: + * This symbol, if defined, indicates that the getpgrp routine is + * available to get the current process group. */ -#$d_lchown HAS_LCHOWN /**/ +/* 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 /**/ -/* FLEXFILENAMES: - * This symbol, if defined, indicates that the system supports filenames - * longer than 14 characters. +/* HAS_SETPGRP: + * This symbol, if defined, indicates that the setpgrp routine is + * available to set the current process group. */ -#$d_flexfnam FLEXFILENAMES /**/ +/* 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 /**/ -/* I_LIBUTIL: - * This symbol, if defined, indicates that <libutil.h> exists and - * should be included. +/* STDCHAR: + * This symbol is defined to be the type of char used in stdio.h. + * It has the values "unsigned char" or "char". */ -#$i_libutil I_LIBUTIL /**/ +#define STDCHAR $stdchar /**/ + +/* 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 /**/ + +/* 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_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_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 /**/ #endif !GROK!THIS! diff --git a/contrib/perl5/configpm b/contrib/perl5/configpm index c64af8a13b97..31b416b7a3c1 100755 --- a/contrib/perl5/configpm +++ b/contrib/perl5/configpm @@ -128,41 +128,84 @@ sub FETCH { # Search for it in the big string my($value, $start, $marker, $quote_type); - $marker = "$_[1]="; + $quote_type = "'"; - # return undef unless (($value) = $config_sh =~ m/^$_[1]='(.*)'\s*$/m); - # Check for the common case, ' delimeted - $start = index($config_sh, "\n$marker$quote_type"); - # If that failed, check for " delimited - if ($start == -1) { - $quote_type = '"'; - $start = index($config_sh, "\n$marker$quote_type"); - } - return undef if ( ($start == -1) && # in case it's first - (substr($config_sh, 0, length($marker)) ne $marker) ); - if ($start == -1) { - # It's the very first thing we found. Skip $start forward - # and figure out the quote mark after the =. - $start = length($marker) + 1; - $quote_type = substr($config_sh, $start - 1, 1); - } - else { - $start += length($marker) + 2; + # Virtual entries. + if ($_[1] eq 'byteorder') { + # byteorder does exist on its own but we overlay a virtual + # dynamically recomputed value. + my $t = $Config{ivtype}; + my $s = $Config{ivsize}; + my $f = $t eq 'long' ? 'L!' : $s == 8 ? 'Q': 'I'; + if ($s == 4 || $s == 8) { + my $i = 0; + foreach my $c (reverse(2..$s)) { $i |= ord($c); $i <<= 8 } + $i |= ord(1); + $value = join('', unpack('a'x$s, pack($f, $i))); + } else { + $value = '?'x$s; + } + } elsif ($_[1] =~ /^((?:cc|ld)flags|libs(?:wanted)?)_nolargefiles/) { + # These are purely virtual, they do not exist, but need to + # be computed on demand for largefile-incapable extensions. + my $key = "${1}_uselargefiles"; + $value = $Config{$1}; + my $withlargefiles = $Config{$key}; + if ($key =~ /^(?:cc|ld)flags_/) { + $value =~ s/\Q$withlargefiles\E\b//; + } elsif ($key =~ /^libs/) { + my @lflibswanted = split(' ', $Config{libswanted_uselargefiles}); + if (@lflibswanted) { + my %lflibswanted; + @lflibswanted{@lflibswanted} = (); + if ($key =~ /^libs_/) { + my @libs = grep { /^-l(.+)/ && + not exists $lflibswanted{$1} } + split(' ', $Config{libs}); + $Config{libs} = join(' ', @libs); + } elsif ($key =~ /^libswanted_/) { + my @libswanted = grep { not exists $lflibswanted{$_} } + split(' ', $Config{libswanted}); + $Config{libswanted} = join(' ', @libswanted); + } + } + } + } else { + $marker = "$_[1]="; + # return undef unless (($value) = $config_sh =~ m/^$_[1]='(.*)'\s*$/m); + # Check for the common case, ' delimeted + $start = index($config_sh, "\n$marker$quote_type"); + # If that failed, check for " delimited + if ($start == -1) { + $quote_type = '"'; + $start = index($config_sh, "\n$marker$quote_type"); + } + return undef if ( ($start == -1) && # in case it's first + (substr($config_sh, 0, length($marker)) ne $marker) ); + if ($start == -1) { + # It's the very first thing we found. Skip $start forward + # and figure out the quote mark after the =. + $start = length($marker) + 1; + $quote_type = substr($config_sh, $start - 1, 1); + } + else { + $start += length($marker) + 2; + } + $value = substr($config_sh, $start, + index($config_sh, "$quote_type\n", $start) - $start); } - $value = substr($config_sh, $start, - index($config_sh, "$quote_type\n", $start) - $start); - # If we had a double-quote, we'd better eval it so escape # sequences and such can be interpolated. Since the incoming # value is supposed to follow shell rules and not perl rules, # we escape any perl variable markers if ($quote_type eq '"') { - $value =~ s/\$/\\\$/g; - $value =~ s/\@/\\\@/g; - eval "\$value = \"$value\""; + $value =~ s/\$/\\\$/g; + $value =~ s/\@/\\\@/g; + eval "\$value = \"$value\""; } #$value = sprintf($value) if $quote_type eq '"'; - $value = undef if $value eq 'undef'; # So we can say "if $Config{'foo'}". + # So we can say "if $Config{'foo'}". + $value = undef if $value eq 'undef'; $_[0]->{$_[1]} = $value; # cache it return $value; } @@ -191,7 +234,8 @@ sub EXISTS { index($config_sh, "\n$_[1]='") != -1 or substr($config_sh, 0, length($_[1])+2) eq "$_[1]='" or index($config_sh, "\n$_[1]=\"") != -1 or - substr($config_sh, 0, length($_[1])+2) eq "$_[1]=\""; + substr($config_sh, 0, length($_[1])+2) eq "$_[1]=\"" or + $_[1] =~ /^(?:(?:cc|ld)flags|libs(?:wanted)?)_nolargefiles$/; } sub STORE { die "\%Config::Config is read-only\n" } diff --git a/contrib/perl5/configure.com b/contrib/perl5/configure.com index 003a047bbe87..62ebaccb1cba 100644 --- a/contrib/perl5/configure.com +++ b/contrib/perl5/configure.com @@ -1,7 +1,7 @@ $ sav_ver = 'F$VERIFY(0)' $! SET VERIFY $! -$! For example, if you unpacked perl into: [USER.PERL5_00n...] then you will +$! For example, if you unpacked perl into: [USER.PERL-5n...] then you will $! want to cd into the tree and execute Configure: $! $! $ SET DEFAULT [USER.PERL5_xxx] @@ -30,12 +30,12 @@ $! with much valuable help from Charles Bailey & $! the whole VMSPerl crew. $! Extended and messed about with by Dan Sugalski $! -$ sav_ver = F$VERIFY(0) -$! $! VMS-isms we will need: $ echo = "write sys$output " $ cat = "type" +$ delete := delete ! local symbol overrides globals with qualifiers $ gcc_symbol = "gcc" +$ ld = "Link" $ ans = "" $ macros = "" $ extra_flags = "" @@ -50,12 +50,20 @@ $ Thread_Live_Dangerously = "MT=" $ use_two_pot_malloc = "N" $ use_pack_malloc = "N" $ use_debugmalloc = "N" -$ d_secintgenv = "N" -$ cc_flags = "" -$ use_multiplicity = "N" +$ ccflags = "" +$ static_ext = "" $ vms_default_directory_name = F$ENVIRONMENT("DEFAULT") -$ max_allowed_dir_depth = 3 ! e.g. [A.B.PERL5_xxx] not [A.B.C.PERL5_xxx] -$! max_allowed_dir_depth = 2 ! e.g. [A.PERL5_xxx] not [A.B.PERL5_xxx] +$ 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") $! @@ -118,16 +126,16 @@ $!: set up default values $ fastread="" $ reuseval="false" $ maniskip = "false" -$ config_sh="" +$ IF F$TYPE(config_sh) .EQS. "" THEN config_sh="" $ alldone="" $ error="" $ silent="" $ extractsh="" $ override="" $ knowitall="" -$ Using_Dec_C = "" -$ Using_Gnu_C = "" +$ ccname="VAX" $ Dec_C_Version = "" +$ cxxversion = "" $ use_threads = "F" $ use_5005_threads = "N" $ use_ithreads = "N" @@ -170,7 +178,7 @@ $ gotopt = "t" $ P'i' = P'i' - "e" $ gotshortopt = "t" $ ENDIF -$ IF (F$EXTRACT(0,1,P'i') .EQS. "f") !"-f") +$ IF (F$EXTRACT(0,1,P'i') .EQS. "f") ! "-f" $ THEN $ P'i' = P'i' - "f" $ config_sh = P'i' @@ -179,6 +187,7 @@ $ THEN $ test_config_sh = F$FILE_ATTRIBUTES(config_sh,"PRO") $ IF (F$LOCATE("R",test_config_sh).NE.F$LENGTH(test_config_sh)) $ THEN +$ config_dflt = "y" $ CONTINUE !at this point check UIC && if test allows... $ !to be continued ? $ ELSE @@ -191,100 +200,103 @@ $ error="true" $ ENDIF $ gotopt = "t" $ ENDIF -$ IF (F$EXTRACT(0,1,P'i') .EQS. "h") +$ IF (F$EXTRACT(0,1,P'i') .EQS. "h") ! "-h" $ THEN $ error = "true" $ gotopt = "t" $ P'i' = P'i' - "h" $ gotshortopt = "t" $ ENDIF -$ IF (F$EXTRACT(0,1,P'i') .EQS. "m") +$ IF (F$EXTRACT(0,1,P'i') .EQS. "m") ! "-m" $ THEN $ maniskip = "true" $ gotopt = "t" $ P'i' = P'i' - "m" $ gotshortopt = "t" $ ENDIF -$ IF (F$EXTRACT(0,1,P'i') .EQS. "r") +$ IF (F$EXTRACT(0,1,P'i') .EQS. "r") ! "-r" $ THEN $ reuseval = "true" $ gotopt = "t" $ P'i' = P'i' - "r" $ gotshortopt = "t" $ ENDIF -$ IF (F$EXTRACT(0,1,P'i') .EQS. "s") +$ IF (F$EXTRACT(0,1,P'i') .EQS. "s") ! "-s" $ THEN $ silent = "true" $ gotopt = "t" $ P'i' = P'i' - "s" $ gotshortopt = "t" $ ENDIF -$ IF (F$EXTRACT(0,1,P'i') .EQS. "E") !"-E") +$ IF (F$EXTRACT(0,1,P'i') .EQS. "E") ! "-E" $ THEN $ alldone = "exit" $ gotopt = "t" $ ENDIF -$ IF (F$EXTRACT(0,1,P'i') .EQS. "K") !"-K") +$ IF (F$EXTRACT(0,1,P'i') .EQS. "K") ! "-K" $ THEN $ knowitall = "true" $ gotopt = "t" $ P'i' = P'i' - "K" $ gotshortopt = "t" $ ENDIF -$ IF (F$EXTRACT(0,1,P'i') .EQS. "O") +$ IF (F$EXTRACT(0,1,P'i') .EQS. "O") ! "-O" $ THEN $ override = "true" $ gotopt = "t" $ P'i' = P'i' - "O" $ gotshortopt = "t" $ ENDIF -$ IF (F$EXTRACT(0,1,P'i') .EQS. "S") !"-S") +$ IF (F$EXTRACT(0,1,P'i') .EQS. "S") ! "-S" $ THEN -$ extractsh = "true" !VMS? +$ extractsh = "true" !VMS? Yes with munchconfig $ gotopt = "t" $ P'i' = P'i' - "S" $ gotshortopt = "t" $ ENDIF -$ IF (F$EXTRACT(0,1,P'i') .EQS. "D") !"-D") +$ IF (F$EXTRACT(0,1,P'i') .EQS. "D") ! "-D" $ THEN $ P'i' = P'i' - "D" -$!Hmm.. this part needs work -$! P'i' $ IF (F$LOCATE("=",P'i') .EQ. F$LENGTH(P'i')) $ THEN -$ P'i' = "define" +$ tmp = P'i' + "=""define""" +$ 'tmp' +$ DELETE/SYMBOL tmp $ ELSE $ IF (F$LOCATE("=",P'i') .EQ. (F$LENGTH(P'i') - 1)) $ THEN $ me = F$PARSE(me,,,"NAME") + F$PARSE(me,,,"TYPE") -$ echo "''me': use '-Usymbol=val' not '-Dsymbol='." +$ echo "''me': use ""-Usymbol=val"" not ""-Dsymbol=""." $ echo "''me': ignoring -D",P'i' $ ELSE -$!Hmm.. this part needs work -$! 'F$EXTRACT(0,F$LOCATE("=",P'i'),P'i')' = - -$! 'F$EXTRACT(F$LOCATE("=",P'i'),P'i'),F$LENGTH(P'i'),P'i')' +$ tmp = F$EXTRACT(0,F$LOCATE("=",P'i'),P'i') +$ tmp = tmp + "=""" + F$EXTRACT(F$LOCATE("=",P'i')+1,F$LENGTH(P'i'),P'i') + """" +$ 'tmp' +$ DELETE/SYMBOL tmp $ ENDIF $ ENDIF -$ ECHO "P''i' =>",P'i',"<=" !Diag $ gotopt = "t" $ ENDIF -$ IF (F$EXTRACT(0,1,P'i') .EQS. "U") !"-U") +$ IF (F$EXTRACT(0,1,P'i') .EQS. "U") ! "-U" $ THEN $ P'i' = P'i' - "U" $ IF (F$LOCATE("=",P'i') .EQ. F$LENGTH(P'i')) $ THEN -$ P'i' = "" +$ tmp = P'i' + "=""""" +$ 'tmp' +$ DELETE/SYMBOL tmp $ ELSE $ IF (F$LOCATE("=",P'i') .LT. (F$LENGTH(P'i') - 1)) $ THEN $ me = F$PARSE(me,,,"NAME") + F$PARSE(me,,,"TYPE") -$ echo "''me': use '-Dsymbol=val' not '-Usymbol=val'." +$ echo "''me': use ""-Dsymbol=val"" not ""-Usymbol=val""." $ echo "''me': ignoring -U",P'i' $ ELSE -$ P'i' = "undef" +$ tmp = P'i' + "=""undef""" +$ 'tmp' +$ DELETE/SYMBOL tmp $ ENDIF $ ENDIF -$ ECHO "P''i' =>",P'i',"<=" !Diag $ gotopt = "t" $ ENDIF $ IF (F$EXTRACT(0,1,P'i') .EQS. "V") @@ -292,7 +304,7 @@ $ THEN $ me = F$PARSE(me,,,"NAME") + F$PARSE(me,,,"TYPE") $ echo "''me' generated by an unknown version of EDT." $ STOP -$ EXIT !0 +$ EXIT $ ENDIF $ IF .NOT.gotopt $ THEN @@ -309,9 +321,10 @@ $! $ IF (error) $ THEN $ me = F$PARSE(me,,,"DIRECTORY")+ F$PARSE(me,,,"NAME") -$ echo "Usage: @''me' [-dehmrEKOSV] [-fconfig.sh] [-Dsymbol] [-Dsymbol=value]" +$ echo "Usage: @''me' [-dehmr""EKOSV""] [-fconfig.sh] [""-Dsymbol""] [""-Dsymbol=value""]" $ echo " [-Usymbol] [-Usymbol=]" -$ TYPE SYS$INPUT +$ TYPE SYS$INPUT: +$ DECK "-d" : use defaults for all answers. "-e" : go on without questioning past the production of config.sh. * "-f" : specify an alternate default configuration file. @@ -330,6 +343,7 @@ $ TYPE SYS$INPUT -"Usymbol" symbol gets the value 'undef' -"Usymbol=" symbol gets completely empty -V : print version number and exit (with a zero status). +$ EOD $ echo "%Config-I-VMS, lower case switches must be enclosed" $ echo "-Config-I-VMS, in double quotation marks, e.g.:" $ echo "-Config-I-VMS, @Configure ""-des""" @@ -344,7 +358,8 @@ $! $Shut_up: $ IF F$Mode() .eqs. "BATCH" $ THEN -$ STDOUT = F$GetQuI("DISPLAY_JOB","LOG_SPECIFICATION",,"THIS_JOB") +$ STDOUT = F$PARSE(F$GETQUI("DISPLAY_ENTRY", "JOB_NAME"), - + F$GETQUI("DISPLAY_ENTRY", "LOG_SPECIFICATION"), ".LOG") $ WRITE SYS$OUTPUT "Warning: Executing in batch mode. To avoid file locking conflicts," $ WRITE SYS$OUTPUT "output intended for SYS$OUTPUT will be sent to a new version" $ WRITE SYS$OUTPUT STDOUT @@ -393,7 +408,7 @@ $ echo "" $ echo4 "First let's make sure your kit is complete. Checking..." $ manifestfound = "" $ miss_list = "" -$! Here I assume we are in the [foo.PERL5xxx.VMS...] tree +$! Here I assume we are in the [foo.PERLxxx...] tree $! because the search routine simply does set def [-] if necessary. $ file_2_find = "MANIFEST" !I hope this one is not in [foo.PERL5xxx.VMS...] $Research_manifest: @@ -418,10 +433,12 @@ $ IF (tmp .GES. "7.2") .AND. (F$GETSYI("HW_MODEL") .GE. 1024) THEN GOTO Beyond_d $ IF (F$ELEMENT(max_allowed_dir_depth,".",F$ENVIRONMENT("Default")).nes.".") $ THEN $ TYPE SYS$INPUT: +$ DECK %Config-E-VMS, ERROR: Sorry! It apears as though your perl build sub-directory is already too deep into the VMS file system. Please try moving stuff into a shallower directory (or altering the "max_allowed_dir_depth" parameter). +$ EOD $ echo4 "ABORTING..." $ SET DEFAULT 'vms_default_directory_name' !be kind rewind $ STOP @@ -537,6 +554,8 @@ $ ENDIF $ IF ((miss_list .NES. "").OR.(manifestfound .EQS. "")) $ THEN $ TYPE SYS$INPUT: +$ DECK + THIS PACKAGE SEEMS TO BE INCOMPLETE. @@ -545,6 +564,7 @@ distinct possibility that your kit is damaged, by typing 'y'es. If you do, don't blame me if something goes wrong. I advise you to type 'n'o and contact the author (dan@sidhe.org) +$ EOD $ READ SYS$COMMAND/PROMPT="Continue? [n] " ans $ IF ans $ THEN @@ -575,13 +595,23 @@ $ If (fastread) $ Then $ echo4 "''rp'" $ Else -$ If (silent) -$ Then +$ If (.NOT. silent) Then echo "" +$ READ SYS$COMMAND/PROMPT="''rp'" ans +$ IF (ans .EQS. "&-d") +$ THEN +$ echo4 "(OK, I will run with -d after this question.)" +$ IF (.NOT. silent) THEN echo "" $ READ SYS$COMMAND/PROMPT="''rp'" ans -$ Else +$ fastread := yes +$ ENDIF +$ IF (ans .EQS. "&-s") +$ THEN +$ echo4 "(OK, I will run with -s after this question.)" $ echo "" $ READ SYS$COMMAND/PROMPT="''rp'" ans -$ Endif +$ silent := true +$ GOSUB Shut_up +$ ENDIF $ Endif $ RETURN $! @@ -602,6 +632,58 @@ $ WRITE CONFIG - $ CLOSE CONFIG $ ENDIF $! +$ IF F$TYPE(usedevel) .EQS. "" THEN usedevel := n +$ patchlevel_h = F$SEARCH("[-]patchlevel.h") +$ IF (patchlevel_h.NES."") +$ THEN +$ SEARCH 'patchlevel_h' "define","PERL_VERSION","epoch"/match=and/out=[]ver.out +$ IF .NOT. usedevel .AND. usedevel .NES. "define" +$ THEN +$ OPEN/READ CONFIG []ver.out +$ READ CONFIG line +$ CLOSE CONFIG +$ tmp = F$EDIT(line,"TRIM,COMPRESS") +$ xpatchlevel = F$INTEGER(F$ELEMENT(2," ",tmp)) +$ line = xpatchlevel / 2 +$ tmp = xpatchlevel - ( line * 2 ) +$ IF tmp .NE. 0 +$ THEN +$ echo4 "patchlevel is " + F$STRING(xpatchlevel) +$ cat4 SYS$INPUT: +$ DECK +*** WHOA THERE!!! *** + + This is an UNSTABLE DEVELOPMENT release. + (The patchlevel, is odd--as opposed to even, + and that signifies a development release. If you want a + maintenance release, you want an even-numbered release.) + + Do ***NOT*** install this into production use. + Data corruption and crashes are possible. + + It is most seriously suggested that you do not continue any further + unless you want to help in developing and debugging Perl. + +$ EOD +$ dflt="n" +$ rp="Do you really want to continue? [''dflt'] " +$ IF (fastread) THEN fastread := FALSE +$ GOSUB myread +$ IF ans .EQS. "" THEN ans = dflt +$ IF ans +$ THEN +$ echo4 "Okay, continuing." +$ ELSE +$ echo4 "Okay, bye." +$ DELETE/NOLOG/NOCONFIRM []ver.out; +$ GOTO Clean_up +$ ENDIF +$ ENDIF +$ DELETE/SYMBOL line +$ DELETE/SYMBOL tmp +$ ENDIF +$ DELETE/NOLOG/NOCONFIRM []ver.out; +$ ENDIF $!: general instructions $ needman = "true" $ firsttime = "true" @@ -626,6 +708,7 @@ $! $ IF (needman) $ THEN $ TYPE SYS$INPUT: +$ DECK This installation shell script will examine your system and ask you questions to determine how the perl5 package should be installed. If you get @@ -634,16 +717,20 @@ process, edit something, then restart this process as you just did. Many of the questions will have default answers in square brackets; typing carriage return will give you the default. +$ EOD $ READ SYS$COMMAND/PROMPT="Type carriage return to continue " ans $ TYPE SYS$INPUT: +$ DECK In a hurry? You may run '@Configure "-d"'. This will bypass nearly all the questions and use the computed defaults (or the previous answers provided there was already a config.sh file). Type '@Configure "-h"' for a list of options. +$ EOD $ READ SYS$COMMAND/PROMPT="Type carriage return to continue " ans $ TYPE SYS$INPUT: +$ DECK Much effort has been expended to ensure that this shell script will run on any VMS system. If despite that it blows up on yours, your @@ -651,6 +738,7 @@ best bet is to edit Configure.com and @ it again. Whatever problems you have with Configure.com, let me (dan@sidhe.org) know how I blew it. +$ EOD $!This installation script affects things in two ways: $! $!1) it may do direct variable substitutions on some of the files included @@ -675,7 +763,7 @@ $ sharpbang = "$ " $!: figure out how to guarantee sh startup !sfn $!: find out where common programs are !sfn $!loclist="awk/cat/comm/cp/echo/expr/find/grep/ln/ls/mkdir/rm/sed/sort/touch/tr/uniq" -$!trylist="Mcc/byacc/cpp/csh/date/egrep/less/line/more/nroff/perl/pg/sendmail/test/uname" +$!trylist="byacc/cpp/csh/date/egrep/less/line/more/nroff/perl/pg/sendmail/test/uname" $! echo "I don't know where '$file' is, and my life depends on it." $! echo "Go find a public domain implementation or fix your PATH setting!" $! echo "" @@ -699,15 +787,49 @@ $ configshfound = F$SEARCH(config_sh) $ IF (configshfound.NES."") THEN GOTO Config_sh_found $ ENDIF $ IF (i.LT.max) THEN GOTO Config_sh_look -$ IF (configshfound.EQS."") THEN GOTO Beyond_config_sh +$! genconfig.pl has "osname='VMS'" +$ osname = F$EDIT(F$GETSYI("NODE_SWTYPE"),"COLLAPSE") +$ IF (configshfound.EQS."") +$ THEN +$ config_sh = "[-]config.sh" ! the fallback default +$ GOTO Beyond_config_sh +$ ENDIF $Config_sh_found: -$ echo "" -$ echo "Fetching default answers from ''config_sh'..." +$ IF F$TYPE(osname) .EQS. "" THEN osname = F$EDIT(F$GETSYI("NODE_SWTYPE"),"COLLAPSE") +$ IF F$TYPE(config_dflt) .EQS. "" THEN config_dflt = "n" +$ rp = "Shall I @ ''config_sh' for default answers? [''config_dflt'] " +$ GOSUB myread +$ IF ans .EQS. "" THEN ans = config_dflt +$ IF ans +$ THEN +$ echo "" +$ echo "Fetching default answers from ''config_sh'..." +$! +$! This @ is why config_sh must employ DCL syntax. Note that for +$! symbols to be returned to this procedure they must be global. +$! Which implies that assignments must be of the :== or == variety. +$! Note further that the [-]config.sh file written by this procedure +$! employs shell syntax. In order to convert shell syntax to DCL +$! you might try: +$! +$! perl -ni -e "s/^#/!#/;s/='/==""/;s/'$/""/;print ""\$ $_"";" config.sh +$! +$! However, watch out for sig_nam, sig_nam_init, sig_num, startperl +$! and any of the lower case double quoted variables such as the *format +$! variables in such a config."sh". +$! +$ @'config_sh' +$! +$ ENDIF +$ DELETE/SYMBOL config_dflt +$! $!we actually do not have "hints/" for VMS $! TYPE SYS$INPUT: +$! DECK $! $!First time through, eh? I have some defaults handy for the following systems: $! +$! EOD $! echo " ","VMS_VAX" $! echo " ","VMS_AXP" $! : Now look for a hint file osname_osvers, unless one has been @@ -723,20 +845,20 @@ $Beyond_config_sh: $! $!: Restore computed paths !sfn $! -$! genconfig.pl has "osname='VMS'" -$ osname = F$EDIT(F$GETSYI("NODE_SWTYPE"),"COLLAPSE") $! %Config-I-VMS, a necessary error trap (could be PC running VCL) $! $ IF (osname .NES. "VMS") $ THEN $ echo4 "Hmm.. I wonder what ''osname' is (?)" $ TYPE SYS$INPUT: +$ DECK %Config-E-VMS, ERROR: Err, you do not appear to be running VMS! This procedure is intended to Configure the building of Perl for VMS. +$ EOD $ READ SYS$COMMAND/PROMPT="Continue anyway? [n] " ans $ IF ans $ THEN @@ -750,11 +872,13 @@ $ ENDIF $ ELSE !we are on VMS huzzah! $ IF .NOT.silent $ THEN TYPE SYS$INPUT: +$ DECK Configure uses the operating system name and version to set some defaults. The default value is probably right if the name rings a bell. Otherwise, since spelling matters for me, either accept the default or answer "none" to leave it blank. +$ EOD $ ENDIF $ rp = "Operating system name? [''osname'] " $ GOSUB myread @@ -768,9 +892,7 @@ $ ENDIF $ ENDIF !(osname .NES./.EQS. "VMS") $! $!: who configured the system -$! see 'user' above. $ cf_by = F$EDIT(user,"LOWERCASE") -$! cf_time = F$CVTIME() !superceded by procedure below $ osvers = F$EDIT(F$GETSYI("VERSION"),"TRIM") $! $! Peter Prymmer has seen: @@ -793,7 +915,6 @@ $! "WIN$Time_Zone" $! $! This snippet o' DCL returns a string in default Unix `date` format, $! and it will prompt to set SYS$TIMEZONE_DIFFERENTIAL. -$! Peter Prymmer pvhp@lns62.lns.cornell.edu $! $ MIN_TZO = -840 !units are minutes here $ MAX_TZO = 840 @@ -832,7 +953,6 @@ $ tzhour = -1*tzhour !keeps !UL happy $ direction = "west of " $ ENDIF $ echo "" -$ echo "%Config-I-VMS," $ echo "According to the setting of your ""SYS$TIMEZONE_DIFFERENTIAL"" (= ''systz')" $ IF tzminrem.ne.0 $ THEN @@ -842,7 +962,7 @@ $ tzspan = "''tzhour' hours" $ ENDIF $ dflt = "y" $ echo "Your system is ''tzspan' ''direction'UTC in England." -$ rp = "%Config-I-VMS, (''systz') Is this UTC Time Zone Offset correct? [''dflt'] " +$ rp = "(''systz') Is this UTC Time Zone Offset correct? [''dflt'] " $ GOSUB myread $ IF ans.OR.(ans.EQS."") $ THEN @@ -852,7 +972,6 @@ $ GOTO Beyond_TimeZone $ ENDIF $ ELSE $ echo "" -$ echo4 "%Config-I-VMS," $ echo4 """SYS$TIMEZONE_DIFFERENTIAL"" does not appear to be DEFINEd on your system" $ ENDIF $! @@ -899,6 +1018,8 @@ $ cf_time = "''wkday' ''mon' ''mday' ''hour':''min':''sec' ''tz' ''year'" $! $!: determine the architecture name $! genconfig.pl has either archname='VMS_AXP' or 'VMS_VAX' +$! Note that DCL in VMS V5.4 does not have F$GETSYI("ARCH_NAME") +$! but does have F$GETSYI("HW_MODEL"). $! $ IF (F$GETSYI("HW_MODEL") .LT. 1024) $ THEN @@ -923,7 +1044,9 @@ $ echo4 "I'll go with ''archname' anyway..." $ ENDIF $ ENDIF $ dflt = "n" -$ rp = "Will you be sharing your PERL_ROOT with ''otherarch'? [''dflt'] " +$ vms_prefix = "perl_root" +$ vms_prefixup = F$EDIT(vms_prefix,"UPCASE") +$ rp = "Will you be sharing your ''vms_prefixup' with ''otherarch'? [''dflt'] " $ GOSUB myread $ if ans.NES."" $ THEN @@ -946,22 +1069,26 @@ $!: set up shell script to do ~ expansion !sfn $!: expand filename !sfn $!: now set up to get a file name !sfn $! -$ prefix = F$ENVIRONMENT("DEFAULT") - ".UU]" + "]" -$ prefix = F$PARSE(prefix,,,,"NO_CONCEAL") - "][" - ".;" -$ prefixbase = prefix - "]" -$ prefix = prefixbase + ".]" +$ IF F$TYPE(prefix) .EQS. "" +$ THEN +$ prefix = F$ENVIRONMENT("DEFAULT") - ".UU]" + "]" +$ prefix = F$PARSE(prefix,,,,"NO_CONCEAL") - "][" - ".;" +$ prefixbase = prefix - "]" +$ prefix = prefixbase + ".]" +$ ENDIF +$ src = prefix $!: determine root of directory hierarchy where package will be installed. $ dflt = prefix $ IF .NOT.silent $ THEN $ echo "" $ echo "By default, ''package' will be installed in ''dflt', pod" -$ echo "pages under ''prefixbase'LIB.POD], etc..., i.e. with ''dflt' as prefix for" +$ echo "pages under ''prefixbase'.LIB.POD], etc..., i.e. with ''dflt' as prefix for" $ echo "all installation directories." -$ echo "On ''osname' the ''prefix' is used to DEFINE the ''packageup'_ROOT prior to installation" +$ echo "On ''osname' the prefix is used to DEFINE the ''vms_prefixup' prior to installation" $ echo "as well as during subsequent use of ''package' via ''packageup'_SETUP.COM." $ ENDIF -$ rp = "Installation prefix to use (for ''packageup'_ROOT)? [ ''dflt' ] " +$ rp = "Installation prefix to use (for ''vms_prefixup')? [ ''dflt' ] " $ GOSUB myread $ IF ans.NES."" $ THEN @@ -970,6 +1097,7 @@ $ IF F$LOCATE(".]",ans) .EQ. F$LENGTH(ans) THEN prefix = prefix - "]" + ".]" $ ELSE $ prefix = dflt $ ENDIF +$ perl_root = prefix $! $! Check here for pre-existing PERL_ROOT. $! -> ask if removal desired. @@ -979,7 +1107,7 @@ $! $ vms_skip_install = "true" $ dflt = "y" $! echo "" -$ rp = "%Config-I-VMS, Skip the remaining """"where install"""" questions? [''dflt'] " +$ rp = "Skip the remaining """"where install"""" questions? [''dflt'] " $ GOSUB myread $ IF (.NOT.ans).AND.(ans.NES."") THEN vms_skip_install = "false" $ IF (.NOT.vms_skip_install) @@ -991,12 +1119,18 @@ $!: determine where private library files go $!: Usual default is /usr/local/lib/perl5. Also allow things like $!: /opt/perl/lib, since /opt/perl/lib/perl5 would be redundant. $ IF .NOT.silent -$ THEN TYPE SYS$INPUT: +$ THEN +$ TYPE SYS$INPUT: +$ DECK There are some auxiliary files for perl5 that need to be put into a private library directory that is accessible by everyone. +$ EOD +$ ENDIF +$ IF F$TYPE(privlib) .NES. "" +$ THEN dflt = privlib +$ ELSE dflt = "''vms_prefix':[lib]" $ ENDIF -$ dflt = prefix - ".]" + ".LIB]" $ rp = "Pathname where the private library files will reside? " $ rp = F$FAO("!AS!/!AS",rp,"[ ''dflt' ] ") $ GOSUB myread @@ -1013,12 +1147,12 @@ $ dflt = "y" $ IF .NOT.silent $ THEN $ echo "" -$ echo "%Config-I-VMS, You may choose to write ''packageup'_SETUP.COM to assign a foreign" -$ echo "-Config-I-VMS, symbol to invoke ''package', which is the usual method." -$ echO "-Config-I-VMS, If you do not do so then you would need a DCL command verb at the" -$ echo "-Config-I-VMS, process or the system wide level." +$ echo "You may choose to write ''packageup'_SETUP.COM to assign a foreign" +$ echo "symbol to invoke ''package', which is the usual method." +$ echO "If you do not do so then you would need a DCL command verb at the" +$ echo "process or the system wide level." $ ENDIF -$ rp = "Invoke perl as a global symbol foreign command [''dflt'] " +$ rp = "Invoke perl as a global symbol foreign command? [''dflt'] " $ GOSUB myread $ IF (.NOT.ans).AND.(ans.NES."") THEN perl_symbol = "false" $! @@ -1028,11 +1162,11 @@ $ dflt = "y" $ IF .NOT.silent $ THEN $ echo "" -$ echo "%Config-I-VMS, Since you won't be using a symbol you must choose to put the ''packageup'" -$ echo "-Config-I-VMS, verb in a per-process table or in the system wide DCLTABLES (which" -$ echo "-Config-I-VMS, would require write privilege)." +$ echo "Since you won't be using a symbol you must choose to put the ''packageup'" +$ echo "verb in a per-process table or in the system wide DCLTABLES (which" +$ echo "would require write privilege)." $ ENDIF -$ rp = "Invoke perl as a per process command verb [ ''dflt' ] " +$ rp = "Invoke perl as a per process command verb? [ ''dflt' ] " $ GOSUB myread $ IF (.NOT.ans).AND.(ans.NES."") $ THEN perl_verb = "DCLTABLES" @@ -1045,7 +1179,7 @@ $ baserev="5.0" $ revision = baserev - ".0" $!: get the patchlevel $ echo "" -$ echo4 "Getting the current patchlevel..." !>&4 +$ echo4 "Getting the current patchlevel..." $ patchlevel_h = F$SEARCH("[-]patchlevel.h") $ IF (patchlevel_h.NES."") $ THEN @@ -1056,7 +1190,7 @@ $ got_api_version = "false" $ got_api_subversion = "false" $ OPEN/READONLY CONFIG 'patchlevel_h' $Patchlevel_h_loop: -$ READ/END_Of_File=Close_patch CONFIG line +$ READ/END_Of_File=Close_patch/ERROR=Close_patch CONFIG line $ IF ((F$LOCATE("#define PERL_VERSION",line).NE.F$LENGTH(line)).AND.(.NOT.got_patch)) $ THEN $ line = F$EDIT(line,"COMPRESS, TRIM") @@ -1087,12 +1221,20 @@ $ line = F$EDIT(line,"COMPRESS, TRIM") $ api_subversion = F$ELEMENT(2," ",line) $ got_api_subversion = "true" $ ENDIF -$ IF (.NOT.got_patch).OR.(.NOT.got_sub) THEN GOTO Patchlevel_h_loop +$ IF (.NOT. got_patch) .OR. - + (.NOT. got_sub) .OR. - + (.NOT. got_api_revision) .OR. - + (.NOT. got_api_version) .OR. - + (.NOT. got_api_subversion) - + THEN GOTO Patchlevel_h_loop $Close_patch: $ CLOSE CONFIG -$ ELSE -$ patchlevel="0" -$ subversion="0" +$ ELSE +$ patchlevel="0" +$ subversion="0" +$ api_revision="0" +$ api_version="0" +$ api_subversion="0" $ ENDIF $ IF (F$STRING(subversion) .NES. "0") $ THEN @@ -1105,7 +1247,6 @@ $ version = revision + "_" + patchlevel + "_" + subversion $! $ IF (.NOT.vms_skip_install) $ THEN -$!: set the prefixup variable, to restore leading tilda escape !sfn $!: set the prefixup variable, to restore leading tilde escape !sfn $! $!: determine where public architecture dependent libraries go @@ -1115,12 +1256,18 @@ $ echo "" $ echo "''package' contains architecture-dependent library files. If you are" $ ENDIF $ IF (.NOT.silent) -$ THEN TYPE SYS$INPUT: +$ THEN +$ TYPE SYS$INPUT: +$ DECK sharing libraries in a heterogeneous environment, you might store these files in a separate location. Otherwise, you can just include them with the rest of the public library files. +$ EOD +$ ENDIF +$ IF F$TYPE(archlib) .NES. "" +$ THEN dflt = archlib +$ ELSE dflt = privlib - "]" + "." + archname + "." + version + "]" $ ENDIF -$ dflt = privlib - "]" + "." + archname + "." + version + "]" $ rp = "Where do you want to put the public architecture-dependent libraries? " $ rp = F$FAO("!AS!/!AS",rp,"[ ''dflt' ] ") $ GOSUB myread @@ -1129,16 +1276,16 @@ $ THEN archlib = ans $ ELSE archlib = dflt $ ENDIF $! -$!: set up the script used to warn in case of inconsistency !sfn -$!: function used to set $1 to $val !sfn -$! $ ENDIF !%Config-I-VMS, skip "where install" questions +$! $! This quotation from Configure has to be included on VMS: +$! $ TYPE SYS$INPUT: +$ DECK There is, however, a strange, musty smell in the air that reminds me of something...hmm...yes...I've got it...there's a VMS nearby, or I'm a Blit. -$ CONTINUE +$ EOD $ IF (.NOT.vms_skip_install) $ THEN $!: it so happens the Eunice I know will not run shell scripts in Unix format @@ -1148,14 +1295,20 @@ $!: now see if they want to do setuid emulation !sfn $! $!: determine where site specific libraries go. $ IF .NOT.silent -$ THEN TYPE SYS$INPUT: +$ THEN +$ TYPE SYS$INPUT: +$ DECK The installation process will also create a directory for site-specific extensions and modules. Some users find it convenient to place all local files in this directory rather than in the main distribution directory. +$ EOD +$ ENDIF +$ IF F$TYPE(sitelib) .NES. "" +$ THEN dflt = sitelib +$ ELSE dflt = privlib - "]" + ".SITE_PERL]" $ ENDIF -$ dflt = privlib - "]" + ".SITE_PERL]" $ rp = "Pathname for the site-specific library files? " $ rp = F$FAO("!AS!/!AS",rp,"[ ''dflt' ] ") $ GOSUB myread @@ -1167,11 +1320,16 @@ $! $!: determine where site specific architecture-dependent libraries go. $ IF .NOT.silent $ THEN TYPE SYS$INPUT: +$ DECK The installation process will also create a directory for architecture-dependent site-specific extensions and modules. +$ EOD +$ ENDIF +$ IF F$TYPE(sitearch) .NES. "" +$ THEN dflt = sitearch +$ ELSE dflt = sitelib - "]" + "." + archname + "]" $ ENDIF -$ dflt = sitelib - "]" + "." + archname + "]" $ rp = "Pathname for the site-specific architecture-dependent library files? " $ rp = F$FAO("!AS!/!AS",rp,"[ ''dflt' ] ") $ GOSUB myread @@ -1183,7 +1341,11 @@ $! $!: determine where old public architecture dependent libraries might be $! $!: determine where public executables go -$ dflt = prefix - ".]" + ".BIN]" +$ IF F$TYPE(bin) .NES. "" +$ THEN dflt = bin +$! ELSE dflt = prefix - ".]" + ".BIN]" +$ ELSE dflt = "/''vms_prefix'/000000" +$ ENDIF $ rp = "Pathname where the public executables will reside? " $ rp = F$FAO("!AS!/!AS",rp,"[ ''dflt' ] ") $ GOSUB myread @@ -1199,8 +1361,57 @@ $!: determine where library module manual pages go $!: What suffix to use on installed man pages $!: see what memory models we can support $! +$ ELSE ! skipping "where install" questions, we must set some symbols +$ IF F$TYPE(archlib).EQS."" THEN - + archlib="''vms_prefix':[lib.''archname'.''version']" +$ IF F$TYPE(bin) .EQS. "" THEN - + bin="/''vms_prefix'/000000" +$ IF F$TYPE(privlib) .EQS. "" THEN - + privlib ="''vms_prefix':[lib]" +$ IF F$TYPE(sitearch) .EQS. "" THEN - + sitearch="''vms_prefix':[lib.site_perl.''archname']" +$ IF F$TYPE(sitelib) .EQS. "" THEN - + sitelib ="''vms_prefix':[lib.site_perl]" $ ENDIF !%Config-I-VMS, skip "where install" questions $! +$! These derived locations can be set whether we've opted to +$! skip the where install questions or not. +$! +$ IF F$TYPE(archlibexp) .EQS. "" THEN - + archlibexp="''vms_prefix':[lib.''archname'.''version']" +$ IF F$TYPE(binexp) .EQS. "" THEN - + binexp ="''vms_prefix':[000000]" +$ IF F$TYPE(builddir) .EQS. "" THEN - + builddir ="''vms_prefix':[000000]" +$ IF F$TYPE(installarchlib) .EQS. "" THEN - + installarchlib="''vms_prefix':[lib.''archname'.''version']" +$ IF F$TYPE(installbin) .EQS. "" THEN - + installbin ="''vms_prefix':[000000]" +$ IF F$TYPE(installscript) .EQS. "" THEN - + installscript ="''vms_prefix':[utils]" +$ IF F$TYPE(installman1dir) .EQS. "" THEN - + installman1dir ="''vms_prefix':[man.man1]" +$ IF F$TYPE(installman3dir) .EQS. "" THEN - + installman3dir ="''vms_prefix':[man.man3]" +$ IF F$TYPE(installprivlib) .EQS. "" THEN - + installprivlib ="''vms_prefix':[lib]" +$ IF F$TYPE(installsitearch) .EQS. "" THEN - + installsitearch="''vms_prefix':[lib.site_perl.''archname']" +$ IF F$TYPE(installsitelib) .EQS. "" THEN - + installsitelib ="''vms_prefix':[lib.site_perl]" +$ IF F$TYPE(oldarchlib) .EQS. "" THEN - + oldarchlib="''vms_prefix':[lib.''archname']" +$ IF F$TYPE(oldarchlibexp) .EQS. "" THEN - + oldarchlibexp="''vms_prefix':[lib.''archname']" +$ IF F$TYPE(privlibexp) .EQS. "" THEN - + privlibexp ="''vms_prefix':[lib]" +$ IF F$TYPE(sitearchexp) .EQS. "" THEN - + sitearchexp ="''vms_prefix':[lib.site_perl.''archname']" +$ IF F$TYPE(sitelib_stem) .EQS. "" THEN - + sitelib_stem ="''vms_prefix':[lib.site_perl]" +$ IF F$TYPE(sitelibexp) .EQS. "" THEN - + sitelibexp ="''vms_prefix':[lib.site_perl]" +$! $!: see if we need a special compiler $! cc_list = "cc/decc|gcc" !%Config-I-VMS, compiler symbols/commands $! @@ -1209,7 +1420,9 @@ $ vms_cc_dflt = "" $ vms_cc_available = "" $! $ OPEN/WRITE CONFIG ccvms.c +$ WRITE CONFIG "#ifdef __DECC" $ WRITE CONFIG "#include <stdlib.h>" !DECC is sooo picky +$ WRITE CONFIG "#endif" $ WRITE CONFIG "#include <stdio.h>" $ WRITE CONFIG "int main() {" $ WRITE CONFIG "#ifdef __DECC" @@ -1228,8 +1441,6 @@ $ tmp = $status $! DEASSIGN SYS$OUTPUT $! DEASSIGN SYS$ERROR $ IF (silent) THEN GOSUB Shut_up -$! echo "%Config-I-VMS, After cc compile $status = >''tmp'<" !diagnostic -$! $ IF tmp.NE.%X10B90001 $ THEN $ IF tmp.NE.%X10000001 @@ -1241,28 +1452,26 @@ $ ENDIF $! $ GOSUB List_Parse $ IF .NOT.silent THEN echo "" -$ echo "%Config-I-VMS, Default ""cc"" is ''line' ''archsufx' ''F$GETSYI("VERSION")'" +$ echo "Default ""cc"" is ''line' ''archsufx' ''F$GETSYI("VERSION")'" $ IF F$LOCATE("VAX",line).NE.F$LENGTH(line) $ THEN $ IF .NOT.silent $ THEN -$ echo "%Config-I-VMS, Will try cc/decc..." +$ echo "Will try cc/decc..." $ ENDIF -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: +$ DEFINE/USER_MODE SYS$ERROR NL: +$ DEFINE/USER_MODE SYS$OUTPUT NL: $ SET NOON $ cc/decc/NoObj/list=ccvms.lis ccvms.c $ tmp = $status -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR $ SET ON $ IF (silent) THEN GOSUB Shut_up $ IF tmp.NE.%X10B90001 $ THEN -$ echo "%Config-I-VMS, Apparently you don't have that one." +$ echo "Apparently you don't have that one." $ ELSE $ GOSUB List_parse -$ echo "%Config-I-VMS, You also have: ''line' ''archsufx' ''F$GETSYI("VERSION")'" +$ echo "You also have: ''line' ''archsufx' ''F$GETSYI("VERSION")'" $ vms_cc_available = vms_cc_available + "cc/decc " $ ENDIF $ ELSE @@ -1274,20 +1483,19 @@ $ ENDIF $ ENDIF $! $Gcc_initial_check: -$ echo "%Config-I-VMS, Checking for Gcc" +$ echo "Checking for gcc" $ OPEN/WRITE CONFIG gccvers.lis -$ DEFINE SYS$ERROR CONFIG -$ DEFINE SYS$OUTPUT CONFIG +$ DEFINE/USER_MODE SYS$ERROR CONFIG +$ DEFINE/USER_MODE SYS$OUTPUT CONFIG $ 'gcc_symbol'/noobj/version _nla0: $ tmp = $status -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR $ IF (silent) THEN GOSUB Shut_up $ CLOSE CONFIG $ IF (tmp.NE.%X10000001).and.(tmp.ne.%X00030001) $ THEN -$ echo "%Config-I-VMS, Symbol ""''gcc_symbol'"" is not defined. I guess you don't have it." -$ goto cc_cleanup +$ echo "Symbol ""''gcc_symbol'"" is not defined. I guess you do not have it." +$ DELETE/NOLOG/NOCONFIRM gccvers.lis; +$ GOTO Cxx_initial_check $ ENDIF $ OPEN/READ CONFIG gccvers.lis $GCC_List_Read: @@ -1299,12 +1507,93 @@ $ echo line $ vms_cc_available = vms_cc_available + "''gcc_symbol' " $ DELETE/NOLOG/NOCONFIRM gccvers.lis; $! +$Cxx_initial_check: +$! +$! Do note that [vms]perl source files have a ways to go before they will +$! compile under CXX. +$! In order to test Configure.com with CXX invoke it with "-Dtry_cxx" on +$! the command line. +$! +$ IF F$TYPE(try_cxx) .EQS. "" THEN try_cxx := n +$ IF try_cxx .OR. try_cxx .EQS. "define" +$! +$ THEN +$! +$ echo "Checking for CXX..." +$ OPEN/WRITE CONFIG ccvms.c +$ WRITE CONFIG "#include <iostream>" +$ WRITE CONFIG "int main() {" +$ WRITE CONFIG "#ifdef __DECCXX" +$ WRITE CONFIG " cout << __DECCXX, endl;" +$ WRITE CONFIG "#else" +$ WRITE CONFIG " cout << 0,endl;" +$ WRITE CONFIG "#endif" +$! Todo: add G++ identifier check ?? +$ WRITE CONFIG " return(0);" +$ WRITE CONFIG "}" +$ CLOSE CONFIG +$ SET NOON +$ DEFINE/USER_MODE SYS$OUTPUT NL: +$ DEFINE/USER_MODE SYS$ERROR NL: +$ cxx ccvms.c +$ tmp = $status +$ SET ON +$! success $status with: +$! DEC C++ V1.1-001 on VMS VAX V5.5-2 +$! DEC C++ V5.6-013 on OpenVMS VAX V7.1 +$! DEC C++ V6.1-003 on OpenVMS Alpha V7.1 +$! Compaq C++ V6.2-016 for OpenVMS Alpha V7.2-1 +$ IF tmp .eq. %X15F60001 +$ THEN +$! Which linker? +$ SET NOON +$ DEFINE/USER_MODE SYS$OUTPUT NL: +$ DEFINE/USER_MODE SYS$ERROR NL: +$ link ccvms.obj +$ tmp = $status +$ SET ON +$ ! success $status with: +$ ! link && DEC C++ V1.1-001 on VMS VAX V5.5-2 +$ ! link && DEC C++ V5.6-013 on OpenVMS VAX V7.1 +$ IF tmp .eq. %X10000001 +$ THEN +$ ld_try = "Link" +$ vms_cc_available = vms_cc_available + "cxx " +$ echo "CXX and LINK are available." +$ ELSE +$ IF F$SEARCH("ccvms.exe") .NES. "" THEN DELETE/NOLOG/NOCONFIRM ccvms.exe; +$ SET NOON +$ DEFINE/USER_MODE SYS$OUTPUT NL: +$ DEFINE/USER_MODE SYS$ERROR NL: +$ cxxlink ccvms.obj +$ tmp = $status +$ SET ON +$ ! success $status with: +$ ! cxxlink && DEC C++ V6.1-003 on OpenVMS Alpha V7.1 +$ ! cxxlink && Compaq C++ V6.2-016 for OpenVMS Alpha V7.2-1 +$ IF tmp .eq. %X10000001 +$ THEN +$ ld_try = "cxxlink" +$ vms_cc_available = vms_cc_available + "cxx " +$ echo "CXX and CXXLINK are available." +$ ENDIF +$ ENDIF +$ IF F$SEARCH("ccvms.exe") .NES. "" THEN DELETE/NOLOG/NOCONFIRM ccvms.exe; +$ ELSE +$ echo "Nope." +$ ENDIF +$ DELETE/NOLOG/NOCONFIRM ccvms.c; +$ IF F$SEARCH("ccvms.obj") .NES. "" THEN DELETE/NOLOG/NOCONFIRM ccvms.obj; +$ CALL Cxx_demangler_cleanup +$! +$ ENDIF ! 1 .eq. 0 or 1 .eq. 1 +$! $CC_Cleanup: $ DELETE/NOLOG/NOCONFIRM ccvms.*; $CC_Desired: $!: see if we need a special compiler $! echo "" -$ echo "%Config-I-VMS, available compiler(s):" +$ echo "Available compiler(s):" $ echo "( ''vms_cc_available')" $ IF .NOT.nocc $ THEN @@ -1321,42 +1610,53 @@ $ Mcc = ans $ IF (F$LOCATE("dec",ans).NE.F$LENGTH(ans)).or.(F$LOCATE("compaq",ans).NE.F$LENGTH(ans)) $ THEN $ Mcc = "cc/decc" -$ Using_Dec_C = "Yes" +$! CPQ ? +$ ccname := DEC $ C_COMPILER_Replace = "CC=cc=''Mcc'" $ ENDIF -$ IF Mcc.NES.dflt +$ IF F$LOCATE("cxx",F$EDIT(ans,"COLLAPSE,LOWERCASE")) .NE. F$LENGTH(ans) $ THEN -$ IF (F$LOCATE("dec",dflt).NE.F$LENGTH(dflt)).or(F$LOCATE("compaq",dflt).NE.F$LENGTH(dflt)) -$ THEN -$ C_COMPILER_Replace = "CC=cc=''Mcc'" -$ ELSE -$ Using_Dec_C = "Yes" -$ ENDIF -$ ELSE -$ IF Mcc .EQS. "cc/decc" +$ Mcc = "cxx" +$ ccname := CXX +$ ld = ld_try +$ C_COMPILER_Replace = "CC=cc=''Mcc'" +$ ELSE ! Not_cxx +$ IF Mcc.NES.dflt $ THEN -$ Using_Dec_C = "Yes" -$ C_COMPILER_Replace = "CC=cc=''Mcc'" +$ IF F$LOCATE("dec",dflt) .NE. F$LENGTH(dflt) .or. - + F$LOCATE("compaq",dflt) .NE. F$LENGTH(dflt) +$ THEN +$ C_COMPILER_Replace = "CC=cc=''Mcc'" +$ ELSE +$ ccname := DEC +$ ENDIF +$ ELSE +$ IF Mcc .EQS. "cc/decc" +$ THEN +$ ccname := DEC +$ C_COMPILER_Replace = "CC=cc=''Mcc'" +$ ENDIF $ ENDIF $ ENDIF $ ELSE $ Mcc = dflt $ IF Mcc .EQS. "cc/decc" $ THEN -$ Using_Dec_C = "Yes" +$ ccname := DEC $ C_COMPILER_Replace = "CC=cc=''Mcc'" $ ENDIF $ IF Mcc .EQS. "gcc" $ THEN -$ Using_Gnu_C = "Yes" +$ ccname := GCC $ C_COMPILER_Replace = "CC=cc=''Mcc'" $ ENDIF $ ENDIF $Decc_Version_check: -$ IF "''Using_Dec_C'".EQS."Yes" +$ ccversion="" +$ IF ccname .EQS. "DEC" $ THEN $ echo "" -$ echo4 "Checking for Dec C's version number..." !>&4 +$ echo4 "Checking for the Dec C version number..." $ OPEN/WRITE CONFIG deccvers.c $ WRITE CONFIG "#include <stdlib.h>" !DECC is sooo picky $ WRITE CONFIG "#include <stdio.h>" @@ -1371,153 +1671,219 @@ $ WRITE CONFIG "#endif" $ WRITE CONFIG " exit(0);" $ WRITE CONFIG "}" $ CLOSE CONFIG -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: +$ SET NOON +$ DEFINE/USER_MODE SYS$ERROR NL: +$ DEFINE/USER_MODE SYS$OUTPUT NL: $ 'Mcc' deccvers.c $ tmp = $status -$ DEASSIGN SYS$ERROR _NLA0: -$ DEASSIGN SYS$OUTPUT _NLA0: $ IF (silent) THEN GOSUB Shut_up -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: +$ DEFINE/USER_MODE SYS$ERROR NL: +$ DEFINE/USER_MODE SYS$OUTPUT NL: $ link deccvers.obj $ tmp = $status -$ DEASSIGN SYS$ERROR -$ DEASSIGN SYS$OUTPUT $ IF (silent) THEN GOSUB Shut_up $ OPEN/WRITE CONFIG deccvers.out -$ DEFINE SYS$ERROR CONFIG -$ DEFINE SYS$OUTPUT CONFIG +$ DEFINE/USER_MODE SYS$ERROR CONFIG +$ DEFINE/USER_MODE SYS$OUTPUT CONFIG $ mcr []deccvers.exe $ tmp = $status +$ SET ON $ CLOSE CONFIG -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR $ IF (silent) THEN GOSUB Shut_up $ OPEN/READ CONFIG deccvers.out $ READ/END_OF_FILE=Dec_c_cleanup CONFIG line $Dec_c_cleanup: $ CLOSE CONFIG -$! DELETE/NOLOG/NOCONFIRM deccvers.*; $ echo "You are using Dec C ''line'" -$ Dec_C_Version = line -$ Dec_C_Version = Dec_C_Version + 0 -$ if Dec_C_Version.ge.60200000 THEN CC_FLAGS = CC_FLAGS + "/NOANSI_ALIAS" +$ ccversion = line +$ Dec_C_Version = F$INTEGER(line) +$ IF Dec_C_Version .GE. 60200000 +$ THEN +$ echo4 "adding /NOANSI_ALIAS qualifier to ccflags." +$ ccflags = ccflags + "/NOANSI_ALIAS" +$ ENDIF +$ DELETE/NOLOG/NOCONFIRM deccvers.*; $ ENDIF $Gcc_check: -$ if "''using_gnu_c'" .eqs. "Yes" +$ gccversion = "" +$ IF ccname .EQS. "GCC" $ THEN -$ vaxcrtl_olb = F$SEARCH("SYS$LIBRARY:VAXCRTL.OLB") -$ vaxcrtl_exe = F$SEARCH("SYS$SHARE:VAXCRTL.EXE") -$ gcclib_olb = F$SEARCH("GNU_CC:[000000]GCCLIB.OLB") -$ IF gcclib_olb .EQS. "" -$ THEN -$! These objects/libs come w/ gcc 2.7.2 for AXP: -$ tmp = F$SEARCH("GNU_CC:[000000]libgcc2.olb") -$ IF tmp .NES. "" then gcclib_olb = tmp -$ tmp = F$SEARCH("GNU_CC:[000000]libgcclib.olb") -$ IF tmp .NES. "" +$ vaxcrtl_olb = F$SEARCH("SYS$LIBRARY:VAXCRTL.OLB") +$ vaxcrtl_exe = F$SEARCH("SYS$SHARE:VAXCRTL.EXE") +$ gcclib_olb = F$SEARCH("GNU_CC:[000000]GCCLIB.OLB") +$ IF gcclib_olb .EQS. "" $ THEN -$ IF gcclib_olb .EQS. "" -$ THEN gcclib_olb = tmp -$ ELSE gcclib_olb = gcclib_olb + "/lib," + tmp +$! These objects/libs come w/ gcc 2.7.2 for AXP: +$ tmp = F$SEARCH("GNU_CC:[000000]libgcc2.olb") +$ IF tmp .NES. "" then gcclib_olb = tmp +$ tmp = F$SEARCH("GNU_CC:[000000]libgcclib.olb") +$ IF tmp .NES. "" +$ THEN +$ IF gcclib_olb .EQS. "" +$ THEN gcclib_olb = tmp +$ ELSE gcclib_olb = gcclib_olb + "/lib," + tmp +$ ENDIF $ ENDIF -$ ENDIF -$ tmp = F$SEARCH("SYS$LIBRARY:VAXCRTL.OLB") -$ IF tmp .NES. "" -$ THEN -$ IF gcclib_olb .EQS. "" -$ THEN gcclib_olb = tmp -$ ELSE gcclib_olb = gcclib_olb + "/lib," + tmp +$ tmp = F$SEARCH("SYS$LIBRARY:VAXCRTL.OLB") +$ IF tmp .NES. "" +$ THEN +$ IF gcclib_olb .EQS. "" +$ THEN gcclib_olb = tmp +$ ELSE gcclib_olb = gcclib_olb + "/lib," + tmp +$ ENDIF $ ENDIF -$ ENDIF -$ tmp = F$SEARCH("GNU_CC:[000000]crt0.obj") -$ IF tmp .NES. "" -$ THEN -$ IF gcclib_olb .EQS. "" -$ THEN gcclib_olb = tmp -$ ELSE gcclib_olb = gcclib_olb + "/lib," + tmp +$ tmp = F$SEARCH("GNU_CC:[000000]crt0.obj") +$ IF tmp .NES. "" +$ THEN +$ IF gcclib_olb .EQS. "" +$ THEN gcclib_olb = tmp +$ ELSE gcclib_olb = gcclib_olb + "/lib," + tmp +$ ENDIF $ ENDIF +$ IF gcclib_olb .EQS. vaxcrtl_olb THEN gcclib_olb = "" !goofy order of axplibs +$ ELSE +$ gcclib_olb = gcclib_olb + "/lib" $ ENDIF -$ IF gcclib_olb .EQS. vaxcrtl_olb THEN gcclib_olb = "" !goofy order of axplibs -$ ELSE -$ gcclib_olb = gcclib_olb + "/lib" -$ ENDIF -$ IF gcclib_olb .NES. "" .AND. - +$ IF gcclib_olb .NES. "" .AND. - (vaxcrtl_olb .NES. "" .OR. - vaxcrtl_exe .NES. "" ) +$ THEN +$ echo "" +$ echo4 "Checking for GNU cc in disguise and/or its version number..." !>&4 +$ OPEN/WRITE CONFIG gccvers.c +$ WRITE CONFIG "#include <stdio.h>" +$ WRITE CONFIG "int main() {" +$ WRITE CONFIG "#ifdef __GNUC__" +$ WRITE CONFIG "#ifdef __VERSION__" +$ WRITE CONFIG " printf(""%s\n"", __VERSION__);" +$ WRITE CONFIG "#else" +$ WRITE CONFIG " printf(""%s\n"", ""1"");" +$ WRITE CONFIG "#endif" +$ WRITE CONFIG "#endif" +$ WRITE CONFIG " exit(0);" +$ WRITE CONFIG "}" +$ CLOSE CONFIG +$ DEFINE SYS$ERROR _NLA0: +$ DEFINE SYS$OUTPUT _NLA0: +$ 'Mcc' gccvers.c +$ tmp = $status +$ DEASSIGN SYS$ERROR _NLA0: +$ DEASSIGN SYS$OUTPUT _NLA0: +$ IF (silent) THEN GOSUB Shut_up +$ DEFINE SYS$ERROR _NLA0: +$ DEFINE SYS$OUTPUT _NLA0: +$ IF vaxcrtl_exe .EQS. "" +$ THEN +$ IF F$LOCATE("VAXCRTL",gcclib_olb).NE.F$LENGTH(gcclib_olb) +$ THEN +$ link gccvers.obj,'gcclib_olb',SYS$LIBRARY:VAXCRTL/Library +$ tmp = $status +$ ELSE +$ link gccvers.obj,'gcclib_olb' +$ tmp = $status +$ ENDIF +$ ELSE +$ OPEN/WRITE CONFIG GCCVERS.OPT +$ WRITE CONFIG "SYS$SHARE:VAXCRTL/SHARE" +$ CLOSE CONFIG +$ link gccvers.obj,GCCVERS.OPT/OPT,'gcclib_olb' +$ tmp = $status +$ ENDIF +$ DEASSIGN SYS$ERROR +$ DEASSIGN SYS$OUTPUT +$ IF (silent) THEN GOSUB Shut_up +$ OPEN/WRITE CONFIG gccvers.out +$ DEFINE SYS$ERROR CONFIG +$ DEFINE SYS$OUTPUT CONFIG +$ mcr []gccvers.exe +$ tmp = $status +$ CLOSE CONFIG +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ IF (silent) THEN GOSUB Shut_up +$ OPEN/READ CONFIG gccvers.out +$ READ/END_OF_FILE=Gcc_cleanup CONFIG line +$Gcc_cleanup: +$ CLOSE CONFIG +$ DELETE/NOLOG/NOCONFIRM gccvers.*; +$ IF F$LOCATE("GNU C version ",line).NE.F$LENGTH(line) +$ THEN +$ echo "You are not using GNU cc." +$ GOTO Host_name +$ ELSE +$ echo "You are using GNU cc ''line'" +$ gccversion = line +$ ccname := "GCC" +$ C_COMPILER_Replace = "CC=cc=''Mcc'" +$ GOTO Include_dirs +$ ENDIF +$ ENDIF +$ ENDIF +$Cxx_Version_check: +$ IF ccname .EQS. "CXX" $ THEN -$ echo "" -$ echo4 "Checking for GNU cc in disguise and/or its version number..." !>&4 -$ OPEN/WRITE CONFIG gccvers.c -$ WRITE CONFIG "#include <stdlib.h>" !DECC is sooo picky +$ OPEN/WRITE CONFIG cxxvers.c $ WRITE CONFIG "#include <stdio.h>" $ WRITE CONFIG "int main() {" -$ WRITE CONFIG "#ifdef __GNUC__" -$ WRITE CONFIG "#ifdef __VERSION__" -$ WRITE CONFIG " printf(""%s\n"", __VERSION__);" +$ WRITE CONFIG "#ifdef __DECCXX_VER" +$ WRITE CONFIG " printf(""%i\n"", __DECCXX_VER);" $ WRITE CONFIG "#else" -$ WRITE CONFIG " printf(""%s\n"", ""1"");" -$ WRITE CONFIG "#endif" +$ WRITE CONFIG " printf(""%i\n"", ""0"");" $ WRITE CONFIG "#endif" -$ WRITE CONFIG " exit(0);" +$ WRITE CONFIG " return(0);" $ WRITE CONFIG "}" $ CLOSE CONFIG -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ 'Mcc' gccvers.c +$ SET NOON +$ DEFINE/USER_MODE SYS$ERROR NL: +$ DEFINE/USER_MODE SYS$OUTPUT NL: +$ 'Mcc' cxxvers.c $ tmp = $status -$ DEASSIGN SYS$ERROR _NLA0: -$ DEASSIGN SYS$OUTPUT _NLA0: +$ SET ON $ IF (silent) THEN GOSUB Shut_up -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ IF vaxcrtl_exe .EQS. "" -$ THEN -$ IF F$LOCATE("VAXCRTL",gcclib_olb).NE.F$LENGTH(gcclib_olb) -$ THEN -$ link gccvers.obj,'gcclib_olb',SYS$LIBRARY:VAXCRTL/Library -$ tmp = $status -$ ELSE -$ link gccvers.obj,'gcclib_olb' -$ tmp = $status -$ ENDIF -$ ELSE -$ OPEN/WRITE CONFIG GCCVERS.OPT -$ WRITE CONFIG "SYS$SHARE:VAXCRTL/SHARE" -$ CLOSE CONFIG -$ link gccvers.obj,GCCVERS.OPT/OPT,'gcclib_olb' -$ tmp = $status -$ ENDIF -$ DEASSIGN SYS$ERROR -$ DEASSIGN SYS$OUTPUT +$ SET NOON +$ DEFINE/USER_MODE SYS$ERROR NL: +$ DEFINE/USER_MODE SYS$OUTPUT NL: +$ 'ld' cxxvers.obj +$ tmp = $status +$ SET ON $ IF (silent) THEN GOSUB Shut_up -$ OPEN/WRITE CONFIG gccvers.out -$ DEFINE SYS$ERROR CONFIG -$ DEFINE SYS$OUTPUT CONFIG -$ mcr []gccvers.exe +$ OPEN/WRITE CONFIG cxxvers.out +$ SET NOON +$ DEFINE/USER_MODE SYS$ERROR CONFIG +$ DEFINE/USER_MODE SYS$OUTPUT CONFIG +$ mcr []cxxvers.exe $ tmp = $status +$ SET ON $ CLOSE CONFIG -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR $ IF (silent) THEN GOSUB Shut_up -$ OPEN/READ CONFIG gccvers.out -$ READ/END_OF_FILE=Gcc_cleanup CONFIG line -$Gcc_cleanup: +$ OPEN/READ CONFIG cxxvers.out +$ READ/END_OF_FILE=Cxx_cleanup CONFIG line +$Cxx_cleanup: $ CLOSE CONFIG -$ DELETE/NOLOG/NOCONFIRM gccvers.*; -$ IF F$LOCATE("GNU C version ",line).NE.F$LENGTH(line) -$ THEN -$ echo "You are not using GNU cc." -$ GOTO Host_name -$ ELSE -$ echo "You are using GNU cc ''line'" -$ Using_Gnu_C = "Yes" -$ C_COMPILER_Replace = "CC=cc=''Mcc'" -$ GOTO Include_dirs -$ ENDIF +$ DELETE/NOLOG/NOCONFIRM cxxvers.*; +$ echo "You are using CXX ''line'" +$ cxxversion = line +$ ccversion = line +$ CALL Cxx_demangler_cleanup $ ENDIF -$endif +$! +$Cxx_demangler_cleanup: SUBROUTINE +$! +$! If we do build with CXX these demangler Dbs will be left all over. +$! However, configure.com does try to remove the [.UU] sub directory. +$! Be sure to set default to the correct place before calling this sub. +$! +$ SET NOON +$ IF F$SEARCH("[.CXX_REPOSITORY]*.*") .NES. "" THEN DELETE/NOLOG/NOCONFIRM [.CXX_REPOSITORY]*.*;* +$ IF F$SEARCH("CXX_REPOSITORY.DIR") .NES. "" +$ THEN +$ SET PROTECTION=(SYSTEM:RWED,OWNER:RWED) CXX_REPOSITORY.DIR +$ DELETE/NOLOG/NOCONFIRM CXX_REPOSITORY.DIR; +$ ENDIF +$ SET ON +$ EXIT +$ ENDSUBROUTINE ! Cxx_demangler_cleanup +$! $ GOTO Host_name $! $List_Parse: @@ -1542,7 +1908,7 @@ $ DELETE/NOLOG/NOCONFIRM ccvms.lis; $ RETURN $! $Include_dirs: -$!: What should the include directory be ? +$!: What should the include directory be ? (.TLB text libraries) $ dflt = gcclib_olb $ rp = "Where are the include files you want to use? " $ IF f$length( rp + "[''dflt'] " ).gt.76 @@ -1608,30 +1974,39 @@ $ ENDIF $ myhostname = myhostname - mydomain $ echo "(Trimming domain name from host name--host name is now ''myhostname')" $ IF .NOT.silent -$ THEN TYPE SYS$INPUT: +$ THEN +$ TYPE SYS$INPUT: +$ DECK I need to get your e-mail address in Internet format if possible, i.e. something like user@host.domain. Please answer accurately since I have no easy means to double check it. The default value provided below is most probably close to the reality but may not be valid from outside your organization... +$ EOD $ ENDIF -$ dflt = "''cf_by'@''myhostname'"+"''mydomain'" -$ rp = "What is your e-mail address? [''dflt'] " -$ GOSUB myread -$ IF ans .nes. "" -$ THEN cf_email = ans -$ ELSE cf_email = dflt +$ IF F$TYPE(cf_email) .EQS. "" +$ THEN +$ dflt = "''cf_by'@''myhostname'"+"''mydomain'" +$ rp = "What is your e-mail address? [''dflt'] " +$ GOSUB myread +$ IF ans .nes. "" +$ THEN cf_email = ans +$ ELSE cf_email = dflt +$ ENDIF $ ENDIF $! $ IF .NOT.silent -$ THEN TYPE SYS$INPUT: +$ THEN +$ TYPE SYS$INPUT: +$ DECK If you or somebody else will be maintaining perl at your site, please fill in the correct e-mail address here so that they may be contacted if necessary. Currently, the "perlbug" program included with perl will send mail to this address in addition to perlbug@perl.com. You may enter "none" for no administrator. +$ EOD $ ENDIF $ dflt = "''cf_email'" $ rp = "Perl administrator e-mail address [''dflt'] " @@ -1667,40 +2042,49 @@ $!: see if we have sigaction $!: see whether socketshr exists $ IF (F$SEARCH(F$PARSE("SocketShr","Sys$Share:.Exe")).NES."") $ THEN -$ has_socketshr = "T" +$ Has_socketshr = "T" $ echo "" -$ echo4 "Hmm... Looks like you have SOCKETSHR's Berkeley networking support." -$ endif -$ if (Dec_C_Version .ge. 50200000) +$ echo4 "Hmm... Looks like you have SOCKETSHR Berkeley networking support." +$ ELSE +$ Has_socketshr = "F" +$ ENDIF +$ IF (ccname .EQS. "DEC" .AND. Dec_C_Version .GE. 50200000) .OR. - + (ccname .EQS. "CXX") $ THEN $ Has_Dec_C_Sockets = "T" $ echo "" -$ echo4 "Hmm... Looks like you've got Dec C's Berkeley networking support." +$ echo4 "Hmm... Looks like you have Dec C Berkeley networking support." +$ ELSE +$ Has_Dec_C_Sockets = "F" $ ENDIF $ ! Hey, we've got both. Default to Dec C, then, since it's better -$ if ("''Has_socketshr'".eq."T") .or.("''has_dec_c_sockets'".eq."T") +$ IF Has_socketshr .OR. Has_Dec_C_Sockets $ THEN $ echo "" -$ echo "You've got sockets available. Which socket stack do you want to" -$ echo "build into perl?" -$ if "''has_dec_c_sockets'".eqs."T" +$ echo "You have sockets available. Which socket stack do you want to" +$ echo "build into Perl?" +$ IF Has_Dec_C_Sockets $ THEN $ dflt = "DECC" $ else $ dflt = "SOCKETSHR" $ endif $ rp = "Choose socket stack (NONE" -$ if "''has_socketshr'".eqs."T" THEN rp = rp + ",SOCKETSHR" -$ if "''has_dec_c_sockets'".eqs."T" THEN rp = rp + ",DECC" +$ IF Has_socketshr THEN rp = rp + ",SOCKETSHR" +$ IF Has_Dec_C_Sockets THEN rp = rp + ",DECC" $ rp = rp + ") [''dflt'] " $ GOSUB myread -$ IF "''ans'".eqs."" THEN ans = "''dflt'" -$ has_dec_c_sockets = "F" -$ has_socketshr = "F" +$ IF ans .EQS. "" THEN ans = "''dflt'" +$ Has_Dec_C_Sockets = "F" +$ Has_socketshr = "F" $ 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 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 @@ -1723,11 +2107,11 @@ $ ENDIF $! $! Ask if they want to build with DEBUGGING $ echo "" -$ echo "Perl can be built with extra runtime debugging enabled. This -$ echo "enables the -D switch, at the cost of some performance. It -$ echo "was mandatory on perl 5.005 and before on VMS, but is now -$ echo "optional. If you don't generally use it you should probably -$ echo "leave this off and gain a bit of extra speed. +$ echo "Perl can be built with extra runtime debugging enabled. This" +$ echo "enables the -D switch, at the cost of some performance. It" +$ echo "was mandatory on perl 5.005 and before on VMS, but is now" +$ echo "optional. If you do not generally use it you should probably" +$ echo "leave this off and gain a bit of extra speed." $ dflt = "y" $ rp = "Build a DEBUGGING version of Perl? [''dflt'] " $ GOSUB myread @@ -1741,77 +2125,72 @@ $ ENDIF $! $! Ask if they want to build with MULTIPLICITY $ echo "" -$ echo "The perl interpreter engine can be built in a way that makes it -$ echo "possible for a program that embeds perl into it (and yes, you can -$ echo "do that--it's pretty keen) to have multiple perl interpreters active -$ echo "at once. There is some performance overhead, however, so you -$ echo "probably don't want to choose this unless you're going to be doing -$ echo "funky perl embedding." +$ echo "Perl can be built so that multiple Perl interpreters can coexist" +$ echo "within the same Perl executable." +$ echo "There is some performance overhead, however, so you" +$ echo "probably do not want to choose this unless you are going to be" +$ echo "doing things with embedded perl." $ dflt = "n" -$ rp = "Build with MULTIPLICITY? [''dflt'] " +$ rp = "Build Perl for multiplicity? [''dflt'] " $ GOSUB myread -$ if ans.eqs."" then ans = dflt -$ IF F$EXTRACT(0, 1, F$EDIT(ans,"COLLAPSE,UPCASE")) .eqs. "Y" +$ IF ans.eqs."" then ans = dflt +$ IF ans $ THEN -$ use_multiplicity="Y" +$ usemultiplicity="define" $ ELSE -$ use_multiplicity="N" +$ usemultiplicity="undef" $ ENDIF $! $! Ask if they want to build with 64-bit support -$ IF (Archname.eqs."VMS_AXP").and.("''f$extract(1,3, f$getsyi(""version""))'".ges."7.1") +$ IF (archname.eqs."VMS_AXP").and.("''f$extract(1,3, f$getsyi(""version""))'".ges."7.1") $ THEN $ dflt = use64bitint $ echo "" -$ echo "You can have native 64-bit long integers. +$ echo "You can have native 64-bit long integers." $ echo "" -$ echo "Perl can be built to take advantage of 64-bit integer types -$ echo "on some systems, which provide a much larger range for perl's -$ echo "mathematical operations. (Note that does *not* enable 64-bit +$ echo "Perl can be built to take advantage of 64-bit integer types" +$ echo "on some systems, which provide a much larger range for perl's" +$ echo "mathematical operations. (Note that does *not* enable 64-bit" $ echo "fileops at the moment, as Dec C doesn't do that yet)." -$ echo "Choosing this option will most probably introduce binary incompatibilities. +$ echo "Choosing this option will most probably introduce binary incompatibilities." $ echo "" -$ echo "If this doesn't make any sense to you, just accept the default ''dflt'. +$ echo "If this does not make any sense to you, just accept the default ''dflt'." $ rp = "Try to use 64-bit integers, if available? [''dflt'] " $ GOSUB myread $ IF ans .EQS. "" THEN ans = dflt -$ IF (f$extract(0, 1, f$edit(ans,"COLLAPSE,UPCASE")) .EQS. "Y") -$ THEN -$ use64bitint="Y" -$ ELSE -$ use64bitint="N" +$ IF ans +$ THEN use64bitint="Y" +$ ELSE use64bitint="N" $ ENDIF $ IF (use64bitint) $ THEN $ dflt = use64bitall $ echo "" -$ echo "Since you chose 64-bitness you may want to try maximal 64-bitness. -$ echo "What you have chosen is minimal 64-bitness which means just enough -$ echo "to get 64-bit integers. The maximal means using as much 64-bitness -$ echo "as is possible on the platform. This in turn means even more binary -$ echo "incompatibilities. On the other hand, your platform may not have -$ echo "any more maximal 64-bitness than what you already have chosen. +$ echo "Since you chose 64-bitness you may want to try maximal 64-bitness." +$ echo "What you have chosen is minimal 64-bitness which means just enough" +$ echo "to get 64-bit integers. The maximal means using as much 64-bitness" +$ echo "as is possible on the platform. This in turn means even more binary" +$ echo "incompatibilities. On the other hand, your platform may not have" +$ echo "any more maximal 64-bitness than what you already have chosen." $ echo "" -$ echo "If this doesn't make any sense to you, just accept the default ''dflt'. +$ echo "If this does not make any sense to you, just accept the default ''dflt'." $ rp = "Try to use full 64-bit support, if available? [''dflt'] " $ GOSUB myread $ IF ans .EQS. "" THEN ans = dflt -$ IF (f$extract(0, 1, f$edit(ans,"COLLAPSE,UPCASE")) .EQS. "Y") -$ THEN -$ use64bitall="Y" -$ ELSE -$ use64bitall="N" +$ IF ans +$ THEN use64bitall="Y" +$ ELSE use64bitall="N" $ ENDIF $ ENDIF $ ENDIF ! AXP && >= 7.1 $! $! Ask about threads, if appropriate -$ if (Using_Dec_C.eqs."Yes") +$ IF ccname .EQS. "DEC" .OR. ccname .EQS. "CXX" $ THEN $ echo "" -$ echo "This version of Perl can be built with threads. While really nifty, -$ echo "they are a beta feature, and there is a speed penalty for perl -$ echo "programs if you build with threads *even if you don't use them* +$ echo "This version of Perl can be built with threads. While really nifty," +$ echo "they are a beta feature, and there is a speed penalty for perl" +$ echo "programs if you build with threads *even if you do not use them*." $ dflt = "n" $ rp = "Build with threads? [''dflt'] " $ GOSUB myread @@ -1819,22 +2198,21 @@ $ if ans.eqs."" then ans = dflt $ if (f$extract(0, 1, "''ans'").eqs."Y").or.(f$extract(0, 1, "''ans'").eqs."y") $ THEN $ use_threads="T" -$! $ ! Shall we do the 5.005-stype threads, or IThreads? -$ echo "As of 5.5.640, Perl has two different internal threading -$ echo "implementations, the 5.005 version (5005threads) and an -$ echo "interpreter-based version (ithreads) that has one -$ echo "interpreter per thread. Both are very experimental. This -$ echo "arrangement exists to help developers work out which one -$ echo "is better. -$ echo " -$ echo "If you're a casual user, you probably don't want -$ echo "interpreter-threads at this time. There doesn't yet exist -$ echo "a way to create threads from within Perl in this model, -$ echo "i.e., ""use Thread;"" will NOT work. -$ echo " +$ echo "As of 5.5.640, Perl has two different internal threading" +$ echo "implementations, the 5.005 version (5005threads) and an" +$ echo "interpreter-based version (ithreads) that has one" +$ echo "interpreter per thread. Both are very experimental. This" +$ echo "arrangement exists to help developers work out which one" +$ echo "is better." +$ echo "" +$ echo "If you are a casual user, you probably do not want" +$ echo "interpreter-threads at this time. There doesn't yet exist" +$ echo "a way to create threads from within Perl in this model," +$ echo "i.e., ""use Thread;"" will NOT work." +$ echo "" $ dflt = "n" -$ rp = "Build with Interpreter threads? [''dflt'] +$ rp = "Build with Interpreter threads? [''dflt'] " $ GOSUB myread $ if ans.eqs."" then ans = dflt $ if (f$extract(0, 1, "''ans'").eqs."Y").or.(f$extract(0, 1, "''ans'").eqs."y") @@ -1846,17 +2224,17 @@ $ use_ithreads="N" $ use_5005_threads="Y" $ ENDIF $ ! Are they on VMS 7.1 on an alpha? -$ if (Archname.eqs."VMS_AXP").and.("''f$extract(1,3, f$getsyi(""version""))'".ges."7.1") +$ if (archname.eqs."VMS_AXP").and.("''f$extract(1,3, f$getsyi(""version""))'".ges."7.1") $ THEN $ echo "" -$ echo "Threaded perl can be linked to use multiple kernel threads -$ echo "and system upcalls on VMS 7.1+ on Alpha systems. This feature -$ echo "allows multiple threads to execute simultaneously on an SMP -$ echo "system as well as preventing a single thread from blocking -$ echo "all the threads in a program, even on a single-processor -$ echo "machine. Unfortunately this feature isn't safe on an -$ echo "unpatched 7.1 system. (Several OS patches were required when -$ echo "this procedure was written) +$ echo "Threaded perl can be linked to use multiple kernel threads" +$ echo "and system upcalls on VMS 7.1+ on Alpha systems. This feature" +$ echo "allows multiple threads to execute simultaneously on an SMP" +$ echo "system as well as preventing a single thread from blocking" +$ echo "all the threads in a program, even on a single-processor" +$ echo "machine. Unfortunately, this feature isn't safe on an" +$ echo "unpatched 7.1 system (several OS patches were required when" +$ echo "this procedure was written)." $ dflt = "n" $ rp = "Enable multiple kernel threads and upcalls? [''dflt'] " $ gosub myread @@ -1868,47 +2246,48 @@ $ ENDIF $ ENDIF $ ENDIF $ ENDIF -$ if archname .eqs. "VMS_AXP" -$ then -$! +$ IF archname .EQS. "VMS_AXP" +$ THEN $! Case sensitive? -$ echo "" -$ echo "By default, perl (and pretty much everything else on VMS) uses -$ echo "case-insensitive linker symbols. Which is to say, when the -$ echo "underlying C code makes a call to a routine called Perl_foo in -$ echo "the source, the name in the object modules or shareable images -$ echo "is really PERL_FOO. There are some packages that use an -$ echo "embedded perl interpreter that instead require case-sensitive -$ echo "linker symbols. -$ echo "" -$ echo "If you have no idea what this means, and don't have -$ echo "any program requiring anything, choose the default. -$ dflt = be_case_sensitive -$ rp = "Case-sensitive symbols [''dflt'] " -$ gosub myread -$ if ans.eqs."" then ans="''dflt'" -$ be_case_sensitive = "''ans'" -$! +$ echo "" +$ echo "By default, perl (and pretty much everything else on VMS) uses" +$ echo "case-insensitive linker symbols. Which is to say, when the" +$ echo "underlying C code makes a call to a routine called Perl_foo in" +$ echo "the source, the name in the object modules or shareable images" +$ echo "is really PERL_FOO. There are some packages that use an" +$ echo "embedded perl interpreter that instead require case-sensitive" +$ echo "linker symbols." +$ echo "" +$ echo "If you have no idea what this means, and do not have" +$ echo "any program requiring anything, choose the default." +$ dflt = be_case_sensitive +$ rp = "Build with case-sensitive symbols? [''dflt'] " +$ GOSUB myread +$ IF ans .EQS. "" THEN ans="''dflt'" +$ be_case_sensitive = "''ans'" $! IEEE math? -$ echo "" -$ echo "Perl normally uses G_FLOAT format floating point numbers -$ echo "internally, as do most things on VMS. You can, however, build -$ echo "with IEEE floating point numbers instead if you need to. -$ dflt = use_ieee_math -$ rp = "Use IEEE math [''dflt'] " -$ gosub myread -$ if ans.eqs."" then ans="''dflt'" -$ use_ieee_math = "''ans'" -$ endif +$ echo "" +$ echo "Perl normally uses G_FLOAT format floating point numbers" +$ echo "internally, as do most things on VMS. You can, however, build" +$ echo "with IEEE floating point numbers instead if you need to." +$ dflt = use_ieee_math +$ rp = "Use IEEE math? [''dflt'] " +$ GOSUB myread +$ IF ans .eqs. "" THEN ans = "''dflt'" +$ use_ieee_math = "''ans'" +$ ENDIF $! CC Flags $ echo "" -$ echo "You can, if you need to, pass extra flags on to the C -$ echo "compiler. In general you should only do this if you really, -$ echo "really know what you're doing. +$ echo "Your compiler may want other flags. For this question you should include" +$ echo "/INCLUDE=(whatever) and /DEFINE=(whatever), flags and any other flags" +$ echo "or qualifiers used by the compiler." +$ echo "" +$ echo "To use no flags, specify the word ""none""." $ dflt = user_c_flags -$ rp = "Extra C flags [''dflt'] " -$ gosub myread -$ if ans.eqs."" then ans="''dflt'" +$ rp = "Any additional cc flags? [''dflt'] " +$ GOSUB myread +$ IF ans .EQS. "" THEN ans = "''dflt'" +$ IF ans .EQS. "none" THEN ans = "" $ user_c_flags = "''ans'" $! $! Ask whether they want to use secure logical translation when tainting @@ -1929,8 +2308,11 @@ $ echo "name translation." $ dflt = "y" $ rp = "Use secure logical name translation? [''dflt'] " $ GOSUB myread -$ if ans.eqs."" then ans="''dflt'" -$ d_secintgenv = f$extract(0, 1, f$edit(ans,"TRIM,COMPRESS,UPCASE")) +$ IF ans .eqs. "" THEN ans = dflt +$ IF ans +$ THEN d_secintgenv := Y +$ ELSE d_secintgenv := N +$ ENDIF $! $! Ask whether they want to default filetypes $ echo "" @@ -1942,47 +2324,56 @@ $ echo "file types of nothing, .pl, and .com, in that order (e.g. typing" $ echo """$ perl foo"" would cause Perl to look for foo., then foo.pl, and" $ echo "finally foo.com)." $ echo "" -$ echo "This is currently broken in some configurations. Only enable it if -$ echo "you know what you're doing. " -$ dflt = "N" +$ echo "This is currently broken in some configurations. Only enable it if" +$ echo "you know what you are doing." +$ dflt = "n" $ rp = "Always use default file types? [''dflt'] " $ GOSUB myread -$ if ans.eqs."" then ans="''dflt'" -$ d_alwdeftype = f$extract(0, 1, f$edit(ans,"COLLAPSE,UPCASE")) -$! +$ IF ans .EQS. "" THEN ans = dflt +$ IF ans +$ THEN d_alwdeftype := Y +$ ELSE d_alwdeftype := N +$ ENDIF $! Ask if they want to use perl's memory allocator $ echo "" -$ echo "Perl has a built-in memory allocator that's tuned for perl's -$ echo "normal memory usage. It's oftentimes better than the standard -$ echo "system memory allocator. It also has the advantage of providing -$ echo "memory allocation statistics, if you choose to enable them. +$ echo "Perl has a built-in memory allocator that is tuned for normal" +$ echo "memory usage. It is oftentimes better than the standard system" +$ echo "memory allocator. It also has the advantage of providing memory" +$ echo "allocation statistics, if you choose to enable them." $ dflt = "n" -$ rp = "Build with perl's memory allocator? [''dflt'] " +$ IF F$TYPE(usemymalloc) .EQS. "STRING" +$ THEN +$ IF usemymalloc THEN dflt = "y" +$ ENDIF +$ rp = "Do you wish to attempt to use the malloc that comes with ''package'? [''dflt'] " $ GOSUB myread -$ if ans.eqs."" then ans="''dflt'" -$ mymalloc = f$extract(0, 1, f$edit(ans,"COLLAPSE,UPCASE")) -$ if mymalloc.eqs."Y" +$ IF ans .eqs. "" THEN ans = dflt +$ IF ans +$ THEN mymalloc := Y +$ ELSE mymalloc := N +$ ENDIF +$ IF mymalloc $ THEN -$ if use_debugging_perl.eqs."Y" +$ IF use_debugging_perl $ THEN $ echo "" -$ echo "Perl can keep statistics on memory usage if you choose to use -$ echo "them. This is useful for debugging, but does have some -$ echo "performance overhead. +$ echo "Perl can keep statistics on memory usage if you choose to use" +$ echo "them. This is useful for debugging, but does have some" +$ echo "performance overhead." $ dflt = "n" $ rp = "Do you want the debugging memory allocator? [''dflt'] " $ gosub myread -$ if ans.eqs."" then ans="''dflt'" +$ IF ans .eqs. "" THEN ans = "''dflt'" $ use_debugmalloc = f$extract(0, 1, f$edit(ans, "COLLAPSE,UPCASE")) $ ENDIF $ ! Check which memory allocator we want $ echo "" -$ echo "There are currently three different memory allocators: the -$ echo "default (which is a pretty good general-purpose memory manager), -$ echo "the TWO_POT allocator (which is optimized to save memory for -$ echo "larger allocations), and PACK_MALLOC (which is optimized to save -$ echo "memory for smaller allocations). They're all good, but if your -$ echo "usage tends towards larger chunks use TWO_POT, otherwise use +$ echo "There are currently three different memory allocators: the" +$ echo "default (which is a pretty good general-purpose memory manager)," +$ echo "the TWO_POT allocator (which is optimized to save memory for" +$ echo "larger allocations), and PACK_MALLOC (which is optimized to save" +$ echo "memory for smaller allocations). They're all good, but if your" +$ echo "usage tends towards larger chunks use TWO_POT, otherwise use" $ echo "PACK_MALLOC." $ dflt = "DEFAULT" $ rp = "Memory allocator (DEFAULT, TWO_POT, PACK_MALLOC) [''dflt'] " @@ -1994,17 +2385,15 @@ $ ENDIF $! $! Ask for their default list of extensions to build $ echo "" -$ echo "It's time to specify which modules you want to build into -$ echo "perl. Most of these are standard and should be chosen, though -$ 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 "Whatever you do, make sure the re module is first or things will -$ echo "break badly" -$ echo " +$ echo "It is time to specify which modules you want to build into" +$ echo "perl. Most of these are standard and should be chosen, though" +$ 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 Thread Sys::Hostname" -$ if Using_Dec_C.eqs."Yes" +$ IF ccname .EQS. "DEC" .OR. ccname .EQS. "CXX" $ THEN $ dflt = dflt + " POSIX" $ ENDIF @@ -2046,11 +2435,11 @@ $ exloop3: $ dflt = f$edit(a,"trim") $! $ extensions = "''ans'" -$ perl_known_extensions = "''dflt'" +$ known_extensions = "''dflt'" $! $! %Config-I-VMS, determine build/make utility here (make gmake mmk mms) $ echo "" -$ echo "%Config-I-VMS, Checking your ""make"" utilities..." +$ echo "Checking your ""make"" utilities..." $! If the 'build' that you use is not here add it and it's test $! switch to the _END_ of these strings (and increment max_build) $! (e.g. builders = builders + "/FOOMAKE" @@ -2073,11 +2462,16 @@ $Build_probe: $ build = F$ELEMENT(n,"/",builders) $ probe = F$ELEMENT(n,"!",probers) $ echo "Testing whether you have ''build' on your system..." +$! +$! Noted with GNU Make version 3.60 that the $status and $severity +$! with the 'probe' Makefile appear to be: $STATUS == "%X1000000C" +$! $SEVERITY == "4". +$! $ SET NOON $ ON CONTROL_Y THEN GOTO Reenable_messages_build $ SET MESSAGE/NOFAC/NOSEV/NOIDENT/NOTEXT $ 'build' 'probe' -$ IF ($SEVERITY .EQ. 1) +$ IF ($SEVERITY .EQ. 1) ! not adequate? $ THEN $ echo "OK." $ IF (build .EQS. orig_dflt) @@ -2101,7 +2495,7 @@ $ IF (ok_builders .NES. "") $ THEN $ echo "Here is the list of builders you can apparently use:" $ echo "(",ok_builders," )" -$ rp = "Which """"make"""" utility do you wish to use [''dflt']? " +$ rp = "Which """"make"""" utility do you wish to use? [''dflt'] " $ GOSUB myread $ ans = F$EDIT(ans,"TRIM, COMPRESS") $ ans = F$EXTRACT(0,F$LOCATE(" ",ans),ans) !throw out "-f Makefile." here @@ -2111,18 +2505,20 @@ $ ELSE build = ans $ ENDIF $ ELSE $ TYPE SYS$INPUT: +$ DECK %Config-E-VMS, ERROR: Well this looks pretty serious. Perl5 cannot be compiled without a "make" utility of some sort and after checking my "builders" list I cannot find the symbol or command you use on your system to compile programs. -$ READ SYS$COMMAND/PROMPT="%Config-I-VMS, Which ""MMS"" do you use? " ans +$ EOD +$ READ SYS$COMMAND/PROMPT="Which ""MMS"" do you use? " ans $ ans = F$EDIT(ans,"TRIM, COMPRESS") $ ans = F$EXTRACT(0,F$LOCATE(" ",ans),ans) !throw out "-f Makefile." here $ IF (ans .EQS. "") $ THEN build = dflt -$ echo "I don't know where 'make' is, and my life depends on it." +$ echo "I do not know where ""make"" is, and my life depends on it." $ echo "Go find a make program or fix your DCL$PATH setting!" $ echo "ABORTING..." $ SET DEFAULT 'vms_default_directory_name' !be kind rewind @@ -2137,13 +2533,17 @@ $ DELETE/NOLOG Makefile.; $ GOTO Beyond_open $Open_error: $ TYPE SYS$INPUT: +$ DECK There seems to be trouble. I just tried to create a file in +$ EOD $ echo4 'F$ENVIRONMENT("DEFAULT")' $ TYPE SYS$INPUT: +$ DECK but was unsuccessful. I am stopping now. Please check that directories' PROTECTION bits. I will leave you in the directory where you started Configure.com +$ EOD $ echo4 "ABORTING..." $ GOTO Clean_up $ STOP @@ -2155,7 +2555,17 @@ $ make = F$EDIT(build,"UPCASE") $! $!: locate the preferred pager for this system $!pagers = "most|more|less|type/page" -$!rp='What pager is used on your system?' +$ dflt = "type/page" +$! assume that the presence of a most symbol indicates the presence +$! of the pager. +$ IF F$TYPE(most) .EQS. "STRING" THEN dflt = "most" +$ IF F$TYPE(pager) .EQS. "STRING" THEN dflt = pager +$ rp="What pager is used on your system? [''dflt'] " +$ GOSUB myread +$ IF (ans .EQS. "") +$ THEN pager = dflt +$ ELSE pager = ans +$ ENDIF $! $! update [.vms]config.vms here $! @@ -2167,38 +2577,3066 @@ $ THEN $ makefile = "" !wrt MANIFEST dir $ UUmakefile = "[-]DESCRIP.MMS" !wrt CWD dir $ DEFmakefile = "DESCRIP.MMS" !wrt DEF dir (?) +$ Makefile_SH = "descrip_mms.template" $ ELSE $ makefile = " -f Makefile." !wrt MANIFEST dir $ UUmakefile = "[-]Makefile." !wrt CWD dir $ DEFmakefile = "Makefile." !wrt DEF dir (?) +$ Makefile_SH = "Makefile.in" $ ENDIF $! -$ IF macros.NES."" -$ THEN +$ IF macros .NES. "" +$ THEN $ tmp = F$LENGTH(macros) $ macros = F$EXTRACT(0,(tmp-1),macros) !miss trailing comma $ macros = "/macro=(" + macros + ")" $ ENDIF $! Build up the extra C flags $! -$ if use_ieee_math -$ then +$ IF use_ieee_math +$ THEN $ extra_flags = "''extra_flags'" + "/float=ieee/ieee=denorm_results" -$ endif -$ if be_case_sensitive -$ then +$ ENDIF +$ IF be_case_sensitive +$ THEN $ extra_flags = "''extra_flags'" + "/Names=As_Is" -$ endif +$ ENDIF $ extra_flags = "''extra_flags'" + "''user_c_flags'" $! -$! Invoke the subconfig piece +$ min_pgflquota = "100000" +$ pgflquota = F$STRING(F$GETJPI("","PGFLQUOTA")) +$ IF pgflquota .LES. min_pgflquota +$ THEN +$ echo4 "Your PGFLQUOTA of ''pgflquota' appears too small to build ''package'." +$ READ SYS$COMMAND/PROMPT="Continue? [n] " ans +$ IF ans +$ THEN +$ echo4 "Continuing..." +$ ELSE +$ echo4 "ABORTING..." +$ GOTO Clean_up +$ ENDIF +$ ENDIF $! $ echo "" -$ echo4 "Checking the C run-time library" -$ dflt = F$ENVIRONMENT("DEFAULT") -$ SET DEFAULT [-.vms] -$ @subconfigure -$ SET DEFAULT 'dflt +$ echo4 "Checking the C run-time library." +$! +$! Former SUBCONFIGURE.COM +$! +$! - build a config.sh for VMS Perl. +$! - use built config.sh to take config_h.SH -> config.h +$! - also take vms/descrip_mms.template -> descrip.mms (VMS Makefile) +$! vms/Makefile.in -> Makefile. (VMS GNU Makefile?) +$! vms/Makefile.SH -> Makefile. (VMS GNU Makefile?) +$! - build make_ext.com extension builder procedure. +$! +$! Note for folks from other platforms changing things in here: +$! +$! Fancy changes (based on compiler capabilities or VMS version or +$! whatever) are tricky, so go ahead and punt on those. +$! +$! Simple changes, though (say, always setting something to 1, or undef, +$! or something like that) are straightforward. Adding a new constant +$! item for the ultimately created config.sh requires at least one +$! (possibly more) line(s) to this file. +$! +$! Add a line in the format: +$! +$! $ WC "foo='undef'" +$! +$! somewhere between the line tagged '##BEGIN WRITE NEW CONSTANTS HERE##' +$! and the one tagged '##END WRITE NEW CONSTANTS HERE##' (note the order +$! is sorted ASCII and corresponds to the output of config.sh in the +$! Bourne shell version of Configure). +$! Be very careful with quoting, as it can be tricky. +$! For example if instead of a constant string like 'undef' or 'define' +$! you wanted to add something to VMS's config.sh that looks like: +$! +$! blank_string='' +$! +$! then add a line that looks like this before the +$! '##END WRITE NEW CONSTANTS HERE##' tagged line: +$! +$! $ WC "blank_string='" + "'" +$! +$! (+ is the string concatenator and "''var'" has the effect +$! of "${var}" in perl or sh, but "'const'" is not interpolated). +$! +$! Note that unitialized variables, such as a line like: +$! +$! $ WC "new_var='" + new_var + "'" +$! +$! should be avoided unless new_var has a value assigned prior +$! to that line (think of perl's -w warnings). +$! +$! %DCL-W-UNDSYM, undefined symbol - check validity and spelling +$! \NEW_VAR\ +$! +$! +$ vms_ver = F$EXTRACT(1,3, osvers) +$ IF F$LENGTH(Mcc) .EQ. 0 THEN Mcc := "cc" +$ MCC = f$edit(mcc, "UPCASE") +$ C_Compiler_Replace := "CC=CC=''Mcc'''ccflags'" +$ IF ccname .EQS. "DEC" +$ THEN +$ Checkcc := "''Mcc'/prefix=all" +$ ELSE +$ IF ccname .EQS. "CXX" +$ THEN +$ Checkcc := cxx +$ ELSE +$ Checkcc := "''Mcc'" +$ ENDIF +$ ENDIF +$ ccflags = ccflags + extra_flags +$ IF be_case_sensitive +$ THEN +$ d_vms_be_case_sensitive = "define" +$ ELSE +$ d_vms_be_case_sensitive = "undef" +$ ENDIF +$! Some constant defaults. +$ hwname = f$getsyi("HW_NAME") +$ myname = myhostname +$ IF myname .EQS. "" THEN myname = F$TRNLNM("SYS$NODE") +$! +$ ccdlflags="" +$ cccdlflags="" +$! +$ IF use64bitint .OR. use64bitint .EQS. "define" +$ THEN +$ use64bitint = "define" +$ uselargefiles = "define" +$ uselongdouble = "define" +$ alignbytes="16" +$ usemorebits = "define" +$ ELSE +$ use64bitint = "undef" +$ uselargefiles = "undef" +$ uselongdouble = "undef" +$ usemorebits = "undef" +$ ENDIF +$ IF use64bitall .OR. use64bitall .EQS. "define" +$ THEN +$ use64bitall = "define" +$ ELSE +$ use64bitall = "undef" +$ ENDIF +$! +$ usemymalloc=mymalloc +$! +$ perl_cc=Mcc +$! +$ IF (sharedperl .AND. F$GETSYI("HW_MODEL") .GE. 1024) +$ THEN +$ obj_ext=".abj" +$ so="axe" +$ dlext="axe" +$ exe_ext=".axe" +$ lib_ext=".alb" +$ ELSE +$ obj_ext=".obj" +$ so="exe" +$ dlext="exe" +$ exe_ext=".exe" +$ lib_ext=".olb" +$ ENDIF +$ dlobj="dl_vms''obj_ext'" +$! +$ cppstdin="''perl_cc'/noobj/preprocess=sys$output sys$input" +$ cppminus=" " +$ cpprun="''perl_cc'/noobj/preprocess=sys$output sys$input" +$ cpplast=" " +$! +$ timetype="time_t" +$ signal_t="void" +$ stdchar="char" +$! +$ IF mymalloc +$ THEN d_mymalloc="define" +$ ELSE d_mymalloc="undef" +$ ENDIF +$! +$ usedl="define" +$ 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 +$ libs="SYS$SHARE:CMA$LIB_SHR.EXE/SHARE SYS$SHARE:CMA$RTL.EXE/SHARE SYS$SHARE:CMA$OPEN_LIB_SHR.exe/SHARE SYS$SHARE:CMA$OPEN_RTL.exe/SHARE" +$ ELSE +$ libs=" " +$ ENDIF +$ IF ccname .EQS. "DEC" .OR. ccname .EQS. "CXX" +$ THEN +$ libc="(DECCRTL)" +$ ELSE +$ libc=" " +$ ENDIF +$! +$! perllibs should be libs with all non-core libs (such as gdbm) removed. +$! +$ perllibs=libs +$! +$! Are we 64 bit? +$! +$ IF use64bitint .OR. use64bitint .EQS. "define" +$ THEN +$ d_PRId64 = "define" +$ d_PRIEUldbl = "define" +$ d_PRIFUldbl = "define" +$ d_PRIGUldbl = "define" +$ d_PRIXU64 = "define" +$ d_PRIeldbl = "define" +$ d_PRIfldbl = "define" +$ d_PRIgldbl = "define" +$ d_PRIu64 = "define" +$ d_PRIo64 = "define" +$ d_PRIx64 = "define" +$ sPRId64 = """Ld""" +$ sPRIEUldbl = """LE""" +$ sPRIFUldbl = """LF""" +$ sPRIGUldbl = """LG""" +$ sPRIXU64 = """LX""" +$ sPRIeldbl = """Le""" +$ sPRIfldbl = """Lf""" +$ sPRIgldbl = """Lg""" +$ sPRIi64 = """Li""" +$ sPRIo64 = """Lo""" +$ sPRIu64 = """Lu""" +$ sPRIx64 = """Lx""" +$ d_quad = "define" +$ quadtype = "long long" +$ uquadtype = "unsigned long long" +$ quadkind = "QUAD_IS_LONG_LONG" +$ d_frexpl = "define" +$ d_isnan = "define" +$ d_isnanl = "define" +$ d_modfl = "define" +$ ELSE +$ d_PRId64 = "undef" +$ d_PRIEUldbl = "define" +$ d_PRIFUldbl = "define" +$ d_PRIGUldbl = "define" +$ d_PRIXU64 = "undef" +$ d_PRIeldbl = "define" +$ d_PRIfldbl = "undef" +$ d_PRIgldbl = "undef" +$ d_PRIu64 = "undef" +$ d_PRIo64 = "undef" +$ d_PRIx64 = "undef" +$ sPRId64 = "" +$ sPRIEUldbl = """E""" +$ sPRIFUldbl = """F""" +$ sPRIGUldbl = """G""" +$ sPRIXU64 = """lX""" +$ sPRIeldbl = """e""" +$ sPRIfldbl = """f""" +$ sPRIgldbl = """g""" +$ sPRIi64 = "" +$ sPRIo64 = "" +$ sPRIu64 = "" +$ sPRIx64 = "" +$ d_quad = "undef" +$ quadtype = "long" +$ uquadtype = "unsigned long" +$ quadkind = "QUAD_IS_LONG" +$ d_frexpl = "undef" +$ d_isnan = "undef" +$ d_isnanl = "undef" +$ d_modfl = "undef" +$ ENDIF +$ d_SCNfldbl = d_PRIfldbl +$ sSCNfldbl = sPRIfldbl ! expect consistency +$! +$! Now some that we build up +$! +$ IF Use_Threads +$ THEN +$ IF use_5005_threads +$ THEN +$ arch = "''arch'-thread" +$ archname = "''archname'-thread" +$ d_old_pthread_create_joinable = "undef" +$ old_pthread_create_joinable = " " +$ use5005threads = "define" +$ useithreads = "undef" +$ ELSE +$ arch = "''arch'-ithread" +$ archname = "''archname'-ithread" +$ d_old_pthread_create_joinable = "undef" +$ old_pthread_create_joinable = " " +$ use5005threads = "undef" +$ useithreads = "define" +$ ENDIF +$ ELSE +$ d_old_pthread_create_joinable = "undef" +$ old_pthread_create_joinable = " " +$ use5005threads = "undef" +$ useithreads = "undef" +$ ENDIF +$! +$! Some that we need to invoke the compiler for +$! +$! +$! handy construction aliases/symbols +$! +$ OS := "open/write CONFIG []try.c" +$ WS := "write CONFIG" +$ CS := "close CONFIG" +$ DS := "delete/nolog/noconfirm []try.*;*" +$ Needs_Opt := N +$ good_compile = %X10B90001 +$ IF ccname .EQS. "GCC" +$ THEN +$ open/write OPTCHAN []try.opt +$ write OPTCHAN "Gnu_CC:[000000]gcclib.olb/library" +$ write OPTCHAN "Sys$Share:VAXCRTL/Share" +$ Close OPTCHAN +$ Needs_Opt := Y +$ good_compile = %X10000001 +$ ENDIF +$ IF ccname .EQS. "CXX" +$ THEN +$ good_compile = %X15F60001 +$ ENDIF +$ good_link = %X10000001 +$ tmp = "" ! null string default +$! +$ GOTO beyond_compile_ok +$! +$! Check for type sizes +$! +$type_size_check: +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "int main()" +$ WS "{" +$ WS "printf(""%d\n"", sizeof(''tmp'));" +$ WS "exit(0);" +$ WS "}" +$ CS +$ GOSUB compile +$ RETURN +$! +$!: locate header file +$findhdr: +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "#include <''tmp'>" +$ WS "int main()" +$ WS "{" +$ WS "printf(""define\n"");" +$ WS "exit(0);" +$ WS "}" +$ CS +$ GOSUB link_ok +$ RETURN +$! +$!: define an alternate in-header-list? function +$inhdr: +$! +$ GOSUB findhdr +$ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link +$ THEN +$ echo4 "<''tmp'> found." +$ tmp = "define" +$ ELSE +$ echo4 "<''tmp'> NOT found." +$ tmp = "undef" +$ ENDIF +$ RETURN +$! +$!: define an is-in-libc? function +$inlibc: +$ GOSUB link_ok +$ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link +$ THEN +$ echo4 "''tmp'() found." +$ tmp = "define" +$ ELSE +$ echo4 "''tmp'() NOT found." +$ tmp = "undef" +$ ENDIF +$ RETURN +$! +$!: define a shorthand compile call +$compile: +$ GOSUB link_ok +$just_mcr_it: +$ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link +$ THEN +$ OPEN/WRITE CONFIG []try.out +$ DEFINE/USER_MODE SYS$ERROR CONFIG +$ DEFINE/USER_MODE SYS$OUTPUT CONFIG +$ MCR []try.exe +$ CLOSE CONFIG +$ OPEN/READ CONFIG []try.out +$ READ CONFIG tmp +$ CLOSE CONFIG +$ DELETE/NOLOG/NOCONFIRM []try.out; +$ DELETE/NOLOG/NOCONFIRM []try.exe; +$ ELSE +$ tmp = "" ! null string default +$ ENDIF +$ RETURN +$! +$link_ok: +$ GOSUB compile_ok +$ DEFINE/USER_MODE SYS$ERROR _NLA0: +$ DEFINE/USER_MODE SYS$OUTPUT _NLA0: +$ SET NOON +$ IF Needs_Opt +$ THEN +$ 'ld' try.obj,try.opt/opt +$ link_status = $status +$ ELSE +$ 'ld' try.obj +$ link_status = $status +$ ENDIF +$ SET ON +$ IF F$SEARCH("try.obj") .NES. "" THEN DELETE/NOLOG/NOCONFIRM try.obj; +$ RETURN +$! +$!: define a shorthand compile call for compilations that should be ok. +$compile_ok: +$ DEFINE/USER_MODE SYS$ERROR _NLA0: +$ DEFINE/USER_MODE SYS$OUTPUT _NLA0: +$ SET NOON +$ 'Checkcc' try.c +$ compile_status = $status +$ SET ON +$ DELETE/NOLOG/NOCONFIRM try.c; +$ RETURN +$! +$beyond_compile_ok: +$! +$! Check for __STDC__ +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "int main()" +$ WS "{" +$ WS "#ifdef __STDC__" +$ WS "printf(""42\n"");" +$ WS "#else" +$ WS "printf(""1\n"");" +$ WS "#endif" +$ WS "exit(0);" +$ WS "}" +$ CS +$ GOSUB compile +$ cpp_stuff=tmp +$ IF F$INTEGER(tmp) .eq. 42 +$ THEN +$ echo4 "Your C compiler and pre-processor defines the symbol:" +$ echo4 "__STDC__" +$ ENDIF +$! +$! Check for double size +$! +$ echo4 "Checking to see how big your double precision numbers are..." +$ tmp="double" +$ GOSUB type_size_check +$ doublesize = tmp +$ echo "Your double is ''doublesize' bytes long." +$! +$! Check for long double size +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "int main()" +$ WS "{" +$ WS "printf(""%d\n"", sizeof(long double));" +$ WS "exit(0);" +$ WS "}" +$ CS +$ echo4 "Checking to see if you have long double..." +$ GOSUB link_ok +$ IF link_status .NE. good_link +$ THEN +$ longdblsize="0" +$ d_longdbl="undef" +$ echo "You do not have long double." +$ ELSE +$ echo "You have long double." +$ echo4 "Checking to see how big your long doubles are..." +$ GOSUB just_mcr_it +$ longdblsize = tmp +$ d_longdbl = "define" +$ echo "Your long doubles are ''longdblsize' bytes long." +$ ENDIF +$! +$!: check for long long +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "int main()" +$ WS "{" +$ WS "printf(""%d\n"", sizeof(long long));" +$ WS "exit(0);" +$ WS "}" +$ CS +$ echo4 "Checking to see if you have long long..." +$ GOSUB link_ok +$ IF link_status .NE. good_link +$ THEN +$ longlongsize="0" +$ d_longlong="undef" +$ echo "You do not have long long." +$ ELSE +$ echo "You have long long." +$ echo4 "Checking to see how big your long longs are..." +$ GOSUB just_mcr_it +$ longlongsize = tmp +$ d_longlong = "define" +$ echo "Your long longs are ''longlongsize' bytes long." +$ ENDIF +$! +$! Check the prototype for getgid +$! +$ echo "Looking for the type for group ids returned by getgid()." +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "#include <types.h>" +$ WS "int main()" +$ WS "{" +$ WS "gid_t foo;" +$ WS "exit(0);" +$ WS "}" +$ CS +$ GOSUB compile_ok +$ IF compile_status .NE. good_compile +$ THEN +$! Okay, gid_t failed. Must be unsigned int +$ gidtype = "unsigned int" +$ echo4 "assuming ""''gidtype'""." +$ ELSE +$ gidtype = "gid_t" +$ echo4 "gid_t found." +$ ENDIF +$! +$! Check to see if we've got dev_t +$! +$ echo "Looking for the type for dev." +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "#include <types.h>" +$ WS "int main()" +$ WS "{" +$ WS "dev_t foo;" +$ WS "exit(0);" +$ WS "}" +$ CS +$ GOSUB compile_ok +$ IF compile_status .NE. good_compile +$ THEN +$! Okay, dev_t failed. Must be unsigned int +$ devtype = "unsigned int" +$ echo4 "assuming ""''devtype'""." +$ ELSE +$ devtype = "dev_t" +$ echo4 "dev_t found." +$ ENDIF +$! +$! Check to see if we've got unistd.h (which we ought to, but you never know) +$! +$ i_netdb = "undef" +$ tmp = "unistd.h" +$ GOSUB inhdr +$ i_unistd = tmp +$! +$!: see if this is a libutil.h system +$! +$ tmp = "libutil.h" +$ GOSUB inhdr +$ i_libutil = tmp +$! +$! Check to see if we've got shadow.h (probably not, but...) +$! +$ tmp = "shadow.h" +$ GOSUB inhdr +$ i_shadow = tmp +$! +$! Check to see if we've got socks.h (probably not, but...) +$! +$ tmp = "socks.h" +$ GOSUB inhdr +$ i_socks = tmp +$! +$! Check the prototype for select +$! +$ IF Has_Dec_C_Sockets .OR. Has_Socketshr +$ THEN +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "#include <types.h>" +$ IF i_unistd .EQS. "define" THEN WS "#include <unistd.h>" +$ IF Has_Socketshr +$ THEN +$ WS "#include <socketshr.h>" +$ ELSE +$ WS "#include <time.h>" +$ WS "#include <socket.h>" +$ ENDIF +$ WS "int main()" +$ WS "{" +$ WS "fd_set *foo;" +$ WS "int bar;" +$ WS "foo = NULL;" +$ WS "bar = select(2, foo, foo, foo, NULL);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ GOSUB compile_ok +$ IF compile_status .NE. good_compile +$ THEN +$! Okay, select failed. Must be an int * +$ selecttype = "int *" +$ echo4 "select() NOT found." +$ ELSE +$ selecttype="fd_set *" +$ echo4 "select() found." +$ ENDIF +$ ELSE +$ ! No sockets, so stick in an int * : no select, so pick a harmless default +$ selecttype = "int *" +$ ENDIF +$! +$! Check to see if fd_set exists +$! +$ echo "Checking to see how well your C compiler handles fd_set and friends ..." +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "#include <types.h>" +$ IF Has_Socketshr +$ THEN +$ WS "#include <socketshr.h>" +$ ENDIF +$ IF Has_Dec_C_Sockets +$ THEN +$ WS "#include <time.h>" +$ WS "#include <socket.h>" +$ ENDIF +$ WS "int main()" +$ WS "{" +$ WS "fd_set *foo;" +$ WS "int bar;" +$ WS "exit(0);" +$ WS "}" +$ CS +$ GOSUB compile_ok +$ IF compile_status .ne. good_compile +$ THEN +$! Okay, fd_set failed. Must not exist +$ d_fd_set = "undef" +$ echo4 "Hmm, your compiler has some difficulty with fd_set." +$ ELSE +$ d_fd_set="define" +$ echo4 "Well, your system knows about the normal fd_set typedef..." +$ ENDIF +$! +$! Check for inttypes.h +$! +$ tmp = "inttypes.h" +$ GOSUB inhdr +$ i_inttypes = tmp +$! +$! Check to see if off64_t exists +$! +$ echo4 "Checking to see if you have off64_t..." +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "#include <types.h>" +$ WS "#''i_inttypes' IIH" +$ WS "#ifdef IIH" +$ WS "#include <inttypes.h>" +$ WS "#endif" +$ WS "int main()" +$ WS "{" +$ WS "off64_t bar;" +$ WS "exit(0);" +$ WS "}" +$ CS +$ GOSUB compile_ok +$ IF compile_status .EQ. good_compile +$ THEN +$ d_off64_t="define" +$ echo "You have off64_t." +$ ELSE +$ d_off64_t = "undef" +$ echo "You do not have off64_t." +$ ENDIF +$! +$! Check to see if fpos64_t exists +$! +$ echo4 "Checking to see if you have fpos64_t..." +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "#include <types.h>" +$ WS "#''i_inttypes' IIH" +$ WS "#ifdef IIH" +$ WS "#include <inttypes.h>" +$ WS "#endif" +$ WS "int main()" +$ WS "{" +$ WS "fpos64_t bar;" +$ WS "exit(0);" +$ WS "}" +$ CS +$ GOSUB compile_ok +$ IF compile_status .EQ. good_compile +$ THEN +$ d_fpos64_t="define" +$ echo "You have fpos64_t." +$ ELSE +$ d_fpos64_t = "undef" +$ echo "You do not have fpos64_t." +$ ENDIF +$! +$! Check to see if int64_t exists +$! +$ echo4 "Checking to see if you have int64_t..." +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "#include <types.h>" +$ WS "#''i_inttypes' IIH" +$ WS "#ifdef IIH" +$ WS "#include <inttypes.h>" +$ WS "#endif" +$ WS "int main()" +$ WS "{" +$ WS "int64_t bar;" +$ WS "exit(0);" +$ WS "}" +$ CS +$ GOSUB compile_ok +$ IF compile_status .EQ. good_compile +$ THEN +$ d_int64_t="define" +$ echo "You have int64_t." +$ ELSE +$ d_int64_t = "undef" +$ echo "You do not have int64_t." +$ ENDIF +$! +$!: see if this is a netdb.h system +$ IF Has_Dec_C_Sockets +$ THEN +$ tmp = "netdb.h" +$ GOSUB inhdr +$ i_netdb = tmp +$ ENDIF +$! +$! Check for h_errno +$! +$ echo4 "Checking to see if you have h_errno..." +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ IF i_unistd .EQS. "define" THEN WS "#include <unistd.h>" +$ IF i_netdb .EQS. "define" THEN WS "#include <netdb.h>" +$ WS "int main()" +$ WS "{" +$ WS "h_errno = 3;" +$ WS "exit(0);" +$ WS "}" +$ CS +$ GOSUB link_ok +$ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link +$ THEN +$ d_herrno="define" +$ echo "You have h_errno." +$ ELSE +$ d_herrno="undef" +$ echo "You do not have h_errno." +$ ENDIF +$! +$! Check to see if gethostname exists +$! +$ IF Has_Dec_C_Sockets .OR. Has_Socketshr +$ THEN +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "#include <types.h>" +$ IF Has_Socketshr +$ THEN +$ WS "#include <socketshr.h>" +$ ELSE +$ WS "#include <time.h>" +$ WS "#include <socket.h>" +$ ENDIF +$ WS "int main()" +$ WS "{" +$ WS "char name[100];" +$ WS "int bar, baz;" +$ WS "bar = 100;" +$ WS "baz = gethostname(name, bar);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ GOSUB link_ok +$ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link +$ THEN +$ d_gethname="define" +$ echo4 "gethostname() found." +$ ELSE +$ d_gethname="undef" +$ ENDIF +$ ELSE +$ ! No sockets, so no gethname +$ d_gethname = "undef" +$ ENDIF +$! +$! Check for sys/file.h +$! +$ tmp = "sys/file.h" +$ GOSUB inhdr +$ i_sysfile = tmp +$! +$! Check for sys/utsname.h +$! +$ tmp = "sys/utsname.h" +$ GOSUB inhdr +$ i_sysutsname = tmp +$! +$! Check for syslog.h +$! +$ tmp = "syslog.h" +$ GOSUB inhdr +$ i_syslog = tmp +$! +$! Check for poll.h +$! +$ tmp = "poll.h" +$ GOSUB inhdr +$ i_poll = tmp +$! +$! Check for sys/uio.h +$! +$ tmp = "sys/uio.h" +$ GOSUB inhdr +$ i_sysuio = tmp +$! +$! Check for sys/mode.h +$! +$ tmp = "sys/mode.h" +$ GOSUB inhdr +$ i_sysmode = tmp +$! +$! Check for sys/access.h +$! +$ tmp = "sys/access.h" +$ GOSUB inhdr +$ i_sysaccess = tmp +$! +$! Check for sys/security.h +$! +$ tmp = "sys/security.h" +$ GOSUB inhdr +$ i_syssecrt = tmp +$! +$! Check for fcntl.h +$! +$ tmp = "fcntl.h" +$ GOSUB inhdr +$ i_fcntl = tmp +$! +$! Check for fcntl +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "#include <fcntl.h>" +$ WS "int main()" +$ WS "{" +$ WS "fcntl(1,2,3);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ 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 <stdio.h>" +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <fcntl.h>" +$ WS "#include <unistd.h>" +$ 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 +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <string.h>" +$ WS "int main()" +$ WS "{" +$ WS "char * place;" +$ WS "place = memchr(""foo"", 47, 3)" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "memchr" +$ GOSUB inlibc +$ d_memchr = tmp +$! +$! Check for strtoull +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <string.h>" +$ WS "int main()" +$ WS "{" +$ WS "unsigned __int64 result;" +$ WS "result = strtoull(""123123"", NULL, 10);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "strtoull" +$ GOSUB inlibc +$ d_strtoull = tmp +$! +$! Check for strtouq +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <string.h>" +$ WS "int main()" +$ WS "{" +$ WS "unsigned __int64 result;" +$ WS "result = strtouq(""123123"", NULL, 10);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "strtouq" +$ GOSUB inlibc +$ d_strtouq = tmp +$! +$! Check for strtoll +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <string.h>" +$ WS "int main()" +$ WS "{" +$ WS "__int64 result;" +$ WS "result = strtoll(""123123"", NULL, 10);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "strtoll" +$ GOSUB inlibc +$ d_strtoll = tmp +$! +$! Check for strtold +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <string.h>" +$ WS "int main()" +$ WS "{" +$ WS "long double result;" +$ WS "result = strtold(""123123"", NULL, 10);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "strtold" +$ GOSUB inlibc +$ d_strtold = tmp +$! +$! Check for atoll +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <string.h>" +$ WS "int main()" +$ WS "{" +$ WS " __int64 result;" +$ WS "result = atoll(""123123"");" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "atoll" +$ GOSUB inlibc +$ d_atoll = tmp +$! +$! Check for atolf +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <string.h>" +$ WS "int main()" +$ WS "{" +$ WS "long double" +$ WS "result = atolf(""123123"");" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "atolf" +$ GOSUB inlibc +$ d_atolf = tmp +$! +$! Check for access +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "int main()" +$ WS "{" +$ WS "access(""foo"", F_OK);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "acess" +$ GOSUB inlibc +$ d_access = tmp +$! +$! Check for bzero +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "#include <strings.h>" +$ WS "int main()" +$ WS "{" +$ WS "char foo[10];" +$ WS "bzero(foo, 10);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "bzero" +$ GOSUB inlibc +$ d_bzero = tmp +$! +$! Check for bcopy +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "#include <strings.h>" +$ WS "int main()" +$ WS "{" +$ WS "char foo[10], bar[10];" +$ WS "bcopy(""foo"", bar, 3);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "bcopy" +$ GOSUB inlibc +$ d_bcopy = tmp +$! +$! Check for mkstemp +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "int main()" +$ WS "{" +$ WS "mkstemp(""foo"");" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "mkstemp" +$ GOSUB inlibc +$ d_mkstemp = tmp +$! +$! Check for mkstemps +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "int main()" +$ WS "{" +$ WS "mkstemps(""foo"", 1);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "mkstemps" +$ GOSUB inlibc +$ d_mkstemps = tmp +$! +$! Check for iconv +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "#include <iconv.h>" +$ WS "int main()" +$ WS "{" +$ WS " iconv_t cd = (iconv_t)0;" +$ WS " char *inbuf, *outbuf;" +$ WS " size_t inleft, outleft;" +$ WS " iconv(cd, &inbuf, &inleft, &outbuf, &outleft);" +$ WS " exit(0);" +$ WS "}" +$ CS +$ GOSUB link_ok +$ IF compile_status .ne. good_compile +$ THEN +$ d_iconv="undef" +$ i_iconv="undef" +$ ELSE +$ IF link_status .ne. good_link +$ THEN +$ d_iconv="undef" +$ i_iconv="undef" +$ ELSE +$ d_iconv="define" +$ i_iconv="define" +$ ENDIF +$ ENDIF +$ IF i_iconv .eqs. "define" +$ THEN echo4 "<iconv.h> found." +$ ELSE echo4 "<iconv.h> NOT found." +$ ENDIF +$! +$! Check for mkdtemp +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "int main()" +$ WS "{" +$ WS "mkdtemp(""foo"");" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "mkdtemp" +$ GOSUB inlibc +$ d_mkdtemp = tmp +$! +$! Check for setvbuf +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "int main()" +$ WS "{" +$ WS "FILE *foo;" +$ WS "char Buffer[99];" +$ WS "foo = fopen(""foo"", ""r"");" +$ WS "setvbuf(foo, Buffer, 0, 0);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "setvbuf" +$ GOSUB inlibc +$ d_setvbuf = tmp +$! +$! Check for setenv +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "int main()" +$ WS "{" +$ WS "setenv(""FOO"", ""BAR"", 0);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "setenv" +$ GOSUB inlibc +$ d_setenv = tmp +$! +$! Check for setproctitle +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "int main()" +$ WS "{" +$ WS "setproctitle(""%s"", ""FOO"");" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "setproctitle" +$ GOSUB inlibc +$ d_setproctitle = tmp +$! +$! Check for <netinet/in.h> +$! +$ IF Has_Dec_C_Sockets .or. Has_Socketshr +$ THEN +$ tmp = "netinet/in.h" +$ GOSUB inhdr +$ i_niin = tmp +$ ELSE +$ i_niin="undef" +$ ENDIF +$! +$! Check for <netinet/tcp.h> +$! +$ IF Has_Dec_C_Sockets .or. Has_Socketshr +$ THEN +$ tmp = "netinet/tcp.h" +$ GOSUB inhdr +$ i_netinettcp = tmp +$ ELSE +$ i_netinettcp="undef" +$ ENDIF +$! +$! Check for endhostent +$! +$ IF Has_Dec_C_Sockets .or. Has_Socketshr +$ THEN +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ IF Has_Socketshr +$ THEN WS "#include <socketshr.h>" +$ ELSE IF i_netdb .EQS. "define" THEN WS "#include <netdb.h>" +$ ENDIF +$ WS "int main()" +$ WS "{" +$ WS "endhostent();" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "endhostent" +$ GOSUB inlibc +$ d_endhent = tmp +$ ELSE +$ d_endhent="undef" +$ ENDIF +$! +$! Check for endnetent +$! +$ IF Has_Dec_C_Sockets .or. Has_Socketshr +$ THEN +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ IF Has_Socketshr +$ THEN WS "#include <socketshr.h>" +$ ELSE IF i_netdb .EQS. "define" THEN WS "#include <netdb.h>" +$ ENDIF +$ WS "int main()" +$ WS "{" +$ WS "endnetent();" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "endnetent" +$ GOSUB inlibc +$ d_endnent = tmp +$ ELSE +$ d_endnent="undef" +$ ENDIF +$! +$! Check for endprotoent +$! +$ IF Has_Dec_C_Sockets .OR. Has_Socketshr +$ THEN +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ IF Has_Socketshr +$ THEN WS "#include <socketshr.h>" +$ ELSE IF i_netdb .EQS. "define" THEN WS "#include <netdb.h>" +$ ENDIF +$ WS "int main()" +$ WS "{" +$ WS "endprotoent();" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "endprotoent" +$ GOSUB inlibc +$ d_endpent = tmp +$ ELSE +$ d_endpent="undef" +$ ENDIF +$! +$! Check for endservent +$! +$ IF Has_Dec_C_Sockets .OR. Has_Socketshr +$ THEN +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ IF Has_Socketshr +$ THEN WS "#include <socketshr.h>" +$ ELSE IF i_netdb .EQS. "define" THEN WS "#include <netdb.h>" +$ ENDIF +$ WS "int main()" +$ WS "{" +$ WS "endservent();" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "endservent" +$ GOSUB inlibc +$ d_endsent = tmp +$ ELSE +$ d_endsent="undef" +$ ENDIF +$! +$! Check for sethostent +$! +$ IF Has_Dec_C_Sockets .OR. Has_Socketshr +$ THEN +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ IF Has_Socketshr +$ THEN WS "#include <socketshr.h>" +$ ELSE IF i_netdb .EQS. "define" THEN WS "#include <netdb.h>" +$ ENDIF +$ WS "int main()" +$ WS "{" +$ WS "sethostent(1);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "sethostent" +$ GOSUB inlibc +$ d_sethent = tmp +$ ELSE +$ d_sethent="undef" +$ ENDIF +$! +$! Check for setnetent +$! +$ IF Has_Dec_C_Sockets .OR. Has_Socketshr +$ THEN +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ IF Has_Socketshr +$ THEN WS "#include <socketshr.h>" +$ ELSE IF i_netdb .EQS. "define" THEN WS "#include <netdb.h>" +$ ENDIF +$ WS "int main()" +$ WS "{" +$ WS "setnetent(1);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "setnetent" +$ GOSUB inlibc +$ d_setnent = tmp +$ ELSE +$ d_setnent="undef" +$ ENDIF +$! +$! Check for setprotoent +$! +$ IF Has_Dec_C_Sockets .OR. Has_Socketshr +$ THEN +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ IF Has_Socketshr +$ THEN WS "#include <socketshr.h>" +$ ELSE IF i_netdb .EQS. "define" THEN WS "#include <netdb.h>" +$ ENDIF +$ WS "int main()" +$ WS "{" +$ WS "setprotoent(1);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "setprotoent" +$ GOSUB inlibc +$ d_setpent = tmp +$ ELSE +$ d_setpent="undef" +$ ENDIF +$! +$! Check for setservent +$! +$ IF Has_Dec_C_Sockets .OR. Has_Socketshr +$ THEN +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ IF Has_Socketshr +$ THEN WS "#include <socketshr.h>" +$ ELSE IF i_netdb .EQS. "define" THEN WS "#include <netdb.h>" +$ ENDIF +$ WS "int main()" +$ WS "{" +$ WS "setservent(1);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "setservent" +$ GOSUB inlibc +$ d_setsent = tmp +$ ELSE +$ d_setsent="undef" +$ ENDIF +$! +$! Check for gethostent +$! +$ IF Has_Dec_C_Sockets .OR. Has_Socketshr +$ THEN +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ IF Has_Socketshr +$ THEN WS "#include <socketshr.h>" +$ ELSE IF i_netdb .EQS. "define" THEN WS "#include <netdb.h>" +$ ENDIF +$ WS "int main()" +$ WS "{" +$ WS "gethostent();" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "gethostent" +$ GOSUB inlibc +$ d_gethent = tmp +$ ELSE +$ d_gethent="undef" +$ ENDIF +$! +$! Check for getnetent +$! +$ IF Has_Dec_C_Sockets .OR. Has_Socketshr +$ THEN +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ IF Has_Socketshr +$ THEN WS "#include <socketshr.h>" +$ ELSE IF i_netdb .EQS. "define" THEN WS "#include <netdb.h>" +$ ENDIF +$ WS "int main()" +$ WS "{" +$ WS "getnetent();" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "getnetent" +$ GOSUB inlibc +$ d_getnent = tmp +$ ELSE +$ d_getnent="undef" +$ ENDIF +$! +$! Check for getprotoent +$! +$ IF Has_Dec_C_Sockets .OR. Has_Socketshr +$ THEN +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ IF Has_Socketshr +$ THEN WS "#include <socketshr.h>" +$ ELSE IF i_netdb .EQS. "define" THEN WS "#include <netdb.h>" +$ ENDIF +$ WS "int main()" +$ WS "{" +$ WS "getprotoent();" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "getprotoent" +$ GOSUB inlibc +$ d_getpent = tmp +$ ELSE +$ d_getpent="undef" +$ ENDIF +$! +$! Check for getservent +$! +$ IF Has_Dec_C_Sockets .OR. Has_Socketshr +$ THEN +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ IF Has_Socketshr +$ THEN WS "#include <socketshr.h>" +$ ELSE IF i_netdb .EQS. "define" THEN WS "#include <netdb.h>" +$ ENDIF +$ WS "int main()" +$ WS "{" +$ WS "getservent();" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "getservent" +$ GOSUB inlibc +$ d_getsent = tmp +$ ELSE +$ d_getsent="undef" +$ ENDIF +$! +$! Check for socklen_t +$! +$ IF Has_Dec_C_Sockets .OR. Has_Socketshr +$ THEN +$ echo4 "Checking to see if you have socklen_t..." +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ IF Has_Socketshr +$ THEN WS "#include <socketshr.h>" +$ ELSE IF i_netdb .EQS. "define" THEN WS "#include <netdb.h>" +$ ENDIF +$ WS "int main()" +$ WS "{" +$ WS "socklen_t x = 16;" +$ WS "exit(0);" +$ WS "}" +$ CS +$ GOSUB link_ok +$ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link +$ THEN +$ d_socklen_t="define" +$ echo "You have socklen_t." +$ ELSE +$ d_socklen_t="undef" +$ echo "You do not have socklen_t." +$ ENDIF +$ ELSE +$ d_socklen_t="undef" +$ ENDIF +$! +$! Check for pthread_yield +$! +$ IF use_threads +$ THEN +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <pthread.h>" +$ WS "#include <stdio.h>" +$ WS "int main()" +$ WS "{" +$ WS "pthread_yield();" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "pthread_yield" +$ GOSUB inlibc +$ d_pthread_yield = tmp +$ ELSE +$ d_pthread_yield="undef" +$ ENDIF +$! +$! Check for sched_yield +$! +$ IF use_threads +$ THEN +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <pthread.h>" +$ WS "#include <stdio.h>" +$ WS "int main()" +$ WS "{" +$ WS "sched_yield();" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "sched_yield" +$ GOSUB inlibc +$ d_sched_yield = tmp +$ IF d_sched_yield .EQS. "define" +$ THEN sched_yield = "sched_yield" +$ ELSE sched_yield = " " +$ ENDIF +$ ELSE +$ d_sched_yield="undef" +$ sched_yield = " " +$ ENDIF +$! +$! Check for generic pointer size +$! +$ echo4 "Checking to see how big your pointers are..." +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "int main()" +$ WS "{" +$ WS "int foo;" +$ WS "foo = sizeof(char *);" +$ WS "printf(""%d\n"", foo);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "char *" +$ GOSUB type_size_check +$ ptrsize = tmp +$ echo "Your pointers are ''ptrsize' bytes long." +$! +$! Check for size_t size +$! +$ tmp = "size_t" +$ zzz = tmp +$ echo4 "Checking the size of ''zzz'..." +$ GOSUB type_size_check +$ sizesize = tmp +$ echo "Your ''zzz' size is ''sizesize' bytes." +$! +$! Check rand48 and its ilk +$! +$ echo4 "Looking for a random number function..." +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "int main()" +$ WS "{" +$ WS "srand48(12L);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ GOSUB link_ok +$ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link +$ THEN +$ drand01 = "drand48()" +$ randseedtype = "long int" +$ seedfunc = "srand48" +$ echo4 "Good, found drand48()." +$ d_drand48proto = "define" +$ ELSE +$ d_drand48proto = "undef" +$ drand01="random()" +$ randseedtype = "unsigned" +$ seedfunc = "srandom" +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "int main()" +$ WS "{" +$ WS "srandom(12);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ GOSUB link_ok +$ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link +$ THEN +$ echo4 "OK, found random()." +$ ELSE +$ drand01="(((float)rand())/((float)RAND_MAX))" +$ randseedtype = "unsigned" +$ seedfunc = "srand" +$ echo4 "Yick, looks like I have to use rand()." +$ ENDIF +$ ENDIF +$! Done with compiler checks. Clean up. +$ IF F$SEARCH("try.c") .NES."" THEN DELETE/NOLOG/NOCONFIRM try.c;* +$ IF F$SEARCH("try.obj").NES."" THEN DELETE/NOLOG/NOCONFIRM try.obj;* +$ IF F$SEARCH("try.exe").NES."" THEN DELETE/NOLOG/NOCONFIRM try.exe;* +$ IF F$SEARCH("try.opt").NES."" THEN DELETE/NOLOG/NOCONFIRM try.opt;* +$ IF F$SEARCH("try.out").NES."" THEN DELETE/NOLOG/NOCONFIRM try.out;* +$ IF ccname .EQS. "CXX" +$ THEN +$ CALL Cxx_demangler_cleanup +$ ENDIF +$! +$! Some that are compiler or VMS version sensitive +$! +$! Gnu C stuff +$ IF ccname .EQS. "GCC" +$ THEN +$ d_attribut="define" +$ vms_cc_type="gcc" +$ ELSE +$ vms_cc_type="cc" +$ d_attribut="undef" +$ ENDIF +$! +$! Dec C >= 5.2 and VMS ver >= 7.0 +$ IF (ccname .EQS. "DEC") .AND. - + (F$INTEGER(Dec_C_Version).GE.50200000) .AND. (vms_ver .GES. "7.0") +$ THEN +$ d_bcmp="define" +$ d_gettimeod="define" +$ d_uname="define" +$ d_sigaction="define" +$ d_truncate="define" +$ d_wait4="define" +$ d_index="define" +$ pidtype="pid_t" +$ sig_name="ZERO HUP INT QUIT ILL TRAP IOT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM ABRT USR1 USR2 SPARE18 SPARE19 CHLD CONT STOP TSTP TTIN TTOU DEBUG SPARE27 SPARE28 SPARE29 SPARE30 SPARE31 SPARE32 RTMIN RTMAX"",0" +$ psnwc1="""ZERO"",""HUP"",""INT"",""QUIT"",""ILL"",""TRAP"",""IOT"",""EMT"",""FPE"",""KILL"",""BUS"",""SEGV"",""SYS""," +$ psnwc2="""PIPE"",""ALRM"",""TERM"",""ABRT"",""USR1"",""USR2"",""SPARE18"",""SPARE19"",""CHLD"",""CONT"",""STOP"",""TSTP""," +$ psnwc3="""TTIN"",""TTOU"",""DEBUG"",""SPARE27"",""SPARE28"",""SPARE29"",""SPARE30"",""SPARE31"",""SPARE32"",""RTMIN"",""RTMAX"",0" +$ sig_name_init = psnwc1 + psnwc2 + psnwc3 +$ sig_num="0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 6 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 64"",0" +$ sig_num_init="0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,6,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,64,0" +$! perl_sig_num_with_commas=sig_num_init +$ uidtype="uid_t" +$ d_pathconf="define" +$ d_fpathconf="define" +$ d_sysconf="define" +$ d_sigsetjmp="define" +$ ELSE +$ pidtype="unsigned int" +$ d_gettimeod="undef" +$ d_bcmp="undef" +$ d_uname="undef" +$ d_sigaction="undef" +$ d_truncate="undef" +$ d_wait4="undef" +$ d_index="undef" +$ sig_name="ZERO HUP INT QUIT ILL TRAP IOT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM ABRT USR1 USR2"",0" +$ psnwc1="""ZERO"",""HUP"",""INT"",""QUIT"",""ILL"",""TRAP"",""IOT"",""EMT"",""FPE"",""KILL"",""BUS"",""SEGV"",""SYS""," +$ psnwc2="""PIPE"",""ALRM"",""TERM"",""ABRT"",""USR1"",""USR2"",0" +$ sig_name_init = psnwc1 + psnwc2 +$ sig_num="0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 6 16 17"",0" +$ sig_num_init="0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,6,16,17,0" +$! perl_sig_num_with_commas=sig_num_init +$ uidtype="unsigned int" +$ d_pathconf="undef" +$ d_fpathconf="undef" +$ d_sysconf="undef" +$ d_sigsetjmp="undef" +$ ENDIF +$! +$ IF d_gethname .EQS. "undef" .AND. d_uname .EQS. "undef" +$ THEN +$ d_phostname="define" +$ ELSE +$ d_phostname="undef" +$ ENDIF +$! +$! Dec C alone +$ IF ccname .EQS. "DEC" +$ THEN +$ d_mbstowcs="define" +$ d_mbtowc="define" +$ d_stdiobase="define" +$ d_stdio_cnt_lval="define" +$ d_stdio_ptr_lval="define" +$ d_stdstdio="define" +$ d_wcstombs="define" +$ d_mblen="define" +$ d_mktime="define" +$ d_strcoll="define" +$ d_strxfrm="define" +$ d_wctomb="define" +$ i_locale="define" +$ d_locconv="define" +$ d_setlocale="define" +$ vms_cc_type="decc" +$ ELSE +$ d_mbstowcs="undef" +$ d_mbtowc="undef" +$ d_stdiobase="undef" +$ d_stdio_cnt_lval="undef" +$ d_stdio_ptr_lval="undef" +$ d_stdstdio="undef" +$ d_wcstombs="undef" +$ d_mblen="undef" +$ d_mktime="undef" +$ d_strcoll="undef" +$ d_strxfrm="undef" +$ d_wctomb="undef" +$ 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 +$ THEN +$ d_vms_do_sockets="define" +$ d_htonl="define" +$ d_socket="define" +$ d_select="define" +$ netdb_hlen_type="int" +$ netdb_host_type="char *" +$ netdb_name_type="char *" +$ netdb_net_type="long" +$ d_gethbyaddr="define" +$ d_gethbyname="define" +$ d_getnbyaddr="define" +$ d_getnbyname="define" +$ d_getpbynumber="define" +$ d_getpbyname="define" +$ d_getsbyport="define" +$ d_getsbyname="define" +$ d_gethostprotos="define" +$ d_getnetprotos="define" +$ d_getprotoprotos="define" +$ d_getservprotos="define" +$ IF ccname .EQS. "DEC" .OR. ccname .EQS. "CXX" +$ THEN +$ socksizetype="unsigned int" +$ ELSE +$ socksizetype="int *" +$ ENDIF +$ ELSE +$ d_vms_do_sockets="undef" +$ d_htonl="undef" +$ d_socket="undef" +$ d_select="undef" +$ netdb_hlen_type="int" +$ netdb_host_type="char *" +$ netdb_name_type="char *" +$ netdb_net_type="long" +$ d_gethbyaddr="undef" +$ d_gethbyname="undef" +$ d_getnbyaddr="undef" +$ d_getnbyname="undef" +$ d_getpbynumber="undef" +$ d_getpbyname="undef" +$ d_getsbyport="undef" +$ d_getsbyname="undef" +$ d_gethostprotos="undef" +$ d_getnetprotos="undef" +$ d_getprotoprotos="undef" +$ d_getservprotos="undef" +$ socksizetype="undef" +$ ENDIF +$! Threads +$ IF use_threads +$ THEN +$ usethreads="define" +$ d_pthreads_created_joinable="define" +$ if (vms_ver .GES. "7.0") +$ THEN +$ d_oldpthreads="undef" +$ ELSE +$ d_oldpthreads="define" +$ ENDIF +$ ELSE +$ d_oldpthreads="undef" +$ usethreads="undef" +$ d_pthreads_created_joinable="undef" +$ ENDIF +$! +$! new (5.005_62++) typedefs for primitives +$! +$ echo "Choosing the C types to be used for Perl's internal types..." +$ ivtype="long" +$ uvtype="unsigned long" +$ i8type="char" +$ u8type="unsigned char" +$ i16type="short" +$ u16type="unsigned short" +$ i32type="int" +$ u32type="unsigned int" +$ i64type="long long" +$ u64type="unsigned long long" +$ nvtype="double" +$! +$ IF use64bitint .OR. use64bitint .EQS. "define" +$ THEN +$ ivtype = "''i64type'" +$ uvtype = "''u64type'" +$ nvtype="long double" +$ ELSE +$ i64size="undef" +$ u64size="undef" +$ ENDIF +$! +$ tmp = "''ivtype'" +$ GOSUB type_size_check +$ ivsize = tmp +$ IF use64bitint .OR. use64bitint .EQS. "define" THEN i64size = tmp +$ IF ivtype .eqs. "long" +$ THEN longsize = tmp +$ ELSE +$ tmp = "long" +$ GOSUB type_size_check +$ longsize = tmp +$ ENDIF +$! +$ tmp = "''uvtype'" +$ GOSUB type_size_check +$ uvsize = tmp +$ IF use64bitint .OR. use64bitint .EQS. "define" THEN u64size = tmp +$! +$ tmp = "''i8type'" +$ GOSUB type_size_check +$ i8size = tmp +$! +$ tmp = "''u8type'" +$ GOSUB type_size_check +$ u8size = tmp +$! +$ tmp = "''i16type'" +$ GOSUB type_size_check +$ i16size = tmp +$ IF i16type .eqs. "short" +$ THEN shortsize = tmp +$ ELSE +$ tmp = "short" +$ gosub type_size_check +$ shortsize = tmp +$ ENDIF +$! +$ tmp = "''u16type'" +$ GOSUB type_size_check +$ u16size = tmp +$! +$ tmp = "''i32type'" +$ GOSUB type_size_check +$ i32size = tmp +$ IF i32type .eqs. "int" +$ THEN intsize = tmp +$ ELSE +$ tmp = "int" +$ gosub type_size_check +$ intsize = tmp +$ ENDIF +$! +$ tmp = "''u32type'" +$ gosub type_size_check +$ u32size = tmp +$! +$ tmp = "''nvtype'" +$ GOSUB type_size_check +$ nvsize = tmp +$! +$ echo "(IV will be ""''ivtype'"", ''ivsize' bytes)" +$ echo "(UV will be ""''uvtype'"", ''uvsize' bytes)" +$ echo "(NV will be ""''nvtype'"", ''nvsize' bytes)" +$! +$ echo4 "Checking whether your NVs can preserve your UVs..." +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "int main() {" +$ WS " ''uvtype' k = (''uvtype')~0, l;" +$ WS " ''nvtype' d;" +$ WS " l = k;" +$ WS " d = (''nvtype')l;" +$ WS " l = (''uvtype')d;" +$ WS " if (l == k)" +$ WS " printf(""preserve\n"");" +$ WS " exit(0);" +$ WS "}" +$ CS +$ GOSUB compile +$ IF tmp .EQS. "preserve" +$ THEN +$ d_nv_preserves_uv = "define" +$ echo "Yes, they can." +$ d_nv_preserves_uv_bits = F$STRING(F$INTEGER(uvsize) * 8) +$ ELSE +$ d_nv_preserves_uv = "undef" +$ echo "No, they can't." +$ echo4 "Checking how many bits of your UVs your NVs can preserve..." +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <stdio.h>" +$ WS "int main() {" +$ WS " ''uvtype' u = 0;" +$ WS " int n = 8 * ''uvsize';" +$ WS " int i;" +$ WS " for (i = 0; i < n; i++) {" +$ WS " u = u << 1 | (''uvtype')1;" +$ WS " if ((''uvtype')(''nvtype')u != u)" +$ WS " break;" +$ WS " }" +$ WS " printf(""%d\n"", i);" +$ WS " exit(0);" +$ WS "}" +$ GOSUB compile +$ d_nv_preserves_uv_bits = tmp +$ ENDIF +$ DELETE/SYMBOL tmp +$! +$ ivdformat="""ld""" +$ uvuformat="""lu""" +$ uvoformat="""lo""" +$ uvxformat="""lx""" +$ uvXUformat="""lX""" +$! uselongdouble? +$ nveformat="""e""" +$ nvfformat="""f""" +$ nvgformat="""g""" +$! +$! Finally the composite ones. All config +$! +$ myuname="''osname' ''myname' ''osvers' ''F$EDIT(hwname, "TRIM")'" +$! +$ IF ccname .EQS. "DEC" +$ THEN +$ ccflags="/Include=[]/Standard=Relaxed_ANSI/Prefix=All/Obj=''obj_ext'/NoList''ccflags'" +$ ENDIF +$ i_dirent = "undef" +$ IF ccname .EQS. "CXX" +$ THEN +$ i_dirent = "define" +$ ccflags="/Include=[]/Standard=ANSI/Prefix=All/Obj=''obj_ext'/NoList''ccflags'" +$ ENDIF +$ IF use_vmsdebug_perl +$ THEN +$ optimize="/Debug/NoOpt" +$ ldflags="/Debug/Trace/Map" +$ dbgprefix = "DBG" +$ ELSE +$ optimize= "" +$ ldflags="/NoTrace/NoMap" +$ dbgprefix = "" +$ ENDIF +$! +$! Okay, we've got everything configured. Now go write out a config.sh. +$ basename_config_sh = F$PARSE(config_sh,,,"NAME",)+F$PARSE(config_sh,,,"TYPE",) +$ echo4 "Creating ''basename_config_sh'..." +$ open/write CONFIG 'config_sh' +$ WC := write CONFIG +$! +$! ##BEGIN WRITE NEW CONSTANTS HERE## +$! +$ WC "#!/bin/sh" +$ WC "#" +$ WC "# This file was produced by Configure.COM on a ''osname' system." +$ WC "#" +$ WC "# Package name : ''package'" +$ WC "# Source directory : ''src'" +$ WC "# Configuration time: " + cf_time +$ WC "# Configuration by : " + cf_by +$ WC "# Target system : " + myuname +$ WC "" +$ WC "CONFIG='true'" +$ WC "Makefile_SH='" + Makefile_SH + "'" +$ WC "Mcc='" + Mcc + "'" +$ WC "PERL_REVISION='" + revision + "'" +$ WC "PERL_VERSION='" + patchlevel + "'" +$ WC "PERL_SUBVERSION='" + subversion + "'" +$ WC "PERL_API_VERSION='" + api_version + "'" +$ WC "PERL_API_SUBVERSION='" + api_subversion + "'" +$ WC "alignbytes='" + alignbytes + "'" +$ WC "aphostname='write sys$output f$edit(f$getsyi(\""SCSNODE\""),\""TRIM,LOWERCASE\"")'" +$ WC "ar='" + "'" +$ WC "archlib='" + archlib + "'" +$ WC "archlibexp='" + archlibexp + "'" +$ WC "archname='" + archname + "'" +$ WC "baserev='" + baserev + "'" +$ WC "bin='" + bin + "'" +$ WC "binexp='" + binexp + "'" +$ WC "builddir='" + builddir + "'" +$ WC "byteorder='1234'" +$ WC "castflags='0'" +$ WC "cc='" + perl_cc + "'" +$ WC "cccdlflags='" + cccdlflags + "'" +$ WC "ccdlflags='" + ccdlflags + "'" +$ WC "ccflags='" + ccflags + "'" +$ WC "ccname='" + ccname + "'" +$ WC "ccversion='" + ccversion + "'" +$ WC "cf_by='" + cf_by + "'" +$ WC "cf_email='" + cf_email + "'" +$ WC "cf_time='" + cf_time + "'" +$ WC "config_args='" + config_args + "'" +$ WC "config_sh='" + config_sh + "'" +$ WC "cpp_stuff='" + cpp_stuff + "'" +$ WC "cpplast='" + cpplast + "'" +$ 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 + "'" +$ WC "d_PRIFldbl='" + d_PRIFUldbl + "'" +$ WC "d_PRIGldbl='" + d_PRIGUldbl + "'" +$ WC "d_PRIX64='" + d_PRIXU64 + "'" +$ WC "d_PRIeldbl='" + d_PRIeldbl + "'" +$ WC "d_PRIfldbl='" + d_PRIfldbl + "'" +$ WC "d_PRIgldbl='" + d_PRIgldbl + "'" +$ WC "d_PRIo64='" + d_PRIo64 + "'" +$ WC "d_PRIu64='" + d_PRIu64 + "'" +$ WC "d_PRIx64='" + d_PRIx64 + "'" +$ WC "d_SCNfldbl='" + d_SCNfldbl + "'" +$ WC "d_access='" + d_access + "'" +$ WC "d_accessx='undef'" +$ WC "d_alarm='define'" +$ WC "d_archlib='define'" +$ WC "d_atolf='" + d_atolf + "'" +$ WC "d_atoll='" + d_atoll + "'" +$ WC "d_attribut='" + d_attribut + "'" +$ WC "d_bcmp='" + d_bcmp + "'" +$ WC "d_bcopy='" + d_bcopy + "'" +$ WC "d_bincompat3='undef'" +$ WC "d_bincompat5005='undef'" +$ WC "d_bsdgetpgrp='undef'" +$! WC "d_bsdpgrp='undef'" +$ WC "d_bsdsetpgrp='undef'" +$ WC "d_bzero='" + d_bzero + "'" +$ WC "d_casti32='define'" +$ WC "d_castneg='define'" +$ WC "d_charvspr='undef'" +$ WC "d_chown='define'" +$ WC "d_chroot='undef'" +$ WC "d_chsize='undef'" +$ WC "d_cmsghdr_s='undef'" +$ WC "d_const='define'" +$ WC "d_crypt='define'" +$ WC "d_csh='undef'" +$ WC "d_cuserid='define'" +$ WC "d_dbl_dig='define'" +$ WC "d_difftime='define'" +$ WC "d_dirnamlen='define'" +$ WC "d_dlerror='undef'" +$ WC "d_dlsymun='undef'" +$ WC "d_dosuid='undef'" +$ WC "d_drand48proto='" + d_drand48proto + "'" +$ WC "d_dup2='define'" +$ WC "d_eaccess='undef'" +$ WC "d_endgrent='define'" +$ WC "d_endhent='" + d_endhent + "'" +$ WC "d_endnent='" + d_endnent + "'" +$ WC "d_endpent='" + d_endpent + "'" +$ WC "d_endpwent='define'" +$ WC "d_endsent='" + d_endsent + "'" +$ WC "d_eofnblk='undef'" +$ 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'" +$ WC "d_flock='undef'" +$ WC "d_fork='undef'" +$ WC "d_fpathconf='" + d_fpathconf + "'" +$ WC "d_fpos64_t='" + d_fpos64_t + "'" +$ WC "d_frexpl='" + d_frexpl + "'" +$ WC "d_fs_data_s='undef'" +$ 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'" +$ WC "d_getfsstat='undef'" +$ WC "d_getgrent='define'" +$ WC "d_getgrps='undef'" +$ WC "d_gethbyaddr='" + d_gethbyaddr + "'" +$ WC "d_gethbyname='" + d_gethbyname + "'" +$ WC "d_gethent='" + d_gethent + "'" +$ WC "d_gethname='" + d_gethname + "'" +$ WC "d_gethostprotos='" + d_gethostprotos + "'" +$ WC "d_getlogin='define'" +$ WC "d_getmnt='undef'" +$ WC "d_getmntent='undef'" +$ 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 + "'" +$ WC "d_getpgid='undef'" +$ WC "d_getpgrp2='undef'" +$ WC "d_getpgrp='undef'" +$ WC "d_getppid='undef'" +$ WC "d_getprior='undef'" +$ WC "d_getprotoprotos='" + d_getprotoprotos + "'" +$ WC "d_getprpwnam='undef'" +$ WC "d_getpwent='define'" +$ WC "d_getsbyname='" + d_getsbyname + "'" +$ WC "d_getsbyport='" + d_getsbyport + "'" +$ WC "d_getsent='" + d_getsent + "'" +$ WC "d_getservprotos='" + d_getservprotos + "'" +$ WC "d_getspnam='undef'" +$ WC "d_gettimeod='" + d_gettimeod + "'" +$ WC "d_gnulibc='undef'" +$ WC "d_grpasswd='undef'" +$ WC "d_hasmntopt='undef'" +$ WC "d_htonl='" + d_htonl + "'" +$ WC "d_iconv='" + d_iconv +"'" +$ WC "d_index='" + d_index + "'" +$ WC "d_inetaton='undef'" +$ WC "d_int64_t='" + d_int64_t + "'" +$ WC "d_isascii='define'" +$ WC "d_isnan='" + d_isnan + "'" +$ WC "d_isnanl='" + d_isnanl + "'" +$ WC "d_killpg='undef'" +$ WC "d_lchown='undef'" +$ WC "d_ldbl_dig='define'" +$ WC "d_link='undef'" +$ WC "d_llseek='undef'" +$ WC "d_locconv='" + d_locconv + "'" +$ WC "d_lockf='undef'" +$ WC "d_longdbl='" + d_longdbl + "'" +$ WC "d_longlong='" + d_longlong + "'" +$ WC "d_lseekproto='define'" +$ WC "d_lstat='undef'" +$ WC "d_madvise='undef'" +$ WC "d_mblen='" + d_mblen + "'" +$ WC "d_mbstowcs='" + d_mbstowcs + "'" +$ WC "d_mbtowc='" + d_mbtowc + "'" +$ WC "d_memchr='" + d_memchr + "'" +$ WC "d_memcmp='define'" +$ WC "d_memcpy='define'" +$ WC "d_memmove='define'" +$ WC "d_memset='define'" +$ WC "d_mkdir='define'" +$ WC "d_mkdtemp='" + d_mkdtemp + "'" +$ WC "d_mkfifo='undef'" +$ WC "d_mknod='undef'" +$ WC "d_mkstemp='" + d_mkstemp + "'" +$ WC "d_mkstemps='" + d_mkstemps + "'" +$ WC "d_mktime='" + d_mktime + "'" +$ WC "d_mmap='undef'" +$ WC "d_modfl='" + d_modfl + "'" +$ WC "d_mprotect='undef'" +$ WC "d_msg='undef'" +$ WC "d_msg_ctrunc='undef'" +$ WC "d_msg_dontroute='undef'" +$ WC "d_msg_oob='undef'" +$ WC "d_msg_peek='undef'" +$ WC "d_msg_proxy='undef'" +$ WC "d_msghdr_s='undef'" +$ WC "d_msync='undef'" +$ WC "d_munmap='undef'" +$ WC "d_mymalloc='" + d_mymalloc + "'" +$ WC "d_nice='define'" +$ WC "d_nv_preserves_uv='" + d_nv_preserves_uv + "'" +$ WC "d_nv_preserves_uv_bits='" + d_nv_preserves_uv_bits + "'" +$ WC "d_off64_t='" + d_off64_t + "'" +$ WC "d_old_pthread_create_joinable='" + d_old_pthread_create_joinable + "'" +$ WC "d_oldarchlib='define'" +$ WC "d_oldpthreads='" + d_oldpthreads + "'" +$ WC "d_open3='define'" +$ WC "d_pathconf='" + d_pathconf + "'" +$ WC "d_pause='define'" +$ WC "d_perl_otherlibdirs='undef'" +$ WC "d_phostname='" + d_phostname + "'" +$ WC "d_pipe='define'" +$ WC "d_poll='undef'" +$ WC "d_pthread_yield='" + d_pthread_yield + "'" +$ WC "d_pthreads_created_joinable='" + d_pthreads_created_joinable + "'" +$ WC "d_pwage='undef'" +$ WC "d_pwchange='undef'" +$ WC "d_pwclass='undef'" +$ WC "d_pwcomment='define'" +$ WC "d_pwexpire='undef'" +$ WC "d_pwgecos='define'" +$ WC "d_pwpasswd='define'" +$ WC "d_pwquota='undef'" +$ WC "d_qgcvt='undef'" +$ WC "d_quad='" + d_quad + "'" +$ WC "d_readdir='define'" +$ WC "d_readlink='undef'" +$ WC "d_readv='undef'" +$ WC "d_recvmsg='undef'" +$ WC "d_rename='define'" +$ WC "d_rewinddir='define'" +$ WC "d_rmdir='define'" +$ WC "d_safebcpy='undef'" +$ WC "d_safemcpy='define'" +$ WC "d_sanemcmp='define'" +$ WC "d_sbrkproto='define'" +$ WC "d_sched_yield='" + d_sched_yield + "'" +$ WC "d_scm_rights='undef'" +$ WC "d_seekdir='define'" +$ WC "d_select='" + d_select + "'" +$ WC "d_sem='undef'" +$ WC "d_semctl_semid_ds='undef'" +$ WC "d_semctl_semun='undef'" +$ WC "d_sendmsg='undef'" +$ WC "d_setegid='undef'" +$ WC "d_setenv='" + d_setenv + "'" +$ WC "d_seteuid='undef'" +$ WC "d_setgrent='undef'" +$ WC "d_setgrps='undef'" +$ WC "d_sethent='" + d_sethent + "'" +$ WC "d_setlinebuf='undef'" +$ WC "d_setlocale='" + d_setlocale + "'" +$ WC "d_setnent='" + d_setnent + "'" +$ WC "d_setpent='" + d_setpent + "'" +$ WC "d_setpgid='undef'" +$ WC "d_setpgrp2='undef'" +$ WC "d_setpgrp='undef'" +$ WC "d_setprior='undef'" +$ WC "d_setproctitle='" + d_setproctitle + "'" +$ WC "d_setpwent='define'" +$ WC "d_setregid='undef'" +$ WC "d_setresgid='undef'" +$ WC "d_setresuid='undef'" +$ WC "d_setreuid='undef'" +$ WC "d_setrgid='undef'" +$ WC "d_setruid='undef'" +$ WC "d_setsent='" + d_setsent + "'" +$ WC "d_setsid='undef'" +$ WC "d_setvbuf='" + d_setvbuf + "'" +$ WC "d_sfio='undef'" +$ WC "d_shm='undef'" +$ WC "d_shmatprototype='undef'" +$ WC "d_sigaction='" + d_sigaction + "'" +$ WC "d_sigsetjmp='" + d_sigsetjmp + "'" +$ WC "d_socket='" + d_socket + "'" +$ WC "d_socklen_t='" + d_socklen_t + "'" +$ WC "d_sockpair='undef'" +$ WC "d_socks5_init='undef'" +$ WC "d_sqrtl='define'" +$ WC "d_statblks='undef'" +$ WC "d_statfs_f_flags='undef'" +$ 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 + "'" +$ WC "d_strchr='define'" +$ WC "d_strcoll='" + d_strcoll + "'" +$ WC "d_strctcpy='define'" +$ WC "d_strerrm='strerror((e),vaxc$errno)'" +$ WC "d_strerror='define'" +$ WC "d_strtod='define'" +$ WC "d_strtol='define'" +$ WC "d_strtold='" + d_strtold + "'" +$ WC "d_strtoll='" + d_strtoll + "'" +$ WC "d_strtoul='define'" +$ WC "d_strtoull='" + d_strtoull + "'" +$ WC "d_strtouq='" + d_strtouq + "'" +$ WC "d_strxfrm='" + d_strxfrm + "'" +$ WC "d_suidsafe='undef'" +$ WC "d_symlink='undef'" +$ WC "d_syscall='undef'" +$ WC "d_sysconf='" + d_sysconf + "'" +$ WC "d_syserrlst='undef'" +$ WC "d_system='define'" +$ WC "d_tcgetpgrp='undef'" +$ WC "d_tcsetpgrp='undef'" +$ WC "d_telldir='define'" +$ WC "d_telldirproto='define'" +$ WC "d_times='define'" +$ WC "d_truncate='" + d_truncate + "'" +$ WC "d_tzname='undef'" +$ WC "d_umask='define'" +$ WC "d_uname='" + d_uname + "'" +$ WC "d_union_semun='undef'" +$ WC "d_unlink_all_versions='undef'" +$ WC "d_ustat='undef'" +$ WC "d_vendorarch='undef'" +$ WC "d_vendorlib='undef'" +$ WC "d_vfork='define'" +$ WC "d_vms_case_sensitive_symbols='" + d_vms_be_case_sensitive + "'" ! VMS +$ WC "d_vms_do_sockets='" + d_vms_do_sockets + "'" ! VMS +$ WC "d_void_closedir='define'" +$ WC "d_volatile='define'" +$ WC "d_vprintf='define'" +$ WC "d_wait4='" + d_wait4 + "'" +$ WC "d_waitpid='define'" +$ WC "d_wcstombs='" + d_wcstombs + "'" +$ WC "d_wctomb='" + d_wctomb + "'" +$ WC "d_writev='undef'" +$ WC "db_hashtype=' '" +$ WC "db_prefixtype=' '" +$ WC "dbgprefix='" + dbgprefix + "'" +$ WC "defvoidused='15'" +$ WC "devtype='" + devtype + "'" +$ WC "direntrytype='struct dirent'" +$ WC "dlext='" + dlext + "'" +$ WC "dlobj='" + dlobj + "'" +$ WC "dlsrc='dl_vms.c'" +$ WC "doublesize='" + doublesize + "'" +$ 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 + "'" +$ WC "fflushNULL='define'" +$ WC "fflushall='undef'" +$ WC "fpostype='fpos_t'" +$ WC "freetype='void'" +$ WC "full_ar='" + "'" +$ WC "full_csh='" + " '" +$ WC "full_sed='_NLA0:'" +$ WC "gccversion='" + gccversion + "'" +$ WC "gidformat='lu'" +$ WC "gidsign='1'" +$ WC "gidsize='4'" +$ WC "gidtype='" + gidtype + "'" +$ WC "groupstype='Gid_t'" +$ WC "hint='none'" +$ WC "hintfile='" + "'" +$ WC "i16size='" + i16size + "'" +$ WC "i16type='" + i16type + "'" +$ WC "i32size='" + i32size + "'" +$ WC "i32type='" + i32type + "'" +$ WC "i64size='" + i64size + "'" +$ WC "i64type='" + i64type + "'" +$ WC "i8size='" + i8size + "'" +$ WC "i8type='" + i8type + "'" +$ WC "i_arpainet='undef'" +$ WC "i_dbm='undef'" +$ WC "i_dirent='" + i_dirent + "'" +$ WC "i_dlfcn='undef'" +$ WC "i_fcntl='" + i_fcntl + "'" +$ WC "i_float='define'" +$ WC "i_grp='undef'" +$ WC "i_iconv='" + i_iconv +"'" +$ WC "i_ieeefp='undef'" +$ WC "i_inttypes='" + i_inttypes + "'" +$ WC "i_libutil='" + i_libutil + "'" +$ WC "i_limits='define'" +$ WC "i_locale='" + i_locale + "'" +$ WC "i_machcthr='undef'" +$ WC "i_machcthreads='undef'" +$ WC "i_math='define'" +$ WC "i_memory='undef'" +$ WC "i_mntent='undef'" +$ WC "i_ndbm='undef'" +$ WC "i_netdb='" + i_netdb + "'" +$ WC "i_neterrno='define'" +$ WC "i_netinettcp='" + i_netinettcp + "'" +$ WC "i_niin='" + i_niin + "'" +$ WC "i_poll='" + i_poll + "'" +$ WC "i_prot='undef'" +$ WC "i_pthread='define'" +$ WC "i_pwd='undef'" +$ WC "i_rpcsvcdbm='undef'" +$ WC "i_sfio='undef'" +$ WC "i_sgtty='undef'" +$ WC "i_shadow='" + i_shadow + "'" +$ WC "i_socks='" + i_socks + "'" +$ WC "i_stdarg='define'" +$ WC "i_stddef='define'" +$ WC "i_stdlib='define'" +$ WC "i_string='define'" +$ WC "i_sunmath='undef'" +$ WC "i_sysaccess='" + i_sysaccess + "'" +$ WC "i_sysdir='undef'" +$ WC "i_sysfile='" + i_sysfile + "'" +$ WC "i_sysioctl='undef'" +$ WC "i_syslog='" + i_syslog + "'" +$ WC "i_sysmman='undef'" +$ WC "i_sysmode='" + i_sysmode + "'" +$ WC "i_sysmount='undef'" +$ WC "i_sysndir='undef'" +$ WC "i_sysparam='undef'" +$ WC "i_sysresrc='undef'" +$ WC "i_syssecrt='" + i_syssecrt + "'" +$ WC "i_sysselct='undef'" +$ WC "i_sysstat='define'" +$ WC "i_sysstatfs='undef'" +$ WC "i_sysstatvfs='undef'" +$ WC "i_systime='undef'" +$ WC "i_systimek='undef'" +$ WC "i_systimes='undef'" +$ WC "i_systypes='define'" +$ WC "i_sysuio='" + i_sysuio + "'" +$ WC "i_sysun='undef'" +$ WC "i_sysutsname='" + i_sysutsname + "'" +$ WC "i_sysvfs='undef'" +$ WC "i_syswait='undef'" +$ WC "i_termio='undef'" +$ WC "i_termios='undef'" +$ WC "i_time='define'" +$ WC "i_unistd='" + i_unistd + "'" +$ WC "i_ustat='undef'" +$ WC "i_utime='undef'" +$ WC "i_values='undef'" +$ WC "i_varargs='undef'" +$ WC "i_vfork='undef'" +$ WC "inc_version_list='0'" +$ WC "inc_version_list_init='0'" +$ WC "installarchlib='" + installarchlib + "'" +$ WC "installbin='" + installbin + "'" +$ WC "installman1dir='" + installman1dir + "'" +$ WC "installman3dir='" + installman3dir + "'" +$ WC "installprivlib='" + installprivlib + "'" +$ WC "installscript='" + installscript + "'" +$ WC "installsitearch='" + installsitearch + "'" +$ WC "installsitelib='" + installsitelib + "'" +$ WC "installusrbinperl='undef'" +$ WC "intsize='" + intsize + "'" +$ WC "ivdformat='" + ivdformat + "'" +$ WC "ivsize='" + ivsize + "'" +$ WC "ivtype='" + ivtype + "'" +$ WC "known_extensions='" + known_extensions + "'" +$ WC "ld='" + ld + "'" +$ WC "lddlflags='/Share'" +$ WC "ldflags='" + ldflags + "'" +$ WC "lib_ext='" + lib_ext + "'" +$ WC "libc='" + libc + "'" +$ WC "libpth='/sys$share /sys$library'" +$ WC "libs='" + libs + "'" +$ WC "longdblsize='" + longdblsize + "'" +$ WC "longlongsize='" + longlongsize + "'" +$ WC "longsize='" + longsize + "'" +$ WC "lseeksize='4'" +$ WC "lseektype='int'" +$ WC "mab='" + "'" +$ WC "make='" + make + "'" +$ WC "malloctype='void *'" +$ WC "man1ext='rno'" +$ WC "man3ext='rno'" +$ WC "mmaptype=' " + "'" +$ WC "modetype='unsigned int'" +$ WC "multiarch='undef'" +$ WC "mydomain='" + mydomain + "'" +$ WC "myhostname='" + myhostname + "'" +$ WC "myuname='" + myuname + "'" +$ WC "netdb_hlen_type='" + netdb_hlen_type + "'" +$ WC "netdb_host_type='" + netdb_host_type + "'" +$ WC "netdb_name_type='" + netdb_name_type + "'" +$ WC "netdb_net_type='" + netdb_net_type + "'" +$ WC "nveformat='" + nveformat + "'" +$ WC "nvfformat='" + nvfformat + "'" +$ WC "nvgformat='" + nvgformat + "'" +$ WC "nvsize='" + nvsize + "'" +$ WC "nvtype='" + nvtype + "'" +$ WC "o_nonblock=' '" +$ WC "obj_ext='" + obj_ext + "'" +$ WC "old_pthread_create_joinable='" + old_pthread_create_joinable + "'" +$ WC "oldarchlib='" + oldarchlib + "'" +$ WC "oldarchlibexp='" + oldarchlibexp + "'" +$ WC "optimize='" + optimize + "'" +$ WC "osname='" + osname + "'" +$ WC "osvers='" + osvers + "'" +$ WC "otherlibdirs='" + "'" +$ WC "package='" + package + "'" +$ WC "pager='" + pager + "'" +$ WC "patchlevel='" + patchlevel + "'" +$ WC "path_sep='|'" +$ WC "perl_root='" + perl_root + "'" ! VMS specific $trnlnm() +$ WC "perladmin='" + perladmin + "'" +$ WC "perllibs='" + perllibs + "'" +$ WC "pgflquota='" + pgflquota + "'" +$ WC "pidtype='" + pidtype + "'" +$ WC "pm_apiversion='" + version + "'" +$! WC "prefix='" + vms_prefix + "'" +$ WC "prefix='" + prefix + "'" +$ WC "privlib='" + privlib + "'" +$ WC "privlibexp='" + privlibexp + "'" +$ WC "prototype='define'" +$ WC "ptrsize='" + ptrsize + "'" +$ WC "quadkind='" + quadkind + "'" +$ WC "quadtype='" + quadtype + "'" +$ WC "randbits='31'" +$ WC "randseedtype='" + randseedtype + "'" +$ WC "ranlib='" + "'" +$ WC "rd_nodata=' '" +$ WC "revision='" + revision + "'" +$ WC "sPRId64='" + sPRId64 + "'" +$ WC "sPRIEldbl='" + sPRIEUldbl + "'" +$ WC "sPRIFldbl='" + sPRIFUldbl + "'" +$ WC "sPRIGldbl='" + sPRIGUldbl + "'" +$ WC "sPRIX64='" + sPRIXU64 + "'" +$ WC "sPRIeldbl='" + sPRIeldbl + "'" +$ WC "sPRIfldbl='" + sPRIfldbl + "'" +$ WC "sPRIgldbl='" + sPRIgldbl + "'" +$! WC "sPRIi64='" + sPRIi64 + "'" +$ WC "sPRIo64='" + sPRIo64 + "'" +$ WC "sPRIu64='" + sPRIu64 + "'" +$ WC "sPRIx64='" + sPRIx64 + "'" +$ WC "sSCNfldbl='" + sSCNfldbl + "'" +$ WC "sched_yield='" + sched_yield + "'" +$ WC "seedfunc='" + seedfunc + "'" +$ WC "selectminbits='32'" +$ WC "selecttype='" + selecttype + "'" +$ WC "sh='MCR'" +$ WC "shmattype='" + " '" +$ WC "shortsize='" + shortsize + "'" +$ WC "shrplib='define'" +$ WC "sig_name='" + sig_name + "'" +$ tmp = "sig_name_init='" + sig_name_init + "'" +$ WC/symbol tmp +$ DELETE/SYMBOL tmp +$ WC "sig_num='" + sig_num + "'" +$ WC "sig_num_init='" + sig_num_init + "'" +$ WC "signal_t='" + signal_t + "'" +$ WC "sitearch='" + sitearch + "'" +$ WC "sitearchexp='" + sitearchexp + "'" +$ WC "sitelib='" + sitelib + "'" +$ WC "sitelib_stem='" + sitelib_stem + "'" +$ WC "sitelibexp='" + sitelibexp + "'" +$ WC "sizesize='" + sizesize + "'" +$ WC "sizetype='size_t'" +$ WC "so='" + so + "'" +$ WC "socksizetype='" + socksizetype + "'" +$ 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='" + static_ext + "'" +$ WC "stdchar='" + stdchar + "'" +$ WC "stdio_base='((*fp)->_base)'" +$ WC "stdio_bufsiz='((*fp)->_cnt + (*fp)->_ptr - (*fp)->_base)'" +$ WC "stdio_cnt='((*fp)->_cnt)'" +$ WC "stdio_ptr='((*fp)->_ptr)'" +$ WC "stdio_stream_array=' " + "'" +$ WC "subversion='" + subversion + "'" +$ WC "timetype='" + timetype + "'" +$ WC "u16size='" + u16size + "'" +$ WC "u16type='" + u16type + "'" +$ WC "u32size='" + u32size + "'" +$ WC "u32type='" + u32type + "'" +$ WC "u64size='" + u64size + "'" +$ WC "u64type='" + u64type + "'" +$ WC "u8size='" + u8size + "'" +$ WC "u8type='" + u8type + "'" +$ WC "uidformat='lu'" +$ WC "uidsign='1'" +$ WC "uidsize='4'" +$ WC "uidtype='" + uidtype + "'" +$ 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 + "'" +$ WC "uselongdouble='" + uselongdouble + "'" +$ WC "usemorebits='" + usemorebits + "'" +$ WC "usemultiplicity='" + usemultiplicity + "'" +$ WC "usemymalloc='" + usemymalloc + "'" +$ WC "useperlio='undef'" +$ WC "useposix='false'" +$ WC "usesocks='undef'" +$ WC "usethreads='" + usethreads + "'" +$ WC "usevfork='true'" +$ WC "uvoformat='" + uvoformat + "'" +$ WC "uvsize='" + uvsize + "'" +$ WC "uvtype='" + uvtype + "'" +$ WC "uvuformat='" + uvuformat + "'" +$ WC "uvxformat='" + uvxformat + "'" +$ WC "uvXUformat='" + uvXUformat + "'" +$ WC "vendorarchexp='" + "'" +$ WC "vendorlib_stem='" + "'" +$ WC "vendorlibexp='" + "'" +$ WC "version='" + version + "'" +$ WC "vms_cc_type='" + vms_cc_type + "'" ! VMS specific +$ WC "vms_prefix='" + vms_prefix + "'" ! VMS specific +$ WC "vms_ver='" + vms_ver + "'" ! VMS specific +$ WC "voidflags='15'" +$ WC "xs_apiversion='" + version + "'" +$ WC "CONFIGDOTSH='true'" +$! +$! ##END WRITE NEW CONSTANTS HERE## +$! +$ CLOSE CONFIG +$! +$! Okay, we've gotten here. Build munchconfig.exe +$ COPY/NOLOG [-.vms]munchconfig.c [] +$ COPY/NOLOG [-.vms]'Makefile_SH' [] +$ 'Perl_CC' munchconfig.c +$ IF Needs_Opt +$ THEN +$ OPEN/WRITE CONFIG []munchconfig.opt +$ IF ccname .EQS. "GCC" +$ THEN +$ WRITE CONFIG "Gnu_CC:[000000]gcclib.olb/library" +$ ENDIF +$ WRITE CONFIG "Sys$Share:VAXCRTL/Share" +$ CLOSE CONFIG +$ 'ld' munchconfig.obj,munchconfig.opt/opt +$ DELETE/NOLOG/NOCONFIRM munchconfig.opt; +$ ELSE +$ 'ld' munchconfig.obj +$ ENDIF +$ IF F$SEARCH("munchconfig.obj") .NES. "" THEN DELETE/NOLOG/NOCONFIRM munchconfig.obj; +$ IF F$SEARCH("munchconfig.c") .NES. "" THEN DELETE/NOLOG/NOCONFIRM munchconfig.c; +$ IF ccname .EQS. "CXX" +$ THEN +$ CALL Cxx_demangler_cleanup +$ ENDIF +$! +$ IF alldone .EQS. "" +$ THEN +$ cat4 SYS$INPUT: +$ DECK + +If you'd like to make any changes to the config.sh file before I begin +to configure things, answer yes to the following question. + +$ EOD +$ dflt="n" +$ rp="Do you wish to edit ''basename_config_sh'? [''dflt'] " +$ GOSUB myread +$ IF ans .EQS. "" then ans = dflt +$ IF ans +$ THEN +$ echo4 "" +$ echo4 "Be sure to type LOGOUT after you have edited the file," +$ echo4 "then this procedure will resume." +$ echo4 "" +$ default = F$ENVIRONMENT("DEFAULT") +$ DIRECTORY 'config_sh' +$ SET DEFAULT [-] +$ SPAWN/WAIT +$ SET DEFAULT 'default' +$ ENDIF +$ ENDIF +$! +$ echo "" +$ echo4 "Adding ''osname' specific preprocessor commands." +$ ! +$ ! we need an fdl file +$ CREATE [-]CONFIG.FDL +$ DECK +RECORD + FORMAT STREAM_LF +$ EOD +$ CREATE /FDL=[-]CONFIG.FDL [-]CONFIG.LOCAL +$ ! First spit out the header info with the local defines (to get +$ ! around the 255 character command line limit) +$ OPEN/APPEND CONFIG [-]config.local +$ IF use_debugging_perl THEN WC "#define DEBUGGING" +$ IF use_two_pot_malloc THEN WC "#define TWO_POT_OPTIMIZE" +$ IF mymalloc THEN WC "#define EMBEDMYMALLOC" +$ IF use_pack_malloc THEN WC "#define PACK_MALLOC" +$ IF use_debugmalloc THEN WC "#define DEBUGGING_MSTATS" +$ IF ccname .EQS. "GCC" THEN WC "#define GNUC_ATTRIBUTE_CHECK" +$ IF (Has_Dec_C_Sockets) +$ THEN +$ WC "#define VMS_DO_SOCKETS" +$ WC "#define DECCRTL_SOCKETS" +$ ELSE +$ IF Has_Socketshr THEN WC "#define VMS_DO_SOCKETS" +$ ENDIF +$! This is VMS-specific for now +$ WC "#''d_setenv' HAS_SETENV" +$ IF d_secintgenv THEN WC "#define SECURE_INTERNAL_GETENV" +$ IF d_alwdeftype THEN WC "#define ALWAYS_DEFTYPES" +$ IF use64bitint .OR. use64bitint .EQS. "define" +$ THEN +$ WC "#define USE_64_BIT_INT" +$ WC "#define USE_LONG_DOUBLE" +$ ENDIF +$ IF use64bitall .OR. use64bitall .EQS. "define" THEN - + WC "#define USE_64_BIT_ALL" +$ IF be_case_sensitive THEN WC "#define VMS_WE_ARE_CASE_SENSITIVE" +$ IF d_herrno .EQS. "undef" THEN WC "#define NEED_AN_H_ERRNO" +$ WC "#define HAS_ENVGETENV" +$ WC "#define PERL_EXTERNAL_GLOB" +$ CLOSE CONFIG +$! +$ echo4 "Doing variable substitutions on .SH files..." +$ echo4 "Extracting config.h (with variable substitutions)" +$! +$! Now build the normal config.h +$ DEFINE/USER_MODE sys$output [-]config.main +$ mcr []munchconfig 'config_sh' [-]config_h.sh +$ ! Concatenate them together +$ copy [-]config.local,[-]config.main [-]config.h +$! Clean up +$ DELETE/NOLOG [-]CONFIG.MAIN;* +$ DELETE/NOLOG [-]CONFIG.LOCAL;* +$ DELETE/NOLOG [-]CONFIG.FDL;* +$! +$ IF ccname .EQS. "DEC" +$ THEN +$ DECC_REPLACE = "DECC=decc=1" +$ ELSE +$ DECC_REPLACE = "DECC=" +$ ENDIF +$ IF ccname .EQS. "CXX" +$ THEN +$ DECCXX_REPLACE = "DECCXX=DECCXX=1" +$ ELSE +$ DECCXX_REPLACE = "DECCXX=" +$ ENDIF +$ IF ccname .EQS. "GCC" +$ THEN +$ GNUC_REPLACE = "GNUC=gnuc=1" +$ ELSE +$ GNUC_REPLACE = "GNUC=" +$ ENDIF +$ IF Has_Dec_C_Sockets +$ THEN +$ SOCKET_REPLACE = "SOCKET=DECC_SOCKETS=1" +$ ELSE +$ IF Has_Socketshr +$ THEN +$ SOCKET_REPLACE = "SOCKET=SOCKETSHR_SOCKETS=1" +$ ELSE +$ SOCKET_REPLACE = "SOCKET=" +$ ENDIF +$ ENDIF +$ IF Use_Threads +$ THEN +$ IF (vms_ver .LES. "6.2") +$ THEN +$ THREAD_REPLACE = "THREAD=OLDTHREADED=1" +$ ELSE +$ THREAD_REPLACE = "THREAD=THREADED=1" +$ ENDIF +$ ELSE +$ THREAD_REPLACE = "THREAD=" +$ ENDIF +$ IF mymalloc +$ THEN +$ MALLOC_REPLACE = "MALLOC=MALLOC=1" +$ ELSE +$ MALLOC_REPLACE = "MALLOC=" +$ ENDIF +$ echo4 "Extracting ''defmakefile' (with variable substitutions)" +$ DEFINE/USER_MODE sys$output 'UUmakefile' +$ mcr []munchconfig 'config_sh' 'Makefile_SH' "''DECC_REPLACE'" - + "''DECCXX_REPLACE'" "''ARCH_TYPE'" "''GNUC_REPLACE'" "''SOCKET_REPLACE'" - + "''THREAD_REPLACE'" "''C_Compiler_Replace'" "''MALLOC_REPLACE'" - + "''Thread_Live_Dangerously'" "PV=''version'" "FLAGS=FLAGS=''extra_flags'" +$! Clean up after ourselves +$ DELETE/NOLOG/NOCONFIRM []munchconfig.exe; +$ echo4 "Extracting make_ext.com (without variable substitutions)" +$ Create Sys$Disk:[-]make_ext.com +$ Deck/Dollar="$EndOfTpl$" +$!++ make_ext.com +$! NOTE: This file is extracted as part of the VMS configuration process. +$! Any changes made to it directly will be lost. If you need to make any +$! changes, please edit the template in Configure.Com instead. +$ def = F$Environment("Default") +$ exts1 = F$Edit(p1,"Compress") +$ p2 = F$Edit(p2,"Upcase,Compress,Trim") +$ If F$Locate("MCR ",p2).eq.0 Then p2 = F$Extract(3,255,p2) +$ miniperl = "$" + F$Search(F$Parse(p2,".Exe")) +$ makeutil = p3 +$ if f$type('p3') .nes. "" then makeutil = 'p3' +$ targ = F$Edit(p4,"Lowercase") +$ i = 0 +$ next_ext: +$ ext = F$Element(i," ",p1) +$ If ext .eqs. " " Then Goto done +$ Define/User_mode Perl_Env_Tables CLISYM_LOCAL +$ miniperl +$ deck + ($extdir = $ENV{'ext'}) =~ s/::/./g; + $extdir =~ s#/#.#g; + if ($extdir =~ /^vms/i) { $extdir =~ s/vms/.vms.ext/i; } + else { $extdir = ".ext.$extdir"; } + ($ENV{'extdir'} = "[$extdir]"); + ($ENV{'up'} = ('-') x ($extdir =~ tr/././)); +$ eod +$ Set Default &extdir +$ redesc = 0 +$ If F$Locate("clean",targ) .eqs. F$Length(targ) +$ Then +$ Write Sys$Output "" +$ Write Sys$Output " Making ''ext' (dynamic)" +$ On Error Then Goto done +$ If F$Search("Descrip.MMS") .eqs. "" +$ Then +$ redesc = 1 +$ Else +$ If F$CvTime(F$File("Descrip.MMS","rdt")) .lts. - + F$CvTime(F$File("Makefile.PL","rdt")) Then redesc = 1 +$ EndIf +$ Else +$ Write Sys$Output "''targ'ing ''ext' . . ." +$ On Error Then Continue +$ EndIf +$ If redesc Then - + miniperl "-I[''up'.lib]" Makefile.PL "INST_LIB=[''up'.lib]" "INST_ARCHLIB=[''up'.lib]" +$ makeutil 'targ' +$ i = i + 1 +$ Set Def &def +$ Goto next_ext +$ done: +$ sts = $Status +$ Set Def &def +$ Exit sts +$!-- make_ext.com +$EndOfTpl$ +$! +$! Note that the /key qualifier to search, as in: +$! search README.* "=head"/key=(position=1)/window=0/output=extra.pods +$! is not supported on VMS V5.5-2, hence not used in extra_pods.com. +$! +$ echo4 "Extracting extra_pods.com (without variable substitutions)" +$ Create Sys$Disk:[-]extra_pods.com +$ Deck/Dollar="$EOExtra_Pods$" +$!++ extra_pods.com +$! NOTE: This file is extracted as part of the VMS configuration process. +$! Any changes made to it directly will be lost. If you need to make any +$! changes, please edit the template in Configure.Com instead. +$! Use FORCE if you've just podified a README.* file on VMS. +$ if f$search("extra.pods") .eqs. "" .or. P1 .eqs. "FORCE" then - + search README.* "=head"/window=0/output=extra.pods +$ open/read/error=extra_close EXTRA extra.pods +$extra_loop: +$ read/error=extra_close/END_OF_FILE=extra_close EXTRA file +$ file_type = f$parse(file,,,"TYPE",) - "." +$ if file_type .nes. "VMS" .and. file_type .nes. "vms" +$ then +$ pod_file = "[.pod]perl''file_type'.pod" +$ file = file - "''f$parse(file,,,"VERSION",)'" +$ if p1 .eqs. "CLEAN" +$ then if f$search(pod_file) .nes. "" then delete/log 'pod_file';* +$ else +$ do_copy := false +$ if f$search(pod_file) .eqs. "" +$ then do_copy := true +$ else +$ file_rdt = f$cvtime(f$file_attributes(file,"RDT")) +$ pod_file_rdt = f$cvtime(f$file_attributes(pod_file,"RDT")) +$ if file_rdt .GTS. pod_file_rdt then do_copy := true +$ endif +$ if do_copy then copy/log/noconfirm 'file' 'pod_file' +$ endif +$ endif +$ goto extra_loop +$extra_close: +$ close EXTRA +$ if p1 .eqs. "CLEAN" .and. f$search("extra.pods;-1") .nes. "" then - + purge/nolog extra.pods +$!-- extra_pods.com +$EOExtra_Pods$ $! $! Warn of dangerous symbols or logical names $! @@ -2206,7 +5644,7 @@ $Bad_environment: SUBROUTINE $ Bad_env = "" $ IF p2 .eqs. "SYMBOL" $ THEN -$ IF f$type('p1) .nes. "" THEN Bad_env := SYMBOL +$ IF f$type('p1') .nes. "" THEN Bad_env := SYMBOL $ ELSE $ IF f$trnlnm(p1) .nes. "" THEN Bad_env := LOGICAL $ ENDIF @@ -2226,7 +5664,7 @@ $ WRITE CONFIG " delete before building ''package' via:" $ WRITE CONFIG " $ DELETE/SYMBOL/GLOBAL ''p1'" $ IF f$locate("""",&p1) .ge. f$length(&p1) $ THEN -$ WRITE CONFIG " after building, testing, and installing ''package' +$ WRITE CONFIG " after building, testing, and installing ''package'" $ WRITE CONFIG " restore the symbol with:" $ WRITE CONFIG " $ ''p1' == """ + &p1 + """" $ ENDIF @@ -2243,7 +5681,7 @@ $ ENDIF $ EXIT $ ENDSUBROUTINE ! Bad_environment $ echo "" -$ echo4 "%Config-I-VMS, Checking for dangerous pre-existing global symbols and logical names." +$ echo4 "Checking for dangerous pre-existing global symbols and logical names." $ CALL Bad_environment "TMP" $ CALL Bad_environment "LIB" $ CALL Bad_environment "T" @@ -2258,28 +5696,28 @@ $ IF (.NOT.perl_symbol) $ THEN $ file_2_find = "[-]''packageup'.cld" $ echo "" -$ echo4 "%Config-I-VMS, The perl.cld file is now being written..." +$ echo4 "The perl.cld file is now being written..." $ OPEN/WRITE CONFIG 'file_2_find' $ ext = ".exe" -$ IF ((sharedperl) .AND. (f$getsyi("ARCH_NAME") .NES. "VAX")) THEN ext := .AXE +$ IF ((sharedperl) .AND. (F$GETSYI("HW_MODEL") .GE. 1024)) THEN ext := .AXE $ IF (use_vmsdebug_perl) $ THEN $ WRITE CONFIG "define verb dbgperl" -$ WRITE CONFIG F$FAO("!_!AS","image ''packageup'_root:[000000]dbgperl''ext'") +$ WRITE CONFIG F$FAO("!_!AS","image ''vms_prefix':[000000]dbgperl''ext'") $ WRITE CONFIG F$FAO("!_!AS","cliflags (foreign)") $ WRITE CONFIG "" $ WRITE CONFIG "define verb perl" -$ WRITE CONFIG F$FAO("!_!AS","image ''packageup'_root:[000000]ndbgPerl''ext'") +$ WRITE CONFIG F$FAO("!_!AS","image ''vms_prefix':[000000]ndbgPerl''ext'") $ WRITE CONFIG F$FAO("!_!AS","cliflags (foreign)") $ ELSE $ WRITE CONFIG "define verb perl" -$ WRITE CONFIG F$FAO("!_!AS","image ''packageup'_root:[000000]perl''ext'") +$ WRITE CONFIG F$FAO("!_!AS","image ''vms_prefix':[000000]perl''ext'") $ WRITE CONFIG F$FAO("!_!AS","cliflags (foreign)") $ ENDIF $ CLOSE CONFIG $ ENDIF ! (.NOT.perl_symbol) $ echo "" -$ echo4 "%Config-I-VMS, The perl_setup.com file is now being written..." +$ echo4 "The perl_setup.com file is now being written..." $ file_2_find = "[-]perl_setup.com" $ OPEN/WRITE CONFIG 'file_2_find' $ WRITE CONFIG "$!" @@ -2294,38 +5732,38 @@ $ WRITE CONFIG "$!" $ prefix = prefix - "000000." $ IF F$LOCATE(".]",prefix) .EQ. F$LENGTH(prefix) THEN - prefix = prefix - "]" + ".]" -$ WRITE CONFIG "$ define/translation=concealed Perl_Root ''prefix'" +$ WRITE CONFIG "$ define/translation=concealed ''vms_prefix' ''prefix'" $ WRITE CONFIG "$ ext = "".exe""" -$ IF sharedperl .EQS. "Y" +$ IF sharedperl $ THEN -$ write config "$ if f$getsyi(""ARCH_NAME"") .nes. ""VAX"" then ext = "".AXE""" +$ write config "$ if f$getsyi(""HW_MODEL"") .ge. 1024 then ext = "".AXE""" $ ENDIF $ IF (perl_symbol) $ THEN $ IF (use_vmsdebug_perl) $ THEN -$ WRITE CONFIG "$ dbgperl :== $Perl_Root:[000000]dbgPerl'ext'" -$ WRITE CONFIG "$ perl :== $Perl_Root:[000000]ndbgPerl'ext'" -$ WRITE CONFIG "$ define dbgPerlShr Perl_Root:[000000]dbgPerlShr'ext'" +$ WRITE CONFIG "$ dbgperl :== $''vms_prefix':[000000]dbgPerl'ext'" +$ WRITE CONFIG "$ perl :== $''vms_prefix':[000000]ndbgPerl'ext'" +$ WRITE CONFIG "$ define dbgPerlShr ''vms_prefix':[000000]dbgPerlShr'ext'" $ ELSE -$ WRITE CONFIG "$ perl :== $Perl_Root:[000000]Perl'ext'" -$ WRITE CONFIG "$ define PerlShr Perl_Root:[000000]PerlShr'ext'" +$ WRITE CONFIG "$ perl :== $''vms_prefix':[000000]Perl'ext'" +$ WRITE CONFIG "$ define PerlShr ''vms_prefix':[000000]PerlShr'ext'" $ ENDIF $ ELSE ! .NOT.perl_symbol $ IF (use_vmsdebug_perl) $ THEN -$ WRITE CONFIG "$ define dbgPerlShr Perl_Root:[000000]dbgPerlShr'ext'" +$ WRITE CONFIG "$ define dbgPerlShr ''vms_prefix':[000000]dbgPerlShr'ext'" $ ELSE -$ WRITE CONFIG "$ define PerlShr Perl_Root:[000000]PerlShr'ext'" +$ WRITE CONFIG "$ define PerlShr ''vms_prefix':[000000]PerlShr'ext'" $ ENDIF $ IF perl_verb .EQS. "PROCESS" $ THEN -$ WRITE CONFIG "$ set command ''packagup'_ROOT:[000000]''packageup'.CLD" +$ WRITE CONFIG "$ set command ''vms_prefix':[000000]''packageup'.CLD" $ ENDIF $ ENDIF ! perl_symbol -$ WRITE CONFIG "$ define/nolog pod2text Perl_Root:[lib.pod]pod2text.com" -$ WRITE CONFIG "$ define/nolog pod2html Perl_Root:[lib.pod]pod2html.com" -$ WRITE CONFIG "$ define/nolog pod2man Perl_Root:[lib.pod]pod2man.com" +$ WRITE CONFIG "$ define/nolog pod2text ''vms_prefix':[lib.pod]pod2text.com" +$ WRITE CONFIG "$ define/nolog pod2html ''vms_prefix':[lib.pod]pod2html.com" +$ WRITE CONFIG "$ define/nolog pod2man ''vms_prefix':[lib.pod]pod2man.com" $! $ IF (tzneedset) $ THEN @@ -2338,59 +5776,59 @@ $ WRITE CONFIG "$! Symbols for commonly used scripts:" $ WRITE CONFIG "$!" $ IF (perl_symbol) $ THEN -$ WRITE CONFIG "$ Perldoc == ""'"+"'Perl' Perl_Root:[lib.pod]Perldoc.com -t""" +$ WRITE CONFIG "$ Perldoc == ""'"+"'Perl' ''vms_prefix':[lib.pod]Perldoc.com -t""" $ WRITE CONFIG "$ pod2text == ""'"+"'Perl' pod2text""" $ WRITE CONFIG "$ pod2html == ""'"+"'Perl' pod2html""" -$ WRITE CONFIG "$ pod2latex == ""'"+"'Perl' Perl_Root:[lib.pod]pod2latex.com""" +$ WRITE CONFIG "$ pod2latex == ""'"+"'Perl' ''vms_prefix':[lib.pod]pod2latex.com""" $ WRITE CONFIG "$!pod2man == ""'"+"'Perl' pod2man""" -$ WRITE CONFIG "$!Perlbug == ""'"+"'Perl' Perl_Root:[lib]Perlbug.com""" -$ WRITE CONFIG "$ c2ph == ""'"+"'Perl' Perl_Root:[utils]c2ph.com""" +$ WRITE CONFIG "$!Perlbug == ""'"+"'Perl' ''vms_prefix':[lib]Perlbug.com""" +$ WRITE CONFIG "$ c2ph == ""'"+"'Perl' ''vms_prefix':[utils]c2ph.com""" $ IF F$LOCATE("Devel::DProf",extensions) .LT. F$LENGTH(extensions) $ THEN -$ WRITE CONFIG "$ dprofpp == ""'"+"'Perl' Perl_Root:[utils]dprofpp.com""" +$ WRITE CONFIG "$ dprofpp == ""'"+"'Perl' ''vms_prefix':[utils]dprofpp.com""" $ ENDIF -$ WRITE CONFIG "$ h2ph == ""'"+"'Perl' Perl_Root:[utils]h2ph.com""" -$ WRITE CONFIG "$ h2xs == ""'"+"'Perl' Perl_Root:[utils]h2xs.com""" -$ WRITE CONFIG "$!perlcc == ""'"+"'Perl' Perl_Root:[utils]perlcc.com""" -$ WRITE CONFIG "$ splain == ""'"+"'Perl' Perl_Root:[utils]splain.com""" +$ WRITE CONFIG "$ h2ph == ""'"+"'Perl' ''vms_prefix':[utils]h2ph.com""" +$ WRITE CONFIG "$ h2xs == ""'"+"'Perl' ''vms_prefix':[utils]h2xs.com""" +$ WRITE CONFIG "$!perlcc == ""'"+"'Perl' ''vms_prefix':[utils]perlcc.com""" +$ WRITE CONFIG "$ splain == ""'"+"'Perl' ''vms_prefix':[utils]splain.com""" $ ELSE -$ WRITE CONFIG "$ Perldoc == ""Perl Perl_Root:[lib.pod]Perldoc.com -t""" +$ WRITE CONFIG "$ Perldoc == ""Perl ''vms_prefix':[lib.pod]Perldoc.com -t""" $ WRITE CONFIG "$ pod2text == ""Perl pod2text""" $ WRITE CONFIG "$ pod2html == ""Perl pod2html""" -$ WRITE CONFIG "$ pod2latex == ""Perl Perl_Root:[lib.pod]pod2latex.com""" +$ WRITE CONFIG "$ pod2latex == ""Perl ''vms_prefix':[lib.pod]pod2latex.com""" $ WRITE CONFIG "$!pod2man == ""Perl pod2man""" -$ WRITE CONFIG "$!Perlbug == ""Perl Perl_Root:[lib]Perlbug.com""" -$ WRITE CONFIG "$ c2ph == ""Perl Perl_Root:[utils]c2ph.com""" +$ WRITE CONFIG "$!Perlbug == ""Perl ''vms_prefix':[lib]Perlbug.com""" +$ WRITE CONFIG "$ c2ph == ""Perl ''vms_prefix':[utils]c2ph.com""" $ IF F$LOCATE("Devel::DProf",extensions) .LT. F$LENGTH(extensions) $ THEN -$ WRITE CONFIG "$ dprofpp == ""Perl Perl_Root:[utils]dprofpp.com""" +$ WRITE CONFIG "$ dprofpp == ""Perl ''vms_prefix':[utils]dprofpp.com""" $ ENDIF -$ WRITE CONFIG "$ h2ph == ""Perl Perl_Root:[utils]h2ph.com""" -$ WRITE CONFIG "$ h2xs == ""Perl Perl_Root:[utils]h2xs.com""" -$ WRITE CONFIG "$!perlcc == ""Perl Perl_Root:[utils]perlcc.com""" -$ WRITE CONFIG "$ splain == ""Perl Perl_Root:[utils]splain.com""" +$ WRITE CONFIG "$ h2ph == ""Perl ''vms_prefix':[utils]h2ph.com""" +$ WRITE CONFIG "$ h2xs == ""Perl ''vms_prefix':[utils]h2xs.com""" +$ WRITE CONFIG "$!perlcc == ""Perl ''vms_prefix':[utils]perlcc.com""" +$ WRITE CONFIG "$ splain == ""Perl ''vms_prefix':[utils]splain.com""" $ ENDIF $ CLOSE CONFIG $! $ echo "" -$ echo "%Config-I-VMS, The file can be found at:" -$ echo4 "-Config-I-VMS, ''F$SEARCH(file_2_find)'" -$ echo "-Config-I-VMS, Add that file (or an @ call to it) to your [SY]LOGIN.COM" -$ echo "-Config-I-VMS, when you are satisfied with a successful compilation," -$ echo "-Config-I-VMS, testing, and installation of your perl." +$ echo "The file can be found at:" +$ echo4 " ''F$SEARCH(file_2_find)'" +$ echo "Add that file (or an @ call to it) to your [SY]LOGIN.COM" +$ echo "when you are satisfied with a successful compilation," +$ echo "testing, and installation of your perl." $ echo "" $ IF ((.NOT.perl_symbol) .AND. (perl_verb .EQS. "DCLTABLES")) $ THEN $ file_2_find = "[-]''packageup'_install.com" -$ OPEN/WRITE CONFIG 'file_2_find +$ OPEN/WRITE CONFIG 'file_2_find' $ WRITE CONFIG "$ set command perl /table=sys$common:[syslib]dcltables.exe -" $ WRITE CONFIG " /output=sys$common:[syslib]dcltables.exe" $ WRITE CONFIG "$ install replace sys$common:[syslib]dcltables.exe" $ CLOSE CONFIG $ echo4 "" -$ echo4 "%Config-I-VMS, In order to install the ''packageup' verb into DCLTABLES run:" -$ echo4 "-Config-I-VMS, @ ''F$SEARCH(file_2_find)'" -$ echo4 "-Config-I-VMS, after a successful build, test, and install. Do so with CMKRNL privilege." +$ echo4 "In order to install the ''packageup' verb into DCLTABLES run:" +$ echo4 " @ ''F$SEARCH(file_2_find)'" +$ echo4 "after a successful build, test, and install. Do so with CMKRNL privilege." $ echo4 "" $ ENDIF $! @@ -2441,8 +5879,8 @@ $ THEN $ DEASSIGN SYS$OUTPUT $! DEASSIGN SYS$ERROR $ ENDIF -$ IF F$GETJPI("","FILCNT").NE.vms_filcnt THEN CLOSE CONFIG -$ IF F$GETJPI("","FILCNT").NE.vms_filcnt +$ IF F$GETJPI("","FILCNT").GT.vms_filcnt THEN CLOSE CONFIG +$ IF F$GETJPI("","FILCNT").GT.vms_filcnt $ THEN WRITE SYS$ERROR "%Config-W-VMS, WARNING: There is a file still open" $ ENDIF $ dflt = F$ENVIRONMENT("DEFAULT") @@ -2454,6 +5892,5 @@ $ SET PROTECTION=(SYSTEM:RWED,OWNER:RWED) UU.DIR $ DELETE/NOLOG/NOCONFIRM UU.DIR; $ ENDIF $ SET DEFAULT 'vms_default_directory_name' !be kind rewind -$ STOP $ EXIT $!: End of Configure diff --git a/contrib/perl5/configure.gnu b/contrib/perl5/configure.gnu index 2ef8331833db..f98eb7660f32 100755 --- a/contrib/perl5/configure.gnu +++ b/contrib/perl5/configure.gnu @@ -86,7 +86,7 @@ EOM exit 1 ;; *) - opts="$opts $1" + opts="$opts '$1'" shift ;; esac @@ -126,7 +126,7 @@ case "$verbose" in *) copt="$copt -d";; esac -set X sh Configure $copt $create $opts +eval "set X sh Configure $copt $create $opts" shift echo "$@" exec "$@" diff --git a/contrib/perl5/cop.h b/contrib/perl5/cop.h index e588675012ab..ec32c3571d63 100644 --- a/contrib/perl5/cop.h +++ b/contrib/perl5/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. @@ -29,32 +29,33 @@ struct cop { # define CopFILE(c) ((c)->cop_file) # define CopFILEGV(c) (CopFILE(c) \ ? gv_fetchfile(CopFILE(c)) : Nullgv) -# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) /* XXX */ +# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) # define CopFILESV(c) (CopFILE(c) \ ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) # define CopFILEAV(c) (CopFILE(c) \ ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) # define CopSTASHPV(c) ((c)->cop_stashpv) -# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = savepv(pv)) /* XXX */ +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) # define CopSTASH(c) (CopSTASHPV(c) \ ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) -# define CopSTASH_set(c,hv) CopSTASHPV_set(c, HvNAME(hv)) -# define CopSTASH_eq(c,hv) (hv \ +# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) +# define CopSTASH_eq(c,hv) ((hv) \ && (CopSTASHPV(c) == HvNAME(hv) \ || (CopSTASHPV(c) && HvNAME(hv) \ && strEQ(CopSTASHPV(c), HvNAME(hv))))) #else # define CopFILEGV(c) ((c)->cop_filegv) -# define CopFILEGV_set(c,gv) ((c)->cop_filegv = gv) -# define CopFILE_set(c,pv) ((c)->cop_filegv = gv_fetchfile(pv)) +# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) # define CopSTASH(c) ((c)->cop_stash) -# define CopSTASH_set(c,hv) ((c)->cop_stash = hv) +# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) -# define CopSTASHPV_set(c,pv) CopSTASH_set(c, gv_stashpv(pv,GV_ADD)) -# define CopSTASH_eq(c,hv) (CopSTASH(c) == hv) + /* cop_stash is not refcounted */ +# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) #endif /* USE_ITHREADS */ #define CopSTASH_ne(c,hv) (!CopSTASH_eq(c,hv)) @@ -79,6 +80,7 @@ struct block_sub { U16 olddepth; U8 hasargs; U8 lval; /* XXX merge lval and hasargs? */ + SV ** oldcurpad; }; #define PUSHSUB(cx) \ @@ -105,13 +107,14 @@ struct block_sub { } STMT_END #endif /* USE_THREADS */ -#ifdef USE_ITHREADS - /* junk in @_ spells trouble when cloning CVs, so don't leave any */ -# define CLEAR_ARGARRAY() av_clear(cx->blk_sub.argarray) -#else -# define CLEAR_ARGARRAY() NOOP -#endif /* USE_ITHREADS */ - +/* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't + * leave any (a fast av_clear(ary), basically) */ +#define CLEAR_ARGARRAY(ary) \ + STMT_START { \ + AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary); \ + SvPVX(ary) = (char*)AvALLOC(ary); \ + AvFILLp(ary) = -1; \ + } STMT_END #define POPSUB(cx,sv) \ STMT_START { \ @@ -124,10 +127,10 @@ struct block_sub { cx->blk_sub.argarray = newAV(); \ av_extend(cx->blk_sub.argarray, fill); \ AvFLAGS(cx->blk_sub.argarray) = AVf_REIFY; \ - PL_curpad[0] = (SV*)cx->blk_sub.argarray; \ + cx->blk_sub.oldcurpad[0] = (SV*)cx->blk_sub.argarray; \ } \ else { \ - CLEAR_ARGARRAY(); \ + CLEAR_ARGARRAY(cx->blk_sub.argarray); \ } \ } \ sv = (SV*)cx->blk_sub.cv; \ @@ -390,7 +393,7 @@ Used to indicate scalar context. See C<GIMME_V>, C<GIMME>, and L<perlcall>. =for apidoc AmU||G_ARRAY -Used to indicate array context. See C<GIMME_V>, C<GIMME> and +Used to indicate list context. See C<GIMME_V>, C<GIMME> and L<perlcall>. =for apidoc AmU||G_VOID @@ -423,12 +426,14 @@ L<perlcall>. #define G_NOARGS 8 /* Don't construct a @_ array. */ #define G_KEEPERR 16 /* Append errors to $@, don't overwrite it */ #define G_NODEBUG 32 /* Disable debugging at toplevel. */ +#define G_METHOD 64 /* Calling method. */ /* flag bits for PL_in_eval */ #define EVAL_NULL 0 /* not in an eval */ #define EVAL_INEVAL 1 /* some enclosing scope is an eval */ #define EVAL_WARNONLY 2 /* used by yywarn() when calling yyerror() */ #define EVAL_KEEPERR 4 /* set by Perl_call_sv if G_KEEPERR */ +#define EVAL_INREQUIRE 8 /* The code is being required. */ /* Support for switching (stack and block) contexts. * This ensures magic doesn't invalidate local stack and cx pointers. @@ -494,7 +499,7 @@ typedef struct stackinfo PERL_SI; * PUTBACK/SPAGAIN to flush/refresh any local SP that may be active */ #define POPSTACK \ STMT_START { \ - djSP; \ + dSP; \ PERL_SI *prev = PL_curstackinfo->si_prev; \ if (!prev) { \ PerlIO_printf(Perl_error_log, "panic: POPSTACK\n"); \ diff --git a/contrib/perl5/cv.h b/contrib/perl5/cv.h index adb424e8eaac..2bce8b2cb8da 100644 --- a/contrib/perl5/cv.h +++ b/contrib/perl5/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. diff --git a/contrib/perl5/deb.c b/contrib/perl5/deb.c index 441487f88eff..dec5c06a15ad 100644 --- a/contrib/perl5/deb.c +++ b/contrib/perl5/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/contrib/perl5/doio.c b/contrib/perl5/doio.c index 0121633c84bd..95690f44e232 100644 --- a/contrib/perl5/doio.c +++ b/contrib/perl5/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 <signal.h> #endif -/* XXX If this causes problems, set i_unistd=undef in the hint file. */ -#ifdef I_UNISTD -# include <unistd.h> -#endif - -#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */ -# include <sys/socket.h> -# if defined(USE_SOCKS) && defined(I_SOCKS) -# include <socks.h> -# endif -# ifdef I_NETBSD -# include <netdb.h> -# endif -# ifndef ENOTSOCK -# ifdef I_NET_ERRNO -# include <net/errno.h> -# 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) @@ -87,7 +67,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, register IO *io = GvIOn(gv); PerlIO *saveifp = Nullfp; PerlIO *saveofp = Nullfp; - char savetype = ' '; + char savetype = IoTYPE_CLOSED; int writing = 0; PerlIO *fp; int fd; @@ -108,7 +88,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (IoIFP(io)) { fd = PerlIO_fileno(IoIFP(io)); - if (IoTYPE(io) == '-') + if (IoTYPE(io) == IoTYPE_STD) result = 0; else if (fd <= PL_maxsysfd) { saveifp = IoIFP(io); @@ -116,7 +96,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, savetype = IoTYPE(io); result = 0; } - else if (IoTYPE(io) == '|') + else if (IoTYPE(io) == IoTYPE_PIPE) result = PerlProc_pclose(IoIFP(io)); else if (IoIFP(io) != IoOFP(io)) { if (IoOFP(io)) { @@ -146,14 +126,14 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, switch (result = rawmode & O_ACCMODE) { case O_RDONLY: - IoTYPE(io) = '<'; + IoTYPE(io) = IoTYPE_RDONLY; break; case O_WRONLY: - IoTYPE(io) = '>'; + IoTYPE(io) = IoTYPE_WRONLY; break; case O_RDWR: default: - IoTYPE(io) = '+'; + IoTYPE(io) = IoTYPE_RDWR; break; } @@ -216,14 +196,14 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } mode[0] = mode[1] = mode[2] = mode[3] = '\0'; IoTYPE(io) = *type; - if (*type == '+' && tlen > 1 && type[tlen-1] != '|') { /* scary */ + if (*type == IoTYPE_RDWR && tlen > 1 && type[tlen-1] != IoTYPE_PIPE) { /* scary */ mode[1] = *type++; --tlen; writing = 1; } - if (*type == '|') { - if (num_svs && (tlen != 2 || type[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); } @@ -234,7 +214,6 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, len = tlen; } if (*name == '\0') { /* command is missing 19990114 */ - dTHR; if (ckWARN(WARN_PIPE)) Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open"); errno = EPIPE; @@ -244,7 +223,6 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, TAINT_ENV(); TAINT_PROPER("piped open"); if (name[len-1] == '|') { - dTHR; name[--len] = '\0' ; if (ckWARN(WARN_PIPE)) Perl_warner(aTHX_ WARN_PIPE, "Can't open bidirectional pipe"); @@ -261,11 +239,12 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } writing = 1; } - else if (*type == '>') { + else if (*type == IoTYPE_WRONLY) { TAINT_PROPER("open"); type++; - if (*type == '>') { - mode[0] = IoTYPE(io) = 'a'; + if (*type == IoTYPE_WRONLY) { + /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */ + mode[0] = IoTYPE(io) = IoTYPE_APPEND; type++; tlen--; } @@ -313,15 +292,30 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, * be optimized away on most platforms; * only Solaris and Linux seem to flush * on that. --jhi */ - PerlIO_seek(fp, 0, SEEK_CUR); +#ifdef USE_SFIO + /* sfio fails to clear error on next + sfwrite, contrary to documentation. + -- Nick Clark */ + if (PerlIO_seek(fp, 0, SEEK_CUR) == -1) + PerlIO_clearerr(fp); +#endif /* On the other hand, do all platforms * take gracefully to flushing a read-only * filehandle? Perhaps we should do * fsetpos(src)+fgetpos(dst)? --nik */ PerlIO_flush(fp); fd = PerlIO_fileno(fp); - if (IoTYPE(thatio) == 's') - IoTYPE(io) = 's'; + /* When dup()ing STDIN, STDOUT or STDERR + * explicitly set appropriate access mode */ + if (IoIFP(thatio) == PerlIO_stdout() + || IoIFP(thatio) == PerlIO_stderr()) + IoTYPE(io) = IoTYPE_WRONLY; + else if (IoIFP(thatio) == PerlIO_stdin()) + IoTYPE(io) = IoTYPE_RDONLY; + /* When dup()ing a socket, say result is + * one as well */ + else if (IoTYPE(thatio) == IoTYPE_SOCKET) + IoTYPE(io) = IoTYPE_SOCKET; } else fd = -1; @@ -339,16 +333,16 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, else { /*SUPPRESS 530*/ for (; isSPACE(*type); type++) ; - if (strEQ(type,"-")) { + if (*type == IoTYPE_STD && !type[1]) { fp = PerlIO_stdout(); - IoTYPE(io) = '-'; + IoTYPE(io) = IoTYPE_STD; } else { fp = PerlIO_open((num_svs ? name : type), mode); } } } - else if (*type == '<') { + else if (*type == IoTYPE_RDONLY) { if (num_svs && tlen != 1) goto unknown_desr; /*SUPPRESS 530*/ @@ -363,16 +357,16 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, name = type; goto duplicity; } - if (strEQ(type,"-")) { + if (*type == IoTYPE_STD && !type[1]) { fp = PerlIO_stdin(); - IoTYPE(io) = '-'; + IoTYPE(io) = IoTYPE_STD; } else fp = PerlIO_open((num_svs ? name : type), mode); } - else if (tlen > 1 && type[tlen-1] == '|') { + else if (tlen > 1 && type[tlen-1] == IoTYPE_PIPE) { if (num_svs) { - if (tlen != 2 || type[0] != '-') + if (tlen != 2 || type[0] != IoTYPE_STD) goto unknown_desr; } else { @@ -384,7 +378,6 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, name = 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; @@ -403,18 +396,18 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, mode = "r"; fp = PerlProc_popen(name,mode); } - IoTYPE(io) = '|'; + IoTYPE(io) = IoTYPE_PIPE; } else { if (num_svs) goto unknown_desr; name = type; - IoTYPE(io) = '<'; + IoTYPE(io) = IoTYPE_RDONLY; /*SUPPRESS 530*/ for (; isSPACE(*name); name++) ; if (strEQ(name,"-")) { fp = PerlIO_stdin(); - IoTYPE(io) = '-'; + IoTYPE(io) = IoTYPE_STD; } else { char *mode; @@ -429,20 +422,17 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } } if (!fp) { - dTHR; - if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == '<' && strchr(name, '\n')) + 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(io) != '-') { - 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; } if (S_ISSOCK(PL_statbuf.st_mode)) - IoTYPE(io) = 's'; /* in case a socket was passed in to us */ + IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */ #ifdef HAS_SOCKET else if ( #ifdef S_IFMT @@ -450,13 +440,15 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, #else !PL_statbuf.st_mode #endif - ) { + && IoTYPE(io) != IoTYPE_WRONLY /* Dups of STD* filehandles already have */ + && IoTYPE(io) != IoTYPE_RDONLY /* type so they aren't marked as sockets */ + ) { /* on OS's that return 0 on fstat()ed pipe */ char tmpbuf[256]; Sock_size_t buflen = sizeof tmpbuf; if (PerlSock_getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf, &buflen) >= 0 || errno != ENOTSOCK) - IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */ + IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */ /* but some return 0 for streams too, sigh */ } #endif @@ -476,11 +468,22 @@ 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); pid = SvIVX(sv); SvIVX(sv) = 0; sv = *av_fetch(PL_fdpid,fd,TRUE); + UNLOCK_FDPID_MUTEX; (void)SvUPGRADE(sv, SVt_IV); SvIVX(sv) = pid; if (!was_fdopen) @@ -501,9 +504,8 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, IoIFP(io) = fp; IoFLAGS(io) &= ~IOf_NOLINE; if (writing) { - dTHR; - if (IoTYPE(io) == 's' - || (IoTYPE(io) == '>' && S_ISCHR(PL_statbuf.st_mode)) ) + if (IoTYPE(io) == IoTYPE_SOCKET + || (IoTYPE(io) == IoTYPE_WRONLY && S_ISCHR(PL_statbuf.st_mode)) ) { char *mode; if (out_raw) @@ -563,7 +565,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); @@ -712,7 +713,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 @@ -771,8 +771,8 @@ Perl_do_pipe(pTHX_ SV *sv, GV *rgv, GV *wgv) IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"); IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"); IoIFP(wstio) = IoOFP(wstio); - IoTYPE(rstio) = '<'; - IoTYPE(wstio) = '>'; + IoTYPE(rstio) = IoTYPE_RDONLY; + IoTYPE(wstio) = IoTYPE_WRONLY; if (!IoIFP(rstio) || !IoOFP(wstio)) { if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio)); else PerlLIO_close(fd[0]); @@ -807,10 +807,8 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit) io = GvIO(gv); if (!io) { /* never opened */ if (not_implicit) { - dTHR; - if (ckWARN(WARN_UNOPENED)) - Perl_warner(aTHX_ WARN_UNOPENED, - "Close on unopened file <%s>",GvENAME(gv)); + if (ckWARN(WARN_UNOPENED)) /* no check for closed here */ + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,SS$_IVCHAN); } return FALSE; @@ -821,7 +819,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit) IoPAGE(io) = 0; IoLINES_LEFT(io) = IoPAGE_LEN(io); } - IoTYPE(io) = ' '; + IoTYPE(io) = IoTYPE_CLOSED; return retval; } @@ -832,7 +830,7 @@ Perl_io_close(pTHX_ IO *io, bool not_implicit) int status; if (IoIFP(io)) { - if (IoTYPE(io) == '|') { + if (IoTYPE(io) == IoTYPE_PIPE) { status = PerlProc_pclose(IoIFP(io)); if (not_implicit) { STATUS_NATIVE_SET(status); @@ -842,7 +840,7 @@ Perl_io_close(pTHX_ IO *io, bool not_implicit) retval = (status != -1); } } - else if (IoTYPE(io) == '-') + else if (IoTYPE(io) == IoTYPE_STD) retval = TRUE; else { if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */ @@ -864,7 +862,6 @@ Perl_io_close(pTHX_ IO *io, bool not_implicit) bool Perl_do_eof(pTHX_ GV *gv) { - dTHR; register IO *io; int ch; @@ -873,13 +870,22 @@ Perl_do_eof(pTHX_ GV *gv) if (!io) return TRUE; else if (ckWARN(WARN_IO) - && (IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout() + && (IoTYPE(io) == IoTYPE_WRONLY || IoIFP(io) == PerlIO_stdout() || IoIFP(io) == PerlIO_stderr())) { - SV* sv = sv_newmortal(); - gv_efullname3(sv, gv, Nullch); - Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output", - SvPV_nolen(sv)); + /* integrate to report_evil_fh()? */ + char *name = NULL; + if (isGV(gv)) { + SV* sv = sv_newmortal(); + gv_efullname4(sv, gv, Nullch, FALSE); + name = SvPV_nolen(sv); + } + if (name && *name) + Perl_warner(aTHX_ WARN_IO, + "Filehandle %s opened only for output", name); + else + Perl_warner(aTHX_ WARN_IO, + "Filehandle opened only for output"); } while (IoIFP(io)) { @@ -921,11 +927,8 @@ Perl_do_tell(pTHX_ GV *gv) #endif return PerlIO_tell(fp); } - { - dTHR; - if (ckWARN(WARN_UNOPENED)) - Perl_warner(aTHX_ WARN_UNOPENED, "tell() on unopened file"); - } + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS$_IFI); return (Off_t)-1; } @@ -943,11 +946,8 @@ Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence) #endif return PerlIO_seek(fp, pos, whence) >= 0; } - { - dTHR; - if (ckWARN(WARN_UNOPENED)) - Perl_warner(aTHX_ WARN_UNOPENED, "seek() on unopened file"); - } + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS$_IFI); return FALSE; } @@ -960,11 +960,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 (ckWARN(WARN_UNOPENED)) - Perl_warner(aTHX_ WARN_UNOPENED, "sysseek() on unopened file"); - } + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS$_IFI); return (Off_t)-1; } @@ -1140,11 +1137,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)) { @@ -1167,7 +1161,7 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) * but only until the system hard limit/the filesystem limit, * at which we would get EPERM. Note that when using buffered * io the write failure can be delayed until the flush/close. --jhi */ - if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp))) + if (len && (PerlIO_write(fp,tmps,len) == 0)) return FALSE; return !PerlIO_error(fp); } @@ -1175,27 +1169,26 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) I32 Perl_my_stat(pTHX) { - djSP; + dSP; IO *io; - GV* tmpgv; + GV* gv; if (PL_op->op_flags & OPf_REF) { EXTEND(SP,1); - tmpgv = cGVOP_gv; + gv = cGVOP_gv; do_fstat: - io = GvIO(tmpgv); + io = GvIO(gv); if (io && IoIFP(io)) { - PL_statgv = tmpgv; + PL_statgv = gv; sv_setpv(PL_statname,""); PL_laststype = OP_STAT; return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache)); } else { - if (tmpgv == PL_defgv) + if (gv == PL_defgv) return PL_laststatval; - if (ckWARN(WARN_UNOPENED)) - Perl_warner(aTHX_ WARN_UNOPENED, "Stat on unopened file <%s>", - GvENAME(tmpgv)); + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); PL_statgv = Nullgv; sv_setpv(PL_statname,""); return (PL_laststatval = -1); @@ -1207,11 +1200,11 @@ Perl_my_stat(pTHX) STRLEN n_a; PUTBACK; if (SvTYPE(sv) == SVt_PVGV) { - tmpgv = (GV*)sv; + gv = (GV*)sv; goto do_fstat; } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { - tmpgv = (GV*)SvRV(sv); + gv = (GV*)SvRV(sv); goto do_fstat; } @@ -1229,7 +1222,7 @@ Perl_my_stat(pTHX) I32 Perl_my_lstat(pTHX) { - djSP; + dSP; SV *sv; STRLEN n_a; if (PL_op->op_flags & OPf_REF) { @@ -1271,7 +1264,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) { @@ -1281,15 +1273,18 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, *a++ = ""; } *a = Nullch; - if (*PL_Argv[0] != '/') /* will execvp use PATH? */ + if (really) + tmps = SvPV(really, n_a); + if ((!really && *PL_Argv[0] != '/') || + (really && *tmps != '/')) /* will execvp use PATH? */ TAINT_ENV(); /* testing IFS here is overkill, probably */ - if (really && *(tmps = SvPV(really, n_a))) - PerlProc_execvp(tmps,PL_Argv); + if (really && *tmps) + 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", - PL_Argv[0], Strerror(errno)); + Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", + (really ? tmps : PL_Argv[0]), Strerror(errno)); if (do_report) { int e = errno; @@ -1419,7 +1414,6 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) goto doshell; } { - dTHR; int e = errno; if (ckWARN(WARN_EXEC)) @@ -1440,7 +1434,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; @@ -1725,7 +1718,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; @@ -1758,7 +1750,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; @@ -1883,7 +1874,6 @@ I32 Perl_do_msgsnd(pTHX_ SV **mark, SV **sp) { #ifdef HAS_MSG - dTHR; SV *mstr; char *mbuf; I32 id, msize, flags; @@ -1906,7 +1896,6 @@ I32 Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) { #ifdef HAS_MSG - dTHR; SV *mstr; char *mbuf; long mtype; @@ -1915,6 +1904,9 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) id = SvIVx(*++mark); mstr = *++mark; + /* suppress warning when reading into undef var --jhi */ + if (! SvOK(mstr)) + sv_setpvn(mstr, "", 0); msize = SvIVx(*++mark); mtype = (long)SvIVx(*++mark); flags = SvIVx(*++mark); @@ -1941,7 +1933,6 @@ I32 Perl_do_semop(pTHX_ SV **mark, SV **sp) { #ifdef HAS_SEM - dTHR; SV *opstr; char *opbuf; I32 id; @@ -1966,7 +1957,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; diff --git a/contrib/perl5/doop.c b/contrib/perl5/doop.c index 06b1b38d5c85..7c0e7321efc8 100644 --- a/contrib/perl5/doop.c +++ b/contrib/perl5/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. @@ -20,39 +20,81 @@ #endif STATIC I32 -S_do_trans_CC_simple(pTHX_ SV *sv) +S_do_trans_simple(pTHX_ SV *sv) { - dTHR; U8 *s; + U8 *d; U8 *send; + U8 *dstart; I32 matches = 0; + I32 grows = PL_op->op_private & OPpTRANS_GROWS; 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; - while (s < send) { - if ((ch = tbl[*s]) >= 0) { - matches++; - *s = ch; + /* First, take care of non-UTF8 input strings, because they're easy */ + if (!SvUTF8(sv)) { + while (s < send) { + if ((ch = tbl[*s]) >= 0) { + matches++; + *s++ = ch; + } + else + s++; } - s++; + SvSETMAGIC(sv); + return matches; } - SvSETMAGIC(sv); + /* Allow for expansion: $_="a".chr(400); tr/a/\xFE/, FE needs encoding */ + if (grows) + New(0, d, len*2+1, U8); + else + d = s; + dstart = d; + while (s < send) { + STRLEN ulen; + UV c; + + /* Need to check this, otherwise 128..255 won't match */ + c = utf8_to_uv(s, send - s, &ulen, 0); + if (c < 0x100 && (ch = tbl[c]) >= 0) { + matches++; + if (UTF8_IS_ASCII(ch)) + *d++ = ch; + else + d = uv_to_utf8(d,ch); + s += ulen; + } + else { /* No match -> copy */ + Copy(s, d, ulen, U8); + d += ulen; + s += ulen; + } + } + if (grows) { + sv_setpvn(sv, (char*)dstart, d - dstart); + Safefree(dstart); + } + else { + *d = '\0'; + SvCUR_set(sv, d - dstart); + } + SvUTF8_on(sv); + SvSETMAGIC(sv); return matches; } STATIC I32 -S_do_trans_CC_count(pTHX_ SV *sv) +S_do_trans_count(pTHX_ SV *sv)/* SPC - OK */ { - dTHR; U8 *s; U8 *send; I32 matches = 0; @@ -61,164 +103,171 @@ S_do_trans_CC_count(pTHX_ SV *sv) 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 (tbl[*s] >= 0) - matches++; - s++; - } + if (!SvUTF8(sv)) + while (s < send) { + if (tbl[*s++] >= 0) + matches++; + } + 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; } STATIC I32 -S_do_trans_CC_complex(pTHX_ SV *sv) +S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */ { - dTHR; U8 *s; U8 *send; U8 *d; + U8 *dstart; + I32 isutf8; I32 matches = 0; + I32 grows = PL_op->op_private & OPpTRANS_GROWS; 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_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 ((ch = tbl[*s]) >= 0) { - *d = ch; - matches++; - if (p == d - 1 && *p == *d) - matches--; - else - p = d++; + 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) + p = d++; + } + else if (ch == -1) /* -1 is unmapped character */ + *d++ = *s; + else if (ch == -2) /* -2 is delete character */ + matches++; + s++; } - else if (ch == -1) /* -1 is unmapped character */ - *d++ = *s; /* -2 is delete character */ - s++; } - } - else { - while (s < send) { - if ((ch = tbl[*s]) >= 0) { - *d = ch; - matches++; - d++; + else { + while (s < send) { + if ((ch = tbl[*s]) >= 0) { + matches++; + *d++ = ch; + } + else if (ch == -1) /* -1 is unmapped character */ + *d++ = *s; + else if (ch == -2) /* -2 is delete character */ + matches++; + s++; } - else if (ch == -1) /* -1 is unmapped character */ - *d++ = *s; /* -2 is delete character */ - s++; } + *d = '\0'; + SvCUR_set(sv, d - dstart); } - 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_UU_simple(pTHX_ SV *sv) -{ - dTHR; - U8 *s; - U8 *send; - U8 *d; - I32 matches = 0; - STRLEN len; - - SV* rv = (SV*)cSVOP->op_sv; - HV* hv = (HV*)SvRV(rv); - SV** svp = hv_fetch(hv, "NONE", 4, FALSE); - UV none = svp ? SvUV(*svp) : 0x7fffffff; - UV extra = none + 1; - UV final; - UV uv; + else { /* isutf8 */ + if (grows) + New(0, d, len*2+1, U8); + else + d = s; + dstart = d; - s = (U8*)SvPV(sv, len); - send = s + len; +#ifdef MACOS_TRADITIONAL +#define comp CoMP /* "comp" is a keyword in some compilers ... */ +#endif - svp = hv_fetch(hv, "FINAL", 5, FALSE); - if (svp) - final = SvUV(*svp); + 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); - d = s; - while (s < send) { - if ((uv = swash_fetch(rv, s)) < none) { - s += UTF8SKIP(s); - matches++; - d = uv_to_utf8(d, uv); + if (comp > 0xff) { /* always unmapped */ + Copy(s, d, len, U8); + d += len; + } + 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 */ + Copy(s, d, len, U8); + d += len; + } + else if (ch == -2) /* -2 is delete character */ + matches++; + s += len; + pch = 0xfeedface; + } } - else if (uv == none) { - int i; - for (i = UTF8SKIP(s); i; i--) - *d++ = *s++; + else { + while (s < send) { + STRLEN len; + UV comp = utf8_to_uv_simple(s, &len); + if (comp > 0xff) { /* always unmapped */ + Copy(s, d, len, U8); + d += len; + } + else if ((ch = tbl[comp]) >= 0) { + d = uv_to_utf8(d, ch); + matches++; + } + else if (ch == -1) { /* -1 is unmapped character */ + Copy(s, d, len, U8); + d += len; + } + else if (ch == -2) /* -2 is delete character */ + matches++; + s += len; + } } - else if (uv == extra) { - s += UTF8SKIP(s); - matches++; - d = uv_to_utf8(d, final); + if (grows) { + sv_setpvn(sv, (char*)dstart, d - dstart); + Safefree(dstart); } - else - s += UTF8SKIP(s); + else { + *d = '\0'; + SvCUR_set(sv, d - dstart); + } + SvUTF8_on(sv); } - *d = '\0'; - SvCUR_set(sv, d - (U8*)SvPVX(sv)); SvSETMAGIC(sv); - - return matches; -} - -STATIC I32 -S_do_trans_UU_count(pTHX_ SV *sv) -{ - dTHR; - U8 *s; - U8 *send; - I32 matches = 0; - STRLEN len; - - SV* rv = (SV*)cSVOP->op_sv; - HV* hv = (HV*)SvRV(rv); - SV** svp = hv_fetch(hv, "NONE", 4, FALSE); - UV none = svp ? SvUV(*svp) : 0x7fffffff; - UV uv; - - s = (U8*)SvPV(sv, len); - send = s + len; - - while (s < send) { - if ((uv = swash_fetch(rv, s)) < none) - matches++; - s += UTF8SKIP(s); - } - return matches; } STATIC I32 -S_do_trans_UC_simple(pTHX_ SV *sv) +S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */ { - dTHR; U8 *s; U8 *send; U8 *d; + U8 *start; + U8 *dstart, *dend; I32 matches = 0; + I32 grows = PL_op->op_private & OPpTRANS_GROWS; STRLEN len; SV* rv = (SV*)cSVOP->op_sv; @@ -228,50 +277,91 @@ S_do_trans_UC_simple(pTHX_ SV *sv) UV extra = none + 1; UV final; UV uv; + 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_CONTINUED(*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); - d = s; + if (grows) { + /* d needs to be bigger than s, in case e.g. upgrading is required */ + New(0, d, len*3+UTF8_MAXLEN, U8); + dend = d + len * 3; + dstart = d; + } + else { + dstart = d = s; + dend = d + len; + } + while (s < send) { if ((uv = swash_fetch(rv, s)) < none) { s += UTF8SKIP(s); matches++; - *d++ = (U8)uv; + d = uv_to_utf8(d, uv); } else if (uv == none) { - I32 ulen; - uv = utf8_to_uv(s, &ulen); - s += ulen; - *d++ = (U8)uv; + int i = UTF8SKIP(s); + Copy(s, d, i, U8); + d += i; + s += i; } else if (uv == extra) { - s += UTF8SKIP(s); + int i = UTF8SKIP(s); + s += i; matches++; - *d++ = (U8)final; + d = uv_to_utf8(d, final); } else s += UTF8SKIP(s); + + if (d > dend) { + STRLEN clen = d - dstart; + STRLEN nlen = dend - dstart + len + UTF8_MAXLEN; + if (!grows) + Perl_croak(aTHX_ "panic: do_trans_complex_utf8"); + Renew(dstart, nlen+UTF8_MAXLEN, U8); + d = dstart + clen; + dend = dstart + nlen; + } + } + if (grows || hibit) { + sv_setpvn(sv, (char*)dstart, d - dstart); + Safefree(dstart); + if (grows && hibit) + Safefree(start); + } + else { + *d = '\0'; + SvCUR_set(sv, d - dstart); } - *d = '\0'; - SvCUR_set(sv, d - (U8*)SvPVX(sv)); SvSETMAGIC(sv); + SvUTF8_on(sv); + if (!isutf8 && !(PL_hints & HINT_UTF8)) + sv_utf8_downgrade(sv, TRUE); return matches; } STATIC I32 -S_do_trans_CU_simple(pTHX_ SV *sv) +S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */ { - dTHR; U8 *s; - U8 *send; - U8 *d; - U8 *dst; + U8 *start, *send; I32 matches = 0; STRLEN len; @@ -279,132 +369,41 @@ S_do_trans_CU_simple(pTHX_ SV *sv) HV* hv = (HV*)SvRV(rv); SV** svp = hv_fetch(hv, "NONE", 4, FALSE); UV none = svp ? SvUV(*svp) : 0x7fffffff; - UV extra = none + 1; - UV final; UV uv; - U8 tmpbuf[UTF8_MAXLEN]; - I32 bits = 16; - - s = (U8*)SvPV(sv, len); - send = s + len; - - svp = hv_fetch(hv, "BITS", 4, FALSE); - if (svp) - bits = (I32)SvIV(*svp); - - svp = hv_fetch(hv, "FINAL", 5, FALSE); - if (svp) - final = SvUV(*svp); - - Newz(801, d, len * (bits >> 3) + 1, U8); - dst = d; - - while (s < send) { - uv = *s++; - if (uv < 0x80) - tmpbuf[0] = uv; - else { - tmpbuf[0] = (( uv >> 6) | 0xc0); - tmpbuf[1] = (( uv & 0x3f) | 0x80); - } - - if ((uv = swash_fetch(rv, tmpbuf)) < none) { - matches++; - d = uv_to_utf8(d, uv); - } - else if (uv == none) - d = uv_to_utf8(d, s[-1]); - else if (uv == extra) { - matches++; - d = uv_to_utf8(d, final); - } - } - *d = '\0'; - sv_usepvn_mg(sv, (char*)dst, d - dst); - - return matches; -} - -/* utf-8 to latin-1 */ - -STATIC I32 -S_do_trans_UC_trivial(pTHX_ SV *sv) -{ - dTHR; - U8 *s; - U8 *send; - U8 *d; - STRLEN len; + U8 hibit = 0; s = (U8*)SvPV(sv, len); - send = s + len; - - d = s; - while (s < send) { - if (*s < 0x80) - *d++ = *s++; - else { - I32 ulen; - UV uv = utf8_to_uv(s, &ulen); - s += ulen; - *d++ = (U8)uv; - } + 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); } - *d = '\0'; - SvCUR_set(sv, d - (U8*)SvPVX(sv)); - SvSETMAGIC(sv); - - return SvCUR(sv); -} - -/* latin-1 to utf-8 */ - -STATIC I32 -S_do_trans_CU_trivial(pTHX_ SV *sv) -{ - dTHR; - U8 *s; - U8 *send; - U8 *d; - U8 *dst; - I32 matches; - STRLEN len; - - s = (U8*)SvPV(sv, len); send = s + len; - Newz(801, d, len * 2 + 1, U8); - dst = d; - - matches = send - s; - while (s < send) { - if (*s < 0x80) - *d++ = *s++; - else { - UV uv = *s++; - *d++ = (( uv >> 6) | 0xc0); - *d++ = (( uv & 0x3f) | 0x80); - } + if ((uv = swash_fetch(rv, s)) < none) + matches++; + s += UTF8SKIP(s); } - *d = '\0'; - sv_usepvn_mg(sv, (char*)dst, d - dst); + if (hibit) + Safefree(start); return matches; } STATIC I32 -S_do_trans_UU_complex(pTHX_ SV *sv) +S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */ { - dTHR; U8 *s; - U8 *send; + U8 *start, *send; U8 *d; I32 matches = 0; I32 squash = PL_op->op_private & OPpTRANS_SQUASH; - I32 from_utf = PL_op->op_private & OPpTRANS_FROM_UTF; - I32 to_utf = PL_op->op_private & OPpTRANS_TO_UTF; I32 del = PL_op->op_private & OPpTRANS_DELETE; + I32 grows = PL_op->op_private & OPpTRANS_GROWS; SV* rv = (SV*)cSVOP->op_sv; HV* hv = (HV*)SvRV(rv); SV** svp = hv_fetch(hv, "NONE", 4, FALSE); @@ -413,166 +412,130 @@ S_do_trans_UU_complex(pTHX_ SV *sv) UV final; UV uv; STRLEN len; - U8 *dst; + 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); - if (PL_op->op_private & OPpTRANS_GROWS) { - I32 bits = 16; - - svp = hv_fetch(hv, "BITS", 4, FALSE); - if (svp) - bits = (I32)SvIV(*svp); - - Newz(801, d, len * (bits >> 3) + 1, U8); - dst = d; + if (grows) { + /* d needs to be bigger than s, in case e.g. upgrading is required */ + New(0, d, len*3+UTF8_MAXLEN, U8); + dend = d + len * 3; + dstart = d; } else { - d = s; - dst = 0; + dstart = d = s; + dend = d + len; } if (squash) { UV puv = 0xfeedface; while (s < send) { - if (from_utf) { - 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; + STRLEN nlen = dend - dstart + len + UTF8_MAXLEN; + if (!grows) + Perl_croak(aTHX_ "panic: do_trans_complex_utf8"); + Renew(dstart, nlen+UTF8_MAXLEN, U8); + d = dstart + clen; + dend = dstart + nlen; } if (uv < none) { matches++; if (uv != puv) { - if (uv >= 0x80 && to_utf) - d = uv_to_utf8(d, uv); - else - *d++ = (U8)uv; + d = uv_to_utf8(d, uv); puv = uv; } - if (from_utf) - s += UTF8SKIP(s); + s += UTF8SKIP(s); continue; } else if (uv == none) { /* "none" is unmapped character */ - if (from_utf) { - if (*s < 0x80) - *d++ = *s++; - else if (to_utf) { - int i; - for (i = UTF8SKIP(s); i; --i) - *d++ = *s++; - } - else { - I32 ulen; - *d++ = (U8)utf8_to_uv(s, &ulen); - s += ulen; - } - } - else { /* must be to_utf only */ - d = uv_to_utf8(d, s[-1]); - } + int i = UTF8SKIP(s); + Copy(s, d, i, U8); + d += i; + s += i; puv = 0xfeedface; continue; } else if (uv == extra && !del) { matches++; if (uv != puv) { - if (final >= 0x80 && to_utf) - d = uv_to_utf8(d, final); - else - *d++ = (U8)final; + d = uv_to_utf8(d, final); puv = final; } - if (from_utf) - s += UTF8SKIP(s); + s += UTF8SKIP(s); continue; } - matches++; /* "none+1" is delete character */ - if (from_utf) - s += UTF8SKIP(s); + matches++; /* "none+1" is delete character */ + s += UTF8SKIP(s); } } else { while (s < send) { - if (from_utf) { - 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; + STRLEN nlen = dend - dstart + len + UTF8_MAXLEN; + if (!grows) + Perl_croak(aTHX_ "panic: do_trans_complex_utf8"); + Renew(dstart, nlen+UTF8_MAXLEN, U8); + d = dstart + clen; + dend = dstart + nlen; } if (uv < none) { matches++; - if (uv >= 0x80 && to_utf) - d = uv_to_utf8(d, uv); - else - *d++ = (U8)uv; - if (from_utf) - s += UTF8SKIP(s); + d = uv_to_utf8(d, uv); + s += UTF8SKIP(s); continue; } else if (uv == none) { /* "none" is unmapped character */ - if (from_utf) { - if (*s < 0x80) - *d++ = *s++; - else if (to_utf) { - int i; - for (i = UTF8SKIP(s); i; --i) - *d++ = *s++; - } - else { - I32 ulen; - *d++ = (U8)utf8_to_uv(s, &ulen); - s += ulen; - } - } - else { /* must be to_utf only */ - d = uv_to_utf8(d, s[-1]); - } + int i = UTF8SKIP(s); + Copy(s, d, i, U8); + d += i; + s += i; continue; } else if (uv == extra && !del) { matches++; - if (final >= 0x80 && to_utf) - d = uv_to_utf8(d, final); - else - *d++ = (U8)final; - if (from_utf) - s += UTF8SKIP(s); + d = uv_to_utf8(d, final); + s += UTF8SKIP(s); continue; } - matches++; /* "none+1" is delete character */ - if (from_utf) - s += UTF8SKIP(s); + matches++; /* "none+1" is delete character */ + s += UTF8SKIP(s); } } - if (dst) - sv_usepvn(sv, (char*)dst, d - dst); + if (grows || hibit) { + sv_setpvn(sv, (char*)dstart, d - dstart); + Safefree(dstart); + if (grows && hibit) + Safefree(start); + } else { *d = '\0'; - SvCUR_set(sv, d - (U8*)SvPVX(sv)); + SvCUR_set(sv, d - dstart); } + SvUTF8_on(sv); + if (!isutf8 && !(PL_hints & HINT_UTF8)) + sv_utf8_downgrade(sv, TRUE); SvSETMAGIC(sv); return matches; @@ -581,8 +544,9 @@ S_do_trans_UU_complex(pTHX_ SV *sv) I32 Perl_do_trans(pTHX_ SV *sv) { - dTHR; STRLEN len; + I32 hasutf = (PL_op->op_private & + (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)); if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL)) Perl_croak(aTHX_ PL_no_modify); @@ -592,40 +556,29 @@ Perl_do_trans(pTHX_ SV *sv) return 0; if (!SvPOKp(sv)) (void)SvPV_force(sv, len); - (void)SvPOK_only(sv); + if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) + (void)SvPOK_only_UTF8(sv); DEBUG_t( Perl_deb(aTHX_ "2.TBL\n")); - switch (PL_op->op_private & 63) { + switch (PL_op->op_private & ~hasutf & 63) { case 0: - return do_trans_CC_simple(sv); - - case OPpTRANS_FROM_UTF: - return do_trans_UC_simple(sv); - - case OPpTRANS_TO_UTF: - return do_trans_CU_simple(sv); - - case OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF: - return do_trans_UU_simple(sv); + if (hasutf) + return do_trans_simple_utf8(sv); + else + return do_trans_simple(sv); case OPpTRANS_IDENTICAL: - return do_trans_CC_count(sv); - - case OPpTRANS_FROM_UTF|OPpTRANS_IDENTICAL: - return do_trans_UC_trivial(sv); - - case OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL: - return do_trans_CU_trivial(sv); - - case OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL: - return do_trans_UU_count(sv); + if (hasutf) + return do_trans_count_utf8(sv); + else + return do_trans_count(sv); default: - if (PL_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) - return do_trans_UU_complex(sv); /* could be UC or CU too */ + if (hasutf) + return do_trans_complex_utf8(sv); else - return do_trans_CC_complex(sv); + return do_trans_complex(sv); } } @@ -644,7 +597,7 @@ Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **s (void)SvUPGRADE(sv, SVt_PV); if (SvLEN(sv) < len + items) { /* current length is way too short */ while (items-- > 0) { - if (*mark && !SvGMAGICAL(*mark) && SvOK(*mark)) { + if (*mark && !SvGAMAGIC(*mark) && SvOK(*mark)) { SvPV(*mark, tmplen); len += tmplen; } @@ -658,22 +611,16 @@ Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **s } if (items-- > 0) { - char *s; - - if (*mark) { - s = SvPV(*mark, tmplen); - sv_setpvn(sv, s, tmplen); - } - else - sv_setpv(sv, ""); + sv_setpv(sv, ""); + if (*mark) + sv_catsv(sv, *mark); mark++; } 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); } } @@ -697,6 +644,7 @@ Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg) SvTAINTED_on(sv); } +/* currently converts input to bytes if possible, but doesn't sweat failure */ UV Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) { @@ -706,8 +654,12 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) if (offset < 0) return retnum; - if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ + 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)) + (void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE); + offset *= size; /* turn into bit offset */ len = (offset + size + 7) / 8; /* required number of bytes */ if (len > srclen) { @@ -739,7 +691,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"); @@ -779,7 +730,7 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) ((UV) s[offset + 4] << 24) + ((UV) s[offset + 5] << 16); else - retnum = + retnum = ((UV) s[offset ] << 56) + ((UV) s[offset + 1] << 48) + ((UV) s[offset + 2] << 40) + @@ -809,7 +760,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"); @@ -829,6 +779,10 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) return retnum; } +/* currently converts input to bytes if possible but doesn't sweat failures, + * although it does ensure that the string it clobbers is not marked as + * utf8-valid any more + */ void Perl_do_vecset(pTHX_ SV *sv) { @@ -844,12 +798,23 @@ Perl_do_vecset(pTHX_ SV *sv) if (!targ) return; s = (unsigned char*)SvPV_force(targ, targlen); + if (SvUTF8(targ)) { + /* This is handled by the SvPOK_only below... + if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE)) + SvUTF8_off(targ); + */ + (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE); + } + + (void)SvPOK_only(targ); lval = SvUV(sv); offset = LvTARGOFF(sv); + if (offset < 0) + Perl_croak(aTHX_ "Assigning to negative offset in vec"); size = LvTARGLEN(sv); - if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ + if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ Perl_croak(aTHX_ "Illegal number of bits in vec"); - + offset *= size; /* turn into bit offset */ len = (offset + size + 7) / 8; /* required number of bytes */ if (len > targlen) { @@ -857,7 +822,7 @@ Perl_do_vecset(pTHX_ SV *sv) (void)memzero(s + targlen, len - targlen + 1); SvCUR_set(targ, len); } - + if (size < 8) { mask = (1 << size) - 1; size = offset & 7; @@ -882,7 +847,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"); @@ -905,8 +869,7 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv) { STRLEN len; char *s; - dTHR; - + if (SvTYPE(sv) == SVt_PVAV) { register I32 i; I32 max; @@ -938,15 +901,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); @@ -967,7 +930,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; @@ -1040,12 +1002,11 @@ Perl_do_chomp(pTHX_ register SV *sv) nope: SvSETMAGIC(sv); return count; -} +} 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; @@ -1062,10 +1023,11 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) char *rsave; bool left_utf = DO_UTF8(left); bool right_utf = DO_UTF8(right); + I32 needlen; if (left_utf && !right_utf) sv_utf8_upgrade(right); - 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))) @@ -1074,17 +1036,23 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) rsave = rc = SvPV(right, rightlen); len = leftlen < rightlen ? leftlen : rightlen; lensave = len; - if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) { + if ((left_utf || right_utf) && (sv == left || sv == right)) { + needlen = optype == OP_BIT_AND ? len : leftlen + rightlen; + Newz(801, dc, needlen + 1, char); + } + else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) { STRLEN n_a; dc = SvPV_force(sv, n_a); if (SvCUR(sv) < len) { dc = SvGROW(sv, len + 1); (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1); } + if (optype != OP_BIT_AND && (left_utf || right_utf)) + dc = SvGROW(sv, leftlen + rightlen + 1); } else { - I32 needlen = ((optype == OP_BIT_AND) - ? len : (leftlen > rightlen ? leftlen : rightlen)); + needlen = ((optype == OP_BIT_AND) + ? len : (leftlen > rightlen ? leftlen : rightlen)); Newz(801, dc, needlen + 1, char); (void)sv_usepvn(sv, dc, needlen); dc = SvPVX(sv); /* sv_usepvn() calls Renew() */ @@ -1093,35 +1061,33 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) (void)SvPOK_only(sv); if (left_utf || right_utf) { UV duc, luc, ruc; + char *dcsave = dc; STRLEN lulen = leftlen; STRLEN rulen = rightlen; - STRLEN dulen = 0; - I32 ulen; - - if (optype != OP_BIT_AND) - dc = SvGROW(sv, leftlen+rightlen+1); + STRLEN ulen; switch (optype) { case OP_BIT_AND: while (lulen && rulen) { - luc = utf8_to_uv((U8*)lc, &ulen); + luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); lc += ulen; lulen -= ulen; - ruc = utf8_to_uv((U8*)rc, &ulen); + ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); rc += ulen; rulen -= ulen; duc = luc & ruc; dc = (char*)uv_to_utf8((U8*)dc, duc); } - dulen = dc - SvPVX(sv); - SvCUR_set(sv, dulen); + if (sv == left || sv == right) + (void)sv_usepvn(sv, dcsave, needlen); + SvCUR_set(sv, dc - dcsave); break; case OP_BIT_XOR: while (lulen && rulen) { - luc = utf8_to_uv((U8*)lc, &ulen); + luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); lc += ulen; lulen -= ulen; - ruc = utf8_to_uv((U8*)rc, &ulen); + ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); rc += ulen; rulen -= ulen; duc = luc ^ ruc; @@ -1130,18 +1096,19 @@ 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((U8*)lc, &ulen); + luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); lc += ulen; lulen -= ulen; - ruc = utf8_to_uv((U8*)rc, &ulen); + ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); rc += ulen; rulen -= ulen; duc = luc | ruc; dc = (char*)uv_to_utf8((U8*)dc, duc); } mop_up_utf: - dulen = dc - SvPVX(sv); - SvCUR_set(sv, dulen); + if (sv == left || sv == right) + (void)sv_usepvn(sv, dcsave, needlen); + SvCUR_set(sv, dc - dcsave); if (rulen) sv_catpvn(sv, rc, rulen); else if (lulen) @@ -1231,7 +1198,7 @@ finish: OP * Perl_do_kv(pTHX) { - djSP; + dSP; HV *hv = (HV*)POPs; HV *keys; register HE *entry; @@ -1240,12 +1207,12 @@ Perl_do_kv(pTHX) I32 dokeys = (PL_op->op_type == OP_KEYS); I32 dovalues = (PL_op->op_type == OP_VALUES); I32 realhv = (SvTYPE(hv) == SVt_PVHV); - - if (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV) + + if (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV) dokeys = dovalues = TRUE; if (!hv) { - if (PL_op->op_flags & OPf_MOD) { /* lvalue */ + if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */ dTARGET; /* make sure to clear its target here */ if (SvTYPE(TARG) == SVt_PVLV) LvTARG(TARG) = Nullsv; @@ -1264,7 +1231,7 @@ Perl_do_kv(pTHX) IV i; dTARGET; - if (PL_op->op_flags & OPf_MOD) { /* lvalue */ + if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */ if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); sv_magic(TARG, Nullsv, 'k', Nullch, 0); diff --git a/contrib/perl5/dosish.h b/contrib/perl5/dosish.h index 08b48fa0fe80..5f12b9d1b27a 100644 --- a/contrib/perl5/dosish.h +++ b/contrib/perl5/dosish.h @@ -100,7 +100,11 @@ #define fwrite1 fwrite #define Fstat(fd,bufptr) fstat((fd),(bufptr)) -#define Fflush(fp) fflush(fp) +#ifdef DJGPP +# define Fflush(fp) djgpp_fflush(fp) +#else +# define Fflush(fp) fflush(fp) +#endif #define Mkdir(path,mode) mkdir((path),(mode)) #ifndef WIN32 diff --git a/contrib/perl5/dump.c b/contrib/perl5/dump.c index 86c56ce8c88f..c9a788cee16f 100644 --- a/contrib/perl5/dump.c +++ b/contrib/perl5/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; @@ -279,9 +276,9 @@ Perl_sv_peek(pTHX_ SV *sv) } } else if (SvNOKp(sv)) { - RESTORE_NUMERIC_STANDARD(); + STORE_NUMERIC_LOCAL_SET_STANDARD(); Perl_sv_catpvf(aTHX_ t, "(%g)",SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); + RESTORE_NUMERIC_LOCAL(); } else if (SvIOKp(sv)) { if (SvIsUV(sv)) @@ -369,7 +366,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 +453,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,8 +765,7 @@ 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 = sv_newmortal(); + SV *d; char *s; U32 flags; U32 type; @@ -783,7 +779,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo flags = SvFLAGS(sv); type = SvTYPE(sv); - Perl_sv_setpvf(aTHX_ d, + d = Perl_newSVpvf(aTHX_ "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (", PTR2UV(SvANY(sv)), PTR2UV(sv), (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv), @@ -824,6 +820,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (CvCLONED(sv)) sv_catpv(d, "CLONED,"); if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,"); if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,"); + if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,"); + if (CvMETHOD(sv)) sv_catpv(d, "METHOD,"); break; case SVt_PVHV: if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,"); @@ -833,6 +831,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (GvINTRO(sv)) sv_catpv(d, "INTRO,"); if (GvMULTI(sv)) sv_catpv(d, "MULTI,"); if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,"); + if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,"); if (GvIMPORTED(sv)) { sv_catpv(d, "IMPORT"); if (GvIMPORTED(sv) == GVf_IMPORTED) @@ -867,6 +866,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo switch (type) { case SVt_NULL: PerlIO_printf(file, "NULL%s\n", s); + SvREFCNT_dec(d); return; case SVt_IV: PerlIO_printf(file, "IV%s\n", s); @@ -915,6 +915,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo break; default: PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s); + SvREFCNT_dec(d); return; } if (type >= SVt_PVIV || type == SVt_IV) { @@ -927,7 +928,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo PerlIO_putc(file, '\n'); } if (type >= SVt_PVNV || type == SVt_NV) { - RESTORE_NUMERIC_STANDARD(); + STORE_NUMERIC_LOCAL_SET_STANDARD(); /* %Vg doesn't work? --jhi */ #ifdef USE_LONG_DOUBLE Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv)); @@ -940,10 +941,13 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv))); if (nest < maxnest) do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim); + SvREFCNT_dec(d); return; } - if (type < SVt_PV) + if (type < SVt_PV) { + SvREFCNT_dec(d); return; + } if (type <= SVt_PVLV) { if (SvPVX(sv)) { Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX(sv))); @@ -1042,7 +1046,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo theoret = HvKEYS(sv); theoret += theoret * theoret/pow2; PerlIO_putc(file, '\n'); - Perl_dump_indent(aTHX_ level, file, " hash quality = %.1f%%", theoret/sum*100); + Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100); } PerlIO_putc(file, '\n'); Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv)); @@ -1178,6 +1182,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv)); break; } + SvREFCNT_dec(d); } void diff --git a/contrib/perl5/embed.h b/contrib/perl5/embed.h index d372b2068728..78fa0890bd4f 100644 --- a/contrib/perl5/embed.h +++ b/contrib/perl5/embed.h @@ -71,6 +71,7 @@ #define append_elem Perl_append_elem #define append_list Perl_append_list #define apply Perl_apply +#define apply_attrs_string Perl_apply_attrs_string #define avhv_delete_ent Perl_avhv_delete_ent #define avhv_exists_ent Perl_avhv_exists_ent #define avhv_fetch_ent Perl_avhv_fetch_ent @@ -129,6 +130,7 @@ #define sv_catpvf_mg_nocontext Perl_sv_catpvf_mg_nocontext #define sv_setpvf_mg_nocontext Perl_sv_setpvf_mg_nocontext #define fprintf_nocontext Perl_fprintf_nocontext +#define printf_nocontext Perl_printf_nocontext #endif #define cv_ckproto Perl_cv_ckproto #define cv_clone Perl_cv_clone @@ -229,6 +231,7 @@ #define gv_check Perl_gv_check #define gv_efullname Perl_gv_efullname #define gv_efullname3 Perl_gv_efullname3 +#define gv_efullname4 Perl_gv_efullname4 #define gv_fetchfile Perl_gv_fetchfile #define gv_fetchmeth Perl_gv_fetchmeth #define gv_fetchmethod Perl_gv_fetchmethod @@ -236,6 +239,7 @@ #define gv_fetchpv Perl_gv_fetchpv #define gv_fullname Perl_gv_fullname #define gv_fullname3 Perl_gv_fullname3 +#define gv_fullname4 Perl_gv_fullname4 #define gv_init Perl_gv_init #define gv_stashpv Perl_gv_stashpv #define gv_stashpvn Perl_gv_stashpvn @@ -269,6 +273,8 @@ #define instr Perl_instr #define io_close Perl_io_close #define invert Perl_invert +#define is_gv_magical Perl_is_gv_magical +#define is_lvalue_sub Perl_is_lvalue_sub #define is_uni_alnum Perl_is_uni_alnum #define is_uni_alnumc Perl_is_uni_alnumc #define is_uni_idfirst Perl_is_uni_idfirst @@ -304,6 +310,7 @@ #define to_uni_title_lc Perl_to_uni_title_lc #define to_uni_lower_lc Perl_to_uni_lower_lc #define is_utf8_char Perl_is_utf8_char +#define is_utf8_string Perl_is_utf8_string #define is_utf8_alnum Perl_is_utf8_alnum #define is_utf8_alnumc Perl_is_utf8_alnumc #define is_utf8_idfirst Perl_is_utf8_idfirst @@ -356,6 +363,7 @@ #define magic_nextpack Perl_magic_nextpack #define magic_regdata_cnt Perl_magic_regdata_cnt #define magic_regdatum_get Perl_magic_regdatum_get +#define magic_regdatum_set Perl_magic_regdatum_set #define magic_set Perl_magic_set #define magic_setamagic Perl_magic_setamagic #define magic_setarylen Perl_magic_setarylen @@ -570,6 +578,7 @@ #define save_freeop Perl_save_freeop #define save_freepv Perl_save_freepv #define save_generic_svref Perl_save_generic_svref +#define save_generic_pvref Perl_save_generic_pvref #define save_gp Perl_save_gp #define save_hash Perl_save_hash #define save_helem Perl_save_helem @@ -583,12 +592,14 @@ #define save_iv Perl_save_iv #define save_list Perl_save_list #define save_long Perl_save_long +#define save_mortalizesv Perl_save_mortalizesv #define save_nogv Perl_save_nogv #define save_op Perl_save_op #define save_scalar Perl_save_scalar #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 @@ -717,14 +728,19 @@ #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_from_utf8 Perl_bytes_from_utf8 +#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 uv_to_utf8 Perl_uv_to_utf8 #define vivify_defelem Perl_vivify_defelem #define vivify_ref Perl_vivify_ref #define wait4pid Perl_wait4pid -#define report_closed_fh Perl_report_closed_fh +#define report_evil_fh Perl_report_evil_fh #define report_uninit Perl_report_uninit #define warn Perl_warn #define vwarn Perl_vwarn @@ -733,11 +749,10 @@ #define watch Perl_watch #define whichsig Perl_whichsig #define yyerror Perl_yyerror -#if defined(USE_PURE_BISON) -#define yylex Perl_yylex -#else -#define yylex Perl_yylex +#ifdef USE_PURE_BISON +#define yylex_r Perl_yylex_r #endif +#define yylex Perl_yylex #define yyparse Perl_yyparse #define yywarn Perl_yywarn #if defined(MYMALLOC) @@ -759,6 +774,9 @@ #endif #define runops_standard Perl_runops_standard #define runops_debug Perl_runops_debug +#if defined(USE_THREADS) +#define sv_lock Perl_sv_lock +#endif #define sv_catpvf_mg Perl_sv_catpvf_mg #define sv_vcatpvf_mg Perl_sv_vcatpvf_mg #define sv_catpv_mg Perl_sv_catpv_mg @@ -802,6 +820,8 @@ #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_add_backref Perl_sv_add_backref +#define sv_del_backref Perl_sv_del_backref #define tmps_grow Perl_tmps_grow #define sv_rvweaken Perl_sv_rvweaken #define magic_killbackrefs Perl_magic_killbackrefs @@ -829,6 +849,12 @@ #define ptr_table_fetch Perl_ptr_table_fetch #define ptr_table_store Perl_ptr_table_store #define ptr_table_split Perl_ptr_table_split +#define ptr_table_clear Perl_ptr_table_clear +#define ptr_table_free Perl_ptr_table_free +#endif +#if defined(HAVE_INTERP_INTERN) +#define sys_intern_clear Perl_sys_intern_clear +#define sys_intern_init Perl_sys_intern_init #endif #if defined(PERL_OBJECT) #else @@ -838,16 +864,12 @@ #define avhv_index S_avhv_index #endif #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) -#define do_trans_CC_simple S_do_trans_CC_simple -#define do_trans_CC_count S_do_trans_CC_count -#define do_trans_CC_complex S_do_trans_CC_complex -#define do_trans_UU_simple S_do_trans_UU_simple -#define do_trans_UU_count S_do_trans_UU_count -#define do_trans_UU_complex S_do_trans_UU_complex -#define do_trans_UC_simple S_do_trans_UC_simple -#define do_trans_CU_simple S_do_trans_CU_simple -#define do_trans_UC_trivial S_do_trans_UC_trivial -#define do_trans_CU_trivial S_do_trans_CU_trivial +#define do_trans_simple S_do_trans_simple +#define do_trans_count S_do_trans_count +#define do_trans_complex S_do_trans_complex +#define do_trans_simple_utf8 S_do_trans_simple_utf8 +#define do_trans_count_utf8 S_do_trans_count_utf8 +#define do_trans_complex_utf8 S_do_trans_complex_utf8 #endif #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT) #define gv_init_sv S_gv_init_sv @@ -876,6 +898,7 @@ #define scalarboolean S_scalarboolean #define too_few_arguments S_too_few_arguments #define too_many_arguments S_too_many_arguments +#define trlist_upgrade S_trlist_upgrade #define op_clear S_op_clear #define null S_null #define pad_addlex S_pad_addlex @@ -949,7 +972,6 @@ #define dopoptoloop S_dopoptoloop #define dopoptosub S_dopoptosub #define dopoptosub_at S_dopoptosub_at -#define free_closures S_free_closures #define save_lines S_save_lines #define doeval S_doeval #define doopen_pmc S_doopen_pmc @@ -1063,8 +1085,6 @@ #define sv_unglob S_sv_unglob #define not_a_number S_not_a_number #define visit S_visit -#define sv_add_backref S_sv_add_backref -#define sv_del_backref S_sv_del_backref # if defined(DEBUGGING) #define del_sv S_del_sv # endif @@ -1086,6 +1106,7 @@ #define scan_trans S_scan_trans #define scan_word S_scan_word #define skipspace S_skipspace +#define swallow_bom S_swallow_bom #define checkcomma S_checkcomma #define force_ident S_force_ident #define incline S_incline @@ -1099,6 +1120,7 @@ #define sublex_push S_sublex_push #define sublex_start S_sublex_start #define filter_gets S_filter_gets +#define find_in_my_stash S_find_in_my_stash #define new_constant S_new_constant #define ao S_ao #define depcom S_depcom @@ -1118,6 +1140,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 @@ -1151,6 +1174,7 @@ #define ck_open Perl_ck_open #define ck_repeat Perl_ck_repeat #define ck_require Perl_ck_require +#define ck_return Perl_ck_return #define ck_rfun Perl_ck_rfun #define ck_rvconst Perl_ck_rvconst #define ck_sassign Perl_ck_sassign @@ -1161,6 +1185,7 @@ #define ck_spair Perl_ck_spair #define ck_split Perl_ck_split #define ck_subr Perl_ck_subr +#define ck_substr Perl_ck_substr #define ck_svconst Perl_ck_svconst #define ck_trunc Perl_ck_trunc #define pp_aassign Perl_pp_aassign @@ -1536,6 +1561,7 @@ #define append_elem(a,b,c) Perl_append_elem(aTHX_ a,b,c) #define append_list(a,b,c) Perl_append_list(aTHX_ a,b,c) #define apply(a,b,c) Perl_apply(aTHX_ a,b,c) +#define apply_attrs_string(a,b,c,d) Perl_apply_attrs_string(aTHX_ a,b,c,d) #define avhv_delete_ent(a,b,c,d) Perl_avhv_delete_ent(aTHX_ a,b,c,d) #define avhv_exists_ent(a,b,c) Perl_avhv_exists_ent(aTHX_ a,b,c) #define avhv_fetch_ent(a,b,c,d) Perl_avhv_fetch_ent(aTHX_ a,b,c,d) @@ -1676,6 +1702,7 @@ #define gv_check(a) Perl_gv_check(aTHX_ a) #define gv_efullname(a,b) Perl_gv_efullname(aTHX_ a,b) #define gv_efullname3(a,b,c) Perl_gv_efullname3(aTHX_ a,b,c) +#define gv_efullname4(a,b,c,d) Perl_gv_efullname4(aTHX_ a,b,c,d) #define gv_fetchfile(a) Perl_gv_fetchfile(aTHX_ a) #define gv_fetchmeth(a,b,c,d) Perl_gv_fetchmeth(aTHX_ a,b,c,d) #define gv_fetchmethod(a,b) Perl_gv_fetchmethod(aTHX_ a,b) @@ -1683,6 +1710,7 @@ #define gv_fetchpv(a,b,c) Perl_gv_fetchpv(aTHX_ a,b,c) #define gv_fullname(a,b) Perl_gv_fullname(aTHX_ a,b) #define gv_fullname3(a,b,c) Perl_gv_fullname3(aTHX_ a,b,c) +#define gv_fullname4(a,b,c,d) Perl_gv_fullname4(aTHX_ a,b,c,d) #define gv_init(a,b,c,d,e) Perl_gv_init(aTHX_ a,b,c,d,e) #define gv_stashpv(a,b) Perl_gv_stashpv(aTHX_ a,b) #define gv_stashpvn(a,b,c) Perl_gv_stashpvn(aTHX_ a,b,c) @@ -1716,6 +1744,8 @@ #define instr(a,b) Perl_instr(aTHX_ a,b) #define io_close(a,b) Perl_io_close(aTHX_ a,b) #define invert(a) Perl_invert(aTHX_ a) +#define is_gv_magical(a,b,c) Perl_is_gv_magical(aTHX_ a,b,c) +#define is_lvalue_sub() Perl_is_lvalue_sub(aTHX) #define is_uni_alnum(a) Perl_is_uni_alnum(aTHX_ a) #define is_uni_alnumc(a) Perl_is_uni_alnumc(aTHX_ a) #define is_uni_idfirst(a) Perl_is_uni_idfirst(aTHX_ a) @@ -1751,6 +1781,7 @@ #define to_uni_title_lc(a) Perl_to_uni_title_lc(aTHX_ a) #define to_uni_lower_lc(a) Perl_to_uni_lower_lc(aTHX_ a) #define is_utf8_char(a) Perl_is_utf8_char(aTHX_ a) +#define is_utf8_string(a,b) Perl_is_utf8_string(aTHX_ a,b) #define is_utf8_alnum(a) Perl_is_utf8_alnum(aTHX_ a) #define is_utf8_alnumc(a) Perl_is_utf8_alnumc(aTHX_ a) #define is_utf8_idfirst(a) Perl_is_utf8_idfirst(aTHX_ a) @@ -1802,6 +1833,7 @@ #define magic_nextpack(a,b,c) Perl_magic_nextpack(aTHX_ a,b,c) #define magic_regdata_cnt(a,b) Perl_magic_regdata_cnt(aTHX_ a,b) #define magic_regdatum_get(a,b) Perl_magic_regdatum_get(aTHX_ a,b) +#define magic_regdatum_set(a,b) Perl_magic_regdatum_set(aTHX_ a,b) #define magic_set(a,b) Perl_magic_set(aTHX_ a,b) #define magic_setamagic(a,b) Perl_magic_setamagic(aTHX_ a,b) #define magic_setarylen(a,b) Perl_magic_setarylen(aTHX_ a,b) @@ -2014,6 +2046,7 @@ #define save_freeop(a) Perl_save_freeop(aTHX_ a) #define save_freepv(a) Perl_save_freepv(aTHX_ a) #define save_generic_svref(a) Perl_save_generic_svref(aTHX_ a) +#define save_generic_pvref(a) Perl_save_generic_pvref(aTHX_ a) #define save_gp(a,b) Perl_save_gp(aTHX_ a,b) #define save_hash(a) Perl_save_hash(aTHX_ a) #define save_helem(a,b,c) Perl_save_helem(aTHX_ a,b,c) @@ -2027,12 +2060,14 @@ #define save_iv(a) Perl_save_iv(aTHX_ a) #define save_list(a,b) Perl_save_list(aTHX_ a,b) #define save_long(a) Perl_save_long(aTHX_ a) +#define save_mortalizesv(a) Perl_save_mortalizesv(aTHX_ a) #define save_nogv(a) Perl_save_nogv(aTHX_ a) #define save_op() Perl_save_op(aTHX) #define save_scalar(a) Perl_save_scalar(aTHX_ a) #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) @@ -2043,7 +2078,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) @@ -2157,27 +2192,31 @@ #define unsharepvn(a,b,c) Perl_unsharepvn(aTHX_ a,b,c) #define unshare_hek(a) Perl_unshare_hek(aTHX_ a) #define utilize(a,b,c,d,e) Perl_utilize(aTHX_ a,b,c,d,e) -#define utf16_to_utf8(a,b,c) Perl_utf16_to_utf8(aTHX_ a,b,c) -#define utf16_to_utf8_reversed(a,b,c) Perl_utf16_to_utf8_reversed(aTHX_ a,b,c) +#define utf16_to_utf8(a,b,c,d) Perl_utf16_to_utf8(aTHX_ a,b,c,d) +#define utf16_to_utf8_reversed(a,b,c,d) Perl_utf16_to_utf8_reversed(aTHX_ a,b,c,d) +#define utf8_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_uv(a,b) Perl_utf8_to_uv(aTHX_ a,b) +#define utf8_to_bytes(a,b) Perl_utf8_to_bytes(aTHX_ a,b) +#define bytes_from_utf8(a,b,c) Perl_bytes_from_utf8(aTHX_ a,b,c) +#define bytes_to_utf8(a,b) Perl_bytes_to_utf8(aTHX_ a,b) +#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) #define wait4pid(a,b,c) Perl_wait4pid(aTHX_ a,b,c) -#define report_closed_fh(a,b,c,d) Perl_report_closed_fh(aTHX_ a,b,c,d) +#define report_evil_fh(a,b,c) Perl_report_evil_fh(aTHX_ a,b,c) #define report_uninit() Perl_report_uninit(aTHX) #define vwarn(a,b) Perl_vwarn(aTHX_ a,b) #define vwarner(a,b,c) Perl_vwarner(aTHX_ a,b,c) #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) -#define yylex(a,b) Perl_yylex(aTHX_ a,b) -#else -#define yylex() Perl_yylex(aTHX) +#ifdef USE_PURE_BISON +#define yylex_r(a,b) Perl_yylex_r(aTHX_ a,b) #endif +#define yylex() Perl_yylex(aTHX) #define yyparse() Perl_yyparse(aTHX) #define yywarn(a) Perl_yywarn(aTHX_ a) #if defined(MYMALLOC) @@ -2199,6 +2238,9 @@ #endif #define runops_standard() Perl_runops_standard(aTHX) #define runops_debug() Perl_runops_debug(aTHX) +#if defined(USE_THREADS) +#define sv_lock(a) Perl_sv_lock(aTHX_ a) +#endif #define sv_vcatpvf_mg(a,b,c) Perl_sv_vcatpvf_mg(aTHX_ a,b,c) #define sv_catpv_mg(a,b) Perl_sv_catpv_mg(aTHX_ a,b) #define sv_catpvn_mg(a,b,c) Perl_sv_catpvn_mg(aTHX_ a,b,c) @@ -2238,6 +2280,8 @@ #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_add_backref(a,b) Perl_sv_add_backref(aTHX_ a,b) +#define sv_del_backref(a) Perl_sv_del_backref(aTHX_ a) #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) @@ -2265,6 +2309,12 @@ #define ptr_table_fetch(a,b) Perl_ptr_table_fetch(aTHX_ a,b) #define ptr_table_store(a,b,c) Perl_ptr_table_store(aTHX_ a,b,c) #define ptr_table_split(a) Perl_ptr_table_split(aTHX_ a) +#define ptr_table_clear(a) Perl_ptr_table_clear(aTHX_ a) +#define ptr_table_free(a) Perl_ptr_table_free(aTHX_ a) +#endif +#if defined(HAVE_INTERP_INTERN) +#define sys_intern_clear() Perl_sys_intern_clear(aTHX) +#define sys_intern_init() Perl_sys_intern_init(aTHX) #endif #if defined(PERL_OBJECT) #else @@ -2274,16 +2324,12 @@ #define avhv_index(a,b,c) S_avhv_index(aTHX_ a,b,c) #endif #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) -#define do_trans_CC_simple(a) S_do_trans_CC_simple(aTHX_ a) -#define do_trans_CC_count(a) S_do_trans_CC_count(aTHX_ a) -#define do_trans_CC_complex(a) S_do_trans_CC_complex(aTHX_ a) -#define do_trans_UU_simple(a) S_do_trans_UU_simple(aTHX_ a) -#define do_trans_UU_count(a) S_do_trans_UU_count(aTHX_ a) -#define do_trans_UU_complex(a) S_do_trans_UU_complex(aTHX_ a) -#define do_trans_UC_simple(a) S_do_trans_UC_simple(aTHX_ a) -#define do_trans_CU_simple(a) S_do_trans_CU_simple(aTHX_ a) -#define do_trans_UC_trivial(a) S_do_trans_UC_trivial(aTHX_ a) -#define do_trans_CU_trivial(a) S_do_trans_CU_trivial(aTHX_ a) +#define do_trans_simple(a) S_do_trans_simple(aTHX_ a) +#define do_trans_count(a) S_do_trans_count(aTHX_ a) +#define do_trans_complex(a) S_do_trans_complex(aTHX_ a) +#define do_trans_simple_utf8(a) S_do_trans_simple_utf8(aTHX_ a) +#define do_trans_count_utf8(a) S_do_trans_count_utf8(aTHX_ a) +#define do_trans_complex_utf8(a) S_do_trans_complex_utf8(aTHX_ a) #endif #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT) #define gv_init_sv(a,b) S_gv_init_sv(aTHX_ a,b) @@ -2312,6 +2358,7 @@ #define scalarboolean(a) S_scalarboolean(aTHX_ a) #define too_few_arguments(a,b) S_too_few_arguments(aTHX_ a,b) #define too_many_arguments(a,b) S_too_many_arguments(aTHX_ a,b) +#define trlist_upgrade(a,b) S_trlist_upgrade(aTHX_ a,b) #define op_clear(a) S_op_clear(aTHX_ a) #define null(a) S_null(aTHX_ a) #define pad_addlex(a) S_pad_addlex(aTHX_ a) @@ -2385,7 +2432,6 @@ #define dopoptoloop(a) S_dopoptoloop(aTHX_ a) #define dopoptosub(a) S_dopoptosub(aTHX_ a) #define dopoptosub_at(a,b) S_dopoptosub_at(aTHX_ a,b) -#define free_closures() S_free_closures(aTHX) #define save_lines(a,b) S_save_lines(aTHX_ a,b) #define doeval(a,b) S_doeval(aTHX_ a,b) #define doopen_pmc(a,b) S_doopen_pmc(aTHX_ a,b) @@ -2498,8 +2544,6 @@ #define sv_unglob(a) S_sv_unglob(aTHX_ a) #define not_a_number(a) S_not_a_number(aTHX_ a) #define visit(a) S_visit(aTHX_ a) -#define sv_add_backref(a,b) S_sv_add_backref(aTHX_ a,b) -#define sv_del_backref(a) S_sv_del_backref(aTHX_ a) # if defined(DEBUGGING) #define del_sv(a) S_del_sv(aTHX_ a) # endif @@ -2521,6 +2565,7 @@ #define scan_trans(a) S_scan_trans(aTHX_ a) #define scan_word(a,b,c,d,e) S_scan_word(aTHX_ a,b,c,d,e) #define skipspace(a) S_skipspace(aTHX_ a) +#define swallow_bom(a) S_swallow_bom(aTHX_ a) #define checkcomma(a,b,c) S_checkcomma(aTHX_ a,b,c) #define force_ident(a,b) S_force_ident(aTHX_ a,b) #define incline(a) S_incline(aTHX_ a) @@ -2534,6 +2579,7 @@ #define sublex_push() S_sublex_push(aTHX) #define sublex_start() S_sublex_start(aTHX) #define filter_gets(a,b,c) S_filter_gets(aTHX_ a,b,c) +#define find_in_my_stash(a,b) S_find_in_my_stash(aTHX_ a,b) #define new_constant(a,b,c,d,e,f) S_new_constant(aTHX_ a,b,c,d,e,f) #define ao(a) S_ao(aTHX_ a) #define depcom() S_depcom(aTHX) @@ -2553,6 +2599,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) @@ -2586,6 +2633,7 @@ #define ck_open(a) Perl_ck_open(aTHX_ a) #define ck_repeat(a) Perl_ck_repeat(aTHX_ a) #define ck_require(a) Perl_ck_require(aTHX_ a) +#define ck_return(a) Perl_ck_return(aTHX_ a) #define ck_rfun(a) Perl_ck_rfun(aTHX_ a) #define ck_rvconst(a) Perl_ck_rvconst(aTHX_ a) #define ck_sassign(a) Perl_ck_sassign(aTHX_ a) @@ -2596,6 +2644,7 @@ #define ck_spair(a) Perl_ck_spair(aTHX_ a) #define ck_split(a) Perl_ck_split(aTHX_ a) #define ck_subr(a) Perl_ck_subr(aTHX_ a) +#define ck_substr(a) Perl_ck_substr(aTHX_ a) #define ck_svconst(a) Perl_ck_svconst(aTHX_ a) #define ck_trunc(a) Perl_ck_trunc(aTHX_ a) #define pp_aassign() Perl_pp_aassign(aTHX) @@ -2981,6 +3030,8 @@ #define append_list Perl_append_list #define Perl_apply CPerlObj::Perl_apply #define apply Perl_apply +#define Perl_apply_attrs_string CPerlObj::Perl_apply_attrs_string +#define apply_attrs_string Perl_apply_attrs_string #define Perl_avhv_delete_ent CPerlObj::Perl_avhv_delete_ent #define avhv_delete_ent Perl_avhv_delete_ent #define Perl_avhv_exists_ent CPerlObj::Perl_avhv_exists_ent @@ -3092,6 +3143,8 @@ #define sv_setpvf_mg_nocontext Perl_sv_setpvf_mg_nocontext #define Perl_fprintf_nocontext CPerlObj::Perl_fprintf_nocontext #define fprintf_nocontext Perl_fprintf_nocontext +#define Perl_printf_nocontext CPerlObj::Perl_printf_nocontext +#define printf_nocontext Perl_printf_nocontext #endif #define Perl_cv_ckproto CPerlObj::Perl_cv_ckproto #define cv_ckproto Perl_cv_ckproto @@ -3281,6 +3334,8 @@ #define gv_efullname Perl_gv_efullname #define Perl_gv_efullname3 CPerlObj::Perl_gv_efullname3 #define gv_efullname3 Perl_gv_efullname3 +#define Perl_gv_efullname4 CPerlObj::Perl_gv_efullname4 +#define gv_efullname4 Perl_gv_efullname4 #define Perl_gv_fetchfile CPerlObj::Perl_gv_fetchfile #define gv_fetchfile Perl_gv_fetchfile #define Perl_gv_fetchmeth CPerlObj::Perl_gv_fetchmeth @@ -3295,6 +3350,8 @@ #define gv_fullname Perl_gv_fullname #define Perl_gv_fullname3 CPerlObj::Perl_gv_fullname3 #define gv_fullname3 Perl_gv_fullname3 +#define Perl_gv_fullname4 CPerlObj::Perl_gv_fullname4 +#define gv_fullname4 Perl_gv_fullname4 #define Perl_gv_init CPerlObj::Perl_gv_init #define gv_init Perl_gv_init #define Perl_gv_stashpv CPerlObj::Perl_gv_stashpv @@ -3361,6 +3418,10 @@ #define io_close Perl_io_close #define Perl_invert CPerlObj::Perl_invert #define invert Perl_invert +#define Perl_is_gv_magical CPerlObj::Perl_is_gv_magical +#define is_gv_magical Perl_is_gv_magical +#define Perl_is_lvalue_sub CPerlObj::Perl_is_lvalue_sub +#define is_lvalue_sub Perl_is_lvalue_sub #define Perl_is_uni_alnum CPerlObj::Perl_is_uni_alnum #define is_uni_alnum Perl_is_uni_alnum #define Perl_is_uni_alnumc CPerlObj::Perl_is_uni_alnumc @@ -3431,6 +3492,8 @@ #define to_uni_lower_lc Perl_to_uni_lower_lc #define Perl_is_utf8_char CPerlObj::Perl_is_utf8_char #define is_utf8_char Perl_is_utf8_char +#define Perl_is_utf8_string CPerlObj::Perl_is_utf8_string +#define is_utf8_string Perl_is_utf8_string #define Perl_is_utf8_alnum CPerlObj::Perl_is_utf8_alnum #define is_utf8_alnum Perl_is_utf8_alnum #define Perl_is_utf8_alnumc CPerlObj::Perl_is_utf8_alnumc @@ -3533,6 +3596,8 @@ #define magic_regdata_cnt Perl_magic_regdata_cnt #define Perl_magic_regdatum_get CPerlObj::Perl_magic_regdatum_get #define magic_regdatum_get Perl_magic_regdatum_get +#define Perl_magic_regdatum_set CPerlObj::Perl_magic_regdatum_set +#define magic_regdatum_set Perl_magic_regdatum_set #define Perl_magic_set CPerlObj::Perl_magic_set #define magic_set Perl_magic_set #define Perl_magic_setamagic CPerlObj::Perl_magic_setamagic @@ -3944,6 +4009,8 @@ #define save_freepv Perl_save_freepv #define Perl_save_generic_svref CPerlObj::Perl_save_generic_svref #define save_generic_svref Perl_save_generic_svref +#define Perl_save_generic_pvref CPerlObj::Perl_save_generic_pvref +#define save_generic_pvref Perl_save_generic_pvref #define Perl_save_gp CPerlObj::Perl_save_gp #define save_gp Perl_save_gp #define Perl_save_hash CPerlObj::Perl_save_hash @@ -3970,6 +4037,8 @@ #define save_list Perl_save_list #define Perl_save_long CPerlObj::Perl_save_long #define save_long Perl_save_long +#define Perl_save_mortalizesv CPerlObj::Perl_save_mortalizesv +#define save_mortalizesv Perl_save_mortalizesv #define Perl_save_nogv CPerlObj::Perl_save_nogv #define save_nogv Perl_save_nogv #define Perl_save_op CPerlObj::Perl_save_op @@ -3982,6 +4051,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 @@ -4230,10 +4301,20 @@ #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 #define utf8_hop Perl_utf8_hop +#define Perl_utf8_to_bytes CPerlObj::Perl_utf8_to_bytes +#define utf8_to_bytes Perl_utf8_to_bytes +#define Perl_bytes_from_utf8 CPerlObj::Perl_bytes_from_utf8 +#define bytes_from_utf8 Perl_bytes_from_utf8 +#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_uv_to_utf8 CPerlObj::Perl_uv_to_utf8 @@ -4244,8 +4325,8 @@ #define vivify_ref Perl_vivify_ref #define Perl_wait4pid CPerlObj::Perl_wait4pid #define wait4pid Perl_wait4pid -#define Perl_report_closed_fh CPerlObj::Perl_report_closed_fh -#define report_closed_fh Perl_report_closed_fh +#define Perl_report_evil_fh CPerlObj::Perl_report_evil_fh +#define report_evil_fh Perl_report_evil_fh #define Perl_report_uninit CPerlObj::Perl_report_uninit #define report_uninit Perl_report_uninit #define Perl_warn CPerlObj::Perl_warn @@ -4262,13 +4343,12 @@ #define whichsig Perl_whichsig #define Perl_yyerror CPerlObj::Perl_yyerror #define yyerror Perl_yyerror -#if defined(USE_PURE_BISON) -#define Perl_yylex CPerlObj::Perl_yylex -#define yylex Perl_yylex -#else +#ifdef USE_PURE_BISON +#define Perl_yylex_r CPerlObj::Perl_yylex_r +#define yylex_r Perl_yylex_r +#endif #define Perl_yylex CPerlObj::Perl_yylex #define yylex Perl_yylex -#endif #define Perl_yyparse CPerlObj::Perl_yyparse #define yyparse Perl_yyparse #define Perl_yywarn CPerlObj::Perl_yywarn @@ -4305,6 +4385,10 @@ #define runops_standard Perl_runops_standard #define Perl_runops_debug CPerlObj::Perl_runops_debug #define runops_debug Perl_runops_debug +#if defined(USE_THREADS) +#define Perl_sv_lock CPerlObj::Perl_sv_lock +#define sv_lock Perl_sv_lock +#endif #define Perl_sv_catpvf_mg CPerlObj::Perl_sv_catpvf_mg #define sv_catpvf_mg Perl_sv_catpvf_mg #define Perl_sv_vcatpvf_mg CPerlObj::Perl_sv_vcatpvf_mg @@ -4389,6 +4473,10 @@ #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_add_backref CPerlObj::Perl_sv_add_backref +#define sv_add_backref Perl_sv_add_backref +#define Perl_sv_del_backref CPerlObj::Perl_sv_del_backref +#define sv_del_backref Perl_sv_del_backref #define Perl_tmps_grow CPerlObj::Perl_tmps_grow #define tmps_grow Perl_tmps_grow #define Perl_sv_rvweaken CPerlObj::Perl_sv_rvweaken @@ -4440,6 +4528,16 @@ #define ptr_table_store Perl_ptr_table_store #define Perl_ptr_table_split CPerlObj::Perl_ptr_table_split #define ptr_table_split Perl_ptr_table_split +#define Perl_ptr_table_clear CPerlObj::Perl_ptr_table_clear +#define ptr_table_clear Perl_ptr_table_clear +#define Perl_ptr_table_free CPerlObj::Perl_ptr_table_free +#define ptr_table_free Perl_ptr_table_free +#endif +#if defined(HAVE_INTERP_INTERN) +#define Perl_sys_intern_clear CPerlObj::Perl_sys_intern_clear +#define sys_intern_clear Perl_sys_intern_clear +#define Perl_sys_intern_init CPerlObj::Perl_sys_intern_init +#define sys_intern_init Perl_sys_intern_init #endif #if defined(PERL_OBJECT) #else @@ -4451,26 +4549,18 @@ #define avhv_index S_avhv_index #endif #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) -#define S_do_trans_CC_simple CPerlObj::S_do_trans_CC_simple -#define do_trans_CC_simple S_do_trans_CC_simple -#define S_do_trans_CC_count CPerlObj::S_do_trans_CC_count -#define do_trans_CC_count S_do_trans_CC_count -#define S_do_trans_CC_complex CPerlObj::S_do_trans_CC_complex -#define do_trans_CC_complex S_do_trans_CC_complex -#define S_do_trans_UU_simple CPerlObj::S_do_trans_UU_simple -#define do_trans_UU_simple S_do_trans_UU_simple -#define S_do_trans_UU_count CPerlObj::S_do_trans_UU_count -#define do_trans_UU_count S_do_trans_UU_count -#define S_do_trans_UU_complex CPerlObj::S_do_trans_UU_complex -#define do_trans_UU_complex S_do_trans_UU_complex -#define S_do_trans_UC_simple CPerlObj::S_do_trans_UC_simple -#define do_trans_UC_simple S_do_trans_UC_simple -#define S_do_trans_CU_simple CPerlObj::S_do_trans_CU_simple -#define do_trans_CU_simple S_do_trans_CU_simple -#define S_do_trans_UC_trivial CPerlObj::S_do_trans_UC_trivial -#define do_trans_UC_trivial S_do_trans_UC_trivial -#define S_do_trans_CU_trivial CPerlObj::S_do_trans_CU_trivial -#define do_trans_CU_trivial S_do_trans_CU_trivial +#define S_do_trans_simple CPerlObj::S_do_trans_simple +#define do_trans_simple S_do_trans_simple +#define S_do_trans_count CPerlObj::S_do_trans_count +#define do_trans_count S_do_trans_count +#define S_do_trans_complex CPerlObj::S_do_trans_complex +#define do_trans_complex S_do_trans_complex +#define S_do_trans_simple_utf8 CPerlObj::S_do_trans_simple_utf8 +#define do_trans_simple_utf8 S_do_trans_simple_utf8 +#define S_do_trans_count_utf8 CPerlObj::S_do_trans_count_utf8 +#define do_trans_count_utf8 S_do_trans_count_utf8 +#define S_do_trans_complex_utf8 CPerlObj::S_do_trans_complex_utf8 +#define do_trans_complex_utf8 S_do_trans_complex_utf8 #endif #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT) #define S_gv_init_sv CPerlObj::S_gv_init_sv @@ -4519,6 +4609,8 @@ #define too_few_arguments S_too_few_arguments #define S_too_many_arguments CPerlObj::S_too_many_arguments #define too_many_arguments S_too_many_arguments +#define S_trlist_upgrade CPerlObj::S_trlist_upgrade +#define trlist_upgrade S_trlist_upgrade #define S_op_clear CPerlObj::S_op_clear #define op_clear S_op_clear #define S_null CPerlObj::S_null @@ -4649,8 +4741,6 @@ #define dopoptosub S_dopoptosub #define S_dopoptosub_at CPerlObj::S_dopoptosub_at #define dopoptosub_at S_dopoptosub_at -#define S_free_closures CPerlObj::S_free_closures -#define free_closures S_free_closures #define S_save_lines CPerlObj::S_save_lines #define save_lines S_save_lines #define S_doeval CPerlObj::S_doeval @@ -4861,10 +4951,6 @@ #define not_a_number S_not_a_number #define S_visit CPerlObj::S_visit #define visit S_visit -#define S_sv_add_backref CPerlObj::S_sv_add_backref -#define sv_add_backref S_sv_add_backref -#define S_sv_del_backref CPerlObj::S_sv_del_backref -#define sv_del_backref S_sv_del_backref # if defined(DEBUGGING) #define S_del_sv CPerlObj::S_del_sv #define del_sv S_del_sv @@ -4903,6 +4989,8 @@ #define scan_word S_scan_word #define S_skipspace CPerlObj::S_skipspace #define skipspace S_skipspace +#define S_swallow_bom CPerlObj::S_swallow_bom +#define swallow_bom S_swallow_bom #define S_checkcomma CPerlObj::S_checkcomma #define checkcomma S_checkcomma #define S_force_ident CPerlObj::S_force_ident @@ -4929,6 +5017,8 @@ #define sublex_start S_sublex_start #define S_filter_gets CPerlObj::S_filter_gets #define filter_gets S_filter_gets +#define S_find_in_my_stash CPerlObj::S_find_in_my_stash +#define find_in_my_stash S_find_in_my_stash #define S_new_constant CPerlObj::S_new_constant #define new_constant S_new_constant #define S_ao CPerlObj::S_ao @@ -4957,6 +5047,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) @@ -5018,6 +5110,8 @@ #define ck_repeat Perl_ck_repeat #define Perl_ck_require CPerlObj::Perl_ck_require #define ck_require Perl_ck_require +#define Perl_ck_return CPerlObj::Perl_ck_return +#define ck_return Perl_ck_return #define Perl_ck_rfun CPerlObj::Perl_ck_rfun #define ck_rfun Perl_ck_rfun #define Perl_ck_rvconst CPerlObj::Perl_ck_rvconst @@ -5038,6 +5132,8 @@ #define ck_split Perl_ck_split #define Perl_ck_subr CPerlObj::Perl_ck_subr #define ck_subr Perl_ck_subr +#define Perl_ck_substr CPerlObj::Perl_ck_substr +#define ck_substr Perl_ck_substr #define Perl_ck_svconst CPerlObj::Perl_ck_svconst #define ck_svconst Perl_ck_svconst #define Perl_ck_trunc CPerlObj::Perl_ck_trunc diff --git a/contrib/perl5/embed.pl b/contrib/perl5/embed.pl index 593ab19f5548..2b0f2aabfed2 100755 --- a/contrib/perl5/embed.pl +++ b/contrib/perl5/embed.pl @@ -25,6 +25,7 @@ sub walk_table (&@) { $F = $filename; } else { + unlink $filename; open F, ">$filename" or die "Can't open $filename: $!"; $F = \*F; } @@ -198,6 +199,7 @@ my @extvars = qw(sv_undef sv_yes sv_no na dowarn diehook dirty perl_destruct_level + ppaddr ); sub readsyms (\%$) { @@ -916,6 +918,9 @@ START_EXTERN_C { return &(PL_##v); } #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHXo) \ { return &(PL_##v); } +#undef PERLVARIC +#define PERLVARIC(v,t,i) const t* Perl_##v##_ptr(pTHXo) \ + { return (const t *)&(PL_##v); } #include "perlvars.h" #undef PERLVAR @@ -1064,6 +1069,16 @@ Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...) return (*PL_StdIO->pVprintf)(PL_StdIO, stream, format, arglist); } +#undef Perl_printf_nocontext +int +Perl_printf_nocontext(const char *format, ...) +{ + dTHXo; + va_list(arglist); + va_start(arglist, format); + return (*PL_StdIO->pVprintf)(PL_StdIO, PerlIO_stdout(), format, arglist); +} + END_EXTERN_C #endif /* PERL_OBJECT */ @@ -1078,12 +1093,12 @@ my %apidocs; my %gutsdocs; my %docfuncs; -sub autodoc ($) { # parse a file and extract documentation info - my($fh) = @_; - my($in, $doc); - +sub autodoc ($$) { # parse a file and extract documentation info + my($fh,$file) = @_; + my($in, $doc, $line); FUNC: while (defined($in = <$fh>)) { + $line++; if ($in =~ /^=for\s+apidoc\s+(.*)\n/) { my $proto = $1; $proto = "||$proto" unless $proto =~ /\|/; @@ -1091,24 +1106,33 @@ FUNC: my $docs = ""; DOC: while (defined($doc = <$fh>)) { + $line++; last DOC if $doc =~ /^=\w+/; + if ($doc =~ m:^\*/$:) { + warn "=cut missing? $file:$line:$doc";; + last DOC; + } $docs .= $doc; } $docs = "\n$docs" if $docs and $docs !~ /^\n/; if ($flags =~ /m/) { if ($flags =~ /A/) { - $apidocs{$name} = [$flags, $docs, $ret, @args]; + $apidocs{$name} = [$flags, $docs, $ret, $file, @args]; } else { - $gutsdocs{$name} = [$flags, $docs, $ret, @args]; + $gutsdocs{$name} = [$flags, $docs, $ret, $file, @args]; } } else { - $docfuncs{$name} = [$flags, $docs, $ret, @args]; + $docfuncs{$name} = [$flags, $docs, $ret, $file, @args]; } - if ($doc =~ /^=for/) { - $in = $doc; - redo FUNC; + if (defined $doc) { + if ($doc =~ /^=for/) { + $in = $doc; + redo FUNC; + } + } else { + warn "$file:$line:$in"; } } } @@ -1116,8 +1140,10 @@ DOC: sub docout ($$$) { # output the docs for one function my($fh, $name, $docref) = @_; - my($flags, $docs, $ret, @args) = @$docref; + my($flags, $docs, $ret, $file, @args) = @$docref; + $docs .= "NOTE: this function is experimental and may change or be +removed without notice.\n\n" if $flags =~ /x/; $docs .= "NOTE: the perl_ form of this function is deprecated.\n\n" if $flags =~ /p/; @@ -1134,12 +1160,13 @@ sub docout ($$$) { # output the docs for one function print $fh "(" . join(", ", @args) . ")"; print $fh "\n\n"; } + print $fh "=for hackers\nFound in file $file\n\n"; } my $file; for $file (glob('*.c'), glob('*.h')) { open F, "< $file" or die "Cannot open $file for docs: $!\n"; - autodoc(\*F); + autodoc(\*F,$file); close F or die "Error closing $file: $!\n"; } @@ -1156,16 +1183,21 @@ walk_table { # load documented functions into approriate hash if ($flags =~ /A/) { my $docref = delete $docfuncs{$func}; warn "no docs for $func\n" unless $docref and @$docref; - $apidocs{$func} = [$docref->[0] . 'A', $docref->[1], $retval, @args]; + $docref->[0].="x" if $flags =~ /M/; + $apidocs{$func} = [$docref->[0] . 'A', $docref->[1], $retval, + $docref->[3], @args]; } else { my $docref = delete $docfuncs{$func}; - $gutsdocs{$func} = [$docref->[0], $docref->[1], $retval, @args]; + $gutsdocs{$func} = [$docref->[0], $docref->[1], $retval, + $docref->[3], @args]; } } return ""; } \*DOC; for (sort keys %docfuncs) { + # Have you used a full for apidoc or just a func name? + # Have you used Ap instead of Am in the for apidoc? warn "Unable to place $_!\n"; } @@ -1235,7 +1267,7 @@ perlintern - autogenerated documentation of purely B<internal> =head1 DESCRIPTION This file is the autogenerated documentation of functions in the -Perl intrepreter that are documented using Perl's internal documentation +Perl interpreter that are documented using Perl's internal documentation format but are not marked as part of the Perl API. In other words, B<they are not for use in extensions>! @@ -1252,7 +1284,7 @@ print GUTS <<'END'; =head1 AUTHORS -The autodocumentation system was orignally added to the Perl core by +The autodocumentation system was originally added to the Perl core by Benjamin Stuhl. Documentation is by whoever was kind enough to document their functions. @@ -1285,6 +1317,7 @@ __END__ : o has no compatibility macro (#define foo Perl_foo) : j not a member of CPerlObj : x not exported +: M may change : : Individual flags may be separated by whitespace. : @@ -1358,6 +1391,7 @@ Ap |bool |Gv_AMupdate |HV* stash p |OP* |append_elem |I32 optype|OP* head|OP* tail p |OP* |append_list |I32 optype|LISTOP* first|LISTOP* last p |I32 |apply |I32 type|SV** mark|SV** sp +Ap |void |apply_attrs_string|char *stashpv|CV *cv|char *attrstr|STRLEN len Ap |SV* |avhv_delete_ent|AV *ar|SV* keysv|I32 flags|U32 hash Ap |bool |avhv_exists_ent|AV *ar|SV* keysv|U32 hash Ap |SV** |avhv_fetch_ent |AV *ar|SV* keysv|I32 lval|U32 hash @@ -1366,17 +1400,17 @@ Ap |HE* |avhv_iternext |AV *ar Ap |SV* |avhv_iterval |AV *ar|HE* entry Ap |HV* |avhv_keys |AV *ar Apd |void |av_clear |AV* ar -Ap |SV* |av_delete |AV* ar|I32 key|I32 flags -Ap |bool |av_exists |AV* ar|I32 key +Apd |SV* |av_delete |AV* ar|I32 key|I32 flags +Apd |bool |av_exists |AV* ar|I32 key Apd |void |av_extend |AV* ar|I32 key -Ap |AV* |av_fake |I32 size|SV** svp +p |AV* |av_fake |I32 size|SV** svp Apd |SV** |av_fetch |AV* ar|I32 key|I32 lval -Ap |void |av_fill |AV* ar|I32 fill +Apd |void |av_fill |AV* ar|I32 fill Apd |I32 |av_len |AV* ar Apd |AV* |av_make |I32 size|SV** svp Apd |SV* |av_pop |AV* ar Apd |void |av_push |AV* ar|SV* val -Ap |void |av_reify |AV* ar +ApM |void |av_reify |AV* ar Apd |SV* |av_shift |AV* ar Apd |SV** |av_store |AV* ar|I32 key|SV* val Apd |void |av_undef |AV* ar @@ -1406,7 +1440,7 @@ Afnrp |void |croak_nocontext|const char* pat|... Afnp |OP* |die_nocontext |const char* pat|... Afnp |void |deb_nocontext |const char* pat|... Afnp |char* |form_nocontext |const char* pat|... -Afnp |void |load_module_nocontext|U32 flags|SV* name|SV* ver|... +Anp |void |load_module_nocontext|U32 flags|SV* name|SV* ver|... Afnp |SV* |mess_nocontext |const char* pat|... Afnp |void |warn_nocontext |const char* pat|... Afnp |void |warner_nocontext|U32 err|const char* pat|... @@ -1416,6 +1450,7 @@ Afnp |void |sv_setpvf_nocontext|SV* sv|const char* pat|... Afnp |void |sv_catpvf_mg_nocontext|SV* sv|const char* pat|... Afnp |void |sv_setpvf_mg_nocontext|SV* sv|const char* pat|... Afnp |int |fprintf_nocontext|PerlIO* stream|const char* fmt|... +Afnp |int |printf_nocontext|const char* fmt|... #endif p |void |cv_ckproto |CV* cv|GV* gv|char* p p |CV* |cv_clone |CV* proto @@ -1447,7 +1482,7 @@ p |OP* |die_where |char* message|STRLEN msglen Ap |void |dounwind |I32 cxix p |bool |do_aexec |SV* really|SV** mark|SV** sp p |bool |do_aexec5 |SV* really|SV** mark|SV** sp|int fd|int flag -Ap |int |do_binmode |PerlIO *fp|int iotype|int flag +Ap |int |do_binmode |PerlIO *fp|int iotype|int mode p |void |do_chop |SV* asv|SV* sv Ap |bool |do_close |GV* gv|bool not_implicit p |bool |do_eof |GV* gv @@ -1464,7 +1499,7 @@ p |I32 |do_msgsnd |SV** mark|SV** sp p |I32 |do_semop |SV** mark|SV** sp p |I32 |do_shmio |I32 optype|SV** mark|SV** sp #endif -p |void |do_join |SV* sv|SV* del|SV** mark|SV** sp +Ap |void |do_join |SV* sv|SV* del|SV** mark|SV** sp p |OP* |do_kv Ap |bool |do_open |GV* gv|char* name|I32 len|int as_raw \ |int rawmode|int rawperm|PerlIO* supplied_fp @@ -1511,7 +1546,7 @@ Ap |char* |vform |const char* pat|va_list* args Ap |void |free_tmps p |OP* |gen_constant_list|OP* o #if !defined(HAS_GETENV_LEN) -p |char* |getenv_len |char* key|unsigned long *len +p |char* |getenv_len |const char* key|unsigned long *len #endif Ap |void |gp_free |GV* gv Ap |GP* |gp_ref |GP* gp @@ -1523,6 +1558,7 @@ Ap |GV* |gv_autoload4 |HV* stash|const char* name|STRLEN len \ Ap |void |gv_check |HV* stash Ap |void |gv_efullname |SV* sv|GV* gv Ap |void |gv_efullname3 |SV* sv|GV* gv|const char* prefix +Ap |void |gv_efullname4 |SV* sv|GV* gv|const char* prefix|bool keepmain Ap |GV* |gv_fetchfile |const char* name Apd |GV* |gv_fetchmeth |HV* stash|const char* name|STRLEN len \ |I32 level @@ -1532,6 +1568,7 @@ Apd |GV* |gv_fetchmethod_autoload|HV* stash|const char* name \ Ap |GV* |gv_fetchpv |const char* name|I32 add|I32 sv_type Ap |void |gv_fullname |SV* sv|GV* gv Ap |void |gv_fullname3 |SV* sv|GV* gv|const char* prefix +Ap |void |gv_fullname4 |SV* sv|GV* gv|const char* prefix|bool keepmain Ap |void |gv_init |GV* gv|HV* stash|const char* name \ |STRLEN len|int multi Apd |HV* |gv_stashpv |const char* name|I32 create @@ -1567,6 +1604,8 @@ p |U32 |intro_my Ap |char* |instr |const char* big|const char* little p |bool |io_close |IO* io|bool not_implicit p |OP* |invert |OP* cmd +dp |bool |is_gv_magical |char *name|STRLEN len|U32 flags +p |I32 |is_lvalue_sub Ap |bool |is_uni_alnum |U32 c Ap |bool |is_uni_alnumc |U32 c Ap |bool |is_uni_idfirst |U32 c @@ -1601,7 +1640,8 @@ 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 +Apd |STRLEN |is_utf8_char |U8 *p +Apd |bool |is_utf8_string |U8 *s|STRLEN len Ap |bool |is_utf8_alnum |U8 *p Ap |bool |is_utf8_alnumc |U8 *p Ap |bool |is_utf8_idfirst|U8 *p @@ -1625,7 +1665,7 @@ p |void |lex_start |SV* line p |OP* |linklist |OP* o p |OP* |list |OP* o p |OP* |listkids |OP* o -Afp |void |load_module|U32 flags|SV* name|SV* ver|... +Ap |void |load_module|U32 flags|SV* name|SV* ver|... Ap |void |vload_module|U32 flags|SV* name|SV* ver|va_list* args p |OP* |localize |OP* arg|I32 lexical Apd |I32 |looks_like_number|SV* sv @@ -1654,6 +1694,7 @@ p |int |magic_mutexfree|SV* sv|MAGIC* mg p |int |magic_nextpack |SV* sv|MAGIC* mg|SV* key p |U32 |magic_regdata_cnt|SV* sv|MAGIC* mg p |int |magic_regdatum_get|SV* sv|MAGIC* mg +p |int |magic_regdatum_set|SV* sv|MAGIC* mg p |int |magic_set |SV* sv|MAGIC* mg p |int |magic_setamagic|SV* sv|MAGIC* mg p |int |magic_setarylen|SV* sv|MAGIC* mg @@ -1824,9 +1865,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 @@ -1860,7 +1901,7 @@ p |void |regprop |SV* sv|regnode* o Ap |void |repeatcpy |char* to|const char* from|I32 len|I32 count Ap |char* |rninstr |const char* big|const char* bigend \ |const char* little|const char* lend -p |Sighandler_t|rsignal |int i|Sighandler_t t +Ap |Sighandler_t|rsignal |int i|Sighandler_t t p |int |rsignal_restore|int i|Sigsave_t* t p |int |rsignal_save |int i|Sighandler_t t1|Sigsave_t* t2 p |Sighandler_t|rsignal_state|int i @@ -1885,6 +1926,7 @@ Ap |void |save_freesv |SV* sv p |void |save_freeop |OP* o Ap |void |save_freepv |char* pv Ap |void |save_generic_svref|SV** sptr +Ap |void |save_generic_pvref|char** str Ap |void |save_gp |GV* gv|I32 empty Ap |HV* |save_hash |GV* gv Ap |void |save_helem |HV* hv|SV *key|SV **sptr @@ -1898,12 +1940,14 @@ Ap |void |save_item |SV* item Ap |void |save_iv |IV* iv Ap |void |save_list |SV** sarg|I32 maxsarg Ap |void |save_long |long* longp +Ap |void |save_mortalizesv|SV* sv Ap |void |save_nogv |GV* gv p |void |save_op 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 @@ -1912,10 +1956,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 @@ -1945,7 +1989,7 @@ Ap |NV |sv_nv |SV* sv Ap |char* |sv_pvn |SV *sv|STRLEN *len Ap |char* |sv_pvutf8n |SV *sv|STRLEN *len Ap |char* |sv_pvbyten |SV *sv|STRLEN *len -Ap |I32 |sv_true |SV *sv +Apd |I32 |sv_true |SV *sv p |void |sv_add_arena |char* ptr|U32 size|U32 flags Ap |int |sv_backoff |SV* sv Apd |SV* |sv_bless |SV* sv|HV* stash @@ -1955,11 +1999,11 @@ Apd |void |sv_catpv |SV* sv|const char* ptr Apd |void |sv_catpvn |SV* sv|const char* ptr|STRLEN len Apd |void |sv_catsv |SV* dsv|SV* ssv Apd |void |sv_chop |SV* sv|char* ptr -p |void |sv_clean_all +p |I32 |sv_clean_all p |void |sv_clean_objs -Ap |void |sv_clear |SV* sv +Apd |void |sv_clear |SV* sv Apd |I32 |sv_cmp |SV* sv1|SV* sv2 -Ap |I32 |sv_cmp_locale |SV* sv1|SV* sv2 +Apd |I32 |sv_cmp_locale |SV* sv1|SV* sv2 #if defined(USE_LOCALE_COLLATE) Ap |char* |sv_collxfrm |SV* sv|STRLEN* nxp #endif @@ -1968,9 +2012,9 @@ Apd |void |sv_dec |SV* sv Ap |void |sv_dump |SV* sv Apd |bool |sv_derived_from|SV* sv|const char* name Apd |I32 |sv_eq |SV* sv1|SV* sv2 -Ap |void |sv_free |SV* sv +Apd |void |sv_free |SV* sv p |void |sv_free_arenas -Ap |char* |sv_gets |SV* sv|PerlIO* fp|I32 append +Apd |char* |sv_gets |SV* sv|PerlIO* fp|I32 append Apd |char* |sv_grow |SV* sv|STRLEN newlen Apd |void |sv_inc |SV* sv Apd |void |sv_insert |SV* bigsv|STRLEN offset|STRLEN len \ @@ -1978,7 +2022,7 @@ Apd |void |sv_insert |SV* bigsv|STRLEN offset|STRLEN len \ Apd |int |sv_isa |SV* sv|const char* name Apd |int |sv_isobject |SV* sv Apd |STRLEN |sv_len |SV* sv -Ap |STRLEN |sv_len_utf8 |SV* sv +Apd |STRLEN |sv_len_utf8 |SV* sv Apd |void |sv_magic |SV* sv|SV* obj|int how|const char* name \ |I32 namlen Apd |SV* |sv_mortalcopy |SV* oldsv @@ -1987,11 +2031,11 @@ Ap |SV* |sv_newref |SV* sv Ap |char* |sv_peek |SV* sv Ap |void |sv_pos_u2b |SV* sv|I32* offsetp|I32* lenp Ap |void |sv_pos_b2u |SV* sv|I32* offsetp -Ap |char* |sv_pvn_force |SV* sv|STRLEN* lp -Ap |char* |sv_pvutf8n_force|SV* sv|STRLEN* lp +Apd |char* |sv_pvn_force |SV* sv|STRLEN* lp +Apd |char* |sv_pvutf8n_force|SV* sv|STRLEN* lp Ap |char* |sv_pvbyten_force|SV* sv|STRLEN* lp -Ap |char* |sv_reftype |SV* sv|int ob -Ap |void |sv_replace |SV* sv|SV* nsv +Apd |char* |sv_reftype |SV* sv|int ob +Apd |void |sv_replace |SV* sv|SV* nsv Ap |void |sv_report_used Ap |void |sv_reset |char* s|HV* stash Afpd |void |sv_setpvf |SV* sv|const char* pat|... @@ -2010,7 +2054,7 @@ Apd |void |sv_setpvn |SV* sv|const char* ptr|STRLEN len Apd |void |sv_setsv |SV* dsv|SV* ssv Ap |void |sv_taint |SV* sv Ap |bool |sv_tainted |SV* sv -Ap |int |sv_unmagic |SV* sv|int type +Apd |int |sv_unmagic |SV* sv|int type Apd |void |sv_unref |SV* sv Ap |void |sv_untaint |SV* sv Apd |bool |sv_upgrade |SV* sv|U32 mt @@ -2039,29 +2083,33 @@ Ap |void |unlock_condpair|void* svv Ap |void |unsharepvn |const char* sv|I32 len|U32 hash p |void |unshare_hek |HEK* hek p |void |utilize |int aver|I32 floor|OP* version|OP* id|OP* arg -Ap |U8* |utf16_to_utf8 |U16* p|U8 *d|I32 bytelen -Ap |U8* |utf16_to_utf8_reversed|U16* p|U8 *d|I32 bytelen -Ap |I32 |utf8_distance |U8 *a|U8 *b -Ap |U8* |utf8_hop |U8 *s|I32 off -Ap |UV |utf8_to_uv |U8 *s|I32* retlen -Ap |U8* |uv_to_utf8 |U8 *d|UV uv +ApM |U8* |utf16_to_utf8 |U8* p|U8 *d|I32 bytelen|I32 *newlen +ApM |U8* |utf16_to_utf8_reversed|U8* p|U8 *d|I32 bytelen|I32 *newlen +ApMd |STRLEN |utf8_length |U8* s|U8 *e +ApMd |IV |utf8_distance |U8 *a|U8 *b +ApMd |U8* |utf8_hop |U8 *s|I32 off +ApMd |U8* |utf8_to_bytes |U8 *s|STRLEN *len +ApMd |U8* |bytes_from_utf8|U8 *s|STRLEN *len|bool *is_utf8 +ApMd |U8* |bytes_to_utf8 |U8 *s|STRLEN *len +ApMd |UV |utf8_to_uv_simple|U8 *s|STRLEN* retlen +ApMd |UV |utf8_to_uv |U8 *s|STRLEN curlen|STRLEN* retlen|U32 flags +ApMd |U8* |uv_to_utf8 |U8 *d|UV uv p |void |vivify_defelem |SV* sv p |void |vivify_ref |SV* sv|U32 to_what p |I32 |wait4pid |Pid_t pid|int* statusp|int flags -p |void |report_closed_fh|GV *gv|IO *io|const char *func|const char *obj +p |void |report_evil_fh |GV *gv|IO *io|I32 op p |void |report_uninit Afpd |void |warn |const char* pat|... Ap |void |vwarn |const char* pat|va_list* args Afp |void |warner |U32 err|const char* pat|... Ap |void |vwarner |U32 err|const char* pat|va_list* args p |void |watch |char** addr -p |I32 |whichsig |char* sig +Ap |I32 |whichsig |char* sig p |int |yyerror |char* s -#if defined(USE_PURE_BISON) -p |int |yylex |YYSTYPE *lvalp|int *lcharp -#else -p |int |yylex +#ifdef USE_PURE_BISON +p |int |yylex_r |YYSTYPE *lvalp|int *lcharp #endif +p |int |yylex p |int |yyparse p |int |yywarn |char* s #if defined(MYMALLOC) @@ -2083,6 +2131,9 @@ Ap |struct perl_vars *|GetVars #endif Ap |int |runops_standard Ap |int |runops_debug +#if defined(USE_THREADS) +Ap |SV* |sv_lock |SV *sv +#endif Afpd |void |sv_catpvf_mg |SV *sv|const char* pat|... Ap |void |sv_vcatpvf_mg |SV* sv|const char* pat|va_list* args Apd |void |sv_catpv_mg |SV *sv|const char *ptr @@ -2127,13 +2178,15 @@ Ap |char* |sv_2pvbyte_nolen|SV* sv Ap |char* |sv_pv |SV *sv Ap |char* |sv_pvutf8 |SV *sv Ap |char* |sv_pvbyte |SV *sv -Ap |void |sv_utf8_upgrade|SV *sv -Ap |bool |sv_utf8_downgrade|SV *sv|bool fail_ok -Ap |void |sv_utf8_encode |SV *sv -Ap |bool |sv_utf8_decode |SV *sv +ApMd |void |sv_utf8_upgrade|SV *sv +ApMd |bool |sv_utf8_downgrade|SV *sv|bool fail_ok +ApMd |void |sv_utf8_encode |SV *sv +ApM |bool |sv_utf8_decode |SV *sv Ap |void |sv_force_normal|SV *sv +Ap |void |sv_add_backref |SV *tsv|SV *sv +Ap |void |sv_del_backref |SV *sv Ap |void |tmps_grow |I32 n -Ap |SV* |sv_rvweaken |SV *sv +Apd |SV* |sv_rvweaken |SV *sv p |int |magic_killbackrefs|SV *sv|MAGIC *mg Ap |OP* |newANONATTRSUB |I32 floor|OP *proto|OP *attrs|OP *block Ap |CV* |newATTRSUB |I32 floor|OP *o|OP *proto|OP *attrs|OP *block @@ -2160,6 +2213,12 @@ Ap |PTR_TBL_t*|ptr_table_new Ap |void* |ptr_table_fetch|PTR_TBL_t *tbl|void *sv Ap |void |ptr_table_store|PTR_TBL_t *tbl|void *oldsv|void *newsv Ap |void |ptr_table_split|PTR_TBL_t *tbl +Ap |void |ptr_table_clear|PTR_TBL_t *tbl +Ap |void |ptr_table_free|PTR_TBL_t *tbl +#endif +#if defined(HAVE_INTERP_INTERN) +Ap |void |sys_intern_clear +Ap |void |sys_intern_init #endif #if defined(PERL_OBJECT) @@ -2174,16 +2233,12 @@ s |I32 |avhv_index |AV* av|SV* sv|U32 hash #endif #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) -s |I32 |do_trans_CC_simple |SV *sv -s |I32 |do_trans_CC_count |SV *sv -s |I32 |do_trans_CC_complex |SV *sv -s |I32 |do_trans_UU_simple |SV *sv -s |I32 |do_trans_UU_count |SV *sv -s |I32 |do_trans_UU_complex |SV *sv -s |I32 |do_trans_UC_simple |SV *sv -s |I32 |do_trans_CU_simple |SV *sv -s |I32 |do_trans_UC_trivial |SV *sv -s |I32 |do_trans_CU_trivial |SV *sv +s |I32 |do_trans_simple |SV *sv +s |I32 |do_trans_count |SV *sv +s |I32 |do_trans_complex |SV *sv +s |I32 |do_trans_simple_utf8 |SV *sv +s |I32 |do_trans_count_utf8 |SV *sv +s |I32 |do_trans_complex_utf8 |SV *sv #endif #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT) @@ -2217,6 +2272,7 @@ s |OP* |no_fh_allowed |OP *o s |OP* |scalarboolean |OP *o s |OP* |too_few_arguments|OP *o|char* name s |OP* |too_many_arguments|OP *o|char* name +s |U8* |trlist_upgrade |U8** sp|U8** ep s |void |op_clear |OP* o s |void |null |OP* o s |PADOFFSET|pad_addlex |SV* name @@ -2294,7 +2350,6 @@ s |I32 |dopoptolabel |char *label s |I32 |dopoptoloop |I32 startingblock s |I32 |dopoptosub |I32 startingblock s |I32 |dopoptosub_at |PERL_CONTEXT* cxstk|I32 startingblock -s |void |free_closures s |void |save_lines |AV *array|SV *sv s |OP* |doeval |int gimme|OP** startop s |PerlIO *|doopen_pmc |const char *name|const char *mode @@ -2322,7 +2377,7 @@ 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 |void |reguni |UV|char *|STRLEN* s |regnode*|regclass s |regnode*|regclassutf8 s |I32 |regcurly |char * @@ -2420,9 +2475,7 @@ s |void |del_xpvbm |XPVBM* p s |void |del_xrv |XRV* p s |void |sv_unglob |SV* sv s |void |not_a_number |SV *sv -s |void |visit |SVFUNC_t f -s |void |sv_add_backref |SV *tsv|SV *sv -s |void |sv_del_backref |SV *sv +s |I32 |visit |SVFUNC_t f # if defined(DEBUGGING) s |void |del_sv |SV *p # endif @@ -2448,6 +2501,7 @@ s |char* |scan_trans |char *start s |char* |scan_word |char *s|char *dest|STRLEN destlen \ |int allow_package|STRLEN *slp s |char* |skipspace |char *s +s |char* |swallow_bom |U8 *s s |void |checkcomma |char *s|char *name|char *what s |void |force_ident |char *s|int kind s |void |incline |char *s @@ -2461,6 +2515,7 @@ s |I32 |sublex_done s |I32 |sublex_push s |I32 |sublex_start s |char * |filter_gets |SV *sv|PerlIO *fp|STRLEN append +s |HV * |find_in_my_stash|char *pkgname|I32 len s |SV* |new_constant |char *s|STRLEN len|const char *key|SV *sv \ |SV *pv|const char *type s |int |ao |int toketype @@ -2483,6 +2538,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/contrib/perl5/embedvar.h b/contrib/perl5/embedvar.h index e790976a18f3..f4ebaa9839ac 100644 --- a/contrib/perl5/embedvar.h +++ b/contrib/perl5/embedvar.h @@ -196,6 +196,7 @@ #define PL_argvoutgv (PERL_GET_INTERP->Iargvoutgv) #define PL_basetime (PERL_GET_INTERP->Ibasetime) #define PL_beginav (PERL_GET_INTERP->Ibeginav) +#define PL_beginav_save (PERL_GET_INTERP->Ibeginav_save) #define PL_bitcount (PERL_GET_INTERP->Ibitcount) #define PL_bufend (PERL_GET_INTERP->Ibufend) #define PL_bufptr (PERL_GET_INTERP->Ibufptr) @@ -228,6 +229,7 @@ #define PL_doextract (PERL_GET_INTERP->Idoextract) #define PL_doswitches (PERL_GET_INTERP->Idoswitches) #define PL_dowarn (PERL_GET_INTERP->Idowarn) +#define PL_dummy1_bincompat (PERL_GET_INTERP->Idummy1_bincompat) #define PL_e_script (PERL_GET_INTERP->Ie_script) #define PL_egid (PERL_GET_INTERP->Iegid) #define PL_endav (PERL_GET_INTERP->Iendav) @@ -246,6 +248,7 @@ #define PL_exitlistlen (PERL_GET_INTERP->Iexitlistlen) #define PL_expect (PERL_GET_INTERP->Iexpect) #define PL_fdpid (PERL_GET_INTERP->Ifdpid) +#define PL_fdpid_mutex (PERL_GET_INTERP->Ifdpid_mutex) #define PL_filemode (PERL_GET_INTERP->Ifilemode) #define PL_forkprocess (PERL_GET_INTERP->Iforkprocess) #define PL_formfeed (PERL_GET_INTERP->Iformfeed) @@ -254,6 +257,7 @@ #define PL_gid (PERL_GET_INTERP->Igid) #define PL_glob_index (PERL_GET_INTERP->Iglob_index) #define PL_globalstash (PERL_GET_INTERP->Iglobalstash) +#define PL_he_arenaroot (PERL_GET_INTERP->Ihe_arenaroot) #define PL_he_root (PERL_GET_INTERP->Ihe_root) #define PL_hintgv (PERL_GET_INTERP->Ihintgv) #define PL_hints (PERL_GET_INTERP->Ihints) @@ -322,9 +326,10 @@ #define PL_nomemok (PERL_GET_INTERP->Inomemok) #define PL_nthreads (PERL_GET_INTERP->Inthreads) #define PL_nthreads_cond (PERL_GET_INTERP->Inthreads_cond) +#define PL_nullstash (PERL_GET_INTERP->Inullstash) #define PL_numeric_local (PERL_GET_INTERP->Inumeric_local) #define PL_numeric_name (PERL_GET_INTERP->Inumeric_name) -#define PL_numeric_radix (PERL_GET_INTERP->Inumeric_radix) +#define PL_numeric_radix_sv (PERL_GET_INTERP->Inumeric_radix_sv) #define PL_numeric_standard (PERL_GET_INTERP->Inumeric_standard) #define PL_ofmt (PERL_GET_INTERP->Iofmt) #define PL_oldbufptr (PERL_GET_INTERP->Ioldbufptr) @@ -376,6 +381,7 @@ #define PL_subname (PERL_GET_INTERP->Isubname) #define PL_sv_arenaroot (PERL_GET_INTERP->Isv_arenaroot) #define PL_sv_count (PERL_GET_INTERP->Isv_count) +#define PL_sv_lock_mutex (PERL_GET_INTERP->Isv_lock_mutex) #define PL_sv_mutex (PERL_GET_INTERP->Isv_mutex) #define PL_sv_no (PERL_GET_INTERP->Isv_no) #define PL_sv_objcount (PERL_GET_INTERP->Isv_objcount) @@ -414,16 +420,27 @@ #define PL_widesyscalls (PERL_GET_INTERP->Iwidesyscalls) #define PL_xiv_arenaroot (PERL_GET_INTERP->Ixiv_arenaroot) #define PL_xiv_root (PERL_GET_INTERP->Ixiv_root) +#define PL_xnv_arenaroot (PERL_GET_INTERP->Ixnv_arenaroot) #define PL_xnv_root (PERL_GET_INTERP->Ixnv_root) +#define PL_xpv_arenaroot (PERL_GET_INTERP->Ixpv_arenaroot) #define PL_xpv_root (PERL_GET_INTERP->Ixpv_root) +#define PL_xpvav_arenaroot (PERL_GET_INTERP->Ixpvav_arenaroot) #define PL_xpvav_root (PERL_GET_INTERP->Ixpvav_root) +#define PL_xpvbm_arenaroot (PERL_GET_INTERP->Ixpvbm_arenaroot) #define PL_xpvbm_root (PERL_GET_INTERP->Ixpvbm_root) +#define PL_xpvcv_arenaroot (PERL_GET_INTERP->Ixpvcv_arenaroot) #define PL_xpvcv_root (PERL_GET_INTERP->Ixpvcv_root) +#define PL_xpvhv_arenaroot (PERL_GET_INTERP->Ixpvhv_arenaroot) #define PL_xpvhv_root (PERL_GET_INTERP->Ixpvhv_root) +#define PL_xpviv_arenaroot (PERL_GET_INTERP->Ixpviv_arenaroot) #define PL_xpviv_root (PERL_GET_INTERP->Ixpviv_root) +#define PL_xpvlv_arenaroot (PERL_GET_INTERP->Ixpvlv_arenaroot) #define PL_xpvlv_root (PERL_GET_INTERP->Ixpvlv_root) +#define PL_xpvmg_arenaroot (PERL_GET_INTERP->Ixpvmg_arenaroot) #define PL_xpvmg_root (PERL_GET_INTERP->Ixpvmg_root) +#define PL_xpvnv_arenaroot (PERL_GET_INTERP->Ixpvnv_arenaroot) #define PL_xpvnv_root (PERL_GET_INTERP->Ixpvnv_root) +#define PL_xrv_arenaroot (PERL_GET_INTERP->Ixrv_arenaroot) #define PL_xrv_root (PERL_GET_INTERP->Ixrv_root) #define PL_yychar (PERL_GET_INTERP->Iyychar) #define PL_yydebug (PERL_GET_INTERP->Iyydebug) @@ -460,6 +477,7 @@ #define PL_argvoutgv (vTHX->Iargvoutgv) #define PL_basetime (vTHX->Ibasetime) #define PL_beginav (vTHX->Ibeginav) +#define PL_beginav_save (vTHX->Ibeginav_save) #define PL_bitcount (vTHX->Ibitcount) #define PL_bufend (vTHX->Ibufend) #define PL_bufptr (vTHX->Ibufptr) @@ -492,6 +510,7 @@ #define PL_doextract (vTHX->Idoextract) #define PL_doswitches (vTHX->Idoswitches) #define PL_dowarn (vTHX->Idowarn) +#define PL_dummy1_bincompat (vTHX->Idummy1_bincompat) #define PL_e_script (vTHX->Ie_script) #define PL_egid (vTHX->Iegid) #define PL_endav (vTHX->Iendav) @@ -510,6 +529,7 @@ #define PL_exitlistlen (vTHX->Iexitlistlen) #define PL_expect (vTHX->Iexpect) #define PL_fdpid (vTHX->Ifdpid) +#define PL_fdpid_mutex (vTHX->Ifdpid_mutex) #define PL_filemode (vTHX->Ifilemode) #define PL_forkprocess (vTHX->Iforkprocess) #define PL_formfeed (vTHX->Iformfeed) @@ -518,6 +538,7 @@ #define PL_gid (vTHX->Igid) #define PL_glob_index (vTHX->Iglob_index) #define PL_globalstash (vTHX->Iglobalstash) +#define PL_he_arenaroot (vTHX->Ihe_arenaroot) #define PL_he_root (vTHX->Ihe_root) #define PL_hintgv (vTHX->Ihintgv) #define PL_hints (vTHX->Ihints) @@ -586,9 +607,10 @@ #define PL_nomemok (vTHX->Inomemok) #define PL_nthreads (vTHX->Inthreads) #define PL_nthreads_cond (vTHX->Inthreads_cond) +#define PL_nullstash (vTHX->Inullstash) #define PL_numeric_local (vTHX->Inumeric_local) #define PL_numeric_name (vTHX->Inumeric_name) -#define PL_numeric_radix (vTHX->Inumeric_radix) +#define PL_numeric_radix_sv (vTHX->Inumeric_radix_sv) #define PL_numeric_standard (vTHX->Inumeric_standard) #define PL_ofmt (vTHX->Iofmt) #define PL_oldbufptr (vTHX->Ioldbufptr) @@ -640,6 +662,7 @@ #define PL_subname (vTHX->Isubname) #define PL_sv_arenaroot (vTHX->Isv_arenaroot) #define PL_sv_count (vTHX->Isv_count) +#define PL_sv_lock_mutex (vTHX->Isv_lock_mutex) #define PL_sv_mutex (vTHX->Isv_mutex) #define PL_sv_no (vTHX->Isv_no) #define PL_sv_objcount (vTHX->Isv_objcount) @@ -678,16 +701,27 @@ #define PL_widesyscalls (vTHX->Iwidesyscalls) #define PL_xiv_arenaroot (vTHX->Ixiv_arenaroot) #define PL_xiv_root (vTHX->Ixiv_root) +#define PL_xnv_arenaroot (vTHX->Ixnv_arenaroot) #define PL_xnv_root (vTHX->Ixnv_root) +#define PL_xpv_arenaroot (vTHX->Ixpv_arenaroot) #define PL_xpv_root (vTHX->Ixpv_root) +#define PL_xpvav_arenaroot (vTHX->Ixpvav_arenaroot) #define PL_xpvav_root (vTHX->Ixpvav_root) +#define PL_xpvbm_arenaroot (vTHX->Ixpvbm_arenaroot) #define PL_xpvbm_root (vTHX->Ixpvbm_root) +#define PL_xpvcv_arenaroot (vTHX->Ixpvcv_arenaroot) #define PL_xpvcv_root (vTHX->Ixpvcv_root) +#define PL_xpvhv_arenaroot (vTHX->Ixpvhv_arenaroot) #define PL_xpvhv_root (vTHX->Ixpvhv_root) +#define PL_xpviv_arenaroot (vTHX->Ixpviv_arenaroot) #define PL_xpviv_root (vTHX->Ixpviv_root) +#define PL_xpvlv_arenaroot (vTHX->Ixpvlv_arenaroot) #define PL_xpvlv_root (vTHX->Ixpvlv_root) +#define PL_xpvmg_arenaroot (vTHX->Ixpvmg_arenaroot) #define PL_xpvmg_root (vTHX->Ixpvmg_root) +#define PL_xpvnv_arenaroot (vTHX->Ixpvnv_arenaroot) #define PL_xpvnv_root (vTHX->Ixpvnv_root) +#define PL_xrv_arenaroot (vTHX->Ixrv_arenaroot) #define PL_xrv_root (vTHX->Ixrv_root) #define PL_yychar (vTHX->Iyychar) #define PL_yydebug (vTHX->Iyydebug) @@ -861,6 +895,7 @@ #define PL_argvoutgv (aTHXo->interp.Iargvoutgv) #define PL_basetime (aTHXo->interp.Ibasetime) #define PL_beginav (aTHXo->interp.Ibeginav) +#define PL_beginav_save (aTHXo->interp.Ibeginav_save) #define PL_bitcount (aTHXo->interp.Ibitcount) #define PL_bufend (aTHXo->interp.Ibufend) #define PL_bufptr (aTHXo->interp.Ibufptr) @@ -893,6 +928,7 @@ #define PL_doextract (aTHXo->interp.Idoextract) #define PL_doswitches (aTHXo->interp.Idoswitches) #define PL_dowarn (aTHXo->interp.Idowarn) +#define PL_dummy1_bincompat (aTHXo->interp.Idummy1_bincompat) #define PL_e_script (aTHXo->interp.Ie_script) #define PL_egid (aTHXo->interp.Iegid) #define PL_endav (aTHXo->interp.Iendav) @@ -911,6 +947,7 @@ #define PL_exitlistlen (aTHXo->interp.Iexitlistlen) #define PL_expect (aTHXo->interp.Iexpect) #define PL_fdpid (aTHXo->interp.Ifdpid) +#define PL_fdpid_mutex (aTHXo->interp.Ifdpid_mutex) #define PL_filemode (aTHXo->interp.Ifilemode) #define PL_forkprocess (aTHXo->interp.Iforkprocess) #define PL_formfeed (aTHXo->interp.Iformfeed) @@ -919,6 +956,7 @@ #define PL_gid (aTHXo->interp.Igid) #define PL_glob_index (aTHXo->interp.Iglob_index) #define PL_globalstash (aTHXo->interp.Iglobalstash) +#define PL_he_arenaroot (aTHXo->interp.Ihe_arenaroot) #define PL_he_root (aTHXo->interp.Ihe_root) #define PL_hintgv (aTHXo->interp.Ihintgv) #define PL_hints (aTHXo->interp.Ihints) @@ -987,9 +1025,10 @@ #define PL_nomemok (aTHXo->interp.Inomemok) #define PL_nthreads (aTHXo->interp.Inthreads) #define PL_nthreads_cond (aTHXo->interp.Inthreads_cond) +#define PL_nullstash (aTHXo->interp.Inullstash) #define PL_numeric_local (aTHXo->interp.Inumeric_local) #define PL_numeric_name (aTHXo->interp.Inumeric_name) -#define PL_numeric_radix (aTHXo->interp.Inumeric_radix) +#define PL_numeric_radix_sv (aTHXo->interp.Inumeric_radix_sv) #define PL_numeric_standard (aTHXo->interp.Inumeric_standard) #define PL_ofmt (aTHXo->interp.Iofmt) #define PL_oldbufptr (aTHXo->interp.Ioldbufptr) @@ -1041,6 +1080,7 @@ #define PL_subname (aTHXo->interp.Isubname) #define PL_sv_arenaroot (aTHXo->interp.Isv_arenaroot) #define PL_sv_count (aTHXo->interp.Isv_count) +#define PL_sv_lock_mutex (aTHXo->interp.Isv_lock_mutex) #define PL_sv_mutex (aTHXo->interp.Isv_mutex) #define PL_sv_no (aTHXo->interp.Isv_no) #define PL_sv_objcount (aTHXo->interp.Isv_objcount) @@ -1079,16 +1119,27 @@ #define PL_widesyscalls (aTHXo->interp.Iwidesyscalls) #define PL_xiv_arenaroot (aTHXo->interp.Ixiv_arenaroot) #define PL_xiv_root (aTHXo->interp.Ixiv_root) +#define PL_xnv_arenaroot (aTHXo->interp.Ixnv_arenaroot) #define PL_xnv_root (aTHXo->interp.Ixnv_root) +#define PL_xpv_arenaroot (aTHXo->interp.Ixpv_arenaroot) #define PL_xpv_root (aTHXo->interp.Ixpv_root) +#define PL_xpvav_arenaroot (aTHXo->interp.Ixpvav_arenaroot) #define PL_xpvav_root (aTHXo->interp.Ixpvav_root) +#define PL_xpvbm_arenaroot (aTHXo->interp.Ixpvbm_arenaroot) #define PL_xpvbm_root (aTHXo->interp.Ixpvbm_root) +#define PL_xpvcv_arenaroot (aTHXo->interp.Ixpvcv_arenaroot) #define PL_xpvcv_root (aTHXo->interp.Ixpvcv_root) +#define PL_xpvhv_arenaroot (aTHXo->interp.Ixpvhv_arenaroot) #define PL_xpvhv_root (aTHXo->interp.Ixpvhv_root) +#define PL_xpviv_arenaroot (aTHXo->interp.Ixpviv_arenaroot) #define PL_xpviv_root (aTHXo->interp.Ixpviv_root) +#define PL_xpvlv_arenaroot (aTHXo->interp.Ixpvlv_arenaroot) #define PL_xpvlv_root (aTHXo->interp.Ixpvlv_root) +#define PL_xpvmg_arenaroot (aTHXo->interp.Ixpvmg_arenaroot) #define PL_xpvmg_root (aTHXo->interp.Ixpvmg_root) +#define PL_xpvnv_arenaroot (aTHXo->interp.Ixpvnv_arenaroot) #define PL_xpvnv_root (aTHXo->interp.Ixpvnv_root) +#define PL_xrv_arenaroot (aTHXo->interp.Ixrv_arenaroot) #define PL_xrv_root (aTHXo->interp.Ixrv_root) #define PL_yychar (aTHXo->interp.Iyychar) #define PL_yydebug (aTHXo->interp.Iyydebug) @@ -1126,6 +1177,7 @@ #define PL_Iargvoutgv PL_argvoutgv #define PL_Ibasetime PL_basetime #define PL_Ibeginav PL_beginav +#define PL_Ibeginav_save PL_beginav_save #define PL_Ibitcount PL_bitcount #define PL_Ibufend PL_bufend #define PL_Ibufptr PL_bufptr @@ -1158,6 +1210,7 @@ #define PL_Idoextract PL_doextract #define PL_Idoswitches PL_doswitches #define PL_Idowarn PL_dowarn +#define PL_Idummy1_bincompat PL_dummy1_bincompat #define PL_Ie_script PL_e_script #define PL_Iegid PL_egid #define PL_Iendav PL_endav @@ -1176,6 +1229,7 @@ #define PL_Iexitlistlen PL_exitlistlen #define PL_Iexpect PL_expect #define PL_Ifdpid PL_fdpid +#define PL_Ifdpid_mutex PL_fdpid_mutex #define PL_Ifilemode PL_filemode #define PL_Iforkprocess PL_forkprocess #define PL_Iformfeed PL_formfeed @@ -1184,6 +1238,7 @@ #define PL_Igid PL_gid #define PL_Iglob_index PL_glob_index #define PL_Iglobalstash PL_globalstash +#define PL_Ihe_arenaroot PL_he_arenaroot #define PL_Ihe_root PL_he_root #define PL_Ihintgv PL_hintgv #define PL_Ihints PL_hints @@ -1252,9 +1307,10 @@ #define PL_Inomemok PL_nomemok #define PL_Inthreads PL_nthreads #define PL_Inthreads_cond PL_nthreads_cond +#define PL_Inullstash PL_nullstash #define PL_Inumeric_local PL_numeric_local #define PL_Inumeric_name PL_numeric_name -#define PL_Inumeric_radix PL_numeric_radix +#define PL_Inumeric_radix_sv PL_numeric_radix_sv #define PL_Inumeric_standard PL_numeric_standard #define PL_Iofmt PL_ofmt #define PL_Ioldbufptr PL_oldbufptr @@ -1306,6 +1362,7 @@ #define PL_Isubname PL_subname #define PL_Isv_arenaroot PL_sv_arenaroot #define PL_Isv_count PL_sv_count +#define PL_Isv_lock_mutex PL_sv_lock_mutex #define PL_Isv_mutex PL_sv_mutex #define PL_Isv_no PL_sv_no #define PL_Isv_objcount PL_sv_objcount @@ -1344,16 +1401,27 @@ #define PL_Iwidesyscalls PL_widesyscalls #define PL_Ixiv_arenaroot PL_xiv_arenaroot #define PL_Ixiv_root PL_xiv_root +#define PL_Ixnv_arenaroot PL_xnv_arenaroot #define PL_Ixnv_root PL_xnv_root +#define PL_Ixpv_arenaroot PL_xpv_arenaroot #define PL_Ixpv_root PL_xpv_root +#define PL_Ixpvav_arenaroot PL_xpvav_arenaroot #define PL_Ixpvav_root PL_xpvav_root +#define PL_Ixpvbm_arenaroot PL_xpvbm_arenaroot #define PL_Ixpvbm_root PL_xpvbm_root +#define PL_Ixpvcv_arenaroot PL_xpvcv_arenaroot #define PL_Ixpvcv_root PL_xpvcv_root +#define PL_Ixpvhv_arenaroot PL_xpvhv_arenaroot #define PL_Ixpvhv_root PL_xpvhv_root +#define PL_Ixpviv_arenaroot PL_xpviv_arenaroot #define PL_Ixpviv_root PL_xpviv_root +#define PL_Ixpvlv_arenaroot PL_xpvlv_arenaroot #define PL_Ixpvlv_root PL_xpvlv_root +#define PL_Ixpvmg_arenaroot PL_xpvmg_arenaroot #define PL_Ixpvmg_root PL_xpvmg_root +#define PL_Ixpvnv_arenaroot PL_xpvnv_arenaroot #define PL_Ixpvnv_root PL_xpvnv_root +#define PL_Ixrv_arenaroot PL_xrv_arenaroot #define PL_Ixrv_root PL_xrv_root #define PL_Iyychar PL_yychar #define PL_Iyydebug PL_yydebug @@ -1683,6 +1751,7 @@ #define no_modify PL_no_modify #define perl_destruct_level PL_perl_destruct_level #define perldb PL_perldb +#define ppaddr PL_ppaddr #define rsfp PL_rsfp #define rsfp_filters PL_rsfp_filters #define stack_base PL_stack_base diff --git a/contrib/perl5/ext/B/B.pm b/contrib/perl5/ext/B/B.pm index 4512d916e61e..c58e769a84d5 100644 --- a/contrib/perl5/ext/B/B.pm +++ b/contrib/perl5/ext/B/B.pm @@ -9,11 +9,17 @@ package B; use XSLoader (); require Exporter; @ISA = qw(Exporter); -@EXPORT_OK = qw(minus_c ppname + +# 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 - parents comppadlist sv_undef compile_stats timing_info init_av); + 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'; @@ -54,6 +60,21 @@ use strict; package B::OBJECT; } +sub B::GV::SAFENAME { + my $name = (shift())->NAME; + + # The regex below corresponds to the isCONTROLVAR macro + # from toke.c + + $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".chr(64 ^ ord($1))/e; + return $name; +} + +sub B::IV::int_value { + my ($self) = @_; + return (($self->FLAGS() & SVf_IVisUV()) ? $self->UVX : $self->IV); +} + my $debug; my $op_count = 0; my @parents = (); @@ -125,6 +146,7 @@ sub objsym { sub walkoptree_exec { my ($op, $method, $level) = @_; + $level ||= 0; my ($sym, $ppname); my $prefix = " " x $level; for (; $$op; $op = $op->next) { @@ -184,7 +206,7 @@ sub walksymtable { *glob = "*main::".$prefix.$sym; if ($sym =~ /::$/) { $sym = $prefix . $sym; - if ($sym ne "main::" && &$recurse($sym)) { + if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) { walksymtable(\%glob, $method, $recurse, $sym); } } else { @@ -326,8 +348,22 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>). =item IV +Returns the value of the IV, I<interpreted as +a signed integer>. This will be misleading +if C<FLAGS & SVf_IVisUV>. Perhaps you want the +C<int_value> method instead? + =item IVX +=item UVX + +=item int_value + +This method returns the value of the IV as an integer. +It differs from C<IV> in that it returns the correct +value regardless of whether it's stored signed or +unsigned. + =item needs64bits =item packiv @@ -358,6 +394,22 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>). =item PV +This method is the one you usually want. It constructs a +string using the length and offset information in the struct: +for ordinary scalars it will return the string that you'd see +from Perl, even if it contains null characters. + +=item PVX + +This method is less often useful. It assumes that the string +stored in the struct is null-terminated, and disregards the +length information. + +It is the appropriate method to use if you need to get the name +of a lexical variable from a padname array. Lexical variable names +are always stored with a null terminator, and the length field +(SvCUR) is overloaded for other purposes and can't be relied on here. + =back =head2 B::PVMG METHODS @@ -426,6 +478,21 @@ This method returns TRUE if the GP field of the GV is NULL. =item NAME +=item SAFENAME + +This method returns the name of the glob, but if the first +character of the name is a control character, then it converts +it to ^X first, so that *^G would return "^G" rather than "\cG". + +It's useful if you want to print out the name of a variable. +If you restrict yourself to globs which exist at compile-time +then the result ought to be unambiguous, because code like +C<${"^G"} = 1> is compiled as two ops - a constant string and +a dereference (rv2gv) - so that the glob is created at runtime. + +If you're working with globs at runtime, and need to disambiguate +*^G from *{"^G"}, then you should use the raw NAME method. + =item STASH =item SV diff --git a/contrib/perl5/ext/B/B.xs b/contrib/perl5/ext/B/B.xs index 9e2985582a15..100574752115 100644 --- a/contrib/perl5/ext/B/B.xs +++ b/contrib/perl5/ext/B/B.xs @@ -81,7 +81,7 @@ static char *opclassnames[] = { static int walkoptree_debug = 0; /* Flag for walkoptree debug hook */ -static SV *specialsv_list[4]; +static SV *specialsv_list[6]; static opclass cc_opclass(pTHX_ OP *o) @@ -386,11 +386,15 @@ BOOT: specialsv_list[1] = &PL_sv_undef; specialsv_list[2] = &PL_sv_yes; specialsv_list[3] = &PL_sv_no; + specialsv_list[4] = pWARN_ALL; + specialsv_list[5] = pWARN_NONE; #include "defsubs.h" } #define B_main_cv() PL_main_cv #define B_init_av() PL_initav +#define B_begin_av() PL_beginav_save +#define B_end_av() PL_endav #define B_main_root() PL_main_root #define B_main_start() PL_main_start #define B_amagic_generation() PL_amagic_generation @@ -402,6 +406,12 @@ BOOT: B::AV B_init_av() +B::AV +B_begin_av() + +B::AV +B_end_av() + B::CV B_main_cv() @@ -515,6 +525,11 @@ minus_c() CODE: PL_minus_c = TRUE; +void +save_BEGINs() + CODE: + PL_minus_c |= 0x10; + SV * cstring(sv) SV * sv @@ -567,11 +582,12 @@ char * OP_name(o) B::OP o CODE: - ST(0) = sv_newmortal(); - sv_setpv(ST(0), PL_op_name[o->op_type]); + RETVAL = PL_op_name[o->op_type]; + OUTPUT: + RETVAL -char * +void OP_ppaddr(o) B::OP o PREINIT: @@ -633,13 +649,20 @@ B::OP LOGOP_other(o) B::LOGOP o -#define LISTOP_children(o) o->op_children - MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_ U32 LISTOP_children(o) B::LISTOP o + OP * kid = NO_INIT + int i = NO_INIT + CODE: + i = 0; + for (kid = o->op_first; kid; kid = kid->op_sibling) + i++; + RETVAL = i; + OUTPUT: + RETVAL #define PMOP_pmreplroot(o) o->op_pmreplroot #define PMOP_pmreplstart(o) o->op_pmreplstart @@ -693,8 +716,8 @@ PMOP_precomp(o) if (rx) sv_setpvn(ST(0), rx->precomp, rx->prelen); -#define SVOP_sv(o) cSVOPo->op_sv -#define SVOP_gv(o) ((GV*)cSVOPo->op_sv) +#define SVOP_sv(o) cSVOPo->op_sv +#define SVOP_gv(o) ((GV*)cSVOPo->op_sv) MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_ @@ -862,11 +885,11 @@ packiv(sv) MODULE = B PACKAGE = B::NV PREFIX = Sv -double +NV SvNV(sv) B::NV sv -double +NV SvNVX(sv) B::NV sv @@ -878,6 +901,10 @@ SvRV(sv) MODULE = B PACKAGE = B::PV PREFIX = Sv +char* +SvPVX(sv) + B::PV sv + void SvPV(sv) B::PV sv @@ -1210,7 +1237,7 @@ CvXSUBANY(cv) MODULE = B PACKAGE = B::CV -U8 +U16 CvFLAGS(cv) B::CV cv @@ -1251,7 +1278,7 @@ HvARRAY(hv) I32 len; (void)hv_iterinit(hv); EXTEND(sp, HvKEYS(hv) * 2); - while (sv = hv_iternextsv(hv, &key, &len)) { + while ((sv = hv_iternextsv(hv, &key, &len))) { PUSHs(newSVpvn(key, len)); PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv)); } diff --git a/contrib/perl5/ext/B/B/Asmdata.pm b/contrib/perl5/ext/B/B/Asmdata.pm index bc0eda935b7a..dc176be9626e 100644 --- a/contrib/perl5/ext/B/B/Asmdata.pm +++ b/contrib/perl5/ext/B/B/Asmdata.pm @@ -15,7 +15,7 @@ use Exporter; our(%insn_data, @insn_name, @optype, @specialsv_name); @optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP); -@specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no); +@specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE); # XXX insn_data is initialised this way because with a large # %insn_data = (foo => [...], bar => [...], ...) initialiser @@ -27,93 +27,93 @@ $insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"]; $insn_data{ldop} = [2, \&PUT_opindex, "GET_opindex"]; $insn_data{stsv} = [3, \&PUT_U32, "GET_U32"]; $insn_data{stop} = [4, \&PUT_U32, "GET_U32"]; -$insn_data{ldspecsv} = [5, \&PUT_U8, "GET_U8"]; -$insn_data{newsv} = [6, \&PUT_U8, "GET_U8"]; -$insn_data{newop} = [7, \&PUT_U8, "GET_U8"]; -$insn_data{newopn} = [8, \&PUT_U8, "GET_U8"]; -$insn_data{newpv} = [9, \&PUT_PV, "GET_PV"]; -$insn_data{pv_cur} = [11, \&PUT_U32, "GET_U32"]; -$insn_data{pv_free} = [12, \&PUT_none, "GET_none"]; -$insn_data{sv_upgrade} = [13, \&PUT_U8, "GET_U8"]; -$insn_data{sv_refcnt} = [14, \&PUT_U32, "GET_U32"]; -$insn_data{sv_refcnt_add} = [15, \&PUT_I32, "GET_I32"]; -$insn_data{sv_flags} = [16, \&PUT_U32, "GET_U32"]; -$insn_data{xrv} = [17, \&PUT_svindex, "GET_svindex"]; -$insn_data{xpv} = [18, \&PUT_none, "GET_none"]; -$insn_data{xiv32} = [19, \&PUT_I32, "GET_I32"]; -$insn_data{xiv64} = [20, \&PUT_IV64, "GET_IV64"]; -$insn_data{xnv} = [21, \&PUT_NV, "GET_NV"]; -$insn_data{xlv_targoff} = [22, \&PUT_U32, "GET_U32"]; -$insn_data{xlv_targlen} = [23, \&PUT_U32, "GET_U32"]; -$insn_data{xlv_targ} = [24, \&PUT_svindex, "GET_svindex"]; -$insn_data{xlv_type} = [25, \&PUT_U8, "GET_U8"]; -$insn_data{xbm_useful} = [26, \&PUT_I32, "GET_I32"]; -$insn_data{xbm_previous} = [27, \&PUT_U16, "GET_U16"]; -$insn_data{xbm_rare} = [28, \&PUT_U8, "GET_U8"]; -$insn_data{xfm_lines} = [29, \&PUT_I32, "GET_I32"]; -$insn_data{xio_lines} = [30, \&PUT_I32, "GET_I32"]; -$insn_data{xio_page} = [31, \&PUT_I32, "GET_I32"]; -$insn_data{xio_page_len} = [32, \&PUT_I32, "GET_I32"]; -$insn_data{xio_lines_left} = [33, \&PUT_I32, "GET_I32"]; -$insn_data{xio_top_name} = [34, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xio_top_gv} = [36, \&PUT_svindex, "GET_svindex"]; -$insn_data{xio_fmt_name} = [37, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xio_fmt_gv} = [38, \&PUT_svindex, "GET_svindex"]; -$insn_data{xio_bottom_name} = [39, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xio_bottom_gv} = [40, \&PUT_svindex, "GET_svindex"]; -$insn_data{xio_subprocess} = [41, \&PUT_U16, "GET_U16"]; -$insn_data{xio_type} = [42, \&PUT_U8, "GET_U8"]; -$insn_data{xio_flags} = [43, \&PUT_U8, "GET_U8"]; -$insn_data{xcv_stash} = [44, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_start} = [45, \&PUT_opindex, "GET_opindex"]; -$insn_data{xcv_root} = [46, \&PUT_opindex, "GET_opindex"]; -$insn_data{xcv_gv} = [47, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_file} = [48, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xcv_depth} = [49, \&PUT_I32, "GET_I32"]; -$insn_data{xcv_padlist} = [50, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_outside} = [51, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_flags} = [52, \&PUT_U16, "GET_U16"]; -$insn_data{av_extend} = [53, \&PUT_I32, "GET_I32"]; -$insn_data{av_push} = [54, \&PUT_svindex, "GET_svindex"]; -$insn_data{xav_fill} = [55, \&PUT_I32, "GET_I32"]; -$insn_data{xav_max} = [56, \&PUT_I32, "GET_I32"]; -$insn_data{xav_flags} = [57, \&PUT_U8, "GET_U8"]; -$insn_data{xhv_riter} = [58, \&PUT_I32, "GET_I32"]; -$insn_data{xhv_name} = [59, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{hv_store} = [60, \&PUT_svindex, "GET_svindex"]; -$insn_data{sv_magic} = [61, \&PUT_U8, "GET_U8"]; -$insn_data{mg_obj} = [62, \&PUT_svindex, "GET_svindex"]; -$insn_data{mg_private} = [63, \&PUT_U16, "GET_U16"]; -$insn_data{mg_flags} = [64, \&PUT_U8, "GET_U8"]; -$insn_data{mg_pv} = [65, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xmg_stash} = [66, \&PUT_svindex, "GET_svindex"]; -$insn_data{gv_fetchpv} = [67, \&PUT_strconst, "GET_strconst"]; -$insn_data{gv_stashpv} = [68, \&PUT_strconst, "GET_strconst"]; -$insn_data{gp_sv} = [69, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_refcnt} = [70, \&PUT_U32, "GET_U32"]; -$insn_data{gp_refcnt_add} = [71, \&PUT_I32, "GET_I32"]; -$insn_data{gp_av} = [72, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_hv} = [73, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_cv} = [74, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_file} = [75, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{gp_io} = [76, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_form} = [77, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_cvgen} = [78, \&PUT_U32, "GET_U32"]; -$insn_data{gp_line} = [79, \&PUT_U16, "GET_U16"]; -$insn_data{gp_share} = [80, \&PUT_svindex, "GET_svindex"]; -$insn_data{xgv_flags} = [81, \&PUT_U8, "GET_U8"]; -$insn_data{op_next} = [82, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_sibling} = [83, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_ppaddr} = [84, \&PUT_strconst, "GET_strconst"]; -$insn_data{op_targ} = [85, \&PUT_U32, "GET_U32"]; -$insn_data{op_type} = [86, \&PUT_U16, "GET_U16"]; -$insn_data{op_seq} = [87, \&PUT_U16, "GET_U16"]; -$insn_data{op_flags} = [88, \&PUT_U8, "GET_U8"]; -$insn_data{op_private} = [89, \&PUT_U8, "GET_U8"]; -$insn_data{op_first} = [90, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_last} = [91, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_other} = [92, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_children} = [93, \&PUT_U32, "GET_U32"]; +$insn_data{stpv} = [5, \&PUT_U32, "GET_U32"]; +$insn_data{ldspecsv} = [6, \&PUT_U8, "GET_U8"]; +$insn_data{newsv} = [7, \&PUT_U8, "GET_U8"]; +$insn_data{newop} = [8, \&PUT_U8, "GET_U8"]; +$insn_data{newopn} = [9, \&PUT_U8, "GET_U8"]; +$insn_data{newpv} = [11, \&PUT_PV, "GET_PV"]; +$insn_data{pv_cur} = [12, \&PUT_U32, "GET_U32"]; +$insn_data{pv_free} = [13, \&PUT_none, "GET_none"]; +$insn_data{sv_upgrade} = [14, \&PUT_U8, "GET_U8"]; +$insn_data{sv_refcnt} = [15, \&PUT_U32, "GET_U32"]; +$insn_data{sv_refcnt_add} = [16, \&PUT_I32, "GET_I32"]; +$insn_data{sv_flags} = [17, \&PUT_U32, "GET_U32"]; +$insn_data{xrv} = [18, \&PUT_svindex, "GET_svindex"]; +$insn_data{xpv} = [19, \&PUT_none, "GET_none"]; +$insn_data{xiv32} = [20, \&PUT_I32, "GET_I32"]; +$insn_data{xiv64} = [21, \&PUT_IV64, "GET_IV64"]; +$insn_data{xnv} = [22, \&PUT_NV, "GET_NV"]; +$insn_data{xlv_targoff} = [23, \&PUT_U32, "GET_U32"]; +$insn_data{xlv_targlen} = [24, \&PUT_U32, "GET_U32"]; +$insn_data{xlv_targ} = [25, \&PUT_svindex, "GET_svindex"]; +$insn_data{xlv_type} = [26, \&PUT_U8, "GET_U8"]; +$insn_data{xbm_useful} = [27, \&PUT_I32, "GET_I32"]; +$insn_data{xbm_previous} = [28, \&PUT_U16, "GET_U16"]; +$insn_data{xbm_rare} = [29, \&PUT_U8, "GET_U8"]; +$insn_data{xfm_lines} = [30, \&PUT_I32, "GET_I32"]; +$insn_data{xio_lines} = [31, \&PUT_I32, "GET_I32"]; +$insn_data{xio_page} = [32, \&PUT_I32, "GET_I32"]; +$insn_data{xio_page_len} = [33, \&PUT_I32, "GET_I32"]; +$insn_data{xio_lines_left} = [34, \&PUT_I32, "GET_I32"]; +$insn_data{xio_top_name} = [36, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{xio_top_gv} = [37, \&PUT_svindex, "GET_svindex"]; +$insn_data{xio_fmt_name} = [38, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{xio_fmt_gv} = [39, \&PUT_svindex, "GET_svindex"]; +$insn_data{xio_bottom_name} = [40, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{xio_bottom_gv} = [41, \&PUT_svindex, "GET_svindex"]; +$insn_data{xio_subprocess} = [42, \&PUT_U16, "GET_U16"]; +$insn_data{xio_type} = [43, \&PUT_U8, "GET_U8"]; +$insn_data{xio_flags} = [44, \&PUT_U8, "GET_U8"]; +$insn_data{xcv_stash} = [45, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_start} = [46, \&PUT_opindex, "GET_opindex"]; +$insn_data{xcv_root} = [47, \&PUT_opindex, "GET_opindex"]; +$insn_data{xcv_gv} = [48, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_file} = [49, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{xcv_depth} = [50, \&PUT_I32, "GET_I32"]; +$insn_data{xcv_padlist} = [51, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_outside} = [52, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_flags} = [53, \&PUT_U16, "GET_U16"]; +$insn_data{av_extend} = [54, \&PUT_I32, "GET_I32"]; +$insn_data{av_push} = [55, \&PUT_svindex, "GET_svindex"]; +$insn_data{xav_fill} = [56, \&PUT_I32, "GET_I32"]; +$insn_data{xav_max} = [57, \&PUT_I32, "GET_I32"]; +$insn_data{xav_flags} = [58, \&PUT_U8, "GET_U8"]; +$insn_data{xhv_riter} = [59, \&PUT_I32, "GET_I32"]; +$insn_data{xhv_name} = [60, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{hv_store} = [61, \&PUT_svindex, "GET_svindex"]; +$insn_data{sv_magic} = [62, \&PUT_U8, "GET_U8"]; +$insn_data{mg_obj} = [63, \&PUT_svindex, "GET_svindex"]; +$insn_data{mg_private} = [64, \&PUT_U16, "GET_U16"]; +$insn_data{mg_flags} = [65, \&PUT_U8, "GET_U8"]; +$insn_data{mg_pv} = [66, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{xmg_stash} = [67, \&PUT_svindex, "GET_svindex"]; +$insn_data{gv_fetchpv} = [68, \&PUT_strconst, "GET_strconst"]; +$insn_data{gv_stashpv} = [69, \&PUT_strconst, "GET_strconst"]; +$insn_data{gp_sv} = [70, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_refcnt} = [71, \&PUT_U32, "GET_U32"]; +$insn_data{gp_refcnt_add} = [72, \&PUT_I32, "GET_I32"]; +$insn_data{gp_av} = [73, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_hv} = [74, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_cv} = [75, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_file} = [76, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{gp_io} = [77, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_form} = [78, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_cvgen} = [79, \&PUT_U32, "GET_U32"]; +$insn_data{gp_line} = [80, \&PUT_U16, "GET_U16"]; +$insn_data{gp_share} = [81, \&PUT_svindex, "GET_svindex"]; +$insn_data{xgv_flags} = [82, \&PUT_U8, "GET_U8"]; +$insn_data{op_next} = [83, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_sibling} = [84, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_ppaddr} = [85, \&PUT_strconst, "GET_strconst"]; +$insn_data{op_targ} = [86, \&PUT_U32, "GET_U32"]; +$insn_data{op_type} = [87, \&PUT_U16, "GET_U16"]; +$insn_data{op_seq} = [88, \&PUT_U16, "GET_U16"]; +$insn_data{op_flags} = [89, \&PUT_U8, "GET_U8"]; +$insn_data{op_private} = [90, \&PUT_U8, "GET_U8"]; +$insn_data{op_first} = [91, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_last} = [92, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_other} = [93, \&PUT_opindex, "GET_opindex"]; $insn_data{op_pmreplroot} = [94, \&PUT_opindex, "GET_opindex"]; $insn_data{op_pmreplrootgv} = [95, \&PUT_svindex, "GET_svindex"]; $insn_data{op_pmreplstart} = [96, \&PUT_opindex, "GET_opindex"]; @@ -128,9 +128,9 @@ $insn_data{op_pv_tr} = [104, \&PUT_op_tr_array, "GET_op_tr_array"]; $insn_data{op_redoop} = [105, \&PUT_opindex, "GET_opindex"]; $insn_data{op_nextop} = [106, \&PUT_opindex, "GET_opindex"]; $insn_data{op_lastop} = [107, \&PUT_opindex, "GET_opindex"]; -$insn_data{cop_label} = [108, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{cop_stashpv} = [109, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{cop_file} = [110, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{cop_label} = [108, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{cop_stashpv} = [109, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{cop_file} = [110, \&PUT_pvindex, "GET_pvindex"]; $insn_data{cop_seq} = [111, \&PUT_U32, "GET_U32"]; $insn_data{cop_arybase} = [112, \&PUT_I32, "GET_I32"]; $insn_data{cop_line} = [113, \&PUT_U16, "GET_U16"]; @@ -138,6 +138,9 @@ $insn_data{cop_warnings} = [114, \&PUT_svindex, "GET_svindex"]; $insn_data{main_start} = [115, \&PUT_opindex, "GET_opindex"]; $insn_data{main_root} = [116, \&PUT_opindex, "GET_opindex"]; $insn_data{curpad} = [117, \&PUT_svindex, "GET_svindex"]; +$insn_data{push_begin} = [118, \&PUT_svindex, "GET_svindex"]; +$insn_data{push_init} = [119, \&PUT_svindex, "GET_svindex"]; +$insn_data{push_end} = [120, \&PUT_svindex, "GET_svindex"]; my ($insn_name, $insn_data); while (($insn_name, $insn_data) = each %insn_data) { diff --git a/contrib/perl5/ext/B/B/Assembler.pm b/contrib/perl5/ext/B/B/Assembler.pm index 6c51a9ad3e3b..5e798ce485d4 100644 --- a/contrib/perl5/ext/B/B/Assembler.pm +++ b/contrib/perl5/ext/B/B/Assembler.pm @@ -4,14 +4,17 @@ # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the README file. + package B::Assembler; use Exporter; use B qw(ppname); use B::Asmdata qw(%insn_data @insn_name); +use Config qw(%Config); +require ByteLoader; # we just need its $VERSIOM @ISA = qw(Exporter); -@EXPORT_OK = qw(assemble_fh assemble_insn strip_comments - parse_statement uncstring); +@EXPORT_OK = qw(assemble_fh newasm endasm assemble); +$VERSION = 0.02; use strict; my %opnumber; @@ -20,7 +23,7 @@ for ($i = 0; defined($opname = ppname($i)); $i++) { $opnumber{$opname} = $i; } -my ($linenum, $errors); +my($linenum, $errors, $out); # global state, set up by newasm sub error { my $str = shift; @@ -49,13 +52,15 @@ sub B::Asmdata::PUT_U8 { return $c; } -sub B::Asmdata::PUT_U16 { pack("n", $_[0]) } -sub B::Asmdata::PUT_U32 { pack("N", $_[0]) } -sub B::Asmdata::PUT_I32 { pack("N", $_[0]) } -sub B::Asmdata::PUT_NV { sprintf("%lf\0", $_[0]) } -sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here +sub B::Asmdata::PUT_U16 { pack("S", $_[0]) } +sub B::Asmdata::PUT_U32 { pack("L", $_[0]) } +sub B::Asmdata::PUT_I32 { pack("L", $_[0]) } +sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...) + # may not even be portable between compilers +sub B::Asmdata::PUT_objindex { pack("L", $_[0]) } # could allow names here sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex } sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex } +sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex } sub B::Asmdata::PUT_strconst { my $arg = shift; @@ -79,7 +84,7 @@ sub B::Asmdata::PUT_PV { my $arg = shift; $arg = uncstring($arg); error "bad string argument: $arg" unless defined($arg); - return pack("N", length($arg)) . $arg; + return pack("L", length($arg)) . $arg; } sub B::Asmdata::PUT_comment_t { my $arg = shift; @@ -90,7 +95,7 @@ sub B::Asmdata::PUT_comment_t { } return $arg . "\n"; } -sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } +sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above sub B::Asmdata::PUT_none { my $arg = shift; error "extraneous argument: $arg" if defined $arg; @@ -103,12 +108,12 @@ sub B::Asmdata::PUT_op_tr_array { error "wrong number of arguments to op_tr_array"; @ary = (0) x 256; } - return pack("n256", @ary); + return pack("S256", @ary); } # XXX Check this works sub B::Asmdata::PUT_IV64 { my $arg = shift; - return pack("NN", $arg >> 32, $arg & 0xffffffff); + return pack("LL", $arg >> 32, $arg & 0xffffffff); } my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a", @@ -138,6 +143,24 @@ sub strip_comments { return $stmt; } +# create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize, +# ptrsize, byteorder +# nvtype is irrelevant (floats are stored as strings) +# byteorder is strconst not U32 because of varying size issues + +sub gen_header { + my $header = ""; + + $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC' + $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"'); + $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]); + $header .= B::Asmdata::PUT_U32($Config{ivsize}); + $header .= B::Asmdata::PUT_U32($Config{ptrsize}); + $header .= B::Asmdata::PUT_strconst(sprintf(qq["0x%s"], $Config{byteorder})); + + $header; +} + sub parse_statement { my $stmt = shift; my ($insn, $arg) = $stmt =~ m{ @@ -183,27 +206,52 @@ sub assemble_insn { sub assemble_fh { my ($fh, $out) = @_; - my ($line, $insn, $arg); - $linenum = 0; - $errors = 0; + my $line; + my $asm = newasm($out); while ($line = <$fh>) { - $linenum++; - chomp $line; - if ($debug) { - my $quotedline = $line; - $quotedline =~ s/\\/\\\\/g; - $quotedline =~ s/"/\\"/g; - &$out(assemble_insn("comment", qq("$quotedline"))); - } - $line = strip_comments($line) or next; - ($insn, $arg) = parse_statement($line); - &$out(assemble_insn($insn, $arg)); - if ($debug) { - &$out(assemble_insn("nop", undef)); - } + assemble($line); } + endasm(); +} + +sub newasm { + my($outsub) = @_; + + die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE'; + die <<EOD if ref $out; +Can't have multiple byteassembly sessions at once! + (perhaps you forgot an endasm()?) +EOD + + $linenum = $errors = 0; + $out = $outsub; + + $out->(gen_header()); +} + +sub endasm { if ($errors) { - die "Assembly failed with $errors error(s)\n"; + die "There were $errors assembly errors\n"; + } + $linenum = $errors = $out = 0; +} + +sub assemble { + my($line) = @_; + my ($insn, $arg); + $linenum++; + chomp $line; + if ($debug) { + my $quotedline = $line; + $quotedline =~ s/\\/\\\\/g; + $quotedline =~ s/"/\\"/g; + $out->(assemble_insn("comment", qq("$quotedline"))); + } + $line = strip_comments($line) or next; + ($insn, $arg) = parse_statement($line); + $out->(assemble_insn($insn, $arg)); + if ($debug) { + $out->(assemble_insn("nop", undef)); } } @@ -217,14 +265,21 @@ B::Assembler - Assemble Perl bytecode =head1 SYNOPSIS - use Assembler; + use B::Assembler qw(newasm endasm assemble); + newasm(\&printsub); # sets up for assembly + assemble($buf); # assembles one line + endasm(); # closes down + + use B::Assembler qw(assemble_fh); + assemble_fh($fh, \&printsub); # assemble everything in $fh =head1 DESCRIPTION See F<ext/B/B/Assembler.pm>. -=head1 AUTHOR +=head1 AUTHORS Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> +Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com> =cut diff --git a/contrib/perl5/ext/B/B/Bytecode.pm b/contrib/perl5/ext/B/B/Bytecode.pm index 27003b6bd0b2..54d7c533c868 100644 --- a/contrib/perl5/ext/B/B/Bytecode.pm +++ b/contrib/perl5/ext/B/B/Bytecode.pm @@ -6,16 +6,18 @@ # License or the Artistic License, as specified in the README file. # package B::Bytecode; + use strict; use Carp; -use IO::File; - -use B qw(minus_c main_cv main_root main_start comppadlist +use B qw(main_cv main_root main_start comppadlist class peekop walkoptree svref_2object cstring walksymtable - SVf_POK SVp_POK SVf_IOK SVp_IOK + init_av begin_av end_av + SVf_POK SVp_POK SVf_IOK SVp_IOK SVf_NOK SVp_NOK + SVf_READONLY GVf_IMPORTED_AV GVf_IMPORTED_CV GVf_IMPORTED_HV + GVf_IMPORTED_SV SVTYPEMASK ); use B::Asmdata qw(@optype @specialsv_name); -use B::Assembler qw(assemble_fh); +use B::Assembler qw(newasm endasm assemble); my %optype_enum; my $i; @@ -31,41 +33,76 @@ sub POK () { SVf_POK|SVp_POK } # XXX Shouldn't be hardwired sub IOK () { SVf_IOK|SVp_IOK } -my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv); -my $assembler_pid; +# Following is SVf_NOK|SVp_NOK +# XXX Shouldn't be hardwired +sub NOK () { SVf_NOK|SVp_NOK } + +# nonexistant flags (see B::GV::bytecode for usage) +sub GVf_IMPORTED_IO () { 0; } +sub GVf_IMPORTED_FORM () { 0; } + +my ($verbose, $no_assemble, $debug_bc, $debug_cv); +my @packages; # list of packages to compile + +sub asm (@) { # print replacement that knows about assembling + if ($no_assemble) { + print @_; + } else { + my $buf = join '', @_; + assemble($_) for (split /\n/, $buf); + } +} + +sub asmf (@) { # printf replacement that knows about assembling + if ($no_assemble) { + printf shift(), @_; + } else { + my $format = shift; + my $buf = sprintf $format, @_; + assemble($_) for (split /\n/, $buf); + } +} # Optimisation options. On the command line, use hyphens instead of # underscores for compatibility with gcc-style options. We use # underscores here because they are OK in (strict) barewords. -my ($strip_syntree, $compress_nullops, $omit_seq, $bypass_nullops); -my %optimise = (strip_syntax_tree => \$strip_syntree, - compress_nullops => \$compress_nullops, +my ($compress_nullops, $omit_seq, $bypass_nullops); +my %optimise = (compress_nullops => \$compress_nullops, omit_sequence_numbers => \$omit_seq, bypass_nullops => \$bypass_nullops); +my $strip_syntree; # this is left here in case stripping the + # syntree ever becomes safe again + # -- BKS, June 2000 + my $nextix = 0; my %symtable; # maps object addresses to object indices. # Filled in at allocation (newsv/newop) time. + my %saved; # maps object addresses (for SVish classes) to "saved yet?" # flag. Set at FOO::bytecode time usually by SV::bytecode. # Manipulated via saved(), mark_saved(), unmark_saved(). +my %strtable; # maps shared strings to object indices + # Filled in at allocation (pvix) time + my $svix = -1; # we keep track of when the sv register contains an element # of the object table to avoid unnecessary repeated # consecutive ldsv instructions. + my $opix = -1; # Ditto for the op register. sub ldsv { my $ix = shift; if ($ix != $svix) { - print "ldsv $ix\n"; + asm "ldsv $ix\n"; $svix = $ix; } } sub stsv { my $ix = shift; - print "stsv $ix\n"; + asm "stsv $ix\n"; $svix = $ix; } @@ -76,14 +113,14 @@ sub set_svix { sub ldop { my $ix = shift; if ($ix != $opix) { - print "ldop $ix\n"; + asm "ldop $ix\n"; $opix = $ix; } } sub stop { my $ix = shift; - print "stop $ix\n"; + asm "stop $ix\n"; $opix = $ix; } @@ -100,12 +137,29 @@ sub pvstring { } } +sub nv { + # print full precision + my $str = sprintf "%.40f", $_[0]; + $str =~ s/0+$//; # remove trailing zeros + $str =~ s/\.$/.0/; + return $str; +} + sub saved { $saved{${$_[0]}} } sub mark_saved { $saved{${$_[0]}} = 1 } sub unmark_saved { $saved{${$_[0]}} = 0 } sub debug { $debug_bc = shift } +sub pvix { # save a shared PV (mainly for COPs) + return $strtable{$_[0]} if defined($strtable{$_[0]}); + asmf "newpv %s\n", pvstring($_[0]); + my $ix = $nextix++; + $strtable{$_[0]} = $ix; + asmf "stpv %d\n", $ix; + return $ix; +} + sub B::OBJECT::nyi { my $obj = shift; warn sprintf("bytecode save method for %s (0x%x) not yet implemented\n", @@ -129,7 +183,7 @@ sub B::OBJECT::objix { sub B::SV::newix { my ($sv, $ix) = @_; - printf "newsv %d\t# %s\n", $sv->FLAGS & 0xf, class($sv); + asmf "newsv %d\t# %s\n", $sv->FLAGS & SVTYPEMASK, class($sv); stsv($ix); } @@ -137,7 +191,7 @@ sub B::GV::newix { my ($gv, $ix) = @_; my $gvname = $gv->NAME; my $name = cstring($gv->STASH->NAME . "::" . $gvname); - print "gv_fetchpv $name\n"; + asm "gv_fetchpv $name\n"; stsv($ix); } @@ -146,7 +200,7 @@ sub B::HV::newix { my $name = $hv->NAME; if ($name) { # It's a stash - printf "gv_stashpv %s\n", cstring($name); + asmf "gv_stashpv %s\n", cstring($name); stsv($ix); } else { # It's an ordinary HV. Fall back to ordinary newix method @@ -158,7 +212,7 @@ sub B::SPECIAL::newix { my ($sv, $ix) = @_; # Special case. $$sv is not the address of the SV but an # index into svspecialsv_list. - printf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv]; + asmf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv]; stsv($ix); } @@ -166,8 +220,8 @@ sub B::OP::newix { my ($op, $ix) = @_; my $class = class($op); my $typenum = $optype_enum{$class}; - croak "OP::newix: can't understand class $class" unless defined($typenum); - print "newop $typenum\t# $class\n"; + croak("OP::newix: can't understand class $class") unless defined($typenum); + asm "newop $typenum\t# $class\n"; stop($ix); } @@ -180,7 +234,7 @@ sub B::OP::bytecode { my $op = shift; my $next = $op->next; my $nextix; - my $sibix = $op->sibling->objix; + my $sibix = $op->sibling->objix unless $strip_syntree; my $ix = $op->objix; my $type = $op->type; @@ -189,24 +243,24 @@ sub B::OP::bytecode { } $nextix = $next->objix; - printf "# %s\n", peekop($op) if $debug_bc; + asmf "# %s\n", peekop($op) if $debug_bc; ldop($ix); - print "op_next $nextix\n"; - print "op_sibling $sibix\n" unless $strip_syntree; - printf "op_type %s\t# %d\n", "pp_" . $op->name, $type; - printf("op_seq %d\n", $op->seq) unless $omit_seq; + asm "op_next $nextix\n"; + asm "op_sibling $sibix\n" unless $strip_syntree; + asmf "op_type %s\t# %d\n", "pp_" . $op->name, $type; + asmf("op_seq %d\n", $op->seq) unless $omit_seq; if ($type || !$compress_nullops) { - printf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n", + asmf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n", $op->targ, $op->flags, $op->private; } } sub B::UNOP::bytecode { my $op = shift; - my $firstix = $op->first->objix; + my $firstix = $op->first->objix unless $strip_syntree; $op->B::OP::bytecode; if (($op->type || !$compress_nullops) && !$strip_syntree) { - print "op_first $firstix\n"; + asm "op_first $firstix\n"; } } @@ -214,7 +268,7 @@ sub B::LOGOP::bytecode { my $op = shift; my $otherix = $op->other->objix; $op->B::UNOP::bytecode; - print "op_other $otherix\n"; + asm "op_other $otherix\n"; } sub B::SVOP::bytecode { @@ -222,7 +276,7 @@ sub B::SVOP::bytecode { my $sv = $op->sv; my $svix = $sv->objix; $op->B::OP::bytecode; - print "op_sv $svix\n"; + asm "op_sv $svix\n"; $sv->bytecode; } @@ -230,7 +284,7 @@ sub B::PADOP::bytecode { my $op = shift; my $padix = $op->padix; $op->B::OP::bytecode; - print "op_padix $padix\n"; + asm "op_padix $padix\n"; } sub B::PVOP::bytecode { @@ -243,27 +297,18 @@ sub B::PVOP::bytecode { # if ($op->name eq "trans") { my @shorts = unpack("s256", $pv); # assembler handles endianness - print "op_pv_tr ", join(",", @shorts), "\n"; + asm "op_pv_tr ", join(",", @shorts), "\n"; } else { - printf "newpv %s\nop_pv\n", pvstring($pv); + asmf "newpv %s\nop_pv\n", pvstring($pv); } } sub B::BINOP::bytecode { my $op = shift; - my $lastix = $op->last->objix; + my $lastix = $op->last->objix unless $strip_syntree; $op->B::UNOP::bytecode; if (($op->type || !$compress_nullops) && !$strip_syntree) { - print "op_last $lastix\n"; - } -} - -sub B::LISTOP::bytecode { - my $op = shift; - my $children = $op->children; - $op->B::BINOP::bytecode; - if (($op->type || !$compress_nullops) && !$strip_syntree) { - print "op_children $children\n"; + asm "op_last $lastix\n"; } } @@ -273,28 +318,29 @@ sub B::LOOP::bytecode { my $nextopix = $op->nextop->objix; my $lastopix = $op->lastop->objix; $op->B::LISTOP::bytecode; - print "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n"; + asm "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n"; } sub B::COP::bytecode { my $op = shift; - my $stashpv = $op->stashpv; my $file = $op->file; my $line = $op->line; + if ($debug_bc) { # do this early to aid debugging + asmf "# line %s:%d\n", $file, $line; + } + my $stashpv = $op->stashpv; my $warnings = $op->warnings; my $warningsix = $warnings->objix; - if ($debug_bc) { - printf "# line %s:%d\n", $file, $line; - } + my $labelix = pvix($op->label); + my $stashix = pvix($stashpv); + my $fileix = pvix($file); + $warnings->bytecode; $op->B::OP::bytecode; - printf <<"EOT", pvstring($op->label), pvstring($stashpv), $op->cop_seq, pvstring($file), $op->arybase; -newpv %s -cop_label -newpv %s -cop_stashpv + asmf <<"EOT", $labelix, $stashix, $op->cop_seq, $fileix, $op->arybase; +cop_label %d +cop_stashpv %d cop_seq %d -newpv %s -cop_file +cop_file %d cop_arybase %d cop_line $line cop_warnings $warningsix @@ -322,13 +368,13 @@ sub B::PMOP::bytecode { } $op->B::LISTOP::bytecode; if ($opname eq "pushre") { - printf "op_pmreplrootgv $replrootix\n"; + asmf "op_pmreplrootgv $replrootix\n"; } else { - print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n"; + asm "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n"; } my $re = pvstring($op->precomp); # op_pmnext omitted since a perl bug means it's sometime corrupt - printf <<"EOT", $op->pmflags, $op->pmpermflags; + asmf <<"EOT", $op->pmflags, $op->pmpermflags; op_pmflags 0x%x op_pmpermflags 0x%x newpv $re @@ -343,7 +389,7 @@ sub B::SV::bytecode { my $refcnt = $sv->REFCNT; my $flags = sprintf("0x%x", $sv->FLAGS); ldsv($ix); - print "sv_refcnt $refcnt\nsv_flags $flags\n"; + asm "sv_refcnt $refcnt\nsv_flags $flags\n"; mark_saved($sv); } @@ -351,7 +397,7 @@ sub B::PV::bytecode { my $sv = shift; return if saved($sv); $sv->B::SV::bytecode; - printf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK; + asmf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK; } sub B::IV::bytecode { @@ -359,14 +405,14 @@ sub B::IV::bytecode { return if saved($sv); my $iv = $sv->IVX; $sv->B::SV::bytecode; - printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; + asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32" if $sv->FLAGS & IOK; # could be PVNV } sub B::NV::bytecode { my $sv = shift; return if saved($sv); $sv->B::SV::bytecode; - printf "xnv %s\n", $sv->NVX; + asmf "xnv %s\n", nv($sv->NVX); } sub B::RV::bytecode { @@ -376,7 +422,7 @@ sub B::RV::bytecode { my $rvix = $rv->objix; $rv->bytecode; $sv->B::SV::bytecode; - print "xrv $rvix\n"; + asm "xrv $rvix\n"; } sub B::PVIV::bytecode { @@ -384,7 +430,7 @@ sub B::PVIV::bytecode { return if saved($sv); my $iv = $sv->IVX; $sv->B::PV::bytecode; - printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; + asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; } sub B::PVNV::bytecode { @@ -404,12 +450,12 @@ sub B::PVNV::bytecode { } else { my $pv = $sv->PV; $sv->B::IV::bytecode; - printf "xnv %s\n", $sv->NVX; + asmf "xnv %s\n", nv($sv->NVX); if ($flag == 1) { $pv .= "\0" . $sv->TABLE; - printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257; + asmf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257; } else { - printf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK; + asmf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK; } } } @@ -431,9 +477,9 @@ sub B::PVMG::bytecode { # @mgobjix = map($_->OBJ->objix, @mgchain); $sv->B::PVNV::bytecode($flag); - print "xmg_stash $stashix\n"; + asm "xmg_stash $stashix\n"; foreach $mg (@mgchain) { - printf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n", + asmf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n", cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR); } } @@ -442,7 +488,7 @@ sub B::PVLV::bytecode { my $sv = shift; return if saved($sv); $sv->B::PVMG::bytecode; - printf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE); + asmf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE); xlv_targoff %d xlv_targlen %d xlv_type %s @@ -454,46 +500,63 @@ sub B::BM::bytecode { return if saved($sv); # See PVNV::bytecode for an explanation of what the argument does $sv->B::PVMG::bytecode(1); - printf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n", + asmf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n", $sv->USEFUL, $sv->PREVIOUS, $sv->RARE; } +sub empty_gv { # is a GV empty except for imported stuff? + my $gv = shift; + + return 0 if ($gv->SV->FLAGS & SVTYPEMASK); # sv not SVt_NULL + my @subfield_names = qw(AV HV CV FORM IO); + @subfield_names = grep {; + no strict 'refs'; + !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->()) && ${$gv->$_()}; + } @subfield_names; + return scalar @subfield_names; +} + sub B::GV::bytecode { my $gv = shift; return if saved($gv); + return unless grep { $_ eq $gv->STASH->NAME; } @packages; + return if $gv->NAME =~ m/^\(/; # ignore overloads - they'll be rebuilt my $ix = $gv->objix; mark_saved($gv); ldsv($ix); - printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS; + asmf <<"EOT", $gv->FLAGS, $gv->GvFLAGS; sv_flags 0x%x xgv_flags 0x%x EOT my $refcnt = $gv->REFCNT; - printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1; + asmf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1; return if $gv->is_empty; - printf <<"EOT", $gv->LINE, pvstring($gv->FILE); + asmf <<"EOT", $gv->LINE, pvix($gv->FILE); gp_line %d -newpv %s -gp_file +gp_file %d EOT my $gvname = $gv->NAME; my $name = cstring($gv->STASH->NAME . "::" . $gvname); my $egv = $gv->EGV; my $egvix = $egv->objix; my $gvrefcnt = $gv->GvREFCNT; - printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1; + asmf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1; if ($gvrefcnt > 1 && $ix != $egvix) { - print "gp_share $egvix\n"; + asm "gp_share $egvix\n"; } else { if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) { my $i; my @subfield_names = qw(SV AV HV CV FORM IO); + @subfield_names = grep {; + no strict 'refs'; + !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->()); + } @subfield_names; my @subfields = map($gv->$_(), @subfield_names); my @ixes = map($_->objix, @subfields); # Reset sv register for $gv ldsv($ix); for ($i = 0; $i < @ixes; $i++) { - printf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; + asmf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; } # Now save all the subfields my $sv; @@ -523,10 +586,10 @@ sub B::HV::bytecode { } ldsv($ix); for ($i = 0; $i < @contents; $i += 2) { - printf("newpv %s\nhv_store %d\n", + asmf("newpv %s\nhv_store %d\n", pvstring($contents[$i]), $ixes[$i / 2]); } - printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS; + asmf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS; } } @@ -551,22 +614,26 @@ sub B::AV::bytecode { # create an AV with NEWSV and SvUPGRADE rather than doing newAV # which is what sets AvMAX and AvFILL. ldsv($ix); - printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS; + asmf "sv_flags 0x%x\n", $av->FLAGS & ~SVf_READONLY; # SvREADONLY_off($av) in case PADCONST + asmf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS; if ($fill > -1) { my $elix; foreach $elix (@ixes) { - print "av_push $elix\n"; + asm "av_push $elix\n"; } } else { if ($max > -1) { - print "av_extend $max\n"; + asm "av_extend $max\n"; } } + asmf "sv_flags 0x%x\n", $av->FLAGS; # restore flags from above } sub B::CV::bytecode { my $cv = shift; return if saved($cv); + return if ${$cv->GV} && ($cv->GV->GvFLAGS & GVf_IMPORTED_CV); + my $fileix = pvix($cv->FILE); my $ix = $cv->objix; $cv->B::PVMG::bytecode; my $i; @@ -581,10 +648,10 @@ sub B::CV::bytecode { # Reset sv register for $cv (since above ->objix calls stomped on it) ldsv($ix); for ($i = 0; $i < @ixes; $i++) { - printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; + asmf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; } - printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS; - printf "newpv %s\nxcv_file\n", pvstring($cv->FILE); + asmf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS; + asmf "xcv_file %d\n", $fileix; # Now save all the subfields (except for CvROOT which was handled # above) and CvSTART (now the initial element of @subfields). shift @subfields; # bye-bye CvSTART @@ -607,17 +674,17 @@ sub B::IO::bytecode { $io->B::PVMG::bytecode; ldsv($ix); - print "xio_top_gv $top_gvix\n"; - print "xio_fmt_gv $fmt_gvix\n"; - print "xio_bottom_gv $bottom_gvix\n"; + asm "xio_top_gv $top_gvix\n"; + asm "xio_fmt_gv $fmt_gvix\n"; + asm "xio_bottom_gv $bottom_gvix\n"; my $field; foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) { - printf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field); + asmf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field); } foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) { - printf "xio_%s %d\n", lc($field), $io->$field(); + asmf "xio_%s %d\n", lc($field), $io->$field(); } - printf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS; + asmf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS; $top_gv->bytecode; $fmt_gv->bytecode; $bottom_gv->bytecode; @@ -628,8 +695,7 @@ sub B::SPECIAL::bytecode { } sub bytecompile_object { - my $sv; - foreach $sv (@_) { + for my $sv (@_) { svref_2object($sv)->bytecode; } } @@ -637,7 +703,7 @@ sub bytecompile_object { sub B::GV::bytecodecv { my $gv = shift; my $cv = $gv->CV; - if ($$cv && !saved($cv)) { + if ($$cv && !saved($cv) && !($gv->FLAGS & GVf_IMPORTED_CV)) { if ($debug_cv) { warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", $gv->STASH->NAME, $gv->NAME, $$cv, $$gv); @@ -646,43 +712,66 @@ sub B::GV::bytecodecv { } } -sub bytecompile_main { - my $curpad = (comppadlist->ARRAY)[1]; - my $curpadix = $curpad->objix; - $curpad->bytecode; - walkoptree(main_root, "bytecode"); - warn "done main program, now walking symbol table\n" if $debug_bc; - my ($pack, %exclude); - foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS strict vars - FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol - SelectSaver blib Cwd)) - { - $exclude{$pack."::"} = 1; +sub save_call_queues { + if (begin_av()->isa("B::AV")) { # this is just to save 'use Foo;' calls + for my $cv (begin_av()->ARRAY) { + next unless grep { $_ eq $cv->STASH->NAME; } @packages; + my $op = $cv->START; +OPLOOP: + while ($$op) { + if ($op->name eq 'require') { # save any BEGIN that does a require + $cv->bytecode; + asmf "push_begin %d\n", $cv->objix; + last OPLOOP; + } + $op = $op->next; + } + } + } + if (init_av()->isa("B::AV")) { + for my $cv (init_av()->ARRAY) { + next unless grep { $_ eq $cv->STASH->NAME; } @packages; + $cv->bytecode; + asmf "push_init %d\n", $cv->objix; + } } - no strict qw(vars refs); - walksymtable(\%{"main::"}, "bytecodecv", sub { - warn "considering $_[0]\n" if $debug_bc; - return !defined($exclude{$_[0]}); - }); - if (!$module_only) { - printf "main_root %d\n", main_root->objix; - printf "main_start %d\n", main_start->objix; - printf "curpad $curpadix\n"; - # XXX Do min_intro_pending and max_intro_pending matter? + if (end_av()->isa("B::AV")) { + for my $cv (end_av()->ARRAY) { + next unless grep { $_ eq $cv->STASH->NAME; } @packages; + $cv->bytecode; + asmf "push_end %d\n", $cv->objix; + } } } -sub prepare_assemble { - my $newfh = IO::File->new_tmpfile; - select($newfh); - binmode $newfh; - return $newfh; +sub symwalk { + no strict 'refs'; + my $ok = 1 if grep { (my $name = $_[0]) =~ s/::$//; $_ eq $name;} @packages; + if (grep { /^$_[0]/; } @packages) { + walksymtable(\%{"$_[0]"}, "bytecodecv", \&symwalk, $_[0]); + } + warn "considering $_[0] ... " . ($ok ? "accepted\n" : "rejected\n") + if $debug_bc; + $ok; } -sub do_assemble { - my $fh = shift; - seek($fh, 0, 0); # rewind the temporary file - assemble_fh($fh, sub { print OUT @_ }); +sub bytecompile_main { + my $curpad = (comppadlist->ARRAY)[1]; + my $curpadix = $curpad->objix; + $curpad->bytecode; + save_call_queues(); + walkoptree(main_root, "bytecode") unless ref(main_root) eq "B::NULL"; + warn "done main program, now walking symbol table\n" if $debug_bc; + if (@packages) { + no strict qw(refs); + walksymtable(\%{"main::"}, "bytecodecv", \&symwalk); + } else { + die "No packages requested for compilation!\n"; + } + asmf "main_root %d\n", main_root->objix; + asmf "main_start %d\n", main_start->objix; + asmf "curpad $curpadix\n"; + # XXX Do min_intro_pending and max_intro_pending matter? } sub compile { @@ -690,7 +779,7 @@ sub compile { my ($option, $opt, $arg); open(OUT, ">&STDOUT"); binmode OUT; - select(OUT); + select OUT; OPTION: while ($option = shift @options) { if ($option =~ /^-(.)(.*)/) { @@ -727,8 +816,6 @@ sub compile { } } elsif ($opt eq "v") { $verbose = 1; - } elsif ($opt eq "m") { - $module_only = 1; } elsif ($opt eq "S") { $no_assemble = 1; } elsif ($opt eq "f") { @@ -747,9 +834,6 @@ sub compile { foreach $ref (values %optimise) { $$ref = 0; } - if ($arg >= 6) { - $strip_syntree = 1; - } if ($arg >= 2) { $bypass_nullops = 1; } @@ -757,28 +841,30 @@ sub compile { $compress_nullops = 1; $omit_seq = 1; } + } elsif ($opt eq "u") { + $arg ||= shift @options; + push @packages, $arg; + } else { + warn qq(ignoring unknown option "$opt$arg"\n); } } + if (! @packages) { + warn "No package specified for compilation, assuming main::\n"; + @packages = qw(main); + } if (@options) { - return sub { - my $objname; - my $newfh; - $newfh = prepare_assemble() unless $no_assemble; - foreach $objname (@options) { - eval "bytecompile_object(\\$objname)"; - } - do_assemble($newfh) unless $no_assemble; - } + die "Extraneous options left on B::Bytecode commandline: @options\n"; } else { - return sub { - my $newfh; - $newfh = prepare_assemble() unless $no_assemble; + return sub { + newasm(\&apr) unless $no_assemble; bytecompile_main(); - do_assemble($newfh) unless $no_assemble; - } + endasm() unless $no_assemble; + }; } } +sub apr { print @_; } + 1; __END__ @@ -848,18 +934,11 @@ which is only used by perl's internal compiler. If op->op_next ever points to a NULLOP, replaces the op_next field with the first non-NULLOP in the path of execution. -=item B<-fstrip-syntax-tree> - -Leaves out code to fill in the pointers which link the internal syntax -tree together. They're not needed at run-time but leaving them out -will make it impossible to recompile or disassemble the resulting -program. It will also stop C<goto label> statements from working. - =item B<-On> Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>. -B<-O6> adds B<-fstrip-syntax-tree>. +B<-O2> adds B<-fbypass-nullops>. =item B<-D> @@ -887,33 +966,33 @@ Prints each CV taken from the final symbol tree walk. Output (bytecode) assembler source rather than piping it through the assembler and outputting bytecode. -=item B<-m> - -Compile as a module rather than a standalone program. Currently this -just means that the bytecodes for initialising C<main_start>, -C<main_root> and C<curpad> are omitted. - +=item B<-upackage> + +Stores package in the output. + =back =head1 EXAMPLES - perl -MO=Bytecode,-O6,-o,foo.plc foo.pl + perl -MO=Bytecode,-O6,-ofoo.plc,-umain foo.pl - perl -MO=Bytecode,-S foo.pl > foo.S + perl -MO=Bytecode,-S,-umain foo.pl > foo.S assemble foo.S > foo.plc Note that C<assemble> lives in the C<B> subdirectory of your perl library directory. The utility called perlcc may also be used to help make use of this compiler. - perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm + perl -MO=Bytecode,-uFoo,-oFoo.pmc Foo.pm =head1 BUGS -Plenty. Current status: experimental. +Output is still huge and there are still occasional crashes during +either compilation or ByteLoading. Current status: experimental. -=head1 AUTHOR +=head1 AUTHORS Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> +Benjamin Stuhl, C<sho_pi@hotmail.com> =cut diff --git a/contrib/perl5/ext/B/B/C.pm b/contrib/perl5/ext/B/B/C.pm index d0c8159d9f31..4befe7988ba2 100644 --- a/contrib/perl5/ext/B/B/C.pm +++ b/contrib/perl5/ext/B/B/C.pm @@ -225,11 +225,10 @@ sub B::LISTOP::save { my ($op, $level) = @_; my $sym = objsym($op); return $sym if defined $sym; - $listopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u", + $listopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, - $op->private, ${$op->first}, ${$op->last}, - $op->children)); + $op->private, ${$op->first}, ${$op->last})); my $ix = $listopsect->index; $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); savesym($op, "(OP*)&listop_list[$ix]"); @@ -255,11 +254,11 @@ sub B::LOOP::save { #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n", # peekop($op->redoop), peekop($op->nextop), # peekop($op->lastop)); # debug - $loopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x", + $loopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x", ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first}, ${$op->last}, - $op->children, ${$op->redoop}, ${$op->nextop}, + ${$op->redoop}, ${$op->nextop}, ${$op->lastop})); my $ix = $loopsect->index; $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); @@ -351,10 +350,10 @@ sub B::PMOP::save { # pmnext handling is broken in perl itself, I think. Bad op_pmnext # fields aren't noticed in perl's runtime (unless you try reset) but we # segfault when trying to dereference it to find op->op_pmnext->op_type - $pmopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x", + $pmopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %s, %s, 0, 0, 0x%x, 0x%x", ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, - ${$op->first}, ${$op->last}, $op->children, + ${$op->first}, ${$op->last}, $replrootfield, $replstartfield, $op->pmflags, $op->pmpermflags,)); my $pm = sprintf("pmop_list[%d]", $pmopsect->index); @@ -1020,9 +1019,8 @@ sub output_all { print <<"EOT"; static int $init_name() { - dTHR; dTARG; - djSP; + dSP; EOT $init->output(\*STDOUT, "\t%s\n"); print "\treturn 0;\n}\n"; @@ -1050,15 +1048,15 @@ typedef struct { STRLEN xpv_cur; /* length of xp_pv as a C string */ STRLEN xpv_len; /* allocated size */ IV xof_off; /* integer value */ - double xnv_nv; /* numeric value, if any */ + NV xnv_nv; /* numeric value, if any */ MAGIC* xmg_magic; /* magic for scalar array */ HV* xmg_stash; /* class package */ HV * xcv_stash; OP * xcv_start; OP * xcv_root; - void (*xcv_xsub) (CV*); - void * xcv_xsubany; + void (*xcv_xsub) (pTHXo_ CV*); + ANY xcv_xsubany; GV * xcv_gv; char * xcv_file; long xcv_depth; /* >= 2 indicates recursive call */ @@ -1174,7 +1172,7 @@ xs_init(pTHX) { char *file = __FILE__; dTARG; - djSP; + dSP; EOT print "\n#ifdef USE_DYNAMIC_LOADING"; print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/; @@ -1210,7 +1208,7 @@ dl_init(pTHX) { char *file = __FILE__; dTARG; - djSP; + dSP; EOT print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n"); print("\ttarg=sv_newmortal();\n"); @@ -1338,7 +1336,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 +1366,7 @@ sub walkpackages if ($sym =~ /::$/) { $sym = $prefix . $sym; - if ($sym ne "main::" && &$recurse($sym)) + if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) { walkpackages(\%glob, $recurse, $sym); } diff --git a/contrib/perl5/ext/B/B/CC.pm b/contrib/perl5/ext/B/B/CC.pm index c5ca2a3df5bb..51922eeb2b21 100644 --- a/contrib/perl5/ext/B/B/CC.pm +++ b/contrib/perl5/ext/B/B/CC.pm @@ -151,7 +151,7 @@ sub init_pp { $ppname = shift; $runtime_list_ref = []; $declare_ref = {}; - runtime("djSP;"); + runtime("dSP;"); declare("I32", "oldsave"); declare("SV", "**svp"); map { declare("SV", "*$_") } qw(sv src dst left right); diff --git a/contrib/perl5/ext/B/B/Debug.pm b/contrib/perl5/ext/B/B/Debug.pm index ae7a9733bcdd..049195b42369 100644 --- a/contrib/perl5/ext/B/B/Debug.pm +++ b/contrib/perl5/ext/B/B/Debug.pm @@ -33,6 +33,16 @@ sub B::BINOP::debug { printf "\top_last\t\t0x%x\n", ${$op->last}; } +sub B::LOOP::debug { + my ($op) = @_; + $op->B::BINOP::debug(); + printf <<'EOT', ${$op->redoop}, ${$op->nextop}, ${$op->lastop}; + op_redoop 0x%x + op_nextop 0x%x + op_lastop 0x%x +EOT +} + sub B::LOGOP::debug { my ($op) = @_; $op->B::UNOP::debug(); @@ -53,7 +63,6 @@ sub B::PMOP::debug { printf "\top_pmnext\t0x%x\n", ${$op->pmnext}; printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp); printf "\top_pmflags\t0x%x\n", $op->pmflags; - $op->pmshort->debug; $op->pmreplroot->debug; } @@ -209,14 +218,14 @@ EOT sub B::GV::debug { my ($gv) = @_; if ($done_gv{$$gv}++) { - printf "GV %s::%s\n", $gv->STASH->NAME, $gv->NAME; + printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME; return; } my ($sv) = $gv->SV; my ($av) = $gv->AV; my ($cv) = $gv->CV; $gv->B::SV::debug; - printf <<'EOT', $gv->NAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS; + printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS; NAME %s STASH %s (0x%x) SV 0x%x @@ -244,7 +253,7 @@ sub B::SPECIAL::debug { sub compile { my $order = shift; B::clearsym(); - if ($order eq "exec") { + if ($order && $order eq "exec") { return sub { walkoptree_exec(main_start, "debug") } } else { return sub { walkoptree(main_root, "debug") } diff --git a/contrib/perl5/ext/B/B/Deparse.pm b/contrib/perl5/ext/B/B/Deparse.pm index cd53c112d8c2..ead02e14a84f 100644 --- a/contrib/perl5/ext/B/B/Deparse.pm +++ b/contrib/perl5/ext/B/B/Deparse.pm @@ -1,5 +1,5 @@ # B::Deparse.pm -# Copyright (c) 1998, 1999 Stephen McCamant. All rights reserved. +# Copyright (c) 1998, 1999, 2000 Stephen McCamant. All rights reserved. # This module is free software; you can redistribute and/or modify # it under the same terms as Perl itself. @@ -8,16 +8,16 @@ package B::Deparse; use Carp 'cluck', 'croak'; -use Config; use B qw(class main_root main_start main_cv svref_2object opnumber OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY SVf_IOK SVf_NOK SVf_ROK SVf_POK + 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.59; +$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? # - <DATA>? @@ -252,17 +257,17 @@ sub walk_sub { walk_tree($op, sub { my $op = shift; if ($op->name eq "gv") { - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); if ($op->next->name eq "entersub") { - next if $self->{'subs_done'}{$$gv}++; - next if class($gv->CV) eq "SPECIAL"; + return if $self->{'subs_done'}{$$gv}++; + return if class($gv->CV) eq "SPECIAL"; $self->todo($gv, $gv->CV, 0); $self->walk_sub($gv->CV); } elsif ($op->next->name eq "enterwrite" or ($op->next->name eq "rv2gv" and $op->next->next->name eq "enterwrite")) { - next if $self->{'forms_done'}{$$gv}++; - next if class($gv->FORM) eq "SPECIAL"; + return if $self->{'forms_done'}{$$gv}++; + return if class($gv->FORM) eq "SPECIAL"; $self->todo($gv, $gv->FORM, 1); $self->walk_sub($gv->FORM); } @@ -345,6 +350,10 @@ sub new { $self->{'cuddle'} = "\n"; $self->{'indent_size'} = 4; $self->{'use_tabs'} = 0; + $self->{'expand'} = 0; + $self->{'unquote'} = 0; + $self->{'linenums'} = 0; + $self->{'parens'} = 0; $self->{'ex_const'} = "'???'"; while (my $arg = shift @_) { if (substr($arg, 0, 2) eq "-u") { @@ -357,6 +366,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; @@ -378,7 +389,7 @@ sub compile { while (scalar(@{$self->{'subs_todo'}})) { push @text, $self->next_todo; } - print indent(join("", @text)), "\n" if @text; + print $self->indent(join("", @text)), "\n" if @text; } } @@ -393,6 +404,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); @@ -433,6 +445,13 @@ sub deparse_sub { if ($cv->FLAGS & SVf_POK) { $proto = "(". $cv->PV . ") "; } + if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) { + $proto .= ": "; + $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE; + $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED; + $proto .= "method " if $cv->CvFLAGS & CVf_METHOD; + } + local($self->{'curcv'}) = $cv; local($self->{'curstash'}) = $self->{'curstash'}; if (not null $cv->ROOT) { @@ -553,7 +572,11 @@ sub maybe_local { my $self = shift; my($op, $cx, $text) = @_; if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { - return $self->maybe_parens_func("local", $text, $cx, 16); + if (want_scalar($op)) { + return "local $text"; + } else { + return $self->maybe_parens_func("local", $text, $cx, 16); + } } else { return $text; } @@ -581,7 +604,11 @@ sub maybe_my { my $self = shift; my($op, $cx, $text) = @_; if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { - return $self->maybe_parens_func("my", $text, $cx, 16); + if (want_scalar($op)) { + return "my $text"; + } else { + return $self->maybe_parens_func("my", $text, $cx, 16); + } } else { return $text; } @@ -672,70 +699,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. @@ -747,7 +773,7 @@ sub gv_name { my $self = shift; my $gv = shift; my $stash = $gv->STASH->NAME; - my $name = $gv->NAME; + my $name = $gv->SAFENAME; if ($stash eq $self->{'curstash'} or $globalnames{$name} or $name =~ /^[^A-Za-z_]/) { @@ -755,8 +781,8 @@ sub gv_name { } else { $stash = $stash . "::"; } - if ($name =~ /^([\cA-\cZ])$/) { - $name = "^" . chr(64 + ord($1)); + if ($name =~ /^\^../) { + $name = "{$name}"; # ${^WARNING_BITS} etc } return $stash . $name; } @@ -840,7 +866,7 @@ sub pp_i_preinc { pfixop(@_, "++", 23) } sub pp_i_predec { pfixop(@_, "--", 23) } sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } -sub pp_complement { maybe_targmy(@_. \&pfixop, "~", 21) } +sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) } sub pp_negate { maybe_targmy(@_, \&real_negate) } sub real_negate { @@ -917,7 +943,6 @@ sub pp_prototype { unop(@_, "prototype") } sub pp_close { unop(@_, "close") } sub pp_fileno { unop(@_, "fileno") } sub pp_umask { unop(@_, "umask") } -sub pp_binmode { unop(@_, "binmode") } sub pp_untie { unop(@_, "untie") } sub pp_tied { unop(@_, "tied") } sub pp_dbmclose { unop(@_, "dbmclose") } @@ -1373,11 +1398,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"; @@ -1457,6 +1485,7 @@ sub pp_return { listop(@_, "return") } sub pp_open { listop(@_, "open") } sub pp_pipe_op { listop(@_, "pipe") } sub pp_tie { listop(@_, "tie") } +sub pp_binmode { listop(@_, "binmode") } sub pp_dbmopen { listop(@_, "dbmopen") } sub pp_sselect { listop(@_, "select") } sub pp_select { listop(@_, "select") } @@ -1653,6 +1682,13 @@ sub pp_list { } } +sub is_ifelse_cont { + my $op = shift; + return ($op->name eq "null" and class($op) eq "UNOP" + and $op->first->name =~ /^(and|cond_expr)$/ + and is_scope($op->first->first->sibling)); +} + sub pp_cond_expr { my $self = shift; my($op, $cx) = @_; @@ -1660,52 +1696,55 @@ sub pp_cond_expr { my $true = $cond->sibling; my $false = $true->sibling; my $cuddle = $self->{'cuddle'}; - unless ($cx == 0 and is_scope($true) and is_scope($false)) { + unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and + (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); return $self->maybe_parens("$cond ? $true : $false", $cx, 8); - } + } + $cond = $self->deparse($cond, 1); $true = $self->deparse($true, 0); - if ($false->name eq "lineseq") { # braces w/o scope => elsif - my $head = "if ($cond) {\n\t$true\n\b}"; - my @elsifs; - while (!null($false) and $false->name eq "lineseq") { - my $newop = $false->first->sibling->first; - my $newcond = $newop->first; - my $newtrue = $newcond->sibling; - $false = $newtrue->sibling; # last in chain is OP_AND => no else - $newcond = $self->deparse($newcond, 1); - $newtrue = $self->deparse($newtrue, 0); - push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}"; - } - if (!null($false)) { - $false = $cuddle . "else {\n\t" . - $self->deparse($false, 0) . "\n\b}\cK"; - } else { - $false = "\cK"; - } - return $head . join($cuddle, "", @elsifs) . $false; + my $head = "if ($cond) {\n\t$true\n\b}"; + my @elsifs; + while (!null($false) and is_ifelse_cont($false)) { + my $newop = $false->first; + my $newcond = $newop->first; + my $newtrue = $newcond->sibling; + $false = $newtrue->sibling; # last in chain is OP_AND => no else + $newcond = $self->deparse($newcond, 1); + $newtrue = $self->deparse($newtrue, 0); + push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}"; + } + if (!null($false)) { + $false = $cuddle . "else {\n\t" . + $self->deparse($false, 0) . "\n\b}\cK"; + } else { + $false = "\cK"; } - $false = $self->deparse($false, 0); - return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK"; + 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; @@ -1737,62 +1776,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 $kid; - } - $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 { @@ -1814,7 +1851,7 @@ sub pp_null { } elsif ($op->first->name eq "enter") { return $self->pp_leave($op, $cx); } elsif ($op->targ == OP_STRINGIFY) { - return $self->dquote($op); + return $self->dquote($op, $cx); } elsif (!null($op->first->sibling) and $op->first->sibling->name eq "readline" and $op->first->sibling->flags & OPf_STACKED) { @@ -1832,21 +1869,10 @@ sub pp_null { } } -# the aassign in-common check messes up SvCUR (always setting it -# to a value >= 100), but it's probably safe to assume there -# won't be any NULs in the names of my() variables. (with -# stash variables, I wouldn't be so sure) -sub padname_fix { - my $str = shift; - $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1; - return $str; -} - sub padname { my $self = shift; my $targ = shift; - my $str = $self->padname_sv($targ)->PV; - return padname_fix($str); + return $self->padname_sv($targ)->PVX; } sub padany { @@ -1879,37 +1905,34 @@ sub pp_threadsv { return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]); } -sub maybe_padgv { +sub gv_or_padgv { my $self = shift; my $op = shift; - my $gv; - if ($Config{useithreads}) { - $gv = $self->padval($op->padix); - } - else { - $gv = $op->gv; + if (class($op) eq "PADOP") { + return $self->padval($op->padix); + } else { # class($op) eq "SVOP" + return $op->gv; } - return $gv; } sub pp_gvsv { my $self = shift; my($op, $cx) = @_; - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv)); } sub pp_gv { my $self = shift; my($op, $cx) = @_; - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); return $self->gv_name($gv); } sub pp_aelemfast { my $self = shift; my($op, $cx) = @_; - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); return "\$" . $self->gv_name($gv) . "[" . $op->private . "]"; } @@ -2220,7 +2243,7 @@ sub pp_entersub { $amper = "&"; $kid = "{" . $self->deparse($kid, 0) . "}"; } elsif ($kid->first->name eq "gv") { - my $gv = $self->maybe_padgv($kid->first); + my $gv = $self->gv_or_padgv($kid->first); if (class($gv->CV) ne "SPECIAL") { $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK; } @@ -2252,9 +2275,9 @@ sub pp_entersub { } else { if (defined $proto and $proto eq "") { return $kid; - } elsif ($proto eq "\$") { + } elsif (defined $proto and $proto eq "\$") { return $self->maybe_parens_func($kid, $args, $cx, 16); - } elsif ($proto or $simple) { + } elsif (defined($proto) && $proto or $simple) { return $self->maybe_parens_func($kid, $args, $cx, 5); } else { return "$kid(" . $args . ")"; @@ -2350,7 +2373,7 @@ sub const { if (class($sv) eq "SPECIAL") { return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no } elsif ($sv->FLAGS & SVf_IOK) { - return $sv->IV; + return $sv->int_value; } elsif ($sv->FLAGS & SVf_NOK) { return $sv->NV; } elsif ($sv->FLAGS & SVf_ROK) { @@ -2381,7 +2404,9 @@ sub pp_const { # return $self->const_sv($op)->PV; # } my $sv = $self->const_sv($op); - return const($sv); +# return const($sv); + my $c = const $sv; + return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c; } sub dq { @@ -2391,7 +2416,13 @@ sub dq { if ($type eq "const") { return uninterp(escape_str(unback($self->const_sv($op)->PV))); } elsif ($type eq "concat") { - return $self->dq($op->first) . $self->dq($op->last); + my $first = $self->dq($op->first); + my $last = $self->dq($op->last); + # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]" + if ($last =~ /^[{\[\w]/) { + $first =~ s/([%\$@])([A-Za-z_]\w*)$/${1}{$2}/; + } + return $first . $last; } elsif ($type eq "uc") { return '\U' . $self->dq($op->first->sibling) . '\E'; } elsif ($type eq "lc") { @@ -2418,7 +2449,7 @@ sub pp_backtick { sub dquote { my $self = shift; - my($op, $cx) = shift; + my($op, $cx) = @_; my $kid = $op->first->sibling; # skip ex-stringify, pushmark return $self->deparse($kid, $cx) if $self->{'unquote'}; $self->maybe_targmy($kid, $cx, @@ -2486,7 +2517,7 @@ sub pchr { # ASCII sub collapse { my(@chars) = @_; - my($c, $str, $tr); + my($str, $c, $tr) = (""); for ($c = 0; $c < @chars; $c++) { $tr = $chars[$c]; $str .= pchr($tr); @@ -2539,7 +2570,7 @@ sub tr_decode_byte { } @from = @newfrom; } - unless ($flags & OPpTRANS_DELETE) { + unless ($flags & OPpTRANS_DELETE || !@to) { pop @to while $#to and $to[$#to] == $to[$#to -1]; } my($from, $to); @@ -2678,9 +2709,15 @@ sub re_dq { my $op = shift; my $type = $op->name; if ($type eq "const") { - return uninterp($self->const_sv($op)->PV); + return re_uninterp($self->const_sv($op)->PV); } elsif ($type eq "concat") { - return $self->re_dq($op->first) . $self->re_dq($op->last); + my $first = $self->re_dq($op->first); + my $last = $self->re_dq($op->last); + # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]" + if ($last =~ /^[{\[\w]/) { + $first =~ s/([%\$@])([A-Za-z_]\w*)$/${1}{$2}/; + } + return $first . $last; } elsif ($type eq "uc") { return '\U' . $self->re_dq($op->first->sibling) . '\E'; } elsif ($type eq "lc") { @@ -2842,8 +2879,8 @@ B::Deparse - Perl compiler backend to produce perl code =head1 SYNOPSIS -B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>][B<,-s>I<LETTERS>] - I<prog.pl> +B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>] + [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl> =head1 DESCRIPTION @@ -2988,6 +3025,55 @@ file is compiled as a main program. =back +=item B<-x>I<LEVEL> + +Expand conventional syntax constructions into equivalent ones that expose +their internal operation. I<LEVEL> 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<LEVEL> 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<LEVEL> is at least 7, if statements will be translated into equivalent +expressions using C<&&>, C<?:> and C<do {}>; 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 @@ -3034,7 +3120,7 @@ See the 'to do' list at the beginning of the module file. =head1 AUTHOR -Stephen McCamant <smccam@uclink4.berkeley.edu>, based on an earlier +Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons. diff --git a/contrib/perl5/ext/B/B/Disassembler.pm b/contrib/perl5/ext/B/B/Disassembler.pm index d054a2d16473..212532b9ce91 100644 --- a/contrib/perl5/ext/B/B/Disassembler.pm +++ b/contrib/perl5/ext/B/B/Disassembler.pm @@ -31,6 +31,13 @@ sub GET_U16 { return unpack("n", $str); } +sub GET_NV { + my $fh = shift; + my $str = $fh->readn(8); + croak "reached EOF while reading NV" unless length($str) == 8; + return unpack("N", $str); +} + sub GET_U32 { my $fh = shift; my $str = $fh->readn(4); diff --git a/contrib/perl5/ext/B/B/Lint.pm b/contrib/perl5/ext/B/B/Lint.pm index ed0d07dfcbd6..094b3cf8fd00 100644 --- a/contrib/perl5/ext/B/B/Lint.pm +++ b/contrib/perl5/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/contrib/perl5/ext/B/B/Showlex.pm b/contrib/perl5/ext/B/B/Showlex.pm index 648f95dcc0a3..842ca3ee2b86 100644 --- a/contrib/perl5/ext/B/B/Showlex.pm +++ b/contrib/perl5/ext/B/B/Showlex.pm @@ -12,7 +12,24 @@ use B::Terse (); # to see the names of file scope lexicals used by bar.pl # -sub showarray { +sub shownamearray { + my ($name, $av) = @_; + my @els = $av->ARRAY; + my $count = @els; + my $i; + print "$name has $count entries\n"; + for ($i = 0; $i < $count; $i++) { + print "$i: "; + my $sv = $els[$i]; + if (class($sv) ne "SPECIAL") { + printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX; + } else { + $sv->terse; + } + } +} + +sub showvaluearray { my ($name, $av) = @_; my @els = $av->ARRAY; my $count = @els; @@ -26,8 +43,8 @@ sub showarray { sub showlex { my ($objname, $namesav, $valsav) = @_; - showarray("Pad of lexical names for $objname", $namesav); - showarray("Pad of lexical values for $objname", $valsav); + shownamearray("Pad of lexical names for $objname", $namesav); + showvaluearray("Pad of lexical values for $objname", $valsav); } sub showlex_obj { diff --git a/contrib/perl5/ext/B/B/Stash.pm b/contrib/perl5/ext/B/B/Stash.pm index 0a3543eed41e..f3a82478777d 100644 --- a/contrib/perl5/ext/B/B/Stash.pm +++ b/contrib/perl5/ext/B/B/Stash.pm @@ -2,11 +2,19 @@ # vishalb@hotmail.com package B::Stash; +=pod + +=head1 NAME + +B::Stash - show what stashes are loaded + +=cut + BEGIN { %Seen = %INC } CHECK { my @arr=scan($main::{"main::"}); - @arr=map{s/\:\:$//;$_;} @arr; + @arr=map{s/\:\:$//;$_ eq "<none>"?():$_;} @arr; print "-umain,-u", join (",-u",@arr) ,"\n"; } sub scan{ diff --git a/contrib/perl5/ext/B/B/Terse.pm b/contrib/perl5/ext/B/B/Terse.pm index 66b5cfc2f2f0..52f0549911e4 100644 --- a/contrib/perl5/ext/B/B/Terse.pm +++ b/contrib/perl5/ext/B/B/Terse.pm @@ -1,7 +1,7 @@ package B::Terse; use strict; -use B qw(peekop class walkoptree_slow walkoptree_exec - main_start main_root cstring svref_2object); +use B qw(peekop class walkoptree walkoptree_exec walkoptree_slow + main_start main_root cstring svref_2object SVf_IVisUV); use B::Asmdata qw(@specialsv_name); sub terse { @@ -15,7 +15,7 @@ sub terse { } sub compile { - my $order = shift; + my $order = @_ ? shift : ""; my @options = @_; B::clearsym(); if (@options) { @@ -37,7 +37,7 @@ sub compile { } sub indent { - my $level = shift; + my $level = @_ ? shift : 0; return " " x $level; } @@ -102,13 +102,14 @@ sub B::GV::terse { $stash = $stash . "::"; } print indent($level); - printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->NAME; + printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->SAFENAME; } sub B::IV::terse { my ($sv, $level) = @_; print indent($level); - printf "%s (0x%lx) %d\n", class($sv), $$sv, $sv->IV; + my $v = $sv->FLAGS & SVf_IVisUV ? "%u" : "%d"; + printf "%s (0x%lx) $v\n", class($sv), $$sv, $sv->int_value; } sub B::NV::terse { diff --git a/contrib/perl5/ext/B/Makefile.PL b/contrib/perl5/ext/B/Makefile.PL index cb9696bf4164..dcf6a1db15b2 100644 --- a/contrib/perl5/ext/B/Makefile.PL +++ b/contrib/perl5/ext/B/Makefile.PL @@ -1,5 +1,6 @@ use ExtUtils::MakeMaker; use Config; +use File::Spec; my $e = $Config{'exe_ext'}; my $o = $Config{'obj_ext'}; @@ -29,8 +30,19 @@ sub post_constants { "\nLIBS = $Config::Config{libs}\n" } -sub postamble { -' -B$(OBJ_EXT) : defsubs.h -' +sub upupfile { + File::Spec->catfile(File::Spec->updir, + File::Spec->updir, $_[0]); +} + +sub MY::postamble { + my $op_h = upupfile('op.h'); + my $cop_h = upupfile('cop.h'); + my $noecho = shift->{NOECHO}; +" +B\$(OBJ_EXT) : defsubs.h + +defsubs.h :: $op_h $cop_h + $noecho \$(NOOP) +" } diff --git a/contrib/perl5/ext/B/O.pm b/contrib/perl5/ext/B/O.pm index 352f8d42069e..2ef91edbd92d 100644 --- a/contrib/perl5/ext/B/O.pm +++ b/contrib/perl5/ext/B/O.pm @@ -1,5 +1,5 @@ package O; -use B qw(minus_c); +use B qw(minus_c save_BEGINs); use Carp; sub import { @@ -11,6 +11,7 @@ sub import { my $compilesub = &{"B::${backend}::compile"}(@options); if (ref($compilesub) eq "CODE") { minus_c; + save_BEGINs; eval 'CHECK { &$compilesub() }'; } else { die $compilesub; diff --git a/contrib/perl5/ext/B/defsubs_h.PL b/contrib/perl5/ext/B/defsubs_h.PL index 80ef936fcecf..da6566b0d717 100644 --- a/contrib/perl5/ext/B/defsubs_h.PL +++ b/contrib/perl5/ext/B/defsubs_h.PL @@ -6,16 +6,23 @@ my ($out) = __FILE__ =~ /(^.*)\.PL/i; $out =~ s/_h$/.h/; open(OUT,">$out") || die "Cannot open $file:$!"; print "Extracting $out...\n"; -foreach my $const (qw(AVf_REAL +foreach my $const (qw( + AVf_REAL HEf_SVKEY + SVf_READONLY SVTYPEMASK + GVf_IMPORTED_AV GVf_IMPORTED_HV + GVf_IMPORTED_SV GVf_IMPORTED_CV + CVf_METHOD CVf_LOCKED CVf_LVALUE SVf_IOK SVf_IVisUV SVf_NOK SVf_POK - SVf_ROK SVp_IOK SVp_POK )) + SVf_ROK SVp_IOK SVp_POK SVp_NOK + )) { doconst($const); } foreach my $file (qw(op.h cop.h)) { - open(OPH,"../../$file") || die "Cannot open ../../$file:$!"; + my $path = $^O eq 'MacOS' ? ":::$file" : "../../$file"; + open(OPH,"$path") || die "Cannot open $path:$!"; while (<OPH>) { doconst($1) if (/#define\s+(\w+)\s+([\(\)\|\dx]+)\s*(?:$|\/\*)/); diff --git a/contrib/perl5/ext/B/ramblings/flip-flop b/contrib/perl5/ext/B/ramblings/flip-flop index e0cb8ff62052..e08333d172db 100644 --- a/contrib/perl5/ext/B/ramblings/flip-flop +++ b/contrib/perl5/ext/B/ramblings/flip-flop @@ -9,13 +9,13 @@ PP(pp_range) } pp_range is a LOGOP. -In array context, it just returns op_next. +In list context, it just returns op_next. In scalar context it checks the truth of targ and returns op_other if true, op_next if false. flip is an UNOP. It "looks after" its child which is always a pp_range LOGOP. -In array context, it just returns the child's op_other. +In list context, it just returns the child's op_other. In scalar context, there are three possible outcomes: (1) set child's targ to 1, our targ to 1 and return op_next. (2) set child's targ to 1, our targ to 0, sp-- and return child's op_other. diff --git a/contrib/perl5/ext/ByteLoader/ByteLoader.pm b/contrib/perl5/ext/ByteLoader/ByteLoader.pm index 286d74697eec..9c8c84d677c2 100644 --- a/contrib/perl5/ext/ByteLoader/ByteLoader.pm +++ b/contrib/perl5/ext/ByteLoader/ByteLoader.pm @@ -2,7 +2,7 @@ package ByteLoader; use XSLoader (); -$VERSION = 0.03; +$VERSION = 0.04; XSLoader::load 'ByteLoader', $VERSION; @@ -17,10 +17,10 @@ ByteLoader - load byte compiled perl code =head1 SYNOPSIS - use ByteLoader 0.03; + use ByteLoader 0.04; <byte code> - use ByteLoader 0.03; + use ByteLoader 0.04; <byte code> =head1 DESCRIPTION diff --git a/contrib/perl5/ext/ByteLoader/ByteLoader.xs b/contrib/perl5/ext/ByteLoader/ByteLoader.xs index 7c3746bba70d..05b795ca25d7 100644 --- a/contrib/perl5/ext/ByteLoader/ByteLoader.xs +++ b/contrib/perl5/ext/ByteLoader/ByteLoader.xs @@ -4,47 +4,95 @@ #include "XSUB.h" #include "byterun.h" -static int -xgetc(PerlIO *io) -{ - dTHX; - return PerlIO_getc(io); -} +/* Something arbitary for a buffer size */ +#define BYTELOADER_BUFFER 8096 -static int -xfread(char *buf, size_t size, size_t n, PerlIO *io) +int +bl_getc(struct byteloader_fdata *data) { dTHX; - int i = PerlIO_read(io, buf, n * size); - if (i > 0) - i /= size; - return i; + if (SvCUR(data->datasv) <= data->next_out) { + int result; + /* Run out of buffered data, so attempt to read some more */ + *(SvPV_nolen (data->datasv)) = '\0'; + SvCUR_set (data->datasv, 0); + data->next_out = 0; + result = FILTER_READ (data->idx + 1, data->datasv, BYTELOADER_BUFFER); + + /* Filter returned error, or we got EOF and no data, then return EOF. + Not sure if filter is allowed to return EOF and add data simultaneously + Think not, but will bullet proof against it. */ + if (result < 0 || SvCUR(data->datasv) == 0) + return EOF; + /* Else there must be at least one byte present, which is good enough */ + } + + return *((char *) SvPV_nolen (data->datasv) + data->next_out++); } -static void -freadpv(U32 len, void *data, XPV *pv) +int +bl_read(struct byteloader_fdata *data, char *buf, size_t size, size_t n) { dTHX; - New(666, pv->xpv_pv, len, char); - PerlIO_read((PerlIO*)data, (void*)pv->xpv_pv, len); - pv->xpv_len = len; - pv->xpv_cur = len - 1; + char *start; + STRLEN len; + size_t wanted = size * n; + + start = SvPV (data->datasv, len); + if (len < (data->next_out + wanted)) { + int result; + + /* Shuffle data to start of buffer */ + len -= data->next_out; + if (len) { + memmove (start, start + data->next_out, len + 1); + SvCUR_set (data->datasv, len); + } else { + *start = '\0'; /* Avoid call to memmove. */ + SvCUR_set (data->datasv, 0); + } + data->next_out = 0; + + /* Attempt to read more data. */ + do { + result = FILTER_READ (data->idx + 1, data->datasv, BYTELOADER_BUFFER); + + start = SvPV (data->datasv, len); + } while (result > 0 && len < wanted); + /* Loop while not (EOF || error) and short reads */ + + /* If not enough data read, truncate copy */ + if (wanted > len) + wanted = len; + } + + if (wanted > 0) { + memcpy (buf, start + data->next_out, wanted); + data->next_out += wanted; + wanted /= size; + } + return (int) wanted; } static I32 byteloader_filter(pTHXo_ int idx, SV *buf_sv, int maxlen) { - dTHR; OP *saveroot = PL_main_root; OP *savestart = PL_main_start; - struct bytestream bs; + struct byteloader_state bstate; + struct byteloader_fdata data; + + data.next_out = 0; + data.datasv = FILTER_DATA(idx); + data.idx = idx; - bs.data = PL_rsfp; - bs.pfgetc = (int(*) (void*))xgetc; - bs.pfread = (int(*) (char*,size_t,size_t,void*))xfread; - bs.pfreadpv = freadpv; + bstate.bs_fdata = &data; + bstate.bs_obj_list = Null(void**); + bstate.bs_obj_list_fill = -1; + bstate.bs_sv = Nullsv; + bstate.bs_iv_overflows = 0; - byterun(aTHXo_ bs); + byterun(aTHXo_ &bstate); if (PL_in_eval) { OP *o; @@ -70,8 +118,12 @@ PROTOTYPES: ENABLE void import(...) + PREINIT: + SV *sv = newSVpvn ("", 0); PPCODE: - filter_add(byteloader_filter, NULL); + if (!sv) + croak ("Could not allocate ByteLoader buffers"); + filter_add(byteloader_filter, sv); void unimport(...) diff --git a/contrib/perl5/ext/ByteLoader/bytecode.h b/contrib/perl5/ext/ByteLoader/bytecode.h index 1621fed4eba4..c6acd28436dc 100644 --- a/contrib/perl5/ext/ByteLoader/bytecode.h +++ b/contrib/perl5/ext/ByteLoader/bytecode.h @@ -5,29 +5,33 @@ typedef char *op_tr_array; typedef int comment_t; typedef SV *svindex; typedef OP *opindex; +typedef char *pvindex; typedef IV IV64; #define BGET_FREAD(argp, len, nelem) \ - bs.pfread((char*)(argp),(len),(nelem),bs.data) -#define BGET_FGETC() bs.pfgetc(bs.data) + bl_read(bstate->bs_fdata,(char*)(argp),(len),(nelem)) +#define BGET_FGETC() bl_getc(bstate->bs_fdata) #define BGET_U32(arg) \ - BGET_FREAD(&arg, sizeof(U32), 1); arg = PerlSock_ntohl((U32)arg) + BGET_FREAD(&arg, sizeof(U32), 1) #define BGET_I32(arg) \ - BGET_FREAD(&arg, sizeof(I32), 1); arg = (I32)PerlSock_ntohl((U32)arg) + BGET_FREAD(&arg, sizeof(I32), 1) #define BGET_U16(arg) \ - BGET_FREAD(&arg, sizeof(U16), 1); arg = PerlSock_ntohs((U16)arg) + BGET_FREAD(&arg, sizeof(U16), 1) #define BGET_U8(arg) arg = BGET_FGETC() -#define BGET_PV(arg) STMT_START { \ - BGET_U32(arg); \ - if (arg) \ - bs.pfreadpv(arg, bs.data, &bytecode_pv); \ - else { \ - bytecode_pv.xpv_pv = 0; \ - bytecode_pv.xpv_len = 0; \ - bytecode_pv.xpv_cur = 0; \ - } \ +#define BGET_PV(arg) STMT_START { \ + BGET_U32(arg); \ + if (arg) { \ + New(666, bstate->bs_pv.xpv_pv, arg, char); \ + bl_read(bstate->bs_fdata, (void*)bstate->bs_pv.xpv_pv, arg, 1); \ + bstate->bs_pv.xpv_len = arg; \ + bstate->bs_pv.xpv_cur = arg - 1; \ + } else { \ + bstate->bs_pv.xpv_pv = 0; \ + bstate->bs_pv.xpv_len = 0; \ + bstate->bs_pv.xpv_cur = 0; \ + } \ } STMT_END #ifdef BYTELOADER_LOG_COMMENTS @@ -63,22 +67,20 @@ typedef IV IV64; arg = (I32)lo; \ } \ else { \ - bytecode_iv_overflows++; \ + bstate->bs_iv_overflows++; \ arg = 0; \ } \ } STMT_END -#define BGET_op_tr_array(arg) do { \ - unsigned short *ary; \ - int i; \ - New(666, ary, 256, unsigned short); \ - BGET_FREAD(ary, 256, 2); \ - for (i = 0; i < 256; i++) \ - ary[i] = PerlSock_ntohs(ary[i]); \ - arg = (char *) ary; \ +#define BGET_op_tr_array(arg) do { \ + unsigned short *ary; \ + int i; \ + New(666, ary, 256, unsigned short); \ + BGET_FREAD(ary, sizeof(unsigned short), 256); \ + arg = (char *) ary; \ } while (0) -#define BGET_pvcontents(arg) arg = bytecode_pv.xpv_pv +#define BGET_pvcontents(arg) arg = bstate->bs_pv.xpv_pv #define BGET_strconst(arg) STMT_START { \ for (arg = PL_tokenbuf; (*arg = BGET_FGETC()); arg++) /* nothing */; \ arg = PL_tokenbuf; \ @@ -91,14 +93,21 @@ typedef IV IV64; } STMT_END #define BGET_objindex(arg, type) STMT_START { \ - U32 ix; \ BGET_U32(ix); \ - arg = (type)bytecode_obj_list[ix]; \ + arg = (type)bstate->bs_obj_list[ix]; \ } STMT_END #define BGET_svindex(arg) BGET_objindex(arg, svindex) #define BGET_opindex(arg) BGET_objindex(arg, opindex) +#define BGET_pvindex(arg) STMT_START { \ + BGET_objindex(arg, pvindex); \ + arg = arg ? savepv(arg) : arg; \ + } STMT_END #define BSET_ldspecsv(sv, arg) sv = specialsv_list[arg] +#define BSET_stpv(pv, arg) STMT_START { \ + BSET_OBJ_STORE(pv, arg); \ + SAVEFREEPV(pv); \ + } STMT_END #define BSET_sv_refcnt_add(svrefcnt, arg) svrefcnt += arg #define BSET_gp_refcnt_add(gprefcnt, arg) gprefcnt += arg @@ -110,23 +119,29 @@ typedef IV IV64; #define BSET_gv_fetchpv(sv, arg) sv = (SV*)gv_fetchpv(arg, TRUE, SVt_PV) #define BSET_gv_stashpv(sv, arg) sv = (SV*)gv_stashpv(arg, TRUE) #define BSET_sv_magic(sv, arg) sv_magic(sv, Nullsv, arg, 0, 0) -#define BSET_mg_pv(mg, arg) mg->mg_ptr = arg; mg->mg_len = bytecode_pv.xpv_cur +#define BSET_mg_pv(mg, arg) mg->mg_ptr = arg; mg->mg_len = bstate->bs_pv.xpv_cur #define BSET_sv_upgrade(sv, arg) (void)SvUPGRADE(sv, arg) #define BSET_xpv(sv) do { \ - SvPV_set(sv, bytecode_pv.xpv_pv); \ - SvCUR_set(sv, bytecode_pv.xpv_cur); \ - SvLEN_set(sv, bytecode_pv.xpv_len); \ + SvPV_set(sv, bstate->bs_pv.xpv_pv); \ + SvCUR_set(sv, bstate->bs_pv.xpv_cur); \ + SvLEN_set(sv, bstate->bs_pv.xpv_len); \ } while (0) #define BSET_av_extend(sv, arg) av_extend((AV*)sv, arg) #define BSET_av_push(sv, arg) av_push((AV*)sv, arg) #define BSET_hv_store(sv, arg) \ - hv_store((HV*)sv, bytecode_pv.xpv_pv, bytecode_pv.xpv_cur, arg, 0) + hv_store((HV*)sv, bstate->bs_pv.xpv_pv, bstate->bs_pv.xpv_cur, arg, 0) #define BSET_pv_free(pv) Safefree(pv.xpv_pv) #define BSET_pregcomp(o, arg) \ ((PMOP*)o)->op_pmregexp = arg ? \ - CALLREGCOMP(aTHX_ arg, arg + bytecode_pv.xpv_cur, ((PMOP*)o)) : 0 -#define BSET_newsv(sv, arg) sv = NEWSV(666,0); SvUPGRADE(sv, arg) + CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv_cur, ((PMOP*)o)) : 0 +#define BSET_newsv(sv, arg) \ + STMT_START { \ + sv = (arg == SVt_PVAV ? (SV*)newAV() : \ + arg == SVt_PVHV ? (SV*)newHV() : \ + NEWSV(666,0)); \ + SvUPGRADE(sv, arg); \ + } STMT_END #define BSET_newop(o, arg) ((o = (OP*)safemalloc(optype_size[arg])), \ memzero((char*)o,optype_size[arg])) #define BSET_newopn(o, arg) STMT_START { \ @@ -135,7 +150,10 @@ typedef IV IV64; oldop->op_next = o; \ } STMT_END -#define BSET_ret(foo) return +#define BSET_ret(foo) STMT_START { \ + Safefree(bstate->bs_obj_list); \ + return; \ + } STMT_END /* * Kludge special-case workaround for OP_MAPSTART @@ -152,10 +170,88 @@ typedef IV IV64; PL_comppad = (AV *)arg; \ pad = AvARRAY(arg); \ } STMT_END +/* this works now that Sarathy's changed the CopFILE_set macro to do the SvREFCNT_inc() + -- BKS 6-2-2000 */ #define BSET_cop_file(cop, arg) CopFILE_set(cop,arg) #define BSET_cop_line(cop, arg) CopLINE_set(cop,arg) #define BSET_cop_stashpv(cop, arg) CopSTASHPV_set(cop,arg) -#define BSET_OBJ_STORE(obj, ix) \ - (I32)ix > bytecode_obj_list_fill ? \ - bset_obj_store(aTHXo_ obj, (I32)ix) : (bytecode_obj_list[ix] = obj) +/* this is simply stolen from the code in newATTRSUB() */ +#define BSET_push_begin(ary,cv) \ + STMT_START { \ + I32 oldscope = PL_scopestack_ix; \ + ENTER; \ + SAVECOPFILE(&PL_compiling); \ + SAVECOPLINE(&PL_compiling); \ + save_svref(&PL_rs); \ + sv_setsv(PL_rs, PL_nrs); \ + if (!PL_beginav) \ + PL_beginav = newAV(); \ + av_push(PL_beginav, cv); \ + call_list(oldscope, PL_beginav); \ + PL_curcop = &PL_compiling; \ + PL_compiling.op_private = PL_hints; \ + LEAVE; \ + } STMT_END +#define BSET_push_init(ary,cv) \ + STMT_START { \ + av_unshift((PL_initav ? PL_initav : (PL_initav = newAV(), PL_initav)), 1); \ + av_store(PL_initav, 0, cv); \ + } STMT_END +#define BSET_push_end(ary,cv) \ + STMT_START { \ + av_unshift((PL_endav ? PL_endav : (PL_endav = newAV(), PL_endav)), 1); \ + av_store(PL_endav, 0, cv); \ + } STMT_END +#define BSET_OBJ_STORE(obj, ix) \ + (I32)ix > bstate->bs_obj_list_fill ? \ + bset_obj_store(aTHXo_ bstate, obj, (I32)ix) : (bstate->bs_obj_list[ix] = obj) + +/* NOTE: the bytecode header only sanity-checks the bytecode. If a script cares about + * what version of Perl it's being called under, it should do a 'require 5.6.0' or + * equivalent. However, since the header includes checks requiring an exact match in + * ByteLoader versions (we can't guarantee forward compatibility), you don't + * need to specify one: + * use ByteLoader; + * is all you need. + * -- BKS, June 2000 +*/ + +#define HEADER_FAIL(f) \ + Perl_croak(aTHX_ "Invalid bytecode for this architecture: " f) +#define HEADER_FAIL1(f, arg1) \ + Perl_croak(aTHX_ "Invalid bytecode for this architecture: " f, arg1) +#define HEADER_FAIL2(f, arg1, arg2) \ + Perl_croak(aTHX_ "Invalid bytecode for this architecture: " f, arg1, arg2) + +#define BYTECODE_HEADER_CHECK \ + STMT_START { \ + U32 sz = 0; \ + strconst str; \ + \ + BGET_U32(sz); /* Magic: 'PLBC' */ \ + if (sz != 0x43424c50) { \ + HEADER_FAIL1("bad magic (want 0x43424c50, got %#x)", (int)sz); \ + } \ + BGET_strconst(str); /* archname */ \ + if (strNE(str, ARCHNAME)) { \ + HEADER_FAIL2("wrong architecture (want %s, you have %s)",str,ARCHNAME); \ + } \ + BGET_strconst(str); /* ByteLoader version */ \ + if (strNE(str, VERSION)) { \ + HEADER_FAIL2("mismatched ByteLoader versions (want %s, you have %s)", \ + str, VERSION); \ + } \ + BGET_U32(sz); /* ivsize */ \ + if (sz != IVSIZE) { \ + HEADER_FAIL("different IVSIZE"); \ + } \ + BGET_U32(sz); /* ptrsize */ \ + if (sz != PTRSIZE) { \ + HEADER_FAIL("different PTRSIZE"); \ + } \ + BGET_strconst(str); /* byteorder */ \ + if (strNE(str, STRINGIFY(BYTEORDER))) { \ + HEADER_FAIL("different byteorder"); \ + } \ + } STMT_END diff --git a/contrib/perl5/ext/ByteLoader/byterun.c b/contrib/perl5/ext/ByteLoader/byterun.c index a1044ab2c0f2..71cd8aa08496 100644 --- a/contrib/perl5/ext/ByteLoader/byterun.c +++ b/contrib/perl5/ext/ByteLoader/byterun.c @@ -26,7 +26,7 @@ #include "bytecode.h" -static int optype_size[] = { +static const int optype_size[] = { sizeof(OP), sizeof(UNOP), sizeof(BINOP), @@ -40,38 +40,34 @@ static int optype_size[] = { sizeof(COP) }; -static SV *specialsv_list[4]; - -static int bytecode_iv_overflows = 0; -static SV *bytecode_sv; -static XPV bytecode_pv; -static void **bytecode_obj_list; -static I32 bytecode_obj_list_fill = -1; - void * -bset_obj_store(pTHXo_ void *obj, I32 ix) +bset_obj_store(pTHXo_ struct byteloader_state *bstate, void *obj, I32 ix) { - if (ix > bytecode_obj_list_fill) { - if (bytecode_obj_list_fill == -1) - New(666, bytecode_obj_list, ix + 1, void*); - else - Renew(bytecode_obj_list, ix + 1, void*); - bytecode_obj_list_fill = ix; + if (ix > bstate->bs_obj_list_fill) { + Renew(bstate->bs_obj_list, ix + 32, void*); + bstate->bs_obj_list_fill = ix + 31; } - bytecode_obj_list[ix] = obj; + bstate->bs_obj_list[ix] = obj; return obj; } void -byterun(pTHXo_ struct bytestream bs) +byterun(pTHXo_ register struct byteloader_state *bstate) { - dTHR; - int insn; + register int insn; + U32 ix; + SV *specialsv_list[6]; + + BYTECODE_HEADER_CHECK; /* croak if incorrect platform */ + New(666, bstate->bs_obj_list, 32, void*); /* set op objlist */ + bstate->bs_obj_list_fill = 31; specialsv_list[0] = Nullsv; specialsv_list[1] = &PL_sv_undef; specialsv_list[2] = &PL_sv_yes; specialsv_list[3] = &PL_sv_no; + specialsv_list[4] = pWARN_ALL; + specialsv_list[5] = pWARN_NONE; while ((insn = BGET_FGETC()) != EOF) { switch (insn) { @@ -95,7 +91,7 @@ byterun(pTHXo_ struct bytestream bs) { svindex arg; BGET_svindex(arg); - bytecode_sv = arg; + bstate->bs_sv = arg; break; } case INSN_LDOP: /* 2 */ @@ -109,7 +105,7 @@ byterun(pTHXo_ struct bytestream bs) { U32 arg; BGET_U32(arg); - BSET_OBJ_STORE(bytecode_sv, arg); + BSET_OBJ_STORE(bstate->bs_sv, arg); break; } case INSN_STOP: /* 4 */ @@ -119,610 +115,610 @@ byterun(pTHXo_ struct bytestream bs) BSET_OBJ_STORE(PL_op, arg); break; } - case INSN_LDSPECSV: /* 5 */ + case INSN_STPV: /* 5 */ + { + U32 arg; + BGET_U32(arg); + BSET_stpv(bstate->bs_pv.xpv_pv, arg); + break; + } + case INSN_LDSPECSV: /* 6 */ { U8 arg; BGET_U8(arg); - BSET_ldspecsv(bytecode_sv, arg); + BSET_ldspecsv(bstate->bs_sv, arg); break; } - case INSN_NEWSV: /* 6 */ + case INSN_NEWSV: /* 7 */ { U8 arg; BGET_U8(arg); - BSET_newsv(bytecode_sv, arg); + BSET_newsv(bstate->bs_sv, arg); break; } - case INSN_NEWOP: /* 7 */ + case INSN_NEWOP: /* 8 */ { U8 arg; BGET_U8(arg); BSET_newop(PL_op, arg); break; } - case INSN_NEWOPN: /* 8 */ + case INSN_NEWOPN: /* 9 */ { U8 arg; BGET_U8(arg); BSET_newopn(PL_op, arg); break; } - case INSN_NEWPV: /* 9 */ + case INSN_NEWPV: /* 11 */ { PV arg; BGET_PV(arg); break; } - case INSN_PV_CUR: /* 11 */ + case INSN_PV_CUR: /* 12 */ { STRLEN arg; BGET_U32(arg); - bytecode_pv.xpv_cur = arg; + bstate->bs_pv.xpv_cur = arg; break; } - case INSN_PV_FREE: /* 12 */ + case INSN_PV_FREE: /* 13 */ { - BSET_pv_free(bytecode_pv); + BSET_pv_free(bstate->bs_pv); break; } - case INSN_SV_UPGRADE: /* 13 */ + case INSN_SV_UPGRADE: /* 14 */ { char arg; BGET_U8(arg); - BSET_sv_upgrade(bytecode_sv, arg); + BSET_sv_upgrade(bstate->bs_sv, arg); break; } - case INSN_SV_REFCNT: /* 14 */ + case INSN_SV_REFCNT: /* 15 */ { U32 arg; BGET_U32(arg); - SvREFCNT(bytecode_sv) = arg; + SvREFCNT(bstate->bs_sv) = arg; break; } - case INSN_SV_REFCNT_ADD: /* 15 */ + case INSN_SV_REFCNT_ADD: /* 16 */ { I32 arg; BGET_I32(arg); - BSET_sv_refcnt_add(SvREFCNT(bytecode_sv), arg); + BSET_sv_refcnt_add(SvREFCNT(bstate->bs_sv), arg); break; } - case INSN_SV_FLAGS: /* 16 */ + case INSN_SV_FLAGS: /* 17 */ { U32 arg; BGET_U32(arg); - SvFLAGS(bytecode_sv) = arg; + SvFLAGS(bstate->bs_sv) = arg; break; } - case INSN_XRV: /* 17 */ + case INSN_XRV: /* 18 */ { svindex arg; BGET_svindex(arg); - SvRV(bytecode_sv) = arg; + SvRV(bstate->bs_sv) = arg; break; } - case INSN_XPV: /* 18 */ + case INSN_XPV: /* 19 */ { - BSET_xpv(bytecode_sv); + BSET_xpv(bstate->bs_sv); break; } - case INSN_XIV32: /* 19 */ + case INSN_XIV32: /* 20 */ { I32 arg; BGET_I32(arg); - SvIVX(bytecode_sv) = arg; + SvIVX(bstate->bs_sv) = arg; break; } - case INSN_XIV64: /* 20 */ + case INSN_XIV64: /* 21 */ { IV64 arg; BGET_IV64(arg); - SvIVX(bytecode_sv) = arg; + SvIVX(bstate->bs_sv) = arg; break; } - case INSN_XNV: /* 21 */ + case INSN_XNV: /* 22 */ { NV arg; BGET_NV(arg); - SvNVX(bytecode_sv) = arg; + SvNVX(bstate->bs_sv) = arg; break; } - case INSN_XLV_TARGOFF: /* 22 */ + case INSN_XLV_TARGOFF: /* 23 */ { STRLEN arg; BGET_U32(arg); - LvTARGOFF(bytecode_sv) = arg; + LvTARGOFF(bstate->bs_sv) = arg; break; } - case INSN_XLV_TARGLEN: /* 23 */ + case INSN_XLV_TARGLEN: /* 24 */ { STRLEN arg; BGET_U32(arg); - LvTARGLEN(bytecode_sv) = arg; + LvTARGLEN(bstate->bs_sv) = arg; break; } - case INSN_XLV_TARG: /* 24 */ + case INSN_XLV_TARG: /* 25 */ { svindex arg; BGET_svindex(arg); - LvTARG(bytecode_sv) = arg; + LvTARG(bstate->bs_sv) = arg; break; } - case INSN_XLV_TYPE: /* 25 */ + case INSN_XLV_TYPE: /* 26 */ { char arg; BGET_U8(arg); - LvTYPE(bytecode_sv) = arg; + LvTYPE(bstate->bs_sv) = arg; break; } - case INSN_XBM_USEFUL: /* 26 */ + case INSN_XBM_USEFUL: /* 27 */ { I32 arg; BGET_I32(arg); - BmUSEFUL(bytecode_sv) = arg; + BmUSEFUL(bstate->bs_sv) = arg; break; } - case INSN_XBM_PREVIOUS: /* 27 */ + case INSN_XBM_PREVIOUS: /* 28 */ { U16 arg; BGET_U16(arg); - BmPREVIOUS(bytecode_sv) = arg; + BmPREVIOUS(bstate->bs_sv) = arg; break; } - case INSN_XBM_RARE: /* 28 */ + case INSN_XBM_RARE: /* 29 */ { U8 arg; BGET_U8(arg); - BmRARE(bytecode_sv) = arg; + BmRARE(bstate->bs_sv) = arg; break; } - case INSN_XFM_LINES: /* 29 */ + case INSN_XFM_LINES: /* 30 */ { I32 arg; BGET_I32(arg); - FmLINES(bytecode_sv) = arg; + FmLINES(bstate->bs_sv) = arg; break; } - case INSN_XIO_LINES: /* 30 */ + case INSN_XIO_LINES: /* 31 */ { long arg; BGET_I32(arg); - IoLINES(bytecode_sv) = arg; + IoLINES(bstate->bs_sv) = arg; break; } - case INSN_XIO_PAGE: /* 31 */ + case INSN_XIO_PAGE: /* 32 */ { long arg; BGET_I32(arg); - IoPAGE(bytecode_sv) = arg; + IoPAGE(bstate->bs_sv) = arg; break; } - case INSN_XIO_PAGE_LEN: /* 32 */ + case INSN_XIO_PAGE_LEN: /* 33 */ { long arg; BGET_I32(arg); - IoPAGE_LEN(bytecode_sv) = arg; + IoPAGE_LEN(bstate->bs_sv) = arg; break; } - case INSN_XIO_LINES_LEFT: /* 33 */ + case INSN_XIO_LINES_LEFT: /* 34 */ { long arg; BGET_I32(arg); - IoLINES_LEFT(bytecode_sv) = arg; + IoLINES_LEFT(bstate->bs_sv) = arg; break; } - case INSN_XIO_TOP_NAME: /* 34 */ + case INSN_XIO_TOP_NAME: /* 36 */ { pvcontents arg; BGET_pvcontents(arg); - IoTOP_NAME(bytecode_sv) = arg; + IoTOP_NAME(bstate->bs_sv) = arg; break; } - case INSN_XIO_TOP_GV: /* 36 */ + case INSN_XIO_TOP_GV: /* 37 */ { svindex arg; BGET_svindex(arg); - *(SV**)&IoTOP_GV(bytecode_sv) = arg; + *(SV**)&IoTOP_GV(bstate->bs_sv) = arg; break; } - case INSN_XIO_FMT_NAME: /* 37 */ + case INSN_XIO_FMT_NAME: /* 38 */ { pvcontents arg; BGET_pvcontents(arg); - IoFMT_NAME(bytecode_sv) = arg; + IoFMT_NAME(bstate->bs_sv) = arg; break; } - case INSN_XIO_FMT_GV: /* 38 */ + case INSN_XIO_FMT_GV: /* 39 */ { svindex arg; BGET_svindex(arg); - *(SV**)&IoFMT_GV(bytecode_sv) = arg; + *(SV**)&IoFMT_GV(bstate->bs_sv) = arg; break; } - case INSN_XIO_BOTTOM_NAME: /* 39 */ + case INSN_XIO_BOTTOM_NAME: /* 40 */ { pvcontents arg; BGET_pvcontents(arg); - IoBOTTOM_NAME(bytecode_sv) = arg; + IoBOTTOM_NAME(bstate->bs_sv) = arg; break; } - case INSN_XIO_BOTTOM_GV: /* 40 */ + case INSN_XIO_BOTTOM_GV: /* 41 */ { svindex arg; BGET_svindex(arg); - *(SV**)&IoBOTTOM_GV(bytecode_sv) = arg; + *(SV**)&IoBOTTOM_GV(bstate->bs_sv) = arg; break; } - case INSN_XIO_SUBPROCESS: /* 41 */ + case INSN_XIO_SUBPROCESS: /* 42 */ { short arg; BGET_U16(arg); - IoSUBPROCESS(bytecode_sv) = arg; + IoSUBPROCESS(bstate->bs_sv) = arg; break; } - case INSN_XIO_TYPE: /* 42 */ + case INSN_XIO_TYPE: /* 43 */ { char arg; BGET_U8(arg); - IoTYPE(bytecode_sv) = arg; + IoTYPE(bstate->bs_sv) = arg; break; } - case INSN_XIO_FLAGS: /* 43 */ + case INSN_XIO_FLAGS: /* 44 */ { char arg; BGET_U8(arg); - IoFLAGS(bytecode_sv) = arg; + IoFLAGS(bstate->bs_sv) = arg; break; } - case INSN_XCV_STASH: /* 44 */ + case INSN_XCV_STASH: /* 45 */ { svindex arg; BGET_svindex(arg); - *(SV**)&CvSTASH(bytecode_sv) = arg; + *(SV**)&CvSTASH(bstate->bs_sv) = arg; break; } - case INSN_XCV_START: /* 45 */ + case INSN_XCV_START: /* 46 */ { opindex arg; BGET_opindex(arg); - CvSTART(bytecode_sv) = arg; + CvSTART(bstate->bs_sv) = arg; break; } - case INSN_XCV_ROOT: /* 46 */ + case INSN_XCV_ROOT: /* 47 */ { opindex arg; BGET_opindex(arg); - CvROOT(bytecode_sv) = arg; + CvROOT(bstate->bs_sv) = arg; break; } - case INSN_XCV_GV: /* 47 */ + case INSN_XCV_GV: /* 48 */ { svindex arg; BGET_svindex(arg); - *(SV**)&CvGV(bytecode_sv) = arg; + *(SV**)&CvGV(bstate->bs_sv) = arg; break; } - case INSN_XCV_FILE: /* 48 */ + case INSN_XCV_FILE: /* 49 */ { - pvcontents arg; - BGET_pvcontents(arg); - CvFILE(bytecode_sv) = arg; + pvindex arg; + BGET_pvindex(arg); + CvFILE(bstate->bs_sv) = arg; break; } - case INSN_XCV_DEPTH: /* 49 */ + case INSN_XCV_DEPTH: /* 50 */ { long arg; BGET_I32(arg); - CvDEPTH(bytecode_sv) = arg; + CvDEPTH(bstate->bs_sv) = arg; break; } - case INSN_XCV_PADLIST: /* 50 */ + case INSN_XCV_PADLIST: /* 51 */ { svindex arg; BGET_svindex(arg); - *(SV**)&CvPADLIST(bytecode_sv) = arg; + *(SV**)&CvPADLIST(bstate->bs_sv) = arg; break; } - case INSN_XCV_OUTSIDE: /* 51 */ + case INSN_XCV_OUTSIDE: /* 52 */ { svindex arg; BGET_svindex(arg); - *(SV**)&CvOUTSIDE(bytecode_sv) = arg; + *(SV**)&CvOUTSIDE(bstate->bs_sv) = arg; break; } - case INSN_XCV_FLAGS: /* 52 */ + case INSN_XCV_FLAGS: /* 53 */ { U16 arg; BGET_U16(arg); - CvFLAGS(bytecode_sv) = arg; + CvFLAGS(bstate->bs_sv) = arg; break; } - case INSN_AV_EXTEND: /* 53 */ + case INSN_AV_EXTEND: /* 54 */ { SSize_t arg; BGET_I32(arg); - BSET_av_extend(bytecode_sv, arg); + BSET_av_extend(bstate->bs_sv, arg); break; } - case INSN_AV_PUSH: /* 54 */ + case INSN_AV_PUSH: /* 55 */ { svindex arg; BGET_svindex(arg); - BSET_av_push(bytecode_sv, arg); + BSET_av_push(bstate->bs_sv, arg); break; } - case INSN_XAV_FILL: /* 55 */ + case INSN_XAV_FILL: /* 56 */ { SSize_t arg; BGET_I32(arg); - AvFILLp(bytecode_sv) = arg; + AvFILLp(bstate->bs_sv) = arg; break; } - case INSN_XAV_MAX: /* 56 */ + case INSN_XAV_MAX: /* 57 */ { SSize_t arg; BGET_I32(arg); - AvMAX(bytecode_sv) = arg; + AvMAX(bstate->bs_sv) = arg; break; } - case INSN_XAV_FLAGS: /* 57 */ + case INSN_XAV_FLAGS: /* 58 */ { U8 arg; BGET_U8(arg); - AvFLAGS(bytecode_sv) = arg; + AvFLAGS(bstate->bs_sv) = arg; break; } - case INSN_XHV_RITER: /* 58 */ + case INSN_XHV_RITER: /* 59 */ { I32 arg; BGET_I32(arg); - HvRITER(bytecode_sv) = arg; + HvRITER(bstate->bs_sv) = arg; break; } - case INSN_XHV_NAME: /* 59 */ + case INSN_XHV_NAME: /* 60 */ { pvcontents arg; BGET_pvcontents(arg); - HvNAME(bytecode_sv) = arg; + HvNAME(bstate->bs_sv) = arg; break; } - case INSN_HV_STORE: /* 60 */ + case INSN_HV_STORE: /* 61 */ { svindex arg; BGET_svindex(arg); - BSET_hv_store(bytecode_sv, arg); + BSET_hv_store(bstate->bs_sv, arg); break; } - case INSN_SV_MAGIC: /* 61 */ + case INSN_SV_MAGIC: /* 62 */ { char arg; BGET_U8(arg); - BSET_sv_magic(bytecode_sv, arg); + BSET_sv_magic(bstate->bs_sv, arg); break; } - case INSN_MG_OBJ: /* 62 */ + case INSN_MG_OBJ: /* 63 */ { svindex arg; BGET_svindex(arg); - SvMAGIC(bytecode_sv)->mg_obj = arg; + SvMAGIC(bstate->bs_sv)->mg_obj = arg; break; } - case INSN_MG_PRIVATE: /* 63 */ + case INSN_MG_PRIVATE: /* 64 */ { U16 arg; BGET_U16(arg); - SvMAGIC(bytecode_sv)->mg_private = arg; + SvMAGIC(bstate->bs_sv)->mg_private = arg; break; } - case INSN_MG_FLAGS: /* 64 */ + case INSN_MG_FLAGS: /* 65 */ { U8 arg; BGET_U8(arg); - SvMAGIC(bytecode_sv)->mg_flags = arg; + SvMAGIC(bstate->bs_sv)->mg_flags = arg; break; } - case INSN_MG_PV: /* 65 */ + case INSN_MG_PV: /* 66 */ { pvcontents arg; BGET_pvcontents(arg); - BSET_mg_pv(SvMAGIC(bytecode_sv), arg); + BSET_mg_pv(SvMAGIC(bstate->bs_sv), arg); break; } - case INSN_XMG_STASH: /* 66 */ + case INSN_XMG_STASH: /* 67 */ { svindex arg; BGET_svindex(arg); - *(SV**)&SvSTASH(bytecode_sv) = arg; + *(SV**)&SvSTASH(bstate->bs_sv) = arg; break; } - case INSN_GV_FETCHPV: /* 67 */ + case INSN_GV_FETCHPV: /* 68 */ { strconst arg; BGET_strconst(arg); - BSET_gv_fetchpv(bytecode_sv, arg); + BSET_gv_fetchpv(bstate->bs_sv, arg); break; } - case INSN_GV_STASHPV: /* 68 */ + case INSN_GV_STASHPV: /* 69 */ { strconst arg; BGET_strconst(arg); - BSET_gv_stashpv(bytecode_sv, arg); + BSET_gv_stashpv(bstate->bs_sv, arg); break; } - case INSN_GP_SV: /* 69 */ + case INSN_GP_SV: /* 70 */ { svindex arg; BGET_svindex(arg); - GvSV(bytecode_sv) = arg; + GvSV(bstate->bs_sv) = arg; break; } - case INSN_GP_REFCNT: /* 70 */ + case INSN_GP_REFCNT: /* 71 */ { U32 arg; BGET_U32(arg); - GvREFCNT(bytecode_sv) = arg; + GvREFCNT(bstate->bs_sv) = arg; break; } - case INSN_GP_REFCNT_ADD: /* 71 */ + case INSN_GP_REFCNT_ADD: /* 72 */ { I32 arg; BGET_I32(arg); - BSET_gp_refcnt_add(GvREFCNT(bytecode_sv), arg); + BSET_gp_refcnt_add(GvREFCNT(bstate->bs_sv), arg); break; } - case INSN_GP_AV: /* 72 */ + case INSN_GP_AV: /* 73 */ { svindex arg; BGET_svindex(arg); - *(SV**)&GvAV(bytecode_sv) = arg; + *(SV**)&GvAV(bstate->bs_sv) = arg; break; } - case INSN_GP_HV: /* 73 */ + case INSN_GP_HV: /* 74 */ { svindex arg; BGET_svindex(arg); - *(SV**)&GvHV(bytecode_sv) = arg; + *(SV**)&GvHV(bstate->bs_sv) = arg; break; } - case INSN_GP_CV: /* 74 */ + case INSN_GP_CV: /* 75 */ { svindex arg; BGET_svindex(arg); - *(SV**)&GvCV(bytecode_sv) = arg; + *(SV**)&GvCV(bstate->bs_sv) = arg; break; } - case INSN_GP_FILE: /* 75 */ + case INSN_GP_FILE: /* 76 */ { - pvcontents arg; - BGET_pvcontents(arg); - GvFILE(bytecode_sv) = arg; + pvindex arg; + BGET_pvindex(arg); + GvFILE(bstate->bs_sv) = arg; break; } - case INSN_GP_IO: /* 76 */ + case INSN_GP_IO: /* 77 */ { svindex arg; BGET_svindex(arg); - *(SV**)&GvIOp(bytecode_sv) = arg; + *(SV**)&GvIOp(bstate->bs_sv) = arg; break; } - case INSN_GP_FORM: /* 77 */ + case INSN_GP_FORM: /* 78 */ { svindex arg; BGET_svindex(arg); - *(SV**)&GvFORM(bytecode_sv) = arg; + *(SV**)&GvFORM(bstate->bs_sv) = arg; break; } - case INSN_GP_CVGEN: /* 78 */ + case INSN_GP_CVGEN: /* 79 */ { U32 arg; BGET_U32(arg); - GvCVGEN(bytecode_sv) = arg; + GvCVGEN(bstate->bs_sv) = arg; break; } - case INSN_GP_LINE: /* 79 */ + case INSN_GP_LINE: /* 80 */ { line_t arg; BGET_U16(arg); - GvLINE(bytecode_sv) = arg; + GvLINE(bstate->bs_sv) = arg; break; } - case INSN_GP_SHARE: /* 80 */ + case INSN_GP_SHARE: /* 81 */ { svindex arg; BGET_svindex(arg); - BSET_gp_share(bytecode_sv, arg); + BSET_gp_share(bstate->bs_sv, arg); break; } - case INSN_XGV_FLAGS: /* 81 */ + case INSN_XGV_FLAGS: /* 82 */ { U8 arg; BGET_U8(arg); - GvFLAGS(bytecode_sv) = arg; + GvFLAGS(bstate->bs_sv) = arg; break; } - case INSN_OP_NEXT: /* 82 */ + case INSN_OP_NEXT: /* 83 */ { opindex arg; BGET_opindex(arg); PL_op->op_next = arg; break; } - case INSN_OP_SIBLING: /* 83 */ + case INSN_OP_SIBLING: /* 84 */ { opindex arg; BGET_opindex(arg); PL_op->op_sibling = arg; break; } - case INSN_OP_PPADDR: /* 84 */ + case INSN_OP_PPADDR: /* 85 */ { strconst arg; BGET_strconst(arg); BSET_op_ppaddr(PL_op->op_ppaddr, arg); break; } - case INSN_OP_TARG: /* 85 */ + case INSN_OP_TARG: /* 86 */ { PADOFFSET arg; BGET_U32(arg); PL_op->op_targ = arg; break; } - case INSN_OP_TYPE: /* 86 */ + case INSN_OP_TYPE: /* 87 */ { OPCODE arg; BGET_U16(arg); BSET_op_type(PL_op, arg); break; } - case INSN_OP_SEQ: /* 87 */ + case INSN_OP_SEQ: /* 88 */ { U16 arg; BGET_U16(arg); PL_op->op_seq = arg; break; } - case INSN_OP_FLAGS: /* 88 */ + case INSN_OP_FLAGS: /* 89 */ { U8 arg; BGET_U8(arg); PL_op->op_flags = arg; break; } - case INSN_OP_PRIVATE: /* 89 */ + case INSN_OP_PRIVATE: /* 90 */ { U8 arg; BGET_U8(arg); PL_op->op_private = arg; break; } - case INSN_OP_FIRST: /* 90 */ + case INSN_OP_FIRST: /* 91 */ { opindex arg; BGET_opindex(arg); cUNOP->op_first = arg; break; } - case INSN_OP_LAST: /* 91 */ + case INSN_OP_LAST: /* 92 */ { opindex arg; BGET_opindex(arg); cBINOP->op_last = arg; break; } - case INSN_OP_OTHER: /* 92 */ + case INSN_OP_OTHER: /* 93 */ { opindex arg; BGET_opindex(arg); cLOGOP->op_other = arg; break; } - case INSN_OP_CHILDREN: /* 93 */ - { - U32 arg; - BGET_U32(arg); - cLISTOP->op_children = arg; - break; - } case INSN_OP_PMREPLROOT: /* 94 */ { opindex arg; @@ -823,22 +819,22 @@ byterun(pTHXo_ struct bytestream bs) } case INSN_COP_LABEL: /* 108 */ { - pvcontents arg; - BGET_pvcontents(arg); + pvindex arg; + BGET_pvindex(arg); cCOP->cop_label = arg; break; } case INSN_COP_STASHPV: /* 109 */ { - pvcontents arg; - BGET_pvcontents(arg); + pvindex arg; + BGET_pvindex(arg); BSET_cop_stashpv(cCOP, arg); break; } case INSN_COP_FILE: /* 110 */ { - pvcontents arg; - BGET_pvcontents(arg); + pvindex arg; + BGET_pvindex(arg); BSET_cop_file(cCOP, arg); break; } @@ -891,6 +887,27 @@ byterun(pTHXo_ struct bytestream bs) BSET_curpad(PL_curpad, arg); break; } + case INSN_PUSH_BEGIN: /* 118 */ + { + svindex arg; + BGET_svindex(arg); + BSET_push_begin(PL_beginav, arg); + break; + } + case INSN_PUSH_INIT: /* 119 */ + { + svindex arg; + BGET_svindex(arg); + BSET_push_init(PL_initav, arg); + break; + } + case INSN_PUSH_END: /* 120 */ + { + svindex arg; + BGET_svindex(arg); + BSET_push_end(PL_endav, arg); + break; + } default: Perl_croak(aTHX_ "Illegal bytecode instruction %d\n", insn); /* NOTREACHED */ diff --git a/contrib/perl5/ext/ByteLoader/byterun.h b/contrib/perl5/ext/ByteLoader/byterun.h index f0de6b482044..f074f2d6cf6f 100644 --- a/contrib/perl5/ext/ByteLoader/byterun.h +++ b/contrib/perl5/ext/ByteLoader/byterun.h @@ -8,108 +8,120 @@ /* * This file is autogenerated from bytecode.pl. Changes made here will be lost. */ -struct bytestream { - void *data; - int (*pfgetc)(void *); - int (*pfread)(char *, size_t, size_t, void *); - void (*pfreadpv)(U32, void *, XPV *); +struct byteloader_fdata { + SV *datasv; + int next_out; + int idx; }; +struct byteloader_state { + struct byteloader_fdata *bs_fdata; + SV *bs_sv; + void **bs_obj_list; + int bs_obj_list_fill; + XPV bs_pv; + int bs_iv_overflows; +}; + +int bl_getc(struct byteloader_fdata *); +int bl_read(struct byteloader_fdata *, char *, size_t, size_t); +extern void byterun(pTHXo_ struct byteloader_state *); + enum { INSN_RET, /* 0 */ INSN_LDSV, /* 1 */ INSN_LDOP, /* 2 */ INSN_STSV, /* 3 */ INSN_STOP, /* 4 */ - INSN_LDSPECSV, /* 5 */ - INSN_NEWSV, /* 6 */ - INSN_NEWOP, /* 7 */ - INSN_NEWOPN, /* 8 */ - INSN_NEWPV, /* 9 */ + INSN_STPV, /* 5 */ + INSN_LDSPECSV, /* 6 */ + INSN_NEWSV, /* 7 */ + INSN_NEWOP, /* 8 */ + INSN_NEWOPN, /* 9 */ INSN_NOP, /* 10 */ - INSN_PV_CUR, /* 11 */ - INSN_PV_FREE, /* 12 */ - INSN_SV_UPGRADE, /* 13 */ - INSN_SV_REFCNT, /* 14 */ - INSN_SV_REFCNT_ADD, /* 15 */ - INSN_SV_FLAGS, /* 16 */ - INSN_XRV, /* 17 */ - INSN_XPV, /* 18 */ - INSN_XIV32, /* 19 */ - INSN_XIV64, /* 20 */ - INSN_XNV, /* 21 */ - INSN_XLV_TARGOFF, /* 22 */ - INSN_XLV_TARGLEN, /* 23 */ - INSN_XLV_TARG, /* 24 */ - INSN_XLV_TYPE, /* 25 */ - INSN_XBM_USEFUL, /* 26 */ - INSN_XBM_PREVIOUS, /* 27 */ - INSN_XBM_RARE, /* 28 */ - INSN_XFM_LINES, /* 29 */ - INSN_XIO_LINES, /* 30 */ - INSN_XIO_PAGE, /* 31 */ - INSN_XIO_PAGE_LEN, /* 32 */ - INSN_XIO_LINES_LEFT, /* 33 */ - INSN_XIO_TOP_NAME, /* 34 */ + INSN_NEWPV, /* 11 */ + INSN_PV_CUR, /* 12 */ + INSN_PV_FREE, /* 13 */ + INSN_SV_UPGRADE, /* 14 */ + INSN_SV_REFCNT, /* 15 */ + INSN_SV_REFCNT_ADD, /* 16 */ + INSN_SV_FLAGS, /* 17 */ + INSN_XRV, /* 18 */ + INSN_XPV, /* 19 */ + INSN_XIV32, /* 20 */ + INSN_XIV64, /* 21 */ + INSN_XNV, /* 22 */ + INSN_XLV_TARGOFF, /* 23 */ + INSN_XLV_TARGLEN, /* 24 */ + INSN_XLV_TARG, /* 25 */ + INSN_XLV_TYPE, /* 26 */ + INSN_XBM_USEFUL, /* 27 */ + INSN_XBM_PREVIOUS, /* 28 */ + INSN_XBM_RARE, /* 29 */ + INSN_XFM_LINES, /* 30 */ + INSN_XIO_LINES, /* 31 */ + INSN_XIO_PAGE, /* 32 */ + INSN_XIO_PAGE_LEN, /* 33 */ + INSN_XIO_LINES_LEFT, /* 34 */ INSN_COMMENT, /* 35 */ - INSN_XIO_TOP_GV, /* 36 */ - INSN_XIO_FMT_NAME, /* 37 */ - INSN_XIO_FMT_GV, /* 38 */ - INSN_XIO_BOTTOM_NAME, /* 39 */ - INSN_XIO_BOTTOM_GV, /* 40 */ - INSN_XIO_SUBPROCESS, /* 41 */ - INSN_XIO_TYPE, /* 42 */ - INSN_XIO_FLAGS, /* 43 */ - INSN_XCV_STASH, /* 44 */ - INSN_XCV_START, /* 45 */ - INSN_XCV_ROOT, /* 46 */ - INSN_XCV_GV, /* 47 */ - INSN_XCV_FILE, /* 48 */ - INSN_XCV_DEPTH, /* 49 */ - INSN_XCV_PADLIST, /* 50 */ - INSN_XCV_OUTSIDE, /* 51 */ - INSN_XCV_FLAGS, /* 52 */ - INSN_AV_EXTEND, /* 53 */ - INSN_AV_PUSH, /* 54 */ - INSN_XAV_FILL, /* 55 */ - INSN_XAV_MAX, /* 56 */ - INSN_XAV_FLAGS, /* 57 */ - INSN_XHV_RITER, /* 58 */ - INSN_XHV_NAME, /* 59 */ - INSN_HV_STORE, /* 60 */ - INSN_SV_MAGIC, /* 61 */ - INSN_MG_OBJ, /* 62 */ - INSN_MG_PRIVATE, /* 63 */ - INSN_MG_FLAGS, /* 64 */ - INSN_MG_PV, /* 65 */ - INSN_XMG_STASH, /* 66 */ - INSN_GV_FETCHPV, /* 67 */ - INSN_GV_STASHPV, /* 68 */ - INSN_GP_SV, /* 69 */ - INSN_GP_REFCNT, /* 70 */ - INSN_GP_REFCNT_ADD, /* 71 */ - INSN_GP_AV, /* 72 */ - INSN_GP_HV, /* 73 */ - INSN_GP_CV, /* 74 */ - INSN_GP_FILE, /* 75 */ - INSN_GP_IO, /* 76 */ - INSN_GP_FORM, /* 77 */ - INSN_GP_CVGEN, /* 78 */ - INSN_GP_LINE, /* 79 */ - INSN_GP_SHARE, /* 80 */ - INSN_XGV_FLAGS, /* 81 */ - INSN_OP_NEXT, /* 82 */ - INSN_OP_SIBLING, /* 83 */ - INSN_OP_PPADDR, /* 84 */ - INSN_OP_TARG, /* 85 */ - INSN_OP_TYPE, /* 86 */ - INSN_OP_SEQ, /* 87 */ - INSN_OP_FLAGS, /* 88 */ - INSN_OP_PRIVATE, /* 89 */ - INSN_OP_FIRST, /* 90 */ - INSN_OP_LAST, /* 91 */ - INSN_OP_OTHER, /* 92 */ - INSN_OP_CHILDREN, /* 93 */ + INSN_XIO_TOP_NAME, /* 36 */ + INSN_XIO_TOP_GV, /* 37 */ + INSN_XIO_FMT_NAME, /* 38 */ + INSN_XIO_FMT_GV, /* 39 */ + INSN_XIO_BOTTOM_NAME, /* 40 */ + INSN_XIO_BOTTOM_GV, /* 41 */ + INSN_XIO_SUBPROCESS, /* 42 */ + INSN_XIO_TYPE, /* 43 */ + INSN_XIO_FLAGS, /* 44 */ + INSN_XCV_STASH, /* 45 */ + INSN_XCV_START, /* 46 */ + INSN_XCV_ROOT, /* 47 */ + INSN_XCV_GV, /* 48 */ + INSN_XCV_FILE, /* 49 */ + INSN_XCV_DEPTH, /* 50 */ + INSN_XCV_PADLIST, /* 51 */ + INSN_XCV_OUTSIDE, /* 52 */ + INSN_XCV_FLAGS, /* 53 */ + INSN_AV_EXTEND, /* 54 */ + INSN_AV_PUSH, /* 55 */ + INSN_XAV_FILL, /* 56 */ + INSN_XAV_MAX, /* 57 */ + INSN_XAV_FLAGS, /* 58 */ + INSN_XHV_RITER, /* 59 */ + INSN_XHV_NAME, /* 60 */ + INSN_HV_STORE, /* 61 */ + INSN_SV_MAGIC, /* 62 */ + INSN_MG_OBJ, /* 63 */ + INSN_MG_PRIVATE, /* 64 */ + INSN_MG_FLAGS, /* 65 */ + INSN_MG_PV, /* 66 */ + INSN_XMG_STASH, /* 67 */ + INSN_GV_FETCHPV, /* 68 */ + INSN_GV_STASHPV, /* 69 */ + INSN_GP_SV, /* 70 */ + INSN_GP_REFCNT, /* 71 */ + INSN_GP_REFCNT_ADD, /* 72 */ + INSN_GP_AV, /* 73 */ + INSN_GP_HV, /* 74 */ + INSN_GP_CV, /* 75 */ + INSN_GP_FILE, /* 76 */ + INSN_GP_IO, /* 77 */ + INSN_GP_FORM, /* 78 */ + INSN_GP_CVGEN, /* 79 */ + INSN_GP_LINE, /* 80 */ + INSN_GP_SHARE, /* 81 */ + INSN_XGV_FLAGS, /* 82 */ + INSN_OP_NEXT, /* 83 */ + INSN_OP_SIBLING, /* 84 */ + INSN_OP_PPADDR, /* 85 */ + INSN_OP_TARG, /* 86 */ + INSN_OP_TYPE, /* 87 */ + INSN_OP_SEQ, /* 88 */ + INSN_OP_FLAGS, /* 89 */ + INSN_OP_PRIVATE, /* 90 */ + INSN_OP_FIRST, /* 91 */ + INSN_OP_LAST, /* 92 */ + INSN_OP_OTHER, /* 93 */ INSN_OP_PMREPLROOT, /* 94 */ INSN_OP_PMREPLROOTGV, /* 95 */ INSN_OP_PMREPLSTART, /* 96 */ @@ -134,7 +146,10 @@ enum { INSN_MAIN_START, /* 115 */ INSN_MAIN_ROOT, /* 116 */ INSN_CURPAD, /* 117 */ - MAX_INSN = 117 + INSN_PUSH_BEGIN, /* 118 */ + INSN_PUSH_INIT, /* 119 */ + INSN_PUSH_END, /* 120 */ + MAX_INSN = 120 }; enum { @@ -151,11 +166,3 @@ enum { OPt_COP /* 10 */ }; -extern void byterun(pTHXo_ struct bytestream bs); - -#define INIT_SPECIALSV_LIST STMT_START { \ - PL_specialsv_list[0] = Nullsv; \ - PL_specialsv_list[1] = &PL_sv_undef; \ - PL_specialsv_list[2] = &PL_sv_yes; \ - PL_specialsv_list[3] = &PL_sv_no; \ - } STMT_END diff --git a/contrib/perl5/ext/DB_File/Changes b/contrib/perl5/ext/DB_File/Changes index 95eb487e5659..eda270d82b52 100644 --- a/contrib/perl5/ext/DB_File/Changes +++ b/contrib/perl5/ext/DB_File/Changes @@ -291,3 +291,46 @@ to David Harris for spotting the underlying problem, contributing the updates to the documentation and writing DB_File::Lock (available on CPAN). + +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/contrib/perl5/ext/DB_File/DB_File.pm b/contrib/perl5/ext/DB_File/DB_File.pm index 00b24b90e611..c8302168f8e4 100644 --- a/contrib/perl5/ext/DB_File/DB_File.pm +++ b/contrib/perl5/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 16th January 2000 -# version 1.72 +# 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.72" ; +$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<seq> 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<get_dup> 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<tree> 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<match> 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<Extra RECNO Methods> 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<THE API INTERFACE>). + 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<ggh> script (available from your nearest CPAN archive in F<authors/id/TOMC/scripts/nshist.gz>). + 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<strict 'subs'> 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/contrib/perl5/ext/DB_File/DB_File.xs b/contrib/perl5/ext/DB_File/DB_File.xs index 2b76bab72263..fa3bb336c2d2 100644 --- a/contrib/perl5/ext/DB_File/DB_File.xs +++ b/contrib/perl5/ext/DB_File/DB_File.xs @@ -3,8 +3,8 @@ DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess <Paul.Marquess@btinternet.com> - last modified 16th January 2000 - version 1.72 + last modified 17 December 2000 + version 1.75 All comments/suggestions/problems are welcome @@ -82,6 +82,14 @@ Support for Berkeley DB 2/3's backward compatability mode. 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. */ @@ -127,6 +135,10 @@ # include <db.h> #endif +#ifdef CAN_PROTOTYPE +extern void __getBerkeleyDBInfo(void); +#endif + #ifndef pTHX # define pTHX # define pTHX_ @@ -158,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 @@ -243,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 { @@ -472,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 @@ -479,6 +509,9 @@ btree_compare(key1, key2) const DBT * key1 ; const DBT * key2 ; #endif + +#endif + { #ifdef dTHX dTHX; @@ -528,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 @@ -535,6 +581,8 @@ btree_prefix(key1, key2) const DBT * key1 ; const DBT * key2 ; #endif + +#endif { #ifdef dTHX dTHX; @@ -583,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 @@ -1265,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/contrib/perl5/ext/DB_File/Makefile.PL b/contrib/perl5/ext/DB_File/Makefile.PL index cac6578bb308..041416029ac4 100644 --- a/contrib/perl5/ext/DB_File/Makefile.PL +++ b/contrib/perl5/ext/DB_File/Makefile.PL @@ -17,6 +17,7 @@ WriteMakefile( OBJECT => 'version$(OBJ_EXT) DB_File$(OBJ_EXT)', XSPROTOARG => '-noprototypes', DEFINE => $OS2 || "", + INC => ($^O eq "MacOS" ? "-i ::::db:include" : "") ); sub MY::postamble { diff --git a/contrib/perl5/ext/DB_File/dbinfo b/contrib/perl5/ext/DB_File/dbinfo index 701ac612b62b..5a4df15907ee 100644 --- a/contrib/perl5/ext/DB_File/dbinfo +++ b/contrib/perl5/ext/DB_File/dbinfo @@ -4,10 +4,10 @@ # a database file # # Author: Paul Marquess <Paul.Marquess@btinternet.com> -# 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/contrib/perl5/ext/DB_File/typemap b/contrib/perl5/ext/DB_File/typemap index 41a24f4a8638..55439ee76d91 100644 --- a/contrib/perl5/ext/DB_File/typemap +++ b/contrib/perl5/ext/DB_File/typemap @@ -1,8 +1,8 @@ # typemap for Perl 5 interface to Berkeley # # written by Paul Marquess <Paul.Marquess@btinternet.com> -# 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/contrib/perl5/ext/DB_File/version.c b/contrib/perl5/ext/DB_File/version.c index f8c6cac9af78..6e55b2e3d18b 100644 --- a/contrib/perl5/ext/DB_File/version.c +++ b/contrib/perl5/ext/DB_File/version.c @@ -4,7 +4,7 @@ written by Paul Marquess <Paul.Marquess@btinternet.com> last modified 16th January 2000 - version 1.72 + version 1.73 All comments/suggestions/problems are welcome @@ -16,6 +16,9 @@ 1.71 - Support for Berkeley DB version 3. 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. + */ @@ -26,8 +29,15 @@ #include <db.h> void +#ifdef CAN_PROTOTYPE +__getBerkeleyDBInfo(void) +#else __getBerkeleyDBInfo() +#endif { +#ifdef dTHX + dTHX; +#endif SV * version_sv = perl_get_sv("DB_File::db_version", GV_ADD|GV_ADDMULTI) ; SV * ver_sv = perl_get_sv("DB_File::db_ver", GV_ADD|GV_ADDMULTI) ; SV * compat_sv = perl_get_sv("DB_File::db_185_compat", GV_ADD|GV_ADDMULTI) ; diff --git a/contrib/perl5/ext/Data/Dumper/Dumper.pm b/contrib/perl5/ext/Data/Dumper/Dumper.pm index 93b87f9aba96..a8e59ab379d7 100644 --- a/contrib/perl5/ext/Data/Dumper/Dumper.pm +++ b/contrib/perl5/ext/Data/Dumper/Dumper.pm @@ -9,7 +9,7 @@ package Data::Dumper; -$VERSION = '2.101'; +$VERSION = '2.102'; #$| = 1; @@ -291,8 +291,7 @@ sub _dump { $s->{level}++; $ipad = $s->{xpad} x $s->{level}; - - if ($realtype eq 'SCALAR') { + if ($realtype eq 'SCALAR' || $realtype eq 'REF') { if ($realpack) { $out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}'; } @@ -685,7 +684,7 @@ the last. Returns the stringified form of the values stored in the object (preserving the order in which they were supplied to C<new>), subject to the -configuration options below. In an array context, it returns a list +configuration options below. In a list context, it returns a list of strings corresponding to the supplied values. The second form, for convenience, simply calls the C<new> method on its @@ -701,7 +700,7 @@ dumping subroutine references. Expects a anonymous hash of name => value pairs. Same rules apply for names as in C<new>. If no argument is supplied, will return the "seen" list of -name => value pairs, in an array context. Otherwise, returns the object +name => value pairs, in a list context. Otherwise, returns the object itself. =item I<$OBJ>->Values(I<[ARRAYREF]>) @@ -732,7 +731,7 @@ itself. Returns the stringified form of the values in the list, subject to the configuration options below. The values will be named C<$VAR>I<n> in the output, where I<n> is a numeric suffix. Will return a list of strings -in an array context. +in a list context. =back diff --git a/contrib/perl5/ext/Data/Dumper/Dumper.xs b/contrib/perl5/ext/Data/Dumper/Dumper.xs index 990ea7469931..25e72b144c9d 100644 --- a/contrib/perl5/ext/Data/Dumper/Dumper.xs +++ b/contrib/perl5/ext/Data/Dumper/Dumper.xs @@ -584,8 +584,10 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, if (SvIOK(val)) { STRLEN len; - i = SvIV(val); - (void) sprintf(tmpbuf, "%"IVdf, (IV)i); + if (SvIsUV(val)) + (void) sprintf(tmpbuf, "%"UVuf, SvUV(val)); + else + (void) sprintf(tmpbuf, "%"IVdf, SvIV(val)); len = strlen(tmpbuf); sv_catpvn(retval, tmpbuf, len); } @@ -803,7 +805,7 @@ Data_Dumper_Dumpxs(href, ...) if ((svp = av_fetch(namesav, i, TRUE))) sv_setsv(name, *svp); else - SvOK_off(name); + (void)SvOK_off(name); if (SvOK(name)) { if ((SvPVX(name))[0] == '*') { diff --git a/contrib/perl5/ext/Devel/DProf/DProf.xs b/contrib/perl5/ext/Devel/DProf/DProf.xs index 31e984f929b7..aba6de99d3ed 100644 --- a/contrib/perl5/ext/Devel/DProf/DProf.xs +++ b/contrib/perl5/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 */ @@ -28,6 +23,7 @@ # define HZ ((I32)CLK_TCK) # define DPROF_HZ HZ # include <starlet.h> /* prototype for sys$gettim() */ +# include <lib$routines.h> # define Times(ptr) (dprof_times(aTHX_ ptr)) #else # ifndef HZ @@ -280,10 +276,6 @@ prof_mark(pTHX_ opcode ptype) { struct tms t; clock_t realtime, rdelta, udelta, sdelta; - char *name, *pv; - char *hvname; - STRLEN len; - SV *sv; U32 id; SV *Sub = GvSV(PL_DBsub); /* name of current sub */ @@ -388,7 +380,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; @@ -477,8 +468,6 @@ prof_record(pTHX) /* Now that we know the runtimes, fill them in at the recorded location -JH */ - clock_t r, u, s; - if (g_SAVE_STACK) { prof_dump_until(aTHX_ g_profstack_ix); } @@ -502,7 +491,7 @@ prof_record(pTHX) static void check_depth(pTHX_ void *foo) { - U32 need_depth = (U32)foo; + U32 need_depth = PTR2UV(foo); if (need_depth != g_depth) { if (need_depth > g_depth) { warn("garbled call depth when profiling"); @@ -547,6 +536,7 @@ XS(XS_DB_sub) prof_mark(aTHX_ OP_ENTERSUB); PUSHMARK(ORIGMARK); perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG); + PL_curstash = oldstash; prof_mark(aTHX_ OP_LEAVESUB); g_depth--; } diff --git a/contrib/perl5/ext/Devel/Peek/Makefile.PL b/contrib/perl5/ext/Devel/Peek/Makefile.PL index 3c6dbf545d1c..f6d0cc9caa5d 100644 --- a/contrib/perl5/ext/Devel/Peek/Makefile.PL +++ b/contrib/perl5/ext/Devel/Peek/Makefile.PL @@ -2,6 +2,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => "Devel::Peek", VERSION_FROM => 'Peek.pm', + XSPROTOARG => '-noprototypes', 'dist' => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', diff --git a/contrib/perl5/ext/Devel/Peek/Peek.pm b/contrib/perl5/ext/Devel/Peek/Peek.pm index 080251bb5e87..08501728c06d 100644 --- a/contrib/perl5/ext/Devel/Peek/Peek.pm +++ b/contrib/perl5/ext/Devel/Peek/Peek.pm @@ -10,7 +10,8 @@ require Exporter; use XSLoader (); @ISA = qw(Exporter); -@EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg); +@EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg + fill_mstats mstats_fillhash mstats2hash); @EXPORT_OK = qw(SvREFCNT SvREFCNT_inc SvREFCNT_dec CvGV); %EXPORT_TAGS = ('ALL' => [@EXPORT, @EXPORT_OK]); @@ -58,16 +59,76 @@ C<CV>. Devel::Peek also supplies C<SvREFCNT()>, C<SvREFCNT_inc()>, and C<SvREFCNT_dec()> which can query, increment, and decrement reference counts on SVs. This document will take a passive, and safe, approach to data debugging and for that it will describe only the C<Dump()> -function. For format of output of mstats() see -L<perldebug/Using C<$ENV{PERL_DEBUG_MSTATS}>>. +function. Function C<DumpArray()> allows dumping of multiple values (useful when you -need to analize returns of functions). +need to analyze returns of functions). The global variable $Devel::Peek::pv_limit can be set to limit the number of character printed in various string values. Setting it to 0 means no limit. +=head2 Memory footprint debugging + +When perl is compiled with support for memory footprint debugging +(default with Perl's malloc()), Devel::Peek provides an access to this API. + +Use mstat() function to emit a memory state statistic to the terminal. +For more information on the format of output of mstat() see +L<perldebug/Using C<$ENV{PERL_DEBUG_MSTATS}>>. + +Three additional functions allow access to this statistic from Perl. +First, use C<mstats_fillhash(%hash)> to get the information contained +in the output of mstat() into %hash. The field of this hash are + + minbucket nbuckets sbrk_good sbrk_slack sbrked_remains sbrks start_slack + topbucket topbucket_ev topbucket_odd total total_chain total_sbrk totfree + +Two additional fields C<free>, C<used> contain array references which +provide per-bucket count of free and used chunks. Two other fields +C<mem_size>, C<available_size> contain array references which provide +the information about the allocated size and usable size of chunks in +each bucket. Again, see L<perldebug/Using C<$ENV{PERL_DEBUG_MSTATS}>> +for details. + +Keep in mind that only the first several "odd-numbered" buckets are +used, so the information on size of the "odd-numbered" buckets which are +not used is probably meaningless. + +The information in + + mem_size available_size minbucket nbuckets + +is the property of a particular build of perl, and does not depend on +the current process. If you do not provide the optional argument to +the functions mstats_fillhash(), fill_mstats(), mstats2hash(), then +the information in fields C<mem_size>, C<available_size> is not +updated. + +C<fill_mstats($buf)> is a much cheaper call (both speedwise and +memory-wise) which collects the statistic into $buf in +machine-readable form. At a later moment you may need to call +C<mstats2hash($buf, %hash)> to use this information to fill %hash. + +All three APIs C<fill_mstats($buf)>, C<mstats_fillhash(%hash)>, and +C<mstats2hash($buf, %hash)> are designed to allocate no memory if used +I<the second time> on the same $buf and/or %hash. + +So, if you want to collect memory info in a cycle, you may call + + $#buf = 999; + fill_mstats($_) for @buf; + mstats_fillhash(%report, 1); # Static info too + + foreach (@buf) { + # Do something... + fill_mstats $_; # Collect statistic + } + foreach (@buf) { + mstats2hash($_, %report); # Preserve static info + # Do something with %report + } + =head1 EXAMPLES The following examples don't attempt to show everything as that would be a @@ -403,8 +464,9 @@ it has no prototype (C<PROTOTYPE> field is missing). =head1 EXPORTS C<Dump>, C<mstat>, C<DeadCode>, C<DumpArray>, C<DumpWithOP> and -C<DumpProg> by default. Additionally available C<SvREFCNT>, -C<SvREFCNT_inc> and C<SvREFCNT_dec>. +C<DumpProg>, C<fill_mstats>, C<mstats_fillhash>, C<mstats2hash> by +default. Additionally available C<SvREFCNT>, C<SvREFCNT_inc> and +C<SvREFCNT_dec>. =head1 BUGS diff --git a/contrib/perl5/ext/Devel/Peek/Peek.xs b/contrib/perl5/ext/Devel/Peek/Peek.xs index 9837e9ceb216..1e481492b5d9 100644 --- a/contrib/perl5/ext/Devel/Peek/Peek.xs +++ b/contrib/perl5/ext/Devel/Peek/Peek.xs @@ -82,8 +82,6 @@ DeadCode(pTHX) } } else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) { - int db_len = SvLEN(pad[j]); - SV *db_sv = pad[j]; levels++; levelm += SvLEN(pad[j])/SvREFCNT(pad[j]); /* Dump(pad[j],4); */ @@ -125,6 +123,183 @@ DeadCode(pTHX) PerlIO_printf(Perl_debug_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",str); #endif +#if defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \ + || (defined(MYMALLOC) && !defined(PLAIN_MALLOC)) + +/* Very coarse overestimate, 2-per-power-of-2, one more to determine NBUCKETS. */ +# define _NBUCKETS (2*8*IVSIZE+1) + +struct mstats_buffer +{ + perl_mstats_t buffer; + UV buf[_NBUCKETS*4]; +}; + +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; + b->buffer.bucket_available_size = b->buf + 3*_NBUCKETS; + Zero(b->buf, (level ? 4*_NBUCKETS: 2*_NBUCKETS), unsigned long); + get_mstats(&(b->buffer), _NBUCKETS, level); +} + +void +fill_mstats(SV *sv, int level) +{ + dTHX; + int nbuckets; + struct mstats_buffer buf; + + if (SvREADONLY(sv)) + croak("Cannot modify a readonly value"); + SvGROW(sv, sizeof(struct mstats_buffer)+1); + _fill_mstats((struct mstats_buffer*)SvPVX(sv),level); + SvCUR_set(sv, sizeof(struct mstats_buffer)); + *SvEND(sv) = '\0'; + SvPOK_only(sv); +} + +void +_mstats_to_hv(HV *hv, struct mstats_buffer *b, int level) +{ + dTHX; + SV **svp; + int type; + + svp = hv_fetch(hv, "topbucket", 9, 1); + sv_setiv(*svp, b->buffer.topbucket); + + svp = hv_fetch(hv, "topbucket_ev", 12, 1); + sv_setiv(*svp, b->buffer.topbucket_ev); + + svp = hv_fetch(hv, "topbucket_odd", 13, 1); + sv_setiv(*svp, b->buffer.topbucket_odd); + + svp = hv_fetch(hv, "totfree", 7, 1); + sv_setiv(*svp, b->buffer.totfree); + + svp = hv_fetch(hv, "total", 5, 1); + sv_setiv(*svp, b->buffer.total); + + svp = hv_fetch(hv, "total_chain", 11, 1); + sv_setiv(*svp, b->buffer.total_chain); + + svp = hv_fetch(hv, "total_sbrk", 10, 1); + sv_setiv(*svp, b->buffer.total_sbrk); + + svp = hv_fetch(hv, "sbrks", 5, 1); + sv_setiv(*svp, b->buffer.sbrks); + + svp = hv_fetch(hv, "sbrk_good", 9, 1); + sv_setiv(*svp, b->buffer.sbrk_good); + + svp = hv_fetch(hv, "sbrk_slack", 10, 1); + sv_setiv(*svp, b->buffer.sbrk_slack); + + svp = hv_fetch(hv, "start_slack", 11, 1); + sv_setiv(*svp, b->buffer.start_slack); + + svp = hv_fetch(hv, "sbrked_remains", 14, 1); + sv_setiv(*svp, b->buffer.sbrked_remains); + + svp = hv_fetch(hv, "minbucket", 9, 1); + sv_setiv(*svp, b->buffer.minbucket); + + svp = hv_fetch(hv, "nbuckets", 8, 1); + sv_setiv(*svp, b->buffer.nbuckets); + + if (_NBUCKETS < b->buffer.nbuckets) + warn("FIXME: internal mstats buffer too short"); + + for (type = 0; type < (level ? 4 : 2); type++) { + UV *p, *p1; + AV *av; + int i; + static const char *types[4] = { + "free", "used", "mem_size", "available_size" + }; + + svp = hv_fetch(hv, types[type], strlen(types[type]), 1); + + if (SvOK(*svp) && !(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV)) + croak("Unexpected value for the key '%s' in the mstats hash", types[type]); + if (!SvOK(*svp)) { + av = newAV(); + SvUPGRADE(*svp, SVt_RV); + SvRV(*svp) = (SV*)av; + SvROK_on(*svp); + } else + av = (AV*)SvRV(*svp); + + av_extend(av, b->buffer.nbuckets - 1); + /* XXXX What is the official way to reduce the size of the array? */ + switch (type) { + case 0: + p = b->buffer.nfree; + break; + case 1: + p = b->buffer.ntotal; + p1 = b->buffer.nfree; + break; + case 2: + p = b->buffer.bucket_mem_size; + break; + case 3: + p = b->buffer.bucket_available_size; + break; + } + for (i = 0; i < b->buffer.nbuckets; i++) { + svp = av_fetch(av, i, 1); + if (type == 1) + sv_setiv(*svp, p[i]-p1[i]); + else + sv_setuv(*svp, p[i]); + } + } +} +void +mstats_fillhash(SV *sv, int level) +{ + struct mstats_buffer buf; + + if (!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV)) + croak("Not a hash reference"); + _fill_mstats(&buf, level); + _mstats_to_hv((HV *)SvRV(sv), &buf, level); +} +void +mstats2hash(SV *sv, SV *rv, int level) +{ + if (!(SvROK(rv) && SvTYPE(SvRV(rv)) == SVt_PVHV)) + croak("Not a hash reference"); + if (!SvPOK(sv)) + croak("Undefined value when expecting mstats buffer"); + if (SvCUR(sv) != sizeof(struct mstats_buffer)) + croak("Wrong size for a value with a mstats buffer"); + _mstats_to_hv((HV *)SvRV(rv), (struct mstats_buffer*)SvPVX(sv), level); +} +#else /* !( defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \ ) */ +void +fill_mstats(SV *sv, int level) +{ + croak("Cannot report mstats without Perl malloc"); +} +void +mstats_fillhash(SV *sv, int level) +{ + croak("Cannot report mstats without Perl malloc"); +} +void +mstats2hash(SV *sv, SV *rv, int level) +{ + croak("Cannot report mstats without Perl malloc"); +} +#endif /* defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS)... */ + #define _CvGV(cv) \ (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) \ ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef) @@ -136,6 +311,17 @@ mstat(str="Devel::Peek::mstat: ") char *str void +fill_mstats(SV *sv, int level = 0) + +void +mstats_fillhash(SV *sv, int level = 0) + PROTOTYPE: \%;$ + +void +mstats2hash(SV *sv, SV *rv, int level = 0) + PROTOTYPE: $\%;$ + +void Dump(sv,lim=4) SV * sv I32 lim @@ -173,7 +359,7 @@ void DumpProg() PPCODE: { - warn("dumpindent is %d", PL_dumpindent); + warn("dumpindent is %d", (int)PL_dumpindent); if (PL_main_root) op_dump(PL_main_root); } @@ -195,7 +381,7 @@ PPCODE: # PPCODE needed since by default it is void -SV * +void SvREFCNT_dec(sv) SV * sv PPCODE: diff --git a/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL b/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL index e0eb604c73ae..266c9d030f77 100644 --- a/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL +++ b/contrib/perl5/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; @@ -21,18 +20,22 @@ package DynaLoader; # feast like to keep their secret; for wonder makes the words of # praise louder.' -# (Quote from Tolkien sugested by Anno Siegel.) +# (Quote from Tolkien suggested by Anno Siegel.) # # See pod text at end of file for documentation. # See also ext/DynaLoader/README in source tree for other information. # # 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,52 +73,116 @@ print OUT <<'EOT'; # (VMS support by Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>) # 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 <<EOT; +# The below \@dl_library_path has been expanded (%Config) in Perl build time. + +\@dl_library_path = ($dl_library_path); + +EOT + } +} +else { + print OUT <<EOT; +# Initialise \@dl_library_path with the 'standard' library path +# for this platform as determined by Configure. + +$cfg_dl_library_path + +EOT +} + +my $ldlibpthname; +my $ldlibpthname_defined; +my $pthsep; + +if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS}) { + $ldlibpthname = $Config::Config{ldlibpthname}; + $ldlibpthname_defined = defined $Config::Config{ldlibpthname} ? 1 : 0; + $pthsep = $Config::Config{path_sep}; +} +else { + $ldlibpthname = q($Config::Config{ldlibpthname}); + $ldlibpthname_defined = q(defined $Config::Config{ldlibpthname}); + $pthsep = q($Config::Config{path_sep}); + print OUT <<EOT; +my \$ldlibpthname = $ldlibpthname; +my \$ldlibpthname_defined = $ldlibpthname_defined; +my \$pthsep = $pthsep; + +EOT +} + +my $env_dl_library_path = <<'EOT'; +if ($ldlibpthname_defined && + exists $ENV{$ldlibpthname}) { + push(@dl_library_path, split(/$pthsep/, $ENV{$ldlibpthname})); +} -# Add to @dl_library_path any extra directories we can gather -# from environment variables. -if ($Is_MacOS) { - push(@dl_library_path, split(/,/, $ENV{LD_LIBRARY_PATH})) - if exists $ENV{LD_LIBRARY_PATH}; -} else { - push(@dl_library_path, split(/:/, $ENV{$Config::Config{ldlibpthname}})) - if exists $Config::Config{ldlibpthname} && - $Config::Config{ldlibpthname} ne '' && - exists $ENV{$Config::Config{ldlibpthname}} ;; - push(@dl_library_path, split(/:/, $ENV{$Config::Config{ldlibpthname}})) - if exists $Config::Config{ldlibpthname} && - $Config::Config{ldlibpthname} ne '' && - exists $ENV{$Config::Config{ldlibpthname}} ;; # E.g. HP-UX supports both its native SHLIB_PATH *and* LD_LIBRARY_PATH. -push(@dl_library_path, split(/:/, $ENV{LD_LIBRARY_PATH})) - if exists $ENV{LD_LIBRARY_PATH}; + +if ($ldlibpthname_defined && + $ldlibpthname ne 'LD_LIBRARY_PATH' && + exists $ENV{LD_LIBRARY_PATH}) { + push(@dl_library_path, split(/$pthsep/, $ENV{LD_LIBRARY_PATH})); +} +EOT + +if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS} && $ENV{PERL_BUILD_EXPAND_ENV_VARS}) { + eval $env_dl_library_path; +} +else { + print OUT <<EOT; +# Add to \@dl_library_path any extra directories we can gather from environment +# during runtime. + +$env_dl_library_path + +EOT +} + +if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS} && $ENV{PERL_BUILD_EXPAND_ENV_VARS}) { + my $dl_library_path = dquoted_comma_list(@dl_library_path); + print OUT <<EOT; +# The below \@dl_library_path has been expanded (%Config, %ENV) +# in Perl build time. + +\@dl_library_path = ($dl_library_path); + +EOT } +print OUT <<'EOT'; # No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. +# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && - !defined(&dl_load_file); - + !defined(&dl_error); if ($dl_debug) { print STDERR "DynaLoader.pm loaded (@INC, @dl_library_path)\n"; @@ -170,8 +236,8 @@ sub bootstrap { print STDERR "DynaLoader::bootstrap for $module ", ($Is_MacOS - ? "(auto/$modpname/$modfname.$dl_dlext)\n" : - "(:auto:$modpname:$modfname.$dl_dlext)\n") + ? "(:auto:$modpname:$modfname.$dl_dlext)\n" : + "(auto/$modpname/$modfname.$dl_dlext)\n") if $dl_debug; foreach (@INC) { @@ -198,7 +264,7 @@ sub bootstrap { croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)") unless $file; # wording similar to error from 'require' - $file = uc($file) if $Is_VMS && $Config{d_vms_case_sensitive_symbols}; + $file = uc($file) if $Is_VMS && $Config::Config{d_vms_case_sensitive_symbols}; my $bootname = "boot_$module"; $bootname =~ s/\W/_/g; @dl_require_symbols = ($bootname); @@ -326,7 +392,7 @@ print OUT <<'EOT'; # (this is a more complicated issue than it first appears) if (m:/: && -d $_) { push(@dirs, $_); next; } - # VMS: we may be using native VMS directry syntax instead of + # VMS: we may be using native VMS directory syntax instead of # Unix emulation, so check this as well if ($Is_VMS && /[:>\]]/ && -d $_) { push(@dirs, $_); next; } diff --git a/contrib/perl5/ext/DynaLoader/XSLoader_pm.PL b/contrib/perl5/ext/DynaLoader/XSLoader_pm.PL index 8cdfd634255e..7657410d46c3 100644 --- a/contrib/perl5/ext/DynaLoader/XSLoader_pm.PL +++ b/contrib/perl5/ext/DynaLoader/XSLoader_pm.PL @@ -37,10 +37,12 @@ print OUT ' my $dl_dlext = ', to_string($Config::Config{'dlext'}), ";\n" ; print OUT <<'EOT'; -# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. package DynaLoader; + +# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. +# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && - !defined(&dl_load_file); + !defined(&dl_error); package XSLoader; 1; # End of main code diff --git a/contrib/perl5/ext/DynaLoader/dl_aix.xs b/contrib/perl5/ext/DynaLoader/dl_aix.xs index 35242ed652da..e29c0f85f76f 100644 --- a/contrib/perl5/ext/DynaLoader/dl_aix.xs +++ b/contrib/perl5/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 @@ -36,6 +38,8 @@ #include <sys/types.h> #include <sys/ldr.h> #include <a.out.h> +#undef FREAD +#undef FWRITE #include <ldfcn.h> #ifdef USE_64_BIT_ALL @@ -58,13 +62,18 @@ /* Older AIX C compilers cannot deal with C++ double-slash comments in the ibmcxx and/or xlC includes. Since we only need a single file, be more fine-grained about what's included <hirschs@btv.ibm.com> */ + #ifdef USE_libC /* The define comes, when it comes, from hints/aix.pl. */ # define LOAD loadAndInit # define UNLOAD terminateAndUnload -# if defined(USE_xlC_load_h) -# include "/usr/lpp/xlC/include/load.h" +# if defined(USE_vacpp_load_h) +# include "/usr/vacpp/include/load.h" # elif defined(USE_ibmcxx_load_h) # include "/usr/ibmcxx/include/load.h" +# elif defined(USE_xlC_load_h) +# include "/usr/lpp/xlC/include/load.h" +# elif defined(USE_load_h) +# include "/usr/include/load.h" # endif #else # define LOAD load @@ -85,12 +94,6 @@ # define FREAD(p,s,n,ldptr) fread(p,s,n,IOPTR(ldptr)) #endif -/* If using PerlIO, redefine these macros from <ldfcn.h> */ -#ifdef USE_PERLIO -#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 @@ -116,8 +119,8 @@ typedef struct Module { } Module, *ModulePtr; /* - * We keep a list of all loaded modules to be able to call the fini - * handlers at atexit() time. + * We keep a list of all loaded modules to be able to reference count + * duplicate dlopen's. */ static ModulePtr modList; /* XXX threaded */ @@ -130,7 +133,7 @@ static int errvalid; /* XXX threaded */ static void caterr(char *); static int readExports(ModulePtr); -static void terminate(void); +static void *findMain(void); static char *strerror_failed = "(strerror failed)"; static char *strerror_r_failed = "(strerror_r failed)"; @@ -197,15 +200,15 @@ void *dlopen(char *path, int mode) { dTHX; register ModulePtr mp; - static int inited; /* XXX threaded */ + static void *mainModule; /* XXX threaded */ /* * Upon the first call register a terminate handler that will * close all libraries. */ - if (!inited) { - inited++; - atexit(terminate); + if (mainModule == NULL) { + if ((mainModule = findMain()) == NULL) + return NULL; } /* * Scan the list of modules if have the module already loaded. @@ -273,9 +276,13 @@ void *dlopen(char *path, int mode) /* * Assume anonymous exports come from the module this dlopen * is linked into, that holds true as long as dlopen and all - * of the perl core are in the same shared object. + * of the perl core are in the same shared object. Also bind + * against the main part, in the case a perl is not the main + * part, e.g mod_perl as DSO in Apache so perl modules can + * also reference Apache symbols. */ - if (loadbind(0, (void *)dlopen, mp->entry) == -1) { + if (loadbind(0, (void *)dlopen, mp->entry) == -1 || + loadbind(0, mainModule, mp->entry)) { int saverrno = errno; dlclose(mp); @@ -303,7 +310,7 @@ static void caterr(char *s) p++; switch(atoi(s)) { case L_ERROR_TOOMANY: - strcat(errbuf, "to many errors"); + strcat(errbuf, "too many errors"); break; case L_ERROR_NOLIB: strcat(errbuf, "can't load library"); @@ -393,12 +400,6 @@ int dlclose(void *handle) return result; } -static void terminate(void) -{ - while (modList) - dlclose(modList); -} - /* Added by Wayne Scott * This is needed because the ldopen system call calls * calloc to allocated a block of date. The ldclose call calls free. @@ -530,11 +531,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); @@ -590,6 +587,52 @@ static int readExports(ModulePtr mp) return 0; } +/* + * Find the main modules entry point. This is used as export pointer + * for loadbind() to be able to resolve references to the main part. + */ +static void * findMain(void) +{ + struct ld_info *lp; + char *buf; + int size = 4*1024; + int i; + void *ret; + + if ((buf = safemalloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "findMain: "); + strerrorcat(errbuf, errno); + return NULL; + } + while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { + safefree(buf); + size += 4*1024; + if ((buf = safemalloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "findMain: "); + strerrorcat(errbuf, errno); + return NULL; + } + } + if (i == -1) { + errvalid++; + strcpy(errbuf, "findMain: "); + strerrorcat(errbuf, errno); + safefree(buf); + return NULL; + } + /* + * The first entry is the main module. The entry point + * returned by load() does actually point to the data + * segment origin. + */ + lp = (struct ld_info *)buf; + ret = lp->ldinfo_dataorg; + safefree(buf); + return ret; +} + /* dl_dlopen.xs * * Platform: SunOS/Solaris, possibly others which use dlopen. @@ -642,6 +685,17 @@ dl_load_file(filename, flags=0) else sv_setiv( ST(0), PTR2IV(RETVAL) ); +int +dl_unload_file(libref) + void * libref + CODE: + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", libref)); + RETVAL = (dlclose(libref) == 0 ? 1 : 0); + if (!RETVAL) + SaveError(aTHX_ "%s", dlerror()) ; + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " retval = %d\n", RETVAL)); + OUTPUT: + RETVAL void * dl_find_symbol(libhandle, symbolname) diff --git a/contrib/perl5/ext/DynaLoader/dl_dlopen.xs b/contrib/perl5/ext/DynaLoader/dl_dlopen.xs index 8e4936d128d9..e1b2a8241082 100644 --- a/contrib/perl5/ext/DynaLoader/dl_dlopen.xs +++ b/contrib/perl5/ext/DynaLoader/dl_dlopen.xs @@ -112,7 +112,7 @@ SaveError("%s",dlerror()) ; Note that SaveError() takes a printf format string. Use a "%s" as - the first parameter if the error may contain and % characters. + the first parameter if the error may contain any % characters. */ @@ -198,7 +198,7 @@ int dl_unload_file(libref) void * libref CODE: - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", libref)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", PTR2ul(libref))); RETVAL = (dlclose(libref) == 0 ? 1 : 0); if (!RETVAL) SaveError(aTHX_ "%s", dlerror()) ; diff --git a/contrib/perl5/ext/DynaLoader/hints/aix.pl b/contrib/perl5/ext/DynaLoader/hints/aix.pl index 7dde941b43d6..d4231ccb3ef8 100644 --- a/contrib/perl5/ext/DynaLoader/hints/aix.pl +++ b/contrib/perl5/ext/DynaLoader/hints/aix.pl @@ -2,9 +2,13 @@ use Config; if ($Config{libs} =~ /-lC/ && -f '/lib/libC.a') { $self->{CCFLAGS} = $Config{ccflags} . ' -DUSE_libC'; - if (-f '/usr/ibmcxx/include/load.h') { + if (-f '/usr/vacpp/include/load.h') { + $self->{CCFLAGS} .= ' -DUSE_vacpp_load_h'; + } elsif (-f '/usr/ibmcxx/include/load.h') { $self->{CCFLAGS} .= ' -DUSE_ibmcxx_load_h'; } elsif (-f '/usr/lpp/xlC/include/load.h') { $self->{CCFLAGS} .= ' -DUSE_xlC_load_h'; + } elsif (-f '/usr/include/load.h') { + $self->{CCFLAGS} .= ' -DUSE_load_h'; } } diff --git a/contrib/perl5/ext/Errno/ChangeLog b/contrib/perl5/ext/Errno/ChangeLog index 2bfa003d96a4..dd94b37bafb0 100644 --- a/contrib/perl5/ext/Errno/ChangeLog +++ b/contrib/perl5/ext/Errno/ChangeLog @@ -1,3 +1,8 @@ +Change 171 on 2000-09-12 by <calle@lysator.liu.se> (Calle Dybedahl) + + - Fixed filename-extracting regexp to allow whitespace between + "#" and "line", which the cpp on Unicos 9 produces. + Change 170 on 1998/07/05 by <gbarr@pobox.com> (Graham Barr) Fixed three problems reported by Hans Mulder for NeXT diff --git a/contrib/perl5/ext/Errno/Errno_pm.PL b/contrib/perl5/ext/Errno/Errno_pm.PL index df68dc3bda60..3f2f3e04266a 100644 --- a/contrib/perl5/ext/Errno/Errno_pm.PL +++ b/contrib/perl5/ext/Errno/Errno_pm.PL @@ -29,6 +29,14 @@ sub process_file { warn "Cannot open '$file'"; return; } + } elsif ($Config{gccversion} ne '') { + # With the -dM option, gcc outputs every #define it finds + my $ccopts = "-E -dM "; + $ccopts .= "-traditional-cpp " if $^O eq 'darwin'; + unless(open(FH,"$Config{cc} $ccopts $file |")) { + warn "Cannot open '$file'"; + return; + } } else { unless(open(FH,"< $file")) { # This file could be a temporary file created by cppstdin @@ -37,11 +45,19 @@ sub process_file { return; } } - while(<FH>) { - $err{$1} = 1 - if /^\s*#\s*define\s+(E\w+)\s+/; - } - close(FH); + + if ($^O eq 'MacOS') { + while(<FH>) { + $err{$1} = $2 + if /^\s*#\s*define\s+(E\w+)\s+(\d+)/; + } + } else { + while(<FH>) { + $err{$1} = 1 + if /^\s*#\s*define\s+(E\w+)\s+/; + } + } + close(FH); } my $cppstdin; @@ -79,6 +95,18 @@ sub get_files { } elsif ($^O eq 'vmesa') { # OS/390 C compiler doesn't generate #file or #line directives $file{'../../vmesa/errno.h'} = 1; + } elsif ($Config{archname} eq 'epoc') { + # Watch out for cross compiling for EPOC (usually done on linux) + $file{'/usr/local/epoc/include/libc/sys/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; + } elsif ($^O eq 'MacOS') { + # note that we are only getting the GUSI errno's here ... + # we might miss out on compiler-specific ones + $file{"$ENV{GUSI}include:sys:errno.h"} = 1; + } else { open(CPPI,"> errno.c") or die "Cannot open errno.c"; @@ -102,7 +130,7 @@ sub get_files { $pat = '^/\*\s+(.+)\s+\d+\s*:\s+\*/'; } else { - $pat = '^#(?:line)?\s*\d+\s+"([^"]+)"'; + $pat = '^#\s*(?:line)?\s*\d+\s+"([^"]+)"'; } while(<CPPO>) { if ($^O eq 'os2' or $^O eq 'MSWin32') { @@ -141,31 +169,33 @@ sub write_errno_pm { close(CPPI); + unless ($^O eq 'MacOS') { # trust what we have # invoke CPP and read the output - if ($^O eq 'VMS') { - my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}"; - $cpp =~ s/sys\$input//i; - open(CPPO,"$cpp errno.c |") or - die "Cannot exec $Config{cppstdin}"; - } elsif ($^O eq 'MSWin32') { - open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or - die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'"; - } else { - my $cpp = default_cpp(); - open(CPPO,"$cpp < errno.c |") - or die "Cannot exec $cpp"; - } + if ($^O eq 'VMS') { + my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}"; + $cpp =~ s/sys\$input//i; + open(CPPO,"$cpp errno.c |") or + die "Cannot exec $Config{cppstdin}"; + } elsif ($^O eq 'MSWin32') { + open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or + die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'"; + } else { + my $cpp = default_cpp(); + open(CPPO,"$cpp < errno.c |") + or die "Cannot exec $cpp"; + } - %err = (); + %err = (); - while(<CPPO>) { - my($name,$expr); - next unless ($name, $expr) = /"(.*?)"\s*\[\s*\[\s*(.*?)\s*\]\s*\]/; - next if $name eq $expr; - $err{$name} = eval $expr; + while(<CPPO>) { + my($name,$expr); + next unless ($name, $expr) = /"(.*?)"\s*\[\s*\[\s*(.*?)\s*\]\s*\]/; + next if $name eq $expr; + $err{$name} = eval $expr; + } + close(CPPO); } - close(CPPO); # Write Errno.pm diff --git a/contrib/perl5/ext/Fcntl/Fcntl.xs b/contrib/perl5/ext/Fcntl/Fcntl.xs index b597e03c1a1b..51851bb6746b 100644 --- a/contrib/perl5/ext/Fcntl/Fcntl.xs +++ b/contrib/perl5/ext/Fcntl/Fcntl.xs @@ -33,13 +33,6 @@ --AD October 16, 1995 */ -static int -not_here(char *s) -{ - croak("%s not implemented on this architecture", s); - return -1; -} - static double constant(char *name, int arg) { diff --git a/contrib/perl5/ext/File/Glob/Changes b/contrib/perl5/ext/File/Glob/Changes index e246c6d6840f..f46ec704e9ad 100644 --- a/contrib/perl5/ext/File/Glob/Changes +++ b/contrib/perl5/ext/File/Glob/Changes @@ -45,3 +45,5 @@ Revision history for Perl extension File::Glob - Add support for either \ or / as separators on DOSISH systems - Limit effect of \ as a quoting operator on DOSISH systems to when it precedes one of []{}-~\ (to minimise backslashitis). +0.992 Tue Mar 20 09:25:48 2001 + - Add alphabetic sorting for csh compatibility (GLOB_ALPHASORT) diff --git a/contrib/perl5/ext/File/Glob/Glob.pm b/contrib/perl5/ext/File/Glob/Glob.pm index 4b7e54b9e3ea..20b26f9661f2 100644 --- a/contrib/perl5/ext/File/Glob/Glob.pm +++ b/contrib/perl5/ext/File/Glob/Glob.pm @@ -11,10 +11,15 @@ require AutoLoader; @ISA = qw(Exporter AutoLoader); +# NOTE: The glob() export is only here for compatibility with 5.6.0. +# csh_glob() should not be used directly, unless you know what you're doing. + @EXPORT_OK = qw( csh_glob + bsd_glob glob GLOB_ABEND + GLOB_ALPHASORT GLOB_ALTDIRFUNC GLOB_BRACE GLOB_CSH @@ -33,6 +38,7 @@ require AutoLoader; %EXPORT_TAGS = ( 'glob' => [ qw( GLOB_ABEND + GLOB_ALPHASORT GLOB_ALTDIRFUNC GLOB_BRACE GLOB_CSH @@ -47,6 +53,7 @@ require AutoLoader; GLOB_QUOTE GLOB_TILDE glob + bsd_glob ) ], ); @@ -99,7 +106,13 @@ sub GLOB_ERROR { return constant('GLOB_ERROR', 0); } -sub GLOB_CSH () { GLOB_BRACE() | GLOB_NOMAGIC() | GLOB_QUOTE() | GLOB_TILDE() } +sub GLOB_CSH () { + GLOB_BRACE() + | GLOB_NOMAGIC() + | GLOB_QUOTE() + | GLOB_TILDE() + | GLOB_ALPHASORT() +} $DEFAULT_FLAGS = GLOB_CSH(); if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos|MacOS)$/) { @@ -108,12 +121,18 @@ if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos|MacOS)$/) { # Autoload methods go after =cut, and are processed by the autosplit program. -sub glob { +sub bsd_glob { my ($pat,$flags) = @_; $flags = $DEFAULT_FLAGS if @_ < 2; return doglob($pat,$flags); } +# File::Glob::glob() is deprecated because its prototype is different from +# CORE::glob() (use bsd_glob() instead) +sub glob { + goto &bsd_glob; +} + ## borrowed heavily from gsar's File::DosGlob my %iter; my %entries; @@ -127,6 +146,9 @@ sub csh_glob { $pat = $_ unless defined $pat; # extract patterns + $pat =~ s/^\s+//; # Protect against empty elements in + $pat =~ s/\s+$//; # things like < *.c> and <*.c >. + # These alone shouldn't trigger ParseWords. if ($pat =~ /\s/) { # XXX this is needed for compatibility with the csh # implementation in Perl. Need to support a flag @@ -177,13 +199,13 @@ File::Glob - Perl extension for BSD glob routine =head1 SYNOPSIS use File::Glob ':glob'; - @list = glob('*.[ch]'); - $homedir = glob('~gnat', GLOB_TILDE | GLOB_ERR); + @list = bsd_glob('*.[ch]'); + $homedir = bsd_glob('~gnat', GLOB_TILDE | GLOB_ERR); if (GLOB_ERROR) { # an error occurred reading $homedir } - ## override the core glob (core glob() does this automatically + ## override the core glob (CORE::glob() does this automatically ## by default anyway, since v5.6.0) use File::Glob ':globally'; my @sources = <*.{c,h,y}> @@ -198,19 +220,27 @@ File::Glob - Perl extension for BSD glob routine =head1 DESCRIPTION -File::Glob implements the FreeBSD glob(3) routine, which is a superset -of the POSIX glob() (described in IEEE Std 1003.2 "POSIX.2"). The -glob() routine takes a mandatory C<pattern> argument, and an optional +File::Glob::bsd_glob() implements the FreeBSD glob(3) routine, which is +a superset of the POSIX glob() (described in IEEE Std 1003.2 "POSIX.2"). +bsd_glob() takes a mandatory C<pattern> argument, and an optional C<flags> argument, and returns a list of filenames matching the pattern, with interpretation of the pattern modified by the C<flags> -variable. The POSIX defined flags are: +variable. + +Since v5.6.0, Perl's CORE::glob() is implemented in terms of bsd_glob(). +Note that they don't share the same prototype--CORE::glob() only accepts +a single argument. Due to historical reasons, CORE::glob() will also +split its argument on whitespace, treating it as multiple patterns, +whereas bsd_glob() considers them as one pattern. + +The POSIX defined flags for bsd_glob() are: =over 4 =item C<GLOB_ERR> -Force glob() to return an error when it encounters a directory it -cannot open or read. Ordinarily glob() continues to find matches. +Force bsd_glob() to return an error when it encounters a directory it +cannot open or read. Ordinarily bsd_glob() continues to find matches. =item C<GLOB_MARK> @@ -220,18 +250,18 @@ appended. =item C<GLOB_NOCASE> By default, file names are assumed to be case sensitive; this flag -makes glob() treat case differences as not significant. +makes bsd_glob() treat case differences as not significant. =item C<GLOB_NOCHECK> -If the pattern does not match any pathname, then glob() returns a list +If the pattern does not match any pathname, then bsd_glob() returns a list consisting of only the pattern. If C<GLOB_QUOTE> is set, its effect is present in the pattern returned. =item C<GLOB_NOSORT> By default, the pathnames are sorted in ascending ASCII order; this -flag prevents that sorting (speeding up glob()). +flag prevents that sorting (speeding up bsd_glob()). =back @@ -266,7 +296,7 @@ Expand patterns that start with '~' to user name home directories. =item C<GLOB_CSH> For convenience, C<GLOB_CSH> is a synonym for -C<GLOB_BRACE | GLOB_NOMAGIC | GLOB_QUOTE | GLOB_TILDE>. +C<GLOB_BRACE | GLOB_NOMAGIC | GLOB_QUOTE | GLOB_TILDE | GLOB_ALPHASORT>. =back @@ -275,9 +305,21 @@ extensions C<GLOB_ALTDIRFUNC>, and C<GLOB_MAGCHAR> flags have not been implemented in the Perl version because they involve more complex interaction with the underlying C structures. +The following flag has been added in the Perl implementation for +compatibility with common flavors of csh: + +=over 4 + +=item C<GLOB_ALPHASORT> + +If C<GLOB_NOSORT> is not in effect, sort filenames is alphabetical +order (case does not matter) rather than in ASCII order. + +=back + =head1 DIAGNOSTICS -glob() returns a list of matching paths, possibly zero length. If an +bsd_glob() returns a list of matching paths, possibly zero length. If an error occurred, &File::Glob::GLOB_ERROR will be non-zero and C<$!> will be set. &File::Glob::GLOB_ERROR is guaranteed to be zero if no error occurred, or one of the following values otherwise: @@ -294,12 +336,12 @@ The glob was stopped because an error was encountered. =back -In the case where glob() has found some matching paths, but is -interrupted by an error, glob() will return a list of filenames B<and> +In the case where bsd_glob() has found some matching paths, but is +interrupted by an error, it will return a list of filenames B<and> set &File::Glob::ERROR. -Note that glob() deviates from POSIX and FreeBSD glob(3) behaviour by -not considering C<ENOENT> and C<ENOTDIR> as errors - glob() will +Note that bsd_glob() deviates from POSIX and FreeBSD glob(3) behaviour +by not considering C<ENOENT> and C<ENOTDIR> as errors - bsd_glob() will continue processing despite those errors, unless the C<GLOB_ERR> flag is set. @@ -311,10 +353,10 @@ Be aware that all filenames returned from File::Glob are tainted. =item * -If you want to use multiple patterns, e.g. C<glob "a* b*">, you should -probably throw them in a set as in C<glob "{a*,b*}>. This is because -the argument to glob isn't subjected to parsing by the C shell. Remember -that you can use a backslash to escape things. +If you want to use multiple patterns, e.g. C<bsd_glob "a* b*">, you should +probably throw them in a set as in C<bsd_glob "{a*,b*}">. This is because +the argument to bsd_glob() isn't subjected to parsing by the C shell. +Remember that you can use a backslash to escape things. =item * @@ -334,14 +376,32 @@ Win32 users should use the real slash. If you really want to use backslashes, consider using Sarathy's File::DosGlob, which comes with the standard Perl distribution. +=item * + +Mac OS (Classic) users should note a few differences. Since +Mac OS is not Unix, when the glob code encounters a tilde glob (e.g. +~user/foo) and the C<GLOB_TILDE> flag is used, it simply returns that +pattern without doing any expansion. + +Glob on Mac OS is case-insensitive by default (if you don't use any +flags). If you specify any flags at all and still want glob +to be case-insensitive, you must include C<GLOB_NOCASE> in the flags. + +The path separator is ':' (aka colon), not '/' (aka slash). Mac OS users +should be careful about specifying relative pathnames. While a full path +always begins with a volume name, a relative pathname should always +begin with a ':'. If specifying a volume name only, a trailing ':' is +required. + =back =head1 AUTHOR The Perl interface was written by Nathan Torkington E<lt>gnat@frii.comE<gt>, and is released under the artistic license. Further modifications were -made by Greg Bacon E<lt>gbacon@cs.uah.eduE<gt> and Gurusamy Sarathy -E<lt>gsar@activestate.comE<gt>. The C glob code has the +made by Greg Bacon E<lt>gbacon@cs.uah.eduE<gt>, Gurusamy Sarathy +E<lt>gsar@activestate.comE<gt>, and Thomas Wegner +E<lt>wegner_thomas@yahoo.comE<gt>. The C glob code has the following copyright: Copyright (c) 1989, 1993 The Regents of the University of California. diff --git a/contrib/perl5/ext/File/Glob/Glob.xs b/contrib/perl5/ext/File/Glob/Glob.xs index e01ae7e85a94..ee8c0c9751fc 100644 --- a/contrib/perl5/ext/File/Glob/Glob.xs +++ b/contrib/perl5/ext/File/Glob/Glob.xs @@ -4,16 +4,9 @@ #include "bsd_glob.h" +/* XXX: need some thread awareness */ static int GLOB_ERROR = 0; -static int -not_here(char *s) -{ - croak("%s not implemented on this architecture", s); - return -1; -} - - static double constant(char *name, int arg) { @@ -28,6 +21,12 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "GLOB_ALPHASORT")) +#ifdef GLOB_ALPHASORT + return GLOB_ALPHASORT; +#else + goto not_there; +#endif if (strEQ(name, "GLOB_ALTDIRFUNC")) #ifdef GLOB_ALTDIRFUNC return GLOB_ALTDIRFUNC; diff --git a/contrib/perl5/ext/File/Glob/bsd_glob.c b/contrib/perl5/ext/File/Glob/bsd_glob.c index 62bfe4f80c8a..15ee659c8584 100644 --- a/contrib/perl5/ext/File/Glob/bsd_glob.c +++ b/contrib/perl5/ext/File/Glob/bsd_glob.c @@ -57,6 +57,9 @@ static char sccsid[] = "@(#)glob.c 8.3 (Berkeley) 10/13/93"; * expand {1,2}{a,b} to 1a 1b 2a 2b * gl_matchc: * Number of matches in the current invocation of glob. + * GLOB_ALPHASORT: + * sort alphabetically like csh (case doesn't matter) instead of in ASCII + * order */ #include <EXTERN.h> @@ -76,8 +79,11 @@ static char sccsid[] = "@(#)glob.c 8.3 (Berkeley) 10/13/93"; #ifndef MAXPATHLEN # ifdef PATH_MAX # define MAXPATHLEN PATH_MAX -# else -# define MAXPATHLEN 1024 +# ifdef MACOS_TRADITIONAL +# define MAXPATHLEN 255 +# else +# define MAXPATHLEN 1024 +# endif # endif #endif @@ -90,7 +96,11 @@ static char sccsid[] = "@(#)glob.c 8.3 (Berkeley) 10/13/93"; #define BG_QUOTE '\\' #define BG_RANGE '-' #define BG_RBRACKET ']' -#define BG_SEP '/' +#ifdef MACOS_TRADITIONAL +# define BG_SEP ':' +#else +# define BG_SEP '/' +#endif #ifdef DOSISH #define BG_SEP2 '\\' #endif @@ -448,6 +458,12 @@ glob0(const Char *pattern, glob_t *pglob) int c, err, oldflags, oldpathc; Char *bufnext, patbuf[MAXPATHLEN+1]; +#ifdef MACOS_TRADITIONAL + if ( (*pattern == BG_TILDE) && (pglob->gl_flags & GLOB_TILDE) ) { + return(globextend(pattern, pglob)); + } +#endif + qpat = globtilde(pattern, patbuf, pglob); qpatnext = qpat; oldflags = pglob->gl_flags; @@ -531,7 +547,8 @@ glob0(const Char *pattern, glob_t *pglob) else if (!(pglob->gl_flags & GLOB_NOSORT)) qsort(pglob->gl_pathv + pglob->gl_offs + oldpathc, pglob->gl_pathc - oldpathc, sizeof(char *), - (pglob->gl_flags & GLOB_NOCASE) ? ci_compare : compare); + (pglob->gl_flags & (GLOB_ALPHASORT|GLOB_NOCASE)) + ? ci_compare : compare); pglob->gl_flags = oldflags; return(0); } @@ -541,13 +558,17 @@ ci_compare(const void *p, const void *q) { const char *pp = *(const char **)p; const char *qq = *(const char **)q; + int ci; while (*pp && *qq) { if (tolower(*pp) != tolower(*qq)) break; ++pp; ++qq; } - return (tolower(*pp) - tolower(*qq)); + ci = tolower(*pp) - tolower(*qq); + if (ci == 0) + return compare(p, q); + return ci; } static int @@ -653,7 +674,7 @@ glob3(Char *pathbuf, Char *pathend, Char *pattern, * and dirent.h as taking pointers to differently typed opaque * structures. */ - Direntry_t *(*readdirfunc)(); + Direntry_t *(*readdirfunc)(DIR*); *pathend = BG_EOS; errno = 0; @@ -689,7 +710,7 @@ glob3(Char *pathbuf, Char *pathend, Char *pattern, /* Search directory for matching names. */ if (pglob->gl_flags & GLOB_ALTDIRFUNC) - readdirfunc = pglob->gl_readdir; + readdirfunc = (Direntry_t *(*)(DIR *))pglob->gl_readdir; else readdirfunc = my_readdir; while ((dp = (*readdirfunc)(dirp))) { @@ -853,10 +874,15 @@ g_opendir(register Char *str, glob_t *pglob) { char buf[MAXPATHLEN]; - if (!*str) + if (!*str) { +#ifdef MACOS_TRADITIONAL + strcpy(buf, ":"); +#else strcpy(buf, "."); - else +#endif + } else { g_Ctoc(str, buf); + } if (pglob->gl_flags & GLOB_ALTDIRFUNC) return((*pglob->gl_opendir)(buf)); diff --git a/contrib/perl5/ext/File/Glob/bsd_glob.h b/contrib/perl5/ext/File/Glob/bsd_glob.h index 10d1de534c64..5d04fff1c341 100644 --- a/contrib/perl5/ext/File/Glob/bsd_glob.h +++ b/contrib/perl5/ext/File/Glob/bsd_glob.h @@ -72,6 +72,7 @@ typedef struct { #define GLOB_QUOTE 0x0400 /* Quote special chars with \. */ #define GLOB_TILDE 0x0800 /* Expand tilde names from the passwd file. */ #define GLOB_NOCASE 0x1000 /* Treat filenames without regard for case. */ +#define GLOB_ALPHASORT 0x2000 /* Alphabetic, not ASCII sort, like csh. */ #define GLOB_NOSPACE (-1) /* Malloc call failed. */ #define GLOB_ABEND (-2) /* Unignored error. */ diff --git a/contrib/perl5/ext/GDBM_File/GDBM_File.pm b/contrib/perl5/ext/GDBM_File/GDBM_File.pm index ab866eecabed..310243c736e8 100644 --- a/contrib/perl5/ext/GDBM_File/GDBM_File.pm +++ b/contrib/perl5/ext/GDBM_File/GDBM_File.pm @@ -40,6 +40,7 @@ L<perl(1)>, L<DB_File(3)>, L<perldbmfilter>. package GDBM_File; use strict; +use warnings; our($VERSION, @ISA, @EXPORT, $AUTOLOAD); require Carp; @@ -53,13 +54,14 @@ use XSLoader (); GDBM_FAST GDBM_INSERT GDBM_NEWDB + GDBM_NOLOCK GDBM_READER GDBM_REPLACE GDBM_WRCREAT GDBM_WRITER ); -$VERSION = "1.03"; +$VERSION = "1.05"; sub AUTOLOAD { my($constname); diff --git a/contrib/perl5/ext/GDBM_File/GDBM_File.xs b/contrib/perl5/ext/GDBM_File/GDBM_File.xs index 870f056c9bf0..5e426f90f32d 100644 --- a/contrib/perl5/ext/GDBM_File/GDBM_File.xs +++ b/contrib/perl5/ext/GDBM_File/GDBM_File.xs @@ -42,12 +42,14 @@ typedef datum datum_value ; typedef void (*FATALFUNC)(); +#ifndef GDBM_FAST static int not_here(char *s) { croak("GDBM_File::%s not implemented on this architecture", s); return -1; } +#endif /* GDBM allocates the datum with system malloc() and expects the user * to free() it. So we either have to free() it immediately, or have @@ -56,7 +58,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)) +#if !defined(MYMALLOC) || (defined(MYMALLOC) && defined(PERL_POLLUTE_MALLOC) && !defined(LEAKTEST)) sv_usepvn(arg, str, size); #else sv_setpvn(arg, str, size); @@ -122,6 +124,12 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "GDBM_NOLOCK")) +#ifdef GDBM_NOLOCK + return GDBM_NOLOCK; +#else + goto not_there; +#endif if (strEQ(name, "GDBM_READER")) #ifdef GDBM_READER return GDBM_READER; @@ -214,7 +222,7 @@ gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak) GDBM_FILE dbp ; RETVAL = NULL ; - if (dbp = gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func)) { + if ((dbp = gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func))) { RETVAL = (GDBM_File)safemalloc(sizeof(GDBM_File_type)) ; Zero(RETVAL, 1, GDBM_File_type) ; RETVAL->dbp = dbp ; diff --git a/contrib/perl5/ext/GDBM_File/typemap b/contrib/perl5/ext/GDBM_File/typemap index 4f79ae3e32a5..1dd063003ab6 100644 --- a/contrib/perl5/ext/GDBM_File/typemap +++ b/contrib/perl5/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/contrib/perl5/ext/IO/IO.xs b/contrib/perl5/ext/IO/IO.xs index 1b79cfd4c093..38acf4114843 100644 --- a/contrib/perl5/ext/IO/IO.xs +++ b/contrib/perl5/ext/IO/IO.xs @@ -136,18 +136,23 @@ io_blocking(InputStream f, int block) MODULE = IO PACKAGE = IO::Seekable PREFIX = f -SV * +void fgetpos(handle) InputStream handle CODE: if (handle) { Fpos_t pos; + if ( #ifdef PerlIO - PerlIO_getpos(handle, &pos); + PerlIO_getpos(handle, &pos) #else - fgetpos(handle, &pos); + fgetpos(handle, &pos) #endif - ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); + ) { + ST(0) = &PL_sv_undef; + } else { + ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); + } } else { ST(0) = &PL_sv_undef; @@ -176,7 +181,7 @@ fsetpos(handle, pos) MODULE = IO PACKAGE = IO::File PREFIX = f -SV * +void new_tmpfile(packname = "IO::File") char * packname PREINIT: diff --git a/contrib/perl5/ext/IO/lib/IO/Handle.pm b/contrib/perl5/ext/IO/lib/IO/Handle.pm index 930df55fec8b..fb754a60bfae 100644 --- a/contrib/perl5/ext/IO/lib/IO/Handle.pm +++ b/contrib/perl5/ext/IO/lib/IO/Handle.pm @@ -71,7 +71,7 @@ corresponding built-in functions: $io->printf ( FMT, [ARGS] ) $io->stat $io->sysread ( BUF, LEN, [OFFSET] ) - $io->syswrite ( BUF, LEN, [OFFSET] ) + $io->syswrite ( BUF, [LEN, [OFFSET]] ) $io->truncate ( LEN ) See L<perlvar> for complete descriptions of each of the following @@ -110,18 +110,19 @@ 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 This works like <$io> described in L<perlop/"I/O Operators"> -except that it's more readable and can be safely called in an -array context but still returns just one line. +except that it's more readable and can be safely called in a +list context but still returns just one line. =item $io->getlines -This works like <$io> when called in an array context to -read all the remaining lines in a file, except that it's more readable. +This works like <$io> when called in a list context to read all +the remaining lines in a file, except that it's more readable. It will also croak() if accidentally called in a scalar context. =item $io->ungetc ( ORD ) @@ -139,31 +140,37 @@ called C<format_write>. =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<clearerr>. +since it was opened or since the last call to C<clearerr>, 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<sync> synchronizes a file's in-memory state with that on the physical medium. C<sync> 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<sync> -is not implemented on all platforms. See L<fsync(3c)>. +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<sync> is not implemented on all +platforms. Returns "0 but true" on success, C<undef> on error, C<undef> +for an invalid handle. See L<fsync(3c)>. =item $io->flush C<flush> 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<undef> on error. =item $io->printflush ( ARGS ) Turns on autoflush, print ARGS and then restores the autoflush status of the -C<IO::Handle> object. +C<IO::Handle> object. Returns the return value from print. =item $io->blocking ( [ BOOL ] ) @@ -183,11 +190,18 @@ C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> 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<setbuf> or C<setvbuf> must not be modified in any -way until the IO::Handle is closed or C<setbuf> or C<setvbuf> 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<setbuf> or C<setvbuf> B<must not +be modified> in any way until the IO::Handle is closed or C<setbuf> or +C<setvbuf> 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<undef> 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 @@ -425,8 +440,11 @@ sub write { sub syswrite { @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])'; - $_[2] = length($_[1]) unless defined $_[2]; - syswrite($_[0], $_[1], $_[2], $_[3] || 0); + if (defined($_[2])) { + syswrite($_[0], $_[1], $_[2], $_[3] || 0); + } else { + syswrite($_[0], $_[1]); + } } sub stat { diff --git a/contrib/perl5/ext/IO/lib/IO/Poll.pm b/contrib/perl5/ext/IO/lib/IO/Poll.pm index 687664b9abfa..70a3469edbb2 100644 --- a/contrib/perl5/ext/IO/lib/IO/Poll.pm +++ b/contrib/perl5/ext/IO/lib/IO/Poll.pm @@ -1,3 +1,4 @@ + # IO::Poll.pm # # Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. @@ -12,28 +13,31 @@ use Exporter (); our(@ISA, @EXPORT_OK, @EXPORT, $VERSION); @ISA = qw(Exporter); -$VERSION = "0.01"; +$VERSION = "0.05"; -@EXPORT = qw(poll); +@EXPORT = qw( POLLIN + POLLOUT + POLLERR + POLLHUP + POLLNVAL + ); @EXPORT_OK = qw( - POLLIN POLLPRI - POLLOUT POLLRDNORM POLLWRNORM POLLRDBAND POLLWRBAND POLLNORM - POLLERR - POLLHUP - POLLNVAL -); + ); +# [0] maps fd's to requested masks +# [1] maps fd's to returned masks +# [2] maps fd's to handles sub new { my $class = shift; - my $self = bless [{},{}], $class; + my $self = bless [{},{},{}], $class; $self; } @@ -42,20 +46,21 @@ sub mask { my $self = shift; my $io = shift; my $fd = fileno($io); - if(@_) { + if (@_) { my $mask = shift; - $self->[0]{$fd} ||= {}; if($mask) { - $self->[0]{$fd}{$io} = $mask; - } - else { + $self->[0]{$fd}{$io} = $mask; # the error events are always returned + $self->[1]{$fd} = 0; # output mask + $self->[2]{$io} = $io; # remember handle + } else { delete $self->[0]{$fd}{$io}; + delete $self->[1]{$fd} unless %{$self->[0]{$fd}}; + delete $self->[2]{$io}; } } - elsif(exists $self->[0]{$fd}{$io}) { + + return unless exists $self->[0]{$fd} and exists $self->[0]{$fd}{$io}; return $self->[0]{$fd}{$io}; - } - return; } @@ -64,13 +69,13 @@ sub poll { $self->[1] = {}; - my($fd,$ref); + my($fd,$mask,$iom); my @poll = (); - while(($fd,$ref) = each %{$self->[0]}) { - my $events = 0; - map { $events |= $_ } values %{$ref}; - push(@poll,$fd, $events); + while(($fd,$iom) = each %{$self->[0]}) { + $mask = 0; + $mask |= $_ for values(%$iom); + push(@poll,$fd => $mask); } my $ret = @poll ? _poll(defined($timeout) ? $timeout * 1000 : -1,@poll) : 0; @@ -80,8 +85,7 @@ sub poll { while(@poll) { my($fd,$got) = splice(@poll,0,2); - $self->[1]{$fd} = $got - if $got; + $self->[1]{$fd} = $got if $got; } return $ret; @@ -91,9 +95,8 @@ sub events { my $self = shift; my $io = shift; my $fd = fileno($io); - - exists $self->[1]{$fd} && exists $self->[0]{$fd}{$io} - ? $self->[1]{$fd} & $self->[0]{$fd}{$io} + exists $self->[1]{$fd} and exists $self->[0]{$fd}{$io} + ? $self->[1]{$fd} & ($self->[0]{$fd}{$io}|POLLHUP|POLLERR|POLLNVAL) : 0; } @@ -105,20 +108,16 @@ sub remove { sub handles { my $self = shift; - - return map { keys %$_ } values %{$self->[0]} - unless(@_); + return values %{$self->[2]} unless @_; my $events = shift || 0; my($fd,$ev,$io,$mask); my @handles = (); while(($fd,$ev) = each %{$self->[1]}) { - if($ev & $events) { - while(($io,$mask) = each %{$self->[0][$fd]}) { - push(@handles, $io) - if $events & $mask; - } + while (($io,$mask) = each %{$self->[0]{$fd}}) { + $mask |= POLLHUP|POLLERR|POLLNVAL; # must allow these + push @handles,$self->[2]{$io} if ($ev & $mask) & $events; } } return @handles; @@ -138,8 +137,8 @@ IO::Poll - Object interface to system poll call $poll = new IO::Poll; - $poll->mask($input_handle => POLLRDNORM | POLLIN | POLLHUP); - $poll->mask($output_handle => POLLWRNORM); + $poll->mask($input_handle => POLLIN); + $poll->mask($output_handle => POLLOUT); $poll->poll($timeout); diff --git a/contrib/perl5/ext/IO/lib/IO/Seekable.pm b/contrib/perl5/ext/IO/lib/IO/Seekable.pm index e09d48b9bff8..243a971acccc 100644 --- a/contrib/perl5/ext/IO/lib/IO/Seekable.pm +++ b/contrib/perl5/ext/IO/lib/IO/Seekable.pm @@ -18,19 +18,69 @@ C<IO::Seekable> does not have a constructor of its own as it is intended to be inherited by other C<IO::Handle> based objects. It provides methods which allow seeking of the file descriptors. -If the C functions fgetpos() and fsetpos() are available, then -C<$io-E<lt>getpos> returns an opaque value that represents the -current position of the IO::File, and C<$io-E<gt>setpos(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<undef> 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<undef> on failure. + +=back + See L<perlfunc> for complete descriptions of each of the following supported C<IO::Seekable> 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<Fcntl> 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<perlfunc> for full details) + +Returns the new position, or C<undef> 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<perlfunc>, diff --git a/contrib/perl5/ext/IO/lib/IO/Select.pm b/contrib/perl5/ext/IO/lib/IO/Select.pm index df92b04b74f3..1a3a26fe6ae3 100644 --- a/contrib/perl5/ext/IO/lib/IO/Select.pm +++ b/contrib/perl5/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); } @@ -300,9 +301,9 @@ Return an array of all registered handles. =item can_read ( [ TIMEOUT ] ) Return an array of handles that are ready for reading. C<TIMEOUT> is -the maximum amount of time to wait before returning an empty list. If -C<TIMEOUT> is not given and any handles are registered then the call -will block. +the maximum amount of time to wait before returning an empty list, in +seconds, possibly fractional. If C<TIMEOUT> is not given and any +handles are registered then the call will block. =item can_write ( [ TIMEOUT ] ) diff --git a/contrib/perl5/ext/IO/lib/IO/Socket.pm b/contrib/perl5/ext/IO/lib/IO/Socket.pm index 6884f02cf868..b8da0926692d 100644 --- a/contrib/perl5/ext/IO/lib/IO/Socket.pm +++ b/contrib/perl5/ext/IO/lib/IO/Socket.pm @@ -361,7 +361,7 @@ perform the system call C<accept> on the socket and return a new object. The new object will be created in the same class as the listen socket, unless C<PKG> is specified. This object can be used to communicate with the client that was trying to connect. In a scalar context the new socket is returned, -or undef upon failure. In an array context a two-element array is returned +or undef upon failure. In a list context a two-element array is returned containing the new socket and the peer address; the list will be empty upon failure. diff --git a/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm b/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm index 27a3d4d847ee..d2cc488dd2d8 100644 --- a/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm +++ b/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm @@ -34,6 +34,7 @@ sub new { sub _sock_info { my($addr,$port,$proto) = @_; + my $origport = $port; my @proto = (); my @serv = (); @@ -59,14 +60,14 @@ sub _sock_info { my $defport = $1 || undef; my $pnum = ($port =~ m,^(\d+)$,)[0]; - if ($port =~ m,\D,) { - unless (@serv = getservbyname($port, $proto[0] || "")) { - $@ = "Bad service '$port'"; - return; - } - } + @serv = getservbyname($port, $proto[0] || "") + if ($port =~ m,\D,); $port = $pnum || $serv[2] || $defport || undef; + unless (defined $port) { + $@ = "Bad service '$origport'"; + return; + } $proto = (getprotobyname($serv[3]))[2] || undef if @serv && !$proto; @@ -150,11 +151,16 @@ sub configure { $sock->socket(AF_INET, $type, $proto) or return _error($sock, $!, "$!"); - if ($arg->{Reuse}) { + if ($arg->{Reuse} || $arg->{ReuseAddr}) { $sock->sockopt(SO_REUSEADDR,1) or return _error($sock, $!, "$!"); } + if ($arg->{ReusePort}) { + $sock->sockopt(SO_REUSEPORT,1) or + return _error($sock, $!, "$!"); + } + if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) { $sock->bind($lport || 0, $laddr) or return _error($sock, $!, "$!"); @@ -301,7 +307,9 @@ C<IO::Socket::INET> provides. Proto Protocol name (or number) "tcp" | "udp" | ... Type Socket type SOCK_STREAM | SOCK_DGRAM | ... Listen Queue size for listen - Reuse Set SO_REUSEADDR before binding + ReuseAddr Set SO_REUSEADDR before binding + Reuse Set SO_REUSEADDR before binding (deprecated, prefer ReuseAddr) + ReusePort Set SO_REUSEPORT before binding Timeout Timeout value for various operations MultiHomed Try all adresses for multi-homed hosts diff --git a/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm b/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm index d083f48b78f7..2a11752d027a 100644 --- a/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm +++ b/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm @@ -37,7 +37,7 @@ sub configure { $sock->bind($addr) or return undef; } - if(exists $arg->{Listen}) { + if(exists $arg->{Listen} && $type != SOCK_DGRAM) { $sock->listen($arg->{Listen} || 5) or return undef; } diff --git a/contrib/perl5/ext/IPC/SysV/Makefile.PL b/contrib/perl5/ext/IPC/SysV/Makefile.PL index 60dd74d9a9c4..f994950d195a 100644 --- a/contrib/perl5/ext/IPC/SysV/Makefile.PL +++ b/contrib/perl5/ext/IPC/SysV/Makefile.PL @@ -31,7 +31,7 @@ WriteMakefile( 'clean' => {FILES => join(" ", map { "$_ */$_ */*/$_" } - qw(*% *.html *.b[ac]k *.old *.orig)) + qw(*% *.html *.b[ac]k *.old)) }, 'macro' => { INSTALLDIRS => 'perl' }, ); diff --git a/contrib/perl5/ext/IPC/SysV/SysV.xs b/contrib/perl5/ext/IPC/SysV/SysV.xs index 38062e028b5e..c7985f99fe3e 100644 --- a/contrib/perl5/ext/IPC/SysV/SysV.xs +++ b/contrib/perl5/ext/IPC/SysV/SysV.xs @@ -194,7 +194,7 @@ PPCODE: MODULE=IPC::SysV PACKAGE=IPC::SysV -int +void ftok(path, id) char * path int id @@ -203,10 +203,10 @@ 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 +void SHMLBA() CODE: #ifdef SHMLBA @@ -436,7 +436,7 @@ BOOT: char *name; int i; - for(i = 0 ; name = IPC__SysV__const[i].n ; i++) { + for(i = 0 ; (name = IPC__SysV__const[i].n) ; i++) { newCONSTSUB(stash,name, newSViv(IPC__SysV__const[i].v)); } } diff --git a/contrib/perl5/ext/NDBM_File/Makefile.PL b/contrib/perl5/ext/NDBM_File/Makefile.PL index 6ceab55a4aed..7b586017d7d4 100644 --- a/contrib/perl5/ext/NDBM_File/Makefile.PL +++ b/contrib/perl5/ext/NDBM_File/Makefile.PL @@ -5,4 +5,5 @@ WriteMakefile( MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'NDBM_File.pm', + INC => ($^O eq "MacOS" ? "-i ::::db:include" : "") ); diff --git a/contrib/perl5/ext/NDBM_File/NDBM_File.pm b/contrib/perl5/ext/NDBM_File/NDBM_File.pm index f98669f4860d..b2804597a14e 100644 --- a/contrib/perl5/ext/NDBM_File/NDBM_File.pm +++ b/contrib/perl5/ext/NDBM_File/NDBM_File.pm @@ -1,16 +1,13 @@ package NDBM_File; -BEGIN { - if ($] >= 5.002) { - use strict; - } -} +use strict; +use warnings; require Tie::Hash; use XSLoader (); our @ISA = qw(Tie::Hash); -our $VERSION = "1.03"; +our $VERSION = "1.04"; XSLoader::load 'NDBM_File', $VERSION; @@ -24,15 +21,93 @@ NDBM_File - Tied access to ndbm files =head1 SYNOPSIS - use NDBM_File; - use Fcntl; # for O_ constants + use Fcntl; # For O_RDWR, O_CREAT, etc. + use NDBM_File; - tie(%h, 'NDBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640); + # Now read and change the hash + $h{newkey} = newvalue; + print $h{oldkey}; + ... + + untie %h; + +=head1 DESCRIPTION + +C<NDBM_File> establishes a connection between a Perl hash variable and +a file in NDBM_File format;. You can manipulate the data in the file +just as if it were in a Perl hash, but when your program exits, the +data will remain in the file, to be used the next time your program +runs. - untie %h; +Use C<NDBM_File> with the Perl built-in C<tie> function to establish +the connection between the variable and the file. The arguments to +C<tie> should be: -=head1 DESCRIPTION +=over 4 + +=item 1. + +The hash variable you want to tie. + +=item 2. + +The string C<"NDBM_File">. (Ths tells Perl to use the C<NDBM_File> +package to perform the functions of the hash.) + +=item 3. + +The name of the file you want to tie to the hash. + +=item 4. + +Flags. Use one of: + +=over 2 + +=item C<O_RDONLY> + +Read-only access to the data in the file. + +=item C<O_WRONLY> + +Write-only access to the data in the file. + +=item C<O_RDWR> + +Both read and write access. + +=back + +If you want to create the file if it does not exist, add C<O_CREAT> to +any of these, as in the example. If you omit C<O_CREAT> and the file +does not already exist, the C<tie> call will fail. + +=item 5. + +The default permissions to use if a new file is created. The actual +permissions will be modified by the user's umask, so you should +probably use 0666 here. (See L<perlfunc/umask>.) + +=back + +=head1 DIAGNOSTICS + +On failure, the C<tie> call returns an undefined value and probably +sets C<$!> to contain the reason the file could not be tied. + +=head2 C<ndbm store returned -1, errno 22, key "..." at ...> + +This warning is emmitted when you try to store a key or a value that +is too long. It means that the change was not recorded in the +database. See BUGS AND WARNINGS below. + +=head1 BUGS AND WARNINGS + +There are a number of limits on the size of the data that you can +store in the NDBM file. The most important is that the length of a +key, plus the length of its associated value, may not exceed 1008 +bytes. -See L<perlfunc/tie>, L<perldbmfilter> +See L<perlfunc/tie>, L<perldbmfilter>, L<Fcntl> =cut diff --git a/contrib/perl5/ext/NDBM_File/NDBM_File.xs b/contrib/perl5/ext/NDBM_File/NDBM_File.xs index 49a1db5e5657..c417eb693e92 100644 --- a/contrib/perl5/ext/NDBM_File/NDBM_File.xs +++ b/contrib/perl5/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 <utx@penguin.cz> */ +#undef ENTER #include <ndbm.h> typedef struct { diff --git a/contrib/perl5/ext/NDBM_File/typemap b/contrib/perl5/ext/NDBM_File/typemap index eeb5d59027f5..40b95f22c022 100644 --- a/contrib/perl5/ext/NDBM_File/typemap +++ b/contrib/perl5/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/contrib/perl5/ext/ODBM_File/ODBM_File.pm b/contrib/perl5/ext/ODBM_File/ODBM_File.pm index 57fe4c352ddd..9e8e008e0243 100644 --- a/contrib/perl5/ext/ODBM_File/ODBM_File.pm +++ b/contrib/perl5/ext/ODBM_File/ODBM_File.pm @@ -1,12 +1,13 @@ package ODBM_File; use strict; +use warnings; require Tie::Hash; use XSLoader (); our @ISA = qw(Tie::Hash); -our $VERSION = "1.02"; +our $VERSION = "1.03"; XSLoader::load 'ODBM_File', $VERSION; @@ -20,14 +21,93 @@ ODBM_File - Tied access to odbm files =head1 SYNOPSIS + use Fcntl; # For O_RDWR, O_CREAT, etc. use ODBM_File; - tie(%h, 'ODBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640); + # Now read and change the hash + $h{newkey} = newvalue; + print $h{oldkey}; + ... + + untie %h; + +=head1 DESCRIPTION + +C<ODBM_File> establishes a connection between a Perl hash variable and +a file in ODBM_File format;. You can manipulate the data in the file +just as if it were in a Perl hash, but when your program exits, the +data will remain in the file, to be used the next time your program +runs. - untie %h; +Use C<ODBM_File> with the Perl built-in C<tie> function to establish +the connection between the variable and the file. The arguments to +C<tie> should be: -=head1 DESCRIPTION +=over 4 + +=item 1. + +The hash variable you want to tie. + +=item 2. + +The string C<"ODBM_File">. (Ths tells Perl to use the C<ODBM_File> +package to perform the functions of the hash.) + +=item 3. + +The name of the file you want to tie to the hash. + +=item 4. + +Flags. Use one of: + +=over 2 + +=item C<O_RDONLY> + +Read-only access to the data in the file. + +=item C<O_WRONLY> + +Write-only access to the data in the file. + +=item C<O_RDWR> + +Both read and write access. + +=back + +If you want to create the file if it does not exist, add C<O_CREAT> to +any of these, as in the example. If you omit C<O_CREAT> and the file +does not already exist, the C<tie> call will fail. + +=item 5. + +The default permissions to use if a new file is created. The actual +permissions will be modified by the user's umask, so you should +probably use 0666 here. (See L<perlfunc/umask>.) + +=back + +=head1 DIAGNOSTICS + +On failure, the C<tie> call returns an undefined value and probably +sets C<$!> to contain the reason the file could not be tied. + +=head2 C<odbm store returned -1, errno 22, key "..." at ...> + +This warning is emmitted when you try to store a key or a value that +is too long. It means that the change was not recorded in the +database. See BUGS AND WARNINGS below. + +=head1 BUGS AND WARNINGS + +There are a number of limits on the size of the data that you can +store in the ODBM file. The most important is that the length of a +key, plus the length of its associated value, may not exceed 1008 +bytes. -See L<perlfunc/tie>, L<perldbmfilter> +See L<perlfunc/tie>, L<perldbmfilter>, L<Fcntl> =cut diff --git a/contrib/perl5/ext/ODBM_File/ODBM_File.xs b/contrib/perl5/ext/ODBM_File/ODBM_File.xs index 150f2ef89475..27174ef062b7 100644 --- a/contrib/perl5/ext/ODBM_File/ODBM_File.xs +++ b/contrib/perl5/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 <utx@penguin.cz> */ +# undef ENTER # include <dbm.h> #else # ifdef I_RPCSVC_DBM diff --git a/contrib/perl5/ext/ODBM_File/typemap b/contrib/perl5/ext/ODBM_File/typemap index 7c23815ec75a..096427ea7f3a 100644 --- a/contrib/perl5/ext/ODBM_File/typemap +++ b/contrib/perl5/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/contrib/perl5/ext/Opcode/Opcode.pm b/contrib/perl5/ext/Opcode/Opcode.pm index 9338d392fae2..841120c4c63d 100644 --- a/contrib/perl5/ext/Opcode/Opcode.pm +++ b/contrib/perl5/ext/Opcode/Opcode.pm @@ -163,7 +163,7 @@ accumulated set of ops at that point. =item an operator set (opset) -An I<opset> as a binary string of approximately 43 bytes which holds a +An I<opset> as a binary string of approximately 44 bytes which holds a set or zero or more operators. The opset and opset_to_ops functions can be used to convert from @@ -185,7 +185,7 @@ tags and sets. All are available for export by the package. =item opcodes In a scalar context opcodes returns the number of opcodes in this -version of perl (around 340 for perl5.002). +version of perl (around 350 for perl-5.7.0). In a list context it returns a list of all the operator names. (Not yet implemented, use @names = opset_to_ops(full_opset).) diff --git a/contrib/perl5/ext/Opcode/Opcode.xs b/contrib/perl5/ext/Opcode/Opcode.xs index 581cbc94d939..cc4e1f45e17a 100644 --- a/contrib/perl5/ext/Opcode/Opcode.xs +++ b/contrib/perl5/ext/Opcode/Opcode.xs @@ -250,7 +250,7 @@ PPCODE: save_aptr(&PL_endav); PL_endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now */ - save_hptr(&PL_defstash); /* save current default stack */ + save_hptr(&PL_defstash); /* save current default stash */ /* the assignment to global defstash changes our sense of 'main' */ PL_defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already */ save_hptr(&PL_curstash); @@ -263,6 +263,11 @@ PPCODE: sv_free((SV*)GvHV(gv)); GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash); + /* %INC must be clean for use/require in compartment */ + save_hash(PL_incgv); + sv_free((SV*)GvHV(PL_incgv)); /* get rid of what save_hash gave us*/ + GvHV(PL_incgv) = (HV*)SvREFCNT_inc(GvHV(gv_HVadd(gv_fetchpv("INC",TRUE,SVt_PVHV)))); + PUSHMARK(SP); perl_call_sv(codesv, GIMME|G_EVAL|G_KEEPERR); /* use callers context */ SPAGAIN; /* for the PUTBACK added by xsubpp */ @@ -320,7 +325,7 @@ PPCODE: void opset(...) CODE: - int i, j; + int i; SV *bitspec, *opset; char *bitmap; STRLEN len, on; diff --git a/contrib/perl5/ext/POSIX/Makefile.PL b/contrib/perl5/ext/POSIX/Makefile.PL index 55c5c1fbf3f6..73bb02dddb54 100644 --- a/contrib/perl5/ext/POSIX/Makefile.PL +++ b/contrib/perl5/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/contrib/perl5/ext/POSIX/POSIX.pm b/contrib/perl5/ext/POSIX/POSIX.pm index 9416f70809ab..252e5bbad1cf 100644 --- a/contrib/perl5/ext/POSIX/POSIX.pm +++ b/contrib/perl5/ext/POSIX/POSIX.pm @@ -565,9 +565,9 @@ sub chmod { sub fstat { usage "fstat(fd)" if @_ != 1; local *TMP; - open(TMP, "<&$_[0]"); # Gross. + CORE::open(TMP, "<&$_[0]"); # Gross. my @l = CORE::stat(TMP); - close(TMP); + CORE::close(TMP); @l; } @@ -893,7 +893,7 @@ sub load_imports { difftime mktime strftime tzset tzname)], unistd_h => [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET - STRERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK + STDERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK _PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX _PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED diff --git a/contrib/perl5/ext/POSIX/POSIX.pod b/contrib/perl5/ext/POSIX/POSIX.pod index 08300e4337b6..49761358ca20 100644 --- a/contrib/perl5/ext/POSIX/POSIX.pod +++ b/contrib/perl5/ext/POSIX/POSIX.pod @@ -65,15 +65,19 @@ all. This could be construed to be a bug. =item _exit -This is identical to the C function C<_exit()>. +This is identical to the C function C<_exit()>. It exits the program +immediately which means among other things buffered I/O is B<not> flushed. =item abort -This is identical to the C function C<abort()>. +This is identical to the C function C<abort()>. It terminates the +process with a C<SIGABRT> signal unless caught by a signal handler or +if the handler does not return normally (it e.g. does a C<longjmp>). =item abs -This is identical to Perl's builtin C<abs()> function. +This is identical to Perl's builtin C<abs()> function, returning +the absolute value of its numerical argument. =item access @@ -83,83 +87,117 @@ Determines the accessibility of a file. print "have read permission\n"; } -Returns C<undef> on failure. +Returns C<undef> on failure. Note: do not use C<access()> for +security purposes. Between the C<access()> call and the operation +you are preparing for the permissions might change: a classic +I<race condition>. =item acos -This is identical to the C function C<acos()>. +This is identical to the C function C<acos()>, returning +the arcus cosine of its numerical argument. See also L<Math::Trig>. =item alarm -This is identical to Perl's builtin C<alarm()> function. +This is identical to Perl's builtin C<alarm()> function, +either for arming or disarming the C<SIGARLM> timer. =item asctime -This is identical to the C function C<asctime()>. +This is identical to the C function C<asctime()>. It returns +a string of the form + + "Fri Jun 2 18:22:13 2000\n\0" + +and it is called thusly + + $asctime = asctime($sec, $min, $hour, $mday, $mon, $year, + $wday, $yday, $isdst); + +The C<$mon> is zero-based: January equals C<0>. The C<$year> is +1900-based: 2001 equals C<101>. The C<$wday>, C<$yday>, and C<$isdst> +default to zero (and the first two are usually ignored anyway). =item asin -This is identical to the C function C<asin()>. +This is identical to the C function C<asin()>, returning +the arcus sine of its numerical argument. See also L<Math::Trig>. =item assert -Unimplemented. +Unimplemented, but you can use L<perlfunc/die> and the L<Carp> module +to achieve similar things. =item atan -This is identical to the C function C<atan()>. +This is identical to the C function C<atan()>, returning the +arcus tangent of its numerical argument. See also L<Math::Trig>. =item atan2 -This is identical to Perl's builtin C<atan2()> function. +This is identical to Perl's builtin C<atan2()> function, returning +the arcus tangent defined by its two numerical arguments, the I<y> +coordinate and the I<x> coordinate. See also L<Math::Trig>. =item atexit -atexit() is C-specific: use END {} instead. +atexit() is C-specific: use C<END {}> instead, see L<perlsub>. =item atof -atof() is C-specific. +atof() is C-specific. Perl converts strings to numbers transparently. +If you need to force a scalar to a number, add a zero to it. =item atoi -atoi() is C-specific. +atoi() is C-specific. Perl converts strings to numbers transparently. +If you need to force a scalar to a number, add a zero to it. +If you need to have just the integer part, see L<perlfunc/int>. =item atol -atol() is C-specific. +atol() is C-specific. Perl converts strings to numbers transparently. +If you need to force a scalar to a number, add a zero to it. +If you need to have just the integer part, see L<perlfunc/int>. =item bsearch -bsearch() not supplied. +bsearch() not supplied. For doing binary search on wordlists, +see L<Search::Dict>. =item calloc -calloc() is C-specific. +calloc() is C-specific. Perl does memory management transparently. =item ceil -This is identical to the C function C<ceil()>. +This is identical to the C function C<ceil()>, returning the smallest +integer value greater than or equal to the given numerical argument. =item chdir -This is identical to Perl's builtin C<chdir()> function. +This is identical to Perl's builtin C<chdir()> function, allowing +one to change the working (default) directory, see L<perlfunc/chdir>. =item chmod -This is identical to Perl's builtin C<chmod()> function. +This is identical to Perl's builtin C<chmod()> function, allowing +one to change file and directory permissions, see L<perlfunc/chmod>. =item chown -This is identical to Perl's builtin C<chown()> function. +This is identical to Perl's builtin C<chown()> function, allowing one +to change file and directory owners and groups, see L<perlfunc/chown>. =item clearerr -Use method C<IO::Handle::clearerr()> instead. +Use the method L<IO::Handle::clearerr()> instead, to reset the error +state (if any) and EOF state (if any) of the given stream. =item clock -This is identical to the C function C<clock()>. +This is identical to the C function C<clock()>, returning the +amount of spent processor time in microseconds. =item close @@ -171,17 +209,23 @@ C<POSIX::open>. Returns C<undef> on failure. +See also L<perlfunc/close>. + =item closedir -This is identical to Perl's builtin C<closedir()> function. +This is identical to Perl's builtin C<closedir()> function for closing +a directory handle, see L<perlfunc/closedir>. =item cos -This is identical to Perl's builtin C<cos()> function. +This is identical to Perl's builtin C<cos()> function, for returning +the cosine of its numerical argument, see L<perlfunc/cos>. +See also L<Math::Trig>. =item cosh -This is identical to the C function C<cosh()>. +This is identical to the C function C<cosh()>, for returning +the hyperbolic cosine of its numeric argument. See also L<Math::Trig>. =item creat @@ -191,6 +235,8 @@ C<POSIX::open>. Use C<POSIX::close> to close the file. $fd = POSIX::creat( "foo", 0611 ); POSIX::close( $fd ); +See also L<perlfunc/sysopen> and its C<O_CREAT> flag. + =item ctermid Generates the path name for the controlling terminal. @@ -199,25 +245,30 @@ Generates the path name for the controlling terminal. =item ctime -This is identical to the C function C<ctime()>. +This is identical to the C function C<ctime()> and equivalent +to C<asctime(localtime(...))>, see L</asctime> and L</localtime>. =item cuserid -Get the character login name of the user. +Get the login name of the owner of the current process. $name = POSIX::cuserid(); =item difftime -This is identical to the C function C<difftime()>. +This is identical to the C function C<difftime()>, for returning +the time difference (in seconds) between two times (as returned +by C<time()>), see L</time>. =item div -div() is C-specific. +div() is C-specific, use L<perlfunc/int> on the usual C</> division and +the modulus C<%>. =item dup -This is similar to the C function C<dup()>. +This is similar to the C function C<dup()>, for duplicating a file +descriptor. This uses file descriptors such as those obtained by calling C<POSIX::open>. @@ -226,7 +277,8 @@ Returns C<undef> on failure. =item dup2 -This is similar to the C function C<dup2()>. +This is similar to the C function C<dup2()>, for duplicating a file +descriptor to an another known file descriptor. This uses file descriptors such as those obtained by calling C<POSIX::open>. @@ -239,57 +291,64 @@ Returns the value of errno. $errno = POSIX::errno(); +This identical to the numerical values of the C<$!>, see L<perlvar/$ERRNO>. + =item execl -execl() is C-specific. +execl() is C-specific, see L<perlfunc/exec>. =item execle -execle() is C-specific. +execle() is C-specific, see L<perlfunc/exec>. =item execlp -execlp() is C-specific. +execlp() is C-specific, see L<perlfunc/exec>. =item execv -execv() is C-specific. +execv() is C-specific, see L<perlfunc/exec>. =item execve -execve() is C-specific. +execve() is C-specific, see L<perlfunc/exec>. =item execvp -execvp() is C-specific. +execvp() is C-specific, see L<perlfunc/exec>. =item exit -This is identical to Perl's builtin C<exit()> function. +This is identical to Perl's builtin C<exit()> function for exiting the +program, see L<perlfunc/exit>. =item exp -This is identical to Perl's builtin C<exp()> function. +This is identical to Perl's builtin C<exp()> function for +returning the exponent (I<e>-based) of the numerical argument, +see L<perlfunc/exp>. =item fabs -This is identical to Perl's builtin C<abs()> function. +This is identical to Perl's builtin C<abs()> function for returning +the absolute value of the numerical argument, see L<perlfunc/abs>. =item fclose -Use method C<IO::Handle::close()> instead. +Use method C<IO::Handle::close()> instead, or see L<perlfunc/close>. =item fcntl -This is identical to Perl's builtin C<fcntl()> function. +This is identical to Perl's builtin C<fcntl()> function, +see L<perlfunc/fcntl>. =item fdopen -Use method C<IO::Handle::new_from_fd()> instead. +Use method C<IO::Handle::new_from_fd()> instead, or see L<perlfunc/open>. =item feof -Use method C<IO::Handle::eof()> instead. +Use method C<IO::Handle::eof()> instead, or see L<perlfunc/eof>. =item ferror @@ -298,38 +357,49 @@ Use method C<IO::Handle::error()> instead. =item fflush Use method C<IO::Handle::flush()> instead. +See also L<perlvar/$OUTPUT_AUTOFLUSH>. =item fgetc -Use method C<IO::Handle::getc()> instead. +Use method C<IO::Handle::getc()> instead, or see L<perlfunc/read>. =item fgetpos -Use method C<IO::Seekable::getpos()> instead. +Use method C<IO::Seekable::getpos()> instead, or see L<L/seek>. =item fgets -Use method C<IO::Handle::gets()> instead. +Use method C<IO::Handle::gets()> instead. Similar to E<lt>E<gt>, also known +as L<perlfunc/readline>. =item fileno -Use method C<IO::Handle::fileno()> instead. +Use method C<IO::Handle::fileno()> instead, or see L<perlfunc/fileno>. =item floor -This is identical to the C function C<floor()>. +This is identical to the C function C<floor()>, returning the largest +integer value less than or equal to the numerical argument. =item fmod This is identical to the C function C<fmod()>. + $r = modf($x, $y); + +It returns the remainder C<$r = $x - $n*$y>, where C<$n = trunc($x/$y)>. +The C<$r> has the same sign as C<$x> and magnitude (absolute value) +less than the magnitude of C<$y>. + =item fopen -Use method C<IO::File::open()> instead. +Use method C<IO::File::open()> instead, or see L<perlfunc/open>. =item fork -This is identical to Perl's builtin C<fork()> function. +This is identical to Perl's builtin C<fork()> function +for duplicating the current process, see L<perlfunc/fork> +and L<perlfork> if you are in Windows. =item fpathconf @@ -346,45 +416,45 @@ Returns C<undef> on failure. =item fprintf -fprintf() is C-specific--use printf instead. +fprintf() is C-specific, see L<perlfunc/printf> instead. =item fputc -fputc() is C-specific--use print instead. +fputc() is C-specific, see L<perlfunc/print> instead. =item fputs -fputs() is C-specific--use print instead. +fputs() is C-specific, see L<perlfunc/print> instead. =item fread -fread() is C-specific--use read instead. +fread() is C-specific, see L<perlfunc/read> instead. =item free -free() is C-specific. +free() is C-specific. Perl does memory management transparently. =item freopen -freopen() is C-specific--use open instead. +freopen() is C-specific, see L<perlfunc/open> instead. =item frexp Return the mantissa and exponent of a floating-point number. - ($mantissa, $exponent) = POSIX::frexp( 3.14 ); + ($mantissa, $exponent) = POSIX::frexp( 1.234e56 ); =item fscanf -fscanf() is C-specific--use <> and regular expressions instead. +fscanf() is C-specific, use E<lt>E<gt> and regular expressions instead. =item fseek -Use method C<IO::Seekable::seek()> instead. +Use method C<IO::Seekable::seek()> instead, or see L<perlfunc/seek>. =item fsetpos -Use method C<IO::Seekable::setpos()> instead. +Use method C<IO::Seekable::setpos()> instead, or seek L<perlfunc/seek>. =item fstat @@ -397,174 +467,221 @@ Perl's builtin C<stat> function. =item ftell -Use method C<IO::Seekable::tell()> instead. +Use method C<IO::Seekable::tell()> instead, or see L<perlfunc/tell>. =item fwrite -fwrite() is C-specific--use print instead. +fwrite() is C-specific, see L<perlfunc/print> instead. =item getc -This is identical to Perl's builtin C<getc()> function. +This is identical to Perl's builtin C<getc()> function, +see L<perlfunc/getc>. =item getchar -Returns one character from STDIN. +Returns one character from STDIN. Identical to Perl's C<getc()>, +see L<perlfunc/getc>. =item getcwd Returns the name of the current working directory. +See also L<Cwd>. =item getegid -Returns the effective group id. +Returns the effective group identifier. Similar to Perl' s builtin +variable C<$(>, see L<perlvar/$EGID>. =item getenv Returns the value of the specified enironment variable. +The same information is available through the C<%ENV> array. =item geteuid -Returns the effective user id. +Returns the effective user identifier. Identical to Perl's builtin C<$E<gt>> +variable, see L<perlvar/$EUID>. =item getgid -Returns the user's real group id. +Returns the user's real group identifier. Similar to Perl's builtin +variable C<$)>, see L<perlvar/$GID>. =item getgrgid -This is identical to Perl's builtin C<getgrgid()> function. +This is identical to Perl's builtin C<getgrgid()> function for +returning group entries by group identifiers, see +L<perlfunc/getgrgid>. =item getgrnam -This is identical to Perl's builtin C<getgrnam()> function. +This is identical to Perl's builtin C<getgrnam()> function for +returning group entries by group names, see L<perlfunc/getgrnam>. =item getgroups -Returns the ids of the user's supplementary groups. +Returns the ids of the user's supplementary groups. Similar to Perl's +builtin variable C<$)>, see L<perlvar/$GID>. =item getlogin -This is identical to Perl's builtin C<getlogin()> function. +This is identical to Perl's builtin C<getlogin()> function for +returning the user name associated with the current session, see +L<perlfunc/getlogin>. =item getpgrp -This is identical to Perl's builtin C<getpgrp()> function. +This is identical to Perl's builtin C<getpgrp()> function for +returning the prcess group identifier of the current process, see +L<perlfunc/getpgrp>. =item getpid -Returns the process's id. +Returns the process identifier. Identical to Perl's builtin +variable C<$$>, see L<perlvar/$PID>. =item getppid -This is identical to Perl's builtin C<getppid()> function. +This is identical to Perl's builtin C<getppid()> function for +returning the process identifier of the parent process of the current +process , see L<perlfunc/getppid>. =item getpwnam -This is identical to Perl's builtin C<getpwnam()> function. +This is identical to Perl's builtin C<getpwnam()> function for +returning user entries by user names, see L<perlfunc/getpwnam>. =item getpwuid -This is identical to Perl's builtin C<getpwuid()> function. +This is identical to Perl's builtin C<getpwuid()> function for +returning user entries by user identifiers, see L<perlfunc/getpwuid>. =item gets -Returns one line from STDIN. +Returns one line from C<STDIN>, similar to E<lt>E<gt>, also known +as the C<readline()> function, see L<perlfunc/readline>. + +B<NOTE>: if you have C programs that still use C<gets()>, be very +afraid. The C<gets()> function is a source of endless grief because +it has no buffer overrun checks. It should B<never> be used. The +C<fgets()> function should be preferred instead. =item getuid -Returns the user's id. +Returns the user's identifier. Identical to Perl's builtin C<$E<lt>> variable, +see L<perlvar/$UID>. =item gmtime -This is identical to Perl's builtin C<gmtime()> function. +This is identical to Perl's builtin C<gmtime()> function for +converting seconds since the epoch to a date in Greenwich Mean Time, +see L<perlfunc/gmtime>. =item isalnum This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:isalnum:]]/> construct instead, or possibly the C</\w/> construct. =item isalpha This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:isalpha:]]/> construct instead. =item isatty Returns a boolean indicating whether the specified filehandle is connected -to a tty. +to a tty. Similar to the C<-t> operator, see L<perlfunc/-X>. =item iscntrl This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:iscntrl:]]/> construct instead. =item isdigit This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:isdigit:]]/> construct instead, or the C</\d/> construct. =item isgraph This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:isgraph:]]/> construct instead. =item islower This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:islower:]]/> construct instead. Do B<not> use C</a-z/>. =item isprint This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:isprint:]]/> construct instead. =item ispunct This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:ispunct:]]/> construct instead. =item isspace This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:isspace:]]/> construct instead, or the C</\s/> construct. =item isupper This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:isupper:]]/> construct instead. Do B<not> use C</A-Z/>. =item isxdigit This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:isxdigit:]]/> construct instead, or simply C</[0-9a-f]/i>. =item kill -This is identical to Perl's builtin C<kill()> function. +This is identical to Perl's builtin C<kill()> function for sending +signals to processes (often to terminate them), see L<perlfunc/kill>. =item labs -labs() is C-specific, use abs instead. +(For returning absolute values of long integers.) +labs() is C-specific, see L<perlfunc/abs> instead. =item ldexp -This is identical to the C function C<ldexp()>. +This is identical to the C function C<ldexp()> +for multiplying floating point numbers with powers of two. + + $x_quadrupled = POSIX::ldexp($x, 2); =item ldiv -ldiv() is C-specific, use / and int instead. +(For computing dividends of long integers.) +ldiv() is C-specific, use C</> and C<int()> instead. =item link -This is identical to Perl's builtin C<link()> function. +This is identical to Perl's builtin C<link()> function +for creating hard links into files, see L<perlfunc/link>. =item localeconv Get numeric formatting information. Returns a reference to a hash containing the current locale formatting values. -The database for the B<de> (Deutsch or German) locale. +Here is how to query the database for the B<de> (Deutsch or German) locale. $loc = POSIX::setlocale( &POSIX::LC_ALL, "de" ); print "Locale = $loc\n"; @@ -590,19 +707,34 @@ The database for the B<de> (Deutsch or German) locale. =item localtime -This is identical to Perl's builtin C<localtime()> function. +This is identical to Perl's builtin C<localtime()> function for +converting seconds since the epoch to a date see L<perlfunc/localtime>. =item log -This is identical to Perl's builtin C<log()> function. +This is identical to Perl's builtin C<log()> function, +returning the natural (I<e>-based) logarithm of the numerical argument, +see L<perlfunc/log>. =item log10 -This is identical to the C function C<log10()>. +This is identical to the C function C<log10()>, +returning the 10-base logarithm of the numerical argument. +You can also use + + sub log10 { log($_[0]) / log(10) } + +or + + sub log10 { log($_[0]) / 2.30258509299405 } + +or + + sub log10 { log($_[0]) * 0.434294481903252 } =item longjmp -longjmp() is C-specific: use die instead. +longjmp() is C-specific: use L<perlfunc/die> instead. =item lseek @@ -616,49 +748,63 @@ Returns C<undef> on failure. =item malloc -malloc() is C-specific. +malloc() is C-specific. Perl does memory management transparently. =item mblen This is identical to the C function C<mblen()>. +Perl does not have any support for the wide and multibyte +characters of the C standards, so this might be a rather +useless function. =item mbstowcs This is identical to the C function C<mbstowcs()>. +Perl does not have any support for the wide and multibyte +characters of the C standards, so this might be a rather +useless function. =item mbtowc This is identical to the C function C<mbtowc()>. +Perl does not have any support for the wide and multibyte +characters of the C standards, so this might be a rather +useless function. =item memchr -memchr() is C-specific, use index() instead. +memchr() is C-specific, see L<perlfunc/index> instead. =item memcmp -memcmp() is C-specific, use eq instead. +memcmp() is C-specific, use C<eq> instead, see L<perlop>. =item memcpy -memcpy() is C-specific, use = instead. +memcpy() is C-specific, use C<=>, see L<perlop>, or see L<perlfunc/substr>. =item memmove -memmove() is C-specific, use = instead. +memmove() is C-specific, use C<=>, see L<perlop>, or see L<perlfunc/substr>. =item memset -memset() is C-specific, use x instead. +memset() is C-specific, use C<x> instead, see L<perlop>. =item mkdir -This is identical to Perl's builtin C<mkdir()> function. +This is identical to Perl's builtin C<mkdir()> function +for creating directories, see L<perlfunc/mkdir>. =item mkfifo -This is similar to the C function C<mkfifo()>. +This is similar to the C function C<mkfifo()> for creating +FIFO special files. -Returns C<undef> on failure. + if (mkfifo($path, $mode)) { .... + +Returns C<undef> on failure. The C<$mode> is similar to the +mode of C<mkdir()>, see L<perlfunc/mkdir>. =item mktime @@ -689,13 +835,16 @@ Return the integral and fractional parts of a floating-point number. =item nice -This is similar to the C function C<nice()>. +This is similar to the C function C<nice()>, for changing +the scheduling preference of the current process. Positive +arguments mean more polite process, negative values more +needy process. Normal user processes can only be more polite. Returns C<undef> on failure. =item offsetof -offsetof() is C-specific. +offsetof() is C-specific, you probably want to see L<perlfunc/pack> instead. =item open @@ -720,6 +869,8 @@ Create a new file with mode 0640. Set up the file for writing. Returns C<undef> on failure. +See also L<perlfunc/sysopen>. + =item opendir Open a directory for reading. @@ -743,13 +894,17 @@ Returns C<undef> on failure. =item pause -This is similar to the C function C<pause()>. +This is similar to the C function C<pause()>, which suspends +the execution of the current process until a signal is received. Returns C<undef> on failure. =item perror -This is identical to the C function C<perror()>. +This is identical to the C function C<perror()>, which outputs to the +standard error stream the specified message followed by ": " and the +current error string. Use the C<warn()> function and the C<$!> +variable instead, see L<perlfunc/warn> and L<perlvar/$ERRNO>. =item pipe @@ -760,39 +915,45 @@ returned by C<POSIX::open>. POSIX::write( $fd0, "hello", 5 ); POSIX::read( $fd1, $buf, 5 ); +See also L<perlfunc/pipe>. + =item pow -Computes $x raised to the power $exponent. +Computes C<$x> raised to the power C<$exponent>. $ret = POSIX::pow( $x, $exponent ); +You can also use the C<**> operator, see L<perlop>. + =item printf -Prints the specified arguments to STDOUT. +Formats and prints the specified arguments to STDOUT. +See also L<perlfunc/printf>. =item putc -putc() is C-specific--use print instead. +putc() is C-specific, see L<perlfunc/print> instead. =item putchar -putchar() is C-specific--use print instead. +putchar() is C-specific, see L<perlfunc/print> instead. =item puts -puts() is C-specific--use print instead. +puts() is C-specific, see L<perlfunc/print> instead. =item qsort -qsort() is C-specific, use sort instead. +qsort() is C-specific, see L<perlfunc/sort> instead. =item raise Sends the specified signal to the current process. +See also L<perlfunc/kill> and the C<$$> in L<perlvar/$PID>. =item rand -rand() is non-portable, use Perl's rand instead. +C<rand()> is non-portable, see L<perlfunc/rand> instead. =item read @@ -805,21 +966,26 @@ read then Perl will extend it to make room for the request. Returns C<undef> on failure. +See also L<perlfunc/sysread>. + =item readdir -This is identical to Perl's builtin C<readdir()> function. +This is identical to Perl's builtin C<readdir()> function +for reading directory entries, see L<perlfunc/readdir>. =item realloc -realloc() is C-specific. +realloc() is C-specific. Perl does memory management transparently. =item remove -This is identical to Perl's builtin C<unlink()> function. +This is identical to Perl's builtin C<unlink()> function +for removing files, see L<perlfunc/unlink>. =item rename -This is identical to Perl's builtin C<rename()> function. +This is identical to Perl's builtin C<rename()> function +for renaming files, see L<perlfunc/rename>. =item rewind @@ -827,23 +993,29 @@ Seeks to the beginning of the file. =item rewinddir -This is identical to Perl's builtin C<rewinddir()> function. +This is identical to Perl's builtin C<rewinddir()> function for +rewinding directory entry streams, see L<perlfunc/rewinddir>. =item rmdir -This is identical to Perl's builtin C<rmdir()> function. +This is identical to Perl's builtin C<rmdir()> function +for removing (empty) directories, see L<perlfunc/rmdir>. =item scanf -scanf() is C-specific--use <> and regular expressions instead. +scanf() is C-specific, use E<lt>E<gt> and regular expressions instead, +see L<perlre>. =item setgid -Sets the real group id for this process. +Sets the real group identifier for this process. +Identical to assigning a value to the Perl's builtin C<$)> variable, +see L<perlvar/$UID>. =item setjmp -setjmp() is C-specific: use eval {} instead. +C<setjmp()> is C-specific: use C<eval {}> instead, +see L<perlfunc/eval>. =item setlocale @@ -879,17 +1051,21 @@ out which locales are available in your system. =item setpgid -This is similar to the C function C<setpgid()>. +This is similar to the C function C<setpgid()> for +setting the process group identifier of the current process. Returns C<undef> on failure. =item setsid -This is identical to the C function C<setsid()>. +This is identical to the C function C<setsid()> for +setting the session identifier of the current process. =item setuid -Sets the real user id for this process. +Sets the real user identifier for this process. +Identical to assigning a value to the Perl's builtin C<$E<lt>> variable, +see L<perlvar/$UID>. =item sigaction @@ -905,7 +1081,7 @@ Returns C<undef> on failure. =item siglongjmp -siglongjmp() is C-specific: use die instead. +siglongjmp() is C-specific: use L<perlfunc/die> instead. =item sigpending @@ -933,7 +1109,8 @@ Returns C<undef> on failure. =item sigsetjmp -sigsetjmp() is C-specific: use eval {} instead. +C<sigsetjmp()> is C-specific: use C<eval {}> instead, +see L<perlfunc/eval>. =item sigsuspend @@ -949,63 +1126,80 @@ Returns C<undef> on failure. =item sin -This is identical to Perl's builtin C<sin()> function. +This is identical to Perl's builtin C<sin()> function +for returning the sine of the numerical argument, +see L<perlfunc/sin>. See also L<Math::Trig>. =item sinh -This is identical to the C function C<sinh()>. +This is identical to the C function C<sinh()> +for returning the hyperbolic sine of the numerical argument. +See also L<Math::Trig>. =item sleep -This is identical to Perl's builtin C<sleep()> function. +This is identical to Perl's builtin C<sleep()> function +for suspending the execution of the current for process +for certain number of seconds, see L<perlfunc/sleep>. =item sprintf -This is identical to Perl's builtin C<sprintf()> function. +This is similar to Perl's builtin C<sprintf()> function +for returning a string that has the arguments formatted as requested, +see L<perlfunc/sprintf>. =item sqrt This is identical to Perl's builtin C<sqrt()> function. +for returning the square root of the numerical argument, +see L<perlfunc/sqrt>. =item srand -srand(). +Give a seed the pseudorandom number generator, see L<perlfunc/srand>. =item sscanf -sscanf() is C-specific--use regular expressions instead. +sscanf() is C-specific, use regular expressions instead, +see L<perlre>. =item stat -This is identical to Perl's builtin C<stat()> function. +This is identical to Perl's builtin C<stat()> function +for retutning information about files and directories. =item strcat -strcat() is C-specific, use .= instead. +strcat() is C-specific, use C<.=> instead, see L<perlop>. =item strchr -strchr() is C-specific, use index() instead. +strchr() is C-specific, see L<perlfunc/index> instead. =item strcmp -strcmp() is C-specific, use eq instead. +strcmp() is C-specific, use C<eq> or C<cmp> instead, see L<perlop>. =item strcoll -This is identical to the C function C<strcoll()>. +This is identical to the C function C<strcoll()> +for collating (comparing) strings transformed using +the C<strxfrm()> function. Not really needed since +Perl can do this transparently, see L<perllocale>. =item strcpy -strcpy() is C-specific, use = instead. +strcpy() is C-specific, use C<=> instead, see L<perlop>. =item strcspn -strcspn() is C-specific, use regular expressions instead. +strcspn() is C-specific, use regular expressions instead, +see L<perlre>. =item strerror Returns the error string for the specified errno. +Identical to the string form of the C<$!>, see L<perlvar/$ERRNO>. =item strftime @@ -1034,39 +1228,38 @@ The string for Tuesday, December 12, 1995. =item strlen -strlen() is C-specific, use length instead. +strlen() is C-specific, use C<length()> instead, see L<perlfunc/length>. =item strncat -strncat() is C-specific, use .= instead. +strncat() is C-specific, use C<.=> instead, see L<perlop>. =item strncmp -strncmp() is C-specific, use eq instead. +strncmp() is C-specific, use C<eq> instead, see L<perlop>. =item strncpy -strncpy() is C-specific, use = instead. - -=item stroul - -stroul() is C-specific. +strncpy() is C-specific, use C<=> instead, see L<perlop>. =item strpbrk -strpbrk() is C-specific. +strpbrk() is C-specific, use regular expressions instead, +see L<perlre>. =item strrchr -strrchr() is C-specific, use rindex() instead. +strrchr() is C-specific, see L<perlfunc/rindex> instead. =item strspn -strspn() is C-specific. +strspn() is C-specific, use regular expressions instead, +see L<perlre>. =item strstr -This is identical to Perl's builtin C<index()> function. +This is identical to Perl's builtin C<index()> function, +see L<perlfunc/index>. =item strtod @@ -1093,7 +1286,8 @@ When called in a scalar context strtod returns the parsed number. =item strtok -strtok() is C-specific. +strtok() is C-specific, use regular expressions instead, see +L<perlre>, or L<perlfunc/split>. =item strtol @@ -1127,12 +1321,12 @@ When called in a scalar context strtol returns the parsed number. =item strtoul -String to unsigned (long) integer translation. strtoul is identical -to strtol except that strtoul only parses unsigned integers. See -I<strtol> for details. +String to unsigned (long) integer translation. strtoul() is identical +to strtol() except that strtoul() only parses unsigned integers. See +L</strtol> for details. -Note: Some vendors supply strtod and strtol but not strtoul. -Other vendors that do suply strtoul parse "-1" as a valid value. +Note: Some vendors supply strtod() and strtol() but not strtoul(). +Other vendors that do supply strtoul() parse "-1" as a valid value. =item strxfrm @@ -1140,6 +1334,11 @@ String transformation. Returns the transformed string. $dst = POSIX::strxfrm( $src ); +Used in conjunction with the C<strcoll()> function, see L</strcoll>. + +Not really needed since Perl can do this transparently, see +L<perllocale>. + =item sysconf Retrieves values of system configurable variables. @@ -1152,53 +1351,66 @@ Returns C<undef> on failure. =item system -This is identical to Perl's builtin C<system()> function. +This is identical to Perl's builtin C<system()> function, see +L<perlfunc/system>. =item tan -This is identical to the C function C<tan()>. +This is identical to the C function C<tan()>, returning the +tangent of the numerical argument. See also L<Math::Trig>. =item tanh -This is identical to the C function C<tanh()>. +This is identical to the C function C<tanh()>, returning the +hyperbolic tangent of the numerical argument. See also L<Math::Trig>. =item tcdrain -This is similar to the C function C<tcdrain()>. +This is similar to the C function C<tcdrain()> for draining +the output queue of its argument stream. Returns C<undef> on failure. =item tcflow -This is similar to the C function C<tcflow()>. +This is similar to the C function C<tcflow()> for controlling +the flow of its argument stream. Returns C<undef> on failure. =item tcflush -This is similar to the C function C<tcflush()>. +This is similar to the C function C<tcflush()> for flushing +the I/O buffers of its argumeny stream. Returns C<undef> on failure. =item tcgetpgrp -This is identical to the C function C<tcgetpgrp()>. +This is identical to the C function C<tcgetpgrp()> for returning the +process group identifier of the foreground process group of the controlling +terminal. =item tcsendbreak -This is similar to the C function C<tcsendbreak()>. +This is similar to the C function C<tcsendbreak()> for sending +a break on its argument stream. Returns C<undef> on failure. =item tcsetpgrp -This is similar to the C function C<tcsetpgrp()>. +This is similar to the C function C<tcsetpgrp()> for setting the +process group identifier of the foreground process group of the controlling +terminal. Returns C<undef> on failure. =item time -This is identical to Perl's builtin C<time()> function. +This is identical to Perl's builtin C<time()> function +for returning the number of seconds since the epoch +(whatever it is for the system), see L<perlfunc/time>. =item times @@ -1214,7 +1426,7 @@ seconds. =item tmpfile -Use method C<IO::File::new_tmpfile()> instead. +Use method C<IO::File::new_tmpfile()> instead, or see L<File::Temp>. =item tmpnam @@ -1222,17 +1434,28 @@ Returns a name for a temporary file. $tmpfile = POSIX::tmpnam(); +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<File::Temp>. + =item tolower -This is identical to Perl's builtin C<lc()> function. +This is identical to the C function, except that it can apply to a single +character or to a whole string. Consider using the C<lc()> function, +see L<perlfunc/lc>, or the equivalent C<\L> operator inside doublequotish +strings. =item toupper -This is identical to Perl's builtin C<uc()> function. +This is identical to the C function, except that it can apply to a single +character or to a whole string. Consider using the C<uc()> function, +see L<perlfunc/uc>, or the equivalent C<\U> operator inside doublequotish +strings. =item ttyname -This is identical to the C function C<ttyname()>. +This is identical to the C function C<ttyname()> for returning the +name of the current terminal. =item tzname @@ -1243,17 +1466,31 @@ Retrieves the time conversion information from the C<tzname> variable. =item tzset -This is identical to the C function C<tzset()>. +This is identical to the C function C<tzset()> for setting +the current timezone based on the environment variable C<TZ>, +to be used by C<ctime()>, C<localtime()>, C<mktime()>, and C<strftime()> +functions. =item umask -This is identical to Perl's builtin C<umask()> function. +This is identical to Perl's builtin C<umask()> function +for setting (and querying) the file creation permission mask, +see L<perlfunc/umask>. =item uname Get name of current operating system. - ($sysname, $nodename, $release, $version, $machine ) = POSIX::uname(); + ($sysname, $nodename, $release, $version, $machine) = POSIX::uname(); + +Note that the actual meanings of the various fields are not +that well standardized, do not expect any great portability. +The C<$sysname> might be the name of the operating system, +the C<$nodename> might be the name of the host, the C<$release> +might be the (major) release number of the operating system, +the C<$version> might be the (minor) release number of the +operating system, and the C<$machine> might be a hardware identifier. +Maybe. =item ungetc @@ -1261,32 +1498,36 @@ Use method C<IO::Handle::ungetc()> instead. =item unlink -This is identical to Perl's builtin C<unlink()> function. +This is identical to Perl's builtin C<unlink()> function +for removing files, see L<perlfunc/unlink>. =item utime -This is identical to Perl's builtin C<utime()> function. +This is identical to Perl's builtin C<utime()> function +for changing the time stamps of files and directories, +see L<perlfunc/utime>. =item vfprintf -vfprintf() is C-specific. +vfprintf() is C-specific, see L<perlfunc/printf> instead. =item vprintf -vprintf() is C-specific. +vprintf() is C-specific, see L<perlfunc/printf> instead. =item vsprintf -vsprintf() is C-specific. +vsprintf() is C-specific, see L<perlfunc/sprintf> instead. =item wait -This is identical to Perl's builtin C<wait()> function. +This is identical to Perl's builtin C<wait()> function, +see L<perlfunc/wait>. =item waitpid Wait for a child process to change state. This is identical to Perl's -builtin C<waitpid()> function. +builtin C<waitpid()> function, see L<perlfunc/waitpid>. $pid = POSIX::waitpid( -1, &POSIX::WNOHANG ); print "status = ", ($? / 256), "\n"; @@ -1294,10 +1535,16 @@ builtin C<waitpid()> function. =item wcstombs This is identical to the C function C<wcstombs()>. +Perl does not have any support for the wide and multibyte +characters of the C standards, so this might be a rather +useless function. =item wctomb This is identical to the C function C<wctomb()>. +Perl does not have any support for the wide and multibyte +characters of the C standards, so this might be a rather +useless function. =item write @@ -1310,6 +1557,8 @@ calling C<POSIX::open>. Returns C<undef> on failure. +See also L<perlfunc/syswrite>. + =back =head1 CLASSES @@ -1715,7 +1964,7 @@ CLK_TCK CLOCKS_PER_SEC =item Constants -R_OK SEEK_CUR SEEK_END SEEK_SET STDIN_FILENO STDOUT_FILENO STRERR_FILENO W_OK X_OK +R_OK SEEK_CUR SEEK_END SEEK_SET STDIN_FILENO STDOUT_FILENO STDERR_FILENO W_OK X_OK =back @@ -1733,7 +1982,3 @@ WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG WIFSTOPPED WSTOPSIG =back -=head1 CREATION - -This document generated by ./mkposixman.PL version 19960129. - diff --git a/contrib/perl5/ext/POSIX/POSIX.xs b/contrib/perl5/ext/POSIX/POSIX.xs index 3a523d1d07a3..7ffd49411a5b 100644 --- a/contrib/perl5/ext/POSIX/POSIX.xs +++ b/contrib/perl5/ext/POSIX/POSIX.xs @@ -55,6 +55,9 @@ #ifdef I_UNISTD #include <unistd.h> #endif +#ifdef MACOS_TRADITIONAL +#undef fdopen +#endif #include <fcntl.h> #if defined(__VMS) && !defined(__POSIX_SOURCE) @@ -80,7 +83,7 @@ /* The non-POSIX CRTL times() has void return type, so we just get the current time directly */ - clock_t vms_times(struct tms *PL_bufptr) { + clock_t vms_times(struct tms *bufptr) { dTHX; clock_t retval; /* Get wall time and convert to 10 ms intervals to @@ -101,7 +104,7 @@ _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder)); # endif /* Fill in the struct tms using the CRTL routine . . .*/ - times((tbuffer_t *)PL_bufptr); + times((tbuffer_t *)bufptr); return (clock_t) retval; } # define times(t) vms_times(t) @@ -139,10 +142,12 @@ # define sigdelset(a,b) not_here("sigdelset") # define sigfillset(a) not_here("sigfillset") # define sigismember(a,b) not_here("sigismember") +# define setuid(a) not_here("setuid") +# define setgid(a) not_here("setgid") #else # ifndef HAS_MKFIFO -# ifdef OS2 +# if defined(OS2) || defined(MACOS_TRADITIONAL) # define mkfifo(a,b) not_here("mkfifo") # else /* !( defined OS2 ) */ # ifndef mkfifo @@ -151,12 +156,17 @@ # endif # endif /* !HAS_MKFIFO */ -# include <grp.h> -# include <sys/times.h> -# ifdef HAS_UNAME -# include <sys/utsname.h> +# ifdef MACOS_TRADITIONAL +# define ttyname(a) (char*)not_here("ttyname") +# define tzset() not_here("tzset") +# else +# include <grp.h> +# include <sys/times.h> +# ifdef HAS_UNAME +# include <sys/utsname.h> +# endif +# include <sys/wait.h> # endif -# include <sys/wait.h> # ifdef I_UTIME # include <utime.h> # endif @@ -529,12 +539,12 @@ mini_mktime(struct tm *ptm) } #ifdef HAS_LONG_DOUBLE -# if LONG_DOUBLESIZE > DOUBLESIZE +# if LONG_DOUBLESIZE > NVSIZE # undef HAS_LONG_DOUBLE /* XXX until we figure out how to use them */ # endif #endif -#ifndef HAS_LONG_DOUBLE +#ifndef HAS_LONG_DOUBLE #ifdef LDBL_MAX #undef LDBL_MAX #endif @@ -554,11 +564,7 @@ not_here(char *s) } static -#if defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE) -long double -#else -double -#endif +NV constant(char *name, int arg) { errno = 0; @@ -1517,6 +1523,11 @@ constant(char *name, int arg) break; case 'H': if (strEQ(name, "HUGE_VAL")) +#if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) + /* HUGE_VALL is admittedly non-POSIX but if we are using long doubles + * we might as well use long doubles. --jhi */ + return HUGE_VALL; +#endif #ifdef HUGE_VAL return HUGE_VAL; #else @@ -2291,9 +2302,9 @@ constant(char *name, int arg) #else goto not_there; #endif - if (strEQ(name, "STRERR_FILENO")) -#ifdef STRERR_FILENO - return STRERR_FILENO; + if (strEQ(name, "STDERR_FILENO")) +#ifdef STDERR_FILENO + return STDERR_FILENO; #else goto not_there; #endif @@ -3005,7 +3016,7 @@ setcc(termios_ref, ccix, cc) MODULE = POSIX PACKAGE = POSIX -double +NV constant(name,arg) char * name int arg @@ -3161,7 +3172,7 @@ localeconv() #ifdef HAS_LOCALECONV struct lconv *lcbuf; RETVAL = newHV(); - if (lcbuf = localeconv()) { + if ((lcbuf = localeconv())) { /* the strings */ if (lcbuf->decimal_point && *lcbuf->decimal_point) hv_store(RETVAL, "decimal_point", 13, @@ -3294,73 +3305,73 @@ setlocale(category, locale = 0) RETVAL -double +NV acos(x) - double x + NV x -double +NV asin(x) - double x + NV x -double +NV atan(x) - double x + NV x -double +NV ceil(x) - double x + NV x -double +NV cosh(x) - double x + NV x -double +NV floor(x) - double x + NV x -double +NV fmod(x,y) - double x - double y + NV x + NV y void frexp(x) - double x + NV x PPCODE: int expvar; /* (We already know stack is long enough.) */ PUSHs(sv_2mortal(newSVnv(frexp(x,&expvar)))); PUSHs(sv_2mortal(newSViv(expvar))); -double +NV ldexp(x,exp) - double x + NV x int exp -double +NV log10(x) - double x + NV x void modf(x) - double x + NV x PPCODE: - double intvar; + NV intvar; /* (We already know stack is long enough.) */ - PUSHs(sv_2mortal(newSVnv(modf(x,&intvar)))); + PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); PUSHs(sv_2mortal(newSVnv(intvar))); -double +NV sinh(x) - double x + NV x -double +NV tan(x) - double x + NV x -double +NV tanh(x) - double x + NV x SysRet sigaction(sig, action, oldaction = 0) @@ -3406,9 +3417,8 @@ sigaction(sig, action, oldaction = 0) /* Set up any desired mask. */ svp = hv_fetch(action, "MASK", 4, FALSE); if (svp && sv_isa(*svp, "POSIX::SigSet")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(*svp)); - sigset = (sigset_t*) tmp; + IV tmp = SvIV((SV*)SvRV(*svp)); + sigset = INT2PTR(sigset_t*, tmp); act.sa_mask = *sigset; } else @@ -3433,9 +3443,8 @@ sigaction(sig, action, oldaction = 0) /* Get back the mask. */ svp = hv_fetch(oldaction, "MASK", 4, TRUE); if (sv_isa(*svp, "POSIX::SigSet")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(*svp)); - sigset = (sigset_t*) tmp; + IV tmp = SvIV((SV*)SvRV(*svp)); + sigset = INT2PTR(sigset_t*, tmp); } else { New(0, sigset, 1, sigset_t); @@ -3506,7 +3515,7 @@ SysRet nice(incr) int incr -int +void pipe() PPCODE: int fds[2]; @@ -3549,7 +3558,7 @@ tcsetpgrp(fd, pgrp_id) int fd pid_t pgrp_id -int +void uname() PPCODE: #ifdef HAS_UNAME @@ -3683,7 +3692,7 @@ strtoul(str, base = 0) PUSHs(&PL_sv_undef); } -SV * +void strxfrm(src) SV * src CODE: @@ -3818,7 +3827,10 @@ mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) OUTPUT: RETVAL -char * +#XXX: if $xsubpp::WantOptimize is always the default +# sv_setpv(TARG, ...) could be used rather than +# ST(0) = sv_2mortal(newSVpv(...)) +void strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) char * fmt int sec diff --git a/contrib/perl5/ext/POSIX/typemap b/contrib/perl5/ext/POSIX/typemap index 63e41c77bf1f..baf9bfc05194 100644 --- a/contrib/perl5/ext/POSIX/typemap +++ b/contrib/perl5/ext/POSIX/typemap @@ -5,6 +5,7 @@ Time_t T_NV Gid_t T_NV Off_t T_NV Dev_t T_NV +NV T_NV fd T_IV speed_t T_IV tcflag_t T_IV diff --git a/contrib/perl5/ext/SDBM_File/SDBM_File.pm b/contrib/perl5/ext/SDBM_File/SDBM_File.pm index c5e26c8e04d8..ee82a54145d9 100644 --- a/contrib/perl5/ext/SDBM_File/SDBM_File.pm +++ b/contrib/perl5/ext/SDBM_File/SDBM_File.pm @@ -1,12 +1,13 @@ package SDBM_File; use strict; +use warnings; require Tie::Hash; use XSLoader (); our @ISA = qw(Tie::Hash); -our $VERSION = "1.02" ; +our $VERSION = "1.03" ; XSLoader::load 'SDBM_File', $VERSION; @@ -20,14 +21,96 @@ SDBM_File - Tied access to sdbm files =head1 SYNOPSIS + use Fcntl; # For O_RDWR, O_CREAT, etc. use SDBM_File; - tie(%h, 'SDBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640); + tie(%h, 'SDBM_File', 'filename', O_RDWR|O_CREAT, 0666) + or die "Couldn't tie SDBM file 'filename': $!; aborting"; + + # Now read and change the hash + $h{newkey} = newvalue; + print $h{oldkey}; + ... untie %h; =head1 DESCRIPTION -See L<perlfunc/tie>, L<perldbmfilter> +C<SDBM_File> establishes a connection between a Perl hash variable and +a file in SDBM_File format;. You can manipulate the data in the file +just as if it were in a Perl hash, but when your program exits, the +data will remain in the file, to be used the next time your program +runs. + +Use C<SDBM_File> with the Perl built-in C<tie> function to establish +the connection between the variable and the file. The arguments to +C<tie> should be: + +=over 4 + +=item 1. + +The hash variable you want to tie. + +=item 2. + +The string C<"SDBM_File">. (Ths tells Perl to use the C<SDBM_File> +package to perform the functions of the hash.) + +=item 3. + +The name of the file you want to tie to the hash. + +=item 4. + +Flags. Use one of: + +=over 2 + +=item C<O_RDONLY> + +Read-only access to the data in the file. + +=item C<O_WRONLY> + +Write-only access to the data in the file. + +=item C<O_RDWR> + +Both read and write access. + +=back + +If you want to create the file if it does not exist, add C<O_CREAT> to +any of these, as in the example. If you omit C<O_CREAT> and the file +does not already exist, the C<tie> call will fail. + +=item 5. + +The default permissions to use if a new file is created. The actual +permissions will be modified by the user's umask, so you should +probably use 0666 here. (See L<perlfunc/umask>.) + +=back + +=head1 DIAGNOSTICS + +On failure, the C<tie> call returns an undefined value and probably +sets C<$!> to contain the reason the file could not be tied. + +=head2 C<sdbm store returned -1, errno 22, key "..." at ...> + +This warning is emmitted when you try to store a key or a value that +is too long. It means that the change was not recorded in the +database. See BUGS AND WARNINGS below. + +=head1 BUGS AND WARNINGS + +There are a number of limits on the size of the data that you can +store in the SDBM file. The most important is that the length of a +key, plus the length of its associated value, may not exceed 1008 +bytes. + +See L<perlfunc/tie>, L<perldbmfilter>, L<Fcntl> =cut diff --git a/contrib/perl5/ext/SDBM_File/SDBM_File.xs b/contrib/perl5/ext/SDBM_File/SDBM_File.xs index a4b90451a9bc..859730bf3ac1 100644 --- a/contrib/perl5/ext/SDBM_File/SDBM_File.xs +++ b/contrib/perl5/ext/SDBM_File/SDBM_File.xs @@ -57,7 +57,7 @@ sdbm_TIEHASH(dbtype, filename, flags, mode) DBM * dbp ; RETVAL = NULL ; - if (dbp = sdbm_open(filename,flags,mode) ) { + if ((dbp = sdbm_open(filename,flags,mode))) { RETVAL = (SDBM_File)safemalloc(sizeof(SDBM_File_type)) ; Zero(RETVAL, 1, SDBM_File_type) ; RETVAL->dbp = dbp ; diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbm.c b/contrib/perl5/ext/SDBM_File/sdbm/dbm.c index dc47d7001dee..321ac3ef6061 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/dbm.c +++ b/contrib/perl5/ext/SDBM_File/sdbm/dbm.c @@ -3,16 +3,33 @@ * All rights reserved. * * Redistribution and use in source and binary forms are permitted - * provided that the above copyright notice and this paragraph are - * duplicated in all such forms and that any documentation, - * advertising materials, and other materials related to such - * distribution and use acknowledge that the software was developed - * by the University of California, Berkeley. The name of the - * University may not be used to endorse or promote products derived - * from this software without specific prior written permission. - * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR - * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * provided that the above copyright notice and this notice are + * duplicated in all such forms. + * + * [additional clause stricken -- see below] + * + * The name of the University may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY + * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR + * PURPOSE. + * + * This notice previously contained the additional clause: + * + * and that any documentation, advertising materials, and other + * materials related to such distribution and use acknowledge that + * the software was developed by the University of California, + * Berkeley. + * + * Pursuant to the licensing change made by the Office of Technology + * Licensing of the University of California, Berkeley on July 22, + * 1999 and documented in: + * + * ftp://ftp.cs.berkeley.edu/pub/4bsd/README.Impt.License.Change + * + * this clause has been stricken and no longer is applicable to this + * software. */ #ifndef lint diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbm.h b/contrib/perl5/ext/SDBM_File/sdbm/dbm.h index 1196953d9653..e2c935523899 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/dbm.h +++ b/contrib/perl5/ext/SDBM_File/sdbm/dbm.h @@ -3,16 +3,33 @@ * All rights reserved. * * Redistribution and use in source and binary forms are permitted - * provided that the above copyright notice and this paragraph are - * duplicated in all such forms and that any documentation, - * advertising materials, and other materials related to such - * distribution and use acknowledge that the software was developed - * by the University of California, Berkeley. The name of the - * University may not be used to endorse or promote products derived - * from this software without specific prior written permission. - * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR - * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * provided that the above copyright notice and this notice are + * duplicated in all such forms. + * + * [additional clause stricken -- see below] + * + * The name of the University may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY + * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR + * PURPOSE. + * + * This notice previously contained the additional clause: + * + * and that any documentation, advertising materials, and other + * materials related to such distribution and use acknowledge that + * the software was developed by the University of California, + * Berkeley. + * + * Pursuant to the licensing change made by the Office of Technology + * Licensing of the University of California, Berkeley on July 22, + * 1999 and documented in: + * + * ftp://ftp.cs.berkeley.edu/pub/4bsd/README.Impt.License.Change + * + * this clause has been stricken and no longer is applicable to this + * software. * * @(#)dbm.h 5.2 (Berkeley) 5/24/89 */ diff --git a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c index 64c75cbb2083..d41c770dfbcc 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c +++ b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c @@ -283,6 +283,10 @@ makroom(register DBM *db, long int hash, int need) { long newp; char twin[PBLKSIZ]; +#if defined(DOSISH) || defined(WIN32) + char zer[PBLKSIZ]; + long oldtail; +#endif char *pag = db->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/contrib/perl5/ext/SDBM_File/typemap b/contrib/perl5/ext/SDBM_File/typemap index eeb5d59027f5..40b95f22c022 100644 --- a/contrib/perl5/ext/SDBM_File/typemap +++ b/contrib/perl5/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/contrib/perl5/ext/Socket/Socket.pm b/contrib/perl5/ext/Socket/Socket.pm index 02f098df77c9..d89b2f66b378 100644 --- a/contrib/perl5/ext/Socket/Socket.pm +++ b/contrib/perl5/ext/Socket/Socket.pm @@ -111,7 +111,7 @@ to inet_aton('255.255.255.255'). =item sockaddr_in SOCKADDR_IN -In an array context, unpacks its SOCKADDR_IN argument and returns an array +In a list context, unpacks its SOCKADDR_IN argument and returns an array consisting of (PORT, ADDRESS). In a scalar context, packs its (PORT, ADDRESS) arguments as a SOCKADDR_IN and returns it. If this is confusing, use pack_sockaddr_in() and unpack_sockaddr_in() explicitly. @@ -135,7 +135,7 @@ Will croak if the structure does not have AF_INET in the right place. =item sockaddr_un SOCKADDR_UN -In an array context, unpacks its SOCKADDR_UN argument and returns an array +In a list context, unpacks its SOCKADDR_UN argument and returns an array consisting of (PATHNAME). In a scalar context, packs its PATHNAME arguments as a SOCKADDR_UN and returns it. If this is confusing, use pack_sockaddr_un() and unpack_sockaddr_un() explicitly. @@ -268,6 +268,7 @@ use XSLoader (); SO_RCVLOWAT SO_RCVTIMEO SO_REUSEADDR + SO_REUSEPORT SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO diff --git a/contrib/perl5/ext/Socket/Socket.xs b/contrib/perl5/ext/Socket/Socket.xs index 0584e785b529..e08982909b56 100644 --- a/contrib/perl5/ext/Socket/Socket.xs +++ b/contrib/perl5/ext/Socket/Socket.xs @@ -1006,12 +1006,15 @@ unpack_sockaddr_un(sun_sv) STRLEN sockaddrlen; char * sun_ad = SvPV(sun_sv,sockaddrlen); char * e; - +# ifndef __linux__ + /* On Linux sockaddrlen on sockets returned by accept, recvfrom, + getpeername and getsockname is not equal to sizeof(addr). */ if (sockaddrlen != sizeof(addr)) { croak("Bad arg length for %s, length is %d, should be %d", "Socket::unpack_sockaddr_un", sockaddrlen, sizeof(addr)); } +# endif Copy( sun_ad, &addr, sizeof addr, char ); diff --git a/contrib/perl5/ext/Sys/Syslog/Syslog.pm b/contrib/perl5/ext/Sys/Syslog/Syslog.pm index 2a91354e8792..92b82a1acdce 100644 --- a/contrib/perl5/ext/Sys/Syslog/Syslog.pm +++ b/contrib/perl5/ext/Sys/Syslog/Syslog.pm @@ -70,9 +70,11 @@ Sets the socket type to be used for the next call to C<openlog()> or C<syslog()> and returns TRUE on success, undef on failure. -A value of 'unix' will connect to the UNIX domain socket returned by -C<_PATH_LOG> in F<syslog.ph>. A value of 'inet' will connect to an -INET socket returned by getservbyname(). Any other value croaks. +A value of 'unix' will connect to the UNIX domain socket returned by the +C<_PATH_LOG> macro (if you system defines it) in F<syslog.h>. A value of +'inet' will connect to an INET socket returned by getservbyname(). If +C<_PATH_LOG> is unavailable or if getservbyname() fails, returns undef. Any +other value croaks. The default is for the INET socket to be used. @@ -107,10 +109,15 @@ L<syslog(3)> =head1 AUTHOR -Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<larry@wall.org>E<gt>. -UNIX domain sockets added by Sean Robinson E<lt>F<robinson_s@sc.maricopa.edu>E<gt> -with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list. -Dependency on F<syslog.ph> replaced with XS code bu Tom Hughes E<lt>F<tom@compton.nu>E<gt>. +Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall +E<lt>F<larry@wall.org>E<gt>. + +UNIX domain sockets added by Sean Robinson +E<lt>F<robinson_s@sc.maricopa.edu>E<gt> with support from Tim Bunce +E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and the perl5-porters mailing list. + +Dependency on F<syslog.ph> replaced with XS code by Tom Hughes +E<lt>F<tom@compton.nu>E<gt>. =cut @@ -159,7 +166,7 @@ sub setlogsock { local($setsock) = shift; &disconnect if $connected; if (lc($setsock) eq 'unix') { - if (defined &_PATH_LOG) { + if (length _PATH_LOG()) { $sock_type = 1; } else { return undef; @@ -244,9 +251,9 @@ sub syslog { else { if (open(CONS,">/dev/console")) { print CONS "<$facility.$priority>$whoami: $message\r"; - exit if defined $pid; # if fork failed, we're parent close CONS; } + exit if defined $pid; # if fork failed, we're parent } } } @@ -267,14 +274,15 @@ 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: $!"; connect(SYSLOG,$that) || croak "connect: $!"; } else { - my $syslog = &_PATH_LOG || croak "_PATH_LOG not found in syslog.ph"; + my $syslog = _PATH_LOG(); + length($syslog) || croak "_PATH_LOG unavailable in syslog.h"; my $that = sockaddr_un($syslog) || croak "Can't locate $syslog"; socket(SYSLOG,AF_UNIX,SOCK_STREAM,0) || croak "socket: $!"; if (!connect(SYSLOG,$that)) { diff --git a/contrib/perl5/ext/Sys/Syslog/Syslog.xs b/contrib/perl5/ext/Sys/Syslog/Syslog.xs index f0573b8109aa..31c0e845a2de 100644 --- a/contrib/perl5/ext/Sys/Syslog/Syslog.xs +++ b/contrib/perl5/ext/Sys/Syslog/Syslog.xs @@ -550,8 +550,7 @@ _PATH_LOG() #ifdef _PATH_LOG RETVAL = _PATH_LOG; #else - croak("Your vendor has not defined the Sys::Syslog macro _PATH_LOG"); - RETVAL = NULL; + RETVAL = ""; #endif OUTPUT: RETVAL diff --git a/contrib/perl5/ext/Thread/Thread.pm b/contrib/perl5/ext/Thread/Thread.pm index 00cba8af6736..23f9fe513845 100644 --- a/contrib/perl5/ext/Thread/Thread.pm +++ b/contrib/perl5/ext/Thread/Thread.pm @@ -12,6 +12,15 @@ $VERSION = "1.0"; Thread - manipulate threads in Perl (EXPERIMENTAL, subject to change) +=head1 CAVEAT + +The Thread extension requires Perl to be built in a particular way to +enable the older 5.005 threading model. Just to confuse matters, there +is an alternate threading model known as "ithreads" that does NOT +support this extension. If you are using a binary distribution such +as ActivePerl that is built with ithreads support, this extension CANNOT +be used. + =head1 SYNOPSIS use Thread; @@ -130,7 +139,7 @@ signal is discarded. =item cond_broadcast VARIABLE -The C<cond_broadcast> function works similarly to C<cond_wait>. +The C<cond_broadcast> function works similarly to C<cond_signal>. C<cond_broadcast>, though, will unblock B<all> the threads that are blocked in a C<cond_wait> on the locked variable, rather than only one. diff --git a/contrib/perl5/ext/Thread/Thread.xs b/contrib/perl5/ext/Thread/Thread.xs index 4b5e6db9f869..15e2aa27c3ad 100644 --- a/contrib/perl5/ext/Thread/Thread.xs +++ b/contrib/perl5/ext/Thread/Thread.xs @@ -21,7 +21,7 @@ static int sig_pipe[2]; #endif static void -remove_thread(pTHX_ struct perl_thread *t) +remove_thread(pTHX_ Thread t) { #ifdef USE_THREADS DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log, @@ -82,7 +82,7 @@ threadstart(void *arg) #else Thread thr = (Thread) arg; LOGOP myop; - djSP; + dSP; I32 oldmark = TOPMARK; I32 oldscope = PL_scopestack_ix; I32 retval; @@ -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))); @@ -323,7 +321,13 @@ newthread (pTHX_ SV *startsv, AV *initargs, char *classname) return sv; #else - croak("No threads in this perl"); +# ifdef USE_ITHREADS + croak("This perl was built for \"ithreads\", which currently does not support Thread.pm.\n" + "Run \"perldoc Thread\" for more information"); +# else + croak("This perl was not built with support for 5.005-style threads.\n" + "Run \"perldoc Thread\" for more information"); +# endif return &PL_sv_undef; #endif } diff --git a/contrib/perl5/ext/re/Makefile.PL b/contrib/perl5/ext/re/Makefile.PL index bd0f1f741c19..bc31b2c2cc6d 100644 --- a/contrib/perl5/ext/re/Makefile.PL +++ b/contrib/perl5/ext/re/Makefile.PL @@ -1,4 +1,6 @@ use ExtUtils::MakeMaker; +use File::Spec; + WriteMakefile( NAME => 're', VERSION_FROM => 're.pm', @@ -9,33 +11,28 @@ WriteMakefile( clean => { FILES => '*$(OBJ_EXT) *.c ../../lib/re.pm' }, ); -sub MY::postamble { - if ($^O eq 'VMS') { - return <<'VMS_EOF'; -re_comp.c : [--]regcomp.c - - $(RM_F) $(MMS$TARGET_NAME) - $(CP) [--]regcomp.c $(MMS$TARGET_NAME) +package MY; -re_comp$(OBJ_EXT) : re_comp.c +sub upupfile { + File::Spec->catfile(File::Spec->updir, File::Spec->updir, $_[0]); +} -re_exec.c : [--]regexec.c - - $(RM_F) $(MMS$TARGET_NAME) - $(CP) [--]regexec.c $(MMS$TARGET_NAME) +sub postamble { + my $regcomp_c = upupfile('regcomp.c'); + my $regexec_c = upupfile('regexec.c'); -re_exec$(OBJ_EXT) : re_exec.c + <<EOF; +re_comp.c : $regcomp_c + - \$(RM_F) re_comp.c + \$(CP) $regcomp_c re_comp.c +re_comp\$(OBJ_EXT) : re_comp.c -VMS_EOF - } else { - return <<'EOF'; -re_comp.c: ../../regcomp.c - -$(RM_F) $@ - $(CP) ../../regcomp.c $@ +re_exec.c : $regexec_c + - \$(RM_F) re_exec.c + \$(CP) $regexec_c re_exec.c -re_exec.c: ../../regexec.c - -$(RM_F) $@ - $(CP) ../../regexec.c $@ +re_exec\$(OBJ_EXT) : re_exec.c EOF - } } diff --git a/contrib/perl5/ext/re/re.xs b/contrib/perl5/ext/re/re.xs index 04a5fdc7420e..25c2a90d60f1 100644 --- a/contrib/perl5/ext/re/re.xs +++ b/contrib/perl5/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/contrib/perl5/form.h b/contrib/perl5/form.h index ca2a0c8433ef..d9f83f07e290 100644 --- a/contrib/perl5/form.h +++ b/contrib/perl5/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. diff --git a/contrib/perl5/global.sym b/contrib/perl5/global.sym index 95e7775609cb..2028723a6147 100644 --- a/contrib/perl5/global.sym +++ b/contrib/perl5/global.sym @@ -21,6 +21,7 @@ Perl_get_context Perl_set_context Perl_amagic_call Perl_Gv_AMupdate +Perl_apply_attrs_string Perl_avhv_delete_ent Perl_avhv_exists_ent Perl_avhv_fetch_ent @@ -32,7 +33,6 @@ Perl_av_clear Perl_av_delete Perl_av_exists Perl_av_extend -Perl_av_fake Perl_av_fetch Perl_av_fill Perl_av_len @@ -68,6 +68,7 @@ Perl_sv_setpvf_nocontext Perl_sv_catpvf_mg_nocontext Perl_sv_setpvf_mg_nocontext Perl_fprintf_nocontext +Perl_printf_nocontext Perl_cv_const_sv Perl_cv_undef Perl_cx_dump @@ -88,6 +89,7 @@ Perl_die Perl_dounwind Perl_do_binmode Perl_do_close +Perl_do_join Perl_do_open Perl_do_open9 Perl_dowantarray @@ -114,6 +116,7 @@ Perl_gv_autoload4 Perl_gv_check Perl_gv_efullname Perl_gv_efullname3 +Perl_gv_efullname4 Perl_gv_fetchfile Perl_gv_fetchmeth Perl_gv_fetchmethod @@ -121,6 +124,7 @@ Perl_gv_fetchmethod_autoload Perl_gv_fetchpv Perl_gv_fullname Perl_gv_fullname3 +Perl_gv_fullname4 Perl_gv_init Perl_gv_stashpv Perl_gv_stashpvn @@ -184,6 +188,7 @@ Perl_to_uni_upper_lc Perl_to_uni_title_lc Perl_to_uni_lower_lc Perl_is_utf8_char +Perl_is_utf8_string Perl_is_utf8_alnum Perl_is_utf8_alnumc Perl_is_utf8_idfirst @@ -320,6 +325,7 @@ Perl_regexec_flags Perl_regnext Perl_repeatcpy Perl_rninstr +Perl_rsignal Perl_savepv Perl_savepvn Perl_savestack_grow @@ -334,6 +340,7 @@ Perl_save_destructor_x Perl_save_freesv Perl_save_freepv Perl_save_generic_svref +Perl_save_generic_pvref Perl_save_gp Perl_save_hash Perl_save_helem @@ -347,11 +354,13 @@ Perl_save_item Perl_save_iv Perl_save_list Perl_save_long +Perl_save_mortalizesv Perl_save_nogv 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 @@ -455,14 +464,20 @@ 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_from_utf8 +Perl_bytes_to_utf8 +Perl_utf8_to_uv_simple Perl_utf8_to_uv Perl_uv_to_utf8 Perl_warn Perl_vwarn Perl_warner Perl_vwarner +Perl_whichsig Perl_dump_mstats Perl_get_mstats Perl_safesysmalloc @@ -476,6 +491,7 @@ Perl_safexfree Perl_GetVars Perl_runops_standard Perl_runops_debug +Perl_sv_lock Perl_sv_catpvf_mg Perl_sv_vcatpvf_mg Perl_sv_catpv_mg @@ -516,6 +532,8 @@ Perl_sv_utf8_downgrade Perl_sv_utf8_encode Perl_sv_utf8_decode Perl_sv_force_normal +Perl_sv_add_backref +Perl_sv_del_backref Perl_tmps_grow Perl_sv_rvweaken Perl_newANONATTRSUB @@ -537,3 +555,7 @@ Perl_ptr_table_new Perl_ptr_table_fetch Perl_ptr_table_store Perl_ptr_table_split +Perl_ptr_table_clear +Perl_ptr_table_free +Perl_sys_intern_clear +Perl_sys_intern_init diff --git a/contrib/perl5/globals.c b/contrib/perl5/globals.c index 0782eba226f6..5bf4aeabcbdb 100644 --- a/contrib/perl5/globals.c +++ b/contrib/perl5/globals.c @@ -79,4 +79,13 @@ Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...) return PerlIO_vprintf(stream, format, arglist); } +int +Perl_printf_nocontext(const char *format, ...) +{ + dTHX; + va_list(arglist); + va_start(arglist, format); + return PerlIO_vprintf(PerlIO_stdout(), format, arglist); +} + #include "perlapi.h" /* bring in PL_force_link_funcs */ diff --git a/contrib/perl5/gv.c b/contrib/perl5/gv.c index be1935560e43..984ce51cd99c 100644 --- a/contrib/perl5/gv.c +++ b/contrib/perl5/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; @@ -75,7 +74,7 @@ Perl_gv_fetchfile(pTHX_ const char *name) gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); sv_setpv(GvSV(gv), name); if (PERLDB_LINE) - hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L'); + hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, 'L'); } if (tmpbuf != smallbuf) Safefree(tmpbuf); @@ -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; @@ -106,7 +104,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : ""; GvCVGEN(gv) = 0; GvEGV(gv) = gv; - sv_magic((SV*)gv, (SV*)gv, '*', name, len); + sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0); GvSTASH(gv) = (HV*)SvREFCNT_inc(stash); GvNAME(gv) = savepvn(name, len); GvNAMELEN(gv) = len; @@ -121,7 +119,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) LEAVE; PL_sub_generation++; - CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv); + CvGV(GvCV(gv)) = gv; CvFILE(GvCV(gv)) = CopFILE(PL_curcop); CvSTASH(GvCV(gv)) = PL_curstash; #ifdef USE_THREADS @@ -159,18 +157,18 @@ S_gv_init_sv(pTHX_ GV *gv, I32 sv_type) Returns the glob with the given C<name> and a defined subroutine or C<NULL>. The glob lives in the given C<stash>, or in the stashes -accessible via @ISA and @UNIVERSAL. +accessible via @ISA and @UNIVERSAL. The argument C<level> should be either 0 or -1. If C<level==0>, as a side-effect creates a glob with the given C<name> in the given C<stash> which in the case of success contains an alias for the subroutine, and sets -up caching info for this glob. Similarly for all the searched stashes. +up caching info for this glob. Similarly for all the searched stashes. This function grants C<"SUPER"> token as a postfix of the stash name. The GV returned from C<gv_fetchmeth> may be a method cache entry, which is not visible to Perl code. So when calling C<call_sv>, you should not use the GV directly; instead, you should use the method's CV, which can be -obtained from the GV with the C<GvCV> macro. +obtained from the GV with the C<GvCV> macro. =cut */ @@ -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)); @@ -317,24 +313,24 @@ Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name) Returns the glob which contains the subroutine to call to invoke the method on the C<stash>. In fact in the presence of autoloading this may be the glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is -already setup. +already setup. The third parameter of C<gv_fetchmethod_autoload> determines whether AUTOLOAD lookup is performed if the given method is not present: non-zero -means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. +means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload> -with a non-zero C<autoload> parameter. +with a non-zero C<autoload> parameter. These functions grant C<"SUPER"> token as a prefix of the method name. Note that if you want to keep the returned glob for a long time, you need to check for it being "AUTOLOAD", since at the later time the call may load a different subroutine due to $AUTOLOAD changing its value. Use the glob -created via a side effect to do this. +created via a side effect to do this. These functions have the same side-effects and as C<gv_fetchmeth> with C<level==0>. C<name> should be writable if contains C<':'> or C<' ''>. The warning against passing the GV returned by C<gv_fetchmeth> to -C<call_sv> apply equally to these functions. +C<call_sv> apply equally to these functions. =cut */ @@ -342,11 +338,10 @@ C<call_sv> 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; - + for (nend = name; *nend; nend++) { if (*nend == '\'') nsplit = nend; @@ -372,7 +367,7 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) gv = gv_fetchmeth(stash, name, nend - name, 0); if (!gv) { - if (strEQ(name,"import")) + if (strEQ(name,"import") || strEQ(name,"unimport")) gv = (GV*)&PL_sv_yes; else if (autoload) gv = gv_autoload4(stash, name, nend - name, TRUE); @@ -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,10 +412,13 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) return Nullgv; cv = GvCV(gv); + if (!CvROOT(cv)) + return Nullgv; + /* * Inheriting AUTOLOAD for non-methods works ... for now. */ - if (ckWARN(WARN_DEPRECATED) && !method && + if (ckWARN(WARN_DEPRECATED) && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash)) Perl_warner(aTHX_ WARN_DEPRECATED, "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", @@ -435,9 +432,18 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) */ varstash = GvSTASH(CvGV(cv)); vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); + ENTER; + +#ifdef USE_THREADS + sv_lock((SV *)varstash); +#endif if (!isGV(vargv)) gv_init(vargv, varstash, autoload, autolen, FALSE); + LEAVE; varsv = GvSV(vargv); +#ifdef USE_THREADS + sv_lock(varsv); +#endif sv_setpv(varsv, HvNAME(stash)); sv_catpvn(varsv, "::", 2); sv_catpvn(varsv, name, len); @@ -513,14 +519,12 @@ 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; I32 len; register const char *namend; HV *stash = 0; - U32 add_gvflags = 0; if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */ name++; @@ -653,8 +657,10 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) : sv_type == SVt_PVAV ? "@" : sv_type == SVt_PVHV ? "%" : ""), name)); + stash = PL_nullstash; } - return Nullgv; + else + return Nullgv; } if (!SvREFCNT(stash)) /* symbol table under destruction */ @@ -680,9 +686,9 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg); gv_init(gv, stash, name, len, add & GV_ADDMULTI); gv_init_sv(gv, sv_type); - GvFLAGS(gv) |= add_gvflags; - if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE)) + if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) + : (PL_dowarn & G_WARN_ON ) ) ) GvMULTI_on(gv) ; /* set up magic where warranted */ @@ -723,7 +729,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) if (strEQ(name, "OVERLOAD")) { HV* hv = GvHVn(gv); GvMULTI_on(gv); - hv_magic(hv, gv, 'A'); + hv_magic(hv, Nullgv, 'A'); } break; case 'S': @@ -737,7 +743,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) } GvMULTI_on(gv); hv = GvHVn(gv); - hv_magic(hv, gv, 'S'); + hv_magic(hv, Nullgv, 'S'); for (i = 1; PL_sig_name[i]; i++) { SV ** init; init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); @@ -807,6 +813,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) else { AV* av = GvAVn(gv); sv_magic((SV*)av, Nullsv, 'D', Nullch, 0); + SvREADONLY_on(av); } goto magicalize; case '#': @@ -827,7 +834,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 */ @@ -841,6 +847,11 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) 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 '\023': /* $^S */ if (len > 1) break; @@ -857,6 +868,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) else { AV* av = GvAVn(gv); sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0); + SvREADONLY_on(av); } /* FALL THROUGH */ case '1': @@ -889,9 +901,16 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) if (len == 1) { SV *sv = GvSV(gv); (void)SvUPGRADE(sv, SVt_PVNV); + Perl_sv_setpvf(aTHX_ sv, +#if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0) + "%8.6" +#else + "%5.3" +#endif + NVff, + SvNVX(PL_patchlevel)); SvNVX(sv) = SvNVX(PL_patchlevel); SvNOK_on(sv); - (void)SvPV_nolen(sv); SvREADONLY_on(sv); } break; @@ -907,6 +926,22 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) } void +Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain) +{ + HV *hv = GvSTASH(gv); + if (!hv) { + (void)SvOK_off(sv); + return; + } + sv_setpv(sv, prefix ? prefix : ""); + if (keepmain || strNE(HvNAME(hv), "main")) { + sv_catpv(sv,HvNAME(hv)); + sv_catpvn(sv,"::", 2); + } + sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); +} + +void Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix) { HV *hv = GvSTASH(gv); @@ -921,6 +956,15 @@ Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix) } void +Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain) +{ + GV *egv = GvEGV(gv); + if (!egv) + egv = gv; + gv_fullname4(sv, egv, prefix, keepmain); +} + +void Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix) { GV *egv = GvEGV(gv); @@ -946,7 +990,6 @@ Perl_gv_efullname(pTHX_ SV *sv, GV *gv) IO * Perl_newIO(pTHX) { - dTHR; IO *io; GV *iogv; @@ -965,7 +1008,6 @@ Perl_newIO(pTHX) void Perl_gv_check(pTHX_ HV *stash) { - dTHR; register HE *entry; register I32 i; register GV *gv; @@ -1042,7 +1084,6 @@ Perl_gp_ref(pTHX_ GP *gp) void Perl_gp_free(pTHX_ GV *gv) { - dTHR; GP* gp; if (!gv || !(gp = GvGP(gv))) @@ -1082,7 +1123,7 @@ Perl_gp_free(pTHX_ GV *gv) AV *GvAVn(gv) register GV *gv; { - if (GvGP(gv)->gp_av) + if (GvGP(gv)->gp_av) return GvGP(gv)->gp_av; else return GvGP(gv_AVadd(gv))->gp_av; @@ -1103,7 +1144,6 @@ register GV *gv; bool Perl_Gv_AMupdate(pTHX_ HV *stash) { - dTHR; GV* gv; CV* cv; MAGIC* mg=mg_find((SV*)stash,'c'); @@ -1154,7 +1194,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) for (i = 1; i < NofAMmeth; i++) { cv = 0; cp = (char *)PL_AMG_names[i]; - + svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE); if (svp && ((sv = *svp) != &PL_sv_undef)) { switch (SvTYPE(sv)) { @@ -1224,19 +1264,19 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) /* GvSV contains the name of the method. */ GV *ngv; - DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n", + DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n", SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) ); - if (!SvPOK(GvSV(gv)) + if (!SvPOK(GvSV(gv)) || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)), FALSE))) { /* Can be an import stub (created by `can'). */ if (GvCVGEN(gv)) { - Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'", + Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'", (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), cp, HvNAME(stash)); } else - Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'", + Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'", (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), cp, HvNAME(stash)); } @@ -1247,7 +1287,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) GvNAME(CvGV(cv))) ); filled = 1; } -#endif +#endif amt.table[i]=(CV*)SvREFCNT_inc(cv); } if (filled) { @@ -1266,9 +1306,8 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) SV* Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { - dTHR; - MAGIC *mg; - CV *cv; + MAGIC *mg; + CV *cv; CV **cvp=NULL, **ocvp=NULL; AMT *amtp, *oamtp; int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0; @@ -1276,10 +1315,10 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) HV* stash; if (!(AMGf_noleft & flags) && SvAMAGIC(left) && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c')) - && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) + && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table : (CV **) NULL)) - && ((cv = cvp[off=method+assignshift]) + && ((cv = cvp[off=method+assignshift]) || (assign && amtp->fallback > AMGfallNEVER && /* fallback to * usual method */ (fl = 1, cv = cvp[off=method])))) { @@ -1315,7 +1354,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); break; case not_amg: - (void)((cv = cvp[off=bool__amg]) + (void)((cv = cvp[off=bool__amg]) || (cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); postpr = 1; @@ -1340,7 +1379,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } break; case abs_amg: - if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) + if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { SV* nullsv=sv_2mortal(newSViv(0)); if (off1==lt_amg) { @@ -1371,13 +1410,16 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } break; case iter_amg: /* XXXX Eventually should do to_gv. */ + /* FAIL safe */ + return NULL; /* Delegate operation to standard mechanisms. */ + break; case to_sv_amg: case to_av_amg: case to_hv_amg: case to_gv_amg: case to_cv_amg: /* FAIL safe */ - return NULL; /* Delegate operation to standard mechanisms. */ + return left; /* Delegate operation to standard mechanisms. */ break; default: goto not_found; @@ -1385,14 +1427,14 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (!cv) goto not_found; } else if (!(AMGf_noright & flags) && SvAMAGIC(right) && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c')) - && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) + && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (amtp = (AMT*)mg->mg_ptr)->table : (CV **) NULL)) && (cv = cvp[off=method])) { /* Method for right * argument found */ lr=1; - } else if (((ocvp && oamtp->fallback > AMGfallNEVER - && (cvp=ocvp) && (lr = -1)) + } else if (((ocvp && oamtp->fallback > AMGfallNEVER + && (cvp=ocvp) && (lr = -1)) || (cvp && amtp->fallback > AMGfallNEVER && (lr=1))) && !(flags & AMGf_unary)) { /* We look for substitution for @@ -1425,6 +1467,16 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } } else { not_found: /* No method found, either report or croak */ + switch (method) { + case to_sv_amg: + case to_av_amg: + case to_hv_amg: + case to_gv_amg: + case to_cv_amg: + /* FAIL safe */ + return left; /* Delegate operation to standard mechanisms. */ + break; + } if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ notfound = 1; lr = -1; } else if (cvp && (cv=cvp[nomethod_amg])) { @@ -1432,22 +1484,22 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } else { SV *msg; if (off==-1) off=method; - msg = sv_2mortal(Perl_newSVpvf(aTHX_ + msg = sv_2mortal(Perl_newSVpvf(aTHX_ "Operation `%s': no method found,%sargument %s%s%s%s", PL_AMG_names[method + assignshift], (flags & AMGf_unary ? " " : "\n\tleft "), - SvAMAGIC(left)? + SvAMAGIC(left)? "in overloaded package ": "has no overloaded magic", - SvAMAGIC(left)? + SvAMAGIC(left)? HvNAME(SvSTASH(SvRV(left))): "", - SvAMAGIC(right)? + SvAMAGIC(right)? ",\n\tright argument in overloaded package ": - (flags & AMGf_unary + (flags & AMGf_unary ? "" : ",\n\tright argument has no overloaded magic"), - SvAMAGIC(right)? + SvAMAGIC(right)? HvNAME(SvSTASH(SvRV(right))): "")); if (amtp && amtp->fallback >= AMGfallYES) { @@ -1461,7 +1513,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } } if (!notfound) { - DEBUG_o( Perl_deb(aTHX_ + 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], method+assignshift==off? "" : @@ -1472,7 +1524,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) flags & AMGf_unary? "" : lr==1 ? " for right argument": " for left argument", flags & AMGf_unary? " for argument" : "", - HvNAME(stash), + HvNAME(stash), fl? ",\n\tassignment variant used": "") ); } /* Since we use shallow copy during assignment, we need @@ -1485,10 +1537,10 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) * b) Increment or decrement, called directly. * assignshift==0, assign==0, method + 0 == off * c) Increment or decrement, translated to assignment add/subtr. - * assignshift==0, assign==T, + * assignshift==0, assign==T, * force_cpy == T * d) Increment or decrement, translated to nomethod. - * assignshift==0, assign==0, + * assignshift==0, assign==0, * force_cpy == T * e) Assignment form translated to nomethod. * assignshift==1, assign==T, method + 1 != off @@ -1580,3 +1632,110 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } } } + +/* +=for apidoc is_gv_magical + +Returns C<TRUE> if given the name of a magical GV. + +Currently only useful internally when determining if a GV should be +created even in rvalue contexts. + +C<flags> is not used at present but available for future extension to +allow selecting particular classes of magical variable. + +=cut +*/ +bool +Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) +{ + if (!len) + return FALSE; + + switch (*name) { + case 'I': + if (len == 3 && strEQ(name, "ISA")) + goto yes; + break; + case 'O': + if (len == 8 && strEQ(name, "OVERLOAD")) + goto yes; + break; + case 'S': + if (len == 3 && strEQ(name, "SIG")) + goto yes; + break; + case '\027': /* $^W & $^WARNING_BITS */ + if (len == 1 + || (len == 12 && strEQ(name, "\027ARNING_BITS")) + || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS"))) + { + goto yes; + } + break; + + case '&': + case '`': + case '\'': + case ':': + case '?': + case '!': + case '-': + case '#': + case '*': + case '[': + case '^': + case '~': + case '=': + case '%': + case '.': + case '(': + case ')': + case '<': + case '>': + case ',': + case '\\': + case '/': + case '|': + case '+': + case ';': + case ']': + case '\001': /* $^A */ + case '\003': /* $^C */ + case '\004': /* $^D */ + case '\005': /* $^E */ + case '\006': /* $^F */ + case '\010': /* $^H */ + case '\011': /* $^I, NOT \t in EBCDIC */ + case '\014': /* $^L */ + case '\017': /* $^O */ + case '\020': /* $^P */ + case '\023': /* $^S */ + case '\024': /* $^T */ + case '\026': /* $^V */ + if (len == 1) + goto yes; + break; + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + if (len > 1) { + char *end = name + len; + while (--end > name) { + if (!isDIGIT(*end)) + return FALSE; + } + } + yes: + return TRUE; + default: + break; + } + return FALSE; +} diff --git a/contrib/perl5/gv.h b/contrib/perl5/gv.h index d2234a69b47b..07a04b67cb6f 100644 --- a/contrib/perl5/gv.h +++ b/contrib/perl5/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/contrib/perl5/handy.h b/contrib/perl5/handy.h index 2c5d706de48f..d71d84a2f51d 100644 --- a/contrib/perl5/handy.h +++ b/contrib/perl5/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. @@ -48,10 +48,10 @@ Null SV pointer. just figure out all the headers such a test needs. Andy Dougherty August 1996 */ -/* bool is built-in for g++-2.6.3 and later, which might be used +/* bool is built-in for g++-2.6.3 and later, which might be used for extensions. <_G_config.h> defines _G_HAVE_BOOL, but we can't be sure _G_config.h will be included before this file. _G_config.h - also defines _G_HAVE_BOOL for both gcc and g++, but only g++ + also defines _G_HAVE_BOOL for both gcc and g++, but only g++ actually has bool. Hence, _G_HAVE_BOOL is pretty useless for us. g++ can be identified by __GNUG__. Andy Dougherty February 2000 @@ -101,8 +101,8 @@ Null SV pointer. Similarly, there is no guarantee that I16 and U16 have exactly 16 bits. - For dealing with issues that may arise from various 32/64-bit - systems, we will ask Configure to check out + For dealing with issues that may arise from various 32/64-bit + systems, we will ask Configure to check out SHORTSIZE == sizeof(short) INTSIZE == sizeof(int) @@ -114,6 +114,10 @@ Null SV pointer. */ +#ifdef I_INTTYPES /* e.g. Linux has int64_t without <inttypes.h> */ +# include <inttypes.h> +#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 <sys/types.h> -# ifdef I_INTTYPES /* e.g. Linux has int64_t without <inttypes.h> */ -# include <inttypes.h> -# 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 <inttypes.h> */ +# 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. */ @@ -260,18 +275,18 @@ C<strncmp>). /* =for apidoc Am|bool|isALNUM|char ch -Returns a boolean indicating whether the C C<char> is an ascii alphanumeric -character or digit. +Returns a boolean indicating whether the C C<char> is an ASCII alphanumeric +character (including underscore) or digit. =for apidoc Am|bool|isALPHA|char ch -Returns a boolean indicating whether the C C<char> is an ascii alphabetic +Returns a boolean indicating whether the C C<char> is an ASCII alphabetic character. =for apidoc Am|bool|isSPACE|char ch Returns a boolean indicating whether the C C<char> is whitespace. =for apidoc Am|bool|isDIGIT|char ch -Returns a boolean indicating whether the C C<char> is an ascii +Returns a boolean indicating whether the C C<char> is an ASCII digit. =for apidoc Am|bool|isUPPER|char ch @@ -296,6 +311,8 @@ Converts the specified character to lowercase. #define isALPHA(c) (isUPPER(c) || isLOWER(c)) #define isSPACE(c) \ ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) =='\r' || (c) == '\f') +#define isPSXSPC(c) (isSPACE(c) || (c) == '\v') +#define isBLANK(c) ((c) == ' ' || (c) == '\t') #define isDIGIT(c) ((c) >= '0' && (c) <= '9') #ifdef EBCDIC /* In EBCDIC we do not do locales: therefore() isupper() is fine. */ @@ -382,6 +399,9 @@ Converts the specified character to lowercase. # endif #endif /* USE_NEXT_CTYPE */ +#define isPSXSPC_LC(c) (isSPACE_LC(c) || (c) == '\v') +#define isBLANK_LC(c) isBLANK(c) /* could be wrong */ + #define isALNUM_uni(c) is_uni_alnum(c) #define isIDFIRST_uni(c) is_uni_idfirst(c) #define isALPHA_uni(c) is_uni_alpha(c) @@ -400,6 +420,9 @@ Converts the specified character to lowercase. #define toTITLE_uni(c) to_uni_title(c) #define toLOWER_uni(c) to_uni_lower(c) +#define isPSXSPC_uni(c) (isSPACE_uni(c) ||(c) == '\f') +#define isBLANK_uni(c) isBLANK(c) /* could be wrong */ + #define isALNUM_LC_uni(c) (c < 256 ? isALNUM_LC(c) : is_uni_alnum_lc(c)) #define isIDFIRST_LC_uni(c) (c < 256 ? isIDFIRST_LC(c) : is_uni_idfirst_lc(c)) #define isALPHA_LC_uni(c) (c < 256 ? isALPHA_LC(c) : is_uni_alpha_lc(c)) @@ -416,6 +439,9 @@ Converts the specified character to lowercase. #define toTITLE_LC_uni(c) (c < 256 ? toUPPER_LC(c) : to_uni_title_lc(c)) #define toLOWER_LC_uni(c) (c < 256 ? toLOWER_LC(c) : to_uni_lower_lc(c)) +#define isPSXSPC_LC_uni(c) (isSPACE_LC_uni(c) ||(c) == '\f') +#define isBLANK_LC_uni(c) isBLANK(c) /* could be wrong */ + #define isALNUM_utf8(p) is_utf8_alnum(p) #define isIDFIRST_utf8(p) is_utf8_idfirst(p) #define isALPHA_utf8(p) is_utf8_alpha(p) @@ -434,25 +460,30 @@ Converts the specified character to lowercase. #define toTITLE_utf8(p) to_utf8_title(p) #define toLOWER_utf8(p) to_utf8_lower(p) -#define isALNUM_LC_utf8(p) isALNUM_LC_uni(utf8_to_uv(p, 0)) -#define isIDFIRST_LC_utf8(p) isIDFIRST_LC_uni(utf8_to_uv(p, 0)) -#define isALPHA_LC_utf8(p) isALPHA_LC_uni(utf8_to_uv(p, 0)) -#define isSPACE_LC_utf8(p) isSPACE_LC_uni(utf8_to_uv(p, 0)) -#define isDIGIT_LC_utf8(p) isDIGIT_LC_uni(utf8_to_uv(p, 0)) -#define isUPPER_LC_utf8(p) isUPPER_LC_uni(utf8_to_uv(p, 0)) -#define isLOWER_LC_utf8(p) isLOWER_LC_uni(utf8_to_uv(p, 0)) -#define isALNUMC_LC_utf8(p) isALNUMC_LC_uni(utf8_to_uv(p, 0)) -#define isCNTRL_LC_utf8(p) isCNTRL_LC_uni(utf8_to_uv(p, 0)) -#define isGRAPH_LC_utf8(p) isGRAPH_LC_uni(utf8_to_uv(p, 0)) -#define isPRINT_LC_utf8(p) isPRINT_LC_uni(utf8_to_uv(p, 0)) -#define isPUNCT_LC_utf8(p) isPUNCT_LC_uni(utf8_to_uv(p, 0)) -#define toUPPER_LC_utf8(p) toUPPER_LC_uni(utf8_to_uv(p, 0)) -#define toTITLE_LC_utf8(p) toTITLE_LC_uni(utf8_to_uv(p, 0)) -#define toLOWER_LC_utf8(p) toLOWER_LC_uni(utf8_to_uv(p, 0)) +#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(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 */ #ifdef EBCDIC -EXT int ebcdic_control (int); -# define toCTRL(c) ebcdic_control(c) +# define toCTRL(c) Perl_ebcdic_control(c) #else /* This conversion works both ways, strangely enough. */ # define toCTRL(c) (toUPPER(c) ^ 64) @@ -467,7 +498,7 @@ typedef U16 line_t; #endif -/* +/* XXX LEAKTEST doesn't really work in perl5. There are direct calls to safemalloc() in the source, so LEAKTEST won't pick them up. (The main "offenders" are extensions.) @@ -484,7 +515,7 @@ typedef U16 line_t; Creates a new SV. A non-zero C<len> parameter indicates the number of bytes of preallocated string space the SV should have. An extra byte for a tailing NUL is also reserved. (SvPOK is not set for the SV even if string -space is allocated.) The reference count for the new SV is set to 1. +space is allocated.) The reference count for the new SV is set to 1. C<id> is an integer id between 0 and 1299 (used to identify leaks). =for apidoc Am|void|New|int id|void* ptr|int nitems|type @@ -505,7 +536,7 @@ The XSUB-writer's interface to the C C<realloc> function. The XSUB-writer's interface to the C C<realloc> function, with cast. -=for apidoc Am|void|Safefree|void* src|void* dest|int nitems|type +=for apidoc Am|void|Safefree|void* ptr The XSUB-writer's interface to the C C<free> function. =for apidoc Am|void|Move|void* src|void* dest|int nitems|type @@ -524,7 +555,7 @@ The XSUB-writer's interface to the C C<memzero> function. The C<dest> is the destination, C<nitems> is the number of items, and C<type> is the type. =for apidoc Am|void|StructCopy|type src|type dest|type -This is an architecture-independant macro to copy one structure to another. +This is an architecture-independent macro to copy one structure to another. =cut */ diff --git a/contrib/perl5/hints/README.hints b/contrib/perl5/hints/README.hints index 5f23b29c2cbd..066677195258 100644 --- a/contrib/perl5/hints/README.hints +++ b/contrib/perl5/hints/README.hints @@ -9,7 +9,7 @@ can't or doesn't guess properly. Most of these hint files have been tested with at least some version of perl5, but some are still left over from perl4. -Please send any problems or suggested changes to perlbug@perl.com. +Please send any problems or suggested changes to perlbug@perl.org. =head1 Hint file naming convention. diff --git a/contrib/perl5/hints/aix.sh b/contrib/perl5/hints/aix.sh index d6f3dd78e0f0..25a15e497984 100644 --- a/contrib/perl5/hints/aix.sh +++ b/contrib/perl5/hints/aix.sh @@ -128,6 +128,13 @@ d_setreuid='undef' # Tell perl which symbols to export for dynamic linking. case "$cc" in *gcc*) ccdlflags='-Xlinker' ;; +*) ccversion=`lslpp -L | grep 'C for AIX Compiler$' | awk '{print $2}'` + case "$ccversion" in + 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." + ;; + esac esac # the required -bE:$installarchlib/CORE/perl.exp is added by # libperl.U (Configure) later. @@ -149,6 +156,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. @@ -171,9 +192,9 @@ $define|true|[yY]*) ;; *) cat >&4 <<EOM -For pthreads you should use the AIX C compiler cc_r. -(now your compiler was set to '$cc') -Cannot continue, aborting. +*** For pthreads you should use the AIX C compiler cc_r. +*** (now your compiler was set to '$cc') +*** Cannot continue, aborting. EOM exit 1 ;; @@ -206,31 +227,47 @@ EOCBU cat > UU/uselargefiles.cbu <<'EOCBU' case "$uselargefiles" in ''|$define|true|[yY]*) - lfcflags="`getconf XBS5_ILP32_OFFBIG_CFLAGS 2>/dev/null`" - lfldflags="`getconf XBS5_ILP32_OFFBIG_LDFLAGS 2>/dev/null`" +# Keep these at the left margin. +ccflags_uselargefiles="`getconf XBS5_ILP32_OFFBIG_CFLAGS 2>/dev/null`" +ldflags_uselargefiles="`getconf XBS5_ILP32_OFFBIG_LDFLAGS 2>/dev/null`" # _Somehow_ in AIX 4.3.1.0 the above getconf call manages to # insert(?) *something* to $ldflags so that later (in Configure) evaluating # $ldflags causes a newline after the '-b64' (the result of the getconf). # (nothing strange shows up in $ldflags even in hexdump; - # so it may be something in the shell, instead?) + # so it may be something (a bug) in the shell, instead?) # Try it out: just uncomment the below line and rerun Configure: -# echo >&4 "AIX 4.3.1.0 $lfldflags mystery" ; exit 1 +# echo >&4 "AIX 4.3.1.0 $ldflags_uselargefiles mystery" ; exit 1 # Just don't ask me how AIX does it, I spent hours wondering. - # Therefore the line re-evaluating lfldflags: it seems to fix + # Therefore the line re-evaluating ldflags_uselargefiles: it seems to fix # the whatever it was that AIX managed to break. --jhi - lfldflags="`echo $lfldflags`" - lflibs="`getconf XBS5_ILP32_OFFBIG_LIBS 2>/dev/null|sed -e 's@^-l@@' -e 's@ -l@ @g`" - case "$lfcflags$lfldflags$lflibs" in + ldflags_uselargefiles="`echo $ldflags_uselargefiles`" +# Keep this at the left margin. +libswanted_uselargefiles="`getconf XBS5_ILP32_OFFBIG_LIBS 2>/dev/null|sed -e 's@^-l@@' -e 's@ -l@ @g`" + case "$ccflags_uselargefiles$ldflags_uselargefiles$libs_uselargefiles" in '');; - *) ccflags="$ccflags $lfcflags" - ldflags="$ldflags $lfldflags" - libswanted="$libswanted $lflibs" + *) ccflags="$ccflags $ccflags_uselargefiles" + ldflags="$ldflags $ldflags_uselargefiles" + libswanted="$libswanted $libswanted_uselargefiles" ;; esac - lfcflags='' - lfldflags='' - lflibs='' - ;; + case "$gccversion" in + '') ;; + *) + cat >&4 <<EOM + +*** Warning: gcc in AIX might not work with the largefile support of Perl +*** (default since 5.6.0), this combination hasn't been tested. +*** I will try, though. + +EOM + # Remove xlc-spefific -qflags. + ccflags="`echo $ccflags | sed -e 's@ -q[^ ]*@ @g' -e 's@^-q[^ ]* @@g'`" + ldflags="`echo $ldflags | sed -e 's@ -q[^ ]*@ @g' -e 's@^-q[^ ]* @@g'`" + echo >&4 "(using ccflags $ccflags)" + echo >&4 "(using ldflags $ldflags)" + ;; + esac + ;; esac EOCBU @@ -279,18 +316,18 @@ int main (void) EOCP set size if eval $compile_ok; then - lfcpuwidth=`./size` - echo "You are running on $lfcpuwidth bit hardware." + qacpuwidth=`./size` + echo "You are running on $qacpuwidth bit hardware." else dflt="32" echo " " echo "(I can't seem to compile the test program. Guessing...)" rp="What is the width of your CPU (in bits)?" . ./myread - lfcpuwidth="$ans" + qacpuwidth="$ans" fi $rm -f size.c size - case "$lfcpuwidth" in + case "$qacpuwidth" in 32*) cat >&4 <<EOM Bzzzt! At present, you can only perform a @@ -299,8 +336,8 @@ EOM exit 1 ;; esac - lfcflags="`getconf XBS5_LP64_OFF64_CFLAGS 2>/dev/null`" - lfldflags="`getconf XBS5_LP64_OFF64_LDFLAGS 2>/dev/null`" + qacflags="`getconf XBS5_LP64_OFF64_CFLAGS 2>/dev/null`" + qaldflags="`getconf XBS5_LP64_OFF64_LDFLAGS 2>/dev/null`" # See jhi's comments above regarding this re-eval. I've # seen similar weirdness in the form of: # @@ -309,8 +346,8 @@ EOM # error messages from 'cc -E' invocation. Again, the offending # string is simply not detectable by any means. Since it doesn't # do any harm, I didn't pursue it. -- sh - lfldflags="`echo $lfldflags`" - lflibs="`getconf XBS5_LP64_OFF64_LIBS 2>/dev/null|sed -e 's@^-l@@' -e 's@ -l@ @g`" + qaldflags="`echo $qaldflags`" + qalibs="`getconf XBS5_LP64_OFF64_LIBS 2>/dev/null|sed -e 's@^-l@@' -e 's@ -l@ @g`" # -q32 and -b32 may have been set by uselargefiles or user. # Remove them. ccflags="`echo $ccflags | sed -e 's@-q32@@'`" @@ -322,15 +359,15 @@ EOM trylist="`echo $trylist | sed -e 's@^ar @@' -e 's@ ar @ @g' -e 's@ ar$@@'`" ar="ar -X64" nm_opt="-X64 $nm_opt" - # Note: Placing the 'lfcflags' variable into the 'ldflags' string - # is NOT a typo. ldlflags is passed to the C compiler for final + # Note: Placing the 'qacflags' variable into the 'ldflags' string + # is NOT a typo. ldflags is passed to the C compiler for final # linking, and it wants -q64 (-b64 is for ld only!). - case "$lfcflags$lfldflags$lflibs" in + case "$qacflags$qaldflags$qalibs" in '');; - *) ccflags="$ccflags $lfcflags" - ldflags="$ldflags $lfcflags" - lddlflags="$lfldflags $lddlflags" - libswanted="$libswanted $lflibs" + *) ccflags="$ccflags $qacflags" + ldflags="$ldflags $qacflags" + lddlflags="$qaldflags $lddlflags" + libswanted="$libswanted $qalibs" ;; esac case "$ccflags" in @@ -344,10 +381,10 @@ EOM # Don't try backwards compatibility bincompat="$undef" d_bincompat5005="$undef" - lfcflags='' - lfldflags='' - lflibs='' - lfcpuwidth='' + qacflags='' + qaldflags='' + qalibs='' + qacpuwidth='' ;; esac EOCBU @@ -357,7 +394,10 @@ cat > UU/uselongdouble.cbu <<'EOCBU' # after it has prompted the user for whether to use long doubles. case "$uselongdouble" in $define|true|[yY]*) - ccflags="$ccflags -qlongdouble" + case "$cc" in + *gcc*) ;; + *) ccflags="$ccflags -qlongdouble" ;; + esac # The explicit cc128, xlc128, xlC128 are not needed, # the -qlongdouble should do the trick. --jhi d_Gconvert='sprintf((b),"%.*llg",(n),(x))' diff --git a/contrib/perl5/hints/bsdos.sh b/contrib/perl5/hints/bsdos.sh index c54a0c1606b0..58755434a385 100644 --- a/contrib/perl5/hints/bsdos.sh +++ b/contrib/perl5/hints/bsdos.sh @@ -3,8 +3,12 @@ # hints file for BSD/OS (adapted from bsd386.sh) # Original by Neil Bowers <neilb@khoros.unm.edu>; Tue Oct 4 12:01:34 EDT 1994 # Updated by Tony Sanders <sanders@bsdi.com>; Sat Aug 23 12:47:45 MDT 1997 -# Added 3.1 with ELF dynamic libraries (NOT in 3.1 yet. Estimated for 4.0) -# SYSV IPC tested Ok so I re-enabled. +# Added 3.1 with ELF dynamic libraries (NOT in 3.1 yet. +# Estimated for 4.0) SYSV IPC tested Ok so I re-enabled. +# +# Updated to work in post-4.0 by Todd C. Miller <millert@openbsd.org> +# +# Updated for threads by "Timur I. Bakeyev" <bsdi@listserv.bat.ru> # # To override the compiler on the command line: # ./Configure -Dcc=gcc2 @@ -18,7 +22,7 @@ d_voidsig='define' usemymalloc='n' # setre?[ug]id() have been replaced by the _POSIX_SAVED_IDS versions. -# See http://www.bsdi.com/bsdi-man?setuid(2) +# See <A HREF="http://www.bsdi.com/bsdi-man?setuid">http://www.bsdi.com/bsdi-man?setuid</A>(2) d_setregid='undef' d_setreuid='undef' d_setrgid='undef' @@ -85,8 +89,8 @@ case "$osvers" in libswanted="Xpm Xaw Xmu Xt SM ICE Xext X11 $libswanted" libswanted="rpc curses termcap $libswanted" ;; -4.0*) - # ELF dynamic link libraries starting in 4.0 (???) +4.*) + # ELF dynamic link libraries starting in 4.0 useshrplib='true' so='so' dlext='so' @@ -94,13 +98,34 @@ case "$osvers" in case "$cc" in '') cc='cc' # cc is gcc2 in 4.0 cccdlflags="-fPIC" - ccdlflags=" " ;; + ccdlflags="-rdynamic -Wl,-rpath,$privlib/$archname/CORE" + ;; esac case "$ld" in '') ld='ld' lddlflags="-shared -x $lddlflags" ;; esac - ;; + # Due usage of static pointer from crt.o + libswanted="util $libswanted" ;; esac +# This script UU/usethreads.cbu will get 'called-back' by Configure +# after it has prompted the user for whether to use threads. +cat > UU/usethreads.cbu <<'EOCBU' +case "$usethreads" in +$define|true|[yY]*) + case "$osvers" in + 3.*|4.*) ccflags="-D_REENTRANT $ccflags" + ;; + *) cat <<EOM >&4 +I did not know that BSD/OS $osvers supports POSIX threads. + +Feel free to tell perlbug@perl.org otherwise. +EOM + exit 1 + ;; + esac + ;; +esac +EOCBU diff --git a/contrib/perl5/hints/cygwin.sh b/contrib/perl5/hints/cygwin.sh index 42114c249f0a..c57d3f6fdf76 100644 --- a/contrib/perl5/hints/cygwin.sh +++ b/contrib/perl5/hints/cygwin.sh @@ -19,9 +19,13 @@ then plibpth=`cd $plibpth && pwd` fi so='dll' -# - eliminate -lc, implied by gcc +# - eliminate -lc, implied by gcc and a symlink to libcygwin.a libswanted=`echo " $libswanted " | sed -e 's/ c / /g'` -libswanted="$libswanted cygipc cygwin kernel32" +# - eliminate -lm, symlink to libcygwin.a +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' @@ -34,11 +38,6 @@ ld='ld2' # - perl malloc needs to be unpolluted bincompat5005='undef' -# stubs (ENOSYS, not implemented) -d_chroot='undef' -d_seteuid='undef' -d_setegid='undef' - # Win9x problem with non-blocking read from a closed pipe d_eofnblk='define' diff --git a/contrib/perl5/hints/darwin.sh b/contrib/perl5/hints/darwin.sh index fd61e424b03c..8625798d5364 100644 --- a/contrib/perl5/hints/darwin.sh +++ b/contrib/perl5/hints/darwin.sh @@ -47,7 +47,7 @@ ld='cc'; so='dylib'; dlext='bundle'; dlsrc='dl_dyld.xs'; usedl='define'; -cccdlflags=''; +cccdlflags=' '; # space, not empty, because otherwise we get -fpic lddlflags="${ldflags} -bundle -undefined suppress"; ldlibpthname='DYLD_LIBRARY_PATH'; useshrplib='true'; diff --git a/contrib/perl5/hints/dec_osf.sh b/contrib/perl5/hints/dec_osf.sh index db7b869cf2be..ce3a40c77dbc 100644 --- a/contrib/perl5/hints/dec_osf.sh +++ b/contrib/perl5/hints/dec_osf.sh @@ -65,32 +65,42 @@ cc=${cc:-cc} # reset _DEC_cc_style= case "`$cc -v 2>&1 | grep cc`" in -*gcc*) _gcc_version=`$cc -v 2>&1 | grep "gcc version" | sed 's%^gcc version \([0-9]*\)\.\([0-9]*\) .*%\1 \2%'` +*gcc*) _gcc_version=`$cc --version 2>&1 | tr . ' '` set $_gcc_version - if test "$1" -lt 2 -o \( "$1" -eq 2 -a "$2" -lt 95 \); then + if test "$1" -lt 2 -o \( "$1" -eq 2 -a \( "$2" -lt 95 -o \( "$2" -eq 95 -a "$3" -lt 2 \) \) \); then cat >&4 <<EOF -Your cc seems to be gcc and its version seems to be less than 2.95. -This is not a good idea since old versions of gcc are known to produce -buggy code when compiling Perl (and no doubt for other programs, too). - -Therefore, I strongly suggest upgrading your gcc. (Why don't you -use the vendor cc is also a good question. It comes with the operating -system and produces good code.) - -Note that as of gcc 2.95 (19990728) and Perl 5.6.0 (end of March 2000) -if the said Perl is compiled with the said gcc the lib/sdbm test will -dump core. As this doesn't happen with the vendor cc, this is -most probably a lingering bug in gcc. Therefore unless you have -a better gcc you are still better off using the vendor cc. +*** Your cc seems to be gcc and its version ($_gcc_version) seems to be +*** less than 2.95.2. This is not a good idea since old versions of gcc +*** are known to produce buggy code when compiling Perl (and no doubt for +*** other programs, too). +*** +*** Therefore, I strongly suggest upgrading your gcc. (Why don't you use +*** the vendor cc is also a good question. It comes with the operating +*** system and produces good code.) Cannot continue, aborting. EOF exit 1 fi + if test "$1" -eq 2 -a "$2" -eq 95 -a "$3" -le 2; then + cat >&4 <<EOF + +*** Note that as of gcc 2.95.2 (19991024) and Perl 5.6.0 (March 2000) +*** if the said Perl is compiled with the said gcc the lib/sdbm test +*** may dump core (meaning that the SDBM_File extension is unusable). +*** As this core dump never happens with the vendor cc, this is most +*** probably a lingering bug in gcc. Therefore unless you have a better +*** gcc installation you are still better off using the vendor cc. + +Since you explicitly chose gcc, I assume that you know what are doing. + +EOF + fi ;; *) # compile something small: taint.c is fine for this. + ccversion=`cc -V | awk '/(Compaq|DEC) C/ {print $3}'` # the main point is the '-v' flag of 'cc'. case "`cc -v -I. -c taint.c -o taint$$.o 2>&1`" in */gemc_cc*) # we have the new DEC GEM CC diff --git a/contrib/perl5/hints/dos_djgpp.sh b/contrib/perl5/hints/dos_djgpp.sh index d50bca4b25e0..ebbd786b45e6 100644 --- a/contrib/perl5/hints/dos_djgpp.sh +++ b/contrib/perl5/hints/dos_djgpp.sh @@ -41,10 +41,13 @@ startperl='#!perl' case "X$optimize" in X) optimize="-O2 -malign-loops=2 -malign-jumps=2 -malign-functions=2" + ldflags='-s' + ;; + X*) + ldflags=' ' ;; esac ccflags="$ccflags -DPERL_EXTERNAL_GLOB" -ldflags='-s' usemymalloc='n' timetype='time_t' diff --git a/contrib/perl5/hints/freebsd.sh b/contrib/perl5/hints/freebsd.sh index fd60ba3cb919..8eb6ac47b040 100644 --- a/contrib/perl5/hints/freebsd.sh +++ b/contrib/perl5/hints/freebsd.sh @@ -86,8 +86,6 @@ case "$osvers" in d_setegid='undef' d_seteuid='undef' ;; -# -# Guesses at what will be needed after 2.2 *) usevfork='true' usemymalloc='n' libswanted=`echo $libswanted | sed 's/ malloc / /'` @@ -179,7 +177,7 @@ $define|true|[yY]*) 0*|1*|2.0*|2.1*) cat <<EOM >&4 I did not know that FreeBSD $osvers supports POSIX threads. -Feel free to tell perlbug@perl.com otherwise. +Feel free to tell perlbug@perl.org otherwise. EOM exit 1 ;; @@ -189,7 +187,8 @@ EOM POSIX threads are not supported well by FreeBSD $osvers. Please consider upgrading to at least FreeBSD 2.2.8, -or preferably to 3.something. +or preferably to the most recent -RELEASE or -STABLE +version (see http://www.freebsd.org/releases/). (While 2.2.7 does have pthreads, it has some problems with the combination of threads and pipes and therefore diff --git a/contrib/perl5/hints/hpux.sh b/contrib/perl5/hints/hpux.sh index ce15f552b44b..464f301427d0 100644 --- a/contrib/perl5/hints/hpux.sh +++ b/contrib/perl5/hints/hpux.sh @@ -23,6 +23,11 @@ # HP-UX 10 pthreads hints: Matthew T Harden <mthard@mthard1.monsanto.com> # From: Dominic Dunlop <domo@computer.org> # Abort and offer advice if bundled (non-ANSI) C compiler selected +# From: H.Merijn Brand <h.m.brand@hccnet.nl> +# ccversion detection +# perl/64/HP-UX wants libdb-3.0 to be shared ELF 64 +# generic pthread support detection for PTH package + # This version: March 8, 2000 # Current maintainer: Jeff Okamoto <okamoto@corp.hp.com> @@ -105,9 +110,13 @@ EOM ;; esac +cc=${cc:-cc} + case `$cc -v 2>&1`"" in *gcc*) ccisgcc="$define" ;; -*) ccisgcc='' ;; +*) ccisgcc='' + ccversion=`which cc | xargs what | awk '/Compiler/{print $2}'` + ;; esac # Determine the architecture type of this system. @@ -154,7 +163,6 @@ $define|true|[yY]*) 64-bit compilation is not supported on HP-UX $xxOsRevMajor. You need at least HP-UX 11.0. Cannot continue, aborting. - EOM exit 1 fi @@ -167,7 +175,6 @@ EOM *** You do not seem to have the 64-bit libraries in /lib/pa20_64. *** Most importantly, I cannot find the $libc. *** Cannot continue, aborting. - EOM exit 1 fi @@ -175,6 +182,7 @@ EOM ccflags="$ccflags +DD64" ldflags="$ldflags +DD64" test -d /lib/pa20_64 && loclibpth="$loclibpth /lib/pa20_64" + libswanted="$libswanted pthread" libscheck='case "`/usr/bin/file $xxx`" in *LP64*|*PA-RISC2.0*) ;; *) xxx=/no/64-bit$xxx ;; @@ -321,6 +329,7 @@ case "$usethreads" in $define|true|[yY]*) if [ "$xxOsRevMajor" -lt 10 ]; then cat <<EOM >&4 + HP-UX $xxOsRevMajor cannot support POSIX threads. Consider upgrading to at least HP-UX 11. Cannot continue, aborting. @@ -329,33 +338,56 @@ EOM fi case "$xxOsRevMajor" in 10) - # Under 10.X, a threaded perl can be built, but it needs - # libcma and OLD_PTHREADS_API. Also <pthread.h> needs to - # be #included before any other includes (in perl.h) - if [ ! -f /usr/include/pthread.h -o ! -f /usr/lib/libcma.sl ]; then + # Under 10.X, a threaded perl can be built + if [ -f /usr/include/pthread.h ]; then + if [ -f /usr/lib/libcma.sl ]; then + # DCE (from Core OS CD) is installed + + # It needs # libcma and OLD_PTHREADS_API. Also <pthread.h> + # needs to be #included before any other includes + # (in perl.h) + + # HP-UX 10.X uses the old pthreads API + d_oldpthreads="$define" + + # include libcma before all the others + libswanted="cma $libswanted" + + # tell perl.h to include <pthread.h> before other include files + ccflags="$ccflags -DPTHREAD_H_FIRST" + + # CMA redefines select to cma_select, and cma_select expects int * + # instead of fd_set * (just like 9.X) + selecttype='int *' + + elif [ -f /usr/lib/libpthread.sl ]; then + # PTH package is installed + libswanted="pthread $libswanted" + else + libswanted="no_threads_available" + fi + else + libswanted="no_threads_available" + fi + + if [ $libswanted = "no_threads_available" ]; then cat <<EOM >&4 + In HP-UX 10.X for POSIX threads you need both of the files -/usr/include/pthread.h and /usr/lib/libcma.sl. -Either you must install the CMA package or you must upgrade to HP-UX 11. -Cannot continue, aborting. -EOM - exit 1 - fi +/usr/include/pthread.h and either /usr/lib/libcma.sl or /usr/lib/libpthread.sl. +Either you must upgrade to HP-UX 11 or install a posix thread library: - # HP-UX 10.X uses the old pthreads API - case "$d_oldpthreads" in - '') d_oldpthreads="$define" ;; - esac + DCE-CoreTools from HP-UX 10.20 Hardware Extensions 3.0 CD (B3920-13941) - # include libcma before all the others - libswanted="cma $libswanted" +or - # tell perl.h to include <pthread.h> before other include files - ccflags="$ccflags -DPTHREAD_H_FIRST" + PTH package from http://hpux.tn.tudelft.nl/hppd/hpux/alpha.html + +Cannot continue, aborting. +EOM + exit 1 + fi - # CMA redefines select to cma_select, and cma_select expects int * - # instead of fd_set * (just like 9.X) - selecttype='int *' ;; 11 | 12) # 12 may want upping the _POSIX_C_SOURCE datestamp... ccflags=" -D_POSIX_C_SOURCE=199506L $ccflags" @@ -387,8 +419,10 @@ cat > UU/uselargefiles.cbu <<'EOCBU' case "$uselargefiles" in ''|$define|true|[yY]*) # there are largefile flags available via getconf(1) - # but we cheat for now. - ccflags="$ccflags -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64" + # but we cheat for now. (Keep that in the left margin.) +ccflags_uselargefiles="-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64" + + ccflags="$ccflags $ccflags_uselargefiles" if test -z "$ccisgcc" -a -z "$gccversion"; then # The strict ANSI mode (-Aa) doesn't like large files. diff --git a/contrib/perl5/hints/irix_6.sh b/contrib/perl5/hints/irix_6.sh index 9d9852d04919..e6117cf1af91 100644 --- a/contrib/perl5/hints/irix_6.sh +++ b/contrib/perl5/hints/irix_6.sh @@ -32,6 +32,14 @@ # Don't bother with -n32 unless you have the 7.1 or later compilers. # But there's no quick and light-weight way to check in 6.2. +# NOTE: some IRIX cc versions, e.g. 7.3.1.1m (try cc -version) have +# been known to have issues (coredumps) when compiling perl.c. +# If you've used -OPT:fast_io=ON and this happens, try removing it. +# If that fails, or you didn't use that, then try adjusting other +# optimization options (-LNO, -INLINE, -O3 to -O2, etcetera). +# The compiler bug has been reported to SGI. +# -- Allen Smith <easmith@beatrice.rutgers.edu> + # Let's assume we want to use 'cc -n32' by default, unless the # necessary libm is missing (which has happened at least twice) case "$cc" in @@ -40,7 +48,13 @@ case "$cc" in *) test -f /usr/lib32/libm.so && cc='cc -n32' ;; esac esac -test -z "$cc" && cc=cc + +cc=${cc:-cc} + +case "$cc" in +*gcc*) ;; +*) ccversion=`cc -version` ;; +esac case "$use64bitint" in $define|true|[yY]*) @@ -77,9 +91,19 @@ esac case "$cc" in *"cc -n32"*) - libscheck='case "`/usr/bin/file $xxx`" in -*N32*) ;; -*) xxx=/no/n32$xxx ;; + # If a library is requested to link against, make sure the + # objects in the library are of the same ABI we are compiling + # against. Albert Chin-A-Young <china@thewrittenword.com> + libscheck='case "$xxx" in +*.a) /bin/ar p $xxx `/bin/ar t $xxx | /usr/bsd/head -1` >$$.o; + case "`/usr/bin/file $$.o`" in + *N32*) rm -f $$.o ;; + *) rm -f $$.o; xxx=/no/n32$xxx ;; + esac ;; +*) case "`/usr/bin/file $xxx`" in + *N32*) ;; + *) xxx=/no/n32$xxx ;; + esac ;; esac' # NOTE: -L/usr/lib32 -L/lib32 are automatically selected by the linker @@ -93,7 +117,7 @@ esac' libc='/usr/lib32/libc.so' plibpth='/usr/lib32 /lib32 /usr/ccs/lib' ;; -*"cc -64") +*"cc -64"*) loclibpth="$loclibpth /usr/lib64" libscheck='case "`/usr/bin/file $xxx`" in @@ -138,7 +162,7 @@ esac # Settings common to both native compiler modes. case "$cc" in -*"cc -n32"|*"cc -64") +*"cc -n32"*|*"cc -64"*) ld=$cc # perl's malloc can return improperly aligned buffer @@ -216,8 +240,10 @@ esac # Don't groan about unused libraries. ldflags="$ldflags -Wl,-woff,84" +# workaround for an optimizer bug case "`$cc -version 2>&1`" in -*7.2.*) op_cflags='optimize=-O1' ;; # workaround for an optimizer bug +*7.2.*) op_cflags='optimize=-O1'; opmini_cflags='optimize=-O1' ;; +*7.3.1.*) op_cflags='optimize=-O2'; opmini_cflags='optimize=-O2' ;; esac # We don't want these libraries. diff --git a/contrib/perl5/hints/linux.sh b/contrib/perl5/hints/linux.sh index 4fb2f89e7c2a..a6b2bd985ab0 100644 --- a/contrib/perl5/hints/linux.sh +++ b/contrib/perl5/hints/linux.sh @@ -189,7 +189,7 @@ fi rm -f try.c a.out -if /bin/bash -c exit; then +if /bin/sh -c exit; then echo '' echo 'You appear to have a working bash. Good.' else @@ -282,7 +282,10 @@ cat > UU/uselargefiles.cbu <<'EOCBU' # after it has prompted the user for whether to use large files. case "$uselargefiles" in ''|$define|true|[yY]*) - ccflags="$ccflags -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64" +# Keep this in the left margin. +ccflags_uselargefiles="-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64" + + ccflags="$ccflags $ccflags_uselargefiles" ;; esac EOCBU diff --git a/contrib/perl5/hints/machten.sh b/contrib/perl5/hints/machten.sh index b4409c1bf0be..3a311a1746a3 100644 --- a/contrib/perl5/hints/machten.sh +++ b/contrib/perl5/hints/machten.sh @@ -15,6 +15,9 @@ # Martijn Koster <m.koster@webcrawler.com> # Richard Yeh <rcyeh@cco.caltech.edu> # +# 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 <domo@computer.org> 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 <domo@computer.org> 000224 @@ -46,10 +49,7 @@ # # MachTen 4.1.1's support for shadow password file access is incomplete: # disable its use completely. -d_endspent=${d_endspent:-undef} -d_getspent=${d_getspent:-undef} d_getspnam=${d_getspnam:-undef} -d_setspent=${d_setspent:-undef} # MachTen 4.1.1 does support dynamic loading, but perl doesn't # know how to use it yet. @@ -200,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 / /' \ @@ -231,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 @@ -241,10 +248,9 @@ Similarly, when you see select the default answer: vfork() works, and avoids expensive data copying. -You may also see "WHOA THERE!!!" messages concerning \$d_endspent, -\$d_getspent, \$d_getspnam and \$d_setspent. In all cases, select the -default answer: MachTen's support for shadow password file access is -incomplete, and should not be used. +You may also see "WHOA THERE!!!" messages concerning \$d_getspnam. +Select the default answer: MachTen's support for shadow password +file access is incomplete, and should not be used. At the end of Configure, you will see a harmless message diff --git a/contrib/perl5/hints/mint.sh b/contrib/perl5/hints/mint.sh index ab55e612e100..b9a7886f9ad5 100644 --- a/contrib/perl5/hints/mint.sh +++ b/contrib/perl5/hints/mint.sh @@ -53,7 +53,6 @@ d_fsetpos='fpos_t' gidtype='gid_t' groupstype='gid_t' lseektype='long' -models='none' modetype='mode_t' sizetype='size_t' timetype='time_t' diff --git a/contrib/perl5/hints/mpeix.sh b/contrib/perl5/hints/mpeix.sh index 556d22148c62..d2ca5f09af47 100644 --- a/contrib/perl5/hints/mpeix.sh +++ b/contrib/perl5/hints/mpeix.sh @@ -10,9 +10,10 @@ # Created for 5.003 by Mark Klein, mklein@dis.com. # Substantially revised for 5.004_01 by Mark Bixby, markb@cccd.edu. # Revised again for 5.004_69 by Mark Bixby, markb@cccd.edu. +# Revised for 5.6.0 by Mark Bixby, mbixby@power.net. # osname='mpeix' -osvers='5.5' # Isn't there a way to determine this dynamically? +osvers=`uname -r | sed -e 's/.[A-Z]\.\([0-9]\)\([0-9]\)\.[0-9][0-9]/\1.\2/'` # # Force Configure to use our wrapper mpeix/nm script # @@ -53,16 +54,34 @@ toke_cflags='ccflags="$ccflags -DARG_ZERO_IS_SCRIPT"' # Linking. # lddlflags='-b' -# What if you want additional libs (e.g. gdbm)? -# This should remove the unwanted libraries from $libswanted and -# add on whatever ones are needed instead. -libs="$libs -lbind -lsyslog -lcurses -lsvipc -lsocket -lm -lc" +# Delete bsd and BSD from the library list. Remove other randomly ordered +# libraries and then re-add them in their proper order (the MPE linker is +# order-sensitive). Add additional MPE-specific libraries. +for mpe_remove in bind bsd BSD c curses m socket str svipc syslog; do + set `echo " $libswanted " | sed -e 's/ / /g' -e "s/ $mpe_remove //"` + libswanted="$*" +done +libswanted="$libswanted bind syslog curses svipc socket str m c" loclibpth="$loclibpth /usr/local/lib /usr/contrib/lib /BIND/PUB/lib /SYSLOG/PUB" # # External functions and data items. # -# Does Configure *really* get *all* of these wrong? +# Q: Does Configure *really* get *all* of these wrong? # +# A: Yes. There are two MPE problems here. The 'undef' functions exist on MPE, +# but are merely dummy routines that return ENOTIMPL or ESYSERR. Since they're +# useless, let's just tell Perl to avoid them. Also, a few data items are +# 'undef' because while they may exist in structures, they are uninitialized. +# +# The 'define' cases are a bit weirder. MPE has a libc.a, libc.sl, and two +# special kernel shared libraries, /SYS/PUB/XL and /SYS/PUB/NL. Much of what +# is in libc.a is duplicated within XL and NL, so when we created libc.sl, we +# omitted the duplicated functions. Since Configure end ups scanning libc.sl, +# we need to 'define' the functions that had been removed. +# +# We don't want to scan XL or NL because we would find way too many POSIX or +# Unix named functions that are really vanilla MPE functions that do something +# completely different than on POSIX or Unix. d_crypt='define' d_difftime='define' d_dlerror='undef' @@ -100,7 +119,7 @@ d_wctomb='define' # # Include files. # -i_termios='undef' +i_termios='undef' # we have termios, but not the full set (just tcget/setattr) i_time='define' i_systime='undef' i_systimek='undef' @@ -109,3 +128,8 @@ timeincl='/usr/include/time.h' # Data types. # timetype='time_t' +# +# Functionality. +# +bincompat5005="$undef" +uselargefiles="$undef" diff --git a/contrib/perl5/hints/openbsd.sh b/contrib/perl5/hints/openbsd.sh index a7d8bf2950af..25781577ff26 100644 --- a/contrib/perl5/hints/openbsd.sh +++ b/contrib/perl5/hints/openbsd.sh @@ -26,8 +26,9 @@ d_setruid=$undef # # Not all platforms support dynamic loading... # -case `arch` in -OpenBSD.alpha|OpenBSD.mips|OpenBSD.powerpc|OpenBSD.vax) +ARCH=`arch|sed 's/^OpenBSD.//'` +case "${ARCH}-${osvers}" in +alpha-*|mips-*|vax-*|powerpc-2.[0-7]|m88k-*) usedl=$undef ;; *) @@ -37,7 +38,15 @@ OpenBSD.alpha|OpenBSD.mips|OpenBSD.powerpc|OpenBSD.vax) # we use -fPIC here because -fpic is *NOT* enough for some of the # extensions like Tk on some OpenBSD platforms (ie: sparc) cccdlflags="-DPIC -fPIC $cccdlflags" - lddlflags="-Bshareable $lddlflags" + case "$osvers" in + [01].*|2.[0-7]|2.[0-7].*) + lddlflags="-Bshareable $lddlflags" + ;; + *) # from 2.8 onwards + ld=${cc:-cc} + lddlflags="-shared -fPIC $lddlflags" + ;; + esac ;; esac @@ -60,7 +69,14 @@ d_suidsafe=$define # cc is gcc so we can do better than -O # Allow a command-line override, such as -Doptimize=-g -test "$optimize" || optimize='-O2' +case "$ARCH" in +m88k) + optimize='-O0' + ;; +*) + test "$optimize" || optimize='-O2' + ;; +esac # This script UU/usethreads.cbu will get 'called-back' by Configure # after it has prompted the user for whether to use threads. @@ -87,6 +103,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/contrib/perl5/hints/os2.sh b/contrib/perl5/hints/os2.sh index 1d9df3683f8a..5ffa589d310c 100644 --- a/contrib/perl5/hints/os2.sh +++ b/contrib/perl5/hints/os2.sh @@ -93,7 +93,7 @@ if test "$libemx" = "X"; then echo "Cannot find C library!" >&2; fi libpth="`echo \"$LIBRARY_PATH\" | tr ';\\\' ' /'`" libpth="$libpth $libemx/mt $libemx" -set `emxrev -f emxlibcm` +set `cmd /c emxrev -f emxlibcm` emxcrtrev=$5 # indented to not put it into config.sh _defemxcrtrev=-D_EMX_CRT_REV_=$emxcrtrev @@ -249,6 +249,8 @@ nm_opt='-p' ####### We define these functions ourselves +d_strtoll='define' +d_strtoull='define' d_getprior='define' d_setprior='define' @@ -281,8 +283,14 @@ case "$0$running_c_cmd" in # Not patched! if test -f ./Configure.cmd ; then echo "!!!" >&2 - echo "!!! ./Configure not patched, but ./Configure.cmd exits" >&2 - echo "!!! Do not know what to do!" >&2 + echo "!!! I see that what is running is ./Configure." >&2 + echo "!!! ./Configure is not patched, but ./Configure.cmd exists." >&2 + echo "!!!" >&2 + echo "!!! You are supposed to run Configure.cmd, not Configure" >&2 + echo "!!! after an automagic patching." >&2 + echo "!!!" >&2 + echo "!!! If you insist on running Configure, please" >&2 + echo "!!! patch it manually from ./os2/diff.configure." >&2 echo "!!!" >&2 exit 2 fi @@ -306,10 +314,6 @@ case "$0$running_c_cmd" in *) echo "!!! Apparently we are running a renamed Configure: '$0'." >&2 esac -# Copy pod: - -cp -uf ./README.os2 ./pod/perlos2.pod - # This script UU/usethreads.cbu will get 'called-back' by Configure # after it has prompted the user for whether to use threads. cat > UU/usethreads.cbu <<'EOCBU' diff --git a/contrib/perl5/hints/os390.sh b/contrib/perl5/hints/os390.sh index d6f68212422a..4eff5a82174c 100644 --- a/contrib/perl5/hints/os390.sh +++ b/contrib/perl5/hints/os390.sh @@ -3,7 +3,8 @@ # OS/390 hints by David J. Fiander <davidf@mks.com> # # OS/390 OpenEdition Release 3 Mon Sep 22 1997 thanks to: -# +# +# John Goodyear <johngood@us.ibm.com> # John Pfuntner <pfuntner@vnet.ibm.com> # Len Johnson <lenjay@ibm.net> # Bud Huff <BAHUFF@us.oracle.com> @@ -15,53 +16,148 @@ # # To get ANSI C, we need to use c89, and ld doesn't exist -cc='c89' -ld='c89' -# To link via definition side decks we need the dll option -cccdlflags='-W 0,dll,"langlvl(extended)"' -# c89 hides most of the useful header stuff, _ALL_SOURCE turns it on again, +# You can override this with Configure -Dcc=gcc -Dld=ld. +case "$cc" in +'') cc='c89' ;; +esac +case "$ld" in +'') ld='c89' ;; +esac + +# -DMAXSIG=38 maximum signal number +# -DOEMVS is used in place of #ifdef __MVS__ in certain places. +# -D_OE_SOCKETS alters system headers. +# -D_XOPEN_SOURCE_EXTENDEDA alters system headers. +# c89 hides most of the useful header stuff, _ALL_SOURCE turns it on again. # YYDYNAMIC ensures that the OS/390 yacc generated parser is reentrant. -# -DEBCDIC should come from Configure. -ccflags='-DMAXSIG=38 -DOEMVS -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -DYYDYNAMIC' -# Turning on optimization breaks perl -optimize='none' +# -DEBCDIC should come from Configure and need not be mentioned here. +# Prepend your favorites with Configure -Dccflags=your_favorites +case "$ccflags" in +'') ccflags='-DMAXSIG=38 -DOEMVS -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -DYYDYNAMIC' ;; +*) ccflags="$ccflags -DMAXSIG=38 -DOEMVS -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -DYYDYNAMIC" ;; +esac -alignbytes=8 +# Turning on optimization breaks perl. +# You can override this with Configure -Doptimize='-O' or somesuch. +case "$optimize" in +'') optimize='none' ;; +esac + +# To link via definition side decks we need the dll option +# You can override this with Configure -Ucccdlflags or somesuch. +case "$cccdlflags" in +'') cccdlflags='-W 0,dll' ;; +esac + +case "$so" in +'') so='a' ;; +esac -usemymalloc='n' +case "$alignbytes" in +'') alignbytes=8 ;; +esac -so='a' +case "$usemymalloc" in +'') usemymalloc='n' ;; +esac # On OS/390, libc.a doesn't really hold anything at all, # so running nm on it is pretty useless. -usenm='n' +# You can override this with Configure -Dusenm. +case "$usenm" in +'') usenm='false' ;; +esac -# Dynamic loading doesn't work on OS/390 quite yet -usedl='n' -dlext='none' +# Setting ldflags='-Wl,EDIT=NO' will get rid of the symbol +# information at the end of the executable (=> smaller binaries). +# Override this option with -Dldflags='whatever else you wanted'. +case "$ldflags" in +'') ldflags='-Wl,EDIT=NO' ;; +esac -# Configure can't figure this out for some reason -d_shmatprototype='define' +# In order to build with dynamic be sure to specify: +# Configure -Dusedl +# Do not forget to add $archlibexp/CORE to your LIBPATH. +# You might want to override some of this with things like: +# Configure -Dusedl -Ddlext=so -Ddlsrc=dl_dllload.xs. +case "$usedl" in +'') + usedl='n' + case "$dlext" in + '') dlext='none' ;; + esac + ;; +define) + case "$useshrplib" in + '') useshrplib='true' ;; + esac + case "$dlsrc" in + '') dlsrc='dl_dllload.xs' ;; + esac + # For performance use 'so' at or beyond v2.8, 'dll' for 2.7 and prior versions + case "`uname -v`x`uname -r`" in + 02x0[89].*|02x1[0-9].*|[0-9][3-9]x*) + so='so' + case "$dlext" in + '') dlext='so' ;; + esac + ;; + *) + so='dll' + case "$dlext" in + '') dlext='dll' ;; + esac + ;; + esac + libperl="libperl.$so" + ccflags="$ccflags -D_SHR_ENVIRON -DPERL_EXTERNAL_GLOB -Wc,dll" + cccdlflags='-c -Wc,dll,EXPORTALL' + # The following will need to be modified for the installed libperl.x. + # The modification to Config.pm is done by the installperl script after the build and test. + ccdlflags="-W l,dll `pwd`/libperl.x" + lddlflags="-W l,dll `pwd`/libperl.x" + ;; +esac +# even on static builds using LIBPATH should be OK. +case "$ldlibpthname" in +'') ldlibpthname=LIBPATH ;; +esac -usenm='false' -i_time='define' -i_systime='define' +# Header files to include. +# You can override these with Configure -Ui_time -Ui_systime. +case "$i_time" in +'') i_time='define' ;; +esac +case "$i_systime" in +'') i_systime='define' ;; +esac # (from aix.sh) # uname -m output is too specific and not appropriate here # osname should come from Configure -# +# You can override this with Configure -Darchname='s390' but please don't. case "$archname" in '') archname="$osname" ;; esac -archobjs=ebcdic.o - -# We have our own cppstdin. -echo 'cat >.$$.c; '"$cc"' -E -Wc,NOLOC ${1+"$@"} .$$.c; rm .$$.c' > cppstdin +# We have our own cppstdin script. This is not a variable since +# Configure sees the presence of the script file. +# We put system header -D definitions in so that Configure +# can find the shmat() prototype in <sys/shm.h> and various +# other things. Unfortunately, cppflags occurs too late to be of +# value external to the script. This may need to be revisited +# under a compiler other than c89. +case "$usedl" in +define) +echo 'cat >.$$.c; '"$cc"' -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -D_SHR_ENVIRON -E -Wc,NOLOC ${1+"$@"} .$$.c; rm .$$.c' > cppstdin + ;; +*) +echo 'cat >.$$.c; '"$cc"' -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -E -Wc,NOLOC ${1+"$@"} .$$.c; rm .$$.c' > cppstdin + ;; +esac # -# Note that Makefile.SH employs a bare yacc to generate +# Note that Makefile.SH employs a bare yacc command to generate # perly.[hc] and a2p.[hc], hence you may wish to: # # alias yacc='myyacc' diff --git a/contrib/perl5/hints/posix-bc.sh b/contrib/perl5/hints/posix-bc.sh index ec21bc327e44..62752339920c 100644 --- a/contrib/perl5/hints/posix-bc.sh +++ b/contrib/perl5/hints/posix-bc.sh @@ -6,37 +6,89 @@ # thanks to the authors of the os390.sh # -# To get ANSI C, we need to use c89, and ld doesn't exist -cc='c89' -ld='c89' +# To get ANSI C, we need to use c89, and ld does not exist +# You can override this with Configure -Dcc=gcc -Dld=ld. +case "$cc" in +'') cc='c89' ;; +esac +case "$ld" in +'') ld='c89' ;; +esac # C-Flags: -ccflags='-DPOSIX_BC -DUSE_PURE_BISON -D_XOPEN_SOURCE_EXTENDED' +# -DPOSIX_BC +# -DUSE_PURE_BISON +# -D_XOPEN_SOURCE_EXTENDED alters system headers. +# Prepend your favorites with Configure -Dccflags=your_favorites +case "$ccflags" in +'') ccflags='-K enum_long,llm_case_lower,llm_keep,no_integer_overflow -DPOSIX_BC -DUSE_PURE_BISON -D_XOPEN_SOURCE_EXTENDED' ;; +*) ccflags='$ccflags -Kenum_long,llm_case_lower,llm_keep,no_integer_overflow -DPOSIX_BC -DUSE_PURE_BISON -D_XOPEN_SOURCE_EXTENDED' ;; +esac + +# ccdlflags have yet to be determined. +#case "$ccdlflags" in +#'') ccdlflags='-c' ;; +#esac + +# cccdlflags have yet to be determined. +#case "$cccdlflags" in +#'') cccdlflags='' ;; +#esac + +# ldflags have yet to be determined. +#case "$ldflags" in +#'') ldflags='' ;; +#esac + +# lddlflags have yet to be determined. +#case "$lddlflags" in +#'') lddlflags='' ;; +#esac # Flags on a RISC-Host (SUNRISE): if [ -n "`bs2cmd SHOW-SYSTEM-INFO | egrep 'HSI-ATT.*TYPE.*SR'`" ]; then echo echo "Congratulations, you are running a machine with Sunrise CPUs." echo "Let's hope you have the matching RISC compiler as well." - ccflags='-K risc_4000 -DPOSIX_BC -DUSE_PURE_BISON -D_XOPEN_SOURCE_EXTENDED' + ccflags="-K risc_4000 $ccflags" ldflags='-K risc_4000' fi # Turning on optimization breaks perl (CORE-DUMP): -optimize='none' +# You can override this with Configure -Doptimize='-O' or somesuch. +case "$optimize" in +'') optimize='none' ;; +esac # we don''t use dynamic memorys (yet): -so='none' -usedl='no' -dlext='none' +case "$so" in +'') so='none' ;; +esac -# On BS2000/Posix, libc.a doesn't really hold anything at all, -# so running nm on it is pretty useless. -usenm='no' - -# other Options: +case "$usemymalloc" in +'') usemymalloc='n' ;; +esac -usemymalloc='no' +# On BS2000/Posix, libc.a does not really hold anything at all, +# so running nm on it is pretty useless. +# You can override this with Configure -Dusenm. +case "$usenm" in +'') usenm='false' ;; +esac -archobjs=ebcdic.o +# Dynamic loading doesn't work on OS/390 quite yet. +# You can override this with +# Configure -Dusedl -Ddlext=.so -Ddlsrc=dl_dllload.xs. +case "$usedl" in +'') usedl='n' ;; +esac +case "$dlext" in +'') dlext='none' ;; +esac +#case "$dlsrc" in +#'') dlsrc='none' ;; +#esac +#case "$ldlibpthname" in +#'') ldlibpthname=LIBPATH ;; +#esac diff --git a/contrib/perl5/hints/powerux.sh b/contrib/perl5/hints/powerux.sh index 4070c01767e4..dc1b3d07f063 100644 --- a/contrib/perl5/hints/powerux.sh +++ b/contrib/perl5/hints/powerux.sh @@ -63,7 +63,7 @@ lddlflags='-Zlink=so' # i_ndbm='undef' -# I have no clude what perl thinks it wants <sys/mode.h> for, but if +# I have no clue what perl thinks it wants <sys/mode.h> for, but if # you include it in a program in PowerMAX without first including # <sys/vnode.h> the code don't compile... # diff --git a/contrib/perl5/hints/solaris_2.sh b/contrib/perl5/hints/solaris_2.sh index 8aee6d40dc00..0bf5bab3afdc 100644 --- a/contrib/perl5/hints/solaris_2.sh +++ b/contrib/perl5/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 <lupe@lupe-christoph.de> +# Based on version by: # Andy Dougherty <doughera@lafayette.edu> -# Based on input from lots of folks, especially +# Which was based on input from lots of folks, especially # Dean Roehrich <roehrich@ironwood-fddi.cray.com> +# 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 <h.b.furuseth@usit.uio.no> -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,42 +58,35 @@ case "$archname" in ;; esac -test -z "`${cc:-cc} -V 2>&1|grep -i workshop`" || ccisworkshop="$define" -test -z "`${cc:-cc} -v 2>&1|grep -i gcc`" || ccisgcc="$define" - -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 "$ccisworkshop" in -"$define") - cat >try.c <<EOF -#include <sunmath.h> -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. # @@ -90,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 <<END >&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. @@ -153,7 +159,7 @@ if grep GNU make.vers > /dev/null 2>&1; then case "`/usr/bin/ls -lL $tmp`" in ??????s*) cat <<END >&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 @@ -165,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 <doughera@lafayette.edu> +# --Andy Dougherty <doughera@lafayette.edu> # Tue Apr 13 17:19:43 EDT 1999 # Get gcc to share its secrets. @@ -202,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 : @@ -272,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 <<EOM +#include <sunmath.h> +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*) @@ -288,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 <<END >&2 + cat <<END >&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 @@ -319,17 +328,21 @@ 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 - set `echo X "$libswanted "| sed -e 's/ c / posix4 pthread c /'` + # 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"; + esac + set `echo X "$libswanted "| sed -e "s/ c / $sched_yield_lib pthread c /"` shift libswanted="$*" @@ -343,18 +356,18 @@ $define|true|[yY]*) cat >try.c <<'EOM' /* Test for sig(set|long)jmp bug. */ #include <setjmp.h> - + main() { sigjmp_buf env; int ret; - + ret = sigsetjmp(env, 1); if (ret) { return ret == 2; } siglongjmp(env, 2); } EOM - if test "`arch`" = i86pc -a "$osvers" = 2.6 && \ + if test "`arch`" = i86pc -a `uname -r` = 5.6 && \ ${cc:-cc} try.c -lpthread >/dev/null 2>&1 && ./a.out; then d_sigsetjmp=$undef cat << 'EOM' >&2 @@ -370,27 +383,42 @@ 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]*) - ccflags="$ccflags `getconf LFS_CFLAGS 2>/dev/null`" - ldflags="$ldflags `getconf LFS_LDFLAGS 2>/dev/null`" - libswanted="$libswanted `getconf LFS_LIBS 2>/dev/null|sed -e 's@^-l@@' -e 's@ -l@ @g`" + +# Keep these in the left margin. +ccflags_uselargefiles="`getconf LFS_CFLAGS 2>/dev/null`" +ldflags_uselargefiles="`getconf LFS_LDFLAGS 2>/dev/null`" +libswanted_uselargefiles="`getconf LFS_LIBS 2>/dev/null|sed -e 's@^-l@@' -e 's@ -l@ @g`" + + ccflags="$ccflags $ccflags_uselargefiles" + ldflags="$ldflags $ldflags_uselargefiles" + libswanted="$libswanted $libswanted_uselargefiles" ;; esac EOCBU -cat > UU/use64bitint.cbu <<'EOCBU' -# This script UU/use64bitint.cbu will get 'called-back' by Configure +# This is truly a mess. +case "$usemorebits" in +"$define"|true|[yY]*) + use64bitint="$define" + uselongdouble="$define" + ;; +esac + +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 - 2.[1-6]) + 5.[0-4]) cat >&4 <<EOM -Solaris `uname -r` does not support 64-bit integers. -You should upgrade to at least Solaris 2.7. +Solaris `uname -r|sed -e 's/^5\./2./'` does not support 64-bit integers. +You should upgrade to at least Solaris 2.5. EOM exit 1 ;; @@ -399,11 +427,20 @@ EOM esac EOCBU -cat > UU/use64bitall.cbu <<'EOCBU' -# This script UU/use64bitall.cbu will get 'called-back' by Configure + cat > 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.[0-6]) + cat >&4 <<EOM +Solaris `uname -r|sed -e 's/^5\./2./'` does not support 64-bit pointers. +You should upgrade to at least Solaris 2.7. +EOM + exit 1 + ;; + esac libc='/usr/lib/sparcv9/libc.so' if test ! -f $libc; then cat >&4 <<EOM @@ -413,21 +450,25 @@ Cannot continue, aborting. EOM exit 1 - fi - . ./UU/workshoplibpth.cbu + fi + . ./workshoplibpth.cbu case "$cc -v 2>/dev/null" in *gcc*) echo 'main() { return 0; }' > try.c - if ${cc:-cc} -mcpu=v9 -m64 -S try.c 2>&1 | grep -e \ - '-m64 is not supported by this configuration'; then + case "`${cc:-cc} -mcpu=v9 -m64 -S try.c 2>&1 | grep 'm64 is not supported by this configuration'`" in + *"m64 is not supported"*) cat >&4 <<EOM -Full 64-bit build not supported by this configuration. +Full 64-bit build is not supported by this gcc configuration. +Check http://gcc.gnu.org/ for the latest news of availability +of gcc for 64-bit Sparc. + Cannot continue, aborting. EOM exit 1 - fi + ;; + esac ccflags="$ccflags -mcpu=v9 -m64" if test X`getconf XBS5_LP64_OFF64_CFLAGS 2>/dev/null` != X; then ccflags="$ccflags -Wa,`getconf XBS5_LP64_OFF64_CFLAGS 2>/dev/null`" @@ -444,236 +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 "$ccisworkshop" in - '') cat >&4 <<EOM +case "$uselongdouble" in +"$define"|true|[yY]*) + if test -f /opt/SUNWspro/lib/libsunmath.so; then + libs="$libs -lsunmath" + ldflags="$ldflags -L/opt/SUNWspro/lib -R/opt/SUNWspro/lib" + d_sqrtl=define + else + cat >&4 <<EOM -I do not see the Sun Workshop compiler; therefore I do not see -the libsunmath; therefore I do not know how to do long doubles, sorry. -I'm disabling the use of long doubles. +The Sun Workshop math library is not installed; therefore I do not +know how to do long doubles, sorry. I'm disabling the use of long +doubles. EOM uselongdouble="$undef" - ;; - *) libswanted="$libswanted sunmath" - loclibpth="$loclibpth /opt/SUNWspro/lib" - ;; - esac - uselongdouble_done=yes + fi ;; esac EOCBU -# Actually, we want to run this already now, if so requested, -# because we need to fix up things right now. -case "$uselongdouble" in -"$define"|true|[yY]*) - . ./UU/uselongdouble.cbu - ;; -esac - -rm -f try.c try.o try -# keep that leading tab - ccisworkshop='' - ccisgcc='' - -# This is just a trick to include some useful notes. -cat > /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/contrib/perl5/hints/svr4.sh b/contrib/perl5/hints/svr4.sh index 8109b3975287..69af6fda2f2f 100644 --- a/contrib/perl5/hints/svr4.sh +++ b/contrib/perl5/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 <sys/stat.h> 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/contrib/perl5/hints/titanos.sh b/contrib/perl5/hints/titanos.sh index cea99f82a3a2..88a3e7a96304 100644 --- a/contrib/perl5/hints/titanos.sh +++ b/contrib/perl5/hints/titanos.sh @@ -12,7 +12,6 @@ intsize='4' usenm='true' nm_opt='-eh' malloctype='void *' -models='none' ccflags="$ccflags -I/usr/include/net -DDEBUGGING -DSTANDARD_C" cppflags="$cppflags -I/usr/include/net -DDEBUGGING -DSTANDARD_C" stdchar='unsigned char' diff --git a/contrib/perl5/hints/unicos.sh b/contrib/perl5/hints/unicos.sh index 7ffd73fbcc04..089b9600e265 100644 --- a/contrib/perl5/hints/unicos.sh +++ b/contrib/perl5/hints/unicos.sh @@ -2,13 +2,21 @@ case `uname -r` in 6.1*) shellflags="-m+65536" ;; esac case "$optimize" in -'') optimize="-O1" ;; +# If we used fastmd (the default) integer values would be limited to 46 bits. +# --Mark P. Lutz +'') optimize="$optimize -h nofastmd" ;; esac -d_setregid='undef' -d_setreuid='undef' +# The default is to die in runtime on math overflows. +# Let's not do that. --jhi +ccflags="$ccflags -h matherror=errno" +# Give int((2/3)*3) a chance to be 2, not 1. --jhi +ccflags="$ccflags -h rounddiv" +# Avoid an optimizer bug where a volatile variables +# isn't correctly saved and restored --Mark P. Lutz +pp_ctl_cflags='ccflags="$ccflags -h scalar0 -h vector0"' case "$usemymalloc" in '') # The perl malloc.c SHOULD work says Ilya. - # But for the time being (5.004_68), alas, it doesn't. + # But for the time being (5.004_68), alas, it doesn't. --jhi # usemymalloc='y' # ccflags="$ccflags -DNO_RCHECK" usemymalloc='n' @@ -16,3 +24,6 @@ case "$usemymalloc" in esac # Configure gets fooled for some reason. There is no getpgid(). d_getpgid='undef' +# These exist but do not really work. +d_setregid='undef' +d_setreuid='undef' diff --git a/contrib/perl5/hints/uts.sh b/contrib/perl5/hints/uts.sh index 9ad72d7e9870..2bae4b0acf2d 100644 --- a/contrib/perl5/hints/uts.sh +++ b/contrib/perl5/hints/uts.sh @@ -1,2 +1,18 @@ -ccflags="$ccflags -DCRIPPLED_CC" -d_lstat=define +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/contrib/perl5/hints/vmesa.sh b/contrib/perl5/hints/vmesa.sh index bc033878229e..0213853fec92 100644 --- a/contrib/perl5/hints/vmesa.sh +++ b/contrib/perl5/hints/vmesa.sh @@ -24,7 +24,7 @@ d_access='define' d_alarm='define' d_archlib='define' # randbits='15' -archobjs="ebcdic.o vmesa.o" +archobjs="vmesa.o" d_attribut='undef' d_bcmp='define' d_bcopy='define' @@ -294,7 +294,6 @@ make='gnumake' mallocobj='' mallocsrc='' malloctype='void *' -models='none' netdb_hlen_type='size_t' netdb_host_type='char *' netdb_name_type='const char *' diff --git a/contrib/perl5/hv.c b/contrib/perl5/hv.c index 44d37e34d300..321d403ca2f0 100644 --- a/contrib/perl5/hv.c +++ b/contrib/perl5/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. @@ -42,9 +42,14 @@ S_more_he(pTHX) { register HE* he; register HE* heend; - New(54, PL_he_root, 1008/sizeof(HE), HE); - he = PL_he_root; + XPV *ptr; + New(54, ptr, 1008/sizeof(XPV), XPV); + ptr->xpv_pv = (char*)PL_he_arenaroot; + PL_he_arenaroot = ptr; + + he = (HE*)ptr; heend = &he[1008 / sizeof(HE) - 1]; + PL_he_root = ++he; while (he < heend) { HeNEXT(he) = (HE*)(he + 1); he++; @@ -144,7 +149,6 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval) 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; @@ -241,7 +245,6 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) 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); @@ -458,7 +461,6 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash) xhv = (XPVHV*)SvANY(hv); if (SvMAGICAL(hv)) { - dTHR; bool needs_copy; bool needs_store; hv_magic_check (hv, &needs_copy, &needs_store); @@ -716,7 +718,6 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, U32 klen) 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')); @@ -792,7 +793,6 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) 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); @@ -1045,8 +1045,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(entry), + newSVsv(HeVAL(entry)), HeHASH(entry)); } HvRITER(ohv) = hv_riter; HvEITER(ohv) = hv_eiter; @@ -1444,12 +1444,8 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash) break; } UNLOCK_STRTAB_MUTEX; - - { - dTHR; - if (!found && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string"); - } + if (!found && ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string"); } /* get a (constant) string ptr from the global string table diff --git a/contrib/perl5/hv.h b/contrib/perl5/hv.h index 5bc38a0a79ae..6830d65f70b4 100644 --- a/contrib/perl5/hv.h +++ b/contrib/perl5/hv.h @@ -1,27 +1,31 @@ /* 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. * */ +/* typedefs to eliminate some typing */ typedef struct he HE; typedef struct hek HEK; +/* entry in hash value chain */ struct he { - HE *hent_next; - HEK *hent_hek; - SV *hent_val; + HE *hent_next; /* next entry in chain */ + HEK *hent_hek; /* hash key */ + SV *hent_val; /* scalar value that was hashed */ }; +/* hash key -- defined separately for use as shared pointer */ struct hek { - U32 hek_hash; - I32 hek_len; - char hek_key[1]; + U32 hek_hash; /* hash of key */ + I32 hek_len; /* length of hash key */ + char hek_key[1]; /* variable-length hash key */ }; +/* hash structure: */ /* This structure must match the beginning of struct xpvmg in sv.h. */ struct xpvhv { char * xhv_array; /* pointer to malloced string */ @@ -38,6 +42,7 @@ struct xpvhv { char *xhv_name; /* name, if a symbol table */ }; +/* hash a key */ #define PERL_HASH(hash,str,len) \ STMT_START { \ register const char *s_PeRlHaSh = str; \ @@ -171,6 +176,7 @@ C<SV*>. #define HEK_LEN(hek) (hek)->hek_len #define HEK_KEY(hek) (hek)->hek_key +/* calculate HV array allocation */ #if defined(STRANGE_MALLOC) || defined(MYMALLOC) # define PERL_HV_ARRAY_ALLOC_BYTES(size) ((size) * sizeof(HE*)) #else diff --git a/contrib/perl5/installhtml b/contrib/perl5/installhtml index cfbbe9f5c67a..d437ded13c0b 100755 --- a/contrib/perl5/installhtml +++ b/contrib/perl5/installhtml @@ -1,6 +1,6 @@ #!./perl -w -# This file should really be a extracted from a .PL +# This file should really be extracted from a .PL file use lib 'lib'; # use source library if present @@ -592,6 +592,7 @@ sub runpod2html { "--htmlroot=$htmlroot", "--podpath=".join(":", @podpath), "--podroot=$podroot", "--netscape", + "--header", ($doindex ? "--index" : "--noindex"), "--" . ($recurse ? "" : "no") . "recurse", ($#libpods >= 0) ? "--libpods=" . join(":", @libpods) : "", diff --git a/contrib/perl5/installman b/contrib/perl5/installman index c9fb0fe18cbf..06f68f5dddfe 100755 --- a/contrib/perl5/installman +++ b/contrib/perl5/installman @@ -1,5 +1,6 @@ -#!./perl +#!./perl -w BEGIN { @INC = ('lib') } +use strict; use Config; use Getopt::Long; use File::Find; @@ -7,40 +8,52 @@ use File::Copy; use File::Path qw(mkpath); use ExtUtils::Packlist; use subs qw(unlink chmod rename link); -use vars qw($packlist); +use vars qw($packlist @modpods); require Cwd; $ENV{SHELL} = 'sh' if $^O eq 'os2'; -$ver = $Config{version}; -$release = substr($],0,3); # Not used presently. -$patchlevel = substr($],3,2); +my $ver = $Config{version}; # Not used presently. +my $release = substr($],0,3); # Not used presently. +my $patchlevel = substr($],3,2); die "Patchlevel of perl ($patchlevel)", "and patchlevel of config.sh ($Config{'PERL_VERSION'}) don't match\n" if $patchlevel != $Config{'PERL_VERSION'}; -$usage = +my $usage = "Usage: installman --man1dir=/usr/wherever --man1ext=1 - --man3dir=/usr/wherever --man3ext=3 - --notify --help + --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'}; - --notify (or -n) just lists commands that would be executed.\n"; - -GetOptions( qw( man1dir=s man1ext=s man3dir=s man3ext=s notify n help)) + 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 batchlimit=i + notify n help silent S verbose V)) || die $usage; -die $usage if $opt_help; - -# These are written funny to avoid -w typo warnings. -$man1dir = defined($opt_man1dir) ? $opt_man1dir : $Config{'installman1dir'}; -$man1ext = defined($opt_man1ext) ? $opt_man1ext : $Config{'man1ext'}; -$man3dir = defined($opt_man3dir) ? $opt_man3dir : $Config{'installman3dir'}; -$man3ext = defined($opt_man3ext) ? $opt_man3ext : $Config{'man3ext'}; - -$notify = $opt_notify || $opt_n; +die $usage if $opts{help}; + +$opts{man1dir} = $Config{'installman1dir'} + unless defined($opts{man1dir}); +$opts{man1ext} = $Config{'man1ext'} + unless defined($opts{man1ext}); +$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}; #Sanity checks @@ -55,42 +68,30 @@ $notify = $opt_notify || $opt_n; $packlist = ExtUtils::Packlist->new("$Config{installarchlib}/.packlist"); # Install the main pod pages. -runpod2man('pod', $man1dir, $man1ext); +runpod2man('pod', $opts{man1dir}, $opts{man1ext}); # Install the pods for library modules. -runpod2man('lib', $man3dir, $man3ext); +runpod2man('lib', $opts{man3dir}, $opts{man3ext}); # Install the pods embedded in the installed scripts -runpod2man('utils', $man1dir, $man1ext, 'c2ph'); -runpod2man('utils', $man1dir, $man1ext, 'h2ph'); -runpod2man('utils', $man1dir, $man1ext, 'h2xs'); -runpod2man('utils', $man1dir, $man1ext, 'perlcc'); -runpod2man('utils', $man1dir, $man1ext, 'perldoc'); -runpod2man('utils', $man1dir, $man1ext, 'perlbug'); -runpod2man('utils', $man1dir, $man1ext, 'pl2pm'); -runpod2man('utils', $man1dir, $man1ext, 'splain'); -runpod2man('utils', $man1dir, $man1ext, 'dprofpp'); -runpod2man('x2p', $man1dir, $man1ext, 's2p'); -runpod2man('x2p', $man1dir, $man1ext, 'a2p.pod'); -runpod2man('x2p', $man1dir, $man1ext, 'find2perl'); -runpod2man('pod', $man1dir, $man1ext, 'pod2man'); -runpod2man('pod', $man1dir, $man1ext, 'pod2html'); -runpod2man('pod', $man1dir, $man1ext, 'pod2text'); -runpod2man('pod', $man1dir, $man1ext, 'pod2usage'); -runpod2man('pod', $man1dir, $man1ext, 'podchecker'); -runpod2man('pod', $man1dir, $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", -# but then it would have to pay attention to $man1dir and $man1ext. -runpod2man('utils', $man1dir, $man1ext, 'pstruct'); +# but then it would have to pay attention to $opts{man1dir} and $opts{man1ext}. +runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'pstruct'); -runpod2man('lib/ExtUtils', $man1dir, $man1ext, 'xsubpp'); +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 @@ -99,12 +100,16 @@ sub runpod2man { my($builddir) = Cwd::getcwd(); if ($mandir eq ' ' or $mandir eq '') { - print STDERR "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; } - print STDERR "chdir $poddir\n"; + print "chdir $poddir\n" if $opts{verbose}; chdir $poddir || die "Unable to cd to $poddir directory!\n$!\n"; # We insist on using the current version of pod2man in case there @@ -118,21 +123,22 @@ sub runpod2man { # yet. (The user may have set the $install* Configure variables # to point to some temporary home, from which the executable gets # installed by occult means.) - $pod2man = "$downdir/perl -I $downdir/lib $downdir/pod/pod2man --section=$manext --official"; + my $pod2man = "$downdir/perl -I $downdir/lib $downdir/pod/pod2man --section=$manext --official"; - mkpath($mandir, 1, 0777) unless $notify; # In File::Path + mkpath($mandir, $opts{verbose}, 0777) unless $opts{notify}; # In File::Path # 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 = (); - find(\&lsmodpods, '.'); + File::Find::find(\&lsmodpods, '.'); } - foreach $mod (@modpods) { - $manpage = $mod; + my @to_process; + foreach my $mod (@modpods) { + my $manpage = $mod; my $tmp; # Skip .pm files that have corresponding .pod files, and Functions.pm. next if (($tmp = $mod) =~ s/\.pm$/.pod/ && -f $tmp); @@ -149,18 +155,28 @@ sub runpod2man { } $tmp = "${mandir}/${manpage}.tmp"; $manpage = "${mandir}/${manpage}.${manext}"; - if (&cmd("$pod2man $mod > $tmp") == 0 && !$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 ($notify) { - unlink($tmp); - } } chdir "$builddir" || die "Unable to cd back to $builddir directory!\n$!\n"; - print STDERR "chdir $builddir\n"; + print " chdir $builddir\n" if $opts{verbose}; } sub lsmodpods { @@ -172,8 +188,8 @@ sub lsmodpods { } } -$packlist->write() unless $notify; -print STDERR " Installation complete\n"; +$packlist->write() unless $opts{notify}; +print " Installation complete\n" if $opts{verbose}; exit 0; @@ -182,9 +198,9 @@ exit 0; # Utility subroutines from installperl sub cmd { - local($cmd) = @_; - print STDERR " $cmd\n"; - unless ($notify) { + my ($cmd) = @_; + print " $cmd\n" if $opts{verbose}; + unless ($opts{notify}) { if ($Config{d_fork}) { fork ? wait : exec $cmd; # Allow user to ^C out of command. } @@ -197,15 +213,15 @@ sub cmd { } sub unlink { - local(@names) = @_; + my(@names) = @_; my $cnt = 0; - foreach $name (@names) { + foreach my $name (@names) { next unless -e $name; chmod 0777, $name if $^O eq 'os2'; - print STDERR " unlink $name\n"; + print " unlink $name\n" if $opts{verbose}; ( CORE::unlink($name) and ++$cnt - or warn "Couldn't unlink $name: $!\n" ) unless $notify; + or warn "Couldn't unlink $name: $!\n" ) unless $opts{notify}; } return $cnt; } @@ -214,26 +230,26 @@ sub link { my($from,$to) = @_; my($success) = 0; - print STDERR " ln $from $to\n"; + print $opts{verbose} ? " ln $from $to\n" : " $to\n" unless $opts{silent}; eval { CORE::link($from, $to) ? $success++ : ($from =~ m#^/afs/# || $to =~ m#^/afs/#) ? die "AFS" # okay inside eval {} : warn "Couldn't link $from to $to: $!\n" - unless $notify; + unless $opts{notify}; }; if ($@) { File::Copy::copy($from, $to) ? $success++ : warn "Couldn't copy $from to $to: $!\n" - unless $notify; + unless $opts{notify}; } $success; } sub rename { - local($from,$to) = @_; + my($from,$to) = @_; if (-f $to and not unlink($to)) { my($i); for ($i = 1; $i < 50; $i++) { @@ -247,16 +263,16 @@ sub rename { } sub chmod { - local($mode,$name) = @_; + my($mode,$name) = @_; - printf STDERR " chmod %o %s\n", $mode, $name; + printf " chmod %o %s\n", $mode, $name if $opts{verbose}; CORE::chmod($mode,$name) || warn sprintf("Couldn't chmod %o %s: $!\n",$mode,$name) - unless $notify; + unless $opts{notify}; } sub samepath { - local($p1, $p2) = @_; - local($dev1, $ino1, $dev2, $ino2); + my($p1, $p2) = @_; + my($dev1, $ino1, $dev2, $ino2); if ($p1 ne $p2) { ($dev1, $ino1) = stat($p1); diff --git a/contrib/perl5/installperl b/contrib/perl5/installperl index b2ddc84c2444..d28027ce3575 100755 --- a/contrib/perl5/installperl +++ b/contrib/perl5/installperl @@ -8,7 +8,9 @@ BEGIN { } use strict; -use vars qw($Is_VMS $Is_W32 $Is_OS2 $Is_Cygwin $nonono $dostrip $versiononly $depth); +my ($Is_VMS, $Is_W32, $Is_OS2, $Is_Cygwin, $nonono, $dostrip, + $versiononly, $silent, $verbose, $otherperls); +use vars qw /$depth/; BEGIN { $Is_VMS = $^O eq 'VMS'; @@ -27,7 +29,6 @@ use File::Path (); use ExtUtils::Packlist; use Config; use subs qw(unlink link chmod); -use vars qw($packlist); # override the ones in the rest of the script sub mkpath { @@ -48,13 +49,19 @@ my $perl_verbase = defined($ENV{PERLNAME_VERBASE}) ? $ENV{PERLNAME_VERBASE} : $perl; +$otherperls = 1; while (@ARGV) { $nonono = 1 if $ARGV[0] eq '-n'; $dostrip = 1 if $ARGV[0] eq '-s'; $versiononly = 1 if $ARGV[0] eq '-v'; + $silent = 1 if $ARGV[0] eq '-S'; + $otherperls = 0 if $ARGV[0] eq '-o'; + $verbose = 1 if $ARGV[0] eq '-V' || $ARGV [0] eq '-n'; shift; } +$versiononly = 1 if $Config{versiononly}; + my @scripts = qw(utils/c2ph utils/h2ph utils/h2xs utils/perlbug utils/perldoc utils/pl2pm utils/splain utils/perlcc utils/dprofpp x2p/s2p x2p/find2perl @@ -109,7 +116,7 @@ find(sub { # print "[$_]\n" for sort keys %archpms; my $ver = $Config{version}; -my $release = substr($],0,3); # Not used presently. +my $release = substr($],0,3); # Not used currently. my $patchlevel = substr($],3,2); die "Patchlevel of perl ($patchlevel)", "and patchlevel of config.sh ($Config{'PERL_VERSION'}) don't match\n" @@ -129,6 +136,15 @@ my $libperl = $Config{libperl}; my $so = $Config{so}; my $dlext = $Config{dlext}; my $dlsrc = $Config{dlsrc}; +if ($^O eq 'os390') { + my $usedl = $Config{usedl}; + if ($usedl eq 'define') { + my $pwd; + chomp($pwd=`pwd`); + my $archlibexp = $Config{archlibexp}; + `./$^X -p -e 's{$pwd\/libperl.x}{$archlibexp/CORE/libperl.x}' lib/Config.pm`; + } +} my $d_dosuid = $Config{d_dosuid}; my $binexp = $Config{binexp}; @@ -146,7 +162,7 @@ if ($Is_VMS) { # Hang in there until File::Spec hits the big time if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; } $installbin || die "No installbin directory in config.sh\n"; --d $installbin || mkpath($installbin, 1, 0777); +-d $installbin || mkpath($installbin, $verbose, 0777); -d $installbin || $nonono || die "$installbin is not a directory\n"; -w $installbin || $nonono || die "$installbin is not writable by you\n" unless $installbin =~ m#^/afs/# || $nonono; @@ -154,36 +170,36 @@ if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; } -x 'perl' . $exe_ext || die "perl isn't executable!\n"; -x 'suidperl' . $exe_ext|| die "suidperl isn't executable!\n" if $d_dosuid; --x 't/TEST' || $Is_W32 +-f 't/rantests' || $Is_W32 || warn "WARNING: You've never run 'make test'!!!", " (Installing anyway.)\n"; if ($Is_W32 or $Is_Cygwin) { my $perldll; -if ($Is_Cygwin) { - $perldll = $libperl; - $perldll =~ s/(\..*)?$/.$dlext/; - if ($Config{useshrplib} eq 'true') { - # install ld2 and perlld as well - foreach ('ld2', 'perlld') { - safe_unlink("$installbin/$_"); - copy("$_", "$installbin/$_"); - chmod(0755, "$installbin/$_"); + if ($Is_Cygwin) { + $perldll = $libperl; + $perldll =~ s/(\..*)?$/.$dlext/; + if ($Config{useshrplib} eq 'true') { + # install ld2 and perlld as well + foreach ('ld2', 'perlld') { + safe_unlink("$installbin/$_"); + copy("$_", "$installbin/$_"); + chmod(0755, "$installbin/$_"); + }; }; - }; -} else { - $perldll = 'perl56.' . $dlext; -} - - if ($dlsrc ne "dl_none.xs") { - -f $perldll || die "No perl DLL built\n"; - } -# Install the DLL - - safe_unlink("$installbin/$perldll"); - copy("$perldll", "$installbin/$perldll"); - chmod(0755, "$installbin/$perldll"); + } else { + $perldll = 'perl56.' . $dlext; + } + + if ($dlsrc ne "dl_none.xs") { + -f $perldll || die "No perl DLL built\n"; + } + # Install the DLL + + safe_unlink("$installbin/$perldll"); + copy("$perldll", "$installbin/$perldll"); + chmod(0755, "$installbin/$perldll"); } # if ($Is_W32 or $Is_Cygwin) @@ -231,10 +247,10 @@ if ($d_dosuid) { my ($do_installarchlib, $do_installprivlib) = (0, 0); -mkpath($installprivlib, 1, 0777); -mkpath($installarchlib, 1, 0777); -mkpath($installsitelib, 1, 0777) if ($installsitelib); -mkpath($installsitearch, 1, 0777) if ($installsitearch); +mkpath($installprivlib, $verbose, 0777); +mkpath($installarchlib, $verbose, 0777); +mkpath($installsitelib, $verbose, 0777) if ($installsitelib); +mkpath($installsitearch, $verbose, 0777) if ($installsitearch); if (chdir "lib") { $do_installarchlib = ! samepath($installarchlib, '.'); @@ -251,12 +267,12 @@ else { } # Install header files and libraries. -mkpath("$installarchlib/CORE", 1, 0777); +mkpath("$installarchlib/CORE", $verbose, 0777); my @corefiles; if ($Is_VMS) { # We did core file selection during build - my $coredir = "lib/$Config{'arch'}/$ver"; + my $coredir = "lib/$Config{archname}/$ver/CORE"; $coredir =~ tr/./_/; - @corefiles = map { s|^$coredir/||i; } <$coredir/*.*>; + map { s|^$coredir/||i; } @corefiles = <$coredir/*.*>; } else { # [als] hard-coded 'libperl' name... not good! @@ -266,7 +282,7 @@ else { push(@corefiles,'perl.exp') if $^O eq 'aix'; if ($^O eq 'mpeix') { # MPE needs mpeixish.h installed as well. - mkpath("$installarchlib/CORE/mpeix", 1, 0777); + mkpath("$installarchlib/CORE/mpeix", $verbose, 0777); push(@corefiles,'mpeix/mpeixish.h'); } # If they have built sperl.o... @@ -307,7 +323,7 @@ if (! $versiononly && ! samepath($installbin, '.') && ($^O ne 'dos') && ! $Is_VM my $mainperl_is_instperl = 0; -if ($Config{installusrbinperl} eq 'define' && +if ($Config{installusrbinperl} && $Config{installusrbinperl} eq 'define' && !$versiononly && !$nonono && !$Is_W32 && !$Is_VMS && -t STDIN && -t STDERR && -w $mainperldir && ! samepath($mainperldir, $installbin)) { my($usrbinperl) = "$mainperldir/$perl$exe_ext"; @@ -359,26 +375,25 @@ if (! $versiononly && (-f 'cppstdin') && (! samepath($installbin, '.'))) { chmod(0755, "$installbin/cppstdin"); } -# Install scripts. +if (! $versiononly) { + # Install scripts. -mkpath($installscript, 1, 0777); + mkpath($installscript, $verbose, 0777); -if (! $versiononly) { for (@scripts) { (my $base = $_) =~ s#.*/##; copy($_, "$installscript/$base"); chmod(0755, "$installscript/$base"); } -} -# pstruct should be a link to c2ph - -if (! $versiononly) { + # pstruct should be a link to c2ph safe_unlink("$installscript/pstruct$scr_ext"); if ($^O eq 'dos' or $Is_VMS or $^O eq 'transit') { - copy("$installscript/c2ph$scr_ext", "$installscript/pstruct$scr_ext"); + copy("$installscript/c2ph$scr_ext", + "$installscript/pstruct$scr_ext"); } else { - link("$installscript/c2ph$scr_ext", "$installscript/pstruct$scr_ext"); + link("$installscript/c2ph$scr_ext", + "$installscript/pstruct$scr_ext"); } } @@ -386,8 +401,8 @@ if (! $versiononly) { # ($installprivlib/pods for cygwin). my $pod = $Is_Cygwin ? 'pods' : 'pod'; -unless ( $versiononly && !($installprivlib =~ m/\Q$ver/)) { - mkpath("${installprivlib}/$pod", 1, 0777); +if ( !$versiononly || ($installprivlib =~ m/\Q$ver/)) { + mkpath("${installprivlib}/$pod", $verbose, 0777); # If Perl 5.003's perldiag.pod is there, rename it. if (open POD, "${installprivlib}/$pod/perldiag.pod") { @@ -418,7 +433,7 @@ unless ( $versiononly && !($installprivlib =~ m/\Q$ver/)) { # Also skip $mainperl if the user opted to have it be a link to the # installed perl. -if (!$versiononly) { +if (!$versiononly && $otherperls) { my ($path, @path); my $dirsep = ($Is_OS2 || $Is_W32) ? ';' : ':' ; ($path = $ENV{"PATH"}) =~ s:\\:/:g ; @@ -444,18 +459,18 @@ if (!$versiononly) { if (-x $otherperl && ! -d $otherperl); } if (@otherperls) { - print STDERR "\nWarning: $perl appears in your path in the following " . + warn "\nWarning: $perl appears in your path in the following " . "locations beyond where\nwe just installed it:\n"; for (@otherperls) { - print STDERR " ", $_, "\n"; + warn " ", $_, "\n"; } - print STDERR "\n"; + warn "\n"; } } $packlist->write() unless $nonono; -print " Installation complete\n"; +print " Installation complete\n" if $verbose; exit 0; @@ -465,7 +480,7 @@ sub yn { my($prompt) = @_; my($answer); my($default) = $prompt =~ m/\[([yn])\]\s*$/i; - print $prompt; + warn $prompt; chop($answer = <STDIN>); $answer = $default if $answer =~ m/^\s*$/; ($answer =~ m/^[yY]/); @@ -480,7 +495,7 @@ sub unlink { foreach my $name (@names) { next unless -e $name; chmod 0777, $name if ($Is_OS2 || $Is_W32 || $Is_Cygwin); - print " unlink $name\n"; + print " unlink $name\n" if $verbose; ( CORE::unlink($name) and ++$cnt or warn "Couldn't unlink $name: $!\n" ) unless $nonono; } @@ -493,11 +508,11 @@ sub safe_unlink { foreach my $name (@names) { next unless -e $name; chmod 0777, $name if ($Is_OS2 || $Is_W32); - print " unlink $name\n"; + print " unlink $name\n" if $verbose; next if CORE::unlink($name); warn "Couldn't unlink $name: $!\n"; if ($! =~ /busy/i) { - print " mv $name $name.old\n"; + print " mv $name $name.old\n" if $verbose; safe_rename($name, "$name.old") or warn "Couldn't rename $name: $!\n"; } @@ -522,7 +537,7 @@ sub link { my($from,$to) = @_; my($success) = 0; - print " ln $from $to\n"; + print $verbose ? " ln $from $to\n" : " $to\n" unless $silent; eval { CORE::link($from, $to) ? $success++ @@ -534,8 +549,9 @@ sub link { }; if ($@) { warn $@; - print " cp $from $to\n"; - print " creating new version of $to\n" if $Is_VMS and -e $to; + print $verbose ? " cp $from $to\n" : " $to\n" unless $silent; + print " creating new version of $to\n" + if $Is_VMS and -e $to and !$silent; File::Copy::copy($from, $to) ? $success++ : warn "Couldn't copy $from to $to: $!\n" @@ -549,7 +565,7 @@ sub chmod { my($mode,$name) = @_; return if ($^O eq 'dos'); - printf " chmod %o %s\n", $mode, $name; + printf " chmod %o %s\n", $mode, $name if $verbose; CORE::chmod($mode,$name) || warn sprintf("Couldn't chmod %o %s: $!\n", $mode, $name) unless $nonono; @@ -558,8 +574,8 @@ sub chmod { sub copy { my($from,$to) = @_; - print " cp $from $to\n"; - print " creating new version of $to\n" if $Is_VMS and -e $to; + print $verbose ? " cp $from $to\n" : " $to\n" unless $silent; + print " creating new version of $to\n" if $Is_VMS and -e $to and !$silent; File::Copy::copy($from, $to) || warn "Couldn't copy $from to $to: $!\n" unless $nonono; @@ -624,7 +640,7 @@ sub installlib { $packlist->{"$installlib/$name"} = { type => 'file' }; if (compare($_, "$installlib/$name") || $nonono) { unlink("$installlib/$name"); - mkpath("$installlib/$dir", 1, 0777); + mkpath("$installlib/$dir", $verbose, 0777); # HP-UX (at least) needs to maintain execute permissions # on dynamically-loaded libraries. copy_if_diff($_, "$installlib/$name") @@ -677,10 +693,10 @@ sub strip foreach my $file (@args) { if (-f $file) { - print " strip $file\n"; + print " strip $file\n" if $verbose; system("strip", @opts, $file); } else { - print "# file '$file' skipped\n"; + print "# file '$file' skipped\n" if $verbose; } } } diff --git a/contrib/perl5/intrpvar.h b/contrib/perl5/intrpvar.h index 39d14c985e4d..57f31bbe1f11 100644 --- a/contrib/perl5/intrpvar.h +++ b/contrib/perl5/intrpvar.h @@ -34,7 +34,7 @@ PERLVAR(Iminus_F, bool) PERLVAR(Idoswitches, bool) /* -=for apidoc Amn|bool|PL_dowarn +=for apidoc mn|bool|PL_dowarn The C variable which corresponds to Perl's $^W warning variable. @@ -89,20 +89,20 @@ PERLVAR(IDBgv, GV *) PERLVAR(IDBline, GV *) /* -=for apidoc Amn|GV *|PL_DBsub +=for apidoc mn|GV *|PL_DBsub When Perl is run in debugging mode, with the B<-d> switch, this GV contains the SV which holds the name of the sub being debugged. This is the C variable which corresponds to Perl's $DB::sub variable. See C<PL_DBsingle>. -=for apidoc Amn|SV *|PL_DBsingle +=for apidoc mn|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. Single-stepping is automatically turned on after every step. This is the C variable which corresponds to Perl's $DB::single variable. See C<PL_DBsub>. -=for apidoc Amn|SV *|PL_DBtrace +=for apidoc mn|SV *|PL_DBtrace Trace variable used when Perl is run in debugging mode, with the B<-d> switch. This is the C variable which corresponds to Perl's $DB::trace variable. See C<PL_DBsingle>. @@ -245,19 +245,19 @@ PERLVARI(Ish_path, char *, SH_PATH)/* full path of shell */ PERLVAR(Isighandlerp, Sighandler_t) PERLVAR(Ixiv_arenaroot, XPV*) /* list of allocated xiv areas */ -PERLVAR(Ixiv_root, IV *) /* free xiv list--shared by interpreters */ -PERLVAR(Ixnv_root, NV *) /* free xnv list--shared by interpreters */ -PERLVAR(Ixrv_root, XRV *) /* free xrv list--shared by interpreters */ -PERLVAR(Ixpv_root, XPV *) /* free xpv list--shared by interpreters */ -PERLVAR(Ixpviv_root, XPVIV *) /* free xpviv list--shared by interpreters */ -PERLVAR(Ixpvnv_root, XPVNV *) /* free xpvnv list--shared by interpreters */ -PERLVAR(Ixpvcv_root, XPVCV *) /* free xpvcv list--shared by interpreters */ -PERLVAR(Ixpvav_root, XPVAV *) /* free xpvav list--shared by interpreters */ -PERLVAR(Ixpvhv_root, XPVHV *) /* free xpvhv list--shared by interpreters */ -PERLVAR(Ixpvmg_root, XPVMG *) /* free xpvmg list--shared by interpreters */ -PERLVAR(Ixpvlv_root, XPVLV *) /* free xpvlv list--shared by interpreters */ -PERLVAR(Ixpvbm_root, XPVBM *) /* free xpvbm list--shared by interpreters */ -PERLVAR(Ihe_root, HE *) /* free he list--shared by interpreters */ +PERLVAR(Ixiv_root, IV *) /* free xiv list */ +PERLVAR(Ixnv_root, NV *) /* free xnv list */ +PERLVAR(Ixrv_root, XRV *) /* free xrv list */ +PERLVAR(Ixpv_root, XPV *) /* free xpv list */ +PERLVAR(Ixpviv_root, XPVIV *) /* free xpviv list */ +PERLVAR(Ixpvnv_root, XPVNV *) /* free xpvnv list */ +PERLVAR(Ixpvcv_root, XPVCV *) /* free xpvcv list */ +PERLVAR(Ixpvav_root, XPVAV *) /* free xpvav list */ +PERLVAR(Ixpvhv_root, XPVHV *) /* free xpvhv list */ +PERLVAR(Ixpvmg_root, XPVMG *) /* free xpvmg list */ +PERLVAR(Ixpvlv_root, XPVLV *) /* free xpvlv list */ +PERLVAR(Ixpvbm_root, XPVBM *) /* free xpvbm list */ +PERLVAR(Ihe_root, HE *) /* free he list */ PERLVAR(Inice_chunk, char *) /* a nice chunk of memory to reuse */ PERLVAR(Inice_chunk_size, U32) /* how nice the chunk of memory is */ @@ -363,8 +363,8 @@ PERLVARI(Inumeric_standard, bool, TRUE) /* Assume simple numerics */ PERLVARI(Inumeric_local, bool, TRUE) /* Assume local numerics */ -PERLVAR(Inumeric_radix, char) - /* The radix character if not '.' */ +PERLVAR(Idummy1_bincompat, char) + /* Used to be numeric_radix */ #endif /* !USE_LOCALE_NUMERIC */ @@ -443,3 +443,33 @@ PERLVAR(IProc, struct IPerlProc*) #if defined(USE_ITHREADS) PERLVAR(Iptr_table, PTR_TBL_t*) #endif +PERLVARI(Ibeginav_save, AV*, Nullav) /* save BEGIN{}s when compiling */ + +#ifdef USE_THREADS +PERLVAR(Ifdpid_mutex, perl_mutex) /* mutex for fdpid array */ +PERLVAR(Isv_lock_mutex, perl_mutex) /* mutex for SvLOCK macro */ +#endif + +PERLVAR(Inullstash, HV *) /* illegal symbols end up here */ + +PERLVAR(Ixnv_arenaroot, XPV*) /* list of allocated xnv areas */ +PERLVAR(Ixrv_arenaroot, XPV*) /* list of allocated xrv areas */ +PERLVAR(Ixpv_arenaroot, XPV*) /* list of allocated xpv areas */ +PERLVAR(Ixpviv_arenaroot,XPVIV*) /* list of allocated xpviv areas */ +PERLVAR(Ixpvnv_arenaroot,XPVNV*) /* list of allocated xpvnv areas */ +PERLVAR(Ixpvcv_arenaroot,XPVCV*) /* list of allocated xpvcv areas */ +PERLVAR(Ixpvav_arenaroot,XPVAV*) /* list of allocated xpvav areas */ +PERLVAR(Ixpvhv_arenaroot,XPVHV*) /* list of allocated xpvhv areas */ +PERLVAR(Ixpvmg_arenaroot,XPVMG*) /* list of allocated xpvmg areas */ +PERLVAR(Ixpvlv_arenaroot,XPVLV*) /* list of allocated xpvlv areas */ +PERLVAR(Ixpvbm_arenaroot,XPVBM*) /* list of allocated xpvbm areas */ +PERLVAR(Ihe_arenaroot, XPV*) /* list of allocated he areas */ + +#ifdef USE_LOCALE_NUMERIC + +PERLVAR(Inumeric_radix_sv, SV *) /* The radix separator if not '.' */ +#endif + +/* New variables must be added to the very end for binary compatibility. + * XSUB.h provides wrapper functions via perlapi.h that make this + * irrelevant, but not all code may be expected to #include XSUB.h. */ diff --git a/contrib/perl5/iperlsys.h b/contrib/perl5/iperlsys.h index f36dcd5f32ac..2f08a24c68e4 100644 --- a/contrib/perl5/iperlsys.h +++ b/contrib/perl5/iperlsys.h @@ -186,13 +186,19 @@ struct IPerlStdIOInfo #ifdef USE_STDIO_PTR # define PerlIO_has_cntptr(f) 1 -# ifdef STDIO_CNT_LVALUE -# define PerlIO_canset_cnt(f) 1 -# ifdef STDIO_PTR_LVALUE +# ifdef STDIO_PTR_LVALUE +# ifdef STDIO_CNT_LVALUE +# define PerlIO_canset_cnt(f) 1 +# ifdef STDIO_PTR_LVAL_NOCHANGE_CNT +# define PerlIO_fast_gets(f) 1 +# endif +# else /* STDIO_CNT_LVALUE */ +# define PerlIO_canset_cnt(f) 0 +# endif +# else /* STDIO_PTR_LVALUE */ +# ifdef STDIO_PTR_LVAL_SETS_CNT # define PerlIO_fast_gets(f) 1 # endif -# else -# define PerlIO_canset_cnt(f) 0 # endif #else /* USE_STDIO_PTR */ # define PerlIO_has_cntptr(f) 0 @@ -266,7 +272,7 @@ struct IPerlStdIOInfo #define PerlIO_setlinebuf(f) \ (*PL_StdIO->pSetlinebuf)(PL_StdIO, (f)) #define PerlIO_printf Perl_fprintf_nocontext -#define PerlIO_stdoutf *PL_StdIO->pPrintf +#define PerlIO_stdoutf Perl_printf_nocontext #define PerlIO_vprintf(f,fmt,a) \ (*PL_StdIO->pVprintf)(PL_StdIO, (f),(fmt),a) #define PerlIO_tell(f) \ @@ -466,11 +472,19 @@ extern PerlIO * PerlIO_stdout (void); extern PerlIO * PerlIO_stderr (void); #endif #ifndef PerlIO_getpos +#ifdef USE_SFIO +extern int PerlIO_getpos (PerlIO *,Off_t *); +#else extern int PerlIO_getpos (PerlIO *,Fpos_t *); #endif +#endif #ifndef PerlIO_setpos +#ifdef USE_SFIO +extern int PerlIO_setpos (PerlIO *,const Off_t *); +#else extern int PerlIO_setpos (PerlIO *,const Fpos_t *); #endif +#endif #ifndef PerlIO_fdupopen extern PerlIO * PerlIO_fdupopen (PerlIO *); #endif @@ -551,7 +565,7 @@ struct IPerlDirInfo #define PerlDir_mkdir(name, mode) Mkdir((name), (mode)) #ifdef VMS -# define PerlDir_chdir(n) chdir(((n) && *(n)) ? (n) : "SYS$LOGIN") +# define PerlDir_chdir(n) Chdir(((n) && *(n)) ? (n) : "SYS$LOGIN") #else # define PerlDir_chdir(name) chdir((name)) #endif diff --git a/contrib/perl5/lib/AutoLoader.pm b/contrib/perl5/lib/AutoLoader.pm index 8fd7d3b8fe2a..ad6bc4013b77 100644 --- a/contrib/perl5/lib/AutoLoader.pm +++ b/contrib/perl5/lib/AutoLoader.pm @@ -4,15 +4,19 @@ use 5.005_64; our(@EXPORT, @EXPORT_OK, $VERSION); my $is_dosish; +my $is_epoc; my $is_vms; +my $is_macos; BEGIN { require Exporter; @EXPORT = @EXPORT = (); @EXPORT_OK = @EXPORT_OK = qw(AUTOLOAD); $is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32'; + $is_epoc = $^O eq 'epoc'; $is_vms = $^O eq 'VMS'; - $VERSION = '5.57'; + $is_macos = $^O eq 'MacOS'; + $VERSION = '5.58'; } AUTOLOAD { @@ -36,7 +40,12 @@ AUTOLOAD { my ($pkg,$func) = ($sub =~ /(.*)::([^:]+)$/); $pkg =~ s#::#/#g; if (defined($filename = $INC{"$pkg.pm"})) { - $filename =~ s#^(.*)$pkg\.pm\z#$1auto/$pkg/$func.al#s; + if ($is_macos) { + $pkg =~ tr#/#:#; + $filename =~ s#^(.*)$pkg\.pm\z#$1auto:$pkg:$func.al#s; + } else { + $filename =~ s#^(.*)$pkg\.pm\z#$1auto/$pkg/$func.al#s; + } # if the file exists, then make sure that it is a # a fully anchored path (i.e either '/usr/lib/auto/foo/bar.al', @@ -51,11 +60,15 @@ AUTOLOAD { $filename = "./$filename"; } } - elsif ($is_vms) { + elsif ($is_epoc) { + unless ($filename =~ m{^([a-z?]:)?[\\/]}is) { + $filename = "./$filename"; + } + }elsif ($is_vms) { # XXX todo by VMSmiths $filename = "./$filename"; } - else { + elsif (!$is_macos) { $filename = "./$filename"; } } @@ -140,6 +153,11 @@ sub import { } } +sub unimport { + my $callpkg = caller; + eval "package $callpkg; sub AUTOLOAD;"; +} + 1; __END__ @@ -259,6 +277,12 @@ the package namespace. Variables pre-declared with this pragma will be visible to any autoloaded routines (but will not be invisible outside the package, unfortunately). +=head2 Not Using AutoLoader + +You can stop using AutoLoader by simply + + no AutoLoader; + =head2 B<AutoLoader> vs. B<SelfLoader> The B<AutoLoader> is similar in purpose to B<SelfLoader>: both delay the diff --git a/contrib/perl5/lib/AutoSplit.pm b/contrib/perl5/lib/AutoSplit.pm index 0be3ae6765a1..8fcf528101f9 100644 --- a/contrib/perl5/lib/AutoSplit.pm +++ b/contrib/perl5/lib/AutoSplit.pm @@ -6,6 +6,7 @@ use Config qw(%Config); use Carp qw(carp); use File::Basename (); use File::Path qw(mkpath); +use File::Spec::Functions qw(curdir catfile); use strict; our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen, $CheckForAutoloader, $CheckModTime); @@ -173,16 +174,23 @@ sub autosplit_lib_modules{ my(@modules) = @_; # list of Module names while(defined($_ = shift @modules)){ - s#::#/#g; # incase specified as ABC::XYZ + while (m#(.*?[^:])::([^:].*)#) { # in case specified as ABC::XYZ + $_ = catfile($1, $2); + } s|\\|/|g; # bug in ksh OS/2 s#^lib/##s; # incase specified as lib/*.pm + my($lib) = catfile(curdir(), "lib"); + if ($Is_VMS) { # may need to convert VMS-style filespecs + $lib =~ s#^\[\]#.\/#; + } + s#^$lib\W+##s; # incase specified as ./lib/*.pm if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs my ($dir,$name) = (/(.*])(.*)/s); $dir =~ s/.*lib[\.\]]//s; $dir =~ s#[\.\]]#/#g; $_ = $dir . $name; } - autosplit_file("lib/$_", "lib/auto", + autosplit_file(catfile($lib, $_), catfile($lib, "auto"), $Keep, $CheckForAutoloader, $CheckModTime); } 0; @@ -199,7 +207,7 @@ sub autosplit_file { local($/) = "\n"; # where to write output files - $autodir ||= "lib/auto"; + $autodir ||= catfile(curdir(), "lib", "auto"); if ($Is_VMS) { ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||; $filename = VMS::Filespec::unixify($filename); # may have dirs @@ -245,6 +253,9 @@ sub autosplit_file { $def_package or die "Can't find 'package Name;' in $filename\n"; my($modpname) = _modpname($def_package); + if ($Is_VMS) { + $modpname = VMS::Filespec::unixify($modpname); # may have dirs + } # this _has_ to match so we have a reasonable timestamp file die "Package $def_package ($modpname.pm) does not ". @@ -253,7 +264,7 @@ sub autosplit_file { ($^O eq 'dos') or ($^O eq 'MSWin32') or $Is_VMS && $filename =~ m/$modpname.pm/i); - my($al_idx_file) = "$autodir/$modpname/$IndexFile"; + my($al_idx_file) = catfile($autodir, $modpname, $IndexFile); if ($check_mod_time){ my($al_ts_time) = (stat("$al_idx_file"))[9] || 1; @@ -264,11 +275,12 @@ sub autosplit_file { } } - print "AutoSplitting $filename ($autodir/$modpname)\n" + my($modnamedir) = catfile($autodir, $modpname); + print "AutoSplitting $filename ($modnamedir)\n" if $Verbose; - unless (-d "$autodir/$modpname"){ - mkpath("$autodir/$modpname",0,0777); + unless (-d $modnamedir){ + mkpath($modnamedir,0,0777); } # We must try to deal with some SVR3 systems with a limit of 14 @@ -311,9 +323,10 @@ sub autosplit_file { push(@subnames, $fq_subname); my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3)); $modpname = _modpname($this_package); - mkpath("$autodir/$modpname",0,0777); - my($lpath) = "$autodir/$modpname/$lname.al"; - my($spath) = "$autodir/$modpname/$sname.al"; + my($modnamedir) = catfile($autodir, $modpname); + mkpath($modnamedir,0,0777); + my($lpath) = catfile($modnamedir, "$lname.al"); + my($spath) = catfile($modnamedir, "$sname.al"); my $path; if (!$Is83 and open(OUT, ">$lpath")){ $path=$lpath; @@ -379,7 +392,7 @@ EOT opendir(OUTDIR,$dir); foreach (sort readdir(OUTDIR)){ next unless /\.al\z/; - my($file) = "$dir/$_"; + my($file) = catfile($dir, $_); $file = lc $file if $Is83 or $Is_VMS; next if $outfiles{$file}; print " deleting $file\n" if ($Verbose>=2); @@ -418,7 +431,9 @@ sub _modpname ($) { if ($^O eq 'MSWin32') { $modpname =~ s#::#\\#g; } else { - $modpname =~ s#::#/#g; + while ($modpname =~ m#(.*?[^:])::([^:].*)#) { + $modpname = catfile($1, $2); + } } $modpname; } diff --git a/contrib/perl5/lib/Benchmark.pm b/contrib/perl5/lib/Benchmark.pm index 3c10a5bc523b..b557be3cc7a6 100644 --- a/contrib/perl5/lib/Benchmark.pm +++ b/contrib/perl5/lib/Benchmark.pm @@ -552,7 +552,9 @@ sub countit { # accuracy since we're not couting these times. $n = int( $tpra * 1.05 * $n / $tc ); # Linear approximation. my $td = timeit($n, $code); - $tc = $td->[1] + $td->[2]; + my $new_tc = $td->[1] + $td->[2]; + # Make sure we are making progress. + $tc = $new_tc > 1.2 * $tc ? $new_tc : 1.2 * $tc; } # Now, do the 'for real' timing(s), repeating until we exceed @@ -581,6 +583,7 @@ sub countit { $ttot = $utot + $stot; last if $ttot >= $tmax; + $ttot = 0.01 if $ttot < 0.01; my $r = $tmax / $ttot - 1; # Linear approximation. $n = int( $r * $ntot ); $n = $nmin if $n < $nmin; diff --git a/contrib/perl5/lib/CPAN.pm b/contrib/perl5/lib/CPAN.pm index 84dfd31a2b8c..fdaadb3be7ac 100644 --- a/contrib/perl5/lib/CPAN.pm +++ b/contrib/perl5/lib/CPAN.pm @@ -1,18 +1,11 @@ +# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- package CPAN; -use vars qw{$Try_autoload - $Revision - $META $Signal $Cwd $End - $Suppress_readline %Dontload - $Frontend $Defaultsite - }; #}; - -$VERSION = '1.52'; - -# $Id: CPAN.pm,v 1.276 2000/01/08 15:29:46 k Exp $ +$VERSION = '1.59_54'; +# $Id: CPAN.pm,v 1.385 2001/02/09 21:37:57 k Exp $ # only used during development: $Revision = ""; -# $Revision = "[".substr(q$Revision: 1.276 $, 10)."]"; +# $Revision = "[".substr(q$Revision: 1.385 $, 10)."]"; use Carp (); use Config (); @@ -29,6 +22,8 @@ use Safe (); use Text::ParseWords (); use Text::Wrap; use File::Spec; +no lib "."; # we need to run chdir all over and we would get at wrong + # libraries there END { $End++; &cleanup; } @@ -47,6 +42,8 @@ END { $End++; &cleanup; } Eval 2048 Config 4096 Tarzip 8192 + Version 16384 + Queue 32768 ]; $CPAN::DEBUG ||= 0; @@ -55,9 +52,12 @@ $CPAN::Frontend ||= "CPAN::Shell"; $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN"; package CPAN; -use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $term); use strict qw(vars); +use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term + $Revision $Signal $End $Suppress_readline $Frontend + $Defaultsite $Have_warned); + @CPAN::ISA = qw(CPAN::Debug Exporter); @EXPORT = qw( @@ -75,12 +75,6 @@ sub AUTOLOAD { if (exists $EXPORT{$l}){ CPAN::Shell->$l(@_); } else { - my $ok = CPAN::Shell->try_dot_al($AUTOLOAD); - if ($ok) { - goto &$AUTOLOAD; -# } else { -# $CPAN::Frontend->mywarn("Could not autoload $AUTOLOAD"); - } $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }. qq{Type ? for help. }); @@ -93,22 +87,24 @@ sub shell { $Suppress_readline = ! -t STDIN unless defined $Suppress_readline; CPAN::Config->load unless $CPAN::Config_loaded++; - my $prompt = "cpan> "; + my $oprompt = shift || "cpan> "; + my $prompt = $oprompt; + my $commandline = shift || ""; + 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'; @@ -121,38 +117,42 @@ sub shell { select $odef; } - no strict; + # 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" : ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : - "available (try ``install Bundle::CPAN'')"; + "available (try 'install Bundle::CPAN')"; $CPAN::Frontend->myprint( - qq{ -cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION$CPAN::Revision) -ReadLine support $rl_avail + sprintf qq{ +cpan shell -- CPAN exploration and modules installation (v%s%s) +ReadLine support %s -}) unless $CPAN::Config->{'inhibit_startup_message'} ; +}, + $CPAN::VERSION, + $CPAN::Revision, + $rl_avail + ) + 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 = $_; @@ -167,25 +167,30 @@ ReadLine support $rl_avail 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; eval { CPAN::Shell->$command(@line) }; warn $@ if $@; - chdir $cwd; + 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) { @@ -194,15 +199,17 @@ ReadLine support $rl_avail $CPAN::META->has_inst("Term::ReadLine::Perl") ) { delete $INC{"Term/ReadLine.pm"}; - my $redef; - local($SIG{__WARN__}) = CPAN::Shell::dotdot_onreload(\$redef); + my $redef = 0; + local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef); 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; @@ -210,7 +217,6 @@ package CPAN::CacheMgr; use File::Find; package CPAN::Config; -import ExtUtils::MakeMaker 'neatvalue'; use vars qw(%can $dot_cpan); %can = ( @@ -223,14 +229,25 @@ package CPAN::FTP; use vars qw($Ua $Thesite $Themethod); @CPAN::FTP::ISA = qw(CPAN::Debug); +package CPAN::LWP::UserAgent; +use vars qw(@ISA $USER $PASSWD $SETUPDONE); +# we delay requiring LWP::UserAgent and setting up inheritence until we need it + 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); +use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03); @CPAN::Index::ISA = qw(CPAN::Debug); -$last_time ||= 0; -$date_of_03 ||= 0; +$LAST_TIME ||= 0; +$DATE_OF_03 ||= 0; +# use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57 +sub PROTOCOL { 2.0 } package CPAN::InfoObj; @CPAN::InfoObj::ISA = qw(CPAN::Debug); @@ -248,8 +265,10 @@ package CPAN::Module; @CPAN::Module::ISA = qw(CPAN::InfoObj); package CPAN::Shell; -use vars qw($AUTOLOAD $redef @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 { @@ -269,89 +288,16 @@ For this you just need to type }); } } else { - my $ok = CPAN::Shell->try_dot_al($AUTOLOAD); - if ($ok) { - goto &$AUTOLOAD; -# } else { -# $CPAN::Frontend->mywarn("Could not autoload $autoload"); - } $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }. qq{Type ? for help. }); } } -#-> CPAN::Shell::try_dot_al -sub try_dot_al { - my($class,$autoload) = @_; - return unless $CPAN::Try_autoload; - # I don't see how to re-use that from the AutoLoader... - my($name,$ok); - # Braces used to preserve $1 et al. - { - my ($pkg,$func) = $autoload =~ /(.*)::([^:]+)$/; - $pkg =~ s|::|/|g; - if (defined($name=$INC{"$pkg.pm"})) - { - $name =~ s|^(.*)$pkg\.pm\z|$1auto/$pkg/$func.al|s; - $name = undef unless (-r $name); - } - unless (defined $name) - { - $name = "auto/$autoload.al"; - $name =~ s|::|/|g; - } - } - my $save = $@; - eval {local $SIG{__DIE__};require $name}; - if ($@) { - if (substr($autoload,-9) eq '::DESTROY') { - *$autoload = sub {}; - $ok = 1; - } else { - if ($name =~ s{(\w{12,})\.al\z}{substr($1,0,11).".al"}e){ - eval {local $SIG{__DIE__};require $name}; - } - if ($@){ - $@ =~ s/ at .*\n//; - Carp::croak $@; - } else { - $ok = 1; - } - } - } else { - - $ok = 1; - - } - $@ = $save; -# my $lm = Carp::longmess(); -# warn "ok[$ok] autoload[$autoload] longmess[$lm]"; # debug - return $ok; -} - -#### autoloader is experimental -#### to try it we have to set $Try_autoload and uncomment -#### the use statement and uncomment the __END__ below -#### You also need AutoSplit 1.01 available. MakeMaker will -#### then build CPAN with all the AutoLoad stuff. -# use AutoLoader; -# $Try_autoload = 1; - -if ($CPAN::Try_autoload) { - my $p; - for $p (qw( - CPAN::Author CPAN::Bundle CPAN::CacheMgr CPAN::Complete - CPAN::Config CPAN::Debug CPAN::Distribution CPAN::FTP - CPAN::FTP::netrc CPAN::Index CPAN::InfoObj CPAN::Module - )) { - *{"$p\::AUTOLOAD"} = \&AutoLoader::AUTOLOAD; - } -} - 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; @@ -402,70 +348,81 @@ package CPAN::Queue; use vars qw{ @All }; +# CPAN::Queue::new ; sub new { - my($class,$mod) = @_; - my $self = bless {mod => $mod}, $class; + my($class,$s) = @_; + my $self = bless { qmod => $s }, $class; push @All, $self; - # my @all = map { $_->{mod} } @All; - # warn "Adding Queue object for mod[$mod] all[@all]"; return $self; } +# CPAN::Queue::first ; sub first { my $obj = $All[0]; - $obj->{mod}; + $obj->{qmod}; } +# CPAN::Queue::delete_first ; sub delete_first { my($class,$what) = @_; my $i; for my $i (0..$#All) { - if ( $All[$i]->{mod} eq $what ) { + if ( $All[$i]->{qmod} eq $what ) { splice @All, $i, 1; return; } } } +# CPAN::Queue::jumpqueue ; sub jumpqueue { - my $class = shift; - my @what = @_; - my $obj; + my $class = shift; + my @what = @_; + CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]", + join(",",map {$_->{qmod}} @All), + join(",",@what) + )) if $CPAN::DEBUG; WHAT: for my $what (reverse @what) { - my $jumped = 0; - for (my $i=0; $i<$#All;$i++) { #prevent deep recursion - if ($All[$i]->{mod} eq $what){ - $jumped++; - if ($jumped > 100) { # one's OK if e.g. just processing now; - # more are OK if user typed it several - # times - $CPAN::Frontend->mywarn( + my $jumped = 0; + for (my $i=0; $i<$#All;$i++) { #prevent deep recursion + CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG; + if ($All[$i]->{qmod} eq $what){ + $jumped++; + if ($jumped > 100) { # one's OK if e.g. just + # processing now; more are OK if + # user typed it several times + $CPAN::Frontend->mywarn( qq{Object [$what] queued more than 100 times, ignoring} ); - next WHAT; - } - } + next WHAT; + } + } + } + my $obj = bless { qmod => $what }, $class; + unshift @All, $obj; } - my $obj = bless { mod => $what }, $class; - unshift @All, $obj; - } + CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]", + join(",",map {$_->{qmod}} @All), + join(",",@what) + )) if $CPAN::DEBUG; } +# CPAN::Queue::exists ; sub exists { my($self,$what) = @_; - my @all = map { $_->{mod} } @All; - my $exists = grep { $_->{mod} eq $what } @All; - # warn "Checking exists in Queue object for mod[$what] all[@all] exists[$exists]"; + my @all = map { $_->{qmod} } @All; + my $exists = grep { $_->{qmod} eq $what } @All; + # warn "in exists what[$what] all[@all] exists[$exists]"; $exists; } +# CPAN::Queue::delete ; sub delete { my($self,$mod) = @_; - @All = grep { $_->{mod} ne $mod } @All; - # my @all = map { $_->{mod} } @All; - # warn "Deleting Queue object for mod[$mod] all[@all]"; + @All = grep { $_->{qmod} ne $mod } @All; } +# CPAN::Queue::nullify_queue ; sub nullify_queue { @All = (); } @@ -476,44 +433,31 @@ package CPAN; $META ||= CPAN->new; # In case we re-eval ourselves we need the || -1; +# from here on only subs. +################################################################################ -# __END__ # uncomment this and AutoSplit version 1.01 will split it - -#-> sub CPAN::autobundle ; -sub autobundle; -#-> sub CPAN::bundle ; -sub bundle; -#-> sub CPAN::expand ; -sub expand; -#-> sub CPAN::force ; -sub force; -#-> sub CPAN::install ; -sub install; -#-> sub CPAN::make ; -sub make; -#-> sub CPAN::clean ; -sub clean; -#-> sub CPAN::test ; -sub test; - -#-> sub CPAN::all ; +#-> sub CPAN::all_objects ; sub all_objects { my($mgr,$class) = @_; CPAN::Config->load unless $CPAN::Config_loaded++; CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG; CPAN::Index->reload; - values %{ $META->{$class} }; + values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok } *all = \&all_objects; -# Called by shell, not in batch mode. Not clean XXX +# Called by shell, not in batch mode. In batch mode I see no risk in +# having many processes updating something as installations are +# continually checked at runtime. In shell mode I suspect it is +# unintentional to open more than one shell at a time + #-> sub CPAN::checklock ; sub checklock { my($self) = @_; my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock"); if (-f $lockfile && -M _ > 0) { - my $fh = FileHandle->new($lockfile); + my $fh = FileHandle->new($lockfile) or + $CPAN::Frontend->mydie("Could not open $lockfile: $!"); my $other = <$fh>; $fh->close; if (defined $other && $other) { @@ -545,7 +489,11 @@ You may want to kill it and delete the lockfile, maybe. On UNIX try: qq{ and then rerun us.\n} ); } - } + } else { + $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile ". + "reports other process with ID ". + "$other. Cannot proceed.\n")); + } } my $dotcpan = $CPAN::Config->{cpan_home}; eval { File::Path::mkpath($dotcpan);}; @@ -610,11 +558,11 @@ or $fh->print($$, "\n"); $self->{LOCK} = $lockfile; $fh->close; - $SIG{'TERM'} = sub { + $SIG{TERM} = sub { &cleanup; $CPAN::Frontend->mydie("Got SIGTERM, leaving"); }; - $SIG{'INT'} = sub { + $SIG{INT} = sub { # no blocks!!! &cleanup if $Signal; $CPAN::Frontend->mydie("Got another SIGINT") if $Signal; @@ -642,7 +590,8 @@ or # # Larry - $SIG{'__DIE__'} = \&cleanup; + # global backstop to cleanup if we should really die + $SIG{__DIE__} = \&cleanup; $self->debug("Signal handler set.") if $CPAN::DEBUG; } @@ -651,6 +600,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();} @@ -660,16 +616,55 @@ 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 ||= ""; - exists $META->{$class}{$id}; + exists $META->{readonly}{$class}{$id} or + exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok } #-> sub CPAN::delete ; sub delete { my($mgr,$class,$id) = @_; - delete $META->{$class}{$id}; + delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok + delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok +} + +#-> sub CPAN::has_usable +# has_inst is sometimes too optimistic, we should replace it with this +# has_usable whenever a case is given +sub has_usable { + my($self,$mod,$message) = @_; + return 1 if $HAS_USABLE->{$mod}; + my $has_inst = $self->has_inst($mod,$message); + return unless $has_inst; + my $usable; + $usable = { + LWP => [ # we frequently had "Can't locate object + # method "new" via package "LWP::UserAgent" at + # (eval 69) line 2006 + sub {require LWP}, + sub {require LWP::UserAgent}, + sub {require HTTP::Request}, + sub {require URI::URL}, + ], + Net::FTP => [ + sub {require Net::FTP}, + sub {require Net::Config}, + ] + }; + if ($usable->{$mod}) { + for my $c (0..$#{$usable->{$mod}}) { + my $code = $usable->{$mod}[$c]; + my $ret = eval { &$code() }; + if ($@) { + warn "DEBUG: c[$c]\$\@[$@]ret[$ret]"; + return; + } + } + } + return $HAS_USABLE->{$mod} = 1; } #-> sub CPAN::has_inst @@ -677,11 +672,14 @@ sub has_inst { my($self,$mod,$message) = @_; Carp::croak("CPAN->has_inst() called without an argument") unless defined $mod; - if (defined $message && $message eq "no") { - $Dontload{$mod}||=1; - return 0; - } elsif (exists $Dontload{$mod}) { - return 0; + if (defined $message && $message eq "no" + || + exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok + || + exists $CPAN::Config->{dontload_hash}{$mod} + ) { + $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok + return 0; } my $file = $mod; my $obj; @@ -707,13 +705,13 @@ sub has_inst { } return 1; } elsif ($mod eq "Net::FTP") { - warn qq{ + $CPAN::Frontend->mywarn(qq{ Please, install Net::FTP as soon as possible. CPAN.pm installs it for you if you just type install Bundle::libnet -}; - sleep 2; +}) unless $Have_warned->{"Net::FTP"}++; + sleep 3; } elsif ($mod eq "MD5"){ $CPAN::Frontend->myprint(qq{ CPAN: MD5 security checks disabled because MD5 not installed. @@ -732,7 +730,9 @@ sub instance { my($mgr,$class,$id) = @_; CPAN::Index->reload; $id ||= ""; - $META->{$class}{$id} ||= $class->new(ID => $id ); + # unsafe meta access, ok? + return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id}; + $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id); } #-> sub CPAN::new ; @@ -760,9 +760,9 @@ sub cleanup { } } return if $ineval && !$End; - return unless defined $META->{'LOCK'}; - return unless -f $META->{'LOCK'}; - unlink $META->{'LOCK'}; + return unless defined $META->{LOCK}; # unsafe meta access, ok + return unless -f $META->{LOCK}; # unsafe meta access, ok + unlink $META->{LOCK}; # unsafe meta access, ok # require Carp; # Carp::cluck("DEBUGGING"); $CPAN::Frontend->mywarn("Lockfile removed.\n"); @@ -785,6 +785,7 @@ sub cachesize { shift->{DU}; } +#-> sub CPAN::CacheMgr::tidyup ; sub tidyup { my($self) = @_; return unless -d $self->{ID}; @@ -812,9 +813,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: $!"); @@ -942,49 +941,85 @@ sub debug { package CPAN::Config; #-> sub CPAN::Config::edit ; +# returns true on successful action sub edit { - my($class,@args) = @_; + my($self,@args) = @_; return unless @args; - CPAN->debug("class[$class]args[".join(" | ",@args)."]"); + CPAN->debug("self[$self]args[".join(" | ",@args)."]"); my($o,$str,$func,$args,$key_exists); $o = shift @args; if($can{$o}) { - $class->$o(@args); + $self->$o(@args); return 1; } else { - if (ref($CPAN::Config->{$o}) eq ARRAY) { + CPAN->debug("o[$o]") if $CPAN::DEBUG; + if ($o =~ /list$/) { $func = shift @args; $func ||= ""; + CPAN->debug("func[$func]") if $CPAN::DEBUG; + my $changed; # Let's avoid eval, it's easier to comprehend without. if ($func eq "push") { push @{$CPAN::Config->{$o}}, @args; + $changed = 1; } elsif ($func eq "pop") { pop @{$CPAN::Config->{$o}}; + $changed = 1; } elsif ($func eq "shift") { shift @{$CPAN::Config->{$o}}; + $changed = 1; } elsif ($func eq "unshift") { unshift @{$CPAN::Config->{$o}}, @args; + $changed = 1; } elsif ($func eq "splice") { splice @{$CPAN::Config->{$o}}, @args; + $changed = 1; } elsif (@args) { $CPAN::Config->{$o} = [@args]; + $changed = 1; } else { - $CPAN::Frontend->myprint( - join "", - " $o ", - ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$o}), - "\n" - ); + $self->prettyprint($o); } + if ($o eq "urllist" && $changed) { + # reset the cached values + undef $CPAN::FTP::Thesite; + undef $CPAN::FTP::Themethod; + } + return $changed; } else { $CPAN::Config->{$o} = $args[0] if defined $args[0]; - $CPAN::Frontend->myprint(" $o " . - (defined $CPAN::Config->{$o} ? - $CPAN::Config->{$o} : "UNDEFINED")); + $self->prettyprint($o); } } } +sub prettyprint { + my($self,$k) = @_; + my $v = $CPAN::Config->{$k}; + if (ref $v) { + my(@report) = ref $v eq "ARRAY" ? + @$v : + map { sprintf(" %-18s => %s\n", + $_, + defined $v->{$_} ? $v->{$_} : "UNDEFINED" + )} keys %$v; + $CPAN::Frontend->myprint( + join( + "", + sprintf( + " %-18s\n", + $k + ), + map {"\t$_\n"} @report + ) + ); + } elsif (defined $v) { + $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v); + } else { + $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, "UNDEFINED"); + } +} + #-> sub CPAN::Config::commit ; sub commit { my($self,$configpm) = @_; @@ -1005,7 +1040,8 @@ Please specify a filename where to save the configuration or try } } - my $msg = <<EOF unless $configpm =~ /MyConfig/; + my $msg; + $msg = <<EOF unless $configpm =~ /MyConfig/; # This is CPAN.pm's systemwide configuration file. This file provides # defaults for users, and the values can be changed in a per-user @@ -1016,7 +1052,8 @@ EOF $msg ||= "\n"; my($fh) = FileHandle->new; rename $configpm, "$configpm~" if -f $configpm; - open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!"; + open $fh, ">$configpm" or + $CPAN::Frontend->mydie("Couldn't open >$configpm: $!"); $fh->print(qq[$msg\$CPAN::Config = \{\n]); foreach (sort keys %$CPAN::Config) { $fh->print( @@ -1069,8 +1106,8 @@ sub load { # system wide settings shift @INC; } - return unless @miss = $self->not_loaded; - # XXX better check for arrayrefs too + return unless @miss = $self->missing_config_data; + require CPAN::FirstTime; my($configpm,$fh,$redo,$theycalled); $redo ||= ""; @@ -1137,15 +1174,18 @@ $configpm initialized. CPAN::FirstTime::init($configpm); } -#-> sub CPAN::Config::not_loaded ; -sub not_loaded { +#-> sub CPAN::Config::missing_config_data ; +sub missing_config_data { my(@miss); - for (qw( - cpan_home keep_source_where build_dir build_cache scan_cache - index_expire gzip tar unzip make pager makepl_arg make_arg - make_install_arg urllist inhibit_startup_message - ftp_proxy http_proxy no_proxy prerequisites_policy - )) { + for ( + "cpan_home", "keep_source_where", "build_dir", "build_cache", + "scan_cache", "index_expire", "gzip", "tar", "unzip", "make", + "pager", + "makepl_arg", "make_arg", "make_install_arg", "urllist", + "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy", + "prerequisites_policy", + "cache_metadata", + ) { push @miss, $_ unless defined $CPAN::Config->{$_}; } return @miss; @@ -1213,19 +1253,17 @@ sub h { } else { $CPAN::Frontend->myprint(q{ Display Information - a authors - b string display bundles - d or info distributions - m /regex/ about modules - i or anything of above - r none reinstall recommendations - u uninstalled distributions + command argument description + a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules + i WORD or /REGEXP/ about anything of above + r NONE reinstall recommendations + ls AUTHOR about files in the author's directory Download, Test, Make, Install... get download make make (implies get) - test modules, make test (implies make) - install dists, bundles make install (implies test) + test MODULES, make test (implies make) + install DISTS, BUNDLES make install (implies test) clean make clean look open subshell in these dists' directories readme display these dists' README files @@ -1241,27 +1279,68 @@ Other *help = \&h; #-> sub CPAN::Shell::a ; -sub a { $CPAN::Frontend->myprint(shift->format_result('Author',@_));} -#-> sub CPAN::Shell::b ; -sub b { +sub a { + my($self,@arg) = @_; + # authors are always UPPERCASE + for (@arg) { + $_ = uc $_ unless /=/; + } + $CPAN::Frontend->myprint($self->format_result('Author',@arg)); +} + +#-> sub CPAN::Shell::ls ; +sub ls { + my($self,@arg) = @_; + my @accept; + for (@arg) { + unless (/^[A-Z\-]+$/i) { + $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author"); + next; + } + push @accept, uc $_; + } + for my $a (@accept){ + 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) = @_; - CPAN->debug("which[@which]") if $CPAN::DEBUG; 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\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"); + } + } + } + } } +} + +#-> sub CPAN::Shell::b ; +sub b { + my($self,@which) = @_; + CPAN->debug("which[@which]") if $CPAN::DEBUG; + $self->local_bundles; $CPAN::Frontend->myprint($self->format_result('Bundle',@which)); } + #-> sub CPAN::Shell::d ; sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));} + #-> sub CPAN::Shell::m ; sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here $CPAN::Frontend->myprint(shift->format_result('Module',@_)); @@ -1278,21 +1357,28 @@ 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); } #-> sub CPAN::Shell::o ; + +# CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf' +# should have been called set and 'o debug' maybe 'set debug' sub o { my($self,$o_type,@o_what) = @_; $o_type ||= ""; CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n"); if ($o_type eq 'conf') { shift @o_what if @o_what && $o_what[0] eq 'help'; - if (!@o_what) { + if (!@o_what) { # print all things, "o conf" my($k,$v); $CPAN::Frontend->myprint("CPAN::Config options"); if (exists $INC{'CPAN/Config.pm'}) { @@ -1308,25 +1394,12 @@ sub o { } $CPAN::Frontend->myprint("\n"); for $k (sort keys %$CPAN::Config) { - $v = $CPAN::Config->{$k}; - if (ref $v) { - $CPAN::Frontend->myprint( - join( - "", - sprintf( - " %-18s\n", - $k - ), - map {"\t$_\n"} @{$v} - ) - ); - } else { - $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v); - } + CPAN::Config->prettyprint($k); } $CPAN::Frontend->myprint("\n"); } elsif (!CPAN::Config->edit(@o_what)) { - $CPAN::Frontend->myprint(qq[Type 'o conf' to view configuration edit options\n\n]); + $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }. + qq{edit options\n\n}); } } elsif ($o_type eq 'debug') { my(%valid); @@ -1334,6 +1407,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/) { @@ -1369,7 +1446,8 @@ sub o { my($k,$v); for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) { $v = $CPAN::DEBUG{$k}; - $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v) if $v & $CPAN::DEBUG; + $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v) + if $v & $CPAN::DEBUG; } } else { $CPAN::Frontend->myprint("Debugging turned off completely.\n"); @@ -1383,10 +1461,10 @@ Known options: } } -sub dotdot_onreload { +sub paintdots_onreload { my($ref) = shift; sub { - if ( $_[0] =~ /Subroutine (\w+) redefined/ ) { + if ( $_[0] =~ /[Ss]ubroutine (\w+) redefined/ ) { my($subr) = $1; ++$$ref; local($|) = 1; @@ -1407,8 +1485,8 @@ sub reload { CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG; my $fh = FileHandle->new($INC{'CPAN.pm'}); local($/); - $redef = 0; - local($SIG{__WARN__}) = dotdot_onreload(\$redef); + my $redef = 0; + local($SIG{__WARN__}) = paintdots_onreload(\$redef); eval <$fh>; warn $@ if $@; $CPAN::Frontend->myprint("\n$redef subroutines redefined\n"); @@ -1424,12 +1502,12 @@ index re-reads the index files\n}); sub _binary_extensions { my($self) = shift @_; my(@result,$module,%seen,%need,$headerdone); - my $isaperl = q{perl5[._-]\\d{3}(_[0-4][0-9])?\\.tar[._-]gz\z}; for $module ($self->expand('Module','/./')) { my $file = $module->cpan_file; next if $file eq "N/A"; next if $file =~ /^Contact Author/; - next if $file =~ / $isaperl /xo; + my $dist = $CPAN::META->instance('CPAN::Distribution',$file); + next if $dist->isa_perl; next unless $module->xs_file; local($|) = 1; $CPAN::Frontend->myprint("."); @@ -1467,15 +1545,21 @@ sub _u_r_common { my($self) = shift @_; my($what) = shift @_; CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG; - Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what; - Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/; + Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless + $what && $what =~ /^[aru]$/; my(@args) = @_; @args = '/./' unless @args; my(@result,$module,%seen,%need,$headerdone, $version_undefs,$version_zeroes); $version_undefs = $version_zeroes = 0; - my $sprintf = "%-25s %9s %9s %s\n"; - for $module ($self->expand('Module',@args)) { + 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 + # for metadata cache + $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand); + } + for $module (@expand) { my $file = $module->cpan_file; next unless defined $file; # ?? my($latest) = $module->cpan_version; @@ -1493,7 +1577,7 @@ sub _u_r_common { } elsif ($have == 0){ $version_zeroes++; } - next if $have >= $latest; + next unless CPAN::Version->vgt($latest, $have); # to be pedantic we should probably say: # && !($have eq "undef" && $latest ne "undef" && $latest gt ""); # to catch the case where CPAN has a version 0 and we have a version undef @@ -1524,16 +1608,34 @@ 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" + )); } - $latest = substr($latest,0,8) if length($latest) > 8; - $have = substr($have,0,8) if length($have) > 8; - $CPAN::Frontend->myprint(sprintf $sprintf, $module->id, $have, $latest, $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); $need{$module->id}++; } unless (%need) { @@ -1615,52 +1717,105 @@ sub autobundle { $to\n\n"); } +#-> sub CPAN::Shell::expandany ; +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::|) { + $self->local_bundles; # scanning so late for bundles seems + # both attractive and crumpy: always + # current state but easy to forget + # somewhere + return $self->expand('Bundle',$s); + } else { + return $self->expand('Module',$s) + if $CPAN::META->exists('CPAN::Module',$s); + } + return; +} + #-> sub CPAN::Shell::expand ; sub expand { shift; my($type,@args) = @_; my($arg,@m); + CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG; for $arg (@args) { - my $regex; + my($regex,$command); if ($arg =~ m|^/(.*)/$|) { $regex = $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 - {$a->id cmp $b->id} - $CPAN::META->all_objects($class) - ) { - unless ($obj->id){ - # BUG, we got an empty object somewhere - CPAN->debug(sprintf( - "Empty id on obj[%s]%%[%s]", - $obj, - join(":", %$obj) - )) if $CPAN::DEBUG; - next; - } - push @m, $obj - if $obj->id =~ /$regex/i - or - ( - ( - $] < 5.00303 ### provide sort of - ### compatibility with 5.003 - || - $obj->can('name') - ) - && - $obj->name =~ /$regex/i - ); - } + for $obj ( + sort + {$a->id cmp $b->id} + $CPAN::META->all_objects($class) + ) { + unless ($obj->id){ + # BUG, we got an empty object somewhere + require Data::Dumper; + CPAN->debug(sprintf( + "Bug in CPAN: Empty id on obj[%s][%s]", + $obj, + Data::Dumper::Dumper($obj) + )) if $CPAN::DEBUG; + next; + } + push @m, $obj + if $obj->id =~ /$regex/i + or + ( + ( + $] < 5.00303 ### provide sort of + ### compatibility with 5.003 + || + $obj->can('name') + ) + && + $obj->name =~ /$regex/i + ); + } + } elsif ($command) { + 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) + ) { + 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)) { @@ -1680,22 +1835,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"; @@ -1723,6 +1889,7 @@ sub print_ornamented { sub myprint { my($self,$what) = @_; + $self->print_ornamented($what, 'bold blue on_yellow'); } @@ -1770,50 +1937,54 @@ sub rematein { } setup_output(); CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG; - my($s,@s); + + # Here is the place to set "test_count" on all involved parties to + # 0. We then can pass this counter on to the involved + # distributions and those can refuse to test if test_count > X. In + # the first stab at it we could use a 1 for "X". + + # But when do I reset the distributions to start with 0 again? + # Jost suggested to have a random or cycling interaction ID that + # we pass through. But the ID is something that is just left lying + # around in addition to the counter, so I'd prefer to set the + # counter to 0 now, and repeat at the end of the loop. But what + # about dependencies? They appear later and are not reset, they + # enter the queue but not its copy. How do they get a sensible + # test_count? + + # construct the queue + my($s,@s,@qcopy); foreach $s (@some) { - CPAN::Queue->new($s); - } - while ($s = CPAN::Queue->first) { my $obj; if (ref $s) { + CPAN->debug("s is an object[$s]") if $CPAN::DEBUG; $obj = $s; - } elsif ($s =~ m|/|) { # looks like a file - $obj = $CPAN::META->instance('CPAN::Distribution',$s); - } elsif ($s =~ m|^Bundle::|) { - $obj = $CPAN::META->instance('CPAN::Bundle',$s); + } elsif ($s =~ m|^/|) { # looks like a regexp + $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ". + "not supported\n"); + sleep 2; + next; } else { - $obj = $CPAN::META->instance('CPAN::Module',$s) - if $CPAN::META->exists('CPAN::Module',$s); + CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG; + $obj = CPAN::Shell->expandany($s); } if (ref $obj) { - CPAN->debug( - qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}. - $obj->as_string. - qq{\]} - ) if $CPAN::DEBUG; - $obj->$pragma() - if - $pragma - && - ($] < 5.00303 || $obj->can($pragma)); ### - ### compatibility - ### with - ### 5.003 - if ($]>=5.00303 && $obj->can('called_for')) { - $obj->called_for($s); - } - CPAN::Queue->delete($s) if $obj->$meth(); # if it is more - # than once in - # the queue + $obj->color_cmd_tmps(0,1); + CPAN::Queue->new($obj->id); + 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" - ); + 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, }. @@ -1822,13 +1993,55 @@ Try the command i /$s/ -to find objects with similar identifiers. +to find objects with matching identifiers. }); + sleep 2; + } + } + + # queuerunner (please be warned: when I started to change the + # queue to hold objects instead of names, I made one or two + # mistakes and never found which. I reverted back instead) + while ($s = CPAN::Queue->first) { + my $obj; + if (ref $s) { + $obj = $s; # I do not believe, we would survive if this happened + } else { + $obj = CPAN::Shell->expandany($s); } + if ($pragma + && + ($] < 5.00303 || $obj->can($pragma))){ + ### compatibility with 5.003 + $obj->$pragma($meth); # the pragma "force" in + # "CPAN::Distribution" must know + # what we are intending + } + if ($]>=5.00303 && $obj->can('called_for')) { + $obj->called_for($s); + } + CPAN->debug( + qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}. + $obj->as_string. + qq{\]} + ) if $CPAN::DEBUG; + + if ($obj->$meth()){ + CPAN::Queue->delete($s); + } else { + CPAN->debug("failed"); + } + + $obj->undelay; CPAN::Queue->delete_first($s); } + for my $obj (@qcopy) { + $obj->color_cmd_tmps(0,0); + } } +#-> sub CPAN::Shell::dump ; +sub dump { shift->rematein('dump',@_); } #-> sub CPAN::Shell::force ; sub force { shift->rematein('force',@_); } #-> sub CPAN::Shell::get ; @@ -1848,6 +2061,60 @@ sub look { shift->rematein('look',@_); } #-> sub CPAN::Shell::cvs_import ; sub cvs_import { shift->rematein('cvs_import',@_); } +package CPAN::LWP::UserAgent; + +sub config { + return if $SETUPDONE; + if ($CPAN::META->has_usable('LWP::UserAgent')) { + require LWP::UserAgent; + @ISA = qw(Exporter LWP::UserAgent); + $SETUPDONE++; + } else { + $CPAN::Frontent->mywarn("LWP::UserAgent not available\n"); + } +} + +sub get_basic_credentials { + my($self, $realm, $uri, $proxy) = @_; + return unless $proxy; + if ($USER && $PASSWD) { + } elsif (defined $CPAN::Config->{proxy_user} && + defined $CPAN::Config->{proxy_pass}) { + $USER = $CPAN::Config->{proxy_user}; + $PASSWD = $CPAN::Config->{proxy_pass}; + } else { + require ExtUtils::MakeMaker; + ExtUtils::MakeMaker->import(qw(prompt)); + $USER = prompt("Proxy authentication needed! + (Note: to permanently configure username and password run + o conf proxy_user your_username + o conf proxy_pass your_password + )\nUsername:"); + if ($CPAN::META->has_inst("Term::ReadKey")) { + Term::ReadKey::ReadMode("noecho"); + } else { + $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"); + } + $PASSWD = prompt("Password:"); + if ($CPAN::META->has_inst("Term::ReadKey")) { + Term::ReadKey::ReadMode("restore"); + } + $CPAN::Frontend->myprint("\n\n"); + } + return($USER,$PASSWD); +} + +sub mirror { + my($self,$url,$aslocal) = @_; + my $result = $self->SUPER::mirror($url,$aslocal); + if ($result->code == 407) { + undef $USER; + undef $PASSWD; + $result = $self->SUPER::mirror($url,$aslocal); + } + $result; +} + package CPAN::FTP; #-> sub CPAN::FTP::ftp_get ; @@ -1860,7 +2127,7 @@ sub ftp_get { my $ftp = Net::FTP->new($host); return 0 unless defined $ftp; $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG; - $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]); + $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]); unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){ warn "Couldn't login on $host"; return; @@ -1881,61 +2148,33 @@ sub ftp_get { # If more accuracy is wanted/needed, Chris Leach sent me this patch... - # leach,> *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997 - # leach,> --- /tmp/cp Wed Sep 24 13:26:40 1997 - # leach,> *************** - # leach,> *** 1562,1567 **** - # leach,> --- 1562,1580 ---- - # leach,> return 1 if substr($url,0,4) eq "file"; - # leach,> return 1 unless $url =~ m|://([^/]+)|; - # leach,> my $host = $1; - # leach,> + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'}; - # leach,> + if ($proxy) { - # leach,> + $proxy =~ m|://([^/:]+)|; - # leach,> + $proxy = $1; - # leach,> + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'}; - # leach,> + if ($noproxy) { - # leach,> + if ($host !~ /$noproxy$/) { - # leach,> + $host = $proxy; - # leach,> + } - # leach,> + } else { - # leach,> + $host = $proxy; - # leach,> + } - # leach,> + } - # leach,> require Net::Ping; - # leach,> return 1 unless $Net::Ping::VERSION >= 2; - # leach,> my $p; - - -# this is quite optimistic and returns one on several occasions where -# inappropriate. But this does no harm. It would do harm if we were -# too pessimistic (as I was before the http_proxy -sub is_reachable { - my($self,$url) = @_; - return 1; # we can't simply roll our own, firewalls may break ping - return 0 unless $url; - return 1 if substr($url,0,4) eq "file"; - return 1 unless $url =~ m|^(\w+)://([^/]+)|; - my $proxytype = $1 . "_proxy"; # ftp_proxy or http_proxy - my $host = $2; - return 1 if $CPAN::Config->{$proxytype} || $ENV{$proxytype}; - require Net::Ping; - return 1 unless $Net::Ping::VERSION >= 2; - my $p; - # 1.3101 had it different: only if the first eval raised an - # exception we tried it with TCP. Now we are happy if icmp wins - # the order and return, we don't even check for $@. Thanks to - # thayer@uis.edu for the suggestion. - eval {$p = Net::Ping->new("icmp");}; - return 1 if $p && ref($p) && $p->ping($host, 10); - eval {$p = Net::Ping->new("tcp");}; - $CPAN::Frontend->mydie($@) if $@; - return $p->ping($host, 10); -} + # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997 + # > --- /tmp/cp Wed Sep 24 13:26:40 1997 + # > *************** + # > *** 1562,1567 **** + # > --- 1562,1580 ---- + # > return 1 if substr($url,0,4) eq "file"; + # > return 1 unless $url =~ m|://([^/]+)|; + # > my $host = $1; + # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'}; + # > + if ($proxy) { + # > + $proxy =~ m|://([^/:]+)|; + # > + $proxy = $1; + # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'}; + # > + if ($noproxy) { + # > + if ($host !~ /$noproxy$/) { + # > + $host = $proxy; + # > + } + # > + } else { + # > + $host = $proxy; + # > + } + # > + } + # > require Net::Ping; + # > return 1 unless $Net::Ping::VERSION >= 2; + # > my $p; + #-> sub CPAN::FTP::localize ; -# sorry for the ugly code here, I'll clean it up as soon as Net::FTP -# is in the core sub localize { my($self,$file,$aslocal,$force) = @_; $force ||= 0; @@ -1945,9 +2184,19 @@ sub localize { if $CPAN::DEBUG; if ($^O eq 'MacOS') { + # Comment by AK on 2000-09-03: Uniq short filenames would be + # available in CHECKSUMS file my($name, $path) = File::Basename::fileparse($aslocal, ''); if (length($name) > 31) { - $name =~ s/(\.(readme(\.(gz|Z))?|(tar\.)?(gz|Z)|tgz|zip|pm\.(gz|Z)))$//; + $name =~ s/( + \.( + readme(\.(gz|Z))? | + (tar\.)?(gz|Z) | + tgz | + zip | + pm\.(gz|Z) + ) + )$//x; my $suf = $1; my $size = 31 - length($suf); while (length($name) > $size) { @@ -1973,19 +2222,42 @@ sub localize { to insufficient permissions.\n}) unless -w $aslocal_dir; # Inheritance is not easier to manage than a few if/else branches - if ($CPAN::META->has_inst('LWP::UserAgent')) { - require LWP::UserAgent; + 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'}; + CPAN::LWP::UserAgent->config; + eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough? + if ($@) { + $CPAN::Frontent->mywarn("CPAN::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}; + + +# >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said: +# +# > I note that although CPAN.pm can use proxies, it doesn't seem equipped to +# > use ones that require basic autorization. +# +# > Example of when I use it manually in my own stuff: +# +# > $ua->proxy(['http','ftp'], http://my.proxy.server:83'); +# > $req->proxy_authorization_basic("username","password"); +# > $res = $ua->request($req); +# + + $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}; + $ENV{http_proxy} = $CPAN::Config->{http_proxy} + if $CPAN::Config->{http_proxy}; + $ENV{no_proxy} = $CPAN::Config->{no_proxy} if $CPAN::Config->{no_proxy}; # Try the list of urls for each single object. We keep a record # where we did get a file from @@ -2008,14 +2280,16 @@ sub localize { ($a == $Thesite) } 0..$last; } - my($level,@levels); + my(@levels); if ($Themethod) { @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/); } else { @levels = qw/easy hard hardest/; } @levels = qw/easy/ if $^O eq 'MacOS'; - for $level (@levels) { + my($levelno); + for $levelno (0..$#levels) { + my $level = $levels[$levelno]; my $method = "host$level"; my @host_seq = $level eq "easy" ? @reordered : 0..$last; # reordered has CDROM up front @@ -2030,17 +2304,20 @@ sub localize { return $ret; } else { unlink $aslocal; + last if $CPAN::Signal; # need to cleanup } } - my(@mess); - push @mess, - qq{Please check, if the URLs I found in your configuration file \(}. - join(", ", @{$CPAN::Config->{urllist}}). - qq{\) are valid. The urllist can be edited.}, - 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"); + unless ($CPAN::Signal) { + my(@mess); + push @mess, + qq{Please check, if the URLs I found in your configuration file \(}. + join(", ", @{$CPAN::Config->{urllist}}). + qq{\) are valid. The urllist can be edited.}, + qq{E.g. with 'o conf urllist push ftp://myurl/'}; + $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n"); + sleep 2; + $CPAN::Frontend->myprint("Could not fetch $file\n"); + } if ($restore) { rename "$aslocal.bak", $aslocal; $CPAN::Frontend->myprint("Trying to get away with old file:\n" . @@ -2054,19 +2331,13 @@ sub hosteasy { my($self,$host_seq,$file,$aslocal) = @_; my($i); HOSTEASY: for $i (@$host_seq) { - my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite; - unless ($self->is_reachable($url)) { - $CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n"); - sleep 2; - next; - } + my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite; $url .= "/" unless substr($url,-1) eq "/"; $url .= $file; $self->debug("localizing perlish[$url]") if $CPAN::DEBUG; if ($url =~ /^file:/) { my $l; - if ($CPAN::META->has_inst('LWP')) { - require URI::URL; + if ($CPAN::META->has_inst('URI::URL')) { my $u = URI::URL->new($url); $l = $u->path; } else { # works only on Unix, is poorly constructed, but @@ -2080,6 +2351,7 @@ sub hosteasy { # meant # file://localhost $l =~ s|^/||s unless -f $l; # e.g. /P: + $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG; } if ( -f $l && -r _) { $Thesite = $i; @@ -2095,13 +2367,16 @@ sub hosteasy { } } } - if ($CPAN::META->has_inst('LWP')) { + if ($CPAN::META->has_usable('LWP')) { $CPAN::Frontend->myprint("Fetching with LWP: $url "); unless ($Ua) { - require LWP::UserAgent; - $Ua = LWP::UserAgent->new; + CPAN::LWP::UserAgent->config; + eval { $Ua = CPAN::LWP::UserAgent->new; }; + if ($@) { + $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@"); + } } my $res = $Ua->mirror($url, $aslocal); if ($res->is_success) { @@ -2110,7 +2385,7 @@ sub hosteasy { utime $now, $now, $aslocal; # download time is more # important than upload time return $aslocal; - } elsif ($url !~ /\.gz\z/) { + } elsif ($url !~ /\.gz(?!\n)\Z/) { my $gzurl = "$url.gz"; $CPAN::Frontend->myprint("Fetching with LWP: $gzurl @@ -2121,22 +2396,25 @@ sub hosteasy { ) { $Thesite = $i; return $aslocal; - } else { - # next HOSTEASY ; } } else { - # Alan Burlison informed me that in firewall envs Net::FTP - # can still succeed where LWP fails. So we do not skip - # Net::FTP anymore when LWP is available. - # next HOSTEASY ; + $CPAN::Frontend->myprint(sprintf( + "LWP failed with code[%s] message[%s]\n", + $res->code, + $res->message, + )); + # Alan Burlison informed me that in firewall environments + # Net::FTP can still succeed where LWP fails. So we do not + # skip Net::FTP anymore when LWP is available. } } else { - $self->debug("LWP not installed") if $CPAN::DEBUG; + $CPAN::Frontend->myprint("LWP not available\n"); } + return if $CPAN::Signal; if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { # that's the nice and easy way thanks to Graham my($host,$dir,$getfile) = ($1,$2,$3); - if ($CPAN::META->has_inst('Net::FTP')) { + if ($CPAN::META->has_usable('Net::FTP')) { $dir =~ s|/+|/|g; $CPAN::Frontend->myprint("Fetching with Net::FTP: $url @@ -2147,7 +2425,7 @@ sub hosteasy { $Thesite = $i; return $aslocal; } - if ($aslocal !~ /\.gz\z/) { + if ($aslocal !~ /\.gz(?!\n)\Z/) { my $gz = "$aslocal.gz"; $CPAN::Frontend->myprint("Fetching with Net::FTP $url.gz @@ -2165,6 +2443,7 @@ sub hosteasy { # next HOSTEASY; } } + return if $CPAN::Signal; } } @@ -2182,10 +2461,6 @@ sub hosthard { File::Path::mkpath($aslocal_dir); HOSTHARD: for $i (@$host_seq) { my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite; - unless ($self->is_reachable($url)) { - $CPAN::Frontend->myprint("Skipping $url (not reachable)\n"); - next; - } $url .= "/" unless substr($url,-1) eq "/"; $url .= $file; my($proto,$host,$dir,$getfile); @@ -2199,91 +2474,90 @@ sub hosthard { } else { next HOSTHARD; # who said, we could ftp anything except ftp? } + next HOSTHARD if $proto eq "file"; # file URLs would have had + # success above. Likely a bogus URL $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; next if $funkyftp =~ /^\s*$/; - my($want_compressed); - my $aslocal_uncompressed; - ($aslocal_uncompressed = $aslocal) =~ s/\.gz//; - my($source_switch) = ""; + my($asl_ungz, $asl_gz); + ($asl_ungz = $aslocal) =~ s/\.gz//; + $asl_gz = "$asl_ungz.gz"; + my($src_switch) = ""; if ($f eq "lynx"){ - $source_switch = " -source"; + $src_switch = " -source"; } elsif ($f eq "ncftp"){ - $source_switch = " -c"; + $src_switch = " -c"; + } elsif ($f eq "wget"){ + $src_switch = " -O -"; } my($chdir) = ""; - my($stdout_redir) = " > $aslocal_uncompressed"; + my($stdout_redir) = " > $asl_ungz"; if ($f eq "ncftpget"){ $chdir = "cd $aslocal_dir && "; $stdout_redir = ""; } $CPAN::Frontend->myprint( qq[ -Trying with "$funkyftp$source_switch" to get +Trying with "$funkyftp$src_switch" to get $url ]); my($system) = - "$chdir$funkyftp$source_switch '$url' $devnull$stdout_redir"; + "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir"; $self->debug("system[$system]") if $CPAN::DEBUG; my($wstatus); if (($wstatus = system($system)) == 0 && ($f eq "lynx" ? - -s $aslocal_uncompressed # lynx returns 0 on my - # system even if it fails + -s $asl_ungz # lynx returns 0 when it fails somewhere : 1 ) ) { if (-s $aslocal) { # Looks good - } elsif ($aslocal_uncompressed ne $aslocal) { + } elsif ($asl_ungz ne $aslocal) { # test gzip integrity - if ( - CPAN::Tarzip->gtest($aslocal_uncompressed) - ) { - rename $aslocal_uncompressed, $aslocal; + if (CPAN::Tarzip->gtest($asl_ungz)) { + # e.g. foo.tar is gzipped --> foo.tar.gz + rename $asl_ungz, $aslocal; } else { - CPAN::Tarzip->gzip($aslocal_uncompressed, - "$aslocal_uncompressed.gz"); + CPAN::Tarzip->gzip($asl_ungz,$asl_gz); } } $Thesite = $i; return $aslocal; - } elsif ($url !~ /\.gz\z/) { - unlink $aslocal_uncompressed if - -f $aslocal_uncompressed && -s _ == 0; + } elsif ($url !~ /\.gz(?!\n)\Z/) { + unlink $asl_ungz if + -f $asl_ungz && -s _ == 0; my $gz = "$aslocal.gz"; my $gzurl = "$url.gz"; $CPAN::Frontend->myprint( qq[ -Trying with "$funkyftp$source_switch" to get +Trying with "$funkyftp$src_switch" to get $url.gz ]); - my($system) = "$funkyftp$source_switch '$url.gz' $devnull > ". - "$aslocal_uncompressed.gz"; + my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz"; $self->debug("system[$system]") if $CPAN::DEBUG; my($wstatus); if (($wstatus = system($system)) == 0 && - -s "$aslocal_uncompressed.gz" + -s $asl_gz ) { # test gzip integrity - if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) { - CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz", - $aslocal); + if (CPAN::Tarzip->gtest($asl_gz)) { + CPAN::Tarzip->gunzip($asl_gz,$aslocal); } else { - rename $aslocal_uncompressed, $aslocal; + # somebody uncompressed file for us? + rename $asl_ungz, $aslocal; } $Thesite = $i; return $aslocal; } else { - unlink "$aslocal_uncompressed.gz" if - -f "$aslocal_uncompressed.gz"; + unlink $asl_gz if -f $asl_gz; } } else { my $estatus = $wstatus >> 8; @@ -2295,8 +2569,9 @@ System call "$system" returned status $estatus (wstat $wstatus)$size }); } - } - } + return if $CPAN::Signal; + } # lynx,ncftpget,ncftp + } # host } sub hosthardest { @@ -2311,10 +2586,6 @@ sub hosthardest { last HOSTHARDEST; } my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite; - unless ($self->is_reachable($url)) { - $CPAN::Frontend->myprint("Skipping $url (not reachable)\n"); - next; - } $url .= "/" unless substr($url,-1) eq "/"; $url .= $file; $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG; @@ -2367,6 +2638,7 @@ sub hosthardest { } else { $CPAN::Frontend->myprint("Hmm... Still failed!\n"); } + return if $CPAN::Signal; } else { $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }. qq{correctly protected.\n}); @@ -2396,9 +2668,10 @@ sub hosthardest { } else { $CPAN::Frontend->myprint("Bad luck... Still failed!\n"); } + return if $CPAN::Signal; $CPAN::Frontend->myprint("Can't access URL $url.\n\n"); sleep 2; - } + } # host } sub talk_ftp { @@ -2526,6 +2799,7 @@ sub new { }, $class; } +# CPAN::FTP::hasdefault; sub hasdefault { shift->{'hasdefault'} } sub netrc { shift->{'netrc'} } sub protected { shift->{'protected'} } @@ -2573,22 +2847,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 - make test install force reload look cvs_import - ) - ); - } elsif ( $line !~ /^[\!abcdhimorutl]/ ) { + @return = grep /^$word/, @CPAN::Complete::COMMANDS; + } elsif ( $line !~ /^[\!abcdghimorutl]/ ) { @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 =~ /^([mru]|make|clean|test|install|readme|look|cvs_import)\s/ ) { + } elsif ($line =~ m/^( + [mru]|make|clean|dump|get|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); @@ -2596,6 +2870,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 = (); } @@ -2605,7 +2882,11 @@ sub cpl { #-> sub CPAN::Complete::cplx ; sub cplx { my($class, $word) = @_; - grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class); + # I believed for many years that this was sorted, today I + # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I + # make it sorted again. Maybe sort was dropped when GNU-readline + # support came in? The RCS file is difficult to read on that:-( + sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class); } #-> sub CPAN::Complete::cpl_any ; @@ -2654,7 +2935,7 @@ package CPAN::Index; #-> sub CPAN::Index::force_reload ; sub force_reload { my($class) = @_; - $CPAN::Index::last_time = 0; + $CPAN::Index::LAST_TIME = 0; $class->reload(1); } @@ -2668,51 +2949,71 @@ sub reload { for ($CPAN::Config->{index_expire}) { $_ = 0.001 unless $_ && $_ > 0.001; } - return if $last_time + $CPAN::Config->{index_expire}*86400 > $time + 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 + } + return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time and ! $force; - ## IFF we are developing, it helps to wipe out the memory between - ## reloads, otherwise it is not what a user expects. - - ## undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274) - ## $CPAN::META = CPAN->new; - my($debug,$t2); - $last_time = $time; - - my $needshort = $^O eq "dos"; - - $cl->rd_authindex($cl - ->reload_x( - "authors/01mailrc.txt.gz", - $needshort ? - File::Spec->catfile('authors', '01mailrc.gz') : - File::Spec->catfile('authors', '01mailrc.txt.gz'), - $force)); - $t2 = time; - $debug = "timing reading 01[".($t2 - $time)."]"; - $time = $t2; - return if $CPAN::Signal; # this is sometimes lengthy - $cl->rd_modpacks($cl - ->reload_x( - "modules/02packages.details.txt.gz", - $needshort ? - File::Spec->catfile('modules', '02packag.gz') : - File::Spec->catfile('modules', '02packages.details.txt.gz'), - $force)); - $t2 = time; - $debug .= "02[".($t2 - $time)."]"; - $time = $t2; - return if $CPAN::Signal; # this is sometimes lengthy - $cl->rd_modlist($cl - ->reload_x( - "modules/03modlist.data.gz", - $needshort ? - File::Spec->catfile('modules', '03mlist.gz') : - File::Spec->catfile('modules', '03modlist.data.gz'), - $force)); - $t2 = time; - $debug .= "03[".($t2 - $time)."]"; - $time = $t2; - CPAN->debug($debug) if $CPAN::DEBUG; + if (0) { + # IFF we are developing, it helps to wipe out the memory + # between reloads, otherwise it is not what a user expects. + undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274) + $CPAN::META = CPAN->new; + } + { + my($debug,$t2); + local $LAST_TIME = $time; + local $CPAN::META->{PROTOCOL} = PROTOCOL; + + my $needshort = $^O eq "dos"; + + $cl->rd_authindex($cl + ->reload_x( + "authors/01mailrc.txt.gz", + $needshort ? + File::Spec->catfile('authors', '01mailrc.gz') : + File::Spec->catfile('authors', '01mailrc.txt.gz'), + $force)); + $t2 = time; + $debug = "timing reading 01[".($t2 - $time)."]"; + $time = $t2; + return if $CPAN::Signal; # this is sometimes lengthy + $cl->rd_modpacks($cl + ->reload_x( + "modules/02packages.details.txt.gz", + $needshort ? + File::Spec->catfile('modules', '02packag.gz') : + File::Spec->catfile('modules', '02packages.details.txt.gz'), + $force)); + $t2 = time; + $debug .= "02[".($t2 - $time)."]"; + $time = $t2; + return if $CPAN::Signal; # this is sometimes lengthy + $cl->rd_modlist($cl + ->reload_x( + "modules/03modlist.data.gz", + $needshort ? + File::Spec->catfile('modules', '03mlist.gz') : + File::Spec->catfile('modules', '03modlist.data.gz'), + $force)); + $cl->write_metadata_cache; + $t2 = time; + $debug .= "03[".($t2 - $time)."]"; + $time = $t2; + CPAN->debug($debug) if $CPAN::DEBUG; + } + $LAST_TIME = $time; + $CPAN::META->{PROTOCOL} = PROTOCOL; } #-> sub CPAN::Index::reload_x ; @@ -2745,9 +3046,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"; @@ -2773,7 +3071,7 @@ sub userid { #-> sub CPAN::Index::rd_modpacks ; sub rd_modpacks { - my($cl, $index_target) = @_; + my($self, $index_target) = @_; my @lines; return unless defined $index_target; $CPAN::Frontend->myprint("Going to read $index_target\n"); @@ -2785,16 +3083,78 @@ sub rd_modpacks { unshift @ls, "\n" x length($1) if /^(\n+)/; push @lines, @ls; } + # read header + my($line_count,$last_updated); while (@lines) { my $shift = shift(@lines); last if $shift =~ /^\s*$/; + $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1; + $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1; } + if (not defined $line_count) { + + warn qq{Warning: Your $index_target does not contain a Line-Count header. +Please check the validity of the index file by comparing it to more +than one CPAN mirror. I'll continue but problems seem likely to +happen.\a +}; + + sleep 5; + } elsif ($line_count != scalar @lines) { + + warn sprintf qq{Warning: Your %s +contains a Line-Count header of %d but I see %d lines there. Please +check the validity of the index file by comparing it to more than one +CPAN mirror. I'll continue but problems seem likely to happen.\a\n}, +$index_target, $line_count, scalar(@lines); + + } + if (not defined $last_updated) { + + warn qq{Warning: Your $index_target does not contain a Last-Updated header. +Please check the validity of the index file by comparing it to more +than one CPAN mirror. I'll continue but problems seem likely to +happen.\a +}; + + sleep 5; + } else { + + $CPAN::Frontend + ->myprint(sprintf qq{ Database was generated on %s\n}, + $last_updated); + $DATE_OF_02 = $last_updated; + + if ($CPAN::META->has_inst(HTTP::Date)) { + require HTTP::Date; + my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24; + if ($age > 30) { + + $CPAN::Frontend + ->mywarn(sprintf + qq{Warning: This index file is %d days old. + Please check the host you chose as your CPAN mirror for staleness. + I'll continue but problems seem likely to happen.\a\n}, + $age); + + } + } else { + $CPAN::Frontend->myprint(" HTTP::Date not available\n"); + } + } + + + # A necessity since we have metadata_cache: delete what isn't + # there anymore + my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN"); + CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG; + my(%exists); foreach (@lines) { chomp; - my($mod,$version,$dist) = split; -### $version =~ s/^\+//; - - # if it is a bundle, instantiate a bundle object + # before 1.56 we split into 3 and discarded the rest. From + # 1.57 we assign remaining text to $comment thus allowing to + # influence isa_perl + my($mod,$version,$dist,$comment) = split " ", $_, 4; my($bundle,$id,$userid); if ($mod eq 'CPAN' && @@ -2803,18 +3163,18 @@ sub rd_modpacks { CPAN::Queue->exists('CPAN') ) ) { - local($^W)= 0; - if ($version > $CPAN::VERSION){ - $CPAN::Frontend->myprint(qq{ - There\'s a new CPAN.pm version (v$version) available! + local($^W)= 0; + if ($version > $CPAN::VERSION){ + $CPAN::Frontend->myprint(qq{ + There's a new CPAN.pm version (v$version) available! [Current version is v$CPAN::VERSION] You might want to try install Bundle::CPAN reload cpan without quitting the current session. It should be a seamless upgrade while we are running... -}); - sleep 2; +}); #}); + sleep 2; $CPAN::Frontend->myprint(qq{\n}); } last if $CPAN::Signal; @@ -2824,29 +3184,29 @@ sub rd_modpacks { if ($bundle){ $id = $CPAN::META->instance('CPAN::Bundle',$mod); - # warn "made mod[$mod]a bundle"; # Let's make it a module too, because bundles have so much - # in common with modules - $CPAN::META->instance('CPAN::Module',$mod); - # warn "made mod[$mod]a module"; + # in common with modules. -# This "next" makes us faster but if the job is running long, we ignore -# rereads which is bad. So we have to be a bit slower again. -# } elsif ($CPAN::META->exists('CPAN::Module',$mod)) { -# next; + # Changed in 1.57_63: seems like memory bloat now without + # any value, so commented out + + # $CPAN::META->instance('CPAN::Module',$mod); + + } else { - } - else { # instantiate a module object $id = $CPAN::META->instance('CPAN::Module',$mod); + } - if ($id->cpan_file ne $dist){ - $userid = $cl->userid($dist); + if ($id->cpan_file ne $dist){ # update only if file is + # different. CPAN prohibits same + # name with different version + $userid = $self->userid($dist); $id->set( 'CPAN_USERID' => $userid, 'CPAN_VERSION' => $version, - 'CPAN_FILE' => $dist + 'CPAN_FILE' => $dist, ); } @@ -2863,13 +3223,29 @@ sub rd_modpacks { $CPAN::META->instance( 'CPAN::Distribution' => $dist )->set( - 'CPAN_USERID' => $userid + 'CPAN_USERID' => $userid, + 'CPAN_COMMENT' => $comment, ); } - + if ($secondtime) { + for my $name ($mod,$dist) { + CPAN->debug("exists name[$name]") if $CPAN::DEBUG; + $exists{$name} = undef; + } + } return if $CPAN::Signal; } undef $fh; + if ($secondtime) { + for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) { + for my $o ($CPAN::META->all_objects($class)) { + next if exists $exists{$o->{ID}}; + $CPAN::META->delete($class,$o->{ID}); + CPAN->debug("deleting ID[$o->{ID}] in class[$class]") + if $CPAN::DEBUG; + } + } + } } #-> sub CPAN::Index::rd_modlist ; @@ -2889,8 +3265,8 @@ sub rd_modlist { while (@eval) { my $shift = shift(@eval); if ($shift =~ /^Date:\s+(.*)/){ - return if $date_of_03 eq $1; - ($date_of_03) = $1; + return if $DATE_OF_03 eq $1; + ($DATE_OF_03) = $1; } last if $shift =~ /^\s*$/; } @@ -2903,26 +3279,132 @@ 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; } } +#-> sub CPAN::Index::write_metadata_cache ; +sub write_metadata_cache { + my($self) = @_; + return unless $CPAN::Config->{'cache_metadata'}; + return unless $CPAN::META->has_usable("Storable"); + my $cache; + foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module + CPAN::Distribution)) { + $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok + } + my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata"); + $cache->{last_time} = $LAST_TIME; + $cache->{DATE_OF_02} = $DATE_OF_02; + $cache->{PROTOCOL} = PROTOCOL; + $CPAN::Frontend->myprint("Going to write $metadata_file\n"); + eval { Storable::nstore($cache, $metadata_file) }; + $CPAN::Frontend->mywarn($@) if $@; +} + +#-> sub CPAN::Index::read_metadata_cache ; +sub read_metadata_cache { + my($self) = @_; + return unless $CPAN::Config->{'cache_metadata'}; + return unless $CPAN::META->has_usable("Storable"); + my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata"); + return unless -r $metadata_file and -f $metadata_file; + $CPAN::Frontend->myprint("Going to read $metadata_file\n"); + my $cache; + eval { $cache = Storable::retrieve($metadata_file) }; + $CPAN::Frontend->mywarn($@) if $@; + if (!$cache || ref $cache ne 'HASH'){ + $LAST_TIME = 0; + return; + } + if (exists $cache->{PROTOCOL}) { + if (PROTOCOL > $cache->{PROTOCOL}) { + $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ". + "with protocol v%s, requiring v%s", + $cache->{PROTOCOL}, + PROTOCOL) + ); + return; + } + } else { + $CPAN::Frontend->mywarn("Ignoring Metadata cache written ". + "with protocol v1.0"); + return; + } + my $clcnt = 0; + my $idcnt = 0; + while(my($class,$v) = each %$cache) { + next unless $class =~ /^CPAN::/; + $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok + while (my($id,$ro) = each %$v) { + $CPAN::META->{readwrite}{$class}{$id} ||= + $class->new(ID=>$id, RO=>$ro); + $idcnt++; + } + $clcnt++; + } + unless ($clcnt) { # sanity check + $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n"); + return; + } + if ($idcnt < 1000) { + $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ". + "in $metadata_file\n"); + return; + } + $CPAN::META->{PROTOCOL} ||= + $cache->{PROTOCOL}; # reading does not up or downgrade, but it + # does initialize to some protocol + $LAST_TIME = $cache->{last_time}; + $DATE_OF_02 = $cache->{DATE_OF_02}; + $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n"); + return; +} + package CPAN::InfoObj; +# Accessors +sub cpan_userid { shift->{RO}{CPAN_USERID} } +sub id { shift->{ID}; } + #-> sub CPAN::InfoObj::new ; -sub new { my $this = bless {}, shift; %$this = @_; $this } +sub new { + my $this = bless {}, shift; + %$this = @_; + $this +} + +# The set method may only be used by code that reads index data or +# otherwise "objective" data from the outside world. All session +# related material may do anything else with instance variables but +# must not touch the hash under the RO attribute. The reason is that +# the RO hash gets written to Metadata file and is thus persistent. #-> sub CPAN::InfoObj::set ; sub set { my($self,%att) = @_; - my(%oldatt) = %$self; - %$self = (%oldatt, %att); -} + my $class = ref $self; + + # This must be ||=, not ||, because only if we write an empty + # reference, only then the set method will write into the readonly + # area. But for Distributions that spring into existence, maybe + # 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} ||= {}; -#-> sub CPAN::InfoObj::id ; -sub id { shift->{'ID'} } + while (my($k,$v) = each %att) { + $ro->{$k} = $v; + } +} #-> sub CPAN::InfoObj::as_glimpse ; sub as_glimpse { @@ -2941,31 +3423,39 @@ sub as_string { my $class = ref($self); $class =~ s/^CPAN:://; push @m, $class, " id = $self->{ID}\n"; - for (sort keys %$self) { - next if $_ eq 'ID'; + for (sort keys %{$self->{RO}}) { + # 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->{$_} - )->email) { - $extra .= " <$email>"; - } else { - $extra .= " <no email>"; - } - $extra .= ")"; - } - if (ref($self->{$_}) eq "ARRAY") { # language interface? XXX - push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra; + $extra .= " (".$self->author; + my $email; # old perls! + if ($email = $CPAN::META->instance("CPAN::Author", + $self->cpan_userid + )->email) { + $extra .= " <$email>"; + } else { + $extra .= " <no email>"; + } + $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; + } + for (sort keys %$self) { + next if m/^(ID|RO)$/; + if (ref($self->{$_}) eq "ARRAY") { + push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}"; } elsif (ref($self->{$_}) eq "HASH") { push @m, sprintf( - " %-12s %s%s\n", + " %-12s %s\n", $_, join(" ",keys %{$self->{$_}}), - $extra); + ); } else { - push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra; + push @m, sprintf " %-12s %s\n", $_, $self->{$_}; } } join "", @m, "\n"; @@ -2974,42 +3464,204 @@ 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 ; sub dump { my($self) = @_; require Data::Dumper; - Data::Dumper::Dumper($self); + print Data::Dumper::Dumper($self); } package CPAN::Author; +#-> sub CPAN::Author::id +sub id { + my $self = shift; + my $id = $self->{ID}; + $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/; + $id; +} + #-> sub CPAN::Author::as_glimpse ; sub as_glimpse { my($self) = @_; my(@m); my $class = ref($self); $class =~ s/^CPAN:://; - push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname; + push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n}, + $class, + $self->{ID}, + $self->fullname, + $self->email); join "", @m; } -# Dead code, I would have liked to have,,, but it was never reached,,, -#sub make { -# my($self) = @_; -# return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n"; -#} - #-> sub CPAN::Author::fullname ; -sub fullname { shift->{'FULLNAME'} } +sub fullname { + shift->{RO}{FULLNAME}; +} *name = \&fullname; #-> sub CPAN::Author::email ; -sub email { shift->{'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(@csf); # chksumfile + @csf = $self->id =~ /(.)(.)(.*)/; + $csf[1] = join "", @csf[0,1]; + $csf[2] = join "", @csf[1,2]; + my(@dl); + @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0); + unless (grep {$_->[2] eq $csf[1]} @dl) { + $CPAN::Frontend->myprint("No files in the directory of $id\n"); + return; + } + @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0); + unless (grep {$_->[2] eq $csf[2]} @dl) { + $CPAN::Frontend->myprint("No files in the directory of $id\n"); + return; + } + @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1); + $CPAN::Frontend->myprint(join "", map { + sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2]) + } sort { $a->[2] cmp $b->[2] } @dl); +} + +# returns an array of arrays, the latter contain (size,mtime,filename) +#-> sub CPAN::Author::dir_listing ; +sub dir_listing { + my $self = shift; + my $chksumfile = shift; + my $recursive = shift; + my $lc_want = + MM->catfile($CPAN::Config->{keep_source_where}, + "authors", "id", @$chksumfile); + local($") = "/"; + # connect "force" argument with "index_expire". + my $force = 0; + if (my @stat = stat $lc_want) { + $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time; + } + my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile", + $lc_want,$force); + 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}) { + if ($recursive) { + my(@dir) = @$chksumfile; + pop @dir; + push @dir, $f, "CHECKSUMS"; + push @result, map { + [$_->[0], $_->[1], "$f/$_->[2]"] + } $self->dir_listing(\@dir,1); + } else { + push @result, [ 0, "-", $f ]; + } + } else { + push @result, [ + ($cksum->{$f}{"size"}||0), + $cksum->{$f}{"mtime"}||"---", + $f + ]; + } + } + @result; +} package CPAN::Distribution; +# Accessors +sub cpan_comment { shift->{RO}{CPAN_COMMENT} } + +sub undelay { + my $self = shift; + delete $self->{later}; +} + +# CPAN::Distribution::normalize +sub normalize { + my($self,$s) = @_; + $s = $self->id unless defined $s; + if ( + $s =~ tr|/|| == 1 + or + $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/| + ) { + return $s if $s =~ m:^N/A|^Contact Author: ; + $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; + my($depth) = shift || 0; + my($color) = shift || 0; + # a distribution needs to recurse into its prereq_pms + + return if exists $self->{incommandcolor} + && $self->{incommandcolor}==$color; + $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ". + "color_cmd_tmps depth[%s] self[%s] id[%s]", + $depth, + $self, + $self->id + )) if $depth>=100; + ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; + my $prereq_pm = $self->prereq_pm; + if (defined $prereq_pm) { + for my $pre (keys %$prereq_pm) { + my $premo = CPAN::Shell->expand("Module",$pre); + $premo->color_cmd_tmps($depth+1,$color); + } + } + if ($color==0) { + delete $self->{sponsored_mods}; + delete $self->{badtestcnt}; + } + $self->{incommandcolor} = $color; +} + #-> sub CPAN::Distribution::as_string ; sub as_string { my $self = shift; @@ -3020,20 +3672,50 @@ 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_file = $mod->cpan_file 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 ; sub called_for { my($self,$id) = @_; - $self->{'CALLED_FOR'} = $id if defined $id; - return $self->{'CALLED_FOR'}; + $self->{CALLED_FOR} = $id if defined $id; + return $self->{CALLED_FOR}; +} + +#-> sub CPAN::Distribution::safe_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 ; @@ -3042,106 +3724,180 @@ sub get { EXCUSE: { my @e; exists $self->{'build_dir'} and push @e, - "Unwrapped into directory $self->{'build_dir'}"; + "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( - $CPAN::Config->{keep_source_where}, - "authors", - "id", - split("/",$self->{ID}) - ); + MM->catfile( + $CPAN::Config->{keep_source_where}, + "authors", + "id", + split("/",$self->id) + ); $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"); + unless ($local_file = + CPAN::FTP->localize("authors/id/$self->{ID}", + $local_wanted)) { + my $note = ""; + if ($CPAN::Index::DATE_OF_02) { + $note = "Note: Current database in memory was generated ". + "on $CPAN::Index::DATE_OF_02\n"; + } + $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note"); + } + $self->debug("local_file[$local_file]") if $CPAN::DEBUG; $self->{localfile} = $local_file; - my $builddir = $CPAN::META->{cachemgr}->dir; - $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; - if ($CPAN::META->has_inst('MD5')) { + # + # 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"; - $self->debug("Changed directory to tmp") if $CPAN::DEBUG; - if (! $local_file) { - Carp::croak "bad download, can't do anything :-(\n"; - } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)\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\z/i ) { + } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) { $self->unzip_me($local_file); - } elsif ( $local_file =~ /\.pm\.(gz|Z)\z/) { + } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) { + $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file); $self->pm2dir_me($local_file); } else { $self->{archived} = "NO"; + $self->safe_chdir($sub_wd); + return; } - chdir File::Spec->updir; - if ($self->{archived} ne 'NO') { - chdir File::Spec->catdir(File::Spec->curdir, "tmp"); - # 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 $_ !~ /^\.\.?\z/s, $dh->read; ### MAC?? - $dh->close; - my ($distdir,$packagedir); - if (@readdir == 1 && -d $readdir[0]) { - $distdir = $readdir[0]; - $packagedir = MM->catdir($builddir,$distdir); - -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 $pragmatic_dir = $self->{'CPAN_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; - chdir File::Spec->updir; - - $self->debug("Changed directory to .. (self is $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) { - my($configure) = MM->catfile($packagedir,"Configure"); - if (-f $configure) { - # do we have anything to do? - $self->{'configure'} = $configure; - } elsif (-f MM->catfile($packagedir,"Makefile")) { - $CPAN::Frontend->myprint(qq{ + + # 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: $!"); + $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) { + # NFS has been reported to have racing problems after the + # renaming of a directory in some environments. + # This trick helps. + sleep 1; + my $mpldh = DirHandle->new($packagedir) + or Carp::croak("Couldn't opendir $packagedir: $!"); + $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read; + $mpldh->close; + } + 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; + } elsif (-f MM->catfile($packagedir,"Makefile")) { + $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; - } else { - my $fh = FileHandle->new(">$makefilepl") - or Carp::croak("Could not open >$makefilepl"); - my $cf = $self->called_for || "unknown"; - $fh->print( + $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 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{ @@ -3150,14 +3906,14 @@ use ExtUtils::MakeMaker; WriteMakefile(NAME => q[$cf]); }); - $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL. - Writing one on our own (calling it $cf)\n}); - } - } + $fh->close; + } } + return $self; } +# CPAN::Distribution::untar_me ; sub untar_me { my($self,$local_file) = @_; $self->{archived} = "tar"; @@ -3168,22 +3924,23 @@ sub untar_me { } } +# CPAN::Distribution::unzip_me ; sub unzip_me { my($self,$local_file) = @_; $self->{archived} = "zip"; - my $system = "$CPAN::Config->{unzip} $local_file"; - if (system($system) == 0) { + if (CPAN::Tarzip->unzip($local_file)) { $self->{unwrapped} = "YES"; } else { $self->{unwrapped} = "NO"; } + return; } sub pm2dir_me { my($self,$local_file) = @_; $self->{archived} = "pm"; my $to = File::Basename::basename($local_file); - $to =~ s/\.(gz|Z)\z//; + $to =~ s/\.(gz|Z)(?!\n)\Z//; if (CPAN::Tarzip->gunzip($local_file,$to)) { $self->{unwrapped} = "YES"; } else { @@ -3195,7 +3952,7 @@ sub pm2dir_me { sub new { my($class,%att) = @_; - $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); + # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); my $this = { %att }; return bless $this, $class; @@ -3222,18 +3979,25 @@ Please define it with "o conf shell <your shell>" return; } 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(); - chdir($dir); + my $dir; + unless ($dir = $self->dir) { + $self->get; + } + unless ($dir ||= $self->dir) { + $CPAN::Frontend->mywarn(qq{ +Could not determine which directory to use for looking at $dist. +}); + return; + } + my $pwd = CPAN::anycwd(); + $self->safe_chdir($dir); $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); system($CPAN::Config->{'shell'}) == 0 or $CPAN::Frontend->mydie("Subprocess shell error"); - chdir($pwd); + $self->safe_chdir($pwd); } +# CPAN::Distribution::cvs_import ; sub cvs_import { my($self) = @_; $self->get; @@ -3243,10 +4007,10 @@ sub cvs_import { my $module = $CPAN::META->instance('CPAN::Module', $package); my $version = $module->cpan_version; - my $userid = $self->{CPAN_USERID}; + my $userid = $self->cpan_userid; my $cvs_dir = (split '/', $dir)[-1]; - $cvs_dir =~ s/-\d+[^-]+\z//; + $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//; my $cvs_root = $CPAN::Config->{cvsroot} || $ENV{CVSROOT}; my $cvs_site_perl = @@ -3259,17 +4023,15 @@ 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(); - chdir($dir); + 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}); $CPAN::Frontend->myprint(qq{@cmd\n}); - system(@cmd) == 0 or + system(@cmd) == 0 or $CPAN::Frontend->mydie("cvs import failed"); - chdir($pwd); + chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!}); } #-> sub CPAN::Distribution::readme ; @@ -3322,7 +4084,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 = @@ -3339,11 +4101,12 @@ 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); if ($lc_file) { - $lc_file =~ s/\.gz\z//; + $lc_file =~ s/\.gz(?!\n)\Z//; CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file); } else { return; @@ -3401,33 +4164,42 @@ sub MD5_check_file { $CPAN::Frontend->myprint("Checksum for $file ok\n"); return $self->{MD5_STATUS} = "OK"; } else { - $CPAN::Frontend->myprint(qq{Checksum mismatch for }. + $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }. qq{distribution file. }. qq{Please investigate.\n\n}. $self->as_string, $CPAN::META->instance( 'CPAN::Author', - $self->{CPAN_USERID} + $self->cpan_userid )->as_string); - my $wrap = qq{I\'d recommend removing $file. It seems to -be a bogus file. Maybe you have configured your \`urllist\' with a -bad URL. Please check this array with \`o conf urllist\', and + + my $wrap = qq{I\'d recommend removing $file. Its MD5 +checksum is incorrect. Maybe you have configured your 'urllist' with +a bad URL. Please check this array with 'o conf urllist', and retry.}; - $CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap)); - $CPAN::Frontend->myprint("\n\n"); - sleep 3; - return; + + $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap)); + + # former versions just returned here but this seems a + # serious threat that deserves a die + + # $CPAN::Frontend->myprint("\n\n"); + # sleep 3; + # return; } # close $fh if fileno($fh); } else { $self->{MD5_STATUS} ||= ""; if ($self->{MD5_STATUS} eq "NIL") { - $CPAN::Frontend->myprint(qq{ -No md5 checksum for $basename in local $chk_file. -Removing $chk_file + $CPAN::Frontend->mywarn(qq{ +Warning: No md5 checksum for $basename in $chk_file. + +The cause for this may be that the file is very new and the checksum +has not yet been calculated, but it may also be that something is +going awry right now. }); - unlink $chk_file or $CPAN::Frontend->myprint("Could not unlink: $!"); - sleep 1; + my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes"); + $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted."); } $self->{MD5_STATUS} = "NIL"; return; @@ -3449,36 +4221,65 @@ sub eq_MD5 { } #-> sub CPAN::Distribution::force ; + +# Both modules and distributions know if "force" is in effect by +# autoinspection, not by inspecting a global variable. One of the +# reason why this was chosen to work that way was the treatment of +# dependencies. They should not autpomatically inherit the force +# status. But this has the downside that ^C and die() will return to +# the prompt but will not be able to reset the force_update +# attributes. We try to correct for it currently in the read_metadata +# routine, and immediately before we check for a Signal. I hope this +# works out in one of v1.57_53ff + sub force { - my($self) = @_; - $self->{'force_update'}++; + my($self, $method) = @_; for my $att (qw( MD5_STATUS archived build_dir localfile make install unwrapped writemakefile )) { delete $self->{$att}; } + if ($method && $method eq "install") { + $self->{"force_update"}++; # name should probably have been force_install + } } +#-> sub CPAN::Distribution::unforce ; +sub unforce { + my($self) = @_; + delete $self->{'force_update'}; +} + +#-> sub CPAN::Distribution::isa_perl ; sub isa_perl { my($self) = @_; my $file = File::Basename::basename($self->id); - return unless $file =~ m{ ^ perl - (5) - ([._-]) - (\d{3}(_[0-4][0-9])?) - \.tar[._-]gz - \z - }xs; - "$1.$3"; + if ($file =~ m{ ^ perl + -? + (5) + ([._-]) + ( + \d{3}(_[0-4][0-9])? + | + \d*[24680]\.\d+ + ) + \.tar[._-]gz + (?!\n)\Z + }xs){ + return "$1.$3"; + } elsif ($self->cpan_comment + && + $self->cpan_comment =~ /isa_perl\(.+?\)/){ + return $1; + } } #-> sub CPAN::Distribution::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) { @@ -3505,9 +4306,11 @@ sub make { # Emergency brake if they said install Pippi and get newest perl if ($self->isa_perl) { if ( - $self->called_for ne $self->id && ! $self->{'force_update'} + $self->called_for ne $self->id && + ! $self->{force_update} ) { - $CPAN::Frontend->mydie(sprintf qq{ + # if we die here, we break bundles + $CPAN::Frontend->mywarn(sprintf qq{ The most recent version "%s" of the module "%s" comes with the current version of perl (%s). I\'ll build that only if you ask for something like @@ -3523,6 +4326,7 @@ or $self->isa_perl, $self->called_for, $self->id); + sleep 5; return; } } $self->get; @@ -3539,7 +4343,10 @@ or $1 || "Had some problem writing Makefile"; defined $self->{'make'} and push @e, - "Has already been processed within this session"; + "Has already been processed within this session"; + + exists $self->{later} and length($self->{later}) and + push @e, $self->{later}; $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } @@ -3606,6 +4413,7 @@ or } if (-f "Makefile") { $self->{writemakefile} = "YES"; + delete $self->{make_clean}; # if cleaned before, enable next } else { $self->{writemakefile} = qq{NO Makefile.PL refused to write a Makefile.}; @@ -3615,98 +4423,177 @@ or # $self->{writemakefile} .= <$fh>; } } - return if $CPAN::Signal; - if (my @prereq = $self->needs_prereq){ - my $id = $self->id; - $CPAN::Frontend->myprint("---- Dependencies detected ". - "during [$id] -----\n"); + if ($CPAN::Signal){ + delete $self->{force_update}; + return; + } + if (my @prereq = $self->unsat_prereq){ + return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner + } + $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg}; + if (system($system) == 0) { + $CPAN::Frontend->myprint(" $system -- OK\n"); + $self->{'make'} = "YES"; + } else { + $self->{writemakefile} ||= "YES"; + $self->{'make'} = "NO"; + $CPAN::Frontend->myprint(" $system -- NOT OK\n"); + } +} + +sub follow_prereqs { + my($self) = shift; + my(@prereq) = @_; + my $id = $self->id; + $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ". + "during [$id] -----\n"); - for my $p (@prereq) { + for my $p (@prereq) { $CPAN::Frontend->myprint(" $p\n"); - } - my $follow = 0; - if ($CPAN::Config->{prerequisites_policy} eq "follow") { + } + my $follow = 0; + if ($CPAN::Config->{prerequisites_policy} eq "follow") { $follow = 1; - } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") { + } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") { require ExtUtils::MakeMaker; my $answer = ExtUtils::MakeMaker::prompt( "Shall I follow them and prepend them to the queue of modules we are processing right now?", "yes"); $follow = $answer =~ /^\s*y/i; - } else { + } else { local($") = ", "; - $CPAN::Frontend->myprint(" Ignoring dependencies on modules @prereq\n"); - } - if ($follow) { - CPAN::Queue->jumpqueue(@prereq,$id); # requeue yourself - return; - } + $CPAN::Frontend-> + myprint(" Ignoring dependencies on modules @prereq\n"); } - $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg}; - if (system($system) == 0) { - $CPAN::Frontend->myprint(" $system -- OK\n"); - $self->{'make'} = "YES"; - } else { - $self->{writemakefile} ||= "YES"; - $self->{'make'} = "NO"; - $CPAN::Frontend->myprint(" $system -- NOT OK\n"); + if ($follow) { + # color them as dirty + for my $p (@prereq) { + CPAN::Shell->expandany($p)->color_cmd_tmps(0,1); + } + CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself + $self->{later} = "Delayed until after prerequisites"; + return 1; # signal success to the queuerunner } } -#-> sub CPAN::Distribution::needs_prereq ; -sub needs_prereq { +#-> sub CPAN::Distribution::unsat_prereq ; +sub unsat_prereq { + my($self) = @_; + my $prereq_pm = $self->prereq_pm or return; + my(@need); + NEED: while (my($need_module, $need_version) = each %$prereq_pm) { + my $nmo = $CPAN::META->instance("CPAN::Module",$need_module); + # we were too demanding: + next if $nmo->uptodate; + + # if they have not specified a version, we accept any installed one + if (not defined $need_version or + $need_version == 0 or + $need_version eq "undef") { + next if defined $nmo->inst_file; + } + + # We only want to install prereqs if either they're not installed + # or if the installed version is too old. We cannot omit this + # check, because if 'force' is in effect, nobody else will check. + { + local($^W) = 0; + if ( + defined $nmo->inst_file && + ! CPAN::Version->vgt($need_version, $nmo->inst_version) + ){ + CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]", + $nmo->id, + $nmo->inst_file, + $nmo->inst_version, + CPAN::Version->readable($need_version) + ); + next NEED; + } + } + + if ($self->{sponsored_mods}{$need_module}++){ + # We have already sponsored it and for some reason it's still + # not available. So we do nothing. Or what should we do? + # if we push it again, we have a potential infinite loop + next; + } + push @need, $need_module; + } + @need; +} + +#-> sub CPAN::Distribution::prereq_pm ; +sub prereq_pm { my($self) = @_; - return unless -f "Makefile"; # we cannot say much - my $fh = FileHandle->new("<Makefile") or - $CPAN::Frontend->mydie("Couldn't open Makefile: $!"); - local($/) = "\n"; - - my(@p,@need); - while (<$fh>) { - last if /MakeMaker post_initialize section/; - my($p) = m{^[\#] + return $self->{prereq_pm} if + exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected}; + return unless $self->{writemakefile}; # no need to have succeeded + # but we must have run it + my $build_dir = $self->{build_dir} or die "Panic: no build_dir?"; + my $makefile = File::Spec->catfile($build_dir,"Makefile"); + my(%p) = (); + my $fh; + if (-f $makefile + and + $fh = FileHandle->new("<$makefile\0")) { + + local($/) = "\n"; + + # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version + while (<$fh>) { + last if /MakeMaker post_initialize section/; + my($p) = m{^[\#] \s+PREREQ_PM\s+=>\s+(.+) }x; - next unless $p; - # warn "Found prereq expr[$p]"; - - while ( $p =~ m/(?:\s)([\w\:]+)=>q\[.*?\],?/g ){ - push @p, $1; - } - last; - } - for my $p (@p) { - my $mo = $CPAN::META->instance("CPAN::Module",$p); - next if $mo->uptodate; - # it's not needed, so don't push it. We cannot omit this step, because - # if 'force' is in effect, nobody else will check. - if ($self->{have_sponsored}{$p}++){ - # We have already sponsored it and for some reason it's still - # not available. So we do nothing. Or what should we do? - # if we push it again, we have a potential infinite loop - next; - } - push @need, $p; + next unless $p; + # warn "Found prereq expr[$p]"; + + # Regexp modified by A.Speer to remember actual version of file + # PREREQ_PM hash key wants, then add to + while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){ + # In case a prereq is mentioned twice, complain. + if ( defined $p{$1} ) { + warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins"; + } + $p{$1} = $2; + } + last; + } } - return @need; + $self->{prereq_pm_detected}++; + return $self->{prereq_pm} = \%p; } #-> sub CPAN::Distribution::test ; sub test { my($self) = @_; $self->make; - return if $CPAN::Signal; + if ($CPAN::Signal){ + delete $self->{force_update}; + return; + } $CPAN::Frontend->myprint("Running make test\n"); + if (my @prereq = $self->unsat_prereq){ + return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner + } EXCUSE: { my @e; - exists $self->{'make'} or push @e, + exists $self->{make} or exists $self->{later} or push @e, "Make had some problems, maybe interrupted? Won't test"; exists $self->{'make'} and $self->{'make'} eq 'NO' and - push @e, "Oops, make had returned bad status"; + push @e, "Can't test without successful make"; + + exists $self->{build_dir} or push @e, "Has no own directory"; + $self->{badtestcnt} ||= 0; + $self->{badtestcnt} > 0 and + push @e, "Won't repeat unsuccessful test during this command"; + + exists $self->{later} and length($self->{later}) and + push @e, $self->{later}; - exists $self->{'build_dir'} or push @e, "Has no own directory"; $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } chdir $self->{'build_dir'} or @@ -3722,9 +4609,10 @@ sub test { my $system = join " ", $CPAN::Config->{'make'}, "test"; if (system($system) == 0) { $CPAN::Frontend->myprint(" $system -- OK\n"); - $self->{'make_test'} = "YES"; + $self->{make_test} = "YES"; } else { - $self->{'make_test'} = "NO"; + $self->{make_test} = "NO"; + $self->{badtestcnt}++; $CPAN::Frontend->myprint(" $system -- NOT OK\n"); } } @@ -3735,7 +4623,9 @@ sub clean { $CPAN::Frontend->myprint("Running make clean\n"); EXCUSE: { my @e; - exists $self->{'build_dir'} or push @e, "Has no own directory"; + exists $self->{make_clean} and $self->{make_clean} eq "YES" and + push @e, "make clean already called once"; + exists $self->{build_dir} or push @e, "Has no own directory"; $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } chdir $self->{'build_dir'} or @@ -3749,10 +4639,31 @@ sub clean { my $system = join " ", $CPAN::Config->{'make'}, "clean"; if (system($system) == 0) { - $CPAN::Frontend->myprint(" $system -- OK\n"); - $self->force; + $CPAN::Frontend->myprint(" $system -- OK\n"); + + # $self->force; + + # Jost Krieger pointed out that this "force" was wrong because + # it has the effect that the next "install" on this distribution + # will untar everything again. Instead we should bring the + # object's state back to where it is after untarring. + + delete $self->{force_update}; + delete $self->{install}; + delete $self->{writemakefile}; + delete $self->{make}; + delete $self->{make_test}; # no matter if yes or no, tests must be redone + $self->{make_clean} = "YES"; + } else { - # Hmmm, what to do if make clean failed? + # Hmmm, what to do if make clean failed? + + $CPAN::Frontend->myprint(qq{ $system -- NOT OK + +make clean did not succeed, marking directory as unusable for further work. +}); + $self->force("make"); # so that this directory won't be used again + } } @@ -3760,18 +4671,21 @@ sub clean { sub install { my($self) = @_; $self->test; - return if $CPAN::Signal; + if ($CPAN::Signal){ + delete $self->{force_update}; + return; + } $CPAN::Frontend->myprint("Running make install\n"); EXCUSE: { my @e; - exists $self->{'build_dir'} or push @e, "Has no own directory"; + exists $self->{build_dir} or push @e, "Has no own directory"; - exists $self->{'make'} or push @e, + exists $self->{make} or exists $self->{later} or push @e, "Make had some problems, maybe interrupted? Won't install"; exists $self->{'make'} and $self->{'make'} eq 'NO' and - push @e, "Oops, make had returned bad status"; + push @e, "make had returned bad status, install seems impossible"; push @e, "make test had returned bad status, ". "won't install without force" @@ -3783,6 +4697,9 @@ sub install { $self->{'install'} eq "YES" ? "Already done" : "Already tried without success"; + exists $self->{later} and length($self->{later}) and + push @e, $self->{later}; + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } chdir $self->{'build_dir'} or @@ -3816,6 +4733,7 @@ sub install { qq{to root to install the package\n}); } } + delete $self->{force_update}; } #-> sub CPAN::Distribution::dir ; @@ -3825,69 +4743,114 @@ sub dir { package CPAN::Bundle; +sub undelay { + my $self = shift; + delete $self->{later}; + for my $c ( $self->contains ) { + my $obj = CPAN::Shell->expandany($c) or next; + $obj->undelay; + } +} + +#-> sub CPAN::Bundle::color_cmd_tmps ; +sub color_cmd_tmps { + my($self) = shift; + my($depth) = shift || 0; + my($color) = shift || 0; + # a module needs to recurse to its cpan_file, a distribution needs + # to recurse into its prereq_pms, a bundle needs to recurse into its modules + + return if exists $self->{incommandcolor} + && $self->{incommandcolor}==$color; + $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ". + "color_cmd_tmps depth[%s] self[%s] id[%s]", + $depth, + $self, + $self->id + )) if $depth>=100; + ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; + + for my $c ( $self->contains ) { + my $obj = CPAN::Shell->expandany($c) or next; + CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG; + $obj->color_cmd_tmps($depth+1,$color); + } + if ($color==0) { + delete $self->{badtestcnt}; + } + $self->{incommandcolor} = $color; +} + #-> sub CPAN::Bundle::as_string ; sub as_string { my($self) = @_; $self->contains; + # following line must be "=", not "||=" because we have a moving target $self->{INST_VERSION} = $self->inst_version; return $self->SUPER::as_string; } #-> sub CPAN::Bundle::contains ; sub contains { - my($self) = @_; - my($parsefile) = $self->inst_file; - my($id) = $self->id; - $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG; - unless ($parsefile) { - # Try to get at it in the cpan directory - $self->debug("no parsefile") if $CPAN::DEBUG; - Carp::confess "I don't know a $id" unless $self->{CPAN_FILE}; - my $dist = $CPAN::META->instance('CPAN::Distribution', - $self->{CPAN_FILE}); - $dist->get; - $self->debug($dist->as_string) if $CPAN::DEBUG; - my($todir) = $CPAN::Config->{'cpan_home'}; - my(@me,$from,$to,$me); - @me = split /::/, $self->id; - $me[-1] .= ".pm"; - $me = MM->catfile(@me); - $from = $self->find_bundle_file($dist->{'build_dir'},$me); - $to = MM->catfile($todir,$me); - File::Path::mkpath(File::Basename::dirname($to)); - File::Copy::copy($from, $to) - or Carp::confess("Couldn't copy $from to $to: $!"); - $parsefile = $to; - } - my @result; - my $fh = FileHandle->new; - local $/ = "\n"; - open($fh,$parsefile) or die "Could not open '$parsefile': $!"; - my $in_cont = 0; - $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG; - while (<$fh>) { - $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 : - m/^=head1\s+CONTENTS/ ? 1 : $in_cont; - next unless $in_cont; - next if /^=/; - s/\#.*//; - next if /^\s+$/; - chomp; - push @result, (split " ", $_, 2)[0]; - } - close $fh; - delete $self->{STATUS}; - $self->{CONTAINS} = join ", ", @result; - $self->debug("CONTAINS[@result]") if $CPAN::DEBUG; - unless (@result) { - $CPAN::Frontend->mywarn(qq{ -The bundle file "$parsefile" may be a broken + my($self) = @_; + my($inst_file) = $self->inst_file || ""; + my($id) = $self->id; + $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG; + unless ($inst_file) { + # Try to get at it in the cpan directory + $self->debug("no inst_file") if $CPAN::DEBUG; + my $cpan_file; + $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless + $cpan_file = $self->cpan_file; + if ($cpan_file eq "N/A") { + $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN. + Maybe stale symlink? Maybe removed during session? Giving up.\n"); + } + my $dist = $CPAN::META->instance('CPAN::Distribution', + $self->cpan_file); + $dist->get; + $self->debug($dist->as_string) if $CPAN::DEBUG; + my($todir) = $CPAN::Config->{'cpan_home'}; + my(@me,$from,$to,$me); + @me = split /::/, $self->id; + $me[-1] .= ".pm"; + $me = MM->catfile(@me); + $from = $self->find_bundle_file($dist->{'build_dir'},$me); + $to = MM->catfile($todir,$me); + File::Path::mkpath(File::Basename::dirname($to)); + File::Copy::copy($from, $to) + or Carp::confess("Couldn't copy $from to $to: $!"); + $inst_file = $to; + } + my @result; + my $fh = FileHandle->new; + local $/ = "\n"; + open($fh,$inst_file) or die "Could not open '$inst_file': $!"; + my $in_cont = 0; + $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG; + while (<$fh>) { + $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 : + m/^=head1\s+CONTENTS/ ? 1 : $in_cont; + next unless $in_cont; + next if /^=/; + s/\#.*//; + next if /^\s+$/; + chomp; + push @result, (split " ", $_, 2)[0]; + } + close $fh; + delete $self->{STATUS}; + $self->{CONTAINS} = \@result; + $self->debug("CONTAINS[@result]") if $CPAN::DEBUG; + unless (@result) { + $CPAN::Frontend->mywarn(qq{ +The bundle file "$inst_file" may be a broken bundlefile. It seems not to contain any bundle definition. Please check the file and if it is bogus, please delete it. Sorry for the inconvenience. }); - } - @result; + } + @result; } #-> sub CPAN::Bundle::find_bundle_file @@ -3900,11 +4863,10 @@ 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(); - chdir $where; + my $cwd = CPAN::anycwd(); + chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!}); ExtUtils::Manifest::mkmanifest(); - chdir $cwd; + chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!}); } my $fh = FileHandle->new($manifest) or Carp::croak("Couldn't open $manifest: $!"); @@ -3936,22 +4898,37 @@ sub find_bundle_file { Carp::croak("Couldn't find a Bundle file in $where"); } +# 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) = @_; - my($me,$inst_file); - ($me = $self->id) =~ s/.*://; -## my(@me,$inst_file); -## @me = split /::/, $self->id; -## $me[-1] .= ".pm"; - $inst_file = MM->catfile($CPAN::Config->{'cpan_home'}, - "Bundle", "$me.pm"); -## "Bundle", @me); - return $self->{'INST_FILE'} = $inst_file if -f $inst_file; -# $inst_file = - $self->SUPER::inst_file; -# return $self->{'INST_FILE'} = $inst_file if -f $inst_file; -# return $self->{'INST_FILE'}; # even if undefined? + my($inst_file); + my(@me); + @me = split /::/, $self->id; + $me[-1] .= ".pm"; + 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 ; @@ -3960,7 +4937,7 @@ sub rematein { $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG; my($id) = $self->id; Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n" - unless $self->inst_file || $self->{CPAN_FILE}; + unless $self->inst_file || $self->cpan_file; my($s,%fail); for $s ($self->contains) { my($type) = $s =~ m|/| ? 'CPAN::Distribution' : @@ -3973,14 +4950,36 @@ explicitly a file $s. sleep 3; } # possibly noisy action: + $self->debug("type[$type] s[$s]") if $CPAN::DEBUG; my $obj = $CPAN::META->instance($type,$s); $obj->$meth(); - my $success = $obj->can("uptodate") ? $obj->uptodate : 0; - $success ||= $obj->{'install'} && $obj->{'install'} eq "YES"; - $fail{$s} = 1 unless $success; + if ($obj->isa(CPAN::Bundle) + && + exists $obj->{install_failed} + && + ref($obj->{install_failed}) eq "HASH" + ) { + for (keys %{$obj->{install_failed}}) { + $self->{install_failed}{$_} = undef; # propagate faiure up + # to me in a + # recursive call + $fail{$s} = 1; # the bundle itself may have succeeded but + # not all children + } + } else { + my $success; + $success = $obj->can("uptodate") ? $obj->uptodate : 0; + $success ||= $obj->{'install'} && $obj->{'install'} eq "YES"; + if ($success) { + delete $self->{install_failed}{$s}; + } else { + $fail{$s} = 1; + } + } } + # recap with less noise - if ( $meth eq "install") { + if ( $meth eq "install" ) { if (%fail) { require Text::Wrap; my $raw = sprintf(qq{Bundle summary: @@ -3990,9 +4989,21 @@ The following items in bundle %s had installation problems:}, $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw)); $CPAN::Frontend->myprint("\n"); my $paragraph = ""; + my %reported; for $s ($self->contains) { - $paragraph .= "$s " if $fail{$s}; + if ($fail{$s}){ + $paragraph .= "$s "; + $self->{install_failed}{$s} = undef; + $reported{$s} = undef; + } } + my $report_propagated; + for $s (sort keys %{$self->{install_failed}}) { + next if exists $reported{$s}; + $paragraph .= "and the following items had problems +during recursive bundle calls: " unless $report_propagated++; + $paragraph .= "$s "; + } $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph)); $CPAN::Frontend->myprint("\n"); } else { @@ -4015,7 +5026,11 @@ sub get { shift->rematein('get',@_); } #-> sub CPAN::Bundle::make ; sub make { shift->rematein('make',@_); } #-> sub CPAN::Bundle::test ; -sub test { shift->rematein('test',@_); } +sub test { + my $self = shift; + $self->{badtestcnt} ||= 0; + $self->rematein('test',@_); +} #-> sub CPAN::Bundle::install ; sub install { my $self = shift; @@ -4024,6 +5039,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) = @_; @@ -4035,13 +5062,72 @@ No File found for bundle } . $self->id . qq{\n}), return; package CPAN::Module; +# Accessors +# sub cpan_userid { shift->{RO}{CPAN_USERID} } +sub userid { + my $self = shift; + return unless exists $self->{RO}; # should never happen + return $self->{RO}{CPAN_USERID} || $self->{RO}{userid}; +} +sub description { shift->{RO}{description} } + +sub undelay { + my $self = shift; + delete $self->{later}; + if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) { + $dist->undelay; + } +} + +#-> sub CPAN::Module::color_cmd_tmps ; +sub color_cmd_tmps { + my($self) = shift; + my($depth) = shift || 0; + my($color) = shift || 0; + # a module needs to recurse to its cpan_file + + return if exists $self->{incommandcolor} + && $self->{incommandcolor}==$color; + $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ". + "color_cmd_tmps depth[%s] self[%s] id[%s]", + $depth, + $self, + $self->id + )) if $depth>=100; + ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; + + if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) { + $dist->color_cmd_tmps($depth+1,$color); + } + if ($color==0) { + delete $self->{badtestcnt}; + } + $self->{incommandcolor} = $color; +} + #-> sub CPAN::Module::as_glimpse ; sub as_glimpse { my($self) = @_; 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; } @@ -4056,11 +5142,11 @@ sub as_string { local($^W) = 0; push @m, $class, " id = $self->{ID}\n"; my $sprintf = " %-12s %s\n"; - push @m, sprintf($sprintf, 'DESCRIPTION', $self->{description}) - if $self->{description}; + push @m, sprintf($sprintf, 'DESCRIPTION', $self->description) + if $self->description; my $sprintf2 = " %-12s %s (%s)\n"; my($userid); - if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){ + if ($userid = $self->cpan_userid || $self->userid){ my $author; if ($author = CPAN::Shell->expand('Author',$userid)) { my $email = ""; @@ -4076,10 +5162,10 @@ sub as_string { ); } } - push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION}) - if $self->{CPAN_VERSION}; - push @m, sprintf($sprintf, 'CPAN_FILE', $self->{CPAN_FILE}) - if $self->{CPAN_FILE}; + push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version) + if $self->cpan_version; + push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file) + if $self->cpan_file; my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n"; my(%statd,%stats,%statl,%stati); @statd{qw,? i c a b R M S,} = qw,unknown idea @@ -4096,24 +5182,68 @@ sub as_string { push @m, sprintf( $sprintf3, 'DSLI_STATUS', - $self->{statd}, - $self->{stats}, - $self->{statl}, - $self->{stati}, - $statd{$self->{statd}}, - $stats{$self->{stats}}, - $statl{$self->{statl}}, - $stati{$self->{stati}} - ) if $self->{statd}; + $self->{RO}{statd}, + $self->{RO}{stats}, + $self->{RO}{statl}, + $self->{RO}{stati}, + $statd{$self->{RO}{statd}}, + $stats{$self->{RO}{stats}}, + $statl{$self->{RO}{statl}}, + $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 CONTAINS/) { + for $item (qw/MANPAGE/) { push @m, sprintf($sprintf, $item, $self->{$item}) if exists $self->{$item}; } + for $item (qw/CONTAINS/) { + push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}})) + if exists $self->{$item} && @{$self->{$item}}; + } push @m, sprintf($sprintf, 'INST_FILE', $local_file || "(not installed)"); push @m, sprintf($sprintf, 'INST_VERSION', @@ -4124,7 +5254,7 @@ sub as_string { sub manpage_headline { my($self,$local_file) = @_; my(@local_file) = $local_file; - $local_file =~ s/\.pm\z/.pod/; + $local_file =~ s/\.pm(?!\n)\Z/.pod/; push @local_file, $local_file; my(@result,$locf); for $locf (@local_file) { @@ -4149,44 +5279,49 @@ sub manpage_headline { } #-> sub CPAN::Module::cpan_file ; -sub cpan_file { +# Note: also inherited by CPAN::Bundle +sub cpan_file { my $self = shift; - CPAN->debug($self->id) if $CPAN::DEBUG; - unless (defined $self->{'CPAN_FILE'}) { + CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG; + unless (defined $self->{RO}{CPAN_FILE}) { CPAN::Index->reload; } - if (exists $self->{'CPAN_FILE'} && defined $self->{'CPAN_FILE'}){ - return $self->{'CPAN_FILE'}; - } elsif (exists $self->{'userid'} && 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) { - return "Contact Author $self->{userid} (Try ``a $self->{userid}'')"; - } - return "Contact Author $fullname <$email>"; + if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){ + return $self->{RO}{CPAN_FILE}; } 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; - $self->{'CPAN_VERSION'} = 'undef' - unless defined $self->{'CPAN_VERSION'}; # I believe this is - # always a bug in the - # index and should be - # reported as such, - # but usually I find - # out such an error - # and do not want to - # provoke too many - # bugreports - $self->{'CPAN_VERSION'}; + + $self->{RO}{CPAN_VERSION} = 'undef' + unless defined $self->{RO}{CPAN_VERSION}; + # I believe this is always a bug in the index and should be reported + # as such, but usually I find out such an error and do not want to + # provoke too many bugreports + + $self->{RO}{CPAN_VERSION}; } #-> sub CPAN::Module::force ; @@ -4198,7 +5333,9 @@ sub force { #-> sub CPAN::Module::rematein ; sub rematein { my($self,$meth) = @_; - $self->debug($self->id) if $CPAN::DEBUG; + $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n", + $meth, + $self->id)); my $cpan_file = $self->cpan_file; if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){ $CPAN::Frontend->mywarn(sprintf qq{ @@ -4206,7 +5343,7 @@ sub rematein { Either the module has not yet been uploaded to CPAN, or it is temporary unavailable. Please contact the author to find out - more about the status. Try ``i %s''. + more about the status. Try 'i %s'. }, $self->id, $self->id, @@ -4215,8 +5352,9 @@ sub rematein { } my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); $pack->called_for($self->id); - $pack->force if exists $self->{'force_update'}; + $pack->force($meth) if exists $self->{'force_update'}; $pack->$meth(); + $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'}; delete $self->{'force_update'}; } @@ -4229,9 +5367,16 @@ sub cvs_import { shift->rematein('cvs_import') } #-> sub CPAN::Module::get ; sub get { shift->rematein('get',@_); } #-> sub CPAN::Module::make ; -sub make { shift->rematein('make') } +sub make { + my $self = shift; + $self->rematein('make'); +} #-> sub CPAN::Module::test ; -sub test { shift->rematein('test') } +sub test { + my $self = shift; + $self->{badtestcnt} ||= 0; + $self->rematein('test',@_); +} #-> sub CPAN::Module::uptodate ; sub uptodate { my($self) = @_; @@ -4245,9 +5390,11 @@ sub uptodate { local($^W)=0; if ($inst_file && - $have >= $latest + ! CPAN::Version->vgt($latest, $have) ) { - return 1; + CPAN->debug("returning uptodate. inst_file[$inst_file] ". + "latest[$latest] have[$have]") if $CPAN::DEBUG; + return 1; } return; } @@ -4304,14 +5451,49 @@ sub inst_version { my($self) = @_; my $parsefile = $self->inst_file or return; local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38; - # warn "HERE"; - my $have = MM->parse_version($parsefile) || "undef"; + my $have; + + # there was a bug in 5.6.0 that let lots of unini warnings out of + # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove + # the following workaround after 5.6.1 is out. + local($SIG{__WARN__}) = sub { my $w = shift; + return if $w =~ /uninitialized/i; + warn $w; + }; + + $have = MM->parse_version($parsefile) || "undef"; + $have =~ s/^ //; # since the %vd hack these two lines here are needed + $have =~ s/ $//; # trailing whitespace happens all the time + + # My thoughts about why %vd processing should happen here + + # Alt1 maintain it as string with leading v: + # read index files do nothing + # compare it use utility for compare + # print it do nothing + + # Alt2 maintain it as what is is + # read index files convert + # compare it use utility because there's still a ">" vs "gt" issue + # print it use CPAN::Version for print + + # Seems cleaner to hold it in memory as a string starting with a "v" + + # If the author of this module made a mistake and wrote a quoted + # "v1.13" instead of v1.13, we simply leave it at that with the + # effect that *we* will treat it like a v-tring while the rest of + # perl won't. Seems sensible when we consider that any action we + # could take now would just add complexity. + + $have = CPAN::Version->readable($have); + $have =~ s/\s*//g; # stringify to float around floating point issues - $have; + $have; # no stringify needed, \s* above matches always } package CPAN::Tarzip; +# CPAN::Tarzip::gzip sub gzip { my($class,$read,$write) = @_; if ($CPAN::META->has_inst("Compress::Zlib")) { @@ -4326,10 +5508,12 @@ sub gzip { $fhw->close; return 1; } else { - system("$CPAN::Config->{'gzip'} -c $read > $write")==0; + system("$CPAN::Config->{gzip} -c $read > $write")==0; } } + +# CPAN::Tarzip::gunzip sub gunzip { my($class,$read,$write) = @_; if ($CPAN::META->has_inst("Compress::Zlib")) { @@ -4346,26 +5530,43 @@ sub gunzip { $fhw->close; return 1; } else { - system("$CPAN::Config->{'gzip'} -dc $read > $write")==0; + system("$CPAN::Config->{gzip} -dc $read > $write")==0; } } + +# CPAN::Tarzip::gtest sub gtest { my($class,$read) = @_; - if ($CPAN::META->has_inst("Compress::Zlib")) { - my($buffer); + # After I had reread the documentation in zlib.h, I discovered that + # uncompressed files do not lead to an gzerror (anymore?). + if ( $CPAN::META->has_inst("Compress::Zlib") ) { + my($buffer,$len); + $len = 0; my $gz = Compress::Zlib::gzopen($read, "rb") - or $CPAN::Frontend->mydie("Cannot open $read: $!\n"); - 1 while $gz->gzread($buffer) > 0 ; - $CPAN::Frontend->mydie("Error reading from $read: $!\n") - if $gz->gzerror != Compress::Zlib::Z_STREAM_END(); - $gz->gzclose() ; - return 1; + or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n", + $read, + $Compress::Zlib::gzerrno)); + while ($gz->gzread($buffer) > 0 ){ + $len += length($buffer); + $buffer = ""; + } + my $err = $gz->gzerror; + my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END(); + if ($len == -s $read){ + $success = 0; + CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG; + } + $gz->gzclose(); + CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG; + return $success; } else { - return system("$CPAN::Config->{'gzip'} -dt $read")==0; + return system("$CPAN::Config->{gzip} -dt $read")==0; } } + +# CPAN::Tarzip::TIEHANDLE sub TIEHANDLE { my($class,$file) = @_; my $ret; @@ -4375,14 +5576,16 @@ sub TIEHANDLE { die "Could not gzopen $file"; $ret = bless {GZ => $gz}, $class; } else { - my $pipe = "$CPAN::Config->{'gzip'} --decompress --stdout $file |"; - my $fh = FileHandle->new($pipe) or die "Could pipe[$pipe]: $!"; + my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |"; + my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!"; binmode $fh; $ret = bless {FH => $fh}, $class; } $ret; } + +# CPAN::Tarzip::READLINE sub READLINE { my($self) = @_; if (exists $self->{GZ}) { @@ -4397,6 +5600,8 @@ sub READLINE { } } + +# CPAN::Tarzip::READ sub READ { my($self,$ref,$length,$offset) = @_; die "read with offset not implemented" if defined $offset; @@ -4410,69 +5615,231 @@ sub READ { } } + +# CPAN::Tarzip::DESTROY sub DESTROY { - my($self) = @_; - if (exists $self->{GZ}) { - my $gz = $self->{GZ}; - $gz->gzclose(); - } else { - my $fh = $self->{FH}; - $fh->close if defined $fh; - } - undef $self; + my($self) = @_; + if (exists $self->{GZ}) { + my $gz = $self->{GZ}; + $gz->gzclose() if defined $gz; # hard to say if it is allowed + # to be undef ever. AK, 2000-09 + } else { + my $fh = $self->{FH}; + $fh->close if defined $fh; + } + undef $self; } + +# CPAN::Tarzip::untar sub untar { my($class,$file) = @_; - # had to disable, because version 0.07 seems to be buggy - if (MM->maybe_command($CPAN::Config->{'gzip'}) - && - MM->maybe_command($CPAN::Config->{'tar'})) { - my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " . - "< $file | $CPAN::Config->{tar} xvf -"; + 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'})) { + # 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) { + $system = "$CPAN::Config->{gzip} --decompress --stdout " . + "< $file | $CPAN::Config->{tar} xvf -"; + } else { + $system = "$CPAN::Config->{tar} xvf $file"; + } if (system($system) != 0) { - # people find the most curious tar binaries that cannot handle - # pipes - my $system = "$CPAN::Config->{'gzip'} --decompress $file"; - if (system($system)==0) { - $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n}); - } else { - $CPAN::Frontend->mydie( - qq{Couldn\'t uncompress $file\n} - ); - } - $file =~ s/\.gz\z//; - $system = "$CPAN::Config->{tar} xvf $file"; - $CPAN::Frontend->myprint(qq{Using Tar:$system:\n}); - if (system($system)==0) { - $CPAN::Frontend->myprint(qq{Untarred $file successfully\n}); - } else { - $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n}); - } - return 1; + # people find the most curious tar binaries that cannot handle + # pipes + if ($is_compressed) { + (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//; + if (CPAN::Tarzip->gunzip($file, $ungzf)) { + $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n}); + } else { + $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n}); + } + $file = $ungzf; + } + $system = "$CPAN::Config->{tar} xvf $file"; + $CPAN::Frontend->myprint(qq{Using Tar:$system:\n}); + if (system($system)==0) { + $CPAN::Frontend->myprint(qq{Untarred $file successfully\n}); + } else { + $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n}); + } + return 1; } else { - return 1; + 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); - $tar->extract($tar->list_files); # I'm pretty sure we have nothing - # that isn't compressed + my $af; # archive file + my @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; + } + } 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); + } 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. -}); } } +sub unzip { + my($class,$file) = @_; + if ($CPAN::META->has_inst("Archive::Zip")) { + # blueprint of the code from Archive::Zip::Tree::extractTree(); + my $zip = Archive::Zip->new(); + my $status; + $status = $zip->read($file); + die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK(); + $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG; + my @members = $zip->members(); + for my $member ( @members ) { + my $af = $member->fileName(); + if ($af =~ m!^(/|\.\./)!) { + $CPAN::Frontend->mydie("ALERT: Archive contains ". + "illegal member [$af]"); + } + my $status = $member->extractToFileNamed( $af ); + $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG; + die "Extracting of file[$af] from zipfile[$file] failed\n" if + $status != Archive::Zip::AZ_OK(); + return if $CPAN::Signal; + } + return 1; + } else { + my $unzip = $CPAN::Config->{unzip} or + $CPAN::Frontend->mydie("Cannot unzip, no unzip program available"); + my @system = ($unzip, $file); + return system(@system) == 0; + } +} + + +package CPAN::Version; +# CPAN::Version::vcmp courtesy Jost Krieger +sub vcmp { + my($self,$l,$r) = @_; + local($^W) = 0; + CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG; + + return 0 if $l eq $r; # short circuit for quicker success + + if ($l=~/^v/ <=> $r=~/^v/) { + for ($l,$r) { + next if /^v/; + $_ = $self->float2vv($_); + } + } + + return + ($l ne "undef") <=> ($r ne "undef") || + ($] >= 5.006 && + $l =~ /^v/ && + $r =~ /^v/ && + $self->vstring($l) cmp $self->vstring($r)) || + $l <=> $r || + $l cmp $r; +} + +sub vgt { + my($self,$l,$r) = @_; + $self->vcmp($l,$r) > 0; +} + +sub vstring { + my($self,$n) = @_; + $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]"; + pack "U*", split /\./, $n; +} + +# vv => visible vstring +sub float2vv { + my($self,$n) = @_; + my($rev) = int($n); + $rev ||= 0; + 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; + while ($mantissa) { + $mantissa =~ s/(\d{1,3})// or + die "Panic: length>0 but not a digit? mantissa[$mantissa]"; + $ret .= ".".int($1); + } + # warn "n[$n]ret[$ret]"; + $ret; +} + +sub readable { + my($self,$n) = @_; + $n =~ /^([\w\-\+\.]+)/; + + return $1 if defined $1 && length($1)>0; + # if the first user reaches version v43, he will be treated as "+". + # We'll have to decide about a new rule here then, depending on what + # will be the prevailing versioning behavior then. + + if ($] < 5.006) { # or whenever v-strings were introduced + # we get them wrong anyway, whatever we do, because 5.005 will + # have already interpreted 0.2.4 to be "0.24". So even if he + # indexer sends us something like "v0.2.4" we compare wrongly. + + # And if they say v1.2, then the old perl takes it as "v12" + + $CPAN::Frontend->mywarn("Suspicious version string seen [$n]"); + return $n; + } + my $better = sprintf "v%vd", $n; + CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG; + return $better; +} + package CPAN; 1; @@ -4518,11 +5885,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<CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine that indexes -all documents available in CPAN authors directories. If C<CPAN::WAIT> -is installed on your system, the interactive shell of <CPAN.pm> will -enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands which send -queries to the WAIT server that has been configured for your +L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine +that indexes all documents available in CPAN authors directories. If +C<CPAN::WAIT> is installed on your system, the interactive shell of +CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> 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 @@ -4541,6 +5908,10 @@ command completion. Once you are on the command line, type 'h' and the rest should be self-explanatory. +The function call C<shell> 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 @@ -4584,10 +5955,10 @@ also is run unconditionally. But for CPAN checks if an install is actually needed for it and prints I<module up to date> in the case that the distribution file containing -the module doesnE<39>t need to be updated. +the module doesn't need to be updated. CPAN also keeps track of what it has done within the current session -and doesnE<39>t try to build a package a second time regardless if it +and doesn't try to build a package a second time regardless if it succeeded or not. The C<force> command takes as a first argument the method to invoke (currently: C<make>, C<test>, or C<install>) and executes the command from scratch. @@ -4615,6 +5986,13 @@ displays the README file of the associated distribution. C<Look> gets and untars (if not yet done) the distribution file, changes to the appropriate directory and opens a subshell process in that directory. +=item ls author + +C<ls> lists all distribution files in and below an author's CPAN +directory. Only those files that contain modules are listed and if +there is more than one for any given module, only the most recent one +is listed. + =item Signals CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are @@ -4659,7 +6037,7 @@ installation. You start on one architecture with the help of a Bundle file produced earlier. CPAN installs the whole Bundle for you, but when you try to repeat the job on the second architecture, CPAN responds with a C<"Foo up to date"> message for all modules. So you -invoke CPAN's recompile on the second architecture and youE<39>re done. +invoke CPAN's recompile on the second architecture and you're done. Another popular use for C<recompile> is to act as a rescue in case your perl breaks binary compatibility. If one of the modules that CPAN uses @@ -4704,7 +6082,7 @@ so you would have to say The first example will be driven by an object of the class CPAN::Module, the second by an object of class CPAN::Distribution. -=head2 ProgrammerE<39>s interface +=head2 Programmer's interface If you do not enter the shell, the available shell commands are both available as methods (C<CPAN::Shell-E<gt>install(...)>) and as @@ -4727,6 +6105,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 @@ -4749,18 +6133,21 @@ functionalities that are available in the shell. print "No VERSION in ", $mod->id, "\n"; } + # find out which distribution on CPAN contains a module: + print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file + Or if you want to write a cronjob to watch The CPAN, you could list -all modules that need updating: +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","/./")){ @@ -4786,7 +6173,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<clean> 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<force> is passed recursively to +all contained objects. + +=item CPAN::Bundle::get() + +Recursively runs the C<get> 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<install> method on all items contained in the bundle + +=item CPAN::Bundle::make() + +Recursively runs the C<make> method on all items contained in the bundle + +=item CPAN::Bundle::readme() + +Recursively runs the C<readme> method on all items contained in the bundle + +=item CPAN::Bundle::test() + +Recursively runs the C<test> 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<make clean> 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<make install> there. If C<make> has not +yet been run, it will be run first. A C<make test> will be issued in +any case and if this fails, the install will be cancelled. The +cancellation can be avoided by letting C<force> run the C<install> 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<get> 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<perl +Makefile.PL> and C<make> 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<make> 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<make test> 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<install> 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<make> 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<readme> on the distribution associated with this module. + +=item CPAN::Module::test() + +Runs a C<test> 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 @@ -4880,17 +6559,18 @@ enthusiasm). =head2 Debugging -The debugging of this module is pretty difficult, because we have +The debugging of this module is a bit complex, because we have interferences of the software producing the indices on CPAN, of the mirroring process on CPAN, of packaging, of configuration, of synchronicity, and of bugs within CPAN.pm. -In interactive mode you can try "o debug" which will list options for -debugging the various parts of the package. The output may not be very -useful for you as it's just a by-product of my own testing, but if you -have an idea which part of the package may have a bug, it's sometimes -worth to give it a try and send me more specific output. You should -know that "o debug" has built-in completion support. +For code debugging in interactive mode you can try "o debug" which +will list options for debugging the various parts of the code. You +should know that "o debug" has built-in completion support. + +For data debugging there is the C<dump> command which takes the same +arguments as make/test/install and outputs the object's Data::Dumper +dump. =head2 Floppy, Zip, Offline Mode @@ -4918,7 +6598,10 @@ defined: build_cache size of cache for directories to build modules build_dir locally accessible directory to build modules index_expire after this many days refetch index files + cache_metadata use serializer to cache metadata cpan_home local directory reserved for this package + dontload_hash anonymous hash: modules in the keys will not be + loaded by the CPAN::has_inst() routine gzip location of external program gzip inactivity_timeout breaks interactive Makefile.PLs after this many seconds inactivity. Set to 0 to never break. @@ -4933,8 +6616,12 @@ defined: prerequisites_policy what to do if you are missing module prerequisites ('follow' automatically, 'ask' me, or 'ignore') + proxy_user username for accessing an authenticating proxy + proxy_pass password for accessing an authenticating proxy 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) @@ -4973,7 +6660,8 @@ works like the corresponding perl commands. =head2 Note on urllist parameter's format urllist parameters are URLs according to RFC 1738. We do a little -guessing if your URL is not compliant, but if you have problems with file URLs, please try the correct format. Either: +guessing if your URL is not compliant, but if you have problems with +file URLs, please try the correct format. Either: file://localhost/whatever/ftp/pub/CPAN/ @@ -5021,8 +6709,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 @@ -5034,7 +6722,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 @@ -5043,12 +6731,18 @@ 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 Thanks to Graham Barr for contributing the following paragraphs about -the interaction between perl, and various firewall configurations. +the interaction between perl, and various firewall configurations. For +further informations on firewalls, it is recommended to consult the +documentation that comes with the ncftp program. If you are unable to +go through the firewall with a simple Perl setup, it is very likely +that you can configure ncftp so that it works for your firewall. + +=head2 Three basic types of firewalls Firewalls can be categorized into three basic types. @@ -5091,7 +6785,7 @@ There are two that I can think off. =item SOCKS If you are using a SOCKS firewall you will need to compile perl and link -it with the SOCKS library, this is what is normally called a ``socksified'' +it with the SOCKS library, this is what is normally called a 'socksified' perl. With this executable you will be able to connect to servers outside the firewall as if it is not there. @@ -5099,18 +6793,179 @@ 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 =back +=head2 Configuring lynx or ncftp for going through a firewall + +If you can go through your firewall with e.g. lynx, presumably with a +command such as + + /usr/local/bin/lynx -pscott:tiger + +then you would configure CPAN.pm with the command + + o conf lynx "/usr/local/bin/lynx -pscott:tiger" + +That's all. Similarly for ncftp or ftp, you would configure something +like + + o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg" + +Your milage may vary... + +=head1 FAQ + +=over + +=item 1) + +I installed a new version of module X but CPAN keeps saying, +I have the old version installed + +Most probably you B<do> have the old version installed. This can +happen if a module installs itself into a different directory in the +@INC path than it was previously installed. This is not really a +CPAN.pm problem, you would have the same problem when installing the +module manually. The easiest way to prevent this behaviour is to add +the argument C<UNINST=1> to the C<make install> call, and that is why +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? + +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<UNINST=1> can cause damage. + +=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 + + o conf make_arg "| tee -ai /root/.cpan/logs/make.out" + o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out" + +so that STDOUT is captured in a file for later inspection. + + +=item 5) + +I am not root, how can I install a module in a personal directory? + +You will most probably like something like this: + + o conf makepl_arg "LIB=~/myperl/lib \ + INSTALLMAN1DIR=~/myperl/man/man1 \ + INSTALLMAN3DIR=~/myperl/man/man3" + install Sybase::Sybperl + +You can make this setting permanent like all C<o conf> settings with +C<o conf commit>. + +You will have to add ~/myperl/man to the MANPATH environment variable +and also tell your perl programs to look into ~/myperl/lib, e.g. by +including + + use lib "$ENV{HOME}/myperl/lib"; + +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 6) + +How to get a package, unwrap it, and make a change before building it? + + look Sybase::Sybperl + +=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 +install, it just uses data found in the generated Makefile. An +undetected missing piece breaks the process. But it may well be that +your Bundle installs some prerequisite later than some depending item +and thus your second try is able to resolve everything. Please note, +CPAN.pm does not know the dependency tree in advance and cannot sort +the queue of things to install in a topologically correct order. It +resolves perfectly well IFF all modules declare the prerequisites +correctly with the PREREQ_PM attribute to MakeMaker. For bundles which +fail and you need to install often, it is recommended sort the Bundle +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 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<on> in lowercase. Change the +occurrences of C<on> to C<On> 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 We should give coverage for B<all> of the CPAN and not just the PAUSE part, right? In this discussion CPAN and PAUSE have become equal -- -but they are not. PAUSE is authors/ and modules/. CPAN is PAUSE plus -the clpa/, doc/, misc/, ports/, src/, scripts/. +but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is +PAUSE plus the clpa/, doc/, misc/, ports/, and src/. Future development should be directed towards a better integration of the other parts. @@ -5124,6 +6979,11 @@ traditional method of building a Perl module package from a shell. Andreas Koenig E<lt>andreas.koenig@anima.deE<gt> +=head1 TRANSLATIONS + +Kawai,Takanori provides a Japanese translation of this manpage at +http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm + =head1 SEE ALSO perl(1), CPAN::Nox(3) diff --git a/contrib/perl5/lib/CPAN/FirstTime.pm b/contrib/perl5/lib/CPAN/FirstTime.pm index 0e795da4fb0a..0429db15270f 100644 --- a/contrib/perl5/lib/CPAN/FirstTime.pm +++ b/contrib/perl5/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.38 $, 10; +$VERSION = substr q$Revision: 1.53 $, 10; =head1 NAME @@ -149,7 +150,7 @@ next question. print qq{ How big should the disk cache be for keeping the build directories -with all the intermediate files? +with all the intermediate files\? }; @@ -175,6 +176,47 @@ disable the cache scanning with 'never'. $CPAN::Config->{scan_cache} = $ans; # + # cache_metadata + # + print qq{ + +To considerably speed up the initial CPAN shell startup, it is +possible to use Storable to create a cache of metadata. If Storable +is not available, the normal index mechanism will be used. + +}; + + defined($default = $CPAN::Config->{cache_metadata}) or $default = 1; + do { + $ans = prompt("Cache metadata (yes/no)?", ($default ? 'yes' : 'no')); + } while ($ans !~ /^\s*[yn]/i); + $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, names +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? # @@ -188,7 +230,7 @@ policy to one of the three values. }; - $default = $CPAN::Config->{prerequisites_policy} || 'follow'; + $default = $CPAN::Config->{prerequisites_policy} || 'ask'; do { $ans = prompt("Policy on building prerequisites (follow, ask or ignore)?", @@ -202,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. }; @@ -214,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; @@ -272,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. @@ -282,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 @@ -325,6 +384,44 @@ the \$CPAN::Config takes precedence. $CPAN::Config->{$_} = prompt("Your $_?",$default); } + if ($CPAN::Config->{ftp_proxy} || + $CPAN::Config->{http_proxy}) { + $default = $CPAN::Config->{proxy_user} || $CPAN::LWP::UserAgent::USER; + print qq{ + +If your proxy is an authenticating proxy, you can store your username +permanently. If you do not want that, just press RETURN. You will then +be asked for your username in every future session. + +}; + if ($CPAN::Config->{proxy_user} = prompt("Your proxy user id?",$default)) { + print qq{ + +Your password for the authenticating proxy can also be stored +permanently on disk. If this violates your security policy, just press +RETURN. You will then be asked for the password in every future +session. + +}; + + if ($CPAN::META->has_inst("Term::ReadKey")) { + Term::ReadKey::ReadMode("noecho"); + } else { + print qq{ + +Warning: Term::ReadKey seems not to be available, your password will +be echoed to the terminal! + +}; + } + $CPAN::Config->{proxy_pass} = prompt("Your proxy password?"); + if ($CPAN::META->has_inst("Term::ReadKey")) { + Term::ReadKey::ReadMode("restore"); + } + $CPAN::Frontend->myprint("\n\n"); + } + } + # # MIRRORED.BY # @@ -361,8 +458,27 @@ sub conf_sites { File::Copy::copy($m,$mby) or die "Could not update $mby: $!"; } my $loopcount = 0; - while () { - if ( ! -f $mby ){ + 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 ($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 }; @@ -383,6 +499,7 @@ sub conf_sites { } } read_mirrored_by($mby); + bring_your_own(); } sub find_exe { @@ -424,7 +541,7 @@ sub picklist { } sub read_mirrored_by { - my($local) = @_; + my $local = shift or return; my(%all,$url,$expected_size,$default,$ans,$host,$dst,$country,$continent,@location); my $fh = FileHandle->new; $fh->open($local) or die "Couldn't open $local: $!"; @@ -503,7 +620,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)); @@ -512,25 +630,37 @@ http: -- that host a CPAN mirror. @urls = picklist (\@urls, $prompt, $default); foreach (@urls) { s/ \(.*\)//; } - %seen = map (($_ => 1), @urls); + push @{$CPAN::Config->{urllist}}, @urls; +} +sub bring_your_own { + my %seen = map (($_ => 1), @{$CPAN::Config->{urllist}}); + my($ans,@urls); do { - $ans = prompt ("Enter another URL or RETURN to quit:", ""); + my $prompt = "Enter another URL or RETURN to quit:"; + unless (%seen) { + $prompt = qq{CPAN.pm needs at least one URL where it can fetch CPAN files from. + +Please enter your CPAN site:}; + } + $ans = prompt ($prompt, ""); if ($ans) { - $ans =~ s|/?$|/|; # has to end with one slash + $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}; - } - 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}; + push @urls, $ans unless $seen{$ans}++; + } else { + 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; + } while $ans || !%seen; push @{$CPAN::Config->{urllist}}, @urls; # xxx delete or comment these out when you're happy that it works diff --git a/contrib/perl5/lib/Carp/Heavy.pm b/contrib/perl5/lib/Carp/Heavy.pm index 5e3de49418b2..4d12bd79106c 100644 --- a/contrib/perl5/lib/Carp/Heavy.pm +++ b/contrib/perl5/lib/Carp/Heavy.pm @@ -42,7 +42,7 @@ sub longmess_heavy { # # 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 + # 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 @@ -121,10 +121,7 @@ sub longmess_heavy { # $line" makes sense as "called at $file line $line". $error = "called"; } - # this kludge circumvents die's incorrect handling of NUL - my $msg = \($mess || $error); - $$msg =~ tr/\0//d; - $$msg; + $mess || $error; } @@ -227,17 +224,14 @@ CALLER: } else { # OK! We've got a candidate package. Time to construct the - # relevant error message and return it. die() doesn't like - # to be given NUL characters (which $msg may contain) so we - # remove them first. + # 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 .= " thread $tid" if $tid; } $msg .= "\n"; - $msg =~ tr/\0//d; return $msg; } } diff --git a/contrib/perl5/lib/Class/Struct.pm b/contrib/perl5/lib/Class/Struct.pm index 63eddac7393b..185a8ff142c0 100644 --- a/contrib/perl5/lib/Class/Struct.pm +++ b/contrib/perl5/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. @@ -168,8 +183,7 @@ sub struct { $cnt = 0; foreach $name (@methods){ if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) { - warnings::warn "function '$name' already defined, overrides struct accessor method" - if warnings::enabled(); + warnings::warnif("function '$name' already defined, overrides struct accessor method"); } else { $pre = $pst = $cmt = $sel = ''; @@ -243,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; @@ -263,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<Class::Struct> exports a single function, C<struct>. @@ -288,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<struct()> function The C<struct> function has three forms of parameter-list. @@ -327,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<Class::Struct> 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 @@ -411,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 @@ -445,7 +468,6 @@ type C<timeval>. $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 @@ -493,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 => @@ -525,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. @@ -542,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<Class::Struct> and modified by Jim Miner, 1997-04-02. members() function removed. @@ -554,7 +577,6 @@ Renamed to C<Class::Struct> and modified by Jim Miner, 1997-04-02. Class name to struct() made optional. Diagnostic checks added. - Originally C<Class::Template> by Dean Roehrich. # Template.pm --- struct/member template builder diff --git a/contrib/perl5/lib/Cwd.pm b/contrib/perl5/lib/Cwd.pm index 9a92829da5e4..9c7b33d9fc2e 100644 --- a/contrib/perl5/lib/Cwd.pm +++ b/contrib/perl5/lib/Cwd.pm @@ -3,7 +3,7 @@ require 5.000; =head1 NAME -getcwd - get pathname of current working directory +Cwd - get pathname of current working directory =head1 SYNOPSIS @@ -14,6 +14,9 @@ getcwd - get pathname of current working directory $dir = getcwd; use Cwd; + $dir = fastcwd; + + use Cwd; $dir = fastgetcwd; use Cwd 'chdir'; @@ -28,16 +31,21 @@ getcwd - get pathname of current working directory =head1 DESCRIPTION +This module provides functions for determining the pathname of the +current working directory. By default, it exports the functions +cwd(), getcwd(), fastcwd(), and fastgetcwd() into the caller's +namespace. Each of these functions are called without arguments and +return the absolute path of the current working directory. It is +recommended that cwd (or another *cwd() function) be used in I<all> +code to ensure portability. + +The cwd() is the most natural and safe form for the current +architecture. For most systems it is identical to `pwd` (but without +the trailing line terminator). + The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions in Perl. -The abs_path() function takes a single argument and returns the -absolute pathname for that argument. It uses the same algorithm -as getcwd(). (Actually, getcwd() is abs_path(".")) Symbolic links -and relative-path components ("." and "..") are resolved to return -the canonical pathname, just like realpath(3). Also callable as -realpath(). - The fastcwd() function looks the same as getcwd(), but runs faster. It's also more dangerous because it might conceivably chdir() you out of a directory that it can't chdir() you back into. If fastcwd @@ -48,16 +56,17 @@ that it leaves you in the same directory that it started in. If it has changed it will C<die> with the message "Unstable directory path, current directory changed unexpectedly". That should never happen. -The fast_abs_path() function looks the same as abs_path(), but runs faster. -And like fastcwd() is more dangerous. +The fastgetcwd() function is provided as a synonym for cwd(). -The cwd() function looks the same as getcwd and fastgetcwd but is -implemented using the most natural and safe form for the current -architecture. For most systems it is identical to `pwd` (but without -the trailing line terminator). +The abs_path() function takes a single argument and returns the +absolute pathname for that argument. It uses the same algorithm as +getcwd(). (Actually, getcwd() is abs_path(".")) Symbolic links and +relative-path components ("." and "..") are resolved to return the +canonical pathname, just like realpath(3). This function is also +callable as realpath(). -It is recommended that cwd (or another *cwd() function) is used in -I<all> code to ensure portability. +The fast_abs_path() function looks the same as abs_path() but runs +faster and, like fastcwd(), is more dangerous. If you ask to override your chdir() built-in function, then your PWD environment variable will be kept up to date. (See @@ -66,31 +75,42 @@ kept up to date if all packages which use chdir import it from Cwd. =cut -## use strict; +use strict; use Carp; -$VERSION = '2.02'; +our $VERSION = '2.04'; -require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(cwd getcwd fastcwd fastgetcwd); -@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); +use base qw/ Exporter /; +our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); +our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); # The 'natural and safe form' for UNIX (pwd may be setuid root) sub _backtick_pwd { - my $cwd; - chop($cwd = `pwd`); + my $cwd = `pwd`; + # `pwd` may fail e.g. if the disk is full + chomp($cwd) if defined $cwd; $cwd; } # Since some ports may predefine cwd internally (e.g., NT) # we take care not to override an existing definition for cwd(). -*cwd = \&_backtick_pwd unless defined &cwd; +unless(defined &cwd) { + # The pwd command is not available in some chroot(2)'ed environments + if($^O eq 'MacOS' || grep { -x "$_/pwd" } split(':', $ENV{PATH})) { + *cwd = \&_backtick_pwd; + } + else { + *cwd = \&getcwd; + } +} +# set a reasonable (and very safe) default for fastgetcwd, in case it +# isn't redefined later (20001212 rspier) +*fastgetcwd = \&cwd; # By Brandon S. Allbery # @@ -156,7 +176,7 @@ sub fastcwd { my $chdir_init = 0; sub chdir_init { - if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos') { + if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') { my($dd,$di) = stat('.'); my($pd,$pi) = stat($ENV{'PWD'}); if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { @@ -164,10 +184,12 @@ sub chdir_init { } } else { - $ENV{'PWD'} = cwd(); + my $wd = cwd(); + $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32'; + $ENV{'PWD'} = $wd; } # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar) - if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) { + if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) { my($pd,$pi) = stat($2); my($dd,$di) = stat($1); if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { @@ -178,11 +200,27 @@ sub chdir_init { } sub chdir { - my $newdir = shift || ''; # allow for no arg (chdir to HOME dir) - $newdir =~ s|///*|/|g; + my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir) + $newdir =~ s|///*|/|g unless $^O eq 'MSWin32'; chdir_init() unless $chdir_init; + my $newpwd; + if ($^O eq 'MSWin32') { + # get the full path name *before* the chdir() + $newpwd = Win32::GetFullPathName($newdir); + } + return 0 unless CORE::chdir $newdir; - if ($^O eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} } + + if ($^O eq 'VMS') { + return $ENV{'PWD'} = $ENV{'DEFAULT'} + } + elsif ($^O eq 'MacOS') { + return $ENV{'PWD'} = cwd(); + } + elsif ($^O eq 'MSWin32') { + $ENV{'PWD'} = $newpwd; + return 1; + } if ($newdir =~ m#^/#s) { $ENV{'PWD'} = $newdir; @@ -263,7 +301,7 @@ sub abs_path sub fast_abs_path { my $cwd = getcwd(); - my $path = shift || '.'; + my $path = @_ ? shift : '.'; CORE::chdir($path) || croak "Cannot chdir to $path:$!"; my $realpath = getcwd(); CORE::chdir($cwd) || croak "Cannot chdir back to $cwd:$!"; @@ -332,12 +370,17 @@ sub _qnx_cwd { } sub _qnx_abs_path { - my $path = shift || '.'; + my $path = @_ ? shift : '.'; my $realpath=`/usr/bin/fullpath -t $path`; chop $realpath; return $realpath; } +sub _epoc_cwd { + $ENV{'PWD'} = EPOC::getcwd(); + return $ENV{'PWD'}; +} + { no warnings; # assignments trigger 'subroutine redefined' warning @@ -386,6 +429,19 @@ sub _qnx_abs_path { *fastcwd = \&cwd; *abs_path = \&fast_abs_path; } + elsif ($^O eq 'epoc') { + *cwd = \&_epoc_cwd; + *getcwd = \&_epoc_cwd; + *fastgetcwd = \&_epoc_cwd; + *fastcwd = \&_epoc_cwd; + *abs_path = \&fast_abs_path; + } + elsif ($^O eq 'MacOS') { + *getcwd = \&cwd; + *fastgetcwd = \&cwd; + *fastcwd = \&cwd; + *abs_path = \&fast_abs_path; + } } # package main; eval join('',<DATA>) || die $@; # quick test diff --git a/contrib/perl5/lib/English.pm b/contrib/perl5/lib/English.pm index f6e3ec00215c..f38c313bebe2 100644 --- a/contrib/perl5/lib/English.pm +++ b/contrib/perl5/lib/English.pm @@ -98,6 +98,8 @@ sub import { *OSNAME *LAST_REGEXP_CODE_RESULT *EXCEPTIONS_BEING_CAUGHT + @LAST_MATCH_START + @LAST_MATCH_END ); # The ground of all being. @ARG is deprecated (5.005 makes @_ lexical) @@ -110,6 +112,8 @@ sub import { *PREMATCH = *` ; *POSTMATCH = *' ; *LAST_PAREN_MATCH = *+ ; + *LAST_MATCH_START = *-{ARRAY} ; + *LAST_MATCH_END = *+{ARRAY} ; # Input. diff --git a/contrib/perl5/lib/ExtUtils/Command.pm b/contrib/perl5/lib/ExtUtils/Command.pm index bccc76cc199d..aec4013d022a 100644 --- a/contrib/perl5/lib/ExtUtils/Command.pm +++ b/contrib/perl5/lib/ExtUtils/Command.pm @@ -177,7 +177,7 @@ Creates directory, including any parent directories. sub mkpath { - File::Path::mkpath([expand_wildcards()],1,0777); + File::Path::mkpath([expand_wildcards()],0,0777); } =item test_f file diff --git a/contrib/perl5/lib/ExtUtils/Embed.pm b/contrib/perl5/lib/ExtUtils/Embed.pm index b649b6b77b6d..98c24ac1cf25 100644 --- a/contrib/perl5/lib/ExtUtils/Embed.pm +++ b/contrib/perl5/lib/ExtUtils/Embed.pm @@ -6,6 +6,7 @@ require Exporter; require FileHandle; use Config; use Getopt::Std; +use File::Spec; #Only when we need them #require ExtUtils::MakeMaker; @@ -86,33 +87,8 @@ sub xsinit { sub xsi_header { return <<EOF; -#if defined(__cplusplus) && !defined(PERL_OBJECT) -#define is_cplusplus -#endif - -#ifdef is_cplusplus -extern "C" { -#endif - #include <EXTERN.h> #include <perl.h> -#ifdef PERL_OBJECT -#define NO_XSLOCKS -#include <XSUB.h> -#include "win32iop.h" -#include <fcntl.h> -#include <perlhost.h> -#endif -#ifdef is_cplusplus -} -# ifndef EXTERN_C -# define EXTERN_C extern "C" -# endif -#else -# ifndef EXTERN_C -# define EXTERN_C extern -# endif -#endif EOF } @@ -190,10 +166,14 @@ sub ldopts { } } $std = 1 unless scalar @link_args; - @path = $path ? split(/:/, $path) : @INC; + my $sep = $Config{path_sep} || ':'; + @path = $path ? split(/\Q$sep/, $path) : @INC; push(@potential_libs, @link_args) if scalar @link_args; - push(@potential_libs, $Config{libs}) if defined $std; + # makemaker includes std libs on windows by default + if ($^O ne 'MSWin32' and defined($std)) { + push(@potential_libs, $Config{perllibs}); + } push(@mods, static_ext()) if $std; @@ -223,12 +203,18 @@ sub ldopts { } #print STDERR "\@potential_libs = @potential_libs\n"; - my $libperl = (grep(/^-l\w*perl\w*$/, @link_args))[0] || "-lperl"; + my $libperl; + if ($^O eq 'MSWin32') { + $libperl = $Config{libperl}; + } + else { + $libperl = (grep(/^-l\w*perl\w*$/, @link_args))[0] || "-lperl"; + } + my $lpath = File::Spec->catdir($Config{archlibexp}, 'CORE'); + $lpath = qq["$lpath"] if $^O eq 'MSWin32'; my($extralibs, $bsloadlibs, $ldloadlibs, $ld_run_path) = - $MM->ext(join ' ', - $MM->catdir("-L$Config{archlibexp}", "CORE"), " $libperl", - @potential_libs); + $MM->ext(join ' ', "-L$lpath", $libperl, @potential_libs); my $ld_or_bs = $bsloadlibs || $ldloadlibs; print STDERR "bs: $bsloadlibs ** ld: $ldloadlibs" if $Verbose; @@ -248,7 +234,9 @@ sub ccdlflags { } sub perl_inc { - my_return(" -I$Config{archlibexp}/CORE "); + my $dir = File::Spec->catdir($Config{archlibexp}, 'CORE'); + $dir = qq["$dir"] if $^O eq 'MSWin32'; + my_return(" -I$dir "); } sub ccopts { @@ -277,6 +265,7 @@ ExtUtils::Embed - Utilities for embedding Perl in C/C++ applications perl -MExtUtils::Embed -e xsinit + perl -MExtUtils::Embed -e ccopts perl -MExtUtils::Embed -e ldopts =head1 DESCRIPTION @@ -484,7 +473,7 @@ B<xsinit()> uses the xsi_* functions to generate most of it's code. =head1 EXAMPLES For examples on how to use B<ExtUtils::Embed> for building C/C++ applications -with embedded perl, see the eg/ directory and L<perlembed>. +with embedded perl, see L<perlembed>. =head1 SEE ALSO diff --git a/contrib/perl5/lib/ExtUtils/Install.pm b/contrib/perl5/lib/ExtUtils/Install.pm index 36c72219a94f..c496aa0ae500 100644 --- a/contrib/perl5/lib/ExtUtils/Install.pm +++ b/contrib/perl5/lib/ExtUtils/Install.pm @@ -16,6 +16,28 @@ my $splitchar = $^O eq 'VMS' ? '|' : ($^O eq 'os2' || $^O eq 'dos') ? ';' : ':'; my @PERL_ENV_LIB = split $splitchar, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || ''; my $Inc_uninstall_warn_handler; +# install relative to here + +my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT}; + +use File::Spec; + +sub install_rooted_file { + if (defined $INSTALL_ROOT) { + MY->catfile($INSTALL_ROOT, $_[0]); + } else { + $_[0]; + } +} + +sub install_rooted_dir { + if (defined $INSTALL_ROOT) { + MY->catdir($INSTALL_ROOT, $_[0]); + } else { + $_[0]; + } +} + #our(@EXPORT, @ISA, $Is_VMS); #use strict; @@ -55,8 +77,9 @@ sub install { opendir DIR, $source_dir_or_file or next; for (readdir DIR) { next if $_ eq "." || $_ eq ".." || $_ eq ".exists"; - if (-w $hash{$source_dir_or_file} || - mkpath($hash{$source_dir_or_file})) { + my $targetdir = install_rooted_dir($hash{$source_dir_or_file}); + if (-w $targetdir || + mkpath($targetdir)) { last; } else { warn "Warning: You do not have permissions to " . @@ -66,7 +89,8 @@ sub install { } closedir DIR; } - $packlist->read($pack{"read"}) if (-f $pack{"read"}); + my $tmpfile = install_rooted_file($pack{"read"}); + $packlist->read($tmpfile) if (-f $tmpfile); my $cwd = cwd(); my($source); @@ -80,11 +104,13 @@ sub install { #October 1997: we want to install .pm files into archlib if #there are any files in arch. So we depend on having ./blib/arch #hardcoded here. - my $targetroot = $hash{$source}; + + my $targetroot = install_rooted_dir($hash{$source}); + if ($source eq "blib/lib" and exists $hash{"blib/arch"} and directory_not_empty("blib/arch")) { - $targetroot = $hash{"blib/arch"}; + $targetroot = install_rooted_dir($hash{"blib/arch"}); print "Files found in blib/arch: installing files in blib/lib into architecture dependent library tree\n"; } chdir($source) or next; @@ -93,8 +119,9 @@ sub install { $atime,$mtime,$ctime,$blksize,$blocks) = stat; return unless -f _; return if $_ eq ".exists"; - my $targetdir = MY->catdir($targetroot,$File::Find::dir); - my $targetfile = MY->catfile($targetdir,$_); + my $targetdir = MY->catdir($targetroot, $File::Find::dir); + my $origfile = $_; + my $targetfile = MY->catfile($targetdir, $_); my $diff = 0; if ( -f $targetfile && -s _ == $size) { @@ -129,16 +156,16 @@ sub install { } else { inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0 } - $packlist->{$targetfile}++; + $packlist->{$origfile}++; }, "."); chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!"); } if ($pack{'write'}) { - $dir = dirname($pack{'write'}); + $dir = install_rooted_dir(dirname($pack{'write'})); mkpath($dir,0,0755); print "Writing $pack{'write'}\n"; - $packlist->write($pack{'write'}); + $packlist->write(install_rooted_file($pack{'write'})); } } @@ -235,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); @@ -259,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($fromto->{$_}),0,0755); + mkpath(dirname($dest),0,0755); + } + if ($need_filtering) { + run_filter($pm_filter, $_, $dest); + print "$pm_filter <$_ >$dest\n"; + } else { + 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); } } @@ -289,18 +344,20 @@ sub add { } sub DESTROY { - my $self = shift; - my($file,$i,$plural); - foreach $file (sort keys %$self) { - $plural = @{$self->{$file}} > 1 ? "s" : ""; - print "## Differing version$plural of $file found. You might like to\n"; - for (0..$#{$self->{$file}}) { - print "rm ", $self->{$file}[$_], "\n"; - $i++; + unless(defined $INSTALL_ROOT) { + my $self = shift; + my($file,$i,$plural); + foreach $file (sort keys %$self) { + $plural = @{$self->{$file}} > 1 ? "s" : ""; + print "## Differing version$plural of $file found. You might like to\n"; + for (0..$#{$self->{$file}}) { + print "rm ", $self->{$file}[$_], "\n"; + $i++; + } + } + $plural = $i>1 ? "all those files" : "this file"; + print "## Running 'make install UNINST=1' will unlink $plural for you.\n"; } - } - $plural = $i>1 ? "all those files" : "this file"; - print "## Running 'make install UNINST=1' will unlink $plural for you.\n"; } 1; @@ -363,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/contrib/perl5/lib/ExtUtils/Liblist.pm b/contrib/perl5/lib/ExtUtils/Liblist.pm index 6029557f11eb..5e2f91db5cf9 100644 --- a/contrib/perl5/lib/ExtUtils/Liblist.pm +++ b/contrib/perl5/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,19 +37,19 @@ sub ext { } sub _unix_os2_ext { - my($self,$potential_libs, $verbose) = @_; - if ($^O =~ 'os2' and $Config{libs}) { + 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. $potential_libs .= " " if $potential_libs; - $potential_libs .= $Config{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'}; - my($libs) = $Config{'libs'}; + my($libs) = $Config{'perllibs'}; my $Config_libext = $Config{lib_ext} || ".a"; @@ -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,28 +202,29 @@ 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; my $BC = 1 if $cc =~ /^bcc/i; my $GC = 1 if $cc =~ /^gcc/i; my $so = $Config{'so'}; - my $libs = $Config{'libs'}; + 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 @@ -230,6 +254,10 @@ sub _win32_ext { # add "$Config{installarchlib}/CORE" to default search path push @libpath, "$Config{installarchlib}/CORE"; + if ($VC and exists $ENV{LIB} and $ENV{LIB}) { + push @libpath, split /;/, $ENV{LIB}; + } + foreach (Text::ParseWords::quotewords('\s+', 0, $potential_libs)){ $thislib = $_; @@ -294,6 +322,7 @@ sub _win32_ext { $found++; $found_lib++; push(@extralibs, $fullname); + push @libs, $fullname unless $libs_seen{$fullname}++; last; } @@ -315,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) @@ -327,18 +357,18 @@ 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'}; @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') . 'PerlShr/Share' ); - push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); # In general, we pass through the basic libraries from %Config unchanged. # The one exception is that if we're building in the Perl source tree, and @@ -361,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); @@ -370,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', @@ -474,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; } } @@ -488,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; @@ -503,20 +535,22 @@ ExtUtils::Liblist - determine libraries to use and how to use them C<require ExtUtils::Liblist;> -C<ExtUtils::Liblist::ext($self, $potential_libs, $verbose);> +C<ExtUtils::Liblist::ext($self, $potential_libs, $verbose, $need_names);> =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: @@ -624,7 +658,7 @@ Unix-OS/2 version in several respects: =item * If C<$potential_libs> is empty, the return value will be empty. -Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) +Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) will be appended to the list of C<$potential_libs>. The libraries will be searched for in the directories specified in C<$potential_libs>, C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. @@ -668,7 +702,7 @@ Entries in C<$potential_libs> beginning with a colon and followed by alphanumeric characters are treated as flags. Unknown flags will be ignored. An entry that matches C</:nodefault/i> disables the appending of default -libraries found in C<$Config{libs}> (this should be only needed very rarely). +libraries found in C<$Config{perllibs}> (this should be only needed very rarely). An entry that matches C</:nosearch/i> disables all searching for the libraries specified after it. Translation of C<-Lfoo> and @@ -678,7 +712,7 @@ valid files or directories. An entry that matches C</:search/i> reenables searching for the libraries specified after it. You can put it at the end to -enable searching for default libraries specified by C<$Config{libs}>. +enable searching for default libraries specified by C<$Config{perllibs}>. =item * diff --git a/contrib/perl5/lib/ExtUtils/MM_Cygwin.pm b/contrib/perl5/lib/ExtUtils/MM_Cygwin.pm index a5ba410fdc08..439c67ccadc5 100644 --- a/contrib/perl5/lib/ExtUtils/MM_Cygwin.pm +++ b/contrib/perl5/lib/ExtUtils/MM_Cygwin.pm @@ -71,6 +71,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/contrib/perl5/lib/ExtUtils/MM_OS2.pm b/contrib/perl5/lib/ExtUtils/MM_OS2.pm index 430235a0aacf..cd6a1e4c49a1 100644 --- a/contrib/perl5/lib/ExtUtils/MM_OS2.pm +++ b/contrib/perl5/lib/ExtUtils/MM_OS2.pm @@ -93,6 +93,22 @@ sub perl_archive return "\$(PERL_INC)/libperl\$(LIB_EXT)"; } +=item perl_archive_after + +This is an internal method that returns path to a library which +should be put on the linker command line I<after> the external libraries +to be linked to dynamic extensions. This may be needed if the linker +is one-pass, and Perl includes some overrides for C RTL functions, +such as malloc(). + +=cut + +sub perl_archive_after +{ + return "\$(PERL_INC)/libperl_override\$(LIB_EXT)" unless $OS2::is_aout; + return ""; +} + sub export_list { my ($self) = @_; diff --git a/contrib/perl5/lib/ExtUtils/MM_Unix.pm b/contrib/perl5/lib/ExtUtils/MM_Unix.pm index 4c8da339b87a..c11333d780f3 100644 --- a/contrib/perl5/lib/ExtUtils/MM_Unix.pm +++ b/contrib/perl5/lib/ExtUtils/MM_Unix.pm @@ -208,6 +208,7 @@ sub ExtUtils::MM_Unix::parse_version ; sub ExtUtils::MM_Unix::pasthru ; sub ExtUtils::MM_Unix::path ; sub ExtUtils::MM_Unix::perl_archive; +sub ExtUtils::MM_Unix::perl_archive_after; sub ExtUtils::MM_Unix::perl_script ; sub ExtUtils::MM_Unix::perldepend ; sub ExtUtils::MM_Unix::pm_to_blib ; @@ -305,8 +306,8 @@ sub cflags { $libperl ||= $self->{LIBPERL_A} || "libperl$self->{LIB_EXT}" ; $libperl =~ s/\.\$\(A\)$/$self->{LIB_EXT}/; - @cflags{qw(cc ccflags optimize large split shellflags)} - = @Config{qw(cc ccflags optimize large split shellflags)}; + @cflags{qw(cc ccflags optimize shellflags)} + = @Config{qw(cc ccflags optimize shellflags)}; my($optdebug) = ""; $cflags{shellflags} ||= ''; @@ -341,16 +342,12 @@ sub cflags { optimize=\"$cflags{optimize}\" perltype=\"$cflags{perltype}\" optdebug=\"$cflags{optdebug}\" - large=\"$cflags{large}\" - split=\"$cflags{'split'}\" eval '$prog' echo cc=\$cc echo ccflags=\$ccflags echo optimize=\$optimize echo perltype=\$perltype echo optdebug=\$optdebug - echo large=\$large - echo split=\$split `; my($line); foreach $line (@o){ @@ -368,7 +365,7 @@ sub cflags { $cflags{optimize} = $optdebug; } - for (qw(ccflags optimize perltype large split)) { + for (qw(ccflags optimize perltype)) { $cflags{$_} =~ s/^\s+//; $cflags{$_} =~ s/\s+/ /g; $cflags{$_} =~ s/\s+$//; @@ -411,8 +408,6 @@ sub cflags { CCFLAGS = $self->{CCFLAGS} OPTIMIZE = $self->{OPTIMIZE} PERLTYPE = $self->{PERLTYPE} -LARGE = $self->{LARGE} -SPLIT = $self->{SPLIT} MPOLLUTE = $pollute }; @@ -457,7 +452,7 @@ EOT push(@otherfiles, qw[./blib $(MAKE_APERL_FILE) $(INST_ARCHAUTODIR)/extralibs.all perlmain.c mon.out core core.*perl.*.? *perl.core so_locations pm_to_blib - *~ */*~ */*/*~ *$(OBJ_EXT) *$(LIB_EXT) perl.exe + *$(OBJ_EXT) *$(LIB_EXT) perl.exe $(BOOTSTRAP) $(BASEEXT).bso $(BASEEXT).def $(BASEEXT).exp ]); @@ -483,7 +478,7 @@ sub const_cccmd { return '' unless $self->needs_linking(); return $self->{CONST_CCCMD} = q{CCCMD = $(CC) -c $(INC) $(CCFLAGS) $(OPTIMIZE) \\ - $(PERLTYPE) $(LARGE) $(SPLIT) $(MPOLLUTE) $(DEFINE_VERSION) \\ + $(PERLTYPE) $(MPOLLUTE) $(DEFINE_VERSION) \\ $(XS_DEFINE_VERSION)}; } @@ -586,7 +581,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"; @@ -680,6 +675,10 @@ EXPORT_LIST = $tmp push @m, " PERL_ARCHIVE = $tmp "; + $tmp = $self->perl_archive_after; + push @m, " +PERL_ARCHIVE_AFTER = $tmp +"; # push @m, q{ #INST_PM = }.join(" \\\n\t", sort values %{$self->{PM}}).q{ @@ -812,7 +811,7 @@ DIST_DEFAULT = $dist_default =item dist_basics (o) -Defines the targets distclean, distcheck, skipcheck, manifest. +Defines the targets distclean, distcheck, skipcheck, manifest, veryclean. =cut @@ -840,6 +839,11 @@ manifest : $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=mkmanifest \\ -e mkmanifest }; + + push @m, q{ +veryclean : realclean + $(RM_F) *~ *.orig */*~ */*.orig +}; join "", @m; } @@ -1062,7 +1066,7 @@ ARMAYBE = '.$armaybe.' OTHERLDFLAGS = '.$otherldflags.' INST_DYNAMIC_DEP = '.$inst_dynamic_dep.' -$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) +$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP) '); if ($armaybe ne ':'){ $ldfrom = 'tmp$(LIB_EXT)'; @@ -1071,18 +1075,20 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists } $ldfrom = "-all $ldfrom -none" if ($^O eq 'dec_osf'); - # Brain dead solaris linker does not use LD_RUN_PATH? - # This fixes dynamic extensions which need shared libs - my $ldrun = ''; - $ldrun = join ' ', map "-R$_", split /:/, $self->{LD_RUN_PATH} - if ($^O eq 'solaris'); - - # The IRIX linker also doesn't use LD_RUN_PATH - $ldrun = qq{-rpath "$self->{LD_RUN_PATH}"} + # The IRIX linker doesn't use LD_RUN_PATH + my $ldrun = qq{-rpath "$self->{LD_RUN_PATH}"} if ($^O eq 'irix' && $self->{LD_RUN_PATH}); - push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom. - ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)'); + # 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) '.$ldrun.' $(LDDLFLAGS) '.$ldfrom. + ' $(OTHERLDFLAGS) -o $@ $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(PERL_ARCHIVE_AFTER) $(EXPORT_LIST)'); push @m, ' $(CHMOD) $(PERM_RWX) $@ '; @@ -1147,9 +1153,9 @@ in these dirs: @$dirs "; } - foreach $dir (@$dirs){ - next unless defined $dir; # $self->{PERL_SRC} may be undefined - foreach $name (@$names){ + foreach $name (@$names){ + foreach $dir (@$dirs){ + next unless defined $dir; # $self->{PERL_SRC} may be undefined my ($abs, $val); if ($self->file_name_is_absolute($name)) { # /foo/bar $abs = $name; @@ -1249,11 +1255,6 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' next; } my($dev,$ino,$mode) = stat FIXIN; - # If they override perm_rwx, we won't notice it during fixin, - # because fixin is run through a new instance of MakeMaker. - # That is why we must run another CHMOD later. - $mode = oct($self->perm_rwx) unless $dev; - chmod $mode, $file; # Print out the new #! line (or equivalent). local $\; @@ -1261,7 +1262,15 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' print FIXOUT $shb, <FIXIN>; close FIXIN; close FIXOUT; - # can't rename open files on some DOSISH platforms + + # can't rename/chmod open files on some DOSISH platforms + + # If they override perm_rwx, we won't notice it during fixin, + # because fixin is run through a new instance of MakeMaker. + # That is why we must run another CHMOD later. + $mode = oct($self->perm_rwx) unless $dev; + chmod $mode, $file; + unless ( rename($file, "$file.bak") ) { warn "Can't rename $file to $file.bak: $!"; next; @@ -1276,6 +1285,7 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' } unlink "$file.bak"; } continue { + close(FIXIN) if fileno(FIXIN); chmod oct($self->perm_rwx), $file or die "Can't reset permissions for $file: $!\n"; system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';; @@ -1653,7 +1663,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") && @@ -2367,7 +2377,7 @@ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) # The front matter of the linkcommand... $linkcmd = join ' ', "\$(CC)", - grep($_, @Config{qw(large split ldflags ccdlflags)}); + grep($_, @Config{qw(ldflags ccdlflags)}); $linkcmd =~ s/\s+/ /g; $linkcmd =~ s,(perl\.exp),\$(PERL_INC)/$1,; @@ -2450,7 +2460,7 @@ MAP_PERLINC = @{$perlinc || []} MAP_STATIC = ", join(" \\\n\t", reverse sort keys %static), " -MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} +MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} "; if (defined $libperl) { @@ -2458,6 +2468,7 @@ MAP_PRELIBS = $Config::Config{libs} $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}"; @@ -2495,14 +2506,9 @@ MAP_LIBPERL = $libperl # SUNOS ld does not take the full path to a shared library my $llibperl = ($libperl)?'$(MAP_LIBPERL)':'-lperl'; - # Brain dead solaris linker does not use LD_RUN_PATH? - # This fixes dynamic extensions which need shared libs - my $ldfrom = ($^O eq 'solaris')? - join(' ', map "-R$_", split /:/, $self->{LD_RUN_PATH}):''; - push @m, " \$(MAP_TARGET) :: $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) \$(INST_ARCHAUTODIR)/extralibs.all - \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) $ldfrom \$(MAP_STATIC) $llibperl `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS) + \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) \$(LDFROM) \$(MAP_STATIC) $llibperl `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS) $self->{NOECHO}echo 'To install the new \"\$(MAP_TARGET)\" binary, call' $self->{NOECHO}echo ' make -f $makefilename inst_perl MAP_TARGET=\$(MAP_TARGET)' $self->{NOECHO}echo 'To remove the intermediate files say' @@ -3038,7 +3044,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) $@ }; } @@ -3110,6 +3116,7 @@ sub processPL { my $list = ref($self->{PL_FILES}->{$plfile}) ? $self->{PL_FILES}->{$plfile} : [$self->{PL_FILES}->{$plfile}]; + my $target; foreach $target (@$list) { push @m, " all :: $target @@ -3149,8 +3156,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}; @@ -3169,9 +3190,11 @@ form Foo/Bar and replaces the slash with C<::>. Returns the replacement. sub replace_manpage_separator { my($self,$man) = @_; if ($^O eq 'uwin') { - $man =~ s,/+,.,g; + $man =~ s,/+,.,g; + } elsif ($Is_Dos) { + $man =~ s,/+,__,g; } else { - $man =~ s,/+,::,g; + $man =~ s,/+,::,g; } $man; } @@ -3490,13 +3513,13 @@ WARN_IF_OLD_PACKLIST = $(PERL) -we 'exit unless -f $$ARGV[0];' \\ -e 'print "Please make sure the two installations are not conflicting\n";' UNINST=0 -VERBINST=1 +VERBINST=0 MOD_INSTALL = $(PERL) -I$(INST_LIB) -I$(PERL_LIB) -MExtUtils::Install \ -e "install({@ARGV},'$(VERBINST)',0,'$(UNINST)');" DOC_INSTALL = $(PERL) -e '$$\="\n\n";' \ --e 'print "=head2 ", scalar(localtime), ": C<", shift, ">", " L<", shift, ">";' \ +-e 'print "=head2 ", scalar(localtime), ": C<", shift, ">", " L<", $$arg=shift, "|", $$arg, ">";' \ -e 'print "=over 4";' \ -e 'while (defined($$key = shift) and defined($$val = shift)){print "=item *";print "C<$$key: $$val>";}' \ -e 'print "=back";' @@ -3791,6 +3814,21 @@ sub perl_archive return ""; } +=item perl_archive_after + +This is an internal method that returns path to a library which +should be put on the linker command line I<after> the external libraries +to be linked to dynamic extensions. This may be needed if the linker +is one-pass, and Perl includes some overrides for C RTL functions, +such as malloc(). + +=cut + +sub perl_archive_after +{ + return ""; +} + =item export_list This is internal method that returns name of a file that is diff --git a/contrib/perl5/lib/ExtUtils/MM_VMS.pm b/contrib/perl5/lib/ExtUtils/MM_VMS.pm index 57a8146dae75..7b75958e8937 100644 --- a/contrib/perl5/lib/ExtUtils/MM_VMS.pm +++ b/contrib/perl5/lib/ExtUtils/MM_VMS.pm @@ -151,11 +151,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 @@ -231,7 +232,9 @@ invoke Perl images. sub find_perl { my($self, $ver, $names, $dirs, $trace) = @_; my($name,$dir,$vmsfile,@sdirs,@snames,@cand); + my($rslt); my($inabs) = 0; + local *TCF; # Check in relative directories first, so we pick up the current # version of Perl if we're running MakeMaker as part of the main build. @sdirs = sort { my($absa) = $self->file_name_is_absolute($a); @@ -277,15 +280,28 @@ sub find_perl { foreach $name (@cand) { print "Checking $name\n" if ($trace >= 2); # If it looks like a potential command, try it without the MCR - if ($name =~ /^[\w\-\$]+$/ && - `$name -e "require $ver; print ""VER_OK\\n"""` =~ /VER_OK/) { + if ($name =~ /^[\w\-\$]+$/) { + open(TCF,">temp_mmvms.com") || die('unable to open temp file'); + print TCF "\$ set message/nofacil/nosever/noident/notext\n"; + print TCF "\$ $name -e \"require $ver; print \"\"VER_OK\\n\"\"\"\n"; + close TCF; + $rslt = `\@temp_mmvms.com` ; + unlink('temp_mmvms.com'); + if ($rslt =~ /VER_OK/) { print "Using PERL=$name\n" if $trace; return $name; } + } next unless $vmsfile = $self->maybe_command($name); $vmsfile =~ s/;[\d\-]*$//; # Clip off version number; we can use a newer version as well print "Executing $vmsfile\n" if ($trace >= 2); - if (`MCR $vmsfile -e "require $ver; print ""VER_OK\\n"""` =~ /VER_OK/) { + open(TCF,">temp_mmvms.com") || die('unable to open temp file'); + print TCF "\$ set message/nofacil/nosever/noident/notext\n"; + print TCF "\$ mcr $vmsfile -e \"require $ver; print \"\"VER_OK\\n\"\"\" \n"; + close TCF; + $rslt = `\@temp_mmvms.com`; + unlink('temp_mmvms.com'); + if ($rslt =~ /VER_OK/) { print "Using PERL=MCR $vmsfile\n" if $trace; return "MCR $vmsfile"; } @@ -611,7 +627,7 @@ INST_ARCHAUTODIR = $self->{INST_ARCHAUTODIR} if ($self->has_link_code()) { push @m,' INST_STATIC = $(INST_ARCHAUTODIR)$(BASEEXT)$(LIB_EXT) -INST_DYNAMIC = $(INST_ARCHAUTODIR)$(BASEEXT).$(DLEXT) +INST_DYNAMIC = $(INST_ARCHAUTODIR)$(DLBASE).$(DLEXT) INST_BOOT = $(INST_ARCHAUTODIR)$(BASEEXT).bs '; } else { @@ -811,7 +827,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(' ',<STDIN>)},'].$autodir.q[')" <.MM_tmp]); + push(@m,q[ $(PERL) "-I$(PERL_LIB)" "-MExtUtils::Install" -e "pm_to_blib({split(' ',<STDIN>)},'].$autodir.q[','$(PM_FILTER)')" <.MM_tmp]); push(@m,qq[ \$(NOECHO) Delete/NoLog/NoConfirm .MM_tmp; \$(NOECHO) \$(TOUCH) pm_to_blib.ts @@ -866,6 +882,11 @@ sub tool_xsubpp { unshift( @tmargs, $self->{XSOPT} ); } + if ($Config{'ldflags'} && + $Config{'ldflags'} =~ m!/Debug!i && + (!exists($self->{XSOPT}) || $self->{XSOPT} !~ /linenumbers/)) { + unshift(@tmargs,'-nolinenumbers'); + } my $xsubpp_version = $self->xsubpp_version($self->catfile($xsdir,'xsubpp')); # What are the correct thresholds for version 1 && 2 Paul? @@ -1018,7 +1039,7 @@ sub dist { # Sanitize these for use in $(DISTVNAME) filespec $attribs{VERSION} =~ s/[^\w\$]/_/g; - $attribs{NAME} =~ s/[^\w\$]/_/g; + $attribs{NAME} =~ s/[^\w\$]/-/g; return ExtUtils::MM_Unix::dist($self,%attribs); } @@ -1194,8 +1215,8 @@ $(BASEEXT).opt : Makefile.PL s/.*[:>\/\]]//; # Trim off dir spec $upcase ? uc($_) : $_; } split ' ', $self->eliminate_macros($self->{OBJECT}); - my($tmp,@lines,$elt) = ''; - my $tmp = shift @omods; + my($tmp,@lines,$elt) = ''; + $tmp = shift @omods; foreach $elt (@omods) { $tmp .= ",$elt"; if (length($tmp) > 80) { push @lines, $tmp; $tmp = ''; } @@ -1652,6 +1673,9 @@ dist : $(DIST_DEFAULT) zipdist : $(DISTVNAME).zip $(NOECHO) $(NOOP) +tardist : $(DISTVNAME).tar$(SUFFIX) + $(NOECHO) $(NOOP) + $(DISTVNAME).zip : distdir $(PREOP) $(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) [.$(DISTVNAME)...]*.*; @@ -1661,7 +1685,7 @@ $(DISTVNAME).zip : distdir $(DISTVNAME).tar$(SUFFIX) : distdir $(PREOP) $(TO_UNIX) - $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)] + $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)...] $(RM_RF) $(DISTVNAME) $(COMPRESS) $(DISTVNAME).tar $(POSTOP) @@ -1872,6 +1896,7 @@ $(OBJECT) : $(PERL_INC)iperlsys.h # We do NOT just update config.h because that is not sufficient. # An out of date config.h is not fatal but complains loudly! $(PERL_INC)config.h : $(PERL_SRC)config.sh + $(NOOP) $(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh $(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.h or genconfig.pl" diff --git a/contrib/perl5/lib/ExtUtils/MM_Win32.pm b/contrib/perl5/lib/ExtUtils/MM_Win32.pm index e08c6791eee4..5361ecee9935 100644 --- a/contrib/perl5/lib/ExtUtils/MM_Win32.pm +++ b/contrib/perl5/lib/ExtUtils/MM_Win32.pm @@ -596,7 +596,7 @@ pm_to_blib: $(TO_INST_PM) ($NMAKE ? 'qw[ <<pmfiles.dat ],' : $DMAKE ? 'qw[ $(mktmp,pmfiles.dat $(PM_TO_BLIB:s,\\,\\\\,)\n) ],' : '{ qw[$(PM_TO_BLIB)] },' - ).q{'}.$autodir.q{')" + ).q{'}.$autodir.q{','$(PM_FILTER)')" }. ($NMAKE ? q{ $(PM_TO_BLIB) << @@ -684,7 +684,7 @@ MOD_INSTALL = $(PERL) -I$(INST_LIB) -I$(PERL_LIB) -MExtUtils::Install \ -e "install({ @ARGV },'$(VERBINST)',0,'$(UNINST)');" DOC_INSTALL = $(PERL) -e "$$\=\"\n\n\";" \ --e "print '=head2 ', scalar(localtime), ': C<', shift, '>', ' L<', shift, '>';" \ +-e "print '=head2 ', scalar(localtime), ': C<', shift, '>', ' L<', $$arg=shift, '|', $$arg, '>';" \ -e "print '=over 4';" \ -e "while (defined($$key = shift) and defined($$val = shift)) { print '=item *';print 'C<', \"$$key: $$val\", '>'; }" \ -e "print '=back';" diff --git a/contrib/perl5/lib/ExtUtils/MakeMaker.pm b/contrib/perl5/lib/ExtUtils/MakeMaker.pm index 38cb2169a338..8bf76c731341 100644 --- a/contrib/perl5/lib/ExtUtils/MakeMaker.pm +++ b/contrib/perl5/lib/ExtUtils/MakeMaker.pm @@ -44,7 +44,7 @@ use vars qw( # default routine without having to know under what OS # it's running. # -@MM::ISA = qw[ExtUtils::MM_Unix ExtUtils::Liblist ExtUtils::MakeMaker]; +@MM::ISA = qw[ExtUtils::MM_Unix ExtUtils::Liblist::Kid ExtUtils::MakeMaker]; # # Setup dummy package: @@ -60,7 +60,7 @@ use vars qw( # "predeclare the package: we only load it via AUTOLOAD # but we have already mentioned it in @ISA -package ExtUtils::Liblist; +package ExtUtils::Liblist::Kid; package ExtUtils::MakeMaker; # @@ -82,7 +82,7 @@ if ($Is_OS2) { require ExtUtils::MM_OS2; } if ($Is_Mac) { - require ExtUtils::MM_Mac; + require ExtUtils::MM_MacOS; } if ($Is_Win32) { require ExtUtils::MM_Win32; @@ -189,7 +189,7 @@ sub full_setup { AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DL_FUNCS DL_VARS EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE FULLPERL FUNCLIST H - HTMLLIBPODS HTMLSCRIPTPOD IMPORTS + HTMLLIBPODS HTMLSCRIPTPODS IMPORTS INC INCLUDE_EXT INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLHTMLPRIVLIBDIR INSTALLHTMLSCRIPTDIR INSTALLHTMLSITELIBDIR INSTALLMAN1DIR INSTALLMAN3DIR INSTALLPRIVLIB INSTALLSCRIPT INSTALLSITEARCH @@ -200,10 +200,14 @@ sub full_setup { PERL_MALLOC_OK NAME NEEDS_LINKING NOECHO NORECURS NO_VC OBJECT OPTIMIZE PERL PERLMAINCC PERL_ARCHLIB PERL_LIB PERL_SRC PERM_RW PERM_RWX - PL_FILES PM PMLIBDIRS POLLUTE PPM_INSTALL_EXEC PPM_INSTALL_SCRIPT PREFIX + PL_FILES PM PM_FILTER PMLIBDIRS POLLUTE PPM_INSTALL_EXEC + PPM_INSTALL_SCRIPT PREFIX PREREQ_PM SKIP TYPEMAPS VERSION VERSION_FROM XS XSOPT XSPROTOARG XS_VERSION clean depend dist dynamic_lib linkext macro realclean tool_autosplit + + MACPERL_SRC MACPERL_LIB MACLIBS_68K MACLIBS_PPC MACLIBS_SC MACLIBS_MRC + MACLIBS_ALL_68K MACLIBS_ALL_PPC MACLIBS_SHARED /; # IMPORTS is used under OS/2 and Win32 @@ -239,7 +243,6 @@ sub full_setup { dir_target libscan makeaperl needs_linking perm_rw perm_rwx subdir_x test_via_harness test_via_script - ]; push @MM_Sections, qw[ @@ -982,23 +985,39 @@ be perl Makefile.PL LIB=~/lib This will install the module's architecture-independent files into -~/lib, the architecture-dependent files into ~/lib/$archname/auto. +~/lib, the architecture-dependent files into ~/lib/$archname. Another way to specify many INSTALL directories with a single parameter is PREFIX. perl Makefile.PL PREFIX=~ -This will replace the string specified by $Config{prefix} in all -$Config{install*} values. +This will replace the string specified by C<$Config{prefix}> 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 +1164,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 +1174,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 +1428,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 +1436,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 +1456,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<NOTE.> Negligence to set this flag in I<any one> 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 +1464,12 @@ specify ld flags) =item LIB -LIB can only be set at C<perl Makefile.PL> time. It has the effect of +LIB should only be set at C<perl Makefile.PL> 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 @@ -1578,6 +1573,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 +1591,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<NOTE.> Negligence to set this flag in I<any one> 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 +1673,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 +1775,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 +1783,8 @@ but these will fail: local $VERSION = '1.02'; local $FOO::VERSION = '1.30'; +(Putting C<my> or C<local> 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 +1839,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', diff --git a/contrib/perl5/lib/ExtUtils/Manifest.pm b/contrib/perl5/lib/ExtUtils/Manifest.pm index 8bb3fc8ebd6e..50a426336122 100644 --- a/contrib/perl5/lib/ExtUtils/Manifest.pm +++ b/contrib/perl5/lib/ExtUtils/Manifest.pm @@ -8,13 +8,14 @@ use Carp; use strict; use vars qw($VERSION @ISA @EXPORT_OK - $Is_VMS $Debug $Verbose $Quiet $MANIFEST $found); + $Is_MacOS $Is_VMS $Debug $Verbose $Quiet $MANIFEST $found); $VERSION = substr(q$Revision: 1.33 $, 10); @ISA=('Exporter'); @EXPORT_OK = ('mkmanifest', 'manicheck', 'fullcheck', 'filecheck', 'skipcheck', 'maniread', 'manicopy'); +$Is_MacOS = $^O eq 'MacOS'; $Is_VMS = $^O eq 'VMS'; if ($Is_VMS) { require File::Basename } @@ -49,6 +50,7 @@ sub mkmanifest { } my $text = $all{$file}; ($file,$text) = split(/\s+/,$text,2) if $Is_VMS && $text; + $file = _unmacify($file); my $tabs = (5 - (length($file)+1)/8); $tabs = 1 if $tabs < 1; $tabs = 0 unless $text; @@ -60,10 +62,11 @@ sub mkmanifest { sub manifind { local $found = {}; find(sub {return if -d $_; - (my $name = $File::Find::name) =~ s|./||; + (my $name = $File::Find::name) =~ s|^\./||; + $name =~ s/^:([^:]+)$/$1/ if $Is_MacOS; warn "Debug: diskfile $name\n" if $Debug; - $name =~ s#(.*)\.$#\L$1# if $Is_VMS; - $found->{$name} = "";}, "."); + $name =~ s#(.*)\.$#\L$1# if $Is_VMS; + $found->{$name} = "";}, $Is_MacOS ? ":" : "."); $found; } @@ -115,7 +118,8 @@ sub _manicheck { } warn "Debug: manicheck checking from disk $file\n" if $Debug; unless ( exists $read->{$file} ) { - warn "Not in $MANIFEST: $file\n" unless $Quiet; + my $canon = "\t" . _unmacify($file) if $Is_MacOS; + warn "Not in $MANIFEST: $file$canon\n" unless $Quiet; push @missentry, $file; } } @@ -135,7 +139,13 @@ sub maniread { while (<M>){ chomp; next if /^#/; - if ($Is_VMS) { + if ($Is_MacOS) { + my($item,$text) = /^(\S+)\s*(.*)/; + $item = _macify($item); + $item =~ s/\\([0-3][0-7][0-7])/sprintf("%c", oct($1))/ge; + $read->{$item}=$text; + } + elsif ($Is_VMS) { my($file)= /^(\S+)/; next unless $file; my($base,$dir) = File::Basename::fileparse($file); @@ -166,7 +176,7 @@ sub _maniskip { chomp; next if /^#/; next if /^\s*$/; - push @skip, $_; + push @skip, _macify($_); } close M; my $opts = $Is_VMS ? 'oi ' : 'o '; @@ -187,15 +197,24 @@ 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); + if ($Is_MacOS) { + if ($file =~ m!:!) { + my $dir = _maccat($target, $file); + $dir =~ s/[^:]+$//; + File::Path::mkpath($dir,1,0755); + } + cp_if_diff($file, _maccat($target, $file), $how); + } else { + $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"],! $Quiet,$Is_VMS ? undef : 0755); + } + cp_if_diff($file, "$target/$file", $how); } - cp_if_diff($file, "$target/$file", $how); } } @@ -204,8 +223,8 @@ sub cp_if_diff { -f $from or carp "$0: $from not found"; my($diff) = 0; local(*F,*T); - open(F,$from) or croak "Can't read $from: $!\n"; - if (open(T,$to)) { + open(F,"< $from\0") or croak "Can't read $from: $!\n"; + if (open(T,"< $to\0")) { while (<F>) { $diff++,last if $_ ne <T>; } $diff++ unless eof(T); close T; @@ -233,12 +252,12 @@ sub cp { copy($srcFile,$dstFile); utime $access, $mod + ($Is_VMS ? 1 : 0), $dstFile; # chmod a+rX-w,go-w - chmod( 0444 | ( $perm & 0111 ? 0111 : 0 ), $dstFile ); + chmod( 0444 | ( $perm & 0111 ? 0111 : 0 ), $dstFile ) unless ($^O eq 'MacOS'); } sub ln { my ($srcFile, $dstFile) = @_; - return &cp if $Is_VMS; + return &cp if $Is_VMS or ($^O eq 'MSWin32' and Win32::IsWin95()); link($srcFile, $dstFile); local($_) = $dstFile; # chmod a+r,go-w+X (except "X" only applies to u=x) my $mode= 0444 | (stat)[2] & 0700; @@ -258,6 +277,42 @@ sub best { } } +sub _macify { + my($file) = @_; + + return $file unless $Is_MacOS; + + $file =~ s|^\./||; + if ($file =~ m|/|) { + $file =~ s|/+|:|g; + $file = ":$file"; + } + + $file; +} + +sub _maccat { + my($f1, $f2) = @_; + + return "$f1/$f2" unless $Is_MacOS; + + $f1 .= ":$f2"; + $f1 =~ s/([^:]:):/$1/g; + return $f1; +} + +sub _unmacify { + my($file) = @_; + + return $file unless $Is_MacOS; + + $file =~ s|^:||; + $file =~ s|([/ \n])|sprintf("\\%03o", unpack("c", $1))|ge; + $file =~ y|:|/|; + + $file; +} + 1; __END__ diff --git a/contrib/perl5/lib/ExtUtils/Mksymlists.pm b/contrib/perl5/lib/ExtUtils/Mksymlists.pm index c8f41c74bcd7..c06b393be353 100644 --- a/contrib/perl5/lib/ExtUtils/Mksymlists.pm +++ b/contrib/perl5/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/contrib/perl5/lib/ExtUtils/typemap b/contrib/perl5/lib/ExtUtils/typemap index a34cd4f9ea77..c309128fc324 100644 --- a/contrib/perl5/lib/ExtUtils/typemap +++ b/contrib/perl5/lib/ExtUtils/typemap @@ -1,4 +1,3 @@ -# $Header: /home/rmb1/misc/CVS/perl5.005_61/lib/ExtUtils/typemap,v 1.3 1999/09/13 09:46:43 rmb1 Exp $ # basic C types int T_IV unsigned T_UV @@ -30,6 +29,7 @@ CV * T_CVREF IV T_IV UV T_UV +NV T_NV I32 T_IV I16 T_IV I8 T_IV @@ -226,13 +226,13 @@ T_U_CHAR T_FLOAT sv_setnv($arg, (double)$var); T_NV - sv_setnv($arg, (double)$var); + sv_setnv($arg, (NV)$var); T_DOUBLE sv_setnv($arg, (double)$var); T_PV sv_setpv((SV*)$arg, $var); T_PTR - sv_setiv($arg, (IV)$var); + sv_setiv($arg, PTR2IV($var)); T_PTRREF sv_setref_pv($arg, Nullch, (void*)$var); T_REF_IV_REF diff --git a/contrib/perl5/lib/ExtUtils/xsubpp b/contrib/perl5/lib/ExtUtils/xsubpp index 5a71e896362f..bb8f3aab0466 100755 --- a/contrib/perl5/lib/ExtUtils/xsubpp +++ b/contrib/perl5/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') { @@ -288,7 +288,7 @@ $END = "!End!\n\n"; # "impossible" keyword (multiple newline) # Match an XS keyword $BLOCK_re= '\s*(' . join('|', qw( REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT - CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE + CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL )) . "|$END)\\s*:"; @@ -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$/; } } @@ -573,6 +572,15 @@ sub GetAliases if $line ; } +sub ATTRS_handler () +{ + for (; !/^$BLOCK_re/o; $_ = shift(@line)) { + next unless /\S/; + TrimWhitespace($_) ; + push @Attributes, $_; + } +} + sub ALIAS_handler () { for (; !/^$BLOCK_re/o; $_ = shift(@line)) { @@ -847,7 +855,25 @@ EOM print("#line 1 \"$filename\"\n") if $WantLineNumbers; +firstmodule: while (<$FH>) { + if (/^=/) { + my $podstartline = $.; + do { + if (/^=cut\s*$/) { + print("/* Skipped embedded POD. */\n"); + printf("#line %d \"$filename\"\n", $. + 1) + if $WantLineNumbers; + next firstmodule + } + + } while (<$FH>); + # 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*$/; @@ -886,6 +912,16 @@ sub fetch_para { } for(;;) { + # Skip embedded PODs + while ($lastline =~ /^=/) { + while ($lastline = <$FH>) { + last if ($lastline =~ /^=cut\s*$/); + } + death ("Error: Unterminated pod") unless $lastline; + $lastline = <$FH>; + chomp $lastline; + $lastline =~ s/^\s+$//; + } if ($lastline !~ /^\s*#/ || # CPP directives: # ANSI: if ifdef ifndef elif else endif define undef @@ -966,7 +1002,6 @@ while (fetch_para()) { # initialize info arrays undef(%args_match); undef(%var_types); - undef(%var_addr); undef(%defaults); undef($class); undef($static); @@ -978,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) ; @@ -1039,12 +1074,12 @@ while (fetch_para()) { last; } $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ; - %XsubAliases = %XsubAliasValues = %Interfaces = (); + %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = (); $DoSetMagic = 1; $orig_args =~ s/\\\s*/ /g; # process line continuations - my %out_vars; + my %only_outlist; if ($process_argtypes and $orig_args =~ /\S/) { my $args = "$orig_args ,"; if ($args =~ /^( (??{ $C_arg }) , )* $ /x) { @@ -1059,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; @@ -1070,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 { @@ -1081,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; } } @@ -1109,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; @@ -1210,7 +1245,7 @@ EOF $gotRETVAL = 0; INPUT_handler() ; - process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|PROTOTYPE|SCOPE") ; + process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE") ; print Q<<"EOF" if $ScopeThisXSUB; # ENTER; @@ -1252,7 +1287,7 @@ EOF } print $deferred; - process_keyword("INIT|ALIAS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ; + process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ; if (check_keyword("PPCODE")) { print_section(); @@ -1296,7 +1331,10 @@ EOF # $wantRETVAL set if 'RETVAL =' autogenerated ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return; undef %outargs ; - process_keyword("POSTCALL|OUTPUT|ALIAS|PROTOTYPE"); + process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE"); + + &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) { @@ -1334,14 +1372,14 @@ 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|PROTOTYPE") ; + process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE") ; print Q<<"EOF" if $ScopeThisXSUB; # ]] @@ -1431,6 +1469,12 @@ EOF EOF } } + elsif (@Attributes) { + push(@InitFileCode, Q<<"EOF"); +# cv = newXS(\"$pname\", XS_$Full_func_name, file); +# apply_attrs_string("$Package", cv, "@Attributes", 0); +EOF + } elsif ($interface) { while ( ($name, $value) = each %Interfaces) { $name = "$Package\::$name" unless $name =~ /::/; diff --git a/contrib/perl5/lib/File/Basename.pm b/contrib/perl5/lib/File/Basename.pm index 4581e7e93c26..94aac2dd44e2 100644 --- a/contrib/perl5/lib/File/Basename.pm +++ b/contrib/perl5/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/; } @@ -189,9 +189,13 @@ sub fileparse { } elsif ($fstype !~ /^VMS/i) { # default to Unix ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#s); - if ($^O eq 'VMS' and $fullname =~ m:/[^/]+/000000/?:) { + if ($^O eq 'VMS' and $fullname =~ m:^(/[^/]+/000000(/|$))(.*):) { # dev:[000000] is top of VMS tree, similar to Unix '/' - ($basename,$dirpath) = ('',$fullname); + # so strip it off and treat the rest as "normal" + my $devspec = $1; + my $remainder = $3; + ($dirpath,$basename) = ($remainder =~ m#^(.*/)?(.*)#s); + $dirpath = $devspec.$dirpath; } $dirpath = './' unless $dirpath; } @@ -236,7 +240,13 @@ sub dirname { if ($_[0] =~ m#/#) { $fstype = '' } else { return $dirname || $ENV{DEFAULT} } } - if ($fstype =~ /MacOS/i) { return $dirname } + if ($fstype =~ /MacOS/i) { + if( !length($basename) && $dirname !~ /^[^:]+:\z/) { + $dirname =~ s/([^:]):\z/$1/s; + ($basename,$dirname) = fileparse $dirname; + } + $dirname .= ":" unless $dirname =~ /:\z/; + } elsif ($fstype =~ /MSDOS/i) { $dirname =~ s/([^:])[\\\/]*\z/$1/; unless( length($basename) ) { @@ -256,7 +266,7 @@ sub dirname { chop $dirname; $dirname =~ s#[^:/]+\z## unless length($basename); } - else { + else { $dirname =~ s:(.)/*\z:$1:s; unless( length($basename) ) { local($File::Basename::Fileparse_fstype) = $fstype; diff --git a/contrib/perl5/lib/File/Copy.pm b/contrib/perl5/lib/File/Copy.pm index e6cf78603423..24d1ffdf630c 100644 --- a/contrib/perl5/lib/File/Copy.pm +++ b/contrib/perl5/lib/File/Copy.pm @@ -37,7 +37,7 @@ sub _catname { # Will be replaced by File::Spec when it arrives import File::Basename 'basename'; } if ($^O eq 'VMS') { $to = VMS::Filespec::vmspath($to) . basename($from); } - elsif ($^O eq 'MacOS') { $to .= ':' . basename($from); } + elsif ($^O eq 'MacOS') { $to =~ s/^([^:]+)$/:$1/; $to .= ':' . basename($from); } elsif ($to =~ m|\\|) { $to .= '\\' . basename($from); } else { $to .= '/' . basename($from); } } @@ -69,6 +69,7 @@ sub copy { && !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles && !($from_a_handle && $^O eq 'mpeix') # and neither can MPE/iX. && !($from_a_handle && $^O eq 'MSWin32') + && !($from_a_handle && $^O eq 'MacOS') ) { return syscopy($from, $to); @@ -83,7 +84,7 @@ sub copy { if ($from_a_handle) { *FROM = *$from{FILEHANDLE}; } else { - $from = "./$from" if $from =~ /^\s/s; + $from = _protect($from) if $from =~ /^\s/s; open(FROM, "< $from\0") or goto fail_open1; binmode FROM or die "($!,$^E)"; $closefrom = 1; @@ -92,7 +93,7 @@ sub copy { if ($to_a_handle) { *TO = *$to{FILEHANDLE}; } else { - $to = "./$to" if $to =~ /^\s/s; + $to = _protect($to) if $to =~ /^\s/s; open(TO,"> $to\0") or goto fail_open2; binmode TO or die "($!,$^E)"; $closeto = 1; @@ -180,6 +181,13 @@ sub move { *cp = \© *mv = \&move; + +if ($^O eq 'MacOS') { + *_protect = sub { MacPerl::MakeFSSpec($_[0]) }; +} else { + *_protect = sub { "./$_[0]" }; +} + # &syscopy is an XSUB under OS/2 unless (defined &syscopy) { if ($^O eq 'VMS') { @@ -196,6 +204,23 @@ unless (defined &syscopy) { return 0 unless @_ == 2; return Win32::CopyFile(@_, 1); }; + } elsif ($^O eq 'MacOS') { + require Mac::MoreFiles; + *syscopy = sub { + my($from, $to) = @_; + my($dir, $toname); + + return 0 unless -e $from; + + if ($to =~ /(.*:)([^:]+):?$/) { + ($dir, $toname) = ($1, $2); + } else { + ($dir, $toname) = (":", $to); + } + + unlink($to); + Mac::MoreFiles::FSpFileCopy($from, $dir, $toname, 1); + }; } else { $Syscopy_is_copy = 1; *syscopy = \© @@ -221,7 +246,7 @@ File::Copy - Copy files or filehandles use POSIX; use File::Copy cp; - $n=FileHandle->new("/dev/null","r"); + $n = FileHandle->new("/a/file","r"); cp($n,"x");' =head1 DESCRIPTION diff --git a/contrib/perl5/lib/File/Find.pm b/contrib/perl5/lib/File/Find.pm index ac73f1b5eb24..3a621c0269db 100644 --- a/contrib/perl5/lib/File/Find.pm +++ b/contrib/perl5/lib/File/Find.pm @@ -42,6 +42,22 @@ Reports the name of a directory only AFTER all its entries have been reported. Entry point finddepth() is a shortcut for specifying C<{ bydepth => 1 }> in the first argument of find(). +=item C<preprocess> + +The value should be a code reference. This code reference is used to +preprocess a directory; it is called after readdir() but before the loop that +calls the wanted() function. It is called with a list of strings and is +expected to return a list of strings. The code can be used to sort the +strings alphabetically, numerically, or to filter out directory entries based +on their name alone. + +=item C<postprocess> + +The value should be a code reference. It is invoked just before leaving the +current directory. It is called in void context with no arguments. The name +of the current directory is in $File::Find::dir. This hook is handy for +summarizing a directory, such as calculating its disk usage. + =item C<follow> Causes symbolic links to be followed. Since directory trees with symbolic @@ -55,7 +71,7 @@ If either I<follow> or I<follow_fast> is in effect: =item * -It is guarantueed that an I<lstat> has been called before the user's +It is guaranteed that an I<lstat> has been called before the user's I<wanted()> function is called. This enables fast file checks involving S< _>. =item * @@ -67,11 +83,10 @@ pathname of the file with all symbolic links resolved =item C<follow_fast> -This is similar to I<follow> except that it may report some files -more than once. It does detect cycles however. -Since only symbolic links have to be hashed, this is -much cheaper both in space and time. -If processing a file more than once (by the user's I<wanted()> function) +This is similar to I<follow> except that it may report some files more +than once. It does detect cycles, however. Since only symbolic links +have to be hashed, this is much cheaper both in space and time. If +processing a file more than once (by the user's I<wanted()> function) is worse than just taking time, the option I<follow> should be used. =item C<follow_skip> @@ -97,14 +112,14 @@ C<$_> will be the same as C<$File::Find::name>. If find is used in taint-mode (-T command line switch or if EUID != UID or if EGID != GID) then internally directory names have to be untainted before they can be cd'ed to. Therefore they are checked against a regular -expression I<untaint_pattern>. Note, that all names passed to the +expression I<untaint_pattern>. Note that all names passed to the user's I<wanted()> function are still tainted. =item C<untaint_pattern> See above. This should be set using the C<qr> quoting operator. The default is set to C<qr|^([-+@\w./]+)$|>. -Note that the paranthesis which are vital. +Note that the parantheses are vital. =item C<untaint_skip> @@ -116,15 +131,15 @@ are skipped. The default is to 'die' in such a case. The wanted() function does whatever verifications you want. C<$File::Find::dir> contains the current directory name, and C<$_> the current filename within that directory. C<$File::Find::name> contains -the complete pathname to the file. You are chdir()'d to C<$File::Find::dir> when -the function is called, unless C<no_chdir> was specified. -When <follow> or <follow_fast> are in effect there is also a -C<$File::Find::fullname>. -The function may set C<$File::Find::prune> to prune the tree -unless C<bydepth> was specified. -Unless C<follow> or C<follow_fast> is specified, for compatibility -reasons (find.pl, find2perl) there are in addition the following globals -available: C<$File::Find::topdir>, C<$File::Find::topdev>, C<$File::Find::topino>, +the complete pathname to the file. You are chdir()'d to +C<$File::Find::dir> when the function is called, unless C<no_chdir> +was specified. When <follow> or <follow_fast> are in effect, there is +also a C<$File::Find::fullname>. The function may set +C<$File::Find::prune> to prune the tree unless C<bydepth> was +specified. Unless C<follow> or C<follow_fast> is specified, for +compatibility reasons (find.pl, find2perl) there are in addition the +following globals available: C<$File::Find::topdir>, +C<$File::Find::topdev>, C<$File::Find::topino>, C<$File::Find::topmode> and C<$File::Find::topnlink>. This library is useful for the C<find2perl> tool, which when fed, @@ -161,7 +176,7 @@ module. =head1 CAVEAT -Be aware that the option to follow symblic links can be dangerous. +Be aware that the option to follow symbolic links can be dangerous. Depending on the structure of the directory tree (including symbolic links to directories) you might traverse a given (physical) directory more than once (only if C<follow_fast> is in effect). @@ -183,7 +198,8 @@ require File::Basename; my %SLnkSeen; my ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow, - $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat); + $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat, + $pre_process, $post_process); sub contract_name { my ($cdir,$fn) = @_; @@ -282,6 +298,8 @@ sub _find_opt { my $cwd_untainted = $cwd; $wanted_callback = $wanted->{wanted}; $bydepth = $wanted->{bydepth}; + $pre_process = $wanted->{preprocess}; + $post_process = $wanted->{postprocess}; $no_chdir = $wanted->{no_chdir}; $full_check = $wanted->{follow}; $follow = $full_check || $wanted->{follow_fast}; @@ -373,7 +391,7 @@ sub _find_opt { $name = $abs_dir . $_; - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" } @@ -429,7 +447,7 @@ sub _find_dir($$$) { $_= ($no_chdir ? $dir_name : $dir_rel ); # prune may happen here $prune= 0; - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" next if $prune; } @@ -464,6 +482,8 @@ sub _find_dir($$$) { } @filenames = readdir DIR; closedir(DIR); + @filenames = &$pre_process(@filenames) if $pre_process; + push @Stack,[$CdLvl,$dir_name,"",-2] if $post_process; if ($nlink == 2 && !$avoid_nlink) { # This dir has no subdirectories. @@ -472,7 +492,7 @@ sub _find_dir($$$) { $name = $dir_pref . $FN; $_ = ($no_chdir ? $name : $FN); - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" } } @@ -496,13 +516,13 @@ sub _find_dir($$$) { else { $name = $dir_pref . $FN; $_= ($no_chdir ? $name : $FN); - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" } } else { $name = $dir_pref . $FN; $_= ($no_chdir ? $name : $FN); - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" } } } @@ -518,7 +538,11 @@ sub _find_dir($$$) { } $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel"); $dir_pref = "$dir_name/"; - if ( $nlink < 0 ) { # must be finddepth, report dirname now + if ( $nlink == -2 ) { + $name = $dir = $p_dir; + $_ = "."; + &$post_process; # End-of-directory processing + } elsif ( $nlink < 0 ) { # must be finddepth, report dirname now $name = $dir_name; if ( substr($name,-2) eq '/.' ) { $name =~ s|/\.$||; @@ -528,7 +552,7 @@ sub _find_dir($$$) { if ( substr($_,-2) eq '/.' ) { s|/\.$||; } - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" } else { push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth; last; @@ -584,13 +608,25 @@ sub _find_dir_symlnk($$$) { while (defined $SE) { unless ($bydepth) { + # change to parent directory + unless ($no_chdir) { + my $udir = $pdir_loc; + if ($untaint) { + $udir = $1 if $pdir_loc =~ m|$untaint_pat|; + } + unless (chdir $udir) { + warn "Can't cd to $udir: $!\n"; + next; + } + } $dir= $p_dir; $name= $dir_name; $_= ($no_chdir ? $dir_name : $dir_rel ); $fullname= $dir_loc; # prune may happen here $prune= 0; - &$wanted_callback; + lstat($_); # make sure file tests with '_' work + { &$wanted_callback }; # protect against wild "next" next if $prune; } @@ -640,7 +676,7 @@ sub _find_dir_symlnk($$$) { $fullname = $new_loc; $name = $dir_pref . $FN; $_ = ($no_chdir ? $name : $FN); - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" } } @@ -673,7 +709,8 @@ sub _find_dir_symlnk($$$) { s|/\.$||; } - &$wanted_callback; + lstat($_); # make sure file tests with '_' work + { &$wanted_callback }; # protect against wild "next" } else { push @Stack,[$dir_loc, $pdir_loc, $p_dir, $dir_rel,-1] if $bydepth; last; @@ -721,7 +758,8 @@ if ($^O eq 'VMS') { } $File::Find::dont_use_nlink = 1 - if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32'; + if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32' || + $^O eq 'cygwin' || $^O eq 'epoc'; # Set dont_use_nlink in your hint file if your system's stat doesn't # report the number of links in a directory as an indication diff --git a/contrib/perl5/lib/File/Path.pm b/contrib/perl5/lib/File/Path.pm index 46f360a46159..0eb6128afe6a 100644 --- a/contrib/perl5/lib/File/Path.pm +++ b/contrib/perl5/lib/File/Path.pm @@ -97,38 +97,42 @@ use File::Basename (); use Exporter (); use strict; -our $VERSION = "1.0403"; +our $VERSION = "1.0404"; our @ISA = qw( Exporter ); our @EXPORT = qw( mkpath rmtree ); my $Is_VMS = $^O eq 'VMS'; +my $Is_MacOS = $^O eq 'MacOS'; # These OSes complain if you want to remove a file that you have no # write permission to: -my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' - || $^O eq 'amigaos'); +my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' || + $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc'); sub mkpath { my($paths, $verbose, $mode) = @_; # $paths -- either a path string or ref to list of paths # $verbose -- optional print "mkdir $path" for each directory created # $mode -- optional permissions, defaults to 0777 - local($")="/"; + local($")=$Is_MacOS ? ":" : "/"; $mode = 0777 unless defined($mode); $paths = [$paths] unless ref $paths; my(@created,$path); foreach $path (@$paths) { $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT - next if -d $path; # Logic wants Unix paths, so go with the flow. - $path = VMS::Filespec::unixify($path) if $Is_VMS; - my $parent = File::Basename::dirname($path); - # Allow for creation of new logical filesystems under VMS - if (not $Is_VMS or $parent !~ m:/[^/]+/000000/?:) { - unless (-d $parent or $path eq $parent) { - push(@created,mkpath($parent, $verbose, $mode)); + if ($Is_VMS) { + next if $path eq '/'; + $path = VMS::Filespec::unixify($path); + if ($path =~ m:^(/[^/]+)/?\z:) { + $path = $1.'/000000'; } } + next if -d $path; + my $parent = File::Basename::dirname($path); + unless (-d $parent or $path eq $parent) { + push(@created,mkpath($parent, $verbose, $mode)); + } print "mkdir $path\n" if $verbose; unless (mkdir($path,$mode)) { my $e = $!; @@ -157,7 +161,12 @@ sub rmtree { my($root); foreach $root (@{$roots}) { - $root =~ s#/\z##; + if ($Is_MacOS) { + $root = ":$root" if $root !~ /:/; + $root =~ s#([^:])\z#$1:#; + } else { + $root =~ s#/\z##; + } (undef, undef, my $rp) = lstat $root or next; $rp &= 07777; # don't forget setuid, setgid, sticky bits if ( -d _ ) { @@ -182,7 +191,11 @@ sub rmtree { # is faster if done in reverse ASCIIbetical order @files = reverse @files if $Is_VMS; ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS; - @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files); + if ($Is_MacOS) { + @files = map("$root$_", @files); + } else { + @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files); + } $count += rmtree(\@files,$verbose,$safe); if ($safe && ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { diff --git a/contrib/perl5/lib/File/Spec.pm b/contrib/perl5/lib/File/Spec.pm index 40f5345140c7..3f79d74b66ac 100644 --- a/contrib/perl5/lib/File/Spec.pm +++ b/contrib/perl5/lib/File/Spec.pm @@ -3,12 +3,13 @@ package File::Spec; use strict; use vars qw(@ISA $VERSION); -$VERSION = '0.8'; +$VERSION = 0.82 ; my %module = (MacOS => 'Mac', MSWin32 => 'Win32', os2 => 'OS2', - VMS => 'VMS'); + VMS => 'VMS', + epoc => 'Epoc'); my $module = $module{$^O} || 'Unix'; require "File/Spec/$module.pm"; diff --git a/contrib/perl5/lib/File/Spec/Functions.pm b/contrib/perl5/lib/File/Spec/Functions.pm index 140738f44398..0036ac1ded00 100644 --- a/contrib/perl5/lib/File/Spec/Functions.pm +++ b/contrib/perl5/lib/File/Spec/Functions.pm @@ -3,7 +3,9 @@ package File::Spec::Functions; use File::Spec; use strict; -use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); +use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); + +$VERSION = '1.1'; require Exporter; diff --git a/contrib/perl5/lib/File/Spec/Mac.pm b/contrib/perl5/lib/File/Spec/Mac.pm index 959e33d0cf3b..9ef55ec84ad8 100644 --- a/contrib/perl5/lib/File/Spec/Mac.pm +++ b/contrib/perl5/lib/File/Spec/Mac.pm @@ -1,8 +1,11 @@ package File::Spec::Mac; use strict; -use vars qw(@ISA); +use vars qw(@ISA $VERSION); require File::Spec::Unix; + +$VERSION = '1.2'; + @ISA = qw(File::Spec::Unix); =head1 NAME @@ -79,9 +82,9 @@ sub catdir { shift; my @args = @_; my $result = shift @args; - $result =~ s/:\z//; + $result =~ s/:\Z(?!\n)//; foreach (@args) { - s/:\z//; + s/:\Z(?!\n)//; s/^://s; $result .= ":$_"; } @@ -150,7 +153,7 @@ sub rootdir { require Mac::Files; my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, &Mac::Files::kSystemFolderType); - $system =~ s/:.*\z/:/s; + $system =~ s/:.*\Z(?!\n)/:/s; return $system; } @@ -189,12 +192,16 @@ folder named "HD" in the current working directory on a drive named "HD"), relative wins. Use ":" in the appropriate place in the path if you want to distinguish unambiguously. +As a special case, the file name '' is always considered to be absolute. + =cut sub file_name_is_absolute { my ($self,$file) = @_; if ($file =~ /:/) { return ($file !~ m/^:/s); + } elsif ( $file eq '' ) { + return 1 ; } else { return (! -e ":$file"); } @@ -228,7 +235,7 @@ sub splitpath { my ($volume,$directory,$file) = ('','',''); if ( $nofile ) { - ( $volume, $directory ) = $path =~ m@((?:[^:]+(?::|\z))?)(.*)@s; + ( $volume, $directory ) = $path =~ m@((?:[^:]+(?::|\Z(?!\n)))?)(.*)@s; } else { $path =~ @@ -242,8 +249,8 @@ sub splitpath { } # Make sure non-empty volumes and directories end in ':' - $volume .= ':' if $volume =~ m@[^:]\z@ ; - $directory .= ':' if $directory =~ m@[^:]\z@ ; + $volume .= ':' if $volume =~ m@[^:]\Z(?!\n)@ ; + $directory .= ':' if $directory =~ m@[^:]\Z(?!\n)@ ; return ($volume,$directory,$file); } @@ -259,7 +266,7 @@ sub splitdir { # check to be sure that there will not be any before handling the # simple case. # - if ( $directories !~ m@:\z@ ) { + if ( $directories !~ m@:\Z(?!\n)@ ) { return split( m@:@, $directories ); } else { @@ -286,11 +293,11 @@ sub catpath { my $segment ; for $segment ( @_ ) { - if ( $result =~ m@[^/]\z@ && $segment =~ m@^[^/]@s ) { + if ( $result =~ m@[^/]\Z(?!\n)@ && $segment =~ m@^[^/]@s ) { $result .= "/$segment" ; } - elsif ( $result =~ m@/\z@ && $segment =~ m@^/@s ) { - $result =~ s@/+\z@/@; + elsif ( $result =~ m@/\Z(?!\n)@ && $segment =~ m@^/@s ) { + $result =~ s@/+\Z(?!\n)@/@; $segment =~ s@^/+@@s; $result .= "$segment" ; } @@ -304,6 +311,12 @@ sub catpath { =item abs2rel +See L<File::Spec::Unix/abs2rel> for general documentation. + +Unlike C<File::Spec::Unix->abs2rel()>, this function will make +checks against the local filesystem if necessary. See +L</file_name_is_absolute> for details. + =cut sub abs2rel { @@ -341,31 +354,15 @@ sub abs2rel { =item rel2abs -Converts a relative path to an absolute path. - - $abs_path = File::Spec->rel2abs( $destination ) ; - $abs_path = File::Spec->rel2abs( $destination, $base ) ; - -If $base is not present or '', then L<cwd()> is used. If $base is relative, -then it is converted to absolute form using L</rel2abs()>. This means that it -is taken to be relative to L<cwd()>. - -On systems with the concept of a volume, this assumes that both paths -are on the $base volume, and ignores the $destination volume. - -On systems that have a grammar that indicates filenames, this ignores the -$base filename as well. Otherwise all path components are assumed to be -directories. - -If $path is absolute, it is cleaned up and returned using L</canonpath()>. - -Based on code written by Shigio Yamaguchi. +See L<File::Spec::Unix/rel2abs> for general documentation. -No checks against the filesystem are made. +Unlike C<File::Spec::Unix->rel2abs()>, this function will make +checks against the local filesystem if necessary. See +L</file_name_is_absolute> for details. =cut -sub rel2abs($;$;) { +sub rel2abs { my ($self,$path,$base ) = @_; if ( ! $self->file_name_is_absolute( $path ) ) { diff --git a/contrib/perl5/lib/File/Spec/OS2.pm b/contrib/perl5/lib/File/Spec/OS2.pm index 33370f06c195..20bf8c9dcefb 100644 --- a/contrib/perl5/lib/File/Spec/OS2.pm +++ b/contrib/perl5/lib/File/Spec/OS2.pm @@ -1,8 +1,11 @@ package File::Spec::OS2; use strict; -use vars qw(@ISA); +use vars qw(@ISA $VERSION); require File::Spec::Unix; + +$VERSION = '1.1'; + @ISA = qw(File::Spec::Unix); sub devnull { diff --git a/contrib/perl5/lib/File/Spec/Unix.pm b/contrib/perl5/lib/File/Spec/Unix.pm index 2305b75b761f..a81c533235f2 100644 --- a/contrib/perl5/lib/File/Spec/Unix.pm +++ b/contrib/perl5/lib/File/Spec/Unix.pm @@ -1,6 +1,9 @@ package File::Spec::Unix; use strict; +use vars qw($VERSION); + +$VERSION = '1.2'; use Cwd; @@ -35,7 +38,7 @@ sub canonpath { $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 + $path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx return $path; } @@ -146,7 +149,7 @@ directory. (Does not strip symlinks, only '.', '..', and equivalents.) sub no_upwards { my $self = shift; - return grep(!/^\.{1,2}\z/s, @_); + return grep(!/^\.{1,2}\Z(?!\n)/s, @_); } =item case_tolerant @@ -162,7 +165,12 @@ sub case_tolerant { =item file_name_is_absolute -Takes as argument a path and returns true, if it is an absolute path. +Takes as argument a path and returns true if it is an absolute path. + +This does not consult the local filesystem on Unix, Win32, or OS/2. It +does sometimes on MacOS (see L<File::Spec::MacOS/file_name_is_absolute>). +It does consult the working environment for VMS (see +L<File::Spec::VMS/file_name_is_absolute>). =cut @@ -223,7 +231,7 @@ sub splitpath { $directory = $path; } else { - $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs; + $path =~ m|^ ( (?: .* / (?: \.\.?\Z(?!\n) )? )? ) ([^/]*) |xs; $directory = $1; $file = $2; } @@ -263,7 +271,7 @@ sub splitdir { # check to be sure that there will not be any before handling the # simple case. # - if ( $directories !~ m|/\z| ) { + if ( $directories !~ m|/\Z(?!\n)| ) { return split( m|/|, $directories ); } else { @@ -308,8 +316,8 @@ sub catpath { Takes a destination path and an optional base path returns a relative path from the base path to the destination path: - $rel_path = File::Spec->abs2rel( $destination ) ; - $rel_path = File::Spec->abs2rel( $destination, $base ) ; + $rel_path = File::Spec->abs2rel( $path ) ; + $rel_path = File::Spec->abs2rel( $path, $base ) ; If $base is not present or '', then L<cwd()> is used. If $base is relative, then it is converted to absolute form using L</rel2abs()>. This means that it @@ -325,9 +333,13 @@ directories. If $path is relative, it is converted to absolute form using L</rel2abs()>. This means that it is taken to be relative to L<cwd()>. -Based on code written by Shigio Yamaguchi. +No checks against the filesystem are made on most systems. On MacOS, +the filesystem may be consulted (see +L<File::Spec::MacOS/file_name_is_absolute>). On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. -No checks against the filesystem are made. +Based on code written by Shigio Yamaguchi. =cut @@ -385,15 +397,15 @@ sub abs2rel { Converts a relative path to an absolute path. - $abs_path = File::Spec->rel2abs( $destination ) ; - $abs_path = File::Spec->rel2abs( $destination, $base ) ; + $abs_path = File::Spec->rel2abs( $path ) ; + $abs_path = File::Spec->rel2abs( $path, $base ) ; If $base is not present or '', then L<cwd()> is used. If $base is relative, then it is converted to absolute form using L</rel2abs()>. This means that it is taken to be relative to L<cwd()>. On systems with the concept of a volume, this assumes that both paths -are on the $base volume, and ignores the $destination volume. +are on the $base volume, and ignores the $path volume. On systems that have a grammar that indicates filenames, this ignores the $base filename as well. Otherwise all path components are assumed to be @@ -401,13 +413,17 @@ directories. If $path is absolute, it is cleaned up and returned using L</canonpath()>. -Based on code written by Shigio Yamaguchi. +No checks against the filesystem are made on most systems. On MacOS, +the filesystem may be consulted (see +L<File::Spec::MacOS/file_name_is_absolute>). On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. -No checks against the filesystem are made. +Based on code written by Shigio Yamaguchi. =cut -sub rel2abs($;$;) { +sub rel2abs { my ($self,$path,$base ) = @_; # Clean up $path diff --git a/contrib/perl5/lib/File/Spec/VMS.pm b/contrib/perl5/lib/File/Spec/VMS.pm index a2ac8cac0bb5..60b0ec8e50dc 100644 --- a/contrib/perl5/lib/File/Spec/VMS.pm +++ b/contrib/perl5/lib/File/Spec/VMS.pm @@ -1,8 +1,11 @@ package File::Spec::VMS; use strict; -use vars qw(@ISA); +use vars qw(@ISA $VERSION); require File::Spec::Unix; + +$VERSION = '1.1'; + @ISA = qw(File::Spec::Unix); use Cwd; @@ -37,6 +40,11 @@ sub eliminate_macros { my($self,$path) = @_; return '' unless $path; $self = {} unless ref $self; + + if ($path =~ /\s/) { + return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path; + } + my($npath) = unixify($path); my($complex) = 0; my($head,$macro,$tail); @@ -56,7 +64,7 @@ sub eliminate_macros { $complex = 1; } } - else { ($macro = unixify($self->{$macro})) =~ s#/\z##; } + else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; } $npath = "$head$macro$tail"; } } @@ -86,8 +94,14 @@ sub fixpath { $self = bless {} unless ref $self; my($fixedpath,$prefix,$name); - if ($path =~ m#^\$\([^\)]+\)\z#s || $path =~ m#[/:>\]]#) { - if ($force_path or $path =~ /(?:DIR\)|\])\z/) { + if ($path =~ /\s/) { + return join ' ', + map { $self->fixpath($_,$force_path) } + split /\s+/, $path; + } + + if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { + if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) { $fixedpath = vmspath($self->eliminate_macros($path)); } else { @@ -97,7 +111,7 @@ sub fixpath { elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) { my($vmspre) = $self->eliminate_macros("\$($prefix)"); # is it a dir or just a name? - $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\z/) ? vmspath($vmspre) : ''; + $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : ''; $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; $fixedpath = vmspath($fixedpath) if $force_path; } @@ -136,7 +150,7 @@ sub canonpath { my($self,$path) = @_; if ($path =~ m|/|) { # Fake Unix - my $pathify = $path =~ m|/\z|; + my $pathify = $path =~ m|/\Z(?!\n)|; $path = $self->SUPER::canonpath($path); if ($pathify) { return vmspath($path); } else { return vmsify($path); } @@ -169,8 +183,8 @@ sub catdir { if (@dirs) { my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); my ($spath,$sdir) = ($path,$dir); - $spath =~ s/\.dir\z//; $sdir =~ s/\.dir\z//; - $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\z/s; + $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//; + $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s; $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); # Special case for VMS absolute directory specs: these will have had device @@ -181,7 +195,7 @@ sub catdir { } else { if (not defined $dir or not length $dir) { $rslt = ''; } - elsif ($dir =~ /^\$\([^\)]+\)\z/s) { $rslt = $dir; } + elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { $rslt = $dir; } else { $rslt = vmspath($dir); } } return $self->canonpath($rslt); @@ -202,8 +216,8 @@ sub catfile { if (@files) { my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); my $spath = $path; - $spath =~ s/\.dir\z//; - if ($spath =~ /^[^\)\]\/:>]+\)\z/s && basename($file) eq $file) { + $spath =~ s/\.dir\Z(?!\n)//; + if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) { $rslt = "$spath$file"; } else { @@ -251,7 +265,7 @@ sub rootdir { Returns a string representation of the first writable directory from the following list or '' if none are writable: - sys$scratch + sys$scratch: $ENV{TMPDIR} =cut @@ -259,7 +273,7 @@ from the following list or '' if none are writable: my $tmpdir; sub tmpdir { return $tmpdir if defined $tmpdir; - foreach ('sys$scratch', $ENV{TMPDIR}) { + foreach ('sys$scratch:', $ENV{TMPDIR}) { next unless defined && -d && -w _; $tmpdir = $_; last; @@ -310,7 +324,7 @@ Checks for VMS directory spec as well as Unix separators. sub file_name_is_absolute { my ($self,$file) = @_; # If it's a logical name, expand it. - $file = $ENV{$file} while $file =~ /^[\w\$\-]+\z/s && $ENV{$file}; + $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file}; return scalar($file =~ m!^/!s || $file =~ m![<\[][^.\-\]>]! || $file =~ /:[^<\[]/); @@ -341,7 +355,7 @@ sub splitdir { $dirspec =~ s/\]\[//g; $dirspec =~ s/\-\-/-.-/g; $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal my(@dirs) = split('\.', vmspath($dirspec)); - $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\z//s; + $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s; @dirs; } @@ -355,7 +369,7 @@ Construct a complete filespec using VMS syntax sub catpath { my($self,$dev,$dir,$file) = @_; if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; } - else { $dev .= ':' unless $dev eq '' or $dev =~ /:\z/; } + else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; } if (length($dev) or length($dir)) { $dir = "[$dir]" unless $dir =~ /[\[<\/]/; $dir = vmspath($dir); @@ -400,17 +414,16 @@ sub abs2rel { } # Split up paths - my ( undef, $path_directories, $path_file ) = - $self->splitpath( $path, 1 ) ; + my ( $path_directories, $path_file ) = + ($self->splitpath( $path, 1 ))[1,2] ; $path_directories = $1 - if $path_directories =~ /^\[(.*)\]\z/s ; + if $path_directories =~ /^\[(.*)\]\Z(?!\n)/s ; - my ( undef, $base_directories, undef ) = - $self->splitpath( $base, 1 ) ; + my $base_directories = ($self->splitpath( $base, 1 ))[1] ; $base_directories = $1 - if $base_directories =~ /^\[(.*)\]\z/s ; + if $base_directories =~ /^\[(.*)\]\Z(?!\n)/s ; # Now, remove all leading components that are the same my @pathchunks = $self->splitdir( $path_directories ); @@ -427,7 +440,7 @@ sub abs2rel { # @basechunks now contains the directories to climb out of, # @pathchunks now has the directories to descend in to. $path_directories = '-.' x @basechunks . join( '.', @pathchunks ) ; - $path_directories =~ s{\.\z}{} ; + $path_directories =~ s{\.\Z(?!\n)}{} ; return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ; } @@ -438,7 +451,7 @@ Use VMS syntax when converting filespecs. =cut -sub rel2abs($;$;) { +sub rel2abs { my $self = shift ; return vmspath(File::Spec::Unix::rel2abs( $self, @_ )) if ( join( '', @_ ) =~ m{/} ) ; @@ -458,17 +471,17 @@ sub rel2abs($;$;) { } # Split up paths - my ( undef, $path_directories, $path_file ) = - $self->splitpath( $path ) ; + my ( $path_directories, $path_file ) = + ($self->splitpath( $path ))[1,2] ; - my ( $base_volume, $base_directories, undef ) = + my ( $base_volume, $base_directories ) = $self->splitpath( $base ) ; $path_directories = '' if $path_directories eq '[]' || $path_directories eq '<>'; my $sep = '' ; $sep = '.' - if ( $base_directories =~ m{[^.\]>]\z} && + if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} && $path_directories =~ m{^[^.\[<]}s ) ; $base_directories = "$base_directories$sep$path_directories"; diff --git a/contrib/perl5/lib/File/Spec/Win32.pm b/contrib/perl5/lib/File/Spec/Win32.pm index aa95fbde363e..3c019853f112 100644 --- a/contrib/perl5/lib/File/Spec/Win32.pm +++ b/contrib/perl5/lib/File/Spec/Win32.pm @@ -2,8 +2,11 @@ package File::Spec::Win32; use strict; use Cwd; -use vars qw(@ISA); +use vars qw(@ISA $VERSION); require File::Spec::Unix; + +$VERSION = '1.2'; + @ISA = qw(File::Spec::Unix); =head1 NAME @@ -40,6 +43,7 @@ from the following list: $ENV{TMPDIR} $ENV{TEMP} $ENV{TMP} + C:/temp /tmp / @@ -49,7 +53,7 @@ my $tmpdir; sub tmpdir { return $tmpdir if defined $tmpdir; my $self = shift; - foreach (@ENV{qw(TMPDIR TEMP TMP)}, qw(/tmp /)) { + foreach (@ENV{qw(TMPDIR TEMP TMP)}, qw(C:/temp /tmp /)) { next unless defined && -d; $tmpdir = $_; last; @@ -105,8 +109,8 @@ sub canonpath { $path =~ s|([^\\])\\+|$1\\|g; # xx////xx -> xx/xx $path =~ s|(\\\.)+\\|\\|g; # xx/././xx -> xx/xx $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # ./xx -> xx - $path =~ s|\\\z|| - unless $path =~ m#^([A-Z]:)?\\\z#s; # xx/ -> xx + $path =~ s|\\\Z(?!\n)|| + unless $path =~ m#^([A-Z]:)?\\\Z(?!\n)#s; # xx/ -> xx return $path; } @@ -146,7 +150,7 @@ sub splitpath { (?:\\\\|//)[^\\/]+[\\/][^\\/]+ )? ) - ( (?:.*[\\\\/](?:\.\.?\z)?)? ) + ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? ) (.*) }xs; $volume = $1; @@ -187,7 +191,7 @@ sub splitdir { # check to be sure that there will not be any before handling the # simple case. # - if ( $directories !~ m|[\\/]\z| ) { + if ( $directories !~ m|[\\/]\Z(?!\n)| ) { return split( m|[\\/]|, $directories ); } else { @@ -216,7 +220,7 @@ sub catpath { # 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 && + if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s && $directory =~ m@^[^\\/]@s ) ; @@ -224,8 +228,8 @@ sub catpath { # 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@ && + if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s && + $volume =~ m@[^\\/]\Z(?!\n)@ && $file =~ m@[^\\/]@ ) { $volume =~ m@([\\/])@ ; @@ -239,34 +243,6 @@ sub catpath { } -=item abs2rel - -Takes a destination path and an optional base path returns a relative path -from the base path to the destination path: - - $rel_path = File::Spec->abs2rel( $destination ) ; - $rel_path = File::Spec->abs2rel( $destination, $base ) ; - -If $base is not present or '', then L</cwd()> is used. If $base is relative, -then it is converted to absolute form using L</rel2abs()>. This means that it -is taken to be relative to L<cwd()>. - -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</rel2abs()>. -This means that it is taken to be relative to L</cwd()>. - -Based on code written by Shigio Yamaguchi. - -No checks against the filesystem are made. - -=cut - sub abs2rel { my($self,$path,$base) = @_; @@ -293,8 +269,7 @@ sub abs2rel { my ( $path_volume, $path_directories, $path_file ) = $self->splitpath( $path, 1 ) ; - my ( undef, $base_directories, undef ) = - $self->splitpath( $base, 1 ) ; + my $base_directories = ($self->splitpath( $base, 1 ))[1] ; # Now, remove all leading components that are the same my @pathchunks = $self->splitdir( $path_directories ); @@ -337,33 +312,8 @@ sub abs2rel { ) ; } -=item rel2abs - -Converts a relative path to an absolute path. - - $abs_path = File::Spec->rel2abs( $destination ) ; - $abs_path = File::Spec->rel2abs( $destination, $base ) ; - -If $base is not present or '', then L<cwd()> is used. If $base is relative, -then it is converted to absolute form using L</rel2abs()>. This means that it -is taken to be relative to L</cwd()>. - -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</canonpath()>. - -Based on code written by Shigio Yamaguchi. - -No checks against the filesystem are made. - -=cut -sub rel2abs($;$;) { +sub rel2abs { my ($self,$path,$base ) = @_; if ( ! $self->file_name_is_absolute( $path ) ) { @@ -378,10 +328,10 @@ sub rel2abs($;$;) { $base = $self->canonpath( $base ) ; } - my ( undef, $path_directories, $path_file ) = - $self->splitpath( $path, 1 ) ; + my ( $path_directories, $path_file ) = + ($self->splitpath( $path, 1 ))[1,2] ; - my ( $base_volume, $base_directories, undef ) = + my ( $base_volume, $base_directories ) = $self->splitpath( $base, 1 ) ; $path = $self->catpath( diff --git a/contrib/perl5/lib/FileHandle.pm b/contrib/perl5/lib/FileHandle.pm index 34c3475d9c41..5eb3a89adcd7 100644 --- a/contrib/perl5/lib/FileHandle.pm +++ b/contrib/perl5/lib/FileHandle.pm @@ -238,12 +238,12 @@ See L<perlfunc/printf>. =item $fh->getline This works like <$fh> described in L<perlop/"I/O Operators"> -except that it's more readable and can be safely called in an -array context but still returns just one line. +except that it's more readable and can be safely called in a +list context but still returns just one line. =item $fh->getlines -This works like <$fh> when called in an array context to +This works like <$fh> when called in a list context to read all the remaining lines in a file, except that it's more readable. It will also croak() if accidentally called in a scalar context. diff --git a/contrib/perl5/lib/Getopt/Long.pm b/contrib/perl5/lib/Getopt/Long.pm index f474c7c4a978..472527d4a7b9 100644 --- a/contrib/perl5/lib/Getopt/Long.pm +++ b/contrib/perl5/lib/Getopt/Long.pm @@ -2,17 +2,17 @@ package Getopt::Long; -# RCS Status : $Id: GetoptLong.pl,v 2.24 2000-03-14 21:28:52+01 jv Exp $ +# RCS Status : $Id: GetoptLong.pl,v 2.26 2001-01-31 10:20:29+01 jv Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Tue Mar 14 21:28:40 2000 -# Update Count : 721 +# 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.23"; +use vars qw($VERSION $VERSION_STRING); +$VERSION = 2.25; +$VERSION_STRING = "2.25"; + +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. @@ -52,7 +57,7 @@ use vars qw($error $debug $major_version $minor_version); use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order $passthrough); # Official invisible variables. -use vars qw($genprefix $caller); +use vars qw($genprefix $caller $gnu_compat); # Public subroutines. sub Configure (@); @@ -89,6 +94,27 @@ sub ConfigDefaults () { $error = 0; # error tally $ignorecase = 1; # ignore case when matching options $passthrough = 0; # leave unrecognized options alone + $gnu_compat = 0; # require --opt=val if value is optional +} + +# Override import. +sub import { + my $pkg = shift; # package + my @syms = (); # symbols to import + my @config = (); # configuration + my $dest = \@syms; # symbols first + for ( @_ ) { + if ( $_ eq ':config' ) { + $dest = \@config; # config next + next; + } + push (@$dest, $_); # push + } + # Hide one level and call super. + local $Exporter::ExportLevel = 1; + $pkg->SUPER::import(@syms); + # And configure. + Configure (@config) if @config; } ################ Initialization ################ @@ -100,6 +126,87 @@ sub ConfigDefaults () { ConfigDefaults(); +################ OO Interface ################ + +package Getopt::Long::Parser; + +# NOTE: The object oriented routines use $error for thread locking. +my $_lock = sub { + lock ($Getopt::Long::error) if $] >= 5.005 +}; + +# Store a copy of the default configuration. Since ConfigDefaults has +# just been called, what we get from Configure is the default. +my $default_config = do { + &$_lock; + Getopt::Long::Configure () +}; + +sub new { + my $that = shift; + my $class = ref($that) || $that; + my %atts = @_; + + # Register the callers package. + my $self = { caller_pkg => (caller)[0] }; + + bless ($self, $class); + + # Process config attributes. + if ( defined $atts{config} ) { + &$_lock; + my $save = Getopt::Long::Configure ($default_config, @{$atts{config}}); + $self->{settings} = Getopt::Long::Configure ($save); + delete ($atts{config}); + } + # Else use default config. + else { + $self->{settings} = $default_config; + } + + if ( %atts ) { # Oops + Getopt::Long::Croak(__PACKAGE__.": unhandled attributes: ". + join(" ", sort(keys(%atts)))); + } + + $self; +} + +sub configure { + my ($self) = shift; + + &$_lock; + + # Restore settings, merge new settings in. + my $save = Getopt::Long::Configure ($self->{settings}, @_); + + # Restore orig config and save the new config. + $self->{settings} = Configure ($save); +} + +sub getoptions { + my ($self) = shift; + + &$_lock; + + # Restore config settings. + my $save = Getopt::Long::Configure ($self->{settings}); + + # Call main routine. + my $ret = 0; + $Getopt::Long::caller = $self->{caller_pkg}; + eval { $ret = Getopt::Long::GetOptions (@_); }; + + # Restore saved settings. + Getopt::Long::Configure ($save); + + # Handle errors and return value. + die ($@) if $@; + return $ret; +} + +package Getopt::Long; + ################ Package return ################ 1; @@ -108,12 +215,12 @@ __END__ ################ AutoLoading subroutines ################ -# RCS Status : $Id: GetoptLongAl.pl,v 2.27 2000-03-17 09:07:26+01 jv Exp $ +# RCS Status : $Id: GetoptLongAl.pl,v 2.30 2001-01-31 10:21:11+01 jv Exp $ # Author : Johan Vromans # Created On : Fri Mar 27 11:50:30 1998 # Last Modified By: Johan Vromans -# Last Modified On: Fri Mar 17 09:00:09 2000 -# Update Count : 55 +# Last Modified On: Tue Dec 26 18:01:16 2000 +# Update Count : 98 # Status : Released sub GetOptions { @@ -137,13 +244,14 @@ sub GetOptions { print STDERR ("GetOpt::Long $Getopt::Long::VERSION ", "called from package \"$pkg\".", "\n ", - 'GetOptionsAl $Revision: 2.27 $ ', + 'GetOptionsAl $Revision: 2.30 $ ', "\n ", "ARGV: (@ARGV)", "\n ", "autoabbrev=$autoabbrev,". "bundling=$bundling,", "getopt_compat=$getopt_compat,", + "gnu_compat=$gnu_compat,", "order=$order,", "\n ", "ignorecase=$ignorecase,", @@ -200,7 +308,7 @@ sub GetOptions { next; } - # Match option spec. Allow '?' as an alias. + # Match option spec. Allow '?' as an alias only. if ( $opt !~ /^((\w+[-\w]*)(\|(\?|\w[-\w]*)?)*)?([!~+]|[=:][infse][@%]?)?$/ ) { $error .= "Error in option spec: \"$opt\"\n"; next; @@ -208,14 +316,24 @@ sub GetOptions { my ($o, $c, $a) = ($1, $5); $c = '' unless defined $c; + # $linko keeps track of the primary name the user specified. + # This name will be used for the internal or external linkage. + # In other words, if the user specifies "FoO|BaR", it will + # match any case combinations of 'foo' and 'bar', but if a global + # variable needs to be set, it will be $opt_FoO in the exact case + # as specified. + my $linko; + if ( ! defined $o ) { # empty -> '-' option - $opctl{$o = ''} = $c; + $linko = $o = ''; + $opctl{''} = $c; + $bopctl{''} = $c if $bundling; } else { # Handle alias names my @o = split (/\|/, $o); - my $linko = $o = $o[0]; + $linko = $o = $o[0]; # Force an alias if the option name is not locase. $a = $o unless $o eq lc($o); $o = lc ($o) @@ -254,18 +372,18 @@ sub GetOptions { $a = $_; } } - $o = $linko; } # If no linkage is supplied in the @optionlist, copy it from # the userlinkage if available. if ( defined $userlinkage ) { unless ( @optionlist > 0 && ref($optionlist[0]) ) { - if ( exists $userlinkage->{$o} && ref($userlinkage->{$o}) ) { - print STDERR ("=> found userlinkage for \"$o\": ", - "$userlinkage->{$o}\n") + if ( exists $userlinkage->{$linko} && + ref($userlinkage->{$linko}) ) { + print STDERR ("=> found userlinkage for \"$linko\": ", + "$userlinkage->{$linko}\n") if $debug; - unshift (@optionlist, $userlinkage->{$o}); + unshift (@optionlist, $userlinkage->{$linko}); } else { # Do nothing. Being undefined will be handled later. @@ -276,13 +394,13 @@ sub GetOptions { # Copy the linkage. If omitted, link to global variable. if ( @optionlist > 0 && ref($optionlist[0]) ) { - print STDERR ("=> link \"$o\" to $optionlist[0]\n") + print STDERR ("=> link \"$linko\" to $optionlist[0]\n") if $debug; if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) { - $linkage{$o} = shift (@optionlist); + $linkage{$linko} = shift (@optionlist); } elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) { - $linkage{$o} = shift (@optionlist); + $linkage{$linko} = shift (@optionlist); $opctl{$o} .= '@' if $opctl{$o} ne '' and $opctl{$o} !~ /\@$/; $bopctl{$o} .= '@' @@ -290,7 +408,7 @@ sub GetOptions { $bopctl{$o} ne '' and $bopctl{$o} !~ /\@$/; } elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) { - $linkage{$o} = shift (@optionlist); + $linkage{$linko} = shift (@optionlist); $opctl{$o} .= '%' if $opctl{$o} ne '' and $opctl{$o} !~ /\%$/; $bopctl{$o} .= '%' @@ -304,22 +422,22 @@ sub GetOptions { else { # Link to global $opt_XXX variable. # Make sure a valid perl identifier results. - my $ov = $o; + my $ov = $linko; $ov =~ s/\W/_/g; if ( $c =~ /@/ ) { - print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n") + print STDERR ("=> link \"$linko\" to \@$pkg","::opt_$ov\n") if $debug; - eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;"); + eval ("\$linkage{\$linko} = \\\@".$pkg."::opt_$ov;"); } elsif ( $c =~ /%/ ) { - print STDERR ("=> link \"$o\" to \%$pkg","::opt_$ov\n") + print STDERR ("=> link \"$linko\" to \%$pkg","::opt_$ov\n") if $debug; - eval ("\$linkage{\$o} = \\\%".$pkg."::opt_$ov;"); + eval ("\$linkage{\$linko} = \\\%".$pkg."::opt_$ov;"); } else { - print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n") + print STDERR ("=> link \"$linko\" to \$$pkg","::opt_$ov\n") if $debug; - eval ("\$linkage{\$o} = \\\$".$pkg."::opt_$ov;"); + eval ("\$linkage{\$linko} = \\\$".$pkg."::opt_$ov;"); } } } @@ -382,7 +500,11 @@ sub GetOptions { next unless defined $opt; if ( defined $arg ) { - $opt = $aliases{$opt} if defined $aliases{$opt}; + if ( defined $aliases{$opt} ) { + print STDERR ("=> alias \"$opt\" -> \"$aliases{$opt}\"\n") + if $debug; + $opt = $aliases{$opt}; + } if ( defined $linkage{$opt} ) { print STDERR ("=> ref(\$L{$opt}) -> ", @@ -543,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; @@ -572,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 ", @@ -646,7 +769,7 @@ sub FindOption ($$$$$$$) { } # Apparently valid. $opt = $tryopt; - print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug; + print STDERR ("=> found \"$type\" for \"", $opt, "\"\n") if $debug; #### Determine argument status #### @@ -675,7 +798,16 @@ sub FindOption ($$$$$$$) { ($mand, $type, $dsttype, $key) = $type =~ /^(.)(.)([@%]?)$/; # Check if there is an option argument available. - if ( defined $optarg ? ($optarg eq '') + if ( $gnu_compat ) { + return (1, $opt, $optarg, $dsttype, $incr, $key) + if defined $optarg; + return (1, $opt, $type eq "s" ? '' : 0, $dsttype, $incr, $key) + if $mand eq ':'; + } + + # Check if there is an option argument available. + if ( defined $optarg + ? ($optarg eq '') : !(defined $rest || @ARGV > 0) ) { # Complain if this option needs an argument. if ( $mand eq "=" ) { @@ -684,10 +816,7 @@ sub FindOption ($$$$$$$) { $error++; undef $opt; } - if ( $mand eq ":" ) { - $arg = $type eq "s" ? '' : 0; - } - return (1, $opt,$arg,$dsttype,$incr,$key); + return (1, $opt, $type eq "s" ? '' : 0, $dsttype, $incr, $key); } # Get (possibly optional) argument. @@ -795,12 +924,12 @@ sub Configure (@) { my $prevconfig = [ $error, $debug, $major_version, $minor_version, $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, - $passthrough, $genprefix ]; + $gnu_compat, $passthrough, $genprefix ]; if ( ref($options[0]) eq 'ARRAY' ) { ( $error, $debug, $major_version, $minor_version, $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, - $passthrough, $genprefix ) = @{shift(@options)}; + $gnu_compat, $passthrough, $genprefix ) = @{shift(@options)}; } my $opt; @@ -811,8 +940,13 @@ sub Configure (@) { $action = 0; $try = $+; } - if ( $try eq 'default' or $try eq 'defaults' ) { - ConfigDefaults () if $action; + if ( ($try eq 'default' or $try eq 'defaults') && $action ) { + ConfigDefaults (); + } + elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) { + local $ENV{POSIXLY_CORRECT}; + $ENV{POSIXLY_CORRECT} = 1 if $action; + ConfigDefaults (); } elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) { $autoabbrev = $action; @@ -820,6 +954,17 @@ sub Configure (@) { elsif ( $try eq 'getopt_compat' ) { $getopt_compat = $action; } + elsif ( $try eq 'gnu_getopt' ) { + if ( $action ) { + $gnu_compat = 1; + $bundling = 1; + $getopt_compat = 0; + $permute = 1; + } + } + elsif ( $try eq 'gnu_compat' ) { + $gnu_compat = $action; + } elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) { $ignorecase = $action; } @@ -841,14 +986,14 @@ sub Configure (@) { elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) { $passthrough = $action; } - elsif ( $try =~ /^prefix=(.+)$/ ) { + elsif ( $try =~ /^prefix=(.+)$/ && $action ) { $genprefix = $1; # Turn into regexp. Needs to be parenthesized! $genprefix = "(" . quotemeta($genprefix) . ")"; eval { '' =~ /$genprefix/; }; Croak ("Getopt::Long: invalid pattern \"$genprefix\"") if $@; } - elsif ( $try =~ /^prefix_pattern=(.+)$/ ) { + elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) { $genprefix = $1; # Parenthesize if needed. $genprefix = "(" . $genprefix . ")" @@ -930,7 +1075,7 @@ could use the more descriptive C<--long>. To distinguish between a bundle of single-character options and a long one, two dashes are used to precede the option name. Early implementations of long options used a plus C<+> instead. Also, option values could be specified either -like +like --size=24 @@ -943,7 +1088,7 @@ The C<+> form is now obsolete and strongly deprecated. =head1 Getting Started with Getopt::Long Getopt::Long is the Perl5 successor of C<newgetopt.pl>. This was -the firs Perl module that provided support for handling the new style +the first Perl module that provided support for handling the new style of command line options, hence the name Getopt::Long. This module also supports single-character options and bundling. In this case, the options are restricted to alphabetic characters only, and the @@ -1166,11 +1311,11 @@ requires a least C<--hea> and C<--hei> for the head and height options. =head2 Summary of Option Specifications Each option specifier consists of two parts: the name specification -and the argument specification. +and the argument specification. The name specification contains the name of the option, optionally followed by a list of alternative names separated by vertical bar -characters. +characters. length option name is "length" length|size|l name is "length", aliases are "size" and "l" @@ -1243,6 +1388,24 @@ considered an option on itself. =head1 Advanced Possibilities +=head2 Object oriented interface + +Getopt::Long can be used in an object oriented way as well: + + use Getopt::Long; + $p = new Getopt::Long::Parser; + $p->configure(...configuration options...); + if ($p->getoptions(...options descriptions...)) ... + +Configuration options can be passed to the constructor: + + $p = new Getopt::Long::Parser + config => [...configuration options...]; + +For thread safety, each method call will acquire an exclusive lock to +the Getopt::Long module. So don't call these methods from a callback +routine! + =head2 Documentation and help texts Getopt::Long encourages the use of Pod::Usage to produce help @@ -1365,7 +1528,7 @@ options, -vax -would set C<a>, C<v> and C<x>, but +would set C<a>, C<v> and C<x>, but --vax @@ -1398,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 @@ -1423,8 +1591,8 @@ When applied to the following command line: arg1 --width=72 arg2 --width=60 arg3 -This will call -C<process("arg1")> while C<$width> is C<80>, +This will call +C<process("arg1")> while C<$width> is C<80>, C<process("arg2")> while C<$width> is C<72>, and C<process("arg3")> while C<$width> is C<60>. @@ -1436,10 +1604,15 @@ L<Configuring Getopt::Long>. Getopt::Long can be configured by calling subroutine Getopt::Long::Configure(). This subroutine takes a list of quoted -strings, each specifying a configuration option to be set, e.g. -C<ignore_case>, or reset, e.g. C<no_ignore_case>. Case does not +strings, each specifying a configuration option to be enabled, e.g. +C<ignore_case>, or disabled, e.g. C<no_ignore_case>. Case does not matter. Multiple calls to Configure() are possible. +Alternatively, as of version 2.24, the configuration options may be +passed together with the C<use> statement: + + use Getopt::Long qw(:config no_ignore_case bundling); + The following options are available: =over 12 @@ -1449,34 +1622,53 @@ The following options are available: This option causes all configuration options to be reset to their default values. +=item posix_default + +This option causes all configuration options to be reset to their +default values as if the environment variable POSIXLY_CORRECT had +been set. + =item auto_abbrev Allow option names to be abbreviated to uniqueness. -Default is set unless environment variable -POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is reset. +Default is enabled unless environment variable +POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is disabled. =item getopt_compat Allow C<+> to start options. -Default is set unless environment variable -POSIXLY_CORRECT has been set, in which case C<getopt_compat> is reset. +Default is enabled unless environment variable +POSIXLY_CORRECT has been set, in which case C<getopt_compat> is disabled. + +=item gnu_compat + +C<gnu_compat> controls whether C<--opt=> is allowed, and what it should +do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>, +C<--opt=> will give option C<opt> and empty value. +This is the way GNU getopt_long() does it. + +=item gnu_getopt + +This is a short way of setting C<gnu_compat> C<bundling> C<permute> +C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be +fully compatible with GNU getopt_long(). =item require_order Whether command line arguments are allowed to be mixed with options. -Default is set unless environment variable -POSIXLY_CORRECT has been set, in which case C<require_order> is reset. +Default is disabled unless environment variable +POSIXLY_CORRECT has been set, in which case C<require_order> is enabled. See also C<permute>, which is the opposite of C<require_order>. =item permute Whether command line arguments are allowed to be mixed with options. -Default is set unless environment variable -POSIXLY_CORRECT has been set, in which case C<permute> is reset. +Default is enabled unless environment variable +POSIXLY_CORRECT has been set, in which case C<permute> is disabled. Note that C<permute> is the opposite of C<require_order>. -If C<permute> is set, this means that +If C<permute> is enabled, this means that --foo arg1 --bar arg2 arg3 @@ -1493,7 +1685,7 @@ processed. The only exception is when C<--> is used: will call the call-back routine for arg1 and arg2, and terminate GetOptions() leaving C<"arg2"> in C<@ARGV>. -If C<require_order> is set, options processing +If C<require_order> is enabled, options processing terminates when the first non-option is encountered. --foo arg1 --bar arg2 arg3 @@ -1502,40 +1694,44 @@ is equivalent to --foo -- arg1 --bar arg2 arg3 -=item bundling (default: reset) +If C<pass_through> is also enabled, options processing will terminate +at the first unrecognized option, or non-option, whichever comes +first. + +=item bundling (default: disabled) -Setting this option will allow single-character options to be bundled. +Enabling this option will allow single-character options to be bundled. To distinguish bundles from long option names, long options I<must> be introduced with C<--> and single-character options (and bundles) with C<->. -Note: resetting C<bundling> also resets C<bundling_override>. +Note: disabling C<bundling> also disables C<bundling_override>. -=item bundling_override (default: reset) +=item bundling_override (default: disabled) -If C<bundling_override> is set, bundling is enabled as with -C<bundling> but now long option names override option bundles. +If C<bundling_override> is enabled, bundling is enabled as with +C<bundling> but now long option names override option bundles. -Note: resetting C<bundling_override> also resets C<bundling>. +Note: disabling C<bundling_override> also disables C<bundling>. B<Note:> Using option bundling can easily lead to unexpected results, especially when mixing long options and bundles. Caveat emptor. -=item ignore_case (default: set) +=item ignore_case (default: enabled) -If set, case is ignored when matching long option names. Single +If enabled, case is ignored when matching long option names. Single character options will be treated case-sensitive. -Note: resetting C<ignore_case> also resets C<ignore_case_always>. +Note: disabling C<ignore_case> also disables C<ignore_case_always>. -=item ignore_case_always (default: reset) +=item ignore_case_always (default: disabled) When bundling is in effect, case is ignored on single-character -options also. +options also. -Note: resetting C<ignore_case_always> also resets C<ignore_case>. +Note: disabling C<ignore_case_always> also disables C<ignore_case>. -=item pass_through (default: reset) +=item pass_through (default: disabled) Options that are unknown, ambiguous or supplied with an invalid option value are passed through in C<@ARGV> instead of being flagged as @@ -1543,7 +1739,9 @@ errors. This makes it possible to write wrapper scripts that process only part of the user supplied command line arguments, and pass the remaining options to some other program. -This can be very confusing, especially when C<permute> is also set. +If C<require_order> is enabled, options processing will terminate at +the first unrecognized option, or non-option, whichever comes first. +However, if C<permute> is enabled instead, results can become confusing. =item prefix @@ -1556,9 +1754,9 @@ A Perl pattern that identifies the strings that introduce options. Default is C<(--|-|\+)> unless environment variable POSIXLY_CORRECT has been set, in which case it is C<(--|-)>. -=item debug (default: reset) +=item debug (default: disabled) -Enable copious debugging output. +Enable debugging output. =back @@ -1569,11 +1767,10 @@ signalled using die() and will terminate the calling program unless the call to Getopt::Long::GetOptions() was embedded in C<eval { ... }>, or die() was trapped using C<$SIG{__DIE__}>. -A return value of 1 (true) indicates success. - -A return status of 0 (false) indicates that the function detected one -or more errors during option parsing. These errors are signalled using -warn() and can be trapped with C<$SIG{__WARN__}>. +GetOptions returns true to indicate success. +It returns false when the function detected one or more errors during +option parsing. These errors are signalled using warn() and can be +trapped with C<$SIG{__WARN__}>. Errors that can't happen are signalled using Carp::croak(). @@ -1629,21 +1826,44 @@ Now the command line may look like: Note that to terminate options processing still requires a double dash C<-->. -GetOptions() will not interpret a leading C<"<>"> as option starters -if the next argument is a reference. To force C<"<"> and C<">"> as -option starters, use C<"><">. Confusing? Well, B<using a starter +GetOptions() will not interpret a leading C<< "<>" >> as option starters +if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as +option starters, use C<< "><" >>. Confusing? Well, B<using a starter argument is strongly deprecated> anyway. =head2 Configuration variables Previous versions of Getopt::Long used variables for the purpose of -configuring. Although manipulating these variables still work, it -is strongly encouraged to use the new C<config> routine. Besides, it -is much easier. +configuring. Although manipulating these variables still work, it is +strongly encouraged to use the C<Configure> routine that was introduced +in version 2.17. Besides, it is much easier. + +=head1 Trouble Shooting + +=head2 Warning: Ignoring '!' modifier for short option + +This warning is issued when the '!' modifier is applied to a short +(one-character) option and bundling is in effect. E.g., + + Getopt::Long::Configure("bundling"); + GetOptions("foo|f!" => \$foo); + +Note that older Getopt::Long versions did not issue a warning, because +the '!' modifier was applied to the first name only. This bug was +fixed in 2.22. + +Solution: separate the long and short names and apply the '!' to the +long names only, e.g., + + GetOptions("foo!" => \$foo, "f" => \$foo); + +=head2 GetOptions does not return a false result when an option is not supplied + +That's why they're called 'options'. =head1 AUTHOR -Johan Vromans E<lt>jvromans@squirrel.nlE<gt> +Johan Vromans <jvromans@squirrel.nl> =head1 COPYRIGHT AND DISCLAIMER @@ -1660,12 +1880,11 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. If you do not have a copy of the GNU General Public License write to -the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, +the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. =cut # Local Variables: -# mode: perl # eval: (load-file "pod.el") # End: diff --git a/contrib/perl5/lib/IPC/Open3.pm b/contrib/perl5/lib/IPC/Open3.pm index 99709ac0ca76..5c9c69ad0287 100644 --- a/contrib/perl5/lib/IPC/Open3.pm +++ b/contrib/perl5/lib/IPC/Open3.pm @@ -44,12 +44,15 @@ by an autogenerated filehandle. If so, you must pass a valid lvalue in the parameter slot so it can be overwritten in the caller, or an exception will be raised. +The filehandles may also be integers, in which case they are understood +as file descriptors. + open3() returns the process ID of the child process. It doesn't return on failure: it just raises an exception matching C</^open3:/>. However, C<exec> failures in the child are not detected. You'll have to trap SIGPIPE yourself. -open2() does not wait for and reap the child process after it exits. +open3() does not wait for and reap the child process after it exits. Except for short programs where it's acceptable to let the operating system take care of this, you need to do this yourself. This is normally as simple as calling C<waitpid $pid, 0> when you're done with the process. @@ -84,6 +87,7 @@ The order of arguments differs from that of open2(). # fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com> # ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career # fixed for autovivving FHs, tchrist again +# allow fd numbers to be used, by Frank Tobin # # $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $ # @@ -136,6 +140,15 @@ sub xclose { close $_[0] or croak "$Me: close($_[0]) failed: $!"; } +sub fh_is_fd { + return $_[0] =~ /\A=?(\d+)\z/; +} + +sub xfileno { + return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd + return fileno $_[0]; +} + my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32'; sub _open3 { @@ -164,9 +177,9 @@ sub _open3 { $dup_err = ($dad_err =~ s/^[<>]&//); # force unqualified filehandles into caller's package - $dad_wtr = qualify $dad_wtr, $package; - $dad_rdr = qualify $dad_rdr, $package; - $dad_err = qualify $dad_err, $package; + $dad_wtr = qualify $dad_wtr, $package unless fh_is_fd($dad_wtr); + $dad_rdr = qualify $dad_rdr, $package unless fh_is_fd($dad_rdr); + $dad_err = qualify $dad_err, $package unless fh_is_fd($dad_err); my $kid_rdr = gensym; my $kid_wtr = gensym; @@ -181,20 +194,20 @@ sub _open3 { # If she wants to dup the kid's stderr onto her stdout I need to # save a copy of her stdout before I put something else there. if ($dad_rdr ne $dad_err && $dup_err - && fileno($dad_err) == fileno(STDOUT)) { + && xfileno($dad_err) == fileno(STDOUT)) { my $tmp = gensym; xopen($tmp, ">&$dad_err"); $dad_err = $tmp; } if ($dup_wtr) { - xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != fileno($dad_wtr); + xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != xfileno($dad_wtr); } else { xclose $dad_wtr; xopen \*STDIN, "<&=" . fileno $kid_rdr; } if ($dup_rdr) { - xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != fileno($dad_rdr); + xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != xfileno($dad_rdr); } else { xclose $dad_rdr; xopen \*STDOUT, ">&=" . fileno $kid_wtr; @@ -204,8 +217,8 @@ sub _open3 { # I have to use a fileno here because in this one case # I'm doing a dup but the filehandle might be a reference # (from the special case above). - xopen \*STDERR, ">&" . fileno $dad_err - if fileno(STDERR) != fileno($dad_err); + xopen \*STDERR, ">&" . xfileno($dad_err) + if fileno(STDERR) != xfileno($dad_err); } else { xclose $dad_err; xopen \*STDERR, ">&=" . fileno $kid_err; diff --git a/contrib/perl5/lib/Math/BigFloat.pm b/contrib/perl5/lib/Math/BigFloat.pm index d8d643ca3e31..1eefac2d79ea 100644 --- a/contrib/perl5/lib/Math/BigFloat.pm +++ b/contrib/perl5/lib/Math/BigFloat.pm @@ -4,6 +4,7 @@ use Math::BigInt; use Exporter; # just for use to be happy @ISA = (Exporter); +$VERSION = '0.02'; use overload '+' => sub {new Math::BigFloat &fadd}, @@ -12,9 +13,12 @@ use overload '<=>' => sub {$_[2]? fcmp($_[1],${$_[0]}) : fcmp(${$_[0]},$_[1])}, 'cmp' => sub {$_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])}, '*' => sub {new Math::BigFloat &fmul}, -'/' => sub {new Math::BigFloat +'/' => sub {new Math::BigFloat $_[2]? scalar fdiv($_[1],${$_[0]}) : scalar fdiv(${$_[0]},$_[1])}, +'%' => sub {new Math::BigFloat + $_[2]? scalar fmod($_[1],${$_[0]}) : + scalar fmod(${$_[0]},$_[1])}, 'neg' => sub {new Math::BigFloat &fneg}, 'abs' => sub {new Math::BigFloat &fabs}, @@ -43,12 +47,15 @@ sub stringify { my $e = $1; my $ln = length($n); - if ($e > 0) { - $n .= "0" x $e . '.'; - } elsif (abs($e) < $ln) { - substr($n, $ln + $e, 0) = '.'; - } else { - $n = '.' . ("0" x (abs($e) - $ln)) . $n; + if ( defined $e ) + { + if ($e > 0) { + $n .= "0" x $e . '.'; + } elsif (abs($e) < $ln) { + substr($n, $ln + $e, 0) = '.'; + } else { + $n = '.' . ("0" x (abs($e) - $ln)) . $n; + } } $n = "-$n" if $minus; @@ -85,6 +92,7 @@ sub fnorm { #(string) return fnum_str # normalize number -- for internal use sub norm { #(mantissa, exponent) return fnum_str local($_, $exp) = @_; + $exp = 0 unless defined $exp; if ($_ eq 'NaN') { 'NaN'; } else { @@ -140,7 +148,7 @@ sub fadd { #(fnum_str, fnum_str) return fnum_str # subtraction sub fsub { #(fnum_str, fnum_str) return fnum_str - fadd($_[$[],fneg($_[$[+1])); + fadd($_[$[],fneg($_[$[+1])); } # division @@ -164,6 +172,27 @@ sub fdiv #(fnum_str, fnum_str[,scale]) return fnum_str } } +# modular division +# args are dividend, divisor +sub fmod #(fnum_str, fnum_str) return fnum_str +{ + local($x,$y) = (fnorm($_[$[]),fnorm($_[$[+1])); + if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') { + 'NaN'; + } else { + local($xm,$xe) = split('E',$x); + local($ym,$ye) = split('E',$y); + if ( $xe < $ye ) + { + $ym .= ('0' x ($ye-$xe)); + } + else + { + $xm .= ('0' x ($xe-$ye)); + } + &norm(Math::BigInt::bmod($xm,$ym)); + } +} # round int $q based on fraction $r/$base using $rnd_mode sub round { #(int_str, int_str, int_str) return int_str local($q,$r,$base) = @_; @@ -174,12 +203,14 @@ sub round { #(int_str, int_str, int_str) return int_str } else { local($cmp) = Math::BigInt::bcmp(Math::BigInt::bmul($r,'+2'),$base); if ( $cmp < 0 || - ($cmp == 0 && - ( $rnd_mode eq 'zero' || + ($cmp == 0 && ( + ($rnd_mode eq 'zero' ) || ($rnd_mode eq '-inf' && (substr($q,$[,1) eq '+')) || ($rnd_mode eq '+inf' && (substr($q,$[,1) eq '-')) || - ($rnd_mode eq 'even' && $q =~ /[24680]$/) || - ($rnd_mode eq 'odd' && $q =~ /[13579]$/) )) ) { + ($rnd_mode eq 'even' && $q =~ /[24680]$/ ) || + ($rnd_mode eq 'odd' && $q =~ /[13579]$/ ) ) + ) + ) { $q; # round down } else { Math::BigInt::badd($q, ((substr($q,$[,1) eq '-') ? '-1' : '+1')); @@ -199,7 +230,7 @@ sub fround { #(fnum_str, scale) return fnum_str $x; } else { &norm(&round(substr($xm,$[,$scale+1), - "+0".substr($xm,$[+$scale+1,1),"+10"), + "+0".substr($xm,$[+$scale+1),"+1"."0" x length(substr($xm,$[+$scale+1))), $xe+length($xm)-$scale-1); } } @@ -223,15 +254,17 @@ sub ffround { #(fnum_str, scale) return fnum_str # normalized "-0" to &round when rounding -0.006 (for # example), purely so &round won't lose the sign. &norm(&round(substr($xm,$[,1).'0', - "+0".substr($xm,$[+1,1),"+10"), $scale); + "+0".substr($xm,$[+1), + "+1"."0" x length(substr($xm,$[+1))), $scale); } else { &norm(&round(substr($xm,$[,$xe), - "+0".substr($xm,$[+$xe,1),"+10"), $scale); + "+0".substr($xm,$[+$xe), + "+1"."0" x length(substr($xm,$[+$xe))), $scale); } } } } - + # compare 2 values returns one of undef, <0, =0, >0 # returns undef if either or both input value are not numbers sub fcmp #(fnum_str, fnum_str) return cond_code @@ -244,9 +277,17 @@ sub fcmp #(fnum_str, fnum_str) return cond_code if ($xm eq '+0' || $ym eq '+0') { return $xm <=> $ym; } - ord($y) <=> ord($x) - || ($xe <=> $ye) * (substr($x,$[,1).'1') - || Math::BigInt::cmp($xm,$ym); + if ( $xe < $ye ) # adjust the exponents to be equal + { + $ym .= '0' x ($ye - $xe); + $ye = $xe; + } + elsif ( $ye < $xe ) # same here + { + $xm .= '0' x ($xe - $ye); + $xe = $ye; + } + return Math::BigInt::cmp($xm,$ym); } } @@ -286,6 +327,7 @@ Math::BigFloat - Arbitrary length float math package $f->fsub(NSTR) return NSTR subtraction $f->fmul(NSTR) return NSTR multiplication $f->fdiv(NSTR[,SCALE]) returns NSTR division to SCALE places + $f->fmod(NSTR) returns NSTR modular remainder $f->fneg() return NSTR negation $f->fabs() return NSTR absolute value $f->fcmp(NSTR) return CODE compare undef,<0,=0,>0 @@ -313,7 +355,7 @@ have embedded whitespace. An input parameter was "Not a Number" or divide by zero or sqrt of negative number. -=item Division is computed to +=item Division is computed to C<max($Math::BigFloat::div_scale,length(dividend)+length(divisor))> digits by default. @@ -352,5 +394,5 @@ as follows: =head1 AUTHOR Mark Biggar - +Patches by John Peacock Apr 2001 =cut diff --git a/contrib/perl5/lib/Math/BigInt.pm b/contrib/perl5/lib/Math/BigInt.pm index a43969c2b232..066577d4cc13 100644 --- a/contrib/perl5/lib/Math/BigInt.pm +++ b/contrib/perl5/lib/Math/BigInt.pm @@ -1,4 +1,5 @@ package Math::BigInt; +$VERSION='0.01'; use overload '+' => sub {new Math::BigInt &badd}, @@ -51,6 +52,11 @@ sub import { $zero = 0; +# overcome a floating point problem on certain osnames (posix-bc, os390) +BEGIN { + my $x = 100000.0; + my $use_mult = int($x*1e-5)*1e5 == $x ? 1 : 0; +} # normalize string form of number. Strip leading zeros. Strip any # white space and add a sign, if missing. @@ -227,8 +233,14 @@ sub mul { #(*int_num_array, *int_num_array) return int_num_array ($car, $cty) = (0, $[); for $y (@y) { $prod = $x * $y + ($prod[$cty] || 0) + $car; + if ($use_mult) { $prod[$cty++] = $prod - ($car = int($prod * 1e-5)) * 1e5; + } + else { + $prod[$cty++] = + $prod - ($car = int($prod / 1e5)) * 1e5; + } } $prod[$cty] += $car if $car; $x = shift @prod; @@ -253,12 +265,22 @@ sub bdiv { #(dividend: num_str, divisor: num_str) return num_str if (($dd = int(1e5/($y[$#y]+1))) != 1) { for $x (@x) { $x = $x * $dd + $car; + if ($use_mult) { $x -= ($car = int($x * 1e-5)) * 1e5; + } + else { + $x -= ($car = int($x / 1e5)) * 1e5; + } } push(@x, $car); $car = 0; for $y (@y) { $y = $y * $dd + $car; + if ($use_mult) { $y -= ($car = int($y * 1e-5)) * 1e5; + } + else { + $y -= ($car = int($y / 1e5)) * 1e5; + } } } else { @@ -275,7 +297,12 @@ sub bdiv { #(dividend: num_str, divisor: num_str) return num_str ($car, $bar) = (0,0); for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) { $prd = $q * $y[$y] + $car; + if ($use_mult) { $prd -= ($car = int($prd * 1e-5)) * 1e5; + } + else { + $prd -= ($car = int($prd / 1e5)) * 1e5; + } $x[$x] += 1e5 if ($bar = (($x[$x] -= $prd + $bar) < 0)); } if ($x[$#x] < $car + $bar) { diff --git a/contrib/perl5/lib/Math/Complex.pm b/contrib/perl5/lib/Math/Complex.pm index 1a47f4af5e63..9812513656df 100644 --- a/contrib/perl5/lib/Math/Complex.pm +++ b/contrib/perl5/lib/Math/Complex.pm @@ -5,17 +5,39 @@ # -- Daniel S. Lewart Since Sep 1997 # -require Exporter; package Math::Complex; -use 5.005_64; -use strict; +our($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $Inf); + +$VERSION = 1.31; + +BEGIN { + unless ($^O eq 'unicosmk') { + my $e = $!; + # We do want an arithmetic overflow, Inf INF inf Infinity:. + undef $Inf unless eval <<'EOE' and $Inf =~ /^inf(?:inity)?$/i; + local $SIG{FPE} = sub {die}; + my $t = CORE::exp 30; + $Inf = CORE::exp $t; +EOE + if (!defined $Inf) { # Try a different method + undef $Inf unless eval <<'EOE' and $Inf =~ /^inf(?:inity)?$/i; + local $SIG{FPE} = sub {die}; + my $t = 1; + $Inf = $t + "1e99999999999999999999999999999999"; +EOE + } + $! = $e; # Clear ERANGE. + } + $Inf = "Inf" if !defined $Inf || !($Inf > 0); # Desperation. +} -our($VERSION, @ISA, @EXPORT, %EXPORT_TAGS); +use strict; -my ( $i, $ip2, %logn ); +my $i; +my %LOGN; -$VERSION = sprintf("%s", q$Id: Complex.pm,v 1.26 1998/11/01 00:00:00 dsl Exp $ =~ /(\d+\.\d+)/); +require Exporter; @ISA = qw(Exporter); @@ -49,6 +71,7 @@ use overload '*' => \&multiply, '/' => \÷, '**' => \&power, + '==' => \&numeq, '<=>' => \&spaceship, 'neg' => \&negate, '~' => \&conjugate, @@ -66,7 +89,6 @@ use overload # Package "privates" # -my $package = 'Math::Complex'; # Package name my %DISPLAY_FORMAT = ('style' => 'cartesian', 'polar_pretty_print' => 1); my $eps = 1e-14; # Epsilon @@ -228,6 +250,13 @@ sub i () { } # +# ip2 +# +# Half of i. +# +sub ip2 () { i / 2 } + +# # Attribute access/set routines # @@ -262,7 +291,8 @@ sub update_polar { my ($x, $y) = @{$self->{'cartesian'}}; $self->{p_dirty} = 0; return $self->{'polar'} = [0, 0] if $x == 0 && $y == 0; - return $self->{'polar'} = [CORE::sqrt($x*$x + $y*$y), CORE::atan2($y, $x)]; + return $self->{'polar'} = [CORE::sqrt($x*$x + $y*$y), + CORE::atan2($y, $x)]; } # @@ -342,7 +372,7 @@ sub _divbyzero { if (defined $_[1]) { $mess .= "(Because in the definition of $_[0], the divisor "; - $mess .= "$_[1] " unless ($_[1] eq '0'); + $mess .= "$_[1] " unless ("$_[1]" eq '0'); $mess .= "is 0)\n"; } @@ -416,8 +446,8 @@ sub power { return 1 if $z2 == 0 || $z1 == 1; return 0 if $z1 == 0 && Re($z2) > 0; } - my $w = $inverted ? CORE::exp($z1 * CORE::log($z2)) - : CORE::exp($z2 * CORE::log($z1)); + my $w = $inverted ? &exp($z1 * &log($z2)) + : &exp($z2 * &log($z1)); # If both arguments cartesian, return cartesian, else polar. return $z1->{c_dirty} == 0 && (not ref $z2 or $z2->{c_dirty} == 0) ? @@ -440,6 +470,19 @@ sub spaceship { } # +# (numeq) +# +# Computes z1 == z2. +# +# (Required in addition to spaceship() because of NaNs.) +sub numeq { + my ($z1, $z2, $inverted) = @_; + my ($re1, $im1) = ref $z1 ? @{$z1->cartesian} : ($z1, 0); + my ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2, 0); + return $re1 == $re2 && $im1 == $im2 ? 1 : 0; +} + +# # (negate) # # Computes -z. @@ -477,7 +520,13 @@ sub conjugate { # sub abs { my ($z, $rho) = @_; - return $z unless ref $z; + unless (ref $z) { + if (@_ == 2) { + $_[0] = $_[1]; + } else { + return CORE::abs($z); + } + } if (defined $rho) { $z->{'polar'} = [ $rho, ${$z->polar}[1] ]; $z->{p_dirty} = 0; @@ -533,7 +582,8 @@ sub arg { sub sqrt { my ($z) = @_; my ($re, $im) = ref $z ? @{$z->cartesian} : ($z, 0); - return $re < 0 ? cplx(0, CORE::sqrt(-$re)) : CORE::sqrt($re) if $im == 0; + return $re < 0 ? cplx(0, CORE::sqrt(-$re)) : CORE::sqrt($re) + if $im == 0; my ($r, $t) = @{$z->polar}; return (ref $z)->emake(CORE::sqrt($r), $t/2); } @@ -547,9 +597,12 @@ sub sqrt { # sub cbrt { my ($z) = @_; - return $z < 0 ? -CORE::exp(CORE::log(-$z)/3) : ($z > 0 ? CORE::exp(CORE::log($z)/3): 0) + return $z < 0 ? + -CORE::exp(CORE::log(-$z)/3) : + ($z > 0 ? CORE::exp(CORE::log($z)/3): 0) unless ref $z; my ($r, $t) = @{$z->polar}; + return 0 if $r == 0; return (ref $z)->emake(CORE::exp(CORE::log($r)/3), $t/3); } @@ -559,7 +612,7 @@ sub cbrt { # Die on bad root. # sub _rootbad { - my $mess = "Root $_[0] not defined, root must be positive integer.\n"; + my $mess = "Root $_[0] illegal, root rank must be positive integer.\n"; my @up = caller(1); @@ -581,7 +634,8 @@ sub _rootbad { sub root { my ($z, $n) = @_; _rootbad($n) if ($n < 1 or int($n) != $n); - my ($r, $t) = ref $z ? @{$z->polar} : (CORE::abs($z), $z >= 0 ? 0 : pi); + my ($r, $t) = ref $z ? + @{$z->polar} : (CORE::abs($z), $z >= 0 ? 0 : pi); my @root; my $k; my $theta_inc = pit2 / $n; @@ -620,7 +674,7 @@ sub Re { # sub Im { my ($z, $Im) = @_; - return $z unless ref $z; + return 0 unless ref $z; if (defined $Im) { $z->{'cartesian'} = [ ${$z->cartesian}[0], $Im ]; $z->{c_dirty} = 0; @@ -723,9 +777,9 @@ sub log10 { sub logn { my ($z, $n) = @_; $z = cplx($z, 0) unless ref $z; - my $logn = $logn{$n}; - $logn = $logn{$n} = CORE::log($n) unless defined $logn; # Cache log(n) - return CORE::log($z) / $logn; + my $logn = $LOGN{$n}; + $logn = $LOGN{$n} = CORE::log($n) unless defined $logn; # Cache log(n) + return &log($z) / $logn; } # @@ -735,11 +789,14 @@ sub logn { # sub cos { my ($z) = @_; + return CORE::cos($z) unless ref $z; my ($x, $y) = @{$z->cartesian}; my $ey = CORE::exp($y); - my $ey_1 = 1 / $ey; - return (ref $z)->make(CORE::cos($x) * ($ey + $ey_1)/2, - CORE::sin($x) * ($ey_1 - $ey)/2); + my $sx = CORE::sin($x); + my $cx = CORE::cos($x); + my $ey_1 = $ey ? 1 / $ey : $Inf; + return (ref $z)->make($cx * ($ey + $ey_1)/2, + $sx * ($ey_1 - $ey)/2); } # @@ -749,11 +806,14 @@ sub cos { # sub sin { my ($z) = @_; + return CORE::sin($z) unless ref $z; my ($x, $y) = @{$z->cartesian}; my $ey = CORE::exp($y); - my $ey_1 = 1 / $ey; - return (ref $z)->make(CORE::sin($x) * ($ey + $ey_1)/2, - CORE::cos($x) * ($ey - $ey_1)/2); + my $sx = CORE::sin($x); + my $cx = CORE::cos($x); + my $ey_1 = $ey ? 1 / $ey : $Inf; + return (ref $z)->make($sx * ($ey + $ey_1)/2, + $cx * ($ey - $ey_1)/2); } # @@ -763,9 +823,9 @@ sub sin { # sub tan { my ($z) = @_; - my $cz = CORE::cos($z); - _divbyzero "tan($z)", "cos($z)" if (CORE::abs($cz) < $eps); - return CORE::sin($z) / $cz; + my $cz = &cos($z); + _divbyzero "tan($z)", "cos($z)" if $cz == 0; + return &sin($z) / $cz; } # @@ -775,7 +835,7 @@ sub tan { # sub sec { my ($z) = @_; - my $cz = CORE::cos($z); + my $cz = &cos($z); _divbyzero "sec($z)", "cos($z)" if ($cz == 0); return 1 / $cz; } @@ -787,7 +847,7 @@ sub sec { # sub csc { my ($z) = @_; - my $sz = CORE::sin($z); + my $sz = &sin($z); _divbyzero "csc($z)", "sin($z)" if ($sz == 0); return 1 / $sz; } @@ -806,9 +866,9 @@ sub cosec { Math::Complex::csc(@_) } # sub cot { my ($z) = @_; - my $sz = CORE::sin($z); + my $sz = &sin($z); _divbyzero "cot($z)", "sin($z)" if ($sz == 0); - return CORE::cos($z) / $sz; + return &cos($z) / $sz; } # @@ -825,8 +885,11 @@ sub cotan { Math::Complex::cot(@_) } # sub acos { my $z = $_[0]; - return CORE::atan2(CORE::sqrt(1-$z*$z), $z) if (! ref $z) && CORE::abs($z) <= 1; - my ($x, $y) = ref $z ? @{$z->cartesian} : ($z, 0); + return CORE::atan2(CORE::sqrt(1-$z*$z), $z) + if (! ref $z) && CORE::abs($z) <= 1; + $z = cplx($z, 0) unless ref $z; + my ($x, $y) = @{$z->cartesian}; + return 0 if $x == 1 && $y == 0; my $t1 = CORE::sqrt(($x+1)*($x+1) + $y*$y); my $t2 = CORE::sqrt(($x-1)*($x-1) + $y*$y); my $alpha = ($t1 + $t2)/2; @@ -837,7 +900,7 @@ sub acos { my $u = CORE::atan2(CORE::sqrt(1-$beta*$beta), $beta); my $v = CORE::log($alpha + CORE::sqrt($alpha*$alpha-1)); $v = -$v if $y > 0 || ($y == 0 && $x < -1); - return __PACKAGE__->make($u, $v); + return (ref $z)->make($u, $v); } # @@ -847,8 +910,11 @@ sub acos { # sub asin { my $z = $_[0]; - return CORE::atan2($z, CORE::sqrt(1-$z*$z)) if (! ref $z) && CORE::abs($z) <= 1; - my ($x, $y) = ref $z ? @{$z->cartesian} : ($z, 0); + return CORE::atan2($z, CORE::sqrt(1-$z*$z)) + if (! ref $z) && CORE::abs($z) <= 1; + $z = cplx($z, 0) unless ref $z; + my ($x, $y) = @{$z->cartesian}; + return 0 if $x == 0 && $y == 0; my $t1 = CORE::sqrt(($x+1)*($x+1) + $y*$y); my $t2 = CORE::sqrt(($x-1)*($x-1) + $y*$y); my $alpha = ($t1 + $t2)/2; @@ -859,7 +925,7 @@ sub asin { my $u = CORE::atan2($beta, CORE::sqrt(1-$beta*$beta)); my $v = -CORE::log($alpha + CORE::sqrt($alpha*$alpha-1)); $v = -$v if $y > 0 || ($y == 0 && $x < -1); - return __PACKAGE__->make($u, $v); + return (ref $z)->make($u, $v); } # @@ -870,11 +936,12 @@ sub asin { sub atan { my ($z) = @_; return CORE::atan2($z, 1) unless ref $z; + my ($x, $y) = ref $z ? @{$z->cartesian} : ($z, 0); + return 0 if $x == 0 && $y == 0; _divbyzero "atan(i)" if ( $z == i); - _divbyzero "atan(-i)" if (-$z == i); - my $log = CORE::log((i + $z) / (i - $z)); - $ip2 = 0.5 * i unless defined $ip2; - return $ip2 * $log; + _logofzero "atan(-i)" if (-$z == i); # -i is a bad file test... + my $log = &log((i + $z) / (i - $z)); + return ip2 * $log; } # @@ -913,10 +980,11 @@ sub acosec { Math::Complex::acsc(@_) } # sub acot { my ($z) = @_; - _divbyzero "acot(0)" if (CORE::abs($z) < $eps); - return ($z >= 0) ? CORE::atan2(1, $z) : CORE::atan2(-1, -$z) unless ref $z; - _divbyzero "acot(i)" if (CORE::abs($z - i) < $eps); - _logofzero "acot(-i)" if (CORE::abs($z + i) < $eps); + _divbyzero "acot(0)" if $z == 0; + return ($z >= 0) ? CORE::atan2(1, $z) : CORE::atan2(-1, -$z) + unless ref $z; + _divbyzero "acot(i)" if ($z - i == 0); + _logofzero "acot(-i)" if ($z + i == 0); return atan(1 / $z); } @@ -937,11 +1005,11 @@ sub cosh { my $ex; unless (ref $z) { $ex = CORE::exp($z); - return ($ex + 1/$ex)/2; + return $ex ? ($ex + 1/$ex)/2 : $Inf; } my ($x, $y) = @{$z->cartesian}; $ex = CORE::exp($x); - my $ex_1 = 1 / $ex; + my $ex_1 = $ex ? 1 / $ex : $Inf; return (ref $z)->make(CORE::cos($y) * ($ex + $ex_1)/2, CORE::sin($y) * ($ex - $ex_1)/2); } @@ -955,12 +1023,15 @@ sub sinh { my ($z) = @_; my $ex; unless (ref $z) { + return 0 if $z == 0; $ex = CORE::exp($z); - return ($ex - 1/$ex)/2; + return $ex ? ($ex - 1/$ex)/2 : "-$Inf"; } my ($x, $y) = @{$z->cartesian}; + my $cy = CORE::cos($y); + my $sy = CORE::sin($y); $ex = CORE::exp($x); - my $ex_1 = 1 / $ex; + my $ex_1 = $ex ? 1 / $ex : $Inf; return (ref $z)->make(CORE::cos($y) * ($ex - $ex_1)/2, CORE::sin($y) * ($ex + $ex_1)/2); } @@ -1016,7 +1087,7 @@ sub cosech { Math::Complex::csch(@_) } sub coth { my ($z) = @_; my $sz = sinh($z); - _divbyzero "coth($z)", "sinh($z)" if ($sz == 0); + _divbyzero "coth($z)", "sinh($z)" if $sz == 0; return cosh($z) / $sz; } @@ -1035,25 +1106,44 @@ sub cotanh { Math::Complex::coth(@_) } sub acosh { my ($z) = @_; unless (ref $z) { - return CORE::log($z + CORE::sqrt($z*$z-1)) if $z >= 1; $z = cplx($z, 0); } my ($re, $im) = @{$z->cartesian}; if ($im == 0) { - return cplx(CORE::log($re + CORE::sqrt($re*$re - 1)), 0) if $re >= 1; - return cplx(0, CORE::atan2(CORE::sqrt(1-$re*$re), $re)) if CORE::abs($re) <= 1; + return CORE::log($re + CORE::sqrt($re*$re - 1)) + if $re >= 1; + return cplx(0, CORE::atan2(CORE::sqrt(1 - $re*$re), $re)) + if CORE::abs($re) < 1; } - return CORE::log($z + CORE::sqrt($z*$z - 1)); + my $t = &sqrt($z * $z - 1) + $z; + # Try Taylor if looking bad (this usually means that + # $z was large negative, therefore the sqrt is really + # close to abs(z), summing that with z...) + $t = 1/(2 * $z) - 1/(8 * $z**3) + 1/(16 * $z**5) - 5/(128 * $z**7) + if $t == 0; + my $u = &log($t); + $u->Im(-$u->Im) if $re < 0 && $im == 0; + return $re < 0 ? -$u : $u; } # # asinh # -# Computes the arc hyperbolic sine asinh(z) = log(z + sqrt(z*z-1)) +# Computes the arc hyperbolic sine asinh(z) = log(z + sqrt(z*z+1)) # sub asinh { my ($z) = @_; - return CORE::log($z + CORE::sqrt($z*$z + 1)); + unless (ref $z) { + my $t = $z + CORE::sqrt($z*$z + 1); + return CORE::log($t) if $t; + } + my $t = &sqrt($z * $z + 1) + $z; + # Try Taylor if looking bad (this usually means that + # $z was large negative, therefore the sqrt is really + # close to abs(z), summing that with z...) + $t = 1/(2 * $z) - 1/(8 * $z**3) + 1/(16 * $z**5) - 5/(128 * $z**7) + if $t == 0; + return &log($t); } # @@ -1067,9 +1157,9 @@ sub atanh { return CORE::log((1 + $z)/(1 - $z))/2 if CORE::abs($z) < 1; $z = cplx($z, 0); } - _divbyzero 'atanh(1)', "1 - $z" if ($z == 1); - _logofzero 'atanh(-1)' if ($z == -1); - return 0.5 * CORE::log((1 + $z) / (1 - $z)); + _divbyzero 'atanh(1)', "1 - $z" if (1 - $z == 0); + _logofzero 'atanh(-1)' if (1 + $z == 0); + return 0.5 * &log((1 + $z) / (1 - $z)); } # @@ -1079,7 +1169,7 @@ sub atanh { # sub asech { my ($z) = @_; - _divbyzero 'asech(0)', $z if ($z == 0); + _divbyzero 'asech(0)', "$z" if ($z == 0); return acosh(1 / $z); } @@ -1108,14 +1198,14 @@ sub acosech { Math::Complex::acsch(@_) } # sub acoth { my ($z) = @_; - _divbyzero 'acoth(0)' if (CORE::abs($z) < $eps); + _divbyzero 'acoth(0)' if ($z == 0); unless (ref $z) { return CORE::log(($z + 1)/($z - 1))/2 if CORE::abs($z) > 1; $z = cplx($z, 0); } - _divbyzero 'acoth(1)', "$z - 1" if (CORE::abs($z - 1) < $eps); - _logofzero 'acoth(-1)', "1 / $z" if (CORE::abs($z + 1) < $eps); - return CORE::log((1 + $z) / ($z - 1)) / 2; + _divbyzero 'acoth(1)', "$z - 1" if ($z - 1 == 0); + _logofzero 'acoth(-1)', "1 + $z" if (1 + $z == 0); + return &log((1 + $z) / ($z - 1)) / 2; } # @@ -1141,8 +1231,8 @@ sub atan2 { ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2, 0); } if ($im2 == 0) { - return cplx(CORE::atan2($re1, $re2), 0) if $im1 == 0; - return cplx(($im1<=>0) * pip2, 0) if $re2 == 0; + return CORE::atan2($re1, $re2) if $im1 == 0; + return ($im1<=>0) * pip2 if $re2 == 0; } my $w = atan($z1/$z2); my ($u, $v) = ref $w ? @{$w->cartesian} : ($w, 0); @@ -1173,23 +1263,15 @@ sub display_format { my %obj = %{$self->{display_format}}; @display_format{keys %obj} = values %obj; } - if (@_ == 1) { - $display_format{style} = shift; - } else { - my %new = @_; - @display_format{keys %new} = values %new; - } - } else { # Called as a class method - if (@_ = 1) { - $display_format{style} = $self; - } else { - my %new = @_; - @display_format{keys %new} = values %new; - } - undef $self; + } + if (@_ == 1) { + $display_format{style} = shift; + } else { + my %new = @_; + @display_format{keys %new} = values %new; } - if (defined $self) { + if (ref $self) { # Called as an object method $self->{display_format} = { %display_format }; return wantarray ? @@ -1197,6 +1279,7 @@ sub display_format { $self->{display_format}->{style}; } + # Called as a class method %DISPLAY_FORMAT = %display_format; return wantarray ? @@ -1235,67 +1318,58 @@ sub stringify_cartesian { my ($x, $y) = @{$z->cartesian}; my ($re, $im); - $x = int($x + ($x < 0 ? -1 : 1) * $eps) - if int(CORE::abs($x)) != int(CORE::abs($x) + $eps); - $y = int($y + ($y < 0 ? -1 : 1) * $eps) - if int(CORE::abs($y)) != int(CORE::abs($y) + $eps); - - $re = "$x" if CORE::abs($x) >= $eps; - my %format = $z->display_format; my $format = $format{format}; - if ($y == 1) { $im = 'i' } - elsif ($y == -1) { $im = '-i' } - elsif (CORE::abs($y) >= $eps) { - $im = (defined $format ? sprintf($format, $y) : $y) . "i"; + if ($x) { + if ($x =~ /^NaN[QS]?$/i) { + $re = $x; + } else { + if ($x =~ /^-?$Inf$/oi) { + $re = $x; + } else { + $re = defined $format ? sprintf($format, $x) : $x; + } + } + } else { + undef $re; } - my $str = ''; - $str = defined $format ? sprintf($format, $re) : $re - if defined $re; + if ($y) { + if ($y =~ /^(NaN[QS]?)$/i) { + $im = $y; + } else { + if ($y =~ /^-?$Inf$/oi) { + $im = $y; + } else { + $im = + defined $format ? + sprintf($format, $y) : + ($y == 1 ? "" : ($y == -1 ? "-" : $y)); + } + } + $im .= "i"; + } else { + undef $im; + } + + my $str = $re; + if (defined $im) { if ($y < 0) { $str .= $im; - } elsif ($y > 0) { + } elsif ($y > 0 || $im =~ /^NaN[QS]?i$/i) { $str .= "+" if defined $re; $str .= $im; } + } elsif (!defined $re) { + $str = "0"; } return $str; } -# Helper for stringify_polar, a Greatest Common Divisor with a memory. - -sub _gcd { - my ($a, $b) = @_; - - use integer; - - # Loops forever if given negative inputs. - - if ($b and $a > $b) { return gcd($a % $b, $b) } - elsif ($a and $b > $a) { return gcd($b % $a, $a) } - else { return $a ? $a : $b } -} - -my %gcd; - -sub gcd { - my ($a, $b) = @_; - - my $id = "$a $b"; - - unless (exists $gcd{$id}) { - $gcd{$id} = _gcd($a, $b); - $gcd{"$b $a"} = $gcd{$id}; - } - - return $gcd{$id}; -} - # # ->stringify_polar # @@ -1306,74 +1380,52 @@ sub stringify_polar { my ($r, $t) = @{$z->polar}; my $theta; - return '[0,0]' if $r <= $eps; - my %format = $z->display_format; + my $format = $format{format}; - my $nt = $t / pit2; - $nt = ($nt - int($nt)) * pit2; - $nt += pit2 if $nt < 0; # Range [0, 2pi] - - if (CORE::abs($nt) <= $eps) { $theta = 0 } - elsif (CORE::abs(pi-$nt) <= $eps) { $theta = 'pi' } - - if (defined $theta) { - $r = int($r + ($r < 0 ? -1 : 1) * $eps) - if int(CORE::abs($r)) != int(CORE::abs($r) + $eps); - $theta = int($theta + ($theta < 0 ? -1 : 1) * $eps) - if ($theta ne 'pi' and - int(CORE::abs($theta)) != int(CORE::abs($theta) + $eps)); - return "\[$r,$theta\]"; + if ($t =~ /^NaN[QS]?$/i || $t =~ /^-?$Inf$/oi) { + $theta = $t; + } elsif ($t == pi) { + $theta = "pi"; + } elsif ($r == 0 || $t == 0) { + $theta = defined $format ? sprintf($format, $t) : $t; } + return "[$r,$theta]" if defined $theta; + # - # Okay, number is not a real. Try to identify pi/n and friends... + # Try to identify pi/n and friends. # - $nt -= pit2 if $nt > pi; - - if ($format{polar_pretty_print} && CORE::abs($nt) >= deg1) { - my ($n, $k, $kpi); - - for ($k = 1, $kpi = pi; $k < 10; $k++, $kpi += pi) { - $n = int($kpi / $nt + ($nt > 0 ? 1 : -1) * 0.5); - if (CORE::abs($kpi/$n - $nt) <= $eps) { - $n = CORE::abs($n); - my $gcd = gcd($k, $n); - if ($gcd > 1) { - $k /= $gcd; - $n /= $gcd; - } - next if $n > 360; - $theta = ($nt < 0 ? '-':''). - ($k == 1 ? 'pi':"${k}pi"); - $theta .= '/'.$n if $n > 1; + $t -= int(CORE::abs($t) / pit2) * pit2; + + if ($format{polar_pretty_print} && $t) { + my ($a, $b); + for $a (2..9) { + $b = $t * $a / pi; + if ($b =~ /^-?\d+$/) { + $b = $b < 0 ? "-" : "" if CORE::abs($b) == 1; + $theta = "${b}pi/$a"; last; } } } - $theta = $nt unless defined $theta; - - $r = int($r + ($r < 0 ? -1 : 1) * $eps) - if int(CORE::abs($r)) != int(CORE::abs($r) + $eps); - $theta = int($theta + ($theta < 0 ? -1 : 1) * $eps) - if ($theta !~ m(^-?\d*pi/\d+$) and - int(CORE::abs($theta)) != int(CORE::abs($theta) + $eps)); - - my $format = $format{format}; if (defined $format) { $r = sprintf($format, $r); - $theta = sprintf($format, $theta); + $theta = sprintf($format, $theta) unless defined $theta; + } else { + $theta = $t unless defined $theta; } - return "\[$r,$theta\]"; + return "[$r,$theta]"; } 1; __END__ =pod + =head1 NAME Math::Complex - complex numbers and associated mathematical functions @@ -1695,7 +1747,7 @@ For instance: print "j = $j\n"; # Prints "j = -0.5+0.866025403784439i" The polar style attempts to emphasize arguments like I<k*pi/n> -(where I<n> is a positive integer and I<k> an integer within [-9,+9]), +(where I<n> is a positive integer and I<k> an integer within [-9, +9]), this is called I<polar pretty-printing>. =head2 CHANGED IN PERL 5.6 @@ -1705,29 +1757,33 @@ C<display_format> object method can now be called using a parameter hash instead of just a one parameter. The old display format style, which can have values C<"cartesian"> or -C<"polar">, can be changed using the C<"style"> parameter. (The one -parameter calling convention also still works.) +C<"polar">, can be changed using the C<"style"> parameter. + + $j->display_format(style => "polar"); + +The one parameter calling convention also still works. + + $j->display_format("polar"); There are two new display parameters. -The first one is C<"format">, which is a sprintf()-style format -string to be used for both parts of the complex number(s). The -default is C<undef>, which corresponds usually (this is somewhat -system-dependent) to C<"%.15g">. You can revert to the default by -setting the format string to C<undef>. +The first one is C<"format">, which is a sprintf()-style format string +to be used for both numeric parts of the complex number(s). The is +somewhat system-dependent but most often it corresponds to C<"%.15g">. +You can revert to the default by setting the C<format> to C<undef>. # the $j from the above example $j->display_format('format' => '%.5f'); print "j = $j\n"; # Prints "j = -0.50000+0.86603i" - $j->display_format('format' => '%.6f'); + $j->display_format('format' => undef); print "j = $j\n"; # Prints "j = -0.5+0.86603i" Notice that this affects also the return values of the C<display_format> methods: in list context the whole parameter hash -will be returned, as opposed to only the style parameter value. If -you want to know the whole truth for a complex number, you must call -both the class method and the object method: +will be returned, as opposed to only the style parameter value. +This is a potential incompatibility with earlier versions if you +have been calling the C<display_format> method in list context. The second new display parameter is C<"polar_pretty_print">, which can be set to true or false, the default being true. See the previous @@ -1791,8 +1847,7 @@ is any integer. Note that because we are operating on approximations of real numbers, these errors can happen when merely `too close' to the singularities -listed above. For example C<tan(2*atan2(1,1)+1e-15)> will die of -division by zero. +listed above. =head1 ERRORS DUE TO INDIGESTIBLE ARGUMENTS diff --git a/contrib/perl5/lib/Math/Trig.pm b/contrib/perl5/lib/Math/Trig.pm index 492706cd6aa8..b28f150798d2 100644 --- a/contrib/perl5/lib/Math/Trig.pm +++ b/contrib/perl5/lib/Math/Trig.pm @@ -36,14 +36,15 @@ my @rdlcnv = qw(cartesian_to_cylindrical %EXPORT_TAGS = ('radial' => [ @rdlcnv ]); -sub pi2 () { 2 * pi } # use constant generates warning -sub pip2 () { pi / 2 } # use constant generates warning -use constant DR => pi2/360; -use constant RD => 360/pi2; -use constant DG => 400/360; -use constant GD => 360/400; -use constant RG => 400/pi2; -use constant GR => pi2/400; +sub pi2 () { 2 * pi } +sub pip2 () { pi / 2 } + +sub DR () { pi2/360 } +sub RD () { 360/pi2 } +sub DG () { 400/360 } +sub GD () { 360/400 } +sub RG () { 400/pi2 } +sub GR () { pi2/400 } # # Truncating remainder. @@ -58,17 +59,23 @@ sub remt ($$) { # Angle conversions. # -sub rad2deg ($) { remt(RD * $_[0], 360) } +sub rad2rad($) { remt($_[0], pi2) } + +sub deg2deg($) { remt($_[0], 360) } + +sub grad2grad($) { remt($_[0], 400) } -sub deg2rad ($) { remt(DR * $_[0], pi2) } +sub rad2deg ($;$) { my $d = RD * $_[0]; $_[1] ? $d : deg2deg($d) } -sub grad2deg ($) { remt(GD * $_[0], 360) } +sub deg2rad ($;$) { my $d = DR * $_[0]; $_[1] ? $d : rad2rad($d) } -sub deg2grad ($) { remt(DG * $_[0], 400) } +sub grad2deg ($;$) { my $d = GD * $_[0]; $_[1] ? $d : deg2deg($d) } -sub rad2grad ($) { remt(RG * $_[0], 400) } +sub deg2grad ($;$) { my $d = DG * $_[0]; $_[1] ? $d : grad2grad($d) } -sub grad2rad ($) { remt(GR * $_[0], pi2) } +sub rad2grad ($;$) { my $d = RG * $_[0]; $_[1] ? $d : grad2grad($d) } + +sub grad2rad ($;$) { my $d = GR * $_[0]; $_[1] ? $d : rad2rad($d) } sub cartesian_to_spherical { my ( $x, $y, $z ) = @_; @@ -280,6 +287,14 @@ and the imaginary part of approximately C<-1.317>. $gradians = rad2grad($radians); The full circle is 2 I<pi> radians or I<360> degrees or I<400> gradians. +The result is by default wrapped to be inside the [0, {2pi,360,400}[ circle. +If you don't want this, supply a true second argument: + + $zillions_of_radians = deg2rad($zillions_of_degrees, 1); + $negative_degrees = rad2deg($negative_radians, 1); + +You can also do the wrapping explicitly by rad2rad(), deg2deg(), and +grad2grad(). =head1 RADIAL COORDINATE CONVERSIONS diff --git a/contrib/perl5/lib/Net/Ping.pm b/contrib/perl5/lib/Net/Ping.pm index 2713383a00c1..a2846fe90210 100644 --- a/contrib/perl5/lib/Net/Ping.pm +++ b/contrib/perl5/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; @@ -442,7 +443,11 @@ hosts on a network. A ping object is first created with optional parameters, a variable number of hosts may be pinged multiple times and then the connection is closed. -You may choose one of three different protocols to use for the ping. +You may choose one of three different protocols to use for the +ping. The "udp" protocol is the default. Note that a live remote host +may still fail to be pingable by one or more of these protocols. For +example, www.microsoft.com is generally alive but not pingable. + With the "tcp" protocol the ping() method attempts to establish a connection to the remote host's echo port. If the connection is successfully established, the remote host is considered reachable. No @@ -455,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<inetd(8)> 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/contrib/perl5/lib/Net/protoent.pm b/contrib/perl5/lib/Net/protoent.pm index 334af789149a..00a76aff075c 100644 --- a/contrib/perl5/lib/Net/protoent.pm +++ b/contrib/perl5/lib/Net/protoent.pm @@ -6,7 +6,7 @@ our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); @EXPORT = qw(getprotobyname getprotobynumber getprotoent); - @EXPORT_OK = qw( $p_name @p_aliases $p_proto ); + @EXPORT_OK = qw( $p_name @p_aliases $p_proto getproto ); %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); } use vars @EXPORT_OK; @@ -78,6 +78,7 @@ regular array variables, so for example C<@{ $proto_obj-E<gt>aliases() The getproto() function is a simple front-end that forwards a numeric argument to getprotobyport(), and the rest to getprotobyname(). +This function is not exported by default. To access this functionality without the core overrides, pass the C<use> an empty import list, and then access diff --git a/contrib/perl5/lib/Pod/Checker.pm b/contrib/perl5/lib/Pod/Checker.pm index ae32677db1a3..0863c80fc888 100644 --- a/contrib/perl5/lib/Pod/Checker.pm +++ b/contrib/perl5/lib/Pod/Checker.pm @@ -10,7 +10,7 @@ package Pod::Checker; use vars qw($VERSION); -$VERSION = 1.098; ## Current version of this package +$VERSION = 1.2; ## Current version of this package require 5.005; ## requires this Perl version or later use Pod::ParseUtils; ## for hyperlinks and lists @@ -44,7 +44,8 @@ This function can take a hash of options: =item B<-warnings> =E<gt> I<val> -Turn warnings on/off. See L<"Warnings">. +Turn warnings on/off. I<val> is usually 1 for on, but higher values +trigger additional warnings. See L<"Warnings">. =back @@ -212,15 +213,14 @@ There is some whitespace on a seemingly empty line. POD is very sensitive to such things, so this is flagged. B<vi> users switch on the B<list> option to avoid this problem. +=begin _disabled_ + =item * file does not start with =head The file starts with a different POD directive than head. This is most probably something you do not want. -=item * No numeric argument for =over - -The C<=over> command is supposed to have a numeric argument (the -indentation). +=end _disabled_ =item * previous =item has no contents @@ -243,7 +243,8 @@ type of the I<first> C<=item> determines the type of the list. Angle brackets not written as C<E<lt>ltE<gt>> and C<E<lt>gtE<gt>> can potentially cause errors as they could be misinterpreted as -markup commands. +markup commands. This is only printed when the -warnings level is +greater than 1. =item * Unknown entity @@ -273,11 +274,36 @@ The NAME section (C<=head1 NAME>) should consist of a single paragraph with the script/module name, followed by a dash `-' and a very short description of what the thing is good for. -=item * Hyperlinks +=back + +=head2 Hyperlinks + +There are some warnings wrt. malformed hyperlinks. + +=over 4 + +=item * ignoring leading/trailing whitespace in link + +There is whitespace at the beginning or the end of the contents of +LE<lt>...E<gt>. -There are some warnings wrt. hyperlinks: -Leading/trailing whitespace, newlines in hyperlinks, -brackets C<()>. +=item * (section) in '$page' deprecated + +There is a section detected in the page name of LE<lt>...E<gt>, e.g. +C<LE<gt>passwd(2)E<gt>>. POD hyperlinks may point to POD documents only. +Please write C<CE<lt>passwd(2)E<gt>> instead. Some formatters are able +to expand this to appropriate code. For links to (builtin) functions, +please say C<LE<lt>perlfunc/mkdirE<gt>>, without (). + +=item * alternative text/node '%s' contains non-escaped | or / + +The characters C<|> and C</> are special in the LE<lt>...E<gt> context. +Although the hyperlink parser does its best to determine which "/" is +text and which is a delimiter in case of doubt, one ought to escape +these literal characters like this: + + / E<sol> + | E<verbar> =back @@ -307,7 +333,6 @@ use strict; use Carp; use Exporter; use Pod::Parser; -require VMS::Filespec if $^O eq 'VMS'; use vars qw(@ISA @EXPORT); @ISA = qw(Pod::Parser); @@ -471,7 +496,6 @@ sub podchecker( $ ; $ % ) { ## Now create a pod checker my $checker = new Pod::Checker(%options); - $checker->parseopts(-process_cut_cmd => 1, -warnings => 1); ## Now check the pod document for errors $checker->parse_from_file($infile, $outfile); @@ -486,6 +510,27 @@ sub podchecker( $ ; $ % ) { ## Method definitions begin here ##------------------------------- +################################## + +=over 4 + +=item C<Pod::Checker-E<gt>new( %options )> + +Return a reference to a new Pod::Checker object that inherits from +Pod::Parser and is used for calling the required methods later. The +following options are recognized: + +C<-warnings =E<gt> num> + Print warnings if C<num> is true. The higher the value of C<num>, +the more warnings are printed. Currently there are only levels 1 and 2. + +C<-quiet =E<gt> num> + If C<num> is true, do not print any errors/warnings. This is useful +when Pod::Checker is used to munge POD code into plain text from within +POD formatters. + +=cut + ## sub new { ## my $this = shift; ## my $class = ref($this) || $this; @@ -501,7 +546,9 @@ sub initialize { ## Initialize number of errors, and setup an error function to ## increment this number and then print to the designated output. $self->{_NUM_ERRORS} = 0; - $self->errorsub('poderror'); # set the error handling subroutine + $self->{-quiet} ||= 0; + # set the error handling subroutine + $self->errorsub($self->{-quiet} ? sub { 1; } : 'poderror'); $self->{_commands} = 0; # total number of POD commands encountered $self->{_list_stack} = []; # stack for nested lists $self->{_have_begin} = ''; # stores =begin @@ -511,12 +558,11 @@ sub initialize { # print warnings? $self->{-warnings} = 1 unless(defined $self->{-warnings}); $self->{_current_head1} = ''; # the current =head1 block + $self->parseopts(-process_cut_cmd => 1, -warnings => $self->{-warnings}); } ################################## -=over 4 - =item C<$checker-E<gt>poderror( @args )> =item C<$checker-E<gt>poderror( {%opts}, @args )> @@ -547,7 +593,6 @@ The error level, should be 'WARNING' or 'ERROR'. sub poderror { my $self = shift; my %opts = (ref $_[0]) ? %{shift()} : (); - $opts{-file} = VMS::Filespec::unixify($opts{-file}) if (exists($opts{-file}) && $^O eq 'VMS'); ## Retrieve options chomp( my $msg = ($opts{-msg} || "")."@_" ); @@ -562,7 +607,7 @@ sub poderror { ## Increment error count and print message " ++($self->{_NUM_ERRORS}) if(!%opts || ($opts{-severity} && $opts{-severity} eq 'ERROR')); - my $out_fh = $self->output_handle(); + my $out_fh = $self->output_handle() || \*STDERR; print $out_fh ($severity, $msg, $line, $file, "\n") if($self->{-warnings} || !%opts || $opts{-severity} ne 'WARNING'); } @@ -672,7 +717,6 @@ sub end_pod { ## print the number of errors found my $self = shift; my $infile = $self->input_file(); - $infile = VMS::Filespec::unixify($infile) if $^O eq 'VMS'; my $out_fh = $self->output_handle(); if(@{$self->{_list_stack}}) { @@ -691,12 +735,15 @@ sub end_pod { my %nodes; foreach($self->node()) { $nodes{$_} = 1; - if(/^(\S+)\s+/) { + if(/^(\S+)\s+\S/) { # we have more than one word. Use the first as a node, too. # This is used heavily in perlfunc.pod $nodes{$1} ||= 2; # derived node } } + foreach($self->idx()) { + $nodes{$_} = 3; # index node + } foreach($self->hyperlink()) { my ($line,$link) = @$_; # _TODO_ what if there is a link to the page itself by the name, @@ -746,24 +793,23 @@ sub command { $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR', -msg => "Unknown command '$cmd'" }); } - else { - # found a valid command - if(!$self->{_commands}++ && $cmd !~ /^head/) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => "file does not start with =head" }); - } - ## check syntax of particular command + else { # found a valid command + $self->{_commands}++; # delete this line if below is enabled again + + ##### following check disabled due to strong request + #if(!$self->{_commands}++ && $cmd !~ /^head/) { + # $self->poderror({ -line => $line, -file => $file, + # -severity => 'WARNING', + # -msg => "file does not start with =head" }); + #} + + # check syntax of particular command if($cmd eq 'over') { # check for argument $arg = $self->interpolate_and_check($paragraph, $line,$file); my $indent = 4; # default if($arg && $arg =~ /^\s*(\d+)\s*$/) { $indent = $1; - } else { - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => "No numeric argument for =over"}); } # start a new list $self->_open_list($indent,$line,$file); @@ -1005,12 +1051,13 @@ sub _check_ptree { unless(ref) { my $count; # count the unescaped angle brackets + # complain only when warning level is greater than 1 my $i = $_; if($count = $i =~ tr/<>/<>/) { $self->poderror({ -line => $line, -file => $file, -severity => 'WARNING', -msg => "$count unescaped <> in paragraph" }) - if($self->{-warnings}); + if($self->{-warnings} && $self->{-warnings}>1); } $text .= $i; next; diff --git a/contrib/perl5/lib/Pod/Find.pm b/contrib/perl5/lib/Pod/Find.pm index 8de197b71da4..4a0ecb9e65a9 100644 --- a/contrib/perl5/lib/Pod/Find.pm +++ b/contrib/perl5/lib/Pod/Find.pm @@ -13,8 +13,9 @@ package Pod::Find; use vars qw($VERSION); -$VERSION = 0.12; ## Current version of this package -require 5.005; ## requires this Perl version or later +$VERSION = 0.21; ## Current version of this package +require 5.005; ## requires this Perl version or later +use Carp; ############################################################################# @@ -32,12 +33,38 @@ Pod::Find - find POD documents in directory trees print "podname=",simplify_name('a/b/c/mymodule.pod'),"\n"; + $location = pod_where( { -inc => 1 }, "Pod::Find" ); + =head1 DESCRIPTION -B<Pod::Find> provides a function B<pod_find> that searches for POD -documents in a given set of files and directories. It returns a hash -with the file names as keys and the POD name as value. The POD name -is derived from the file name and its position in the directory tree. +B<Pod::Find> provides a set of functions to locate POD files. Note that +no function is exported by default to avoid pollution of your namespace, +so be sure to specify them in the B<use> statement if you need them: + + use Pod::Find qw(pod_find); + +=cut + +use strict; +#use diagnostics; +use Exporter; +use File::Spec; +use File::Find; +use Cwd; + +use vars qw(@ISA @EXPORT_OK $VERSION); +@ISA = qw(Exporter); +@EXPORT_OK = qw(&pod_find &simplify_name &pod_where &contains_pod); + +# package global variables +my $SIMPLIFY_RX; + +=head2 C<pod_find( { %opts } , @directories )> + +The function B<pod_find> searches for POD documents in a given set of +files and/or directories. It returns a hash with the file names as keys +and the POD name as value. The POD name is derived from the file name +and its position in the directory tree. E.g. when searching in F<$HOME/perl5lib>, the file F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>, @@ -51,73 +78,39 @@ A warning is printed if more than one POD file with the same POD name is found, e.g. F<CPAN.pm> in different directories. This usually indicates duplicate occurrences of modules in the I<@INC> search path. -The function B<simplify_name> is equivalent to B<basename>, but also -strips Perl-like extensions (.pm, .pl, .pod) and extensions like -F<.bat>, F<.cmd> on Win32 and OS/2, respectively. - -Note that neither B<pod_find> nor B<simplify_name> are exported by -default so be sure to specify them in the B<use> statement if you need -them: - - use Pod::Find qw(pod_find simplify_name); - -=head1 OPTIONS - -The first argument for B<pod_find> may be a hash reference with options. -The rest are either directories that are searched recursively or files. -The POD names of files are the plain basenames with any Perl-like extension -(.pm, .pl, .pod) stripped. +B<OPTIONS> The first argument for B<pod_find> may be a hash reference +with options. The rest are either directories that are searched +recursively or files. The POD names of files are the plain basenames +with any Perl-like extension (.pm, .pl, .pod) stripped. =over 4 -=item B<-verbose> +=item C<-verbose =E<gt> 1> Print progress information while scanning. -=item B<-perl> +=item C<-perl =E<gt> 1> Apply Perl-specific heuristics to find the correct PODs. This includes stripping Perl-like extensions, omitting subdirectories that are numeric but do I<not> match the current Perl interpreter's version id, suppressing F<site_perl> as a module hierarchy name etc. -=item B<-script> +=item C<-script =E<gt> 1> Search for PODs in the current Perl interpreter's installation B<scriptdir>. This is taken from the local L<Config|Config> module. -=item B<-inc> +=item C<-inc =E<gt> 1> Search for PODs in the current Perl interpreter's I<@INC> paths. This -automatically considers paths specified in the C<PERL5LIB> environment. +automatically considers paths specified in the C<PERL5LIB> environment +as this is prepended to I<@INC> by the Perl interpreter itself. =back -=head1 AUTHOR - -Marek Rouchal E<lt>marek@saftsack.fs.uni-bayreuth.deE<gt>, -heavily borrowing code from Nick Ing-Simmons' PodToHtml. - -=head1 SEE ALSO - -L<Pod::Parser>, L<Pod::Checker> - =cut -use strict; -#use diagnostics; -use Exporter; -use File::Spec; -use File::Find; -use Cwd; - -use vars qw(@ISA @EXPORT_OK $VERSION); -@ISA = qw(Exporter); -@EXPORT_OK = qw(&pod_find &simplify_name); - -# package global variables -my $SIMPLIFY_RX; - # return a hash of the POD files found # first argument may be a hashref (options), # rest is a list of directories to search recursively @@ -152,7 +145,7 @@ sub pod_find # * remove e.g. 5.00503 # * remove pod/ if followed by *.pod (e.g. in pod/perlfunc.pod) $SIMPLIFY_RX = - qq!^(?i:site_perl/|\Q$Config::Config{archname}\E/|\\d+\\.\\d+([_.]?\\d+)?/|pod/(?=.*?\\.pod\\z))*!; + qq!^(?i:site(_perl)?/|\Q$Config::Config{archname}\E/|\\d+\\.\\d+([_.]?\\d+)?/|pod/(?=.*?\\.pod\\z))*!; } @@ -167,7 +160,9 @@ sub pod_find $try = File::Spec->catfile($pwd,$try); } # simplify path - $try = File::Spec->canonpath($try); + # on VMS canonpath will vmsify:[the.path], but File::Find::find + # wants /unixy/paths + $try = File::Spec->canonpath($try) if ($^O ne 'VMS'); my $name; if(-f $try) { if($name = _check_and_extract_name($try, $opts{-verbose})) { @@ -222,27 +217,14 @@ sub _check_and_extract_name { # check extension or executable flag # this involves testing the .bat extension on Win32! - unless($file =~ /\.(pod|pm|plx?)\z/i || (-f $file && -x _ && -T _)) { - return undef; + unless(-f $file && -T _ && ($file =~ /\.(pod|pm|plx?)\z/i || -x _ )) { + return undef; } - # check for one line of POD - unless(open(POD,"<$file")) { - warn "Error: $file is unreadable: $!\n"; - return undef; - } - local $/ = undef; - my $pod = <POD>; - close(POD); - unless($pod =~ /\n=(head\d|pod|over|item)\b/) { - warn "No POD in $file, skipping.\n" - if($verbose); - return; - } - undef $pod; + return undef unless contains_pod($file,$verbose); # strip non-significant path components - # _TODO_ what happens on e.g. Win32? + # TODO what happens on e.g. Win32? my $name = $file; if(defined $root_rx) { $name =~ s!$root_rx!!s; @@ -256,6 +238,14 @@ sub _check_and_extract_name { $name; } +=head2 C<simplify_name( $str )> + +The function B<simplify_name> is equivalent to B<basename>, but also +strips Perl-like extensions (.pm, .pl, .pod) and extensions like +F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively. + +=cut + # basic simplification of the POD name: # basename & strip extension sub simplify_name { @@ -271,8 +261,185 @@ sub _simplify { # strip Perl's own extensions $_[0] =~ s/\.(pod|pm|plx?)\z//i; # strip meaningless extensions on Win32 and OS/2 - $_[0] =~ s/\.(bat|exe|cmd)\z//i if($^O =~ /win|os2/i); + $_[0] =~ s/\.(bat|exe|cmd)\z//i if($^O =~ /mswin|os2/i); + # strip meaningless extensions on VMS + $_[0] =~ s/\.(com)\z//i if($^O eq 'VMS'); } +# contribution from Tim Jenness <t.jenness@jach.hawaii.edu> + +=head2 C<pod_where( { %opts }, $pod )> + +Returns the location of a pod document given a search directory +and a module (e.g. C<File::Find>) or script (e.g. C<perldoc>) name. + +Options: + +=over 4 + +=item C<-inc =E<gt> 1> + +Search @INC for the pod and also the C<scriptdir> defined in the +L<Config|Config> module. + +=item C<-dirs =E<gt> [ $dir1, $dir2, ... ]> + +Reference to an array of search directories. These are searched in order +before looking in C<@INC> (if B<-inc>). Current directory is used if +none are specified. + +=item C<-verbose =E<gt> 1> + +List directories as they are searched + +=back + +Returns the full path of the first occurence to the file. +Package names (eg 'A::B') are automatically converted to directory +names in the selected directory. (eg on unix 'A::B' is converted to +'A/B'). Additionally, '.pm', '.pl' and '.pod' are appended to the +search automatically if required. + +A subdirectory F<pod/> is also checked if it exists in any of the given +search directories. This ensures that e.g. L<perlfunc|perlfunc> is +found. + +It is assumed that if a module name is supplied, that that name +matches the file name. Pods are not opened to check for the 'NAME' +entry. + +A check is made to make sure that the file that is found does +contain some pod documentation. + +=cut + +sub pod_where { + + # default options + my %options = ( + '-inc' => 0, + '-verbose' => 0, + '-dirs' => [ '.' ], + ); + + # Check for an options hash as first argument + if (defined $_[0] && ref($_[0]) eq 'HASH') { + my $opt = shift; + + # Merge default options with supplied options + %options = (%options, %$opt); + } + + # Check usage + carp 'Usage: pod_where({options}, $pod)' unless (scalar(@_)); + + # Read argument + my $pod = shift; + + # Split on :: and then join the name together using File::Spec + my @parts = split (/::/, $pod); + + # Get full directory list + my @search_dirs = @{ $options{'-dirs'} }; + + if ($options{'-inc'}) { + + require Config; + + # Add @INC + push (@search_dirs, @INC) if $options{'-inc'}; + + # Add location of pod documentation for perl man pages (eg perlfunc) + # This is a pod directory in the private install tree + #my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'}, + # 'pod'); + #push (@search_dirs, $perlpoddir) + # if -d $perlpoddir; + + # Add location of binaries such as pod2text + push (@search_dirs, $Config::Config{'scriptdir'}) + if -d $Config::Config{'scriptdir'}; + } + + # Loop over directories + Dir: foreach my $dir ( @search_dirs ) { + + # Don't bother if cant find the directory + if (-d $dir) { + warn "Looking in directory $dir\n" + if $options{'-verbose'}; + + # Now concatenate this directory with the pod we are searching for + my $fullname = File::Spec->catfile($dir, @parts); + warn "Filename is now $fullname\n" + if $options{'-verbose'}; + + # Loop over possible extensions + foreach my $ext ('', '.pod', '.pm', '.pl') { + my $fullext = $fullname . $ext; + if (-f $fullext && + contains_pod($fullext, $options{'-verbose'}) ) { + warn "FOUND: $fullext\n" if $options{'-verbose'}; + return $fullext; + } + } + } else { + warn "Directory $dir does not exist\n" + if $options{'-verbose'}; + next Dir; + } + if(-d File::Spec->catdir($dir,'pod')) { + $dir = File::Spec->catdir($dir,'pod'); + redo Dir; + } + } + # No match; + return undef; +} + +=head2 C<contains_pod( $file , $verbose )> + +Returns true if the supplied filename (not POD module) contains some pod +information. + +=cut + +sub contains_pod { + my $file = shift; + my $verbose = 0; + $verbose = shift if @_; + + # check for one line of POD + unless(open(POD,"<$file")) { + warn "Error: $file is unreadable: $!\n"; + return undef; + } + + local $/ = undef; + my $pod = <POD>; + close(POD) || die "Error closing $file: $!\n"; + unless($pod =~ /\n=(head\d|pod|over|item)\b/s) { + warn "No POD in $file, skipping.\n" + if($verbose); + return 0; + } + + return 1; +} + +=head1 AUTHOR + +Marek Rouchal E<lt>marek@saftsack.fs.uni-bayreuth.deE<gt>, +heavily borrowing code from Nick Ing-Simmons' PodToHtml. + +Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt> provided +C<pod_where> and C<contains_pod>. + +=head1 SEE ALSO + +L<Pod::Parser>, L<Pod::Checker>, L<perldoc> + +=cut + 1; diff --git a/contrib/perl5/lib/Pod/Functions.pm b/contrib/perl5/lib/Pod/Functions.pm index 03cbf711eb6d..44619d53d8bb 100644 --- a/contrib/perl5/lib/Pod/Functions.pm +++ b/contrib/perl5/lib/Pod/Functions.pm @@ -296,7 +296,7 @@ values HASH return a list of the values in a hash vec Binary test or set particular bits in a string wait Process wait for any child process to die waitpid Process wait for a particular child process to die -wantarray Misc,Flow get list vs array context of current subroutine call +wantarray Misc,Flow get void vs scalar vs list context of current subroutine call warn I/O print debugging info write I/O print a picture record y/// String transliterate a string diff --git a/contrib/perl5/lib/Pod/Html.pm b/contrib/perl5/lib/Pod/Html.pm index 89e3d0f43259..f70a42bccce9 100644 --- a/contrib/perl5/lib/Pod/Html.pm +++ b/contrib/perl5/lib/Pod/Html.pm @@ -893,6 +893,10 @@ sub scan_dir { $pages{$_} = "" unless defined $pages{$_}; $pages{$_} .= "$dir/$_.pod:"; push(@pods, "$dir/$_.pod"); + } elsif (/\.html\z/) { # .html + s/\.html\z//; + $pages{$_} = "" unless defined $pages{$_}; + $pages{$_} .= "$dir/$_.pod:"; } elsif (/\.pm\z/) { # .pm s/\.pm\z//; $pages{$_} = "" unless defined $pages{$_}; @@ -1438,8 +1442,10 @@ sub process_text1($$;$$){ } elsif( $func eq 'E' ){ # E<x> - convert to character - $$rstr =~ s/^(\w+)>//; - $res = "&$1;"; + $$rstr =~ s/^([^>]*)>//; + my $escape = $1; + $escape =~ s/^(\d+|X[\dA-F]+)$/#$1/i; + $res = "&$escape;"; } elsif( $func eq 'F' ){ # F<filename> - italizice @@ -1940,7 +1946,7 @@ sub depod1($;$$){ $res .= $$rstr; } elsif( $func eq 'E' ){ # E<x> - convert to character - $$rstr =~ s/^(\w+)>//; + $$rstr =~ s/^([^>]*)>//; $res .= $E2c{$1} || ""; } elsif( $func eq 'X' ){ # X<> - ignore diff --git a/contrib/perl5/lib/Pod/InputObjects.pm b/contrib/perl5/lib/Pod/InputObjects.pm index 849182bf3717..352373b9da40 100644 --- a/contrib/perl5/lib/Pod/InputObjects.pm +++ b/contrib/perl5/lib/Pod/InputObjects.pm @@ -11,7 +11,7 @@ package Pod::InputObjects; use vars qw($VERSION); -$VERSION = 1.12; ## Current version of this package +$VERSION = 1.13; ## Current version of this package require 5.005; ## requires this Perl version or later ############################################################################# @@ -42,7 +42,7 @@ are defined: =begin __PRIVATE__ -=item B<Pod::InputSource> +=item package B<Pod::InputSource> An object corresponding to a source of POD input text. It is mostly a wrapper around a filehandle or C<IO::Handle>-type object (or anything @@ -51,23 +51,23 @@ additional information relevant to the parsing of PODs. =end __PRIVATE__ -=item B<Pod::Paragraph> +=item package B<Pod::Paragraph> An object corresponding to a paragraph of POD input text. It may be a plain paragraph, a verbatim paragraph, or a command paragraph (see L<perlpod>). -=item B<Pod::InteriorSequence> +=item package B<Pod::InteriorSequence> An object corresponding to an interior sequence command from the POD input text (see L<perlpod>). -=item B<Pod::ParseTree> +=item package B<Pod::ParseTree> An object corresponding to a tree of parsed POD text. Each "node" in a parse-tree (or I<ptree>) is either a text-string or a reference to a B<Pod::InteriorSequence> object. The nodes appear in the parse-tree -in they order in which they were parsed from left-to-right. +in the order in which they were parsed from left-to-right. =back @@ -232,7 +232,7 @@ It has the following methods/attributes: ##--------------------------------------------------------------------------- -=head2 B<new()> +=head2 Pod::Paragraph-E<gt>B<new()> my $pod_para1 = Pod::Paragraph->new(-text => $text); my $pod_para2 = Pod::Paragraph->new(-name => $cmd, @@ -284,7 +284,7 @@ sub new { ##--------------------------------------------------------------------------- -=head2 B<cmd_name()> +=head2 $pod_para-E<gt>B<cmd_name()> my $para_cmd = $pod_para->cmd_name(); @@ -303,7 +303,7 @@ sub cmd_name { ##--------------------------------------------------------------------------- -=head2 B<text()> +=head2 $pod_para-E<gt>B<text()> my $para_text = $pod_para->text(); @@ -318,7 +318,7 @@ sub text { ##--------------------------------------------------------------------------- -=head2 B<raw_text()> +=head2 $pod_para-E<gt>B<raw_text()> my $raw_pod_para = $pod_para->raw_text(); @@ -335,7 +335,7 @@ sub raw_text { ##--------------------------------------------------------------------------- -=head2 B<cmd_prefix()> +=head2 $pod_para-E<gt>B<cmd_prefix()> my $prefix = $pod_para->cmd_prefix(); @@ -351,7 +351,7 @@ sub cmd_prefix { ##--------------------------------------------------------------------------- -=head2 B<cmd_separator()> +=head2 $pod_para-E<gt>B<cmd_separator()> my $separator = $pod_para->cmd_separator(); @@ -367,7 +367,7 @@ sub cmd_separator { ##--------------------------------------------------------------------------- -=head2 B<parse_tree()> +=head2 $pod_para-E<gt>B<parse_tree()> my $ptree = $pod_parser->parse_text( $pod_para->text() ); $pod_para->parse_tree( $ptree ); @@ -387,13 +387,13 @@ sub parse_tree { ##--------------------------------------------------------------------------- -=head2 B<file_line()> +=head2 $pod_para-E<gt>B<file_line()> my ($filename, $line_number) = $pod_para->file_line(); my $position = $pod_para->file_line(); Returns the current filename and line number for the paragraph -object. If called in an array context, it returns a list of two +object. If called in a list context, it returns a list of two elements: first the filename, then the line number. If called in a scalar context, it returns a string containing the filename, followed by a colon (':'), followed by the line number. @@ -423,7 +423,7 @@ It has the following methods/attributes: ##--------------------------------------------------------------------------- -=head2 B<new()> +=head2 Pod::InteriorSequence-E<gt>B<new()> my $pod_seq1 = Pod::InteriorSequence->new(-name => $cmd -ldelim => $delimiter); @@ -497,7 +497,7 @@ sub new { ##--------------------------------------------------------------------------- -=head2 B<cmd_name()> +=head2 $pod_seq-E<gt>B<cmd_name()> my $seq_cmd = $pod_seq->cmd_name(); @@ -546,7 +546,7 @@ sub _unset_child2parent_links { ##--------------------------------------------------------------------------- -=head2 B<prepend()> +=head2 $pod_seq-E<gt>B<prepend()> $pod_seq->prepend($text); $pod_seq1->prepend($pod_seq2); @@ -565,7 +565,7 @@ sub prepend { ##--------------------------------------------------------------------------- -=head2 B<append()> +=head2 $pod_seq-E<gt>B<append()> $pod_seq->append($text); $pod_seq1->append($pod_seq2); @@ -584,7 +584,7 @@ sub append { ##--------------------------------------------------------------------------- -=head2 B<nested()> +=head2 $pod_seq-E<gt>B<nested()> $outer_seq = $pod_seq->nested || print "not nested"; @@ -602,7 +602,7 @@ sub nested { ##--------------------------------------------------------------------------- -=head2 B<raw_text()> +=head2 $pod_seq-E<gt>B<raw_text()> my $seq_raw_text = $pod_seq->raw_text(); @@ -623,7 +623,7 @@ sub raw_text { ##--------------------------------------------------------------------------- -=head2 B<left_delimiter()> +=head2 $pod_seq-E<gt>B<left_delimiter()> my $ldelim = $pod_seq->left_delimiter(); @@ -642,7 +642,7 @@ sub left_delimiter { ##--------------------------------------------------------------------------- -=head2 B<right_delimiter()> +=head2 $pod_seq-E<gt>B<right_delimiter()> The rightmost delimiter beginning the argument text to the interior sequence (should be ">"). @@ -659,7 +659,7 @@ sub right_delimiter { ##--------------------------------------------------------------------------- -=head2 B<parse_tree()> +=head2 $pod_seq-E<gt>B<parse_tree()> my $ptree = $pod_parser->parse_text($paragraph_text); $pod_seq->parse_tree( $ptree ); @@ -680,13 +680,13 @@ sub parse_tree { ##--------------------------------------------------------------------------- -=head2 B<file_line()> +=head2 $pod_seq-E<gt>B<file_line()> my ($filename, $line_number) = $pod_seq->file_line(); my $position = $pod_seq->file_line(); Returns the current filename and line number for the interior sequence -object. If called in an array context, it returns a list of two +object. If called in a list context, it returns a list of two elements: first the filename, then the line number. If called in a scalar context, it returns a string containing the filename, followed by a colon (':'), followed by the line number. @@ -701,7 +701,7 @@ sub file_line { ##--------------------------------------------------------------------------- -=head2 B<DESTROY()> +=head2 Pod::InteriorSequence::B<DESTROY()> This method performs any necessary cleanup for the interior-sequence. If you override this method then it is B<imperative> that you invoke @@ -738,7 +738,7 @@ itself contain a parse-tree (since interior sequences may be nested). ##--------------------------------------------------------------------------- -=head2 B<new()> +=head2 Pod::ParseTree-E<gt>B<new()> my $ptree1 = Pod::ParseTree->new; my $ptree2 = new Pod::ParseTree; @@ -766,7 +766,7 @@ sub new { ##--------------------------------------------------------------------------- -=head2 B<top()> +=head2 $ptree-E<gt>B<top()> my $top_node = $ptree->top(); $ptree->top( $top_node ); @@ -794,7 +794,7 @@ sub top { ##--------------------------------------------------------------------------- -=head2 B<children()> +=head2 $ptree-E<gt>B<children()> This method gets/sets the children of the top node in the parse-tree. If no arguments are given, it returns the list (array) of children @@ -814,7 +814,7 @@ sub children { ##--------------------------------------------------------------------------- -=head2 B<prepend()> +=head2 $ptree-E<gt>B<prepend()> This method prepends the given text or parse-tree to the current parse-tree. If the first item on the parse-tree is text and the argument is also text, @@ -842,7 +842,7 @@ sub prepend { ##--------------------------------------------------------------------------- -=head2 B<append()> +=head2 $ptree-E<gt>B<append()> This method appends the given text or parse-tree to the current parse-tree. If the last item on the parse-tree is text and the argument is also text, @@ -866,7 +866,7 @@ sub append { } } -=head2 B<raw_text()> +=head2 $ptree-E<gt>B<raw_text()> my $ptree_raw_text = $ptree->raw_text(); @@ -902,7 +902,7 @@ sub _set_child2parent_links { ## nothing to do, Pod::ParseTrees cant have parent pointers } -=head2 B<DESTROY()> +=head2 Pod::ParseTree::B<DESTROY()> This method performs any necessary cleanup for the parse-tree. If you override this method then it is B<imperative> diff --git a/contrib/perl5/lib/Pod/Man.pm b/contrib/perl5/lib/Pod/Man.pm index 97a382823e6f..31036826b955 100644 --- a/contrib/perl5/lib/Pod/Man.pm +++ b/contrib/perl5/lib/Pod/Man.pm @@ -1,7 +1,7 @@ # Pod::Man -- Convert POD data to formatted *roff input. -# $Id: Man.pm,v 1.2 2000/03/19 07:30:13 eagle Exp $ +# $Id: Man.pm,v 1.15 2001/02/10 06:50:22 eagle Exp $ # -# Copyright 1999, 2000 by Russ Allbery <rra@stanford.edu> +# Copyright 1999, 2000, 2001 by Russ Allbery <rra@stanford.edu> # # This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. @@ -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.02; +$VERSION = 1.15; ############################################################################ @@ -47,8 +47,10 @@ $VERSION = 1.02; # The following is the static preamble which starts all *roff output we # generate. It's completely static except for the font to use as a -# fixed-width font, which is designed by @CFONT@. $PREAMBLE should -# therefore be run through s/\@CFONT\@/<font>/g before output. +# fixed-width font, which is designed by @CFONT@, and the left and right +# quotes to use for C<> text, designated by @LQOUTE@ and @RQUOTE@. +# $PREAMBLE should therefore be run through s/\@CFONT\@/<font>/g before +# output. $PREAMBLE = <<'----END OF PREAMBLE----'; .de Sh \" Subsection heading .br @@ -93,8 +95,8 @@ $PREAMBLE = <<'----END OF PREAMBLE----'; . if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch . ds L" "" . ds R" "" -. ds C` ` -. ds C' ' +. ds C` @LQUOTE@ +. ds C' @RQUOTE@ 'br\} .el\{\ . ds -- \|\(em\| @@ -110,7 +112,7 @@ $PREAMBLE = <<'----END OF PREAMBLE----'; .if \nF \{\ . de IX . tm Index:\\$1\t\\n%\t"\\$2" -. . +.. . nr % 0 . rr F .\} @@ -183,7 +185,8 @@ $PREAMBLE = <<'----END OF PREAMBLE----'; .\} .rm #[ #] #H #V #F C ----END OF PREAMBLE---- - +#`# for cperl-mode + # This table is taken nearly verbatim from Tom Christiansen's pod2man. It # assumes that the standard preamble has already been printed, since that's # what defines all of the accent marks. Note that some of these are quoted @@ -194,6 +197,8 @@ $PREAMBLE = <<'----END OF PREAMBLE----'; 'lt' => '<', # left chevron, less-than 'gt' => '>', # right chevron, greater-than 'quot' => '"', # double quote + 'sol' => '/', # solidus (forward slash) + 'verbar' => '|', # vertical bar 'Aacute' => "A\\*'", # capital A, acute accent 'aacute' => "a\\*'", # small a, acute accent @@ -273,38 +278,11 @@ sub protect { s/^([.\'\\])/\\&$1/mg; $_; } - -# 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] } - + ############################################################################ # Initialization ############################################################################ @@ -323,7 +301,8 @@ sub initialize { for (qw/fixed fixedbold fixeditalic fixedbolditalic/) { if (defined $$self{$_}) { if (length ($$self{$_}) < 1 || length ($$self{$_}) > 2) { - croak "roff font should be 1 or 2 chars, not `$$self{$_}'"; + croak qq(roff font should be 1 or 2 chars,) + . qq( not "$$self{$_}"); } } else { $$self{$_} = ''; @@ -368,16 +347,35 @@ sub initialize { $$self{$_} =~ s/\"/\"\"/g if $$self{$_}; } + # Figure out what quotes we'll be using for C<> text. + $$self{quotes} ||= '"'; + if ($$self{quotes} eq 'none') { + $$self{LQUOTE} = $$self{RQUOTE} = ''; + } elsif (length ($$self{quotes}) == 1) { + $$self{LQUOTE} = $$self{RQUOTE} = $$self{quotes}; + } elsif ($$self{quotes} =~ /^(.)(.)$/ + || $$self{quotes} =~ /^(..)(..)$/) { + $$self{LQUOTE} = $1; + $$self{RQUOTE} = $2; + } else { + croak qq(Invalid quote specification "$$self{quotes}"); + } + + # Double the first quote; note that this should not be s///g as two + # double quotes is represented in *roff as three double quotes, not + # four. Weird, I know. + $$self{LQUOTE} =~ s/\"/\"\"/; + $$self{RQUOTE} =~ s/\"/\"\"/; + $$self{INDENT} = 0; # Current indentation level. $$self{INDENTS} = []; # Stack of indentations. $$self{INDEX} = []; # Index keys waiting to be printed. + $$self{ITEMS} = 0; # The number of consecutive =items. $self->SUPER::initialize; } -# For each document we process, output the preamble first. Note that the -# fixed width font is a global default; once we interpolate it into the -# PREAMBLE, it ain't ever changing. Maybe fix this later. +# For each document we process, output the preamble first. sub begin_pod { my $self = shift; @@ -412,6 +410,10 @@ sub begin_pod { } } + # If $name contains spaces, quote it; this mostly comes up in the case + # of input from stdin. + $name = '"' . $name . '"' if ($name =~ /\s/); + # Modification date header. Try to use the modification time of our # input. if (!defined $$self{date}) { @@ -423,15 +425,18 @@ sub begin_pod { } # Now, print out the preamble and the title. - $PREAMBLE =~ s/\@CFONT\@/$$self{fixed}/; - chomp $PREAMBLE; + local $_ = $PREAMBLE; + s/\@CFONT\@/$$self{fixed}/; + s/\@LQUOTE\@/$$self{LQUOTE}/; + s/\@RQUOTE\@/$$self{RQUOTE}/; + chomp $_; print { $self->output_handle } <<"----END OF HEADER----"; .\\" Automatically generated by Pod::Man version $VERSION .\\" @{[ scalar localtime ]} .\\" .\\" Standard preamble: .\\" ====================================================================== -$PREAMBLE +$_ .\\" ====================================================================== .\\" .IX Title "$name $section" @@ -458,9 +463,19 @@ sub command { my $self = shift; my $command = shift; return if $command eq 'pod'; - return if ($$self{EXCLUDE} && $command ne 'end'); - $command = 'cmd_' . $command; - $self->$command (@_); + return if ($$self{EXCLUDE} && $command ne 'end'); + if ($self->can ('cmd_' . $command)) { + $command = 'cmd_' . $command; + $self->$command (@_); + } else { + my ($text, $line, $paragraph) = @_; + my $file; + ($file, $line) = $paragraph->file_line; + $text =~ s/\n+\z//; + $text = " $text" if ($text =~ /^\S/); + warn qq($file:$line: Unknown command paragraph "=$command$text"\n); + return; + } } # Called for a verbatim paragraph. Gets the paragraph, the line number, and @@ -477,7 +492,7 @@ sub verbatim { 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me; s/\\/\\e/g; s/^(\s*\S)/'\&' . $1/gme; - $self->makespace if $$self{NEEDSPACE}; + $self->makespace; $self->output (".Vb $lines\n$_.Ve\n"); $$self{NEEDSPACE} = 0; } @@ -503,7 +518,7 @@ sub textblock { > ( ,?\s+(and\s+)? # Allow lots of them, conjuncted. - L< + L< / ( [:\w]+ ( \(\) )? ) > @@ -529,8 +544,8 @@ sub textblock { # scalars as well as scalars and does the right thing with them. $text = $self->parse ($text, @_); $text =~ s/\n\s*$/\n/; - $self->makespace if $$self{NEEDSPACE}; - $self->output (protect $self->mapfonts ($text)); + $self->makespace; + $self->output (protect $self->textmapfonts ($text)); $self->outindex; $$self{NEEDSPACE} = 1; } @@ -550,8 +565,11 @@ sub sequence { return bless \ "$tmp", 'Pod::Man::String'; } - # C<>, L<>, X<>, and E<> don't apply guesswork to their contents. - local $_ = $self->collapse ($seq->parse_tree, $command =~ /^[CELX]$/); + # C<>, L<>, X<>, and E<> don't apply guesswork to their contents. C<> + # needs some additional special handling. + my $literal = ($command =~ /^[CELX]$/); + $literal++ if $command eq 'C'; + local $_ = $self->collapse ($seq->parse_tree, $literal); # Handle E<> escapes. if ($command eq 'E') { @@ -576,8 +594,6 @@ sub sequence { } elsif ($command eq 'I') { return bless \ ('\f(IS' . $_ . '\f(IE'), 'Pod::Man::String'; } elsif ($command eq 'C') { - s/-/\\-/g; - s/__/_\\|_/g; return bless \ ('\f(FS\*(C`' . $_ . "\\*(C'\\f(FE"), 'Pod::Man::String'; } @@ -588,7 +604,7 @@ sub sequence { my $tmp = $self->buildlink ($_); return bless \ "$tmp", 'Pod::Man::String'; } - + # Whitespace protection replaces whitespace with "\ ". if ($command eq 'S') { s/\s+/\\ /g; @@ -618,7 +634,12 @@ sub cmd_head1 { local $_ = $self->parse (@_); s/\s+$//; s/\\s-?\d//g; - $self->output (switchquotes ('.SH', $self->mapfonts ($_))); + s/\s*\n\s*/ /g; + if ($$self{ITEMS} > 1) { + $$self{ITEMS} = 0; + $self->output (".PD\n"); + } + $self->output ($self->switchquotes ('.SH', $self->mapfonts ($_))); $self->outindex (($_ eq 'NAME') ? () : ('Header', $_)); $$self{NEEDSPACE} = 0; } @@ -628,11 +649,48 @@ sub cmd_head2 { my $self = shift; local $_ = $self->parse (@_); s/\s+$//; - $self->output (switchquotes ('.Sh', $self->mapfonts ($_))); + s/\s*\n\s*/ /g; + if ($$self{ITEMS} > 1) { + $$self{ITEMS} = 0; + $self->output (".PD\n"); + } + $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+$//; + s/\s*\n\s*/ /g; + 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+$//; + s/\s*\n\s*/ /g; + 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 { @@ -682,17 +740,19 @@ sub cmd_item { my $index; if (/\w/ && !/^\w[.\)]\s*$/) { $index = $_; - $index =~ s/^\s*[-*+o.]?\s*//; + $index =~ s/^\s*[-*+o.]?(?:\s+|\Z)//; } s/^\*(\s|\Z)/\\\(bu$1/; if ($$self{WEIRDINDENT}) { $self->output (".RE\n"); $$self{WEIRDINDENT} = 0; } - $_ = $self->mapfonts ($_); - $self->output (switchquotes ('.Ip', $_, $$self{INDENT})); + $_ = $self->textmapfonts ($_); + $self->output (".PD 0\n") if ($$self{ITEMS} == 1); + $self->output ($self->switchquotes ('.Ip', $_, $$self{INDENT})); $self->outindex ($index ? ('Item', $index) : ()); $$self{NEEDSPACE} = 0; + $$self{ITEMS}++; } # Begin a block for a particular translator. Setting VERBATIM triggers @@ -746,6 +806,10 @@ sub buildlink { s/^\s+//; s/\s+$//; + # If the argument looks like a URL, return it verbatim. This only + # handles URLs that use the server syntax. + if (m%^[a-z]+://\S+$%) { return $_ } + # Default to using the whole content of the link entry as a section # name. Note that L<manpage/> forces a manpage interpretation, as does # something looking like L<manpage(section)>. Do the same thing to @@ -795,18 +859,52 @@ sub buildlink { # At this point, we'll have embedded font codes of the form \f(<font>[SE] # where <font> is one of B, I, or F. Turn those into the right font start -# or end codes. B<someI<thing> 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<someI<thing> 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)}; @@ -825,13 +923,15 @@ sub parse { $self->parse_text ({ -expand_seq => 'sequence', -expand_ptree => 'collapse' }, @_); } - + # Takes a parse tree and a flag saying whether or not to treat it as literal # text (not call guesswork on it), and returns the concatenation of all of # the text strings in that parse tree. If the literal flag isn't true, # guesswork() will be called on all plain scalars in the parse tree. -# Assumes that everything in the parse tree is either a scalar or a -# reference to a scalar. +# Otherwise, just escape backslashes in the normal case. If collapse is +# being called on a C<> sequence, literal is set to 2, and we do some +# additional cleanup. Assumes that everything in the parse tree is either a +# scalar or a reference to a scalar. sub collapse { my ($self, $ptree, $literal) = @_; if ($literal) { @@ -840,6 +940,8 @@ sub collapse { $$_; } else { s/\\/\\e/g; + s/-/\\-/g if $literal > 1; + s/__/_\\|_/g if $literal > 1; $_; } } $ptree->children); @@ -935,7 +1037,10 @@ sub guesswork { # Make vertical whitespace. sub makespace { my $self = shift; - $self->output ($$self{INDENT} > 0 ? ".Sp\n" : ".PP\n"); + $self->output (".PD\n") if ($$self{ITEMS} > 1); + $$self{ITEMS} = 0; + $self->output ($$self{INDENT} > 0 ? ".Sp\n" : ".PP\n") + if $$self{NEEDSPACE}; } # Output any pending index entries, and optionally an index entry given as @@ -964,6 +1069,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 @@ -1096,6 +1239,18 @@ Pod::Man doesn't assume you have this, and defaults to CB. Some systems (such as Solaris) have this font available as CX. Only matters for troff(1) output. +=item quotes + +Sets the quote marks used to surround CE<lt>> text. If the value is a +single character, it is used as both the left and right quote; if it is two +characters, the first character is used as the left quote and the second as +the right quoted; and if it is four characters, the first two are used as +the left quote and the second two as the right quote. + +This may also be set to the special value C<none>, in which case no quote +marks are added around CE<lt>> text (but the font is still changed for troff +output). + =item release Set the centered footer. By default, this is the version of Perl you run @@ -1132,7 +1287,7 @@ details. =over 4 -=item roff font should be 1 or 2 chars, not `%s' +=item roff font should be 1 or 2 chars, not "%s" (F) You specified a *roff font (using C<fixed>, C<fixedbold>, etc.) that wasn't either one or two characters. Pod::Man doesn't support *roff fonts @@ -1145,6 +1300,16 @@ versions of nroff(1) and troff(1) don't either). unable to parse. You should never see this error message; it probably indicates a bug in Pod::Man. +=item Invalid quote specification "%s" + +(F) The quote specification given (the quotes option to the constructor) was +invalid. A quote specification must be one, two, or four characters long. + +=item %s:%d: Unknown command paragraph "%s". + +(W) The POD source contained a non-standard command paragraph (something of +the form C<=command args>) that Pod::Man didn't know about. It was ignored. + =item Unknown escape EE<lt>%sE<gt> (W) The POD source contained an C<EE<lt>E<gt>> escape that Pod::Man didn't @@ -1155,6 +1320,11 @@ know about. C<EE<lt>%sE<gt>> was printed verbatim in the output. (W) The POD source contained a non-standard interior sequence (something of the form C<XE<lt>E<gt>>) that Pod::Man didn't know about. It was ignored. +=item %s: Unknown command paragraph "%s" on line %d. + +(W) The POD source contained a non-standard command paragraph (something of +the form C<=command args>) that Pod::Man didn't know about. It was ignored. + =item Unmatched =back (W) Pod::Man encountered a C<=back> command that didn't correspond to an diff --git a/contrib/perl5/lib/Pod/ParseUtils.pm b/contrib/perl5/lib/Pod/ParseUtils.pm index 2cb8cdcd3bcd..7d994c750bdc 100644 --- a/contrib/perl5/lib/Pod/ParseUtils.pm +++ b/contrib/perl5/lib/Pod/ParseUtils.pm @@ -10,7 +10,7 @@ package Pod::ParseUtils; use vars qw($VERSION); -$VERSION = 0.2; ## Current version of this package +$VERSION = 0.22; ## Current version of this package require 5.005; ## requires this Perl version or later =head1 NAME @@ -49,7 +49,7 @@ The following methods are available: =over 4 -=item new() +=item Pod::List-E<gt>new() Create a new list object. Properties may be specified through a hash reference like this: @@ -79,7 +79,7 @@ sub initialize { $self->{-type} ||= ''; } -=item file() +=item $list-E<gt>file() Without argument, retrieves the file name the list is in. This must have been set before by either specifying B<-file> in the B<new()> @@ -92,7 +92,7 @@ sub file { return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; } -=item start() +=item $list-E<gt>start() Without argument, retrieves the line number where the list started. This must have been set before by either specifying B<-start> in the @@ -106,7 +106,7 @@ sub start { return (@_ > 1) ? ($_[0]->{-start} = $_[1]) : $_[0]->{-start}; } -=item indent() +=item $list-E<gt>indent() Without argument, retrieves the indent level of the list as specified in C<=over n>. This must have been set before by either specifying @@ -120,7 +120,7 @@ sub indent { return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent}; } -=item type() +=item $list-E<gt>type() Without argument, retrieves the list type, which can be an arbitrary value, e.g. C<OL>, C<UL>, ... when thinking the HTML way. @@ -135,7 +135,7 @@ sub type { return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; } -=item rx() +=item $list-E<gt>rx() Without argument, retrieves a regular expression for simplifying the individual item strings once the list type has been determined. Usage: @@ -152,7 +152,7 @@ sub rx { return (@_ > 1) ? ($_[0]->{-rx} = $_[1]) : $_[0]->{-rx}; } -=item item() +=item $list-E<gt>item() Without argument, retrieves the array of the items in this list. The items may be represented by any scalar. @@ -172,7 +172,7 @@ sub item { } } -=item parent() +=item $list-E<gt>parent() Without argument, retrieves information about the parent holding this list, which is represented as an arbitrary scalar. @@ -188,7 +188,7 @@ sub parent { return (@_ > 1) ? ($_[0]->{-parent} = $_[1]) : $_[0]->{-parent}; } -=item tag() +=item $list-E<gt>tag() Without argument, retrieves information about the list tag, which can be any scalar. @@ -227,7 +227,7 @@ used to construct hyperlinks. =over 4 -=item new() +=item Pod::Hyperlink-E<gt>new() The B<new()> method can either be passed a set of key/value pairs or a single scalar value, namely the contents of a C<LE<lt>...E<gt>> sequence. An object @@ -269,10 +269,14 @@ sub initialize { $self->{_warnings} = []; } -=item parse($string) +=item $link-E<gt>parse($string) This method can be used to (re)parse a (new) hyperlink, i.e. the contents of a C<LE<lt>...E<gt>> sequence. The result is stored in the current object. +Warnings are stored in the B<warnings> property. +E.g. sections like C<LE<lt>open(2)E<gt>> are deprected, as they do not point +to Perl documents. C<LE<lt>DBI::foo(3p)E<gt>> is wrong as well, the manpage +section can simply be dropped. =cut @@ -280,14 +284,13 @@ sub parse { my $self = shift; local($_) = $_[0]; # syntax check the link and extract destination - my ($alttext,$page,$node,$type) = ('','','',''); + my ($alttext,$page,$node,$type) = (undef,'','',''); $self->{_warnings} = []; # collapse newlines with whitespace - if(s/\s*\n+\s*/ /g) { - $self->warning("collapsing newlines to blanks"); - } + s/\s*\n+\s*/ /g; + # strip leading/trailing whitespace if(s/^[\s\n]+//) { $self->warning("ignoring leading whitespace in link"); @@ -308,25 +311,24 @@ sub parse { # problem: a lot of people use (), or (1) or the like to indicate # man page sections. But this collides with L<func()> that is supposed # to point to an internal funtion... - # I would like the following better, here and below: - #if(m!^(\w+(?:::\w+)*)$!) { - my $page_rx = '[\w.]+(?:::[\w.]+)*'; + my $page_rx = '[\w.]+(?:::[\w.]+)*(?:[(](?:\d\w*|)[)]|)'; + # page name only if(m!^($page_rx)$!o) { $page = $1; $type = 'page'; } # alttext, page and "section" - elsif(m!^(.+?)\s*[|]\s*($page_rx)\s*/\s*"(.+)"$!o) { + elsif(m!^(.*?)\s*[|]\s*($page_rx)\s*/\s*"(.+)"$!o) { ($alttext, $page, $node) = ($1, $2, $3); $type = 'section'; } # alttext and page - elsif(m!^(.+?)\s*[|]\s*($page_rx)$!o) { + elsif(m!^(.*?)\s*[|]\s*($page_rx)$!o) { ($alttext, $page) = ($1, $2); $type = 'page'; } # alttext and "section" - elsif(m!^(.+?)\s*[|]\s*(?:/\s*|)"(.+)"$!) { + elsif(m!^(.*?)\s*[|]\s*(?:/\s*|)"(.+)"$!) { ($alttext, $node) = ($1,$2); $type = 'section'; } @@ -356,16 +358,16 @@ sub parse { $type = 'hyperlink'; } # alttext, page and item - elsif(m!^(.+?)\s*[|]\s*($page_rx)\s*/\s*(.+)$!o) { + elsif(m!^(.*?)\s*[|]\s*($page_rx)\s*/\s*(.+)$!o) { ($alttext, $page, $node) = ($1, $2, $3); $type = 'item'; } # alttext and item - elsif(m!^(.+?)\s*[|]\s*/(.+)$!) { + elsif(m!^(.*?)\s*[|]\s*/(.+)$!) { ($alttext, $node) = ($1,$2); } # nonstandard: alttext and hyperlink - elsif(m!^(.+?)\s*[|]\s*((?:http|ftp|mailto|news):.+)$!) { + elsif(m!^(.*?)\s*[|]\s*((?:http|ftp|mailto|news):.+)$!) { ($alttext, $node) = ($1,$2); $type = 'hyperlink'; } @@ -377,9 +379,19 @@ sub parse { # collapse whitespace in nodes $node =~ s/\s+/ /gs; - #if($page =~ /[(]\w*[)]$/) { - # $self->warning("section in '$page' deprecated"); - #} + # empty alternative text expands to node name + if(defined $alttext) { + if(!length($alttext)) { + $alttext = $node | $page; + } + } + else { + $alttext = ''; + } + + if($page =~ /[(]\w*[)]$/) { + $self->warning("(section) in '$page' deprecated"); + } if($node =~ m:[|/]:) { $self->warning("node '$node' contains non-escaped | or /"); } @@ -435,7 +447,7 @@ sub _construct_text { } } -=item markup($string) +=item $link-E<gt>markup($string) Set/retrieve the textual value of the link. This string contains special markers C<PE<lt>E<gt>> and C<QE<lt>E<gt>> that should be expanded by the @@ -450,7 +462,7 @@ sub markup { return (@_ > 1) ? ($_[0]->{_markup} = $_[1]) : $_[0]->{_markup}; } -=item text() +=item $link-E<gt>text() This method returns the textual representation of the hyperlink as above, but without markers (read only). Depending on the link type this is one of @@ -469,7 +481,7 @@ sub text { $_[0]->{_text}; } -=item warning() +=item $link-E<gt>warning() After parsing, this method returns any warnings encountered during the parsing process. @@ -486,7 +498,9 @@ sub warning { return @{$self->{_warnings}}; } -=item line(), file() +=item $link-E<gt>file() + +=item $link-E<gt>line() Just simple slots for storing information about the line and the file the link was encountered in. Has to be filled in manually. @@ -503,7 +517,7 @@ sub file { return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; } -=item page() +=item $link-E<gt>page() This method sets or returns the POD page this link points to. @@ -518,7 +532,7 @@ sub page { $_[0]->{-page}; } -=item node() +=item $link-E<gt>node() As above, but the destination node text of the link. @@ -533,7 +547,7 @@ sub node { $_[0]->{-node}; } -=item alttext() +=item $link-E<gt>alttext() Sets or returns an alternative text specified in the link. @@ -548,7 +562,7 @@ sub alttext { $_[0]->{-alttext}; } -=item type() +=item $link-E<gt>type() The node type, either C<section> or C<item>. As an unofficial type, there is also C<hyperlink>, derived from e.g. C<LE<lt>http://perl.comE<gt>> @@ -560,7 +574,7 @@ sub type { return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; } -=item link() +=item $link-E<gt>link() Returns the link as contents of C<LE<lt>E<gt>>. Reciprocal to B<parse()>. @@ -620,7 +634,7 @@ The following methods are available: =over 4 -=item new() +=item Pod::Cache-E<gt>new() Create a new cache object. This object can hold an arbitrary number of POD documents of class Pod::Cache::Item. @@ -635,7 +649,7 @@ sub new { return $self; } -=item item() +=item $cache-E<gt>item() Add a new item to the cache. Without arguments, this method returns a list of all cache elements. @@ -654,7 +668,7 @@ sub item { } } -=item find_page($name) +=item $cache-E<gt>find_page($name) Look for a POD document named C<$name> in the cache. Returns the reference to the corresponding Pod::Cache::Item object or undef if @@ -686,7 +700,7 @@ The following methods are available: =over 4 -=item new() +=item Pod::Cache::Item-E<gt>new() Create a new object. @@ -707,7 +721,7 @@ sub initialize { $self->{-nodes} = [] unless(defined $self->{-nodes}); } -=item page() +=item $cacheitem-E<gt>page() Set/retrieve the POD document name (e.g. "Pod::Parser"). @@ -718,7 +732,7 @@ sub page { return (@_ > 1) ? ($_[0]->{-page} = $_[1]) : $_[0]->{-page}; } -=item description() +=item $cacheitem-E<gt>description() Set/retrieve the POD short description as found in the C<=head1 NAME> section. @@ -730,7 +744,7 @@ sub description { return (@_ > 1) ? ($_[0]->{-description} = $_[1]) : $_[0]->{-description}; } -=item path() +=item $cacheitem-E<gt>path() Set/retrieve the POD file storage path. @@ -741,7 +755,7 @@ sub path { return (@_ > 1) ? ($_[0]->{-path} = $_[1]) : $_[0]->{-path}; } -=item file() +=item $cacheitem-E<gt>file() Set/retrieve the POD file name. @@ -752,7 +766,7 @@ sub file { return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; } -=item nodes() +=item $cacheitem-E<gt>nodes() Add a node (or a list of nodes) to the document's node list. Note that the order is kept, i.e. start with the first node and end with the last. @@ -775,14 +789,12 @@ sub nodes { } } -=item find_node($name) +=item $cacheitem-E<gt>find_node($name) Look for a node or index entry named C<$name> in the object. Returns the unique id of the node (i.e. the second element of the array stored in the node arry) or undef if not found. -=back - =cut sub find_node { @@ -798,7 +810,7 @@ sub find_node { undef; } -=item idx() +=item $cacheitem-E<gt>idx() Add an index entry (or a list of them) to the document's index list. Note that the order is kept, i.e. start with the first node and end with the last. @@ -807,6 +819,8 @@ same order the entries have been added. An index entry can be any scalar, but usually is a pair of string and unique id. +=back + =cut # The POD index entries diff --git a/contrib/perl5/lib/Pod/Parser.pm b/contrib/perl5/lib/Pod/Parser.pm index 48fc198ded73..6782519d96df 100644 --- a/contrib/perl5/lib/Pod/Parser.pm +++ b/contrib/perl5/lib/Pod/Parser.pm @@ -10,7 +10,7 @@ package Pod::Parser; use vars qw($VERSION); -$VERSION = 1.12; ## Current version of this package +$VERSION = 1.13; ## Current version of this package require 5.005; ## requires this Perl version or later ############################################################################# @@ -205,7 +205,6 @@ use strict; use Pod::InputObjects; use Carp; use Exporter; -require VMS::Filespec if $^O eq 'VMS'; BEGIN { if ($] < 5.6) { require Symbol; @@ -783,11 +782,11 @@ sub parse_text { ## Iterate over all sequence starts text (NOTE: split with ## capturing parens keeps the delimiters) $_ = $text; - my @tokens = split /([A-Z]<(?:<+\s+)?)/; + my @tokens = split /([A-Z]<(?:<+\s)?)/; while ( @tokens ) { $_ = shift @tokens; ## Look for the beginning of a sequence - if ( /^([A-Z])(<(?:<+\s+)?)$/ ) { + if ( /^([A-Z])(<(?:<+\s)?)$/ ) { ## Push a new sequence onto the stack of those "in-progress" ($cmd, $ldelim) = ($1, $2); $seq = Pod::InteriorSequence->new( @@ -848,7 +847,6 @@ sub parse_text { my $errorsub = (@seq_stack > 1) ? $self->errorsub() : undef; while (@seq_stack > 1) { ($cmd, $file, $line) = ($seq->name, $seq->file_line); - $file = VMS::Filespec::unixify($file) if $^O eq 'VMS'; $ldelim = $seq->ldelim; ($rdelim = $ldelim) =~ tr/</>/; $rdelim =~ s/^(\S+)(\s*)$/$2$1/; @@ -1081,10 +1079,9 @@ sub parse_from_filehandle { && (length $paragraph)); ## Issue a warning about any non-empty blank lines - if (length($1) > 1 and $myOpts{'-warnings'} and ! $myData{_CUTTING}) { + if (length($1) > 0 and $myOpts{'-warnings'} and ! $myData{_CUTTING}) { my $errorsub = $self->errorsub(); my $file = $self->input_file(); - $file = VMS::Filespec::unixify($file) if $^O eq 'VMS'; my $errmsg = "*** WARNING: line containing nothing but whitespace". " in paragraph at line $nlines in file $file\n"; (ref $errorsub) and &{$errorsub}($errmsg) diff --git a/contrib/perl5/lib/Pod/Select.pm b/contrib/perl5/lib/Pod/Select.pm index 5dd1595107e9..e7c820f3503a 100644 --- a/contrib/perl5/lib/Pod/Select.pm +++ b/contrib/perl5/lib/Pod/Select.pm @@ -10,7 +10,7 @@ package Pod::Select; use vars qw($VERSION); -$VERSION = 1.12; ## Current version of this package +$VERSION = 1.13; ## Current version of this package require 5.005; ## requires this Perl version or later ############################################################################# @@ -92,7 +92,7 @@ The formal syntax of a section specification is: =over 4 -=item +=item * I<head1-title-regex>/I<head2-title-regex>/... @@ -109,33 +109,39 @@ Some example section specifications follow. =over 4 -=item +=item * + Match the C<NAME> and C<SYNOPSIS> sections and all of their subsections: C<NAME|SYNOPSIS> -=item +=item * + Match only the C<Question> and C<Answer> subsections of the C<DESCRIPTION> section: C<DESCRIPTION/Question|Answer> -=item +=item * + Match the C<Comments> subsection of I<all> sections: C</Comments> -=item +=item * + Match all subsections of C<DESCRIPTION> I<except> for C<Comments>: C<DESCRIPTION/!Comments> -=item +=item * + Match the C<DESCRIPTION> section but do I<not> match any of its subsections: C<DESCRIPTION/!.+> -=item +=item * + Match all top level sections but none of their subsections: C</!.+> @@ -160,7 +166,7 @@ The formal syntax of a range specification is: =over 4 -=item +=item * /I<start-range-regex>/[../I<end-range-regex>/] diff --git a/contrib/perl5/lib/Pod/Text.pm b/contrib/perl5/lib/Pod/Text.pm index d93e5a4b7105..9936025101a2 100644 --- a/contrib/perl5/lib/Pod/Text.pm +++ b/contrib/perl5/lib/Pod/Text.pm @@ -1,7 +1,7 @@ # Pod::Text -- Convert POD data to formatted ASCII text. -# $Id: Text.pm,v 2.3 1999/10/07 09:41:57 eagle Exp $ +# $Id: Text.pm,v 2.8 2001/02/10 06:50:23 eagle Exp $ # -# Copyright 1999 by Russ Allbery <rra@stanford.edu> +# Copyright 1999, 2000, 2001 by Russ Allbery <rra@stanford.edu> # # This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. @@ -33,7 +33,11 @@ use vars qw(@ISA @EXPORT %ESCAPES $VERSION); # We have to export pod2text for backward compatibility. @EXPORT = qw(pod2text); -($VERSION = (split (' ', q$Revision: 2.3 $ ))[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 = 2.08; ############################################################################ @@ -43,13 +47,15 @@ use vars qw(@ISA @EXPORT %ESCAPES $VERSION); # This table is taken near verbatim from Pod::PlainText in Pod::Parser, # which got it near verbatim from the original Pod::Text. It is therefore # credited to Tom Christiansen, and I'm glad I didn't have to write it. :) -# "iexcl" to "divide" added by Tim Jenness +# "iexcl" to "divide" added by Tim Jenness. %ESCAPES = ( 'amp' => '&', # ampersand 'lt' => '<', # left chevron, less-than 'gt' => '>', # right chevron, greater-than 'quot' => '"', # double quote - + 'sol' => '/', # solidus (forward slash) + 'verbar' => '|', # vertical bar + "Aacute" => "\xC1", # capital A, acute accent "aacute" => "\xE1", # small a, acute accent "Acirc" => "\xC2", # capital A, circumflex accent @@ -76,8 +82,8 @@ use vars qw(@ISA @EXPORT %ESCAPES $VERSION); "eth" => "\xF0", # small eth, Icelandic "Euml" => "\xCB", # capital E, dieresis or umlaut mark "euml" => "\xEB", # small e, dieresis or umlaut mark - "Iacute" => "\xCD", # capital I, acute accent - "iacute" => "\xED", # small i, acute accent + "Iacute" => "\xCC", # capital I, acute accent + "iacute" => "\xEC", # small i, acute accent "Icirc" => "\xCE", # capital I, circumflex accent "icirc" => "\xEE", # small i, circumflex accent "Igrave" => "\xCD", # capital I, grave accent @@ -112,43 +118,43 @@ use vars qw(@ISA @EXPORT %ESCAPES $VERSION); "Yacute" => "\xDD", # capital Y, acute accent "yacute" => "\xFD", # small y, acute accent "yuml" => "\xFF", # small y, dieresis or umlaut mark - - "lchevron" => "\xAB", # left chevron (double less than) laquo - "rchevron" => "\xBB", # right chevron (double greater than) raquo - - "iexcl" => "\xA1", # inverted exclamation mark - "cent" => "\xA2", # cent sign - "pound" => "\xA3", # (UK) pound sign - "curren" => "\xA4", # currency sign - "yen" => "\xA5", # yen sign - "brvbar" => "\xA6", # broken vertical bar - "sect" => "\xA7", # section sign - "uml" => "\xA8", # diaresis - "copy" => "\xA9", # Copyright symbol - "ordf" => "\xAA", # feminine ordinal indicator - "laquo" => "\xAB", # left pointing double angle quotation mark - "not" => "\xAC", # not sign - "shy" => "\xAD", # soft hyphen - "reg" => "\xAE", # registered trademark - "macr" => "\xAF", # macron, overline - "deg" => "\xB0", # degree sign - "plusmn" => "\xB1", # plus-minus sign - "sup2" => "\xB2", # superscript 2 - "sup3" => "\xB3", # superscript 3 - "acute" => "\xB4", # acute accent - "micro" => "\xB5", # micro sign - "para" => "\xB6", # pilcrow sign = paragraph sign - "middot" => "\xB7", # middle dot = Georgian comma - "cedil" => "\xB8", # cedilla - "sup1" => "\xB9", # superscript 1 - "ordm" => "\xBA", # masculine ordinal indicator - "raquo" => "\xBB", # right pointing double angle quotation mark - "frac14" => "\xBC", # vulgar fraction one quarter - "frac12" => "\xBD", # vulgar fraction one half - "frac34" => "\xBE", # vulgar fraction three quarters - "iquest" => "\xBF", # inverted question mark - "times" => "\xD7", # multiplication sign - "divide" => "\xF7", # division sign + + "laquo" => "\xAB", # left pointing double angle quotation mark + "lchevron" => "\xAB", # synonym (backwards compatibility) + "raquo" => "\xBB", # right pointing double angle quotation mark + "rchevron" => "\xBB", # synonym (backwards compatibility) + + "iexcl" => "\xA1", # inverted exclamation mark + "cent" => "\xA2", # cent sign + "pound" => "\xA3", # (UK) pound sign + "curren" => "\xA4", # currency sign + "yen" => "\xA5", # yen sign + "brvbar" => "\xA6", # broken vertical bar + "sect" => "\xA7", # section sign + "uml" => "\xA8", # diaresis + "copy" => "\xA9", # Copyright symbol + "ordf" => "\xAA", # feminine ordinal indicator + "not" => "\xAC", # not sign + "shy" => "\xAD", # soft hyphen + "reg" => "\xAE", # registered trademark + "macr" => "\xAF", # macron, overline + "deg" => "\xB0", # degree sign + "plusmn" => "\xB1", # plus-minus sign + "sup2" => "\xB2", # superscript 2 + "sup3" => "\xB3", # superscript 3 + "acute" => "\xB4", # acute accent + "micro" => "\xB5", # micro sign + "para" => "\xB6", # pilcrow sign = paragraph sign + "middot" => "\xB7", # middle dot = Georgian comma + "cedil" => "\xB8", # cedilla + "sup1" => "\xB9", # superscript 1 + "ordm" => "\xBA", # masculine ordinal indicator + "frac14" => "\xBC", # vulgar fraction one quarter + "frac12" => "\xBD", # vulgar fraction one half + "frac34" => "\xBE", # vulgar fraction three quarters + "iquest" => "\xBF", # inverted question mark + "times" => "\xD7", # multiplication sign + "divide" => "\xF7", # division sign ); @@ -166,6 +172,20 @@ sub initialize { $$self{sentence} = 0 unless defined $$self{sentence}; $$self{width} = 76 unless defined $$self{width}; + # Figure out what quotes we'll be using for C<> text. + $$self{quotes} ||= '"'; + if ($$self{quotes} eq 'none') { + $$self{LQUOTE} = $$self{RQUOTE} = ''; + } elsif (length ($$self{quotes}) == 1) { + $$self{LQUOTE} = $$self{RQUOTE} = $$self{quotes}; + } elsif ($$self{quotes} =~ /^(.)(.)$/ + || $$self{quotes} =~ /^(..)(..)$/) { + $$self{LQUOTE} = $1; + $$self{RQUOTE} = $2; + } else { + croak qq(Invalid quote specification "$$self{quotes}"); + } + $$self{INDENTS} = []; # Stack of indentations. $$self{MARGIN} = $$self{indent}; # Current left margin in spaces. @@ -187,8 +207,18 @@ sub command { return if $command eq 'pod'; return if ($$self{EXCLUDE} && $command ne 'end'); $self->item ("\n") if defined $$self{ITEM}; - $command = 'cmd_' . $command; - $self->$command (@_); + if ($self->can ('cmd_' . $command)) { + $command = 'cmd_' . $command; + $self->$command (@_); + } else { + my ($text, $line, $paragraph) = @_; + my $file; + ($file, $line) = $paragraph->file_line; + $text =~ s/\n+\z//; + $text = " $text" if ($text =~ /^\S/); + warn qq($file:$line: Unknown command paragraph "=$command$text"\n); + return; + } } # Called for a verbatim paragraph. Gets the paragraph, the line number, and @@ -228,7 +258,7 @@ sub textblock { > ( ,?\s+(and\s+)? # Allow lots of them, conjuncted. - L< + L< / ( [:\w]+ @@ -346,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; @@ -393,7 +449,7 @@ sub cmd_end { my $self = shift; $$self{EXCLUDE} = 0; $$self{VERBATIM} = 0; -} +} # One paragraph for a particular translator. Ignore it unless it's intended # for text, in which case we treat it as a verbatim text block. @@ -413,9 +469,11 @@ sub cmd_for { # The simple formatting ones. These are here mostly so that subclasses can # override them and do more complicated things. sub seq_b { return $_[0]{alt} ? "``$_[1]''" : $_[1] } -sub seq_c { return $_[0]{alt} ? "``$_[1]''" : "`$_[1]'" } sub seq_f { return $_[0]{alt} ? "\"$_[1]\"" : $_[1] } sub seq_i { return '*' . $_[1] . '*' } +sub seq_c { + return $_[0]{alt} ? "``$_[1]''" : "$_[0]{LQUOTE}$_[1]$_[0]{RQUOTE}" +} # The complicated one. Handle links. Since this is plain text, we can't # actually make any real links, so this is all to figure out what text we @@ -434,6 +492,10 @@ sub seq_l { s/^\s+//; s/\s+$//; + # If the argument looks like a URL, return it verbatim. This only + # handles URLs that use the server syntax. + if (m%^[a-z]+://\S+$%) { return $_ } + # Default to using the whole content of the link entry as a section # name. Note that L<manpage/> forces a manpage interpretation, as does # something looking like L<manpage(section)>. The latter is an @@ -586,13 +648,14 @@ sub pod2text { # means we need to turn the first argument into a file handle. Magic # open will handle the <&STDIN case automagically. if (defined $_[1]) { + my @fhs = @_; local *IN; - unless (open (IN, $_[0])) { - croak ("Can't open $_[0] for reading: $!\n"); + unless (open (IN, $fhs[0])) { + croak ("Can't open $fhs[0] for reading: $!\n"); return; } - $_[0] = \*IN; - return $parser->parse_from_filehandle (@_); + $fhs[0] = \*IN; + return $parser->parse_from_filehandle (@fhs); } else { return $parser->parse_from_file (@_); } @@ -658,6 +721,17 @@ it's the expected formatting for manual pages; if you're formatting arbitrary text documents, setting this to true may result in more pleasing output. +=item quotes + +Sets the quote marks used to surround CE<lt>> text. If the value is a +single character, it is used as both the left and right quote; if it is two +characters, the first character is used as the left quote and the second as +the right quoted; and if it is four characters, the first two are used as +the left quote and the second two as the right quote. + +This may also be set to the special value C<none>, in which case no quote +marks are added around CE<lt>> text. + =item sentence If set to a true value, Pod::Text will assume that each sentence ends in two @@ -693,6 +767,16 @@ indicates a bug in Pod::Text; you should never see it. (F) Pod::Text was invoked via the compatibility mode pod2text() interface and the input file it was given could not be opened. +=item Invalid quote specification "%s" + +(F) The quote specification given (the quotes option to the constructor) was +invalid. A quote specification must be one, two, or four characters long. + +=item %s:%d: Unknown command paragraph "%s". + +(W) The POD source contained a non-standard command paragraph (something of +the form C<=command args>) that Pod::Man didn't know about. It was ignored. + =item Unknown escape: %s (W) The POD source contained an C<EE<lt>E<gt>> escape that Pod::Text didn't diff --git a/contrib/perl5/lib/Pod/Text/Color.pm b/contrib/perl5/lib/Pod/Text/Color.pm index 10e1d9fa309c..e943216d88dc 100644 --- a/contrib/perl5/lib/Pod/Text/Color.pm +++ b/contrib/perl5/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 <rra@stanford.edu> # @@ -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/contrib/perl5/lib/Pod/Text/Termcap.pm b/contrib/perl5/lib/Pod/Text/Termcap.pm index 7e89ec61bef8..333852a42587 100644 --- a/contrib/perl5/lib/Pod/Text/Termcap.pm +++ b/contrib/perl5/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 <rra@stanford.edu> # @@ -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/contrib/perl5/lib/Pod/Usage.pm b/contrib/perl5/lib/Pod/Usage.pm index aa8f712dcf57..388607617d18 100644 --- a/contrib/perl5/lib/Pod/Usage.pm +++ b/contrib/perl5/lib/Pod/Usage.pm @@ -10,7 +10,7 @@ package Pod::Usage; use vars qw($VERSION); -$VERSION = 1.12; ## Current version of this package +$VERSION = 1.14; ## Current version of this package require 5.005; ## requires this Perl version or later =head1 NAME @@ -46,7 +46,7 @@ B<pod2usage> should be given either a single argument, or a list of arguments corresponding to an associative array (a "hash"). When a single argument is given, it should correspond to exactly one of the following: -=over +=over 4 =item * @@ -68,7 +68,7 @@ assumed to be a hash. If a hash is supplied (either as a reference or as a list) it should contain one or more elements with the following keys: -=over +=over 4 =item C<-message> @@ -80,6 +80,9 @@ program's usage message. =item C<-exitval> The desired exit status to pass to the B<exit()> function. +This should be an integer, or else the string "NOEXIT" to +indicate that control should simply be returned without +terminating the invoking process. =item C<-verbose> @@ -129,7 +132,7 @@ Unless they are explicitly specified, the default values for the exit status, verbose level, and output stream to use are determined as follows: -=over +=over 4 =item * @@ -159,7 +162,7 @@ Although the above may seem a bit confusing at first, it generally does "the right thing" in most situations. This determination of the default values to use is based upon the following typical Unix conventions: -=over +=over 4 =item * @@ -395,6 +398,7 @@ with re-writing this manpage. use strict; #use diagnostics; use Carp; +use Config; use Exporter; use File::Spec; @@ -497,8 +501,19 @@ sub pod2usage { } ## Now translate the pod document and then exit with the desired status - $parser->parse_from_file($opts{"-input"}, $opts{"-output"}); - exit($opts{"-exitval"}); + if ( $opts{"-verbose"} >= 2 + and !ref($opts{"-input"}) + and $opts{"-output"} == \*STDOUT ) + { + ## spit out the entire PODs. Might as well invoke perldoc + my $progpath = File::Spec->catfile($Config{bin}, "perldoc"); + system($progpath, $opts{"-input"}); + } + else { + $parser->parse_from_file($opts{"-input"}, $opts{"-output"}); + } + + exit($opts{"-exitval"}) unless (lc($opts{"-exitval"}) eq 'noexit'); } ##--------------------------------------------------------------------------- diff --git a/contrib/perl5/lib/SelfLoader.pm b/contrib/perl5/lib/SelfLoader.pm index 99372f26308a..3b9c52d9122d 100644 --- a/contrib/perl5/lib/SelfLoader.pm +++ b/contrib/perl5/lib/SelfLoader.pm @@ -3,7 +3,7 @@ package SelfLoader; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(AUTOLOAD); -$VERSION = "1.0901"; +$VERSION = "1.0902"; sub Version {$VERSION} $DEBUG = 0; @@ -20,6 +20,7 @@ sub croak { require Carp; goto &Carp::croak } AUTOLOAD { print STDERR "SelfLoader::AUTOLOAD for $AUTOLOAD\n" if $DEBUG; my $SL_code = $Cache{$AUTOLOAD}; + my $save = $@; # evals in both AUTOLOAD and _load_stubs can corrupt $@ unless ($SL_code) { # Maybe this pack had stubs before __DATA__, and never initialized. # Or, this maybe an automatic DESTROY method call when none exists. @@ -31,11 +32,13 @@ AUTOLOAD { croak "Undefined subroutine $AUTOLOAD" unless $SL_code; } print STDERR "SelfLoader::AUTOLOAD eval: $SL_code\n" if $DEBUG; + eval $SL_code; if ($@) { $@ =~ s/ at .*\n//; croak $@; } + $@ = $save; defined(&$AUTOLOAD) || die "SelfLoader inconsistency error"; delete $Cache{$AUTOLOAD}; goto &$AUTOLOAD diff --git a/contrib/perl5/lib/Shell.pm b/contrib/perl5/lib/Shell.pm index 62aa82964c19..c2f522cae309 100644 --- a/contrib/perl5/lib/Shell.pm +++ b/contrib/perl5/lib/Shell.pm @@ -1,8 +1,13 @@ package Shell; use 5.005_64; -our($capture_stderr, $VERSION); +use strict; +use warnings; +our($capture_stderr, $VERSION, $AUTOLOAD); -$VERSION = '0.2'; +$VERSION = '0.3'; + +sub new { bless \$VERSION, shift } # Nothing better to bless +sub DESTROY { } sub import { my $self = shift; @@ -10,24 +15,24 @@ sub import { my @EXPORT; if (@_) { @EXPORT = @_; - } - else { + } else { @EXPORT = 'AUTOLOAD'; } - foreach $sym (@EXPORT) { + foreach my $sym (@EXPORT) { + no strict 'refs'; *{"${callpack}::$sym"} = \&{"Shell::$sym"}; } -}; +} -AUTOLOAD { +sub AUTOLOAD { + shift if ref $_[0] && $_[0]->isa( 'Shell' ); my $cmd = $AUTOLOAD; $cmd =~ s/^.*:://; eval <<"*END*"; sub $AUTOLOAD { if (\@_ < 1) { \$Shell::capture_stderr ? `$cmd 2>&1` : `$cmd`; - } - elsif ('$^O' eq 'os2') { + } elsif ('$^O' eq 'os2') { local(\*SAVEOUT, \*READ, \*WRITE); open SAVEOUT, '>&STDOUT' or die; @@ -46,16 +51,14 @@ AUTOLOAD { close READ; waitpid \$pid, 0; \@ret; - } - else { + } else { local(\$/) = undef; my \$ret = <READ>; close READ; waitpid \$pid, 0; \$ret; } - } - else { + } else { my \$a; my \@arr = \@_; if ('$^O' eq 'MSWin32') { @@ -74,11 +77,10 @@ AUTOLOAD { s/\\\\\\\\"/\\\\\\\\"""/g; \$_ = qq["\$_"] if /\\s/; } - } - else { + } else { for (\@arr) { s/(['\\\\])/\\\\\$1/g; - \$_ = "'\$_'"; + \$_ = \$_; } } push \@arr, '2>&1' if \$Shell::capture_stderr; @@ -88,8 +90,7 @@ AUTOLOAD { my \@ret = <SUBPROC>; close SUBPROC; # XXX Oughta use a destructor. \@ret; - } - else { + } else { local(\$/) = undef; my \$ret = <SUBPROC>; close SUBPROC; @@ -104,6 +105,7 @@ AUTOLOAD { } 1; + __END__ =head1 NAME @@ -155,10 +157,45 @@ The module now should work on Win32. Jenda +There seemed to be a problem where all arguments to a shell command were +quoted before being executed. As in the following example: + + cat('</etc/passwd'); + ls('*.pl'); + +really turned into: + + cat '</etc/passwd' + ls '*.pl' + +instead of: + + cat </etc/passwd + ls *.pl + +and of course, this is wrong. + +I have fixed this bug, it was brought up by Wolfgang Laun [ID 20000326.008] + +Casey + +=head2 OBJECT ORIENTED SYNTAX + +Shell now has an OO interface. Good for namespace conservation +and shell representation. + + use Shell; + my $sh = Shell->new; + print $sh->ls; + +Casey + =head1 AUTHOR Larry Wall Changes by Jenda@Krynicky.cz and Dave Cottle <d.cottle@csc.canterbury.ac.nz> +Changes and bug fixes by Casey Tweten <crt@kiski.net> + =cut diff --git a/contrib/perl5/lib/Symbol.pm b/contrib/perl5/lib/Symbol.pm index a842c1cd7beb..a95383a5d68c 100644 --- a/contrib/perl5/lib/Symbol.pm +++ b/contrib/perl5/lib/Symbol.pm @@ -129,8 +129,15 @@ sub delete_package ($) { my $stem_symtab = *{$stem}{HASH}; return unless defined $stem_symtab and exists $stem_symtab->{$leaf}; - my $leaf_glob = $stem_symtab->{$leaf}; - my $leaf_symtab = *{$leaf_glob}{HASH}; + + # free all the symbols in the package + + my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; + foreach my $name (keys %$leaf_symtab) { + undef *{$pkg . $name}; + } + + # delete the symbol table %$leaf_symtab = (); delete $stem_symtab->{$leaf}; diff --git a/contrib/perl5/lib/Term/ANSIColor.pm b/contrib/perl5/lib/Term/ANSIColor.pm index e7a2157207b2..b61efcb0451c 100644 --- a/contrib/perl5/lib/Term/ANSIColor.pm +++ b/contrib/perl5/lib/Term/ANSIColor.pm @@ -1,11 +1,14 @@ # Term::ANSIColor -- Color screen output using ANSI escape sequences. -# $Id: ANSIColor.pm,v 1.1 1997/12/10 20:05:29 eagle Exp $ +# $Id: ANSIColor.pm,v 1.3 2000/08/06 18:28:10 eagle Exp $ # -# Copyright 1996, 1997 by Russ Allbery <rra@stanford.edu> -# and Zenin <zenin@best.com> +# Copyright 1996, 1997, 1998, 2000 +# by Russ Allbery <rra@stanford.edu> and Zenin <zenin@best.com> # # This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. +# +# Ah, September, when the sysadmins turn colors and fall off the trees.... +# -- Dave Van Domelen ############################################################################ # Modules and declarations @@ -27,8 +30,10 @@ use Exporter (); ON_GREEN ON_YELLOW ON_BLUE ON_MAGENTA ON_CYAN ON_WHITE)]); Exporter::export_ok_tags ('constants'); - -($VERSION = (split (' ', q$Revision: 1.1 $ ))[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. +$VERSION = 1.03; ############################################################################ @@ -38,6 +43,7 @@ Exporter::export_ok_tags ('constants'); %attributes = ('clear' => 0, 'reset' => 0, 'bold' => 1, + 'dark' => 2, 'underline' => 4, 'underscore' => 4, 'blink' => 5, @@ -92,7 +98,8 @@ sub AUTOLOAD { }; goto &$AUTOLOAD; } else { - die "undefined subroutine &$AUTOLOAD called"; + require Carp; + Carp::croak ("undefined subroutine &$AUTOLOAD called"); } } @@ -119,19 +126,28 @@ sub color { # Given a string and a set of attributes, returns the string surrounded by # escape codes to set those attributes and then clear them at the end of the -# string. If $EACHLINE is set, insert a reset before each occurrence of the -# string $EACHLINE and the starting attribute code after the string -# $EACHLINE, so that no attribute crosses line delimiters (this is often -# desirable if the output is to be piped to a pager or some other program). +# string. The attributes can be given either as an array ref as the first +# argument or as a list as the second and subsequent arguments. If +# $EACHLINE is set, insert a reset before each occurrence of the string +# $EACHLINE and the starting attribute code after the string $EACHLINE, so +# that no attribute crosses line delimiters (this is often desirable if the +# output is to be piped to a pager or some other program). sub colored { - my $string = shift; + my ($string, @codes); + if (ref $_[0]) { + @codes = @{+shift}; + $string = join ('', @_); + } else { + $string = shift; + @codes = @_; + } if (defined $EACHLINE) { - my $attr = color (@_); + my $attr = color (@codes); join '', map { $_ && $_ ne $EACHLINE ? $attr . $_ . "\e[0m" : $_ } split (/(\Q$EACHLINE\E)/, $string); } else { - color (@_) . $string . "\e[0m"; + color (@codes) . $string . "\e[0m"; } } @@ -157,6 +173,7 @@ Term::ANSIColor - Color screen output using ANSI escape sequences print "This text is normal.\n"; print colored ("Yellow on magenta.\n", 'yellow on_magenta'); print "This text is normal.\n"; + print colored ['yellow on_magenta'], "Yellow on magenta.\n"; use Term::ANSIColor qw(:constants); print BOLD, BLUE, "This text is in bold blue.\n", RESET; @@ -179,22 +196,30 @@ you can save it as a string, pass it to something else, send it to a file handle, or do anything else with it that you might care to). The recognized attributes (all of which should be fairly intuitive) are -clear, reset, bold, underline, underscore, blink, reverse, concealed, -black, red, green, yellow, blue, magenta, on_black, on_red, on_green, -on_yellow, on_blue, on_magenta, on_cyan, and on_white. Case is not -significant. Underline and underscore are equivalent, as are clear and -reset, so use whichever is the most intuitive to you. The color alone +clear, reset, dark, bold, underline, underscore, blink, reverse, +concealed, black, red, green, yellow, blue, magenta, on_black, on_red, +on_green, on_yellow, on_blue, on_magenta, on_cyan, and on_white. Case is +not significant. Underline and underscore are equivalent, as are clear +and reset, so use whichever is the most intuitive to you. The color alone sets the foreground color, and on_color sets the background color. -Note that attributes, once set, last until they are unset (by sending the -attribute "reset"). Be careful to do this, or otherwise your attribute will -last after your script is done running, and people get very annoyed at -having their prompt and typing changed to weird colors. +Note that not all attributes are supported by all terminal types, and some +terminals may not support any of these sequences. Dark, blink, and +concealed in particular are frequently not implemented. + +Attributes, once set, last until they are unset (by sending the attribute +"reset"). Be careful to do this, or otherwise your attribute will last +after your script is done running, and people get very annoyed at having +their prompt and typing changed to weird colors. As an aid to help with this, colored() takes a scalar as the first argument and any number of attribute strings as the second argument and returns the scalar wrapped in escape codes so that the attributes will be set as requested before the string and reset to normal after the string. +Alternately, you can pass a reference to an array as the first argument, +and then the contents of that array will be taken as attributes and color +codes and the remainder of the arguments as text to colorize. + Normally, colored() just puts attribute codes at the beginning and end of the string, but if you set $Term::ANSIColor::EACHLINE to some string, that string will be considered the line delimiter and the attribute will @@ -205,10 +230,10 @@ Normally you'll want to set $Term::ANSIColor::EACHLINE to C<"\n"> to use this feature. Alternately, if you import C<:constants>, you can use the constants CLEAR, -RESET, BOLD, UNDERLINE, UNDERSCORE, BLINK, REVERSE, CONCEALED, BLACK, RED, -GREEN, YELLOW, BLUE, MAGENTA, ON_BLACK, ON_RED, ON_GREEN, ON_YELLOW, -ON_BLUE, ON_MAGENTA, ON_CYAN, and ON_WHITE directly. These are the same -as color('attribute') and can be used if you prefer typing: +RESET, BOLD, DARK, UNDERLINE, UNDERSCORE, BLINK, REVERSE, CONCEALED, +BLACK, RED, GREEN, YELLOW, BLUE, MAGENTA, ON_BLACK, ON_RED, ON_GREEN, +ON_YELLOW, ON_BLUE, ON_MAGENTA, ON_CYAN, and ON_WHITE directly. These are +the same as color('attribute') and can be used if you prefer typing: print BOLD BLUE ON_WHITE "Text\n", RESET; @@ -231,14 +256,14 @@ will reset the display mode afterwards, whereas: will not. The subroutine interface has the advantage over the constants interface in -that only 2 soubrutines are exported into your namespace, verses 22 in the -constants interface. On the flip side, the constants interface has the -advantage of better compile time error checking, since misspelled names of -colors or attributes in calls to color() and colored() won't be caught -until runtime whereas misspelled names of constants will be caught at -compile time. So, polute your namespace with almost two dozen subrutines -that you may not even use that oftin, or risk a silly bug by mistyping an -attribute. Your choice, TMTOWTDI after all. +that only two subroutines are exported into your namespace, versus +twenty-two in the constants interface. On the flip side, the constants +interface has the advantage of better compile time error checking, since +misspelled names of colors or attributes in calls to color() and colored() +won't be caught until runtime whereas misspelled names of constants will +be caught at compile time. So, polute your namespace with almost two +dozen subroutines that you may not even use that often, or risk a silly +bug by mistyping an attribute. Your choice, TMTOWTDI after all. =head1 DIAGNOSTICS @@ -246,11 +271,11 @@ attribute. Your choice, TMTOWTDI after all. =item Invalid attribute name %s -You passed an invalid attribute name to either color() or colored(). +(F) You passed an invalid attribute name to either color() or colored(). -=item Identifier %s used only once: possible typo +=item Name "%s" used only once: possible typo -You probably mistyped a constant color name such as: +(W) You probably mistyped a constant color name such as: print FOOBAR "This text is color FOOBAR\n"; @@ -259,7 +284,7 @@ force the next error. =item No comma allowed after filehandle -You probably mistyped a constant color name such as: +(F) You probably mistyped a constant color name such as: print FOOBAR, "This text is color FOOBAR\n"; @@ -267,9 +292,9 @@ Generating this fatal compile error is one of the main advantages of using the constants interface, since you'll immediately know if you mistype a color name. -=item Bareword %s not allowed while "strict subs" in use +=item Bareword "%s" not allowed while "strict subs" in use -You probably mistyped a constant color name such as: +(F) You probably mistyped a constant color name such as: $Foobar = FOOBAR . "This line should be blue\n"; @@ -298,6 +323,25 @@ For easier debuging, you may prefer to always use the commas when not setting $Term::ANSIColor::AUTORESET so that you'll get a fatal compile error rather than a warning. +=head1 NOTES + +Jean Delvare provided the following table of different common terminal +emulators and their support for the various attributes: + + clear bold dark under blink reverse conceal + ------------------------------------------------------------------------ + xterm yes yes no yes bold yes yes + linux yes yes yes bold yes yes no + rxvt yes yes no yes bold/black yes no + dtterm yes yes yes yes reverse yes yes + teraterm yes reverse no yes rev/red yes no + aixterm kinda normal no yes no yes yes + +Where the entry is other than yes or no, that emulator interpret the given +attribute as something else instead. Note that on an aixterm, clear +doesn't reset colors; you have to explicitly set the colors back to what +you want. More entries in this table are welcome. + =head1 AUTHORS Original idea (using constants) by Zenin (zenin@best.com), reimplemented diff --git a/contrib/perl5/lib/Term/ReadLine.pm b/contrib/perl5/lib/Term/ReadLine.pm index 8bb820578a9f..fc78d7b6fa13 100644 --- a/contrib/perl5/lib/Term/ReadLine.pm +++ b/contrib/perl5/lib/Term/ReadLine.pm @@ -169,12 +169,14 @@ 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 +187,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"; diff --git a/contrib/perl5/lib/Test.pm b/contrib/perl5/lib/Test.pm index c708f57a0505..4a38d5466891 100644 --- a/contrib/perl5/lib/Test.pm +++ b/contrib/perl5/lib/Test.pm @@ -1,11 +1,10 @@ use strict; package Test; -use 5.005_64; use Test::Harness 1.1601 (); use Carp; our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $ntest, $TestLevel); #public-ish our($TESTOUT, $ONFAIL, %todo, %history, $planned, @FAILDETAIL); #private-ish -$VERSION = '1.13'; +$VERSION = '1.15'; require Exporter; @ISA=('Exporter'); @EXPORT=qw(&plan &ok &skip); @@ -82,8 +81,16 @@ sub ok ($;$$) { $context .= ' TODO?!' if $todo; print $TESTOUT "ok $ntest # ($context)\n"; } else { - print $TESTOUT "not " if !$ok; - print $TESTOUT "ok $ntest\n"; + # Issuing two separate print()s causes severe trouble with + # Test::Harness on VMS. The "not "'s for failed tests occur + # on a separate line and would not get counted as failures. + #print $TESTOUT "not " if !$ok; + #print $TESTOUT "ok $ntest\n"; + # Replace with a single print() as a workaround: + my $okline = ''; + $okline = "not " if !$ok; + $okline .= "ok $ntest\n"; + print $TESTOUT $okline; if (!$ok) { my $detail = { 'repetition' => $repetition, 'package' => $pkg, @@ -178,9 +185,9 @@ __END__ =head1 DESCRIPTION -L<Test::Harness> 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<Test::Harness|Test::Harness> 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/contrib/perl5/lib/Test/Harness.pm b/contrib/perl5/lib/Test/Harness.pm index 99027411343c..f446e6502914 100644 --- a/contrib/perl5/lib/Test/Harness.pm +++ b/contrib/perl5/lib/Test/Harness.pm @@ -8,7 +8,7 @@ use FileHandle; use strict; our($VERSION, $verbose, $switches, $have_devel_corestack, $curtest, - @ISA, @EXPORT, @EXPORT_OK); + $columns, @ISA, @EXPORT, @EXPORT_OK); $have_devel_corestack = 0; $VERSION = "1.1604"; @@ -27,36 +27,18 @@ my $subtests_skipped = 0; @EXPORT= qw(&runtests); @EXPORT_OK= qw($verbose $switches); -format STDOUT_TOP = -Failed Test Status Wstat Total Fail Failed List of failed -------------------------------------------------------------------------------- -. - -format STDOUT = -@<<<<<<<<<<<<<< @>> @>>>> @>>>> @>>> ^##.##% ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -{ $curtest->{name}, - $curtest->{estat}, - $curtest->{wstat}, - $curtest->{max}, - $curtest->{failed}, - $curtest->{percent}, - $curtest->{canon} -} -~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< - $curtest->{canon} -. - - $verbose = 0; $switches = "-w"; +$columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80; sub globdir { opendir DIRH, shift; my @f = readdir DIRH; closedir DIRH; @f } sub runtests { my(@tests) = @_; local($|) = 1; - my($test,$te,$ok,$next,$max,$pct,$totok,$totbonus,@failed,%failedtests); + my($test,$te,$ok,$next,$max,$pct,$totbonus,@failed,%failedtests); my $totmax = 0; + my $totok = 0; my $files = 0; my $bad = 0; my $good = 0; @@ -102,7 +84,7 @@ sub runtests { $fh->close or print "can't close $test. $!\n"; my $cmd = ($ENV{'HARNESS_COMPILE_TEST'}) ? "./perl -I../lib ../utils/perlcc $test " - . "-run 2>> ./compilelog |" + . "-r 2>> ./compilelog |" : "$^X $s $test|"; $cmd = "MCR $cmd" if $^O eq 'VMS'; $fh->open($cmd) or print "can't run $test. $!\n"; @@ -158,12 +140,12 @@ sub runtests { $bonus++, $totbonus++ if $todo{$this}; } if ($this > $next) { - # warn "Test output counter mismatch [test $this]\n"; + # print "Test output counter mismatch [test $this]\n"; # no need to warn probably push @failed, $next..$this-1; } elsif ($this < $next) { #we have seen more "ok" lines than the number suggests - warn "Confused test output: test $this answered after test ", $next-1, "\n"; + print "Confused test output: test $this answered after test ", $next-1, "\n"; $next = $this; } $next = $this + 1; @@ -230,7 +212,7 @@ sub runtests { } if (@failed) { my ($txt, $canon) = canonfailed($max,$skipped,@failed); - print $txt; + print "${ml}$txt"; $failedtests{$test} = { canon => $canon, max => $max, failed => scalar @failed, name => $test, percent => 100*(scalar @failed)/$max, @@ -304,7 +286,54 @@ sub runtests { $pct = sprintf("%.2f", $good / $total * 100); my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.", $totmax - $totok, $totmax, 100*$totok/$totmax; + # Create formats + # First, figure out max length of test names + my $failed_str = "Failed Test"; + my $middle_str = " Status Wstat Total Fail Failed "; + my $list_str = "List of Failed"; + my $max_namelen = length($failed_str); my $script; + foreach $script (keys %failedtests) { + $max_namelen = + (length $failedtests{$script}->{name} > $max_namelen) ? + length $failedtests{$script}->{name} : $max_namelen; + } + my $list_len = $columns - length($middle_str) - $max_namelen; + if ($list_len < length($list_str)) { + $list_len = length($list_str); + $max_namelen = $columns - length($middle_str) - $list_len; + if ($max_namelen < length($failed_str)) { + $max_namelen = length($failed_str); + $columns = $max_namelen + length($middle_str) + $list_len; + } + } + + my $fmt_top = "format STDOUT_TOP =\n" + . sprintf("%-${max_namelen}s", $failed_str) + . $middle_str + . $list_str . "\n" + . "-" x $columns + . "\n.\n"; + my $fmt = "format STDOUT =\n" + . "@" . "<" x ($max_namelen - 1) + . " @>> @>>>> @>>>> @>>> ^##.##% " + . "^" . "<" x ($list_len - 1) . "\n" + . '{ $curtest->{name}, $curtest->{estat},' + . ' $curtest->{wstat}, $curtest->{max},' + . ' $curtest->{failed}, $curtest->{percent},' + . ' $curtest->{canon}' + . "\n}\n" + . "~~" . " " x ($columns - $list_len - 2) . "^" + . "<" x ($list_len - 1) . "\n" + . '$curtest->{canon}' + . "\n.\n"; + + eval $fmt_top; + die $@ if $@; + eval $fmt; + die $@ if $@; + + # Now write to formats for $script (sort keys %failedtests) { $curtest = $failedtests{$script}; write; @@ -323,16 +352,9 @@ sub runtests { my $tried_devel_corestack; sub corestatus { my($st) = @_; - my($ret); eval {require 'wait.ph'}; - if ($@) { - SWITCH: { - $ret = ($st & 0200); # Tim says, this is for 90% - } - } else { - $ret = WCOREDUMP($st); - } + my $ret = defined &WCOREDUMP ? WCOREDUMP($st) : $st & 0200; eval { require Devel::CoreStack; $have_devel_corestack++ } unless $tried_devel_corestack++; @@ -516,6 +538,12 @@ switches used to invoke perl on each test. For example, setting C<HARNESS_PERL_SWITCHES> to "-W" will run all tests with all warnings enabled. +If C<HARNESS_COLUMNS> is set, then this value will be used for the +width of the terminal. If it is not set then it will default to +C<COLUMNS>. If this is not set, it will default to 80. Note that users +of Bourne-sh based shells will need to C<export COLUMNS> for this +module to use that variable. + Harness sets C<HARNESS_ACTIVE> before executing the individual tests. This allows the tests to determine if they are being executed through the harness or by any other means. diff --git a/contrib/perl5/lib/Text/ParseWords.pm b/contrib/perl5/lib/Text/ParseWords.pm index 2a6afc3be9db..23eace978246 100644 --- a/contrib/perl5/lib/Text/ParseWords.pm +++ b/contrib/perl5/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/contrib/perl5/lib/Text/Soundex.pm b/contrib/perl5/lib/Text/Soundex.pm index 3079b90612c0..d5887640b8d4 100644 --- a/contrib/perl5/lib/Text/Soundex.pm +++ b/contrib/perl5/lib/Text/Soundex.pm @@ -108,7 +108,7 @@ many people seem to prefer an I<unlikely> value like C<Z000> can be assigned to C<$soundex_nocode>. In scalar context C<soundex> returns the soundex code of its first -argument, and in array context a list is returned in which each element is the +argument, and in list context a list is returned in which each element is the soundex code for the corresponding argument passed to C<soundex> e.g. @codes = soundex qw(Mike Stok); diff --git a/contrib/perl5/lib/Text/Tabs.pm b/contrib/perl5/lib/Text/Tabs.pm index 933f917acdcb..c431019908e0 100644 --- a/contrib/perl5/lib/Text/Tabs.pm +++ b/contrib/perl5/lib/Text/Tabs.pm @@ -73,11 +73,11 @@ Text::Tabs -- expand and unexpand tabs per the unix expand(1) and unexpand(1) =head1 SYNOPSIS - use Text::Tabs; +use Text::Tabs; - $tabstop = 4; - @lines_without_tabs = expand(@lines_with_tabs); - @lines_with_tabs = unexpand(@lines_without_tabs); +$tabstop = 4; +@lines_without_tabs = expand(@lines_with_tabs); +@lines_with_tabs = unexpand(@lines_without_tabs); =head1 DESCRIPTION diff --git a/contrib/perl5/lib/Text/Wrap.pm b/contrib/perl5/lib/Text/Wrap.pm index 5f95edb69c72..579e09b395b9 100644 --- a/contrib/perl5/lib/Text/Wrap.pm +++ b/contrib/perl5/lib/Text/Wrap.pm @@ -6,7 +6,7 @@ require Exporter; @EXPORT = qw(wrap fill); @EXPORT_OK = qw($columns $break $huge); -$VERSION = 98.112902; +$VERSION = 2001.0131; use vars qw($VERSION $columns $debug $break $huge); use strict; @@ -15,7 +15,7 @@ BEGIN { $columns = 76; # <= screen width $debug = 0; $break = '\s'; - $huge = 'wrap'; # alternatively: 'die' + $huge = 'wrap'; # alternatively: 'die' or 'overflow' } use Text::Tabs qw(expand unexpand); @@ -25,20 +25,25 @@ sub wrap my ($ip, $xp, @t) = @_; my $r = ""; - my $t = expand(join(" ",@t)); + my $tail = pop(@t); + my $t = expand(join("", (map { /\s+\Z/ ? ( $_ ) : ($_, ' ') } @t), $tail)); my $lead = $ip; my $ll = $columns - length(expand($ip)) - 1; my $nll = $columns - length(expand($xp)) - 1; my $nl = ""; my $remainder = ""; - while ($t !~ /^\s*$/) { - if ($t =~ s/^([^\n]{0,$ll})($break|\Z(?!\n))//xm) { + pos($t) = 0; + while ($t !~ /\G\s*\Z/gc) { + if ($t =~ /\G([^\n]{0,$ll})($break|\Z(?!\n))/xmgc) { $r .= unexpand($nl . $lead . $1); $remainder = $2; - } elsif ($huge eq 'wrap' && $t =~ s/^([^\n]{$ll})//) { + } elsif ($huge eq 'wrap' && $t =~ /\G([^\n]{$ll})/gc) { $r .= unexpand($nl . $lead . $1); $remainder = "\n"; + } elsif ($huge eq 'overflow' && $t =~ /\G([^\n]*?)($break|\Z(?!\n))/xmgc) { + $r .= unexpand($nl . $lead . $1); + $remainder = $2; } elsif ($huge eq 'die') { die "couldn't wrap '$t'"; } else { @@ -53,11 +58,13 @@ sub wrap print "-----------$r---------\n" if $debug; - print "Finish up with '$lead', '$t'\n" if $debug; + print "Finish up with '$lead'\n" if $debug; - $r .= $lead . $t if $t ne ""; + $r .= $lead . substr($t, pos($t), length($t)-pos($t)) + if pos($t) ne length($t); print "-----------$r---------\n" if $debug;; + return $r; } @@ -76,7 +83,8 @@ sub fill # if paragraph_indent is the same as line_indent, # separate paragraphs with blank lines - return join ($ip eq $xp ? "\n\n" : "\n", @para); + my $ps = ($ip eq $xp) ? "\n\n" : "\n"; + return join ($ps, @para); } 1; @@ -88,38 +96,73 @@ Text::Wrap - line wrapping to form simple paragraphs =head1 SYNOPSIS +B<Example 1> + use Text::Wrap + $initial_tab = "\t"; # Tab before first line + $subsequent_tab = ""; # All other lines flush left + print wrap($initial_tab, $subsequent_tab, @text); print fill($initial_tab, $subsequent_tab, @text); + @lines = wrap($initial_tab, $subsequent_tab, @text); + + @paragraphs = fill($initial_tab, $subsequent_tab, @text); + +B<Example 2> + use Text::Wrap qw(wrap $columns $huge); - $columns = 132; + $columns = 132; # Wrap at 132 characters $huge = 'die'; $huge = 'wrap'; + $huge = 'overflow'; -=head1 DESCRIPTION +B<Example 3> + + use Text::Wrap -Text::Wrap::wrap() is a very simple paragraph formatter. It formats a -single paragraph at a time by breaking lines at word boundaries. -Indentation is controlled for the first line ($initial_tab) and -all subsequent lines ($subsequent_tab) independently. + $Text::Wrap::columns = 72; + print wrap('', '', @text); -Lines are wrapped at $Text::Wrap::columns columns. -$Text::Wrap::columns should be set to the full width of your output device. +=head1 DESCRIPTION -When words that are longer than $columns are encountered, they -are broken up. Previous versions of wrap() die()ed instead. -To restore the old (dying) behavior, set $Text::Wrap::huge to -'die'. +Text::Wrap::wrap() is a very simple paragraph formatter. It formats a +single paragraph at a time by breaking lines at word boundries. +Indentation is controlled for the first line (C<$initial_tab>) and +all subsquent lines (C<$subsequent_tab>) independently. Please note: +C<$initial_tab> and C<$subsequent_tab> are the literal strings that will +be used: it is unlikley you would want to pass in a number. + +Lines are wrapped at C<$Text::Wrap::columns> columns. C<$Text::Wrap::columns> +should be set to the full width of your output device. In fact, +every resulting line will have length of no more than C<$columns - 1>. + +Beginner note: In example 2, above C<$columns> is imported into +the local namespace, and set locally. In example 3, +C<$Text::Wrap::columns> is set in its own namespace without importing it. + +When words that are longer than C<$columns> are encountered, they +are broken up. C<wrap()> adds a C<"\n"> at column C<$columns>. +This behavior can be overridden by setting C<$huge> to +'die' or to 'overflow'. When set to 'die', large words will cause +C<die()> to be called. When set to 'overflow', large words will be +left intact. Text::Wrap::fill() is a simple multi-paragraph formatter. It formats each paragraph separately and then joins them together when it's done. It -will destroy any whitespace in the original text. It breaks text into +will destory any whitespace in the original text. It breaks text into paragraphs by looking for whitespace after a newline. In other respects it acts like wrap(). +When called in list context, C<wrap()> will return a list of lines and +C<fill()> will return a list of paragraphs. + +Historical notes: Older versions of C<wrap()> and C<fill()> always +returned strings. Also, 'die' used to be the default value of +C<$huge>. Now, 'wrap' is the default value. + =head1 EXAMPLE print wrap("\t","","This is a bit of text that forms diff --git a/contrib/perl5/lib/Tie/Array.pm b/contrib/perl5/lib/Tie/Array.pm index eb83aaee17ad..f4c619359650 100644 --- a/contrib/perl5/lib/Tie/Array.pm +++ b/contrib/perl5/lib/Tie/Array.pm @@ -8,73 +8,70 @@ our $VERSION = '1.01'; # Pod documentation after __END__ below. sub DESTROY { } -sub EXTEND { } -sub UNSHIFT { shift->SPLICE(0,0,@_) } -sub SHIFT { shift->SPLICE(0,1) } +sub EXTEND { } +sub UNSHIFT { scalar shift->SPLICE(0,0,@_) } +sub SHIFT { shift->SPLICE(0,1) } +#sub SHIFT { (shift->SPLICE(0,1))[0] } sub CLEAR { shift->STORESIZE(0) } -sub PUSH -{ +sub PUSH +{ my $obj = shift; my $i = $obj->FETCHSIZE; $obj->STORE($i++, shift) while (@_); } -sub POP +sub POP { my $obj = shift; my $newsize = $obj->FETCHSIZE - 1; my $val; - if ($newsize >= 0) + if ($newsize >= 0) { $val = $obj->FETCH($newsize); $obj->STORESIZE($newsize); } $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 { my $pkg = ref $_[0]; @@ -91,21 +88,21 @@ use vars qw(@ISA); @ISA = 'Tie::Array'; sub TIEARRAY { bless [], $_[0] } -sub FETCHSIZE { scalar @{$_[0]} } -sub STORESIZE { $#{$_[0]} = $_[1]-1 } +sub FETCHSIZE { scalar @{$_[0]} } +sub STORESIZE { $#{$_[0]} = $_[1]-1 } sub STORE { $_[0]->[$_[1]] = $_[2] } sub FETCH { $_[0]->[$_[1]] } sub CLEAR { @{$_[0]} = () } -sub POP { pop(@{$_[0]}) } +sub POP { pop(@{$_[0]}) } sub PUSH { my $o = shift; push(@$o,@_) } -sub SHIFT { shift(@{$_[0]}) } -sub UNSHIFT { my $o = shift; unshift(@$o,@_) } +sub SHIFT { shift(@{$_[0]}) } +sub UNSHIFT { my $o = shift; unshift(@$o,@_) } sub EXISTS { exists $_[0]->[$_[1]] } sub DELETE { delete $_[0]->[$_[1]] } sub SPLICE { - my $ob = shift; + my $ob = shift; my $sz = $ob->FETCHSIZE; my $off = @_ ? shift : 0; $off += $sz if $off < 0; @@ -121,16 +118,16 @@ __END__ Tie::Array - base class for tied arrays -=head1 SYNOPSIS +=head1 SYNOPSIS package NewArray; use Tie::Array; @ISA = ('Tie::Array'); # mandatory methods - sub TIEARRAY { ... } - sub FETCH { ... } - sub FETCHSIZE { ... } + sub TIEARRAY { ... } + sub FETCH { ... } + sub FETCHSIZE { ... } sub STORE { ... } # mandatory if elements writeable sub STORESIZE { ... } # mandatory if elements can be added/deleted @@ -138,13 +135,13 @@ Tie::Array - base class for tied arrays sub DELETE { ... } # mandatory if delete() expected to work # optional methods - for efficiency - sub CLEAR { ... } - sub PUSH { ... } - sub POP { ... } - sub SHIFT { ... } - sub UNSHIFT { ... } - sub SPLICE { ... } - sub EXTEND { ... } + sub CLEAR { ... } + sub PUSH { ... } + sub POP { ... } + sub SHIFT { ... } + sub UNSHIFT { ... } + sub SPLICE { ... } + sub EXTEND { ... } sub DESTROY { ... } package NewStdArray; @@ -162,7 +159,7 @@ Tie::Array - base class for tied arrays -=head1 DESCRIPTION +=head1 DESCRIPTION This module provides methods for array-tying classes. See L<perltie> for a list of the functions required in order to tie an array @@ -173,16 +170,16 @@ on the tied array, and implementations of C<PUSH>, C<POP>, C<SHIFT>, C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>, C<FETCHSIZE>, C<STORESIZE>. -The B<Tie::StdArray> package provides efficient methods required for tied arrays +The B<Tie::StdArray> package provides efficient methods required for tied arrays which are implemented as blessed references to an "inner" perl array. -It inherits from B<Tie::Array>, and should cause tied arrays to behave exactly -like standard arrays, allowing for selective overloading of methods. +It inherits from B<Tie::Array>, and should cause tied arrays to behave exactly +like standard arrays, allowing for selective overloading of methods. For developers wishing to write their own tied arrays, the required methods are briefly defined below. See the L<perltie> section for more detailed descriptive, as well as example code: -=over +=over =item TIEARRAY classname, LIST @@ -190,7 +187,7 @@ The class method is invoked by the command C<tie @array, classname>. Associates an array instance with the specified class. C<LIST> would represent additional arguments (along the lines of L<AnyDBM_File> and compatriots) needed to complete the association. The method should return an object of a class which -provides the methods below. +provides the methods below. =item STORE this, index, value @@ -214,7 +211,7 @@ Sets the total number of items in the tied array associated with object I<this> to be I<count>. If this makes the array larger then class's mapping of C<undef> should be returned for new positions. If the array becomes smaller then entries beyond count should be -deleted. +deleted. =item EXTEND this, count @@ -242,7 +239,7 @@ object I<this>. Normal object destructor method. -=item PUSH this, LIST +=item PUSH this, LIST Append elements of LIST to the array. @@ -255,17 +252,17 @@ Remove last element of the array and return it. Remove the first element of the array (shifting other elements down) and return it. -=item UNSHIFT this, LIST +=item UNSHIFT this, LIST Insert LIST elements at the beginning of the array, moving existing elements up to make room. =item SPLICE this, offset, length, LIST -Perform the equivalent of C<splice> on the array. +Perform the equivalent of C<splice> on the array. -I<offset> is optional and defaults to zero, negative values count back -from the end of the array. +I<offset> is optional and defaults to zero, negative values count back +from the end of the array. I<length> is optional and defaults to rest of the array. @@ -277,16 +274,15 @@ Returns a list of the original I<length> elements at I<offset>. =head1 CAVEATS -There is no support at present for tied @ISA. There is a potential conflict +There is no support at present for tied @ISA. There is a potential conflict between magic entries needed to notice setting of @ISA, and those needed to -implement 'tie'. +implement 'tie'. Very little consideration has been given to the behaviour of tied arrays when C<$[> is not default value of zero. -=head1 AUTHOR +=head1 AUTHOR Nick Ing-Simmons E<lt>nik@tiuk.ti.comE<gt> -=cut - +=cut diff --git a/contrib/perl5/lib/Tie/Handle.pm b/contrib/perl5/lib/Tie/Handle.pm index 588ecead8999..81b079224964 100644 --- a/contrib/perl5/lib/Tie/Handle.pm +++ b/contrib/perl5/lib/Tie/Handle.pm @@ -1,7 +1,7 @@ package Tie::Handle; use 5.005_64; -our $VERSION = '1.0'; +our $VERSION = '4.0'; =head1 NAME @@ -105,6 +105,15 @@ destruction of an instance. The L<perltie> section contains an example of tying handles. +=head1 COMPATIBILITY + +This version of Tie::Handle is neither related to nor compatible with +the Tie::Handle (3.0) module available on CPAN. It was due to an +accident that two modules with the same name appeared. The namespace +clash has been cleared in favor of this module that comes with the +perl core in September 2000 and accordingly the version number has +been bumped up to 4.0. + =cut use Carp; @@ -120,8 +129,7 @@ sub new { sub TIEHANDLE { my $pkg = shift; if (defined &{"{$pkg}::new"}) { - warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing" - if warnings::enabled(); + warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing"); $pkg->new(@_); } else { @@ -184,10 +192,10 @@ sub WRITE { sub CLOSE { my $pkg = ref $_[0]; croak "$pkg doesn't define a CLOSE method"; -} +} package Tie::StdHandle; -our @ISA = 'Tie::Handle'; +our @ISA = 'Tie::Handle'; use Carp; sub TIEHANDLE @@ -197,7 +205,7 @@ sub TIEHANDLE bless $fh,$class; $fh->OPEN(@_) if (@_); return $fh; -} +} sub EOF { eof($_[0]) } sub TELL { tell($_[0]) } @@ -207,9 +215,9 @@ sub CLOSE { close($_[0]) } sub BINMODE { binmode($_[0]) } sub OPEN -{ +{ $_[0]->CLOSE if defined($_[0]->FILENO); - open($_[0],$_[1]); + @_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]); } sub READ { read($_[0],$_[1],$_[2]) } @@ -217,7 +225,7 @@ sub READLINE { my $fh = $_[0]; <$fh> } sub GETC { getc($_[0]) } sub WRITE -{ +{ my $fh = $_[0]; print $fh substr($_[1],0,$_[2]) } diff --git a/contrib/perl5/lib/Tie/Hash.pm b/contrib/perl5/lib/Tie/Hash.pm index c6ec3d4f5c62..2244711669ab 100644 --- a/contrib/perl5/lib/Tie/Hash.pm +++ b/contrib/perl5/lib/Tie/Hash.pm @@ -114,8 +114,7 @@ sub new { sub TIEHASH { my $pkg = shift; if (defined &{"${pkg}::new"}) { - warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing" - if warnings::enabled(); + warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing"); $pkg->new(@_); } else { diff --git a/contrib/perl5/lib/Tie/RefHash.pm b/contrib/perl5/lib/Tie/RefHash.pm index ffa9eb20a00c..461148821f59 100644 --- a/contrib/perl5/lib/Tie/RefHash.pm +++ b/contrib/perl5/lib/Tie/RefHash.pm @@ -9,17 +9,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<tie> the hash variable to this module. +This module provides the ability to use references as hash keys if you +first C<tie> 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::RefHash. It is implemented using the standard perl TIEHASH interface. Please see the C<tie> 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 +45,11 @@ see the C<tie> 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 @@ -43,7 +57,7 @@ Gurusamy Sarathy gsar@activestate.com =head1 VERSION -Version 1.21 22 Jun 1999 +Version 1.3 8 Apr 2001 =head1 SEE ALSO @@ -51,11 +65,13 @@ perl(1), perlfunc(1), perltie(1) =cut -require 5.003_11; +use v5.6.0; use Tie::Hash; -@ISA = qw(Tie::Hash); use strict; +our @ISA = qw(Tie::Hash); +our $VERSION = '1.3'; + sub TIEHASH { my $c = shift; my $s = []; @@ -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; +our @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/contrib/perl5/lib/Tie/Scalar.pm b/contrib/perl5/lib/Tie/Scalar.pm index 0c6759006f06..89ad03eddc15 100644 --- a/contrib/perl5/lib/Tie/Scalar.pm +++ b/contrib/perl5/lib/Tie/Scalar.pm @@ -91,8 +91,7 @@ sub new { sub TIESCALAR { my $pkg = shift; if (defined &{"{$pkg}::new"}) { - warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing" - if warnings::enabled(); + warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing"); $pkg->new(@_); } else { diff --git a/contrib/perl5/lib/Tie/SubstrHash.pm b/contrib/perl5/lib/Tie/SubstrHash.pm index 4b18a58e122c..1c04c6fe269d 100644 --- a/contrib/perl5/lib/Tie/SubstrHash.pm +++ b/contrib/perl5/lib/Tie/SubstrHash.pm @@ -33,6 +33,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 +43,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 +79,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 +139,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 +148,65 @@ 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; +} + +# See: +# +# http://www-groups.dcs.st-andrews.ac.uk/~history/HistTopics/Prime_numbers.html +# + +sub findgteprime { # find the smallest prime integer greater than or equal to use integer; - my $num = shift; - $num++ unless $num % 2; + my $num = ceil(shift); + return 2 if $num <= 2; - $max = int sqrt $num; + $num++ unless $num % 2; + my $i; + my $sqrtnum = int sqrt $num; + my $sqrtnumsquared = $sqrtnum * $sqrtnum; NUM: for (;; $num += 2) { - for ($i = 3; $i <= $max; $i += 2) { - next NUM unless $num % $i; + if ($sqrtnumsquared < $num) { + $sqrtnum++; + $sqrtnumsquared = $sqrtnum * $sqrtnum; } - return $num; + for ($i = 3; $i <= $sqrtnum; $i += 2) { + next NUM unless $num % $i; + } + return $num; } } diff --git a/contrib/perl5/lib/base.pm b/contrib/perl5/lib/base.pm index 3cb42f5bfa2f..d055129fb0e9 100644 --- a/contrib/perl5/lib/base.pm +++ b/contrib/perl5/lib/base.pm @@ -30,7 +30,7 @@ C<require>s them. Whether to C<require> a base class package is determined by the absence of a global $VERSION in the base package. If $VERSION is not detected even after loading it, <base> will define $VERSION in the base package, setting it to the string -C<-1, defined by base.pm>. +C<-1, set by base.pm>. =head1 HISTORY diff --git a/contrib/perl5/lib/bigint.pl b/contrib/perl5/lib/bigint.pl index 4044f7f63483..9a3d50d365af 100644 --- a/contrib/perl5/lib/bigint.pl +++ b/contrib/perl5/lib/bigint.pl @@ -42,6 +42,12 @@ package bigint; # bnorm(BINT) return BINT normalization # +# overcome a floating point problem on certain osnames (posix-bc, os390) +BEGIN { + my $x = 100000.0; + my $use_mult = int($x*1e-5)*1e5 == $x ? 1 : 0; +} + $zero = 0; @@ -212,8 +218,14 @@ sub main'bmul { #(num_str, num_str) return num_str ($car, $cty) = (0, $[); for $y (@y) { $prod = $x * $y + $prod[$cty] + $car; - $prod[$cty++] = - $prod - ($car = int($prod * 1e-5)) * 1e5; + if ($use_mult) { + $prod[$cty++] = + $prod - ($car = int($prod * 1e-5)) * 1e5; + } + else { + $prod[$cty++] = + $prod - ($car = int($prod / 1e5)) * 1e5; + } } $prod[$cty] += $car if $car; $x = shift @prod; @@ -239,12 +251,22 @@ sub main'bdiv { #(dividend: num_str, divisor: num_str) return num_str if (($dd = int(1e5/($y[$#y]+1))) != 1) { for $x (@x) { $x = $x * $dd + $car; + if ($use_mult) { $x -= ($car = int($x * 1e-5)) * 1e5; + } + else { + $x -= ($car = int($x / 1e5)) * 1e5; + } } push(@x, $car); $car = 0; for $y (@y) { $y = $y * $dd + $car; + if ($use_mult) { $y -= ($car = int($y * 1e-5)) * 1e5; + } + else { + $y -= ($car = int($y / 1e5)) * 1e5; + } } } else { @@ -259,7 +281,12 @@ sub main'bdiv { #(dividend: num_str, divisor: num_str) return num_str ($car, $bar) = (0,0); for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) { $prd = $q * $y[$y] + $car; + if ($use_mult) { $prd -= ($car = int($prd * 1e-5)) * 1e5; + } + else { + $prd -= ($car = int($prd / 1e5)) * 1e5; + } $x[$x] += 1e5 if ($bar = (($x[$x] -= $prd + $bar) < 0)); } if ($x[$#x] < $car + $bar) { diff --git a/contrib/perl5/lib/bytes.pm b/contrib/perl5/lib/bytes.pm index f93d6158d9fc..f2f7e0157cb8 100644 --- a/contrib/perl5/lib/bytes.pm +++ b/contrib/perl5/lib/bytes.pm @@ -38,11 +38,28 @@ The C<use bytes> pragma disables character semantics for the rest of the lexical scope in which it appears. C<no bytes> can be used to reverse the effect of C<use bytes> within the current lexical scope. -Perl normally assumes character semantics in the presence of -character data (i.e. data that has come from a source that has -been marked as being of a particular character encoding). - -To understand the implications and differences between character +Perl normally assumes character semantics in the presence of character +data (i.e. data that has come from a source that has been marked as +being of a particular character encoding). When C<use bytes> is in +effect, the encoding is temporarily ignored, and each string is treated +as a series of bytes. + +As an example, when Perl sees C<$x = chr(400)>, it encodes the character +in UTF8 and stores it in $x. Then it is marked as character data, so, +for instance, C<length $x> returns C<1>. However, in the scope of the +C<bytes> pragma, $x is treated as a series of bytes - the bytes that make +up the UTF8 encoding - and C<length $x> returns C<2>: + + $x = chr(400); + print "Length is ", length $x, "\n"; # "Length is 1" + printf "Contents are %vd\n", $x; # "Contents are 400" + { + use bytes; + print "Length is ", length $x, "\n"; # "Length is 2" + printf "Contents are %vd\n", $x; # "Contents are 198.144" + } + +For more on the implications and differences between character semantics and byte semantics, see L<perlunicode>. =head1 SEE ALSO diff --git a/contrib/perl5/lib/charnames.pm b/contrib/perl5/lib/charnames.pm index 7c2209b9f096..5f0c95f0cb8b 100644 --- a/contrib/perl5/lib/charnames.pm +++ b/contrib/perl5/lib/charnames.pm @@ -1,5 +1,6 @@ package charnames; use bytes (); # for $bytes::hint_bits +use warnings(); $charnames::hint_bits = 0x20000; my $txt; @@ -29,8 +30,11 @@ sub charnames { } } die "Unknown charname '$name'" unless @off; - - my $ord = hex substr $txt, $off[0] - 4, 4; + + my $hexlen = 4; # Unicode guarantees 4-, 5-, or 6-digit format + $hexlen++ while + $hexlen < 6 && substr($txt, $off[0] - $hexlen - 1, 1) =~ /[0-9a-f]/; + my $ord = hex substr $txt, $off[0] - $hexlen, $hexlen; if ($^H & $bytes::hint_bits) { # "use bytes" in effect? use bytes; return chr $ord if $ord <= 255; @@ -51,6 +55,13 @@ sub import { $^H{charnames_full} = delete $h{':full'}; $^H{charnames_short} = delete $h{':short'}; $^H{charnames_scripts} = [map uc, keys %h]; + if (warnings::enabled('utf8') && @{$^H{charnames_scripts}}) { + $txt = do "unicode/Name.pl" unless $txt; + for (@{$^H{charnames_scripts}}) { + warnings::warn('utf8', "No such script: '$_'") unless + $txt =~ m/\t\t$_ (?:CAPITAL |SMALL )?LETTER /; + } + } } diff --git a/contrib/perl5/lib/diagnostics.pm b/contrib/perl5/lib/diagnostics.pm index a2c927baca51..884ea3ca6554 100755 --- a/contrib/perl5/lib/diagnostics.pm +++ b/contrib/perl5/lib/diagnostics.pm @@ -44,7 +44,7 @@ These still go out B<STDERR>. Due to the interaction between runtime and compiletime issues, and because it's probably not a very good idea anyway, you may not use C<no diagnostics> to turn them off at compiletime. -However, you may control there behaviour at runtime using the +However, you may control their behaviour at runtime using the disable() and enable() methods to turn them off and on respectively. The B<-verbose> flag first prints out the L<perldiag> introduction before @@ -167,19 +167,23 @@ Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995. =cut +use strict; use 5.005_64; use Carp; -$VERSION = v1.0; +our $VERSION = v1.0; +our $DEBUG; +our $VERBOSE; +our $PRETTY; use Config; -($privlib, $archlib) = @Config{qw(privlibexp archlibexp)}; +my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)}; if ($^O eq 'VMS') { require VMS::Filespec; $privlib = VMS::Filespec::unixify($privlib); $archlib = VMS::Filespec::unixify($archlib); } -@trypod = ( +my @trypod = ( "$archlib/pod/perldiag.pod", "$privlib/pod/perldiag-$Config{version}.pod", "$privlib/pod/perldiag.pod", @@ -189,21 +193,21 @@ if ($^O eq 'VMS') { ); # handy for development testing of new warnings etc unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod"; -($PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0]; +(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0]; $DEBUG ||= 0; my $WHOAMI = ref bless []; # nobody's business, prolly not even mine -$| = 1; - +local $| = 1; local $_; +my $standalone; +my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7); + CONFIG: { - $opt_p = $opt_d = $opt_v = $opt_f = ''; - %HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = (); - %exact_duplicate = (); + our $opt_p = our $opt_d = our $opt_v = our $opt_f = ''; - unless (caller) { + unless (caller) { $standalone++; require Getopt::Std; Getopt::Std::getopts('pdvf:') @@ -212,7 +216,7 @@ CONFIG: { $DEBUG = 2 if $opt_d; $VERBOSE = $opt_v; $PRETTY = $opt_p; - } + } if (open(POD_DIAG, $PODFILE)) { warn "Happy happy podfile from real $PODFILE\n" if $DEBUG; @@ -221,11 +225,12 @@ CONFIG: { if (caller) { INCPATH: { - for $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) { + for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) { warn "Checking $file\n" if $DEBUG; if (open(POD_DIAG, $file)) { while (<POD_DIAG>) { - next unless /^__END__\s*# wish diag dbase were more accessible/; + next unless + /^__END__\s*# wish diag dbase were more accessible/; print STDERR "podfile is $file\n" if $DEBUG; last INCPATH; } @@ -274,6 +279,7 @@ if (eof(POD_DIAG)) { # etc ); +our %HTML_Escapes; *HTML_Escapes = do { if ($standalone) { $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; @@ -284,20 +290,20 @@ if (eof(POD_DIAG)) { *THITHER = $standalone ? *STDOUT : *STDERR; -$transmo = <<EOFUNC; +my $transmo = <<EOFUNC; sub transmo { #local \$^W = 0; # recursive warnings we do NOT need! study; EOFUNC -### sub finish_compilation { # 5.001e panic: top_level for embedded version +my %msg; +{ print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG; - ### local - $RS = ''; + local $/ = ''; local $_; + my $header; + my $for_item; while (<POD_DIAG>) { - #s/(.*)\n//; - #$header = $1; unescape(); if ($PRETTY) { @@ -321,29 +327,35 @@ EOFUNC } s/^/ /gm; $msg{$header} .= $_; + undef $for_item; } next; } - unless ( s/=item (.*)\s*\Z//) { + unless ( s/=item (.*?)\s*\z//) { if ( s/=head1\sDESCRIPTION//) { $msg{$header = 'DESCRIPTION'} = ''; + undef $for_item; } + elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) { + $for_item = $1; + } next; } # strip formatting directives in =item line - ($header = $1) =~ s/[A-Z]<(.*?)>/$1/g; + $header = $for_item || $1; + undef $for_item; + $header =~ s/[A-Z]<(.*?)>/$1/g; if ($header =~ /%[csd]/) { - $rhs = $lhs = $header; - #if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E\$/g) { - if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E/g) { + my $rhs = my $lhs = $header; + if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E-?\\d+\Q$2\E/g) { $lhs =~ s/\\%s/.*?/g; } else { - # if i had lookbehind negations, i wouldn't have to do this \377 noise + # if i had lookbehind negations, + # i wouldn't have to do this \377 noise $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g; - #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/; $lhs =~ s/\377([^\377]*)$/\Q$1\E/; $lhs =~ s/\377//g; $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all @@ -369,25 +381,23 @@ EOFUNC print STDERR $transmo if $DEBUG; eval $transmo; die $@ if $@; - $RS = "\n"; -### } +} if ($standalone) { if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } - while (defined ($error = <>)) { + while (defined (my $error = <>)) { splainthis($error) || print THITHER $error; } exit; -} else { - #$old_w = 0; - $oldwarn = ''; $olddie = ''; -} +} + +my $olddie; +my $oldwarn; sub import { shift; - #$old_w = $^W; - $^W = 1; # yup, clobbered the global variable; tough, if you - # want diags, you want diags. + $^W = 1; # yup, clobbered the global variable; + # tough, if you want diags, you want diags. return if $SIG{__WARN__} eq \&warn_trap; for (@_) { @@ -421,10 +431,9 @@ sub enable { &import } sub disable { shift; - #$^W = $old_w; return unless $SIG{__WARN__} eq \&warn_trap; - $SIG{__WARN__} = $oldwarn; - $SIG{__DIE__} = $olddie; + $SIG{__WARN__} = $oldwarn || ''; + $SIG{__DIE__} = $olddie || ''; } sub warn_trap { @@ -465,6 +474,10 @@ sub death_trap { # into an indirect recursion loop }; +my %exact_duplicate; +my %old_diag; +my $count; +my $wantspace; sub splainthis { local $_ = shift; local $\; @@ -473,7 +486,7 @@ sub splainthis { my $orig = $_; # return unless defined; s/, <.*?> (?:line|chunk).*$//; - $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/; + my $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/; s/^\((.*)\)$/$1/; if ($exact_duplicate{$orig}++) { return &transmo; @@ -542,8 +555,5 @@ sub shorten { } -# have to do this: RS isn't set until run time, but we're executing at compiletime -$RS = "\n"; - 1 unless $standalone; # or it'll complain about itself __END__ # wish diag dbase were more accessible diff --git a/contrib/perl5/lib/fields.pm b/contrib/perl5/lib/fields.pm index ac4581036f72..37ff99d78ac4 100644 --- a/contrib/perl5/lib/fields.pm +++ b/contrib/perl5/lib/fields.pm @@ -172,8 +172,7 @@ sub import { if ($fno and $fno != $next) { require Carp; if ($fno < $fattr->[0]) { - warnings::warn("Hides field '$f' in base class") - if warnings::enabled(); + warnings::warnif("Hides field '$f' in base class") ; } else { Carp::croak("Field name '$f' already in use"); } diff --git a/contrib/perl5/lib/ftp.pl b/contrib/perl5/lib/ftp.pl index aa6a48966505..3f0af1a8d7fa 100644 --- a/contrib/perl5/lib/ftp.pl +++ b/contrib/perl5/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/contrib/perl5/lib/getopts.pl b/contrib/perl5/lib/getopts.pl index 25958199a6a9..4a50b8f6c224 100644 --- a/contrib/perl5/lib/getopts.pl +++ b/contrib/perl5/lib/getopts.pl @@ -16,41 +16,50 @@ sub Getopts { local($argumentative) = @_; local(@args,$_,$first,$rest); local($errs) = 0; + local($[) = 0; @args = split( / */, $argumentative ); while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { - ($first,$rest) = ($1,$2); - $pos = index($argumentative,$first); - if($pos >= 0) { - if($pos < $#args && $args[$pos+1] eq ':') { - shift(@ARGV); - if($rest eq '') { - ++$errs unless @ARGV; - $rest = shift(@ARGV); - } - ${"opt_$first"} = $rest; - } - else { - ${"opt_$first"} = 1; - if($rest eq '') { - shift(@ARGV); + ($first,$rest) = ($1,$2); + $pos = index($argumentative,$first); + if($pos >= $[) { + if($args[$pos+1] eq ':') { + shift(@ARGV); + if($rest eq '') { + ++$errs unless(@ARGV); + $rest = shift(@ARGV); + } + eval " + push(\@opt_$first, \$rest); + if(\$opt_$first eq '') { + \$opt_$first = \$rest; + } + else { + \$opt_$first .= ' ' . \$rest; + } + "; + } + else { + eval "\$opt_$first = 1"; + if($rest eq '') { + shift(@ARGV); + } + else { + $ARGV[0] = "-$rest"; + } + } } else { - $ARGV[0] = "-$rest"; + print STDERR "Unknown option: $first\n"; + ++$errs; + if($rest ne '') { + $ARGV[0] = "-$rest"; + } + else { + shift(@ARGV); + } } - } - } - else { - print STDERR "Unknown option: $first\n"; - ++$errs; - if($rest ne '') { - $ARGV[0] = "-$rest"; - } - else { - shift(@ARGV); - } } - } $errs == 0; } diff --git a/contrib/perl5/lib/integer.pm b/contrib/perl5/lib/integer.pm index 86afcaf130db..998574f0a776 100644 --- a/contrib/perl5/lib/integer.pm +++ b/contrib/perl5/lib/integer.pm @@ -2,7 +2,7 @@ package integer; =head1 NAME -integer - Perl pragma to compute arithmetic in integer instead of double +integer - Perl pragma to use integer arithmetic instead of floating point =head1 SYNOPSIS @@ -12,34 +12,69 @@ integer - Perl pragma to compute arithmetic in integer instead of double =head1 DESCRIPTION -This tells the compiler to use integer operations -from here to the end of the enclosing BLOCK. On many machines, -this doesn't matter a great deal for most computations, but on those -without floating point hardware, it can make a big difference. - -Note that this affects the operations, not the numbers. If you run this -code +This tells the compiler to use integer operations from here to the end +of the enclosing BLOCK. On many machines, this doesn't matter a great +deal for most computations, but on those without floating point +hardware, it can make a big difference in performance. + +Note that this only affects how most of the arithmetic and relational +B<operators> handle their operands and results, and B<not> how all +numbers everywhere are treated. Specifically, C<use integer;> has the +effect that before computing the results of the arithmetic operators +(+, -, *, /, %, +=, -=, *=, /=, %=, and unary minus), the comparison +operators (<, <=, >, >=, ==, !=, <=>), and the bitwise operators (|, &, +^, <<, >>, |=, &=, ^=, <<=, >>=), the operands have their fractional +portions truncated (or floored), and the result will have its +fractional portion truncated as well. In addition, the range of +operands and results is restricted to that of familiar two's complement +integers, i.e., -(2**31) .. (2**31-1) on 32-bit architectures, and +-(2**63) .. (2**63-1) on 64-bit architectures. For example, this code use integer; - $x = 1.5; - $y = $x + 1; - $z = -1.5; - -you'll be left with C<$x == 1.5>, C<$y == 2> and C<$z == -1>. The $z -case happens because unary C<-> counts as an operation. - -Native integer arithmetic (as provided by your C compiler) is used. -This means that Perl's own semantics for arithmetic operations may -not be preserved. One common source of trouble is the modulus of -negative numbers, which Perl does one way, but your hardware may do -another. - - % perl -le 'print (4 % -3)' - -2 - % perl -Minteger -le 'print (4 % -3)' - 1 - -See L<perlmod/Pragmatic Modules>. + $x = 5.8; + $y = 2.5; + $z = 2.7; + $a = 2**31 - 1; # Largest positive integer on 32-bit machines + $, = ", "; + print $x, -$x, $x + $y, $x - $y, $x / $y, $x * $y, $y == $z, $a, $a + 1; + +will print: 5.8, -5, 7, 3, 2, 10, 1, 2147483647, -2147483648 + +Note that $x is still printed as having its true non-integer value of +5.8 since it wasn't operated on. And note too the wrap-around from the +largest positive integer to the largest negative one. Also, arguments +passed to functions and the values returned by them are B<not> affected +by C<use integer;>. E.g., + + srand(1.5); + $, = ", "; + print sin(.5), cos(.5), atan2(1,2), sqrt(2), rand(10); + +will give the same result with or without C<use integer;> The power +operator C<**> is also not affected, so that 2 ** .5 is always the +square root of 2. Now, it so happens that the pre- and post- increment +and decrement operators, ++ and --, are not affected by C<use integer;> +either. Some may rightly consider this to be a bug -- but at least it's +a long-standing one. + +Finally, C<use integer;> also has an additional affect on the bitwise +operators. Normally, the operands and results are treated as +B<unsigned> integers, but with C<use integer;> the operands and results +are B<signed>. This means, among other things, that ~0 is -1, and -2 & +-5 is -6. + +Internally, native integer arithmetic (as provided by your C compiler) +is used. This means that Perl's own semantics for arithmetic +operations may not be preserved. One common source of trouble is the +modulus of negative numbers, which Perl does one way, but your hardware +may do another. + + % perl -le 'print (4 % -3)' + -2 + % perl -Minteger -le 'print (4 % -3)' + 1 + +See L<perlmodlib/"Pragmatic Modules">, L<perlop/"Integer Arithmetic"> =cut diff --git a/contrib/perl5/lib/lib.pm b/contrib/perl5/lib/lib.pm index 98e2f733cb97..077dd633e7d6 100644 --- a/contrib/perl5/lib/lib.pm +++ b/contrib/perl5/lib/lib.pm @@ -32,6 +32,7 @@ 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"; } @@ -49,6 +50,8 @@ sub unimport { foreach (@_) { ++$names{$_}; ++$names{"$_/$archname"} if -d "$_/$archname/auto"; + ++$names{"$_/$ver"} if -d "$_/$ver"; + ++$names{"$_/$ver/$archname"} if -d "$_/$ver/$archname"; } # Remove ALL instances of each named directory. diff --git a/contrib/perl5/lib/overload.pm b/contrib/perl5/lib/overload.pm index ba96bc9ab615..70a5f884e649 100644 --- a/contrib/perl5/lib/overload.pm +++ b/contrib/perl5/lib/overload.pm @@ -106,7 +106,7 @@ sub mycan { # Real can would leave stubs. } %constants = ( - 'integer' => 0x1000, + 'integer' => 0x1000, 'float' => 0x2000, 'binary' => 0x4000, 'q' => 0x8000, @@ -127,11 +127,29 @@ sub mycan { # Real can would leave stubs. dereferencing => '${} @{} %{} &{} *{}', special => 'nomethod fallback ='); +use warnings::register; sub constant { # Arguments: what, sub while (@_) { - $^H{$_[0]} = $_[1]; - $^H |= $constants{$_[0]} | $overload::hint_bits; + if (@_ == 1) { + warnings::warnif ("Odd number of arguments for overload::constant"); + last; + } + elsif (!exists $constants {$_ [0]}) { + warnings::warnif ("`$_[0]' is not an overloadable type"); + } + elsif (!ref $_ [1] || "$_[1]" !~ /CODE\(0x[\da-f]+\)$/) { + # Can't use C<ref $_[1] eq "CODE"> above as code references can be + # blessed, and C<ref> would return the package the ref is blessed into. + if (warnings::enabled) { + $_ [1] = "undef" unless defined $_ [1]; + warnings::warn ("`$_[1]' is not a code reference"); + } + } + else { + $^H{$_[0]} = $_[1]; + $^H |= $constants{$_[0]} | $overload::hint_bits; + } shift, shift; } } @@ -149,7 +167,7 @@ sub remove_constant { __END__ -=head1 NAME +=head1 NAME overload - Package for overloading perl operations @@ -157,7 +175,7 @@ overload - Package for overloading perl operations package SomeThing; - use overload + use overload '+' => \&myadd, '-' => \&mysub; # etc @@ -179,12 +197,12 @@ The compilation directive package Number; use overload - "+" => \&add, + "+" => \&add, "*=" => "muas"; declares function Number::add() for addition, and method muas() in the "class" C<Number> (or one of its base classes) -for the assignment form C<*=> of multiplication. +for the assignment form C<*=> of multiplication. Arguments of this directive come in (key, value) pairs. Legal values are values legal inside a C<&{ ... }> call, so the name of a @@ -279,20 +297,20 @@ if C<+=> is not overloaded. =back B<Warning.> Due to the presense of assignment versions of operations, -routines which may be called in assignment context may create -self-referential structures. Currently Perl will not free self-referential +routines which may be called in assignment context may create +self-referential structures. Currently Perl will not free self-referential structures until cycles are C<explicitly> broken. You may get problems when traversing your structures too. -Say, +Say, use overload '+' => sub { bless [ \$_[0], \$_[1] ] }; is asking for trouble, since for code C<$obj += $foo> the subroutine -is called as C<$obj = add($obj, $foo, undef)>, or C<$obj = [\$obj, +is called as C<$obj = add($obj, $foo, undef)>, or C<$obj = [\$obj, \$foo]>. If using such a subroutine is an important optimization, one can overload C<+=> explicitly by a non-"optimized" version, or switch -to non-optimized version if C<not defined $_[2]> (see +to non-optimized version if C<not defined $_[2]> (see L<Calling Conventions for Binary Operations>). Even if no I<explicit> assignment-variants of operators are present in @@ -365,6 +383,11 @@ be used instead. C<bool> is used in the flow control operators return any arbitrary Perl value. If the corresponding operation for this value is overloaded too, that operation will be called again with this value. +As a special case if the overload returns the object itself then it will +be used directly. An overloaded conversion returning the object is +probably a bug, because you're likely to get something that looks like +C<YourPackage=HASH(0x8172b34)>. + =item * I<Iteration> "<>" @@ -382,6 +405,12 @@ If not overloaded, the argument will be dereferenced I<as is>, thus should be of correct type. These functions should return a reference of correct type, or another object with overloaded dereferencing. +As a special case if the overload returns the object itself then it +will be used directly (provided it is the correct type). + +The dereference operators must be specified explicitly they will not be passed to +"nomethod". + =item * I<Special> "nomethod", "fallback", "=", @@ -464,11 +493,16 @@ the last one is used. Say, C<1-$a> can be equivalent to if the pair C<"nomethod" =E<gt> "nomethodMethod"> was specified in the C<use overload> directive. +The C<"nomethod"> mechanism is I<not> used for the dereference operators +( ${} @{} %{} &{} *{} ). + + If some operation cannot be resolved, and there is no function assigned to C<"nomethod">, then an exception will be raised via die()-- unless C<"fallback"> was specified as a key in C<use overload> directive. -=head2 Fallback + +=head2 Fallback The key C<"fallback"> governs what to do if a method for a particular operation is not found. Three different cases are possible depending on @@ -492,7 +526,7 @@ present. =item * defined, but FALSE No autogeneration is tried. Perl tries to call -C<"nomethod"> value, and if this is missing, raises an exception. +C<"nomethod"> value, and if this is missing, raises an exception. =back @@ -510,7 +544,7 @@ This operation is called in the situations when a mutator is applied to a reference that shares its object with some other reference, such as - $a=$b; + $a=$b; ++$a; To make this change $a and not change $b, a copy of C<$$a> is made, @@ -521,7 +555,7 @@ done if C<++> is expressed via a method for C<'++'> or C<'+='> (or C<nomethod>). Note that if this operation is expressed via C<'+'> a nonmutator, i.e., as in - $a=$b; + $a=$b; $a=$a+1; then C<$a> does not reference a new copy of C<$$a>, since $$a does not @@ -535,15 +569,15 @@ string copy if the object is a plain scalar. =item B<Example> -The actually executed code for +The actually executed code for - $a=$b; + $a=$b; Something else which does not modify $a or $b.... ++$a; may be - $a=$b; + $a=$b; Something else which does not modify $a or $b.... $a = $a->clone(undef,""); $a->incr(undef,""); @@ -570,7 +604,7 @@ substitutions are possible for the following operations: C<$a+=$b> can use the method for C<"+"> if the method for C<"+="> is not defined. -=item I<Conversion operations> +=item I<Conversion operations> String, numeric, and boolean conversion are calculated in terms of one another if not all of them are defined. @@ -597,7 +631,7 @@ string or numerical conversion. can be expressed in terms of string conversion. -=item I<Comparison operations> +=item I<Comparison operations> can be expressed in terms of its "spaceship" counterpart: either C<E<lt>=E<gt>> or C<cmp>: @@ -705,20 +739,20 @@ to overload constant pieces of regular expressions. The corresponding values are references to functions which take three arguments: the first one is the I<initial> string form of the constant, the second one -is how Perl interprets this constant, the third one is how the constant is used. +is how Perl interprets this constant, the third one is how the constant is used. Note that the initial string form does not -contain string delimiters, and has backslashes in backslash-delimiter +contain string delimiters, and has backslashes in backslash-delimiter combinations stripped (thus the value of delimiter is not relevant for -processing of this string). The return value of this function is how this +processing of this string). The return value of this function is how this constant is going to be interpreted by Perl. The third argument is undefined unless for overloaded C<q>- and C<qr>- constants, it is C<q> in single-quote context (comes from strings, regular expressions, and single-quote HERE -documents), it is C<tr> for arguments of C<tr>/C<y> operators, +documents), it is C<tr> for arguments of C<tr>/C<y> operators, it is C<s> for right-hand side of C<s>-operator, and it is C<qq> otherwise. Since an expression C<"ab$cd,,"> is just a shortcut for C<'ab' . $cd . ',,'>, it is expected that overloaded constant strings are equipped with reasonable -overloaded catenation operator, otherwise absurd results will result. +overloaded catenation operator, otherwise absurd results will result. Similarly, negative numbers are considered as negations of positive constants. Note that it is probably meaningless to call the functions overload::constant() @@ -732,7 +766,7 @@ From these methods they may be called as overload::constant integer => sub {Math::BigInt->new(shift)}; } -B<BUGS> Currently overloaded-ness of constants does not propagate +B<BUGS> Currently overloaded-ness of constants does not propagate into C<eval '...'>. =head1 IMPLEMENTATION @@ -774,7 +808,7 @@ packages acquire a magic during the next C<bless>ing into the package. This magic is three-words-long for packages without overloading, and carries the cache table if the package is overloaded. -Copying (C<$a=$b>) is shallow; however, a one-level-deep copying is +Copying (C<$a=$b>) is shallow; however, a one-level-deep copying is carried out before any operation that can imply an assignment to the object $a (or $b) refers to, like C<$a++>. You can override this behavior by defining your own copy constructor (see L<"Copy Constructor">). @@ -785,8 +819,8 @@ to be changed are constant (but this is not enforced). =head1 Metaphor clash One may wonder why the semantic of overloaded C<=> is so counter intuitive. -If it I<looks> counter intuitive to you, you are subject to a metaphor -clash. +If it I<looks> counter intuitive to you, you are subject to a metaphor +clash. Here is a Perl object metaphor: @@ -805,10 +839,10 @@ that $a and $b are separate entities. The difference is not relevant in the absence of mutators. After a Perl-way assignment an operation which mutates the data referenced by $a -would change the data referenced by $b too. Effectively, after +would change the data referenced by $b too. Effectively, after C<$a = $b> values of $a and $b become I<indistinguishable>. -On the other hand, anyone who has used algebraic notation knows the +On the other hand, anyone who has used algebraic notation knows the expressive power of the arithmetic metaphor. Overloading works hard to enable this metaphor while preserving the Perlian way as far as possible. Since it is not not possible to freely mix two contradicting @@ -817,7 +851,7 @@ far as all the mutators are called via overloaded access only>. The way it is done is described in L<Copy Constructor>. If some mutator methods are directly applied to the overloaded values, -one may need to I<explicitly unlink> other values which references the +one may need to I<explicitly unlink> other values which references the same value: $a = new Data 23; @@ -841,7 +875,7 @@ However, it would not make preserve "objectness" of $a. But Perl I<has> a way to make assignments to an object do whatever you want. It is just not the overload, but tie()ing interface (see L<perlfunc/tie>). Adding a FETCH() method -which returns the object itself, and STORE() method which changes the +which returns the object itself, and STORE() method which changes the value of the object, one can reproduce the arithmetic metaphor in its completeness, at least for variables which were tie()d from the start. @@ -878,16 +912,15 @@ numeric value.) This prints: =head2 Two-face references Suppose you want to create an object which is accessible as both an -array reference, and a hash reference, similar to the builtin -L<array-accessible-as-a-hash|perlref/"Pseudo-hashes: Using an array as -a hash"> builtin Perl type. Let us make it better than the builtin -type, there will be no restriction that you cannot use the index 0 of -your array. +array reference and a hash reference, similar to the +L<pseudo-hash|perlref/"Pseudo-hashes: Using an array as a hash"> +builtin Perl type. Let's make it better than a pseudo-hash by +allowing index 0 to be treated as a normal element. package two_refs; use overload '%{}' => \&gethash, '@{}' => sub { $ {shift()} }; - sub new { - my $p = shift; + sub new { + my $p = shift; bless \ [@_], $p; } sub gethash { @@ -901,13 +934,13 @@ your array. my %fields; my $i = 0; $fields{$_} = $i++ foreach qw{zero one two three}; - sub STORE { + sub STORE { my $self = ${shift()}; my $key = $fields{shift()}; defined $key or die "Out of band access"; $$self->[$key] = shift; } - sub FETCH { + sub FETCH { my $self = ${shift()}; my $key = $fields{shift()}; defined $key or die "Out of band access"; @@ -934,26 +967,26 @@ would would lead to a memory leak. Both these problems can be cured. Say, if we want to overload hash dereference on a reference to an object which is I<implemented> as a hash itself, the only problem one has to circumvent is how to access -this I<actual> hash (as opposed to the I<virtual> exhibited by +this I<actual> hash (as opposed to the I<virtual> hash exhibited by the overloaded dereference operator). Here is one possible fetching routine: sub access_hash { my ($self, $key) = (shift, shift); my $class = ref $self; - bless $self, 'overload::dummy'; # Disable overloading of %{} + bless $self, 'overload::dummy'; # Disable overloading of %{} my $out = $self->{$key}; bless $self, $class; # Restore overloading $out; } -To move creation of the tied hash on each access, one may an extra +To remove creation of the tied hash on each access, one may an extra level of indirection which allows a non-circular structure of references: package two_refs1; use overload '%{}' => sub { ${shift()}->[1] }, '@{}' => sub { ${shift()}->[0] }; - sub new { - my $p = shift; + sub new { + my $p = shift; my $a = [@_]; my %h; tie %h, $p, $a; @@ -970,23 +1003,23 @@ level of indirection which allows a non-circular structure of references: my %fields; my $i = 0; $fields{$_} = $i++ foreach qw{zero one two three}; - sub STORE { + sub STORE { my $a = ${shift()}; my $key = $fields{shift()}; defined $key or die "Out of band access"; $a->[$key] = shift; } - sub FETCH { + sub FETCH { my $a = ${shift()}; my $key = $fields{shift()}; defined $key or die "Out of band access"; $a->[$key]; } -Now if $baz is overloaded like this, then C<$bar> is a reference to a +Now if $baz is overloaded like this, then C<$baz> is a reference to a reference to the intermediate array, which keeps a reference to an actual array, and the access hash. The tie()ing object for the access -hash is also a reference to a reference to the actual array, so +hash is a reference to a reference to the actual array, so =over @@ -1061,7 +1094,7 @@ Add a pretty-printer method to the module F<symbolic.pm>: $a = $a->pretty if ref $a; $b = $b->pretty if ref $b; "[$meth $a $b]"; - } + } Now one can finish the script by @@ -1073,7 +1106,7 @@ inside such a method it is not necessary to pretty-print the I<components> $a and $b of an object. In the above subroutine C<"[$meth $a $b]"> is a catenation of some strings and components $a and $b. If these components use overloading, the catenation operator -will look for an overloaded operator C<.>, if not present, it will +will look for an overloaded operator C<.>; if not present, it will look for an overloaded operator C<"">. Thus it is enough to use use overload nomethod => \&wrap, '""' => \&str; @@ -1082,7 +1115,7 @@ look for an overloaded operator C<"">. Thus it is enough to use $a = 'u' unless defined $a; $b = 'u' unless defined $b; "[$meth $a $b]"; - } + } Now one can change the last line of the script to @@ -1093,7 +1126,7 @@ which outputs side = [/ [- [sqrt [+ 1 [** [n 1 u] 2]] u] 1] [n 1 u]] and one can inspect the value in debugger using all the possible -methods. +methods. Something is is still amiss: consider the loop variable $cnt of the script. It was a number, not an object. We cannot make this value of @@ -1127,9 +1160,9 @@ slightly modified str()): } else { "[$meth $a]"; } - } - my %subr = ( n => sub {$_[0]}, - sqrt => sub {sqrt $_[0]}, + } + my %subr = ( n => sub {$_[0]}, + sqrt => sub {sqrt $_[0]}, '-' => sub {shift() - shift()}, '+' => sub {shift() + shift()}, '/' => sub {shift() / shift()}, @@ -1138,7 +1171,7 @@ slightly modified str()): ); sub num { my ($meth, $a, $b) = @{+shift}; - my $subr = $subr{$meth} + my $subr = $subr{$meth} or die "Do not know how to ($meth) in symbolic"; $a = $a->num if ref $a eq __PACKAGE__; $b = $b->num if ref $b eq __PACKAGE__; @@ -1176,7 +1209,7 @@ mutator methods (C<++>, C<-=> and so on), does not do deep copying (not required without mutators!), and implements only those arithmetic operations which are used in the example. -To implement most arithmetic operations is easy, one should just use +To implement most arithmetic operations is easy; one should just use the tables of operations, and change the code which fills %subr to my %subr = ( 'n' => sub {$_[0]} ); @@ -1198,7 +1231,7 @@ special to make C<+=> and friends work, except filling C<+=> entry of way to know that the implementation of C<'+='> does not mutate the argument, compare L<Copy Constructor>). -To implement a copy constructor, add C<'=' => \&cpy> to C<use overload> +To implement a copy constructor, add C<< '=' => \&cpy >> to C<use overload> line, and code (this code assumes that mutators change things one level deep only, so recursive copying is not needed): @@ -1207,7 +1240,7 @@ deep only, so recursive copying is not needed): bless [@$self], ref $self; } -To make C<++> and C<--> work, we need to implement actual mutators, +To make C<++> and C<--> work, we need to implement actual mutators, either directly, or in C<nomethod>. We continue to do things inside C<nomethod>, thus add @@ -1216,7 +1249,7 @@ C<nomethod>, thus add return $obj; } -after the first line of wrap(). This is not a most effective +after the first line of wrap(). This is not a most effective implementation, one may consider sub inc { $_[0] = bless ['++', shift, 1]; } @@ -1239,8 +1272,8 @@ As a final remark, note that one can fill %subr by $subr{'++'} = $subr{'+'}; $subr{'--'} = $subr{'-'}; -This finishes implementation of a primitive symbolic calculator in -50 lines of Perl code. Since the numeric values of subexpressions +This finishes implementation of a primitive symbolic calculator in +50 lines of Perl code. Since the numeric values of subexpressions are not cached, the calculator is very slow. Here is the answer for the exercise: In the case of str(), we need no @@ -1266,9 +1299,9 @@ until the value is I<used>. To see it in action, add a method - sub STORE { - my $obj = shift; - $#$obj = 1; + sub STORE { + my $obj = shift; + $#$obj = 1; @$obj->[0,1] = ('=', shift); } @@ -1337,6 +1370,27 @@ key (in fact a presence of this method shows that this package has overloading enabled, and it is what is used by the C<Overloaded> function of module C<overload>). +The module might issue the following warnings: + +=over 4 + +=item Odd number of arguments for overload::constant + +(W) The call to overload::constant contained an odd number of arguments. +The arguments should come in pairs. + +=item `%s' is not an overloadable type + +(W) You tried to overload a constant type the overload package is unaware of. + +=item `%s' is not a code reference + +(W) The second (fourth, sixth, ...) argument of overload::constant needs +to be a code reference. Either an anonymous subroutine, or a reference +to a subroutine. + +=back + =head1 BUGS Because it is used for overloading, the per-package hash %OVERLOAD now @@ -1348,12 +1402,12 @@ C<fallback> is present (possibly undefined). This may create interesting effects if some package is not overloaded, but inherits from two overloaded packages. -Relation between overloading and tie()ing is broken. Overloading is +Relation between overloading and tie()ing is broken. Overloading is triggered or not basing on the I<previous> class of tie()d value. -This happens because the presence of overloading is checked too early, +This happens because the presence of overloading is checked too early, before any tie()d access is attempted. If the FETCH()ed class of the -tie()d value does not change, a simple workaround is to access the value +tie()d value does not change, a simple workaround is to access the value immediately after tie()ing, so that after this call the I<previous> class coincides with the current one. diff --git a/contrib/perl5/lib/perl5db.pl b/contrib/perl5/lib/perl5db.pl index 132e08e0bd9d..63b4381339ce 100644 --- a/contrib/perl5/lib/perl5db.pl +++ b/contrib/perl5/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 @@ -34,7 +34,7 @@ $header = "perl5db.pl version $VERSION"; # interpreter, though the values used by perl5db.pl have the form # "$break_condition\0$action". Values are magical in numeric context. # -# The scalar ${'_<'.$filename} contains "_<$filename". +# The scalar ${'_<'.$filename} contains $filename. # # Note that no subroutine call is possible until &DB::sub is defined # (for subroutines defined outside of the package DB). In fact the same 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"; } @@ -426,7 +432,7 @@ if ($notty) { PeerAddr => $remoteport, Proto => 'tcp', ); - if (!$OUT) { die "Could not create socket to connect to remote host."; } + if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; } $IN = $OUT; } else { @@ -617,7 +623,7 @@ EOP next CMD; } } - $cmd =~ /^q$/ && ($exiting = 1) && exit 0; + $cmd =~ /^q$/ && ($fall_off_end = 1) && exit $?; $cmd =~ /^h$/ && do { print_help($help); next CMD; }; @@ -899,9 +905,9 @@ EOP print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n"; next CMD; }; $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do { - my $cond = $3 || '1'; + my $cond = length $3 ? $3 : '1'; my ($subname, $break) = ($2, $1 eq 'postpone'); - $subname =~ s/\'/::/; + $subname =~ s/\'/::/g; $subname = "${'package'}::" . $subname unless $subname =~ /::/; $subname = "main".$subname if substr($subname,0,2) eq "::"; @@ -910,8 +916,8 @@ EOP next CMD; }; $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do { $subname = $1; - $cond = $2 || '1'; - $subname =~ s/\'/::/; + $cond = length $2 ? $2 : '1'; + $subname =~ s/\'/::/g; $subname = "${'package'}::" . $subname unless $subname =~ /::/; $subname = "main".$subname if substr($subname,0,2) eq "::"; @@ -931,7 +937,7 @@ EOP next CMD; }; $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do { $i = $1 || $line; - $cond = $2 || '1'; + $cond = length $2 ? $2 : '1'; if ($dbline[$i] == 0) { print $OUT "Line $i not breakable.\n"; } else { @@ -941,8 +947,12 @@ EOP next CMD; }; $cmd =~ /^d\b\s*(\d*)/ && do { $i = $1 || $line; - $dbline{$i} =~ s/^[^\0]*//; - delete $dbline{$i} if $dbline{$i} eq ''; + if ($dbline[$i] == 0) { + print $OUT "Line $i not breakable.\n"; + } else { + $dbline{$i} =~ s/^[^\0]*//; + delete $dbline{$i} if $dbline{$i} eq ''; + } next CMD; }; $cmd =~ /^A$/ && do { print $OUT "Deleting all actions...\n"; @@ -980,18 +990,18 @@ EOP next CMD; }; $cmd =~ /^<\s*(.*)/ && do { unless ($1) { - print OUT "All < actions cleared.\n"; + print $OUT "All < actions cleared.\n"; $pre = []; next CMD; } if ($1 eq '?') { unless (@$pre) { - print OUT "No pre-prompt Perl actions.\n"; + print $OUT "No pre-prompt Perl actions.\n"; next CMD; } - print OUT "Perl commands run before each prompt:\n"; + print $OUT "Perl commands run before each prompt:\n"; for my $action ( @$pre ) { - print "\t< -- $action\n"; + print $OUT "\t< -- $action\n"; } next CMD; } @@ -999,18 +1009,18 @@ EOP next CMD; }; $cmd =~ /^>\s*(.*)/ && do { unless ($1) { - print OUT "All > actions cleared.\n"; + print $OUT "All > actions cleared.\n"; $post = []; next CMD; } if ($1 eq '?') { unless (@$post) { - print OUT "No post-prompt Perl actions.\n"; + print $OUT "No post-prompt Perl actions.\n"; next CMD; } - print OUT "Perl commands run after each prompt:\n"; + print $OUT "Perl commands run after each prompt:\n"; for my $action ( @$post ) { - print "\t> -- $action\n"; + print $OUT "\t> -- $action\n"; } next CMD; } @@ -1018,7 +1028,7 @@ EOP next CMD; }; $cmd =~ /^\{\{\s*(.*)/ && do { if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) { - print OUT "{{ is now a debugger command\n", + print $OUT "{{ is now a debugger command\n", "use `;{{' if you mean Perl code\n"; $cmd = "h {{"; redo CMD; @@ -1027,23 +1037,23 @@ EOP next CMD; }; $cmd =~ /^\{\s*(.*)/ && do { unless ($1) { - print OUT "All { actions cleared.\n"; + print $OUT "All { actions cleared.\n"; $pretype = []; next CMD; } if ($1 eq '?') { unless (@$pretype) { - print OUT "No pre-prompt debugger actions.\n"; + print $OUT "No pre-prompt debugger actions.\n"; next CMD; } - print OUT "Debugger commands run before each prompt:\n"; + print $OUT "Debugger commands run before each prompt:\n"; for my $action ( @$pretype ) { - print "\t{ -- $action\n"; + print $OUT "\t{ -- $action\n"; } next CMD; } if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) { - print OUT "{ is now a debugger command\n", + print $OUT "{ is now a debugger command\n", "use `;{' if you mean Perl code\n"; $cmd = "h {"; redo CMD; @@ -1426,7 +1436,7 @@ EOP $piped= ""; } } # CMD: - $exiting = 1 unless defined $cmd; + $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF foreach $evalarg (@$post) { &eval; } @@ -1507,6 +1517,7 @@ sub eval { local $otrace = $trace; local $osingle = $single; local $od = $^D; + { ($evalarg) = $evalarg =~ /(.*)/s; } @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug $trace = $otrace; $single = $osingle; @@ -1698,8 +1709,6 @@ sub unbalanced { } sub gets { - local($.); - #<IN>; &readline("cont: "); } @@ -1804,6 +1813,7 @@ EOP } sub readline { + local $.; if (@typeahead) { my $left = @typeahead; my $got = shift @typeahead; @@ -1815,7 +1825,7 @@ sub readline { local $frame = 0; local $doret = -2; if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) { - print $OUT @_; + $OUT->write(join('', @_)); my $stuff; $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread? $stuff; @@ -2161,8 +2171,8 @@ B<W> Delete all watch-expressions. B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current). Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps. B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\". -B<x> I<expr> Evals expression in array context, dumps the result. -B<m> I<expr> Evals expression in array context, prints methods callable +B<x> I<expr> Evals expression in list context, dumps the result. +B<m> I<expr> Evals expression in list context, prints methods callable on the first element of the result. B<m> I<class> Prints methods callable via the given class. @@ -2257,7 +2267,7 @@ I<Debugger controls:> B<L> List break/watch/act B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess B<q> or B<^D> Quit B<R> Attempt a restart I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr> - B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods. + B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods. B<p> I<expr> Print expression (uses script's current package). B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern. @@ -2680,10 +2690,11 @@ sub end_report { } END { - $finished = $inhibit_exit; # So that some keys may be disabled. + $finished = 1 if $inhibit_exit; # So that some keys may be disabled. + $fall_off_end = 1 unless $inhibit_exit; # Do not stop in at_exit() and destructors on exit: - $DB::single = !$exiting && !$runnonstop; - DB::fake::at_exit() unless $exiting or $runnonstop; + $DB::single = !$fall_off_end && !$runnonstop; + DB::fake::at_exit() unless $fall_off_end or $runnonstop; } package DB::fake; diff --git a/contrib/perl5/lib/strict.pm b/contrib/perl5/lib/strict.pm index 042227f967a0..8afb9a37921c 100644 --- a/contrib/perl5/lib/strict.pm +++ b/contrib/perl5/lib/strict.pm @@ -37,6 +37,14 @@ use symbolic references (see L<perlref>). $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<goto &$AUTOLOAD> would not break under stricture. + + =item C<strict vars> This generates a compile-time error if you access a variable that wasn't diff --git a/contrib/perl5/lib/syslog.pl b/contrib/perl5/lib/syslog.pl index 70c439b9aeab..f0dbb1c96a20 100644 --- a/contrib/perl5/lib/syslog.pl +++ b/contrib/perl5/lib/syslog.pl @@ -34,7 +34,7 @@ use warnings::register; $host = 'localhost' unless $host; # set $syslog'host to change if ($] >= 5 && warnings::enabled()) { - warnings::warn "You should 'use Sys::Syslog' instead; continuing"; + warnings::warn("You should 'use Sys::Syslog' instead; continuing"); } require 'syslog.ph'; diff --git a/contrib/perl5/lib/termcap.pl b/contrib/perl5/lib/termcap.pl index 06da956666c9..f295a2d476b5 100644 --- a/contrib/perl5/lib/termcap.pl +++ b/contrib/perl5/lib/termcap.pl @@ -22,7 +22,7 @@ sub Tgetent { local($TERM) = @_; local($TERMCAP,$_,$entry,$loop,$field); - warn "Tgetent: no ospeed set" unless $ospeed; + # warn "Tgetent: no ospeed set" unless $ospeed; foreach $key (keys %TC) { delete $TC{$key}; } diff --git a/contrib/perl5/lib/unicode/ArabLink.pl b/contrib/perl5/lib/unicode/ArabLink.pl index fd5ed8a6b1db..2ad1871bac3b 100644 --- a/contrib/perl5/lib/unicode/ArabLink.pl +++ b/contrib/perl5/lib/unicode/ArabLink.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0622 0625 R @@ -12,10 +12,9 @@ return <<'END'; 0633 063a D 0640 C 0641 0647 D -0648 0649 R -064a D -0671 U -0672 0673 R +0648 R +0649 064a D +0671 0673 R 0674 U 0675 0677 R 0678 0687 D diff --git a/contrib/perl5/lib/unicode/ArabLnkGrp.pl b/contrib/perl5/lib/unicode/ArabLnkGrp.pl index 61f30d4348f7..1581a048973e 100644 --- a/contrib/perl5/lib/unicode/ArabLnkGrp.pl +++ b/contrib/perl5/lib/unicode/ArabLnkGrp.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0622 0623 ALEF @@ -27,8 +27,7 @@ return <<'END'; 0647 HEH 0648 WAW 0649 064a YEH -0671 <no shaping> -0672 0673 ALEF +0671 0673 ALEF 0674 <no shaping> 0675 ALEF 0676 0677 WAW diff --git a/contrib/perl5/lib/unicode/ArabShap.txt b/contrib/perl5/lib/unicode/ArabShap.txt index 6092d6223cd3..9b60290e62e3 100644 --- a/contrib/perl5/lib/unicode/ArabShap.txt +++ b/contrib/perl5/lib/unicode/ArabShap.txt @@ -1,5 +1,32 @@ -# Unicode; Schematic Name; Link; Link Group +# ArabicShaping-3.txt +# +# This file is a normative contributory data file in the +# Unicode Character Database. +# +# This file defines the shaping classes for Arabic and Syriac +# positional shaping, repeating in machine readable form the +# information printed in Tables 8-6, 8-7, 8-8, 8-10, 8-11, and +# 8-13 of The Unicode Standard, Version 3.0. +# +# See sections 8.2 and 8.3 of The Unicode Standard, Version 3.0 +# for more information. +# +# Each line contains four fields, separated by a semicolon. +# +# The first field gives the code point, in 4-digit hexadecimal +# form, of an Arabic or Syriac character. +# The second field gives a short schematic name for that character, +# abbreviated from the normative Unicode character name. +# The third field defines the joining type: R right-joining, +# D dual-joining, U non-joining +# The fourth field defines the joining group. +# +# ############################################################# + +# Unicode; Schematic Name; Joining Type; Joining Group + # Arabic characters + 0622; MADDA ON ALEF; R; ALEF 0623; HAMZA ON ALEF; R; ALEF 0624; HAMZA ON WAW; R; WAW @@ -34,9 +61,9 @@ 0646; NOON; D; NOON 0647; HEH; D; HEH 0648; WAW; R; WAW -0649; ALEF MAKSURA; R; YEH +0649; ALEF MAKSURA; D; YEH 064A; YEH; D; YEH -0671; HAMZAT WASL ON ALEF; U; <no shaping> +0671; HAMZAT WASL ON ALEF; R; ALEF 0672; WAVY HAMZA ON ALEF; R; ALEF 0673; WAVY HAMZA UNDER ALEF; R; ALEF 0674; HIGH HAMZA; U; <no shaping> @@ -139,7 +166,9 @@ 06FA; SEEN WITH DOT BELOW AND 3 DOTS ABOVE; D; SEEN 06FB; DAD WITH DOT BELOW; D; SAD 06FC; GHAIN WITH DOT BELOW; D; AIN + # Syriac characters + 0710; ALAPH; R; ALAPH 0712; BETH; D; BETH 0713; GAMAL; D; GAMAL diff --git a/contrib/perl5/lib/unicode/Bidirectional.pl b/contrib/perl5/lib/unicode/Bidirectional.pl index 73898b8399c2..3cc2d0aafd51 100644 --- a/contrib/perl5/lib/unicode/Bidirectional.pl +++ b/contrib/perl5/lib/unicode/Bidirectional.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0000 0008 BN @@ -635,4 +635,6 @@ ffe5 ffe6 ET ffe8 ffee ON fff9 fffb BN fffc fffd ON +f0000 ffffd L +100000 10fffd L END diff --git a/contrib/perl5/lib/unicode/Block.pl b/contrib/perl5/lib/unicode/Block.pl index ee680b724d4b..2b5bfce3e14c 100644 --- a/contrib/perl5/lib/unicode/Block.pl +++ b/contrib/perl5/lib/unicode/Block.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0000 007F Basic Latin diff --git a/contrib/perl5/lib/unicode/Category.pl b/contrib/perl5/lib/unicode/Category.pl index bffd1169bef9..9c81514c58a0 100644 --- a/contrib/perl5/lib/unicode/Category.pl +++ b/contrib/perl5/lib/unicode/Category.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0000 001f Cc @@ -1503,4 +1503,6 @@ ffe9 ffec Sm ffed ffee So fff9 fffb Cf fffc fffd So +f0000 ffffd Co +100000 10fffd Co END diff --git a/contrib/perl5/lib/unicode/CombiningClass.pl b/contrib/perl5/lib/unicode/CombiningClass.pl index a40949830c33..628b9c63db27 100644 --- a/contrib/perl5/lib/unicode/CombiningClass.pl +++ b/contrib/perl5/lib/unicode/CombiningClass.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0300 0314 230 diff --git a/contrib/perl5/lib/unicode/CompExcl.txt b/contrib/perl5/lib/unicode/CompExcl.txt index 5ea46afc6398..53f846729d56 100644 --- a/contrib/perl5/lib/unicode/CompExcl.txt +++ b/contrib/perl5/lib/unicode/CompExcl.txt @@ -1,3 +1,5 @@ +# CompositionExclusions-2.txt +# # Composition Exclusions # This file lists the characters from the UTR #15 Composition Exclusion Table. # @@ -133,8 +135,8 @@ FB4E # HEBREW LETTER PE WITH RAFE # (4) Non-Starter Decompositions # These characters can be derived from the UnicodeData file # by including all characters whose canonical decomposition consists -# of a sequence of characters, the first of which has a canonical -# class of zero. +# of a sequence of characters, the first of which has a non-zero +# combining class. # These characters are simply quoted here for reference. # 0344 COMBINING GREEK DIALYTIKA TONOS diff --git a/contrib/perl5/lib/unicode/Decomposition.pl b/contrib/perl5/lib/unicode/Decomposition.pl index ecc30b205e3e..1fe29cd1577f 100644 --- a/contrib/perl5/lib/unicode/Decomposition.pl +++ b/contrib/perl5/lib/unicode/Decomposition.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 00a0 <noBreak> 0020 diff --git a/contrib/perl5/lib/unicode/In/AlphabeticPresentationForms.pl b/contrib/perl5/lib/unicode/In/AlphabeticPresentationForms.pl index c42e944a3c53..a85b9cabecae 100644 --- a/contrib/perl5/lib/unicode/In/AlphabeticPresentationForms.pl +++ b/contrib/perl5/lib/unicode/In/AlphabeticPresentationForms.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; FB00 FB4F diff --git a/contrib/perl5/lib/unicode/In/Arabic.pl b/contrib/perl5/lib/unicode/In/Arabic.pl index 5010ab73de6d..5fbbbfa028e3 100644 --- a/contrib/perl5/lib/unicode/In/Arabic.pl +++ b/contrib/perl5/lib/unicode/In/Arabic.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0600 06FF diff --git a/contrib/perl5/lib/unicode/In/ArabicPresentationForms-A.pl b/contrib/perl5/lib/unicode/In/ArabicPresentationForms-A.pl index 6edd74d755b1..62521bb1b1ba 100644 --- a/contrib/perl5/lib/unicode/In/ArabicPresentationForms-A.pl +++ b/contrib/perl5/lib/unicode/In/ArabicPresentationForms-A.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; FB50 FDFF diff --git a/contrib/perl5/lib/unicode/In/ArabicPresentationForms-B.pl b/contrib/perl5/lib/unicode/In/ArabicPresentationForms-B.pl index 964073931ed5..6b2d44742b12 100644 --- a/contrib/perl5/lib/unicode/In/ArabicPresentationForms-B.pl +++ b/contrib/perl5/lib/unicode/In/ArabicPresentationForms-B.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; FE70 FEFE diff --git a/contrib/perl5/lib/unicode/In/Armenian.pl b/contrib/perl5/lib/unicode/In/Armenian.pl index 19b74acd71a9..d4736a75064c 100644 --- a/contrib/perl5/lib/unicode/In/Armenian.pl +++ b/contrib/perl5/lib/unicode/In/Armenian.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0530 058F diff --git a/contrib/perl5/lib/unicode/In/Arrows.pl b/contrib/perl5/lib/unicode/In/Arrows.pl index 7ce44183a166..a7ef468593cf 100644 --- a/contrib/perl5/lib/unicode/In/Arrows.pl +++ b/contrib/perl5/lib/unicode/In/Arrows.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2190 21FF diff --git a/contrib/perl5/lib/unicode/In/BasicLatin.pl b/contrib/perl5/lib/unicode/In/BasicLatin.pl index 39987f16ec19..36d6456fa613 100644 --- a/contrib/perl5/lib/unicode/In/BasicLatin.pl +++ b/contrib/perl5/lib/unicode/In/BasicLatin.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0000 007F diff --git a/contrib/perl5/lib/unicode/In/Bengali.pl b/contrib/perl5/lib/unicode/In/Bengali.pl index c0a47d30d1a3..07dc6ac102ca 100644 --- a/contrib/perl5/lib/unicode/In/Bengali.pl +++ b/contrib/perl5/lib/unicode/In/Bengali.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0980 09FF diff --git a/contrib/perl5/lib/unicode/In/BlockElements.pl b/contrib/perl5/lib/unicode/In/BlockElements.pl index e96e64faa039..495629b9382b 100644 --- a/contrib/perl5/lib/unicode/In/BlockElements.pl +++ b/contrib/perl5/lib/unicode/In/BlockElements.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2580 259F diff --git a/contrib/perl5/lib/unicode/In/Bopomofo.pl b/contrib/perl5/lib/unicode/In/Bopomofo.pl index 553560670c26..3dbf73a2368c 100644 --- a/contrib/perl5/lib/unicode/In/Bopomofo.pl +++ b/contrib/perl5/lib/unicode/In/Bopomofo.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 3100 312F diff --git a/contrib/perl5/lib/unicode/In/BopomofoExtended.pl b/contrib/perl5/lib/unicode/In/BopomofoExtended.pl index d0ee43a43737..f2ca6de96da9 100644 --- a/contrib/perl5/lib/unicode/In/BopomofoExtended.pl +++ b/contrib/perl5/lib/unicode/In/BopomofoExtended.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 31A0 31BF diff --git a/contrib/perl5/lib/unicode/In/BoxDrawing.pl b/contrib/perl5/lib/unicode/In/BoxDrawing.pl index d580199b7fff..a3cd897498af 100644 --- a/contrib/perl5/lib/unicode/In/BoxDrawing.pl +++ b/contrib/perl5/lib/unicode/In/BoxDrawing.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2500 257F diff --git a/contrib/perl5/lib/unicode/In/BraillePatterns.pl b/contrib/perl5/lib/unicode/In/BraillePatterns.pl index e5c9e4ca7014..58afc05a2010 100644 --- a/contrib/perl5/lib/unicode/In/BraillePatterns.pl +++ b/contrib/perl5/lib/unicode/In/BraillePatterns.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2800 28FF diff --git a/contrib/perl5/lib/unicode/In/CJKCompatibility.pl b/contrib/perl5/lib/unicode/In/CJKCompatibility.pl index 07ab8edfd49a..793520f4eb3d 100644 --- a/contrib/perl5/lib/unicode/In/CJKCompatibility.pl +++ b/contrib/perl5/lib/unicode/In/CJKCompatibility.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 3300 33FF diff --git a/contrib/perl5/lib/unicode/In/CJKCompatibilityForms.pl b/contrib/perl5/lib/unicode/In/CJKCompatibilityForms.pl index 122ccd7ad603..a9ba270122ba 100644 --- a/contrib/perl5/lib/unicode/In/CJKCompatibilityForms.pl +++ b/contrib/perl5/lib/unicode/In/CJKCompatibilityForms.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; FE30 FE4F diff --git a/contrib/perl5/lib/unicode/In/CJKCompatibilityIdeographs.pl b/contrib/perl5/lib/unicode/In/CJKCompatibilityIdeographs.pl index 59c8e5dd5b2e..d841bc548262 100644 --- a/contrib/perl5/lib/unicode/In/CJKCompatibilityIdeographs.pl +++ b/contrib/perl5/lib/unicode/In/CJKCompatibilityIdeographs.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; F900 FAFF diff --git a/contrib/perl5/lib/unicode/In/CJKRadicalsSupplement.pl b/contrib/perl5/lib/unicode/In/CJKRadicalsSupplement.pl index d4c0c82bb640..2d1370799a05 100644 --- a/contrib/perl5/lib/unicode/In/CJKRadicalsSupplement.pl +++ b/contrib/perl5/lib/unicode/In/CJKRadicalsSupplement.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2E80 2EFF diff --git a/contrib/perl5/lib/unicode/In/CJKSymbolsandPunctuation.pl b/contrib/perl5/lib/unicode/In/CJKSymbolsandPunctuation.pl index 24ecc37b67fa..ca525ae3838f 100644 --- a/contrib/perl5/lib/unicode/In/CJKSymbolsandPunctuation.pl +++ b/contrib/perl5/lib/unicode/In/CJKSymbolsandPunctuation.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 3000 303F diff --git a/contrib/perl5/lib/unicode/In/CJKUnifiedIdeographs.pl b/contrib/perl5/lib/unicode/In/CJKUnifiedIdeographs.pl index 351cf74a82c0..729f4c631504 100644 --- a/contrib/perl5/lib/unicode/In/CJKUnifiedIdeographs.pl +++ b/contrib/perl5/lib/unicode/In/CJKUnifiedIdeographs.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 4E00 9FFF diff --git a/contrib/perl5/lib/unicode/In/CJKUnifiedIdeographsExtensionA.pl b/contrib/perl5/lib/unicode/In/CJKUnifiedIdeographsExtensionA.pl index 012f54c82451..e92f091938b7 100644 --- a/contrib/perl5/lib/unicode/In/CJKUnifiedIdeographsExtensionA.pl +++ b/contrib/perl5/lib/unicode/In/CJKUnifiedIdeographsExtensionA.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 3400 4DB5 diff --git a/contrib/perl5/lib/unicode/In/Cherokee.pl b/contrib/perl5/lib/unicode/In/Cherokee.pl index 10cae1a652a6..1e9ad746d3bc 100644 --- a/contrib/perl5/lib/unicode/In/Cherokee.pl +++ b/contrib/perl5/lib/unicode/In/Cherokee.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 13A0 13FF diff --git a/contrib/perl5/lib/unicode/In/CombiningDiacriticalMarks.pl b/contrib/perl5/lib/unicode/In/CombiningDiacriticalMarks.pl index a32f974bfb1d..d3a45d4cd032 100644 --- a/contrib/perl5/lib/unicode/In/CombiningDiacriticalMarks.pl +++ b/contrib/perl5/lib/unicode/In/CombiningDiacriticalMarks.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0300 036F diff --git a/contrib/perl5/lib/unicode/In/CombiningHalfMarks.pl b/contrib/perl5/lib/unicode/In/CombiningHalfMarks.pl index 100471bdbb77..4f0a5731a75c 100644 --- a/contrib/perl5/lib/unicode/In/CombiningHalfMarks.pl +++ b/contrib/perl5/lib/unicode/In/CombiningHalfMarks.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; FE20 FE2F diff --git a/contrib/perl5/lib/unicode/In/CombiningMarksforSymbols.pl b/contrib/perl5/lib/unicode/In/CombiningMarksforSymbols.pl index f45e7e049098..9dde706cc3c4 100644 --- a/contrib/perl5/lib/unicode/In/CombiningMarksforSymbols.pl +++ b/contrib/perl5/lib/unicode/In/CombiningMarksforSymbols.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 20D0 20FF diff --git a/contrib/perl5/lib/unicode/In/ControlPictures.pl b/contrib/perl5/lib/unicode/In/ControlPictures.pl index 77a759f1a0b9..78113e8c55ba 100644 --- a/contrib/perl5/lib/unicode/In/ControlPictures.pl +++ b/contrib/perl5/lib/unicode/In/ControlPictures.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2400 243F diff --git a/contrib/perl5/lib/unicode/In/CurrencySymbols.pl b/contrib/perl5/lib/unicode/In/CurrencySymbols.pl index 567ae97da382..8cbc1600e956 100644 --- a/contrib/perl5/lib/unicode/In/CurrencySymbols.pl +++ b/contrib/perl5/lib/unicode/In/CurrencySymbols.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 20A0 20CF diff --git a/contrib/perl5/lib/unicode/In/Cyrillic.pl b/contrib/perl5/lib/unicode/In/Cyrillic.pl index 9ca104c7db7f..f057731818d8 100644 --- a/contrib/perl5/lib/unicode/In/Cyrillic.pl +++ b/contrib/perl5/lib/unicode/In/Cyrillic.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0400 04FF diff --git a/contrib/perl5/lib/unicode/In/Devanagari.pl b/contrib/perl5/lib/unicode/In/Devanagari.pl index 61372b58abe9..c99eff18ecd3 100644 --- a/contrib/perl5/lib/unicode/In/Devanagari.pl +++ b/contrib/perl5/lib/unicode/In/Devanagari.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0900 097F diff --git a/contrib/perl5/lib/unicode/In/Dingbats.pl b/contrib/perl5/lib/unicode/In/Dingbats.pl index 0f820ca711cc..1bbb102999c5 100644 --- a/contrib/perl5/lib/unicode/In/Dingbats.pl +++ b/contrib/perl5/lib/unicode/In/Dingbats.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2700 27BF diff --git a/contrib/perl5/lib/unicode/In/EnclosedAlphanumerics.pl b/contrib/perl5/lib/unicode/In/EnclosedAlphanumerics.pl index de52aa8d9927..46b4cf5589bd 100644 --- a/contrib/perl5/lib/unicode/In/EnclosedAlphanumerics.pl +++ b/contrib/perl5/lib/unicode/In/EnclosedAlphanumerics.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2460 24FF diff --git a/contrib/perl5/lib/unicode/In/EnclosedCJKLettersandMonths.pl b/contrib/perl5/lib/unicode/In/EnclosedCJKLettersandMonths.pl index e4de0e0261dc..da5a7a1ecb94 100644 --- a/contrib/perl5/lib/unicode/In/EnclosedCJKLettersandMonths.pl +++ b/contrib/perl5/lib/unicode/In/EnclosedCJKLettersandMonths.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 3200 32FF diff --git a/contrib/perl5/lib/unicode/In/Ethiopic.pl b/contrib/perl5/lib/unicode/In/Ethiopic.pl index 13c309050a3d..5b472c47c5c0 100644 --- a/contrib/perl5/lib/unicode/In/Ethiopic.pl +++ b/contrib/perl5/lib/unicode/In/Ethiopic.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 1200 137F diff --git a/contrib/perl5/lib/unicode/In/GeneralPunctuation.pl b/contrib/perl5/lib/unicode/In/GeneralPunctuation.pl index 81c76992dc71..aa82c30bd70b 100644 --- a/contrib/perl5/lib/unicode/In/GeneralPunctuation.pl +++ b/contrib/perl5/lib/unicode/In/GeneralPunctuation.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2000 206F diff --git a/contrib/perl5/lib/unicode/In/GeometricShapes.pl b/contrib/perl5/lib/unicode/In/GeometricShapes.pl index 170422d2d09d..6cf8ea72f7d4 100644 --- a/contrib/perl5/lib/unicode/In/GeometricShapes.pl +++ b/contrib/perl5/lib/unicode/In/GeometricShapes.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 25A0 25FF diff --git a/contrib/perl5/lib/unicode/In/Georgian.pl b/contrib/perl5/lib/unicode/In/Georgian.pl index 773ed1562a8a..493f57053e5f 100644 --- a/contrib/perl5/lib/unicode/In/Georgian.pl +++ b/contrib/perl5/lib/unicode/In/Georgian.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 10A0 10FF diff --git a/contrib/perl5/lib/unicode/In/Greek.pl b/contrib/perl5/lib/unicode/In/Greek.pl index ff753d19b4ec..ac4bbee588d4 100644 --- a/contrib/perl5/lib/unicode/In/Greek.pl +++ b/contrib/perl5/lib/unicode/In/Greek.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0370 03FF diff --git a/contrib/perl5/lib/unicode/In/GreekExtended.pl b/contrib/perl5/lib/unicode/In/GreekExtended.pl index b8f02e7f0a2f..acd43be8140c 100644 --- a/contrib/perl5/lib/unicode/In/GreekExtended.pl +++ b/contrib/perl5/lib/unicode/In/GreekExtended.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 1F00 1FFF diff --git a/contrib/perl5/lib/unicode/In/Gujarati.pl b/contrib/perl5/lib/unicode/In/Gujarati.pl index ff6c6503bb32..0e3c8e98ce51 100644 --- a/contrib/perl5/lib/unicode/In/Gujarati.pl +++ b/contrib/perl5/lib/unicode/In/Gujarati.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0A80 0AFF diff --git a/contrib/perl5/lib/unicode/In/Gurmukhi.pl b/contrib/perl5/lib/unicode/In/Gurmukhi.pl index b888df694161..32ff23943b1b 100644 --- a/contrib/perl5/lib/unicode/In/Gurmukhi.pl +++ b/contrib/perl5/lib/unicode/In/Gurmukhi.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0A00 0A7F diff --git a/contrib/perl5/lib/unicode/In/HalfwidthandFullwidthForms.pl b/contrib/perl5/lib/unicode/In/HalfwidthandFullwidthForms.pl index e45265393f1c..fd3ba327f63b 100644 --- a/contrib/perl5/lib/unicode/In/HalfwidthandFullwidthForms.pl +++ b/contrib/perl5/lib/unicode/In/HalfwidthandFullwidthForms.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; FF00 FFEF diff --git a/contrib/perl5/lib/unicode/In/HangulCompatibilityJamo.pl b/contrib/perl5/lib/unicode/In/HangulCompatibilityJamo.pl index c15379fafca1..744e57270ff8 100644 --- a/contrib/perl5/lib/unicode/In/HangulCompatibilityJamo.pl +++ b/contrib/perl5/lib/unicode/In/HangulCompatibilityJamo.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 3130 318F diff --git a/contrib/perl5/lib/unicode/In/HangulJamo.pl b/contrib/perl5/lib/unicode/In/HangulJamo.pl index c329b54c34e5..a1d1c6770898 100644 --- a/contrib/perl5/lib/unicode/In/HangulJamo.pl +++ b/contrib/perl5/lib/unicode/In/HangulJamo.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 1100 11FF diff --git a/contrib/perl5/lib/unicode/In/HangulSyllables.pl b/contrib/perl5/lib/unicode/In/HangulSyllables.pl index 7d91a363f52d..80cd4a4420a8 100644 --- a/contrib/perl5/lib/unicode/In/HangulSyllables.pl +++ b/contrib/perl5/lib/unicode/In/HangulSyllables.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; AC00 D7A3 diff --git a/contrib/perl5/lib/unicode/In/Hebrew.pl b/contrib/perl5/lib/unicode/In/Hebrew.pl index abe7b9ede4be..2e29a282368a 100644 --- a/contrib/perl5/lib/unicode/In/Hebrew.pl +++ b/contrib/perl5/lib/unicode/In/Hebrew.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0590 05FF diff --git a/contrib/perl5/lib/unicode/In/HighPrivateUseSurrogates.pl b/contrib/perl5/lib/unicode/In/HighPrivateUseSurrogates.pl index 6ed7ac96fdde..0e1320d7ee4b 100644 --- a/contrib/perl5/lib/unicode/In/HighPrivateUseSurrogates.pl +++ b/contrib/perl5/lib/unicode/In/HighPrivateUseSurrogates.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; DB80 DBFF diff --git a/contrib/perl5/lib/unicode/In/HighSurrogates.pl b/contrib/perl5/lib/unicode/In/HighSurrogates.pl index 924a0c9bdbd8..6acc6c45036d 100644 --- a/contrib/perl5/lib/unicode/In/HighSurrogates.pl +++ b/contrib/perl5/lib/unicode/In/HighSurrogates.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; D800 DB7F diff --git a/contrib/perl5/lib/unicode/In/Hiragana.pl b/contrib/perl5/lib/unicode/In/Hiragana.pl index 7a6530218875..5905fe9b283b 100644 --- a/contrib/perl5/lib/unicode/In/Hiragana.pl +++ b/contrib/perl5/lib/unicode/In/Hiragana.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 3040 309F diff --git a/contrib/perl5/lib/unicode/In/IPAExtensions.pl b/contrib/perl5/lib/unicode/In/IPAExtensions.pl index 20906d630069..5365373c1b47 100644 --- a/contrib/perl5/lib/unicode/In/IPAExtensions.pl +++ b/contrib/perl5/lib/unicode/In/IPAExtensions.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0250 02AF diff --git a/contrib/perl5/lib/unicode/In/IdeographicDescriptionCharacters.pl b/contrib/perl5/lib/unicode/In/IdeographicDescriptionCharacters.pl index 4baae881a1b6..dafb5b4fe37d 100644 --- a/contrib/perl5/lib/unicode/In/IdeographicDescriptionCharacters.pl +++ b/contrib/perl5/lib/unicode/In/IdeographicDescriptionCharacters.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2FF0 2FFF diff --git a/contrib/perl5/lib/unicode/In/Kanbun.pl b/contrib/perl5/lib/unicode/In/Kanbun.pl index 57d6bd21f49d..9ad03a661b15 100644 --- a/contrib/perl5/lib/unicode/In/Kanbun.pl +++ b/contrib/perl5/lib/unicode/In/Kanbun.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 3190 319F diff --git a/contrib/perl5/lib/unicode/In/KangxiRadicals.pl b/contrib/perl5/lib/unicode/In/KangxiRadicals.pl index d26fd6c77433..165398c9e927 100644 --- a/contrib/perl5/lib/unicode/In/KangxiRadicals.pl +++ b/contrib/perl5/lib/unicode/In/KangxiRadicals.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2F00 2FDF diff --git a/contrib/perl5/lib/unicode/In/Kannada.pl b/contrib/perl5/lib/unicode/In/Kannada.pl index 109197a6f71d..a679445f3f8b 100644 --- a/contrib/perl5/lib/unicode/In/Kannada.pl +++ b/contrib/perl5/lib/unicode/In/Kannada.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0C80 0CFF diff --git a/contrib/perl5/lib/unicode/In/Katakana.pl b/contrib/perl5/lib/unicode/In/Katakana.pl index 93bd5a03faaf..2976d2582244 100644 --- a/contrib/perl5/lib/unicode/In/Katakana.pl +++ b/contrib/perl5/lib/unicode/In/Katakana.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 30A0 30FF diff --git a/contrib/perl5/lib/unicode/In/Khmer.pl b/contrib/perl5/lib/unicode/In/Khmer.pl index f3e86851b3b3..6a85224223ea 100644 --- a/contrib/perl5/lib/unicode/In/Khmer.pl +++ b/contrib/perl5/lib/unicode/In/Khmer.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 1780 17FF diff --git a/contrib/perl5/lib/unicode/In/Lao.pl b/contrib/perl5/lib/unicode/In/Lao.pl index 41ff11f805bf..fdddd867661a 100644 --- a/contrib/perl5/lib/unicode/In/Lao.pl +++ b/contrib/perl5/lib/unicode/In/Lao.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0E80 0EFF diff --git a/contrib/perl5/lib/unicode/In/Latin-1Supplement.pl b/contrib/perl5/lib/unicode/In/Latin-1Supplement.pl index 1b252eb23e99..6a901fba1c6b 100644 --- a/contrib/perl5/lib/unicode/In/Latin-1Supplement.pl +++ b/contrib/perl5/lib/unicode/In/Latin-1Supplement.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0080 00FF diff --git a/contrib/perl5/lib/unicode/In/LatinExtended-A.pl b/contrib/perl5/lib/unicode/In/LatinExtended-A.pl index b8be987db08c..a042350176ae 100644 --- a/contrib/perl5/lib/unicode/In/LatinExtended-A.pl +++ b/contrib/perl5/lib/unicode/In/LatinExtended-A.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0100 017F diff --git a/contrib/perl5/lib/unicode/In/LatinExtended-B.pl b/contrib/perl5/lib/unicode/In/LatinExtended-B.pl index b9aff43f3d47..b7106c6d375e 100644 --- a/contrib/perl5/lib/unicode/In/LatinExtended-B.pl +++ b/contrib/perl5/lib/unicode/In/LatinExtended-B.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0180 024F diff --git a/contrib/perl5/lib/unicode/In/LatinExtendedAdditional.pl b/contrib/perl5/lib/unicode/In/LatinExtendedAdditional.pl index d309e90814f6..e17cc3de9517 100644 --- a/contrib/perl5/lib/unicode/In/LatinExtendedAdditional.pl +++ b/contrib/perl5/lib/unicode/In/LatinExtendedAdditional.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 1E00 1EFF diff --git a/contrib/perl5/lib/unicode/In/LetterlikeSymbols.pl b/contrib/perl5/lib/unicode/In/LetterlikeSymbols.pl index 1768740d425e..c2249a7b94e0 100644 --- a/contrib/perl5/lib/unicode/In/LetterlikeSymbols.pl +++ b/contrib/perl5/lib/unicode/In/LetterlikeSymbols.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2100 214F diff --git a/contrib/perl5/lib/unicode/In/LowSurrogates.pl b/contrib/perl5/lib/unicode/In/LowSurrogates.pl index 752b264e81f9..025bd13950b4 100644 --- a/contrib/perl5/lib/unicode/In/LowSurrogates.pl +++ b/contrib/perl5/lib/unicode/In/LowSurrogates.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; DC00 DFFF diff --git a/contrib/perl5/lib/unicode/In/Malayalam.pl b/contrib/perl5/lib/unicode/In/Malayalam.pl index 8fb57cdb10a2..5a01d40927e8 100644 --- a/contrib/perl5/lib/unicode/In/Malayalam.pl +++ b/contrib/perl5/lib/unicode/In/Malayalam.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0D00 0D7F diff --git a/contrib/perl5/lib/unicode/In/MathematicalOperators.pl b/contrib/perl5/lib/unicode/In/MathematicalOperators.pl index 055f19e5903a..8b45e1881c80 100644 --- a/contrib/perl5/lib/unicode/In/MathematicalOperators.pl +++ b/contrib/perl5/lib/unicode/In/MathematicalOperators.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2200 22FF diff --git a/contrib/perl5/lib/unicode/In/MiscellaneousSymbols.pl b/contrib/perl5/lib/unicode/In/MiscellaneousSymbols.pl index 9dcdd2695425..cc5b02fdc2bd 100644 --- a/contrib/perl5/lib/unicode/In/MiscellaneousSymbols.pl +++ b/contrib/perl5/lib/unicode/In/MiscellaneousSymbols.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2600 26FF diff --git a/contrib/perl5/lib/unicode/In/MiscellaneousTechnical.pl b/contrib/perl5/lib/unicode/In/MiscellaneousTechnical.pl index 370c00f320cd..a1058a0c6d65 100644 --- a/contrib/perl5/lib/unicode/In/MiscellaneousTechnical.pl +++ b/contrib/perl5/lib/unicode/In/MiscellaneousTechnical.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2300 23FF diff --git a/contrib/perl5/lib/unicode/In/Mongolian.pl b/contrib/perl5/lib/unicode/In/Mongolian.pl index 394014d49694..98a4914ce637 100644 --- a/contrib/perl5/lib/unicode/In/Mongolian.pl +++ b/contrib/perl5/lib/unicode/In/Mongolian.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 1800 18AF diff --git a/contrib/perl5/lib/unicode/In/Myanmar.pl b/contrib/perl5/lib/unicode/In/Myanmar.pl index 4b3f3181b006..3aa2f414101f 100644 --- a/contrib/perl5/lib/unicode/In/Myanmar.pl +++ b/contrib/perl5/lib/unicode/In/Myanmar.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 1000 109F diff --git a/contrib/perl5/lib/unicode/In/NumberForms.pl b/contrib/perl5/lib/unicode/In/NumberForms.pl index d33ece0bbc4d..2a606a6bf740 100644 --- a/contrib/perl5/lib/unicode/In/NumberForms.pl +++ b/contrib/perl5/lib/unicode/In/NumberForms.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2150 218F diff --git a/contrib/perl5/lib/unicode/In/Ogham.pl b/contrib/perl5/lib/unicode/In/Ogham.pl index e097d90c773a..de320a91727a 100644 --- a/contrib/perl5/lib/unicode/In/Ogham.pl +++ b/contrib/perl5/lib/unicode/In/Ogham.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 1680 169F diff --git a/contrib/perl5/lib/unicode/In/OpticalCharacterRecognition.pl b/contrib/perl5/lib/unicode/In/OpticalCharacterRecognition.pl index be1d981c7cbd..7f0aff830e62 100644 --- a/contrib/perl5/lib/unicode/In/OpticalCharacterRecognition.pl +++ b/contrib/perl5/lib/unicode/In/OpticalCharacterRecognition.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2440 245F diff --git a/contrib/perl5/lib/unicode/In/Oriya.pl b/contrib/perl5/lib/unicode/In/Oriya.pl index 5a680f674314..771a24575790 100644 --- a/contrib/perl5/lib/unicode/In/Oriya.pl +++ b/contrib/perl5/lib/unicode/In/Oriya.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0B00 0B7F diff --git a/contrib/perl5/lib/unicode/In/PrivateUse.pl b/contrib/perl5/lib/unicode/In/PrivateUse.pl index 0c118f4fe48d..0b0c00407d5c 100644 --- a/contrib/perl5/lib/unicode/In/PrivateUse.pl +++ b/contrib/perl5/lib/unicode/In/PrivateUse.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; E000 F8FF diff --git a/contrib/perl5/lib/unicode/In/Runic.pl b/contrib/perl5/lib/unicode/In/Runic.pl index 0bd42df80c9d..52ca7aa4fb55 100644 --- a/contrib/perl5/lib/unicode/In/Runic.pl +++ b/contrib/perl5/lib/unicode/In/Runic.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 16A0 16FF diff --git a/contrib/perl5/lib/unicode/In/Sinhala.pl b/contrib/perl5/lib/unicode/In/Sinhala.pl index 37e007c05743..5a892fd3c1c9 100644 --- a/contrib/perl5/lib/unicode/In/Sinhala.pl +++ b/contrib/perl5/lib/unicode/In/Sinhala.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0D80 0DFF diff --git a/contrib/perl5/lib/unicode/In/SmallFormVariants.pl b/contrib/perl5/lib/unicode/In/SmallFormVariants.pl index 736415e67e00..148e6e85b880 100644 --- a/contrib/perl5/lib/unicode/In/SmallFormVariants.pl +++ b/contrib/perl5/lib/unicode/In/SmallFormVariants.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; FE50 FE6F diff --git a/contrib/perl5/lib/unicode/In/SpacingModifierLetters.pl b/contrib/perl5/lib/unicode/In/SpacingModifierLetters.pl index 6e9cdf0b53ff..0e31fea4b4e9 100644 --- a/contrib/perl5/lib/unicode/In/SpacingModifierLetters.pl +++ b/contrib/perl5/lib/unicode/In/SpacingModifierLetters.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 02B0 02FF diff --git a/contrib/perl5/lib/unicode/In/Specials.pl b/contrib/perl5/lib/unicode/In/Specials.pl index f9f730f84022..03f69a3b8e1b 100644 --- a/contrib/perl5/lib/unicode/In/Specials.pl +++ b/contrib/perl5/lib/unicode/In/Specials.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; FFF0 FFFD diff --git a/contrib/perl5/lib/unicode/In/SuperscriptsandSubscripts.pl b/contrib/perl5/lib/unicode/In/SuperscriptsandSubscripts.pl index efcec0b84179..b0f90cd67b61 100644 --- a/contrib/perl5/lib/unicode/In/SuperscriptsandSubscripts.pl +++ b/contrib/perl5/lib/unicode/In/SuperscriptsandSubscripts.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2070 209F diff --git a/contrib/perl5/lib/unicode/In/Syriac.pl b/contrib/perl5/lib/unicode/In/Syriac.pl index 7c81fb6f3249..f85f1a9fd74f 100644 --- a/contrib/perl5/lib/unicode/In/Syriac.pl +++ b/contrib/perl5/lib/unicode/In/Syriac.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0700 074F diff --git a/contrib/perl5/lib/unicode/In/Tamil.pl b/contrib/perl5/lib/unicode/In/Tamil.pl index e65ed2fa1959..71fa923d6f5c 100644 --- a/contrib/perl5/lib/unicode/In/Tamil.pl +++ b/contrib/perl5/lib/unicode/In/Tamil.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0B80 0BFF diff --git a/contrib/perl5/lib/unicode/In/Telugu.pl b/contrib/perl5/lib/unicode/In/Telugu.pl index d5ed2368c2b8..ff09b1ed8702 100644 --- a/contrib/perl5/lib/unicode/In/Telugu.pl +++ b/contrib/perl5/lib/unicode/In/Telugu.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0C00 0C7F diff --git a/contrib/perl5/lib/unicode/In/Thaana.pl b/contrib/perl5/lib/unicode/In/Thaana.pl index 361bd4d4b44c..f88768c924f0 100644 --- a/contrib/perl5/lib/unicode/In/Thaana.pl +++ b/contrib/perl5/lib/unicode/In/Thaana.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0780 07BF diff --git a/contrib/perl5/lib/unicode/In/Thai.pl b/contrib/perl5/lib/unicode/In/Thai.pl index 3376de4e18c6..e77c0c512f2f 100644 --- a/contrib/perl5/lib/unicode/In/Thai.pl +++ b/contrib/perl5/lib/unicode/In/Thai.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0E00 0E7F diff --git a/contrib/perl5/lib/unicode/In/Tibetan.pl b/contrib/perl5/lib/unicode/In/Tibetan.pl index 50837ad8bc71..35436b3b14eb 100644 --- a/contrib/perl5/lib/unicode/In/Tibetan.pl +++ b/contrib/perl5/lib/unicode/In/Tibetan.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0F00 0FFF diff --git a/contrib/perl5/lib/unicode/In/UnifiedCanadianAboriginalSyllabics.pl b/contrib/perl5/lib/unicode/In/UnifiedCanadianAboriginalSyllabics.pl index ad4eb278662b..83c6a78cca71 100644 --- a/contrib/perl5/lib/unicode/In/UnifiedCanadianAboriginalSyllabics.pl +++ b/contrib/perl5/lib/unicode/In/UnifiedCanadianAboriginalSyllabics.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 1400 167F diff --git a/contrib/perl5/lib/unicode/In/YiRadicals.pl b/contrib/perl5/lib/unicode/In/YiRadicals.pl index f25c6954ff24..7350871cb216 100644 --- a/contrib/perl5/lib/unicode/In/YiRadicals.pl +++ b/contrib/perl5/lib/unicode/In/YiRadicals.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; A490 A4CF diff --git a/contrib/perl5/lib/unicode/In/YiSyllables.pl b/contrib/perl5/lib/unicode/In/YiSyllables.pl index f4e3a8bcbc04..baa038eb307d 100644 --- a/contrib/perl5/lib/unicode/In/YiSyllables.pl +++ b/contrib/perl5/lib/unicode/In/YiSyllables.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; A000 A48F diff --git a/contrib/perl5/lib/unicode/Is/ASCII.pl b/contrib/perl5/lib/unicode/Is/ASCII.pl index 63f95ae7dd40..1434a55d9654 100644 --- a/contrib/perl5/lib/unicode/Is/ASCII.pl +++ b/contrib/perl5/lib/unicode/Is/ASCII.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0000 007f diff --git a/contrib/perl5/lib/unicode/Is/Alnum.pl b/contrib/perl5/lib/unicode/Is/Alnum.pl index d44f744e2048..a0aac6293850 100644 --- a/contrib/perl5/lib/unicode/Is/Alnum.pl +++ b/contrib/perl5/lib/unicode/Is/Alnum.pl @@ -1,22 +1,28 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0030 0039 0041 005a 0061 007a 00aa +00b2 00b3 00b5 -00ba +00b9 00ba +00bc 00be 00c0 00d6 00d8 00f6 -00f8 01c4 -01c6 01c7 -01c9 01ca -01cc 01f1 -01f3 021f +00f8 021f 0222 0233 0250 02ad +02b0 02b8 +02bb 02c1 +02d0 02d1 +02e0 02e4 +02ee +0300 034e +0360 0362 +037a 0386 0388 038a 038c @@ -25,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 @@ -64,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 @@ -75,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 @@ -99,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 @@ -141,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 @@ -187,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 @@ -210,20 +281,20 @@ return <<'END'; 1f5b 1f5d 1f5f 1f7d -1f80 1f87 -1f90 1f97 -1fa0 1fa7 -1fb0 1fb4 -1fb6 1fbb +1f80 1fb4 +1fb6 1fbc 1fbe 1fc2 1fc4 -1fc6 1fcb +1fc6 1fcc 1fd0 1fd3 1fd6 1fdb 1fe0 1fec 1ff2 1ff4 -1ff6 1ffb -207f +1ff6 1ffc +2070 +2074 2079 +207f 2089 +20d0 20e3 2102 2107 210a 2113 @@ -235,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 @@ -248,8 +332,7 @@ ac00 d7a3 f900 fa2d fb00 fb06 fb13 fb17 -fb1d -fb1f fb28 +fb1d fb28 fb2a fb36 fb38 fb3c fb3e @@ -260,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/contrib/perl5/lib/unicode/Is/Alpha.pl b/contrib/perl5/lib/unicode/Is/Alpha.pl index 0e94688e8529..13dc003c9646 100644 --- a/contrib/perl5/lib/unicode/Is/Alpha.pl +++ b/contrib/perl5/lib/unicode/Is/Alpha.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0041 005a @@ -9,13 +9,17 @@ return <<'END'; 00ba 00c0 00d6 00d8 00f6 -00f8 01c4 -01c6 01c7 -01c9 01ca -01cc 01f1 -01f3 021f +00f8 021f 0222 0233 0250 02ad +02b0 02b8 +02bb 02c1 +02d0 02d1 +02e0 02e4 +02ee +0300 034e +0360 0362 +037a 0386 0388 038a 038c @@ -24,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 @@ -61,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 @@ -71,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 @@ -93,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 @@ -130,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 @@ -178,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 @@ -193,20 +261,18 @@ return <<'END'; 1f5b 1f5d 1f5f 1f7d -1f80 1f87 -1f90 1f97 -1fa0 1fa7 -1fb0 1fb4 -1fb6 1fbb +1f80 1fb4 +1fb6 1fbc 1fbe 1fc2 1fc4 -1fc6 1fcb +1fc6 1fcc 1fd0 1fd3 1fd6 1fdb 1fe0 1fec 1ff2 1ff4 -1ff6 1ffb +1ff6 1ffc 207f +20d0 20e3 2102 2107 210a 2113 @@ -218,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 @@ -231,8 +302,7 @@ ac00 d7a3 f900 fa2d fb00 fb06 fb13 fb17 -fb1d -fb1f fb28 +fb1d fb28 fb2a fb36 fb38 fb3c fb3e @@ -243,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/contrib/perl5/lib/unicode/Is/BidiAN.pl b/contrib/perl5/lib/unicode/Is/BidiAN.pl index 4a71ae532d15..4519c6d51d53 100644 --- a/contrib/perl5/lib/unicode/Is/BidiAN.pl +++ b/contrib/perl5/lib/unicode/Is/BidiAN.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0660 0669 diff --git a/contrib/perl5/lib/unicode/Is/BidiB.pl b/contrib/perl5/lib/unicode/Is/BidiB.pl index e4ba16567adb..33bdb459441c 100644 --- a/contrib/perl5/lib/unicode/Is/BidiB.pl +++ b/contrib/perl5/lib/unicode/Is/BidiB.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 000a diff --git a/contrib/perl5/lib/unicode/Is/BidiCS.pl b/contrib/perl5/lib/unicode/Is/BidiCS.pl index f8d037d118e5..e21765384323 100644 --- a/contrib/perl5/lib/unicode/Is/BidiCS.pl +++ b/contrib/perl5/lib/unicode/Is/BidiCS.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 002c diff --git a/contrib/perl5/lib/unicode/Is/BidiEN.pl b/contrib/perl5/lib/unicode/Is/BidiEN.pl index d63270aecf74..113de874544d 100644 --- a/contrib/perl5/lib/unicode/Is/BidiEN.pl +++ b/contrib/perl5/lib/unicode/Is/BidiEN.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0030 0039 diff --git a/contrib/perl5/lib/unicode/Is/BidiES.pl b/contrib/perl5/lib/unicode/Is/BidiES.pl index 5a1a36a6d8fd..d1cd305f54ff 100644 --- a/contrib/perl5/lib/unicode/Is/BidiES.pl +++ b/contrib/perl5/lib/unicode/Is/BidiES.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 002f diff --git a/contrib/perl5/lib/unicode/Is/BidiET.pl b/contrib/perl5/lib/unicode/Is/BidiET.pl index 5e7af2bbf40d..0a66fa834680 100644 --- a/contrib/perl5/lib/unicode/Is/BidiET.pl +++ b/contrib/perl5/lib/unicode/Is/BidiET.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0023 0025 diff --git a/contrib/perl5/lib/unicode/Is/BidiL.pl b/contrib/perl5/lib/unicode/Is/BidiL.pl index 8dc4ca87c0a2..a08d8b8900b1 100644 --- a/contrib/perl5/lib/unicode/Is/BidiL.pl +++ b/contrib/perl5/lib/unicode/Is/BidiL.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0041 005a @@ -320,4 +320,6 @@ ffc2 ffc7 ffca ffcf ffd2 ffd7 ffda ffdc +f0000 ffffd +100000 10fffd END diff --git a/contrib/perl5/lib/unicode/Is/BidiON.pl b/contrib/perl5/lib/unicode/Is/BidiON.pl index bde00ff12385..ec0f18ff1d22 100644 --- a/contrib/perl5/lib/unicode/Is/BidiON.pl +++ b/contrib/perl5/lib/unicode/Is/BidiON.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0021 0022 diff --git a/contrib/perl5/lib/unicode/Is/BidiR.pl b/contrib/perl5/lib/unicode/Is/BidiR.pl index fccc1f6d6e40..9f776ae53f87 100644 --- a/contrib/perl5/lib/unicode/Is/BidiR.pl +++ b/contrib/perl5/lib/unicode/Is/BidiR.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 05be diff --git a/contrib/perl5/lib/unicode/Is/BidiS.pl b/contrib/perl5/lib/unicode/Is/BidiS.pl index b28b3310eaaa..ac2655d6ed61 100644 --- a/contrib/perl5/lib/unicode/Is/BidiS.pl +++ b/contrib/perl5/lib/unicode/Is/BidiS.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0009 diff --git a/contrib/perl5/lib/unicode/Is/BidiWS.pl b/contrib/perl5/lib/unicode/Is/BidiWS.pl index 25d8b8f6aa8a..ebd24e546e90 100644 --- a/contrib/perl5/lib/unicode/Is/BidiWS.pl +++ b/contrib/perl5/lib/unicode/Is/BidiWS.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 000c diff --git a/contrib/perl5/lib/unicode/Is/C.pl b/contrib/perl5/lib/unicode/Is/C.pl index 0db83c4bf301..51e4ede0672b 100644 --- a/contrib/perl5/lib/unicode/Is/C.pl +++ b/contrib/perl5/lib/unicode/Is/C.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0000 001f @@ -15,4 +15,6 @@ dc00 dfff e000 f8ff feff fff9 fffb +f0000 ffffd +100000 10fffd END diff --git a/contrib/perl5/lib/unicode/Is/Cc.pl b/contrib/perl5/lib/unicode/Is/Cc.pl index d7184e315110..6b97adc9eb44 100644 --- a/contrib/perl5/lib/unicode/Is/Cc.pl +++ b/contrib/perl5/lib/unicode/Is/Cc.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0000 001f diff --git a/contrib/perl5/lib/unicode/Is/Cn.pl b/contrib/perl5/lib/unicode/Is/Cn.pl index ec287c456ab2..fb75e8769c5a 100644 --- a/contrib/perl5/lib/unicode/Is/Cn.pl +++ b/contrib/perl5/lib/unicode/Is/Cn.pl @@ -1,5 +1,373 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; +0220 0221 +0234 024f +02ae 02af +02ef 02ff +034f 035f +0363 0373 +0376 0379 +037b 037d +037f 0383 +038b +038d +03a2 +03cf +03d8 03d9 +03f4 03ff +0487 +048a 048b +04c5 04c6 +04c9 04ca +04cd 04cf +04f6 04f7 +04fa 0530 +0557 0558 +0560 +0588 +058b 0590 +05a2 +05ba +05c5 05cf +05eb 05ef +05f5 060b +060d 061a +061c 061e +0620 +063b 063f +0656 065f +066e 066f +06ee 06ef +06ff +070e +072d 072f +074b 077f +07b1 0900 +0904 +093a 093b +094e 094f +0955 0957 +0971 0980 +0984 +098d 098e +0991 0992 +09a9 +09b1 +09b3 09b5 +09ba 09bb +09bd +09c5 09c6 +09c9 09ca +09ce 09d6 +09d8 09db +09de +09e4 09e5 +09fb 0a01 +0a03 0a04 +0a0b 0a0e +0a11 0a12 +0a29 +0a31 +0a34 +0a37 +0a3a 0a3b +0a3d +0a43 0a46 +0a49 0a4a +0a4e 0a58 +0a5d +0a5f 0a65 +0a75 0a80 +0a84 +0a8c +0a8e +0a92 +0aa9 +0ab1 +0ab4 +0aba 0abb +0ac6 +0aca +0ace 0acf +0ad1 0adf +0ae1 0ae5 +0af0 0b00 +0b04 +0b0d 0b0e +0b11 0b12 +0b29 +0b31 +0b34 0b35 +0b3a 0b3b +0b44 0b46 +0b49 0b4a +0b4e 0b55 +0b58 0b5b +0b5e +0b62 0b65 +0b71 0b81 +0b84 +0b8b 0b8d +0b91 +0b96 0b98 +0b9b +0b9d +0ba0 0ba2 +0ba5 0ba7 +0bab 0bad +0bb6 +0bba 0bbd +0bc3 0bc5 +0bc9 +0bce 0bd6 +0bd8 0be6 +0bf3 0c00 +0c04 +0c0d +0c11 +0c29 +0c34 +0c3a 0c3d +0c45 +0c49 +0c4e 0c54 +0c57 0c5f +0c62 0c65 +0c70 0c81 +0c84 +0c8d +0c91 +0ca9 +0cb4 +0cba 0cbd +0cc5 +0cc9 +0cce 0cd4 +0cd7 0cdd +0cdf +0ce2 0ce5 +0cf0 0d01 +0d04 +0d0d +0d11 +0d29 +0d3a 0d3d +0d44 0d45 +0d49 +0d4e 0d56 +0d58 0d5f +0d62 0d65 +0d70 0d81 +0d84 +0d97 0d99 +0db2 +0dbc +0dbe 0dbf +0dc7 0dc9 +0dcb 0dce +0dd5 +0dd7 +0de0 0df1 +0df5 0e00 +0e3b 0e3e +0e5c 0e80 +0e83 +0e85 0e86 +0e89 +0e8b 0e8c +0e8e 0e93 +0e98 +0ea0 +0ea4 +0ea6 +0ea8 0ea9 +0eac +0eba +0ebe 0ebf +0ec5 +0ec7 +0ece 0ecf +0eda 0edb +0ede 0eff +0f48 +0f6b 0f70 +0f8c 0f8f +0f98 +0fbd +0fcd 0fce +0fd0 0fff +1022 +1028 +102b +1033 1035 +103a 103f +105a 109f +10c6 10cf +10f7 10fa +10fc 10ff +115a 115e +11a3 11a7 +11fa 11ff +1207 +1247 +1249 +124e 124f +1257 +1259 +125e 125f +1287 +1289 +128e 128f +12af +12b1 +12b6 12b7 +12bf +12c1 +12c6 12c7 +12cf +12d7 +12ef +130f +1311 +1316 1317 +131f +1347 +135b 1360 +137d 139f +13f5 1400 +1677 167f +169d 169f +16f1 177f +17dd 17df +17ea 17ff +180f +181a 181f +1878 187f +18aa 1dff +1e9c 1e9f +1efa 1eff +1f16 1f17 +1f1e 1f1f +1f46 1f47 +1f4e 1f4f +1f58 +1f5a +1f5c +1f5e +1f7e 1f7f +1fb5 +1fc5 +1fd4 1fd5 +1fdc +1ff0 1ff1 +1ff5 +1fff +2047 +204e 2069 +2071 2073 +208f 209f +20b0 20cf +20e4 20ff +213b 2152 +2184 218f +21f4 21ff +22f2 22ff +237c +239b 23ff +2427 243f +244b 245f +24eb 24ff +2596 259f +25f8 25ff +2614 2618 +2672 2700 +2705 +270a 270b +2728 +274c +274e +2753 2755 +2757 +275f 2760 +2768 2775 +2795 2797 +27b0 +27bf 27ff +2900 2e7f +2e9a +2ef4 2eff +2fd6 2fef +2ffc 2fff +303b 303d +3040 +3095 3098 +309f 30a0 +30ff 3104 +312d 3130 +318f +31b8 31ff +321d 321f +3244 325f +327c 327e +32b1 32bf +32cc 32cf +32ff +3377 337a +33de 33df +33ff +4db6 4dff +9fa6 9fff +a48d a48f +a4a2 a4a3 +a4b4 +a4c1 +a4c5 +a4c7 abff +d7a4 d7ff +fa2e faff +fb07 fb12 +fb18 fb1c +fb37 +fb3d +fb3f +fb42 +fb45 +fbb2 fbd2 +fd40 fd4f +fd90 fd91 +fdc8 fdef +fdfc fe1f +fe24 fe2f +fe45 fe48 +fe53 +fe67 +fe6c fe6f +fe73 +fe75 +fefd fefe +ff00 +ff5f ff60 +ffbf ffc1 +ffc8 ffc9 +ffd0 ffd1 +ffd8 ffd9 +ffdd ffdf +ffe7 +ffef fff8 +10000 1fffd +20000 2fffd +30000 3fffd +40000 4fffd +50000 5fffd +60000 6fffd +70000 7fffd +80000 8fffd +90000 9fffd +a0000 afffd +b0000 bfffd +c0000 cfffd +d0000 dfffd +e0000 efffd END diff --git a/contrib/perl5/lib/unicode/Is/Cntrl.pl b/contrib/perl5/lib/unicode/Is/Cntrl.pl index 0db83c4bf301..51e4ede0672b 100644 --- a/contrib/perl5/lib/unicode/Is/Cntrl.pl +++ b/contrib/perl5/lib/unicode/Is/Cntrl.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0000 001f @@ -15,4 +15,6 @@ dc00 dfff e000 f8ff feff fff9 fffb +f0000 ffffd +100000 10fffd END diff --git a/contrib/perl5/lib/unicode/Is/Co.pl b/contrib/perl5/lib/unicode/Is/Co.pl index c456d33aea00..d077fd2bd316 100644 --- a/contrib/perl5/lib/unicode/Is/Co.pl +++ b/contrib/perl5/lib/unicode/Is/Co.pl @@ -1,6 +1,8 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; e000 f8ff +f0000 ffffd +100000 10fffd END diff --git a/contrib/perl5/lib/unicode/Is/DCcircle.pl b/contrib/perl5/lib/unicode/Is/DCcircle.pl index 4c47b28b26f3..82c9edcd2b81 100644 --- a/contrib/perl5/lib/unicode/Is/DCcircle.pl +++ b/contrib/perl5/lib/unicode/Is/DCcircle.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2460 2473 diff --git a/contrib/perl5/lib/unicode/Is/DCcompat.pl b/contrib/perl5/lib/unicode/Is/DCcompat.pl index 75d25695f32c..5ae2b6a9f481 100644 --- a/contrib/perl5/lib/unicode/Is/DCcompat.pl +++ b/contrib/perl5/lib/unicode/Is/DCcompat.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 00a8 diff --git a/contrib/perl5/lib/unicode/Is/DCfinal.pl b/contrib/perl5/lib/unicode/Is/DCfinal.pl index 33fbf6aff876..3c81bcc6c4a6 100644 --- a/contrib/perl5/lib/unicode/Is/DCfinal.pl +++ b/contrib/perl5/lib/unicode/Is/DCfinal.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; fb51 diff --git a/contrib/perl5/lib/unicode/Is/DCfont.pl b/contrib/perl5/lib/unicode/Is/DCfont.pl index c72234b3bfa0..7feff18b22dd 100644 --- a/contrib/perl5/lib/unicode/Is/DCfont.pl +++ b/contrib/perl5/lib/unicode/Is/DCfont.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2102 diff --git a/contrib/perl5/lib/unicode/Is/DCinitial.pl b/contrib/perl5/lib/unicode/Is/DCinitial.pl index 0145b7dd71c4..c6d7802eafa8 100644 --- a/contrib/perl5/lib/unicode/Is/DCinitial.pl +++ b/contrib/perl5/lib/unicode/Is/DCinitial.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; fb54 diff --git a/contrib/perl5/lib/unicode/Is/DCisolated.pl b/contrib/perl5/lib/unicode/Is/DCisolated.pl index cc8541eb7ba1..e4e24f786a37 100644 --- a/contrib/perl5/lib/unicode/Is/DCisolated.pl +++ b/contrib/perl5/lib/unicode/Is/DCisolated.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; fb50 diff --git a/contrib/perl5/lib/unicode/Is/DCnarrow.pl b/contrib/perl5/lib/unicode/Is/DCnarrow.pl index 9417de1bbda9..7887452105de 100644 --- a/contrib/perl5/lib/unicode/Is/DCnarrow.pl +++ b/contrib/perl5/lib/unicode/Is/DCnarrow.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; ff61 ffbe diff --git a/contrib/perl5/lib/unicode/Is/DCnoBreak.pl b/contrib/perl5/lib/unicode/Is/DCnoBreak.pl index 1fd9e8735b3e..18c01059ed78 100644 --- a/contrib/perl5/lib/unicode/Is/DCnoBreak.pl +++ b/contrib/perl5/lib/unicode/Is/DCnoBreak.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 00a0 diff --git a/contrib/perl5/lib/unicode/Is/DCsmall.pl b/contrib/perl5/lib/unicode/Is/DCsmall.pl index f6c80691636a..3a37931b5661 100644 --- a/contrib/perl5/lib/unicode/Is/DCsmall.pl +++ b/contrib/perl5/lib/unicode/Is/DCsmall.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; fe50 fe52 diff --git a/contrib/perl5/lib/unicode/Is/DCsquare.pl b/contrib/perl5/lib/unicode/Is/DCsquare.pl index b55fdd9c6a68..f27993d6b854 100644 --- a/contrib/perl5/lib/unicode/Is/DCsquare.pl +++ b/contrib/perl5/lib/unicode/Is/DCsquare.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 3300 3357 diff --git a/contrib/perl5/lib/unicode/Is/DCsub.pl b/contrib/perl5/lib/unicode/Is/DCsub.pl index 98c4dfa87e72..f709a228c287 100644 --- a/contrib/perl5/lib/unicode/Is/DCsub.pl +++ b/contrib/perl5/lib/unicode/Is/DCsub.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2080 208e diff --git a/contrib/perl5/lib/unicode/Is/DCsuper.pl b/contrib/perl5/lib/unicode/Is/DCsuper.pl index 865a26dd920c..1e6a0c5feb09 100644 --- a/contrib/perl5/lib/unicode/Is/DCsuper.pl +++ b/contrib/perl5/lib/unicode/Is/DCsuper.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 00aa diff --git a/contrib/perl5/lib/unicode/Is/DCvertical.pl b/contrib/perl5/lib/unicode/Is/DCvertical.pl index 5d5548360656..33b9feb7243c 100644 --- a/contrib/perl5/lib/unicode/Is/DCvertical.pl +++ b/contrib/perl5/lib/unicode/Is/DCvertical.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; fe30 fe44 diff --git a/contrib/perl5/lib/unicode/Is/DCwide.pl b/contrib/perl5/lib/unicode/Is/DCwide.pl index 09dae19629eb..afe1e06b7d5b 100644 --- a/contrib/perl5/lib/unicode/Is/DCwide.pl +++ b/contrib/perl5/lib/unicode/Is/DCwide.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 3000 diff --git a/contrib/perl5/lib/unicode/Is/DecoCanon.pl b/contrib/perl5/lib/unicode/Is/DecoCanon.pl index c5a59f6596c2..57c167b5f821 100644 --- a/contrib/perl5/lib/unicode/Is/DecoCanon.pl +++ b/contrib/perl5/lib/unicode/Is/DecoCanon.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 00c0 00c5 diff --git a/contrib/perl5/lib/unicode/Is/DecoCompat.pl b/contrib/perl5/lib/unicode/Is/DecoCompat.pl index 43d34fc110bf..940d956f9f9a 100644 --- a/contrib/perl5/lib/unicode/Is/DecoCompat.pl +++ b/contrib/perl5/lib/unicode/Is/DecoCompat.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 00a0 diff --git a/contrib/perl5/lib/unicode/Is/Digit.pl b/contrib/perl5/lib/unicode/Is/Digit.pl index 2ab8156d778b..259bb891f6b7 100644 --- a/contrib/perl5/lib/unicode/Is/Digit.pl +++ b/contrib/perl5/lib/unicode/Is/Digit.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0030 0039 diff --git a/contrib/perl5/lib/unicode/Is/Graph.pl b/contrib/perl5/lib/unicode/Is/Graph.pl index 9c94bb722cbc..238cc56229cf 100644 --- a/contrib/perl5/lib/unicode/Is/Graph.pl +++ b/contrib/perl5/lib/unicode/Is/Graph.pl @@ -1,9 +1,9 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # 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,9 +265,8 @@ return <<'END'; 1fdd 1fef 1ff2 1ff4 1ff6 1ffe -2000 200b -2010 2029 -202f 2046 +2010 2027 +2030 2046 2048 204d 2070 2074 208e @@ -303,7 +302,7 @@ return <<'END'; 2e9b 2ef3 2f00 2fd5 2ff0 2ffb -3000 303a +3001 303a 303e 303f 3041 3094 3099 309e @@ -329,6 +328,7 @@ a4b5 a4c0 a4c2 a4c4 a4c6 ac00 d7a3 +e000 f8ff f900 fa2d fb00 fb06 fb13 fb17 @@ -359,4 +359,6 @@ ffda ffdc ffe0 ffe6 ffe8 ffee fffc fffd +f0000 ffffd +100000 10fffd END diff --git a/contrib/perl5/lib/unicode/Is/L.pl b/contrib/perl5/lib/unicode/Is/L.pl index c32f83049ce4..bfe2c2741289 100644 --- a/contrib/perl5/lib/unicode/Is/L.pl +++ b/contrib/perl5/lib/unicode/Is/L.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0041 005a diff --git a/contrib/perl5/lib/unicode/Is/Ll.pl b/contrib/perl5/lib/unicode/Is/Ll.pl index 28147943e85a..03dafcc7426f 100644 --- a/contrib/perl5/lib/unicode/Is/Ll.pl +++ b/contrib/perl5/lib/unicode/Is/Ll.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0061 007a diff --git a/contrib/perl5/lib/unicode/Is/Lm.pl b/contrib/perl5/lib/unicode/Is/Lm.pl index 4380afe18e8d..23a3c55d4a39 100644 --- a/contrib/perl5/lib/unicode/Is/Lm.pl +++ b/contrib/perl5/lib/unicode/Is/Lm.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 02b0 02b8 diff --git a/contrib/perl5/lib/unicode/Is/Lo.pl b/contrib/perl5/lib/unicode/Is/Lo.pl index 78fab4cd0e15..d82c6bbdaf84 100644 --- a/contrib/perl5/lib/unicode/Is/Lo.pl +++ b/contrib/perl5/lib/unicode/Is/Lo.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 01bb diff --git a/contrib/perl5/lib/unicode/Is/Lower.pl b/contrib/perl5/lib/unicode/Is/Lower.pl index 28147943e85a..03dafcc7426f 100644 --- a/contrib/perl5/lib/unicode/Is/Lower.pl +++ b/contrib/perl5/lib/unicode/Is/Lower.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0061 007a diff --git a/contrib/perl5/lib/unicode/Is/Lt.pl b/contrib/perl5/lib/unicode/Is/Lt.pl index 809c37a1f250..b19755ca8e9c 100644 --- a/contrib/perl5/lib/unicode/Is/Lt.pl +++ b/contrib/perl5/lib/unicode/Is/Lt.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 01c5 diff --git a/contrib/perl5/lib/unicode/Is/Lu.pl b/contrib/perl5/lib/unicode/Is/Lu.pl index 8dde2742d0a4..07dee4834c2a 100644 --- a/contrib/perl5/lib/unicode/Is/Lu.pl +++ b/contrib/perl5/lib/unicode/Is/Lu.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0041 005a diff --git a/contrib/perl5/lib/unicode/Is/M.pl b/contrib/perl5/lib/unicode/Is/M.pl index 9367775a820c..e3ef7f3dfab0 100644 --- a/contrib/perl5/lib/unicode/Is/M.pl +++ b/contrib/perl5/lib/unicode/Is/M.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0300 034e diff --git a/contrib/perl5/lib/unicode/Is/Mc.pl b/contrib/perl5/lib/unicode/Is/Mc.pl index 937d8d40059e..a76d66c9b302 100644 --- a/contrib/perl5/lib/unicode/Is/Mc.pl +++ b/contrib/perl5/lib/unicode/Is/Mc.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0903 diff --git a/contrib/perl5/lib/unicode/Is/Mirrored.pl b/contrib/perl5/lib/unicode/Is/Mirrored.pl index e2c55a6443e8..d324f506a798 100644 --- a/contrib/perl5/lib/unicode/Is/Mirrored.pl +++ b/contrib/perl5/lib/unicode/Is/Mirrored.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0028 0029 diff --git a/contrib/perl5/lib/unicode/Is/Mn.pl b/contrib/perl5/lib/unicode/Is/Mn.pl index aba40afa57b6..803e038d973b 100644 --- a/contrib/perl5/lib/unicode/Is/Mn.pl +++ b/contrib/perl5/lib/unicode/Is/Mn.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0300 034e diff --git a/contrib/perl5/lib/unicode/Is/N.pl b/contrib/perl5/lib/unicode/Is/N.pl index 1291f2713f09..8667e774b4cb 100644 --- a/contrib/perl5/lib/unicode/Is/N.pl +++ b/contrib/perl5/lib/unicode/Is/N.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0030 0039 diff --git a/contrib/perl5/lib/unicode/Is/Nd.pl b/contrib/perl5/lib/unicode/Is/Nd.pl index 2ab8156d778b..259bb891f6b7 100644 --- a/contrib/perl5/lib/unicode/Is/Nd.pl +++ b/contrib/perl5/lib/unicode/Is/Nd.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0030 0039 diff --git a/contrib/perl5/lib/unicode/Is/No.pl b/contrib/perl5/lib/unicode/Is/No.pl index 6a57dc5f8916..13cac3b0e8f5 100644 --- a/contrib/perl5/lib/unicode/Is/No.pl +++ b/contrib/perl5/lib/unicode/Is/No.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 00b2 00b3 diff --git a/contrib/perl5/lib/unicode/Is/P.pl b/contrib/perl5/lib/unicode/Is/P.pl index 8fd1e8e1838e..97330ecd48b4 100644 --- a/contrib/perl5/lib/unicode/Is/P.pl +++ b/contrib/perl5/lib/unicode/Is/P.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0021 0023 diff --git a/contrib/perl5/lib/unicode/Is/Pd.pl b/contrib/perl5/lib/unicode/Is/Pd.pl index 58997ca7e98c..b4a2ffbe8f4e 100644 --- a/contrib/perl5/lib/unicode/Is/Pd.pl +++ b/contrib/perl5/lib/unicode/Is/Pd.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 002d diff --git a/contrib/perl5/lib/unicode/Is/Pe.pl b/contrib/perl5/lib/unicode/Is/Pe.pl index 8879191c3428..2b5bd3eeb9cc 100644 --- a/contrib/perl5/lib/unicode/Is/Pe.pl +++ b/contrib/perl5/lib/unicode/Is/Pe.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0029 diff --git a/contrib/perl5/lib/unicode/Is/Po.pl b/contrib/perl5/lib/unicode/Is/Po.pl index e6b8b025203d..849ee17867c7 100644 --- a/contrib/perl5/lib/unicode/Is/Po.pl +++ b/contrib/perl5/lib/unicode/Is/Po.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0021 0023 diff --git a/contrib/perl5/lib/unicode/Is/Print.pl b/contrib/perl5/lib/unicode/Is/Print.pl index 956058606584..1229a282b2e3 100644 --- a/contrib/perl5/lib/unicode/Is/Print.pl +++ b/contrib/perl5/lib/unicode/Is/Print.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0020 007e @@ -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/contrib/perl5/lib/unicode/Is/Ps.pl b/contrib/perl5/lib/unicode/Is/Ps.pl index a7dee379ebea..90f18098b748 100644 --- a/contrib/perl5/lib/unicode/Is/Ps.pl +++ b/contrib/perl5/lib/unicode/Is/Ps.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0028 diff --git a/contrib/perl5/lib/unicode/Is/Punct.pl b/contrib/perl5/lib/unicode/Is/Punct.pl index 8fd1e8e1838e..97330ecd48b4 100644 --- a/contrib/perl5/lib/unicode/Is/Punct.pl +++ b/contrib/perl5/lib/unicode/Is/Punct.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0021 0023 diff --git a/contrib/perl5/lib/unicode/Is/S.pl b/contrib/perl5/lib/unicode/Is/S.pl index 8851766e9f22..a304e17ff530 100644 --- a/contrib/perl5/lib/unicode/Is/S.pl +++ b/contrib/perl5/lib/unicode/Is/S.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0024 diff --git a/contrib/perl5/lib/unicode/Is/Sc.pl b/contrib/perl5/lib/unicode/Is/Sc.pl index 5776bd6a5767..adeb3e43363f 100644 --- a/contrib/perl5/lib/unicode/Is/Sc.pl +++ b/contrib/perl5/lib/unicode/Is/Sc.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0024 diff --git a/contrib/perl5/lib/unicode/Is/Sm.pl b/contrib/perl5/lib/unicode/Is/Sm.pl index ae9424cc621a..540da63e6436 100644 --- a/contrib/perl5/lib/unicode/Is/Sm.pl +++ b/contrib/perl5/lib/unicode/Is/Sm.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 002b diff --git a/contrib/perl5/lib/unicode/Is/So.pl b/contrib/perl5/lib/unicode/Is/So.pl index 4e9dfc2b5ee8..3caf617b665f 100644 --- a/contrib/perl5/lib/unicode/Is/So.pl +++ b/contrib/perl5/lib/unicode/Is/So.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 00a6 00a7 diff --git a/contrib/perl5/lib/unicode/Is/Space.pl b/contrib/perl5/lib/unicode/Is/Space.pl index 4121ef49b86e..9971082fbed2 100644 --- a/contrib/perl5/lib/unicode/Is/Space.pl +++ b/contrib/perl5/lib/unicode/Is/Space.pl @@ -1,9 +1,8 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# 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 +0009 000d 0020 00a0 1680 diff --git a/contrib/perl5/lib/unicode/Is/SylA.pl b/contrib/perl5/lib/unicode/Is/SylA.pl index ec287c456ab2..6a3fc47eb9b0 100644 --- a/contrib/perl5/lib/unicode/Is/SylA.pl +++ b/contrib/perl5/lib/unicode/Is/SylA.pl @@ -1,5 +1,158 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; +1203 +120b +1213 +121b +1223 +122b +1233 +123b +1243 +1253 +1263 +126b +1273 +127b +1283 +1293 +129b +12a3 +12ab +12bb +12cb +12d3 +12db +12e3 +12eb +12f3 +12fb +1303 +130b +131b +1323 +132b +1333 +133b +1343 +134b +1353 +13a0 +13a6 13a7 +13ad +13b3 +13b9 +13be 13bf +13c6 +13cc +13d3 13d4 +13dc 13dd +13e3 +13e9 +13ef +140a +1438 +1455 +146a +1472 +1490 +14aa +14c7 +14da +14f4 +1515 +152d +154b +154d +1559 +1566 +156e +1573 +1579 +1583 +1589 +158d +1593 +159a +159e +15a4 +15ac +15b3 +15b7 +15bb +15bf +15c3 +15c9 +15cf +15d5 +15e1 +15e7 +15ed +15f4 +15fa +1600 +1607 +160d +1613 +161b +1621 +1627 +162d +1633 +1639 +163f +1645 +164d +1653 +1659 +1660 +1666 +166c +1675 +30a1 30a2 +30ab 30ac +30b5 30b6 +30bf 30c0 +30ca +30cf 30d1 +30de +30e3 30e4 +30e9 +30ee 30ef +30f5 +30f7 +32d0 +32d5 +32da +32df +32e4 +32e9 +32ee +32f3 +32f6 +32fb +ff67 +ff6c +ff71 +ff76 +ff7b +ff80 +ff85 +ff8a +ff8f +ff94 +ff97 +ff9c +3041 3042 +304b 304c +3055 3056 +305f 3060 +306a +306f 3071 +307e +3083 3084 +3089 +308e 308f END diff --git a/contrib/perl5/lib/unicode/Is/SylC.pl b/contrib/perl5/lib/unicode/Is/SylC.pl index ec287c456ab2..fb8b08e300fe 100644 --- a/contrib/perl5/lib/unicode/Is/SylC.pl +++ b/contrib/perl5/lib/unicode/Is/SylC.pl @@ -1,5 +1,70 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; +1205 +120d +1215 +121d +1225 +122d +1235 +123d +1245 +1255 +1265 +126d +1275 +127d +1285 +1295 +129d +12a5 +12ad +12bd +12cd +12d5 +12dd +12e5 +12ed +12f5 +12fd +1305 +130d +131d +1325 +132d +1335 +133d +1345 +134d +1355 +13c0 +13cd +141d +142b 142e +1449 144b +1466 +1483 +1485 1488 +14a1 +14bb 14bf +14d0 14d2 +14ea 14ec +1505 1506 +1508 150b +1525 +153e 1540 +1550 1552 +155d +156a +156f +157b 157d +1585 +1595 1596 +159f +15a6 +15ae 15af +30f3 +ff9d END diff --git a/contrib/perl5/lib/unicode/Is/SylE.pl b/contrib/perl5/lib/unicode/Is/SylE.pl index ec287c456ab2..d762748c69a3 100644 --- a/contrib/perl5/lib/unicode/Is/SylE.pl +++ b/contrib/perl5/lib/unicode/Is/SylE.pl @@ -1,5 +1,147 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; +1204 +120c +1214 +121c +1224 +122c +1234 +123c +1244 +1254 +1264 +126c +1274 +127c +1284 +1294 +129c +12a4 +12ac +12bc +12cc +12d4 +12dc +12e4 +12ec +12f4 +12fc +1304 +130c +131c +1324 +132c +1334 +133c +1344 +134c +1354 +13a1 +13a8 +13ae +13b4 +13ba +13c1 +13c7 +13ce +13d5 13d6 +13de +13e4 +13ea +13f0 +1401 +142f +144c +1467 +146b +1489 +14a3 +14c0 +14d3 +14ed +1510 +1526 +1542 1544 +1553 +155e 155f +156b +1570 +1574 +1586 +158a +1597 +159b +15a7 +15b0 +15b4 +15b8 +15bc +15c0 +15c6 +15cc +15d2 +15de +15e4 +15ea +15f1 +15f7 +15fd +1604 +160a +1610 +1617 +161e +1624 +162a +1630 +1636 +163c +1642 +164a +1650 +1656 +165d +1663 +1669 +30a7 30a8 +30b1 30b2 +30bb 30bc +30c6 30c7 +30cd +30d8 30da +30e1 +30ec +30f1 +30f6 +30f9 +32d3 +32d8 +32dd +32e2 +32e7 +32ec +32f1 +32f9 +32fd +ff6a +ff74 +ff79 +ff7e +ff83 +ff88 +ff8d +ff92 +ff9a +3047 3048 +3051 3052 +305b 305c +3066 3067 +306d +3078 307a +3081 +308c +3091 END diff --git a/contrib/perl5/lib/unicode/Is/SylI.pl b/contrib/perl5/lib/unicode/Is/SylI.pl index ec287c456ab2..29bc70f4fa5d 100644 --- a/contrib/perl5/lib/unicode/Is/SylI.pl +++ b/contrib/perl5/lib/unicode/Is/SylI.pl @@ -1,5 +1,154 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; +1202 +120a +1212 +121a +1222 +122a +1232 +123a +1242 +1252 +1262 +126a +1272 +127a +1282 +1292 +129a +12a2 +12aa +12ba +12ca +12d2 +12da +12e2 +12ea +12f2 +12fa +1302 +130a +131a +1322 +132a +1332 +133a +1342 +134a +1352 +13a2 +13a9 +13af +13b5 +13bb +13c2 +13c8 +13cf +13d7 13d8 +13df +13e5 +13eb +13f1 +1403 +1409 +1431 +1437 +144e +1454 +1468 +146d +148b +14a5 +14c2 +14d5 +14ef +1511 +1528 +1541 +1546 +1555 +1560 1561 +156c +1571 +1575 +157f +1587 +158b +158f +1598 +159c +15a0 +15a8 +15b1 +15b5 +15b9 +15bd +15c1 +15c8 +15ce +15d4 +15e0 +15e6 +15ec +15f3 +15f9 +15ff +1606 +160c +1612 +1619 161a +1620 +1626 +162c +1632 +1638 +163e +1644 +164c +1652 +1658 +165f +1665 +166b +1671 +30a3 30a4 +30ad 30ae +30b7 30b8 +30c1 30c2 +30cb +30d2 30d4 +30df +30ea +30f0 +30f8 +32d1 +32d6 +32db +32e0 +32e5 +32ea +32ef +32f7 +32fc +ff68 +ff72 +ff77 +ff7c +ff81 +ff86 +ff8b +ff90 +ff98 +3043 3044 +304d 304e +3057 3058 +3061 3062 +306b +3072 3074 +307f +308a +3090 END diff --git a/contrib/perl5/lib/unicode/Is/SylO.pl b/contrib/perl5/lib/unicode/Is/SylO.pl index ec287c456ab2..2c795f0291b2 100644 --- a/contrib/perl5/lib/unicode/Is/SylO.pl +++ b/contrib/perl5/lib/unicode/Is/SylO.pl @@ -1,5 +1,157 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; +1206 +120e +1216 +121e +1226 +122e +1236 +123e +1246 +1256 +1266 +126e +1276 +127e +1286 +1296 +129e +12a6 +12ae +12be +12ce +12d6 +12de +12e6 +12ee +12f6 +12fe +1306 +130e +131e +1326 +132e +1336 +133e +1346 +134e +1356 +13a3 +13aa +13b0 +13b6 +13bc +13c3 +13c9 +13d0 +13d9 +13e0 +13e6 +13ec +13f2 +1405 +1433 +1450 +1469 +146f +148d +14a7 +14c4 +14d7 +14f1 +1513 +152a +1548 +154a +1557 +1564 +156d +1572 +1577 +1581 +1588 +158c +1591 +1599 +159d +15a2 +15aa +15b2 +15b6 +15ba +15be +15c2 +15c5 +15cb +15d1 +15dd +15e3 +15e9 +15f0 +15f6 +15fc +1603 +1609 +160f +1616 +161d +1623 +1629 +162f +1635 +163b +1641 +1649 +164f +1655 +165c +1662 +1668 +1673 +30a9 30aa +30b3 30b4 +30bd 30be +30c8 30c9 +30ce +30db 30dd +30e2 +30e7 30e8 +30ed +30f2 +30fa +32d4 +32d9 +32de +32e3 +32e8 +32ed +32f2 +32f5 +32fa +32fe +ff66 +ff6b +ff6e +ff75 +ff7a +ff7f +ff84 +ff89 +ff8e +ff93 +ff96 +ff9b +3049 304a +3053 3054 +305d 305e +3068 3069 +306e +307b 307d +3082 +3087 3088 +308d +3092 END diff --git a/contrib/perl5/lib/unicode/Is/SylU.pl b/contrib/perl5/lib/unicode/Is/SylU.pl index ec287c456ab2..117d981ee6c0 100644 --- a/contrib/perl5/lib/unicode/Is/SylU.pl +++ b/contrib/perl5/lib/unicode/Is/SylU.pl @@ -1,5 +1,122 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; +1201 +1209 +1211 +1219 +1221 +1229 +1231 +1239 +1241 +1251 +1261 +1269 +1271 +1279 +1281 +1291 +1299 +12a1 +12a9 +12b9 +12c9 +12d1 +12d9 +12e1 +12e9 +12f1 +12f9 +1301 +1309 +1319 +1321 +1329 +1331 +1339 +1341 +1349 +1351 +13a4 +13ab +13b1 +13b7 +13bd +13c4 +13ca +13d1 +13da +13e1 +13e7 +13ed +13f3 +15c4 +15ca +15d0 +15dc +15e2 +15e8 +15ef +15f5 +15fb +1602 +1608 +160e +1614 1615 +161c +1622 +1628 +162e +1634 +163a +1640 +1648 +164e +1654 +165b +1661 +1667 +30a5 30a6 +30af 30b0 +30b9 30ba +30c3 30c5 +30cc +30d5 30d7 +30e0 +30e5 30e6 +30eb +30f4 +32d2 +32d7 +32dc +32e1 +32e6 +32eb +32f0 +32f4 +32f8 +ff69 +ff6d +ff6f +ff73 +ff78 +ff7d +ff82 +ff87 +ff8c +ff91 +ff95 +ff99 +3045 3046 +304f 3050 +3059 305a +3063 3065 +306c +3075 3077 +3080 +3085 3086 +308b +3094 END diff --git a/contrib/perl5/lib/unicode/Is/SylV.pl b/contrib/perl5/lib/unicode/Is/SylV.pl index ec287c456ab2..e5a39ed65458 100644 --- a/contrib/perl5/lib/unicode/Is/SylV.pl +++ b/contrib/perl5/lib/unicode/Is/SylV.pl @@ -1,5 +1,54 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; +1200 +1208 +1210 +1218 +1220 +1228 +1230 +1238 +1240 +1250 +1260 +1268 +1270 +1278 +1280 +1290 +1298 +12a0 +12a8 +12b8 +12c8 +12d0 +12d8 +12e0 +12e8 +12f0 +12f8 +1300 +1308 +1318 +1320 +1328 +1330 +1338 +1340 +1348 +1350 +13a5 +13ac +13b2 +13b8 +13c5 +13cb +13d2 +13db +13e2 +13e8 +13ee +13f4 END diff --git a/contrib/perl5/lib/unicode/Is/SylWA.pl b/contrib/perl5/lib/unicode/Is/SylWA.pl index ec287c456ab2..39e94caabe04 100644 --- a/contrib/perl5/lib/unicode/Is/SylWA.pl +++ b/contrib/perl5/lib/unicode/Is/SylWA.pl @@ -1,5 +1,49 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; +120f +1217 +121f +1227 +122f +1237 +123f +124b +125b +1267 +126f +1277 +127f +128b +1297 +129f +12a7 +12b3 +12c3 +12df +12e7 +12f7 +12ff +1307 +1313 +1327 +132f +1337 +133f +134f +1357 +1417 1418 +1444 1445 +1461 1462 +147e 147f +149c 149d +14b6 14b7 +14cb 14cc +14e6 14e7 +1500 1501 +150c 150f +1521 1522 +1539 153a +15db END diff --git a/contrib/perl5/lib/unicode/Is/SylWC.pl b/contrib/perl5/lib/unicode/Is/SylWC.pl index ec287c456ab2..4272b8934f0b 100644 --- a/contrib/perl5/lib/unicode/Is/SylWC.pl +++ b/contrib/perl5/lib/unicode/Is/SylWC.pl @@ -1,5 +1,13 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; +124d +125d +128d +12b5 +12c5 +1315 +1484 +1507 END diff --git a/contrib/perl5/lib/unicode/Is/SylWE.pl b/contrib/perl5/lib/unicode/Is/SylWE.pl index ec287c456ab2..c4c5ba99aee1 100644 --- a/contrib/perl5/lib/unicode/Is/SylWE.pl +++ b/contrib/perl5/lib/unicode/Is/SylWE.pl @@ -1,5 +1,23 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; +124c +125c +128c +12b4 +12c4 +1314 +140c 140d +143a 143b +1457 1458 +1474 1475 +1492 1493 +14ac 14ad +14c9 14ca +14dc 14dd +14f6 14f7 +1517 1518 +152f 1530 +15d8 END diff --git a/contrib/perl5/lib/unicode/Is/SylWI.pl b/contrib/perl5/lib/unicode/Is/SylWI.pl index ec287c456ab2..c914b07a5677 100644 --- a/contrib/perl5/lib/unicode/Is/SylWI.pl +++ b/contrib/perl5/lib/unicode/Is/SylWI.pl @@ -1,5 +1,22 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; +124a +125a +128a +12b2 +12c2 +1312 +140e 140f +143c 143d +1459 145a +1476 1477 +1494 1495 +14ae 14af +14de 14df +14f8 14f9 +1519 151a +1531 1532 +15da END diff --git a/contrib/perl5/lib/unicode/Is/SylWV.pl b/contrib/perl5/lib/unicode/Is/SylWV.pl index ec287c456ab2..6a06ae908764 100644 --- a/contrib/perl5/lib/unicode/Is/SylWV.pl +++ b/contrib/perl5/lib/unicode/Is/SylWV.pl @@ -1,5 +1,11 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; +1248 +1258 +1288 +12b0 +12c0 +1310 END diff --git a/contrib/perl5/lib/unicode/Is/Upper.pl b/contrib/perl5/lib/unicode/Is/Upper.pl index 8dde2742d0a4..16f875241d58 100644 --- a/contrib/perl5/lib/unicode/Is/Upper.pl +++ b/contrib/perl5/lib/unicode/Is/Upper.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0041 005a @@ -86,9 +86,9 @@ return <<'END'; 01b5 01b7 01b8 01bc -01c4 -01c7 -01ca +01c4 01c5 +01c7 01c8 +01ca 01cb 01cd 01cf 01d1 @@ -106,7 +106,7 @@ return <<'END'; 01ea 01ec 01ee -01f1 +01f1 01f2 01f4 01f6 01f8 01fa @@ -355,11 +355,14 @@ return <<'END'; 1f5d 1f5f 1f68 1f6f -1fb8 1fbb -1fc8 1fcb +1f88 1f8f +1f98 1f9f +1fa8 1faf +1fb8 1fbc +1fc8 1fcc 1fd8 1fdb 1fe8 1fec -1ff8 1ffb +1ff8 1ffc 2102 2107 210b 210d diff --git a/contrib/perl5/lib/unicode/Is/Word.pl b/contrib/perl5/lib/unicode/Is/Word.pl index 23186bd27d92..6ea32e6099d2 100644 --- a/contrib/perl5/lib/unicode/Is/Word.pl +++ b/contrib/perl5/lib/unicode/Is/Word.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0030 0039 @@ -7,17 +7,23 @@ return <<'END'; 005f 0061 007a 00aa +00b2 00b3 00b5 -00ba +00b9 00ba +00bc 00be 00c0 00d6 00d8 00f6 -00f8 01c4 -01c6 01c7 -01c9 01ca -01cc 01f1 -01f3 021f +00f8 021f 0222 0233 0250 02ad +02b0 02b8 +02bb 02c1 +02d0 02d1 +02e0 02e4 +02ee +0300 034e +0360 0362 +037a 0386 0388 038a 038c @@ -26,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 @@ -65,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 @@ -76,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 @@ -100,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 @@ -142,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 @@ -188,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 @@ -211,20 +282,20 @@ return <<'END'; 1f5b 1f5d 1f5f 1f7d -1f80 1f87 -1f90 1f97 -1fa0 1fa7 -1fb0 1fb4 -1fb6 1fbb +1f80 1fb4 +1fb6 1fbc 1fbe 1fc2 1fc4 -1fc6 1fcb +1fc6 1fcc 1fd0 1fd3 1fd6 1fdb 1fe0 1fec 1ff2 1ff4 -1ff6 1ffb -207f +1ff6 1ffc +2070 +2074 2079 +207f 2089 +20d0 20e3 2102 2107 210a 2113 @@ -236,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 @@ -249,8 +333,7 @@ ac00 d7a3 f900 fa2d fb00 fb06 fb13 fb17 -fb1d -fb1f fb28 +fb1d fb28 fb2a fb36 fb38 fb3c fb3e @@ -261,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/contrib/perl5/lib/unicode/Is/XDigit.pl b/contrib/perl5/lib/unicode/Is/XDigit.pl index e55682500b27..b26a3b40747f 100644 --- a/contrib/perl5/lib/unicode/Is/XDigit.pl +++ b/contrib/perl5/lib/unicode/Is/XDigit.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0030 0039 diff --git a/contrib/perl5/lib/unicode/Is/Z.pl b/contrib/perl5/lib/unicode/Is/Z.pl index 22a9792d4f50..03416c026527 100644 --- a/contrib/perl5/lib/unicode/Is/Z.pl +++ b/contrib/perl5/lib/unicode/Is/Z.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0020 diff --git a/contrib/perl5/lib/unicode/Is/Zl.pl b/contrib/perl5/lib/unicode/Is/Zl.pl index 0989e1d9205d..5f127ce33ab9 100644 --- a/contrib/perl5/lib/unicode/Is/Zl.pl +++ b/contrib/perl5/lib/unicode/Is/Zl.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2028 diff --git a/contrib/perl5/lib/unicode/Is/Zp.pl b/contrib/perl5/lib/unicode/Is/Zp.pl index 3b23446fe9e9..4e38303e722f 100644 --- a/contrib/perl5/lib/unicode/Is/Zp.pl +++ b/contrib/perl5/lib/unicode/Is/Zp.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 2029 diff --git a/contrib/perl5/lib/unicode/Is/Zs.pl b/contrib/perl5/lib/unicode/Is/Zs.pl index db18055ea437..56cf9e46622e 100644 --- a/contrib/perl5/lib/unicode/Is/Zs.pl +++ b/contrib/perl5/lib/unicode/Is/Zs.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0020 diff --git a/contrib/perl5/lib/unicode/Jamo.txt b/contrib/perl5/lib/unicode/Jamo.txt index 6910ab924ea8..ea288f03976b 100644 --- a/contrib/perl5/lib/unicode/Jamo.txt +++ b/contrib/perl5/lib/unicode/Jamo.txt @@ -1,69 +1,91 @@ -#Value; Short Name; Unicode Name -U+1100; G; HANGUL CHOSEONG KIYEOK -U+1101; GG; HANGUL CHOSEONG SSANGKIYEOK -U+1102; N; HANGUL CHOSEONG NIEUN -U+1103; D; HANGUL CHOSEONG TIKEUT -U+1104; DD; HANGUL CHOSEONG SSANGTIKEUT -U+1105; R; HANGUL CHOSEONG RIEUL -U+1106; M; HANGUL CHOSEONG MIEUM -U+1107; B; HANGUL CHOSEONG PIEUP -U+1108; BB; HANGUL CHOSEONG SSANGPIEUP -U+1109; S; HANGUL CHOSEONG SIOS -U+110A; SS; HANGUL CHOSEONG SSANGSIOS -U+110B; ; HANGUL CHOSEONG IEUNG -U+110C; J; HANGUL CHOSEONG CIEUC -U+110D; JJ; HANGUL CHOSEONG SSANGCIEUC -U+110E; C; HANGUL CHOSEONG CHIEUCH -U+110F; K; HANGUL CHOSEONG KHIEUKH -U+1110; T; HANGUL CHOSEONG THIEUTH -U+1111; P; HANGUL CHOSEONG PHIEUPH -U+1112; H; HANGUL CHOSEONG HIEUH -U+1161; A; HANGUL JUNGSEONG A -U+1162; AE; HANGUL JUNGSEONG AE -U+1163; YA; HANGUL JUNGSEONG YA -U+1164; YAE; HANGUL JUNGSEONG YAE -U+1165; EO; HANGUL JUNGSEONG EO -U+1166; E; HANGUL JUNGSEONG E -U+1167; YEO; HANGUL JUNGSEONG YEO -U+1168; YE; HANGUL JUNGSEONG YE -U+1169; O; HANGUL JUNGSEONG O -U+116A; WA; HANGUL JUNGSEONG WA -U+116B; WAE; HANGUL JUNGSEONG WAE -U+116C; OE; HANGUL JUNGSEONG OE -U+116D; YO; HANGUL JUNGSEONG YO -U+116E; U; HANGUL JUNGSEONG U -U+116F; WEO; HANGUL JUNGSEONG WEO -U+1170; WE; HANGUL JUNGSEONG WE -U+1171; WI; HANGUL JUNGSEONG WI -U+1172; YU; HANGUL JUNGSEONG YU -U+1173; EU; HANGUL JUNGSEONG EU -U+1174; YI; HANGUL JUNGSEONG YI -U+1175; I; HANGUL JUNGSEONG I -U+11A8; G; HANGUL JONGSEONG KIYEOK -U+11A9; GG; HANGUL JONGSEONG SSANGKIYEOK -U+11AA; GS; HANGUL JONGSEONG KIYEOK-SIOS -U+11AB; N; HANGUL JONGSEONG NIEUN -U+11AC; NJ; HANGUL JONGSEONG NIEUN-CIEUC -U+11AD; NH; HANGUL JONGSEONG NIEUN-HIEUH -U+11AE; D; HANGUL JONGSEONG TIKEUT -U+11AF; L; HANGUL JONGSEONG RIEUL -U+11B0; LG; HANGUL JONGSEONG RIEUL-KIYEOK -U+11B1; LM; HANGUL JONGSEONG RIEUL-MIEUM -U+11B2; LB; HANGUL JONGSEONG RIEUL-PIEUP -U+11B3; LS; HANGUL JONGSEONG RIEUL-SIOS -U+11B4; LT; HANGUL JONGSEONG RIEUL-THIEUTH -U+11B5; LP; HANGUL JONGSEONG RIEUL-PHIEUPH -U+11B6; LH; HANGUL JONGSEONG RIEUL-HIEUH -U+11B7; M; HANGUL JONGSEONG MIEUM -U+11B8; B; HANGUL JONGSEONG PIEUP -U+11B9; BS; HANGUL JONGSEONG PIEUP-SIOS -U+11BA; S; HANGUL JONGSEONG SIOS -U+11BB; SS; HANGUL JONGSEONG SSANGSIOS -U+11BC; NG; HANGUL JONGSEONG IEUNG -U+11BD; J; HANGUL JONGSEONG CIEUC -U+11BE; C; HANGUL JONGSEONG CHIEUCH -U+11BF; K; HANGUL JONGSEONG KHIEUKH -U+11C0; T; HANGUL JONGSEONG THIEUTH -U+11C1; P; HANGUL JONGSEONG PHIEUPH -U+11C2; H; HANGUL JONGSEONG HIEUH +# Jamo-3.txt +# +# This file is a normative contributory data file in the +# Unicode Character Database. +# +# This file defines the Jamo Short Name property, repeating +# in machine readable form the information printed in Table 4-4 +# of The Unicode Standard, Version 3.0. +# +# See sections 3.11 and 4.4 of The Unicode Standard, Version 3.0 +# for more information. +# +# Each line contains two fields, separated by a semicolon. +# +# The first field gives the code point, in 4-digit hexadecimal +# form, of a combining jamo character that participates in +# the algorithmic determination Hangul syllable character names. +# The second field gives the Jamo Short Name as a one-, two-, +# or three-character ASCII string (or in one case, for U+110B, +# the null string). +# +# ############################################################# + +1100; G # HANGUL CHOSEONG KIYEOK +1101; GG # HANGUL CHOSEONG SSANGKIYEOK +1102; N # HANGUL CHOSEONG NIEUN +1103; D # HANGUL CHOSEONG TIKEUT +1104; DD # HANGUL CHOSEONG SSANGTIKEUT +1105; R # HANGUL CHOSEONG RIEUL +1106; M # HANGUL CHOSEONG MIEUM +1107; B # HANGUL CHOSEONG PIEUP +1108; BB # HANGUL CHOSEONG SSANGPIEUP +1109; S # HANGUL CHOSEONG SIOS +110A; SS # HANGUL CHOSEONG SSANGSIOS +110B; # HANGUL CHOSEONG IEUNG +110C; J # HANGUL CHOSEONG CIEUC +110D; JJ # HANGUL CHOSEONG SSANGCIEUC +110E; C # HANGUL CHOSEONG CHIEUCH +110F; K # HANGUL CHOSEONG KHIEUKH +1110; T # HANGUL CHOSEONG THIEUTH +1111; P # HANGUL CHOSEONG PHIEUPH +1112; H # HANGUL CHOSEONG HIEUH +1161; A # HANGUL JUNGSEONG A +1162; AE # HANGUL JUNGSEONG AE +1163; YA # HANGUL JUNGSEONG YA +1164; YAE # HANGUL JUNGSEONG YAE +1165; EO # HANGUL JUNGSEONG EO +1166; E # HANGUL JUNGSEONG E +1167; YEO # HANGUL JUNGSEONG YEO +1168; YE # HANGUL JUNGSEONG YE +1169; O # HANGUL JUNGSEONG O +116A; WA # HANGUL JUNGSEONG WA +116B; WAE # HANGUL JUNGSEONG WAE +116C; OE # HANGUL JUNGSEONG OE +116D; YO # HANGUL JUNGSEONG YO +116E; U # HANGUL JUNGSEONG U +116F; WEO # HANGUL JUNGSEONG WEO +1170; WE # HANGUL JUNGSEONG WE +1171; WI # HANGUL JUNGSEONG WI +1172; YU # HANGUL JUNGSEONG YU +1173; EU # HANGUL JUNGSEONG EU +1174; YI # HANGUL JUNGSEONG YI +1175; I # HANGUL JUNGSEONG I +11A8; G # HANGUL JONGSEONG KIYEOK +11A9; GG # HANGUL JONGSEONG SSANGKIYEOK +11AA; GS # HANGUL JONGSEONG KIYEOK-SIOS +11AB; N # HANGUL JONGSEONG NIEUN +11AC; NJ # HANGUL JONGSEONG NIEUN-CIEUC +11AD; NH # HANGUL JONGSEONG NIEUN-HIEUH +11AE; D # HANGUL JONGSEONG TIKEUT +11AF; L # HANGUL JONGSEONG RIEUL +11B0; LG # HANGUL JONGSEONG RIEUL-KIYEOK +11B1; LM # HANGUL JONGSEONG RIEUL-MIEUM +11B2; LB # HANGUL JONGSEONG RIEUL-PIEUP +11B3; LS # HANGUL JONGSEONG RIEUL-SIOS +11B4; LT # HANGUL JONGSEONG RIEUL-THIEUTH +11B5; LP # HANGUL JONGSEONG RIEUL-PHIEUPH +11B6; LH # HANGUL JONGSEONG RIEUL-HIEUH +11B7; M # HANGUL JONGSEONG MIEUM +11B8; B # HANGUL JONGSEONG PIEUP +11B9; BS # HANGUL JONGSEONG PIEUP-SIOS +11BA; S # HANGUL JONGSEONG SIOS +11BB; SS # HANGUL JONGSEONG SSANGSIOS +11BC; NG # HANGUL JONGSEONG IEUNG +11BD; J # HANGUL JONGSEONG CIEUC +11BE; C # HANGUL JONGSEONG CHIEUCH +11BF; K # HANGUL JONGSEONG KHIEUKH +11C0; T # HANGUL JONGSEONG THIEUTH +11C1; P # HANGUL JONGSEONG PHIEUPH +11C2; H # HANGUL JONGSEONG HIEUH diff --git a/contrib/perl5/lib/unicode/JamoShort.pl b/contrib/perl5/lib/unicode/JamoShort.pl index 760bcba03e30..19cd4290c621 100644 --- a/contrib/perl5/lib/unicode/JamoShort.pl +++ b/contrib/perl5/lib/unicode/JamoShort.pl @@ -1,72 +1,72 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; -1100 G -1101 GG -1102 N -1103 D -1104 DD -1105 R -1106 M -1107 B -1108 BB -1109 S -110a SS -110b -110c J -110d JJ -110e C -110f K -1110 T -1111 P -1112 H -1161 A -1162 AE -1163 YA -1164 YAE -1165 EO -1166 E -1167 YEO -1168 YE -1169 O -116a WA -116b WAE -116c OE -116d YO -116e U -116f WEO -1170 WE -1171 WI -1172 YU -1173 EU -1174 YI -1175 I -11a8 G -11a9 GG -11aa GS -11ab N -11ac NJ -11ad NH -11ae D -11af L -11b0 LG -11b1 LM -11b2 LB -11b3 LS -11b4 LT -11b5 LP -11b6 LH -11b7 M -11b8 B -11b9 BS -11ba S -11bb SS -11bc NG -11bd J -11be C -11bf K -11c0 T -11c1 P -11c2 H +1100 G # HANGUL CHOSEONG KIYEOK +1101 GG # HANGUL CHOSEONG SSANGKIYEOK +1102 N # HANGUL CHOSEONG NIEUN +1103 D # HANGUL CHOSEONG TIKEUT +1104 DD # HANGUL CHOSEONG SSANGTIKEUT +1105 R # HANGUL CHOSEONG RIEUL +1106 M # HANGUL CHOSEONG MIEUM +1107 B # HANGUL CHOSEONG PIEUP +1108 BB # HANGUL CHOSEONG SSANGPIEUP +1109 S # HANGUL CHOSEONG SIOS +110a SS # HANGUL CHOSEONG SSANGSIOS +110b # HANGUL CHOSEONG IEUNG +110c J # HANGUL CHOSEONG CIEUC +110d JJ # HANGUL CHOSEONG SSANGCIEUC +110e C # HANGUL CHOSEONG CHIEUCH +110f K # HANGUL CHOSEONG KHIEUKH +1110 T # HANGUL CHOSEONG THIEUTH +1111 P # HANGUL CHOSEONG PHIEUPH +1112 H # HANGUL CHOSEONG HIEUH +1161 A # HANGUL JUNGSEONG A +1162 AE # HANGUL JUNGSEONG AE +1163 YA # HANGUL JUNGSEONG YA +1164 YAE # HANGUL JUNGSEONG YAE +1165 EO # HANGUL JUNGSEONG EO +1166 E # HANGUL JUNGSEONG E +1167 YEO # HANGUL JUNGSEONG YEO +1168 YE # HANGUL JUNGSEONG YE +1169 O # HANGUL JUNGSEONG O +116a WA # HANGUL JUNGSEONG WA +116b WAE # HANGUL JUNGSEONG WAE +116c OE # HANGUL JUNGSEONG OE +116d YO # HANGUL JUNGSEONG YO +116e U # HANGUL JUNGSEONG U +116f WEO # HANGUL JUNGSEONG WEO +1170 WE # HANGUL JUNGSEONG WE +1171 WI # HANGUL JUNGSEONG WI +1172 YU # HANGUL JUNGSEONG YU +1173 EU # HANGUL JUNGSEONG EU +1174 YI # HANGUL JUNGSEONG YI +1175 I # HANGUL JUNGSEONG I +11a8 G # HANGUL JONGSEONG KIYEOK +11a9 GG # HANGUL JONGSEONG SSANGKIYEOK +11aa GS # HANGUL JONGSEONG KIYEOK-SIOS +11ab N # HANGUL JONGSEONG NIEUN +11ac NJ # HANGUL JONGSEONG NIEUN-CIEUC +11ad NH # HANGUL JONGSEONG NIEUN-HIEUH +11ae D # HANGUL JONGSEONG TIKEUT +11af L # HANGUL JONGSEONG RIEUL +11b0 LG # HANGUL JONGSEONG RIEUL-KIYEOK +11b1 LM # HANGUL JONGSEONG RIEUL-MIEUM +11b2 LB # HANGUL JONGSEONG RIEUL-PIEUP +11b3 LS # HANGUL JONGSEONG RIEUL-SIOS +11b4 LT # HANGUL JONGSEONG RIEUL-THIEUTH +11b5 LP # HANGUL JONGSEONG RIEUL-PHIEUPH +11b6 LH # HANGUL JONGSEONG RIEUL-HIEUH +11b7 M # HANGUL JONGSEONG MIEUM +11b8 B # HANGUL JONGSEONG PIEUP +11b9 BS # HANGUL JONGSEONG PIEUP-SIOS +11ba S # HANGUL JONGSEONG SIOS +11bb SS # HANGUL JONGSEONG SSANGSIOS +11bc NG # HANGUL JONGSEONG IEUNG +11bd J # HANGUL JONGSEONG CIEUC +11be C # HANGUL JONGSEONG CHIEUCH +11bf K # HANGUL JONGSEONG KHIEUKH +11c0 T # HANGUL JONGSEONG THIEUTH +11c1 P # HANGUL JONGSEONG PHIEUPH +11c2 H # HANGUL JONGSEONG HIEUH END diff --git a/contrib/perl5/lib/unicode/Makefile b/contrib/perl5/lib/unicode/Makefile index c68fa3af00f3..af5e77b47bae 100644 --- a/contrib/perl5/lib/unicode/Makefile +++ b/contrib/perl5/lib/unicode/Makefile @@ -1,6 +1,5 @@ all: - ./mktables.PL - ./MakeEthiopicSyllables.PL + ../../miniperl -I../../lib ./mktables.PL clean: rm -f *.pl */*.pl diff --git a/contrib/perl5/lib/unicode/Name.pl b/contrib/perl5/lib/unicode/Name.pl index ef8979f0d133..f5c4c56f21c3 100644 --- a/contrib/perl5/lib/unicode/Name.pl +++ b/contrib/perl5/lib/unicode/Name.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0000 001f <control> @@ -10549,4 +10549,6 @@ fffa INTERLINEAR ANNOTATION SEPARATOR fffb INTERLINEAR ANNOTATION TERMINATOR fffc OBJECT REPLACEMENT CHARACTER fffd REPLACEMENT CHARACTER +f0000 ffffd <Plane 15 Private Use, First> +100000 10fffd <Plane 16 Private Use, First> END diff --git a/contrib/perl5/lib/unicode/Number.pl b/contrib/perl5/lib/unicode/Number.pl index b0e054a0d06d..1f5c2c84c7e4 100644 --- a/contrib/perl5/lib/unicode/Number.pl +++ b/contrib/perl5/lib/unicode/Number.pl @@ -1,7 +1,8 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; +0030 0 0031 1 0032 2 0033 3 @@ -17,6 +18,7 @@ return <<'END'; 00bc 1/4 00bd 1/2 00be 3/4 +0660 0 0661 1 0662 2 0663 3 @@ -26,6 +28,7 @@ return <<'END'; 0667 7 0668 8 0669 9 +06f0 0 06f1 1 06f2 2 06f3 3 @@ -35,6 +38,7 @@ return <<'END'; 06f7 7 06f8 8 06f9 9 +0966 0 0967 1 0968 2 0969 3 @@ -44,6 +48,7 @@ return <<'END'; 096d 7 096e 8 096f 9 +09e6 0 09e7 1 09e8 2 09e9 3 @@ -58,6 +63,7 @@ return <<'END'; 09f6 3 09f7 4 09f9 16 +0a66 0 0a67 1 0a68 2 0a69 3 @@ -67,6 +73,7 @@ return <<'END'; 0a6d 7 0a6e 8 0a6f 9 +0ae6 0 0ae7 1 0ae8 2 0ae9 3 @@ -76,6 +83,7 @@ return <<'END'; 0aed 7 0aee 8 0aef 9 +0b66 0 0b67 1 0b68 2 0b69 3 @@ -97,6 +105,7 @@ return <<'END'; 0bf0 10 0bf1 100 0bf2 1000 +0c66 0 0c67 1 0c68 2 0c69 3 @@ -106,6 +115,7 @@ return <<'END'; 0c6d 7 0c6e 8 0c6f 9 +0ce6 0 0ce7 1 0ce8 2 0ce9 3 @@ -115,6 +125,7 @@ return <<'END'; 0ced 7 0cee 8 0cef 9 +0d66 0 0d67 1 0d68 2 0d69 3 @@ -124,6 +135,7 @@ return <<'END'; 0d6d 7 0d6e 8 0d6f 9 +0e50 0 0e51 1 0e52 2 0e53 3 @@ -133,6 +145,7 @@ return <<'END'; 0e57 7 0e58 8 0e59 9 +0ed0 0 0ed1 1 0ed2 2 0ed3 3 @@ -142,6 +155,7 @@ return <<'END'; 0ed7 7 0ed8 8 0ed9 9 +0f20 0 0f21 1 0f22 2 0f23 3 @@ -151,6 +165,17 @@ return <<'END'; 0f27 7 0f28 8 0f29 9 +0f2a 1/2 +0f2b 3/2 +0f2c 5/2 +0f2d 7/2 +0f2e 9/2 +0f2f 11/2 +0f30 13/2 +0f31 15/2 +0f32 17/2 +0f33 -1/2 +1040 0 1041 1 1042 2 1043 3 @@ -183,6 +208,7 @@ return <<'END'; 16ee 17 16ef 18 16f0 19 +17e0 0 17e1 1 17e2 2 17e3 3 @@ -192,6 +218,7 @@ return <<'END'; 17e7 7 17e8 8 17e9 9 +1810 0 1811 1 1812 2 1813 3 @@ -201,12 +228,14 @@ return <<'END'; 1817 7 1818 8 1819 9 +2070 0 2074 4 2075 5 2076 6 2077 7 2078 8 2079 9 +2080 0 2081 1 2082 2 2083 3 @@ -322,6 +351,7 @@ return <<'END'; 2499 18 249a 19 249b 20 +24ea 0 2776 1 2777 2 2778 3 @@ -352,6 +382,7 @@ return <<'END'; 2791 8 2792 9 2793 10 +3007 0 3021 1 3022 2 3023 3 @@ -364,6 +395,20 @@ return <<'END'; 3038 10 3039 20 303a 30 +3192 1 +3193 2 +3194 3 +3195 4 +3220 1 +3221 2 +3222 3 +3223 4 +3224 5 +3225 6 +3226 7 +3227 8 +3228 9 +3229 10 3280 1 3281 2 3282 3 @@ -374,6 +419,7 @@ return <<'END'; 3287 8 3288 9 3289 10 +ff10 0 ff11 1 ff12 2 ff13 3 diff --git a/contrib/perl5/lib/unicode/ReadMe.txt b/contrib/perl5/lib/unicode/ReadMe.txt index c2c4aee6a5d4..b8a643ca2713 100644 --- a/contrib/perl5/lib/unicode/ReadMe.txt +++ b/contrib/perl5/lib/unicode/ReadMe.txt @@ -1,45 +1,13 @@ -June 23, 1999 +August 30, 2000 -This directory contains the initial release for Unicode 3.0. +This directory contains the first update release for Unicode 3.0. This release consists of corrections and additions to the -Unicode Character Database, to match the publication of -The Unicode Standard, Version 3.0. +Unicode Character Database for the Unicode Standard, +Version 3.0.1. Detailed documentation of the files constituting the Unicode Character Database (contributory data files for the standard itself) can now be found in UnicodeCharacterDatabase.html. --------------------------------------------------------------------------- -NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE - -The files have been copied from - - ftp://ftp.unicode.org/Public/3.0-Update/ - -and most of them have been renamed to better fit 8.3 filename limitations. - -long name at unicode.org short name latest '#' ------------------------- ---------- ---------- -ArabicShaping-#.txt ArabShap.txt 2 -Blocks-#.txt Blocks.txt 3 -CompositionExclusions-#.txt CompExcl.txt 1 -EastAsianWidth-#.txt EAWidth.txt 3 -Index-#.txt Index.txt 3.0.0 -Jamo-#.txt Jamo.txt 2 -LineBreak-#.txt LineBrk.txt 5 -NamesList-#.txt Names.txt 3.0.0 -NamesList-#.html NamesList.html 1 -PropList-#.txt Props.txt 3.0.0 -SpecialCasing-#.txt SpecCase.txt 2 -UnicodeData-#.txt Unicode.300 3.0.0 -UnicodeData-#.html Unicode3.html 3.0.0 -UnicodeCharacterDatabase-#.html UCD300.html 3.0.0 - -The *.pl files are generated from these files by the 'mktables.PL' script. - -While the files have been renamed the links in the html files haven't. - --- -jhi@iki.fi diff --git a/contrib/perl5/lib/unicode/SpecCase.txt b/contrib/perl5/lib/unicode/SpecCase.txt index af002ef4cfab..94662d384f78 100644 --- a/contrib/perl5/lib/unicode/SpecCase.txt +++ b/contrib/perl5/lib/unicode/SpecCase.txt @@ -1,4 +1,4 @@ -# SpecialCasing-2.txt +# SpecialCasing-3.txt # # Special Casing Properties # @@ -26,26 +26,33 @@ # <upper> := <code_point_list> # <code_point_list> := <code_point> (<s>+ <code_point>)* # <code_point> := <hex><hex><hex><hex> -# <hex> := [0-1A-Fa-f] +# <hex> := [0-9A-Fa-f] # <s> := <space> # -# <condition_list> := <locale>? (<s>+ <context>)* -# <locale> := <ISO_3166_code> ( "_" <ISO_639_code> )? ( "_" <variant> )? +# <condition_list> := <locale>? (<s>+ <context>)* <sep> +# <locale> := <ISO_639_code> ( "_" <ISO_3166_code> )? ( "_" <variant> )? # <ISO_3166_code> := 2-letter country code, # as in http://www.unicode.org/unicode/onlinedat/countries.html # <ISO_639_code> := 2-letter code, # as in http://www.unicode.org/unicode/onlinedat/languages.html -# <context> := "FINAL" | "NON_FINAL" | "MODERN" | "NON_MODERN" +# <context> := "FINAL" | "NON_FINAL" | "MODERN" | "NON_MODERN" | "AFTER_i" +# +# A condition list overrides the normal behavior if all of the listed conditions are true. +# Case distinctions in the condition list are not significant. # -# A condition list overrides the normal behavior if any of the listed conditions is true. # FINAL: The letter is not followed by a letter of category L* (e.g. Ll, Lt, Lu, Lm, or Lo). # MODERN: The mapping is only used for modern text. +# AFTER_i: The last base character was "i" 0069 +# # Conditions preceded by "NON_" represent the negation of the condition # # New contexts may be added in the future. -# Parsers of this file must be prepared to deal with that situation. # Additional whitespace around elements is optional. Blank lines are ignored in parsing. # On any line, all text following "#" is a comment, and are ignored in parsing. +# +# Parsers of this file must be prepared to deal future additions to this format: +# * Additional contexts +# * Additional fields # ================================================================================ # ================================================================================ @@ -76,7 +83,7 @@ FB17; FB17; 0544 056D; 0544 053D; # ARMENIAN SMALL LIGATURE MEN XEH # No corresponding uppercase precomposed character -0149; 0149; 02BC 006E; 02BC 004E; # LATIN SMALL LETTER N PRECEDED BY APOSTROPHE +0149; 0149; 02BC 004E; 02BC 004E; # LATIN SMALL LETTER N PRECEDED BY APOSTROPHE 0390; 0390; 0399 0308 0301; 0399 0308 0301; # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS 03B0; 03B0; 03A5 0308 0301; 03A5 0308 0301; # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS 01F0; 01F0; 004A 030C; 004A 030C; # LATIN SMALL LETTER J WITH CARON @@ -199,7 +206,7 @@ FB17; FB17; 0544 056D; 0544 053D; # ARMENIAN SMALL LIGATURE MEN XEH # 03C3; 03C3; 03A3; 03A3; # GREEK SMALL LETTER SIGMA # 03C2; 03C2; 03A3; 03A3; # GREEK SMALL LETTER FINAL SIGMA -# Note: the following cases are not included, since they would normalize in lowercasing +# Note: the following cases are not included, since they would case-fold in lowercasing # 03C3; 03C2; 03A3; 03A3; FINAL; # GREEK SMALL LETTER SIGMA # 03C2; 03C3; 03A3; 03A3; NON_FINAL; # GREEK SMALL LETTER FINAL SIGMA @@ -208,12 +215,16 @@ FB17; FB17; 0544 056D; 0544 053D; # ARMENIAN SMALL LIGATURE MEN XEH # Locale-sensitive mappings # ================================================================================ +# Lithuanian + +0307; 0307; ; ; lt AFTER_i; # Remove DOT ABOVE after "i" with upper or titlecase + # Turkish -0049; 0131; 0049; 0049; TR; # LATIN CAPITAL LETTER I -0069; 0069; 0130; 0130; TR; # LATIN SMALL LETTER I +0049; 0131; 0049; 0049; tr; # LATIN CAPITAL LETTER I +0069; 0069; 0130; 0130; tr; # LATIN SMALL LETTER I # Note: the following cases are already in the UnicodeData file. -# 0131; 0131; 0049; 0049; TR; # LATIN SMALL LETTER DOTLESS I -# 0130; 0069; 0130; 0130; TR; # LATIN CAPITAL LETTER I WITH DOT ABOVE +# 0131; 0131; 0049; 0049; tr; # LATIN SMALL LETTER DOTLESS I +# 0130; 0069; 0130; 0130; tr; # LATIN CAPITAL LETTER I WITH DOT ABOVE diff --git a/contrib/perl5/lib/unicode/To/Digit.pl b/contrib/perl5/lib/unicode/To/Digit.pl index a96bc1c1a6a5..4bace1e66217 100644 --- a/contrib/perl5/lib/unicode/To/Digit.pl +++ b/contrib/perl5/lib/unicode/To/Digit.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0030 0039 0000 diff --git a/contrib/perl5/lib/unicode/To/Lower.pl b/contrib/perl5/lib/unicode/To/Lower.pl index a78a7e4492a8..89755b7c3a55 100644 --- a/contrib/perl5/lib/unicode/To/Lower.pl +++ b/contrib/perl5/lib/unicode/To/Lower.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0041 005a 0061 diff --git a/contrib/perl5/lib/unicode/To/Title.pl b/contrib/perl5/lib/unicode/To/Title.pl index d8f5c048d4e7..cadeaf909b0a 100644 --- a/contrib/perl5/lib/unicode/To/Title.pl +++ b/contrib/perl5/lib/unicode/To/Title.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0061 007a 0041 diff --git a/contrib/perl5/lib/unicode/To/Upper.pl b/contrib/perl5/lib/unicode/To/Upper.pl index 1fc7637753a7..d6c03d34bdca 100644 --- a/contrib/perl5/lib/unicode/To/Upper.pl +++ b/contrib/perl5/lib/unicode/To/Upper.pl @@ -1,5 +1,5 @@ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables.PL from e.g. Unicode.300. +# This file is built by mktables.PL from e.g. Unicode.301. # Any changes made here will be lost! return <<'END'; 0061 007a 0041 diff --git a/contrib/perl5/lib/unicode/mktables.PL b/contrib/perl5/lib/unicode/mktables.PL index cef6936b6802..5aca93ecef9a 100755 --- a/contrib/perl5/lib/unicode/mktables.PL +++ b/contrib/perl5/lib/unicode/mktables.PL @@ -1,28 +1,47 @@ #!../../miniperl -$UnicodeData = "Unicode.300"; +use bytes; + +$UnicodeData = "Unicode.301"; +$SyllableData = "syllables.txt"; +$PropData = "PropList.txt"; + # Note: we try to keep filenames unique within first 8 chars. Using # subdirectories for the following helps. -mkdir "In", 0777; -mkdir "Is", 0777; -mkdir "To", 0777; +mkdir "In", 0755; +mkdir "Is", 0755; +mkdir "To", 0755; @todo = ( # typical - ['IsWord', '$cat =~ /^L[ulo]|^Nd/ or $code eq "005F"', ''], - ['IsAlnum', '$cat =~ /^L[ulo]|^Nd/', ''], - ['IsAlpha', '$cat =~ /^L[ulo]/', ''], - ['IsSpace', '$cat =~ /^Z/ or $code lt "0020" and chr(hex $code) =~ /^\s/', ''], + # 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', '$code =~ /^(0020|0009)$/ || + $cat =~ /^Z[^lp]$/', ''], ['IsDigit', '$cat =~ /^Nd$/', ''], - ['IsUpper', '$cat =~ /^Lu$/', ''], + ['IsUpper', '$cat =~ /^L[ut]$/', ''], ['IsLower', '$cat =~ /^Ll$/', ''], - ['IsASCII', 'hex $code <= 127', ''], + ['IsASCII', '$code le "007f"', ''], ['IsCntrl', '$cat =~ /^C/', ''], - ['IsGraph', '$cat =~ /^[^C]/ and $code ne "0020"', ''], - ['IsPrint', '$cat =~ /^[^C]/', ''], + ['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'], @@ -42,12 +61,14 @@ mkdir "To", 0777; ['IsM', '$cat =~ /^M/', ''], # Mark ['IsMn', '$cat eq "Mn"', ''], # Mark, Non-Spacing ['IsMc', '$cat eq "Mc"', ''], # Mark, Combining + ['IsMe', '$cat eq "Me"', ''], # Mark, Enclosing ['IsN', '$cat =~ /^N/', ''], # Number ['IsNd', '$cat eq "Nd"', ''], # Number, Decimal Digit ['IsNo', '$cat eq "No"', ''], # Number, Other + ['IsNl', '$cat eq "Nl"', ''], # Number, Letter - ['IsZ', '$cat =~ /^Z/', ''], # Zeparator + ['IsZ', '$cat =~ /^Z/', ''], # Separator ['IsZs', '$cat eq "Zs"', ''], # Separator, Space ['IsZl', '$cat eq "Zl"', ''], # Separator, Line ['IsZp', '$cat eq "Zp"', ''], # Separator, Paragraph @@ -56,6 +77,9 @@ mkdir "To", 0777; ['IsCc', '$cat eq "Cc"', ''], # Other, Control or Format ['IsCo', '$cat eq "Co"', ''], # Other, Private Use ['IsCn', '$cat eq "Cn"', ''], # Other, Not Assigned + ['IsCf', '$cat eq "Cf"', ''], # Other, Format + ['IsCs', '$cat eq "Cs"', ''], # Other, Surrogate + ['IsCn', 'Unassigned Code Value',$PropData], # Other, Not Assigned # Informative @@ -71,9 +95,13 @@ mkdir "To", 0777; ['IsPs', '$cat eq "Ps"', ''], # Punctuation, Open ['IsPe', '$cat eq "Pe"', ''], # Punctuation, Close ['IsPo', '$cat eq "Po"', ''], # Punctuation, Other + ['IsPc', '$cat eq "Pc"', ''], # Punctuation, Connector + ['IsPi', '$cat eq "Pi"', ''], # Punctuation, Initial quote + ['IsPf', '$cat eq "Pf"', ''], # Punctuation, Final quote ['IsS', '$cat =~ /^S/', ''], # Symbol ['IsSm', '$cat eq "Sm"', ''], # Symbol, Math + ['IsSk', '$cat eq "Sk"', ''], # Symbol, Modifier ['IsSc', '$cat eq "Sc"', ''], # Symbol, Currency ['IsSo', '$cat eq "So"', ''], # Symbol, Other @@ -94,6 +122,15 @@ mkdir "To", 0777; # and punctuation specific to # those scripts + ['IsBidiLRE', '$bid eq "LRE"', ''], # Left-to-Right Embedding + ['IsBidiLRO', '$bid eq "LRO"', ''], # Left-to-Right Override + ['IsBidiAL', '$bid eq "AL"', ''], # Right-to-Left Arabic + ['IsBidiRLE', '$bid eq "RLE"', ''], # Right-to-Left Embedding + ['IsBidiRLO', '$bid eq "RLO"', ''], # Right-to-Left Override + ['IsBidiPDF', '$bid eq "PDF"', ''], # Pop Directional Format + ['IsBidiNSM', '$bid eq "NSM"', ''], # Non-Spacing Mark + ['IsBidiBN', '$bid eq "BN"', ''], # Boundary Neutral + # Weak types: ['IsBidiEN','$bid eq "EN"', ''], # European Number @@ -122,7 +159,7 @@ mkdir "To", 0777; ['IsDCfont', '$decomp =~ /^<font>/', ''], ['IsDCnoBreak', '$decomp =~ /^<noBreak>/', ''], ['IsDCinitial', '$decomp =~ /^<initial>/', ''], - ['IsDCinital', '$decomp =~ /^<medial>/', ''], + ['IsDCmedial', '$decomp =~ /^<medial>/', ''], ['IsDCfinal', '$decomp =~ /^<final>/', ''], ['IsDCisolated', '$decomp =~ /^<isolated>/', ''], ['IsDCcircle', '$decomp =~ /^<circle>/', ''], @@ -133,11 +170,12 @@ mkdir "To", 0777; ['IsDCnarrow', '$decomp =~ /^<narrow>/', ''], ['IsDCsmall', '$decomp =~ /^<small>/', ''], ['IsDCsquare', '$decomp =~ /^<square>/', ''], + ['IsDCfraction', '$decomp =~ /^<fraction>/', ''], ['IsDCcompat', '$decomp =~ /^<compat>/', ''], # Number - ['Number', '$num', '$num'], + ['Number', '$num ne ""', '$num'], # Mirrored @@ -154,18 +192,41 @@ mkdir "To", 0777; # Syllables - ['IsSylV', '$syl eq "V"', ''], - ['IsSylU', '$syl eq "U"', ''], - ['IsSylI', '$syl eq "I"', ''], - ['IsSylA', '$syl eq "A"', ''], - ['IsSylE', '$syl eq "E"', ''], - ['IsSylC', '$syl eq "C"', ''], - ['IsSylO', '$syl eq "O"', ''], - ['IsSylWV', '$syl eq "V"', ''], - ['IsSylWI', '$syl eq "I"', ''], - ['IsSylWA', '$syl eq "A"', ''], - ['IsSylWE', '$syl eq "E"', ''], - ['IsSylWC', '$syl eq "C"', ''], + syllable_defs(), + +# Line break properties - Normative + + ['IsLbrkBK','$brk eq "BK"', ''], # Mandatory Break + ['IsLbrkCR','$brk eq "CR"', ''], # Carriage Return + ['IsLbrkLF','$brk eq "LF"', ''], # Line Feed + ['IsLbrkCM','$brk eq "CM"', ''], # Attached Characters and Combining Marks + ['IsLbrkSG','$brk eq "SG"', ''], # Surrogates + ['IsLbrkGL','$brk eq "GL"', ''], # Non-breaking (Glue) + ['IsLbrkCB','$brk eq "CB"', ''], # Contingent Break Opportunity + ['IsLbrkSP','$brk eq "SP"', ''], # Space + ['IsLbrkZW','$brk eq "ZW"', ''], # Zero Width Space + +# Line break properties - Informative + ['IsLbrkXX','$brk eq "XX"', ''], # Unknown + ['IsLbrkOP','$brk eq "OP"', ''], # Opening Punctuation + ['IsLbrkCL','$brk eq "CL"', ''], # Closing Punctuation + ['IsLbrkQU','$brk eq "QU"', ''], # Ambiguous Quotation + ['IsLbrkNS','$brk eq "NS"', ''], # Non Starter + ['IsLbrkEX','$brk eq "EX"', ''], # Exclamation/Interrogation + ['IsLbrkSY','$brk eq "SY"', ''], # Symbols Allowing Breaks + ['IsLbrkIS','$brk eq "IS"', ''], # Infix Separator (Numeric) + ['IsLbrkPR','$brk eq "PR"', ''], # Prefix (Numeric) + ['IsLbrkPO','$brk eq "PO"', ''], # Postfix (Numeric) + ['IsLbrkNU','$brk eq "NU"', ''], # Numeric + ['IsLbrkAL','$brk eq "AL"', ''], # Ordinary Alphabetic and Symbol Characters + ['IsLbrkID','$brk eq "ID"', ''], # Ideographic + ['IsLbrkIN','$brk eq "IN"', ''], # Inseparable + ['IsLbrkHY','$brk eq "HY"', ''], # Hyphen + ['IsLbrkBB','$brk eq "BB"', ''], # Break Opportunity Before + ['IsLbrkBA','$brk eq "BA"', ''], # Break Opportunity After + ['IsLbrkSA','$brk eq "SA"', ''], # Complex Context (South East Asian) + ['IsLbrkAI','$brk eq "AI"', ''], # Ambiguous (Alphabetic or Ideographic) + ['IsLbrkB2','$brk eq "B2"', ''], # Break Opportunity Before and After ); # This is not written for speed... @@ -197,8 +258,8 @@ END exit if @ARGV and not grep { $_ eq Block } @ARGV; print "Block\n"; -open(UD, 'Blocks.txt') or die "Can't open blocks.txt: $!\n"; -open(OUT, ">Block.pl") or die "Can't create $table.pl: $!\n"; +open(UD, 'Blocks.txt') or die "Can't open Blocks.txt: $!\n"; +open(OUT, ">Block.pl") or die "Can't create Block.pl: $!\n"; print OUT <<EOH; # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! # This file is built by $0 from e.g. $UnicodeData. @@ -242,6 +303,8 @@ sub proplist { my $out; my $split; + return listFromPropFile($wanted) if $val eq $PropData; + if ($table =~ /^Arab/) { open(UD, "ArabShap.txt") or warn "Can't open $table: $!"; @@ -253,10 +316,15 @@ sub proplist { $split = '($code, $short, $name) = split(/; */); $code =~ s/^U\+//;'; } elsif ($table =~ /^IsSyl/) { - open(UD, "syllables.txt") or warn "Can't open $table: $!"; + open(UD, $SyllableData) or warn "Can't open $table: $!"; $split = '($code, $short, $syl) = split(/; */); $code =~ s/^U\+//;'; } + elsif ($table =~ /^IsLbrk/) { + open(UD, "LineBrk.txt") or warn "Can't open $table: $!"; + + $split = '($code, $brk, $name) = split(/;/);'; + } else { open(UD, $UnicodeData) or warn "Can't open $UnicodeData: $!"; @@ -268,8 +336,8 @@ sub proplist { eval <<"END"; while (<UD>) { next if /^#/; - next if /^\s/; - chop; + next if /^\\s/; + s/\\s+\$//; $split if ($wanted) { push(\@wanted, [hex \$code, hex $val, \$name =~ /, First>\$/]); @@ -303,7 +371,7 @@ END eval <<"END"; while (<UD>) { next if /^#/; - next if /^\s*\$/; + next if /^\\s*\$/; chop; $split if ($wanted) { @@ -336,4 +404,44 @@ END $out; } +sub listFromPropFile { + my ($wanted) = @_; + my $out; + + open (UD, $PropData) or die "Can't open $PropData: $!\n"; + local($/) = "\n" . '*' x 43 . "\n\nProperty dump for:"; # not 42? + + <UD>; + while (<UD>) { + chomp; + if (s/0x[\d\w]+\s+\((.*?)\)// and $wanted eq $1) { + s/\(\d+ chars\)//g; + s/^\s+//mg; + s/\s+$//mg; + s/\.\./\t/g; + $out = lc $_; + last; + } + } + close (UD); + "$out\n"; +} + +sub syllable_defs { + my @defs; + my %seen; + + open (SD, $SyllableData) or die "Can't open $SyllableData: $!\n"; + while (<SD>) { + next if /^\s*(#|$)/; + s/\s+$//; + ($code, $name, $syl) = split /; */; + next unless $syl; + push (@defs, ["IsSyl$syl", qq{\$syl eq "$syl"}, '']) + unless $seen{$syl}++; + } + close (SD); + return (@defs); +} + # eof diff --git a/contrib/perl5/lib/unicode/syllables.txt b/contrib/perl5/lib/unicode/syllables.txt index 40e946e6d82b..bc8bc23681a2 100644 --- a/contrib/perl5/lib/unicode/syllables.txt +++ b/contrib/perl5/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/contrib/perl5/lib/utf8.pm b/contrib/perl5/lib/utf8.pm index 17ec37bbe215..6d6c0eb503e5 100644 --- a/contrib/perl5/lib/utf8.pm +++ b/contrib/perl5/lib/utf8.pm @@ -1,5 +1,7 @@ package utf8; +if (ord('A') != 193) { # make things more pragmatic for EBCDIC folk + $utf8::hint_bits = 0x00800000; sub import { @@ -13,7 +15,10 @@ sub unimport { sub AUTOLOAD { require "utf8_heavy.pl"; - goto &$AUTOLOAD; + goto &$AUTOLOAD if defined &$AUTOLOAD; + Carp::croak("Undefined subroutine $AUTOLOAD called"); +} + } 1; @@ -44,7 +49,9 @@ in future we would like to standardize on the UTF-8 encoding for source text. Until UTF-8 becomes the default format for source text, this pragma should be used to recognize UTF-8 in the source. When UTF-8 becomes the standard source format, this pragma will -effectively become a no-op. +effectively become a no-op. This pragma already is a no-op on +EBCDIC platforms (where it is alright to code perl in EBCDIC +rather than UTF-8). Enabling the C<utf8> pragma has the following effects: diff --git a/contrib/perl5/lib/vars.pm b/contrib/perl5/lib/vars.pm index bde0b2a0e8c2..39a15bd312bb 100644 --- a/contrib/perl5/lib/vars.pm +++ b/contrib/perl5/lib/vars.pm @@ -8,7 +8,9 @@ require 5.002; # if Carp hasn't been loaded in earlier compile time. :-( # We'll let those bugs get found on the development track. require Carp if $] < 5.00450; -use warnings::register(); + +use warnings::register; +require strict; sub import { my $callpack = caller; @@ -25,6 +27,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/contrib/perl5/lib/warnings.pm b/contrib/perl5/lib/warnings.pm index 11558d50d442..25172393657d 100644 --- a/contrib/perl5/lib/warnings.pm +++ b/contrib/perl5/lib/warnings.pm @@ -26,6 +26,14 @@ warnings - Perl pragma to control optional warnings warnings::warn("void", "some warning"); } + if (warnings::enabled($object)) { + warnings::warn($object, "some warning"); + } + + warnif("some warning"); + warnif("void", "some warning"); + warnif($object, "some warning"); + =head1 DESCRIPTION If no import list is supplied, all possible warnings are either enabled @@ -37,30 +45,82 @@ A number of functions are provided to assist module authors. =item use warnings::register -Creates a new warnings category which has the same name as the module -where the call to the pragma is used. +Creates a new warnings category with the same name as the package where +the call to the pragma is used. + +=item warnings::enabled() + +Use the warnings category with the same name as the current package. + +Return TRUE if that warnings category is enabled in the calling module. +Otherwise returns FALSE. + +=item warnings::enabled($category) + +Return TRUE if the warnings category, C<$category>, is enabled in the +calling module. +Otherwise returns FALSE. + +=item warnings::enabled($object) + +Use the name of the class for the object reference, C<$object>, as the +warnings category. + +Return TRUE if that warnings category is enabled in the first scope +where the object is used. +Otherwise returns FALSE. + +=item warnings::warn($message) + +Print C<$message> to STDERR. + +Use the warnings category with the same name as the current package. + +If that warnings category has been set to "FATAL" in the calling module +then die. Otherwise return. + +=item warnings::warn($category, $message) + +Print C<$message> to STDERR. + +If the warnings category, C<$category>, has been set to "FATAL" in the +calling module then die. Otherwise return. + +=item warnings::warn($object, $message) -=item warnings::enabled([$category]) +Print C<$message> to STDERR. -Returns TRUE if the warnings category C<$category> is enabled in the -calling module. Otherwise returns FALSE. +Use the name of the class for the object reference, C<$object>, as the +warnings category. -If the parameter, C<$category>, isn't supplied, the current package name -will be used. +If that warnings category has been set to "FATAL" in the scope where C<$object> +is first used then die. Otherwise return. -=item warnings::warn([$category,] $message) -If the calling module has I<not> set C<$category> to "FATAL", print -C<$message> to STDERR. -If the calling module has set C<$category> to "FATAL", print C<$message> -STDERR then die. +=item warnings::warnif($message) -If the parameter, C<$category>, isn't supplied, the current package name -will be used. +Equivalent to: + + if (warnings::enabled()) + { warnings::warn($message) } + +=item warnings::warnif($category, $message) + +Equivalent to: + + if (warnings::enabled($category)) + { warnings::warn($category, $message) } + +=item warnings::warnif($object, $message) + +Equivalent to: + + if (warnings::enabled($object)) + { warnings::warn($object, $message) } =back -See L<perlmod/Pragmatic Modules> and L<perllexwarn>. +See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>. =cut @@ -243,44 +303,80 @@ sub bits { sub import { shift; - ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ; + my $mask = ${^WARNING_BITS} ; + if (vec($mask, $Offsets{'all'}, 1)) { + $mask |= $Bits{'all'} ; + $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); + } + ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ; } sub unimport { shift; my $mask = ${^WARNING_BITS} ; if (vec($mask, $Offsets{'all'}, 1)) { - $mask = $Bits{'all'} ; + $mask |= $Bits{'all'} ; $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); } ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ; } -sub enabled +sub __chk { - croak("Usage: warnings::enabled([category])") - unless @_ == 1 || @_ == 0 ; - local $Carp::CarpLevel = 1 ; my $category ; my $offset ; - my $callers_bitmask = (caller(1))[9] ; - return 0 unless defined $callers_bitmask ; - + my $isobj = 0 ; if (@_) { # check the category supplied. $category = shift ; + if (ref $category) { + croak ("not an object") + if $category !~ /^([^=]+)=/ ;+ + $category = $1 ; + $isobj = 1 ; + } $offset = $Offsets{$category}; croak("unknown warnings category '$category'") unless defined $offset; } else { - $category = (caller(0))[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 $i = 2 ; + my $pkg ; + + if ($isobj) { + while (do { { package DB; $pkg = (caller($i++))[0] } } ) { + last unless @DB::args && $DB::args[0] =~ /^$category=/ ; + } + $i -= 2 ; + } + else { + for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) { + last if $pkg ne $this_pkg ; + } + $i = 2 + if !$pkg || $pkg eq $this_pkg ; + } + + my $callers_bitmask = (caller($i))[9] ; + return ($callers_bitmask, $offset, $i) ; +} + +sub enabled +{ + croak("Usage: warnings::enabled([category])") + unless @_ == 1 || @_ == 0 ; + + my ($callers_bitmask, $offset, $i) = __chk(@_) ; + + return 0 unless defined $callers_bitmask ; return vec($callers_bitmask, $offset, 1) || vec($callers_bitmask, $Offsets{'all'}, 1) ; } @@ -290,29 +386,34 @@ sub warn { croak("Usage: warnings::warn([category,] 'message')") unless @_ == 2 || @_ == 1 ; - local $Carp::CarpLevel = 1 ; - my $category ; - my $offset ; - my $callers_bitmask = (caller(1))[9] ; - - if (@_ == 2) { - $category = shift ; - $offset = $Offsets{$category}; - croak("unknown warnings category '$category'") - unless defined $offset ; - } - else { - $category = (caller(0))[0] ; - $offset = $Offsets{$category}; - croak("package '$category' not registered for warnings") - unless defined $offset ; - } - my $message = shift ; + my $message = pop ; + my ($callers_bitmask, $offset, $i) = __chk(@_) ; + local $Carp::CarpLevel = $i ; croak($message) if vec($callers_bitmask, $offset+1, 1) || vec($callers_bitmask, $Offsets{'all'}+1, 1) ; carp($message) ; } +sub warnif +{ + croak("Usage: warnings::warnif([category,] 'message')") + unless @_ == 2 || @_ == 1 ; + + my $message = pop ; + my ($callers_bitmask, $offset, $i) = __chk(@_) ; + local $Carp::CarpLevel = $i ; + + return + unless defined $callers_bitmask && + (vec($callers_bitmask, $offset, 1) || + vec($callers_bitmask, $Offsets{'all'}, 1)) ; + + croak($message) + if vec($callers_bitmask, $offset+1, 1) || + vec($callers_bitmask, $Offsets{'all'}+1, 1) ; + + carp($message) ; +} 1; diff --git a/contrib/perl5/lib/warnings/register.pm b/contrib/perl5/lib/warnings/register.pm index da6be9795202..f98075a5ee8c 100644 --- a/contrib/perl5/lib/warnings/register.pm +++ b/contrib/perl5/lib/warnings/register.pm @@ -1,5 +1,13 @@ package warnings::register ; +=pod + +=head1 NAME + +warnings::register - warnings import function + +=cut + require warnings ; sub mkMask diff --git a/contrib/perl5/makedef.pl b/contrib/perl5/makedef.pl index e63034beb01d..e983967537e7 100644 --- a/contrib/perl5/makedef.pl +++ b/contrib/perl5/makedef.pl @@ -51,7 +51,7 @@ while (@ARGV) { $PLATFORM = $1 if ($flag =~ /^PLATFORM=(\w+)$/); } -my @PLATFORM = qw(aix win32 os2); +my @PLATFORM = qw(aix win32 os2 MacOS); my %PLATFORM; @PLATFORM{@PLATFORM} = (); @@ -77,8 +77,14 @@ elsif ($PLATFORM eq 'win32') { s!^!..\\!; } } +elsif ($PLATFORM eq 'MacOS') { + foreach ($thrdvar_h, $intrpvar_h, $perlvars_h, $global_sym, + $pp_sym, $globvar_sym, $perlio_sym) { + s!^!::!; + } +} -unless ($PLATFORM eq 'win32') { +unless ($PLATFORM eq 'win32' || $PLATFORM eq 'MacOS') { open(CFG,$config_sh) || die "Cannot open $config_sh: $!\n"; while (<CFG>) { if (/^(?:ccflags|optimize)='(.+)'$/) { @@ -99,6 +105,7 @@ while (<CFG>) { $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+(USE_SFIO)\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/; @@ -157,7 +164,7 @@ elsif ($PLATFORM eq 'os2') { # print STDERR "'$dll' <= '$define{PERL_DLL}'\n"; print <<"---EOP---"; LIBRARY '$dll' INITINSTANCE TERMINSTANCE -DESCRIPTION '\@#perl5-porters\@perl.org:$v#\@ Perl interpreter, configured as $CONFIG_ARGS' +DESCRIPTION '\@#perl5-porters\@perl.org:$v#\@ Perl interpreter' STACKSIZE 32768 CODE LOADONCALL DATA LOADONCALL NONSHARED MULTIPLE @@ -259,7 +266,9 @@ elsif ($PLATFORM eq 'aix') { Perl_safexrealloc Perl_same_dirent Perl_unlnk + Perl_sys_intern_clear Perl_sys_intern_dup + Perl_sys_intern_init PL_cryptseen PL_opsave PL_statusvalue_vms @@ -279,6 +288,8 @@ elsif ($PLATFORM eq 'os2') { my_tmpfile my_tmpnam my_flock + my_rmdir + my_mkdir malloc_mutex threads_mutex nthreads @@ -309,10 +320,38 @@ elsif ($PLATFORM eq 'os2') { Perl_hab_GET )]); } +elsif ($PLATFORM eq 'MacOS') { + skip_symbols [qw( + Perl_GetVars + PL_cryptseen + PL_cshlen + PL_cshname + PL_statusvalue_vms + PL_sys_intern + PL_opsave + PL_timesbuf + Perl_dump_fds + Perl_my_bcopy + Perl_my_bzero + Perl_my_chsize + Perl_my_htonl + Perl_my_memcmp + Perl_my_memset + Perl_my_ntohl + Perl_my_swap + Perl_safexcalloc + Perl_safexfree + Perl_safexmalloc + Perl_safexrealloc + Perl_unlnk + Perl_sys_intern_clear + Perl_sys_intern_init + )]; +} + unless ($define{'DEBUGGING'}) { skip_symbols [qw( - Perl_deb Perl_deb_growlevel Perl_debop Perl_debprofdump @@ -363,6 +402,8 @@ if ($define{'MYMALLOC'}) { Perl_mfree Perl_realloc Perl_calloc + Perl_strdup + Perl_putenv )]; if ($define{'USE_5005THREADS'} || $define{'USE_ITHREADS'}) { emit_symbols [qw( @@ -401,6 +442,8 @@ unless ($define{'USE_5005THREADS'}) { PL_svref_mutex PL_cred_mutex PL_eval_mutex + PL_fdpid_mutex + PL_sv_lock_mutex PL_eval_cond PL_eval_owner PL_threads_mutex @@ -417,6 +460,7 @@ unless ($define{'USE_5005THREADS'}) { Perl_find_threadsv Perl_unlock_condpair Perl_magic_mutexfree + Perl_sv_lock )]; } @@ -440,6 +484,8 @@ unless ($define{'USE_ITHREADS'}) { Perl_ptr_table_new Perl_ptr_table_split Perl_ptr_table_store + Perl_ptr_table_clear + Perl_ptr_table_free perl_clone perl_clone_using )]; @@ -505,7 +551,53 @@ if ($define{'PERL_GLOBAL_STRUCT'}) { my @syms = ($global_sym, $globvar_sym); # $pp_sym is not part of the API if ($define{'USE_PERLIO'}) { - push @syms, $perlio_sym; + push @syms, $perlio_sym; + if ($define{'USE_SFIO'}) { + # SFIO defines most of the PerlIO routines as macros + skip_symbols [qw( + PerlIO_canset_cnt + PerlIO_clearerr + PerlIO_close + PerlIO_eof + PerlIO_error + PerlIO_exportFILE + PerlIO_fast_gets + PerlIO_fdopen + PerlIO_fileno + PerlIO_findFILE + PerlIO_flush + PerlIO_get_base + PerlIO_get_bufsiz + PerlIO_get_cnt + PerlIO_get_ptr + PerlIO_getc + PerlIO_getname + PerlIO_has_base + PerlIO_has_cntptr + PerlIO_importFILE + PerlIO_open + PerlIO_printf + PerlIO_putc + PerlIO_puts + PerlIO_read + PerlIO_releaseFILE + PerlIO_reopen + PerlIO_rewind + PerlIO_seek + PerlIO_set_cnt + PerlIO_set_ptrcnt + PerlIO_setlinebuf + PerlIO_sprintf + PerlIO_stderr + PerlIO_stdin + PerlIO_stdout + PerlIO_stdoutf + PerlIO_tell + PerlIO_ungetc + PerlIO_vprintf + PerlIO_write + )]; + } } for my $syms (@syms) { @@ -729,6 +821,15 @@ elsif ($PLATFORM eq 'os2') { keys %export; delete $export{$_} foreach @missing; } +elsif ($PLATFORM eq 'MacOS') { + open MACSYMS, 'macperl.sym' or die 'Cannot read macperl.sym'; + + while (<MACSYMS>) { + try_symbol($_); + } + + close MACSYMS; +} # Now all symbols should be defined because # next we are going to output them. @@ -775,7 +876,7 @@ sub output_symbol { elsif ($PLATFORM eq 'os2') { print qq( "$symbol"\n); } - elsif ($PLATFORM eq 'aix') { + elsif ($PLATFORM eq 'aix' || $PLATFORM eq 'MacOS') { print "$symbol\n"; } } diff --git a/contrib/perl5/makedepend.SH b/contrib/perl5/makedepend.SH index 7129e08a8456..7f8a108e3b53 100755 --- a/contrib/perl5/makedepend.SH +++ b/contrib/perl5/makedepend.SH @@ -108,7 +108,11 @@ for file in `$cat .clist`; do if [ "$archname" = cygwin ]; then uwinfix="-e s,\\\\\\\\,/,g" else - uwinfix= + if [ "$osname" = posix-bc ]; then + uwinfix="-e s/\\*POSIX(\\(.*\\))/\\1/" + else + uwinfix= + fi fi fi fi @@ -130,22 +134,37 @@ for file in `$cat .clist`; do -e 's|\\$||' \ -e p \ -e '}' ) >UU/$file.c - if [ "$osname" = os390 -a "$file" = perly.c ]; then - $echo '#endif' >>UU/$file.c + if [ "$osname" = os390 ]; then + if [ "$file" = perly.c ]; then + $echo '#endif' >>UU/$file.c + fi + $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c | + $sed \ + -e '/^#.*<stdin>/d' \ + -e '/^#.*"-"/d' \ + -e 's#\.[0-9][0-9]*\.c#'"$file.c#" \ + -e 's/^[ ]*#[ ]*line/#/' \ + -e '/^# *[0-9][0-9]* *[".\/]/!d' \ + -e 's/^.*"\(.*\)".*$/'$filebase'\$(OBJ_EXT): \1/' \ + -e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'\$(OBJ_EXT): \1/' \ + -e 's|: \./|: |' \ + -e 's|\.c\.c|.c|' $uwinfix | \ + $uniq | $sort | $uniq >> .deptmp + else + $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c | + $sed \ + -e '1d' \ + -e '/^#.*<stdin>/d' \ + -e '/^#.*"-"/d' \ + -e 's#\.[0-9][0-9]*\.c#'"$file.c#" \ + -e 's/^[ ]*#[ ]*line/#/' \ + -e '/^# *[0-9][0-9]* *[".\/]/!d' \ + -e 's/^.*"\(.*\)".*$/'$filebase'\$(OBJ_EXT): \1/' \ + -e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'\$(OBJ_EXT): \1/' \ + -e 's|: \./|: |' \ + -e 's|\.c\.c|.c|' $uwinfix | \ + $uniq | $sort | $uniq >> .deptmp fi - $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c | - $sed \ - -e '1d' \ - -e '/^#.*<stdin>/d' \ - -e '/^#.*"-"/d' \ - -e 's#\.[0-9][0-9]*\.c#'"$file.c#" \ - -e 's/^[ ]*#[ ]*line/#/' \ - -e '/^# *[0-9][0-9]* *[".\/]/!d' \ - -e 's/^.*"\(.*\)".*$/'$filebase'\$(OBJ_EXT): \1/' \ - -e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'\$(OBJ_EXT): \1/' \ - -e 's|: \./|: |' \ - -e 's|\.c\.c|.c|' $uwinfix | \ - $uniq | $sort | $uniq >> .deptmp done $sed <$mf >$mf.new -e '1,/^# AUTOMATICALLY/!d' diff --git a/contrib/perl5/malloc.c b/contrib/perl5/malloc.c index 57ca5a1b8490..b2288fdccb8d 100644 --- a/contrib/perl5/malloc.c +++ b/contrib/perl5/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 +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)<<LOG_OF_MIN_ARENA; - if (size >= 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 <unistd.h> -#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); } } @@ -1045,7 +1096,7 @@ Perl_malloc(register size_t nbytes) DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05lu) malloc %ld bytes\n", - PTR2UV(p+1), (unsigned long)(PL_an++), + PTR2UV(p), (unsigned long)(PL_an++), (long)size)); /* remove from linked list */ @@ -1060,7 +1111,7 @@ Perl_malloc(register size_t nbytes) dTHX; PerlIO_printf(PerlIO_stderr(), "Unaligned `next' pointer in the free " - "chain 0x"UVxf" at 0x%"UVxf"\n", + "chain 0x%"UVxf" at 0x%"UVxf"\n", PTR2UV(p->ov_next), PTR2UV(p)); } #endif @@ -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; @@ -1889,6 +1943,7 @@ Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level) buf->start_slack = start_slack; buf->sbrked_remains = sbrked_remains; MALLOC_UNLOCK; + buf->nbuckets = NBUCKETS; if (level) { for (i = MIN_BUCKET ; i < NBUCKETS; i++) { if (i >= buflen) @@ -1911,12 +1966,10 @@ void Perl_dump_mstats(pTHX_ char *s) { #ifdef DEBUGGING_MSTATS - register int i, j; - register union overhead *p; + register int i; perl_mstats_t buffer; - unsigned long nf[NBUCKETS]; - unsigned long nt[NBUCKETS]; - struct chunk_chain_s* nextchain; + UV nf[NBUCKETS]; + UV nt[NBUCKETS]; buffer.nfree = nf; buffer.ntotal = nt; @@ -1924,18 +1977,18 @@ Perl_dump_mstats(pTHX_ char *s) if (s) PerlIO_printf(Perl_error_log, - "Memory allocation statistics %s (buckets %ld(%ld)..%ld(%ld)\n", + "Memory allocation statistics %s (buckets %"IVdf"(%"IVdf")..%"IVdf"(%"IVdf")\n", s, - (long)BUCKET_SIZE_REAL(MIN_BUCKET), - (long)BUCKET_SIZE(MIN_BUCKET), - (long)BUCKET_SIZE_REAL(buffer.topbucket), - (long)BUCKET_SIZE(buffer.topbucket)); - PerlIO_printf(Perl_error_log, "%8ld free:", buffer.totfree); + (IV)BUCKET_SIZE_REAL(MIN_BUCKET), + (IV)BUCKET_SIZE(MIN_BUCKET), + (IV)BUCKET_SIZE_REAL(buffer.topbucket), + (IV)BUCKET_SIZE(buffer.topbucket)); + PerlIO_printf(Perl_error_log, "%8"IVdf" free:", buffer.totfree); for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) { PerlIO_printf(Perl_error_log, ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) - ? " %5d" - : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")), + ? " %5"UVuf + : ((i < 12*BUCKETS_PER_POW2) ? " %3"UVuf : " %"UVuf)), buffer.nfree[i]); } #ifdef BUCKETS_ROOT2 @@ -1943,17 +1996,17 @@ Perl_dump_mstats(pTHX_ char *s) for (i = MIN_BUCKET + 1; i <= buffer.topbucket_odd; i += BUCKETS_PER_POW2) { PerlIO_printf(Perl_error_log, ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) - ? " %5d" - : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")), + ? " %5"UVuf + : ((i < 12*BUCKETS_PER_POW2) ? " %3"UVuf : " %"UVuf)), buffer.nfree[i]); } #endif - PerlIO_printf(Perl_error_log, "\n%8ld used:", buffer.total - buffer.totfree); + PerlIO_printf(Perl_error_log, "\n%8"IVdf" used:", buffer.total - buffer.totfree); for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) { PerlIO_printf(Perl_error_log, ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) - ? " %5d" - : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")), + ? " %5"IVdf + : ((i < 12*BUCKETS_PER_POW2) ? " %3"IVdf : " %"IVdf)), buffer.ntotal[i] - buffer.nfree[i]); } #ifdef BUCKETS_ROOT2 @@ -1961,12 +2014,12 @@ Perl_dump_mstats(pTHX_ char *s) for (i = MIN_BUCKET + 1; i <= buffer.topbucket_odd; i += BUCKETS_PER_POW2) { PerlIO_printf(Perl_error_log, ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) - ? " %5d" - : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")), + ? " %5"IVdf + : ((i < 12*BUCKETS_PER_POW2) ? " %3"IVdf : " %"IVdf)), buffer.ntotal[i] - buffer.nfree[i]); } #endif - PerlIO_printf(Perl_error_log, "\nTotal sbrk(): %ld/%ld:%ld. Odd ends: pad+heads+chain+tail: %ld+%ld+%ld+%ld.\n", + PerlIO_printf(Perl_error_log, "\nTotal sbrk(): %"IVdf"/%"IVdf":%"IVdf". Odd ends: pad+heads+chain+tail: %"IVdf"+%"IVdf"+%"IVdf"+%"IVdf".\n", buffer.total_sbrk, buffer.sbrks, buffer.sbrk_good, buffer.sbrk_slack, buffer.start_slack, buffer.total_chain, buffer.sbrked_remains); diff --git a/contrib/perl5/mg.c b/contrib/perl5/mg.c index 39416399f890..e1b727a0af3f 100644 --- a/contrib/perl5/mg.c +++ b/contrib/perl5/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 <unistd.h> -#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<sv_magic>. 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<sv_magic>. int Perl_mg_set(pTHX_ SV *sv) { - dTHR; I32 mgs_ix; MAGIC* mg; MAGIC* nextmg; @@ -292,7 +284,8 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { if (isUPPER(mg->mg_type)) { sv_magic(nsv, - mg->mg_type == 'P' ? SvTIED_obj(sv, mg) : mg->mg_obj, + mg->mg_type == 'P' ? SvTIED_obj(sv, mg) : + (mg->mg_type == 'D' && mg->mg_obj) ? sv : mg->mg_obj, toLOWER(mg->mg_type), key, klen); count++; } @@ -338,7 +331,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)) { @@ -354,7 +346,6 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register I32 paren; register I32 s; register I32 i; @@ -379,10 +370,17 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) return 0; } +int +Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg) +{ + Perl_croak(aTHX_ PL_no_modify); + /* NOT REACHED */ + return 0; +} + U32 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register I32 paren; register I32 i; register REGEXP *rx; @@ -464,7 +462,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; @@ -489,8 +486,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { char msg[256]; - sv_setnv(sv,(double)gLastMacOSErr); - sv_setpv(sv, gLastMacOSErr ? GetSysErrText(gLastMacOSErr, msg) : ""); + sv_setnv(sv,(double)gMacPerl_OSErr); + sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : ""); } #else #ifdef VMS @@ -561,13 +558,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; case '\023': /* ^S */ { - dTHR; if (PL_lex_state != LEX_NOTPARSING) (void)SvOK_off(sv); else if (PL_in_eval) - sv_setiv(sv, 1); - else - sv_setiv(sv, 0); + sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE)); } break; case '\024': /* ^T */ @@ -614,6 +608,9 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { i = t1 - s1; s = rx->subbeg + s1; + if (!rx->subbeg) + break; + getrx: if (i >= 0) { bool was_tainted; @@ -884,7 +881,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; @@ -903,7 +899,7 @@ Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) { -#if defined(VMS) +#if defined(VMS) || defined(EPOC) Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); #else # ifdef PERL_IMPLICIT_SYS @@ -925,12 +921,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 +#if !defined(MACOS_TRADITIONAL) # ifndef PERL_USE_SAFE_PUTENV I32 i; @@ -940,10 +932,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 /* !defined(MACOS_TRADITIONAL) */ # endif /* WIN32 */ # endif /* PERL_IMPLICIT_SYS */ #endif /* VMS */ @@ -997,7 +989,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; @@ -1259,7 +1250,6 @@ Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) { - dTHR; OP *o; I32 i; GV* gv; @@ -1272,15 +1262,12 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) atoi(MgPV(mg,n_a)), FALSE); if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) o->op_private = i; - else if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Can't break at that line\n"); return 0; } int Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg) { - dTHR; sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase); return 0; } @@ -1288,7 +1275,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; } @@ -1301,7 +1287,6 @@ Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) 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); @@ -1320,7 +1305,6 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) SSize_t pos; STRLEN len; STRLEN ulen = 0; - dTHR; mg = 0; @@ -1409,11 +1393,15 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) I32 offs = LvTARGOFF(sv); I32 rem = LvTARGLEN(sv); + if (SvUTF8(lsv)) + sv_pos_u2b(lsv, &offs, &rem); if (offs > len) offs = len; if (rem + offs > len) rem = len - offs; sv_setpvn(sv, tmps + offs, (STRLEN)rem); + if (SvUTF8(lsv)) + SvUTF8_on(sv); return 0; } @@ -1421,15 +1409,32 @@ int 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); + char *tmps = SvPV(sv, len); + SV *lsv = LvTARG(sv); + I32 lvoff = LvTARGOFF(sv); + I32 lvlen = LvTARGLEN(sv); + + if (DO_UTF8(sv)) { + sv_utf8_upgrade(lsv); + sv_pos_u2b(lsv, &lvoff, &lvlen); + sv_insert(lsv, lvoff, lvlen, tmps, len); + SvUTF8_on(lsv); + } + else if (SvUTF8(lsv)) { + sv_pos_u2b(lsv, &lvoff, &lvlen); + tmps = (char*)bytes_to_utf8((U8*)tmps, &len); + sv_insert(lsv, lvoff, lvlen, tmps, len); + Safefree(tmps); + } + else + sv_insert(lsv, lvoff, lvlen, 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; @@ -1438,7 +1443,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; @@ -1497,7 +1501,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); @@ -1528,7 +1531,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; @@ -1652,7 +1654,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; @@ -1670,7 +1671,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '\005': /* ^E */ #ifdef MACOS_TRADITIONAL - gLastMacOSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); + gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); #else # ifdef VMS set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); @@ -1735,18 +1736,21 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_compiling.cop_warnings = pWARN_NONE; break; } - if (isWARN_on(sv, WARN_ALL)) { - PL_compiling.cop_warnings = pWARN_ALL; - PL_dowarn |= G_WARN_ONCE ; - } - else { + { STRLEN len, i; int accumulate = 0 ; + int any_fatals = 0 ; char * ptr = (char*)SvPV(sv, len) ; - for (i = 0 ; i < len ; ++i) - accumulate += ptr[i] ; + for (i = 0 ; i < len ; ++i) { + accumulate |= ptr[i] ; + any_fatals |= (ptr[i] & 0xAA) ; + } if (!accumulate) PL_compiling.cop_warnings = pWARN_NONE; + else if (isWARN_on(sv, WARN_ALL) && !any_fatals) { + PL_compiling.cop_warnings = pWARN_ALL; + PL_dowarn |= G_WARN_ONCE ; + } else { if (specialWARN(PL_compiling.cop_warnings)) PL_compiling.cop_warnings = newSVsv(sv) ; @@ -1755,6 +1759,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) PL_dowarn |= G_WARN_ONCE ; } + } } } @@ -2088,7 +2093,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));) @@ -2124,7 +2128,11 @@ static SV* sig_sv; Signal_t Perl_sighandler(int sig) { +#if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT) + dTHXoa(PL_curinterp); /* fake TLS, because signals don't do TLS */ +#else dTHX; +#endif dSP; GV *gv = Nullgv; HV *st; @@ -2134,6 +2142,10 @@ Perl_sighandler(int sig) U32 flags = 0; I32 o_save_i = PL_savestack_ix; XPV *tXpv = PL_Xpv; + +#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; @@ -2221,7 +2233,6 @@ cleanup: static void restore_magic(pTHXo_ void *p) { - dTHR; MGS* mgs = SSPTR(PTR2IV(p), MGS*); SV* sv = mgs->mgs_sv; @@ -2263,7 +2274,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/contrib/perl5/mg.h b/contrib/perl5/mg.h index ad50f5a0ae46..004880344089 100644 --- a/contrib/perl5/mg.h +++ b/contrib/perl5/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/contrib/perl5/minimod.pl b/contrib/perl5/minimod.pl index 8efbd31ffc5b..18b9c0748cf7 100644 --- a/contrib/perl5/minimod.pl +++ b/contrib/perl5/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/contrib/perl5/myconfig.SH b/contrib/perl5/myconfig.SH index 7861f5e0ed17..e80dfb5b5f81 100755 --- a/contrib/perl5/myconfig.SH +++ b/contrib/perl5/myconfig.SH @@ -34,14 +34,14 @@ Summary of my $package (revision $baserev version $PERL_VERSION subversion $PERL config_args='$config_args' hint=$hint, useposix=$useposix, d_sigaction=$d_sigaction usethreads=$usethreads use5005threads=$use5005threads useithreads=$useithreads usemultiplicity=$usemultiplicity - useperlio=$useperlio d_sfio=$d_sfio uselargefiles=$uselargefiles - use64bitint=$use64bitint use64bitall=$use64bitall uselongdouble=$uselongdouble usesocks=$usesocks + useperlio=$useperlio d_sfio=$d_sfio uselargefiles=$uselargefiles usesocks=$usesocks + use64bitint=$use64bitint use64bitall=$use64bitall uselongdouble=$uselongdouble Compiler: - cc='$cc', optimize='$optimize', gccversion=$gccversion + cc='$cc', ccflags ='$ccflags', + optimize='$optimize', cppflags='$cppflags' - ccflags ='$ccflags' - stdchar='$stdchar', d_stdstdio=$d_stdstdio, usevfork=$usevfork - intsize=$intsize, longsize=$longsize, ptrsize=$ptrsize, doublesize=$doublesize + ccversion='$ccversion', gccversion='$gccversion', gccosandvers='$gccosandvers' + intsize=$intsize, longsize=$longsize, ptrsize=$ptrsize, doublesize=$doublesize, byteorder=$byteorder d_longlong=$d_longlong, longlongsize=$longlongsize, d_longdbl=$d_longdbl, longdblsize=$longdblsize ivtype='$ivtype', ivsize=$ivsize, nvtype='$nvtype', nvsize=$nvsize, Off_t='$lseektype', lseeksize=$lseeksize alignbytes=$alignbytes, usemymalloc=$usemymalloc, prototype=$prototype @@ -49,6 +49,7 @@ Summary of my $package (revision $baserev version $PERL_VERSION subversion $PERL ld='$ld', ldflags ='$ldflags' libpth=$libpth libs=$libs + perllibs=$perllibs libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl Dynamic Linking: dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' diff --git a/contrib/perl5/objXSUB.h b/contrib/perl5/objXSUB.h index 68c31b0538e3..d4ba2a22a97a 100644 --- a/contrib/perl5/objXSUB.h +++ b/contrib/perl5/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_apply_attrs_string +#define Perl_apply_attrs_string pPerl->Perl_apply_attrs_string +#undef apply_attrs_string +#define apply_attrs_string Perl_apply_attrs_string #undef Perl_avhv_delete_ent #define Perl_avhv_delete_ent pPerl->Perl_avhv_delete_ent #undef avhv_delete_ent @@ -79,10 +83,6 @@ #define Perl_av_extend pPerl->Perl_av_extend #undef av_extend #define av_extend Perl_av_extend -#undef Perl_av_fake -#define Perl_av_fake pPerl->Perl_av_fake -#undef av_fake -#define av_fake Perl_av_fake #undef Perl_av_fetch #define Perl_av_fetch pPerl->Perl_av_fetch #undef av_fetch @@ -228,6 +228,10 @@ #define Perl_fprintf_nocontext pPerl->Perl_fprintf_nocontext #undef fprintf_nocontext #define fprintf_nocontext Perl_fprintf_nocontext +#undef Perl_printf_nocontext +#define Perl_printf_nocontext pPerl->Perl_printf_nocontext +#undef printf_nocontext +#define printf_nocontext Perl_printf_nocontext #endif #undef Perl_cv_const_sv #define Perl_cv_const_sv pPerl->Perl_cv_const_sv @@ -313,6 +317,10 @@ #endif #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) #endif +#undef Perl_do_join +#define Perl_do_join pPerl->Perl_do_join +#undef do_join +#define do_join Perl_do_join #undef Perl_do_open #define Perl_do_open pPerl->Perl_do_open #undef do_open @@ -423,6 +431,10 @@ #define Perl_gv_efullname3 pPerl->Perl_gv_efullname3 #undef gv_efullname3 #define gv_efullname3 Perl_gv_efullname3 +#undef Perl_gv_efullname4 +#define Perl_gv_efullname4 pPerl->Perl_gv_efullname4 +#undef gv_efullname4 +#define gv_efullname4 Perl_gv_efullname4 #undef Perl_gv_fetchfile #define Perl_gv_fetchfile pPerl->Perl_gv_fetchfile #undef gv_fetchfile @@ -451,6 +463,10 @@ #define Perl_gv_fullname3 pPerl->Perl_gv_fullname3 #undef gv_fullname3 #define gv_fullname3 Perl_gv_fullname3 +#undef Perl_gv_fullname4 +#define Perl_gv_fullname4 pPerl->Perl_gv_fullname4 +#undef gv_fullname4 +#define gv_fullname4 Perl_gv_fullname4 #undef Perl_gv_init #define Perl_gv_init pPerl->Perl_gv_init #undef gv_init @@ -703,6 +719,10 @@ #define Perl_is_utf8_char pPerl->Perl_is_utf8_char #undef is_utf8_char #define is_utf8_char Perl_is_utf8_char +#undef Perl_is_utf8_string +#define Perl_is_utf8_string pPerl->Perl_is_utf8_string +#undef is_utf8_string +#define is_utf8_string Perl_is_utf8_string #undef Perl_is_utf8_alnum #define Perl_is_utf8_alnum pPerl->Perl_is_utf8_alnum #undef is_utf8_alnum @@ -1279,6 +1299,10 @@ #define Perl_rninstr pPerl->Perl_rninstr #undef rninstr #define rninstr Perl_rninstr +#undef Perl_rsignal +#define Perl_rsignal pPerl->Perl_rsignal +#undef rsignal +#define rsignal Perl_rsignal #if !defined(HAS_RENAME) #endif #undef Perl_savepv @@ -1337,6 +1361,10 @@ #define Perl_save_generic_svref pPerl->Perl_save_generic_svref #undef save_generic_svref #define save_generic_svref Perl_save_generic_svref +#undef Perl_save_generic_pvref +#define Perl_save_generic_pvref pPerl->Perl_save_generic_pvref +#undef save_generic_pvref +#define save_generic_pvref Perl_save_generic_pvref #undef Perl_save_gp #define Perl_save_gp pPerl->Perl_save_gp #undef save_gp @@ -1389,6 +1417,10 @@ #define Perl_save_long pPerl->Perl_save_long #undef save_long #define save_long Perl_save_long +#undef Perl_save_mortalizesv +#define Perl_save_mortalizesv pPerl->Perl_save_mortalizesv +#undef save_mortalizesv +#define save_mortalizesv Perl_save_mortalizesv #undef Perl_save_nogv #define Perl_save_nogv pPerl->Perl_save_nogv #undef save_nogv @@ -1409,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 @@ -1829,6 +1865,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 @@ -1837,6 +1877,22 @@ #define Perl_utf8_hop pPerl->Perl_utf8_hop #undef utf8_hop #define utf8_hop Perl_utf8_hop +#undef Perl_utf8_to_bytes +#define Perl_utf8_to_bytes pPerl->Perl_utf8_to_bytes +#undef utf8_to_bytes +#define utf8_to_bytes Perl_utf8_to_bytes +#undef Perl_bytes_from_utf8 +#define Perl_bytes_from_utf8 pPerl->Perl_bytes_from_utf8 +#undef bytes_from_utf8 +#define bytes_from_utf8 Perl_bytes_from_utf8 +#undef Perl_bytes_to_utf8 +#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 @@ -1861,8 +1917,11 @@ #define Perl_vwarner pPerl->Perl_vwarner #undef vwarner #define vwarner Perl_vwarner -#if defined(USE_PURE_BISON) -#else +#undef Perl_whichsig +#define Perl_whichsig pPerl->Perl_whichsig +#undef whichsig +#define whichsig Perl_whichsig +#ifdef USE_PURE_BISON #endif #if defined(MYMALLOC) #undef Perl_dump_mstats @@ -1922,6 +1981,12 @@ #define Perl_runops_debug pPerl->Perl_runops_debug #undef runops_debug #define runops_debug Perl_runops_debug +#if defined(USE_THREADS) +#undef Perl_sv_lock +#define Perl_sv_lock pPerl->Perl_sv_lock +#undef sv_lock +#define sv_lock Perl_sv_lock +#endif #undef Perl_sv_catpvf_mg #define Perl_sv_catpvf_mg pPerl->Perl_sv_catpvf_mg #undef sv_catpvf_mg @@ -2084,6 +2149,14 @@ #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_add_backref +#define Perl_sv_add_backref pPerl->Perl_sv_add_backref +#undef sv_add_backref +#define sv_add_backref Perl_sv_add_backref +#undef Perl_sv_del_backref +#define Perl_sv_del_backref pPerl->Perl_sv_del_backref +#undef sv_del_backref +#define sv_del_backref Perl_sv_del_backref #undef Perl_tmps_grow #define Perl_tmps_grow pPerl->Perl_tmps_grow #undef tmps_grow @@ -2171,6 +2244,24 @@ #define Perl_ptr_table_split pPerl->Perl_ptr_table_split #undef ptr_table_split #define ptr_table_split Perl_ptr_table_split +#undef Perl_ptr_table_clear +#define Perl_ptr_table_clear pPerl->Perl_ptr_table_clear +#undef ptr_table_clear +#define ptr_table_clear Perl_ptr_table_clear +#undef Perl_ptr_table_free +#define Perl_ptr_table_free pPerl->Perl_ptr_table_free +#undef ptr_table_free +#define ptr_table_free Perl_ptr_table_free +#endif +#if defined(HAVE_INTERP_INTERN) +#undef Perl_sys_intern_clear +#define Perl_sys_intern_clear pPerl->Perl_sys_intern_clear +#undef sys_intern_clear +#define sys_intern_clear Perl_sys_intern_clear +#undef Perl_sys_intern_init +#define Perl_sys_intern_init pPerl->Perl_sys_intern_init +#undef sys_intern_init +#define sys_intern_init Perl_sys_intern_init #endif #if defined(PERL_OBJECT) #else diff --git a/contrib/perl5/op.c b/contrib/perl5/op.c index 1cfc6dde2a10..5fe0a0398083 100644 --- a/contrib/perl5/op.c +++ b/contrib/perl5/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. @@ -55,6 +55,7 @@ S_Slab_Alloc(pTHX_ int m, size_t sz) : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o)) #define PAD_MAX 999999999 +#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) STATIC char* S_gv_ename(pTHX_ GV *gv) @@ -102,18 +103,41 @@ S_no_bareword_allowed(pTHX_ OP *o) SvPV_nolen(cSVOPo_sv))); } +STATIC U8* +S_trlist_upgrade(pTHX_ U8** sp, U8** ep) +{ + U8 *s = *sp; + U8 *e = *ep; + U8 *d; + + Newz(801, d, (e - s) * 2, U8); + *sp = d; + + while (s < e) { + if (*s < 0x80 || *s == 0xff) + *d++ = *s++; + else { + U8 c = *s++; + *d++ = ((c >> 6) | 0xc0); + *d++ = ((c & 0x3f) | 0x80); + } + } + *ep = d; + return *sp; +} + + /* "register" allocation */ 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])) { @@ -162,6 +186,7 @@ Perl_pad_allocmy(pTHX_ char *name) do { if ((sv = svp[off]) && sv != &PL_sv_undef + && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0) && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash) && strEQ(name, SvPVX(sv))) { @@ -237,7 +262,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; @@ -321,9 +345,12 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, } } else if (!CvUNIQUE(PL_compcv)) { - if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)) + if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv) + && !(SvFLAGS(sv) & SVpad_OUR)) + { Perl_warner(aTHX_ WARN_CLOSURE, "Variable \"%s\" will not stay shared", name); + } } } av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv)); @@ -381,7 +408,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; @@ -444,7 +470,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; @@ -464,7 +489,6 @@ Perl_pad_leavemy(pTHX_ I32 fill) PADOFFSET Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) { - dTHR; SV *sv; I32 retval; @@ -515,7 +539,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", @@ -532,7 +555,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) @@ -560,7 +582,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) @@ -590,7 +611,6 @@ void Perl_pad_reset(pTHX) { #ifdef USE_BROKEN_PAD_RESET - dTHR; register I32 po; if (AvARRAY(PL_comppad) != PL_curpad) @@ -619,7 +639,6 @@ Perl_pad_reset(pTHX) PADOFFSET Perl_find_threadsv(pTHX_ const char *name) { - dTHR; char *p; PADOFFSET key; SV **svp; @@ -780,6 +799,7 @@ S_op_clear(pTHX_ OP *o) cSVOPo->op_sv = Nullsv; #endif break; + case OP_METHOD_NAMED: case OP_CONST: SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = Nullsv; @@ -839,8 +859,8 @@ S_cop_free(pTHX_ COP* cop) { Safefree(cop->cop_label); #ifdef USE_ITHREADS - Safefree(CopFILE(cop)); /* XXXXX share in a pvtable? */ - Safefree(CopSTASHPV(cop)); /* XXXXX share in a pvtable? */ + Safefree(CopFILE(cop)); /* XXX share in a pvtable? */ + Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */ #else /* NOTE: COP.cop_stash is not refcounted */ SvREFCNT_dec(CopFILEGV(cop)); @@ -903,7 +923,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); @@ -999,10 +1018,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; @@ -1119,7 +1135,6 @@ 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)) @@ -1160,7 +1175,6 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_DBSTATE: case OP_ENTERTRY: case OP_ENTER: - case OP_SCALAR: if (!(o->op_flags & OPf_KIDS)) break; /* FALL THROUGH */ @@ -1179,6 +1193,8 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_REQUIRE: /* all requires must return a boolean value */ o->op_flags &= ~OPf_WANT; + /* FALL THROUGH */ + case OP_SCALAR: return scalar(o); case OP_SPLIT: if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { @@ -1187,11 +1203,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; } @@ -1292,7 +1305,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); @@ -1323,7 +1335,6 @@ S_modkids(pTHX_ OP *o, I32 type) OP * Perl_mod(pTHX_ OP *o, I32 type) { - dTHR; OP *kid; STRLEN n_a; @@ -1341,6 +1352,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) { @@ -1371,6 +1407,7 @@ Perl_mod(pTHX_ OP *o, I32 type) } else { /* lvalue subroutine call */ o->op_private |= OPpLVAL_INTRO; + PL_modcount = RETURN_UNLIMITED_NUMBER; if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { /* Backward compatibility mode: */ o->op_private |= OPpENTERSUB_INARGS; @@ -1505,7 +1542,7 @@ Perl_mod(pTHX_ OP *o, I32 type) if (!type && cUNOPo->op_first->op_type != OP_GV) Perl_croak(aTHX_ "Can't localize through a reference"); if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { - PL_modcount = 10000; + PL_modcount = RETURN_UNLIMITED_NUMBER; return o; /* Treat \(@foo) like ordinary list. */ } /* FALL THROUGH */ @@ -1514,14 +1551,16 @@ Perl_mod(pTHX_ OP *o, I32 type) goto nomod; ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ - case OP_AASSIGN: case OP_ASLICE: case OP_HSLICE: + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; + /* FALL THROUGH */ + case OP_AASSIGN: case OP_NEXTSTATE: case OP_DBSTATE: - case OP_REFGEN: case OP_CHOMP: - PL_modcount = 10000; + PL_modcount = RETURN_UNLIMITED_NUMBER; break; case OP_RV2SV: if (!type && cUNOPo->op_first->op_type != OP_GV) @@ -1540,11 +1579,13 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_PADAV: case OP_PADHV: - PL_modcount = 10000; + PL_modcount = RETURN_UNLIMITED_NUMBER; if (type == OP_REFGEN && o->op_flags & OPf_PARENS) return o; /* Treat \(@foo) like ordinary list. */ if (scalar_mod_type(o, type)) goto nomod; + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; /* FALL THROUGH */ case OP_PADSV: PL_modcount++; @@ -1572,6 +1613,8 @@ Perl_mod(pTHX_ OP *o, I32 type) /* FALL THROUGH */ case OP_POS: case OP_VEC: + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; lvalue_func: pad_free(o->op_targ); o->op_targ = pad_alloc(o->op_type, SVs_PADMY); @@ -1586,12 +1629,15 @@ Perl_mod(pTHX_ OP *o, I32 type) if (type == OP_ENTERSUB && !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) o->op_private |= OPpLVAL_DEFER; + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; PL_modcount++; break; case OP_SCOPE: case OP_LEAVE: case OP_ENTER: + case OP_LINESEQ: if (o->op_flags & OPf_KIDS) mod(cLISTOPo->op_last, type); break; @@ -1610,8 +1656,14 @@ Perl_mod(pTHX_ OP *o, I32 type) for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) mod(kid, type); break; + + case OP_RETURN: + if (type != OP_LEAVESUBLV) + goto nomod; + break; /* mod()ing was handled by ck_return() */ } - o->op_flags |= OPf_MOD; + if (type != OP_LEAVESUBLV) + o->op_flags |= OPf_MOD; if (type == OP_AASSIGN || type == OP_SASSIGN) o->op_flags |= OPf_SPECIAL|OPf_REF; @@ -1620,7 +1672,8 @@ Perl_mod(pTHX_ OP *o, I32 type) o->op_flags &= ~OPf_SPECIAL; PL_hints |= HINT_BLOCK_SCOPE; } - else if (type != OP_GREPSTART && type != OP_ENTERSUB) + else if (type != OP_GREPSTART && type != OP_ENTERSUB + && type != OP_LEAVESUBLV) o->op_flags |= OPf_REF; return o; } @@ -1845,6 +1898,37 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) LEAVE; } +void +Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, + char *attrstr, STRLEN len) +{ + OP *attrs = Nullop; + + if (!len) { + len = strlen(attrstr); + } + + while (len) { + for (; isSPACE(*attrstr) && len; --len, ++attrstr) ; + if (len) { + char *sstr = attrstr; + for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ; + attrs = append_elem(OP_LIST, attrs, + newSVOP(OP_CONST, 0, + newSVpvn(sstr, attrstr-sstr))); + } + } + + Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, + newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), + Nullsv, prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), + prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, + newRV((SV*)cv)), + attrs))); +} + STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs) { @@ -1927,7 +2011,6 @@ Perl_sawparens(pTHX_ OP *o) OP * Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) { - dTHR; OP *o; if (ckWARN(WARN_MISC) && @@ -1946,11 +2029,14 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) desc, sample, sample); } - if (right->op_type == OP_MATCH || + if (!(right->op_flags & OPf_STACKED) && + (right->op_type == OP_MATCH || right->op_type == OP_SUBST || - right->op_type == OP_TRANS) { + right->op_type == OP_TRANS)) { right->op_flags |= OPf_STACKED; - if (right->op_type != OP_MATCH) + if (right->op_type != OP_MATCH && + ! (right->op_type == OP_TRANS && + right->op_private & OPpTRANS_IDENTICAL)) left = mod(left, right->op_type); if (right->op_type == OP_TRANS) o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); @@ -2011,7 +2097,6 @@ Perl_save_hints(pTHX) int Perl_block_start(pTHX_ int full) { - dTHR; int retval = PL_savestack_ix; SAVEI32(PL_comppad_name_floor); @@ -2040,7 +2125,6 @@ Perl_block_start(pTHX_ int full) OP* Perl_block_end(pTHX_ I32 floor, OP *seq) { - dTHR; int needblockscope = PL_hints & HINT_BLOCK_SCOPE; OP* retval = scalarseq(seq); LEAVE_SCOPE(floor); @@ -2068,7 +2152,6 @@ S_newDEFSVOP(pTHX) void Perl_newPROG(pTHX_ OP *o) { - dTHR; if (PL_in_eval) { if (PL_eval_root) return; @@ -2113,10 +2196,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", @@ -2151,7 +2233,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; @@ -2269,7 +2350,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; @@ -2317,13 +2397,6 @@ Perl_convert(pTHX_ I32 type, I32 flags, OP *o) if (o->op_type != type) return o; - if (cLISTOPo->op_children < 7) { - /* XXX do we really need to do this if we're done appending?? */ - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) - last = kid; - cLISTOPo->op_last = last; /* in case check substituted last arg */ - } - return fold_constants(o); } @@ -2351,7 +2424,6 @@ Perl_append_elem(pTHX_ I32 type, OP *first, OP *last) ((LISTOP*)first)->op_first = last; } ((LISTOP*)first)->op_last = last; - ((LISTOP*)first)->op_children++; return first; } @@ -2372,10 +2444,8 @@ Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) first->op_last->op_sibling = last->op_first; first->op_last = last->op_last; - first->op_children += last->op_children; - if (first->op_children) - first->op_flags |= OPf_KIDS; - + first->op_flags |= (last->op_flags & OPf_KIDS); + #ifdef PL_OP_SLAB_ALLOC #else Safefree(last); @@ -2405,7 +2475,7 @@ Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) first->op_sibling = ((LISTOP*)last)->op_first; ((LISTOP*)last)->op_first = first; } - ((LISTOP*)last)->op_children++; + last->op_flags |= OPf_KIDS; return last; } @@ -2438,7 +2508,8 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) listop->op_type = type; listop->op_ppaddr = PL_ppaddr[type]; - listop->op_children = (first != 0) + (last != 0); + if (first || last) + flags |= OPf_KIDS; listop->op_flags = flags; if (!last && first) @@ -2458,8 +2529,6 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) if (!last) listop->op_last = pushop; } - else if (listop->op_children) - listop->op_flags |= OPf_KIDS; return (OP*)listop; } @@ -2556,25 +2625,33 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) SV *rstr = ((SVOP*)repl)->op_sv; STRLEN tlen; STRLEN rlen; - register U8 *t = (U8*)SvPV(tstr, tlen); - register U8 *r = (U8*)SvPV(rstr, rlen); + U8 *t = (U8*)SvPV(tstr, tlen); + U8 *r = (U8*)SvPV(rstr, rlen); register I32 i; register I32 j; I32 del; I32 complement; I32 squash; + I32 grows = 0; register short *tbl; + PL_hints |= HINT_BLOCK_SCOPE; complement = o->op_private & OPpTRANS_COMPLEMENT; del = o->op_private & OPpTRANS_DELETE; squash = o->op_private & OPpTRANS_SQUASH; + + if (SvUTF8(tstr)) + o->op_private |= OPpTRANS_FROM_UTF; + + if (SvUTF8(rstr)) + o->op_private |= OPpTRANS_TO_UTF; if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { SV* listsv = newSVpvn("# comment\n",10); SV* transv = 0; U8* tend = t + tlen; U8* rend = r + rlen; - I32 ulen; + STRLEN ulen; U32 tfirst = 1; U32 tlast = 0; I32 tdiff; @@ -2585,15 +2662,17 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) I32 none = 0; U32 max = 0; I32 bits; - I32 grows = 0; I32 havefinal = 0; U32 final; I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; I32 to_utf = o->op_private & OPpTRANS_TO_UTF; + U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend); + U8* rsave = to_utf ? NULL : trlist_upgrade(&r, &rend); 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; @@ -2601,7 +2680,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) while (t < tend) { cp[i++] = t; t += UTF8SKIP(t); - if (*t == 0xff) { + if (t < tend && *t == 0xff) { t++; t += UTF8SKIP(t); } @@ -2609,7 +2688,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(s, &ulen); + I32 cur = j < i - 1 ? cp[j+1] - s : tend - s; + UV val = utf8_to_uv(s, cur, &ulen, 0); s += ulen; diff = val - nextmin; if (diff > 0) { @@ -2621,8 +2701,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); } } - if (*s == 0xff) - val = utf8_to_uv(s+1, &ulen); + if (s < tend && *s == 0xff) + val = utf8_to_uv(s+1, cur - 1, &ulen, 0); if (val >= nextmin) nextmin = val + 1; } @@ -2634,29 +2714,27 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) t = (U8*)SvPVX(transv); tlen = SvCUR(transv); tend = t + tlen; + Safefree(cp); } else if (!rlen && !del) { r = t; rlen = tlen; rend = tend; } if (!squash) { - if (to_utf && from_utf) { /* only counting characters */ - if (t == r || (tlen == rlen && memEQ(t, r, tlen))) - o->op_private |= OPpTRANS_IDENTICAL; - } - else { /* straight latin-1 translation */ - if (tlen == 4 && memEQ(t, "\0\377\303\277", 4) && - rlen == 4 && memEQ(r, "\0\377\303\277", 4)) + if (t == r || + (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) + { o->op_private |= OPpTRANS_IDENTICAL; - } + } } while (t < tend || tfirst <= tlast) { /* see if we need more "t" chars */ if (tfirst > tlast) { - tfirst = (I32)utf8_to_uv(t, &ulen); + 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(++t, &ulen); + t++; + tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0); t += ulen; } else @@ -2666,10 +2744,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(r, &ulen); + 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(++r, &ulen); + r++; + rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0); r += ulen; } else @@ -2711,20 +2790,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (rfirst + diff > max) max = rfirst + diff; rfirst += diff + 1; - if (!grows) { - if (rfirst <= 0x80) - ; - else if (rfirst <= 0x800) - grows |= (tfirst < 0x80); - else if (rfirst <= 0x10000) - grows |= (tfirst < 0x800); - else if (rfirst <= 0x200000) - grows |= (tfirst < 0x10000); - else if (rfirst <= 0x4000000) - grows |= (tfirst < 0x200000); - else if (rfirst <= 0x80000000) - grows |= (tfirst < 0x4000000); - } + if (!grows) + grows = (UNISKIP(tfirst) < UNISKIP(rfirst)); } tfirst += diff + 1; } @@ -2740,6 +2807,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) else bits = 8; + Safefree(cPVOPo->op_pv); cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none); SvREFCNT_dec(listsv); if (transv) @@ -2749,9 +2817,14 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, newSVuv((UV)final), 0); - if (grows && to_utf) + if (grows) o->op_private |= OPpTRANS_GROWS; + if (tsave) + Safefree(tsave); + if (rsave) + Safefree(rsave); + op_free(expr); op_free(repl); return o; @@ -2772,8 +2845,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) else tbl[i] = i; } - else + else { + if (i < 128 && r[j] >= 128) + grows = 1; tbl[i] = r[j++]; + } } } } @@ -2794,10 +2870,15 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } --j; } - if (tbl[t[i]] == -1) + if (tbl[t[i]] == -1) { + if (t[i] < 128 && r[j] >= 128) + grows = 1; tbl[t[i]] = r[j]; + } } } + if (grows) + o->op_private |= OPpTRANS_GROWS; op_free(expr); op_free(repl); @@ -2807,7 +2888,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); @@ -2834,7 +2914,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; @@ -2854,7 +2933,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)) @@ -3025,7 +3104,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)); @@ -3054,7 +3132,6 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) void Perl_package(pTHX_ OP *o) { - dTHR; SV *sv; save_hptr(&PL_curstash); @@ -3222,8 +3299,15 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) sv = va_arg(*args, SV*); } } - utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), - veop, modname, imop); + { + line_t ocopline = PL_copline; + int oexpect = PL_expect; + + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); + PL_expect = oexpect; + PL_copline = ocopline; + } } OP * @@ -3309,7 +3393,6 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } if (list_assignment(left)) { - dTHR; OP *curop; PL_modcount = 0; @@ -3366,7 +3449,11 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } else if (curop->op_type == OP_PUSHRE) { if (((PMOP*)curop)->op_pmreplroot) { +#ifdef USE_ITHREADS + GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot]; +#else GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot; +#endif if (gv == PL_defgv || SvCUR(gv) == PL_generation) break; SvCUR(gv) = PL_generation; @@ -3411,7 +3498,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } } else { - if (PL_modcount < 10000 && + if (PL_modcount < RETURN_UNLIMITED_NUMBER && ((LISTOP*)right)->op_last->op_type == OP_CONST) { SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; @@ -3446,7 +3533,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; @@ -3486,9 +3572,9 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) PL_copline = NOLINE; } #ifdef USE_ITHREADS - CopFILE_set(cop, CopFILE(PL_curcop)); /* XXXXX share in a pvtable? */ + CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ #else - CopFILEGV_set(cop, (GV*)SvREFCNT_inc(CopFILEGV(PL_curcop))); + CopFILEGV_set(cop, CopFILEGV(PL_curcop)); #endif CopSTASH_set(cop, PL_curstash); @@ -3535,7 +3621,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; @@ -3647,7 +3732,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; @@ -3701,7 +3785,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; @@ -3748,7 +3831,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 && @@ -3804,7 +3886,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; @@ -3845,10 +3926,12 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * if (cont) { next = LINKLIST(cont); - loopflags |= OPpLOOP_CONTINUE; } if (expr) { - cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0)); + OP *unstack = newOP(OP_UNSTACK, 0); + if (!next) + next = unstack; + cont = append_elem(OP_LINESEQ, cont, unstack); if ((line_t)whileline != NOLINE) { PL_copline = whileline; cont = append_elem(OP_LINESEQ, cont, @@ -3871,8 +3954,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * if (listop) ((LISTOP*)listop)->op_last->op_next = condop = (o == listop ? redo : LINKLIST(o)); - if (!next) - next = condop; } else o = listop; @@ -3997,7 +4078,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; @@ -4024,7 +4104,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)); @@ -4046,16 +4125,19 @@ Perl_cv_undef(pTHX_ CV *cv) SAVEVPTR(PL_curpad); PL_curpad = 0; - if (!CvCLONED(cv)) - op_free(CvROOT(cv)); + op_free(CvROOT(cv)); CvROOT(cv) = Nullop; LEAVE; } SvPOK_off((SV*)cv); /* forget prototype */ - CvFLAGS(cv) = 0; - SvREFCNT_dec(CvGV(cv)); CvGV(cv) = Nullgv; - SvREFCNT_dec(CvOUTSIDE(cv)); + /* Since closure prototypes have the same lifetime as the containing + * CV, they don't hold a refcount on the outside CV. This avoids + * the refcount loop between the outer CV (which keeps a refcount to + * the closure prototype in the pad entry for pp_anoncode()) and the + * closure prototype, and the ensuing memory leak. --GSAR */ + if (!CvANON(cv) || CvCLONED(cv)) + SvREFCNT_dec(CvOUTSIDE(cv)); CvOUTSIDE(cv) = Nullcv; if (CvPADLIST(cv)) { /* may be during global destruction */ @@ -4078,6 +4160,7 @@ Perl_cv_undef(pTHX_ CV *cv) } CvPADLIST(cv) = Nullav; } + CvFLAGS(cv) = 0; } STATIC void @@ -4130,7 +4213,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); @@ -4161,9 +4243,9 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) CvOWNER(cv) = 0; #endif /* USE_THREADS */ CvFILE(cv) = CvFILE(proto); - CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto)); + CvGV(cv) = CvGV(proto); CvSTASH(cv) = CvSTASH(proto); - CvROOT(cv) = CvROOT(proto); + CvROOT(cv) = OpREFCNT_inc(CvROOT(proto)); CvSTART(cv) = CvSTART(proto); if (outside) CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside); @@ -4273,8 +4355,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; @@ -4364,7 +4444,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,8 +4506,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) goto done; } /* ahem, death to those who redefine active sort subs */ - if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv)) + if (PL_curstackinfo->si_type == PERLSI_SORT && + PL_sortcop == CvSTART(cv)) { + op_free(block); Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name); + } if (!block) goto withattrs; if ((const_sv = cv_const_sv(cv))) @@ -4485,8 +4567,30 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvOUTSIDE(PL_compcv) = 0; CvPADLIST(cv) = CvPADLIST(PL_compcv); CvPADLIST(PL_compcv) = 0; - if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */ - CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv); + /* inner references to PL_compcv must be fixed up ... */ + { + AV *padlist = CvPADLIST(cv); + AV *comppad_name = (AV*)AvARRAY(padlist)[0]; + AV *comppad = (AV*)AvARRAY(padlist)[1]; + SV **namepad = AvARRAY(comppad_name); + SV **curpad = AvARRAY(comppad); + for (ix = AvFILLp(comppad_name); ix > 0; ix--) { + SV *namesv = namepad[ix]; + if (namesv && namesv != &PL_sv_undef + && *SvPVX(namesv) == '&') + { + CV *innercv = (CV*)curpad[ix]; + if (CvOUTSIDE(innercv) == PL_compcv) { + CvOUTSIDE(innercv) = cv; + if (!CvANON(innercv) || CvCLONED(innercv)) { + (void)SvREFCNT_inc(cv); + SvREFCNT_dec(PL_compcv); + } + } + } + } + } + /* ... before we throw it away */ SvREFCNT_dec(PL_compcv); } else { @@ -4497,7 +4601,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PL_sub_generation++; } } - CvGV(cv) = (GV*)SvREFCNT_inc(gv); + CvGV(cv) = gv; CvFILE(cv) = CopFILE(PL_curcop); CvSTASH(cv) = PL_curstash; #ifdef USE_THREADS @@ -4541,7 +4645,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv); if (CvLVALUE(cv)) { - CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block)); + CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, + mod(scalarseq(block), OP_LEAVESUBLV)); } else { CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); @@ -4589,6 +4694,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } + /* If a potential closure prototype, don't keep a refcount on outer CV. + * This is okay as the lifetime of the prototype is tied to the + * lifetime of the outer CV. Avoids memory leak due to reference + * loop. --GSAR */ + if (!name) + SvREFCNT_dec(CvOUTSIDE(cv)); + if (name || aname) { char *s; char *tname = (name ? name : aname); @@ -4636,8 +4748,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!PL_beginav) PL_beginav = newAV(); DEBUG_x( dump_sub(gv) ); - av_push(PL_beginav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_push(PL_beginav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ call_list(oldscope, PL_beginav); PL_curcop = &PL_compiling; @@ -4649,8 +4761,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PL_endav = newAV(); DEBUG_x( dump_sub(gv) ); av_unshift(PL_endav, 1); - av_store(PL_endav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_store(PL_endav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "CHECK") && !PL_error_count) { if (!PL_checkav) @@ -4659,8 +4771,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (PL_main_start && ckWARN(WARN_VOID)) Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block"); av_unshift(PL_checkav, 1); - av_store(PL_checkav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_store(PL_checkav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "INIT") && !PL_error_count) { if (!PL_initav) @@ -4668,8 +4780,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) DEBUG_x( dump_sub(gv) ); if (PL_main_start && ckWARN(WARN_VOID)) Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); - av_push(PL_initav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_push(PL_initav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } } @@ -4692,13 +4804,13 @@ eligible for inlining at compile-time. void Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) { - dTHR; ENTER; - SAVECOPLINE(PL_curcop); - SAVEHINTS(); + SAVECOPLINE(PL_curcop); CopLINE_set(PL_curcop, PL_copline); + + SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) { @@ -4734,7 +4846,6 @@ Used by C<xsubpp> 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; @@ -4771,7 +4882,7 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) PL_sub_generation++; } } - CvGV(cv) = (GV*)SvREFCNT_inc(gv); + CvGV(cv) = gv; #ifdef USE_THREADS New(666, CvMUTEXP(cv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(cv)); @@ -4795,15 +4906,15 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) if (strEQ(s, "BEGIN")) { if (!PL_beginav) PL_beginav = newAV(); - av_push(PL_beginav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_push(PL_beginav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "END")) { if (!PL_endav) PL_endav = newAV(); av_unshift(PL_endav, 1); - av_store(PL_endav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_store(PL_endav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "CHECK")) { if (!PL_checkav) @@ -4811,16 +4922,16 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) if (PL_main_start && ckWARN(WARN_VOID)) Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block"); av_unshift(PL_checkav, 1); - av_store(PL_checkav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_store(PL_checkav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "INIT")) { if (!PL_initav) PL_initav = newAV(); if (PL_main_start && ckWARN(WARN_VOID)) Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); - av_push(PL_initav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_push(PL_initav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } } else @@ -4833,7 +4944,6 @@ done: void Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) { - dTHR; register CV *cv; char *name; GV *gv; @@ -4858,7 +4968,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) } cv = PL_compcv; GvFORM(gv) = cv; - CvGV(cv) = (GV*)SvREFCNT_inc(gv); + CvGV(cv) = gv; CvFILE(cv) = CopFILE(PL_curcop); for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { @@ -4931,8 +5041,6 @@ Perl_oopsAV(pTHX_ OP *o) OP * Perl_oopsHV(pTHX_ OP *o) { - dTHR; - switch (o->op_type) { case OP_PADSV: case OP_PADAV: @@ -5229,7 +5337,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); @@ -5324,11 +5431,13 @@ Perl_ck_rvconst(pTHX_ register OP *o) #ifdef USE_ITHREADS /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); + SvREFCNT_dec(PL_curpad[kPADOP->op_padix]); GvIN_PAD_on(gv); PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv); #else kid->op_sv = SvREFCNT_inc(gv); #endif + kid->op_private = 0; kid->op_ppaddr = PL_ppaddr[OP_GV]; } } @@ -5338,7 +5447,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) { @@ -5376,7 +5484,6 @@ Perl_ck_ftst(pTHX_ OP *o) OP * Perl_ck_fun(pTHX_ OP *o) { - dTHR; register OP *kid; OP **tokid; OP *sibl; @@ -5616,6 +5723,7 @@ Perl_ck_glob(pTHX_ OP *o) gv = newGVgen("main"); gv_IOadd(gv); append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); + SvREFCNT_dec((SV*)gv); /* had excess refcnt */ scalarkids(o); return o; } @@ -5701,10 +5809,13 @@ 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: + /* This is needed for + if (defined %stash::) + to work. Do not break Tk. + */ break; /* Globals via GV can be undef */ case OP_PADAV: case OP_AASSIGN: /* Is this a good idea? */ @@ -5714,6 +5825,10 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ "\t(Maybe you should just omit the defined()?)\n"); break; case OP_RV2HV: + /* This is needed for + if (defined %stash::) + to work. Do not break Tk. + */ break; /* Globals via GV can be undef */ case OP_PADHV: Perl_warner(aTHX_ WARN_DEPRECATED, @@ -5932,6 +6047,17 @@ Perl_ck_require(pTHX_ OP *o) return ck_fun(o); } +OP * +Perl_ck_return(pTHX_ OP *o) +{ + OP *kid; + if (CvLVALUE(PL_compcv)) { + for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + mod(kid, OP_LEAVESUBLV); + } + return o; +} + #if 0 OP * Perl_ck_retarget(pTHX_ OP *o) @@ -5994,6 +6120,7 @@ Perl_ck_shift(pTHX_ OP *o) OP * Perl_ck_sort(pTHX_ OP *o) { + OP *firstkid; o->op_private = 0; #ifdef USE_LOCALE if (PL_hints & HINT_LOCALE) @@ -6002,10 +6129,10 @@ Perl_ck_sort(pTHX_ OP *o) if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED) simplify_sort(o); - if (o->op_flags & OPf_STACKED) { /* may have been cleared */ - OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + if (o->op_flags & OPf_STACKED) { /* may have been cleared */ OP *k; - kid = kUNOP->op_first; /* get past null */ + OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { linklist(kid); @@ -6035,24 +6162,32 @@ Perl_ck_sort(pTHX_ OP *o) } peep(k); - kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ - if (o->op_type == OP_SORT) + kid = firstkid; + if (o->op_type == OP_SORT) { + /* provide scalar context for comparison function/block */ + kid = scalar(kid); kid->op_next = kid; + } else kid->op_next = k; o->op_flags |= OPf_SPECIAL; } else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV) - null(cLISTOPo->op_first->op_sibling); + null(firstkid); + + firstkid = firstkid->op_sibling; } + /* provide list context for arguments */ + if (o->op_type == OP_SORT) + list(firstkid); + return 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; @@ -6112,7 +6247,6 @@ S_simplify_sort(pTHX_ OP *o) kid = cLISTOPo->op_first->op_sibling; cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */ op_free(kid); /* then delete it */ - cLISTOPo->op_children--; } OP * @@ -6134,7 +6268,7 @@ Perl_ck_split(pTHX_ OP *o) cLISTOPo->op_last = kid; /* There was only one element previously */ } - if (kid->op_type != OP_MATCH) { + if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { OP *sibl = kid->op_sibling; kid->op_sibling = 0; kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop); @@ -6186,7 +6320,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; @@ -6251,7 +6384,9 @@ Perl_ck_subr(pTHX_ OP *o) proto++; arg++; if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF) - bad_type(arg, "block", gv_ename(namegv), o2); + bad_type(arg, + arg == 1 ? "block or sub {}" : "sub {}", + gv_ename(namegv), o2); break; case '*': /* '*' allows any scalar type, including bareword */ @@ -6299,8 +6434,8 @@ Perl_ck_subr(pTHX_ OP *o) bad_type(arg, "symbol", gv_ename(namegv), o2); goto wrapref; case '&': - if (o2->op_type != OP_RV2CV) - bad_type(arg, "sub", gv_ename(namegv), o2); + if (o2->op_type != OP_ENTERSUB) + bad_type(arg, "subroutine entry", gv_ename(namegv), o2); goto wrapref; case '$': if (o2->op_type != OP_RV2SV @@ -6378,15 +6513,29 @@ Perl_ck_trunc(pTHX_ OP *o) return ck_fun(o); } +OP * +Perl_ck_substr(pTHX_ OP *o) +{ + o = ck_fun(o); + if ((o->op_flags & OPf_KIDS) && o->op_private == 4) { + OP *kid = cLISTOPo->op_first; + + if (kid->op_type == OP_NULL) + kid = kid->op_sibling; + if (kid) + kid->op_flags |= OPf_MOD; + + } + return o; +} + /* A peephole optimizer. We visit the ops in the order they're to execute. */ void Perl_peep(pTHX_ register OP *o) { - dTHR; register OP* oldop = 0; STRLEN n_a; - OP *last_composite = Nullop; if (!o || o->op_seq) return; @@ -6405,7 +6554,6 @@ Perl_peep(pTHX_ register OP *o) case OP_DBSTATE: PL_curcop = ((COP*)o); /* for warnings */ o->op_seq = PL_op_seqmax++; - last_composite = Nullop; break; case OP_CONST: @@ -6417,9 +6565,18 @@ Perl_peep(pTHX_ register OP *o) * for reference counts, sv_upgrade() etc. */ if (cSVOP->op_sv) { PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP); - SvREFCNT_dec(PL_curpad[ix]); - SvPADTMP_on(cSVOPo->op_sv); - PL_curpad[ix] = cSVOPo->op_sv; + if (SvPADTMP(cSVOPo->op_sv)) { + /* If op_sv is already a PADTMP then it is being used by + * another pad, so make a copy. */ + sv_setsv(PL_curpad[ix],cSVOPo->op_sv); + SvREADONLY_on(PL_curpad[ix]); + SvREFCNT_dec(cSVOPo->op_sv); + } + else { + SvREFCNT_dec(PL_curpad[ix]); + SvPADTMP_on(cSVOPo->op_sv); + PL_curpad[ix] = cSVOPo->op_sv; + } cSVOPo->op_sv = Nullsv; o->op_targ = ix; } @@ -6487,7 +6644,7 @@ Perl_peep(pTHX_ register OP *o) (PL_op = pop->op_next) && pop->op_next->op_type == OP_AELEM && !(pop->op_next->op_private & - (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) && + (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase) <= 255 && i >= 0) @@ -6535,9 +6692,16 @@ Perl_peep(pTHX_ register OP *o) break; case OP_ENTERLOOP: + case OP_ENTERITER: 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; @@ -6545,6 +6709,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; @@ -6677,42 +6844,6 @@ Perl_peep(pTHX_ register OP *o) break; } - case OP_RV2AV: - case OP_RV2HV: - if (!(o->op_flags & OPf_WANT) - || (o->op_flags & OPf_WANT) == OPf_WANT_LIST) - { - last_composite = o; - } - o->op_seq = PL_op_seqmax++; - break; - - case OP_RETURN: - if (o->op_next && o->op_next->op_type != OP_LEAVESUBLV) { - o->op_seq = PL_op_seqmax++; - break; - } - /* FALL THROUGH */ - - case OP_LEAVESUBLV: - if (last_composite) { - OP *r = last_composite; - - while (r->op_sibling) - r = r->op_sibling; - if (r->op_next == o - || (r->op_next->op_type == OP_LIST - && r->op_next->op_next == o)) - { - if (last_composite->op_type == OP_RV2AV) - yyerror("Lvalue subs returning arrays not implemented yet"); - else - yyerror("Lvalue subs returning hashes not implemented yet"); - ; - } - } - /* FALL THROUGH */ - default: o->op_seq = PL_op_seqmax++; break; diff --git a/contrib/perl5/op.h b/contrib/perl5/op.h index 081d10c0e88a..e2699346c387 100644 --- a/contrib/perl5/op.h +++ b/contrib/perl5/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. @@ -55,7 +55,7 @@ typedef U32 PADOFFSET; /* =for apidoc Amn|U32|GIMME_V The XSUB-writer's equivalent to Perl's C<wantarray>. Returns C<G_VOID>, -C<G_SCALAR> or C<G_ARRAY> for void, scalar or array context, +C<G_SCALAR> or C<G_ARRAY> for void, scalar or list context, respectively. =for apidoc Amn|U32|GIMME @@ -94,7 +94,8 @@ Deprecated. Use C<GIMME_V> instead. /* On OP_EXISTS, treat av as av, not avhv. */ /* On OP_(ENTER|LEAVE)EVAL, don't clear $@ */ /* On OP_ENTERITER, loop var is per-thread */ - /* On pushre, re is /\s+/ imp. by split " " */ + /* On pushre, re is /\s+/ imp. by split " " */ + /* On regcomp, "use re 'eval'" was in scope */ /* old names; don't use in new code, but don't break them, either */ #define OPf_LIST OPf_WANT_LIST @@ -129,9 +130,7 @@ Deprecated. Use C<GIMME_V> instead. /* Private for OP_TRANS */ #define OPpTRANS_FROM_UTF 1 #define OPpTRANS_TO_UTF 2 -#define OPpTRANS_IDENTICAL 4 - /* When CU or UC, means straight latin-1 to utf-8 or vice versa */ - /* Otherwise, IDENTICAL means the right side is the same as the left */ +#define OPpTRANS_IDENTICAL 4 /* right side is same as left */ #define OPpTRANS_SQUASH 8 #define OPpTRANS_DELETE 16 #define OPpTRANS_COMPLEMENT 32 @@ -140,9 +139,6 @@ Deprecated. Use C<GIMME_V> 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. */ @@ -160,7 +156,9 @@ Deprecated. Use C<GIMME_V> instead. /* OP_?ELEM only */ #define OPpLVAL_DEFER 16 /* Defer creation of array/hash elem */ /* OP_RV2?V, OP_GVSV only */ -#define OPpOUR_INTRO 16 /* Defer creation of array/hash elem */ +#define OPpOUR_INTRO 16 /* Variable was in an our() */ + /* OP_RV2[AH]V, OP_PAD[AH]V, OP_[AH]ELEM */ +#define OPpMAYBE_LVSUB 8 /* We might be an lvalue to return */ /* for OP_RV2?V, lower bits carry hints (currently only HINT_STRICT_REFS) */ /* Private for OPs with TARGLEX */ @@ -231,14 +229,12 @@ struct listop { BASEOP OP * op_first; OP * op_last; - U32 op_children; }; struct pmop { BASEOP OP * op_first; OP * op_last; - U32 op_children; OP * op_pmreplroot; OP * op_pmreplstart; PMOP * op_pmnext; /* list of all scanpats */ @@ -291,7 +287,6 @@ struct loop { BASEOP OP * op_first; OP * op_last; - U32 op_children; OP * op_redoop; OP * op_nextop; OP * op_lastop; @@ -415,19 +410,17 @@ struct loop { # define OP_REFCNT_LOCK MUTEX_LOCK(&PL_op_mutex) # define OP_REFCNT_UNLOCK MUTEX_UNLOCK(&PL_op_mutex) # define OP_REFCNT_TERM MUTEX_DESTROY(&PL_op_mutex) -# define OpREFCNT_set(o,n) ((o)->op_targ = (n)) -# define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop) -# define OpREFCNT_dec(o) (--(o)->op_targ) #else # define OP_REFCNT_INIT NOOP # define OP_REFCNT_LOCK NOOP # define OP_REFCNT_UNLOCK NOOP # define OP_REFCNT_TERM NOOP -# define OpREFCNT_set(o,n) NOOP -# define OpREFCNT_inc(o) (o) -# define OpREFCNT_dec(o) 0 #endif +#define OpREFCNT_set(o,n) ((o)->op_targ = (n)) +#define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop) +#define OpREFCNT_dec(o) (--(o)->op_targ) + /* flags used by Perl_load_module() */ #define PERL_LOADMOD_DENY 0x1 #define PERL_LOADMOD_NOIMPORT 0x2 diff --git a/contrib/perl5/opcode.h b/contrib/perl5/opcode.h index f0fcba9fefd1..542ec60c8b40 100644 --- a/contrib/perl5/opcode.h +++ b/contrib/perl5/opcode.h @@ -439,7 +439,7 @@ EXT char *PL_op_desc[] = { "integer addition (+)", "subtraction (-)", "integer subtraction (-)", - "concatenation (.)", + "concatenation (.) or string", "string", "left bitshift (<<)", "right bitshift (>>)", @@ -513,7 +513,7 @@ EXT char *PL_op_desc[] = { "unpack", "pack", "split", - "join", + "join or string", "list", "list slice", "anonymous list ([])", @@ -541,7 +541,7 @@ EXT char *PL_op_desc[] = { "method lookup", "subroutine entry", "subroutine exit", - "lvalue subroutine exit", + "lvalue subroutine return", "caller", "warn", "die", @@ -1205,7 +1205,7 @@ EXT OP * (CPERLscope(*PL_check)[]) (pTHX_ OP *op) = { MEMBER_TO_FPTR(Perl_ck_fun), /* oct */ MEMBER_TO_FPTR(Perl_ck_fun), /* abs */ MEMBER_TO_FPTR(Perl_ck_lengthconst), /* length */ - MEMBER_TO_FPTR(Perl_ck_fun), /* substr */ + MEMBER_TO_FPTR(Perl_ck_substr), /* substr */ MEMBER_TO_FPTR(Perl_ck_fun), /* vec */ MEMBER_TO_FPTR(Perl_ck_index), /* index */ MEMBER_TO_FPTR(Perl_ck_index), /* rindex */ @@ -1278,7 +1278,7 @@ EXT OP * (CPERLscope(*PL_check)[]) (pTHX_ OP *op) = { MEMBER_TO_FPTR(Perl_ck_null), /* iter */ MEMBER_TO_FPTR(Perl_ck_null), /* enterloop */ MEMBER_TO_FPTR(Perl_ck_null), /* leaveloop */ - MEMBER_TO_FPTR(Perl_ck_null), /* return */ + MEMBER_TO_FPTR(Perl_ck_return), /* return */ MEMBER_TO_FPTR(Perl_ck_null), /* last */ MEMBER_TO_FPTR(Perl_ck_null), /* next */ MEMBER_TO_FPTR(Perl_ck_null), /* redo */ diff --git a/contrib/perl5/opcode.pl b/contrib/perl5/opcode.pl index eb64e8dc14ef..82de92f4630a 100755 --- a/contrib/perl5/opcode.pl +++ b/contrib/perl5/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"; @@ -193,6 +194,9 @@ END '}', 13, # loopexop ); +my %OP_IS_SOCKET; +my %OP_IS_FILETEST; + for (@ops) { $argsum = 0; $flags = $flags{$_}; @@ -210,7 +214,12 @@ for (@ops) { $argsum |= $opclass{$1} << 9; $mul = 0x2000; # 2 ^ OASHIFT for $arg (split(' ',$args{$_})) { + if ($arg =~ /^F/) { + $OP_IS_SOCKET{$_} = 1 if $arg =~ s/s//; + $OP_IS_FILETEST{$_} = 1 if $arg =~ s/-//; + } $argnum = ($arg =~ s/\?//) ? 8 : 0; + die "op = $_, arg = $arg\n" unless length($arg) == 1; $argnum += $argnum{$arg}; warn "# Conflicting bit 32 for '$_'.\n" if $argnum & 8 and $mul == 0x10000000; @@ -228,6 +237,20 @@ print <<END; END_EXTERN_C END +if (keys %OP_IS_SOCKET) { + print ON "\n#define OP_IS_SOCKET(op) \\\n\t("; + print ON join(" || \\\n\t ", + map { "(op) == OP_" . uc() } sort keys %OP_IS_SOCKET); + print ON ")\n\n"; +} + +if (keys %OP_IS_FILETEST) { + print ON "\n#define OP_IS_FILETEST(op) \\\n\t("; + print ON join(" || \\\n\t ", + map { "(op) == OP_" . uc() } sort keys %OP_IS_FILETEST); + print ON ")\n\n"; +} + close OC or die "Error closing opcode.h: $!"; close ON or die "Error closing opnames.h: $!"; @@ -299,7 +322,7 @@ sub tab { # trans not OK (dTARG; TARG = sv_newmortal();) # ucfirst etc not OK: TMP arg processed inplace # quotemeta not OK (unsafe when TARG == arg) -# each repeat not OK too due to array context +# each repeat not OK too due to list context # pack split - unknown whether they are safe # sprintf: is calling do_sprintf(TARG,...) which can act on TARG # before other args are processed. @@ -434,7 +457,7 @@ add addition (+) ck_null IfsT2 S S i_add integer addition (+) ck_null ifsT2 S S subtract subtraction (-) ck_null IfsT2 S S i_subtract integer subtraction (-) ck_null ifsT2 S S -concat concatenation (.) ck_concat fsT2 S S +concat concatenation (.) or string ck_concat fsT2 S S stringify string ck_fun fsT@ S left_shift left bitshift (<<) ck_bitop fsT2 S S @@ -493,7 +516,7 @@ abs abs ck_fun fsTu% S? # String stuff. length length ck_lengthconst isTu% S? -substr substr ck_fun st@ S S S? S? +substr substr ck_substr st@ S S S? S? vec vec ck_fun ist@ S S S index index ck_index isT@ S S S? @@ -533,7 +556,7 @@ hslice hash slice ck_null m@ H L unpack unpack ck_fun @ S S pack pack ck_fun mst@ S L split split ck_split t@ S S S -join join ck_join mst@ S L +join join or string ck_join mst@ S L # List operators. @@ -574,7 +597,7 @@ orassign logical or assignment (||=) ck_null s| method method lookup ck_method d1 entersub subroutine entry ck_subr dmt1 L leavesub subroutine exit ck_null 1 -leavesublv lvalue subroutine exit ck_null 1 +leavesublv lvalue subroutine return ck_null 1 caller caller ck_fun t% S? warn warn ck_fun imst@ L die die ck_fun dimst@ L @@ -591,7 +614,7 @@ enteriter foreach loop entry ck_null d{ iter foreach loop iterator ck_null 0 enterloop loop entry ck_null d{ leaveloop loop exit ck_null 2 -return return ck_null dm@ L +return return ck_return dm@ L last last ck_null ds} next next ck_null ds} redo redo ck_null ds} @@ -635,8 +658,8 @@ sysseek sysseek ck_fun s@ F S S sysread sysread ck_fun imst@ F R S S? syswrite syswrite ck_fun imst@ F S S? S? -send send ck_fun imst@ F S S S? -recv recv ck_fun imst@ F R S S +send send ck_fun imst@ Fs S S S? +recv recv ck_fun imst@ Fs R S S eof eof ck_eof is% F? tell tell ck_fun st% F? @@ -650,52 +673,52 @@ flock flock ck_fun isT@ F S # Sockets. -socket socket ck_fun is@ F S S S -sockpair socketpair ck_fun is@ F F S S S +socket socket ck_fun is@ Fs S S S +sockpair socketpair ck_fun is@ Fs Fs S S S -bind bind ck_fun is@ F S -connect connect ck_fun is@ F S -listen listen ck_fun is@ F S -accept accept ck_fun ist@ F F -shutdown shutdown ck_fun ist@ F S +bind bind ck_fun is@ Fs S +connect connect ck_fun is@ Fs S +listen listen ck_fun is@ Fs S +accept accept ck_fun ist@ Fs Fs +shutdown shutdown ck_fun ist@ Fs S -gsockopt getsockopt ck_fun is@ F S S -ssockopt setsockopt ck_fun is@ F S S S +gsockopt getsockopt ck_fun is@ Fs S S +ssockopt setsockopt ck_fun is@ Fs S S S -getsockname getsockname ck_fun is% F -getpeername getpeername ck_fun is% F +getsockname getsockname ck_fun is% Fs +getpeername getpeername ck_fun is% Fs # Stat calls. lstat lstat ck_ftst u- F stat stat ck_ftst u- F -ftrread -R ck_ftst isu- F -ftrwrite -W ck_ftst isu- F -ftrexec -X ck_ftst isu- F -fteread -r ck_ftst isu- F -ftewrite -w ck_ftst isu- F -fteexec -x ck_ftst isu- F -ftis -e ck_ftst isu- F -fteowned -O ck_ftst isu- F -ftrowned -o ck_ftst isu- F -ftzero -z ck_ftst isu- F -ftsize -s ck_ftst istu- F -ftmtime -M ck_ftst stu- F -ftatime -A ck_ftst stu- F -ftctime -C ck_ftst stu- F -ftsock -S ck_ftst isu- F -ftchr -c ck_ftst isu- F -ftblk -b ck_ftst isu- F -ftfile -f ck_ftst isu- F -ftdir -d ck_ftst isu- F -ftpipe -p ck_ftst isu- F -ftlink -l ck_ftst isu- F -ftsuid -u ck_ftst isu- F -ftsgid -g ck_ftst isu- F -ftsvtx -k ck_ftst isu- F -fttty -t ck_ftst is- F -fttext -T ck_ftst isu- F -ftbinary -B ck_ftst isu- F +ftrread -R ck_ftst isu- F- +ftrwrite -W ck_ftst isu- F- +ftrexec -X ck_ftst isu- F- +fteread -r ck_ftst isu- F- +ftewrite -w ck_ftst isu- F- +fteexec -x ck_ftst isu- F- +ftis -e ck_ftst isu- F- +fteowned -O ck_ftst isu- F- +ftrowned -o ck_ftst isu- F- +ftzero -z ck_ftst isu- F- +ftsize -s ck_ftst istu- F- +ftmtime -M ck_ftst stu- F- +ftatime -A ck_ftst stu- F- +ftctime -C ck_ftst stu- F- +ftsock -S ck_ftst isu- F- +ftchr -c ck_ftst isu- F- +ftblk -b ck_ftst isu- F- +ftfile -f ck_ftst isu- F- +ftdir -d ck_ftst isu- F- +ftpipe -p ck_ftst isu- F- +ftlink -l ck_ftst isu- F- +ftsuid -u ck_ftst isu- F- +ftsgid -g ck_ftst isu- F- +ftsvtx -k ck_ftst isu- F- +fttty -t ck_ftst is- F- +fttext -T ck_ftst isu- F- +ftbinary -B ck_ftst isu- F- # File calls. diff --git a/contrib/perl5/opnames.h b/contrib/perl5/opnames.h index e9f8b4fe6feb..ba28f685fc51 100644 --- a/contrib/perl5/opnames.h +++ b/contrib/perl5/opnames.h @@ -360,3 +360,49 @@ typedef enum opcode { #define MAXO 351 + +#define OP_IS_SOCKET(op) \ + ((op) == OP_ACCEPT || \ + (op) == OP_BIND || \ + (op) == OP_CONNECT || \ + (op) == OP_GETPEERNAME || \ + (op) == OP_GETSOCKNAME || \ + (op) == OP_GSOCKOPT || \ + (op) == OP_LISTEN || \ + (op) == OP_RECV || \ + (op) == OP_SEND || \ + (op) == OP_SHUTDOWN || \ + (op) == OP_SOCKET || \ + (op) == OP_SOCKPAIR || \ + (op) == OP_SSOCKOPT) + + +#define OP_IS_FILETEST(op) \ + ((op) == OP_FTATIME || \ + (op) == OP_FTBINARY || \ + (op) == OP_FTBLK || \ + (op) == OP_FTCHR || \ + (op) == OP_FTCTIME || \ + (op) == OP_FTDIR || \ + (op) == OP_FTEEXEC || \ + (op) == OP_FTEOWNED || \ + (op) == OP_FTEREAD || \ + (op) == OP_FTEWRITE || \ + (op) == OP_FTFILE || \ + (op) == OP_FTIS || \ + (op) == OP_FTLINK || \ + (op) == OP_FTMTIME || \ + (op) == OP_FTPIPE || \ + (op) == OP_FTREXEC || \ + (op) == OP_FTROWNED || \ + (op) == OP_FTRREAD || \ + (op) == OP_FTRWRITE || \ + (op) == OP_FTSGID || \ + (op) == OP_FTSIZE || \ + (op) == OP_FTSOCK || \ + (op) == OP_FTSUID || \ + (op) == OP_FTSVTX || \ + (op) == OP_FTTEXT || \ + (op) == OP_FTTTY || \ + (op) == OP_FTZERO) + diff --git a/contrib/perl5/patchlevel.h b/contrib/perl5/patchlevel.h index f95db63f63c1..6f98d1c219c5 100644 --- a/contrib/perl5/patchlevel.h +++ b/contrib/perl5/patchlevel.h @@ -5,7 +5,7 @@ #define PERL_REVISION 5 /* age */ #define PERL_VERSION 6 /* epoch */ -#define PERL_SUBVERSION 0 /* generation */ +#define PERL_SUBVERSION 1 /* generation */ /* The following numbers describe the earliest compatible version of Perl ("compatibility" here being defined as sufficient binary/API diff --git a/contrib/perl5/perl.c b/contrib/perl5/perl.c index 578fafc3f1b5..9596b6a01e4a 100644 --- a/contrib/perl5/perl.c +++ b/contrib/perl5/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. @@ -180,6 +180,8 @@ perl_construct(pTHXx) # endif /* EMULATE_ATOMIC_REFCOUNTS */ MUTEX_INIT(&PL_cred_mutex); + MUTEX_INIT(&PL_sv_lock_mutex); + MUTEX_INIT(&PL_fdpid_mutex); thr = init_main_thread(); #endif /* USE_THREADS */ @@ -272,10 +274,15 @@ perl_construct(pTHXx) PL_localpatches = local_patches; /* For possible -v */ #endif +#ifdef HAVE_INTERP_INTERN + sys_intern_init(); +#endif + PerlIO_init(); /* Hook to IO system */ PL_fdpid = newAV(); /* for remembering popen pids by fd */ PL_modglobal = newHV(); /* pointers to per-interpreter module globals */ + PL_errors = newSVpvn("",0); ENTER; } @@ -291,9 +298,7 @@ Shuts down a Perl interpreter. See L<perlembed>. void perl_destruct(pTHXx) { - dTHR; int destruct_level; /* 0=none, 1=full, 2=full with checks */ - I32 last_sv_count; HV *hv; #ifdef USE_THREADS Thread t; @@ -370,6 +375,7 @@ perl_destruct(pTHXx) DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n")); MUTEX_DESTROY(&PL_threads_mutex); COND_DESTROY(&PL_nthreads_cond); + PL_nthreads--; #endif /* !defined(FAKE_THREADS) */ #endif /* USE_THREADS */ @@ -431,6 +437,21 @@ perl_destruct(pTHXx) return; } + /* jettison our possibly duplicated environment */ + +#ifdef USE_ENVIRON_ARRAY + if (environ != PL_origenviron) { + I32 i; + + for (i = 0; environ[i]; i++) + safesysfree(environ[i]); + /* Must use safesysfree() when working with environ. */ + safesysfree(environ); + + environ = PL_origenviron; + } +#endif + /* loosen bonds of global variables */ if(PL_rsfp) { @@ -555,6 +576,7 @@ perl_destruct(pTHXx) #ifdef USE_LOCALE_NUMERIC Safefree(PL_numeric_name); PL_numeric_name = Nullch; + SvREFCNT_dec(PL_numeric_radix_sv); #endif /* clear utf8 character classes */ @@ -595,9 +617,14 @@ perl_destruct(pTHXx) if (!specialWARN(PL_compiling.cop_warnings)) SvREFCNT_dec(PL_compiling.cop_warnings); PL_compiling.cop_warnings = Nullsv; -#ifndef USE_ITHREADS +#ifdef USE_ITHREADS + Safefree(CopFILE(&PL_compiling)); + CopFILE(&PL_compiling) = Nullch; + Safefree(CopSTASHPV(&PL_compiling)); +#else SvREFCNT_dec(CopFILEGV(&PL_compiling)); - CopFILEGV_set(&PL_compiling, Nullgv); + CopFILEGV(&PL_compiling) = Nullgv; + /* cop_stash is not refcounted */ #endif /* Prepare to destruct main symbol table. */ @@ -631,13 +658,13 @@ perl_destruct(pTHXx) } /* Now absolutely destruct everything, somehow or other, loops or no. */ - last_sv_count = 0; SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */ SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */ - while (PL_sv_count != 0 && PL_sv_count != last_sv_count) { - last_sv_count = PL_sv_count; - sv_clean_all(); - } + + /* the 2 is for PL_fdpid and PL_strtab */ + while (PL_sv_count > 2 && sv_clean_all()) + ; + SvFLAGS(PL_fdpid) &= ~SVTYPEMASK; SvFLAGS(PL_fdpid) |= SVt_PVAV; SvFLAGS(PL_strtab) &= ~SVTYPEMASK; @@ -647,6 +674,10 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_fdpid); /* needed in io_close() */ PL_fdpid = Nullav; +#ifdef HAVE_INTERP_INTERN + sys_intern_clear(); +#endif + /* Destruct the global string table. */ { /* Yell and reset the HeVAL() slots that are still holding refcounts, @@ -678,6 +709,11 @@ perl_destruct(pTHXx) } SvREFCNT_dec(PL_strtab); +#ifdef USE_ITHREADS + /* free the pointer table used for cloning */ + ptr_table_free(PL_ptr_table); +#endif + /* free special SVs */ SvREFCNT(&PL_sv_yes) = 0; @@ -696,9 +732,6 @@ perl_destruct(pTHXx) if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count); - sv_free_arenas(); - - /* No SVs have survived, need to clean out */ Safefree(PL_origfilename); Safefree(PL_reg_start_tmp); if (PL_reg_curpm) @@ -706,6 +739,9 @@ perl_destruct(pTHXx) Safefree(PL_reg_poscache); Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh)); Safefree(PL_op_mask); + Safefree(PL_psig_ptr); + Safefree(PL_psig_name); + Safefree(PL_bitcount); nuke_stacks(); PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */ @@ -715,6 +751,7 @@ perl_destruct(pTHXx) MUTEX_DESTROY(&PL_sv_mutex); MUTEX_DESTROY(&PL_eval_mutex); MUTEX_DESTROY(&PL_cred_mutex); + MUTEX_DESTROY(&PL_fdpid_mutex); COND_DESTROY(&PL_eval_cond); #ifdef EMULATE_ATOMIC_REFCOUNTS MUTEX_DESTROY(&PL_svref_mutex); @@ -727,6 +764,8 @@ perl_destruct(pTHXx) PL_thrsv = Nullsv; #endif /* USE_THREADS */ + sv_free_arenas(); + /* As the absolutely last thing, free the non-arena SV for mess() */ if (PL_mess_sv) { @@ -794,7 +833,6 @@ Tells a Perl interpreter to parse a Perl script. See L<perlembed>. int perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) { - dTHR; I32 oldscope; int ret; dJMPENV; @@ -817,7 +855,7 @@ setuid perl scripts securely.\n"); PL_origargv = argv; PL_origargc = argc; -#ifndef VMS /* VMS doesn't have environ array */ +#ifdef USE_ENVIRON_ARRAY PL_origenviron = environ; #endif @@ -896,7 +934,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; @@ -964,6 +1001,11 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) goto reswitch; case 'e': +#ifdef MACOS_TRADITIONAL + /* ignore -e for Dev:Pseudo argument */ + if (argv[1] && !strcmp(argv[1], "Dev:Pseudo")) + break; +#endif if (PL_euid != PL_uid || PL_egid != PL_gid) Perl_croak(aTHX_ "No -e allowed in setuid scripts"); if (!PL_e_script) { @@ -1134,6 +1176,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_tainting = TRUE; else { while (s && *s) { + char *d; while (isSPACE(*s)) s++; if (*s == '-') { @@ -1141,11 +1184,18 @@ print \" \\@INC:\\n @INC\\n\";"); if (isSPACE(*s)) continue; } + d = s; if (!*s) break; if (!strchr("DIMUdmw", *s)) Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); - s = moreswitches(s); + while (++s && *s) { + if (isSPACE(*s)) { + *s++ = '\0'; + break; + } + } + moreswitches(d); } } } @@ -1185,7 +1235,11 @@ print \" \\@INC:\\n @INC\\n\";"); } #endif +#ifdef MACOS_TRADITIONAL + if (PL_doextract || gMacPerl_AlwaysExtract) { +#else if (PL_doextract) { +#endif find_beginning(); if (cddir && PerlDir_chdir(cddir) < 0) Perl_croak(aTHX_ "Can't chdir to %s",cddir); @@ -1225,12 +1279,16 @@ print \" \\@INC:\\n @INC\\n\";"); if (xsinit) (*xsinit)(aTHXo); /* in case linked C routines want magical variables */ -#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) +#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) init_os_extras(); #endif #ifdef USE_SOCKS +# ifdef HAS_SOCKS5_INIT + socks5_init(argv[0]); +# else SOCKSinit(argv[0]); +# endif #endif init_predump_symbols(); @@ -1246,6 +1304,16 @@ print \" \\@INC:\\n @INC\\n\";"); SETERRNO(0,SS$_NORMAL); PL_error_count = 0; +#ifdef MACOS_TRADITIONAL + if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) { + if (PL_minus_c) + Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename)); + else { + Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n", + MacPerl_MPWFileName(PL_origfilename)); + } + } +#else if (yyparse() || PL_error_count) { if (PL_minus_c) Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename); @@ -1254,6 +1322,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_origfilename); } } +#endif CopLINE_set(PL_curcop, 0); PL_curstash = PL_defstash; PL_preprocess = FALSE; @@ -1299,7 +1368,6 @@ Tells a Perl interpreter to run. See L<perlembed>. int perl_run(pTHXx) { - dTHR; I32 oldscope; int ret = 0; dJMPENV; @@ -1367,8 +1435,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")); @@ -1379,7 +1445,11 @@ S_run_body(pTHX_ I32 oldscope) PTR2UV(thr))); if (PL_minus_c) { +#ifdef MACOS_TRADITIONAL + PerlIO_printf(Perl_error_log, "%s syntax OK\n", MacPerl_MPWFileName(PL_origfilename)); +#else PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); +#endif my_exit(0); } if (PERLDB_SINGLE && PL_DBsingle) @@ -1423,10 +1493,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); @@ -1565,18 +1633,7 @@ Perl_call_method(pTHX_ const char *methname, I32 flags) /* name of the subroutine */ /* See G_* flags in cop.h */ { - dSP; - OP myop; - if (!PL_op) { - Zero(&myop, 1, OP); - PL_op = &myop; - } - XPUSHs(sv_2mortal(newSVpv(methname,0))); - PUTBACK; - pp_method(); - if (PL_op == &myop) - PL_op = Nullop; - return call_sv(*PL_stack_sp--, flags); + return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD); } /* May be called with any of a CV, a GV, or an SV containing the name. */ @@ -1591,11 +1648,11 @@ L<perlcall>. I32 Perl_call_sv(pTHX_ SV *sv, I32 flags) - /* See G_* flags in cop.h */ { dSP; LOGOP myop; /* fake syntax tree node */ + UNOP method_op; I32 oldmark; I32 retval; I32 oldscope; @@ -1633,6 +1690,14 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) && !(flags & G_NODEBUG)) PL_op->op_private |= OPpENTERSUB_DB; + if (flags & G_METHOD) { + Zero(&method_op, 1, UNOP); + method_op.op_next = PL_op; + method_op.op_ppaddr = PL_ppaddr[OP_METHOD]; + myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; + PL_op = (OP*)&method_op; + } + if (!(flags & G_EVAL)) { CATCH_SET(TRUE); call_body((OP*)&myop, FALSE); @@ -1640,7 +1705,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) CATCH_SET(oldcatch); } else { - cLOGOP->op_other = PL_op; + myop.op_other = (OP*)&myop; PL_markstack_ptr--; /* we're trying to emulate pp_entertry() here */ { @@ -1650,7 +1715,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) ENTER; SAVETMPS; - push_return(PL_op->op_next); + 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. */ @@ -1749,13 +1814,11 @@ 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); + PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */ else - PL_op = Perl_pp_entersub(aTHX); + PL_op = Perl_pp_entersub(aTHX); /* this does */ } if (PL_op) CALLRUNOPS(aTHX); @@ -1877,7 +1940,6 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) dSP; SV* sv = newSVpv(p, 0); - PUSHMARK(SP); eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); @@ -1938,7 +2000,7 @@ S_usage(pTHX_ char *name) /* XXX move this out into a module ? */ "-0[octal] specify record separator (\\0, if no argument)", "-a autosplit mode with -n or -p (splits $_ into @F)", "-C enable native wide character system interfaces", -"-c check syntax only (runs BEGIN and END blocks)", +"-c check syntax only (runs BEGIN and CHECK blocks)", "-d[:debugger] run program under debugger", "-D[number/list] set debugging flags (argument is a bit mask or alphabets)", "-e 'command' one line of program (several -e's allowed, omit programfile)", @@ -1966,9 +2028,11 @@ NULL }; char **p = usage_msg; - printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name); + PerlIO_printf(PerlIO_stdout(), + "\nUsage: %s [switches] [--] [programfile] [arguments]", + name); while (*p) - printf("\n %s", *p++); + PerlIO_printf(PerlIO_stdout(), "\n %s", *p++); } /* This routine handles any switches that can be given during run */ @@ -1976,13 +2040,13 @@ 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); if (rschar & ~((U8)~0)) @@ -2015,9 +2079,25 @@ Perl_moreswitches(pTHX_ char *s) case 'd': forbid_setid("-d"); s++; - if (*s == ':' || *s == '=') { - my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s)); + /* The following permits -d:Mod to accepts arguments following an = + in the fashion that -MSome::Mod does. */ + if (*s == ':' || *s == '=') { + char *start; + SV *sv; + sv = newSVpv("use Devel::", 0); + start = ++s; + /* We now allow -d:Module=Foo,Bar */ + while(isALNUM(*s) || *s==':') ++s; + if (*s != '=') + sv_catpv(sv, start); + else { + sv_catpvn(sv, start, s-start); + sv_catpv(sv, " split(/,/,q{"); + sv_catpv(sv, ++s); + sv_catpv(sv, "})"); + } s += strlen(s); + my_setenv("PERL5DB", SvPV(sv, PL_na)); } if (!PL_perldb) { PL_perldb = PERLDB_ALL; @@ -2029,7 +2109,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++) @@ -2041,7 +2121,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"); @@ -2098,11 +2177,11 @@ Perl_moreswitches(pTHX_ char *s) if (isDIGIT(*s)) { PL_ors = savepv("\n"); PL_orslen = 1; + numlen = 0; /* disallow underscores */ *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen); s += numlen; } else { - dTHR; if (RsPARA(PL_nrs)) { PL_ors = "\n\n"; PL_orslen = 2; @@ -2135,6 +2214,9 @@ Perl_moreswitches(pTHX_ char *s) sv_catpv( sv, " ()"); } } else { + if (s == start) + Perl_croak(aTHX_ "Module name required with -%c option", + s[-1]); sv_catpvn(sv, start, s-start); sv_catpv(sv, " split(/,/,q{"); sv_catpv(sv, ++s); @@ -2167,6 +2249,9 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 'u': +#ifdef MACOS_TRADITIONAL + Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh"); +#endif PL_do_undump = TRUE; s++; return s; @@ -2175,59 +2260,81 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 'v': - printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s", - PL_patchlevel, ARCHNAME)); + PerlIO_printf(PerlIO_stdout(), + Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s", + PL_patchlevel, ARCHNAME)); #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) - printf("\n(with %d registered patch%s, see perl -V for more detail)", - (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); + PerlIO_printf(PerlIO_stdout(), + "\n(with %d registered patch%s, " + "see perl -V for more detail)", + (int)LOCAL_PATCH_COUNT, + (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif - printf("\n\nCopyright 1987-2000, Larry Wall\n"); + PerlIO_printf(PerlIO_stdout(), + "\n\nCopyright 1987-2001, Larry Wall\n"); +#ifdef MACOS_TRADITIONAL + PerlIO_printf(PerlIO_stdout(), + "\nMac OS port Copyright (c) 1991-2001, Matthias Neeracher\n"); +#endif #ifdef MSDOS - printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); + PerlIO_printf(PerlIO_stdout(), + "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); #endif #ifdef DJGPP - printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"); - printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n" + "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); #endif #ifdef OS2 - printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" - "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n"); + PerlIO_printf(PerlIO_stdout(), + "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" + "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n"); #endif #ifdef atarist - printf("atariST series port, ++jrb bammi@cadence.com\n"); + PerlIO_printf(PerlIO_stdout(), + "atariST series port, ++jrb bammi@cadence.com\n"); #endif #ifdef __BEOS__ - printf("BeOS port Copyright Tom Spindler, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "BeOS port Copyright Tom Spindler, 1997-1999\n"); #endif #ifdef MPE - printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n"); #endif #ifdef OEMVS - printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); #endif #ifdef __VOS__ - printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n"); #endif #ifdef __OPEN_VM - printf("VM/ESA port by Neale Ferguson, 1998-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "VM/ESA port by Neale Ferguson, 1998-1999\n"); #endif #ifdef POSIX_BC - printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); #endif #ifdef __MINT__ - printf("MiNT port by Guido Flohr, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "MiNT port by Guido Flohr, 1997-1999\n"); #endif #ifdef EPOC - printf("EPOC port by Olaf Flebbe, 1999-2000\n"); + PerlIO_printf(PerlIO_stdout(), + "EPOC port by Olaf Flebbe, 1999-2000\n"); #endif #ifdef BINARY_BUILD_NOTICE BINARY_BUILD_NOTICE; #endif - printf("\n\ + PerlIO_printf(PerlIO_stdout(), + "\n\ Perl may be copied only under the terms of either the Artistic License or the\n\ -GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\ +GNU General Public License, which may be found in the Perl 5 source kit.\n\n\ Complete documentation for Perl, including FAQ lists, should be found on\n\ this system using `man perl' or `perldoc perl'. If you have access to the\n\ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); @@ -2389,7 +2496,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 @@ -2425,6 +2531,7 @@ S_init_main_stash(pTHX) CopSTASH_set(&PL_compiling, PL_defstash); PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)); PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV)); + PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV)); /* We must init $/ before switches are processed. */ sv_setpvn(get_sv("/", TRUE), "\n", 1); } @@ -2432,8 +2539,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) { @@ -2456,6 +2561,11 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) } } +#ifdef USE_ITHREADS + Safefree(CopFILE(PL_curcop)); +#else + SvREFCNT_dec(CopFILEGV(PL_curcop)); +#endif CopFILE_set(PL_curcop, PL_origfilename); if (strEQ(PL_origfilename,"-")) scriptname = ""; @@ -2478,7 +2588,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) sv_catpvn(sv, "-I", 2); sv_catpv(sv,PRIVLIB_EXP); -#ifdef MSDOS +#if defined(MSDOS) || defined(WIN32) Perl_sv_setpvf(aTHX_ cmd, "\ sed %s -e \"/^[^#]/b\" \ -e \"/^#[ ]*include[ ]/b\" \ @@ -2608,72 +2718,85 @@ S_fd_on_nosuid_fs(pTHX_ int fd) * an irrelevant filesystem while trying to reach the right one. */ -# ifdef HAS_FSTATVFS +#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(HAS_FSTATVFS) +# define FD_ON_NOSUID_CHECK_OKAY struct statvfs stfs; + check_okay = fstatvfs(fd, &stfs) == 0; on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID); -# else -# ifdef PERL_MOUNT_NOSUID -# if defined(HAS_FSTATFS) && \ - defined(HAS_STRUCT_STATFS) && \ - defined(HAS_STRUCT_STATFS_F_FLAGS) +# endif /* fstatvfs */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(PERL_MOUNT_NOSUID) && \ + defined(HAS_FSTATFS) && \ + defined(HAS_STRUCT_STATFS) && \ + defined(HAS_STRUCT_STATFS_F_FLAGS) +# define FD_ON_NOSUID_CHECK_OKAY struct statfs stfs; + check_okay = fstatfs(fd, &stfs) == 0; on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID); -# else -# if defined(HAS_FSTAT) && \ - defined(HAS_USTAT) && \ - defined(HAS_GETMNT) && \ - defined(HAS_STRUCT_FS_DATA) && \ - defined(NOSTAT_ONE) +# endif /* fstatfs */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(PERL_MOUNT_NOSUID) && \ + defined(HAS_FSTAT) && \ + defined(HAS_USTAT) && \ + defined(HAS_GETMNT) && \ + defined(HAS_STRUCT_FS_DATA) && \ + defined(NOSTAT_ONE) +# define FD_ON_NOSUID_CHECK_OKAY struct stat fdst; + if (fstat(fd, &fdst) == 0) { - struct ustat us; - if (ustat(fdst.st_dev, &us) == 0) { - struct fs_data fsd; - /* NOSTAT_ONE here because we're not examining fields which - * vary between that case and STAT_ONE. */ + struct ustat us; + if (ustat(fdst.st_dev, &us) == 0) { + struct fs_data fsd; + /* NOSTAT_ONE here because we're not examining fields which + * vary between that case and STAT_ONE. */ if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) { - size_t cmplen = sizeof(us.f_fname); - if (sizeof(fsd.fd_req.path) < cmplen) - cmplen = sizeof(fsd.fd_req.path); - if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) && - fdst.st_dev == fsd.fd_req.dev) { - check_okay = 1; - on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID; - } - } - } - } - } -# endif /* fstat+ustat+getmnt */ -# endif /* fstatfs */ -# else -# if defined(HAS_GETMNTENT) && \ - defined(HAS_HASMNTOPT) && \ - defined(MNTOPT_NOSUID) - FILE *mtab = fopen("/etc/mtab", "r"); - struct mntent *entry; - struct stat stb, fsb; + size_t cmplen = sizeof(us.f_fname); + if (sizeof(fsd.fd_req.path) < cmplen) + cmplen = sizeof(fsd.fd_req.path); + if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) && + fdst.st_dev == fsd.fd_req.dev) { + check_okay = 1; + on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID; + } + } + } + } + } +# endif /* fstat+ustat+getmnt */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(HAS_GETMNTENT) && \ + defined(HAS_HASMNTOPT) && \ + defined(MNTOPT_NOSUID) +# define FD_ON_NOSUID_CHECK_OKAY + FILE *mtab = fopen("/etc/mtab", "r"); + struct mntent *entry; + struct stat stb, fsb; if (mtab && (fstat(fd, &stb) == 0)) { - while (entry = getmntent(mtab)) { - if (stat(entry->mnt_dir, &fsb) == 0 - && fsb.st_dev == stb.st_dev) - { - /* found the filesystem */ - check_okay = 1; - if (hasmntopt(entry, MNTOPT_NOSUID)) - on_nosuid = 1; - break; - } /* A single fs may well fail its stat(). */ - } + while (entry = getmntent(mtab)) { + if (stat(entry->mnt_dir, &fsb) == 0 + && fsb.st_dev == stb.st_dev) + { + /* found the filesystem */ + check_okay = 1; + if (hasmntopt(entry, MNTOPT_NOSUID)) + on_nosuid = 1; + break; + } /* A single fs may well fail its stat(). */ + } } if (mtab) - fclose(mtab); -# endif /* getmntent+hasmntopt */ -# endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */ -# endif /* statvfs */ + fclose(mtab); +# endif /* getmntent+hasmntopt */ if (!check_okay) Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename); @@ -2709,7 +2832,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 */ @@ -2758,16 +2880,6 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) if (tmpstatbuf.st_dev != PL_statbuf.st_dev || tmpstatbuf.st_ino != PL_statbuf.st_ino) { (void)PerlIO_close(PL_rsfp); - if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */ - PerlIO_printf(PL_rsfp, -"User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\ -(Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n", - PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino, - (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino, - CopFILE(PL_curcop), - PL_statbuf.st_uid, PL_statbuf.st_gid); - (void)PerlProc_pclose(PL_rsfp); - } Perl_croak(aTHX_ "Permission denied\n"); } if ( @@ -2917,7 +3029,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) || @@ -2940,9 +3051,29 @@ S_find_beginning(pTHX) /* skip forward in input to the real script? */ 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) + Perl_croak(aTHX_ "No Perl script found in input\n"); + + if (PL_doextract) /* require explicit override ? */ + if (!OverrideExtract(PL_origfilename)) + Perl_croak(aTHX_ "User aborted script\n"); + else + PL_doextract = FALSE; + + /* Pater peccavi, file does not have #! */ + PerlIO_rewind(PL_rsfp); + + break; + } +#else while (PL_doextract) { if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) Perl_croak(aTHX_ "No Perl script found in input\n"); +#endif if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) { PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */ PL_doextract = FALSE; @@ -2987,7 +3118,6 @@ S_forbid_setid(pTHX_ char *s) void Perl_init_debugger(pTHX) { - dTHR; HV *ostash = PL_curstash; PL_curstash = PL_debstash; @@ -3055,7 +3185,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) { @@ -3092,7 +3221,6 @@ S_init_lexer(pTHX) STATIC void S_init_predump_symbols(pTHX) { - dTHR; GV *tmpgv; IO *io; @@ -3124,17 +3252,19 @@ S_init_predump_symbols(pTHX) PL_statname = NEWSV(66,0); /* last filename we did stat on */ - if (!PL_osname) - PL_osname = savepv(OSNAME); + if (PL_osname) + Safefree(PL_osname); + PL_osname = savepv(OSNAME); } STATIC void S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env) { - dTHR; char *s; SV *sv; GV* tmpgv; + char **dup_env_base = 0; + int dup_env_count = 0; argc--,argv++; /* skip name of script */ if (PL_doswitches) { @@ -3163,12 +3293,17 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register TAINT; if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) { +#ifdef MACOS_TRADITIONAL + /* $0 is not majick on a Mac */ + sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename)); +#else sv_setpv(GvSV(tmpgv),PL_origfilename); magicname("0", "0", 1); +#endif } if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) #ifdef OS2 - sv_setpv(GvSV(tmpgv), os2_execname()); + sv_setpv(GvSV(tmpgv), os2_execname(aTHX)); #else sv_setpv(GvSV(tmpgv),PL_origargv[0]); #endif @@ -3180,15 +3315,15 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register SV *sv = newSVpv(argv[0],0); av_push(GvAVn(PL_argvgv),sv); if (PL_widesyscalls) - sv_utf8_upgrade(sv); + (void)sv_utf8_decode(sv); } } if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) { HV *hv; GvMULTI_on(PL_envgv); hv = GvHVn(PL_envgv); - hv_magic(hv, PL_envgv, 'E'); -#if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */ + hv_magic(hv, Nullgv, 'E'); +#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 @@ -3198,6 +3333,26 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register env = environ; if (env != environ) environ[0] = Nullch; +#ifdef NEED_ENVIRON_DUP_FOR_MODIFY + { + char **env_base; + for (env_base = env; *env; env++) + dup_env_count++; + if ((dup_env_base = (char **) + safesysmalloc( sizeof(char *) * (dup_env_count+1) ))) { + char **dup_env; + for (env = env_base, dup_env = dup_env_base; + *env; + env++, dup_env++) { + /* With environ one needs to use safesysmalloc(). */ + *dup_env = safesysmalloc(strlen(*env) + 1); + (void)strcpy(*dup_env, *env); + } + *dup_env = Nullch; + env = dup_env_base; + } /* else what? */ + } +#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */ for (; *env; env++) { if (!(s = strchr(*env,'='))) continue; @@ -3208,12 +3363,16 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register sv = newSVpv(s--,0); (void)hv_store(hv, *env, s - *env, sv, 0); *s = '='; -#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV) - /* Sins of the RTL. See note in my_setenv(). */ - (void)PerlEnv_putenv(savepv(*env)); -#endif } -#endif +#ifdef NEED_ENVIRON_DUP_FOR_MODIFY + if (dup_env_base) { + char **dup_env; + for (dup_env = dup_env_base; *dup_env; dup_env++) + safesysfree(*dup_env); + safesysfree(dup_env_base); + } +#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */ +#endif /* USE_ENVIRON_ARRAY */ #ifdef DYNAMIC_ENV_FETCH HvNAME(hv) = savepv(ENV_HV_NAME); #endif @@ -3258,6 +3417,27 @@ S_init_perllib(pTHX) #ifdef ARCHLIB_EXP incpush(ARCHLIB_EXP, FALSE, FALSE); #endif +#ifdef MACOS_TRADITIONAL + { + struct stat tmpstatbuf; + SV * privdir = NEWSV(55, 0); + char * macperl = PerlEnv_getenv("MACPERL"); + + if (!macperl) + macperl = ""; + + Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl); + if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) + incpush(SvPVX(privdir), TRUE, FALSE); + 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) + incpush(":", FALSE, FALSE); +#else #ifndef PRIVLIB_EXP # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" #endif @@ -3307,17 +3487,26 @@ S_init_perllib(pTHX) incpush(PERL_VENDORLIB_STEM, FALSE, TRUE); #endif +#ifdef PERL_OTHERLIBDIRS + incpush(PERL_OTHERLIBDIRS, TRUE, TRUE); +#endif + if (!PL_tainting) incpush(".", FALSE, FALSE); +#endif /* MACOS_TRADITIONAL */ } -#if defined(DOSISH) +#if defined(DOSISH) || defined(EPOC) # define PERLLIB_SEP ';' #else # if defined(VMS) # define PERLLIB_SEP '|' # else -# define PERLLIB_SEP ':' +# if defined(MACOS_TRADITIONAL) +# define PERLLIB_SEP ',' +# else +# define PERLLIB_SEP ':' +# endif # endif #endif #ifndef PERLLIB_MANGLE @@ -3357,6 +3546,12 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) sv_setpv(libdir, PERLLIB_MANGLE(p, 0)); p = Nullch; /* break out */ } +#ifdef MACOS_TRADITIONAL + if (!strchr(SvPVX(libdir), ':')) + sv_insert(libdir, 0, 0, ":", 1); + if (SvPVX(libdir)[SvCUR(libdir)-1] != ':') + sv_catpv(libdir, ":"); +#endif /* * BEFORE pushing libdir onto @INC we may first push version- and @@ -3384,8 +3579,17 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) SvPV(libdir,len)); #endif if (addsubdirs) { +#ifdef MACOS_TRADITIONAL +#define PERL_AV_SUFFIX_FMT "" +#define PERL_ARCH_FMT "%s:" +#define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT +#else +#define PERL_AV_SUFFIX_FMT "/" +#define PERL_ARCH_FMT "/%s" +#define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT +#endif /* .../version/archname if -d .../version/archname */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT, libdir, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION, ARCHNAME); @@ -3394,7 +3598,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) av_push(GvAVn(PL_incgv), newSVsv(subdir)); /* .../version if -d .../version */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir, + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION); if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && @@ -3402,7 +3606,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) av_push(GvAVn(PL_incgv), newSVsv(subdir)); /* .../archname if -d .../archname */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME); + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME); if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) av_push(GvAVn(PL_incgv), newSVsv(subdir)); @@ -3412,7 +3616,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) if (addoldvers) { for (incver = incverlist; *incver; incver++) { /* .../xxx if -d .../xxx */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver); + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver); if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) av_push(GvAVn(PL_incgv), newSVsv(subdir)); @@ -3477,8 +3681,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); @@ -3506,7 +3711,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; @@ -3516,7 +3720,14 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) while (AvFILL(paramList) >= 0) { cv = (CV*)av_shift(paramList); - SAVEFREESV(cv); + if ((PL_minus_c & 0x10) && (paramList == PL_beginav)) { + /* save PL_beginav for compiler */ + if (! PL_beginav_save) + PL_beginav_save = newAV(); + av_push(PL_beginav_save, (SV*)cv); + } else { + SAVEFREESV(cv); + } #ifdef PERL_FLEXIBLE_EXCEPTIONS CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv); #else @@ -3604,8 +3815,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) { @@ -3654,7 +3863,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/contrib/perl5/perl.h b/contrib/perl5/perl.h index d2aae98723e8..1f187bd1a8c5 100644 --- a/contrib/perl5/perl.h +++ b/contrib/perl5/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. @@ -164,8 +164,8 @@ class CPerlObj; #define aTHXo_ this, #define PERL_OBJECT_THIS aTHXo #define PERL_OBJECT_THIS_ aTHXo_ -#define dTHXoa(a) pTHXo = a -#define dTHXo dTHXoa(PERL_GET_THX) +#define dTHXoa(a) pTHXo = (CPerlObj*)a +#define dTHXo pTHXo = PERL_GET_THX #define pTHXx void #define pTHXx_ @@ -179,16 +179,17 @@ 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 # define MULTIPLICITY # endif # define pTHX register PerlInterpreter *my_perl # define aTHX my_perl +# define dTHXa(a) pTHX = (PerlInterpreter*)a # endif -# define dTHXa(a) pTHX = a -# define dTHX dTHXa(PERL_GET_THX) +# define dTHX pTHX = PERL_GET_THX # define pTHX_ pTHX, # define aTHX_ aTHX, # define pTHX_1 2 @@ -242,6 +243,7 @@ struct perl_thread; # define aTHXo aTHX # define aTHXo_ aTHX_ # define dTHXo dTHX +# define dTHXoa(x) dTHXa(x) #endif #ifndef pTHXx @@ -297,7 +299,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 @@ -486,21 +488,16 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); # include <sys/param.h> #endif -/* needed for IAMSUID case for 4.4BSD systems - * XXX there should probably be a Configure variable - */ - -#ifdef I_SYS_PARAM -#if (defined (BSD) && (BSD >= 199306)) -# include <sys/mount.h> -#endif /* !BSD */ -#endif /* !I_SYS_PARAM */ - /* Use all the "standard" definitions? */ #if defined(STANDARD_C) && defined(I_STDLIB) # include <stdlib.h> #endif +/* If this causes problems, set i_unistd=undef in the hint file. */ +#ifdef I_UNISTD +# include <unistd.h> +#endif + #ifdef PERL_MICRO /* Last chance to export Perl_my_swap */ # define MYSWAP #endif @@ -547,17 +544,6 @@ Free_t Perl_mfree (Malloc_t where); typedef struct perl_mstats perl_mstats_t; -struct perl_mstats { - unsigned long *nfree; - unsigned long *ntotal; - long topbucket, topbucket_ev, topbucket_odd, totfree, total, total_chain; - long total_sbrk, sbrks, sbrk_good, sbrk_slack, start_slack, sbrked_remains; - long minbucket; - /* Level 1 info */ - unsigned long *bucket_mem_size; - unsigned long *bucket_available_size; -}; - # define safemalloc Perl_malloc # define safecalloc Perl_calloc # define saferealloc Perl_realloc @@ -718,10 +704,50 @@ struct perl_mstats { #endif #include <errno.h> -#ifdef HAS_SOCKET -# ifdef I_NET_ERRNO -# include <net/errno.h> + +#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 <sys/socket.h> +# if defined(USE_SOCKS) && defined(I_SOCKS) +# if !defined(INCLUDE_PROTOTYPES) +# define INCLUDE_PROTOTYPES /* for <socks.h> */ +# define PERL_SOCKS_NEED_PROTOTYPES +# endif +# ifdef USE_THREADS +# define PERL_USE_THREADS /* store our value */ +# undef USE_THREADS +# endif +# include <socks.h> +# 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 +# ifdef USE_64_BIT_ALL +# define SOCKS_64BIT_BUG /* until proven otherwise */ # endif +# endif +# ifdef I_NETDB +# include <netdb.h> +# endif +# ifndef ENOTSOCK +# ifdef I_NET_ERRNO +# include <net/errno.h> +# endif +# endif +#endif + +#ifdef SETERRNO +# undef SETERRNO /* SOCKS might have defined this */ #endif #ifdef VMS @@ -1071,8 +1097,16 @@ typedef UVTYPE UV; #define PTR2IV(p) INT2PTR(IV,p) #define PTR2UV(p) INT2PTR(UV,p) #define PTR2NV(p) NUM2PTR(NV,p) +#if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +#else +# define PTR2ul(p) INT2PTR(unsigned long,p) +#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 @@ -1153,16 +1187,22 @@ typedef NVTYPE NV; # include <sunmath.h> # endif # define NV_DIG LDBL_DIG -# ifdef HAS_SQRTL - /* libsunmath doesn't have modfl and frexpl as of mid-March 2000 */ - /* XXX Configure probe for modfl and frexpl needed XXX */ -# if defined(__sun) && defined(__svr4) -# define Perl_modf(x,y) ((long double)modf((double)(x),(double*)(y))) -# define Perl_frexp(x) ((long double)frexp((double)(x))) +# ifdef LDBL_MANT_DIG +# define NV_MANT_DIG LDBL_MANT_DIG +# endif +# ifdef LDBL_MAX +# define NV_MAX LDBL_MAX +# define NV_MIN LDBL_MIN +# else +# ifdef HUGE_VALL +# define NV_MAX HUGE_VALL # else -# define Perl_modf modfl -# define Perl_frexp frexpl +# ifdef HUGE_VAL +# define NV_MAX ((NV)HUGE_VAL) +# endif # endif +# endif +# ifdef HAS_SQRTL # define Perl_cos cosl # define Perl_sin sinl # define Perl_sqrt sqrtl @@ -1173,10 +1213,39 @@ typedef NVTYPE NV; # define Perl_floor floorl # define Perl_fmod fmodl # endif +/* e.g. libsunmath doesn't have modfl and frexpl as of mid-March 2000 */ +# ifdef HAS_MODFL +# define Perl_modf(x,y) modfl(x,y) +# else +# define Perl_modf(x,y) ((long double)modf((double)(x),(double*)(y))) +# endif +# ifdef HAS_FREXPL +# define Perl_frexp(x,y) frexpl(x,y) +# else +# define Perl_frexp(x,y) ((long double)frexp((double)(x),y)) +# endif +# ifdef HAS_ISNANL +# define Perl_isnan(x) isnanl(x) +# else +# ifdef HAS_ISNAN +# define Perl_isnan(x) isnan((double)(x)) +# else +# define Perl_isnan(x) ((x)!=(x)) +# endif +# endif #else # define NV_DIG DBL_DIG -# define Perl_modf modf -# define Perl_frexp frexp +# ifdef DBL_MANT_DIG +# define NV_MANT_DIG DBL_MANT_DIG +# endif +# ifdef DBL_MAX +# define NV_MAX DBL_MAX +# define NV_MIN DBL_MIN +# else +# ifdef HUGE_VAL +# define NV_MAX HUGE_VAL +# endif +# endif # define Perl_cos cos # define Perl_sin sin # define Perl_sqrt sqrt @@ -1186,19 +1255,33 @@ typedef NVTYPE NV; # define Perl_pow pow # define Perl_floor floor # define Perl_fmod fmod +# define Perl_modf(x,y) modf(x,y) +# define Perl_frexp(x,y) frexp(x,y) +# ifdef HAS_ISNAN +# define Perl_isnan(x) isnan(x) +# else +# define Perl_isnan(x) ((x)!=(x)) +# endif #endif #if !defined(Perl_atof) && defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) # if !defined(Perl_atof) && defined(HAS_STRTOLD) -# define Perl_atof(s) strtold(s, (char**)NULL) +# define Perl_atof(s) (NV)strtold(s, (char**)NULL) # endif # if !defined(Perl_atof) && defined(HAS_ATOLF) -# define Perl_atof atolf +# define Perl_atof (NV)atolf +# endif +# if !defined(Perl_atof) && defined(PERL_SCNfldbl) +# define Perl_atof PERL_SCNfldbl +# define Perl_atof2(s,f) sscanf((s), "%"PERL_SCNfldbl, &(f)) # endif #endif #if !defined(Perl_atof) # define Perl_atof atof /* we assume atof being available anywhere */ #endif +#if !defined(Perl_atof2) +# define Perl_atof2(s,f) ((f) = (NV)Perl_atof(s)) +#endif /* Previously these definitions used hardcoded figures. * It is hoped these formula are more portable, although @@ -1371,28 +1454,25 @@ typedef NVTYPE NV; #ifdef UV_IS_QUAD -# ifdef UQUAD_MAX -# define PERL_UQUAD_MAX ((UV)UQUAD_MAX) -# else # define PERL_UQUAD_MAX (~(UV)0) -# endif - -# define PERL_UQUAD_MIN ((UV)0) - -# ifdef QUAD_MAX -# define PERL_QUAD_MAX ((IV)QUAD_MAX) -# else +# define PERL_UQUAD_MIN ((UV)0) # define PERL_QUAD_MAX ((IV) (PERL_UQUAD_MAX >> 1)) -# endif - -# ifdef QUAD_MIN -# define PERL_QUAD_MIN ((IV)QUAD_MIN) -# else # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) -# endif #endif +struct perl_mstats { + UV *nfree; + UV *ntotal; + IV topbucket, topbucket_ev, topbucket_odd, totfree, total, total_chain; + IV total_sbrk, sbrks, sbrk_good, sbrk_slack, start_slack, sbrked_remains; + IV minbucket; + /* Level 1 info */ + UV *bucket_mem_size; + UV *bucket_available_size; + UV nbuckets; +}; + typedef MEM_SIZE STRLEN; typedef struct op OP; @@ -1408,7 +1488,12 @@ typedef struct pvop PVOP; typedef struct loop LOOP; typedef struct interpreter PerlInterpreter; -typedef struct sv SV; +#ifdef UTS +# define STRUCT_SV perl_sv /* Amdahl's <ksync.h> has struct sv */ +#else +# define STRUCT_SV sv +#endif +typedef struct STRUCT_SV SV; typedef struct av AV; typedef struct hv HV; typedef struct cv CV; @@ -1573,6 +1658,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 @@ -1581,7 +1669,18 @@ typedef struct ptr_tbl PTR_TBL_t; # endif # endif # endif -#endif +#endif + +#ifndef NO_ENVIRON_ARRAY +# define USE_ENVIRON_ARRAY +#endif + +#ifdef JPL + /* E.g. JPL needs to operate on a copy of the real environment. + * JDK 1.2 and 1.3 seem to get upset if the original environment + * is diddled with. */ +# define NEED_ENVIRON_DUP_FOR_MODIFY +#endif #ifndef PERL_SYS_INIT3 # define PERL_SYS_INIT3(argvp,argcp,envp) PERL_SYS_INIT(argvp,argcp) @@ -1771,9 +1870,25 @@ typedef pthread_key_t perl_key; # endif #endif +#ifndef UVf +# ifdef CHECK_FORMAT +# define UVf UVuf +# else +# define UVf "Vu" +# endif +#endif + +#ifndef VDf +# ifdef CHECK_FORMAT +# define VDf "p" +# else +# define VDf "vd" +# endif +#endif + /* Some unistd.h's give a prototype for pause() even though HAS_PAUSE ends up undefined. This causes the #define - below to be rejected by the compmiler. Sigh. + below to be rejected by the compiler. Sigh. */ #ifdef HAS_PAUSE #define Pause pause @@ -1993,6 +2108,7 @@ Gid_t getegid (void); #ifndef Perl_error_log # define Perl_error_log (PL_stderrgv \ + && GvIOp(PL_stderrgv) \ && IoOFP(GvIOp(PL_stderrgv)) \ ? IoOFP(GvIOp(PL_stderrgv)) \ : PerlIO_stderr()) @@ -2013,9 +2129,11 @@ Gid_t getegid (void); # if defined(PERL_OBJECT) # define DEBUG_m(a) if (PL_debug & 128) a # else + /* Temporarily turn off memory debugging in case the a + * does memory allocation, either directly or indirectly. */ # define DEBUG_m(a) \ STMT_START { \ - if (PERL_GET_INTERP) { dTHX; if (PL_debug & 128) { a; } } \ + if (PERL_GET_INTERP) { dTHX; if (PL_debug & 128) {PL_debug&=~128; a; PL_debug|=128;} } \ } STMT_END # endif #define DEBUG_f(a) if (PL_debug & 256) a @@ -2031,6 +2149,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) @@ -2051,6 +2170,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 @@ -2121,8 +2241,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); @@ -2208,18 +2332,18 @@ typedef OP* (CPERLscope(*PPADDR_t)[]) (pTHX); # define environ (*environ_pointer) EXT char *** environ_pointer; # else -# if defined(__APPLE__) +# if defined(__APPLE__) && defined(PERL_CORE) # include <crt_externs.h> /* for the env array */ # define environ (*_NSGetEnviron()) # endif # endif #else /* VMS and some other platforms don't use the environ array */ -# if !defined(VMS) +# ifdef USE_ENVIRON_ARRAY # if !defined(DONT_DECLARE_STD) || \ (defined(__svr4__) && defined(__GNUC__) && defined(sun)) || \ defined(__sgi) || \ - defined(__DGUX) || defined(EPOC) + defined(__DGUX) extern char ** environ; /* environment variables supplied via exec */ # endif # endif @@ -2584,10 +2708,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*); @@ -2833,7 +2953,8 @@ EXT MGVTBL PL_vtbl_defelem = {MEMBER_TO_FPTR(Perl_magic_getdefelem),MEMBER_TO_FP EXT MGVTBL PL_vtbl_regexp = {0,0,0,0, MEMBER_TO_FPTR(Perl_magic_freeregexp)}; EXT MGVTBL PL_vtbl_regdata = {0, 0, MEMBER_TO_FPTR(Perl_magic_regdata_cnt), 0, 0}; -EXT MGVTBL PL_vtbl_regdatum = {MEMBER_TO_FPTR(Perl_magic_regdatum_get), 0, 0, 0, 0}; +EXT MGVTBL PL_vtbl_regdatum = {MEMBER_TO_FPTR(Perl_magic_regdatum_get), + MEMBER_TO_FPTR(Perl_magic_regdatum_set), 0, 0, 0}; #ifdef USE_LOCALE_COLLATE EXT MGVTBL PL_vtbl_collxfrm = {0, @@ -3061,23 +3182,29 @@ 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) \ +#define IS_NUMERIC_RADIX(s) \ ((PL_hints & HINT_LOCALE) && \ - PL_numeric_radix && (c) == PL_numeric_radix) + PL_numeric_radix_sv && memEQ(s, SvPVX(PL_numeric_radix_sv), SvCUR(PL_numeric_radix_sv))) + +#define STORE_NUMERIC_LOCAL_SET_STANDARD() \ + bool was_local = (PL_hints & HINT_LOCALE) && PL_numeric_local; \ + 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(); + +#define RESTORE_NUMERIC_LOCAL() \ + if (was_local) SET_NUMERIC_LOCAL(); + +#define RESTORE_NUMERIC_STANDARD() \ + if (was_standard) SET_NUMERIC_STANDARD(); -#define RESTORE_NUMERIC_LOCAL() if ((PL_hints & HINT_LOCALE) && PL_numeric_standard) SET_NUMERIC_LOCAL() -#define RESTORE_NUMERIC_STANDARD() if ((PL_hints & HINT_LOCALE) && PL_numeric_local) SET_NUMERIC_STANDARD() #define Atof my_atof #else /* !USE_LOCALE_NUMERIC */ @@ -3085,6 +3212,8 @@ typedef struct am_table_short AMTS; #define SET_NUMERIC_STANDARD() /**/ #define SET_NUMERIC_LOCAL() /**/ #define IS_NUMERIC_RADIX(c) (0) +#define STORE_NUMERIC_LOCAL_SET_STANDARD() /**/ +#define STORE_NUMERIC_STANDARD_SET_LOCAL() /**/ #define RESTORE_NUMERIC_LOCAL() /**/ #define RESTORE_NUMERIC_STANDARD() /**/ #define Atof Perl_atof @@ -3309,6 +3438,10 @@ typedef struct am_table_short AMTS; # include <libutil.h> /* 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" @@ -3335,6 +3468,10 @@ typedef struct am_table_short AMTS; I_SYSMMAN Mmap_t + NVef + NVff + NVgf + so that Configure picks them up. */ #endif /* Include guard */ diff --git a/contrib/perl5/perlapi.c b/contrib/perl5/perlapi.c index 787c2f220cbc..5fc0c4d7679e 100644 --- a/contrib/perl5/perlapi.c +++ b/contrib/perl5/perlapi.c @@ -41,6 +41,9 @@ START_EXTERN_C { return &(PL_##v); } #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHXo) \ { return &(PL_##v); } +#undef PERLVARIC +#define PERLVARIC(v,t,i) const t* Perl_##v##_ptr(pTHXo) \ + { return (const t *)&(PL_##v); } #include "perlvars.h" #undef PERLVAR @@ -82,6 +85,13 @@ Perl_Gv_AMupdate(pTHXo_ HV* stash) return ((CPerlObj*)pPerl)->Perl_Gv_AMupdate(stash); } +#undef Perl_apply_attrs_string +void +Perl_apply_attrs_string(pTHXo_ char *stashpv, CV *cv, char *attrstr, STRLEN len) +{ + ((CPerlObj*)pPerl)->Perl_apply_attrs_string(stashpv, cv, attrstr, len); +} + #undef Perl_avhv_delete_ent SV* Perl_avhv_delete_ent(pTHXo_ AV *ar, SV* keysv, I32 flags, U32 hash) @@ -159,13 +169,6 @@ Perl_av_extend(pTHXo_ AV* ar, I32 key) ((CPerlObj*)pPerl)->Perl_av_extend(ar, key); } -#undef Perl_av_fake -AV* -Perl_av_fake(pTHXo_ I32 size, SV** svp) -{ - return ((CPerlObj*)pPerl)->Perl_av_fake(size, svp); -} - #undef Perl_av_fetch SV** Perl_av_fetch(pTHXo_ AV* ar, I32 key, I32 lval) @@ -477,6 +480,8 @@ Perl_sv_setpvf_mg_nocontext(SV* sv, const char* pat, ...) } #undef Perl_fprintf_nocontext + +#undef Perl_printf_nocontext #endif #undef Perl_cv_const_sv @@ -616,9 +621,9 @@ Perl_dounwind(pTHXo_ I32 cxix) #undef Perl_do_binmode int -Perl_do_binmode(pTHXo_ PerlIO *fp, int iotype, int flag) +Perl_do_binmode(pTHXo_ PerlIO *fp, int iotype, int mode) { - return ((CPerlObj*)pPerl)->Perl_do_binmode(fp, iotype, flag); + return ((CPerlObj*)pPerl)->Perl_do_binmode(fp, iotype, mode); } #undef Perl_do_close @@ -632,6 +637,13 @@ Perl_do_close(pTHXo_ GV* gv, bool not_implicit) #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) #endif +#undef Perl_do_join +void +Perl_do_join(pTHXo_ SV* sv, SV* del, SV** mark, SV** sp) +{ + ((CPerlObj*)pPerl)->Perl_do_join(sv, del, mark, sp); +} + #undef Perl_do_open bool Perl_do_open(pTHXo_ GV* gv, char* name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO* supplied_fp) @@ -826,6 +838,13 @@ Perl_gv_efullname3(pTHXo_ SV* sv, GV* gv, const char* prefix) ((CPerlObj*)pPerl)->Perl_gv_efullname3(sv, gv, prefix); } +#undef Perl_gv_efullname4 +void +Perl_gv_efullname4(pTHXo_ SV* sv, GV* gv, const char* prefix, bool keepmain) +{ + ((CPerlObj*)pPerl)->Perl_gv_efullname4(sv, gv, prefix, keepmain); +} + #undef Perl_gv_fetchfile GV* Perl_gv_fetchfile(pTHXo_ const char* name) @@ -875,6 +894,13 @@ Perl_gv_fullname3(pTHXo_ SV* sv, GV* gv, const char* prefix) ((CPerlObj*)pPerl)->Perl_gv_fullname3(sv, gv, prefix); } +#undef Perl_gv_fullname4 +void +Perl_gv_fullname4(pTHXo_ SV* sv, GV* gv, const char* prefix, bool keepmain) +{ + ((CPerlObj*)pPerl)->Perl_gv_fullname4(sv, gv, prefix, keepmain); +} + #undef Perl_gv_init void Perl_gv_init(pTHXo_ GV* gv, HV* stash, const char* name, STRLEN len, int multi) @@ -1310,12 +1336,19 @@ 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); } +#undef Perl_is_utf8_string +bool +Perl_is_utf8_string(pTHXo_ U8 *s, STRLEN len) +{ + return ((CPerlObj*)pPerl)->Perl_is_utf8_string(s, len); +} + #undef Perl_is_utf8_alnum bool Perl_is_utf8_alnum(pTHXo_ U8 *p) @@ -2206,21 +2239,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); } @@ -2343,6 +2376,13 @@ Perl_rninstr(pTHXo_ const char* big, const char* bigend, const char* little, con { return ((CPerlObj*)pPerl)->Perl_rninstr(big, bigend, little, lend); } + +#undef Perl_rsignal +Sighandler_t +Perl_rsignal(pTHXo_ int i, Sighandler_t t) +{ + return ((CPerlObj*)pPerl)->Perl_rsignal(i, t); +} #if !defined(HAS_RENAME) #endif @@ -2444,6 +2484,13 @@ Perl_save_generic_svref(pTHXo_ SV** sptr) ((CPerlObj*)pPerl)->Perl_save_generic_svref(sptr); } +#undef Perl_save_generic_pvref +void +Perl_save_generic_pvref(pTHXo_ char** str) +{ + ((CPerlObj*)pPerl)->Perl_save_generic_pvref(str); +} + #undef Perl_save_gp void Perl_save_gp(pTHXo_ GV* gv, I32 empty) @@ -2535,6 +2582,13 @@ Perl_save_long(pTHXo_ long* longp) ((CPerlObj*)pPerl)->Perl_save_long(longp); } +#undef Perl_save_mortalizesv +void +Perl_save_mortalizesv(pTHXo_ SV* sv) +{ + ((CPerlObj*)pPerl)->Perl_save_mortalizesv(sv); +} + #undef Perl_save_nogv void Perl_save_nogv(pTHXo_ GV* gv) @@ -2570,6 +2624,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) @@ -2593,28 +2654,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); } @@ -3293,20 +3354,27 @@ Perl_unsharepvn(pTHXo_ const char* sv, I32 len, U32 hash) #undef Perl_utf16_to_utf8 U8* -Perl_utf16_to_utf8(pTHXo_ U16* p, U8 *d, I32 bytelen) +Perl_utf16_to_utf8(pTHXo_ U8* p, U8 *d, I32 bytelen, I32 *newlen) { - return ((CPerlObj*)pPerl)->Perl_utf16_to_utf8(p, d, bytelen); + return ((CPerlObj*)pPerl)->Perl_utf16_to_utf8(p, d, bytelen, newlen); } #undef Perl_utf16_to_utf8_reversed U8* -Perl_utf16_to_utf8_reversed(pTHXo_ U16* p, U8 *d, I32 bytelen) +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); + 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); @@ -3319,11 +3387,39 @@ Perl_utf8_hop(pTHXo_ U8 *s, I32 off) return ((CPerlObj*)pPerl)->Perl_utf8_hop(s, off); } +#undef Perl_utf8_to_bytes +U8* +Perl_utf8_to_bytes(pTHXo_ U8 *s, STRLEN *len) +{ + return ((CPerlObj*)pPerl)->Perl_utf8_to_bytes(s, len); +} + +#undef Perl_bytes_from_utf8 +U8* +Perl_bytes_from_utf8(pTHXo_ U8 *s, STRLEN *len, bool *is_utf8) +{ + return ((CPerlObj*)pPerl)->Perl_bytes_from_utf8(s, len, is_utf8); +} + +#undef Perl_bytes_to_utf8 +U8* +Perl_bytes_to_utf8(pTHXo_ U8 *s, STRLEN *len) +{ + return ((CPerlObj*)pPerl)->Perl_bytes_to_utf8(s, len); +} + +#undef Perl_utf8_to_uv_simple +UV +Perl_utf8_to_uv_simple(pTHXo_ U8 *s, STRLEN* retlen) +{ + return ((CPerlObj*)pPerl)->Perl_utf8_to_uv_simple(s, retlen); +} + #undef Perl_utf8_to_uv UV -Perl_utf8_to_uv(pTHXo_ U8 *s, I32* retlen) +Perl_utf8_to_uv(pTHXo_ U8 *s, STRLEN curlen, STRLEN* retlen, U32 flags) { - return ((CPerlObj*)pPerl)->Perl_utf8_to_uv(s, retlen); + return ((CPerlObj*)pPerl)->Perl_utf8_to_uv(s, curlen, retlen, flags); } #undef Perl_uv_to_utf8 @@ -3366,8 +3462,14 @@ Perl_vwarner(pTHXo_ U32 err, const char* pat, va_list* args) { ((CPerlObj*)pPerl)->Perl_vwarner(err, pat, args); } -#if defined(USE_PURE_BISON) -#else + +#undef Perl_whichsig +I32 +Perl_whichsig(pTHXo_ char* sig) +{ + return ((CPerlObj*)pPerl)->Perl_whichsig(sig); +} +#ifdef USE_PURE_BISON #endif #if defined(MYMALLOC) @@ -3474,6 +3576,15 @@ Perl_runops_debug(pTHXo) { return ((CPerlObj*)pPerl)->Perl_runops_debug(); } +#if defined(USE_THREADS) + +#undef Perl_sv_lock +SV* +Perl_sv_lock(pTHXo_ SV *sv) +{ + return ((CPerlObj*)pPerl)->Perl_sv_lock(sv); +} +#endif #undef Perl_sv_catpvf_mg void @@ -3772,6 +3883,20 @@ Perl_sv_force_normal(pTHXo_ SV *sv) ((CPerlObj*)pPerl)->Perl_sv_force_normal(sv); } +#undef Perl_sv_add_backref +void +Perl_sv_add_backref(pTHXo_ SV *tsv, SV *sv) +{ + ((CPerlObj*)pPerl)->Perl_sv_add_backref(tsv, sv); +} + +#undef Perl_sv_del_backref +void +Perl_sv_del_backref(pTHXo_ SV *sv) +{ + ((CPerlObj*)pPerl)->Perl_sv_del_backref(sv); +} + #undef Perl_tmps_grow void Perl_tmps_grow(pTHXo_ I32 n) @@ -3921,6 +4046,36 @@ Perl_ptr_table_split(pTHXo_ PTR_TBL_t *tbl) { ((CPerlObj*)pPerl)->Perl_ptr_table_split(tbl); } + +#undef Perl_ptr_table_clear +void +Perl_ptr_table_clear(pTHXo_ PTR_TBL_t *tbl) +{ + ((CPerlObj*)pPerl)->Perl_ptr_table_clear(tbl); +} + +#undef Perl_ptr_table_free +void +Perl_ptr_table_free(pTHXo_ PTR_TBL_t *tbl) +{ + ((CPerlObj*)pPerl)->Perl_ptr_table_free(tbl); +} +#endif +#if defined(HAVE_INTERP_INTERN) + +#undef Perl_sys_intern_clear +void +Perl_sys_intern_clear(pTHXo) +{ + ((CPerlObj*)pPerl)->Perl_sys_intern_clear(); +} + +#undef Perl_sys_intern_init +void +Perl_sys_intern_init(pTHXo) +{ + ((CPerlObj*)pPerl)->Perl_sys_intern_init(); +} #endif #if defined(PERL_OBJECT) #else @@ -3998,6 +4153,16 @@ Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...) return (*PL_StdIO->pVprintf)(PL_StdIO, stream, format, arglist); } +#undef Perl_printf_nocontext +int +Perl_printf_nocontext(const char *format, ...) +{ + dTHXo; + va_list(arglist); + va_start(arglist, format); + return (*PL_StdIO->pVprintf)(PL_StdIO, PerlIO_stdout(), format, arglist); +} + END_EXTERN_C #endif /* PERL_OBJECT */ diff --git a/contrib/perl5/perlapi.h b/contrib/perl5/perlapi.h index 5e5ac2825b03..1f2dc8bfec9e 100644 --- a/contrib/perl5/perlapi.h +++ b/contrib/perl5/perlapi.h @@ -130,6 +130,8 @@ START_EXTERN_C #define PL_basetime (*Perl_Ibasetime_ptr(aTHXo)) #undef PL_beginav #define PL_beginav (*Perl_Ibeginav_ptr(aTHXo)) +#undef PL_beginav_save +#define PL_beginav_save (*Perl_Ibeginav_save_ptr(aTHXo)) #undef PL_bitcount #define PL_bitcount (*Perl_Ibitcount_ptr(aTHXo)) #undef PL_bufend @@ -194,6 +196,8 @@ START_EXTERN_C #define PL_doswitches (*Perl_Idoswitches_ptr(aTHXo)) #undef PL_dowarn #define PL_dowarn (*Perl_Idowarn_ptr(aTHXo)) +#undef PL_dummy1_bincompat +#define PL_dummy1_bincompat (*Perl_Idummy1_bincompat_ptr(aTHXo)) #undef PL_e_script #define PL_e_script (*Perl_Ie_script_ptr(aTHXo)) #undef PL_egid @@ -230,6 +234,8 @@ START_EXTERN_C #define PL_expect (*Perl_Iexpect_ptr(aTHXo)) #undef PL_fdpid #define PL_fdpid (*Perl_Ifdpid_ptr(aTHXo)) +#undef PL_fdpid_mutex +#define PL_fdpid_mutex (*Perl_Ifdpid_mutex_ptr(aTHXo)) #undef PL_filemode #define PL_filemode (*Perl_Ifilemode_ptr(aTHXo)) #undef PL_forkprocess @@ -246,6 +252,8 @@ START_EXTERN_C #define PL_glob_index (*Perl_Iglob_index_ptr(aTHXo)) #undef PL_globalstash #define PL_globalstash (*Perl_Iglobalstash_ptr(aTHXo)) +#undef PL_he_arenaroot +#define PL_he_arenaroot (*Perl_Ihe_arenaroot_ptr(aTHXo)) #undef PL_he_root #define PL_he_root (*Perl_Ihe_root_ptr(aTHXo)) #undef PL_hintgv @@ -382,12 +390,14 @@ START_EXTERN_C #define PL_nthreads (*Perl_Inthreads_ptr(aTHXo)) #undef PL_nthreads_cond #define PL_nthreads_cond (*Perl_Inthreads_cond_ptr(aTHXo)) +#undef PL_nullstash +#define PL_nullstash (*Perl_Inullstash_ptr(aTHXo)) #undef PL_numeric_local #define PL_numeric_local (*Perl_Inumeric_local_ptr(aTHXo)) #undef PL_numeric_name #define PL_numeric_name (*Perl_Inumeric_name_ptr(aTHXo)) -#undef PL_numeric_radix -#define PL_numeric_radix (*Perl_Inumeric_radix_ptr(aTHXo)) +#undef PL_numeric_radix_sv +#define PL_numeric_radix_sv (*Perl_Inumeric_radix_sv_ptr(aTHXo)) #undef PL_numeric_standard #define PL_numeric_standard (*Perl_Inumeric_standard_ptr(aTHXo)) #undef PL_ofmt @@ -490,6 +500,8 @@ START_EXTERN_C #define PL_sv_arenaroot (*Perl_Isv_arenaroot_ptr(aTHXo)) #undef PL_sv_count #define PL_sv_count (*Perl_Isv_count_ptr(aTHXo)) +#undef PL_sv_lock_mutex +#define PL_sv_lock_mutex (*Perl_Isv_lock_mutex_ptr(aTHXo)) #undef PL_sv_mutex #define PL_sv_mutex (*Perl_Isv_mutex_ptr(aTHXo)) #undef PL_sv_no @@ -566,26 +578,48 @@ START_EXTERN_C #define PL_xiv_arenaroot (*Perl_Ixiv_arenaroot_ptr(aTHXo)) #undef PL_xiv_root #define PL_xiv_root (*Perl_Ixiv_root_ptr(aTHXo)) +#undef PL_xnv_arenaroot +#define PL_xnv_arenaroot (*Perl_Ixnv_arenaroot_ptr(aTHXo)) #undef PL_xnv_root #define PL_xnv_root (*Perl_Ixnv_root_ptr(aTHXo)) +#undef PL_xpv_arenaroot +#define PL_xpv_arenaroot (*Perl_Ixpv_arenaroot_ptr(aTHXo)) #undef PL_xpv_root #define PL_xpv_root (*Perl_Ixpv_root_ptr(aTHXo)) +#undef PL_xpvav_arenaroot +#define PL_xpvav_arenaroot (*Perl_Ixpvav_arenaroot_ptr(aTHXo)) #undef PL_xpvav_root #define PL_xpvav_root (*Perl_Ixpvav_root_ptr(aTHXo)) +#undef PL_xpvbm_arenaroot +#define PL_xpvbm_arenaroot (*Perl_Ixpvbm_arenaroot_ptr(aTHXo)) #undef PL_xpvbm_root #define PL_xpvbm_root (*Perl_Ixpvbm_root_ptr(aTHXo)) +#undef PL_xpvcv_arenaroot +#define PL_xpvcv_arenaroot (*Perl_Ixpvcv_arenaroot_ptr(aTHXo)) #undef PL_xpvcv_root #define PL_xpvcv_root (*Perl_Ixpvcv_root_ptr(aTHXo)) +#undef PL_xpvhv_arenaroot +#define PL_xpvhv_arenaroot (*Perl_Ixpvhv_arenaroot_ptr(aTHXo)) #undef PL_xpvhv_root #define PL_xpvhv_root (*Perl_Ixpvhv_root_ptr(aTHXo)) +#undef PL_xpviv_arenaroot +#define PL_xpviv_arenaroot (*Perl_Ixpviv_arenaroot_ptr(aTHXo)) #undef PL_xpviv_root #define PL_xpviv_root (*Perl_Ixpviv_root_ptr(aTHXo)) +#undef PL_xpvlv_arenaroot +#define PL_xpvlv_arenaroot (*Perl_Ixpvlv_arenaroot_ptr(aTHXo)) #undef PL_xpvlv_root #define PL_xpvlv_root (*Perl_Ixpvlv_root_ptr(aTHXo)) +#undef PL_xpvmg_arenaroot +#define PL_xpvmg_arenaroot (*Perl_Ixpvmg_arenaroot_ptr(aTHXo)) #undef PL_xpvmg_root #define PL_xpvmg_root (*Perl_Ixpvmg_root_ptr(aTHXo)) +#undef PL_xpvnv_arenaroot +#define PL_xpvnv_arenaroot (*Perl_Ixpvnv_arenaroot_ptr(aTHXo)) #undef PL_xpvnv_root #define PL_xpvnv_root (*Perl_Ixpvnv_root_ptr(aTHXo)) +#undef PL_xrv_arenaroot +#define PL_xrv_arenaroot (*Perl_Ixrv_arenaroot_ptr(aTHXo)) #undef PL_xrv_root #define PL_xrv_root (*Perl_Ixrv_root_ptr(aTHXo)) #undef PL_yychar diff --git a/contrib/perl5/perlio.c b/contrib/perl5/perlio.c index 6945a75069a7..87419801c81c 100644 --- a/contrib/perl5/perlio.c +++ b/contrib/perl5/perlio.c @@ -1,6 +1,6 @@ /* perlio.c * - * Copyright (c) 1996-2000, Nick Ing-Simmons + * Copyright (c) 1996-2001, Nick Ing-Simmons * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -172,10 +172,14 @@ PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt) #else Perl_croak(aTHX_ "Cannot set 'ptr' of FILE * on this system"); #endif -#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) +#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) && defined (STDIO_PTR_LVAL_NOCHANGE_CNT) FILE_cnt(f) = cnt; #else - Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system"); +#if defined(STDIO_PTR_LVAL_SETS_CNT) + assert (FILE_cnt(f) == cnt); +#else + Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system when setting 'ptr'"); +#endif #endif } @@ -485,7 +489,11 @@ PerlIO_init(void) #ifndef HAS_FSETPOS #undef PerlIO_setpos int +#ifdef USE_SFIO +PerlIO_setpos(PerlIO *f, const Off_t *pos) +#else PerlIO_setpos(PerlIO *f, const Fpos_t *pos) +#endif { return PerlIO_seek(f,*pos,0); } @@ -507,11 +515,19 @@ PerlIO_setpos(PerlIO *f, const Fpos_t *pos) #ifndef HAS_FGETPOS #undef PerlIO_getpos int +#ifdef USE_SFIO +PerlIO_getpos(PerlIO *f, Off_t *pos) +{ + *pos = PerlIO_seek(f,0,0); + return 0; +} +#else PerlIO_getpos(PerlIO *f, Fpos_t *pos) { *pos = PerlIO_tell(f); return 0; } +#endif #else #ifndef PERLIO_IS_STDIO #undef PerlIO_getpos diff --git a/contrib/perl5/perlsdio.h b/contrib/perl5/perlsdio.h index 7afda6819198..6ce82d80b378 100644 --- a/contrib/perl5/perlsdio.h +++ b/contrib/perl5/perlsdio.h @@ -97,20 +97,30 @@ #ifdef STDIO_CNT_LVALUE #define PerlIO_canset_cnt(f) 1 +#define PerlIO_set_cnt(f,c) (FILE_cnt(f) = (c)) #ifdef STDIO_PTR_LVALUE +#ifdef STDIO_PTR_LVAL_NOCHANGE_CNT #define PerlIO_fast_gets(f) 1 #endif -#define PerlIO_set_cnt(f,c) (FILE_cnt(f) = (c)) -#else +#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 */ @@ -213,9 +223,11 @@ #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_ @@ -315,9 +327,11 @@ #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_ diff --git a/contrib/perl5/perlsfio.h b/contrib/perl5/perlsfio.h index c4ed5c7650e4..d9b3323bf5cd 100644 --- a/contrib/perl5/perlsfio.h +++ b/contrib/perl5/perlsfio.h @@ -3,6 +3,11 @@ #include <sfio.h> #endif +/* sfio 2000 changed _stdopen to _stdfdopen */ +#if SFIO_VERSION >= 20000101L +#define _stdopen _stdfdopen +#endif + extern Sfio_t* _stdopen _ARG_((int, const char*)); extern int _stdprintf _ARG_((const char*, ...)); @@ -13,7 +18,7 @@ extern int _stdprintf _ARG_((const char*, ...)); #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) @@ -30,7 +35,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) @@ -44,15 +54,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 = (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/contrib/perl5/perly.c b/contrib/perl5/perly.c index 36b51c02e758..2b5108fac166 100644 --- a/contrib/perl5/perly.c +++ b/contrib/perl5/perly.c @@ -1386,6 +1386,9 @@ yyparse() #endif struct ysv *ysave; +#ifdef USE_ITHREADS + ENTER; /* force yydestruct() before we return */ +#endif New(73, ysave, 1, struct ysv); SAVEDESTRUCTOR_X(yydestruct, ysave); ysave->oldyydebug = yydebug; @@ -1744,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" @@ -2477,6 +2480,9 @@ yyoverflow: yyabort: retval = 1; yyaccept: +#ifdef USE_ITHREADS + LEAVE; /* force yydestruct() before we return */ +#endif return retval; } diff --git a/contrib/perl5/perly.y b/contrib/perl5/perly.y index 5170b365f3e0..f9c5c5f60696 100644 --- a/contrib/perl5/perly.y +++ b/contrib/perl5/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. @@ -61,6 +61,7 @@ static void yydestruct(pTHXo_ void *ptr); #ifdef USE_PURE_BISON #define YYLEX_PARAM (&yychar) +#define yylex yylex_r #endif %} @@ -266,7 +267,7 @@ nexpr : /* NULL */ ; texpr : /* NULL means true */ - { (void)scan_num("1"); $$ = yylval.opval; } + { (void)scan_num("1", &yylval); $$ = yylval.opval; } | expr ; diff --git a/contrib/perl5/perly_c.diff b/contrib/perl5/perly_c.diff index 0b73880c4e42..0cfe10f8d7e1 100644 --- a/contrib/perl5/perly_c.diff +++ b/contrib/perl5/perly_c.diff @@ -12,7 +12,7 @@ if (yys = getenv("YYDEBUG")) { yyn = *yys; ---- 1447,1473 ---- +--- 1447,1476 ---- yyparse() { register int yym, yyn, yystate; @@ -27,6 +27,9 @@ ! #endif + struct ysv *ysave; ++ #ifdef USE_ITHREADS ++ ENTER; /* force yydestruct() before we return */ ++ #endif + New(73, ysave, 1, struct ysv); + SAVEDESTRUCTOR_X(yydestruct, ysave); + ysave->oldyydebug = yydebug; @@ -42,7 +45,7 @@ yyn = *yys; *************** *** 1463,1468 **** ---- 1480,1495 ---- +--- 1483,1498 ---- yyerrflag = 0; yychar = (-1); @@ -68,7 +71,7 @@ } *++yyssp = yystate = yytable[yyn]; *++yyvsp = yylval; ---- 1520,1538 ---- +--- 1523,1541 ---- #endif if (yyssp >= yyss + yystacksize - 1) { @@ -97,7 +100,7 @@ } *++yyssp = yystate = yytable[yyn]; *++yyvsp = yylval; ---- 1573,1591 ---- +--- 1576,1594 ---- #endif if (yyssp >= yyss + yystacksize - 1) { @@ -134,7 +137,7 @@ yyaccept: ! return (0); } ---- 2524,2569 ---- +--- 2527,2575 ---- #endif if (yyssp >= yyss + yystacksize - 1) { @@ -160,6 +163,9 @@ yyabort: ! retval = 1; yyaccept: +! #ifdef USE_ITHREADS +! LEAVE; /* force yydestruct() before we return */ +! #endif ! return retval; ! } ! diff --git a/contrib/perl5/pod/perl.pod b/contrib/perl5/pod/perl.pod index 59ca0e0368dc..b7e88fb24202 100644 --- a/contrib/perl5/pod/perl.pod +++ b/contrib/perl5/pod/perl.pod @@ -12,83 +12,114 @@ B<perl> S<[ B<-sTuU> ]> S<[ B<-hv> ] [ B<-V>[:I<configvar>] ]> S<[ B<-i>[I<extension>] ]> S<[ B<-e> I<'command'> ] [ B<--> ] [ I<programfile> ] [ I<argument> ]...> -For ease of access, the Perl manual has been split up into several -sections: +For ease of access, the Perl manual has been split up into several sections: perl Perl overview (this section) - perldelta Perl changes since previous version - perl5005delta Perl changes in version 5.005 - perl5004delta Perl changes in version 5.004 perlfaq Perl frequently asked questions perltoc Perl documentation table of contents + perlbook Perl book information - perldata Perl data structures perlsyn Perl syntax + perldata Perl data structures perlop Perl operators and precedence - perlre Perl regular expressions - perlrun Perl execution and options - perlfunc Perl builtin functions - perlopentut Perl open() tutorial - perlvar Perl predefined variables perlsub Perl subroutines - perlmod Perl modules: how they work - perlmodlib Perl modules: how to write and use - perlmodinstall Perl modules: how to install from CPAN - perlform Perl formats - perlunicode Perl unicode support - perllocale Perl locale support - + perlfunc Perl builtin functions perlreftut Perl references short introduction - perlref Perl references, the rest of the story perldsc Perl data structures intro + perlrequick Perl regular expressions quick start + perlpod Perl plain old documentation + perlstyle Perl style guide + perltrap Perl traps for the unwary + + perlrun Perl execution and options + perldiag Perl diagnostic messages + perllexwarn Perl warnings and their control + perldebtut Perl debugging tutorial + perldebug Perl debugging + + perlvar Perl predefined variables perllol Perl data structures: arrays of arrays + perlopentut Perl open() tutorial + perlretut Perl regular expressions tutorial + + perlre Perl regular expressions, the rest of the story + perlref Perl references, the rest of the story + + perlform Perl formats + perlboot Perl OO tutorial for beginners perltoot Perl OO tutorial, part 1 perltootc Perl OO tutorial, part 2 perlobj Perl objects - perltie Perl objects hidden behind simple variables perlbot Perl OO tricks and examples + perltie Perl objects hidden behind simple variables + perlipc Perl interprocess communication perlfork Perl fork() information + perlnumber Perl number semantics perlthrtut Perl threads tutorial - perllexwarn Perl warnings and their control - perlfilter Perl source filters - perldbmfilter Perl DBM filters - perlcompile Perl compiler suite intro - perldebug Perl debugging - perldiag Perl diagnostic messages - perlnumber Perl number semantics - perlsec Perl security - perltrap Perl traps for the unwary perlport Perl portability guide - perlstyle Perl style guide + perllocale Perl locale support + perlunicode Perl unicode support + perlebcdic Considerations for running Perl on EBCDIC platforms - perlpod Perl plain old documentation - perlbook Perl book information + perlsec Perl security + + perlmod Perl modules: how they work + perlmodlib Perl modules: how to write and use + perlmodinstall Perl modules: how to install from CPAN + perlnewmod Perl modules: preparing a new module for distribution + + perlfaq1 General Questions About Perl + perlfaq2 Obtaining and Learning about Perl + perlfaq3 Programming Tools + perlfaq4 Data Manipulation + perlfaq5 Files and Formats + perlfaq6 Regexes + perlfaq7 Perl Language Issues + perlfaq8 System Interaction + perlfaq9 Networking + + perlcompile Perl compiler suite intro perlembed Perl ways to embed perl in your C or C++ application - perlapio Perl internal IO abstraction interface perldebguts Perl debugging guts and tips - perlxs Perl XS application programming interface perlxstut Perl XS tutorial + perlxs Perl XS application programming interface + perlclib Internal replacements for standard C library functions perlguts Perl internal functions for those doing extensions perlcall Perl calling conventions from C + perlutil utilities packaged with the Perl distribution + perlfilter Perl source filters + perldbmfilter Perl DBM filters perlapi Perl API listing (autogenerated) perlintern Perl internal functions (autogenerated) - + perlapio Perl internal IO abstraction interface perltodo Perl things to do perlhack Perl hackers guide + perlhist Perl history records + perldelta Perl changes since previous version + perl5005delta Perl changes in version 5.005 + perl5004delta Perl changes in version 5.004 + perlaix Perl notes for AIX perlamiga Perl notes for Amiga + perlbs2000 Perl notes for POSIX-BC BS2000 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 + perlmacos Perl notes for Mac OS (Classic) + perlmpeix Perl notes for MPE/iX perlos2 Perl notes for OS/2 perlos390 Perl notes for OS/390 + perlsolaris Perl notes for Solaris + perlvmesa Perl notes for VM/ESA 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, @@ -162,58 +193,85 @@ But wait, there's more... Begun in 1993 (see L<perlhist>), Perl version 5 is nearly a complete rewrite that provides the following additional benefits: -=over +=over 4 + +=item * -=item * modularity and reusability using innumerable modules +modularity and reusability using innumerable modules Described in L<perlmod>, L<perlmodlib>, and L<perlmodinstall>. -=item * embeddable and extensible +=item * + +embeddable and extensible Described in L<perlembed>, L<perlxstut>, L<perlxs>, L<perlcall>, L<perlguts>, and L<xsubpp>. -=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<perltie> and L<AnyDBM_File>. -=item * subroutines can now be overridden, autoloaded, and prototyped +=item * + +subroutines can now be overridden, autoloaded, and prototyped Described in L<perlsub>. -=item * arbitrarily nested data structures and anonymous functions +=item * + +arbitrarily nested data structures and anonymous functions Described in L<perlreftut>, L<perlref>, L<perldsc>, and L<perllol>. -=item * object-oriented programming +=item * + +object-oriented programming Described in L<perlobj>, L<perltoot>, and L<perlbot>. -=item * compilability into C code or Perl bytecode +=item * + +compilability into C code or Perl bytecode Described in L<B> and L<B::Bytecode>. -=item * support for light-weight processes (threads) +=item * + +support for light-weight processes (threads) Described in L<perlthrtut> and L<Thread>. -=item * support for internationalization, localization, and Unicode +=item * + +support for internationalization, localization, and Unicode Described in L<perllocale> and L<utf8>. -=item * lexical scoping +=item * + +lexical scoping Described in L<perlsub>. -=item * regular expression enhancements +=item * + +regular expression enhancements Described in L<perlre>, with additional examples in L<perlop>. -=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<perldebug>. -=item * POSIX 1003.1 compliant library +=item * + +POSIX 1003.1 compliant library Described in L<POSIX>. @@ -293,7 +351,7 @@ affected by wraparound). You may mail your bug reports (be sure to include full configuration information as output by the myconfig program in the perl source -tree, or by C<perl -V>) to perlbug@perl.com . If you've succeeded +tree, or by C<perl -V>) to perlbug@perl.org . If you've succeeded in compiling perl, the B<perlbug> script in the F<utils/> subdirectory can be used to help mail in a bug report. diff --git a/contrib/perl5/pod/perl5004delta.pod b/contrib/perl5/pod/perl5004delta.pod index 85a8f96161be..429cba93ced7 100644 --- a/contrib/perl5/pod/perl5004delta.pod +++ b/contrib/perl5/pod/perl5004delta.pod @@ -24,7 +24,10 @@ problems. See the F<Changes> 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<INSTALL> file for how to use it. =head2 New and changed syntax -=over +=over 4 =item $coderef->(PARAMS) @@ -276,7 +279,7 @@ S<C<< $table->{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<use English> 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<UNIVERSAL> 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<isa> available as a plain subroutine in the current package. See L<perltie> 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<README.amigaos> in the perl distribution. Six new pragmatic modules exist: -=over +=over 4 =item use autouse MODULE => qw(sub1 sub2 sub3) @@ -810,7 +813,7 @@ builtin operations. When C<use locale> is in effect, the current LC_CTYPE locale is used for regular expressions and case mapping; LC_COLLATE for string -ordering; and LC_NUMERIC for numeric formating in printf and sprintf +ordering; and LC_NUMERIC for numeric formatting in printf and sprintf (but B<not> in print). LC_NUMERIC is always used in write, since lexical scoping of formats is problematic at best. @@ -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<void> XSUBs now default to returning nothing @@ -1083,7 +1086,7 @@ XSUB's return type is really C<SV *>. =head1 C Language API Changes -=over +=over 4 =item C<gv_fetchmethod> and C<perl_call_sv> @@ -1124,7 +1127,7 @@ which can be more efficient. See L<perlguts> for details. Many of the base and library pods were updated. These new pods are included in section 1: -=over +=over 4 =item L<perldelta> @@ -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<can> diff --git a/contrib/perl5/pod/perl5005delta.pod b/contrib/perl5/pod/perl5005delta.pod index b133c0dd813d..78bf90f616b9 100644 --- a/contrib/perl5/pod/perl5005delta.pod +++ b/contrib/perl5/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<required> to build perl. See F<INSTALL>. -=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<PL_> prefix. New extensions should C<not> refer to perl globals @@ -87,7 +91,9 @@ support may cease in a future release. See L<perlguts/"API LISTING">. -=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<dTHR> 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,13 +602,15 @@ Various pragmata to control behavior of regular expressions. =head2 Changes in existing modules -=over +=over 4 =item Benchmark You can now run tests for I<x> seconds instead of guessing the right number of tests to run. +Keeps better time. + =item Carp Carp has a new function cluck(). cluck() warns, like carp(), but also adds @@ -660,10 +668,6 @@ See <perlmodinstall> and L<CPAN>. Cwd::cwd is faster on most platforms. -=item Benchmark - -Keeps better time. - =back =head1 Utility Changes @@ -702,7 +706,7 @@ L<perlthrtut> 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 +863,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 +920,7 @@ fix the problem can be found in L<perllocale/"LOCALE PROBLEMS">. =head1 Obsolete Diagnostics -=over +=over 4 =item Can't mktemp() diff --git a/contrib/perl5/pod/perlapi.pod b/contrib/perl5/pod/perlapi.pod index e0ae4cfb5814..67009d0fad48 100644 --- a/contrib/perl5/pod/perlapi.pod +++ b/contrib/perl5/pod/perlapi.pod @@ -25,6 +25,9 @@ Same as C<av_len()>. Deprecated, use C<av_len()> instead. int AvFILL(AV* av) +=for hackers +Found in file av.h + =item av_clear Clears an array, making it empty. Does not free the memory used by the @@ -32,6 +35,31 @@ array itself. void av_clear(AV* ar) +=for hackers +Found in file av.c + +=item av_delete + +Deletes the element indexed by C<key> from the array. Returns the +deleted element. C<flags> is currently ignored. + + SV* av_delete(AV* ar, I32 key, I32 flags) + +=for hackers +Found in file av.c + +=item av_exists + +Returns true if the element indexed by C<key> has been initialized. + +This relies on the fact that uninitialized array elements are set to +C<&PL_sv_undef>. + + bool av_exists(AV* ar, I32 key) + +=for hackers +Found in file av.c + =item av_extend Pre-extend an array. The C<key> is the index to which the array should be @@ -39,6 +67,9 @@ extended. void av_extend(AV* ar, I32 key) +=for hackers +Found in file av.c + =item av_fetch Returns the SV at the specified index in the array. The C<key> is the @@ -50,6 +81,19 @@ more information on how to use this function on tied arrays. SV** av_fetch(AV* ar, I32 key, I32 lval) +=for hackers +Found in file av.c + +=item av_fill + +Ensure than an array has a given number of elements, equivalent to +Perl's C<$#array = $fill;>. + + void av_fill(AV* ar, I32 fill) + +=for hackers +Found in file av.c + =item av_len Returns the highest index in the array. Returns -1 if the array is @@ -57,6 +101,9 @@ empty. I32 av_len(AV* ar) +=for hackers +Found in file av.c + =item av_make Creates a new AV and populates it with a list of SVs. The SVs are copied @@ -65,6 +112,9 @@ will have a reference count of 1. AV* av_make(I32 size, SV** svp) +=for hackers +Found in file av.c + =item av_pop Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array @@ -72,6 +122,9 @@ is empty. SV* av_pop(AV* ar) +=for hackers +Found in file av.c + =item av_push Pushes an SV onto the end of the array. The array will grow automatically @@ -79,12 +132,18 @@ to accommodate the addition. void av_push(AV* ar, SV* val) +=for hackers +Found in file av.c + =item av_shift Shifts an SV off the beginning of the array. SV* av_shift(AV* ar) +=for hackers +Found in file av.c + =item av_store Stores an SV in an array. The array index is specified as C<key>. The @@ -100,12 +159,18 @@ more information on how to use this function on tied arrays. SV** av_store(AV* ar, I32 key, SV* val) +=for hackers +Found in file av.c + =item av_undef Undefines the array. Frees the memory used by the array itself. void av_undef(AV* ar) +=for hackers +Found in file av.c + =item av_unshift Unshift the given number of C<undef> values onto the beginning of the @@ -114,6 +179,40 @@ must then use C<av_store> to assign values to these new elements. void av_unshift(AV* ar, I32 num) +=for hackers +Found in file av.c + +=item bytes_from_utf8 + +Converts a string C<s> of length C<len> from UTF8 into byte encoding. +Unlike <utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to +the newly-created string, and updates C<len> to contain the new +length. Returns the original string if no conversion occurs, C<len> +is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to +0 if C<s> is converted or contains all 7bit characters. + +NOTE: this function is experimental and may change or be +removed without notice. + + U8* bytes_from_utf8(U8 *s, STRLEN *len, bool *is_utf8) + +=for hackers +Found in file utf8.c + +=item bytes_to_utf8 + +Converts a string C<s> of length C<len> from ASCII into UTF8 encoding. +Returns a pointer to the newly-created string, and sets C<len> to +reflect the new length. + +NOTE: this function is experimental and may change or be +removed without notice. + + U8* bytes_to_utf8(U8 *s, STRLEN *len) + +=for hackers +Found in file utf8.c + =item call_argv Performs a callback to the specified Perl sub. See L<perlcall>. @@ -122,6 +221,9 @@ NOTE: the perl_ form of this function is deprecated. I32 call_argv(const char* sub_name, I32 flags, char** argv) +=for hackers +Found in file perl.c + =item call_method Performs a callback to the specified Perl method. The blessed object must @@ -131,6 +233,9 @@ NOTE: the perl_ form of this function is deprecated. I32 call_method(const char* methname, I32 flags) +=for hackers +Found in file perl.c + =item call_pv Performs a callback to the specified Perl sub. See L<perlcall>. @@ -139,6 +244,9 @@ NOTE: the perl_ form of this function is deprecated. I32 call_pv(const char* sub_name, I32 flags) +=for hackers +Found in file perl.c + =item call_sv Performs a callback to the Perl sub whose name is in the SV. See @@ -148,6 +256,9 @@ NOTE: the perl_ form of this function is deprecated. I32 call_sv(SV* sv, I32 flags) +=for hackers +Found in file perl.c + =item CLASS Variable which is setup by C<xsubpp> to indicate the @@ -155,6 +266,9 @@ class name for a C++ XS constructor. This is always a C<char*>. See C<THIS>. char* CLASS +=for hackers +Found in file XSUB.h + =item Copy The XSUB-writer's interface to the C C<memcpy> function. The C<src> is the @@ -163,20 +277,36 @@ the type. May fail on overlapping copies. See also C<Move>. void Copy(void* src, void* dest, int nitems, type) +=for hackers +Found in file handy.h + =item croak -This is the XSUB-writer's interface to Perl's C<die> function. Use this -function the same way you use the C C<printf> function. See -C<warn>. +This is the XSUB-writer's interface to Perl's C<die> function. +Normally use this function the same way you use the C C<printf> +function. See C<warn>. + +If you want to throw an exception object, assign the object to +C<$@> and then pass C<Nullch> to croak(): + + errsv = get_sv("@", TRUE); + sv_setsv(errsv, exception_object); + croak(Nullch); void croak(const char* pat, ...) +=for hackers +Found in file util.c + =item CvSTASH Returns the stash of the CV. HV* CvSTASH(CV* cv) +=for hackers +Found in file cv.h + =item dMARK Declare a stack marker variable, C<mark>, for the XSUB. See C<MARK> and @@ -184,12 +314,18 @@ C<dORIGMARK>. dMARK; +=for hackers +Found in file pp.h + =item dORIGMARK Saves the original stack mark for the XSUB. See C<ORIGMARK>. dORIGMARK; +=for hackers +Found in file pp.h + =item dSP Declares a local copy of perl's stack pointer for the XSUB, available via @@ -197,6 +333,9 @@ the C<SP> macro. See C<SP>. dSP; +=for hackers +Found in file pp.h + =item dXSARGS Sets up stack and mark pointers for an XSUB, calling dSP and dMARK. This @@ -205,6 +344,9 @@ variable to indicate the number of items on the stack. dXSARGS; +=for hackers +Found in file XSUB.h + =item dXSI32 Sets up the C<ix> variable for an XSUB which has aliases. This is usually @@ -212,12 +354,18 @@ handled automatically by C<xsubpp>. dXSI32; +=for hackers +Found in file XSUB.h + =item ENTER Opening bracket on a callback. See C<LEAVE> and L<perlcall>. ENTER; +=for hackers +Found in file scope.h + =item eval_pv Tells Perl to C<eval> the given string and return an SV* result. @@ -226,6 +374,9 @@ NOTE: the perl_ form of this function is deprecated. SV* eval_pv(const char* p, I32 croak_on_error) +=for hackers +Found in file perl.c + =item eval_sv Tells Perl to C<eval> the string in the SV. @@ -234,14 +385,20 @@ NOTE: the perl_ form of this function is deprecated. I32 eval_sv(SV* sv, I32 flags) +=for hackers +Found in file perl.c + =item EXTEND Used to extend the argument stack for an XSUB's return values. Once -used, guarrantees that there is room for at least C<nitems> to be pushed +used, guarantees that there is room for at least C<nitems> to be pushed onto the stack. void EXTEND(SP, int nitems) +=for hackers +Found in file pp.h + =item fbm_compile Analyses the string in order to make fast searches on it using fbm_instr() @@ -249,6 +406,9 @@ Analyses the string in order to make fast searches on it using fbm_instr() void fbm_compile(SV* sv, U32 flags) +=for hackers +Found in file util.c + =item fbm_instr Returns the location of the SV in the string delimited by C<str> and @@ -258,6 +418,9 @@ then. char* fbm_instr(unsigned char* big, unsigned char* bigend, SV* littlesv, U32 flags) +=for hackers +Found in file util.c + =item FREETMPS Closing bracket for temporaries on a callback. See C<SAVETMPS> and @@ -265,6 +428,9 @@ L<perlcall>. FREETMPS; +=for hackers +Found in file scope.h + =item get_av Returns the AV of the specified Perl array. If C<create> is set and the @@ -275,6 +441,9 @@ NOTE: the perl_ form of this function is deprecated. AV* get_av(const char* name, I32 create) +=for hackers +Found in file perl.c + =item get_cv Returns the CV of the specified Perl subroutine. If C<create> is set and @@ -286,6 +455,9 @@ NOTE: the perl_ form of this function is deprecated. CV* get_cv(const char* name, I32 create) +=for hackers +Found in file perl.c + =item get_hv Returns the HV of the specified Perl hash. If C<create> is set and the @@ -296,6 +468,9 @@ NOTE: the perl_ form of this function is deprecated. HV* get_hv(const char* name, I32 create) +=for hackers +Found in file perl.c + =item get_sv Returns the SV of the specified Perl scalar. If C<create> is set and the @@ -306,6 +481,9 @@ NOTE: the perl_ form of this function is deprecated. SV* get_sv(const char* name, I32 create) +=for hackers +Found in file perl.c + =item GIMME A backward-compatible version of C<GIMME_V> which can only return @@ -314,71 +492,89 @@ Deprecated. Use C<GIMME_V> instead. U32 GIMME +=for hackers +Found in file op.h + =item GIMME_V The XSUB-writer's equivalent to Perl's C<wantarray>. Returns C<G_VOID>, -C<G_SCALAR> or C<G_ARRAY> for void, scalar or array context, +C<G_SCALAR> or C<G_ARRAY> for void, scalar or list context, respectively. U32 GIMME_V +=for hackers +Found in file op.h + =item GvSV Return the SV from the GV. SV* GvSV(GV* gv) +=for hackers +Found in file gv.h + =item gv_fetchmeth Returns the glob with the given C<name> and a defined subroutine or C<NULL>. The glob lives in the given C<stash>, or in the stashes -accessible via @ISA and @UNIVERSAL. +accessible via @ISA and @UNIVERSAL. The argument C<level> should be either 0 or -1. If C<level==0>, as a side-effect creates a glob with the given C<name> in the given C<stash> which in the case of success contains an alias for the subroutine, and sets -up caching info for this glob. Similarly for all the searched stashes. +up caching info for this glob. Similarly for all the searched stashes. This function grants C<"SUPER"> token as a postfix of the stash name. The GV returned from C<gv_fetchmeth> may be a method cache entry, which is not visible to Perl code. So when calling C<call_sv>, you should not use the GV directly; instead, you should use the method's CV, which can be -obtained from the GV with the C<GvCV> macro. +obtained from the GV with the C<GvCV> macro. GV* gv_fetchmeth(HV* stash, const char* name, STRLEN len, I32 level) +=for hackers +Found in file gv.c + =item gv_fetchmethod See L<gv_fetchmethod_autoload>. GV* gv_fetchmethod(HV* stash, const char* name) +=for hackers +Found in file gv.c + =item gv_fetchmethod_autoload Returns the glob which contains the subroutine to call to invoke the method on the C<stash>. In fact in the presence of autoloading this may be the glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is -already setup. +already setup. The third parameter of C<gv_fetchmethod_autoload> determines whether AUTOLOAD lookup is performed if the given method is not present: non-zero -means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. +means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload> -with a non-zero C<autoload> parameter. +with a non-zero C<autoload> parameter. These functions grant C<"SUPER"> token as a prefix of the method name. Note that if you want to keep the returned glob for a long time, you need to check for it being "AUTOLOAD", since at the later time the call may load a different subroutine due to $AUTOLOAD changing its value. Use the glob -created via a side effect to do this. +created via a side effect to do this. These functions have the same side-effects and as C<gv_fetchmeth> with C<level==0>. C<name> should be writable if contains C<':'> or C<' ''>. The warning against passing the GV returned by C<gv_fetchmeth> to -C<call_sv> apply equally to these functions. +C<call_sv> apply equally to these functions. GV* gv_fetchmethod_autoload(HV* stash, const char* name, I32 autoload) +=for hackers +Found in file gv.c + =item gv_stashpv Returns a pointer to the stash for a specified package. C<name> should @@ -388,6 +584,9 @@ package does not exist then NULL is returned. HV* gv_stashpv(const char* name, I32 create) +=for hackers +Found in file gv.c + =item gv_stashsv Returns a pointer to the stash for a specified package, which must be a @@ -395,47 +594,74 @@ valid UTF-8 string. See C<gv_stashpv>. HV* gv_stashsv(SV* sv, I32 create) +=for hackers +Found in file gv.c + =item G_ARRAY -Used to indicate array context. See C<GIMME_V>, C<GIMME> and +Used to indicate list context. See C<GIMME_V>, C<GIMME> and L<perlcall>. +=for hackers +Found in file cop.h + =item G_DISCARD Indicates that arguments returned from a callback should be discarded. See L<perlcall>. +=for hackers +Found in file cop.h + =item G_EVAL Used to force a Perl C<eval> wrapper around a callback. See L<perlcall>. +=for hackers +Found in file cop.h + =item G_NOARGS Indicates that no arguments are being sent to a callback. See L<perlcall>. +=for hackers +Found in file cop.h + =item G_SCALAR Used to indicate scalar context. See C<GIMME_V>, C<GIMME>, and L<perlcall>. +=for hackers +Found in file cop.h + =item G_VOID Used to indicate void context. See C<GIMME_V> and L<perlcall>. +=for hackers +Found in file cop.h + =item HEf_SVKEY This flag, used in the length slot of hash entries and magic structures, specifies the structure contains a C<SV*> pointer where a C<char*> pointer is to be expected. (For information only--not to be used). +=for hackers +Found in file hv.h + =item HeHASH Returns the computed hash stored in the hash entry. U32 HeHASH(HE* he) +=for hackers +Found in file hv.h + =item HeKEY Returns the actual pointer stored in the key slot of the hash entry. The @@ -445,6 +671,9 @@ usually preferable for finding the value of a key. void* HeKEY(HE* he) +=for hackers +Found in file hv.h + =item HeKLEN If this is negative, and amounts to C<HEf_SVKEY>, it indicates the entry @@ -454,6 +683,9 @@ lengths. STRLEN HeKLEN(HE* he) +=for hackers +Found in file hv.h + =item HePV Returns the key slot of the hash entry as a C<char*> value, doing any @@ -468,6 +700,9 @@ described elsewhere in this document. char* HePV(HE* he, STRLEN len) +=for hackers +Found in file hv.h + =item HeSVKEY Returns the key as an C<SV*>, or C<Nullsv> if the hash entry does not @@ -475,6 +710,9 @@ contain an C<SV*> key. SV* HeSVKEY(HE* he) +=for hackers +Found in file hv.h + =item HeSVKEY_force Returns the key as an C<SV*>. Will create and return a temporary mortal @@ -482,6 +720,9 @@ C<SV*> if the hash entry contains only a C<char*> key. SV* HeSVKEY_force(HE* he) +=for hackers +Found in file hv.h + =item HeSVKEY_set Sets the key to a given C<SV*>, taking care to set the appropriate flags to @@ -490,24 +731,36 @@ C<SV*>. SV* HeSVKEY_set(HE* he, SV* sv) +=for hackers +Found in file hv.h + =item HeVAL Returns the value slot (type C<SV*>) stored in the hash entry. SV* HeVAL(HE* he) +=for hackers +Found in file hv.h + =item HvNAME Returns the package name of a stash. See C<SvSTASH>, C<CvSTASH>. char* HvNAME(HV* stash) +=for hackers +Found in file hv.h + =item hv_clear Clears a hash, making it empty. void hv_clear(HV* tb) +=for hackers +Found in file hv.c + =item hv_delete Deletes a key/value pair in the hash. The value SV is removed from the @@ -517,6 +770,9 @@ will be returned. SV* hv_delete(HV* tb, const char* key, U32 klen, I32 flags) +=for hackers +Found in file hv.c + =item hv_delete_ent Deletes a key/value pair in the hash. The value SV is removed from the @@ -526,6 +782,9 @@ precomputed hash value, or 0 to ask for it to be computed. SV* hv_delete_ent(HV* tb, SV* key, I32 flags, U32 hash) +=for hackers +Found in file hv.c + =item hv_exists Returns a boolean indicating whether the specified hash key exists. The @@ -533,6 +792,9 @@ C<klen> is the length of the key. bool hv_exists(HV* tb, const char* key, U32 klen) +=for hackers +Found in file hv.c + =item hv_exists_ent Returns a boolean indicating whether the specified hash key exists. C<hash> @@ -541,6 +803,9 @@ computed. bool hv_exists_ent(HV* tb, SV* key, U32 hash) +=for hackers +Found in file hv.c + =item hv_fetch Returns the SV which corresponds to the specified key in the hash. The @@ -553,6 +818,9 @@ information on how to use this function on tied hashes. SV** hv_fetch(HV* tb, const char* key, U32 klen, I32 lval) +=for hackers +Found in file hv.c + =item hv_fetch_ent Returns the hash entry which corresponds to the specified key in the hash. @@ -568,6 +836,9 @@ information on how to use this function on tied hashes. HE* hv_fetch_ent(HV* tb, SV* key, I32 lval, U32 hash) +=for hackers +Found in file hv.c + =item hv_iterinit Prepares a starting point to traverse a hash table. Returns the number of @@ -580,6 +851,9 @@ value, you can get it through the macro C<HvFILL(tb)>. I32 hv_iterinit(HV* tb) +=for hackers +Found in file hv.c + =item hv_iterkey Returns the key from the current position of the hash iterator. See @@ -587,6 +861,9 @@ C<hv_iterinit>. char* hv_iterkey(HE* entry, I32* retlen) +=for hackers +Found in file hv.c + =item hv_iterkeysv Returns the key as an C<SV*> from the current position of the hash @@ -595,12 +872,18 @@ see C<hv_iterinit>. SV* hv_iterkeysv(HE* entry) +=for hackers +Found in file hv.c + =item hv_iternext Returns entries from a hash iterator. See C<hv_iterinit>. HE* hv_iternext(HV* tb) +=for hackers +Found in file hv.c + =item hv_iternextsv Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one @@ -608,6 +891,9 @@ operation. SV* hv_iternextsv(HV* hv, char** key, I32* retlen) +=for hackers +Found in file hv.c + =item hv_iterval Returns the value from the current position of the hash iterator. See @@ -615,12 +901,18 @@ C<hv_iterkey>. SV* hv_iterval(HV* tb, HE* entry) +=for hackers +Found in file hv.c + =item hv_magic Adds magic to a hash. See C<sv_magic>. void hv_magic(HV* hv, GV* gv, int how) +=for hackers +Found in file hv.c + =item hv_store Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is @@ -637,6 +929,9 @@ information on how to use this function on tied hashes. SV** hv_store(HV* tb, const char* key, U32 klen, SV* val, U32 hash) +=for hackers +Found in file hv.c + =item hv_store_ent Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash> @@ -654,33 +949,48 @@ information on how to use this function on tied hashes. HE* hv_store_ent(HV* tb, SV* key, SV* val, U32 hash) +=for hackers +Found in file hv.c + =item hv_undef Undefines the hash. void hv_undef(HV* tb) +=for hackers +Found in file hv.c + =item isALNUM -Returns a boolean indicating whether the C C<char> is an ascii alphanumeric -character or digit. +Returns a boolean indicating whether the C C<char> is an ASCII alphanumeric +character (including underscore) or digit. bool isALNUM(char ch) +=for hackers +Found in file handy.h + =item isALPHA -Returns a boolean indicating whether the C C<char> is an ascii alphabetic +Returns a boolean indicating whether the C C<char> is an ASCII alphabetic character. bool isALPHA(char ch) +=for hackers +Found in file handy.h + =item isDIGIT -Returns a boolean indicating whether the C C<char> is an ascii +Returns a boolean indicating whether the C C<char> is an ASCII digit. bool isDIGIT(char ch) +=for hackers +Found in file handy.h + =item isLOWER Returns a boolean indicating whether the C C<char> is a lowercase @@ -688,12 +998,18 @@ character. bool isLOWER(char ch) +=for hackers +Found in file handy.h + =item isSPACE Returns a boolean indicating whether the C C<char> is whitespace. bool isSPACE(char ch) +=for hackers +Found in file handy.h + =item isUPPER Returns a boolean indicating whether the C C<char> is an uppercase @@ -701,6 +1017,30 @@ character. bool isUPPER(char ch) +=for hackers +Found in file handy.h + +=item is_utf8_char + +Tests if some arbitrary number of bytes begins in a valid UTF-8 character. +The actual number of bytes in the UTF-8 character will be returned if it +is valid, otherwise 0. + + STRLEN is_utf8_char(U8 *p) + +=for hackers +Found in file utf8.c + +=item is_utf8_string + +Returns true if first C<len> bytes of the given string form valid a UTF8 +string, false otherwise. + + bool is_utf8_string(U8 *s, STRLEN len) + +=for hackers +Found in file utf8.c + =item items Variable which is setup by C<xsubpp> to indicate the number of @@ -708,6 +1048,9 @@ items on the stack. See L<perlxs/"Variable-length Parameter Lists">. I32 items +=for hackers +Found in file XSUB.h + =item ix Variable which is setup by C<xsubpp> to indicate which of an @@ -715,12 +1058,18 @@ XSUB's aliases was used to invoke it. See L<perlxs/"The ALIAS: Keyword">. I32 ix +=for hackers +Found in file XSUB.h + =item LEAVE Closing bracket on a callback. See C<ENTER> and L<perlcall>. LEAVE; +=for hackers +Found in file scope.h + =item looks_like_number Test if an the content of an SV looks like a number (or is a @@ -728,58 +1077,88 @@ number). I32 looks_like_number(SV* sv) +=for hackers +Found in file sv.c + =item MARK Stack marker variable for the XSUB. See C<dMARK>. +=for hackers +Found in file pp.h + =item mg_clear Clear something magical that the SV represents. See C<sv_magic>. int mg_clear(SV* sv) +=for hackers +Found in file mg.c + =item mg_copy Copies the magic from one SV to another. See C<sv_magic>. int mg_copy(SV* sv, SV* nsv, const char* key, I32 klen) +=for hackers +Found in file mg.c + =item mg_find Finds the magic pointer for type matching the SV. See C<sv_magic>. MAGIC* mg_find(SV* sv, int type) +=for hackers +Found in file mg.c + =item mg_free Free any magic storage used by the SV. See C<sv_magic>. int mg_free(SV* sv) +=for hackers +Found in file mg.c + =item mg_get Do magic after a value is retrieved from the SV. See C<sv_magic>. int mg_get(SV* sv) +=for hackers +Found in file mg.c + =item mg_length Report on the SV's length. See C<sv_magic>. U32 mg_length(SV* sv) +=for hackers +Found in file mg.c + =item mg_magical Turns on the magical status of an SV. See C<sv_magic>. void mg_magical(SV* sv) +=for hackers +Found in file mg.c + =item mg_set Do magic after a value is assigned to the SV. See C<sv_magic>. int mg_set(SV* sv) +=for hackers +Found in file mg.c + =item Move The XSUB-writer's interface to the C C<memmove> function. The C<src> is the @@ -788,18 +1167,27 @@ the type. Can do overlapping moves. See also C<Copy>. void Move(void* src, void* dest, int nitems, type) +=for hackers +Found in file handy.h + =item New The XSUB-writer's interface to the C C<malloc> function. void New(int id, void* ptr, int nitems, type) +=for hackers +Found in file handy.h + =item newAV Creates a new AV. The reference count is set to 1. AV* newAV() +=for hackers +Found in file av.c + =item Newc The XSUB-writer's interface to the C C<malloc> function, with @@ -807,6 +1195,9 @@ cast. void Newc(int id, void* ptr, int nitems, type, cast) +=for hackers +Found in file handy.h + =item newCONSTSUB Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is @@ -814,12 +1205,18 @@ eligible for inlining at compile-time. void newCONSTSUB(HV* stash, char* name, SV* sv) +=for hackers +Found in file op.c + =item newHV Creates a new HV. The reference count is set to 1. HV* newHV() +=for hackers +Found in file hv.c + =item newRV_inc Creates an RV wrapper for an SV. The reference count for the original SV is @@ -827,6 +1224,9 @@ incremented. SV* newRV_inc(SV* sv) +=for hackers +Found in file sv.h + =item newRV_noinc Creates an RV wrapper for an SV. The reference count for the original @@ -834,16 +1234,22 @@ SV is B<not> incremented. SV* newRV_noinc(SV *sv) +=for hackers +Found in file sv.c + =item NEWSV Creates a new SV. A non-zero C<len> parameter indicates the number of bytes of preallocated string space the SV should have. An extra byte for a tailing NUL is also reserved. (SvPOK is not set for the SV even if string -space is allocated.) The reference count for the new SV is set to 1. +space is allocated.) The reference count for the new SV is set to 1. C<id> is an integer id between 0 and 1299 (used to identify leaks). SV* NEWSV(int id, STRLEN len) +=for hackers +Found in file handy.h + =item newSViv Creates a new SV and copies an integer into it. The reference count for the @@ -851,6 +1257,9 @@ SV is set to 1. SV* newSViv(IV i) +=for hackers +Found in file sv.c + =item newSVnv Creates a new SV and copies a floating point value into it. @@ -858,6 +1267,9 @@ The reference count for the SV is set to 1. SV* newSVnv(NV n) +=for hackers +Found in file sv.c + =item newSVpv Creates a new SV and copies a string into it. The reference count for the @@ -866,6 +1278,9 @@ strlen(). For efficiency, consider using C<newSVpvn> instead. SV* newSVpv(const char* s, STRLEN len) +=for hackers +Found in file sv.c + =item newSVpvf Creates a new SV an initialize it with the string formatted like @@ -873,6 +1288,9 @@ C<sprintf>. SV* newSVpvf(const char* pat, ...) +=for hackers +Found in file sv.c + =item newSVpvn Creates a new SV and copies a string into it. The reference count for the @@ -882,6 +1300,9 @@ C<len> bytes long. SV* newSVpvn(const char* s, STRLEN len) +=for hackers +Found in file sv.c + =item newSVrv Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then @@ -891,12 +1312,18 @@ reference count is 1. SV* newSVrv(SV* rv, const char* classname) +=for hackers +Found in file sv.c + =item newSVsv Creates a new SV which is an exact duplicate of the original SV. SV* newSVsv(SV* old) +=for hackers +Found in file sv.c + =item newSVuv Creates a new SV and copies an unsigned integer into it. @@ -904,15 +1331,24 @@ The reference count for the SV is set to 1. SV* newSVuv(UV u) +=for hackers +Found in file sv.c + =item newXS Used by C<xsubpp> to hook up XSUBs as Perl subs. +=for hackers +Found in file op.c + =item newXSproto Used by C<xsubpp> to hook up XSUBs as Perl subs. Adds Perl prototypes to the subs. +=for hackers +Found in file XSUB.h + =item Newz The XSUB-writer's interface to the C C<malloc> function. The allocated @@ -920,98 +1356,104 @@ memory is zeroed with C<memzero>. void Newz(int id, void* ptr, int nitems, type) +=for hackers +Found in file handy.h + =item Nullav Null AV pointer. +=for hackers +Found in file av.h + =item Nullch Null character pointer. +=for hackers +Found in file handy.h + =item Nullcv Null CV pointer. +=for hackers +Found in file cv.h + =item Nullhv Null HV pointer. +=for hackers +Found in file hv.h + =item Nullsv Null SV pointer. +=for hackers +Found in file handy.h + =item ORIGMARK The original stack mark for the XSUB. See C<dORIGMARK>. +=for hackers +Found in file pp.h + =item perl_alloc Allocates a new Perl interpreter. See L<perlembed>. PerlInterpreter* perl_alloc() +=for hackers +Found in file perl.c + =item perl_construct Initializes a new Perl interpreter. See L<perlembed>. void perl_construct(PerlInterpreter* interp) +=for hackers +Found in file perl.c + =item perl_destruct Shuts down a Perl interpreter. See L<perlembed>. void perl_destruct(PerlInterpreter* interp) +=for hackers +Found in file perl.c + =item perl_free Releases a Perl interpreter. See L<perlembed>. void perl_free(PerlInterpreter* interp) +=for hackers +Found in file perl.c + =item perl_parse Tells a Perl interpreter to parse a Perl script. See L<perlembed>. int perl_parse(PerlInterpreter* interp, XSINIT_t xsinit, int argc, char** argv, char** env) +=for hackers +Found in file perl.c + =item perl_run Tells a Perl interpreter to run. See L<perlembed>. int perl_run(PerlInterpreter* interp) -=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. -Single-stepping is automatically turned on after every step. This is the C -variable which corresponds to Perl's $DB::single variable. See -C<PL_DBsub>. - - SV * PL_DBsingle - -=item PL_DBsub - -When Perl is run in debugging mode, with the B<-d> switch, this GV contains -the SV which holds the name of the sub being debugged. This is the C -variable which corresponds to Perl's $DB::sub variable. See -C<PL_DBsingle>. - - GV * PL_DBsub - -=item PL_DBtrace - -Trace variable used when Perl is run in debugging mode, with the B<-d> -switch. This is the C variable which corresponds to Perl's $DB::trace -variable. See C<PL_DBsingle>. - - SV * PL_DBtrace - -=item PL_dowarn - -The C variable which corresponds to Perl's $^W warning variable. - - bool PL_dowarn +=for hackers +Found in file perl.c =item PL_modglobal @@ -1023,6 +1465,9 @@ prefixed by the package name of the extension that owns the data. HV* PL_modglobal +=for hackers +Found in file intrpvar.h + =item PL_na A convenience variable which is typically used with C<SvPV> when one @@ -1032,6 +1477,9 @@ C<SvPV_nolen> macro. STRLEN PL_na +=for hackers +Found in file thrdvar.h + =item PL_sv_no This is the C<false> SV. See C<PL_sv_yes>. Always refer to this as @@ -1039,12 +1487,18 @@ C<&PL_sv_no>. SV PL_sv_no +=for hackers +Found in file intrpvar.h + =item PL_sv_undef This is the C<undef> SV. Always refer to this as C<&PL_sv_undef>. SV PL_sv_undef +=for hackers +Found in file intrpvar.h + =item PL_sv_yes This is the C<true> SV. See C<PL_sv_no>. Always refer to this as @@ -1052,36 +1506,54 @@ C<&PL_sv_yes>. SV PL_sv_yes +=for hackers +Found in file intrpvar.h + =item POPi Pops an integer off the stack. IV POPi +=for hackers +Found in file pp.h + =item POPl Pops a long off the stack. long POPl +=for hackers +Found in file pp.h + =item POPn Pops a double off the stack. NV POPn +=for hackers +Found in file pp.h + =item POPp Pops a string off the stack. char* POPp +=for hackers +Found in file pp.h + =item POPs Pops an SV off the stack. SV* POPs +=for hackers +Found in file pp.h + =item PUSHi Push an integer onto the stack. The stack must have room for this element. @@ -1089,6 +1561,9 @@ Handles 'set' magic. See C<XPUSHi>. void PUSHi(IV iv) +=for hackers +Found in file pp.h + =item PUSHMARK Opening bracket for arguments on a callback. See C<PUTBACK> and @@ -1096,6 +1571,9 @@ L<perlcall>. PUSHMARK; +=for hackers +Found in file pp.h + =item PUSHn Push a double onto the stack. The stack must have room for this element. @@ -1103,6 +1581,9 @@ Handles 'set' magic. See C<XPUSHn>. void PUSHn(NV nv) +=for hackers +Found in file pp.h + =item PUSHp Push a string onto the stack. The stack must have room for this element. @@ -1111,13 +1592,19 @@ C<XPUSHp>. void PUSHp(char* str, STRLEN len) +=for hackers +Found in file pp.h + =item PUSHs -Push an SV onto the stack. The stack must have room for this element. +Push an SV onto the stack. The stack must have room for this element. Does not handle 'set' magic. See C<XPUSHs>. void PUSHs(SV* sv) +=for hackers +Found in file pp.h + =item PUSHu Push an unsigned integer onto the stack. The stack must have room for this @@ -1125,6 +1612,9 @@ element. See C<XPUSHu>. void PUSHu(UV uv) +=for hackers +Found in file pp.h + =item PUTBACK Closing bracket for XSUB arguments. This is usually handled by C<xsubpp>. @@ -1132,12 +1622,18 @@ See C<PUSHMARK> and L<perlcall> for other uses. PUTBACK; +=for hackers +Found in file pp.h + =item Renew The XSUB-writer's interface to the C C<realloc> function. void Renew(void* ptr, int nitems, type) +=for hackers +Found in file handy.h + =item Renewc The XSUB-writer's interface to the C C<realloc> function, with @@ -1145,6 +1641,9 @@ cast. void Renewc(void* ptr, int nitems, type, cast) +=for hackers +Found in file handy.h + =item require_pv Tells Perl to C<require> a module. @@ -1153,6 +1652,9 @@ NOTE: the perl_ form of this function is deprecated. void require_pv(const char* pv) +=for hackers +Found in file perl.c + =item RETVAL Variable which is setup by C<xsubpp> to hold the return value for an @@ -1161,11 +1663,17 @@ L<perlxs/"The RETVAL Variable">. (whatever) RETVAL +=for hackers +Found in file XSUB.h + =item Safefree The XSUB-writer's interface to the C C<free> function. - void Safefree(void* src, void* dest, int nitems, type) + void Safefree(void* ptr) + +=for hackers +Found in file handy.h =item savepv @@ -1173,6 +1681,9 @@ Copy a string to a safe spot. This does not use an SV. char* savepv(const char* sv) +=for hackers +Found in file util.c + =item savepvn Copy a string to a safe spot. The C<len> indicates number of bytes to @@ -1180,6 +1691,9 @@ copy. This does not use an SV. char* savepvn(const char* sv, I32 len) +=for hackers +Found in file util.c + =item SAVETMPS Opening bracket for temporaries on a callback. See C<FREETMPS> and @@ -1187,29 +1701,44 @@ L<perlcall>. SAVETMPS; +=for hackers +Found in file scope.h + =item SP Stack pointer. This is usually handled by C<xsubpp>. See C<dSP> and C<SPAGAIN>. +=for hackers +Found in file pp.h + =item SPAGAIN Refetch the stack pointer. Used after a callback. See L<perlcall>. SPAGAIN; +=for hackers +Found in file pp.h + =item ST Used to access elements on the XSUB's stack. SV* ST(int ix) +=for hackers +Found in file XSUB.h + =item strEQ Test two strings to see if they are equal. Returns true or false. bool strEQ(char* s1, char* s2) +=for hackers +Found in file handy.h + =item strGE Test two strings to see if the first, C<s1>, is greater than or equal to @@ -1217,6 +1746,9 @@ the second, C<s2>. Returns true or false. bool strGE(char* s1, char* s2) +=for hackers +Found in file handy.h + =item strGT Test two strings to see if the first, C<s1>, is greater than the second, @@ -1224,6 +1756,9 @@ C<s2>. Returns true or false. bool strGT(char* s1, char* s2) +=for hackers +Found in file handy.h + =item strLE Test two strings to see if the first, C<s1>, is less than or equal to the @@ -1231,6 +1766,9 @@ second, C<s2>. Returns true or false. bool strLE(char* s1, char* s2) +=for hackers +Found in file handy.h + =item strLT Test two strings to see if the first, C<s1>, is less than the second, @@ -1238,6 +1776,9 @@ C<s2>. Returns true or false. bool strLT(char* s1, char* s2) +=for hackers +Found in file handy.h + =item strNE Test two strings to see if they are different. Returns true or @@ -1245,6 +1786,9 @@ false. bool strNE(char* s1, char* s2) +=for hackers +Found in file handy.h + =item strnEQ Test two strings to see if they are equal. The C<len> parameter indicates @@ -1253,6 +1797,9 @@ C<strncmp>). bool strnEQ(char* s1, char* s2, STRLEN len) +=for hackers +Found in file handy.h + =item strnNE Test two strings to see if they are different. The C<len> parameter @@ -1261,24 +1808,36 @@ wrapper for C<strncmp>). bool strnNE(char* s1, char* s2, STRLEN len) +=for hackers +Found in file handy.h + =item StructCopy -This is an architecture-independant macro to copy one structure to another. +This is an architecture-independent macro to copy one structure to another. void StructCopy(type src, type dest, type) +=for hackers +Found in file handy.h + =item SvCUR Returns the length of the string which is in the SV. See C<SvLEN>. STRLEN SvCUR(SV* sv) +=for hackers +Found in file sv.h + =item SvCUR_set Set the length of the string which is in the SV. See C<SvCUR>. void SvCUR_set(SV* sv, STRLEN len) +=for hackers +Found in file sv.h + =item SvEND Returns a pointer to the last character in the string which is in the SV. @@ -1286,6 +1845,9 @@ See C<SvCUR>. Access the character as *(SvEND(sv)). char* SvEND(SV* sv) +=for hackers +Found in file sv.h + =item SvGETMAGIC Invokes C<mg_get> on an SV if it has 'get' magic. This macro evaluates its @@ -1293,6 +1855,9 @@ argument more than once. void SvGETMAGIC(SV* sv) +=for hackers +Found in file sv.h + =item SvGROW Expands the character buffer in the SV so that it has room for the @@ -1302,12 +1867,18 @@ Returns a pointer to the character buffer. void SvGROW(SV* sv, STRLEN len) +=for hackers +Found in file sv.h + =item SvIOK Returns a boolean indicating whether the SV contains an integer. bool SvIOK(SV* sv) +=for hackers +Found in file sv.h + =item SvIOKp Returns a boolean indicating whether the SV contains an integer. Checks @@ -1315,30 +1886,72 @@ the B<private> setting. Use C<SvIOK>. bool SvIOKp(SV* sv) +=for hackers +Found in file sv.h + +=item SvIOK_notUV + +Returns a boolean indicating whether the SV contains an signed integer. + + void SvIOK_notUV(SV* sv) + +=for hackers +Found in file sv.h + =item SvIOK_off Unsets the IV status of an SV. void SvIOK_off(SV* sv) +=for hackers +Found in file sv.h + =item SvIOK_on Tells an SV that it is an integer. void SvIOK_on(SV* sv) +=for hackers +Found in file sv.h + =item SvIOK_only Tells an SV that it is an integer and disables all other OK bits. void SvIOK_only(SV* sv) +=for hackers +Found in file sv.h + +=item SvIOK_only_UV + +Tells and SV that it is an unsigned integer and disables all other OK bits. + + void SvIOK_only_UV(SV* sv) + +=for hackers +Found in file sv.h + +=item SvIOK_UV + +Returns a boolean indicating whether the SV contains an unsigned integer. + + void SvIOK_UV(SV* sv) + +=for hackers +Found in file sv.h + =item SvIV Coerces the given SV to an integer and returns it. IV SvIV(SV* sv) +=for hackers +Found in file sv.h + =item SvIVX Returns the integer which is stored in the SV, assuming SvIOK is @@ -1346,12 +1959,19 @@ true. IV SvIVX(SV* sv) +=for hackers +Found in file sv.h + =item SvLEN -Returns the size of the string buffer in the SV. See C<SvCUR>. +Returns the size of the string buffer in the SV, not including any part +attributable to C<SvOOK>. See C<SvCUR>. STRLEN SvLEN(SV* sv) +=for hackers +Found in file sv.h + =item SvNIOK Returns a boolean indicating whether the SV contains a number, integer or @@ -1359,6 +1979,9 @@ double. bool SvNIOK(SV* sv) +=for hackers +Found in file sv.h + =item SvNIOKp Returns a boolean indicating whether the SV contains a number, integer or @@ -1366,18 +1989,27 @@ double. Checks the B<private> setting. Use C<SvNIOK>. bool SvNIOKp(SV* sv) +=for hackers +Found in file sv.h + =item SvNIOK_off Unsets the NV/IV status of an SV. void SvNIOK_off(SV* sv) +=for hackers +Found in file sv.h + =item SvNOK Returns a boolean indicating whether the SV contains a double. bool SvNOK(SV* sv) +=for hackers +Found in file sv.h + =item SvNOKp Returns a boolean indicating whether the SV contains a double. Checks the @@ -1385,30 +2017,45 @@ B<private> setting. Use C<SvNOK>. bool SvNOKp(SV* sv) +=for hackers +Found in file sv.h + =item SvNOK_off Unsets the NV status of an SV. void SvNOK_off(SV* sv) +=for hackers +Found in file sv.h + =item SvNOK_on Tells an SV that it is a double. void SvNOK_on(SV* sv) +=for hackers +Found in file sv.h + =item SvNOK_only Tells an SV that it is a double and disables all other OK bits. void SvNOK_only(SV* sv) +=for hackers +Found in file sv.h + =item SvNV Coerce the given SV to a double and return it. NV SvNV(SV* sv) +=for hackers +Found in file sv.h + =item SvNVX Returns the double which is stored in the SV, assuming SvNOK is @@ -1416,12 +2063,18 @@ true. NV SvNVX(SV* sv) +=for hackers +Found in file sv.h + =item SvOK Returns a boolean indicating whether the value is an SV. bool SvOK(SV* sv) +=for hackers +Found in file sv.h + =item SvOOK Returns a boolean indicating whether the SvIVX is a valid offset value for @@ -1431,6 +2084,9 @@ allocated string buffer is really (SvPVX - SvIVX). bool SvOOK(SV* sv) +=for hackers +Found in file sv.h + =item SvPOK Returns a boolean indicating whether the SV contains a character @@ -1438,6 +2094,9 @@ string. bool SvPOK(SV* sv) +=for hackers +Found in file sv.h + =item SvPOKp Returns a boolean indicating whether the SV contains a character string. @@ -1445,24 +2104,46 @@ Checks the B<private> setting. Use C<SvPOK>. bool SvPOKp(SV* sv) +=for hackers +Found in file sv.h + =item SvPOK_off Unsets the PV status of an SV. void SvPOK_off(SV* sv) +=for hackers +Found in file sv.h + =item SvPOK_on Tells an SV that it is a string. void SvPOK_on(SV* sv) +=for hackers +Found in file sv.h + =item SvPOK_only Tells an SV that it is a string and disables all other OK bits. void SvPOK_only(SV* sv) +=for hackers +Found in file sv.h + +=item SvPOK_only_UTF8 + +Tells an SV that it is a UTF8 string (do not use frivolously) +and disables all other OK bits. + + void SvPOK_only_UTF8(SV* sv) + +=for hackers +Found in file sv.h + =item SvPV Returns a pointer to the string in the SV, or a stringified form of the SV @@ -1470,6 +2151,9 @@ if the SV does not contain a string. Handles 'get' magic. char* SvPV(SV* sv, STRLEN len) +=for hackers +Found in file sv.h + =item SvPVX Returns a pointer to the string in the SV. The SV must contain a @@ -1477,6 +2161,9 @@ string. char* SvPVX(SV* sv) +=for hackers +Found in file sv.h + =item SvPV_force Like <SvPV> but will force the SV into becoming a string (SvPOK). You want @@ -1484,6 +2171,9 @@ force if you are going to update the SvPVX directly. char* SvPV_force(SV* sv, STRLEN len) +=for hackers +Found in file sv.h + =item SvPV_nolen Returns a pointer to the string in the SV, or a stringified form of the SV @@ -1491,48 +2181,72 @@ if the SV does not contain a string. Handles 'get' magic. char* SvPV_nolen(SV* sv) +=for hackers +Found in file sv.h + =item SvREFCNT Returns the value of the object's reference count. U32 SvREFCNT(SV* sv) +=for hackers +Found in file sv.h + =item SvREFCNT_dec Decrements the reference count of the given SV. void SvREFCNT_dec(SV* sv) +=for hackers +Found in file sv.h + =item SvREFCNT_inc Increments the reference count of the given SV. SV* SvREFCNT_inc(SV* sv) +=for hackers +Found in file sv.h + =item SvROK Tests if the SV is an RV. bool SvROK(SV* sv) +=for hackers +Found in file sv.h + =item SvROK_off Unsets the RV status of an SV. void SvROK_off(SV* sv) +=for hackers +Found in file sv.h + =item SvROK_on Tells an SV that it is an RV. void SvROK_on(SV* sv) +=for hackers +Found in file sv.h + =item SvRV Dereferences an RV to return the SV. SV* SvRV(SV* sv) +=for hackers +Found in file sv.h + =item SvSETMAGIC Invokes C<mg_set> on an SV if it has 'set' magic. This macro evaluates its @@ -1540,6 +2254,9 @@ argument more than once. void SvSETMAGIC(SV* sv) +=for hackers +Found in file sv.h + =item SvSetSV Calls C<sv_setsv> if dsv is not the same as ssv. May evaluate arguments @@ -1547,6 +2264,9 @@ more than once. void SvSetSV(SV* dsb, SV* ssv) +=for hackers +Found in file sv.h + =item SvSetSV_nosteal Calls a non-destructive version of C<sv_setsv> if dsv is not the same as @@ -1554,18 +2274,27 @@ ssv. May evaluate arguments more than once. void SvSetSV_nosteal(SV* dsv, SV* ssv) +=for hackers +Found in file sv.h + =item SvSTASH Returns the stash of the SV. HV* SvSTASH(SV* sv) +=for hackers +Found in file sv.h + =item SvTAINT Taints an SV if tainting is enabled void SvTAINT(SV* sv) +=for hackers +Found in file sv.h + =item SvTAINTED Checks to see if an SV is tainted. Returns TRUE if it is, FALSE if @@ -1573,6 +2302,9 @@ not. bool SvTAINTED(SV* sv) +=for hackers +Found in file sv.h + =item SvTAINTED_off Untaints an SV. Be I<very> careful with this routine, as it short-circuits @@ -1584,12 +2316,18 @@ untainting variables. void SvTAINTED_off(SV* sv) +=for hackers +Found in file sv.h + =item SvTAINTED_on Marks an SV as tainted. void SvTAINTED_on(SV* sv) +=for hackers +Found in file sv.h + =item SvTRUE Returns a boolean indicating whether Perl would evaluate the SV as true or @@ -1597,45 +2335,75 @@ false, defined or undefined. Does not handle 'get' magic. bool SvTRUE(SV* sv) +=for hackers +Found in file sv.h + +=item svtype + +An enum of flags for Perl types. These are found in the file B<sv.h> +in the C<svtype> enum. Test these flags with the C<SvTYPE> macro. + +=for hackers +Found in file sv.h + =item SvTYPE Returns the type of the SV. See C<svtype>. svtype SvTYPE(SV* sv) -=item svtype - -An enum of flags for Perl types. These are found in the file B<sv.h> -in the C<svtype> enum. Test these flags with the C<SvTYPE> macro. +=for hackers +Found in file sv.h =item SVt_IV Integer type flag for scalars. See C<svtype>. +=for hackers +Found in file sv.h + =item SVt_NV Double type flag for scalars. See C<svtype>. +=for hackers +Found in file sv.h + =item SVt_PV Pointer type flag for scalars. See C<svtype>. +=for hackers +Found in file sv.h + =item SVt_PVAV Type flag for arrays. See C<svtype>. +=for hackers +Found in file sv.h + =item SVt_PVCV Type flag for code refs. See C<svtype>. +=for hackers +Found in file sv.h + =item SVt_PVHV Type flag for hashes. See C<svtype>. +=for hackers +Found in file sv.h + =item SVt_PVMG Type flag for blessed scalars. See C<svtype>. +=for hackers +Found in file sv.h + =item SvUPGRADE Used to upgrade an SV to a more complex form. Uses C<sv_upgrade> to @@ -1643,12 +2411,45 @@ perform the upgrade if necessary. See C<svtype>. void SvUPGRADE(SV* sv, svtype type) +=for hackers +Found in file sv.h + +=item SvUTF8 + +Returns a boolean indicating whether the SV contains UTF-8 encoded data. + + void SvUTF8(SV* sv) + +=for hackers +Found in file sv.h + +=item SvUTF8_off + +Unsets the UTF8 status of an SV. + + void SvUTF8_off(SV *sv) + +=for hackers +Found in file sv.h + +=item SvUTF8_on + +Tells an SV that it is a string and encoded in UTF8. Do not use frivolously. + + void SvUTF8_on(SV *sv) + +=for hackers +Found in file sv.h + =item SvUV Coerces the given SV to an unsigned integer and returns it. UV SvUV(SV* sv) +=for hackers +Found in file sv.h + =item SvUVX Returns the unsigned integer which is stored in the SV, assuming SvIOK is @@ -1656,6 +2457,9 @@ true. UV SvUVX(SV* sv) +=for hackers +Found in file sv.h + =item sv_2mortal Marks an SV as mortal. The SV will be destroyed when the current context @@ -1663,6 +2467,9 @@ ends. SV* sv_2mortal(SV* sv) +=for hackers +Found in file sv.c + =item sv_bless Blesses an SV into a specified package. The SV must be an RV. The package @@ -1671,6 +2478,9 @@ of the SV is unaffected. SV* sv_bless(SV* sv, HV* stash) +=for hackers +Found in file sv.c + =item sv_catpv Concatenates the string onto the end of the string which is in the SV. @@ -1678,6 +2488,9 @@ Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>. void sv_catpv(SV* sv, const char* ptr) +=for hackers +Found in file sv.c + =item sv_catpvf Processes its arguments like C<sprintf> and appends the formatted output @@ -1686,12 +2499,18 @@ typically be called after calling this function to handle 'set' magic. void sv_catpvf(SV* sv, const char* pat, ...) +=for hackers +Found in file sv.c + =item sv_catpvf_mg Like C<sv_catpvf>, but also handles 'set' magic. void sv_catpvf_mg(SV *sv, const char* pat, ...) +=for hackers +Found in file sv.c + =item sv_catpvn Concatenates the string onto the end of the string which is in the SV. The @@ -1700,31 +2519,47 @@ C<len> indicates number of bytes to copy. Handles 'get' magic, but not void sv_catpvn(SV* sv, const char* ptr, STRLEN len) +=for hackers +Found in file sv.c + =item sv_catpvn_mg Like C<sv_catpvn>, but also handles 'set' magic. void sv_catpvn_mg(SV *sv, const char *ptr, STRLEN len) +=for hackers +Found in file sv.c + =item sv_catpv_mg Like C<sv_catpv>, but also handles 'set' magic. void sv_catpv_mg(SV *sv, const char *ptr) +=for hackers +Found in file sv.c + =item sv_catsv -Concatenates the string from SV C<ssv> onto the end of the string in SV -C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>. +Concatenates the string from SV C<ssv> onto the end of the string in +SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but +not 'set' magic. See C<sv_catsv_mg>. void sv_catsv(SV* dsv, SV* ssv) +=for hackers +Found in file sv.c + =item sv_catsv_mg Like C<sv_catsv>, but also handles 'set' magic. void sv_catsv_mg(SV *dstr, SV *sstr) +=for hackers +Found in file sv.c + =item sv_chop Efficient removal of characters from the beginning of the string buffer. @@ -1734,6 +2569,19 @@ string. void sv_chop(SV* sv, char* ptr) +=for hackers +Found in file sv.c + +=item sv_clear + +Clear an SV, making it empty. Does not free the memory used by the SV +itself. + + void sv_clear(SV* sv) + +=for hackers +Found in file sv.c + =item sv_cmp Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the @@ -1742,12 +2590,28 @@ C<sv2>. I32 sv_cmp(SV* sv1, SV* sv2) +=for hackers +Found in file sv.c + +=item sv_cmp_locale + +Compares the strings in two SVs in a locale-aware manner. See +L</sv_cmp_locale> + + I32 sv_cmp_locale(SV* sv1, SV* sv2) + +=for hackers +Found in file sv.c + =item sv_dec Auto-decrement of the value in the SV. void sv_dec(SV* sv) +=for hackers +Found in file sv.c + =item sv_derived_from Returns a boolean indicating whether the SV is derived from the specified @@ -1756,6 +2620,9 @@ for class names as well as for objects. bool sv_derived_from(SV* sv, const char* name) +=for hackers +Found in file universal.c + =item sv_eq Returns a boolean indicating whether the strings in the two SVs are @@ -1763,6 +2630,28 @@ identical. I32 sv_eq(SV* sv1, SV* sv2) +=for hackers +Found in file sv.c + +=item sv_free + +Free the memory used by an SV. + + void sv_free(SV* sv) + +=for hackers +Found in file sv.c + +=item sv_gets + +Get a line from the filehandle and store it into the SV, optionally +appending to the currently-stored string. + + char* sv_gets(SV* sv, PerlIO* fp, I32 append) + +=for hackers +Found in file sv.c + =item sv_grow Expands the character buffer in the SV. This will use C<sv_unref> and will @@ -1771,12 +2660,18 @@ Use C<SvGROW>. char* sv_grow(SV* sv, STRLEN newlen) +=for hackers +Found in file sv.c + =item sv_inc Auto-increment of the value in the SV. void sv_inc(SV* sv) +=for hackers +Found in file sv.c + =item sv_insert Inserts a string at the specified offset/length within the SV. Similar to @@ -1784,6 +2679,9 @@ the Perl substr() function. void sv_insert(SV* bigsv, STRLEN offset, STRLEN len, char* little, STRLEN littlelen) +=for hackers +Found in file sv.c + =item sv_isa Returns a boolean indicating whether the SV is blessed into the specified @@ -1792,6 +2690,9 @@ an inheritance relationship. int sv_isa(SV* sv, const char* name) +=for hackers +Found in file sv.c + =item sv_isobject Returns a boolean indicating whether the SV is an RV pointing to a blessed @@ -1800,18 +2701,37 @@ will return false. int sv_isobject(SV* sv) +=for hackers +Found in file sv.c + =item sv_len Returns the length of the string in the SV. See also C<SvCUR>. STRLEN sv_len(SV* sv) +=for hackers +Found in file sv.c + +=item sv_len_utf8 + +Returns the number of characters in the string in an SV, counting wide +UTF8 bytes as a single character. + + STRLEN sv_len_utf8(SV* sv) + +=for hackers +Found in file sv.c + =item sv_magic Adds magic to an SV. void sv_magic(SV* sv, SV* obj, int how, const char* name, I32 namlen) +=for hackers +Found in file sv.c + =item sv_mortalcopy Creates a new SV which is a copy of the original SV. The new SV is marked @@ -1819,12 +2739,64 @@ as mortal. SV* sv_mortalcopy(SV* oldsv) +=for hackers +Found in file sv.c + =item sv_newmortal Creates a new SV which is mortal. The reference count of the SV is set to 1. SV* sv_newmortal() +=for hackers +Found in file sv.c + +=item sv_pvn_force + +Get a sensible string out of the SV somehow. + + char* sv_pvn_force(SV* sv, STRLEN* lp) + +=for hackers +Found in file sv.c + +=item sv_pvutf8n_force + +Get a sensible UTF8-encoded string out of the SV somehow. See +L</sv_pvn_force>. + + char* sv_pvutf8n_force(SV* sv, STRLEN* lp) + +=for hackers +Found in file sv.c + +=item sv_reftype + +Returns a string describing what the SV is a reference to. + + char* sv_reftype(SV* sv, int ob) + +=for hackers +Found in file sv.c + +=item sv_replace + +Make the first argument a copy of the second, then delete the original. + + void sv_replace(SV* sv, SV* nsv) + +=for hackers +Found in file sv.c + +=item sv_rvweaken + +Weaken a reference. + + SV* sv_rvweaken(SV *sv) + +=for hackers +Found in file sv.c + =item sv_setiv Copies an integer into the given SV. Does not handle 'set' magic. See @@ -1832,12 +2804,18 @@ C<sv_setiv_mg>. void sv_setiv(SV* sv, IV num) +=for hackers +Found in file sv.c + =item sv_setiv_mg Like C<sv_setiv>, but also handles 'set' magic. void sv_setiv_mg(SV *sv, IV i) +=for hackers +Found in file sv.c + =item sv_setnv Copies a double into the given SV. Does not handle 'set' magic. See @@ -1845,12 +2823,18 @@ C<sv_setnv_mg>. void sv_setnv(SV* sv, NV num) +=for hackers +Found in file sv.c + =item sv_setnv_mg Like C<sv_setnv>, but also handles 'set' magic. void sv_setnv_mg(SV *sv, NV num) +=for hackers +Found in file sv.c + =item sv_setpv Copies a string into an SV. The string must be null-terminated. Does not @@ -1858,6 +2842,9 @@ handle 'set' magic. See C<sv_setpv_mg>. void sv_setpv(SV* sv, const char* ptr) +=for hackers +Found in file sv.c + =item sv_setpvf Processes its arguments like C<sprintf> and sets an SV to the formatted @@ -1865,12 +2852,18 @@ output. Does not handle 'set' magic. See C<sv_setpvf_mg>. void sv_setpvf(SV* sv, const char* pat, ...) +=for hackers +Found in file sv.c + =item sv_setpvf_mg Like C<sv_setpvf>, but also handles 'set' magic. void sv_setpvf_mg(SV *sv, const char* pat, ...) +=for hackers +Found in file sv.c + =item sv_setpviv Copies an integer into the given SV, also updating its string value. @@ -1878,12 +2871,18 @@ Does not handle 'set' magic. See C<sv_setpviv_mg>. void sv_setpviv(SV* sv, IV num) +=for hackers +Found in file sv.c + =item sv_setpviv_mg Like C<sv_setpviv>, but also handles 'set' magic. void sv_setpviv_mg(SV *sv, IV iv) +=for hackers +Found in file sv.c + =item sv_setpvn Copies a string into an SV. The C<len> parameter indicates the number of @@ -1891,18 +2890,27 @@ bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>. void sv_setpvn(SV* sv, const char* ptr, STRLEN len) +=for hackers +Found in file sv.c + =item sv_setpvn_mg Like C<sv_setpvn>, but also handles 'set' magic. void sv_setpvn_mg(SV *sv, const char *ptr, STRLEN len) +=for hackers +Found in file sv.c + =item sv_setpv_mg Like C<sv_setpv>, but also handles 'set' magic. void sv_setpv_mg(SV *sv, const char *ptr) +=for hackers +Found in file sv.c + =item sv_setref_iv Copies an integer into a new SV, optionally blessing the SV. The C<rv> @@ -1913,6 +2921,9 @@ will be returned and will have a reference count of 1. SV* sv_setref_iv(SV* rv, const char* classname, IV iv) +=for hackers +Found in file sv.c + =item sv_setref_nv Copies a double into a new SV, optionally blessing the SV. The C<rv> @@ -1923,6 +2934,9 @@ will be returned and will have a reference count of 1. SV* sv_setref_nv(SV* rv, const char* classname, NV nv) +=for hackers +Found in file sv.c + =item sv_setref_pv Copies a pointer into a new SV, optionally blessing the SV. The C<rv> @@ -1939,6 +2953,9 @@ Note that C<sv_setref_pvn> copies the string while this copies the pointer. SV* sv_setref_pv(SV* rv, const char* classname, void* pv) +=for hackers +Found in file sv.c + =item sv_setref_pvn Copies a string into a new SV, optionally blessing the SV. The length of the @@ -1952,6 +2969,9 @@ Note that C<sv_setref_pv> copies the pointer while this copies the string. SV* sv_setref_pvn(SV* rv, const char* classname, char* pv, STRLEN n) +=for hackers +Found in file sv.c + =item sv_setsv Copies the contents of the source SV C<ssv> into the destination SV C<dsv>. @@ -1961,12 +2981,18 @@ C<sv_setsv_mg>. void sv_setsv(SV* dsv, SV* ssv) +=for hackers +Found in file sv.c + =item sv_setsv_mg Like C<sv_setsv>, but also handles 'set' magic. void sv_setsv_mg(SV *dstr, SV *sstr) +=for hackers +Found in file sv.c + =item sv_setuv Copies an unsigned integer into the given SV. Does not handle 'set' magic. @@ -1974,12 +3000,36 @@ See C<sv_setuv_mg>. void sv_setuv(SV* sv, UV num) +=for hackers +Found in file sv.c + =item sv_setuv_mg Like C<sv_setuv>, but also handles 'set' magic. void sv_setuv_mg(SV *sv, UV u) +=for hackers +Found in file sv.c + +=item sv_true + +Returns true if the SV has a true value by Perl's rules. + + I32 sv_true(SV *sv) + +=for hackers +Found in file sv.c + +=item sv_unmagic + +Removes magic from an SV. + + int sv_unmagic(SV* sv, int type) + +=for hackers +Found in file sv.c + =item sv_unref Unsets the RV status of the SV, and decrements the reference count of @@ -1988,6 +3038,9 @@ as a reversal of C<newSVrv>. See C<SvROK_off>. void sv_unref(SV* sv) +=for hackers +Found in file sv.c + =item sv_upgrade Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See @@ -1995,6 +3048,9 @@ C<svtype>. bool sv_upgrade(SV* sv, U32 mt) +=for hackers +Found in file sv.c + =item sv_usepvn Tells an SV to use C<ptr> to find its string value. Normally the string is @@ -2007,12 +3063,58 @@ See C<sv_usepvn_mg>. void sv_usepvn(SV* sv, char* ptr, STRLEN len) +=for hackers +Found in file sv.c + =item sv_usepvn_mg Like C<sv_usepvn>, but also handles 'set' magic. void sv_usepvn_mg(SV *sv, char *ptr, STRLEN len) +=for hackers +Found in file sv.c + +=item sv_utf8_downgrade + +Attempt to convert the PV of an SV from UTF8-encoded to byte encoding. +This may not be possible if the PV contains non-byte encoding characters; +if this is the case, either returns false or, if C<fail_ok> is not +true, croaks. + +NOTE: this function is experimental and may change or be +removed without notice. + + bool sv_utf8_downgrade(SV *sv, bool fail_ok) + +=for hackers +Found in file sv.c + +=item sv_utf8_encode + +Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8> +flag so that it looks like bytes again. Nothing calls this. + +NOTE: this function is experimental and may change or be +removed without notice. + + void sv_utf8_encode(SV *sv) + +=for hackers +Found in file sv.c + +=item sv_utf8_upgrade + +Convert the PV of an SV to its UTF8-encoded form. + +NOTE: this function is experimental and may change or be +removed without notice. + + void sv_utf8_upgrade(SV *sv) + +=for hackers +Found in file sv.c + =item sv_vcatpvfn Processes its arguments like C<vsprintf> and appends the formatted output @@ -2023,6 +3125,9 @@ locales). void sv_vcatpvfn(SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted) +=for hackers +Found in file sv.c + =item sv_vsetpvfn Works like C<vcatpvfn> but copies the text into the SV instead of @@ -2030,6 +3135,9 @@ appending it. void sv_vsetpvfn(SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted) +=for hackers +Found in file sv.c + =item THIS Variable which is setup by C<xsubpp> to designate the object in a C++ @@ -2038,18 +3146,152 @@ L<perlxs/"Using XS With C++">. (whatever) THIS +=for hackers +Found in file XSUB.h + =item toLOWER Converts the specified character to lowercase. char toLOWER(char ch) +=for hackers +Found in file handy.h + =item toUPPER Converts the specified character to uppercase. char toUPPER(char ch) +=for hackers +Found in file handy.h + +=item utf8_distance + +Returns the number of UTF8 characters between the UTF-8 pointers C<a> +and C<b>. + +WARNING: use only if you *know* that the pointers point inside the +same UTF-8 buffer. + +NOTE: this function is experimental and may change or be +removed without notice. + + IV utf8_distance(U8 *a, U8 *b) + +=for hackers +Found in file utf8.c + +=item utf8_hop + +Return the UTF-8 pointer C<s> displaced by C<off> characters, either +forward or backward. + +WARNING: do not use the following unless you *know* C<off> is within +the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned +on the first byte of character or just after the last byte of a character. + +NOTE: this function is experimental and may change or be +removed without notice. + + 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<s> in characters. +Stops at C<e> (inclusive). If C<e E<lt> s> or if the scan would end +up past C<e>, croaks. + +NOTE: this function is experimental and may change or be +removed without notice. + + STRLEN utf8_length(U8* s, U8 *e) + +=for hackers +Found in file utf8.c + +=item utf8_to_bytes + +Converts a string C<s> of length C<len> from UTF8 into byte encoding. +Unlike C<bytes_to_utf8>, this over-writes the original string, and +updates len to contain the new length. +Returns zero on failure, setting C<len> to -1. + +NOTE: this function is experimental and may change or be +removed without notice. + + U8* utf8_to_bytes(U8 *s, STRLEN *len) + +=for hackers +Found in file utf8.c + +=item utf8_to_uv + +Returns the character value of the first character in the string C<s> +which is assumed to be in UTF8 encoding and no longer than C<curlen>; +C<retlen> will be set to the length, in bytes, of that character. + +If C<s> does not point to a well-formed UTF8 character, the behaviour +is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY, +it is assumed that the caller will raise a warning, and this function +will silently just set C<retlen> to C<-1> and return zero. If the +C<flags> does not contain UTF8_CHECK_ONLY, warnings about +malformations will be given, C<retlen> will be set to the expected +length of the UTF-8 character in bytes, and zero will be returned. + +The C<flags> can also contain various flags to allow deviations from +the strict UTF-8 encoding (see F<utf8.h>). + +NOTE: this function is experimental and may change or be +removed without notice. + + UV utf8_to_uv(U8 *s, STRLEN curlen, STRLEN* retlen, U32 flags) + +=for hackers +Found in file utf8.c + +=item utf8_to_uv_simple + +Returns the character value of the first character in the string C<s> +which is assumed to be in UTF8 encoding; C<retlen> will be set to the +length, in bytes, of that character. + +If C<s> does not point to a well-formed UTF8 character, zero is +returned and retlen is set, if possible, to -1. + +NOTE: this function is experimental and may change or be +removed without notice. + + UV utf8_to_uv_simple(U8 *s, STRLEN* retlen) + +=for hackers +Found in file utf8.c + +=item uv_to_utf8 + +Adds the UTF8 representation of the Unicode codepoint C<uv> to the end +of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free +bytes available. The return value is the pointer to the byte after the +end of the new character. In other words, + + d = uv_to_utf8(d, uv); + +is the recommended Unicode-aware way of saying + + *(d++) = uv; + +NOTE: this function is experimental and may change or be +removed without notice. + + U8* uv_to_utf8(U8 *d, UV uv) + +=for hackers +Found in file utf8.c + =item warn This is the XSUB-writer's interface to Perl's C<warn> function. Use this @@ -2058,6 +3300,9 @@ C<croak>. void warn(const char* pat, ...) +=for hackers +Found in file util.c + =item XPUSHi Push an integer onto the stack, extending the stack if necessary. Handles @@ -2065,6 +3310,9 @@ Push an integer onto the stack, extending the stack if necessary. Handles void XPUSHi(IV iv) +=for hackers +Found in file pp.h + =item XPUSHn Push a double onto the stack, extending the stack if necessary. Handles @@ -2072,6 +3320,9 @@ Push a double onto the stack, extending the stack if necessary. Handles void XPUSHn(NV nv) +=for hackers +Found in file pp.h + =item XPUSHp Push a string onto the stack, extending the stack if necessary. The C<len> @@ -2080,6 +3331,9 @@ C<PUSHp>. void XPUSHp(char* str, STRLEN len) +=for hackers +Found in file pp.h + =item XPUSHs Push an SV onto the stack, extending the stack if necessary. Does not @@ -2087,18 +3341,27 @@ handle 'set' magic. See C<PUSHs>. void XPUSHs(SV* sv) +=for hackers +Found in file pp.h + =item XPUSHu -Push an unsigned integer onto the stack, extending the stack if necessary. +Push an unsigned integer onto the stack, extending the stack if necessary. See C<PUSHu>. void XPUSHu(UV uv) +=for hackers +Found in file pp.h + =item XS Macro to declare an XSUB and its C parameter list. This is handled by C<xsubpp>. +=for hackers +Found in file XSUB.h + =item XSRETURN Return from XSUB, indicating number of items on the stack. This is usually @@ -2106,48 +3369,72 @@ handled by C<xsubpp>. void XSRETURN(int nitems) +=for hackers +Found in file XSUB.h + =item XSRETURN_EMPTY Return an empty list from an XSUB immediately. XSRETURN_EMPTY; +=for hackers +Found in file XSUB.h + =item XSRETURN_IV Return an integer from an XSUB immediately. Uses C<XST_mIV>. void XSRETURN_IV(IV iv) +=for hackers +Found in file XSUB.h + =item XSRETURN_NO Return C<&PL_sv_no> from an XSUB immediately. Uses C<XST_mNO>. XSRETURN_NO; +=for hackers +Found in file XSUB.h + =item XSRETURN_NV Return an double from an XSUB immediately. Uses C<XST_mNV>. void XSRETURN_NV(NV nv) +=for hackers +Found in file XSUB.h + =item XSRETURN_PV Return a copy of a string from an XSUB immediately. Uses C<XST_mPV>. void XSRETURN_PV(char* str) +=for hackers +Found in file XSUB.h + =item XSRETURN_UNDEF Return C<&PL_sv_undef> from an XSUB immediately. Uses C<XST_mUNDEF>. XSRETURN_UNDEF; +=for hackers +Found in file XSUB.h + =item XSRETURN_YES Return C<&PL_sv_yes> from an XSUB immediately. Uses C<XST_mYES>. XSRETURN_YES; +=for hackers +Found in file XSUB.h + =item XST_mIV Place an integer into the specified position C<pos> on the stack. The @@ -2155,6 +3442,9 @@ value is stored in a new mortal SV. void XST_mIV(int pos, IV iv) +=for hackers +Found in file XSUB.h + =item XST_mNO Place C<&PL_sv_no> into the specified position C<pos> on the @@ -2162,6 +3452,9 @@ stack. void XST_mNO(int pos) +=for hackers +Found in file XSUB.h + =item XST_mNV Place a double into the specified position C<pos> on the stack. The value @@ -2169,6 +3462,9 @@ is stored in a new mortal SV. void XST_mNV(int pos, NV nv) +=for hackers +Found in file XSUB.h + =item XST_mPV Place a copy of a string into the specified position C<pos> on the stack. @@ -2176,6 +3472,9 @@ The value is stored in a new mortal SV. void XST_mPV(int pos, char* str) +=for hackers +Found in file XSUB.h + =item XST_mUNDEF Place C<&PL_sv_undef> into the specified position C<pos> on the @@ -2183,6 +3482,9 @@ stack. void XST_mUNDEF(int pos) +=for hackers +Found in file XSUB.h + =item XST_mYES Place C<&PL_sv_yes> into the specified position C<pos> on the @@ -2190,11 +3492,17 @@ stack. void XST_mYES(int pos) +=for hackers +Found in file XSUB.h + =item XS_VERSION The version identifier for an XS module. This is usually handled automatically by C<ExtUtils::MakeMaker>. See C<XS_VERSION_BOOTCHECK>. +=for hackers +Found in file XSUB.h + =item XS_VERSION_BOOTCHECK Macro to verify that a PM module's $VERSION variable matches the XS @@ -2203,6 +3511,9 @@ C<xsubpp>. See L<perlxs/"The VERSIONCHECK: Keyword">. XS_VERSION_BOOTCHECK; +=for hackers +Found in file XSUB.h + =item Zero The XSUB-writer's interface to the C C<memzero> function. The C<dest> is the @@ -2210,6 +3521,9 @@ destination, C<nitems> is the number of items, and C<type> is the type. void Zero(void* dest, int nitems, type) +=for hackers +Found in file handy.h + =back =head1 AUTHORS diff --git a/contrib/perl5/pod/perlbook.pod b/contrib/perl5/pod/perlbook.pod index 3a693ddd8e54..44f0233ee1e1 100644 --- a/contrib/perl5/pod/perlbook.pod +++ b/contrib/perl5/pod/perlbook.pod @@ -4,12 +4,13 @@ perlbook - Perl book information =head1 DESCRIPTION -The Camel Book, officially known as I<Programming Perl, Second Edition>, -by Larry Wall et al, is the definitive reference work covering nearly -all of Perl. You can order it and other Perl books from O'Reilly & -Associates, 1-800-998-9938. Local/overseas is +1 707 829 0515. If you -can locate an O'Reilly order form, you can also fax to +1 707 829 0104. -If you're web-connected, you can even mosey on over to http://www.ora.com/ +The Camel Book, officially known as I<Programming Perl, Third Edition, +July 2000>, by Larry Wall et al, ISBN 0-596-00027-8, is the definitive +reference work covering nearly all of Perl. You can order it and +other Perl books from O'Reilly & Associates, 1-800-998-9938. +Local/overseas is +1 707 829 0515. If you can locate an O'Reilly +order form, you can also fax to +1 707 829 0104. If you're +web-connected, you can even mosey on over to http://www.oreilly.com/ for an online order form. Other Perl books from various publishers and authors diff --git a/contrib/perl5/pod/perlboot.pod b/contrib/perl5/pod/perlboot.pod index b549f45e490d..3c18246f0ca4 100644 --- a/contrib/perl5/pod/perlboot.pod +++ b/contrib/perl5/pod/perlboot.pod @@ -790,9 +790,13 @@ Hopefully, this gets you started, though. For more information, see L<perlobj> (for all the gritty details about Perl objects, now that you've seen the basics), L<perltoot> (the -tutorial for those who already know objects), L<perlbot> (for some -more tricks), and books such as Damian Conway's excellent I<Object -Oriented Perl>. +tutorial for those who already know objects), L<perltootc> (dealing +with class data), L<perlbot> (for some more tricks), and books such as +Damian Conway's excellent I<Object Oriented Perl>. + +Some modules which might prove interesting are Class::Accessor, +Class::Class, Class::Contract, Class::Data::Inheritable, +Class::MethodMaker and Tie::SecureHash =head1 COPYRIGHT diff --git a/contrib/perl5/pod/perlcall.pod b/contrib/perl5/pod/perlcall.pod index 148b24b51bdd..40f1d65a7beb 100644 --- a/contrib/perl5/pod/perlcall.pod +++ b/contrib/perl5/pod/perlcall.pod @@ -201,8 +201,8 @@ As with G_SCALAR, this flag has 2 effects: =item 1. -It indicates to the subroutine being called that it is executing in an -array context (if it executes I<wantarray> the result will be true). +It indicates to the subroutine being called that it is executing in a +list context (if it executes I<wantarray> the result will be true). =item 2. @@ -355,7 +355,7 @@ use of this flag. As mentioned above, you can determine the context of the currently executing subroutine in Perl with I<wantarray>. The equivalent test can be made in C by using the C<GIMME_V> macro, which returns -C<G_ARRAY> if you have been called in an array context, C<G_SCALAR> if +C<G_ARRAY> if you have been called in a list context, C<G_SCALAR> if in a scalar context, or C<G_VOID> if in a void context (i.e. the return value will not be used). An older version of this macro is called C<GIMME>; in a void context it returns C<G_SCALAR> instead of @@ -589,12 +589,6 @@ local copy, I<not> the global copy. =item 4. -The only flag specified this time is G_DISCARD. Because we are passing 2 -parameters to the Perl subroutine this time, we have not specified -G_NOARGS. - -=item 5. - Next, we come to XPUSHs. This is where the parameters actually get pushed onto the stack. In this case we are pushing a string and an integer. @@ -602,7 +596,7 @@ integer. See L<perlguts/"XSUBs and the Argument Stack"> for details on how the XPUSH macros work. -=item 6. +=item 5. Because we created temporary values (by means of sv_2mortal() calls) we will have to tidy up the Perl stack and dispose of mortal SVs. @@ -632,10 +626,12 @@ to limit the scope of local variables. See the section I<Using Perl to dispose of temporaries> for details of an alternative to using these macros. -=item 7. +=item 6. -Finally, I<LeftString> can now be called via the I<call_pv> -function. +Finally, I<LeftString> can now be called via the I<call_pv> function. +The only flag specified this time is G_DISCARD. Because we are passing +2 parameters to the Perl subroutine this time, we have not specified +G_NOARGS. =back @@ -806,7 +802,7 @@ Notes =item 1. -We wanted array context, so G_ARRAY was used. +We wanted list context, so G_ARRAY was used. =item 2. diff --git a/contrib/perl5/pod/perlcompile.pod b/contrib/perl5/pod/perlcompile.pod index 697cb80d4096..282592e9fb16 100644 --- a/contrib/perl5/pod/perlcompile.pod +++ b/contrib/perl5/pod/perlcompile.pod @@ -183,9 +183,6 @@ one-liners: rename $was, $_ unless $was eq $_; } -(this is the I<rename> program that comes in the I<eg/> directory -of the Perl source distribution). - The decompiler has several options for the code it generates. For instance, you can set the size of each indent from 4 (as above) to 2 with: @@ -308,7 +305,7 @@ I<assemble> program that produces bytecode. This module is used by the B::CC back end. It walks "basic blocks". A basic block is a series of operations which is known to execute from -start to finish, with no possiblity of branching or halting. +start to finish, with no possibility of branching or halting. =item B::Bytecode @@ -369,12 +366,12 @@ can identify. See L</"The Lint Back End"> for details about usage. =item B::Showlex This module prints out the my() variables used in a function or a -file. To gt a list of the my() variables used in the subroutine +file. To get a list of the my() variables used in the subroutine mysub() defined in the file myperlprogram: $ perl -MO=Showlex,mysub myperlprogram -To gt a list of the my() variables used in the file myperlprogram: +To get a list of the my() variables used in the file myperlprogram: $ perl -MO=Showlex myperlprogram @@ -419,7 +416,7 @@ names. The optimized C backend outputs code for more modules than it should (e.g., DirHandle). It also has little hope of properly handling -C<goto LABEL> outside the running subroutine (C<goto &sub> is ok). +C<goto LABEL> outside the running subroutine (C<goto &sub> is okay). C<goto LABEL> currently does not work at all in this backend. It also creates a huge initialization function that gives C compilers headaches. Splitting the initialization function gives diff --git a/contrib/perl5/pod/perldata.pod b/contrib/perl5/pod/perldata.pod index ac444fa17c4f..315f716ed876 100644 --- a/contrib/perl5/pod/perldata.pod +++ b/contrib/perl5/pod/perldata.pod @@ -209,9 +209,9 @@ with a regular expression (as documented in L<perlre>). unless /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/; The length of an array is a scalar value. You may find the length -of array @days by evaluating C<$#days>, as in B<csh>. Technically -speaking, this isn't the length of the array; it's the subscript -of the last element, since there is ordinarily a 0th element. +of array @days by evaluating C<$#days>, as in B<csh>. However, this +isn't the length of the array; it's the subscript of the last element, +which is a different value since there is ordinarily a 0th element. Assigning to C<$#days> actually changes the length of the array. Shortening an array this way destroys intervening values. Lengthening an array that was previously shortened does not recover values @@ -259,7 +259,7 @@ of sixteen buckets has been touched, and presumably contains all 10,000 of your items. This isn't supposed to happen. You can preallocate space for a hash by assigning to the keys() function. -This rounds up the allocated bucked to the next power of two: +This rounds up the allocated buckets to the next power of two: keys(%users) = 1000; # allocate 1024 buckets @@ -303,7 +303,8 @@ price is $Z<>100." print "The price is $Price.\n"; # interpreted As in some shells, you can enclose the variable name in braces to -disambiguate it from following alphanumerics. You must also do +disambiguate it from following alphanumerics (and underscores). +You must also do this when interpolating a variable into a string to separate the variable name from a following double-colon or an apostrophe, since these would be otherwise treated as a package separator: @@ -412,20 +413,20 @@ string may be either an identifier (a word), or some quoted text. If quoted, the type of quotes you use determines the treatment of the text, just as in regular quoting. An unquoted identifier works like double quotes. There must be no space between the C<< << >> and -the identifier. (If you put a space it will be treated as a null -identifier, which is valid, and matches the first empty line.) The -terminating string must appear by itself (unquoted and with no -surrounding whitespace) on the terminating line. +the identifier, unless the identifier is quoted. (If you put a space it +will be treated as a null identifier, which is valid, and matches the first +empty line.) The terminating string must appear by itself (unquoted and +with no surrounding whitespace) on the terminating line. print <<EOF; The price is $Price. EOF - print <<"EOF"; # same as above + print << "EOF"; # same as above The price is $Price. EOF - print <<`EOC`; # execute commands + print << `EOC`; # execute commands echo hi there echo lo there EOC @@ -436,7 +437,7 @@ surrounding whitespace) on the terminating line. I said bar. bar - myfunc(<<"THIS", 23, <<'THAT'); + myfunc(<< "THIS", 23, <<'THAT'); Here's a line or two. THIS @@ -461,6 +462,39 @@ from each line manually: down from the door where it began. FINIS +If you use a here-doc within a delimited construct, such as in C<s///eg>, +the quoted material must come on the lines following the final delimiter. +So instead of + + s/this/<<E . 'that' + the other + E + . 'more '/eg; + +you have to write + + s/this/<<E . 'that' + . 'more '/eg; + the other + E + +If the terminating identifier is on the last line of the program, you +must be sure there is a newline after it; otherwise, Perl will give the +warning B<Can't find string terminator "END" anywhere before EOF...>. + +Additionally, the quoting rules for the identifier are not related to +Perl's quoting rules -- C<q()>, C<qq()>, and the like are not supported +in place of C<''> and C<"">, and the only interpolation is for backslashing +the quoting character: + + print << "abc\"def"; + testing... + abc"def + +Finally, quoted strings cannot span multiple lines. The general rule is +that the identifier must be a string literal. Stick with that, and you +should be safe. + =head2 List value constructors List values are denoted by separating individual values by commas @@ -523,6 +557,15 @@ has no effect. Thus ((),(),()) is equivalent to (). Similarly, interpolating an array with no elements is the same as if no array had been interpolated at that point. +This interpolation combines with the facts that the opening +and closing parentheses are optional (except necessary for +precedence) and lists may end with an optional comma to mean that +multiple commas within lists are legal syntax. The list C<1,,3> is a +concatenation of two lists, C<1,> and C<3>, the first of which ends +with that optional comma. C<1,,3> is C<(1,),(3)> is C<1,3> (And +similarly for C<1,,,3> is C<(1,),(,),3> is C<1,3> and so on.) Not that +we'd advise you to use this obfuscation. + A list value may also be subscripted like a normal array. You must put the list in parentheses to avoid ambiguity. For example: diff --git a/contrib/perl5/pod/perldbmfilter.pod b/contrib/perl5/pod/perldbmfilter.pod index 3350596aab83..8384999e6a78 100644 --- a/contrib/perl5/pod/perldbmfilter.pod +++ b/contrib/perl5/pod/perldbmfilter.pod @@ -124,7 +124,7 @@ Here is another real-life example. By default, whenever Perl writes to a DBM database it always writes the key and value as strings. So when you use this: - $hash{12345} = "soemthing" ; + $hash{12345} = "something" ; the key 12345 will get stored in the DBM database as the 5 byte string "12345". If you actually want the key to be stored in the DBM database diff --git a/contrib/perl5/pod/perldebguts.pod b/contrib/perl5/pod/perldebguts.pod index b74f3efb6bab..20cc5460fd44 100644 --- a/contrib/perl5/pod/perldebguts.pod +++ b/contrib/perl5/pod/perldebguts.pod @@ -13,17 +13,17 @@ intimate with Perl's guts to understand. Caveat lector. Perl has special debugging hooks at compile-time and run-time used to create debugging environments. These hooks are not to be confused -with the I<perl -Dxxx> command described in L<perlrun>, which are -usable only if a special Perl built per the instructions the +with the I<perl -Dxxx> command described in L<perlrun>, which is +usable only if a special Perl is built per the instructions in the F<INSTALL> podpage in the Perl source tree. For example, whenever you call Perl's built-in C<caller> function from the package DB, the arguments that the corresponding stack -frame was called with are copied to the the @DB::args array. The +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<perlvar/$^P>): -=over +=over 4 =item * @@ -32,20 +32,22 @@ Perl inserts the contents of C<$ENV{PERL5DB}> (or C<BEGIN {require =item * -The array C<@{"_<$filename"}> holds the lines of $filename for all -files compiled by Perl. The same for C<eval>ed strings that contain +Each array C<@{"_<$filename"}> holds the lines of $filename for a +file compiled by Perl. The same for C<eval>ed strings that contain subroutines, or which are currently being executed. The $filename for C<eval>ed strings looks like C<(eval 34)>. Code assertions -in regexes look like C<(re_eval 19)>. +in regexes look like C<(re_eval 19)>. + +Values in this array are magical in numeric context: they compare +equal to zero only if the line is not breakable. =item * -The hash C<%{"_<$filename"}> contains breakpoints and actions keyed +Each hash C<%{"_<$filename"}> contains breakpoints and actions keyed by line number. Individual entries (as opposed to the whole hash) are settable. Perl only cares about Boolean true here, although the values used by F<perl5db.pl> have the form -C<"$break_condition\0$action">. Values in this hash are magical -in numeric context: they are zeros if the line is not breakable. +C<"$break_condition\0$action">. The same holds for evaluated strings that contain subroutines, or which are currently being executed. The $filename for C<eval>ed strings @@ -53,7 +55,7 @@ looks like C<(eval 34)> or C<(re_eval 19)>. =item * -The scalar C<${"_<$filename"}> contains C<"_<$filename">. This is +Each scalar C<${"_<$filename"}> contains C<"_<$filename">. This is also the case for evaluated strings that contain subroutines, or which are currently being executed. The $filename for C<eval>ed strings looks like C<(eval 34)> or C<(re_eval 19)>. @@ -154,7 +156,7 @@ L<perldebug/"Options"> for description of options parsed by C<DB::parse_options(string)>. The function C<DB::dump_trace(skip[, count])> skips the specified number of frames and returns a list containing information about the calling frames (all of them, if -C<count> is missing). Each entry is reference to a a hash with +C<count> is missing). Each entry is reference to a hash with keys C<context> (either C<.>, C<$>, or C<@>), C<sub> (subroutine name, or info about C<eval>), C<args> (C<undef> or a reference to an array), C<file>, and C<line>. @@ -400,7 +402,7 @@ shorter than 7 chars. The fields of interest which may appear in the last line are -=over +=over 4 =item C<anchored> I<STRING> C<at> I<POS> @@ -630,7 +632,7 @@ Perl is a profligate wastrel when it comes to memory use. There is a saying that to estimate memory usage of Perl, assume a reasonable algorithm for memory allocation, multiply that estimate by 10, and while you still may miss the mark, at least you won't be quite so -astonished. This is not absolutely true, but may prvide a good +astonished. This is not absolutely true, but may provide a good grasp of what happens. Assume that an integer cannot take less than 20 bytes of memory, a @@ -639,7 +641,7 @@ than 32 bytes (all these examples assume 32-bit architectures, the result are quite a bit worse on 64-bit architectures). If a variable is accessed in two of three different ways (which require an integer, a float, or a string), the memory footprint may increase yet another -20 bytes. A sloppy malloc(3) implementation can make inflate these +20 bytes. A sloppy malloc(3) implementation can inflate these numbers dramatically. On the opposite end of the scale, a declaration like @@ -666,7 +668,7 @@ the top level of the Perl source tree. If your perl is using Perl's malloc() and was compiled with the necessary switches (this is the default), then it will print memory -usage statistics after compiling your code hwen C<< $ENV{PERL_DEBUG_MSTATS} +usage statistics after compiling your code when C<< $ENV{PERL_DEBUG_MSTATS} > 1 >>, and before termination of the program when C<< $ENV{PERL_DEBUG_MSTATS} >= 1 >>. The report format is similar to the following example: @@ -686,12 +688,12 @@ the following example: Total sbrk(): 215040/47:145. Odd ends: pad+heads+chain+tail: 0+2192+0+6144. It is possible to ask for such a statistic at arbitrary points in -your execution using the mstats() function out of the standard +your execution using the mstat() function out of the standard Devel::Peek module. Here is some explanation of that format: -=over +=over 4 =item C<buckets SMALLEST(APPROX)..GREATEST(APPROX)> @@ -720,7 +722,7 @@ of two--or possibly one page greater. In the second row, if present, the memory footprints of the buckets are between the memory footprints of two buckets "above". -For example, suppose under the pervious example, the memory footprints +For example, suppose under the previous example, the memory footprints were free: 8 16 32 64 128 256 512 1024 2048 4096 8192 @@ -804,7 +806,7 @@ To see this list, insert two C<warn('!...')> statements around the call: do 'lib/auto/POSIX/autosplit.ix'; warn('!!! "after"'); -and run it with PErl's B<-DL> option. The first warn() will print +and run it with Perl's B<-DL> option. The first warn() will print memory allocation info before parsing the file and will memorize the statistics at this point (we ignore what it prints). The second warn() prints increments with respect to these memorized data. This @@ -838,11 +840,11 @@ per glob - for glob name, and glob stringification magic. Here are explanations for other I<Id>s above: -=over +=over 4 =item C<717> -CReates bigger C<XPV*> structures. In the case above, it +Creates bigger C<XPV*> structures. In the case above, it creates 3 C<AV>s per subroutine, one for a list of lexical variable names, one for a scratchpad (which contains lexical variables and C<targets>), and one for the array of scratchpads needed for @@ -892,7 +894,7 @@ these categories. If warn() string starts with -=over +=over 4 =item C<!!!> diff --git a/contrib/perl5/pod/perldebug.pod b/contrib/perl5/pod/perldebug.pod index c8ef60fa45ff..0aff91a558e0 100644 --- a/contrib/perl5/pod/perldebug.pod +++ b/contrib/perl5/pod/perldebug.pod @@ -82,7 +82,7 @@ recursively, unlike the real C<print> function in Perl. See L<Dumpvalue> 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<option> can be abbreviated, but for clarity probably should -not be. Several options can be set together. See L<"Options"> for -a list of these. +not be. Several options can be set together. See L<"Configurable Options"> +for a list of these. =item < ? @@ -342,7 +342,7 @@ missing, all actions are wiped out! Adds an action (Perl command) to happen after the prompt when you've just given a command to return to executing the script. A multi-line -command may be entered by slackbashing the newlines. +command may be entered by backslashing the newlines. =item { ? @@ -465,6 +465,8 @@ working example of something along the lines of: The debugger has numerous options settable using the C<O> command, either interactively or from the environment or an rc file. +(./.perldb or ~/.perldb under Unix.) + =over 12 @@ -600,9 +602,11 @@ include lexicals in a module's file scope, or lost in closures. =back -During startup, options are initialized from C<$ENV{PERLDB_OPTS}>. -You may place the initialization options C<TTY>, C<noTTY>, -C<ReadLine>, and C<NonStop> there. +After the rc file is read, the debugger reads the C<$ENV{PERLDB_OPTS}> +environment variable and parses this as the remainder of a `O ...' +line as one might enter at the debugger prompt. You may place the +initialization options C<TTY>, C<noTTY>, C<ReadLine>, and C<NonStop> +there. If your rc file contains: @@ -767,6 +771,11 @@ Breakable lines are marked with C<:>. Lines with breakpoints are marked by C<b> and those with actions by C<a>. The line that's about to be executed is marked by C<< ==> >>. +Please be aware that code in debugger listings may not look the same +as your original source code. Line directives and external source +filters can alter the code before Perl sees it, causing code to move +from its original positions or take on entirely different forms. + =item Frame listing When the C<frame> option is set, the debugger would print entered (and diff --git a/contrib/perl5/pod/perldelta.pod b/contrib/perl5/pod/perldelta.pod index 4a1a14201e66..86235f03870d 100644 --- a/contrib/perl5/pod/perldelta.pod +++ b/contrib/perl5/pod/perldelta.pod @@ -1,16 +1,612 @@ =head1 NAME -perldelta - what's new for perl v5.6.0 +perldelta - what's new for perl v5.6.x =head1 DESCRIPTION -This document describes differences between the 5.005 release and this one. +This document describes differences between the 5.005 release and the 5.6.1 +release. +=head1 Summary of changes between 5.6.0 and 5.6.1 + +This section contains a summary of the changes between the 5.6.0 release +and the 5.6.1 release. More details about the changes mentioned here +may be found in the F<Changes> files that accompany the Perl source +distribution. See L<perlhack> for pointers to online resources where you +can inspect the individual patches described by these changes. + +=head2 Security Issues + +suidperl will not run /bin/mail anymore, because some platforms have +a /bin/mail that is vulnerable to buffer overflow attacks. + +Note that suidperl is neither built nor installed by default in +any recent version of perl. Use of suidperl is highly discouraged. +If you think you need it, try alternatives such as sudo first. +See http://www.courtesan.com/sudo/. + +=head2 Core bug fixes + +This is not an exhaustive list. It is intended to cover only the +significant user-visible changes. + +=over + +=item C<UNIVERSAL::isa()> + +A bug in the caching mechanism used by C<UNIVERSAL::isa()> that affected +base.pm has been fixed. The bug has existed since the 5.005 releases, +but wasn't tickled by base.pm in those releases. + +=item Memory leaks + +Various cases of memory leaks and attempts to access uninitialized memory +have been cured. See L</"Known Problems"> below for further issues. + +=item Numeric conversions + +Numeric conversions did not recognize changes in the string value +properly in certain circumstances. + +In other situations, large unsigned numbers (those above 2**31) could +sometimes lose their unsignedness, causing bogus results in arithmetic +operations. + +Integer modulus on large unsigned integers sometimes returned +incorrect values. + +Perl 5.6.0 generated "not a number" warnings on certain conversions where +previous versions didn't. + +These problems have all been rectified. + +Infinity is now recognized as a number. + +=item qw(a\\b) + +In Perl 5.6.0, qw(a\\b) produced a string with two backslashes instead +of one, in a departure from the behavior in previous versions. The +older behavior has been reinstated. + +=item caller() + +caller() could cause core dumps in certain situations. Carp was sometimes +affected by this problem. + +=item Bugs in regular expressions + +Pattern matches on overloaded values are now handled correctly. + +Perl 5.6.0 parsed m/\x{ab}/ incorrectly, leading to spurious warnings. +This has been corrected. + +The RE engine found in Perl 5.6.0 accidentally pessimised certain kinds +of simple pattern matches. These are now handled better. + +Regular expression debug output (whether through C<use re 'debug'> +or via C<-Dr>) now looks better. + +Multi-line matches like C<"a\nxb\n" =~ /(?!\A)x/m> were flawed. The +bug has been fixed. + +Use of $& could trigger a core dump under some situations. This +is now avoided. + +Match variables $1 et al., weren't being unset when a pattern match +was backtracking, and the anomaly showed up inside C</...(?{ ... }).../> +etc. These variables are now tracked correctly. + +pos() did not return the correct value within s///ge in earlier +versions. This is now handled correctly. + +=item "slurp" mode + +readline() on files opened in "slurp" mode could return an extra "" at +the end in certain situations. This has been corrected. + +=item Autovivification of symbolic references to special variables + +Autovivification of symbolic references of special variables described +in L<perlvar> (as in C<${$num}>) was accidentally disabled. This works +again now. + +=item Lexical warnings + +Lexical warnings now propagate correctly into C<eval "...">. + +C<use warnings qw(FATAL all)> did not work as intended. This has been +corrected. + +Lexical warnings could leak into other scopes in some situations. +This is now fixed. + +warnings::enabled() now reports the state of $^W correctly if the caller +isn't using lexical warnings. + +=item Spurious warnings and errors + +Perl 5.6.0 could emit spurious warnings about redefinition of dl_error() +when statically building extensions into perl. This has been corrected. + +"our" variables could result in bogus "Variable will not stay shared" +warnings. This is now fixed. + +"our" variables of the same name declared in two sibling blocks +resulted in bogus warnings about "redeclaration" of the variables. +The problem has been corrected. + +=item glob() + +Compatibility of the builtin glob() with old csh-based glob has been +improved with the addition of GLOB_ALPHASORT option. See C<File::Glob>. + +File::Glob::glob() has been renamed to File::Glob::bsd_glob() +because the name clashes with the builtin glob(). The older +name is still available for compatibility, but is deprecated. + +Spurious syntax errors generated in certain situations, when glob() +caused File::Glob to be loaded for the first time, have been fixed. + +=item Tainting + +Some cases of inconsistent taint propagation (such as within hash +values) have been fixed. + +The tainting behavior of sprintf() has been rationalized. It does +not taint the result of floating point formats anymore, making the +behavior consistent with that of string interpolation. + +=item sort() + +Arguments to sort() weren't being provided the right wantarray() context. +The comparison block is now run in scalar context, and the arguments to +be sorted are always provided list context. + +sort() is also fully reentrant, in the sense that the sort function +can itself call sort(). This did not work reliably in previous releases. + +=item #line directives + +#line directives now work correctly when they appear at the very +beginning of C<eval "...">. + +=item Subroutine prototypes + +The (\&) prototype now works properly. + +=item map() + +map() could get pathologically slow when the result list it generates +is larger than the source list. The performance has been improved for +common scenarios. + +=item Debugger + +Debugger exit code now reflects the script exit code. + +Condition C<"0"> in breakpoints is now treated correctly. + +The C<d> command now checks the line number. + +C<$.> is no longer corrupted by the debugger. + +All debugger output now correctly goes to the socket if RemotePort +is set. + +=item PERL5OPT + +PERL5OPT can be set to more than one switch group. Previously, +it used to be limited to one group of options only. + +=item chop() + +chop(@list) in list context returned the characters chopped in reverse +order. This has been reversed to be in the right order. + +=item Unicode support + +Unicode support has seen a large number of incremental improvements, +but continues to be highly experimental. It is not expected to be +fully supported in the 5.6.x maintenance releases. + +substr(), join(), repeat(), reverse(), quotemeta() and string +concatenation were all handling Unicode strings incorrectly in +Perl 5.6.0. This has been corrected. + +Support for C<tr///CU> and C<tr///UC> etc., have been removed since +we realized the interface is broken. For similar functionality, +see L<perlfunc/pack>. + +The Unicode Character Database has been updated to version 3.0.1 +with additions made available to the public as of August 30, 2000. + +The Unicode character classes \p{Blank} and \p{SpacePerl} have been +added. "Blank" is like C isblank(), that is, it contains only +"horizontal whitespace" (the space character is, the newline isn't), +and the "SpacePerl" is the Unicode equivalent of C<\s> (\p{Space} +isn't, since that includes the vertical tabulator character, whereas +C<\s> doesn't.) + +If you are experimenting with Unicode support in perl, the development +versions of Perl may have more to offer. In particular, I/O layers +are now available in the development track, but not in the maintenance +track, primarily to do backward compatibility issues. Unicode support +is also evolving rapidly on a daily basis in the development track--the +maintenance track only reflects the most conservative of these changes. + +=item 64-bit support + +Support for 64-bit platforms has been improved, but continues to be +experimental. The level of support varies greatly among platforms. + +=item Compiler + +The B Compiler and its various backends have had many incremental +improvements, but they continue to remain highly experimental. Use in +production environments is discouraged. + +The perlcc tool has been rewritten so that the user interface is much +more like that of a C compiler. + +The perlbc tools has been removed. Use C<perlcc -B> instead. + +=item Lvalue subroutines + +There have been various bugfixes to support lvalue subroutines better. +However, the feature still remains experimental. + +=item IO::Socket + +IO::Socket::INET failed to open the specified port if the service +name was not known. It now correctly uses the supplied port number +as is. + +=item File::Find + +File::Find now chdir()s correctly when chasing symbolic links. + +=item xsubpp + +xsubpp now tolerates embedded POD sections. + +=item C<no Module;> + +C<no Module;> does not produce an error even if Module does not have an +unimport() method. This parallels the behavior of C<use> vis-a-vis +C<import>. + +=item Tests + +A large number of tests have been added. + +=back + +=head2 Core features + +untie() will now call an UNTIE() hook if it exists. See L<perltie> +for details. + +The C<-DT> command line switch outputs copious tokenizing information. +See L<perlrun>. + +Arrays are now always interpolated in double-quotish strings. Previously, +C<"foo@bar.com"> used to be a fatal error at compile time, if an array +C<@bar> was not used or declared. This transitional behavior was +intended to help migrate perl4 code, and is deemed to be no longer useful. +See L</"Arrays now always interpolate into double-quoted strings">. + +keys(), each(), pop(), push(), shift(), splice() and unshift() +can all be overridden now. + +C<my __PACKAGE__ $obj> now does the expected thing. + +=head2 Configuration issues + +On some systems (IRIX and Solaris among them) the system malloc is demonstrably +better. While the defaults haven't been changed in order to retain binary +compatibility with earlier releases, you may be better off building perl +with C<Configure -Uusemymalloc ...> as discussed in the F<INSTALL> file. + +C<Configure> has been enhanced in various ways: + +=over + +=item * + +Minimizes use of temporary files. + +=item * + +By default, does not link perl with libraries not used by it, such as +the various dbm libraries. SunOS 4.x hints preserve behavior on that +platform. + +=item * + +Support for pdp11-style memory models has been removed due to obsolescence. + +=item * + +Building outside the source tree is supported on systems that have +symbolic links. This is done by running + + sh /path/to/source/Configure -Dmksymlinks ... + make all test install + +in a directory other than the perl source directory. See F<INSTALL>. + +=item * + +C<Configure -S> can be run non-interactively. + +=back + +=head2 Documentation + +README.aix, README.solaris and README.macos have been added. README.posix-bc +has been renamed to README.bs2000. These are installed as L<perlaix>, +L<perlsolaris>, L<perlmacos>, and L<perlbs2000> respectively. + +The following pod documents are brand new: + + perlclib Internal replacements for standard C library functions + perldebtut Perl debugging tutorial + perlebcdic Considerations for running Perl on EBCDIC platforms + perlnewmod Perl modules: preparing a new module for distribution + perlrequick Perl regular expressions quick start + perlretut Perl regular expressions tutorial + perlutil utilities packaged with the Perl distribution + +The F<INSTALL> file has been expanded to cover various issues, such as +64-bit support. + +A longer list of contributors has been added to the source distribution. +See the file C<AUTHORS>. + +Numerous other changes have been made to the included documentation and FAQs. + +=head2 Bundled modules + +The following modules have been added. + +=over + +=item B::Concise + +Walks Perl syntax tree, printing concise info about ops. See L<B::Concise>. + +=item File::Temp + +Returns name and handle of a temporary file safely. See L<File::Temp>. + +=item Pod::LaTeX + +Converts Pod data to formatted LaTeX. See L<Pod::LaTeX>. + +=item Pod::Text::Overstrike + +Converts POD data to formatted overstrike text. See L<Pod::Text::Overstrike>. + +=back + +The following modules have been upgraded. + +=over + +=item CGI + +CGI v2.752 is now included. + +=item CPAN + +CPAN v1.59_54 is now included. + +=item Class::Struct + +Various bugfixes have been added. + +=item DB_File + +DB_File v1.75 supports newer Berkeley DB versions, among other +improvements. + +=item Devel::Peek + +Devel::Peek has been enhanced to support dumping of memory statistics, +when perl is built with the included malloc(). + +=item File::Find + +File::Find now supports pre and post-processing of the files in order +to sort() them, etc. + +=item Getopt::Long + +Getopt::Long v2.25 is included. + +=item IO::Poll + +Various bug fixes have been included. + +=item IPC::Open3 + +IPC::Open3 allows use of numeric file descriptors. + +=item Math::BigFloat + +The fmod() function supports modulus operations. Various bug fixes +have also been included. + +=item Math::Complex + +Math::Complex handles inf, NaN etc., better. + +=item Net::Ping + +ping() could fail on odd number of data bytes, and when the echo service +isn't running. This has been corrected. + +=item Opcode + +A memory leak has been fixed. + +=item Pod::Parser + +Version 1.13 of the Pod::Parser suite is included. + +=item Pod::Text + +Pod::Text and related modules have been upgraded to the versions +in podlators suite v2.08. + +=item SDBM_File + +On dosish platforms, some keys went missing because of lack of support for +files with "holes". A workaround for the problem has been added. + +=item Sys::Syslog + +Various bug fixes have been included. + +=item Tie::RefHash + +Now supports Tie::RefHash::Nestable to automagically tie hashref values. + +=item Tie::SubstrHash + +Various bug fixes have been included. + +=back + +=head2 Platform-specific improvements + +The following new ports are now available. + +=over + +=item NCR MP-RAS + +=item NonStop-UX + +=back + +Perl now builds under Amdahl UTS. + +Perl has also been verified to build under Amiga OS. + +Support for EPOC has been much improved. See README.epoc. + +Building perl with -Duseithreads or -Duse5005threads now works +under HP-UX 10.20 (previously it only worked under 10.30 or later). +You will need a thread library package installed. See README.hpux. + +Long doubles should now work under Linux. + +MacOS Classic is now supported in the mainstream source package. +See README.macos. + +Support for MPE/iX has been updated. See README.mpeix. + +Support for OS/2 has been improved. See C<os2/Changes> and README.os2. + +Dynamic loading on z/OS (formerly OS/390) has been improved. See +README.os390. + +Support for VMS has seen many incremental improvements, including +better support for operators like backticks and system(), and better +%ENV handling. See C<README.vms> and L<perlvms>. + +Support for Stratus VOS has been improved. See C<vos/Changes> and README.vos. + +Support for Windows has been improved. + +=over + +=item * + +fork() emulation has been improved in various ways, but still continues +to be experimental. See L<perlfork> for known bugs and caveats. + +=item * + +%SIG has been enabled under USE_ITHREADS, but its use is completely +unsupported under all configurations. + +=item * + +Borland C++ v5.5 is now a supported compiler that can build Perl. +However, the generated binaries continue to be incompatible with those +generated by the other supported compilers (GCC and Visual C++). + +=item * + +Non-blocking waits for child processes (or pseudo-processes) are +supported via C<waitpid($pid, &POSIX::WNOHANG)>. + +=item * + +A memory leak in accept() has been fixed. + +=item * + +wait(), waitpid() and backticks now return the correct exit status under +Windows 9x. + +=item * + +Trailing new %ENV entries weren't propagated to child processes. This +is now fixed. + +=item * + +Current directory entries in %ENV are now correctly propagated to child +processes. + +=item * + +Duping socket handles with open(F, ">&MYSOCK") now works under Windows 9x. + +=item * + +The makefiles now provide a single switch to bulk-enable all the features +enabled in ActiveState ActivePerl (a popular binary distribution). + +=item * + +Win32::GetCwd() correctly returns C:\ instead of C: when at the drive root. +Other bugs in chdir() and Cwd::cwd() have also been fixed. + +=item * + +fork() correctly returns undef and sets EAGAIN when it runs out of +pseudo-process handles. + +=item * + +ExtUtils::MakeMaker now uses $ENV{LIB} to search for libraries. + +=item * + +UNC path handling is better when perl is built to support fork(). + +=item * + +A handle leak in socket handling has been fixed. + +=item * + +send() works from within a pseudo-process. + +=back + +Unless specifically qualified otherwise, the remainder of this document +covers changes between the 5.005 and 5.6.0 releases. + =head1 Core Enhancements =head2 Interpreter cloning, threads, and concurrency -Perl 5.005_63 introduces the beginnings of support for running multiple +Perl 5.6.0 introduces the beginnings of support for running multiple interpreters concurrently in different threads. In conjunction with the perl_clone() API call, which can be used to selectively duplicate the state of any given interpreter, it is possible to compile a @@ -76,7 +672,7 @@ will be needed to complete the toolkit for dealing with Unicode. The new C<\N> escape interpolates named characters within strings. For example, C<"Hi! \N{WHITE SMILING FACE}"> evaluates to a string -with a unicode smiley face at the end. +with a Unicode smiley face at the end. =head2 "our" declarations @@ -91,7 +687,7 @@ variables. See L<perlfunc/our>. Literals of the form C<v1.2.3.4> are now parsed as a string composed of characters with the specified ordinals. This is an alternative, more -readable way to construct (possibly unicode) strings instead of +readable way to construct (possibly Unicode) strings instead of interpolating characters, as in C<"\x{1}\x{2}\x{3}\x{4}">. The leading C<v> may be omitted if there are more than two ordinals, so C<1.2.3> is parsed the same as C<v1.2.3>. @@ -375,7 +971,7 @@ problems associated with it. NOTE: This is currently an experimental feature. Interfaces and implementation are subject to change. -=item Support for CHECK blocks +=head2 Support for CHECK blocks In addition to C<BEGIN>, C<INIT>, C<END>, C<DESTROY> and C<AUTOLOAD>, subroutines named C<CHECK> are now special. These are queued up during @@ -388,7 +984,7 @@ be called directly. For example to match alphabetic characters use /[[:alpha:]]/. See L<perlre> for details. -=item Better pseudo-random number generator +=head2 Better pseudo-random number generator In 5.005_0x and earlier, perl's rand() function used the C library rand(3) function. As of 5.005_52, Configure tests for drand48(), @@ -409,7 +1005,7 @@ Thus: now correctly prints "3|a", instead of "2|a". -=item Better worst-case behavior of hashes +=head2 Better worst-case behavior of hashes Small changes in the hashing algorithm have been implemented in order to improve the distribution of lower order bits in the @@ -506,7 +1102,7 @@ If the array is tied, the EXISTS() method in the corresponding tied package will be invoked. delete() may be used to remove an element from the array and return -it. The array element at that position returns to its unintialized +it. The array element at that position returns to its uninitialized state, so that testing for the same element with exists() will return false. If the element happens to be the one at the end, the size of the array also shrinks up to the highest element that tests true for @@ -632,7 +1228,7 @@ Diagnostic output now goes to whichever file the C<STDERR> handle is pointing at, instead of always going to the underlying C runtime library's C<stderr>. -=item More consistent close-on-exec behavior +=head2 More consistent close-on-exec behavior On systems that support a close-on-exec flag on filehandles, the flag is now set for any handles created by pipe(), socketpair(), @@ -693,7 +1289,7 @@ The variable modified by shmread(), and messages returned by msgrcv() because other untrusted processes can modify messages and shared memory segments for their own nefarious purposes. -=item More functional bareword prototype (*) +=head2 More functional bareword prototype (*) Bareword prototypes have been rationalized to enable them to be used to override builtins that accept barewords and interpret them in @@ -760,6 +1356,37 @@ with another number. This behavior must be specifically enabled when running Configure. See F<INSTALL> and F<README.Y2K>. +=head2 Arrays now always interpolate into double-quoted strings + +In double-quoted strings, arrays now interpolate, no matter what. The +behavior in earlier versions of perl 5 was that arrays would interpolate +into strings if the array had been mentioned before the string was +compiled, and otherwise Perl would raise a fatal compile-time error. +In versions 5.000 through 5.003, the error was + + Literal @example now requires backslash + +In versions 5.004_01 through 5.6.0, the error was + + In string, @example now must be written as \@example + +The idea here was to get people into the habit of writing +C<"fred\@example.com"> when they wanted a literal C<@> sign, just as +they have always written C<"Give me back my \$5"> when they wanted a +literal C<$> sign. + +Starting with 5.6.1, when Perl now sees an C<@> sign in a +double-quoted string, it I<always> attempts to interpolate an array, +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<fred.com> if you don't backslash the C<@>. +See http://www.plover.com/~mjd/perl/at-error.html for more details +about the history here. + =head1 Modules and Pragmata =head2 Modules @@ -780,7 +1407,7 @@ under the Compiler, but there is still a significant way to go to achieve production quality compiled executables. NOTE: The Compiler suite remains highly experimental. The - generated code may not be correct, even it manages to execute + generated code may not be correct, even when it manages to execute without errors. =item Benchmark @@ -1007,7 +1634,7 @@ messages. For example: =head1 DESCRIPTION - B<This program> will read the given input file(s) and do someting + B<This program> will read the given input file(s) and do something useful with the contents thereof. =cut @@ -1039,7 +1666,7 @@ IO::Socket::accept now uses select() instead of alarm() for doing timeouts. IO::Socket::INET->new now sets $! correctly on failure. $@ is -still set for backwards compatability. +still set for backwards compatibility. =item JPL @@ -1409,7 +2036,7 @@ eliminating redundant copying overheads. Minor changes in how subroutine calls are handled internally provide marginal improvements in performance. -=item delete(), each(), values() and hash iteration are faster +=head2 delete(), each(), values() and hash iteration are faster The hash values returned by delete(), each(), values() and hashes in a list context are the actual values in the hash, instead of copies. @@ -1518,6 +2145,13 @@ config.sh file from an earlier version of perl, you should be sure to check that Configure makes sensible choices for the new directories. See INSTALL for complete details. +=head2 gcc automatically tried if 'cc' does not seem to be working + +In many platforms the vendor-supplied 'cc' is too stripped-down to +build Perl (basically, the 'cc' doesn't do ANSI C). If this seems +to be the case and the 'cc' does not seem to be the GNU C compiler +'gcc', an automatic attempt is made to find and use 'gcc' instead. + =head1 Platform specific changes =head2 Supported platforms @@ -1526,14 +2160,6 @@ See INSTALL for complete details. =item * -VM/ESA is now supported. - -=item * - -Siemens BS2000 is now supported under the POSIX Shell. - -=item * - The Mach CThreads (NEXTSTEP, OPENSTEP) are now supported by the Thread extension. @@ -1547,7 +2173,7 @@ Rhapsody/Darwin is now supported. =item * -EPOC is is now supported (on Psion 5). +EPOC is now supported (on Psion 5). =item * @@ -1590,7 +2216,7 @@ platform, but the possibility exists. =head2 VMS Numerous revisions and extensions to configuration, build, testing, and -installation process to accomodate core changes and VMS-specific options. +installation process to accommodate core changes and VMS-specific options. Expand %ENV-handling code to allow runtime mapping to logical names, CLI symbols, and CRTL environ array. @@ -1703,7 +2329,7 @@ been fixed. =head2 All compilation errors are true errors -Some "errors" encountered at compile time were by neccessity +Some "errors" encountered at compile time were by necessity generated as warnings followed by eventual termination of the program. This enabled more such errors to be reported in a single run, rather than causing a hard stop at the first error @@ -1811,9 +2437,10 @@ cause silent failures. This has been fixed. Prior versions used to run BEGIN B<and> END blocks when Perl was 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. +is used, or if compilation fails. -See L<CHECK blocks> for how to run things when the compile phase ends. +See L</"Support for CHECK blocks"> for how to run things when the compile +phase ends. =head2 Potential to leak DATA filehandles @@ -2155,7 +2782,7 @@ L<perlport> for more on portability concerns. (W internal) A warning peculiar to VMS. Perl tried to read the CRTL's internal environ array, and encountered an element without the C<=> delimiter -used to spearate keys from values. The element is ignored. +used to separate keys from values. The element is ignored. =item Ill-formed message in prime_env_iter: |%s| @@ -2306,6 +2933,20 @@ when you meant Remember that "my", "our", and "local" bind tighter than comma. +=item Possible unintended interpolation of %s in string + +(W ambiguous) It used to be that Perl would try to guess whether you +wanted an array interpolated or a literal @. It no longer does this; +arrays are now I<always> interpolated into strings. This means that +if you try something like: + + print "fred@example.com"; + +and the array C<@example> doesn't exist, Perl is going to print +C<fred.com>, which is probably not what you wanted. To get a literal +C<@> sign in a string, put a backslash before it, just as you would +to get a literal C<$> sign. + =item Possible Y2K bug: %s (W y2k) You are concatenating the number 19 with another number, which @@ -2313,7 +2954,7 @@ could be a potential Year 2000 problem. =item pragma "attrs" is deprecated, use "sub NAME : ATTRS" instead -(W deprecated) You have written somehing like this: +(W deprecated) You have written something like this: sub doit { @@ -2530,7 +3171,7 @@ There is a potential incompatibility in the behavior of list slices that are comprised entirely of undefined values. See L</"Behavior of list slices is more consistent">. -=head2 Format of $English::PERL_VERSION is different +=item Format of $English::PERL_VERSION is different The English module now sets $PERL_VERSION to $^V (a string value) rather than C<$]> (a numeric value). This is a potential incompatibility. @@ -2592,9 +3233,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 @@ -2655,7 +3299,7 @@ a simple scalar or as a reference to a typeglob. See L</"More functional bareword prototype (*)">. -=head2 Semantics of bit operators may have changed on 64-bit platforms +=item Semantics of bit operators may have changed on 64-bit platforms If your platform is either natively 64-bit or if Perl has been configured to used 64-bit integers, i.e., $Config{ivsize} is 8, @@ -2669,7 +3313,7 @@ the excess bits in the result of unary C<~>, e.g., C<~$x & 0xffffffff>. See L</"Bit operators support full native integer width">. -=head2 More builtins taint their results +=item More builtins taint their results As described in L</"Improved security features">, there may be more sources of taint in a Perl program. @@ -2744,7 +3388,7 @@ See L<perlguts/"Memory Allocation"> for further information about that. =head2 Compatible C Source API Changes -=over +=over 4 =item C<PATCHLEVEL> is now C<PERL_VERSION> @@ -2784,21 +3428,26 @@ For the full list of public API functions, see L<perlapi>. =head1 Known Problems -=head2 Thread test failures +=head2 Localizing a tied hash element may leak memory -The subtests 19 and 20 of lib/thr5005.t test are known to fail due to -fundamental problems in the 5.005 threading implementation. These are -not new failures--Perl 5.005_0x has the same bugs, but didn't have these -tests. +As of the 5.6.1 release, there is a known leak when code such as this +is executed: -=head2 EBCDIC platforms not supported + use Tie::Hash; + tie my %tie_hash => 'Tie::StdHash'; -In earlier releases of Perl, EBCDIC environments like OS390 (also -known as Open Edition MVS) and VM-ESA were supported. Due to changes -required by the UTF-8 (Unicode) support, the EBCDIC platforms are not -supported in Perl 5.6.0. + ... + + local($tie_hash{Foo}) = 1; # leaks -=head2 In 64-bit HP-UX the lib/io_multihomed test may hang +=head2 Known test failures + +=over + +=item 64-bit builds + +Subtest #15 of lib/b.t may fail under 64-bit builds on platforms such +as HP-UX PA64 and Linux IA64. The issue is still being investigated. The lib/io_multihomed test may hang in HP-UX if Perl has been configured to be 64-bit. Because other 64-bit platforms do not @@ -2806,19 +3455,40 @@ hang in this test, HP-UX is suspect. All other tests pass in 64-bit HP-UX. The test attempts to create and connect to "multihomed" sockets (sockets which have multiple IP addresses). -=head2 NEXTSTEP 3.3 POSIX test failure +Note that 64-bit support is still experimental. + +=item Failure of Thread tests + +The subtests 19 and 20 of lib/thr5005.t test are known to fail due to +fundamental problems in the 5.005 threading implementation. These are +not new failures--Perl 5.005_0x has the same bugs, but didn't have these +tests. (Note that support for 5.005-style threading remains experimental.) + +=item NEXTSTEP 3.3 POSIX test failure In NEXTSTEP 3.3p2 the implementation of the strftime(3) in the operating system libraries is buggy: the %j format numbers the days of a month starting from zero, which, while being logical to programmers, will cause the subtests 19 to 27 of the lib/posix test may fail. -=head2 Tru64 (aka Digital UNIX, aka DEC OSF/1) lib/sdbm test failure with gcc +=item Tru64 (aka Digital UNIX, aka DEC OSF/1) lib/sdbm test failure with gcc If compiled with gcc 2.95 the lib/sdbm test will fail (dump core). The cure is to use the vendor cc, it comes with the operating system and produces good code. +=back + +=head2 EBCDIC platforms not fully supported + +In earlier releases of Perl, EBCDIC environments like OS390 (also +known as Open Edition MVS) and VM-ESA were supported. Due to changes +required by the UTF-8 (Unicode) support, the EBCDIC platforms are not +supported in Perl 5.6.0. + +The 5.6.1 release improves support for EBCDIC platforms, but they +are not fully supported yet. + =head2 UNICOS/mk CC failures during Configure run In UNICOS/mk the following errors may appear during the Configure run: @@ -2847,11 +3517,6 @@ operation must be considered erroneous. For example: These expressions will get run-time errors in some future release of Perl. -=head2 Windows 2000 - -Windows 2000 is known to fail test 22 in lib/open3.t (cause unknown at -this time). That test passes under Windows NT. - =head2 Experimental features As discussed above, many features are still experimental. Interfaces and @@ -2879,7 +3544,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 @@ -2904,6 +3571,18 @@ appear in %ENV. This may be a benign occurrence, as some software packages might directly modify logical name tables and introduce nonstandard names, or it may indicate that a logical name table has been corrupted. +=item In string, @%s now must be written as \@%s + +The description of this error used to say: + + (Someday it will simply assume that an unbackslashed @ + interpolates an array.) + +That day has come, and this fatal error has been removed. It has been +replaced by a non-fatal warning instead. +See L</Arrays now always interpolate into double-quoted strings> for +details. + =item Probable precedence problem on %s (W) The compiler found a bareword where it expected a conditional, @@ -2938,13 +3617,13 @@ warning. And in Perl 5.005, this special treatment will cease. If you find what you think is a bug, you might check the articles recently posted to the comp.lang.perl.misc newsgroup. -There may also be information at http://www.perl.com/perl/, the Perl +There may also be information at http://www.perl.com/, the Perl Home Page. If you believe you have an unreported bug, please run the B<perlbug> program included with your release. Be sure to trim your bug down to a tiny but sufficient test case. Your bug report, along with the -output of C<perl -V>, will be sent off to perlbug@perl.com to be +output of C<perl -V>, will be sent off to perlbug@perl.org to be analysed by the Perl porting team. =head1 SEE ALSO @@ -2959,9 +3638,9 @@ The F<Artistic> and F<Copying> files for copyright information. =head1 HISTORY -Written by Gurusamy Sarathy <F<gsar@activestate.com>>, with many +Written by Gurusamy Sarathy <F<gsar@ActiveState.com>>, with many contributions from The Perl Porters. -Send omissions or corrections to <F<perlbug@perl.com>>. +Send omissions or corrections to <F<perlbug@perl.org>>. =cut diff --git a/contrib/perl5/pod/perldiag.pod b/contrib/perl5/pod/perldiag.pod index 9ed75526044a..b842c1c5eaec 100644 --- a/contrib/perl5/pod/perldiag.pod +++ b/contrib/perl5/pod/perldiag.pod @@ -15,8 +15,8 @@ desperation): (X) A very fatal error (nontrappable). (A) An alien error message (not generated by Perl). -The majority of messages from the first three classifications above (W, -D & S) can be controlled using the C<warnings> pragma. +The majority of messages from the first three classifications above +(W, D & S) can be controlled using the C<warnings> pragma. If a message can be controlled by the C<warnings> pragma, its warning category is included with the classification letter in the description @@ -35,116 +35,94 @@ L<perlfunc/eval>. In almost all cases, warnings may be selectively disabled or promoted to fatal errors using the C<warnings> pragma. See L<warnings>. -Some of these messages are generic. Spots that vary are denoted with a %s, -just as in a printf format. Note that some messages start with a %s! -Since the messages are listed in alphabetical order, the symbols -C<"%(-?@> sort before the letters, while C<[> and C<\> sort after. +The messages are in alphabetical order, without regard to upper or +lower-case. Some of these messages are generic. Spots that vary are +denoted with a %s or other printf-style escape. These escapes are +ignored by the alphabetical order, as are all characters other than +letters. To look up your message, just ignore anything that is not a +letter. =over 4 -=item "%s" variable %s masks earlier declaration in same %s - -(W misc) A "my" or "our" variable has been redeclared in the current scope or statement, -effectively eliminating all access to the previous instance. This is almost -always a typographical error. Note that the earlier variable will still exist -until the end of the scope or until all closure referents to it are -destroyed. - -=item "my sub" not yet implemented - -(F) Lexically scoped subroutines are not yet implemented. Don't try that -yet. - -=item "my" variable %s can't be in a package - -(F) Lexically scoped variables aren't in a package, so it doesn't make sense -to try to declare one with a package qualifier on the front. Use local() -if you want to localize a package variable. - -=item "no" not allowed in expression - -(F) The "no" keyword is recognized and executed at compile time, and returns -no useful value. See L<perlmod>. - -=item "our" variable %s redeclared +=item accept() on closed socket %s -(W misc) You seem to have already declared the same global once before in the -current lexical scope. +(W closed) You tried to do an accept on a closed socket. Did you forget +to check the return value of your socket() call? See +L<perlfunc/accept>. -=item "use" not allowed in expression +=item Allocation too large: %lx -(F) The "use" keyword is recognized and executed at compile time, and returns -no useful value. See L<perlmod>. +(X) You can't allocate more than 64K on an MS-DOS machine. =item '!' allowed only after types %s (F) The '!' is allowed in pack() and unpack() only after certain types. See L<perlfunc/pack>. -=item / cannot take a count - -(F) You had an unpack template indicating a counted-length string, -but you have also specified an explicit size for the string. -See L<perlfunc/pack>. - -=item / must be followed by a, A or Z - -(F) You had an unpack template indicating a counted-length string, -which must be followed by one of the letters a, A or Z -to indicate what sort of string is to be unpacked. -See L<perlfunc/pack>. +=item Ambiguous call resolved as CORE::%s(), qualify as such or use & -=item / must be followed by a*, A* or Z* +(W ambiguous) A subroutine you have declared has the same name as a Perl +keyword, and you have used the name without qualification for calling +one or the other. Perl decided to call the builtin because the +subroutine is not imported. -(F) You had a pack template indicating a counted-length string, -Currently the only things that can have their length counted are a*, A* or Z*. -See L<perlfunc/pack>. +To force interpretation as a subroutine call, either put an ampersand +before the subroutine name, or qualify the name with its package. +Alternatively, you can import the subroutine (or pretend that it's +imported with the C<use subs> pragma). -=item / must follow a numeric type +To silently interpret it as the Perl operator, use the C<CORE::> prefix +on the operator (e.g. C<CORE::log($x)>) or by declaring the subroutine +to be an object method (see L<perlsub/"Subroutine Attributes"> or +L<attributes>). -(F) You had an unpack template that contained a '#', -but this did not follow some numeric unpack specification. -See L<perlfunc/pack>. +=item Ambiguous use of %s resolved as %s -=item % may only be used in unpack +(W ambiguous)(S) You said something that may not be interpreted the way +you thought. Normally it's pretty easy to disambiguate it by supplying +a missing quote, operator, parenthesis pair or declaration. -(F) You can't pack a string by supplying a checksum, because the -checksumming process loses information, and you can't go the other -way. See L<perlfunc/unpack>. +=item '|' and '<' may not both be specified on command line -=item /%s/: Unrecognized escape \\%c passed through +(F) An error peculiar to VMS. Perl does its own command line +redirection, and found that STDIN was a pipe, and that you also tried to +redirect STDIN using '<'. Only one STDIN stream to a customer, please. -(W regexp) You used a backslash-character combination which is not recognized -by Perl. This combination appears in an interpolated variable or a -C<'>-delimited regular expression. The character was understood literally. +=item '|' and '>' may not both be specified on command line -=item /%s/: Unrecognized escape \\%c in character class passed through +(F) An error peculiar to VMS. Perl does its own command line +redirection, and thinks you tried to redirect stdout both to a file and +into a pipe to another command. You need to choose one or the other, +though nothing's stopping you from piping into a program or Perl script +which 'splits' output into two streams, such as -(W regexp) You used a backslash-character combination which is not recognized -by Perl inside character classes. The character was understood literally. + open(OUT,">$ARGV[0]") or die "Can't write to $ARGV[0]: $!"; + while (<STDIN>) { + print; + print OUT; + } + close OUT; -=item /%s/ should probably be written as "%s" +=item Applying %s to %s will act on scalar(%s) -(W syntax) You have used a pattern where Perl expected to find a string, -as in the first argument to C<join>. Perl will treat the true -or false result of matching the pattern against $_ as the string, -which is probably not what you had in mind. +(W misc) The pattern match (//), substitution (s///), and +transliteration (tr///) operators work on scalar values. If you apply +one of them to an array or a hash, it will convert the array or hash to +a scalar value -- the length of an array, or the population info of a +hash -- and then work on that scalar value. This is probably not what +you meant to do. See L<perlfunc/grep> and L<perlfunc/map> for +alternatives. -=item %s (...) interpreted as function +=item Args must match #! line -(W syntax) You've run afoul of the rule that says that any list operator followed -by parentheses turns into a function, with all the list operators arguments -found inside the parentheses. See L<perlop/Terms and List Operators (Leftward)>. +(F) The setuid emulator requires that the arguments Perl was invoked +with match the arguments specified on the #! line. Since some systems +impose a one-argument limit on the #! line, try combining switches; +for example, turn C<-w -U> into C<-wU>. -=item %s() called too early to check prototype +=item Arg too short for msgsnd -(W prototype) You've called a function that has a prototype before the parser saw a -definition or declaration for it, and Perl could not check that the call -conforms to the prototype. You need to either add an early prototype -declaration for the subroutine in question, or move the subroutine -definition ahead of the call to get proper prototype checking. Alternatively, -if you are certain that you're calling the function correctly, you may put -an ampersand before the name to avoid the warning. See L<perlsub>. +(F) msgsnd() requires a string at least as long as sizeof(long). =item %s argument is not a HASH or ARRAY element @@ -155,7 +133,8 @@ an ampersand before the name to avoid the warning. See L<perlsub>. =item %s argument is not a HASH or ARRAY element or slice -(F) The argument to delete() must be either a hash or array element, such as: +(F) The argument to delete() must be either a hash or array element, +such as: $foo{$bar} $ref->{"susie"}[12] @@ -168,191 +147,19 @@ or a hash or array slice, such as: =item %s argument is not a subroutine name (F) The argument to exists() for C<exists &sub> must be a subroutine -name, and not a subroutine call. C<exists &sub()> will generate this error. - -=item %s did not return a true value - -(F) A required (or used) file must return a true value to indicate that -it compiled correctly and ran its initialization code correctly. It's -traditional to end such a file with a "1;", though any true value would -do. See L<perlfunc/require>. - -=item %s found where operator expected - -(S) The Perl lexer knows whether to expect a term or an operator. If it -sees what it knows to be a term when it was expecting to see an operator, -it gives you this warning. Usually it indicates that an operator or -delimiter was omitted, such as a semicolon. - -=item %s had compilation errors - -(F) The final summary message when a C<perl -c> fails. - -=item %s has too many errors - -(F) The parser has given up trying to parse the program after 10 errors. -Further error messages would likely be uninformative. - -=item %s matches null string many times - -(W regexp) The pattern you've specified would be an infinite loop if the -regular expression engine didn't specifically check for that. See L<perlre>. - -=item %s never introduced - -(S internal) The symbol in question was declared but somehow went out of scope -before it could possibly have been used. - -=item %s package attribute may clash with future reserved word: %s - -(W reserved) A lowercase attribute name was used that had a package-specific handler. -That name might have a meaning to Perl itself some day, even though it -doesn't yet. Perhaps you should use a mixed-case attribute name, instead. -See L<attributes>. - -=item %s syntax OK - -(F) The final summary message when a C<perl -c> succeeds. - -=item %s: Command not found - -(A) You've accidentally run your script through B<csh> instead -of Perl. Check the #! line, or manually feed your script into -Perl yourself. - -=item %s: Expression syntax - -(A) You've accidentally run your script through B<csh> instead -of Perl. Check the #! line, or manually feed your script into -Perl yourself. - -=item %s: Undefined variable - -(A) You've accidentally run your script through B<csh> instead -of Perl. Check the #! line, or manually feed your script into -Perl yourself. - -=item %s: not found - -(A) You've accidentally run your script through the Bourne shell -instead of Perl. Check the #! line, or manually feed your script -into Perl yourself. - -=item (in cleanup) %s - -(W misc) This prefix usually indicates that a DESTROY() method raised -the indicated exception. Since destructors are usually called by -the system at arbitrary points during execution, and often a vast -number of times, the warning is issued only once for any number -of failures that would otherwise result in the same message being -repeated. - -Failure of user callbacks dispatched using the C<G_KEEPERR> flag -could also result in this warning. See L<perlcall/G_KEEPERR>. - -=item (Missing semicolon on previous line?) - -(S) This is an educated guess made in conjunction with the message "%s -found where operator expected". Don't automatically put a semicolon on -the previous line just because you saw this message. - -=item B<-P> not allowed for setuid/setgid script - -(F) The script would have to be opened by the C preprocessor by name, -which provides a race condition that breaks security. - -=item C<-T> and C<-B> not implemented on filehandles - -(F) Perl can't peek at the stdio buffer of filehandles when it doesn't -know about your kind of stdio. You'll have to use a filename instead. - -=item C<-p> destination: %s - -(F) An error occurred during the implicit output invoked by the C<-p> -command-line switch. (This output goes to STDOUT unless you've -redirected it with select().) - -=item 500 Server error - -See Server error. - -=item ?+* follows nothing in regexp - -(F) You started a regular expression with a quantifier. Backslash it -if you meant it literally. See L<perlre>. - -=item @ outside of string - -(F) You had a pack template that specified an absolute position outside -the string being unpacked. See L<perlfunc/pack>. - -=item <> should be quotes - -(F) You wrote C<< require <file> >> when you should have written -C<require 'file'>. - -=item accept() on closed socket %s - -(W closed) You tried to do an accept on a closed socket. Did you forget to check -the return value of your socket() call? See L<perlfunc/accept>. - -=item Allocation too large: %lx - -(X) You can't allocate more than 64K on an MS-DOS machine. - -=item Applying %s to %s will act on scalar(%s) - -(W misc) The pattern match (//), substitution (s///), and transliteration (tr///) -operators work on scalar values. If you apply one of them to an array -or a hash, it will convert the array or hash to a scalar value -- the -length of an array, or the population info of a hash -- and then work on -that scalar value. This is probably not what you meant to do. See -L<perlfunc/grep> and L<perlfunc/map> for alternatives. - -=item Arg too short for msgsnd - -(F) msgsnd() requires a string at least as long as sizeof(long). - -=item Ambiguous use of %s resolved as %s - -(W ambiguous)(S) You said something that may not be interpreted the way -you thought. Normally it's pretty easy to disambiguate it by supplying -a missing quote, operator, parenthesis pair or declaration. - -=item Ambiguous call resolved as CORE::%s(), qualify as such or use & - -(W ambiguous) A subroutine you have declared has the same name as a Perl keyword, -and you have used the name without qualification for calling one or the -other. Perl decided to call the builtin because the subroutine is -not imported. - -To force interpretation as a subroutine call, either put an ampersand -before the subroutine name, or qualify the name with its package. -Alternatively, you can import the subroutine (or pretend that it's -imported with the C<use subs> pragma). - -To silently interpret it as the Perl operator, use the C<CORE::> prefix -on the operator (e.g. C<CORE::log($x)>) or by declaring the subroutine -to be an object method (see L<perlsub/"Subroutine Attributes"> -or L<attributes>). - -=item Args must match #! line - -(F) The setuid emulator requires that the arguments Perl was invoked -with match the arguments specified on the #! line. Since some systems -impose a one-argument limit on the #! line, try combining switches; -for example, turn C<-w -U> into C<-wU>. +name, and not a subroutine call. C<exists &sub()> will generate this +error. =item Argument "%s" isn't numeric%s -(W numeric) The indicated string was fed as an argument to an operator that -expected a numeric value instead. If you're fortunate the message +(W numeric) The indicated string was fed as an argument to an operator +that expected a numeric value instead. If you're fortunate the message will identify which operator was so unfortunate. =item Array @%s missing the @ in argument %d of %s() -(D deprecated) Really old Perl let you omit the @ on array names in some spots. This -is now heavily deprecated. +(D deprecated) Really old Perl let you omit the @ on array names in some +spots. This is now heavily deprecated. =item assertion botched: %s @@ -368,26 +175,31 @@ is now heavily deprecated. must either both be scalars or both be lists. Otherwise Perl won't know which context to supply to the right side. +=item Negative offset to vec in lvalue context + +(F) When vec is called in an lvalue context, the second argument must be +greater than or equal to zero. + =item Attempt to free non-arena SV: 0x%lx -(P internal) All SV objects are supposed to be allocated from arenas that will -be garbage collected on exit. An SV was discovered to be outside any -of those arenas. +(P internal) All SV objects are supposed to be allocated from arenas +that will be garbage collected on exit. An SV was discovered to be +outside any of those arenas. =item Attempt to free nonexistent shared string -(P internal) Perl maintains a reference counted internal table of strings to -optimize the storage and access of hash keys and other strings. This -indicates someone tried to decrement the reference count of a string -that can no longer be found in the table. +(P internal) Perl maintains a reference counted internal table of +strings to optimize the storage and access of hash keys and other +strings. This indicates someone tried to decrement the reference count +of a string that can no longer be found in the table. =item Attempt to free temp prematurely -(W debugging) Mortalized values are supposed to be freed by the free_tmps() -routine. This indicates that something else is freeing the SV before -the free_tmps() routine gets a chance, which means that the free_tmps() -routine will be freeing an unreferenced scalar when it does try to free -it. +(W debugging) Mortalized values are supposed to be freed by the +free_tmps() routine. This indicates that something else is freeing the +SV before the free_tmps() routine gets a chance, which means that the +free_tmps() routine will be freeing an unreferenced scalar when it does +try to free it. =item Attempt to free unreferenced glob pointers @@ -395,18 +207,19 @@ it. =item Attempt to free unreferenced scalar -(W internal) Perl went to decrement the reference count of a scalar to see if it -would go to 0, and discovered that it had already gone to 0 earlier, -and should have been freed, and in fact, probably was freed. This -could indicate that SvREFCNT_dec() was called too many times, or that -SvREFCNT_inc() was called too few times, or that the SV was mortalized -when it shouldn't have been, or that memory has been corrupted. +(W internal) Perl went to decrement the reference count of a scalar to +see if it would go to 0, and discovered that it had already gone to 0 +earlier, and should have been freed, and in fact, probably was freed. +This could indicate that SvREFCNT_dec() was called too many times, or +that SvREFCNT_inc() was called too few times, or that the SV was +mortalized when it shouldn't have been, or that memory has been +corrupted. =item Attempt to join self (F) You tried to join a thread from within itself, which is an -impossible task. You may be joining the wrong thread, or you may -need to move the join() to some other thread. +impossible task. You may be joining the wrong thread, or you may need +to move the join() to some other thread. =item Attempt to pack pointer to temporary value @@ -419,14 +232,14 @@ avoid this warning. =item Attempt to use reference as lvalue in substr -(W substr) You supplied a reference as the first argument to substr() used -as an lvalue, which is pretty strange. Perhaps you forgot to +(W substr) You supplied a reference as the first argument to substr() +used as an lvalue, which is pretty strange. Perhaps you forgot to dereference it first. See L<perlfunc/substr>. =item Bad arg length for %s, is %d, should be %d -(F) You passed a buffer of the wrong size to one of msgctl(), semctl() or -shmctl(). In C parlance, the correct sizes are, respectively, +(F) You passed a buffer of the wrong size to one of msgctl(), semctl() +or shmctl(). In C parlance, the correct sizes are, respectively, S<sizeof(struct msqid_ds *)>, S<sizeof(struct semid_ds *)>, and S<sizeof(struct shmid_ds *)>. @@ -438,20 +251,19 @@ most likely an unexpected right brace '}'. =item Bad filehandle: %s -(F) A symbol was passed to something wanting a filehandle, but the symbol -has no filehandle associated with it. Perhaps you didn't do an open(), or -did it in another package. +(F) A symbol was passed to something wanting a filehandle, but the +symbol has no filehandle associated with it. Perhaps you didn't do an +open(), or did it in another package. =item Bad free() ignored -(S malloc) An internal routine called free() on something that had never been -malloc()ed in the first place. Mandatory, but can be disabled by -setting environment variable C<PERL_BADFREE> to 1. +(S malloc) An internal routine called free() on something that had never +been malloc()ed in the first place. Mandatory, but can be disabled by +setting environment variable C<PERL_BADFREE> to 0. -This message can be quite often seen with DB_File on systems with -"hard" dynamic linking, like C<AIX> and C<OS/2>. It is a bug of -C<Berkeley DB> which is left unnoticed if C<DB> uses I<forgiving> -system malloc(). +This message can be seen quite often with DB_File on systems with "hard" +dynamic linking, like C<AIX> and C<OS/2>. It is a bug of C<Berkeley DB> +which is left unnoticed if C<DB> uses I<forgiving> system malloc(). =item Bad hash @@ -463,11 +275,17 @@ system malloc(). pseudo-hash is not legal. Index values must be at 1 or greater. See L<perlref>. +=item Badly placed ()'s + +(A) You've accidentally run your script through B<csh> instead +of Perl. Check the #! line, or manually feed your script into +Perl yourself. + =item Bad name after %s:: -(F) You started to name a symbol by using a package prefix, and then didn't -finish the symbol. In particular, you can't interpolate outside of quotes, -so +(F) You started to name a symbol by using a package prefix, and then +didn't finish the symbol. In particular, you can't interpolate outside +of quotes, so $var = 'myvar'; $sym = mypack::$var; @@ -479,9 +297,9 @@ is not the same as =item Bad realloc() ignored -(S malloc) An internal routine called realloc() on something that had never been -malloc()ed in the first place. Mandatory, but can be disabled by -setting environment variable C<PERL_BADFREE> to 1. +(S malloc) An internal routine called realloc() on something that had +never been malloc()ed in the first place. Mandatory, but can be disabled +by setting environment variable C<PERL_BADFREE> to 1. =item Bad symbol for array @@ -490,60 +308,63 @@ wasn't a symbol table entry. =item Bad symbol for filehandle -(P) An internal request asked to add a filehandle entry to something that -wasn't a symbol table entry. +(P) An internal request asked to add a filehandle entry to something +that wasn't a symbol table entry. =item Bad symbol for hash (P) An internal request asked to add a hash entry to something that wasn't a symbol table entry. -=item Badly placed ()'s - -(A) You've accidentally run your script through B<csh> instead -of Perl. Check the #! line, or manually feed your script into -Perl yourself. - -=item Bareword "%s" not allowed while "strict subs" in use - -(F) With "strict subs" in use, a bareword is only allowed as a -subroutine identifier, in curly brackets or to the left of the "=>" symbol. -Perhaps you need to predeclare a subroutine? - -=item Bareword "%s" refers to nonexistent package - -(W bareword) You used a qualified bareword of the form C<Foo::>, but -the compiler saw no other uses of that namespace before that point. -Perhaps you need to predeclare a package? - =item Bareword found in conditional -(W bareword) The compiler found a bareword where it expected a conditional, -which often indicates that an || or && was parsed as part of the -last argument of the previous construct, for example: +(W bareword) The compiler found a bareword where it expected a +conditional, which often indicates that an || or && was parsed as part +of the last argument of the previous construct, for example: open FOO || die; -It may also indicate a misspelled constant that has been interpreted -as a bareword: +It may also indicate a misspelled constant that has been interpreted as +a bareword: use constant TYPO => 1; if (TYOP) { print "foo" } The C<strict> pragma is useful in avoiding such errors. +=item Bareword "%s" not allowed while "strict subs" in use + +(F) With "strict subs" in use, a bareword is only allowed as a +subroutine identifier, in curly brackets or to the left of the "=>" +symbol. Perhaps you need to predeclare a subroutine? + +=item Bareword "%s" refers to nonexistent package + +(W bareword) You used a qualified bareword of the form C<Foo::>, but the +compiler saw no other uses of that namespace before that point. Perhaps +you need to predeclare a package? + =item BEGIN failed--compilation aborted -(F) An untrapped exception was raised while executing a BEGIN subroutine. -Compilation stops immediately and the interpreter is exited. +(F) An untrapped exception was raised while executing a BEGIN +subroutine. Compilation stops immediately and the interpreter is +exited. =item BEGIN not safe after errors--compilation aborted (F) Perl found a C<BEGIN {}> subroutine (or a C<use> directive, which -implies a C<BEGIN {}>) after one or more compilation errors had -already occurred. Since the intended environment for the C<BEGIN {}> -could not be guaranteed (due to the errors), and since subsequent code -likely depends on its correct operation, Perl just gave up. +implies a C<BEGIN {}>) after one or more compilation errors had already +occurred. Since the intended environment for the C<BEGIN {}> could not +be guaranteed (due to the errors), and since subsequent code likely +depends on its correct operation, Perl just gave up. + +=item \1 better written as $1 + +(W syntax) Outside of patterns, backreferences live on as variables. +The use of backslashes is grandfathered on the right-hand side of a +substitution, but stylistically it's better to use the variable form +because other Perl programmers will expect it, and it works better if +there are more than 9 backreferences. =item Binary number > 0b11111111111111111111111111111111 non-portable @@ -553,8 +374,8 @@ L<perlport> for more on portability concerns. =item bind() on closed socket %s -(W closed) You tried to do a bind on a closed socket. Did you forget to check -the return value of your socket() call? See L<perlfunc/bind>. +(W closed) You tried to do a bind on a closed socket. Did you forget to +check the return value of your socket() call? See L<perlfunc/bind>. =item Bit vector size > 32 non-portable @@ -562,108 +383,78 @@ the return value of your socket() call? See L<perlfunc/bind>. =item Bizarre copy of %s in %s -(P) Perl detected an attempt to copy an internal value that is not copiable. +(P) Perl detected an attempt to copy an internal value that is not +copyable. + +=item B<-P> not allowed for setuid/setgid script + +(F) The script would have to be opened by the C preprocessor by name, +which provides a race condition that breaks security. =item Buffer overflow in prime_env_iter: %s -(W internal) A warning peculiar to VMS. While Perl was preparing to iterate over -%ENV, it encountered a logical name or symbol definition which was too long, -so it was truncated to the string shown. +(W internal) A warning peculiar to VMS. While Perl was preparing to +iterate over %ENV, it encountered a logical name or symbol definition +which was too long, so it was truncated to the string shown. =item Callback called exit (F) A subroutine invoked from an external package via call_sv() exited by calling exit. -=item Can't "goto" out of a pseudo block - -(F) A "goto" statement was executed to jump out of what might look -like a block, except that it isn't a proper block. This usually -occurs if you tried to jump out of a sort() block or subroutine, which -is a no-no. See L<perlfunc/goto>. - -=item Can't "goto" into the middle of a foreach loop - -(F) A "goto" statement was executed to jump into the middle of a -foreach loop. You can't get there from here. See L<perlfunc/goto>. - -=item Can't "last" outside a loop block - -(F) A "last" statement was executed to break out of the current block, -except that there's this itty bitty problem called there isn't a -current block. Note that an "if" or "else" block doesn't count as a -"loopish" block, as doesn't a block given to sort(), map() or grep(). -You can usually double the curlies to get the same effect though, -because the inner curlies will be considered a block that loops once. -See L<perlfunc/last>. - -=item Can't "next" outside a loop block - -(F) A "next" statement was executed to reiterate the current block, but -there isn't a current block. Note that an "if" or "else" block doesn't -count as a "loopish" block, as doesn't a block given to sort(), map() -or grep(). You can usually double the curlies to get the same effect -though, because the inner curlies will be considered a block that -loops once. See L<perlfunc/next>. - -=item Can't read CRTL environ +=item %s() called too early to check prototype -(S) A warning peculiar to VMS. Perl tried to read an element of %ENV -from the CRTL's internal environment array and discovered the array was -missing. You need to figure out where your CRTL misplaced its environ -or define F<PERL_ENV_TABLES> (see L<perlvms>) so that environ is not searched. +(W prototype) You've called a function that has a prototype before the +parser saw a definition or declaration for it, and Perl could not check +that the call conforms to the prototype. You need to either add an +early prototype declaration for the subroutine in question, or move the +subroutine definition ahead of the call to get proper prototype +checking. Alternatively, if you are certain that you're calling the +function correctly, you may put an ampersand before the name to avoid +the warning. See L<perlsub>. -=item Can't "redo" outside a loop block +=item / cannot take a count -(F) A "redo" statement was executed to restart the current block, but -there isn't a current block. Note that an "if" or "else" block doesn't -count as a "loopish" block, as doesn't a block given to sort(), map() -or grep(). You can usually double the curlies to get the same effect -though, because the inner curlies will be considered a block that -loops once. See L<perlfunc/redo>. +(F) You had an unpack template indicating a counted-length string, but +you have also specified an explicit size for the string. See +L<perlfunc/pack>. =item Can't bless non-reference value (F) Only hard references may be blessed. This is how Perl "enforces" encapsulation of objects. See L<perlobj>. -=item Can't break at that line - -(S internal) A warning intended to only be printed while running within the debugger, indicating -the line number specified wasn't the location of a statement that could -be stopped at. - =item Can't call method "%s" in empty package "%s" (F) You called a method correctly, and it correctly indicated a package functioning as a class, but that package doesn't have ANYTHING defined in it, let alone methods. See L<perlobj>. -=item Can't call method "%s" on unblessed reference - -(F) A method call must know in what package it's supposed to run. It -ordinarily finds this out from the object reference you supply, but -you didn't supply an object reference in this case. A reference isn't -an object reference until it has been blessed. See L<perlobj>. - -=item Can't call method "%s" without a package or object reference +=item Can't call method "%s" on an undefined value (F) You used the syntax of a method call, but the slot filled by the -object reference or package name contains an expression that returns -a defined value which is neither an object reference nor a package name. -Something like this will reproduce the error: +object reference or package name contains an undefined value. Something +like this will reproduce the error: - $BADREF = 42; + $BADREF = undef; process $BADREF 1,2,3; $BADREF->process(1,2,3); -=item Can't call method "%s" on an undefined value +=item Can't call method "%s" on unblessed reference + +(F) A method call must know in what package it's supposed to run. It +ordinarily finds this out from the object reference you supply, but you +didn't supply an object reference in this case. A reference isn't an +object reference until it has been blessed. See L<perlobj>. + +=item Can't call method "%s" without a package or object reference (F) You used the syntax of a method call, but the slot filled by the -object reference or package name contains an undefined value. +object reference or package name contains an expression that returns a +defined value which is neither an object reference nor a package name. Something like this will reproduce the error: - $BADREF = undef; + $BADREF = 42; process $BADREF 1,2,3; $BADREF->process(1,2,3); @@ -674,7 +465,14 @@ that you can chdir to, possibly because it doesn't exist. =item Can't check filesystem of script "%s" for nosuid -(P) For some reason you can't check the filesystem of the script for nosuid. +(P) For some reason you can't check the filesystem of the script for +nosuid. + +=item Can't coerce array into hash + +(F) You used an array where a hash was expected, but the array has no +information on how to map from keys to array indices. You can do that +only with arrays that have a hash reference at index 0. =item Can't coerce %s to integer in %s @@ -701,16 +499,10 @@ but then $foo no longer contains a glob. (F) Certain types of SVs, in particular real symbol table entries (typeglobs), can't be forced to stop being what they are. -=item Can't coerce array into hash - -(F) You used an array where a hash was expected, but the array has no -information on how to map from keys to array indices. You can do that -only with arrays that have a hash reference at index 0. - =item Can't create pipe mailbox -(P) An error peculiar to VMS. The process is suffering from exhausted quotas -or other plumbing problems. +(P) An error peculiar to VMS. The process is suffering from exhausted +quotas or other plumbing problems. =item Can't declare class for non-scalar %s in "%s" @@ -723,15 +515,21 @@ for other types of variables in future. (F) Only scalar, array, and hash variables may be declared as "my" or "our" variables. They must have ordinary identifiers as names. +=item Can't do inplace edit: %s is not a regular file + +(S inplace) You tried to use the B<-i> switch on a special file, such as +a file in /dev, or a FIFO. The file was ignored. + =item Can't do inplace edit on %s: %s -(S inplace) The creation of the new file failed for the indicated reason. +(S inplace) The creation of the new file failed for the indicated +reason. =item Can't do inplace edit without backup -(F) You're on a system such as MS-DOS that gets confused if you try reading -from a deleted (but still opened) file. You have to say C<-i.bak>, or some -such. +(F) You're on a system such as MS-DOS that gets confused if you try +reading from a deleted (but still opened) file. You have to say +C<-i.bak>, or some such. =item Can't do inplace edit: %s would not be unique @@ -739,15 +537,16 @@ such. characters and Perl was unable to create a unique filename during inplace editing with the B<-i> switch. The file was ignored. -=item Can't do inplace edit: %s is not a regular file +=item Can't do {n,m} with n > m before << HERE in regex m/%s/ -(S inplace) You tried to use the B<-i> switch on a special file, such as a file in -/dev, or a FIFO. The file was ignored. +(F) Minima must be less than or equal to maxima. If you really want your +regexp to match something 0 times, just put {0}. The << HERE shows in the +regular expression about where the problem was discovered. See L<perlre>. =item Can't do setegid! -(P) The setegid() call failed for some reason in the setuid emulator -of suidperl. +(P) The setegid() call failed for some reason in the setuid emulator of +suidperl. =item Can't do seteuid! @@ -755,134 +554,161 @@ of suidperl. =item Can't do setuid -(F) This typically means that ordinary perl tried to exec suidperl to -do setuid emulation, but couldn't exec it. It looks for a name of the -form sperl5.000 in the same directory that the perl executable resides -under the name perl5.000, typically /usr/local/bin on Unix machines. -If the file is there, check the execute permissions. If it isn't, ask -your sysadmin why he and/or she removed it. +(F) This typically means that ordinary perl tried to exec suidperl to do +setuid emulation, but couldn't exec it. It looks for a name of the form +sperl5.000 in the same directory that the perl executable resides under +the name perl5.000, typically /usr/local/bin on Unix machines. If the +file is there, check the execute permissions. If it isn't, ask your +sysadmin why he and/or she removed it. =item Can't do waitpid with flags -(F) This machine doesn't have either waitpid() or wait4(), so only waitpid() -without flags is emulated. - -=item Can't do {n,m} with n > m - -(F) Minima must be less than or equal to maxima. If you really want -your regexp to match something 0 times, just put {0}. See L<perlre>. +(F) This machine doesn't have either waitpid() or wait4(), so only +waitpid() without flags is emulated. =item Can't emulate -%s on #! line -(F) The #! line specifies a switch that doesn't make sense at this point. -For example, it'd be kind of silly to put a B<-x> on the #! line. +(F) The #! line specifies a switch that doesn't make sense at this +point. For example, it'd be kind of silly to put a B<-x> on the #! +line. =item Can't exec "%s": %s -(W exec) An system(), exec(), or piped open call could not execute the named -program for the indicated reason. Typical reasons include: the permissions -were wrong on the file, the file wasn't found in C<$ENV{PATH}>, the -executable in question was compiled for another architecture, or the -#! line in a script points to an interpreter that can't be run for -similar reasons. (Or maybe your system doesn't support #! at all.) +(W exec) An system(), exec(), or piped open call could not execute the +named program for the indicated reason. Typical reasons include: the +permissions were wrong on the file, the file wasn't found in +C<$ENV{PATH}>, the executable in question was compiled for another +architecture, or the #! line in a script points to an interpreter that +can't be run for similar reasons. (Or maybe your system doesn't support +#! at all.) =item Can't exec %s -(F) Perl was trying to execute the indicated program for you because that's -what the #! line said. If that's not what you wanted, you may need to -mention "perl" on the #! line somewhere. +(F) Perl was trying to execute the indicated program for you because +that's what the #! line said. If that's not what you wanted, you may +need to mention "perl" on the #! line somewhere. =item Can't execute %s -(F) You used the B<-S> switch, but the copies of the script to execute found -in the PATH did not have correct permissions. +(F) You used the B<-S> switch, but the copies of the script to execute +found in the PATH did not have correct permissions. -=item Can't find %s on PATH, '.' not in PATH +=item Can't find an opnumber for "%s" -(F) You used the B<-S> switch, but the script to execute could not be found -in the PATH, or at least not with the correct permissions. The script -exists in the current directory, but PATH prohibits running it. +(F) A string of a form C<CORE::word> was given to prototype(), but there +is no builtin with the name C<word>. + +=item Can't find label %s + +(F) You said to goto a label that isn't mentioned anywhere that it's +possible for us to go to. See L<perlfunc/goto>. =item Can't find %s on PATH -(F) You used the B<-S> switch, but the script to execute could not be found -in the PATH. +(F) You used the B<-S> switch, but the script to execute could not be +found in the PATH. -=item Can't find label %s +=item Can't find %s on PATH, '.' not in PATH -(F) You said to goto a label that isn't mentioned anywhere that it's possible -for us to go to. See L<perlfunc/goto>. +(F) You used the B<-S> switch, but the script to execute could not be +found in the PATH, or at least not with the correct permissions. The +script exists in the current directory, but PATH prohibits running it. =item Can't find string terminator %s anywhere before EOF -(F) Perl strings can stretch over multiple lines. This message means that -the closing delimiter was omitted. Because bracketed quotes count nesting -levels, the following is missing its final parenthesis: +(F) Perl strings can stretch over multiple lines. This message means +that the closing delimiter was omitted. Because bracketed quotes count +nesting levels, the following is missing its final parenthesis: print q(The character '(' starts a side comment.); -If you're getting this error from a here-document, you may have -included unseen whitespace before or after your closing tag. A good -programmer's editor will have a way to help you find these characters. +If you're getting this error from a here-document, you may have included +unseen whitespace before or after your closing tag. A good programmer's +editor will have a way to help you find these characters. + +=item Can't find %s property definition %s + +(F) You may have tried to use C<\p> which means a Unicode property for +example \p{Lu} is all uppercase letters. Escape the C<\p>, either +C<\\p> (just the C<\p>) or by C<\Q\p> (the rest of the string, until +possible C<\E>). =item Can't fork -(F) A fatal error occurred while trying to fork while opening a pipeline. +(F) A fatal error occurred while trying to fork while opening a +pipeline. =item Can't get filespec - stale stat buffer? -(S) A warning peculiar to VMS. This arises because of the difference between -access checks under VMS and under the Unix model Perl assumes. Under VMS, -access checks are done by filename, rather than by bits in the stat buffer, so -that ACLs and other protections can be taken into account. Unfortunately, Perl -assumes that the stat buffer contains all the necessary information, and passes -it, instead of the filespec, to the access checking routine. It will try to -retrieve the filespec using the device name and FID present in the stat buffer, -but this works only if you haven't made a subsequent call to the CRTL stat() -routine, because the device name is overwritten with each call. If this warning -appears, the name lookup failed, and the access checking routine gave up and -returned FALSE, just to be conservative. (Note: The access checking routine -knows about the Perl C<stat> operator and file tests, so you shouldn't ever -see this warning in response to a Perl command; it arises only if some internal -code takes stat buffers lightly.) +(S) A warning peculiar to VMS. This arises because of the difference +between access checks under VMS and under the Unix model Perl assumes. +Under VMS, access checks are done by filename, rather than by bits in +the stat buffer, so that ACLs and other protections can be taken into +account. Unfortunately, Perl assumes that the stat buffer contains all +the necessary information, and passes it, instead of the filespec, to +the access checking routine. It will try to retrieve the filespec using +the device name and FID present in the stat buffer, but this works only +if you haven't made a subsequent call to the CRTL stat() routine, +because the device name is overwritten with each call. If this warning +appears, the name lookup failed, and the access checking routine gave up +and returned FALSE, just to be conservative. (Note: The access checking +routine knows about the Perl C<stat> operator and file tests, so you +shouldn't ever see this warning in response to a Perl command; it arises +only if some internal code takes stat buffers lightly.) =item Can't get pipe mailbox device name -(P) An error peculiar to VMS. After creating a mailbox to act as a pipe, Perl -can't retrieve its name for later use. +(P) An error peculiar to VMS. After creating a mailbox to act as a +pipe, Perl can't retrieve its name for later use. =item Can't get SYSGEN parameter value for MAXBUF (P) An error peculiar to VMS. Perl asked $GETSYI how big you want your mailbox buffers to be, and didn't get an answer. -=item Can't goto subroutine outside a subroutine +=item Can't "goto" into the middle of a foreach loop -(F) The deeply magical "goto subroutine" call can only replace one subroutine -call for another. It can't manufacture one out of whole cloth. In general -you should be calling it out of only an AUTOLOAD routine anyway. See -L<perlfunc/goto>. +(F) A "goto" statement was executed to jump into the middle of a foreach +loop. You can't get there from here. See L<perlfunc/goto>. + +=item Can't "goto" out of a pseudo block + +(F) A "goto" statement was executed to jump out of what might look like +a block, except that it isn't a proper block. This usually occurs if +you tried to jump out of a sort() block or subroutine, which is a no-no. +See L<perlfunc/goto>. =item Can't goto subroutine from an eval-string -(F) The "goto subroutine" call can't be used to jump out of an eval "string". -(You can use it to jump out of an eval {BLOCK}, but you probably don't want to.) +(F) The "goto subroutine" call can't be used to jump out of an eval +"string". (You can use it to jump out of an eval {BLOCK}, but you +probably don't want to.) + +=item Can't goto subroutine outside a subroutine + +(F) The deeply magical "goto subroutine" call can only replace one +subroutine call for another. It can't manufacture one out of whole +cloth. In general you should be calling it out of only an AUTOLOAD +routine anyway. See L<perlfunc/goto>. =item Can't ignore signal CHLD, forcing to default -(W signal) Perl has detected that it is being run with the SIGCHLD signal -(sometimes known as SIGCLD) disabled. Since disabling this signal -will interfere with proper determination of exit status of child -processes, Perl has reset the signal to its default value. -This situation typically indicates that the parent program under -which Perl may be running (e.g. cron) is being very careless. +(W signal) Perl has detected that it is being run with the SIGCHLD +signal (sometimes known as SIGCLD) disabled. Since disabling this +signal will interfere with proper determination of exit status of child +processes, Perl has reset the signal to its default value. This +situation typically indicates that the parent program under which Perl +may be running (e.g. cron) is being very careless. -=item Can't localize through a reference +=item Can't "last" outside a loop block -(F) You said something like C<local $$ref>, which Perl can't currently -handle, because when it goes to restore the old value of whatever $ref -pointed to after the scope of the local() is finished, it can't be -sure that $ref will still be a reference. +(F) A "last" statement was executed to break out of the current block, +except that there's this itty bitty problem called there isn't a current +block. Note that an "if" or "else" block doesn't count as a "loopish" +block, as doesn't a block given to sort(), map() or grep(). You can +usually double the curlies to get the same effect though, because the +inner curlies will be considered a block that loops once. See +L<perlfunc/last>. =item Can't localize lexical variable %s @@ -893,27 +719,34 @@ package name. =item Can't localize pseudo-hash element -(F) You said something like C<< local $ar->{'key'} >>, where $ar is -a reference to a pseudo-hash. That hasn't been implemented yet, but -you can get a similar effect by localizing the corresponding array -element directly -- C<< local $ar->[$ar->[0]{'key'}] >>. +(F) You said something like C<< local $ar->{'key'} >>, where $ar is a +reference to a pseudo-hash. That hasn't been implemented yet, but you +can get a similar effect by localizing the corresponding array element +directly -- C<< local $ar->[$ar->[0]{'key'}] >>. -=item Can't locate auto/%s.al in @INC +=item Can't localize through a reference -(F) A function (or method) was called in a package which allows autoload, -but there is no function to autoload. Most probable causes are a misprint -in a function/method name or a failure to C<AutoSplit> the file, say, by -doing C<make install>. +(F) You said something like C<local $$ref>, which Perl can't currently +handle, because when it goes to restore the old value of whatever $ref +pointed to after the scope of the local() is finished, it can't be sure +that $ref will still be a reference. =item Can't locate %s (F) You said to C<do> (or C<require>, or C<use>) a file that couldn't be found. Perl looks for the file in all the locations mentioned in @INC, -unless the file name included the full path to the file. Perhaps you need -to set the PERL5LIB or PERL5OPT environment variable to say where the extra -library is, or maybe the script needs to add the library name to @INC. Or -maybe you just misspelled the name of the file. See L<perlfunc/require> -and L<lib>. +unless the file name included the full path to the file. Perhaps you +need to set the PERL5LIB or PERL5OPT environment variable to say where +the extra library is, or maybe the script needs to add the library name +to @INC. Or maybe you just misspelled the name of the file. See +L<perlfunc/require> and L<lib>. + +=item Can't locate auto/%s.al in @INC + +(F) A function (or method) was called in a package which allows +autoload, but there is no function to autoload. Most probable causes +are a misprint in a function/method name or a failure to C<AutoSplit> +the file, say, by doing C<make install>. =item Can't locate object method "%s" via package "%s" @@ -921,88 +754,123 @@ and L<lib>. functioning as a class, but that package doesn't define that particular method, nor does any of its base classes. See L<perlobj>. +=item (perhaps you forgot to load "%s"?) + +(F) This is an educated guess made in conjunction with the message +"Can't locate object method \"%s\" via package \"%s\"". It often means +that a method requires a package that has not been loaded. + =item Can't locate package %s for @%s::ISA -(W syntax) The @ISA array contained the name of another package that doesn't seem -to exist. +(W syntax) The @ISA array contained the name of another package that +doesn't seem to exist. =item Can't make list assignment to \%ENV on this system -(F) List assignment to %ENV is not supported on some systems, notably VMS. +(F) List assignment to %ENV is not supported on some systems, notably +VMS. =item Can't modify %s in %s -(F) You aren't allowed to assign to the item indicated, or otherwise try to -change it, such as with an auto-increment. - -=item Can't modify non-lvalue subroutine call - -(F) Subroutines meant to be used in lvalue context should be declared as -such, see L<perlsub/"Lvalue subroutines">. +(F) You aren't allowed to assign to the item indicated, or otherwise try +to change it, such as with an auto-increment. =item Can't modify nonexistent substring (P) The internal routine that does assignment to a substr() was handed a NULL. +=item Can't modify non-lvalue subroutine call + +(F) Subroutines meant to be used in lvalue context should be declared as +such, see L<perlsub/"Lvalue subroutines">. + =item Can't msgrcv to read-only var (F) The target of a msgrcv must be modifiable to be used as a receive buffer. +=item Can't "next" outside a loop block + +(F) A "next" statement was executed to reiterate the current block, but +there isn't a current block. Note that an "if" or "else" block doesn't +count as a "loopish" block, as doesn't a block given to sort(), map() or +grep(). You can usually double the curlies to get the same effect +though, because the inner curlies will be considered a block that loops +once. See L<perlfunc/next>. + =item Can't open %s: %s (S inplace) The implicit opening of a file through use of the C<< <> >> filehandle, either implicitly under the C<-n> or C<-p> command-line switches, or explicitly, failed for the indicated reason. Usually this -is because you don't have read permission for a file which you named -on the command line. +is because you don't have read permission for a file which you named on +the command line. =item Can't open bidirectional pipe -(W pipe) You tried to say C<open(CMD, "|cmd|")>, which is not supported. You can -try any of several modules in the Perl library to do this, such as -IPC::Open2. Alternately, direct the pipe's output to a file using ">", -and then read it in under a different file handle. +(W pipe) You tried to say C<open(CMD, "|cmd|")>, which is not supported. +You can try any of several modules in the Perl library to do this, such +as IPC::Open2. Alternately, direct the pipe's output to a file using +">", and then read it in under a different file handle. =item Can't open error file %s as stderr -(F) An error peculiar to VMS. Perl does its own command line redirection, and -couldn't open the file specified after '2>' or '2>>' on the -command line for writing. +(F) An error peculiar to VMS. Perl does its own command line +redirection, and couldn't open the file specified after '2>' or '2>>' on +the command line for writing. =item Can't open input file %s as stdin -(F) An error peculiar to VMS. Perl does its own command line redirection, and -couldn't open the file specified after '<' on the command line for reading. +(F) An error peculiar to VMS. Perl does its own command line +redirection, and couldn't open the file specified after '<' on the +command line for reading. =item Can't open output file %s as stdout -(F) An error peculiar to VMS. Perl does its own command line redirection, and -couldn't open the file specified after '>' or '>>' on the command -line for writing. +(F) An error peculiar to VMS. Perl does its own command line +redirection, and couldn't open the file specified after '>' or '>>' on +the command line for writing. =item Can't open output pipe (name: %s) -(P) An error peculiar to VMS. Perl does its own command line redirection, and -couldn't open the pipe into which to send data destined for stdout. +(P) An error peculiar to VMS. Perl does its own command line +redirection, and couldn't open the pipe into which to send data destined +for stdout. =item Can't open perl script "%s": %s (F) The script you specified can't be opened for the indicated reason. +=item Can't read CRTL environ + +(S) A warning peculiar to VMS. Perl tried to read an element of %ENV +from the CRTL's internal environment array and discovered the array was +missing. You need to figure out where your CRTL misplaced its environ +or define F<PERL_ENV_TABLES> (see L<perlvms>) so that environ is not +searched. + =item Can't redefine active sort subroutine %s (F) Perl optimizes the internal handling of sort subroutines and keeps -pointers into them. You tried to redefine one such sort subroutine when it -was currently active, which is not allowed. If you really want to do +pointers into them. You tried to redefine one such sort subroutine when +it was currently active, which is not allowed. If you really want to do this, you should write C<sort { &func } @x> instead of C<sort func @x>. +=item Can't "redo" outside a loop block + +(F) A "redo" statement was executed to restart the current block, but +there isn't a current block. Note that an "if" or "else" block doesn't +count as a "loopish" block, as doesn't a block given to sort(), map() +or grep(). You can usually double the curlies to get the same effect +though, because the inner curlies will be considered a block that +loops once. See L<perlfunc/redo>. + =item Can't remove %s: %s, skipping file -(S inplace) You requested an inplace edit without creating a backup file. Perl -was unable to remove the original file to replace it with the modified -file. The file was left unmodified. +(S inplace) You requested an inplace edit without creating a backup +file. Perl was unable to remove the original file to replace it with +the modified file. The file was left unmodified. =item Can't rename %s to %s: %s, skipping file @@ -1011,41 +879,55 @@ probably because you don't have write permission to the directory. =item Can't reopen input pipe (name: %s) in binary mode -(P) An error peculiar to VMS. Perl thought stdin was a pipe, and tried to -reopen it to accept binary data. Alas, it failed. +(P) An error peculiar to VMS. Perl thought stdin was a pipe, and tried +to reopen it to accept binary data. Alas, it failed. + +=item Can't resolve method `%s' overloading `%s' in package `%s' + +(F|P) Error resolving overloading specified by a method name (as opposed +to a subroutine reference): no such method callable via the package. If +method name is C<???>, this is an internal error. =item Can't reswap uid and euid -(P) The setreuid() call failed for some reason in the setuid emulator -of suidperl. +(P) The setreuid() call failed for some reason in the setuid emulator of +suidperl. + +=item Can't return %s from lvalue subroutine + +(F) Perl detected an attempt to return illegal lvalues (such as +temporary or readonly values) from a subroutine used as an lvalue. This +is not allowed. + +=item Can't return %s to lvalue scalar context + +(F) You tried to return a complete array or hash from an lvalue subroutine, +but you called the subroutine in a way that made Perl think you meant +to return only one value. You probably meant to write parentheses around +the call to the subroutine, which tell Perl that the call should be in +list context. =item Can't return outside a subroutine (F) The return statement was executed in mainline code, that is, where there was no subroutine call to return out of. See L<perlsub>. -=item Can't return %s from lvalue subroutine - -(F) Perl detected an attempt to return illegal lvalues (such -as temporary or readonly values) from a subroutine used as an lvalue. -This is not allowed. - =item Can't stat script "%s" -(P) For some reason you can't fstat() the script even though you have -it open already. Bizarre. +(P) For some reason you can't fstat() the script even though you have it +open already. Bizarre. =item Can't swap uid and euid -(P) The setreuid() call failed for some reason in the setuid emulator -of suidperl. +(P) The setreuid() call failed for some reason in the setuid emulator of +suidperl. =item Can't take log of %g (F) For ordinary real numbers, you can't take the logarithm of a negative number or zero. There's a Math::Complex package that comes -standard with Perl, though, if you really want to do that for -the negative numbers. +standard with Perl, though, if you really want to do that for the +negative numbers. =item Can't take sqrt of %g @@ -1066,23 +948,46 @@ as the main Perl stack. =item Can't upgrade that kind of scalar -(P) The internal sv_upgrade routine adds "members" to an SV, making -it into a more specialized kind of SV. The top several SV types are -so specialized, however, that they cannot be interconverted. This -message indicates that such a conversion was attempted. +(P) The internal sv_upgrade routine adds "members" to an SV, making it +into a more specialized kind of SV. The top several SV types are so +specialized, however, that they cannot be interconverted. This message +indicates that such a conversion was attempted. =item Can't upgrade to undef -(P) The undefined SV is the bottom of the totem pole, in the scheme -of upgradability. Upgrading to undef indicates an error in the -code calling sv_upgrade. +(P) The undefined SV is the bottom of the totem pole, in the scheme of +upgradability. Upgrading to undef indicates an error in the code +calling sv_upgrade. -=item Can't use %%! because Errno.pm is not available +=item Can't use an undefined value as %s reference + +(F) A value used as either a hard reference or a symbolic reference must +be a defined value. This helps to delurk some insidious errors. + +=item Can't use bareword ("%s") as %s ref while "strict refs" in use + +(F) Only hard references are allowed by "strict refs". Symbolic +references are disallowed. See L<perlref>. + +=item Can't use %! because Errno.pm is not available (F) The first time the %! hash is used, perl automatically loads the Errno.pm module. The Errno module is expected to tie the %! hash to provide symbolic names for C<$!> errno values. +=item Can't use %s for loop variable + +(F) Only a simple scalar variable may be used as a loop variable on a +foreach. + +=item Can't use global %s in "my" + +(F) You tried to declare a magical variable as a lexical variable. This +is not allowed, because the magic can be tied to only one location +(namely the global variable) and it would be incredibly confusing to +have variables in your program that looked like magical variables but +weren't. + =item Can't use "my %s" in sort comparison (F) The global variables $a and $b are reserved for sort comparisons. @@ -1091,46 +996,16 @@ and the variable had earlier been declared as a lexical variable. Either qualify the sort variable with the package name, or rename the lexical variable. -=item Can't use %s for loop variable - -(F) Only a simple scalar variable may be used as a loop variable on a foreach. - =item Can't use %s ref as %s ref (F) You've mixed up your reference types. You have to dereference a reference of the type needed. You can use the ref() function to test the type of the reference, if need be. -=item Can't use \%c to mean $%c in expression - -(W syntax) In an ordinary expression, backslash is a unary operator that creates -a reference to its argument. The use of backslash to indicate a backreference -to a matched substring is valid only as part of a regular expression pattern. -Trying to do this in ordinary Perl code produces a value that prints -out looking like SCALAR(0xdecaf). Use the $1 form instead. - -=item Can't use bareword ("%s") as %s ref while "strict refs" in use - -(F) Only hard references are allowed by "strict refs". Symbolic references -are disallowed. See L<perlref>. - =item Can't use string ("%s") as %s ref while "strict refs" in use -(F) Only hard references are allowed by "strict refs". Symbolic references -are disallowed. See L<perlref>. - -=item Can't use an undefined value as %s reference - -(F) A value used as either a hard reference or a symbolic reference must -be a defined value. This helps to delurk some insidious errors. - -=item Can't use global %s in "my" - -(F) You tried to declare a magical variable as a lexical variable. This is -not allowed, because the magic can be tied to only one location (namely -the global variable) and it would be incredibly confusing to have -variables in your program that looked like magical variables but -weren't. +(F) Only hard references are allowed by "strict refs". Symbolic +references are disallowed. See L<perlref>. =item Can't use subscript on %s @@ -1138,6 +1013,15 @@ weren't. subscript. But to the left of the brackets was an expression that didn't look like an array reference, or anything else subscriptable. +=item Can't use \%c to mean $%c in expression + +(W syntax) In an ordinary expression, backslash is a unary operator that +creates a reference to its argument. The use of backslash to indicate a +backreference to a matched substring is valid only as part of a regular +expression pattern. Trying to do this in ordinary Perl code produces a +value that prints out looking like SCALAR(0xdecaf). Use the $1 form +instead. + =item Can't weaken a nonreference (F) You attempted to weaken something that was not a reference. Only @@ -1145,125 +1029,90 @@ references can be weakened. =item Can't x= to read-only value -(F) You tried to repeat a constant value (often the undefined value) with -an assignment operator, which implies modifying the value itself. +(F) You tried to repeat a constant value (often the undefined value) +with an assignment operator, which implies modifying the value itself. Perhaps you need to copy the value to a temporary, and repeat that. -=item Can't find an opnumber for "%s" - -(F) A string of a form C<CORE::word> was given to prototype(), but -there is no builtin with the name C<word>. - -=item Can't resolve method `%s' overloading `%s' in package `%s' - -(F|P) Error resolving overloading specified by a method name (as -opposed to a subroutine reference): no such method callable via the -package. If method name is C<???>, this is an internal error. - -=item Character class [:%s:] unknown - -(F) The class in the character class [: :] syntax is unknown. -See L<perlre>. - -=item Character class syntax [%s] belongs inside character classes - -(W unsafe) The character class constructs [: :], [= =], and [. .] go -I<inside> character classes, the [] are part of the construct, -for example: /[012[:alpha:]345]/. Note that [= =] and [. .] -are not currently implemented; they are simply placeholders for -future extensions. - -=item Character class syntax [. .] is reserved for future extensions - -(W regexp) Within regular expression character classes ([]) the syntax beginning -with "[." and ending with ".]" is reserved for future extensions. -If you need to represent those character sequences inside a regular -expression character class, just quote the square brackets with the -backslash: "\[." and ".\]". - -=item Character class syntax [= =] is reserved for future extensions - -(W regexp) Within regular expression character classes ([]) the syntax -beginning with "[=" and ending with "=]" is reserved for future extensions. -If you need to represent those character sequences inside a regular -expression character class, just quote the square brackets with the -backslash: "\[=" and "=\]". - =item chmod() mode argument is missing initial 0 (W chmod) A novice will sometimes say chmod 777, $filename -not realizing that 777 will be interpreted as a decimal number, equivalent -to 01411. Octal constants are introduced with a leading 0 in Perl, as in C. +not realizing that 777 will be interpreted as a decimal number, +equivalent to 01411. Octal constants are introduced with a leading 0 in +Perl, as in C. -=item Close on unopened file <%s> +=item close() on unopened filehandle %s (W unopened) You tried to close a filehandle that was never opened. +=item %s: Command not found + +(A) You've accidentally run your script through B<csh> instead of Perl. +Check the #! line, or manually feed your script into Perl yourself. + =item Compilation failed in require (F) Perl could not compile a file specified in a C<require> statement. -Perl uses this generic message when none of the errors that it encountered -were severe enough to halt compilation immediately. +Perl uses this generic message when none of the errors that it +encountered were severe enough to halt compilation immediately. =item Complex regular subexpression recursion limit (%d) exceeded -(W regexp) The regular expression engine uses recursion in complex situations -where back-tracking is required. Recursion depth is limited to 32766, -or perhaps less in architectures where the stack cannot grow +(W regexp) The regular expression engine uses recursion in complex +situations where back-tracking is required. Recursion depth is limited +to 32766, or perhaps less in architectures where the stack cannot grow arbitrarily. ("Simple" and "medium" situations are handled without recursion and are not subject to a limit.) Try shortening the string -under examination; looping in Perl code (e.g. with C<while>) rather -than in the regular expression engine; or rewriting the regular -expression so that it is simpler or backtracks less. (See L<perlbook> -for information on I<Mastering Regular Expressions>.) +under examination; looping in Perl code (e.g. with C<while>) rather than +in the regular expression engine; or rewriting the regular expression so +that it is simpler or backtracks less. (See L<perlfaq2> for information +on I<Mastering Regular Expressions>.) =item connect() on closed socket %s -(W closed) You tried to do a connect on a closed socket. Did you forget to check -the return value of your socket() call? See L<perlfunc/connect>. +(W closed) You tried to do a connect on a closed socket. Did you forget +to check the return value of your socket() call? See +L<perlfunc/connect>. + +=item Constant(%s)%s: %s + +(F) The parser found inconsistencies either while attempting to define +an overloaded constant, or when trying to find the character name +specified in the C<\N{...}> escape. Perhaps you forgot to load the +corresponding C<overload> or C<charnames> pragma? See L<charnames> and +L<overload>. =item Constant is not %s reference (F) A constant value (perhaps declared using the C<use constant> pragma) -is being dereferenced, but it amounts to the wrong type of reference. The -message indicates the type of reference that was expected. This usually -indicates a syntax error in dereferencing the constant value. +is being dereferenced, but it amounts to the wrong type of reference. +The message indicates the type of reference that was expected. This +usually indicates a syntax error in dereferencing the constant value. See L<perlsub/"Constant Functions"> and L<constant>. =item Constant subroutine %s redefined -(S|W redefine) You redefined a subroutine which had previously been eligible for -inlining. See L<perlsub/"Constant Functions"> for commentary and -workarounds. +(S|W redefine) You redefined a subroutine which had previously been +eligible for inlining. See L<perlsub/"Constant Functions"> for +commentary and workarounds. =item Constant subroutine %s undefined -(W misc) You undefined a subroutine which had previously been eligible for -inlining. See L<perlsub/"Constant Functions"> for commentary and +(W misc) You undefined a subroutine which had previously been eligible +for inlining. See L<perlsub/"Constant Functions"> for commentary and workarounds. -=item constant(%s): %s - -(F) The parser found inconsistencies either while attempting to define an -overloaded constant, or when trying to find the character name specified -in the C<\N{...}> escape. Perhaps you forgot to load the corresponding -C<overload> or C<charnames> pragma? See L<charnames> and L<overload>. - =item Copy method did not return a reference -(F) The method which overloads "=" is buggy. See L<overload/Copy Constructor>. +(F) The method which overloads "=" is buggy. See +L<overload/Copy Constructor>. =item CORE::%s is not a keyword (F) The CORE:: namespace is reserved for Perl keywords. -=item Corrupt malloc ptr 0x%lx at 0x%lx - -(P) The malloc package that comes with Perl had an internal failure. - =item corrupted regexp pointers (P) The regular expression engine got confused by what the regular @@ -1271,69 +1120,82 @@ expression compiler gave it. =item corrupted regexp program -(P) The regular expression engine got passed a regexp program without -a valid magic number. +(P) The regular expression engine got passed a regexp program without a +valid magic number. + +=item Corrupt malloc ptr 0x%lx at 0x%lx + +(P) The malloc package that comes with Perl had an internal failure. + +=item C<-p> destination: %s + +(F) An error occurred during the implicit output invoked by the C<-p> +command-line switch. (This output goes to STDOUT unless you've +redirected it with select().) + +=item C<-T> and C<-B> not implemented on filehandles + +(F) Perl can't peek at the stdio buffer of filehandles when it doesn't +know about your kind of stdio. You'll have to use a filename instead. =item Deep recursion on subroutine "%s" -(W recursion) This subroutine has called itself (directly or indirectly) 100 -times more than it has returned. This probably indicates an infinite -recursion, unless you're writing strange benchmark programs, in which -case it indicates something else. +(W recursion) This subroutine has called itself (directly or indirectly) +100 times more than it has returned. This probably indicates an +infinite recursion, unless you're writing strange benchmark programs, in +which case it indicates something else. =item defined(@array) is deprecated -(D deprecated) defined() is not usually useful on arrays because it checks for an -undefined I<scalar> value. If you want to see if the array is empty, -just use C<if (@array) { # not empty }> for example. +(D deprecated) defined() is not usually useful on arrays because it +checks for an undefined I<scalar> value. If you want to see if the +array is empty, just use C<if (@array) { # not empty }> for example. =item defined(%hash) is deprecated -(D deprecated) defined() is not usually useful on hashes because it checks for an -undefined I<scalar> value. If you want to see if the hash is empty, -just use C<if (%hash) { # not empty }> for example. +(D deprecated) defined() is not usually useful on hashes because it +checks for an undefined I<scalar> value. If you want to see if the hash +is empty, just use C<if (%hash) { # not empty }> for example. =item Delimiter for here document is too long -(F) In a here document construct like C<<<FOO>, the label -C<FOO> is too long for Perl to handle. You have to be seriously -twisted to write code that triggers this error. +(F) In a here document construct like C<<<FOO>, the label C<FOO> is too +long for Perl to handle. You have to be seriously twisted to write code +that triggers this error. =item Did not produce a valid header See Server error. +=item %s did not return a true value + +(F) A required (or used) file must return a true value to indicate that +it compiled correctly and ran its initialization code correctly. It's +traditional to end such a file with a "1;", though any true value would +do. See L<perlfunc/require>. + =item (Did you mean &%s instead?) -(W) You probably referred to an imported subroutine &FOO as $FOO or some such. +(W) You probably referred to an imported subroutine &FOO as $FOO or some +such. =item (Did you mean "local" instead of "our"?) -(W misc) Remember that "our" does not localize the declared global variable. -You have declared it again in the same lexical scope, which seems superfluous. +(W misc) Remember that "our" does not localize the declared global +variable. You have declared it again in the same lexical scope, which +seems superfluous. =item (Did you mean $ or @ instead of %?) -(W) You probably said %hash{$key} when you meant $hash{$key} or @hash{@keys}. -On the other hand, maybe you just meant %hash and got carried away. +(W) You probably said %hash{$key} when you meant $hash{$key} or +@hash{@keys}. On the other hand, maybe you just meant %hash and got +carried away. =item Died (F) You passed die() an empty string (the equivalent of C<die "">) or you called it with no args and both C<$@> and C<$_> were empty. -=item (Do you need to predeclare %s?) - -(S) This is an educated guess made in conjunction with the message "%s -found where operator expected". It often means a subroutine or module -name is being referenced that hasn't been declared yet. This may be -because of ordering problems in your file, or because of a missing -"sub", "package", "require", or "use" statement. If you're -referencing something that isn't defined yet, you don't actually have -to define the subroutine or package before the current location. You -can use an empty "sub foo;" or "package FOO;" to enter a "forward" -declaration. - =item Document contains no data See Server error. @@ -1346,24 +1208,29 @@ See Server error. (P) This should have been caught by safemalloc() instead. +=item (Do you need to predeclare %s?) + +(S) This is an educated guess made in conjunction with the message "%s +found where operator expected". It often means a subroutine or module +name is being referenced that hasn't been declared yet. This may be +because of ordering problems in your file, or because of a missing +"sub", "package", "require", or "use" statement. If you're referencing +something that isn't defined yet, you don't actually have to define the +subroutine or package before the current location. You can use an empty +"sub foo;" or "package FOO;" to enter a "forward" declaration. + =item Duplicate free() ignored -(S malloc) An internal routine called free() on something that had already -been freed. +(S malloc) An internal routine called free() on something that had +already been freed. =item elseif should be elsif -(S) There is no keyword "elseif" in Perl because Larry thinks it's -ugly. Your code will be interpreted as an attempt to call a method -named "elseif" for the class returned by the following block. This is +(S) There is no keyword "elseif" in Perl because Larry thinks it's ugly. +Your code will be interpreted as an attempt to call a method named +"elseif" for the class returned by the following block. This is unlikely to be what you want. -=item %s failed--call queue aborted - -(F) An untrapped exception was raised while executing a CHECK, INIT, or -END subroutine. Processing of the remainder of the queue of such -routines has been prematurely ended. - =item entering effective %s failed (F) While under the C<use filetest> pragma, switching the real and @@ -1373,30 +1240,30 @@ effective uids or gids failed. (F) An error peculiar to VMS. Because Perl may have to deal with file specifications in either VMS or Unix syntax, it converts them to a -single form when it must operate on them directly. Either you've -passed an invalid file specification to Perl, or you've found a -case the conversion routines don't handle. Drat. +single form when it must operate on them directly. Either you've passed +an invalid file specification to Perl, or you've found a case the +conversion routines don't handle. Drat. =item %s: Eval-group in insecure regular expression -(F) Perl detected tainted data when trying to compile a regular expression -that contains the C<(?{ ... })> zero-width assertion, which is unsafe. -See L<perlre/(?{ code })>, and L<perlsec>. +(F) Perl detected tainted data when trying to compile a regular +expression that contains the C<(?{ ... })> zero-width assertion, which +is unsafe. See L<perlre/(?{ code })>, and L<perlsec>. -=item %s: Eval-group not allowed, use re 'eval' +=item %s: Eval-group not allowed at run time -(F) A regular expression contained the C<(?{ ... })> zero-width assertion, -but that construct is only allowed when the C<use re 'eval'> pragma is -in effect. See L<perlre/(?{ code })>. +(F) Perl tried to compile a regular expression containing the +C<(?{ ... })> zero-width assertion at run time, as it would when the +pattern contains interpolated values. Since that is a security risk, it +is not allowed. If you insist, you may still do this by explicitly +building the pattern from an interpolated string at run time and using +that in an eval(). See L<perlre/(?{ code })>. -=item %s: Eval-group not allowed at run time +=item %s: Eval-group not allowed, use re 'eval' -(F) Perl tried to compile a regular expression containing the C<(?{ ... })> -zero-width assertion at run time, as it would when the pattern contains -interpolated values. Since that is a security risk, it is not allowed. -If you insist, you may still do this by explicitly building the pattern -from an interpolated string at run time and using that in an eval(). -See L<perlre/(?{ code })>. +(F) A regular expression contained the C<(?{ ... })> zero-width +assertion, but that construct is only allowed when the C<use re 'eval'> +pragma is in effect. See L<perlre/(?{ code })>. =item Excessively long <> operator @@ -1411,97 +1278,112 @@ variable and glob that. =item Exiting eval via %s -(W exiting) You are exiting an eval by unconventional means, such as -a goto, or a loop control statement. +(W exiting) You are exiting an eval by unconventional means, such as a +goto, or a loop control statement. =item Exiting format via %s -(W exiting) You are exiting an eval by unconventional means, such as -a goto, or a loop control statement. +(W exiting) You are exiting an eval by unconventional means, such as a +goto, or a loop control statement. =item Exiting pseudo-block via %s -(W exiting) You are exiting a rather special block construct (like a sort block or -subroutine) by unconventional means, such as a goto, or a loop control -statement. See L<perlfunc/sort>. +(W exiting) You are exiting a rather special block construct (like a +sort block or subroutine) by unconventional means, such as a goto, or a +loop control statement. See L<perlfunc/sort>. =item Exiting subroutine via %s -(W exiting) You are exiting a subroutine by unconventional means, such as -a goto, or a loop control statement. +(W exiting) You are exiting a subroutine by unconventional means, such +as a goto, or a loop control statement. =item Exiting substitution via %s -(W exiting) You are exiting a substitution by unconventional means, such as -a return, a goto, or a loop control statement. +(W exiting) You are exiting a substitution by unconventional means, such +as a return, a goto, or a loop control statement. =item Explicit blessing to '' (assuming package main) (W misc) You are blessing a reference to a zero length string. This has the effect of blessing the reference into the package main. This is -usually not what you want. Consider providing a default target -package, e.g. bless($ref, $p || 'MyPackage'); +usually not what you want. Consider providing a default target package, +e.g. bless($ref, $p || 'MyPackage'); + +=item %s: Expression syntax + +(A) You've accidentally run your script through B<csh> instead of Perl. +Check the #! line, or manually feed your script into Perl yourself. + +=item %s failed--call queue aborted + +(F) An untrapped exception was raised while executing a CHECK, INIT, or +END subroutine. Processing of the remainder of the queue of such +routines has been prematurely ended. =item false [] range "%s" in regexp -(W regexp) A character class range must start and end at a literal character, not -another character class like C<\d> or C<[:alpha:]>. The "-" in your false -range is interpreted as a literal "-". Consider quoting the "-", "\-". -See L<perlre>. +(W regexp) A character class range must start and end at a literal +character, not another character class like C<\d> or C<[:alpha:]>. The +"-" in your false range is interpreted as a literal "-". Consider +quoting the "-", "\-". See L<perlre>. =item Fatal VMS error at %s, line %d -(P) An error peculiar to VMS. Something untoward happened in a VMS system -service or RTL routine; Perl's exit status should provide more details. The -filename in "at %s" and the line number in "line %d" tell you which section of -the Perl source code is distressed. +(P) An error peculiar to VMS. Something untoward happened in a VMS +system service or RTL routine; Perl's exit status should provide more +details. The filename in "at %s" and the line number in "line %d" tell +you which section of the Perl source code is distressed. =item fcntl is not implemented (F) Your machine apparently doesn't implement fcntl(). What is this, a PDP-11 or something? -=item Filehandle %s never opened - -(W unopened) An I/O operation was attempted on a filehandle that was never initialized. -You need to do an open() or a socket() call, or call a constructor from -the FileHandle package. - =item Filehandle %s opened only for input -(W io) You tried to write on a read-only filehandle. If you -intended it to be a read-write filehandle, you needed to open it with -"+<" or "+>" or "+>>" instead of with "<" or nothing. If -you intended only to write the file, use ">" or ">>". See -L<perlfunc/open>. +(W io) You tried to write on a read-only filehandle. If you intended it +to be a read-write filehandle, you needed to open it with "+<" or "+>" +or "+>>" instead of with "<" or nothing. If you intended only to write +the file, use ">" or ">>". See L<perlfunc/open>. =item Filehandle %s opened only for output -(W io) You tried to read from a filehandle opened only for writing. If you -intended it to be a read/write filehandle, you needed to open it with -"+<" or "+>" or "+>>" instead of with "<" or nothing. If -you intended only to read from the file, use "<". See -L<perlfunc/open>. +(W io) You tried to read from a filehandle opened only for writing. If +you intended it to be a read/write filehandle, you needed to open it +with "+<" or "+>" or "+>>" instead of with "<" or nothing. If you +intended only to read from the file, use "<". See L<perlfunc/open>. =item Final $ should be \$ or $name (F) You must now decide whether the final $ in a string was meant to be -a literal dollar sign, or was meant to introduce a variable name -that happens to be missing. So you have to put either the backslash or -the name. +a literal dollar sign, or was meant to introduce a variable name that +happens to be missing. So you have to put either the backslash or the +name. =item Final @ should be \@ or @name (F) You must now decide whether the final @ in a string was meant to be -a literal "at" sign, or was meant to introduce a variable name -that happens to be missing. So you have to put either the backslash or -the name. +a literal "at" sign, or was meant to introduce a variable name that +happens to be missing. So you have to put either the backslash or the +name. =item flock() on closed filehandle %s -(W closed) The filehandle you're attempting to flock() got itself closed some -time before now. Check your logic flow. flock() operates on filehandles. -Are you attempting to call flock() on a dirhandle by the same name? +(W closed) The filehandle you're attempting to flock() got itself closed +some time before now. Check your logic flow. flock() operates on +filehandles. Are you attempting to call flock() on a dirhandle by the +same name? + +=item Quantifier follows nothing before << HERE in regex m/%s/ + +(F) You started a regular expression with a quantifier. Backslash it if you +meant it literally. The << HERE shows in the regular expression about where the +problem was discovered. See L<perlre>. + +=item Format not terminated + +(F) A format must be terminated by a line with a solitary dot. Perl got +to the end of your file without finding such a line. =item Format %s redefined @@ -1512,11 +1394,6 @@ Are you attempting to call flock() on a dirhandle by the same name? eval "format NAME =..."; } -=item Format not terminated - -(F) A format must be terminated by a line with a solitary dot. Perl got -to the end of your file without finding such a line. - =item Found = in conditional, should be == (W syntax) You said @@ -1529,6 +1406,13 @@ when you meant (or something like that). +=item %s found where operator expected + +(S) The Perl lexer knows whether to expect a term or an operator. If it +sees what it knows to be a term when it was expecting to see an +operator, it gives you this warning. Usually it indicates that an +operator or delimiter was omitted, such as a semicolon. + =item gdbm store returned %d, errno %d, key "%s" (S) A warning from the GDBM_File extension that a store failed. @@ -1541,34 +1425,19 @@ on the Internet. =item get%sname() on closed socket %s -(W closed) You tried to get a socket or peer socket name on a closed socket. -Did you forget to check the return value of your socket() call? +(W closed) You tried to get a socket or peer socket name on a closed +socket. Did you forget to check the return value of your socket() call? =item getpwnam returned invalid UIC %#o for user "%s" (S) A warning peculiar to VMS. The call to C<sys$getuai> underlying the C<getpwnam> operator returned an invalid UIC. -=item glob failed (%s) - -(W glob) Something went wrong with the external program(s) used for C<glob> -and C<< <*.c> >>. Usually, this means that you supplied a C<glob> -pattern that caused the external program to fail and exit with a nonzero -status. If the message indicates that the abnormal exit resulted in a -coredump, this may also mean that your csh (C shell) is broken. If so, -you should change all of the csh-related variables in config.sh: If you -have tcsh, make the variables refer to it as if it were csh (e.g. -C<full_csh='/usr/bin/tcsh'>); otherwise, make them all empty (except that -C<d_csh> should be C<'undef'>) so that Perl will think csh is missing. -In either case, after editing config.sh, run C<./Configure -S> and -rebuild Perl. +=item getsockopt() on closed socket %s -=item Glob not terminated - -(F) The lexer saw a left angle bracket in a place where it was expecting -a term, so it's looking for the corresponding right angle bracket, and not -finding it. Chances are you left some needed parentheses out earlier in -the line, and you really meant a "less than". +(W closed) You tried to get a socket option on a closed socket. Did you +forget to check the return value of your socket() call? See +L<perlfunc/getsockopt>. =item Global symbol "%s" requires explicit package name @@ -1577,21 +1446,56 @@ must either be lexically scoped (using "my"), declared beforehand using "our", or explicitly qualified to say which package the global variable is in (using "::"). +=item glob failed (%s) + +(W glob) Something went wrong with the external program(s) used for +C<glob> and C<< <*.c> >>. Usually, this means that you supplied a +C<glob> pattern that caused the external program to fail and exit with a +nonzero status. If the message indicates that the abnormal exit +resulted in a coredump, this may also mean that your csh (C shell) is +broken. If so, you should change all of the csh-related variables in +config.sh: If you have tcsh, make the variables refer to it as if it +were csh (e.g. C<full_csh='/usr/bin/tcsh'>); otherwise, make them all +empty (except that C<d_csh> should be C<'undef'>) so that Perl will +think csh is missing. In either case, after editing config.sh, run +C<./Configure -S> and rebuild Perl. + +=item Glob not terminated + +(F) The lexer saw a left angle bracket in a place where it was expecting +a term, so it's looking for the corresponding right angle bracket, and +not finding it. Chances are you left some needed parentheses out +earlier in the line, and you really meant a "less than". + +=item Got an error from DosAllocMem + +(P) An error peculiar to OS/2. Most probably you're using an obsolete +version of Perl, and this should not happen anyway. + =item goto must have label (F) Unlike with "next" or "last", you're not allowed to goto an unspecified destination. See L<perlfunc/goto>. +=item %s had compilation errors + +(F) The final summary message when a C<perl -c> fails. + =item Had to create %s unexpectedly -(S internal) A routine asked for a symbol from a symbol table that ought to have -existed already, but for some reason it didn't, and had to be created on -an emergency basis to prevent a core dump. +(S internal) A routine asked for a symbol from a symbol table that ought +to have existed already, but for some reason it didn't, and had to be +created on an emergency basis to prevent a core dump. =item Hash %%s missing the % in argument %d of %s() -(D deprecated) Really old Perl let you omit the % on hash names in some spots. This -is now heavily deprecated. +(D deprecated) Really old Perl let you omit the % on hash names in some +spots. This is now heavily deprecated. + +=item %s has too many errors + +(F) The parser has given up trying to parse the program after 10 errors. +Further error messages would likely be uninformative. =item Hexadecimal number > 0xffffffff non-portable @@ -1603,99 +1507,102 @@ L<perlport> for more on portability concerns. (F) Perl limits identifiers (names for variables, functions, etc.) to about 250 characters for simple names, and somewhat more for compound -names (like C<$A::B>). You've exceeded Perl's limits. Future -versions of Perl are likely to eliminate these arbitrary limitations. +names (like C<$A::B>). You've exceeded Perl's limits. Future versions +of Perl are likely to eliminate these arbitrary limitations. -=item Ill-formed CRTL environ value "%s" +=item Illegal binary digit %s -(W internal) A warning peculiar to VMS. Perl tried to read the CRTL's internal -environ array, and encountered an element without the C<=> delimiter -used to spearate keys from values. The element is ignored. +(F) You used a digit other than 0 or 1 in a binary number. -=item Ill-formed message in prime_env_iter: |%s| +=item Illegal binary digit %s ignored -(W internal) A warning peculiar to VMS. Perl tried to read a logical name -or CLI symbol definition when preparing to iterate over %ENV, and -didn't see the expected delimiter between key and value, so the -line was ignored. +(W digit) You may have tried to use a digit other than 0 or 1 in a +binary number. Interpretation of the binary number stopped before the +offending digit. =item Illegal character %s (carriage return) (F) Perl normally treats carriage returns in the program text as it -would any other whitespace, which means you should never see this -error when Perl was built using standard options. For some reason, -your version of Perl appears to have been built without this support. -Talk to your Perl administrator. +would any other whitespace, which means you should never see this error +when Perl was built using standard options. For some reason, your +version of Perl appears to have been built without this support. Talk +to your Perl administrator. =item Illegal division by zero -(F) You tried to divide a number by 0. Either something was wrong in your -logic, or you need to put a conditional in to guard against meaningless input. +(F) You tried to divide a number by 0. Either something was wrong in +your logic, or you need to put a conditional in to guard against +meaningless input. + +=item Illegal hexadecimal digit %s ignored + +(W digit) You may have tried to use a character other than 0 - 9 or +A - F, a - f in a hexadecimal number. Interpretation of the hexadecimal +number stopped before the illegal character. =item Illegal modulus zero -(F) You tried to divide a number by 0 to get the remainder. Most numbers -don't take to this kindly. +(F) You tried to divide a number by 0 to get the remainder. Most +numbers don't take to this kindly. -=item Illegal binary digit %s +=item Illegal number of bits in vec -(F) You used a digit other than 0 or 1 in a binary number. +(F) The number of bits in vec() (the third argument) must be a power of +two from 1 to 32 (or 64, if your platform supports that). =item Illegal octal digit %s (F) You used an 8 or 9 in a octal number. -=item Illegal binary digit %s ignored - -(W digit) You may have tried to use a digit other than 0 or 1 in a binary number. -Interpretation of the binary number stopped before the offending digit. - =item Illegal octal digit %s ignored -(W digit) You may have tried to use an 8 or 9 in a octal number. Interpretation -of the octal number stopped before the 8 or 9. +(W digit) You may have tried to use an 8 or 9 in a octal number. +Interpretation of the octal number stopped before the 8 or 9. -=item Illegal hexadecimal digit %s ignored +=item Illegal switch in PERL5OPT: %s -(W digit) You may have tried to use a character other than 0 - 9 or A - F, a - f -in a hexadecimal number. Interpretation of the hexadecimal number stopped -before the illegal character. +(X) The PERL5OPT environment variable may only be used to set the +following switches: B<-[DIMUdmw]>. -=item Illegal number of bits in vec +=item Ill-formed CRTL environ value "%s" -(F) The number of bits in vec() (the third argument) must be a power of -two from 1 to 32 (or 64, if your platform supports that). +(W internal) A warning peculiar to VMS. Perl tried to read the CRTL's +internal environ array, and encountered an element without the C<=> +delimiter used to separate keys from values. The element is ignored. -=item Illegal switch in PERL5OPT: %s +=item Ill-formed message in prime_env_iter: |%s| -(X) The PERL5OPT environment variable may only be used to set the -following switches: B<-[DIMUdmw]>. +(W internal) A warning peculiar to VMS. Perl tried to read a logical +name or CLI symbol definition when preparing to iterate over %ENV, and +didn't see the expected delimiter between key and value, so the line was +ignored. + +=item (in cleanup) %s -=item In string, @%s now must be written as \@%s +(W misc) This prefix usually indicates that a DESTROY() method raised +the indicated exception. Since destructors are usually called by the +system at arbitrary points during execution, and often a vast number of +times, the warning is issued only once for any number of failures that +would otherwise result in the same message being repeated. -(F) It used to be that Perl would try to guess whether you wanted an -array interpolated or a literal @. It did this when the string was first -used at runtime. Now strings are parsed at compile time, and ambiguous -instances of @ must be disambiguated, either by prepending a backslash to -indicate a literal, or by declaring (or using) the array within the -program before the string (lexically). (Someday it will simply assume -that an unbackslashed @ interpolates an array.) +Failure of user callbacks dispatched using the C<G_KEEPERR> flag could +also result in this warning. See L<perlcall/G_KEEPERR>. =item Insecure dependency in %s (F) You tried to do something that the tainting mechanism didn't like. -The tainting mechanism is turned on when you're running setuid or setgid, -or when you specify B<-T> to turn it on explicitly. The tainting mechanism -labels all data that's derived directly or indirectly from the user, -who is considered to be unworthy of your trust. If any such data is -used in a "dangerous" operation, you get this error. See L<perlsec> -for more information. +The tainting mechanism is turned on when you're running setuid or +setgid, or when you specify B<-T> to turn it on explicitly. The +tainting mechanism labels all data that's derived directly or indirectly +from the user, who is considered to be unworthy of your trust. If any +such data is used in a "dangerous" operation, you get this error. See +L<perlsec> for more information. =item Insecure directory in %s -(F) You can't use system(), exec(), or a piped open in a setuid or setgid -script if C<$ENV{PATH}> contains a directory that is writable by the world. -See L<perlsec>. +(F) You can't use system(), exec(), or a piped open in a setuid or +setgid script if C<$ENV{PATH}> contains a directory that is writable by +the world. See L<perlsec>. =item Insecure $ENV{%s} while running %s @@ -1707,33 +1614,44 @@ known value, using trustworthy data. See L<perlsec>. =item Integer overflow in %s number -(W overflow) The hexadecimal, octal or binary number you have specified either -as a literal or as an argument to hex() or oct() is too big for your -architecture, and has been converted to a floating point number. On a -32-bit architecture the largest hexadecimal, octal or binary number +(W overflow) The hexadecimal, octal or binary number you have specified +either as a literal or as an argument to hex() or oct() is too big for +your architecture, and has been converted to a floating point number. +On a 32-bit architecture the largest hexadecimal, octal or binary number representable without overflow is 0xFFFFFFFF, 037777777777, or 0b11111111111111111111111111111111 respectively. Note that Perl transparently promotes all numbers to a floating point representation internally--subject to loss of precision errors in subsequent operations. +=item Internal disaster before << HERE in regex m/%s/ + +(P) Something went badly wrong in the regular expression parser. +The << HERE shows in the regular expression about where the problem was +discovered. + + =item Internal inconsistency in tracking vforks -(S) A warning peculiar to VMS. Perl keeps track of the number -of times you've called C<fork> and C<exec>, to determine -whether the current call to C<exec> should affect the current -script or a subprocess (see L<perlvms/"exec LIST">). Somehow, this count -has become scrambled, so Perl is making a guess and treating -this C<exec> as a request to terminate the Perl script -and execute the specified command. +(S) A warning peculiar to VMS. Perl keeps track of the number of times +you've called C<fork> and C<exec>, to determine whether the current call +to C<exec> should affect the current script or a subprocess (see +L<perlvms/"exec LIST">). Somehow, this count has become scrambled, so +Perl is making a guess and treating this C<exec> as a request to +terminate the Perl script and execute the specified command. -=item internal disaster in regexp +=item Internal urp before << HERE in regex m/%s/ -(P) Something went badly wrong in the regular expression parser. +(P) Something went badly awry in the regular expression parser. The <<<HERE +shows in the regular expression about where the problem was discovered. -=item internal urp in regexp at /%s/ -(P) Something went badly awry in the regular expression parser. +=item %s (...) interpreted as function + +(W syntax) You've run afoul of the rule that says that any list operator +followed by parentheses turns into a function, with all the list +operators arguments found inside the parentheses. See +L<perlop/Terms and List Operators (Leftward)>. =item Invalid %s attribute: %s @@ -1742,52 +1660,63 @@ by Perl or by a user-supplied handler. See L<attributes>. =item Invalid %s attributes: %s -The indicated attributes for a subroutine or variable were not recognized -by Perl or by a user-supplied handler. See L<attributes>. +The indicated attributes for a subroutine or variable were not +recognized by Perl or by a user-supplied handler. See L<attributes>. + +=item Invalid conversion in %s: "%s" + +(W printf) Perl does not understand the given format conversion. See +L<perlfunc/sprintf>. =item invalid [] range "%s" in regexp (F) The range specified in a character class had a minimum character greater than the maximum character. See L<perlre>. -=item Invalid conversion in %s: "%s" - -(W printf) Perl does not understand the given format conversion. -See L<perlfunc/sprintf>. - =item Invalid separator character %s in attribute list (F) Something other than a colon or whitespace was seen between the -elements of an attribute list. If the previous attribute -had a parenthesised parameter list, perhaps that list was terminated -too soon. See L<attributes>. +elements of an attribute list. If the previous attribute had a +parenthesised parameter list, perhaps that list was terminated too soon. +See L<attributes>. =item Invalid type in pack: '%s' (F) The given character is not a valid pack type. See L<perlfunc/pack>. -(W pack) The given character is not a valid pack type but used to be silently -ignored. +(W pack) The given character is not a valid pack type but used to be +silently ignored. =item Invalid type in unpack: '%s' -(F) The given character is not a valid unpack type. See L<perlfunc/unpack>. -(W unpack) The given character is not a valid unpack type but used to be silently -ignored. +(F) The given character is not a valid unpack type. See +L<perlfunc/unpack>. +(W unpack) The given character is not a valid unpack type but used to be +silently ignored. =item ioctl is not implemented (F) Your machine apparently doesn't implement ioctl(), which is pretty strange for a machine that supports C. +=item `%s' is not a code reference + +(W) The second (fourth, sixth, ...) argument of overload::constant needs +to be a code reference. Either an anonymous subroutine, or a reference +to a subroutine. + +=item `%s' is not an overloadable type + +(W) You tried to overload a constant type the overload package is unaware of. + =item junk on end of regexp (P) The regular expression parser is confused. =item Label not found for "last %s" -(F) You named a loop to break out of, but you're not currently in a -loop of that name, not even if you count where you were called from. -See L<perlfunc/last>. +(F) You named a loop to break out of, but you're not currently in a loop +of that name, not even if you count where you were called from. See +L<perlfunc/last>. =item Label not found for "next %s" @@ -1808,14 +1737,62 @@ effective uids or gids failed. =item listen() on closed socket %s -(W closed) You tried to do a listen on a closed socket. Did you forget to check -the return value of your socket() call? See L<perlfunc/listen>. +(W closed) You tried to do a listen on a closed socket. Did you forget +to check the return value of your socket() call? See +L<perlfunc/listen>. + +=item Lookbehind longer than %d not implemented at {#} mark in regex %s + +There is an upper limit to the depth of lookbehind in the (?<= +regular expression construct. =item Lvalue subs returning %s not implemented yet (F) Due to limitations in the current implementation, array and hash -values cannot be returned in subroutines used in lvalue context. -See L<perlsub/"Lvalue subroutines">. +values cannot be returned in subroutines used in lvalue context. See +L<perlsub/"Lvalue subroutines">. + +=item Lookbehind longer than %d not implemented before << HERE %s + +(F) There is currently a limit on the length of string which lookbehind can +handle. This restriction may be eased in a future release. The << HERE shows in +the regular expression about where the problem was discovered. + +=item Malformed PERLLIB_PREFIX + +(F) An error peculiar to OS/2. PERLLIB_PREFIX should be of the form + + prefix1;prefix2 + +or + + prefix1 prefix2 + +with nonempty prefix1 and prefix2. If C<prefix1> is indeed a prefix of +a builtin library search path, prefix2 is substituted. The error may +appear if components are not found, or are too long. See +"PERLLIB_PREFIX" in L<perlos2>. + +=item Malformed UTF-8 character (%s) + +Perl detected something that didn't comply with UTF-8 encoding rules. + +=item Malformed UTF-16 surrogate + +Perl thought it was reading UTF-16 encoded character data but while +doing it Perl met a malformed Unicode surrogate. + +=item %s matches null string many times + +(W regexp) The pattern you've specified would be an infinite loop if the +regular expression engine didn't specifically check for that. See +L<perlre>. + +=item % may only be used in unpack + +(F) You can't pack a string by supplying a checksum, because the +checksumming process loses information, and you can't go the other way. +See L<perlfunc/unpack>. =item Method for operation %s not found in package %s during blessing @@ -1836,12 +1813,6 @@ ended earlier on the current line. (W syntax) An underline in a decimal constant wasn't on a 3-digit boundary. -=item Missing $ on loop variable - -(F) Apparently you've been programming in B<csh> too much. Variables are always -mentioned with the $ in Perl, unlike in the shells, where it can vary from -one line to the next. - =item Missing %sbrace%s on \N{} (F) Wrong syntax of character name literal C<\N{charname}> within @@ -1854,8 +1825,20 @@ double-quotish context. =item Missing command in piped open -(W pipe) You used the C<open(FH, "| command")> or C<open(FH, "command |")> -construction, but the command was missing or blank. +(W pipe) You used the C<open(FH, "| command")> or +C<open(FH, "command |")> construction, but the command was missing or +blank. + +=item Missing name in "my sub" + +(F) The reserved syntax for lexically scoped subroutines requires that +they have a name with which they can be found. + +=item Missing $ on loop variable + +(F) Apparently you've been programming in B<csh> too much. Variables +are always mentioned with the $ in Perl, unlike in the shells, where it +can vary from one line to the next. =item (Missing operator before %s?) @@ -1864,9 +1847,15 @@ found where operator expected". Often the missing operator is a comma. =item Missing right curly or square bracket -(F) The lexer counted more opening curly or square brackets than -closing ones. As a general rule, you'll find it's missing near the place -you were last editing. +(F) The lexer counted more opening curly or square brackets than closing +ones. As a general rule, you'll find it's missing near the place you +were last editing. + +=item (Missing semicolon on previous line?) + +(S) This is an educated guess made in conjunction with the message "%s +found where operator expected". Don't automatically put a semicolon on +the previous line just because you saw this message. =item Modification of a read-only value attempted @@ -1879,76 +1868,110 @@ catches that. But an easy way to do the same thing is: Another way is to assign to a substr() that's off the end of the string. -=item Modification of non-creatable array value attempted, subscript %d +Yet another way is to assign to a C<foreach> loop I<VAR> when I<VAR> +is aliased to a constant in the look I<LIST>: + + $x = 1; + foreach my $n ($x, 2) { + $n *= 2; # modifies the $x, but fails on attempt to modify the 2 + } + +=item Modification of non-creatable array value attempted, %s (F) You tried to make an array value spring into existence, and the subscript was probably negative, even counting from end of the array backwards. -=item Modification of non-creatable hash value attempted, subscript "%s" +=item Modification of non-creatable hash value attempted, %s -(P) You tried to make a hash value spring into existence, and it couldn't -be created for some peculiar reason. +(P) You tried to make a hash value spring into existence, and it +couldn't be created for some peculiar reason. =item Module name must be constant (F) Only a bare module name is allowed as the first argument to a "use". +=item Module name required with -%c option + +(F) The C<-M> or C<-m> options say that Perl should load some module, but +you omitted the name of the module. Consult L<perlrun> for full details +about C<-M> and C<-m>. + =item msg%s not implemented (F) You don't have System V message IPC on your system. =item Multidimensional syntax %s not supported -(W syntax) Multidimensional arrays aren't written like C<$foo[1,2,3]>. They're written -like C<$foo[1][2][3]>, as in C. +(W syntax) Multidimensional arrays aren't written like C<$foo[1,2,3]>. +They're written like C<$foo[1][2][3]>, as in C. -=item Missing name in "my sub" +=item / must be followed by a*, A* or Z* + +(F) You had a pack template indicating a counted-length string, +Currently the only things that can have their length counted are a*, A* +or Z*. See L<perlfunc/pack>. -(F) The reserved syntax for lexically scoped subroutines requires that they -have a name with which they can be found. +=item / must be followed by a, A or Z + +(F) You had an unpack template indicating a counted-length string, which +must be followed by one of the letters a, A or Z to indicate what sort +of string is to be unpacked. See L<perlfunc/pack>. + +=item / must follow a numeric type + +(F) You had an unpack template that contained a '#', but this did not +follow some numeric unpack specification. See L<perlfunc/pack>. + +=item "my sub" not yet implemented + +(F) Lexically scoped subroutines are not yet implemented. Don't try +that yet. + +=item "my" variable %s can't be in a package + +(F) Lexically scoped variables aren't in a package, so it doesn't make +sense to try to declare one with a package qualifier on the front. Use +local() if you want to localize a package variable. =item Name "%s::%s" used only once: possible typo (W once) Typographical errors often show up as unique variable names. -If you had a good reason for having a unique name, then just mention -it again somehow to suppress the message. The C<our> declaration is +If you had a good reason for having a unique name, then just mention it +again somehow to suppress the message. The C<our> declaration is provided for this purpose. =item Negative length -(F) You tried to do a read/write/send/recv operation with a buffer length -that is less than 0. This is difficult to imagine. +(F) You tried to do a read/write/send/recv operation with a buffer +length that is less than 0. This is difficult to imagine. -=item nested *?+ in regexp +=item Nested quantifiers before << HERE in regex m/%s/ -(F) You can't quantify a quantifier without intervening parentheses. So -things like ** or +* or ?* are illegal. +(F) You can't quantify a quantifier without intervening parentheses. So +things like ** or +* or ?* are illegal. The << HERE shows in the regular +expression about where the problem was discovered. -Note, however, that the minimal matching quantifiers, C<*?>, C<+?>, and C<??> appear -to be nested quantifiers, but aren't. See L<perlre>. +Note, however, that the minimal matching quantifiers, C<*?>, C<+?>, and +C<??> appear to be nested quantifiers, but aren't. See L<perlre>. -=item No #! line -(F) The setuid emulator requires that scripts have a well-formed #! line -even on machines that don't support the #! construct. +=item %s never introduced + +(S internal) The symbol in question was declared but somehow went out of +scope before it could possibly have been used. =item No %s allowed while running setuid -(F) Certain operations are deemed to be too insecure for a setuid or setgid -script to even be allowed to attempt. Generally speaking there will be -another way to do what you want that is, if not secure, at least securable. -See L<perlsec>. +(F) Certain operations are deemed to be too insecure for a setuid or +setgid script to even be allowed to attempt. Generally speaking there +will be another way to do what you want that is, if not secure, at least +securable. See L<perlsec>. =item No B<-e> allowed in setuid scripts (F) A setuid script can't be specified by the user. -=item No %s specified for -%c - -(F) The indicated command line switch needs a mandatory argument, but -you haven't specified one. - =item No comma allowed after %s (F) A list operator that has a filehandle or "indirect object" is not @@ -1969,18 +1992,17 @@ this error was triggered? =item No command into which to pipe on command line -(F) An error peculiar to VMS. Perl handles its own command line redirection, -and found a '|' at the end of the command line, so it doesn't know where you -want to pipe the output from this command. +(F) An error peculiar to VMS. Perl handles its own command line +redirection, and found a '|' at the end of the command line, so it +doesn't know where you want to pipe the output from this command. =item No DB::DB routine defined -(F) The currently executing code was compiled with the B<-d> switch, -but for some reason the perl5db.pl file (or some facsimile thereof) -didn't define a routine to be called at the beginning of each -statement. Which is odd, because the file should have been required -automatically, and should have blown up the require if it didn't parse -right. +(F) The currently executing code was compiled with the B<-d> switch, but +for some reason the perl5db.pl file (or some facsimile thereof) didn't +define a routine to be called at the beginning of each statement. Which +is odd, because the file should have been required automatically, and +should have blown up the require if it didn't parse right. =item No dbm on this machine @@ -1996,33 +2018,43 @@ ordinary subroutine call. =item No error file after 2> or 2>> on command line -(F) An error peculiar to VMS. Perl handles its own command line redirection, -and found a '2>' or a '2>>' on the command line, but can't find -the name of the file to which to write data destined for stderr. +(F) An error peculiar to VMS. Perl handles its own command line +redirection, and found a '2>' or a '2>>' on the command line, but can't +find the name of the file to which to write data destined for stderr. =item No input file after < on command line -(F) An error peculiar to VMS. Perl handles its own command line redirection, -and found a '<' on the command line, but can't find the name of the file -from which to read data for stdin. +(F) An error peculiar to VMS. Perl handles its own command line +redirection, and found a '<' on the command line, but can't find the +name of the file from which to read data for stdin. + +=item No #! line + +(F) The setuid emulator requires that scripts have a well-formed #! line +even on machines that don't support the #! construct. + +=item "no" not allowed in expression + +(F) The "no" keyword is recognized and executed at compile time, and +returns no useful value. See L<perlmod>. =item No output file after > on command line -(F) An error peculiar to VMS. Perl handles its own command line redirection, -and found a lone '>' at the end of the command line, so it doesn't know -where you wanted to redirect stdout. +(F) An error peculiar to VMS. Perl handles its own command line +redirection, and found a lone '>' at the end of the command line, so it +doesn't know where you wanted to redirect stdout. =item No output file after > or >> on command line -(F) An error peculiar to VMS. Perl handles its own command line redirection, -and found a '>' or a '>>' on the command line, but can't find the -name of the file to which to write data destined for stdout. +(F) An error peculiar to VMS. Perl handles its own command line +redirection, and found a '>' or a '>>' on the command line, but can't +find the name of the file to which to write data destined for stdout. =item No package name allowed for variable %s in "our" -(F) Fully qualified variable names are not allowed in "our" declarations, -because that doesn't make much sense under existing semantics. Such -syntax is reserved for future extensions. +(F) Fully qualified variable names are not allowed in "our" +declarations, because that doesn't make much sense under existing +semantics. Such syntax is reserved for future extensions. =item No Perl script found in input @@ -2041,8 +2073,19 @@ your system. =item No space allowed after -%c -(F) The argument to the indicated command line switch must follow immediately -after the switch, without intervening spaces. +(F) The argument to the indicated command line switch must follow +immediately after the switch, without intervening spaces. + +=item No %s specified for -%c + +(F) The indicated command line switch needs a mandatory argument, but +you haven't specified one. + +=item No such pipe open + +(P) An error peculiar to VMS. The internal routine my_pclose() tried to +close a pipe which hadn't been opened. This should have been caught +earlier as an attempt to close an unopened filehandle. =item No such pseudo-hash field "%s" @@ -2052,36 +2095,23 @@ array indices for that to work. =item No such pseudo-hash field "%s" in variable %s of type %s -(F) You tried to access a field of a typed variable where the type -does not know about the field name. The field names are looked up in -the %FIELDS hash in the type package at compile time. The %FIELDS hash -is usually set up with the 'fields' pragma. - -=item No such pipe open - -(P) An error peculiar to VMS. The internal routine my_pclose() tried to -close a pipe which hadn't been opened. This should have been caught earlier as -an attempt to close an unopened filehandle. +(F) You tried to access a field of a typed variable where the type does +not know about the field name. The field names are looked up in the +%FIELDS hash in the type package at compile time. The %FIELDS hash is +%usually set up with the 'fields' pragma. =item No such signal: SIG%s -(W signal) You specified a signal name as a subscript to %SIG that was not recognized. -Say C<kill -l> in your shell to see the valid signal names on your system. - -=item no UTC offset information; assuming local time is UTC - -(S) A warning peculiar to VMS. Perl was unable to find the local -timezone offset, so it's assuming that local system time is equivalent -to UTC. If it's not, define the logical name F<SYS$TIMEZONE_DIFFERENTIAL> -to translate to the number of seconds which need to be added to UTC to -get local time. +(W signal) You specified a signal name as a subscript to %SIG that was +not recognized. Say C<kill -l> in your shell to see the valid signal +names on your system. =item Not a CODE reference (F) Perl was trying to evaluate a reference to a code value (that is, a subroutine), but found a reference to something else instead. You can -use the ref() function to find out what kind of ref it really was. -See also L<perlref>. +use the ref() function to find out what kind of ref it really was. See +also L<perlref>. =item Not a format reference @@ -2090,16 +2120,22 @@ format, but this indicates you did, and that it didn't exist. =item Not a GLOB reference -(F) Perl was trying to evaluate a reference to a "typeglob" (that is, -a symbol table entry that looks like C<*foo>), but found a reference to -something else instead. You can use the ref() function to find out -what kind of ref it really was. See L<perlref>. +(F) Perl was trying to evaluate a reference to a "typeglob" (that is, a +symbol table entry that looks like C<*foo>), but found a reference to +something else instead. You can use the ref() function to find out what +kind of ref it really was. See L<perlref>. =item Not a HASH reference -(F) Perl was trying to evaluate a reference to a hash value, but -found a reference to something else instead. You can use the ref() -function to find out what kind of ref it really was. See L<perlref>. +(F) Perl was trying to evaluate a reference to a hash value, but found a +reference to something else instead. You can use the ref() function to +find out what kind of ref it really was. See L<perlref>. + +=item Not an ARRAY reference + +(F) Perl was trying to evaluate a reference to an array value, but found +a reference to something else instead. You can use the ref() function +to find out what kind of ref it really was. See L<perlref>. =item Not a perl script @@ -2109,41 +2145,54 @@ mention perl. =item Not a SCALAR reference -(F) Perl was trying to evaluate a reference to a scalar value, but -found a reference to something else instead. You can use the ref() -function to find out what kind of ref it really was. See L<perlref>. +(F) Perl was trying to evaluate a reference to a scalar value, but found +a reference to something else instead. You can use the ref() function +to find out what kind of ref it really was. See L<perlref>. =item Not a subroutine reference (F) Perl was trying to evaluate a reference to a code value (that is, a subroutine), but found a reference to something else instead. You can -use the ref() function to find out what kind of ref it really was. -See also L<perlref>. +use the ref() function to find out what kind of ref it really was. See +also L<perlref>. =item Not a subroutine reference in overload table (F) An attempt was made to specify an entry in an overloading table that doesn't somehow point to a valid subroutine. See L<overload>. -=item Not an ARRAY reference - -(F) Perl was trying to evaluate a reference to an array value, but -found a reference to something else instead. You can use the ref() -function to find out what kind of ref it really was. See L<perlref>. - =item Not enough arguments for %s (F) The function requires more arguments than you specified. =item Not enough format arguments -(W syntax) A format specified more picture fields than the next line supplied. -See L<perlform>. +(W syntax) A format specified more picture fields than the next line +supplied. See L<perlform>. + +=item %s: not found + +(A) You've accidentally run your script through the Bourne shell instead +of Perl. Check the #! line, or manually feed your script into Perl +yourself. + +=item no UTC offset information; assuming local time is UTC + +(S) A warning peculiar to VMS. Perl was unable to find the local +timezone offset, so it's assuming that local system time is equivalent +to UTC. If it's not, define the logical name +F<SYS$TIMEZONE_DIFFERENTIAL> to translate to the number of seconds which +need to be added to UTC to get local time. =item Null filename used -(F) You can't require the null filename, especially because on many machines -that means the current directory! See L<perlfunc/require>. +(F) You can't require the null filename, especially because on many +machines that means the current directory! See L<perlfunc/require>. + +=item NULL OP IN RUN + +(P debugging) Some internal routine called run() with a null opcode +pointer. =item Null picture in formline @@ -2151,10 +2200,6 @@ that means the current directory! See L<perlfunc/require>. specification. It was found to be empty, which probably means you supplied it an uninitialized value. See L<perlform>. -=item NULL OP IN RUN - -(P debugging) Some internal routine called run() with a null opcode pointer. - =item Null realloc (P) An attempt was made to realloc NULL. @@ -2169,36 +2214,53 @@ supplied it an uninitialized value. See L<perlform>. =item Number too long -(F) Perl limits the representation of decimal numbers in programs to about -about 250 characters. You've exceeded that length. Future versions of -Perl are likely to eliminate this arbitrary limitation. In the meantime, -try using scientific notation (e.g. "1e6" instead of "1_000_000"). +(F) Perl limits the representation of decimal numbers in programs to +about about 250 characters. You've exceeded that length. Future +versions of Perl are likely to eliminate this arbitrary limitation. In +the meantime, try using scientific notation (e.g. "1e6" instead of +"1_000_000"). + +=item Octal number in vector unsupported + +(F) Numbers with a leading C<0> are not currently allowed in vectors. +The octal number interpretation of such numbers may be supported in a +future version. =item Octal number > 037777777777 non-portable -(W portable) The octal number you specified is larger than 2**32-1 (4294967295) -and therefore non-portable between systems. See L<perlport> for more -on portability concerns. +(W portable) The octal number you specified is larger than 2**32-1 +(4294967295) and therefore non-portable between systems. See +L<perlport> for more on portability concerns. See also L<perlport> for writing portable code. -=item Octal number in vector unsupported +=item Odd number of arguments for overload::constant -(F) Numbers with a leading C<0> are not currently allowed in vectors. The -octal number interpretation of such numbers may be supported in a future -version. +(W) The call to overload::constant contained an odd number of arguments. +The arguments should come in pairs. =item Odd number of elements in hash assignment -(W misc) You specified an odd number of elements to initialize a hash, which -is odd, because hashes come in key/value pairs. +(W misc) You specified an odd number of elements to initialize a hash, +which is odd, because hashes come in key/value pairs. =item Offset outside string (F) You tried to do a read/write/send/recv operation with an offset -pointing outside the buffer. This is difficult to imagine. -The sole exception to this is that C<sysread()>ing past the buffer -will extend the buffer and zero pad the new area. +pointing outside the buffer. This is difficult to imagine. The sole +exception to this is that C<sysread()>ing past the buffer will extend +the buffer and zero pad the new area. + +=item -%s on unopened filehandle %s + +(W unopened) You tried to invoke a file test operator on a filehandle +that isn't open. Check your logic. See also L<perlfunc/-X>. + +=item %s() on unopened %s %s + +(W unopened) An I/O operation was attempted on a filehandle that was +never initialized. You need to do an open(), a sysopen(), or a socket() +call, or call a constructor from the FileHandle package. =item oops: oopsAV @@ -2210,59 +2272,82 @@ will extend the buffer and zero pad the new area. =item Operation `%s': no method found, %s -(F) An attempt was made to perform an overloaded operation for which -no handler was defined. While some handlers can be autogenerated in -terms of other handlers, there is no default handler for any -operation, unless C<fallback> overloading key is specified to be -true. See L<overload>. +(F) An attempt was made to perform an overloaded operation for which no +handler was defined. While some handlers can be autogenerated in terms +of other handlers, there is no default handler for any operation, unless +C<fallback> overloading key is specified to be true. See L<overload>. =item Operator or semicolon missing before %s -(S ambiguous) You used a variable or subroutine call where the parser was -expecting an operator. The parser has assumed you really meant -to use an operator, but this is highly likely to be incorrect. -For example, if you say "*foo *foo" it will be interpreted as -if you said "*foo * 'foo'". +(S ambiguous) You used a variable or subroutine call where the parser +was expecting an operator. The parser has assumed you really meant to +use an operator, but this is highly likely to be incorrect. For +example, if you say "*foo *foo" it will be interpreted as if you said +"*foo * 'foo'". + +=item "our" variable %s redeclared + +(W misc) You seem to have already declared the same global once before +in the current lexical scope. =item Out of memory! (X) The malloc() function returned 0, indicating there was insufficient -remaining memory (or virtual memory) to satisfy the request. Perl -has no option but to exit immediately. +remaining memory (or virtual memory) to satisfy the request. Perl has +no option but to exit immediately. -=item Out of memory for yacc stack +=item Out of memory during "large" request for %s -(F) The yacc parser wanted to grow its stack so it could continue parsing, -but realloc() wouldn't give it more memory, virtual or otherwise. +(F) The malloc() function returned 0, indicating there was insufficient +remaining memory (or virtual memory) to satisfy the request. However, +the request was judged large enough (compile-time default is 64K), so a +possibility to shut down by trapping this error is granted. =item Out of memory during request for %s -(X|F) The malloc() function returned 0, indicating there was insufficient -remaining memory (or virtual memory) to satisfy the request. +(X|F) The malloc() function returned 0, indicating there was +insufficient remaining memory (or virtual memory) to satisfy the +request. The request was judged to be small, so the possibility to trap it depends on the way perl was compiled. By default it is not trappable. -However, if compiled for this, Perl may use the contents of C<$^M> as -an emergency pool after die()ing with this message. In this case the -error is trappable I<once>. - -=item Out of memory during "large" request for %s - -(F) The malloc() function returned 0, indicating there was insufficient -remaining memory (or virtual memory) to satisfy the request. However, -the request was judged large enough (compile-time default is 64K), so -a possibility to shut down by trapping this error is granted. +However, if compiled for this, Perl may use the contents of C<$^M> as an +emergency pool after die()ing with this message. In this case the error +is trappable I<once>, and the error message will include the line and file +where the failed request happened. =item Out of memory during ridiculously large request (F) You can't allocate more than 2^31+"small amount" bytes. This error -is most likely to be caused by a typo in the Perl program. e.g., C<$arr[time]> -instead of C<$arr[$time]>. +is most likely to be caused by a typo in the Perl program. e.g., +C<$arr[time]> instead of C<$arr[$time]>. + +=item Out of memory for yacc stack + +(F) The yacc parser wanted to grow its stack so it could continue +parsing, but realloc() wouldn't give it more memory, virtual or +otherwise. + +=item @ outside of string + +(F) You had a pack template that specified an absolute position outside +the string being unpacked. See L<perlfunc/pack>. + +=item %s package attribute may clash with future reserved word: %s + +(W reserved) A lowercase attribute name was used that had a +package-specific handler. That name might have a meaning to Perl itself +some day, even though it doesn't yet. Perhaps you should use a +mixed-case attribute name, instead. See L<attributes>. =item page overflow -(W io) A single call to write() produced more lines than can fit on a page. -See L<perlform>. +(W io) A single call to write() produced more lines than can fit on a +page. See L<perlform>. + +=item panic: %s + +(P) An internal error. =item panic: ck_grep @@ -2274,8 +2359,8 @@ See L<perlform>. =item panic: corrupt saved stack index -(P) The savestack was requested to restore more localized values than there -are in the savestack. +(P) The savestack was requested to restore more localized values than +there are in the savestack. =item panic: del_backref @@ -2287,21 +2372,20 @@ reference. (P) We popped the context stack to an eval context, and then discovered it wasn't an eval context. -=item panic: do_match +=item panic: pp_match -(P) The internal pp_match() routine was called with invalid operational data. - -=item panic: do_split - -(P) Something terrible went wrong in setting up for the split. +(P) The internal pp_match() routine was called with invalid operational +data. =item panic: do_subst -(P) The internal pp_subst() routine was called with invalid operational data. +(P) The internal pp_subst() routine was called with invalid operational +data. -=item panic: do_trans +=item panic: do_trans_%s -(P) The internal do_trans() routine was called with invalid operational data. +(P) The internal do_trans routines were called with invalid operational +data. =item panic: frexp @@ -2331,22 +2415,23 @@ it wasn't a block context. =item panic: leave_scope clearsv -(P) A writable lexical variable became read-only somehow within the scope. +(P) A writable lexical variable became read-only somehow within the +scope. =item panic: leave_scope inconsistency (P) The savestack probably got out of sync. At least, there was an invalid enum on the top of it. -=item panic: malloc - -(P) Something requested a negative number of bytes of malloc. - =item panic: magic_killbackrefs (P) Failed an internal consistency check while trying to reset all weak references to an object. +=item panic: malloc + +(P) Something requested a negative number of bytes of malloc. + =item panic: mapstart (P) The compiler is screwed up with respect to the map() function. @@ -2391,6 +2476,10 @@ and freeing temporaries and lexicals from. (P) The foreach iterator got called in a non-loop context frame. +=item panic: pp_split + +(P) Something terrible went wrong in setting up for the split. + =item panic: realloc (P) Something requested a negative number of bytes of realloc. @@ -2422,9 +2511,10 @@ was string. (P) The lexer got into a bad state while processing a case modifier. -=item panic: %s +=item panic: utf16_to_utf8: odd bytelen -(P) An internal error. +(P) Something tried to call utf16_to_utf8 with an odd (as opposed +to even) byte length. =item Parentheses missing around "%s" list @@ -2438,11 +2528,38 @@ when you meant Remember that "my", "our", and "local" bind tighter than comma. -=item Perl %3.3f required--this is only version %s, stopped +=item Perl %s required--this is only version %s, stopped + +(F) The module in question uses features of a version of Perl more +recent than the currently running version. How long has it been since +you upgraded, anyway? See L<perlfunc/require>. -(F) The module in question uses features of a version of Perl more recent -than the currently running version. How long has it been since you upgraded, -anyway? See L<perlfunc/require>. +=item PERL_SH_DIR too long + +(F) An error peculiar to OS/2. PERL_SH_DIR is the directory to find the +C<sh>-shell in. See "PERL_SH_DIR" in L<perlos2>. + +=item perl: warning: Setting locale failed. + +(S) The whole warning message will look something like: + + perl: warning: Setting locale failed. + perl: warning: Please check that your locale settings: + LC_ALL = "En_US", + LANG = (unset) + are supported and installed on your system. + perl: warning: Falling back to the standard locale ("C"). + +Exactly what were the failed locale settings varies. In the above the +settings were that the LC_ALL was "En_US" and the LANG had no value. +This error means that Perl detected that you and/or your operating +system supplier and/or system administrator have set up the so-called +locale system but Perl could not use those settings. This was not +dead serious, fortunately: there is a "default locale" called "C" that +Perl can and will use, the script will be run. Before you really fix +the problem, however, you will get the same error message each time +you run Perl. How to really fix the problem can be found in +L<perllocale> section B<LOCALE PROBLEMS>. =item Permission denied @@ -2450,25 +2567,49 @@ anyway? See L<perlfunc/require>. =item pid %x not a child -(W exec) A warning peculiar to VMS. Waitpid() was asked to wait for a process which -isn't a subprocess of the current process. While this is fine from VMS' -perspective, it's probably not what you intended. +(W exec) A warning peculiar to VMS. Waitpid() was asked to wait for a +process which isn't a subprocess of the current process. While this is +fine from VMS' perspective, it's probably not what you intended. + +=item POSIX syntax [%s] belongs inside character classes + +(W unsafe) The character class constructs [: :], [= =], and [. .] go +I<inside> character classes, the [] are part of the construct, for +example: /[012[:alpha:]345]/. Note that [= =] and [. .] are not +currently implemented; they are simply placeholders for future +extensions and will cause fatal errors. + +=item POSIX syntax [. .] is reserved for future extensions + +(F regexp) Within regular expression character classes ([]) the syntax +beginning with "[." and ending with ".]" is reserved for future +extensions. If you need to represent those character sequences inside +a regular expression character class, just quote the square brackets +with the backslash: "\[." and ".\]". + +=item POSIX syntax [= =] is reserved for future extensions + +(F) Within regular expression character classes ([]) the syntax +beginning with "[=" and ending with "=]" is reserved for future +extensions. If you need to represent those character sequences inside +a regular expression character class, just quote the square brackets +with the backslash: "\[=" and "=\]". + +=item POSIX class [:%s:] unknown + +(F) The class in the character class [: :] syntax is unknown. See +L<perlre>. =item POSIX getpgrp can't take an argument (F) Your system has POSIX getpgrp(), which takes no argument, unlike the BSD version, which takes a pid. -=item Possible Y2K bug: %s - -(W y2k) You are concatenating the number 19 with another number, which -could be a potential Year 2000 problem. - =item Possible attempt to put comments in qw() list (W qw) qw() lists contain items separated by whitespace; as with literal -strings, comment characters are not ignored, but are instead treated -as literal data. (You may have used different delimiters than the +strings, comment characters are not ignored, but are instead treated as +literal data. (You may have used different delimiters than the parentheses shown here; braces are also frequently used.) You probably wrote something like this: @@ -2495,10 +2636,10 @@ old-fashioned way, with quotes and commas: =item Possible attempt to separate words with commas -(W qw) qw() lists contain items separated by whitespace; therefore commas -aren't needed to separate the items. (You may have used different -delimiters than the parentheses shown here; braces are also frequently -used.) +(W qw) qw() lists contain items separated by whitespace; therefore +commas aren't needed to separate the items. (You may have used +different delimiters than the parentheses shown here; braces are also +frequently used.) You probably wrote something like this: @@ -2516,9 +2657,14 @@ Perl guesses a reasonable buffer size, but puts a sentinel byte at the end of the buffer just in case. This sentinel byte got clobbered, and Perl assumes that memory is now corrupted. See L<perlfunc/ioctl>. +=item Possible Y2K bug: %s + +(W y2k) You are concatenating the number 19 with another number, which +could be a potential Year 2000 problem. + =item pragma "attrs" is deprecated, use "sub NAME : ATTRS" instead -(W deprecated) You have written somehing like this: +(W deprecated) You have written something like this: sub doit { @@ -2544,55 +2690,77 @@ is now misinterpreted as open(FOO || die); -because of the strict regularization of Perl 5's grammar into unary -and list operators. (The old open was a little of both.) You must -put parentheses around the filehandle, or use the new "or" operator -instead of "||". +because of the strict regularization of Perl 5's grammar into unary and +list operators. (The old open was a little of both.) You must put +parentheses around the filehandle, or use the new "or" operator instead +of "||". =item Premature end of script headers See Server error. +=item printf() on closed filehandle %s + +(W closed) The filehandle you're writing to got itself closed sometime +before now. Check your logic flow. + =item print() on closed filehandle %s -(W closed) The filehandle you're printing on got itself closed sometime before now. -Check your logic flow. +(W closed) The filehandle you're printing on got itself closed sometime +before now. Check your logic flow. -=item printf() on closed filehandle %s +=item Process terminated by SIG%s -(W closed) The filehandle you're writing to got itself closed sometime before now. -Check your logic flow. +(W) This is a standard message issued by OS/2 applications, while *nix +applications die in silence. It is considered a feature of the OS/2 +port. One can easily disable this by appropriate sighandlers, see +L<perlipc/"Signals">. See also "Process terminated by SIGTERM/SIGINT" +in L<perlos2>. =item Prototype mismatch: %s vs %s -(S unsafe) The subroutine being declared or defined had previously been declared -or defined with a different function prototype. +(S unsafe) The subroutine being declared or defined had previously been +declared or defined with a different function prototype. + +=item Quantifier in {,} bigger than %d before << HERE in regex m/%s/ + +(F) There is currently a limit to the size of the min and max values of the +{min,max} construct. The << HERE shows in the regular expression about where +the problem was discovered. See L<perlre>. + +=item Quantifier unexpected on zero-length expression before << HERE %s + +(W regexp) You applied a regular expression quantifier in a place where +it makes no sense, such as on a zero-width assertion. Try putting the +quantifier inside the assertion instead. For example, the way to match +"abc" provided that it is followed by three repetitions of "xyz" is +C</abc(?=(?:xyz){3})/>, not C</abc(?=xyz){3}/>. =item Range iterator outside integer range (F) One (or both) of the numeric arguments to the range operator ".." 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. +One possible workaround is to force Perl to use magical string increment +by prepending "0" to your numbers. =item readline() on closed filehandle %s -(W closed) The filehandle you're reading from got itself closed sometime before now. -Check your logic flow. - -=item realloc() of freed memory ignored - -(S malloc) An internal routine called realloc() on something that had already -been freed. +(W closed) The filehandle you're reading from got itself closed sometime +before now. Check your logic flow. =item Reallocation too large: %lx (F) You can't allocate more than 64K on an MS-DOS machine. +=item realloc() of freed memory ignored + +(S malloc) An internal routine called realloc() on something that had +already been freed. + =item Recompile perl with B<-D>DEBUGGING to use B<-D> switch -(F debugging) You can't use the B<-D> option unless the code to produce the -desired output is compiled into Perl, which entails some overhead, +(F debugging) You can't use the B<-D> option unless the code to produce +the desired output is compiled into Perl, which entails some overhead, which is why it's currently left out of your copy. =item Recursive inheritance detected in package '%s' @@ -2600,17 +2768,18 @@ which is why it's currently left out of your copy. (F) More than 100 levels of inheritance were used. Probably indicates an unintended loop in your inheritance hierarchy. -=item Recursive inheritance detected while looking for method '%s' in package '%s' +=item Recursive inheritance detected while looking for method %s -(F) More than 100 levels of inheritance were encountered while invoking a -method. Probably indicates an unintended loop in your inheritance hierarchy. +(F) More than 100 levels of inheritance were encountered while invoking +a method. Probably indicates an unintended loop in your inheritance +hierarchy. =item Reference found where even-sized list expected -(W misc) You gave a single reference where Perl was expecting a list with -an even number of elements (for assignment to a hash). This -usually means that you used the anon hash constructor when you meant -to use parens. In any case, a hash requires key/value B<pairs>. +(W misc) You gave a single reference where Perl was expecting a list +with an even number of elements (for assignment to a hash). This usually +means that you used the anon hash constructor when you meant to use +parens. In any case, a hash requires key/value B<pairs>. %hash = { one => 1, two => 2, }; # WRONG %hash = [ qw/ an anon array / ]; # WRONG @@ -2624,37 +2793,43 @@ Doing so has no effect. =item Reference miscount in sv_replace() -(W internal) The internal sv_replace() function was handed a new SV with a -reference count of other than 1. +(W internal) The internal sv_replace() function was handed a new SV with +a reference count of other than 1. + +=item Reference to nonexistent group before << HERE in regex m/%s/ -=item regexp *+ operand could be empty +(F) You used something like C<\7> in your regular expression, but there are +not at least seven sets of capturing parentheses in the expression. If you +wanted to have the character with value 7 inserted into the regular expression, +prepend a zero to make the number at least two digits: C<\07> -(F) The part of the regexp subject to either the * or + quantifier -could match an empty string. +The << HERE shows in the regular expression about where the problem was +discovered. =item regexp memory corruption (P) The regular expression engine got confused by what the regular expression compiler gave it. -=item regexp out of space +=item Regexp out of space -(P) A "can't happen" error, because safemalloc() should have caught it earlier. +(P) A "can't happen" error, because safemalloc() should have caught it +earlier. =item Repeat count in pack overflows -(F) You can't specify a repeat count so large that it overflows -your signed integers. See L<perlfunc/pack>. +(F) You can't specify a repeat count so large that it overflows your +signed integers. See L<perlfunc/pack>. =item Repeat count in unpack overflows -(F) You can't specify a repeat count so large that it overflows -your signed integers. See L<perlfunc/unpack>. +(F) You can't specify a repeat count so large that it overflows your +signed integers. See L<perlfunc/unpack>. =item Reversed %s= operator -(W syntax) You wrote your assignment operator backwards. The = must always -comes last, to avoid ambiguity with subsequent unary operators. +(W syntax) You wrote your assignment operator backwards. The = must +always comes last, to avoid ambiguity with subsequent unary operators. =item Runaway format @@ -2666,12 +2841,13 @@ shifting or popping (for array variables). See L<perlform>. =item Scalar value @%s[%s] better written as $%s[%s] -(W syntax) You've used an array slice (indicated by @) to select a single element of -an array. Generally it's better to ask for a scalar value (indicated by $). -The difference is that C<$foo[&bar]> always behaves like a scalar, both when -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. +(W syntax) You've used an array slice (indicated by @) to select a +single element of an array. Generally it's better to ask for a scalar +value (indicated by $). The difference is that C<$foo[&bar]> always +behaves like a scalar, both when 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. On the other hand, if you were actually hoping to treat the array element as a list, you need to look into how references work, because @@ -2680,18 +2856,26 @@ L<perlref>. =item Scalar value @%s{%s} better written as $%s{%s} -(W syntax) You've used a hash slice (indicated by @) to select a single element of -a hash. Generally it's better to ask for a scalar value (indicated by $). -The difference is that C<$foo{&bar}> always behaves like a scalar, both when -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. - -On the other hand, if you were actually hoping to treat the hash -element as a list, you need to look into how references work, because -Perl will not magically convert between scalars and lists for you. See +(W syntax) You've used a hash slice (indicated by @) to select a single +element of a hash. Generally it's better to ask for a scalar value +(indicated by $). The difference is that C<$foo{&bar}> always behaves +like a scalar, both when 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. + +On the other hand, if you were actually hoping to treat the hash element +as a list, you need to look into how references work, because Perl will +not magically convert between scalars and lists for you. See L<perlref>. +=item Scalars leaked: %d + +(P) Something went wrong in Perl's internal bookkeeping of scalars: +not all scalar variables were deallocated by the time Perl exited. +What this usually indicates is a memory leak, which is of course bad, +especially if the Perl program is intended to be long-running. + =item Script is not setuid/setgid in suidperl (F) Oddly, the suidperl program was invoked on a script without a setuid @@ -2703,71 +2887,84 @@ or setgid bit set. This doesn't make much sense. construct. Remember that bracketing delimiters count nesting level. Missing the leading C<$> from a variable C<$m> may cause this error. -=item %sseek() on unopened file +=item %sseek() on unopened filehandle -(W unopened) You tried to use the seek() or sysseek() function on a filehandle that -was either never opened or has since been closed. +(W unopened) You tried to use the seek() or sysseek() function on a +filehandle that was either never opened or has since been closed. =item select not implemented (F) This machine doesn't implement the select() system call. -=item sem%s not implemented +=item Semicolon seems to be missing -(F) You don't have System V semaphore IPC on your system. +(W semicolon) A nearby syntax error was probably caused by a missing +semicolon, or possibly some other missing operator, such as a comma. =item semi-panic: attempt to dup freed string -(S internal) The internal newSVsv() routine was called to duplicate a scalar -that had previously been marked as free. +(S internal) The internal newSVsv() routine was called to duplicate a +scalar that had previously been marked as free. -=item Semicolon seems to be missing +=item sem%s not implemented -(W semicolon) A nearby syntax error was probably caused by a missing semicolon, -or possibly some other missing operator, such as a comma. +(F) You don't have System V semaphore IPC on your system. =item send() on closed socket %s -(W closed) The socket you're sending to got itself closed sometime before now. -Check your logic flow. +(W closed) The socket you're sending to got itself closed sometime +before now. Check your logic flow. -=item Sequence (? incomplete +=item Sequence (? incomplete before << HERE mark in regex m/%s/ -(F) A regular expression ended with an incomplete extension (?. -See L<perlre>. +(F) A regular expression ended with an incomplete extension (?. The <<<HERE +shows in the regular expression about where the problem was discovered. See +L<perlre>. -=item Sequence (?#... not terminated +=item Sequence (?{...}) not terminated or not {}-balanced in %s -(F) A regular expression comment must be terminated by a closing -parenthesis. Embedded parentheses aren't allowed. See L<perlre>. +(F) If the contents of a (?{...}) clause contains braces, they must balance +for Perl to properly detect the end of the clause. See L<perlre>. -=item Sequence (?%s...) not implemented +=item Sequence (?%s...) not implemented before << HERE mark in %s -(F) A proposed regular expression extension has the character reserved -but has not yet been written. See L<perlre>. +(F) A proposed regular expression extension has the character reserved but +has not yet been written. The << HERE shows in the regular expression about +where the problem was discovered. See L<perlre>. -=item Sequence (?%s...) not recognized +=item Sequence (?%s...) not recognized before << HERE mark in %s (F) You used a regular expression extension that doesn't make sense. +The << HERE shows in the regular expression about +where the problem was discovered. See L<perlre>. +=item Sequence (?#... not terminated in regex m/%s/ + +(F) A regular expression comment must be terminated by a closing +parenthesis. Embedded parentheses aren't allowed. See L<perlre>. + +=item 500 Server error + +See Server error. + =item Server error This is the error message generally seen in a browser window when trying -to run a CGI program (including SSI) over the web. The actual error -text varies widely from server to server. The most frequently-seen -variants are "500 Server error", "Method (something) not permitted", -"Document contains no data", "Premature end of script headers", and -"Did not produce a valid header". +to run a CGI program (including SSI) over the web. The actual error text +varies widely from server to server. The most frequently-seen variants +are "500 Server error", "Method (something) not permitted", "Document +contains no data", "Premature end of script headers", and "Did not +produce a valid header". B<This is a CGI error, not a Perl error>. -You need to make sure your script is executable, is accessible by the user -CGI is running the script under (which is probably not the user account you -tested it under), does not rely on any environment variables (like PATH) -from the user it isn't running under, and isn't in a location where the CGI -server can't find it, basically, more or less. Please see the following -for more information: +You need to make sure your script is executable, is accessible by the +user CGI is running the script under (which is probably not the user +account you tested it under), does not rely on any environment variables +(like PATH) from the user it isn't running under, and isn't in a +location where the CGI server can't find it, basically, more or less. +Please see the following for more information: http://www.perl.com/CPAN/doc/FAQs/cgi/idiots-guide.html http://www.perl.com/CPAN/doc/FAQs/cgi/perl-cgi-faq.html @@ -2779,50 +2976,70 @@ You should also look at L<perlfaq9>. =item setegid() not implemented -(F) You tried to assign to C<$)>, and your operating system doesn't support -the setegid() system call (or equivalent), or at least Configure didn't -think so. +(F) You tried to assign to C<$)>, and your operating system doesn't +support the setegid() system call (or equivalent), or at least Configure +didn't think so. =item seteuid() not implemented -(F) You tried to assign to C<< $> >>, and your operating system doesn't support -the seteuid() system call (or equivalent), or at least Configure didn't -think so. +(F) You tried to assign to C<< $> >>, and your operating system doesn't +support the seteuid() system call (or equivalent), or at least Configure +didn't think so. =item setpgrp can't take arguments -(F) Your system has the setpgrp() from BSD 4.2, which takes no arguments, -unlike POSIX setpgid(), which takes a process ID and process group ID. +(F) Your system has the setpgrp() from BSD 4.2, which takes no +arguments, unlike POSIX setpgid(), which takes a process ID and process +group ID. =item setrgid() not implemented -(F) You tried to assign to C<$(>, and your operating system doesn't support -the setrgid() system call (or equivalent), or at least Configure didn't -think so. +(F) You tried to assign to C<$(>, and your operating system doesn't +support the setrgid() system call (or equivalent), or at least Configure +didn't think so. =item setruid() not implemented -(F) You tried to assign to C<$<>, and your operating system doesn't support -the setruid() system call (or equivalent), or at least Configure didn't -think so. +(F) You tried to assign to C<$<>, and your operating system doesn't +support the setruid() system call (or equivalent), or at least Configure +didn't think so. + +=item setsockopt() on closed socket %s + +(W closed) You tried to set a socket option on a closed socket. Did you +forget to check the return value of your socket() call? See +L<perlfunc/setsockopt>. =item Setuid/gid script is writable by world -(F) The setuid emulator won't run a script that is writable by the world, -because the world might have written on it already. +(F) The setuid emulator won't run a script that is writable by the +world, because the world might have written on it already. =item shm%s not implemented (F) You don't have System V shared memory IPC on your system. +=item <> should be quotes + +(F) You wrote C<< require <file> >> when you should have written +C<require 'file'>. + +=item /%s/ should probably be written as "%s" + +(W syntax) You have used a pattern where Perl expected to find a string, +as in the first argument to C<join>. Perl will treat the true or false +result of matching the pattern against $_ as the string, which is +probably not what you had in mind. + =item shutdown() on closed socket %s -(W closed) You tried to do a shutdown on a closed socket. Seems a bit superfluous. +(W closed) You tried to do a shutdown on a closed socket. Seems a bit +superfluous. =item SIG%s handler "%s" not defined -(W signal) The signal handler named in %SIG doesn't, in fact, exist. Perhaps you -put it into the wrong package? +(W signal) The signal handler named in %SIG doesn't, in fact, exist. +Perhaps you put it into the wrong package? =item sort is now a reserved word @@ -2842,36 +3059,28 @@ or less than one element. See L<perlfunc/sort>. =item Split loop -(P) The split was looping infinitely. (Obviously, a split shouldn't iterate -more times than there are characters of input, which is what happened.) -See L<perlfunc/split>. - -=item Stat on unopened file <%s> - -(W unopened) You tried to use the stat() function (or an equivalent file test) -on a filehandle that was either never opened or has since been closed. +(P) The split was looping infinitely. (Obviously, a split shouldn't +iterate more times than there are characters of input, which is what +happened.) See L<perlfunc/split>. =item Statement unlikely to be reached -(W exec) You did an exec() with some statement after it other than a die(). -This is almost always an error, because exec() never returns unless -there was a failure. You probably wanted to use system() instead, -which does return. To suppress this warning, put the exec() in a block -by itself. +(W exec) You did an exec() with some statement after it other than a +die(). This is almost always an error, because exec() never returns +unless there was a failure. You probably wanted to use system() +instead, which does return. To suppress this warning, put the exec() in +a block by itself. -=item Strange *+?{} on zero-length expression +=item stat() on unopened filehandle %s -(W regexp) You applied a regular expression quantifier in a place where it -makes no sense, such as on a zero-width assertion. -Try putting the quantifier inside the assertion instead. For example, -the way to match "abc" provided that it is followed by three -repetitions of "xyz" is C</abc(?=(?:xyz){3})/>, not C</abc(?=xyz){3}/>. +(W unopened) You tried to use the stat() function on a filehandle that +was either never opened or has since been closed. -=item Stub found while resolving method `%s' overloading `%s' in package `%s' +=item Stub found while resolving method `%s' overloading %s -(P) Overloading resolution over @ISA tree may be broken by importation stubs. -Stubs should never be implicitely created, but explicit calls to C<can> -may break this. +(P) Overloading resolution over @ISA tree may be broken by importation +stubs. Stubs should never be implicitly created, but explicit calls to +C<can> may break this. =item Subroutine %s redefined @@ -2884,9 +3093,9 @@ may break this. =item Substitution loop -(P) The substitution was looping infinitely. (Obviously, a -substitution shouldn't iterate more times than there are characters of -input, which is what happened.) See the discussion of substitution in +(P) The substitution was looping infinitely. (Obviously, a substitution +shouldn't iterate more times than there are characters of input, which +is what happened.) See the discussion of substitution in L<perlop/"Quote and Quote-like Operators">. =item Substitution pattern not terminated @@ -2903,21 +3112,39 @@ Missing the leading C<$> from variable C<$s> may cause this error. =item substr outside of string -(W substr),(F) You tried to reference a substr() that pointed outside of a -string. That is, the absolute value of the offset was larger than the -length of the string. See L<perlfunc/substr>. This warning is -fatal if substr is used in an lvalue context (as the left hand side -of an assignment or as a subroutine argument for example). +(W substr),(F) You tried to reference a substr() that pointed outside of +a string. That is, the absolute value of the offset was larger than the +length of the string. See L<perlfunc/substr>. This warning is fatal if +substr is used in an lvalue context (as the left hand side of an +assignment or as a subroutine argument for example). =item suidperl is no longer needed since %s -(F) Your Perl was compiled with B<-D>SETUID_SCRIPTS_ARE_SECURE_NOW, but a -version of the setuid emulator somehow got run anyway. +(F) Your Perl was compiled with B<-D>SETUID_SCRIPTS_ARE_SECURE_NOW, but +a version of the setuid emulator somehow got run anyway. + +=item Switch (?(condition)... contains too many branches before << HE%s + +(F) A (?(condition)if-clause|else-clause) construct can have at most two +branches (the if-clause and the else-clause). If you want one or both to +contain alternation, such as using C<this|that|other>, enclose it in +clustering parentheses: + + (?(condition)(?:this|that|other)|else-clause) + +The << HERE shows in the regular expression about where the problem was +discovered. See L<perlre>. + +=item Switch condition not recognized before << HERE in regex m/%s/ + +(F) If the argument to the (?(...)if-clause|else-clause) construct is a +number, it can be only a number. The << HERE shows in the regular expression +about where the problem was discovered. See L<perlre>. =item switching effective %s is not implemented -(F) While under the C<use filetest> pragma, we cannot switch the -real and effective uids or gids. +(F) While under the C<use filetest> pragma, we cannot switch the real +and effective uids or gids. =item syntax error @@ -2938,13 +3165,18 @@ before this, because Perl is good at understanding random input. Occasionally the line number may be misleading, and once in a blue moon the only way to figure out what's triggering the error is to call C<perl -c> repeatedly, chopping away half the program each time to see -if the error went away. Sort of the cybernetic version of S<20 questions>. +if the error went away. Sort of the cybernetic version of S<20 +questions>. =item syntax error at line %d: `%s' unexpected -(A) You've accidentally run your script through the Bourne shell -instead of Perl. Check the #! line, or manually feed your script -into Perl yourself. +(A) You've accidentally run your script through the Bourne shell instead +of Perl. Check the #! line, or manually feed your script into Perl +yourself. + +=item %s syntax OK + +(F) The final summary message when a C<perl -c> succeeds. =item System V %s is not implemented on this machine @@ -2955,28 +3187,23 @@ unconfigured. Consult your system support. =item syswrite() on closed filehandle %s -(W closed) The filehandle you're writing to got itself closed sometime before now. -Check your logic flow. +(W closed) The filehandle you're writing to got itself closed sometime +before now. Check your logic flow. =item Target of goto is too deeply nested -(F) You tried to use C<goto> to reach a label that was too deeply -nested for Perl to reach. Perl is doing you a favor by refusing. - -=item tell() on unopened file - -(W unopened) You tried to use the tell() function on a filehandle that was either -never opened or has since been closed. +(F) You tried to use C<goto> to reach a label that was too deeply nested +for Perl to reach. Perl is doing you a favor by refusing. -=item Test on unopened file <%s> +=item tell() on unopened filehandle -(W unopened) You tried to invoke a file test operator on a filehandle that isn't -open. Check your logic. See also L<perlfunc/-X>. +(W unopened) You tried to use the tell() function on a filehandle that +was either never opened or has since been closed. =item That use of $[ is unsupported -(F) Assignment to C<$[> is now strictly circumscribed, and interpreted as -a compiler directive. You may say only one of +(F) Assignment to C<$[> is now strictly circumscribed, and interpreted +as a compiler directive. You may say only one of $[ = 0; $[ = 1; @@ -2985,13 +3212,8 @@ a compiler directive. You may say only one of local $[ = 1; ... -This is to prevent the problem of one module changing the array base -out from under another module inadvertently. See L<perlvar/$[>. - -=item The %s function is unimplemented - -The function indicated isn't implemented on this architecture, according -to the probings of Configure. +This is to prevent the problem of one module changing the array base out +from under another module inadvertently. See L<perlvar/$[>. =item The crypt() function is unimplemented due to excessive paranoia @@ -3001,27 +3223,34 @@ think the U.S. Government thinks it's a secret, or at least that they will continue to pretend that it is. And if you quote me on that, I will deny it. +=item The %s function is unimplemented + +The function indicated isn't implemented on this architecture, according +to the probings of Configure. + =item The stat preceding C<-l _> wasn't an lstat -(F) It makes no sense to test the current stat buffer for symbolic linkhood -if the last stat that wrote to the stat buffer already went past -the symlink to get to the real file. Use an actual filename instead. +(F) It makes no sense to test the current stat buffer for symbolic +linkhood if the last stat that wrote to the stat buffer already went +past the symlink to get to the real file. Use an actual filename +instead. =item This Perl can't reset CRTL environ elements (%s) =item This Perl can't set CRTL environ elements (%s=%s) -(W internal) Warnings peculiar to VMS. You tried to change or delete an element -of the CRTL's internal environ array, but your copy of Perl wasn't -built with a CRTL that contained the setenv() function. You'll need to -rebuild Perl with a CRTL that does, or redefine F<PERL_ENV_TABLES> (see -L<perlvms>) so that the environ array isn't the target of the change to +(W internal) Warnings peculiar to VMS. You tried to change or delete an +element of the CRTL's internal environ array, but your copy of Perl +wasn't built with a CRTL that contained the setenv() function. You'll +need to rebuild Perl with a CRTL that does, or redefine +F<PERL_ENV_TABLES> (see L<perlvms>) so that the environ array isn't the +target of the change to %ENV which produced the warning. =item times not implemented -(F) Your version of the C library apparently doesn't do times(). I suspect -you're not running on Unix. +(F) Your version of the C library apparently doesn't do times(). I +suspect you're not running on Unix. =item Too few args to syscall @@ -3037,9 +3266,9 @@ script, it's too late to properly taint everything from the environment. So Perl gives up. If the Perl script is being executed as a command using the #! -mechanism (or its local equivalent), this error can usually be fixed -by editing the #! line so that the B<-T> option is a part of Perl's -first argument: e.g. change C<perl -n -T> to C<perl -T -n>. +mechanism (or its local equivalent), this error can usually be fixed by +editing the #! line so that the B<-T> option is a part of Perl's first +argument: e.g. change C<perl -n -T> to C<perl -T -n>. If the Perl script is being executed as C<perl scriptname>, then the B<-T> option must appear on the command line: C<perl -T scriptname>. @@ -3054,17 +3283,9 @@ are not intended for use inside scripts. Use the C<use> pragma instead. (W void) A CHECK or INIT block is being defined during run time proper, when the opportunity to run them has already passed. Perhaps you are -loading a file with C<require> or C<do> when you should be using -C<use> instead. Or perhaps you should put the C<require> or C<do> -inside a BEGIN block. - -=item Too many ('s - -=item Too many )'s - -(A) You've accidentally run your script through B<csh> instead -of Perl. Check the #! line, or manually feed your script into -Perl yourself. +loading a file with C<require> or C<do> when you should be using C<use> +instead. Or perhaps you should put the C<require> or C<do> inside a +BEGIN block. =item Too many args to syscall @@ -3074,10 +3295,17 @@ Perl yourself. (F) The function requires fewer arguments than you specified. +=item Too many )'s + +(A) You've accidentally run your script through B<csh> instead of Perl. +Check the #! line, or manually feed your script into Perl yourself. + +=item Too many ('s + =item trailing \ in regexp -(F) The regular expression ends with an unbackslashed backslash. Backslash -it. See L<perlre>. +(F) The regular expression ends with an unbackslashed backslash. +Backslash it. See L<perlre>. =item Transliteration pattern not terminated @@ -3109,8 +3337,8 @@ literals always start with 0 in Perl, as in C. =item umask not implemented -(F) Your machine doesn't implement the umask function and you tried -to use it to restrict permissions for yourself (EXPR & 0700). +(F) Your machine doesn't implement the umask function and you tried to +use it to restrict permissions for yourself (EXPR & 0700). =item Unable to create sub named "%s" @@ -3118,23 +3346,23 @@ to use it to restrict permissions for yourself (EXPR & 0700). =item Unbalanced context: %d more PUSHes than POPs -(W internal) The exit code detected an internal inconsistency in how many execution -contexts were entered and left. +(W internal) The exit code detected an internal inconsistency in how +many execution contexts were entered and left. =item Unbalanced saves: %d more saves than restores -(W internal) The exit code detected an internal inconsistency in how many -values were temporarily localized. +(W internal) The exit code detected an internal inconsistency in how +many values were temporarily localized. =item Unbalanced scopes: %d more ENTERs than LEAVEs -(W internal) The exit code detected an internal inconsistency in how many blocks -were entered and left. +(W internal) The exit code detected an internal inconsistency in how +many blocks were entered and left. =item Unbalanced tmps: %d more allocs than frees -(W internal) The exit code detected an internal inconsistency in how many mortal -scalars were allocated and freed. +(W internal) The exit code detected an internal inconsistency in how +many mortal scalars were allocated and freed. =item Undefined format "%s" called @@ -3143,13 +3371,13 @@ another package? See L<perlform>. =item Undefined sort subroutine "%s" called -(F) The sort comparison routine specified doesn't seem to exist. Perhaps -it's in a different package? See L<perlfunc/sort>. +(F) The sort comparison routine specified doesn't seem to exist. +Perhaps it's in a different package? See L<perlfunc/sort>. =item Undefined subroutine &%s called -(F) The subroutine indicated hasn't been defined, or if it was, it -has since been undefined. +(F) The subroutine indicated hasn't been defined, or if it was, it has +since been undefined. =item Undefined subroutine called @@ -3158,8 +3386,8 @@ or if it was, it has since been undefined. =item Undefined subroutine in sort -(F) The sort comparison routine specified is declared but doesn't seem to -have been defined yet. See L<perlfunc/sort>. +(F) The sort comparison routine specified is declared but doesn't seem +to have been defined yet. See L<perlfunc/sort>. =item Undefined top format "%s" called @@ -3168,17 +3396,36 @@ another package? See L<perlform>. =item Undefined value assigned to typeglob -(W misc) An undefined value was assigned to a typeglob, a la C<*foo = undef>. -This does nothing. It's possible that you really mean C<undef *foo>. +(W misc) An undefined value was assigned to a typeglob, a la +C<*foo = undef>. This does nothing. It's possible that you really mean +C<undef *foo>. + +=item %s: Undefined variable + +(A) You've accidentally run your script through B<csh> instead of Perl. +Check the #! line, or manually feed your script into Perl yourself. =item unexec of %s into %s failed! (F) The unexec() routine failed for some reason. See your local FSF representative, who probably put it there in the first place. + =item Unknown BYTEORDER -(F) There are no byte-swapping functions for a machine with this byte order. +(F) There are no byte-swapping functions for a machine with this byte +order. + +=item Unknown switch condition (?(%.2s before << HERE in regex m/%s/ + +(F) The condition of a (?(condition)if-clause|else-clause) construct is not +known. The condition may be lookaround (the condition is true if the +lookaround is true), a (?{...}) construct (the condition is true if the +code evaluates to a true value), or a number (the condition is true if the +set of capturing parentheses named by the number is defined). + +The << HERE shows in the regular expression about where the problem was +discovered. See L<perlre>. =item Unknown open() mode '%s' @@ -3193,30 +3440,32 @@ iterating over it, and someone else stuck a message in the stream of data Perl expected. Someone's very confused, or perhaps trying to subvert Perl's population of %ENV for nefarious purposes. -=item unmatched () in regexp +=item unmatched [ before << HERE mark in regex m/%s/ -(F) Unbackslashed parentheses must always be balanced in regular -expressions. If you're a vi user, the % key is valuable for finding -the matching parenthesis. See L<perlre>. +(F) The brackets around a character class must match. If you wish to +include a closing bracket in a character class, backslash it or put it +first. See L<perlre>. The << HERE shows in the regular expression about +where the escape was discovered. -=item Unmatched right %s bracket +=item unmatched ( in regexp before << HERE mark in regex m/%s/ -(F) The lexer counted more closing curly or square brackets than -opening ones, so you're probably missing a matching opening bracket. -As a general rule, you'll find the missing one (so to speak) near the -place you were last editing. +(F) Unbackslashed parentheses must always be balanced in regular +expressions. If you're a vi user, the % key is valuable for finding the +matching parenthesis. See L<perlre>. -=item unmatched [] in regexp +=item Unmatched right %s bracket -(F) The brackets around a character class must match. If you wish to -include a closing bracket in a character class, backslash it or put it first. -See L<perlre>. +(F) The lexer counted more closing curly or square brackets than opening +ones, so you're probably missing a matching opening bracket. As a +general rule, you'll find the missing one (so to speak) near the place +you were last editing. =item Unquoted string "%s" may clash with future reserved word -(W reserved) You used a bareword that might someday be claimed as a reserved word. -It's best to put such a word in quotes, or capitalize it somehow, or insert -an underbar into it. You might also declare it as a subroutine. +(W reserved) You used a bareword that might someday be claimed as a +reserved word. It's best to put such a word in quotes, or capitalize it +somehow, or insert an underbar into it. You might also declare it as a +subroutine. =item Unrecognized character %s @@ -3224,238 +3473,295 @@ an underbar into it. You might also declare it as a subroutine. in your Perl script (or eval). Perhaps you tried to run a compressed script, a binary program, or a directory as a Perl program. +=item /%s/: Unrecognized escape \\%c in character class passed through + +(W regexp) You used a backslash-character combination which is not +recognized by Perl inside character classes. The character was +understood literally. + +=item Unrecognized escape \\%c passed through before << HERE in m/%s/ + +(W regexp) You used a backslash-character combination which is not +recognized by Perl. This combination appears in an interpolated variable or +a C<'>-delimited regular expression. The character was understood +literally. The << HERE shows in the regular expression about where the escape +was discovered. + + =item Unrecognized escape \\%c passed through -(W misc) You used a backslash-character combination which is not recognized -by Perl. +(W misc) You used a backslash-character combination which is not +recognized by Perl. =item Unrecognized signal name "%s" -(F) You specified a signal name to the kill() function that was not recognized. -Say C<kill -l> in your shell to see the valid signal names on your system. +(F) You specified a signal name to the kill() function that was not +recognized. Say C<kill -l> in your shell to see the valid signal names +on your system. =item Unrecognized switch: -%s (-h will show valid options) -(F) You specified an illegal option to Perl. Don't do that. -(If you think you didn't do that, check the #! line to see if it's -supplying the bad switch on your behalf.) +(F) You specified an illegal option to Perl. Don't do that. (If you +think you didn't do that, check the #! line to see if it's supplying the +bad switch on your behalf.) =item Unsuccessful %s on filename containing newline -(W newline) A file operation was attempted on a filename, and that operation -failed, PROBABLY because the filename contained a newline, PROBABLY -because you forgot to chop() or chomp() it off. See L<perlfunc/chomp>. +(W newline) A file operation was attempted on a filename, and that +operation failed, PROBABLY because the filename contained a newline, +PROBABLY because you forgot to chomp() it off. See L<perlfunc/chomp>. =item Unsupported directory function "%s" called (F) Your machine doesn't support opendir() and readdir(). +=item Unsupported function %s + +(F) This machine doesn't implement the indicated function, apparently. +At least, Configure doesn't think so. + =item Unsupported function fork (F) Your version of executable does not support forking. -Note that under some systems, like OS/2, there may be different flavors of -Perl executables, some of which may support fork, some not. Try changing -the name you call Perl by to C<perl_>, C<perl__>, and so on. +Note that under some systems, like OS/2, there may be different flavors +of Perl executables, some of which may support fork, some not. Try +changing the name you call Perl by to C<perl_>, C<perl__>, and so on. -=item Unsupported function %s +=item Unsupported script encoding -(F) This machine doesn't implement the indicated function, apparently. -At least, Configure doesn't think so. +(F) Your program file begins with a Unicode Byte Order Mark (BOM) which +declares it to be in a Unicode encoding that Perl cannot yet read. =item Unsupported socket function "%s" called (F) Your machine doesn't support the Berkeley socket mechanism, or at least that's what Configure thought. -=item Unterminated <> operator +=item Unterminated attribute list -(F) The lexer saw a left angle bracket in a place where it was expecting -a term, so it's looking for the corresponding right angle bracket, and not -finding it. Chances are you left some needed parentheses out earlier in -the line, and you really meant a "less than". +(F) The lexer found something other than a simple identifier at the +start of an attribute, and it wasn't a semicolon or the start of a +block. Perhaps you terminated the parameter list of the previous +attribute too soon. See L<attributes>. =item Unterminated attribute parameter in attribute list -(F) The lexer saw an opening (left) parenthesis character while parsing an -attribute list, but the matching closing (right) parenthesis +(F) The lexer saw an opening (left) parenthesis character while parsing +an attribute list, but the matching closing (right) parenthesis character was not found. You may need to add (or remove) a backslash character to get your parentheses to balance. See L<attributes>. -=item Unterminated attribute list +=item Unterminated compressed integer -(F) The lexer found something other than a simple identifier at the start -of an attribute, and it wasn't a semicolon or the start of a -block. Perhaps you terminated the parameter list of the previous attribute -too soon. See L<attributes>. +(F) An argument to unpack("w",...) was incompatible with the BER +compressed integer format and could not be converted to an integer. +See L<perlfunc/pack>. -=item Use of $# is deprecated +=item Unterminated <> operator -(D deprecated) This was an ill-advised attempt to emulate a poorly defined B<awk> feature. -Use an explicit printf() or sprintf() instead. +(F) The lexer saw a left angle bracket in a place where it was expecting +a term, so it's looking for the corresponding right angle bracket, and +not finding it. Chances are you left some needed parentheses out +earlier in the line, and you really meant a "less than". -=item Use of $* is deprecated +=item untie attempted while %d inner references still exist -(D deprecated) This variable magically turned on multi-line pattern matching, both for -you and for any luckless subroutine that you happen to call. You should -use the new C<//m> and C<//s> modifiers now to do that without the dangerous -action-at-a-distance effects of C<$*>. +(W untie) A copy of the object returned from C<tie> (or C<tied>) was +still valid when C<untie> was called. -=item Use of %s in printf format not supported +=item Useless use of %s in void context -(F) You attempted to use a feature of printf that is accessible from -only C. This usually means there's a better way to do it in Perl. +(W void) You did something without a side effect in a context that does +nothing with the return value, such as a statement that doesn't return a +value from a block, or the left side of a scalar comma operator. Very +often this points not to stupidity on your part, but a failure of Perl +to parse your program the way you thought it would. For example, you'd +get this if you mixed up your C precedence with Python precedence and +said -=item Use of bare << to mean <<"" is deprecated + $one, $two = 1, 2; -(D deprecated) You are now encouraged to use the explicitly quoted form if you -wish to use an empty line as the terminator of the here-document. +when you meant to say -=item Use of implicit split to @_ is deprecated + ($one, $two) = (1, 2); -(D deprecated) It makes a lot of work for the compiler when you clobber a -subroutine's argument list, so it's better if you assign the results of -a split() explicitly to an array (or list). +Another common error is to use ordinary parentheses to construct a list +reference when you should be using square or curly brackets, for +example, if you say -=item Use of inherited AUTOLOAD for non-method %s() is deprecated + $array = (1,2); -(D deprecated) As an (ahem) accidental feature, C<AUTOLOAD> subroutines are -looked up as methods (using the C<@ISA> hierarchy) even when the subroutines -to be autoloaded were called as plain functions (e.g. C<Foo::bar()>), -not as methods (e.g. C<< Foo->bar() >> or C<< $obj->bar() >>). +when you should have said -This bug will be rectified in Perl 5.005, which will use method lookup -only for methods' C<AUTOLOAD>s. However, there is a significant base -of existing code that may be using the old behavior. So, as an -interim step, Perl 5.004 issues an optional warning when non-methods -use inherited C<AUTOLOAD>s. + $array = [1,2]; -The simple rule is: Inheritance will not work when autoloading -non-methods. The simple fix for old code is: In any module that used to -depend on inheriting C<AUTOLOAD> for non-methods from a base class named -C<BaseClass>, execute C<*AUTOLOAD = \&BaseClass::AUTOLOAD> during startup. +The square brackets explicitly turn a list value into a scalar value, +while parentheses do not. So when a parenthesized list is evaluated in +a scalar context, the comma is treated like C's comma operator, which +throws away the left argument, which is not what you want. See +L<perlref> for more on this. -In code that currently says C<use AutoLoader; @ISA = qw(AutoLoader);> you -should remove AutoLoader from @ISA and change C<use AutoLoader;> to -C<use AutoLoader 'AUTOLOAD';>. +=item Useless use of "re" pragma -=item Use of reserved word "%s" is deprecated +(W) You did C<use re;> without any arguments. That isn't very useful. -(D deprecated) The indicated bareword is a reserved word. Future versions of perl -may use it as a keyword, so you're better off either explicitly quoting -the word in a manner appropriate for its context of use, or using a -different name altogether. The warning can be suppressed for subroutine -names by either adding a C<&> prefix, or using a package qualifier, -e.g. C<&our()>, or C<Foo::our()>. +=item "use" not allowed in expression -=item Use of %s is deprecated +(F) The "use" keyword is recognized and executed at compile time, and +returns no useful value. See L<perlmod>. -(D deprecated) The construct indicated is no longer recommended for use, generally -because there's a better way to do it, and also because the old way has -bad side effects. +=item Use of bare << to mean <<"" is deprecated -=item Use of uninitialized value%s +(D deprecated) You are now encouraged to use the explicitly quoted form +if you wish to use an empty line as the terminator of the here-document. -(W uninitialized) An undefined value was used as if it were already defined. It was -interpreted as a "" or a 0, but maybe it was a mistake. To suppress this -warning assign a defined value to your variables. +=item Use of implicit split to @_ is deprecated -=item Useless use of "re" pragma +(D deprecated) It makes a lot of work for the compiler when you clobber +a subroutine's argument list, so it's better if you assign the results +of a split() explicitly to an array (or list). -(W) You did C<use re;> without any arguments. That isn't very useful. +=item Use of inherited AUTOLOAD for non-method %s() is deprecated -=item Useless use of %s in void context +(D deprecated) As an (ahem) accidental feature, C<AUTOLOAD> subroutines +are looked up as methods (using the C<@ISA> hierarchy) even when the +subroutines to be autoloaded were called as plain functions (e.g. +C<Foo::bar()>), not as methods (e.g. C<< Foo->bar() >> or C<< +$obj->bar() >>). -(W void) You did something without a side effect in a context that does nothing -with the return value, such as a statement that doesn't return a value -from a block, or the left side of a scalar comma operator. Very often -this points not to stupidity on your part, but a failure of Perl to parse -your program the way you thought it would. For example, you'd get this -if you mixed up your C precedence with Python precedence and said +This bug will be rectified in future by using method lookup only for +methods' C<AUTOLOAD>s. However, there is a significant base of existing +code that may be using the old behavior. So, as an interim step, Perl +currently issues an optional warning when non-methods use inherited +C<AUTOLOAD>s. - $one, $two = 1, 2; +The simple rule is: Inheritance will not work when autoloading +non-methods. The simple fix for old code is: In any module that used +to depend on inheriting C<AUTOLOAD> for non-methods from a base class +named C<BaseClass>, execute C<*AUTOLOAD = \&BaseClass::AUTOLOAD> during +startup. -when you meant to say +In code that currently says C<use AutoLoader; @ISA = qw(AutoLoader);> +you should remove AutoLoader from @ISA and change C<use AutoLoader;> to +C<use AutoLoader 'AUTOLOAD';>. - ($one, $two) = (1, 2); +=item Use of %s in printf format not supported -Another common error is to use ordinary parentheses to construct a list -reference when you should be using square or curly brackets, for -example, if you say +(F) You attempted to use a feature of printf that is accessible from +only C. This usually means there's a better way to do it in Perl. - $array = (1,2); +=item Use of $* is deprecated -when you should have said +(D deprecated) This variable magically turned on multi-line pattern +matching, both for you and for any luckless subroutine that you happen +to call. You should use the new C<//m> and C<//s> modifiers now to do +that without the dangerous action-at-a-distance effects of C<$*>. - $array = [1,2]; +=item Use of %s is deprecated -The square brackets explicitly turn a list value into a scalar value, -while parentheses do not. So when a parenthesized list is evaluated in -a scalar context, the comma is treated like C's comma operator, which -throws away the left argument, which is not what you want. See -L<perlref> for more on this. +(D deprecated) The construct indicated is no longer recommended for use, +generally because there's a better way to do it, and also because the +old way has bad side effects. -=item untie attempted while %d inner references still exist +=item Use of $# is deprecated + +(D deprecated) This was an ill-advised attempt to emulate a poorly +defined B<awk> feature. Use an explicit printf() or sprintf() instead. -(W untie) A copy of the object returned from C<tie> (or C<tied>) was still -valid when C<untie> was called. +=item Use of reserved word "%s" is deprecated + +(D deprecated) The indicated bareword is a reserved word. Future +versions of perl may use it as a keyword, so you're better off either +explicitly quoting the word in a manner appropriate for its context of +use, or using a different name altogether. The warning can be +suppressed for subroutine names by either adding a C<&> prefix, or using +a package qualifier, e.g. C<&our()>, or C<Foo::our()>. + +=item Use of uninitialized value%s + +(W uninitialized) An undefined value was used as if it were already +defined. It was interpreted as a "" or a 0, but maybe it was a mistake. +To suppress this warning assign a defined value to your variables. + +To help you figure out what was undefined, perl tells you what operation +you used the undefined value in. Note, however, that perl optimizes your +program and the operation displayed in the warning may not necessarily +appear literally in your program. For example, C<"that $foo"> is +usually optimized into C<"that " . $foo>, and the warning will refer to +the C<concatenation (.)> operator, even though there is no C<.> in your +program. =item Value of %s can be "0"; test with defined() -(W misc) In a conditional expression, you used <HANDLE>, <*> (glob), C<each()>, -or C<readdir()> as a boolean value. Each of these constructs can return a -value of "0"; that would make the conditional expression false, which is -probably not what you intended. When using these constructs in conditional -expressions, test their values with the C<defined> operator. +(W misc) In a conditional expression, you used <HANDLE>, <*> (glob), +C<each()>, or C<readdir()> as a boolean value. Each of these constructs +can return a value of "0"; that would make the conditional expression +false, which is probably not what you intended. When using these +constructs in conditional expressions, test their values with the +C<defined> operator. =item Value of CLI symbol "%s" too long -(W misc) A warning peculiar to VMS. Perl tried to read the value of an %ENV -element from a CLI symbol table, and found a resultant string longer -than 1024 characters. The return value has been truncated to 1024 -characters. +(W misc) A warning peculiar to VMS. Perl tried to read the value of an +%ENV element from a CLI symbol table, and found a resultant string +longer than 1024 characters. The return value has been truncated to +1024 characters. =item Variable "%s" is not imported%s -(F) While "use strict" in effect, you referred to a global variable -that you apparently thought was imported from another module, because -something else of the same name (usually a subroutine) is exported -by that module. It usually means you put the wrong funny character -on the front of your variable. +(F) While "use strict" in effect, you referred to a global variable that +you apparently thought was imported from another module, because +something else of the same name (usually a subroutine) is exported by +that module. It usually means you put the wrong funny character on the +front of your variable. + +=item "%s" variable %s masks earlier declaration in same %s + +(W misc) A "my" or "our" variable has been redeclared in the current +scope or statement, effectively eliminating all access to the previous +instance. This is almost always a typographical error. Note that the +earlier variable will still exist until the end of the scope or until +all closure referents to it are destroyed. =item Variable "%s" may be unavailable -(W closure) An inner (nested) I<anonymous> subroutine is inside a I<named> -subroutine, and outside that is another subroutine; and the anonymous -(innermost) subroutine is referencing a lexical variable defined in -the outermost subroutine. For example: +(W closure) An inner (nested) I<anonymous> subroutine is inside a +I<named> subroutine, and outside that is another subroutine; and the +anonymous (innermost) subroutine is referencing a lexical variable +defined in the outermost subroutine. For example: sub outermost { my $a; sub middle { sub { $a } } } If the anonymous subroutine is called or referenced (directly or -indirectly) from the outermost subroutine, it will share the variable -as you would expect. But if the anonymous subroutine is called or -referenced when the outermost subroutine is not active, it will see -the value of the shared variable as it was before and during the -*first* call to the outermost subroutine, which is probably not what -you want. - -In these circumstances, it is usually best to make the middle -subroutine anonymous, using the C<sub {}> syntax. Perl has specific -support for shared variables in nested anonymous subroutines; a named -subroutine in between interferes with this feature. +indirectly) from the outermost subroutine, it will share the variable as +you would expect. But if the anonymous subroutine is called or +referenced when the outermost subroutine is not active, it will see the +value of the shared variable as it was before and during the *first* +call to the outermost subroutine, which is probably not what you want. + +In these circumstances, it is usually best to make the middle subroutine +anonymous, using the C<sub {}> syntax. Perl has specific support for +shared variables in nested anonymous subroutines; a named subroutine in +between interferes with this feature. + +=item Variable syntax + +(A) You've accidentally run your script through B<csh> instead +of Perl. Check the #! line, or manually feed your script into +Perl yourself. =item Variable "%s" will not stay shared -(W closure) An inner (nested) I<named> subroutine is referencing a lexical -variable defined in an outer subroutine. +(W closure) An inner (nested) I<named> subroutine is referencing a +lexical variable defined in an outer subroutine. When the inner subroutine is called, it will probably see the value of -the outer subroutine's variable as it was before and during the -*first* call to the outer subroutine; in this case, after the first -call to the outer subroutine is complete, the inner and outer -subroutines will no longer share a common value for the variable. In -other words, the variable will no longer be shared. +the outer subroutine's variable as it was before and during the *first* +call to the outer subroutine; in this case, after the first call to the +outer subroutine is complete, the inner and outer subroutines will no +longer share a common value for the variable. In other words, the +variable will no longer be shared. Furthermore, if the outer subroutine is anonymous and references a lexical variable outside itself, then the outer and inner subroutines @@ -3463,15 +3769,14 @@ will I<never> share the given variable. This problem can usually be solved by making the inner subroutine anonymous, using the C<sub {}> syntax. When inner anonymous subs that -reference variables in outer subroutines are called or referenced, -they are automatically rebound to the current values of such -variables. +reference variables in outer subroutines are called or referenced, they +are automatically rebound to the current values of such variables. -=item Variable syntax +=item Variable length lookbehind not implemented before << HERE in %s -(A) You've accidentally run your script through B<csh> instead -of Perl. Check the #! line, or manually feed your script into -Perl yourself. +(F) Lookbehind is allowed only for subexpressions whose length is fixed and +known at compile time. The << HERE shows in the regular expression about where +the problem was discovered. =item Version number must be a constant number @@ -3479,27 +3784,6 @@ Perl yourself. its equivalent C<BEGIN> block found an internal inconsistency with the version number. -=item perl: warning: Setting locale failed. - -(S) The whole warning message will look something like: - - perl: warning: Setting locale failed. - perl: warning: Please check that your locale settings: - LC_ALL = "En_US", - LANG = (unset) - are supported and installed on your system. - perl: warning: Falling back to the standard locale ("C"). - -Exactly what were the failed locale settings varies. In the above the -settings were that the LC_ALL was "En_US" and the LANG had no value. -This error means that Perl detected that you and/or your system -administrator have set up the so-called variable system but Perl could -not use those settings. This was not dead serious, fortunately: there -is a "default locale" called "C" that Perl can and will use, the -script will be run. Before you really fix the problem, however, you -will get the same error message each time you run Perl. How to really -fix the problem can be found in L<perllocale> section B<LOCALE PROBLEMS>. - =item Warning: something's wrong (W) You passed warn() an empty string (the equivalent of C<warn "">) or @@ -3507,15 +3791,16 @@ you called it with no args and C<$_> was empty. =item Warning: unable to close filehandle %s properly -(S) The implicit close() done by an open() got an error indication on the -close(). This usually indicates your file system ran out of disk space. +(S) The implicit close() done by an open() got an error indication on +the close(). This usually indicates your file system ran out of disk +space. =item Warning: Use of "%s" without parentheses is ambiguous -(S ambiguous) You wrote a unary operator followed by something that looks like a -binary operator that could also have been interpreted as a term or -unary operator. For instance, if you know that the rand function -has a default argument of 1.0, and you write +(S ambiguous) You wrote a unary operator followed by something that +looks like a binary operator that could also have been interpreted as a +term or unary operator. For instance, if you know that the rand +function has a default argument of 1.0, and you write rand + 5; @@ -3529,10 +3814,14 @@ but in actual fact, you got So put in parentheses to say what you really mean. +=item Wide character in %s + +(F) Perl met a wide character (>255) when it wasn't expecting one. + =item write() on closed filehandle %s -(W closed) The filehandle you're writing to got itself closed sometime before now. -Check your logic flow. +(W closed) The filehandle you're writing to got itself closed sometime +before now. Check your logic flow. =item X outside of string @@ -3546,99 +3835,34 @@ the end of the string being unpacked. See L<perlfunc/pack>. =item Xsub "%s" called in sort -(F) The use of an external subroutine as a sort comparison is not yet supported. +(F) The use of an external subroutine as a sort comparison is not yet +supported. =item Xsub called in sort -(F) The use of an external subroutine as a sort comparison is not yet supported. +(F) The use of an external subroutine as a sort comparison is not yet +supported. =item You can't use C<-l> on a filehandle -(F) A filehandle represents an opened file, and when you opened the file it -already went past any symlink you are presumably trying to look for. +(F) A filehandle represents an opened file, and when you opened the file +it already went past any symlink you are presumably trying to look for. Use a filename instead. =item YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET! (F) And you probably never will, because you probably don't have the sources to your kernel, and your vendor probably doesn't give a rip -about what you want. Your best bet is to use the wrapsuid script in -the eg directory to put a setuid C wrapper around your script. +about what you want. Your best bet is to use the wrapsuid script in the +eg directory to put a setuid C wrapper around your script. =item You need to quote "%s" -(W syntax) You assigned a bareword as a signal handler name. Unfortunately, you -already have a subroutine of that name declared, which means that Perl 5 -will try to call the subroutine when the assignment is executed, which is -probably not what you want. (If it IS what you want, put an & in front.) - -=item %cetsockopt() on closed socket %s - -(W closed) You tried to get or set a socket option on a closed socket. -Did you forget to check the return value of your socket() call? -See L<perlfunc/getsockopt> and L<perlfunc/setsockopt>. - -=item \1 better written as $1 - -(W syntax) Outside of patterns, backreferences live on as variables. The use -of backslashes is grandfathered on the right-hand side of a -substitution, but stylistically it's better to use the variable form -because other Perl programmers will expect it, and it works better -if there are more than 9 backreferences. - -=item '|' and '<' may not both be specified on command line - -(F) An error peculiar to VMS. Perl does its own command line redirection, and -found that STDIN was a pipe, and that you also tried to redirect STDIN using -'<'. Only one STDIN stream to a customer, please. - -=item '|' and '>' may not both be specified on command line - -(F) An error peculiar to VMS. Perl does its own command line redirection, and -thinks you tried to redirect stdout both to a file and into a pipe to another -command. You need to choose one or the other, though nothing's stopping you -from piping into a program or Perl script which 'splits' output into two -streams, such as - - open(OUT,">$ARGV[0]") or die "Can't write to $ARGV[0]: $!"; - while (<STDIN>) { - print; - print OUT; - } - close OUT; - -=item Got an error from DosAllocMem - -(P) An error peculiar to OS/2. Most probably you're using an obsolete -version of Perl, and this should not happen anyway. - -=item Malformed PERLLIB_PREFIX - -(F) An error peculiar to OS/2. PERLLIB_PREFIX should be of the form - - prefix1;prefix2 - -or - - prefix1 prefix2 - -with nonempty prefix1 and prefix2. If C<prefix1> is indeed a prefix -of a builtin library search path, prefix2 is substituted. The error -may appear if components are not found, or are too long. See -"PERLLIB_PREFIX" in F<README.os2>. - -=item PERL_SH_DIR too long - -(F) An error peculiar to OS/2. PERL_SH_DIR is the directory to find the -C<sh>-shell in. See "PERL_SH_DIR" in F<README.os2>. - -=item Process terminated by SIG%s - -(W) This is a standard message issued by OS/2 applications, while *nix -applications die in silence. It is considered a feature of the OS/2 -port. One can easily disable this by appropriate sighandlers, see -L<perlipc/"Signals">. See also "Process terminated by SIGTERM/SIGINT" -in F<README.os2>. +(W syntax) You assigned a bareword as a signal handler name. +Unfortunately, you already have a subroutine of that name declared, +which means that Perl 5 will try to call the subroutine when the +assignment is executed, which is probably not what you want. (If it IS +what you want, put an & in front.) =back diff --git a/contrib/perl5/pod/perlembed.pod b/contrib/perl5/pod/perlembed.pod index c4df676b19c0..ecbe1f6706c0 100644 --- a/contrib/perl5/pod/perlembed.pod +++ b/contrib/perl5/pod/perlembed.pod @@ -37,25 +37,45 @@ Read on... =over 5 -L<Compiling your C program> +=item * -L<Adding a Perl interpreter to your C program> +Compiling your C program -L<Calling a Perl subroutine from your C program> +=item * -L<Evaluating a Perl statement from your C program> +Adding a Perl interpreter to your C program -L<Performing Perl pattern matches and substitutions from your C program> +=item * -L<Fiddling with the Perl stack from your C program> +Calling a Perl subroutine from your C program -L<Maintaining a persistent interpreter> +=item * -L<Maintaining multiple interpreter instances> +Evaluating a Perl statement from your C program -L<Using Perl modules, which themselves use C libraries, from your C program> +=item * -L<Embedding Perl under Win32> +Performing Perl pattern matches and substitutions from your C program + +=item * + +Fiddling with the Perl stack from your C program + +=item * + +Maintaining a persistent interpreter + +=item * + +Maintaining multiple interpreter instances + +=item * + +Using Perl modules, which themselves use C libraries, from your C program + +=item * + +Embedding Perl under Win32 =back @@ -258,9 +278,8 @@ and package C<END {}> blocks. If you want to pass arguments to the Perl subroutine, you can add strings to the C<NULL>-terminated C<args> list passed to I<call_argv>. For other data types, or to examine return values, -you'll need to manipulate the Perl stack. That's demonstrated in the -last section of this document: L<Fiddling with the Perl stack from -your C program>. +you'll need to manipulate the Perl stack. That's demonstrated in +L<Fiddling with the Perl stack from your C program>. =head2 Evaluating a Perl statement from your C program @@ -356,7 +375,7 @@ made. int matches(SV *string, char *pattern, AV **matches); Given an C<SV>, a pattern, and a pointer to an empty C<AV>, -matches() evaluates C<$string =~ $pattern> in an array context, and +matches() evaluates C<$string =~ $pattern> in a list context, and fills in I<matches> with the array elements, returning the number of matches found. Here's a sample program, I<match.c>, that uses all three (long lines have @@ -434,7 +453,7 @@ been wrapped here): /** matches(string, pattern, matches) ** - ** Used for matches in an array context. + ** Used for matches in a list context. ** ** Returns the number of matches, ** and fills in **matches with the matching substrings @@ -796,9 +815,11 @@ during a session. Such an application might sporadically decide to release any resources associated with the interpreter. The program must take care to ensure that this takes place I<before> -the next interpreter is constructed. By default, the global variable +the next interpreter is constructed. By default, when perl is not +built with any special options, the global variable C<PL_perl_destruct_level> is set to C<0>, since extra cleaning isn't -needed when a program has only one interpreter. +usually needed when a program only ever creates a single interpreter +in its entire lifetime. Setting C<PL_perl_destruct_level> to C<1> makes everything squeaky clean: @@ -820,9 +841,16 @@ When I<perl_destruct()> is called, the interpreter's syntax parse tree and symbol tables are cleaned up, and global variables are reset. Now suppose we have more than one interpreter instance running at the -same time. This is feasible, but only if you used the -C<-DMULTIPLICITY> flag when building Perl. By default, that sets -C<PL_perl_destruct_level> to C<1>. +same time. This is feasible, but only if you used the Configure option +C<-Dusemultiplicity> or the options C<-Dusethreads -Duseithreads> when +building Perl. By default, enabling one of these Configure options +sets the per-interpreter global variable C<PL_perl_destruct_level> to +C<1>, so that thorough cleaning is automatic. + +Using C<-Dusethreads -Duseithreads> rather than C<-Dusemultiplicity> +is more appropriate if you intend to run multiple interpreters +concurrently in different threads, because it enables support for +linking in the thread libraries of your system with the interpreter. Let's give it a try: @@ -843,22 +871,41 @@ Let's give it a try: char *one_args[] = { "one_perl", SAY_HELLO }; char *two_args[] = { "two_perl", SAY_HELLO }; + PERL_SET_CONTEXT(one_perl); perl_construct(one_perl); + PERL_SET_CONTEXT(two_perl); perl_construct(two_perl); + PERL_SET_CONTEXT(one_perl); perl_parse(one_perl, NULL, 3, one_args, (char **)NULL); + PERL_SET_CONTEXT(two_perl); perl_parse(two_perl, NULL, 3, two_args, (char **)NULL); + PERL_SET_CONTEXT(one_perl); perl_run(one_perl); + PERL_SET_CONTEXT(two_perl); perl_run(two_perl); + PERL_SET_CONTEXT(one_perl); perl_destruct(one_perl); + PERL_SET_CONTEXT(two_perl); perl_destruct(two_perl); + PERL_SET_CONTEXT(one_perl); perl_free(one_perl); + PERL_SET_CONTEXT(two_perl); perl_free(two_perl); } +Note the calls to PERL_SET_CONTEXT(). These are necessary to initialize +the global state that tracks which interpreter is the "current" one on +the particular process or thread that may be running it. It should +always be used if you have more than one interpreter and are making +perl API calls on both interpreters in an interleaved fashion. + +PERL_SET_CONTEXT(interp) should also be called whenever C<interp> is +used by a thread that did not create it (using either perl_alloc(), or +the more esoteric perl_clone()). Compile as usual: @@ -894,21 +941,14 @@ That's where the glue code can be inserted to create the initial contact between Perl and linked C/C++ routines. Let's take a look some pieces of I<perlmain.c> to see how Perl does this: + static void xs_init (pTHX); - #ifdef __cplusplus - # define EXTERN_C extern "C" - #else - # define EXTERN_C extern - #endif - - static void xs_init (void); - - EXTERN_C void boot_DynaLoader (CV* cv); - EXTERN_C void boot_Socket (CV* cv); + EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); + EXTERN_C void boot_Socket (pTHX_ CV* cv); EXTERN_C void - xs_init() + xs_init(pTHX) { char *file = __FILE__; /* DynaLoader is a special case */ @@ -957,19 +997,11 @@ Consult L<perlxs>, L<perlguts>, and L<perlapi> for more details. =head1 Embedding Perl under Win32 -At the time of this writing (5.004), there are two versions of Perl -which run under Win32. (The two versions are merging in 5.005.) -Interfacing to ActiveState's Perl library is quite different from the -examples in this documentation, as significant changes were made to -the internal Perl API. However, it is possible to embed ActiveState's -Perl runtime. For details, see the Perl for Win32 FAQ at -http://www.perl.com/CPAN/doc/FAQs/win32/perlwin32faq.html. - -With the "official" Perl version 5.004 or higher, all the examples -within this documentation will compile and run untouched, although -the build process is slightly different between Unix and Win32. +In general, all of the source code shown here should work unmodified under +Windows. -For starters, backticks don't work under the Win32 native command shell. +However, there are some caveats about the command-line examples shown. +For starters, backticks won't work under the Win32 native command shell. The ExtUtils::Embed kit on CPAN ships with a script called B<genmake>, which generates a simple makefile to build a program from a single C source file. It can be used like this: diff --git a/contrib/perl5/pod/perlfaq.pod b/contrib/perl5/pod/perlfaq.pod index fa6943f0db0e..bc29c694f2c5 100644 --- a/contrib/perl5/pod/perlfaq.pod +++ b/contrib/perl5/pod/perlfaq.pod @@ -4,710 +4,1303 @@ perlfaq - frequently asked questions about Perl ($Date: 1999/05/23 20:38:02 $) =head1 DESCRIPTION -This document is structured into the following sections: +The perlfaq is structured into the following documents: -=over -=item perlfaq: Structural overview of the FAQ. +=head2 perlfaq: Structural overview of the FAQ. This document. -=item L<perlfaq1>: General Questions About Perl +=head2 L<perlfaq1>: General Questions About Perl Very general, high-level information about Perl. =over 4 -=item * What is Perl? +=item * -=item * Who supports Perl? Who develops it? Why is it free? +What is Perl? -=item * Which version of Perl should I use? +=item * -=item * What are perl4 and perl5? +Who supports Perl? Who develops it? Why is it free? -=item * What is perl6? +=item * -=item * How stable is Perl? +Which version of Perl should I use? -=item * Is Perl difficult to learn? +=item * -=item * How does Perl compare with other languages like Java, Python, REXX, Scheme, or Tcl? +What are perl4 and perl5? -=item * Can I do [task] in Perl? +=item * -=item * When shouldn't I program in Perl? +What is perl6? -=item * What's the difference between "perl" and "Perl"? +=item * -=item * Is it a Perl program or a Perl script? +How stable is Perl? -=item * What is a JAPH? +=item * -=item * Where can I get a list of Larry Wall witticisms? +Is Perl difficult to learn? -=item * How can I convince my sysadmin/supervisor/employees to use version (5/5.005/Perl instead of some other language)? +=item * + +How does Perl compare with other languages like Java, Python, REXX, Scheme, or Tcl? + +=item * + +Can I do [task] in Perl? + +=item * + +When shouldn't I program in Perl? + +=item * + +What's the difference between "perl" and "Perl"? + +=item * + +Is it a Perl program or a Perl script? + +=item * + +What is a JAPH? + +=item * + +Where can I get a list of Larry Wall witticisms? + +=item * + +How can I convince my sysadmin/supervisor/employees to use version 5/5.005/Perl instead of some other language? =back -=item L<perlfaq2>: Obtaining and Learning about Perl +=head2 L<perlfaq2>: Obtaining and Learning about Perl Where to find source and documentation to Perl, support, and related matters. =over 4 -=item * What machines support Perl? Where do I get it? +=item * + +What machines support Perl? Where do I get it? + +=item * + +How can I get a binary version of Perl? + +=item * -=item * How can I get a binary version of Perl? +I don't have a C compiler on my system. How can I compile perl? -=item * I don't have a C compiler on my system. How can I compile perl? +=item * -=item * I copied the Perl binary from one machine to another, but scripts don't work. +I copied the Perl binary from one machine to another, but scripts don't work. -=item * I grabbed the sources and tried to compile but gdbm/dynamic loading/malloc/linking/... failed. How do I make it work? +=item * -=item * What modules and extensions are available for Perl? What is CPAN? What does CPAN/src/... mean? +I grabbed the sources and tried to compile but gdbm/dynamic loading/malloc/linking/... failed. How do I make it work? -=item * Is there an ISO or ANSI certified version of Perl? +=item * -=item * Where can I get information on Perl? +What modules and extensions are available for Perl? What is CPAN? What does CPAN/src/... mean? -=item * What are the Perl newsgroups on USENET? Where do I post questions? +=item * -=item * Where should I post source code? +Is there an ISO or ANSI certified version of Perl? -=item * Perl Books +=item * -=item * Perl in Magazines +Where can I get information on Perl? -=item * Perl on the Net: FTP and WWW Access +=item * -=item * What mailing lists are there for perl? +What are the Perl newsgroups on Usenet? Where do I post questions? -=item * Archives of comp.lang.perl.misc +=item * -=item * Where can I buy a commercial version of Perl? +Where should I post source code? -=item * Where do I send bug reports? +=item * -=item * What is perl.com? +Perl Books + +=item * + +Perl in Magazines + +=item * + +Perl on the Net: FTP and WWW Access + +=item * + +What mailing lists are there for Perl? + +=item * + +Archives of comp.lang.perl.misc + +=item * + +Where can I buy a commercial version of Perl? + +=item * + +Where do I send bug reports? + +=item * + +What is perl.com? Perl Mongers? pm.org? perl.org? =back -=item L<perlfaq3>: Programming Tools +=head2 L<perlfaq3>: Programming Tools Programmer tools and programming support. =over 4 -=item * How do I do (anything)? +=item * + +How do I do (anything)? + +=item * + +How can I use Perl interactively? + +=item * + +Is there a Perl shell? -=item * How can I use Perl interactively? +=item * -=item * Is there a Perl shell? +How do I debug my Perl programs? -=item * How do I debug my Perl programs? +=item * -=item * How do I profile my Perl programs? +How do I profile my Perl programs? -=item * How do I cross-reference my Perl programs? +=item * -=item * Is there a pretty-printer (formatter) for Perl? +How do I cross-reference my Perl programs? -=item * Is there a ctags for Perl? +=item * -=item * Is there an IDE or Windows Perl Editor? +Is there a pretty-printer (formatter) for Perl? -=item * Where can I get Perl macros for vi? +=item * -=item * Where can I get perl-mode for emacs? +Is there a ctags for Perl? -=item * How can I use curses with Perl? +=item * -=item * How can I use X or Tk with Perl? +Is there an IDE or Windows Perl Editor? -=item * How can I generate simple menus without using CGI or Tk? +=item * -=item * What is undump? +Where can I get Perl macros for vi? -=item * How can I make my Perl program run faster? +=item * -=item * How can I make my Perl program take less memory? +Where can I get perl-mode for emacs? -=item * Is it unsafe to return a pointer to local data? +=item * -=item * How can I free an array or hash so my program shrinks? +How can I use curses with Perl? -=item * How can I make my CGI script more efficient? +=item * -=item * How can I hide the source for my Perl program? +How can I use X or Tk with Perl? -=item * How can I compile my Perl program into byte code or C? +=item * -=item * How can I compile Perl into Java? +How can I generate simple menus without using CGI or Tk? -=item * How can I get C<#!perl> to work on [MS-DOS,NT,...]? +=item * -=item * Can I write useful perl programs on the command line? +What is undump? -=item * Why don't perl one-liners work on my DOS/Mac/VMS system? +=item * -=item * Where can I learn about CGI or Web programming in Perl? +How can I make my Perl program run faster? -=item * Where can I learn about object-oriented Perl programming? +=item * -=item * Where can I learn about linking C with Perl? [h2xs, xsubpp] +How can I make my Perl program take less memory? -=item * I've read perlembed, perlguts, etc., but I can't embed perl in -my C program, what am I doing wrong? +=item * -=item * When I tried to run my script, I got this message. What does it +Is it unsafe to return a pointer to local data? + +=item * + +How can I free an array or hash so my program shrinks? + +=item * + +How can I make my CGI script more efficient? + +=item * + +How can I hide the source for my Perl program? + +=item * + +How can I compile my Perl program into byte code or C? + +=item * + +How can I compile Perl into Java? + +=item * + +How can I get C<#!perl> to work on [MS-DOS,NT,...]? + +=item * + +Can I write useful Perl programs on the command line? + +=item * + +Why don't Perl one-liners work on my DOS/Mac/VMS system? + +=item * + +Where can I learn about CGI or Web programming in Perl? + +=item * + +Where can I learn about object-oriented Perl programming? + +=item * + +Where can I learn about linking C with Perl? [h2xs, xsubpp] + +=item * + +I've read perlembed, perlguts, etc., but I can't embed perl in +my C program; what am I doing wrong? + +=item * + +When I tried to run my script, I got this message. What does it mean? -=item * What's MakeMaker? +=item * + +What's MakeMaker? =back -=item L<perlfaq4>: Data Manipulation +=head2 L<perlfaq4>: Data Manipulation Manipulating numbers, dates, strings, arrays, hashes, and miscellaneous data issues. =over 4 -=item * Why am I getting long decimals (eg, 19.9499999999999) instead of the numbers I should be getting (eg, 19.95)? +=item * + +Why am I getting long decimals (eg, 19.9499999999999) instead of the numbers I should be getting (eg, 19.95)? + +=item * + +Why isn't my octal data interpreted correctly? + +=item * + +Does Perl have a round() function? What about ceil() and floor()? Trig functions? + +=item * + +How do I convert bits into ints? + +=item * + +Why doesn't & work the way I want it to? + +=item * -=item * Why isn't my octal data interpreted correctly? +How do I multiply matrices? -=item * Does Perl have a round() function? What about ceil() and floor()? Trig functions? +=item * -=item * How do I convert bits into ints? +How do I perform an operation on a series of integers? -=item * Why doesn't & work the way I want it to? +=item * -=item * How do I multiply matrices? +How can I output Roman numerals? -=item * How do I perform an operation on a series of integers? +=item * -=item * How can I output Roman numerals? +Why aren't my random numbers random? -=item * Why aren't my random numbers random? +=item * -=item * How do I find the week-of-the-year/day-of-the-year? +How do I find the week-of-the-year/day-of-the-year? -=item * How do I find the current century or millennium? +=item * -=item * How can I compare two dates and find the difference? +How do I find the current century or millennium? -=item * How can I take a string and turn it into epoch seconds? +=item * -=item * How can I find the Julian Day? +How can I compare two dates and find the difference? -=item * How do I find yesterday's date? +=item * -=item * Does Perl have a year 2000 problem? Is Perl Y2K compliant? +How can I take a string and turn it into epoch seconds? -=item * How do I validate input? +=item * -=item * How do I unescape a string? +How can I find the Julian Day? -=item * How do I remove consecutive pairs of characters? +=item * -=item * How do I expand function calls in a string? +How do I find yesterday's date? -=item * How do I find matching/nesting anything? +=item * -=item * How do I reverse a string? +Does Perl have a Year 2000 problem? Is Perl Y2K compliant? -=item * How do I expand tabs in a string? +=item * -=item * How do I reformat a paragraph? +How do I validate input? -=item * How can I access/change the first N letters of a string? +=item * -=item * How do I change the Nth occurrence of something? +How do I unescape a string? -=item * How can I count the number of occurrences of a substring within a string? +=item * -=item * How do I capitalize all the words on one line? +How do I remove consecutive pairs of characters? -=item * How can I split a [character] delimited string except when inside +=item * + +How do I expand function calls in a string? + +=item * + +How do I find matching/nesting anything? + +=item * + +How do I reverse a string? + +=item * + +How do I expand tabs in a string? + +=item * + +How do I reformat a paragraph? + +=item * + +How can I access/change the first N letters of a string? + +=item * + +How do I change the Nth occurrence of something? + +=item * + +How can I count the number of occurrences of a substring within a string? + +=item * + +How do I capitalize all the words on one line? + +=item * + +How can I split a [character] delimited string except when inside [character]? (Comma-separated files) -=item * How do I strip blank space from the beginning/end of a string? +=item * + +How do I strip blank space from the beginning/end of a string? + +=item * + +How do I pad a string with blanks or pad a number with zeroes? + +=item * + +How do I extract selected columns from a string? + +=item * + +How do I find the soundex value of a string? + +=item * + +How can I expand variables in text strings? + +=item * + +What's wrong with always quoting "$vars"? + +=item * + +Why don't my <<HERE documents work? + +=item * + +What is the difference between a list and an array? + +=item * + +What is the difference between $array[1] and @array[1]? + +=item * + +How can I remove duplicate elements from a list or array? -=item * How do I pad a string with blanks or pad a number with zeroes? +=item * -=item * How do I extract selected columns from a string? +How can I tell whether a list or array contains a certain element? -=item * How do I find the soundex value of a string? +=item * -=item * How can I expand variables in text strings? +How do I compute the difference of two arrays? How do I compute the intersection of two arrays? -=item * What's wrong with always quoting "$vars"? +=item * -=item * Why don't my <<HERE documents work? +How do I test whether two arrays or hashes are equal? -=item * What is the difference between a list and an array? +=item * -=item * What is the difference between $array[1] and @array[1]? +How do I find the first array element for which a condition is true? -=item * How can I remove duplicate elements from a list or array? +=item * -=item * How can I tell whether a list or array contains a certain element? +How do I handle linked lists? -=item * How do I compute the difference of two arrays? How do I compute the intersection of two arrays? +=item * -=item * How do I test whether two arrays or hashes are equal? +How do I handle circular lists? -=item * How do I find the first array element for which a condition is true? +=item * -=item * How do I handle linked lists? +How do I shuffle an array randomly? -=item * How do I handle circular lists? +=item * -=item * How do I shuffle an array randomly? +How do I process/modify each element of an array? -=item * How do I process/modify each element of an array? +=item * -=item * How do I select a random element from an array? +How do I select a random element from an array? -=item * How do I permute N elements of a list? +=item * -=item * How do I sort an array by (anything)? +How do I permute N elements of a list? -=item * How do I manipulate arrays of bits? +=item * -=item * Why does defined() return true on empty arrays and hashes? +How do I sort an array by (anything)? -=item * How do I process an entire hash? +=item * -=item * What happens if I add or remove keys from a hash while iterating over it? +How do I manipulate arrays of bits? -=item * How do I look up a hash element by value? +=item * -=item * How can I know how many entries are in a hash? +Why does defined() return true on empty arrays and hashes? -=item * How do I sort a hash (optionally by value instead of key)? +=item * -=item * How can I always keep my hash sorted? +How do I process an entire hash? -=item * What's the difference between "delete" and "undef" with hashes? +=item * -=item * Why don't my tied hashes make the defined/exists distinction? +What happens if I add or remove keys from a hash while iterating over it? -=item * How do I reset an each() operation part-way through? +=item * -=item * How can I get the unique keys from two hashes? +How do I look up a hash element by value? -=item * How can I store a multidimensional array in a DBM file? +=item * -=item * How can I make my hash remember the order I put elements into it? +How can I know how many entries are in a hash? -=item * Why does passing a subroutine an undefined element in a hash create it? +=item * -=item * How can I make the Perl equivalent of a C structure/C++ class/hash or array of hashes or arrays? +How do I sort a hash (optionally by value instead of key)? -=item * How can I use a reference as a hash key? +=item * -=item * How do I handle binary data correctly? +How can I always keep my hash sorted? -=item * How do I determine whether a scalar is a number/whole/integer/float? +=item * -=item * How do I keep persistent data across program calls? +What's the difference between "delete" and "undef" with hashes? -=item * How do I print out or copy a recursive data structure? +=item * -=item * How do I define methods for every class/object? +Why don't my tied hashes make the defined/exists distinction? -=item * How do I verify a credit card checksum? +=item * -=item * How do I pack arrays of doubles or floats for XS code? +How do I reset an each() operation part-way through? + +=item * + +How can I get the unique keys from two hashes? + +=item * + +How can I store a multidimensional array in a DBM file? + +=item * + +How can I make my hash remember the order I put elements into it? + +=item * + +Why does passing a subroutine an undefined element in a hash create it? + +=item * + +How can I make the Perl equivalent of a C structure/C++ class/hash or array of hashes or arrays? + +=item * + +How can I use a reference as a hash key? + +=item * + +How do I handle binary data correctly? + +=item * + +How do I determine whether a scalar is a number/whole/integer/float? + +=item * + +How do I keep persistent data across program calls? + +=item * + +How do I print out or copy a recursive data structure? + +=item * + +How do I define methods for every class/object? + +=item * + +How do I verify a credit card checksum? + +=item * + +How do I pack arrays of doubles or floats for XS code? =back -=item L<perlfaq5>: Files and Formats +=head2 L<perlfaq5>: Files and Formats I/O and the "f" issues: filehandles, flushing, formats and footers. =over 4 -=item * How do I flush/unbuffer an output filehandle? Why must I do this? +=item * + +How do I flush/unbuffer an output filehandle? Why must I do this? + +=item * + +How do I change one line in a file/delete a line in a file/insert a line in the middle of a file/append to the beginning of a file? + +=item * + +How do I count the number of lines in a file? + +=item * + +How do I make a temporary file name? + +=item * + +How can I manipulate fixed-record-length files? + +=item * + +How can I make a filehandle local to a subroutine? How do I pass filehandles between subroutines? How do I make an array of filehandles? -=item * How do I change one line in a file/delete a line in a file/insert a line in the middle of a file/append to the beginning of a file? +=item * -=item * How do I count the number of lines in a file? +How can I use a filehandle indirectly? -=item * How do I make a temporary file name? +=item * -=item * How can I manipulate fixed-record-length files? +How can I set up a footer format to be used with write()? -=item * How can I make a filehandle local to a subroutine? How do I pass filehandles between subroutines? How do I make an array of filehandles? +=item * -=item * How can I use a filehandle indirectly? +How can I write() into a string? -=item * How can I set up a footer format to be used with write()? +=item * -=item * How can I write() into a string? +How can I output my numbers with commas added? -=item * How can I output my numbers with commas added? +=item * -=item * How can I translate tildes (~) in a filename? +How can I translate tildes (~) in a filename? -=item * How come when I open a file read-write it wipes it out? +=item * -=item * Why do I sometimes get an "Argument list too long" when I use <*>? +How come when I open a file read-write it wipes it out? -=item * Is there a leak/bug in glob()? +=item * -=item * How can I open a file with a leading ">" or trailing blanks? +Why do I sometimes get an "Argument list too long" when I use <*>? -=item * How can I reliably rename a file? +=item * -=item * How can I lock a file? +Is there a leak/bug in glob()? -=item * Why can't I just open(FH, ">file.lock")? +=item * -=item * I still don't get locking. I just want to increment the number in the file. How can I do this? +How can I open a file with a leading ">" or trailing blanks? -=item * How do I randomly update a binary file? +=item * -=item * How do I get a file's timestamp in perl? +How can I reliably rename a file? -=item * How do I set a file's timestamp in perl? +=item * -=item * How do I print to more than one file at once? +How can I lock a file? -=item * How can I read in an entire file all at once? +=item * -=item * How can I read in a file by paragraphs? +Why can't I just open(FH, ">file.lock")? -=item * How can I read a single character from a file? From the keyboard? +=item * -=item * How can I tell whether there's a character waiting on a filehandle? +I still don't get locking. I just want to increment the number in the file. How can I do this? -=item * How do I do a C<tail -f> in perl? +=item * -=item * How do I dup() a filehandle in Perl? +How do I randomly update a binary file? -=item * How do I close a file descriptor by number? +=item * -=item * Why can't I use "C:\temp\foo" in DOS paths? What doesn't `C:\temp\foo.exe` work? +How do I get a file's timestamp in perl? -=item * Why doesn't glob("*.*") get all the files? +=item * -=item * Why does Perl let me delete read-only files? Why does C<-i> clobber protected files? Isn't this a bug in Perl? +How do I set a file's timestamp in perl? -=item * How do I select a random line from a file? +=item * -=item * Why do I get weird spaces when I print an array of lines? +How do I print to more than one file at once? + +=item * + +How can I read in an entire file all at once? + +=item * + +How can I read in a file by paragraphs? + +=item * + +How can I read a single character from a file? From the keyboard? + +=item * + +How can I tell whether there's a character waiting on a filehandle? + +=item * + +How do I do a C<tail -f> in perl? + +=item * + +How do I dup() a filehandle in Perl? + +=item * + +How do I close a file descriptor by number? + +=item * + +Why can't I use "C:\temp\foo" in DOS paths? What doesn't `C:\temp\foo.exe` work? + +=item * + +Why doesn't glob("*.*") get all the files? + +=item * + +Why does Perl let me delete read-only files? Why does C<-i> clobber protected files? Isn't this a bug in Perl? + +=item * + +How do I select a random line from a file? + +=item * + +Why do I get weird spaces when I print an array of lines? =back -=item L<perlfaq6>: Regexps +=head2 L<perlfaq6>: Regexps Pattern matching and regular expressions. =over 4 -=item * How can I hope to use regular expressions without creating illegible and unmaintainable code? +=item * + +How can I hope to use regular expressions without creating illegible and unmaintainable code? + +=item * + +I'm having trouble matching over more than one line. What's wrong? + +=item * + +How can I pull out lines between two patterns that are themselves on different lines? + +=item * + +I put a regular expression into $/ but it didn't work. What's wrong? + +=item * + +How do I substitute case insensitively on the LHS while preserving case on the RHS? + +=item * + +How can I make C<\w> match national character sets? + +=item * + +How can I match a locale-smart version of C</[a-zA-Z]/>? + +=item * -=item * I'm having trouble matching over more than one line. What's wrong? +How can I quote a variable to use in a regex? -=item * How can I pull out lines between two patterns that are themselves on different lines? +=item * -=item * I put a regular expression into $/ but it didn't work. What's wrong? +What is C</o> really for? -=item * How do I substitute case insensitively on the LHS, but preserving case on the RHS? +=item * -=item * How can I make C<\w> match national character sets? +How do I use a regular expression to strip C style comments from a file? -=item * How can I match a locale-smart version of C</[a-zA-Z]/>? +=item * -=item * How can I quote a variable to use in a regex? +Can I use Perl regular expressions to match balanced text? -=item * What is C</o> really for? +=item * -=item * How do I use a regular expression to strip C style comments from a file? +What does it mean that regexes are greedy? How can I get around it? -=item * Can I use Perl regular expressions to match balanced text? +=item * -=item * What does it mean that regexes are greedy? How can I get around it? +How do I process each word on each line? -=item * How do I process each word on each line? +=item * -=item * How can I print out a word-frequency or line-frequency summary? +How can I print out a word-frequency or line-frequency summary? -=item * How can I do approximate matching? +=item * -=item * How do I efficiently match many regular expressions at once? +How can I do approximate matching? -=item * Why don't word-boundary searches with C<\b> work for me? +=item * -=item * Why does using $&, $`, or $' slow my program down? +How do I efficiently match many regular expressions at once? -=item * What good is C<\G> in a regular expression? +=item * -=item * Are Perl regexes DFAs or NFAs? Are they POSIX compliant? +Why don't word-boundary searches with C<\b> work for me? -=item * What's wrong with using grep or map in a void context? +=item * -=item * How can I match strings with multibyte characters? +Why does using $&, $`, or $' slow my program down? -=item * How do I match a pattern that is supplied by the user? +=item * + +What good is C<\G> in a regular expression? + +=item * + +Are Perl regexes DFAs or NFAs? Are they POSIX compliant? + +=item * + +What's wrong with using grep or map in a void context? + +=item * + +How can I match strings with multibyte characters? + +=item * + +How do I match a pattern that is supplied by the user? =back -=item L<perlfaq7>: General Perl Language Issues +=head2 L<perlfaq7>: General Perl Language Issues General Perl language issues that don't clearly fit into any of the other sections. =over 4 -=item * Can I get a BNF/yacc/RE for the Perl language? +=item * + +Can I get a BNF/yacc/RE for the Perl language? + +=item * + +What are all these $@%&* punctuation signs, and how do I know when to use them? + +=item * + +Do I always/never have to quote my strings or use semicolons and commas? + +=item * + +How do I skip some return values? + +=item * + +How do I temporarily block warnings? + +=item * + +What's an extension? + +=item * + +Why do Perl operators have different precedence than C operators? + +=item * + +How do I declare/create a structure? + +=item * + +How do I create a module? + +=item * + +How do I create a class? + +=item * + +How can I tell if a variable is tainted? + +=item * + +What's a closure? + +=item * + +What is variable suicide and how can I prevent it? + +=item * + +How can I pass/return a {Function, FileHandle, Array, Hash, Method, Regex}? + +=item * -=item * What are all these $@%&* punctuation signs, and how do I know when to use them? +How do I create a static variable? -=item * Do I always/never have to quote my strings or use semicolons and commas? +=item * -=item * How do I skip some return values? +What's the difference between dynamic and lexical (static) scoping? Between local() and my()? -=item * How do I temporarily block warnings? +=item * -=item * What's an extension? +How can I access a dynamic variable while a similarly named lexical is in scope? -=item * Why do Perl operators have different precedence than C operators? +=item * -=item * How do I declare/create a structure? +What's the difference between deep and shallow binding? -=item * How do I create a module? +=item * -=item * How do I create a class? +Why doesn't "my($foo) = <FILE>;" work right? -=item * How can I tell if a variable is tainted? +=item * -=item * What's a closure? +How do I redefine a builtin function, operator, or method? -=item * What is variable suicide and how can I prevent it? +=item * -=item * How can I pass/return a {Function, FileHandle, Array, Hash, Method, Regex}? +What's the difference between calling a function as &foo and foo()? -=item * How do I create a static variable? +=item * -=item * What's the difference between dynamic and lexical (static) scoping? Between local() and my()? +How do I create a switch or case statement? -=item * How can I access a dynamic variable while a similarly named lexical is in scope? +=item * -=item * What's the difference between deep and shallow binding? +How can I catch accesses to undefined variables/functions/methods? -=item * Why doesn't "my($foo) = <FILE>;" work right? +=item * -=item * How do I redefine a builtin function, operator, or method? +Why can't a method included in this same file be found? -=item * What's the difference between calling a function as &foo and foo()? +=item * -=item * How do I create a switch or case statement? +How can I find out my current package? -=item * How can I catch accesses to undefined variables/functions/methods? +=item * -=item * Why can't a method included in this same file be found? +How can I comment out a large block of perl code? -=item * How can I find out my current package? +=item * -=item * How can I comment out a large block of perl code? +How do I clear a package? -=item * How do I clear a package? +=item * -=item * How can I use a variable as a variable name? +How can I use a variable as a variable name? =back -=item L<perlfaq8>: System Interaction +=head2 L<perlfaq8>: System Interaction Interprocess communication (IPC), control over the user-interface (keyboard, screen and pointing devices). =over 4 -=item * How do I find out which operating system I'm running under? +=item * -=item * How come exec() doesn't return? +How do I find out which operating system I'm running under? -=item * How do I do fancy stuff with the keyboard/screen/mouse? +=item * -=item * How do I print something out in color? +How come exec() doesn't return? -=item * How do I read just one key without waiting for a return key? +=item * -=item * How do I check whether input is ready on the keyboard? +How do I do fancy stuff with the keyboard/screen/mouse? -=item * How do I clear the screen? +=item * -=item * How do I get the screen size? +How do I print something out in color? -=item * How do I ask the user for a password? +=item * -=item * How do I read and write the serial port? +How do I read just one key without waiting for a return key? -=item * How do I decode encrypted password files? +=item * -=item * How do I start a process in the background? +How do I check whether input is ready on the keyboard? -=item * How do I trap control characters/signals? +=item * -=item * How do I modify the shadow password file on a Unix system? +How do I clear the screen? -=item * How do I set the time and date? +=item * -=item * How can I sleep() or alarm() for under a second? +How do I get the screen size? -=item * How can I measure time under a second? +=item * -=item * How can I do an atexit() or setjmp()/longjmp()? (Exception handling) +How do I ask the user for a password? -=item * Why doesn't my sockets program work under System V (Solaris)? What does the error message "Protocol not supported" mean? +=item * -=item * How can I call my system's unique C functions from Perl? +How do I read and write the serial port? -=item * Where do I get the include files to do ioctl() or syscall()? +=item * -=item * Why do setuid perl scripts complain about kernel problems? +How do I decode encrypted password files? -=item * How can I open a pipe both to and from a command? +=item * -=item * Why can't I get the output of a command with system()? +How do I start a process in the background? -=item * How can I capture STDERR from an external command? +=item * -=item * Why doesn't open() return an error when a pipe open fails? +How do I trap control characters/signals? -=item * What's wrong with using backticks in a void context? +=item * -=item * How can I call backticks without shell processing? +How do I modify the shadow password file on a Unix system? -=item * Why can't my script read from STDIN after I gave it EOF (^D on Unix, ^Z on MS-DOS)? +=item * -=item * How can I convert my shell script to perl? +How do I set the time and date? -=item * Can I use perl to run a telnet or ftp session? +=item * -=item * How can I write expect in Perl? +How can I sleep() or alarm() for under a second? -=item * Is there a way to hide perl's command line from programs such as "ps"? +=item * -=item * I {changed directory, modified my environment} in a perl script. How come the change disappeared when I exited the script? How do I get my changes to be visible? +How can I measure time under a second? -=item * How do I close a process's filehandle without waiting for it to complete? +=item * -=item * How do I fork a daemon process? +How can I do an atexit() or setjmp()/longjmp()? (Exception handling) -=item * How do I make my program run with sh and csh? +=item * -=item * How do I find out if I'm running interactively or not? +Why doesn't my sockets program work under System V (Solaris)? What does the error message "Protocol not supported" mean? -=item * How do I timeout a slow event? +=item * -=item * How do I set CPU limits? +How can I call my system's unique C functions from Perl? -=item * How do I avoid zombies on a Unix system? +=item * -=item * How do I use an SQL database? +Where do I get the include files to do ioctl() or syscall()? -=item * How do I make a system() exit on control-C? +=item * -=item * How do I open a file without blocking? +Why do setuid perl scripts complain about kernel problems? -=item * How do I install a module from CPAN? +=item * -=item * What's the difference between require and use? +How can I open a pipe both to and from a command? -=item * How do I keep my own module/library directory? +=item * -=item * How do I add the directory my program lives in to the module/library search path? +Why can't I get the output of a command with system()? -=item * How do I add a directory to my include path at runtime? +=item * -=item * What is socket.ph and where do I get it? +How can I capture STDERR from an external command? + +=item * + +Why doesn't open() return an error when a pipe open fails? + +=item * + +What's wrong with using backticks in a void context? + +=item * + +How can I call backticks without shell processing? + +=item * + +Why can't my script read from STDIN after I gave it EOF (^D on Unix, ^Z on MS-DOS)? + +=item * + +How can I convert my shell script to perl? + +=item * + +Can I use perl to run a telnet or ftp session? + +=item * + +How can I write expect in Perl? + +=item * + +Is there a way to hide perl's command line from programs such as "ps"? + +=item * + +I {changed directory, modified my environment} in a perl script. How come the change disappeared when I exited the script? How do I get my changes to be visible? + +=item * + +How do I close a process's filehandle without waiting for it to complete? + +=item * + +How do I fork a daemon process? + +=item * + +How do I find out if I'm running interactively or not? + +=item * + +How do I timeout a slow event? + +=item * + +How do I set CPU limits? + +=item * + +How do I avoid zombies on a Unix system? + +=item * + +How do I use an SQL database? + +=item * + +How do I make a system() exit on control-C? + +=item * + +How do I open a file without blocking? + +=item * + +How do I install a module from CPAN? + +=item * + +What's the difference between require and use? + +=item * + +How do I keep my own module/library directory? + +=item * + +How do I add the directory my program lives in to the module/library search path? + +=item * + +How do I add a directory to my include path at runtime? + +=item * + +What is socket.ph and where do I get it? =back -=item L<perlfaq9>: Networking +=head2 L<perlfaq9>: Networking Networking, the Internet, and a few on the web. =over 4 -=item * My CGI script runs from the command line but not the browser. (500 Server Error) +=item * -=item * How can I get better error messages from a CGI program? +My CGI script runs from the command line but not the browser. (500 Server Error) -=item * How do I remove HTML from a string? +=item * -=item * How do I extract URLs? +How can I get better error messages from a CGI program? -=item * How do I download a file from the user's machine? How do I open a file on another machine? +=item * -=item * How do I make a pop-up menu in HTML? +How do I remove HTML from a string? -=item * How do I fetch an HTML file? +=item * -=item * How do I automate an HTML form submission? +How do I extract URLs? -=item * How do I decode or create those %-encodings on the web? +=item * -=item * How do I redirect to another page? +How do I download a file from the user's machine? How do I open a file on another machine? -=item * How do I put a password on my web pages? +=item * -=item * How do I edit my .htpasswd and .htgroup files with Perl? +How do I make a pop-up menu in HTML? -=item * How do I make sure users can't enter values into a form that cause my CGI script to do bad things? +=item * -=item * How do I parse a mail header? +How do I fetch an HTML file? -=item * How do I decode a CGI form? +=item * -=item * How do I check a valid mail address? +How do I automate an HTML form submission? -=item * How do I decode a MIME/BASE64 string? +=item * -=item * How do I return the user's mail address? +How do I decode or create those %-encodings on the web? -=item * How do I send mail? +=item * -=item * How do I read mail? +How do I redirect to another page? -=item * How do I find out my hostname/domainname/IP address? +=item * -=item * How do I fetch a news article or the active newsgroups? +How do I put a password on my web pages? -=item * How do I fetch/put an FTP file? +=item * -=item * How can I do RPC in Perl? +How do I edit my .htpasswd and .htgroup files with Perl? -=back +=item * + +How do I make sure users can't enter values into a form that cause my CGI script to do bad things? + +=item * + +How do I parse a mail header? + +=item * + +How do I decode a CGI form? + +=item * + +How do I check a valid mail address? + +=item * +How do I decode a MIME/BASE64 string? + +=item * + +How do I return the user's mail address? + +=item * + +How do I send mail? + +=item * + +How do I read mail? + +=item * + +How do I find out my hostname/domainname/IP address? + +=item * + +How do I fetch a news article or the active newsgroups? + +=item * + +How do I fetch/put an FTP file? + +=item * + +How can I do RPC in Perl? =back -=head2 Where to get this document + +=head1 About the perlfaq documents + +=head2 Where to get the perlfaq This document is posted regularly to comp.lang.perl.announce and several other related newsgroups. It is available in a variety of -formats from CPAN in the /CPAN/doc/FAQs/FAQ/ directory, or on the web +formats from CPAN in the /CPAN/doc/FAQs/FAQ/ directory or on the web at http://www.perl.com/perl/faq/ . -=head2 How to contribute to this document +=head2 How to contribute to the perlfaq You may mail corrections, additions, and suggestions to perlfaq-suggestions@perl.com . This alias should not be @@ -740,11 +1333,11 @@ All rights reserved. =head2 Bundled Distributions -When included as part of the Standard Version of Perl, or as part of +When included as part of the Standard Version of Perl or as part of its complete documentation whether printed or otherwise, this work may be distributed only under the terms of Perl's Artistic License. Any distribution of this file or derivatives thereof I<outside> -of that package require that special arrangements be made with +of that package requires that special arrangements be made with copyright holder. Irrespective of its distribution, all code examples in these files @@ -764,6 +1357,10 @@ in respect of this information or its use. =over 4 +=item 1/November/2000 + +A few grammatical fixes and updates implemented by John Borwick. + =item 23/May/99 Extensive updates from the net in preparation for 5.6 release. diff --git a/contrib/perl5/pod/perlfaq1.pod b/contrib/perl5/pod/perlfaq1.pod index af4d7cbd04c3..68c6bfd92889 100644 --- a/contrib/perl5/pod/perlfaq1.pod +++ b/contrib/perl5/pod/perlfaq1.pod @@ -36,7 +36,7 @@ In particular, the core development team (known as the Perl Porters) are a rag-tag band of highly altruistic individuals committed to producing better software for free than you could hope to purchase for money. You may snoop on pending developments via -news://news.perl.com/perl.porters-gw/ and the Deja archive at +nntp://news.perl.com/perl.porters-gw/ and the Deja archive at http://www.deja.com/ using the perl.porters-gw newsgroup, or you can subscribe to the mailing list by sending perl5-porters-request@perl.org a subscription request. @@ -56,8 +56,8 @@ You should definitely use version 5. Version 4 is old, limited, and no longer maintained; its last patch (4.036) was in 1992, long ago and far away. Sure, it's stable, but so is anything that's dead; in fact, perl4 had been called a dead, flea-bitten camel carcass. The most recent -production release is 5.005_03 (although 5.004_05 is still supported). -The most cutting-edge development release is 5.005_57. Further references +production release is 5.6 (although 5.005_03 is still supported). +The most cutting-edge development release is 5.7. Further references to the Perl language in this document refer to the production release unless otherwise specified. There may be one or more official bug fixes by the time you read this, and also perhaps some experimental versions @@ -78,8 +78,8 @@ The 5.0 release is, essentially, a ground-up rewrite of the original perl source code from releases 1 through 4. It has been modularized, object-oriented, tweaked, trimmed, and optimized until it almost doesn't look like the old code. However, the interface is mostly the same, and -compatibility with previous releases is very high. See L<perltrap/"Perl4 -to Perl5 Traps">. +compatibility with previous releases is very high. +See L<perltrap/"Perl4 to Perl5 Traps">. To avoid the "what language is perl5?" confusion, some people prefer to simply use "perl" to refer to the latest version of perl and avoid using @@ -89,24 +89,21 @@ See L<perlhist> for a history of Perl revisions. =head2 What is perl6? -Perl6 is a semi-jocular reference to the Topaz project. Headed by Chip -Salzenberg, Topaz is yet-another ground-up rewrite of the current release -of Perl, one whose major goal is to create a more maintainable core than -found in release 5. Written in nominally portable C++, Topaz hopes to -maintain 100% source-compatibility with previous releases of Perl but to -run significantly faster and smaller. The Topaz team hopes to provide -an XS compatibility interface to allow most XS modules to work unchanged, -albeit perhaps without the efficiency that the new interface would allow. -New features in Topaz are as yet undetermined, and will be addressed -once compatibility and performance goals are met. - -If you are a hard-working C++ wizard with a firm command of Perl's -internals, and you would like to work on the project, send a request to -perl6-porters-request@perl.org to subscribe to the Topaz mailing list. - -There is no ETA for Topaz. It is expected to be several years before it -achieves enough robustness, compatibility, portability, and performance -to replace perl5 for ordinary use by mere mortals. +At The Second O'Reilly Open Source Software Convention, Larry Wall +announced Perl6 development would begin in earnest. Perl6 was an oft +used term for Chip Salzenberg's project to rewrite Perl in C++ named +Topaz. However, Topaz should not be confused with the nisus to rewrite +Perl while keeping the lessons learned from other software, as well as +Perl5, in mind. + +If you have a desire to help in the crusade to make Perl a better place +then peruse the Perl6 developers page at http://www.perl.org/perl6/ and +get involved. + +The first alpha release is expected by Summer 2001. + +"We're really serious about reinventing everything that needs reinventing." +--Larry Wall =head2 How stable is Perl? @@ -123,10 +120,10 @@ and the rare new keyword). =head2 Is Perl difficult to learn? -No, Perl is easy to start learning -- and easy to keep learning. It looks +No, Perl is easy to start learning--and easy to keep learning. It looks like most programming languages you're likely to have experience with, so if you've ever written a C program, an awk script, a shell -script, or even a BASIC program, you're already part way there. +script, or even a BASIC program, you're already partway there. Most tasks only require a small subset of the Perl language. One of the guiding mottos for Perl development is "there's more than one way @@ -186,7 +183,7 @@ languages that come to mind include prolog and matlab. =head2 When shouldn't I program in Perl? -When your manager forbids it -- but do consider replacing them :-). +When your manager forbids it--but do consider replacing them :-). Actually, one good reason is when you already have an existing application written in another language that's all done (and done @@ -204,7 +201,7 @@ limitations given in the previous statement to some degree, but understand that Perl remains fundamentally a dynamically typed language, not a statically typed one. You certainly won't be chastised if you don't trust nuclear-plant or brain-surgery monitoring code to it. And Larry -will sleep easier, too -- Wall Street programs not withstanding. :-) +will sleep easier, too--Wall Street programs not withstanding. :-) =head2 What's the difference between "perl" and "Perl"? @@ -223,17 +220,17 @@ Larry doesn't really care. He says (half in jest) that "a script is what you give the actors. A program is what you give the audience." Originally, a script was a canned sequence of normally interactive -commands, that is, a chat script. Something like a UUCP or PPP chat +commands--that is, a chat script. Something like a UUCP or PPP chat script or an expect script fits the bill nicely, as do configuration scripts run by a program at its start up, such F<.cshrc> or F<.ircrc>, for example. Chat scripts were just drivers for existing programs, not stand-alone programs in their own right. A computer scientist will correctly explain that all programs are -interpreted, and that the only question is at what level. But if you +interpreted and that the only question is at what level. But if you ask this question of someone who isn't a computer scientist, they might tell you that a I<program> has been compiled to physical machine code -once, and can then be run multiple times, whereas a I<script> must be +once and can then be run multiple times, whereas a I<script> must be translated by a program each time it's used. Perl programs are (usually) neither strictly compiled nor strictly @@ -266,7 +263,7 @@ Newer examples can be found by perusing Larry's postings: http://x1.dejanews.com/dnquery.xp?QRY=*&DBS=2&ST=PS&defaultOp=AND&LNG=ALL&format=terse&showsort=date&maxhits=100&subjects=&groups=&authors=larry@*wall.org&fromdate=&todate= -=head2 How can I convince my sysadmin/supervisor/employees to use version (5/5.005/Perl instead of some other language)? +=head2 How can I convince my sysadmin/supervisor/employees to use version 5/5.005/Perl instead of some other language? If your manager or employees are wary of unsupported software, or software which doesn't officially ship with your operating system, you @@ -275,15 +272,15 @@ more productive using and utilizing Perl constructs, functionality, simplicity, and power, then the typical manager/supervisor/employee may be persuaded. Regarding using Perl in general, it's also sometimes helpful to point out that delivery times may be reduced -using Perl, as compared to other languages. +using Perl compared to other languages. If you have a project which has a bottleneck, especially in terms of translation or testing, Perl almost certainly will provide a viable, -and quick solution. In conjunction with any persuasion effort, you +quick solution. In conjunction with any persuasion effort, you should not fail to point out that Perl is used, quite extensively, and with extremely reliable and valuable results, at many large computer -software and/or hardware companies throughout the world. In fact, -many Unix vendors now ship Perl by default, and support is usually +software and hardware companies throughout the world. In fact, +many Unix vendors now ship Perl by default. Support is usually just a news-posting away, if you can't find the answer in the I<comprehensive> documentation, including this FAQ. @@ -295,22 +292,29 @@ by the Perl Development Team. Another big sell for Perl5 is the large number of modules and extensions which greatly reduce development time for any given task. Also mention that the difference between version 4 and version 5 of Perl is like the difference between awk and C++. -(Well, OK, maybe not quite that distinct, but you get the idea.) If you -want support and a reasonable guarantee that what you're developing -will continue to work in the future, then you have to run the supported -version. That probably means running the 5.005 release, although 5.004 -isn't that bad. Several important bugs were fixed from the 5.000 through -5.003 versions, though, so try upgrading past them if possible. +(Well, OK, maybe it's not quite that distinct, but you get the idea.) +If you want support and a reasonable guarantee that what you're +developing will continue to work in the future, then you have to run +the supported version. As of April 2001 that probably means +running either of the releases 5.6.1 (released in April 2001) or +5.005_03 (released in March 1999), although 5.004_05 isn't that bad +if you B<absolutely> need such an old version (released in April 1999) +for stability reasons. Anything older than 5.004_05 shouldn't be used. Of particular note is the massive bug hunt for buffer overflow problems that went into the 5.004 release. All releases prior to that, including perl4, are considered insecure and should be upgraded as soon as possible. +In August 2000 in all Linux distributions a new security problem was +found in the optional 'suidperl' (not built or installed by default) +in all the Perl branches 5.6, 5.005, and 5.004, see +http://www.cpan.org/src/5.0/sperl-2000-08-05/ + =head1 AUTHOR AND COPYRIGHT -Copyright (c) 1997, 1998, 1999 Tom Christiansen and Nathan Torkington. -All rights reserved. +Copyright (c) 1997, 1998, 1999, 2000, 2001 Tom Christiansen and Nathan +Torkington. All rights reserved. When included as an integrated part of the Standard Distribution of Perl or of its documentation (printed or otherwise), this works is diff --git a/contrib/perl5/pod/perlfaq2.pod b/contrib/perl5/pod/perlfaq2.pod index af9178dee1ba..aecc1fc4c3be 100644 --- a/contrib/perl5/pod/perlfaq2.pod +++ b/contrib/perl5/pod/perlfaq2.pod @@ -12,17 +12,16 @@ related matters. The standard release of Perl (the one maintained by the perl development team) is distributed only in source code form. You -can find this at http://www.perl.com/CPAN/src/latest.tar.gz , which -in standard Internet format (a gzipped archive in POSIX tar format). +can find this at http://www.cpan.org/src/latest.tar.gz , which +is in a standard Internet format (a gzipped archive in POSIX tar format). Perl builds and runs on a bewildering number of platforms. Virtually all known and current Unix derivatives are supported (Perl's native platform), as are other systems like VMS, DOS, OS/2, Windows, -QNX, BeOS, and the Amiga. There are also the beginnings of support -for MPE/iX. +QNX, BeOS, OS X, MPE/iX and the Amiga. Binary distributions for some proprietary platforms, including -Apple systems, can be found http://www.perl.com/CPAN/ports/ directory. +Apple systems, can be found http://www.cpan.org/ports/ directory. Because these are not part of the standard distribution, they may and in fact do differ from the base Perl port in a variety of ways. You'll have to check their respective release notes to see just @@ -41,12 +40,11 @@ get free compilers for, not for Unix systems. Some URLs that might help you are: + http://www.cpan.org/ports/ http://language.perl.com/info/software.html - http://www.perl.com/pub/language/info/software.html#binary - http://www.perl.com/CPAN/ports/ Someone looking for a Perl for Win16 might look to Laszlo Molnar's djgpp -port in http://www.perl.com/CPAN/ports/msdos/ , which comes with clear +port in http://www.cpan.org/ports/#msdos , which comes with clear installation instructions. A simple installation guide for MS-DOS using Ilya Zakharevich's OS/2 port is available at http://www.cs.ruu.nl/%7Epiet/perl5dos.html @@ -69,19 +67,19 @@ eventually live on, and then type C<make install>. Most other approaches are doomed to failure. One simple way to check that things are in the right place is to print out -the hard-coded @INC which perl is looking for. +the hard-coded @INC that perl looks through for libraries: % perl -e 'print join("\n",@INC)' -If this command lists any paths which don't exist on your system, then you +If this command lists any paths that don't exist on your system, then you may need to move the appropriate libraries to these locations, or create symbolic links, aliases, or shortcuts appropriately. @INC is also printed as part of the output of % perl -V -You might also want to check out L<perlfaq8/"How do I keep my own -module/library directory?">. +You might also want to check out +L<perlfaq8/"How do I keep my own module/library directory?">. =head2 I grabbed the sources and tried to compile but gdbm/dynamic loading/malloc/linking/... failed. How do I make it work? @@ -92,26 +90,32 @@ architecture. =head2 What modules and extensions are available for Perl? What is CPAN? What does CPAN/src/... mean? -CPAN stands for Comprehensive Perl Archive Network, a huge archive -replicated on dozens of machines all over the world. CPAN contains +CPAN stands for Comprehensive Perl Archive Network, a ~700mb archive +replicated on nearly 200 machines all over the world. CPAN contains source code, non-native ports, documentation, scripts, and many third-party modules and extensions, designed for everything from commercial database interfaces to keyboard/screen control to web -walking and CGI scripts. The master machine for CPAN is -ftp://ftp.funet.fi/pub/languages/perl/CPAN/, but you can use the -address http://www.perl.com/CPAN/CPAN.html to fetch a copy from a -"site near you". See http://www.perl.com/CPAN (without a slash at the -end) for how this process works. +walking and CGI scripts. The master web site for CPAN is +http://www.cpan.org/ and there is the CPAN Multiplexer at +http://www.perl.com/CPAN/CPAN.html which will choose a mirror near you +via DNS. See http://www.perl.com/CPAN (without a slash at the +end) for how this process works. Also, http://mirror.cpan.org/ +has a nice interface to the http://www.cpan.org/MIRRORED.BY +mirror directory. + +See the CPAN FAQ at http://www.cpan.org/misc/cpan-faq.html for +answers to the most frequently asked questions about CPAN +including how to become a mirror. CPAN/path/... is a naming convention for files available on CPAN sites. CPAN indicates the base directory of a CPAN mirror, and the rest of the path is the path from that directory to the file. For instance, if you're using ftp://ftp.funet.fi/pub/languages/perl/CPAN -as your CPAN site, the file CPAN/misc/japh file is downloadable as +as your CPAN site, the file CPAN/misc/japh is downloadable as ftp://ftp.funet.fi/pub/languages/perl/CPAN/misc/japh . -Considering that there are hundreds of existing modules in the -archive, one probably exists to do nearly anything you can think of. +Considering that there are close to two thousand existing modules in +the archive, one probably exists to do nearly anything you can think of. Current categories under CPAN/modules/by-category/ include Perl core modules; development support; operating system interfaces; networking, devices, and interprocess communication; data type utilities; database @@ -122,6 +126,10 @@ compression; image manipulation; mail and news; control flow utilities; filehandle and I/O; Microsoft Windows modules; and miscellaneous modules. +See http://www.cpan.org/modules/00modlist.long.html or +http://search.cpan.org/ for a more complete list of modules by category. + + =head2 Is there an ISO or ANSI certified version of Perl? Certainly not. Larry expects that he'll be certified before Perl is. @@ -133,30 +141,33 @@ If you have Perl installed locally, you probably have the documentation installed as well: type C<man perl> if you're on a system resembling Unix. This will lead you to other important man pages, including how to set your $MANPATH. If you're not on a Unix system, access to the documentation -will be different; for example, it might be only in HTML format. But all +will be different; for example, documentation might only be in HTML format. All proper Perl installations have fully-accessible documentation. You might also try C<perldoc perl> in case your system doesn't have a proper man command, or it's been misinstalled. If that doesn't work, try looking in /usr/local/lib/perl5/pod for documentation. -If all else fails, consult the CPAN/doc directory, which contains the -complete documentation in various formats, including native pod, -troff, html, and plain text. There's also a web page at -http://www.perl.com/perl/info/documentation.html that might help. +If all else fails, consult http://perldoc.cpan.org/ or +http://www.perldoc.com/ both offer the complete documentation +in html format. -Many good books have been written about Perl -- see the section below +Many good books have been written about Perl--see the section below for more details. Tutorial documents are included in current or upcoming Perl releases -include L<perltoot> for objects, L<perlopentut> for file opening -semantics, L<perlreftut> for managing references, and L<perlxstut> -for linking C and Perl together. There may be more by the -time you read this. The following URLs might also be of +include L<perltoot> for objects or L<perlboot> for a beginner's +approach to objects, L<perlopentut> for file opening semantics, +L<perlreftut> for managing references, L<perlretut> for regular +expressions, L<perlthrtut> for threads, L<perldebtut> for debugging, +and L<perlxstut> for linking C and Perl together. There may be more +by the time you read this. The following URLs might also be of assistance: - http://language.perl.com/info/documentation.html + http://perldoc.cpan.org/ + http://www.perldoc.com/ http://reference.perl.com/query.cgi?tutorials + http://bookmarks.cpan.org/search.cgi?cat=Training%2FTutorials =head2 What are the Perl newsgroups on Usenet? Where do I post questions? @@ -183,53 +194,49 @@ to alt.sources, please make sure it follows their posting standards, including setting the Followup-To header line to NOT include alt.sources; see their FAQ (http://www.faqs.org/faqs/alt-sources-intro/) for details. -If you're just looking for software, first use AltaVista -(http://www.altavista.com), Deja (http://www.deja.com), and -search CPAN. This is faster and more productive than just posting -a request. +If you're just looking for software, first use Google +(http://www.google.com), Deja (http://www.deja.com), and +CPAN Search (http://search.cpan.org). This is faster and more +productive than just posting a request. =head2 Perl Books A number of books on Perl and/or CGI programming are available. A few of these are good, some are OK, but many aren't worth your money. Tom Christiansen maintains a list of these books, some with extensive -reviews, at http://www.perl.com/perl/critiques/index.html. +reviews, at http://www.perl.com/perl/critiques/index.html . The incontestably definitive reference book on Perl, written by -the creator of Perl, is now in its second edition: +the creator of Perl, is now (July 2000) in its third edition: Programming Perl (the "Camel Book"): - by Larry Wall, Tom Christiansen, and Randal Schwartz - ISBN 1-56592-149-6 (English) - ISBN 4-89052-384-7 (Japanese) - URL: http://www.oreilly.com/catalog/pperl2/ - (French, German, Italian, and Hungarian translations also - available) + by Larry Wall, Tom Christiansen, and Jon Orwant + 0-596-00027-8 [3rd edition July 2000] + http://www.oreilly.com/catalog/pperl3/ + (English, translations to several languages are also available) The companion volume to the Camel containing thousands -of real-world examples, mini-tutorials, and complete programs -(first premiering at the 1998 Perl Conference), is: +of real-world examples, mini-tutorials, and complete programs is: The Perl Cookbook (the "Ram Book"): - by Tom Christiansen and Nathan Torkington, - with Foreword by Larry Wall - ISBN: 1-56592-243-3 - URL: http://perl.oreilly.com/cookbook/ + by Tom Christiansen and Nathan Torkington, + with Foreword by Larry Wall + ISBN 1-56592-243-3 [1st Edition August 1998] + http://perl.oreilly.com/cookbook/ If you're already a hard-core systems programmer, then the Camel Book -might suffice for you to learn Perl from. But if you're not, check -out: +might suffice for you to learn Perl from. If you're not, check out Learning Perl (the "Llama Book"): - by Randal Schwartz and Tom Christiansen + by Randal Schwartz and Tom Christiansen with Foreword by Larry Wall - ISBN: 1-56592-284-0 - URL: http://www.oreilly.com/catalog/lperl2/ + ISBN 1-56592-284-0 [2nd Edition July 1997] + http://www.oreilly.com/catalog/lperl2/ Despite the picture at the URL above, the second edition of "Llama -Book" really has a blue cover, and is updated for the 5.004 release +Book" really has a blue cover and was updated for the 5.004 release of Perl. Various foreign language editions are available, including -I<Learning Perl on Win32 Systems> (the Gecko Book). +I<Learning Perl on Win32 Systems> (the "Gecko Book"). If you're not an accidental programmer, but a more serious and possibly even degreed computer scientist who doesn't need as much hand-holding as @@ -237,126 +244,174 @@ we try to provide in the Llama or its defurred cousin the Gecko, please check out the delightful book, I<Perl: The Programmer's Companion>, written by Nigel Chapman. -You can order O'Reilly books directly from O'Reilly & Associates, -1-800-998-9938. Local/overseas is 1-707-829-0515. If you can -locate an O'Reilly order form, you can also fax to 1-707-829-0104. -See http://www.ora.com/ on the Web. +Addison-Wesley (http://www.awlonline.com/) and Manning +(http://www.manning.com/) are also publishers of some fine Perl books +such as Object Oriented Programming with Perl by Damian Conway and +Network Programming with Perl by Lincoln Stein. + +An excellent technical book discounter is Bookpool at +http://www.bookpool.com/ where a 30% discount or more is not unusual. What follows is a list of the books that the FAQ authors found personally useful. Your mileage may (but, we hope, probably won't) vary. -Recommended books on (or mostly on) Perl follow; those marked with -a star may be ordered from O'Reilly. +Recommended books on (or mostly on) Perl follow. -=over +=over 4 =item References - *Programming Perl - by Larry Wall, Tom Christiansen, and Randal L. Schwartz + Programming Perl + by Larry Wall, Tom Christiansen, and Jon Orwant + ISBN 0-596-00027-8 [3rd edition July 2000] + http://www.oreilly.com/catalog/pperl3/ - *Perl 5 Desktop Reference + Perl 5 Pocket Reference by Johan Vromans + ISBN 0-596-00032-4 [3rd edition May 2000] + http://www.oreilly.com/catalog/perlpr3/ - *Perl in a Nutshell + Perl in a Nutshell by Ellen Siever, Stephan Spainhour, and Nathan Patwardhan + ISBN 1-56592-286-7 [1st edition December 1998] + http://www.oreilly.com/catalog/perlnut/ =item Tutorials - *Learning Perl [2nd edition] + Elements of Programming with Perl + by Andrew L. Johnson + ISBN 1884777805 [1st edition October 1999] + http://www.manning.com/Johnson/ + + Learning Perl by Randal L. Schwartz and Tom Christiansen with foreword by Larry Wall + ISBN 1-56592-284-0 [2nd edition July 1997] + http://www.oreilly.com/catalog/lperl2/ - *Learning Perl on Win32 Systems + Learning Perl on Win32 Systems by Randal L. Schwartz, Erik Olson, and Tom Christiansen, with foreword by Larry Wall + ISBN 1-56592-324-3 [1st edition August 1997] + http://www.oreilly.com/catalog/lperlwin/ Perl: The Programmer's Companion by Nigel Chapman + ISBN 0-471-97563-X [1st edition October 1997] + http://catalog.wiley.com/title.cgi?isbn=047197563X - Cross-Platform Perl - by Eric F. Johnson + Cross-Platform Perl + by Eric Foster-Johnson + ISBN 1-55851-483-X [2nd edition September 2000] + http://www.pconline.com/~erc/perlbook.htm - MacPerl: Power and Ease - by Vicki Brown and Chris Nandor, foreword by Matthias Neeracher + MacPerl: Power and Ease + by Vicki Brown and Chris Nandor, + with foreword by Matthias Neeracher + ISBN 1-881957-32-2 [1st edition May 1998] + http://www.macperl.com/ptf_book/ -=item Task-Oriented +=item Task-Oriented - *The Perl Cookbook + The Perl Cookbook by Tom Christiansen and Nathan Torkington with foreword by Larry Wall + ISBN 1-56592-243-3 [1st edition August 1998] + http://www.oreilly.com/catalog/cookbook/ - Perl5 Interactive Course [2nd edition] - by Jon Orwant - - *Advanced Perl Programming - by Sriram Srinivasan - - Effective Perl Programming + Effective Perl Programming by Joseph Hall + ISBN 0-201-41975-0 [1st edition 1998] + http://www.awl.com/ + =item Special Topics - *Mastering Regular Expressions - by Jeffrey Friedl + Mastering Regular Expressions + by Jeffrey E. F. Friedl + ISBN 1-56592-257-3 [1st edition January 1997] + http://www.oreilly.com/catalog/regex/ - How to Set up and Maintain a World Wide Web Site [2nd edition] + Network Programming with Perl by Lincoln Stein + ISBN 0-201-61571-1 [1st edition 2001] + http://www.awlonline.com/ + + Object Oriented Perl + Damian Conway + with foreword by Randal L. Schwartz + ISBN 1884777791 [1st edition August 1999] + http://www.manning.com/Conway/ - *Learning Perl/Tk + Data Munging with Perl + Dave Cross + ISBN 1930110006 [1st edition 2001] + http://www.manning.com/cross + + Learning Perl/Tk by Nancy Walsh + ISBN 1-56592-314-6 [1st edition January 1999] + http://www.oreilly.com/catalog/lperltk/ =back =head2 Perl in Magazines The first and only periodical devoted to All Things Perl, I<The -Perl Journal> contains tutorials, demonstrations, case studies, -announcements, contests, and much more. TPJ has columns on web +Perl Journal> contained tutorials, demonstrations, case studies, +announcements, contests, and much more. I<TPJ> had columns on web development, databases, Win32 Perl, graphical programming, regular -expressions, and networking, and sponsors the Obfuscated Perl -Contest. It is published quarterly under the gentle hand of its -editor, Jon Orwant. See http://www.tpj.com/ or send mail to -subscriptions@tpj.com . +expressions, and networking, and sponsored the Obfuscated Perl +Contest. Sadly, this publication is no longer in circulation, but +should it be resurrected, it will most likely be announced on +http://use.perl.org/ . Beyond this, magazines that frequently carry high-quality articles on Perl are I<Web Techniques> (see http://www.webtechniques.com/), I<Performance Computing> (http://www.performance-computing.com/), and Usenix's newsletter/magazine to its members, I<login:>, at http://www.usenix.org/. Randal's Web Technique's columns are available on the web at -http://www.stonehenge.com/merlyn/WebTechniques/. +http://www.stonehenge.com/merlyn/WebTechniques/ . =head2 Perl on the Net: FTP and WWW Access -To get the best (and possibly cheapest) performance, pick a site from -the list below and use it to grab the complete list of mirror sites. +To get the best performance, pick a site from +the list below and use it to grab the complete list of mirror sites +which is at /CPAN/MIRRORED.BY or at http://mirror.cpan.org/. From there you can find the quickest site for you. Remember, the -following list is I<not> the complete list of CPAN mirrors. - - http://www.perl.com/CPAN-local - http://www.perl.com/CPAN (redirects to an ftp mirror) - ftp://cpan.valueclick.com/pub/CPAN/ +following list is I<not> the complete list of CPAN mirrors +(the complete list contains 165 sites as of January 2001): + + http://www.cpan.org/ + http://www.perl.com/CPAN/ + http://download.sourceforge.net/mirrors/CPAN/ + ftp://ftp.digital.com/pub/plan/perl/CPAN/ + ftp://ftp.flirble.org/pub/languages/perl/CPAN/ + ftp://ftp.uvsq.fr/pub/perl/CPAN/ ftp://ftp.funet.fi/pub/languages/perl/CPAN/ - http://www.cs.ruu.nl/pub/PERL/CPAN/ - ftp://ftp.cs.colorado.edu/pub/perl/CPAN/ + ftp://ftp.dti.ad.jp/pub/lang/CPAN/ + ftp://mirror.aarnet.edu.au/pub/perl/CPAN/ + ftp://cpan.if.usp.br/pub/mirror/CPAN/ + +One may also use xx.cpan.org where "xx" is the 2-letter country code +for your domain; e.g. Australia would use au.cpan.org. =head2 What mailing lists are there for Perl? Most of the major modules (Tk, CGI, libwww-perl) have their own mailing lists. Consult the documentation that came with the module for -subscription information. The Perl Mongers attempt to maintain a -list of mailing lists at: +subscription information. - http://www.perl.org/support/online_support.html#mail + http://lists.cpan.org/ =head2 Archives of comp.lang.perl.misc -Have you tried Deja or AltaVista? Those are the +Have you tried Deja or AltaVista? Those are the best archives. Just look up "*perl*" as a newsgroup. http://www.deja.com/dnquery.xp?QRY=&DBS=2&ST=PS&defaultOp=AND&LNG=ALL&format=terse&showsort=date&maxhits=25&subjects=&groups=*perl*&authors=&fromdate=&todate= -You'll probably want to trim that down a bit, though. +You might want to trim that down a bit, though. You'll probably want more a sophisticated query and retrieval mechanism than a file listing, preferably one that allows you to retrieve @@ -370,7 +425,7 @@ let perlfaq-suggestions@perl.com know. =head2 Where can I buy a commercial version of Perl? -In a real sense, Perl already I<is> commercial software: It has a license +In a real sense, Perl already I<is> commercial software: it has a license that you can grab and carefully read to your manager. It is distributed in releases and comes in well-defined packages. There is a very large user community and an extensive literature. The comp.lang.perl.* @@ -384,13 +439,13 @@ However, these answers may not suffice for managers who require a purchase order from a company whom they can sue should anything go awry. Or maybe they need very serious hand-holding and contractual obligations. Shrink-wrapped CDs with Perl on them are available from several sources if -that will help. For example, many Perl books carry a Perl distribution -on them, as do the O'Reilly Perl Resource Kits (in both the Unix flavor +that will help. For example, many Perl books include a distribution of Perl, +as do the O'Reilly Perl Resource Kits (in both the Unix flavor and in the proprietary Microsoft flavor); the free Unix distributions also all come with Perl. -Or you can purchase commercial incidence based support through the Perl -Clinic. The following is a commercial from them: +Alternatively, you can purchase commercial incidence based support +through the Perl Clinic. The following is a commercial from them: "The Perl Clinic is a commercial Perl support service operated by ActiveState Tool Corp. and The Ingram Group. The operators have many @@ -401,7 +456,7 @@ on a wide range of platforms. we will put our best effort into understanding your problem, providing an explanation of the situation, and a recommendation on how to proceed." -Contact The Perl Clinic at: +Contact The Perl Clinic at www.PerlClinic.com @@ -419,7 +474,7 @@ See also www.perl.com for updates on tutorials, training, and support. If you are reporting a bug in the perl interpreter or the modules shipped with Perl, use the I<perlbug> program in the Perl distribution or -mail your report to perlbug@perl.com . +mail your report to perlbug@perl.org . If you are posting a bug with a non-standard port (see the answer to "What platforms is Perl available for?"), a binary distribution, or a @@ -431,40 +486,38 @@ Read the perlbug(1) man page (perl5.004 or later) for more information. =head2 What is perl.com? Perl Mongers? pm.org? perl.org? -The perl.com domain is owned by Tom Christiansen, who created it as a -public service long before perl.org came about. Despite the name, it's a -pretty non-commercial site meant to be a clearinghouse for information -about all things Perlian, accepting no paid advertisements, bouncy -happy GIFs, or silly Java applets on its pages. The Perl Home Page at -http://www.perl.com/ is currently hosted on a T3 line courtesy of Songline -Systems, a software-oriented subsidiary of O'Reilly and Associates. -Other starting points include +The Perl Home Page at http://www.perl.com/ is currently hosted on a +T3 line courtesy of Songline Systems, a software-oriented subsidiary of +O'Reilly and Associates. Other starting points include http://language.perl.com/ http://conference.perl.com/ http://reference.perl.com/ -Perl Mongers is an advocacy organization for the Perl language. For -details, see the Perl Mongers web site at http://www.perlmongers.org/. +Perl Mongers is an advocacy organization for the Perl language which +maintains the web site http://www.perl.org/ as a general advocacy +site for the Perl language. Perl Mongers uses the pm.org domain for services related to Perl user -groups. See the Perl user group web site at http://www.pm.org/ for more -information about joining, starting, or requesting services for a Perl -user group. +groups, including the hosting of mailing lists and web sites. See the +Perl user group web site at http://www.pm.org/ for more information about +joining, starting, or requesting services for a Perl user group. -Perl Mongers also maintains the perl.org domain to provide general +Perl Mongers also maintain the perl.org domain to provide general support services to the Perl community, including the hosting of mailing lists, web sites, and other services. The web site http://www.perl.org/ is a general advocacy site for the Perl language, and there are many other sub-domains for special topics, such as - http://history.perl.org/ http://bugs.perl.org/ - http://www.news.perl.org/ + http://history.perl.org/ + http://lists.perl.org/ + http://news.perl.org/ + http://use.perl.org/ =head1 AUTHOR AND COPYRIGHT -Copyright (c) 1997-1999 Tom Christiansen and Nathan Torkington. +Copyright (c) 1997-2001 Tom Christiansen and Nathan Torkington. All rights reserved. When included as an integrated part of the Standard Distribution diff --git a/contrib/perl5/pod/perlfaq3.pod b/contrib/perl5/pod/perlfaq3.pod index b05b7361c0f5..49cae1a2093e 100644 --- a/contrib/perl5/pod/perlfaq3.pod +++ b/contrib/perl5/pod/perlfaq3.pod @@ -49,22 +49,22 @@ uninteresting, but may still be what you want. =head2 How do I debug my Perl programs? Have you tried C<use warnings> or used C<-w>? They enable warnings -for dubious practices. +to detect dubious practices. Have you tried C<use strict>? It prevents you from using symbolic references, makes you predeclare any subroutines that you call as bare words, and (probably most importantly) forces you to predeclare your -variables with C<my> or C<our> or C<use vars>. +variables with C<my>, C<our>, or C<use vars>. -Did you check the returns of each and every system call? The operating -system (and thus Perl) tells you whether they worked or not, and if not +Did you check the return values of each and every system call? The operating +system (and thus Perl) tells you whether they worked, and if not why. open(FH, "> /etc/cantwrite") or die "Couldn't write to /etc/cantwrite: $!\n"; Did you read L<perltrap>? It's full of gotchas for old and new Perl -programmers, and even has sections for those of you who are upgrading +programmers and even has sections for those of you who are upgrading from languages like I<awk> and I<C>. Have you tried the Perl debugger, described in L<perldebug>? You can @@ -73,10 +73,11 @@ why what it's doing isn't what it should be doing. =head2 How do I profile my Perl programs? -You should get the Devel::DProf module from CPAN, and also use -Benchmark.pm from the standard distribution. Benchmark lets you time -specific portions of your code, while Devel::DProf gives detailed -breakdowns of where your code spends its time. +You should get the Devel::DProf module from the standard distribution +(or separately on CPAN) and also use Benchmark.pm from the standard +distribution. The Benchmark module lets you time specific portions of +your code, while Devel::DProf gives detailed breakdowns of where your +code spends its time. Here's a sample use of Benchmark: @@ -104,7 +105,7 @@ on your hardware, operating system, and the load on your machine): map: 6 secs ( 4.97 usr 0.00 sys = 4.97 cpu) Be aware that a good benchmark is very hard to write. It only tests the -data you give it, and really proves little about differing complexities +data you give it and proves little about the differing complexities of contrasting algorithms. =head2 How do I cross-reference my Perl programs? @@ -125,17 +126,17 @@ challenging at best to write a stand-alone Perl parser. Of course, if you simply follow the guidelines in L<perlstyle>, you shouldn't need to reformat. The habit of formatting your code as you write it will help prevent bugs. Your editor can and should help you -with this. The perl-mode for emacs can provide a remarkable amount of -help with most (but not all) code, and even less programmable editors -can provide significant assistance. Tom swears by the following -settings in vi and its clones: +with this. The perl-mode or newer cperl-mode for emacs can provide +remarkable amounts of help with most (but not all) code, and even less +programmable editors can provide significant assistance. Tom swears +by the following settings in vi and its clones: set ai sw=4 map! ^O {^M}^[O^T Now put that in your F<.exrc> file (replacing the caret characters with control characters) and away you go. In insert mode, ^T is -for indenting, ^D is for undenting, and ^O is for blockdenting -- +for indenting, ^D is for undenting, and ^O is for blockdenting-- as it were. If you haven't used the last one, you're missing a lot. A more complete example, with comments, can be found at http://www.perl.com/CPAN-local/authors/id/TOMC/scripts/toms.exrc.gz @@ -156,42 +157,192 @@ the trick. And if not, it's easy to hack into what you want. =head2 Is there an IDE or Windows Perl Editor? -If you're on Unix, you already have an IDE -- Unix itself. This powerful -IDE derives from its interoperability, flexibility, and configurability. -If you really want to get a feel for Unix-qua-IDE, the best thing to do -is to find some high-powered programmer whose native language is Unix. -Find someone who has been at this for many years, and just sit back -and watch them at work. They have created their own IDE, one that -suits their own tastes and aptitudes. Quietly observe them edit files, -move them around, compile them, debug them, test them, etc. The entire -development *is* integrated, like a top-of-the-line German sports car: -functional, powerful, and elegant. You will be absolutely astonished -at the speed and ease exhibited by the native speaker of Unix in his -home territory. The art and skill of a virtuoso can only be seen to be -believed. That is the path to mastery -- all these cobbled little IDEs -are expensive toys designed to sell a flashy demo using cheap tricks, -and being optimized for immediate but shallow understanding rather than -enduring use, are but a dim palimpsest of real tools. - -In short, you just have to learn the toolbox. However, if you're not -on Unix, then your vendor probably didn't bother to provide you with -a proper toolbox on the so-called complete system that you forked out -your hard-earned cash on. - -PerlBuilder (XXX URL to follow) is an integrated development environment -for Windows that supports Perl development. Perl programs are just plain -text, though, so you could download emacs for Windows (???) or a vi clone -(vim) which runs on for win32 (http://www.cs.vu.nl/%7Etmgil/vi.html). -If you're transferring Windows files to Unix, be sure to transfer in -ASCII mode so the ends of lines are appropriately mangled. +Perl programs are just plain text, so any editor will do. + +If you're on Unix, you already have an IDE--Unix itself. The UNIX +philosophy is the philosophy of several small tools that each do one +thing and do it well. It's like a carpenter's toolbox. + +If you want a Windows IDE, check the following: + +=over 4 + +=item CodeMagicCD + +http://www.codemagiccd.com/ + +=item Komodo + +ActiveState's cross-platform, multi-language IDE has Perl support, +including a regular expression debugger and remote debugging +(http://www.ActiveState.com/Products/Komodo/index.html). +(Visual Perl, a Visual Studio.NET plug-in is currently (early 2001) +in beta (http://www.ActiveState.com/Products/VisualPerl/index.html)). + +=item The Object System + +(http://www.castlelink.co.uk/object_system/) is a Perl web +applications development IDE. + +=item PerlBuilder + +(http://www.solutionsoft.com/perl.htm) is an integrated development +environment for Windows that supports Perl development. + +=item Perl code magic + +(http://www.petes-place.com/codemagic.html). + +=item visiPerl+ + +http://helpconsulting.net/visiperl/, from Help Consulting. + +=back + +For editors: if you're on Unix you probably have vi or a vi clone already, +and possibly an emacs too, so you may not need to download anything. +In any emacs the cperl-mode (M-x cperl-mode) gives you perhaps the +best available Perl editing mode in any editor. + +For Windows editors: you can download an Emacs + +=over 4 + +=item GNU Emacs + +http://www.gnu.org/software/emacs/windows/ntemacs.html + +=item MicroEMACS + +http://members.nbci.com/uemacs/ + +=item XEmacs + +http://www.xemacs.org/Download/index.html + +=back + +or a vi clone such as + +=over 4 + +=item Elvis + +ftp://ftp.cs.pdx.edu/pub/elvis/ http://www.fh-wedel.de/elvis/ + +=item Vile + +http://vile.cx/ + +=item Vim + +http://www.vim.org/ + +win32: http://www.cs.vu.nl/%7Etmgil/vi.html + +=back + +For vi lovers in general, Windows or elsewhere: +http://www.thomer.com/thomer/vi/vi.html. + +nvi (http://www.bostic.com/vi/, available from CPAN in src/misc/) is +yet another vi clone, unfortunately not available for Windows, but in +UNIX platforms you might be interested in trying it out, firstly because +strictly speaking it is not a vi clone, it is the real vi, or the new +incarnation of it, and secondly because you can embed Perl inside it +to use Perl as the scripting language. nvi is not alone in this, +though: at least also vim and vile offer an embedded Perl. + +The following are Win32 multilanguage editor/IDESs that support Perl: + +=over 4 + +=item Codewright + +http://www.starbase.com/ + +=item MultiEdit + +http://www.MultiEdit.com/ + +=item SlickEdit + +http://www.slickedit.com/ + +=back + +There is also a toyedit Text widget based editor written in Perl +that is distributed with the Tk module on CPAN. The ptkdb +(http://world.std.com/~aep/ptkdb/) is a Perl/tk based debugger that +acts as a development environment of sorts. Perl Composer +(http://perlcomposer.sourceforge.net/vperl.html) is an IDE for Perl/Tk +GUI creation. + +In addition to an editor/IDE you might be interested in a more +powerful shell environment for Win32. Your options include + +=over 4 + +=item Bash + +from the Cygwin package (http://sources.redhat.com/cygwin/) + +=item Ksh + +from the MKS Toolkit (http://www.mks.com/), or the Bourne shell of +the U/WIN environment (http://www.research.att.com/sw/tools/uwin/) + +=item Tcsh + +ftp://ftp.astron.com/pub/tcsh/, see also +http://www.primate.wisc.edu/software/csh-tcsh-book/ + +=item Zsh + +ftp://ftp.blarg.net/users/amol/zsh/, see also http://www.zsh.org/ + +=back + +MKS and U/WIN are commercial (U/WIN is free for educational and +research purposes), Cygwin is covered by the GNU Public License (but +that shouldn't matter for Perl use). The Cygwin, MKS, and U/WIN all +contain (in addition to the shells) a comprehensive set of standard +UNIX toolkit utilities. + +If you're transferring text files between Unix and Windows using FTP +be sure to transfer them in ASCII mode so the ends of lines are +appropriately converted. + +On Mac OS the MacPerl Application comes with a simple 32k text editor +that behaves like a rudimentary IDE. In contrast to the MacPerl Application +the MPW Perl tool can make use of the MPW Shell itself as an editor (with +no 32k limit). + +=over 4 + +=item BBEdit and BBEdit Lite + +are text editors for Mac OS that have a Perl sensitivity mode +(http://web.barebones.com/). + +=item Alpha + +is an editor, written and extensible in Tcl, that nonetheless has +built in support for several popular markup and programming languages +including Perl and HTML (http://alpha.olm.net/). + +=back + +Pepper and Pe are programming language sensitive text editors for Mac +OS X and BeOS respectively (http://www.hekkelman.com/). =head2 Where can I get Perl macros for vi? For a complete version of Tom Christiansen's vi configuration file, -see http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/toms.exrc.gz, -the standard benchmark file for vi emulators. This runs best with nvi, +see http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/toms.exrc.gz , +the standard benchmark file for vi emulators. The file runs best with nvi, the current version of vi out of Berkeley, which incidentally can be built -with an embedded Perl interpreter -- see http://www.perl.com/CPAN/src/misc. +with an embedded Perl interpreter--see http://www.perl.com/CPAN/src/misc. =head2 Where can I get perl-mode for emacs? @@ -223,7 +374,7 @@ that doesn't force you to use Tcl just to get at Tk. Sx is an interface to the Athena Widget set. Both are available from CPAN. See the directory http://www.perl.com/CPAN/modules/by-category/08_User_Interfaces/ -Invaluable for Perl/Tk programming are: the Perl/Tk FAQ at +Invaluable for Perl/Tk programming are the Perl/Tk FAQ at http://w4.lns.cornell.edu/%7Epvhp/ptk/ptkTOC.html , the Perl/Tk Reference Guide available at http://www.perl.com/CPAN-local/authors/Stephen_O_Lidie/ , and the @@ -237,13 +388,12 @@ module, which is curses-based, can help with this. =head2 What is undump? -See the next questions. +See the next question on ``How can I make my Perl program run faster?'' =head2 How can I make my Perl program run faster? The best way to do this is to come up with a better algorithm. This -can often make a dramatic difference. Chapter 8 in the Camel has some -efficiency tips in it you might want to look at. Jon Bentley's book +can often make a dramatic difference. Jon Bentley's book ``Programming Pearls'' (that's not a misspelling!) has some good tips on optimization, too. Advice on benchmarking boils down to: benchmark and profile to make sure you're optimizing the right part, look for @@ -254,8 +404,8 @@ A different approach is to autoload seldom-used Perl code. See the AutoSplit and AutoLoader modules in the standard distribution for that. Or you could locate the bottleneck and think about writing just that part in C, the way we used to take bottlenecks in C code and -write them in assembler. Similar to rewriting in C is the use of -modules that have critical sections written in C (for instance, the +write them in assembler. Similar to rewriting in C, +modules that have critical sections can be written in C (for instance, the PDL module from CPAN). In some cases, it may be worth it to use the backend compiler to @@ -294,7 +444,7 @@ shared amongst all hashes using them, so require no reallocation. In some cases, using substr() or vec() to simulate arrays can be highly beneficial. For example, an array of a thousand booleans will take at least 20,000 bytes of space, but it can be turned into one -125-byte bit vector for a considerable memory savings. The standard +125-byte bit vector--a considerable memory savings. The standard Tie::SubstrHash module can also help for certain types of data structure. If you're working with specialist data structures (matrices, for instance) modules that implement these in C may use @@ -339,7 +489,7 @@ $scalar> will return memory to the system, while on Solaris 2.6 it won't. In general, try it yourself and see. However, judicious use of my() on your variables will help make sure -that they go out of scope so that Perl can free up their storage for +that they go out of scope so that Perl can free up that space for use in other parts of your program. A global variable, of course, never goes out of scope, so you can't get its space automatically reclaimed, although undef()ing and/or delete()ing it will achieve the same effect. @@ -380,12 +530,13 @@ care. See http://www.perl.com/CPAN/modules/by-category/15_World_Wide_Web_HTML_HTTP_CGI/ . A non-free, commercial product, ``The Velocity Engine for Perl'', -(http://www.binevolve.com/ or http://www.binevolve.com/velocigen/) might -also be worth looking at. It will allow you to increase the performance -of your Perl programs, up to 25 times faster than normal CGI Perl by -running in persistent Perl mode, or 4 to 5 times faster without any -modification to your existing CGI programs. Fully functional evaluation -copies are available from the web site. +(http://www.binevolve.com/ or http://www.binevolve.com/velocigen/ ) +might also be worth looking at. It will allow you to increase the +performance of your Perl programs, running programs up to 25 times +faster than normal CGI Perl when running in persistent Perl mode or 4 +to 5 times faster without any modification to your existing CGI +programs. Fully functional evaluation copies are available from the +web site. =head2 How can I hide the source for my Perl program? @@ -395,12 +546,12 @@ unsatisfactory) solutions with varying levels of ``security''. First of all, however, you I<can't> take away read permission, because the source code has to be readable in order to be compiled and interpreted. (That doesn't mean that a CGI script's source is -readable by people on the web, though, only by people with access to -the filesystem) So you have to leave the permissions at the socially +readable by people on the web, though--only by people with access to +the filesystem.) So you have to leave the permissions at the socially friendly 0755 level. Some people regard this as a security problem. If your program does -insecure things, and relies on people not knowing how to exploit those +insecure things and relies on people not knowing how to exploit those insecurities, it is not secure. It is often possible for someone to determine the insecure things and exploit them without viewing the source. Security through obscurity, the name for hiding your bugs @@ -412,7 +563,7 @@ the byte code compiler and interpreter described below, but the curious might still be able to de-compile it. You can try using the native-code compiler described below, but crackers might be able to disassemble it. These pose varying degrees of difficulty to people wanting to get at -your code, but none can definitively conceal it (this is true of every +your code, but none can definitively conceal it (true of every language, not just Perl). If you're concerned about people profiting from your code, then the @@ -434,10 +585,10 @@ really for people looking for turn-key solutions. Merely compiling into C does not in and of itself guarantee that your code will run very much faster. That's because except for lucky cases where a lot of native type inferencing is possible, the normal Perl -run time system is still present and so your program will take just as +run-time system is still present and so your program will take just as long to run and be just as big. Most programs save little more than compilation time, leaving execution no more than 10-30% faster. A few -rare programs actually benefit significantly (like several times +rare programs actually benefit significantly (even running several times faster), but this takes some tweaking of your code. You'll probably be astonished to learn that the current version of the @@ -452,8 +603,8 @@ For example, on one author's system, F</usr/bin/perl> is only 11k in size! In general, the compiler will do nothing to make a Perl program smaller, -faster, more portable, or more secure. In fact, it will usually hurt -all of those. The executable will be bigger, your VM system may take +faster, more portable, or more secure. In fact, it can make your +situation worse. The executable will be bigger, your VM system may take longer to load the whole thing, the binary is fragile and hard to fix, and compilation never stopped software piracy in the form of crackers, viruses, or bootleggers. The real advantage of the compiler is merely @@ -463,11 +614,13 @@ Perl install anyway. =head2 How can I compile Perl into Java? -You can't. Not yet, anyway. You can integrate Java and Perl with the +You can also integrate Java and Perl with the Perl Resource Kit from O'Reilly and Associates. See -http://www.oreilly.com/catalog/prkunix/ for more information. -The Java interface will be supported in the core 5.6 release -of Perl. +http://www.oreilly.com/catalog/prkunix/ . + +Perl 5.6 comes with Java Perl Lingo, or JPL. JPL, still in +development, allows Perl code to be called from Java. See jpl/README +in the Perl source tree. =head2 How can I get C<#!perl> to work on [MS-DOS,NT,...]? @@ -477,7 +630,7 @@ For OS/2 just use as the first line in C<*.cmd> file (C<-S> due to a bug in cmd.exe's `extproc' handling). For DOS one should first invent a corresponding -batch file, and codify it in C<ALTERNATIVE_SHEBANG> (see the +batch file and codify it in C<ALTERNATIVE_SHEBANG> (see the F<INSTALL> file in the source distribution for more information). The Win95/NT installation, when using the ActiveState port of Perl, @@ -546,9 +699,9 @@ For example: # VMS perl -e "print ""Hello world\n""" -The problem is that none of this is reliable: it depends on the +The problem is that none of these examples are reliable: they depend on the command interpreter. Under Unix, the first two often work. Under DOS, -it's entirely possible neither works. If 4DOS was the command shell, +it's entirely possible that neither works. If 4DOS was the command shell, you'd probably have better luck like this: perl -e "print <Ctrl-x>"Hello world\n<Ctrl-x>"" @@ -596,13 +749,12 @@ when it runs fine on the command line'', see these sources: CGI Security FAQ http://www.go2net.com/people/paulp/cgi-security/safe-cgi.txt - =head2 Where can I learn about object-oriented Perl programming? -A good place to start is L<perltoot>, and you can use L<perlobj> and -L<perlbot> for reference. Perltoot didn't come out until the 5.004 -release, but you can get a copy (in pod, html, or postscript) from -http://www.perl.com/CPAN/doc/FMTEYEWTK/ . +A good place to start is L<perltoot>, and you can use L<perlobj>, +L<perlboot>, and L<perlbot> for reference. Perltoot didn't come out +until the 5.004 release; you can get a copy (in pod, html, or +postscript) from http://www.perl.com/CPAN/doc/FMTEYEWTK/ . =head2 Where can I learn about linking C with Perl? [h2xs, xsubpp] @@ -614,7 +766,7 @@ how the authors of existing extension modules wrote their code and solved their problems. =head2 I've read perlembed, perlguts, etc., but I can't embed perl in -my C program, what am I doing wrong? +my C program; what am I doing wrong? Download the ExtUtils::Embed kit from CPAN and run `make test'. If the tests pass, read the pods again and again and again. If they diff --git a/contrib/perl5/pod/perlfaq4.pod b/contrib/perl5/pod/perlfaq4.pod index e997a8fcb96a..8c570c268331 100644 --- a/contrib/perl5/pod/perlfaq4.pod +++ b/contrib/perl5/pod/perlfaq4.pod @@ -4,7 +4,7 @@ perlfaq4 - Data Manipulation ($Revision: 1.49 $, $Date: 1999/05/23 20:37:49 $) =head1 DESCRIPTION -The section of the FAQ answers question related to the manipulation +The section of the FAQ answers questions related to the manipulation of data as numbers, dates, strings, arrays, hashes, and miscellaneous data issues. @@ -13,13 +13,13 @@ data issues. =head2 Why am I getting long decimals (eg, 19.9499999999999) instead of the numbers I should be getting (eg, 19.95)? The infinite set that a mathematician thinks of as the real numbers can -only be approximate on a computer, since the computer only has a finite +only be approximated on a computer, since the computer only has a finite number of bits to store an infinite number of, um, numbers. Internally, your computer represents floating-point numbers in binary. Floating-point numbers read in from a file or appearing as literals in your program are converted from their decimal floating-point -representation (eg, 19.95) to the internal binary representation. +representation (eg, 19.95) to an internal binary representation. However, 19.95 can't be precisely represented as a binary floating-point number, just like 1/3 can't be exactly represented as a @@ -29,7 +29,7 @@ of 19.95, therefore, isn't exactly 19.95. When a floating-point number gets printed, the binary floating-point representation is converted back to decimal. These decimal numbers are displayed in either the format you specify with printf(), or the -current output format for numbers (see L<perlvar/"$#"> if you use +current output format for numbers. (See L<perlvar/"$#"> if you use print. C<$#> has a different default value in Perl5 than it did in Perl4. Changing C<$#> yourself is deprecated.) @@ -75,7 +75,7 @@ functions. $ceil = ceil(3.5); # 4 $floor = floor(3.5); # 3 -In 5.000 to 5.003 Perls, trigonometry was done in the Math::Complex +In 5.000 to 5.003 perls, trigonometry was done in the Math::Complex module. With 5.004, the Math::Trig module (part of the standard Perl distribution) implements the trigonometric functions. Internally it uses the Math::Complex module and some functions can break out from @@ -206,8 +206,8 @@ than more. Computers are good at being predictable and bad at being random (despite appearances caused by bugs in your programs :-). -http://www.perl.com/CPAN/doc/FMTEYEWTK/random, courtesy of Tom -Phoenix, talks more about this.. John von Neumann said, ``Anyone who +http://www.perl.com/CPAN/doc/FMTEYEWTK/random , courtesy of Tom +Phoenix, talks more about this. John von Neumann said, ``Anyone who attempts to generate random numbers by deterministic means is, of course, living in a state of sin.'' @@ -286,7 +286,7 @@ Use the Time::JulianDay module (part of the Time-modules bundle available from CPAN.) Before you immerse yourself too deeply in this, be sure to verify that it -is the I<Julian> Day you really want. Are they really just interested in +is the I<Julian> Day you really want. Are you really just interested in a way of getting serial days so that they can do date arithmetic? If you are interested in performing date arithmetic, this can be done using either Date::Manip or Date::Calc, without converting to Julian Day first. @@ -370,7 +370,7 @@ you can. Is that the pencil's fault? Of course it isn't. The date and time functions supplied with Perl (gmtime and localtime) supply adequate information to determine the year well beyond 2000 (2038 is when trouble strikes for 32-bit machines). The year returned -by these functions when used in an array context is the year minus 1900. +by these functions when used in a list context is the year minus 1900. For years between 1910 and 1999 this I<happens> to be a 2-digit decimal number. To avoid the year 2000 problem simply do not treat the year as a 2-digit number. It isn't. @@ -398,7 +398,7 @@ addresses, etc.) for details. It depends just what you mean by ``escape''. URL escapes are dealt with in L<perlfaq9>. Shell escapes with the backslash (C<\>) -character are removed with: +character are removed with s/\\(.)/$1/g; @@ -512,7 +512,7 @@ use substr() as an lvalue: substr($a, 0, 3) = "Tom"; Although those with a pattern matching kind of thought process will -likely prefer: +likely prefer $a =~ s/^.../Tom/; @@ -549,7 +549,7 @@ repetition count and repeated pattern like this: =head2 How can I count the number of occurrences of a substring within a string? -There are a number of ways, with varying efficiency: If you want a +There are a number of ways, with varying efficiency. If you want a count of a certain single character (X) within a string, you can use the C<tr///> function like so: @@ -574,8 +574,8 @@ To make the first letter of each word upper case: $line =~ s/\b(\w)/\U$1/g; This has the strange effect of turning "C<don't do it>" into "C<Don'T -Do It>". Sometimes you might want this, instead (Suggested by brian d. -foy): +Do It>". Sometimes you might want this. Other times you might need a +more thorough solution (Suggested by brian d. foy): $string =~ s/ ( (^\w) #at the beginning of the line @@ -637,15 +637,15 @@ distribution) lets you say: use Text::ParseWords; @new = quotewords(",", 0, $text); -There's also a Text::CSV module on CPAN. +There's also a Text::CSV (Comma-Separated Values) module on CPAN. =head2 How do I strip blank space from the beginning/end of a string? -Although the simplest approach would seem to be: +Although the simplest approach would seem to be $string =~ s/^\s*(.*?)\s*$/$1/; -Not only is this unnecessarily slow and destructive, it also fails with +not only is this unnecessarily slow and destructive, it also fails with embedded newlines. It is much faster to do this operation in two steps: $string =~ s/^\s+//; @@ -740,7 +740,7 @@ you can use this kind of thing: =head2 How do I find the soundex value of a string? Use the standard Text::Soundex module distributed with Perl. -But before you do so, you may want to determine whether `soundex' is in +Before you do so, you may want to determine whether `soundex' is in fact what you think it is. Knuth's soundex algorithm compresses words into a small space, and so it does not necessarily distinguish between two words which you might want to appear separately. For example, the @@ -779,9 +779,9 @@ of the FAQ. =head2 What's wrong with always quoting "$vars"? -The problem is that those double-quotes force stringification, -coercing numbers and references into strings, even when you -don't want them to be. Think of it this way: double-quote +The problem is that those double-quotes force stringification-- +coercing numbers and references into strings--even when you +don't want them to be strings. Think of it this way: double-quote expansion is used to produce new strings. If you already have a string, why do you need more? @@ -857,13 +857,13 @@ in the indentation. A nice general-purpose fixer-upper function for indented here documents follows. It expects to be called with a here document as its argument. It looks to see whether each line begins with a common substring, and -if so, strips that off. Otherwise, it takes the amount of leading -white space found on the first line and removes that much off each +if so, strips that substring off. Otherwise, it takes the amount of leading +whitespace found on the first line and removes that much off each subsequent line. sub fix { local $_ = shift; - my ($white, $leader); # common white space and common leading string + my ($white, $leader); # common whitespace and common leading string if (/^\s*(?:([^\w\s]+)(\s*).*\n)(?:\s*\1\2?.*\n)+$/) { ($white, $leader) = ($2, quotemeta($1)); } else { @@ -886,7 +886,7 @@ This works with leading special strings, dynamically determined: @@@ } MAIN_INTERPRETER_LOOP -Or with a fixed amount of leading white space, with remaining +Or with a fixed amount of leading whitespace, with remaining indentation correctly preserved: $poem = fix<<EVER_ON_AND_ON; @@ -910,7 +910,7 @@ Subroutines are passed and return lists, you put things into list context, you initialize arrays with lists, and you foreach() across a list. C<@> variables are arrays, anonymous arrays are arrays, arrays in scalar context behave like the number of elements in them, subroutines -access their arguments through the array C<@_>, push/pop/shift only work +access their arguments through the array C<@_>, and push/pop/shift only work on arrays. As a side note, there's no such thing as a list in scalar context. @@ -924,7 +924,7 @@ last value to be returned: 9. =head2 What is the difference between $array[1] and @array[1]? -The former is a scalar value, the latter an array slice, which makes +The former is a scalar value; the latter an array slice, making it a list with one (scalar) value. You should use $ when you want a scalar value (most of the time) and @ when you want a list with one scalar value in it (very, very rarely; nearly never, in fact). @@ -948,33 +948,43 @@ ordered and whether you wish to preserve the ordering. =over 4 -=item a) If @in is sorted, and you want @out to be sorted: +=item a) + +If @in is sorted, and you want @out to be sorted: (this assumes all true values in the array) - $prev = 'nonesuch'; - @out = grep($_ ne $prev && ($prev = $_), @in); + $prev = "not equal to $in[0]"; + @out = grep($_ ne $prev && ($prev = $_, 1), @in); This is nice in that it doesn't use much extra memory, simulating -uniq(1)'s behavior of removing only adjacent duplicates. It's less -nice in that it won't work with false values like undef, 0, or ""; -"0 but true" is OK, though. +uniq(1)'s behavior of removing only adjacent duplicates. The ", 1" +guarantees that the expression is true (so that grep picks it up) +even if the $_ is 0, "", or undef. + +=item b) -=item b) If you don't know whether @in is sorted: +If you don't know whether @in is sorted: undef %saw; @out = grep(!$saw{$_}++, @in); -=item c) Like (b), but @in contains only small integers: +=item c) + +Like (b), but @in contains only small integers: @out = grep(!$saw[$_]++, @in); -=item d) A way to do (b) without any loops or greps: +=item d) + +A way to do (b) without any loops or greps: undef %saw; @saw{@in} = (); @out = sort keys %saw; # remove sort if undesired -=item e) Like (d), but @in contains only small positive integers: +=item e) + +Like (d), but @in contains only small positive integers: undef @ary; @ary[@in] = @in; @@ -1023,11 +1033,11 @@ Now check whether C<vec($read,$n,1)> is true for some C<$n>. Please do not use - $is_there = grep $_ eq $whatever, @array; + ($is_there) = grep $_ eq $whatever, @array; or worse yet - $is_there = grep /$whatever/, @array; + ($is_there) = grep /$whatever/, @array; These are slow (checks every element even if the first matches), inefficient (same reason), and potentially buggy (what if there are @@ -1057,7 +1067,7 @@ each element is unique in a given array: } Note that this is the I<symmetric difference>, that is, all elements in -either A or in B, but not in both. Think of it as an xor operation. +either A or in B but not in both. Think of it as an xor operation. =head2 How do I test whether two arrays or hashes are equal? @@ -1148,7 +1158,7 @@ You could walk the list this way: } print "\n"; -You could grow the list this way: +You could add to the list this way: my ($head, $tail); $tail = append($head, 1); # grow a new head @@ -1189,7 +1199,6 @@ Use this: my $i; for ($i = @$array; --$i; ) { my $j = int rand ($i+1); - next if $i == $j; @$array[$i,$j] = @$array[$j,$i]; } } @@ -1197,7 +1206,7 @@ Use this: fisher_yates_shuffle( \@array ); # permutes @array in place You've probably seen shuffling algorithms that work using splice, -randomly picking another element to swap the current element with: +randomly picking another element to swap the current element with srand; @new = (); @@ -1298,7 +1307,7 @@ case-insensitively. } @sorted = @data[ sort { $idx[$a] cmp $idx[$b] } 0 .. $#idx ]; -Which could also be written this way, using a trick +which could also be written this way, using a trick that's come to be known as the Schwartzian Transform: @sorted = map { $_->[0] } @@ -1439,7 +1448,7 @@ table, at which point you've totally bamboozled the iterator code. Even if the table doesn't double, there's no telling whether your new entry will be inserted before or after the current iterator position. -Either treasure up your changes and make them after the iterator finishes, +Either treasure up your changes and make them after the iterator finishes or use keys to fetch all the old keys at once, and iterate over the list of keys. @@ -1472,7 +1481,7 @@ take the scalar sense of the keys() function: $num_keys = scalar keys %hash; -In void context, the keys() function just resets the iterator, which is +The keys() function also resets the iterator, which in void context is faster for tied hashes than would be iterating through the whole hash, one key-value pair at a time. @@ -1488,8 +1497,8 @@ keys or values: } keys %hash; # and by value Here we'll do a reverse numeric sort by value, and if two keys are -identical, sort by length of key, and if that fails, by straight ASCII -comparison of the keys (well, possibly modified by your locale -- see +identical, sort by length of key, or if that fails, by straight ASCII +comparison of the keys (well, possibly modified by your locale--see L<perllocale>). @keys = sort { @@ -1746,7 +1755,7 @@ if you just want to say, ``Is this a float?'' Or you could check out the String::Scanf module on CPAN instead. The POSIX module (part of the standard Perl distribution) provides the -C<strtol> and C<strtod> for converting strings to double and longs, +C<strtod> and C<strtol> for converting strings to double and longs, respectively. =head2 How do I keep persistent data across program calls? diff --git a/contrib/perl5/pod/perlfaq5.pod b/contrib/perl5/pod/perlfaq5.pod index 6ae7755f8b72..4ae7407e96f9 100644 --- a/contrib/perl5/pod/perlfaq5.pod +++ b/contrib/perl5/pod/perlfaq5.pod @@ -10,7 +10,7 @@ formats, and footers. =head2 How do I flush/unbuffer an output filehandle? Why must I do this? The C standard I/O library (stdio) normally buffers characters sent to -devices. This is done for efficiency reasons, so that there isn't a +devices. This is done for efficiency reasons so that there isn't a system call for each byte. Any time you use print() or write() in Perl, you go though this buffering. syswrite() circumvents stdio and buffering. @@ -83,16 +83,17 @@ Perl is a programming language. You have to decompose the problem into low-level calls to read, write, open, close, and seek. Although humans have an easy time thinking of a text file as being a -sequence of lines that operates much like a stack of playing cards -- or -punch cards -- computers usually see the text file as a sequence of bytes. +sequence of lines that operates much like a stack of playing cards--or +punch cards--computers usually see the text file as a sequence of bytes. In general, there's no direct way for Perl to seek to a particular line of a file, insert text into a file, or remove text from a file. -(There are exceptions in special circumstances. You can add or remove at -the very end of the file. Another is replacing a sequence of bytes with -another sequence of the same length. Another is using the C<$DB_RECNO> -array bindings as documented in L<DB_File>. Yet another is manipulating -files with all lines the same length.) +(There are exceptions in special circumstances. You can add or remove +data at the very end of the file. A sequence of bytes can be replaced +with another sequence of the same length. The C<$DB_RECNO> array +bindings as documented in L<DB_File> also provide a direct way of +modifying a file. Files where all lines are the same length are also +easy to alter.) The general solution is to create a temporary copy of the text file with the changes you want, then copy that over the original. This assumes @@ -174,16 +175,17 @@ This assumes no funny games with newline translations. =head2 How do I make a temporary file name? Use the C<new_tmpfile> class method from the IO::File module to get a -filehandle opened for reading and writing. Use this if you don't -need to know the file's name. +filehandle opened for reading and writing. Use it if you don't +need to know the file's name: use IO::File; $fh = IO::File->new_tmpfile() or die "Unable to make new temporary file: $!"; -Or you can use the C<tmpnam> function from the POSIX module to get a -filename that you then open yourself. Use this if you do need to know -the file's name. +If you do need to know the file's name, you can use the C<tmpnam> +function from the POSIX module to get a filename that you then open +yourself: + use Fcntl; use POSIX qw(tmpnam); @@ -199,9 +201,9 @@ the file's name. # now go on to use the file ... -If you're committed to doing this by hand, use the process ID and/or -the current time-value. If you need to have many temporary files in -one process, use a counter: +If you're committed to creating a temporary file by hand, use the +process ID and/or the current time-value. If you need to have many +temporary files in one process, use a counter: BEGIN { use Fcntl; @@ -272,7 +274,7 @@ had, for example, a function named TmpHandle(), or a variable named # *HostFile automatically closes/disappears here } -Here's how to use this in a loop to open and store a bunch of +Here's how to use typeglobs in a loop to open and store a bunch of filehandles. We'll use as values of the hash an ordered pair to make it easy to sort the hash in insertion order. @@ -292,8 +294,8 @@ pair to make it easy to sort the hash in insertion order. } For passing filehandles to functions, the easiest way is to -preface them with a star, as in func(*STDIN). See L<perlfaq7/"Passing -Filehandles"> for details. +preface them with a star, as in func(*STDIN). +See L<perlfaq7/"Passing Filehandles"> for details. If you want to create many anonymous handles, you should check out the Symbol, FileHandle, or IO::Handle (etc.) modules. Here's the equivalent @@ -306,7 +308,7 @@ code with Symbol::gensym, which is reasonably light-weight: $file{$filename} = [ $i++, $fh ]; } -Or here using the semi-object-oriented FileHandle module, which certainly +Here's using the semi-object-oriented FileHandle module, which certainly isn't light-weight: use FileHandle; @@ -317,7 +319,7 @@ isn't light-weight: } Please understand that whether the filehandle happens to be a (probably -localized) typeglob or an anonymous handle from one of the modules, +localized) typeglob or an anonymous handle from one of the modules in no way affects the bizarre rules for managing indirect handles. See the next question. @@ -325,7 +327,7 @@ See the next question. An indirect filehandle is using something other than a symbol in a place that a filehandle is expected. Here are ways -to get those: +to get indirect filehandles: $fh = SOME_FH; # bareword is strict-subs hostile $fh = "SOME_FH"; # strict-refs hostile; same package only @@ -333,7 +335,7 @@ to get those: $fh = \*SOME_FH; # ref to typeglob (bless-able) $fh = *SOME_FH{IO}; # blessed IO::Handle from *SOME_FH typeglob -Or to use the C<new> method from the FileHandle or IO modules to +Or, you can use the C<new> method from the FileHandle or IO modules to create an anonymous filehandle, store that in a scalar variable, and use it as though it were a normal filehandle. @@ -378,9 +380,10 @@ is risky.) accept_fh($handle); In the examples above, we assigned the filehandle to a scalar variable -before using it. That is because only simple scalar variables, -not expressions or subscripts into hashes or arrays, can be used with -built-ins like C<print>, C<printf>, or the diamond operator. These are +before using it. That is because only simple scalar variables, not +expressions or subscripts of hashes or arrays, can be used with +built-ins like C<print>, C<printf>, or the diamond operator. Using +something other than a simple scalar varaible as a filehandle is illegal and won't even compile: @fd = (*STDIN, *STDOUT, *STDERR); @@ -449,7 +452,7 @@ You can't just: because you have to put the comma in and then recalculate your position. -Alternatively, this commifies all numbers in a line regardless of +Alternatively, this code commifies all numbers in a line regardless of whether they have decimal portions, are preceded by + or -, or whatever: @@ -463,11 +466,11 @@ whatever: =head2 How can I translate tildes (~) in a filename? -Use the <> (glob()) operator, documented in L<perlfunc>. This -requires that you have a shell installed that groks tildes, meaning -csh or tcsh or (some versions of) ksh, and thus may have portability -problems. The Glob::KGlob module (available from CPAN) gives more -portable glob functionality. +Use the <> (glob()) operator, documented in L<perlfunc>. Older +versions of Perl require that you have a shell installed that groks +tildes. Recent perl versions have this feature built in. The +Glob::KGlob module (available from CPAN) gives more portable glob +functionality. Within Perl, you may use this directly: @@ -551,8 +554,8 @@ To open a file without blocking, creating if necessary: Be warned that neither creation nor deletion of files is guaranteed to be an atomic operation over NFS. That is, two processes might both -successful create or unlink the same file! Therefore O_EXCL -isn't so exclusive as you might wish. +successfully create or unlink the same file! Therefore O_EXCL +isn't as exclusive as you might wish. See also the new L<perlopentut> if you have it (new for 5.6). @@ -573,15 +576,15 @@ one that doesn't use the shell to do globbing. Due to the current implementation on some operating systems, when you use the glob() function or its angle-bracket alias in a scalar -context, you may cause a leak and/or unpredictable behavior. It's +context, you may cause a memory leak and/or unpredictable behavior. It's best therefore to use glob() only in list context. =head2 How can I open a file with a leading ">" or trailing blanks? Normally perl ignores trailing blanks in filenames, and interprets certain leading characters (or a trailing "|") to mean something -special. To avoid this, you might want to use a routine like this. -It makes incomplete pathnames into explicit relative ones, and tacks a +special. To avoid this, you might want to use a routine like the one below. +It turns incomplete pathnames into explicit relative ones, and tacks a trailing null byte on the name to make perl leave it alone: sub safe_filename { @@ -603,7 +606,7 @@ It would be a lot clearer to use sysopen(), though: use Fcntl; $badpath = "<<<something really wicked "; - open (FH, $badpath, O_WRONLY | O_CREAT | O_TRUNC) + sysopen (FH, $badpath, O_WRONLY | O_CREAT | O_TRUNC) or die "can't open $badpath: $!"; For more information, see also the new L<perlopentut> if you have it @@ -611,10 +614,10 @@ For more information, see also the new L<perlopentut> if you have it =head2 How can I reliably rename a file? -Well, usually you just use Perl's rename() function. But that may not -work everywhere, in particular, renaming files across file systems. +Well, usually you just use Perl's rename() function. That may not +work everywhere, though, particularly when renaming files across file systems. Some sub-Unix systems have broken ports that corrupt the semantics of -rename() -- for example, WinNT does this right, but Win95 and Win98 +rename()--for example, WinNT does this right, but Win95 and Win98 are broken. (The last two parts are not surprising, but the first is. :-) If your operating system supports a proper mv(1) program or its moral @@ -624,11 +627,11 @@ equivalent, this works: It may be more compelling to use the File::Copy module instead. You just copy to the new file to the new name (checking return values), -then delete the old one. This isn't really the same semantics as a +then delete the old one. This isn't really the same semantically as a real rename(), though, which preserves metainformation like permissions, timestamps, inode info, etc. -The newer version of File::Copy exports a move() function. +Newer versions of File::Copy exports a move() function. =head2 How can I lock a file? @@ -654,12 +657,12 @@ filehandle be open for writing (or appending, or read/writing). Some versions of flock() can't lock files over a network (e.g. on NFS file systems), so you'd need to force the use of fcntl(2) when you build Perl. -But even this is dubious at best. See the flock entry of L<perlfunc>, +But even this is dubious at best. See the flock entry of L<perlfunc> and the F<INSTALL> file in the source distribution for information on building Perl to do this. Two potentially non-obvious but traditional flock semantics are that -it waits indefinitely until the lock is granted, and that its locks +it waits indefinitely until the lock is granted, and that its locks are I<merely advisory>. Such discretionary locks are more flexible, but offer fewer guarantees. This means that files locked with flock() may be modified by programs that do not also use flock(). Cars that stop @@ -667,13 +670,13 @@ for red lights get on well with each other, but not with cars that don't stop for red lights. See the perlport manpage, your port's specific documentation, or your system-specific local manpages for details. It's best to assume traditional behavior if you're writing portable programs. -(But if you're not, you should as always feel perfectly free to write +(If you're not, you should as always feel perfectly free to write for your own system's idiosyncrasies (sometimes called "features"). Slavish adherence to portability concerns shouldn't get in the way of your getting your job done.) -For more information on file locking, see also L<perlopentut/"File -Locking"> if you have it (new for 5.6). +For more information on file locking, see also +L<perlopentut/"File Locking"> if you have it (new for 5.6). =back @@ -700,20 +703,18 @@ these tend to involve busy-wait, which is also subdesirable. Didn't anyone ever tell you web-page hit counters were useless? They don't count number of hits, they're a waste of time, and they serve -only to stroke the writer's vanity. Better to pick a random number. -It's more realistic. +only to stroke the writer's vanity. It's better to pick a random number; +they're more realistic. Anyway, this is what you can do if you can't help yourself. - use Fcntl ':flock'; + use Fcntl qw(:DEFAULT :flock); sysopen(FH, "numfile", O_RDWR|O_CREAT) or die "can't open numfile: $!"; flock(FH, LOCK_EX) or die "can't flock numfile: $!"; $num = <FH> || 0; seek(FH, 0, 0) or die "can't rewind numfile: $!"; truncate(FH, 0) or die "can't truncate numfile: $!"; (print FH $num+1, "\n") or die "can't write numfile: $!"; - # Perl as of 5.004 automatically flushes before unlocking - flock(FH, LOCK_UN) or die "can't flock numfile: $!"; close FH or die "can't close numfile: $!"; Here's a much better web-page hit counter: @@ -743,7 +744,7 @@ like this: close FH; Locking and error checking are left as an exercise for the reader. -Don't forget them, or you'll be quite sorry. +Don't forget them or you'll be quite sorry. =head2 How do I get a file's timestamp in perl? @@ -793,7 +794,7 @@ Error checking is, as usual, left as an exercise for the reader. Note that utime() currently doesn't work correctly with Win95/NT ports. A bug has been reported. Check it carefully before using -it on those platforms. +utime() on those platforms. =head2 How do I print to more than one file at once? @@ -815,8 +816,8 @@ Or even: close(STDOUT) or die "Closing: $!\n"; Otherwise you'll have to write your own multiplexing print -function -- or your own tee program -- or use Tom Christiansen's, -at http://www.perl.com/CPAN/authors/id/TOMC/scripts/tct.gz, which is +function--or your own tee program--or use Tom Christiansen's, +at http://www.perl.com/CPAN/authors/id/TOMC/scripts/tct.gz , which is written in Perl and offers much greater functionality than the stock version. @@ -834,20 +835,20 @@ do so one line at a time: This is tremendously more efficient than reading the entire file into memory as an array of lines and then processing it one element at a time, -which is often -- if not almost always -- the wrong approach. Whenever +which is often--if not almost always--the wrong approach. Whenever you see someone do this: @lines = <INPUT>; -You should think long and hard about why you need everything loaded +you should think long and hard about why you need everything loaded at once. It's just not a scalable solution. You might also find it -more fun to use the the standard DB_File module's $DB_RECNO bindings, +more fun to use the standard DB_File module's $DB_RECNO bindings, which allow you to tie an array to a file so that accessing an element the array actually accesses the corresponding line in the file. On very rare occasion, you may have an algorithm that demands that the entire file be in memory at once as one scalar. The simplest solution -to that is: +to that is $var = `cat $file`; @@ -886,7 +887,7 @@ Note that a blank line must have no blanks in it. Thus C<"fred\n You can use the builtin C<getc()> function for most filehandles, but it won't (easily) work on a terminal device. For STDIN, either use -the Term::ReadKey module from CPAN, or use the sample code in +the Term::ReadKey module from CPAN or use the sample code in L<perlfunc/getc>. If your system supports the portable operating system programming @@ -942,7 +943,7 @@ turns off echo processing as well. END { cooked() } -The Term::ReadKey module from CPAN may be easier to use. Recent version +The Term::ReadKey module from CPAN may be easier to use. Recent versions include also support for non-portable systems as well. use Term::ReadKey; @@ -997,8 +998,8 @@ table: # 78-83 ALT 1234567890-= # 84 CTR PgUp -This is all trial and error I did a long time ago, I hope I'm reading the -file that worked. +This is all trial and error I did a long time ago; I hope I'm reading the +file that worked... =head2 How can I tell whether there's a character waiting on a filehandle? @@ -1056,7 +1057,7 @@ And then hard-code it, leaving porting as an exercise to your successor. ioctl(FH, $FIONREAD, $size) or die "Couldn't call ioctl: $!\n"; $size = unpack("L", $size); -FIONREAD requires a filehandle connected to a stream, meaning sockets, +FIONREAD requires a filehandle connected to a stream, meaning that sockets, pipes, and tty devices work, but I<not> files. =head2 How do I do a C<tail -f> in perl? @@ -1111,14 +1112,14 @@ Error checking, as always, has been left as an exercise for the reader. This should rarely be necessary, as the Perl close() function is to be used for things that Perl opened itself, even if it was a dup of a -numeric descriptor, as with MHCONTEXT above. But if you really have +numeric descriptor as with MHCONTEXT above. But if you really have to, you may be able to do this: require 'sys/syscall.ph'; $rc = syscall(&SYS_close, $fd + 0); # must force numeric die "can't sysclose $fd: $!" unless $rc == -1; -Or just use the fdopen(3S) feature of open(): +Or, just use the fdopen(3S) feature of open(): { local *F; @@ -1138,7 +1139,7 @@ have a file called "c:(tab)emp(formfeed)oo" or Either single-quote your strings, or (preferably) use forward slashes. Since all DOS and Windows versions since something like MS-DOS 2.0 or so have treated C</> and C<\> the same in a path, you might as well use the -one that doesn't clash with Perl -- or the POSIX shell, ANSI C and C++, +one that doesn't clash with Perl--or the POSIX shell, ANSI C and C++, awk, Tcl, Java, or Python, just to mention a few. POSIX paths are more portable, too. @@ -1173,7 +1174,7 @@ Here's an algorithm from the Camel Book: This has a significant advantage in space over reading the whole file in. A simple proof by induction is available upon -request if you doubt its correctness. +request if you doubt the algorithm's correctness. =head2 Why do I get weird spaces when I print an array of lines? @@ -1183,7 +1184,7 @@ Saying joins together the elements of C<@lines> with a space between them. If C<@lines> were C<("little", "fluffy", "clouds")> then the above -statement would print: +statement would print little fluffy clouds diff --git a/contrib/perl5/pod/perlfaq6.pod b/contrib/perl5/pod/perlfaq6.pod index bf007ee26be4..ed6c01b31b18 100644 --- a/contrib/perl5/pod/perlfaq6.pod +++ b/contrib/perl5/pod/perlfaq6.pod @@ -8,8 +8,9 @@ This section is surprisingly small because the rest of the FAQ is littered with answers involving regular expressions. For example, decoding a URL and checking whether something is a number are handled with regular expressions, but those answers are found elsewhere in -this document (in the section on Data and the Networking one on -networking, to be precise). +this document (in L<perlfaq9>: ``How do I decode or create those %-encodings +on the web'' and L<perfaq4>: ``How do I determine whether a scalar is +a number/whole/integer/float'', to be precise). =head2 How can I hope to use regular expressions without creating illegible and unmaintainable code? @@ -175,7 +176,7 @@ appear within a certain time. $file->waitfor('/second line\n/'); print $file->getline; -=head2 How do I substitute case insensitively on the LHS, but preserving case on the RHS? +=head2 How do I substitute case insensitively on the LHS while preserving case on the RHS? Here's a lovely Perlish solution by Larry Rosler. It exploits properties of bitwise xor on ASCII strings. @@ -185,7 +186,7 @@ properties of bitwise xor on ASCII strings. $old = 'test'; $new = 'success'; - s{(\Q$old\E} + s{(\Q$old\E)} { uc $new | (uc $1 ^ $1) . (uc(substr $1, -1) ^ substr $1, -1) x (length($new) - length $1) @@ -280,10 +281,11 @@ Without the \Q, the regex would also spuriously match "di". =head2 What is C</o> really for? Using a variable in a regular expression match forces a re-evaluation -(and perhaps recompilation) each time through. The C</o> modifier -locks in the regex the first time it's used. This always happens in a -constant regular expression, and in fact, the pattern was compiled -into the internal format at the same time your entire program was. +(and perhaps recompilation) each time the regular expression is +encountered. The C</o> modifier locks in the regex the first time +it's used. This always happens in a constant regular expression, and +in fact, the pattern was compiled into the internal format at the same +time your entire program was. Use of C</o> is irrelevant unless variable interpolation is used in the pattern, and if so, the regex engine will neither know nor care @@ -367,8 +369,8 @@ A slight modification also removes C++ comments: =head2 Can I use Perl regular expressions to match balanced text? Although Perl regular expressions are more powerful than "mathematical" -regular expressions, because they feature conveniences like backreferences -(C<\1> and its ilk), they still aren't powerful enough -- with +regular expressions because they feature conveniences like backreferences +(C<\1> and its ilk), they still aren't powerful enough--with the possible exception of bizarre and experimental features in the development-track releases of Perl. You still need to use non-regex techniques to parse balanced text, such as the text enclosed between @@ -379,7 +381,7 @@ and possibly nested single chars, like C<`> and C<'>, C<{> and C<}>, or C<(> and C<)> can be found in http://www.perl.com/CPAN/authors/id/TOMC/scripts/pull_quotes.gz . -The C::Scan module from CPAN contains such subs for internal usage, +The C::Scan module from CPAN contains such subs for internal use, but they are undocumented. =head2 What does it mean that regexes are greedy? How can I get around it? @@ -402,7 +404,7 @@ expression engine to find a match as quickly as possible and pass control on to whatever is next in line, like you would if you were playing hot potato. -=head2 How do I process each word on each line? +=head2 How do I process each word on each line? Use the split function: @@ -415,7 +417,8 @@ Use the split function: Note that this isn't really a word in the English sense; it's just chunks of consecutive non-whitespace characters. -To work with only alphanumeric sequences, you might consider +To work with only alphanumeric sequences (including underscores), you +might consider while (<>) { foreach $word (m/(\w+)/g) { @@ -449,7 +452,8 @@ regular expression: print "$count $line"; } -If you want these output in a sorted order, see the section on Hashes. +If you want these output in a sorted order, see L<perlfaq4>: ``How do I +sort a hash (optionally by value instead of key)?''. =head2 How can I do approximate matching? @@ -486,7 +490,7 @@ approach, one which makes use of the new C<qr//> operator: =head2 Why don't word-boundary searches with C<\b> work for me? -Two common misconceptions are that C<\b> is a synonym for C<\s+>, and +Two common misconceptions are that C<\b> is a synonym for C<\s+> and that it's the edge between whitespace characters and non-whitespace characters. Neither is correct. C<\b> is the place between a C<\w> character and a C<\W> character (that is, C<\b> is the edge of a @@ -513,11 +517,11 @@ not "this" or "island". =head2 Why does using $&, $`, or $' slow my program down? -Because once Perl sees that you need one of these variables anywhere in -the program, it has to provide them on each and every pattern match. +Once Perl sees that you need one of these variables anywhere in +the program, it provides them on each and every pattern match. The same mechanism that handles these provides for the use of $1, $2, etc., so you pay the same price for each regex that contains capturing -parentheses. But if you never use $&, etc., in your script, then regexes +parentheses. If you never use $&, etc., in your script, then regexes I<without> capturing parentheses won't be penalized. So avoid $&, $', and $` if you can, but if you can't, once you've used them at all, use them at will because you've already paid the price. Remember that some @@ -526,11 +530,16 @@ variable is no longer "expensive" the way the other two are. =head2 What good is C<\G> in a regular expression? -The notation C<\G> is used in a match or substitution in conjunction the -C</g> modifier (and ignored if there's no C</g>) to anchor the regular -expression to the point just past where the last match occurred, i.e. the -pos() point. A failed match resets the position of C<\G> unless the -C</c> modifier is in effect. +The notation C<\G> is used in a match or substitution in conjunction with +the C</g> modifier to anchor the regular expression to the point just past +where the last match occurred, i.e. the pos() point. A failed match resets +the position of C<\G> unless the C</c> modifier is in effect. C<\G> can be +used in a match without the C</g> modifier; it acts the same (i.e. still +anchors at the pos() point) but of course only matches once and does not +update pos(), as non-C</g> expressions never do. C<\G> in an expression +applied to a target string that has never been matched against a C</g> +expression before or has had its pos() reset is functionally equivalent to +C<\A>, which matches at the beginning of the string. For example, suppose you had a line of text quoted in standard mail and Usenet notation, (that is, with leading C<< > >> characters), and @@ -583,7 +592,7 @@ Of course, that could have been written as } } -But then you lose the vertical alignment of the regular expressions. +but then you lose the vertical alignment of the regular expressions. =head2 Are Perl regexes DFAs or NFAs? Are they POSIX compliant? @@ -664,12 +673,12 @@ Well, if it's really a pattern, then just use chomp($pattern = <STDIN>); if ($line =~ /$pattern/) { } -Or, since you have no guarantee that your user entered +Alternatively, since you have no guarantee that your user entered a valid regular expression, trap the exception this way: if (eval { $line =~ /$pattern/ }) { } -But if all you really want to search for a string, not a pattern, +If all you really want to search for a string, not a pattern, then you should either use the index() function, which is made for string searching, or if you can't be disabused of using a pattern match on a non-pattern, then be sure to use C<\Q>...C<\E>, documented diff --git a/contrib/perl5/pod/perlfaq7.pod b/contrib/perl5/pod/perlfaq7.pod index 1ca7893f13db..0299c2d8934a 100644 --- a/contrib/perl5/pod/perlfaq7.pod +++ b/contrib/perl5/pod/perlfaq7.pod @@ -29,18 +29,18 @@ They are type specifiers, as detailed in L<perldata>: * for all types of that symbol name. In version 4 you used them like pointers, but in modern perls you can just use references. -A couple of others that you're likely to encounter that aren't -really type specifiers are: +There are couple of other symbols that you're likely to encounter that aren't +really type specifiers: <> are used for inputting a record from a filehandle. \ takes a reference to something. Note that <FILE> is I<neither> the type specifier for files nor the name of the handle. It is the C<< <> >> operator applied -to the handle FILE. It reads one line (well, record - see +to the handle FILE. It reads one line (well, record--see L<perlvar/$/>) from the handle FILE in scalar context, or I<all> lines in list context. When performing open, close, or any other operation -besides C<< <> >> on files, or even talking about the handle, do +besides C<< <> >> on files, or even when talking about the handle, do I<not> use the brackets. These are correct: C<eof(FH)>, C<seek(FH, 0, 2)> and "copying from STDIN to FILE". @@ -106,15 +106,15 @@ use my() on C<$^W>, only local(). =head2 What's an extension? -A way of calling compiled C code from Perl. Reading L<perlxstut> -is a good place to learn more about extensions. +An extension is a way of calling compiled C code from Perl. Reading +L<perlxstut> is a good place to learn more about extensions. =head2 Why do Perl operators have different precedence than C operators? Actually, they don't. All C operators that Perl copies have the same precedence in Perl as they do in C. The problem is with operators that C doesn't have, especially functions that give a list context to everything -on their right, eg print, chmod, exec, and so on. Such functions are +on their right, eg. print, chmod, exec, and so on. Such functions are called "list operators" and appear as such in the precedence table in L<perlop>. @@ -196,6 +196,10 @@ own module. Make sure to change the names appropriately. } our @EXPORT_OK; + # exported package globals go here + our $Var1; + our %Hashit; + # non-exported package globals go here our @more; our $stuff; @@ -254,7 +258,7 @@ is given no processes to signal): } This is not C<-w> clean, however. There is no C<-w> clean way to -detect taintedness - take this as a hint that you should untaint +detect taintedness--take this as a hint that you should untaint all possibly-tainted data. =head2 What's a closure? @@ -270,7 +274,7 @@ around when the subroutine was defined (deep binding). Closures make sense in any programming language where you can have the return value of a function be itself a function, as you can in Perl. Note that some languages provide anonymous functions but are not -capable of providing proper closures; the Python language, for +capable of providing proper closures: the Python language, for example. For more information on closures, check out any textbook on functional programming. Scheme is a language that not only supports but encourages closures. @@ -345,11 +349,14 @@ With the exception of regexes, you need to pass references to these objects. See L<perlsub/"Pass by Reference"> for this particular question, and L<perlref> for information on references. +See ``Passing Regexes'', below, for information on passing regular +expressions. + =over 4 =item Passing Variables and Functions -Regular variables and functions are quite easy: just pass in a +Regular variables and functions are quite easy to pass: just pass in a reference to an existing or anonymous variable or function: func( \$some_scalar ); @@ -366,7 +373,7 @@ reference to an existing or anonymous variable or function: =item Passing Filehandles To pass filehandles to subroutines, use the C<*FH> or C<\*FH> notations. -These are "typeglobs" - see L<perldata/"Typeglobs and Filehandles"> +These are "typeglobs"--see L<perldata/"Typeglobs and Filehandles"> and especially L<perlsub/"Pass by Reference"> for more information. Here's an excerpt: @@ -390,7 +397,7 @@ they'll still work properly under C<use strict 'refs'>. For example: If you're planning on generating new filehandles, you could do this: sub openit { - my $name = shift; + my $path = shift; local *FH; return open (FH, $path) ? *FH : undef; } @@ -456,8 +463,8 @@ To pass an object method into a subroutine, you can do this: } } -Or you can use a closure to bundle up the object and its method call -and arguments: +Or, you can use a closure to bundle up the object, its +method call, and arguments: my $whatnot = sub { $some_obj->obfuscate(@args) }; func($whatnot); @@ -491,8 +498,8 @@ Now prev_counter() and next_counter() share a private variable $counter that was initialized at compile time. To declare a file-private variable, you'll still use a my(), putting -it at the outer scope level at the top of the file. Assume this is in -file Pax.pm: +the declaration at the outer scope level at the top of the file. +Assume this is in file Pax.pm: package Pax; my $started = scalar(localtime(time())); @@ -512,14 +519,14 @@ See L<perlsub/"Persistent Private Variables"> for details. =head2 What's the difference between dynamic and lexical (static) scoping? Between local() and my()? -C<local($x)> saves away the old value of the global variable C<$x>, -and assigns a new value for the duration of the subroutine, I<which is +C<local($x)> saves away the old value of the global variable C<$x> +and assigns a new value for the duration of the subroutine I<which is visible in other functions called from that subroutine>. This is done at run-time, so is called dynamic scoping. local() always affects global variables, also called package variables or dynamic variables. C<my($x)> creates a new variable that is only visible in the current -subroutine. This is done at compile-time, so is called lexical or +subroutine. This is done at compile-time, so it is called lexical or static scoping. my() always affects private variables, also called lexical variables or (improperly) static(ly scoped) variables. @@ -553,8 +560,8 @@ In summary, local() doesn't make what you think of as private, local variables. It gives a global variable a temporary value. my() is what you're looking for if you want private variables. -See L<perlsub/"Private Variables via my()"> and L<perlsub/"Temporary -Values via local()"> for excruciating details. +See L<perlsub/"Private Variables via my()"> and +L<perlsub/"Temporary Values via local()"> for excruciating details. =head2 How can I access a dynamic variable while a similarly named lexical is in scope? @@ -630,8 +637,8 @@ see L<perltoot/"Overridden Methods">. =head2 What's the difference between calling a function as &foo and foo()? When you call a function as C<&foo>, you allow that function access to -your current @_ values, and you by-pass prototypes. That means that -the function doesn't get an empty @_, it gets yours! While not +your current @_ values, and you bypass prototypes. +The function doesn't get an empty @_--it gets yours! While not strictly speaking a bug (it's documented that way in L<perlsub>), it would be hard to consider this a feature in most cases. @@ -705,7 +712,7 @@ Sometimes you should change the positions of the constant and the variable. For example, let's say you wanted to test which of many answers you were given, but in a case-insensitive way that also allows abbreviations. You can use the following technique if the strings all start with -different characters, or if you want to arrange the matches so that +different characters or if you want to arrange the matches so that one takes precedence over another, as C<"SEND"> has precedence over C<"STOP"> here: @@ -763,15 +770,16 @@ C<__WARN__> like this: Some possible reasons: your inheritance is getting confused, you've misspelled the method name, or the object is of the wrong type. Check -out L<perltoot> for details on these. You may also use C<print -ref($object)> to find out the class C<$object> was blessed into. +out L<perltoot> for details about any of the above cases. You may +also use C<print ref($object)> to find out the class C<$object> was +blessed into. Another possible reason for problems is because you've used the indirect object syntax (eg, C<find Guru "Samy">) on a class name before Perl has seen that such a package exists. It's wisest to make sure your packages are all defined before you start using them, which will be taken care of if you use the C<use> statement instead of -C<require>. If not, make sure to use arrow notation (eg, +C<require>. If not, make sure to use arrow notation (eg., C<< Guru->find("Samy") >>) instead. Object notation is explained in L<perlobj>. @@ -785,7 +793,7 @@ out what the currently compiled package is: my $packname = __PACKAGE__; -But if you're a method and you want to print an error message +But, if you're a method and you want to print an error message that includes the kind of object you were called on (which is not necessarily the same as the one in which you were compiled): @@ -857,19 +865,19 @@ of a variable. This works I<sometimes>, but it is a very bad idea for two reasons. -The first reason is that they I<only work on global variables>. -That means above that if $fred is a lexical variable created with my(), -that the code won't work at all: you'll accidentally access the global -and skip right over the private lexical altogether. Global variables -are bad because they can easily collide accidentally and in general make -for non-scalable and confusing code. +The first reason is that this technique I<only works on global +variables>. That means that if $fred is a lexical variable created +with my() in the above example, the code wouldn't work at all: you'd +accidentally access the global and skip right over the private lexical +altogether. Global variables are bad because they can easily collide +accidentally and in general make for non-scalable and confusing code. Symbolic references are forbidden under the C<use strict> pragma. They are not true references and consequently are not reference counted or garbage collected. The other reason why using a variable to hold the name of another -variable a bad idea is that the question often stems from a lack of +variable is a bad idea is that the question often stems from a lack of understanding of Perl data structures, particularly hashes. By using symbolic references, you are just using the package's symbol-table hash (like C<%main::>) instead of a user-defined hash. The solution is to @@ -890,7 +898,7 @@ own variables: $str = 'this has a $fred and $barney in it'; $str =~ s/(\$\w+)/$1/eeg; # need double eval -Instead, it would be better to keep a hash around like %USER_VARS and have +it would be better to keep a hash around like %USER_VARS and have variable references actually refer to entries in that hash: $str =~ s/\$(\w+)/$USER_VARS{$1}/g; # no /e here at all @@ -902,11 +910,11 @@ make it less confusing, like bracketed percent symbols, etc. $str = 'this has a %fred% and %barney% in it'; $str =~ s/%(\w+)%/$USER_VARS{$1}/g; # no /e here at all -Another reason that folks sometimes think they want a variable to contain -the name of a variable is because they don't know how to build proper -data structures using hashes. For example, let's say they wanted two -hashes in their program: %fred and %barney, and to use another scalar -variable to refer to those by name. +Another reason that folks sometimes think they want a variable to +contain the name of a variable is because they don't know how to build +proper data structures using hashes. For example, let's say they +wanted two hashes in their program: %fred and %barney, and that they +wanted to use another scalar variable to refer to those by name. $name = "fred"; $$name{WIFE} = "wilma"; # set %fred @@ -942,9 +950,9 @@ but the real code in the closure actually was compiled only once. So, sometimes you might want to use symbolic references to directly manipulate the symbol table. This doesn't matter for formats, handles, and -subroutines, because they are always global -- you can't use my() on them. -But for scalars, arrays, and hashes -- and usually for subroutines -- -you probably want to use hard references only. +subroutines, because they are always global--you can't use my() on them. +For scalars, arrays, and hashes, though--and usually for subroutines-- +you probably only want to use hard references. =head1 AUTHOR AND COPYRIGHT @@ -963,3 +971,4 @@ are hereby placed into the public domain. You are permitted and encouraged to use this code in your own programs for fun or for profit as you see fit. A simple comment in the code giving credit would be courteous but is not required. + diff --git a/contrib/perl5/pod/perlfaq8.pod b/contrib/perl5/pod/perlfaq8.pod index ed22ba0c59fa..1df3b6ac0ab1 100644 --- a/contrib/perl5/pod/perlfaq8.pod +++ b/contrib/perl5/pod/perlfaq8.pod @@ -5,7 +5,7 @@ perlfaq8 - System Interaction ($Revision: 1.39 $, $Date: 1999/05/23 18:37:57 $) =head1 DESCRIPTION This section of the Perl FAQ covers questions involving operating -system interaction. This involves interprocess communication (IPC), +system interaction. Topics include interprocess communication (IPC), control over the user-interface (keyboard, screen and pointing devices), and most anything else not related to data manipulation. @@ -95,10 +95,10 @@ It even includes limited support for Windows. $key = ReadKey(0); ReadMode('normal'); -However, that requires that you have a working C compiler and can use it -to build and install a CPAN module. Here's a solution using -the standard POSIX module, which is already on your systems (assuming -your system supports POSIX). +However, using the code requires that you have a working C compiler +and can use it to build and install a CPAN module. Here's a solution +using the standard POSIX module, which is already on your systems +(assuming your system supports POSIX). use HotKey; $key = readkey(); @@ -214,10 +214,10 @@ illustrative: (This question has nothing to do with the web. See a different FAQ for that.) -There's an example of this in L<perlfunc/crypt>). First, you put -the terminal into "no echo" mode, then just read the password -normally. You may do this with an old-style ioctl() function, POSIX -terminal control (see L<POSIX>, and Chapter 7 of the Camel), or a call +There's an example of this in L<perlfunc/crypt>). First, you put the +terminal into "no echo" mode, then just read the password normally. +You may do this with an old-style ioctl() function, POSIX terminal +control (see L<POSIX> or its documentation the Camel Book), or a call to the B<stty> program, with varying degrees of portability. You can also do this for most systems using the Term::ReadKey module @@ -232,16 +232,16 @@ from CPAN, which is easier to use and in theory more portable. This depends on which operating system your program is running on. In the case of Unix, the serial ports will be accessible through files in -/dev; on other systems, the devices names will doubtless differ. +/dev; on other systems, device names will doubtless differ. Several problem areas common to all device interaction are the -following +following: =over 4 =item lockfiles Your system may use lockfiles to control multiple access. Make sure -you follow the correct protocol. Unpredictable behaviour can result +you follow the correct protocol. Unpredictable behavior can result from multiple processes reading from one device. =item open mode @@ -264,7 +264,7 @@ give the numeric values you want directly, using octal ("\015"), hex print DEV "atv1\012"; # wrong, for some devices print DEV "atv1\015"; # right, for some devices -Even though with normal text files, a "\n" will do the trick, there is +Even though with normal text files a "\n" will do the trick, there is still no unified scheme for terminating a line that is portable between Unix, DOS/Win, and Macintosh, except to terminate I<ALL> line ends with "\015\012", and strip what you don't need from the output. @@ -276,7 +276,8 @@ next. If you expect characters to get to your device when you print() them, you'll want to autoflush that filehandle. You can use select() and the C<$|> variable to control autoflushing (see L<perlvar/$|> -and L<perlfunc/select>): +and L<perlfunc/select>, or L<perlfaq5>, ``How do I flush/unbuffer an +output filehandle? Why must I do this?''): $oldh = select(DEV); $| = 1; @@ -320,7 +321,7 @@ go bump in the night, finally came up with this: # been opened on a pipe... system("/bin/stty $stty"); $_ = <MODEM_IN>; - chop; + chomp; if ( !m/^Connected/ ) { print STDERR "$0: cu printed `$_' instead of `Connected'\n"; } @@ -331,7 +332,7 @@ go bump in the night, finally came up with this: You spend lots and lots of money on dedicated hardware, but this is bound to get you talked about. -Seriously, you can't if they are Unix password files - the Unix +Seriously, you can't if they are Unix password files--the Unix password system employs one-way encryption. It's more like hashing than encryption. The best you can check is whether something else hashes to the same string. You can't turn a hash back into the original string. @@ -388,7 +389,8 @@ Zombies are not an issue with C<system("prog &")>. You don't actually "trap" a control character. Instead, that character generates a signal which is sent to your terminal's currently foregrounded process group, which you then trap in your process. -Signals are documented in L<perlipc/"Signals"> and chapter 6 of the Camel. +Signals are documented in L<perlipc/"Signals"> and the +section on ``Signals'' in the Camel. Be warned that very few C libraries are re-entrant. Therefore, if you attempt to print() in a handler that got invoked during another stdio @@ -397,7 +399,7 @@ inconsistent state, and your program will dump core. You can sometimes avoid this by using syswrite() instead of print(). Unless you're exceedingly careful, the only safe things to do inside a -signal handler are: set a variable and exit. And in the first case, +signal handler are (1) set a variable and (2) exit. In the first case, you should only set a variable in such a way that malloc() is not called (eg, by setting a variable that already has a value). @@ -413,15 +415,16 @@ However, because syscalls restart by default, you'll find that if you're in a "slow" call, such as <FH>, read(), connect(), or wait(), that the only way to terminate them is by "longjumping" out; that is, by raising an exception. See the time-out handler for a -blocking flock() in L<perlipc/"Signals"> or chapter 6 of the Camel. +blocking flock() in L<perlipc/"Signals"> or the section on ``Signals'' +in the Camel book. =head2 How do I modify the shadow password file on a Unix system? -If perl was installed correctly, and your shadow library was written +If perl was installed correctly and your shadow library was written properly, the getpw*() functions described in L<perlfunc> should in theory provide (read-only) access to entries in the shadow password file. To change the file, make a new shadow password file (the format -varies from system to system - see L<passwd(5)> for specifics) and use +varies from system to system--see L<passwd(5)> for specifics) and use pwd_mkdb(8) to install it (see L<pwd_mkdb(8)> for more details). =head2 How do I set the time and date? @@ -443,9 +446,8 @@ probably get away with setting an environment variable: If you want finer granularity than the 1 second that the sleep() function provides, the easiest way is to use the select() function as -documented in L<perlfunc/"select">. If your system has itimers and -syscall() support, you can check out the old example in -http://www.perl.com/CPAN/doc/misc/ancient/tutorial/eg/itimers.pl . +documented in L<perlfunc/"select">. Try the Time::HiRes and +the BSD::Itimer modules (available from CPAN). =head2 How can I measure time under a second? @@ -495,15 +497,16 @@ managed to finish its output without filling up the disk: close(STDOUT) || die "stdout close failed: $!"; } -The END block isn't called when untrapped signals kill the program, though, so if -you use END blocks you should also use +The END block isn't called when untrapped signals kill the program, +though, so if you use END blocks you should also use use sigtrap qw(die normal-signals); Perl's exception-handling mechanism is its eval() operator. You can use eval() as setjmp and die() as longjmp. For details of this, see the section on signals, especially the time-out handler for a blocking -flock() in L<perlipc/"Signals"> and chapter 6 of the Camel. +flock() in L<perlipc/"Signals"> or the section on ``Signals'' in +the Camel Book. If exception handling is all you're interested in, try the exceptions.pl library (part of the standard perl distribution). @@ -511,7 +514,7 @@ exceptions.pl library (part of the standard perl distribution). If you want the atexit() syntax (and an rmexit() as well), try the AtExit module available from CPAN. -=head2 Why doesn't my sockets program work under System V (Solaris)? What does the error message "Protocol not supported" mean? +=head2 Why doesn't my sockets program work under System V (Solaris)? What does the error message "Protocol not supported" mean? Some Sys-V based systems, notably Solaris 2.X, redefined some of the standard socket constants. Since these were constant across all @@ -523,14 +526,14 @@ values are different. Go figure. =head2 How can I call my system's unique C functions from Perl? -In most cases, you write an external module to do it - see the answer +In most cases, you write an external module to do it--see the answer to "Where can I learn about linking C with Perl? [h2xs, xsubpp]". However, if the function is a system call, and your system supports syscall(), you can use the syscall function (documented in L<perlfunc>). Remember to check the modules that came with your distribution, and -CPAN as well - someone may already have written a module to do it. +CPAN as well--someone may already have written a module to do it. =head2 Where do I get the include files to do ioctl() or syscall()? @@ -568,9 +571,9 @@ scripts inherently insecure. Perl gives you a number of options The IPC::Open2 module (part of the standard perl distribution) is an easy-to-use approach that internally uses pipe(), fork(), and exec() to do the job. Make sure you read the deadlock warnings in its documentation, -though (see L<IPC::Open2>). See L<perlipc/"Bidirectional Communication -with Another Process"> and L<perlipc/"Bidirectional Communication with -Yourself"> +though (see L<IPC::Open2>). See +L<perlipc/"Bidirectional Communication with Another Process"> and +L<perlipc/"Bidirectional Communication with Yourself"> You may also use the IPC::Open3 module (part of the standard perl distribution), but be warned that it has a different order of @@ -596,7 +599,7 @@ There are three basic ways of running external commands: open (PIPE, "cmd |"); # using open() With system(), both STDOUT and STDERR will go the same place as the -script's versions of these, unless the command redirects them. +script's STDOUT and STDERR, unless the system() command redirects them. Backticks and open() read B<only> the STDOUT of your command. With any of these, you can change file descriptors before the call: @@ -689,7 +692,7 @@ In some cases, even this won't work. If the second argument to a piped open() contains shell metacharacters, perl fork()s, then exec()s a shell to decode the metacharacters and eventually run the desired program. Now when you call wait(), you only learn whether or not the -I<shell> could be successfully started. Best to avoid shell +I<shell> could be successfully started...it's best to avoid shell metacharacters. On systems that follow the spawn() paradigm, open() I<might> do what @@ -716,17 +719,17 @@ Consider this line: `cat /etc/termcap`; You haven't assigned the output anywhere, so it just wastes memory -(for a little while). Plus you forgot to check C<$?> to see whether -the program even ran correctly. Even if you wrote +(for a little while). You forgot to check C<$?> to see whether +the program even ran correctly, too. Even if you wrote print `cat /etc/termcap`; -In most cases, this could and probably should be written as +this code could and probably should be written as system("cat /etc/termcap") == 0 or die "cat program failed!"; -Which will get the output quickly (as it is generated, instead of only +which will get the output quickly (as it is generated, instead of only at the end) and also check the return value. system() also provides direct control over whether shell wildcard @@ -763,7 +766,7 @@ and fix it for you. =head2 Why can't my script read from STDIN after I gave it EOF (^D on Unix, ^Z on MS-DOS)? -Because some stdio's set error and eof flags that need clearing. The +Some stdio's set error and eof flags that need clearing. The POSIX module defines clearerr() that you can use. That is the technically correct way to do it. Here are some less reliable workarounds: @@ -856,9 +859,9 @@ state there, as in: =item Unix -In the strictest sense, it can't be done -- the script executes as a +In the strictest sense, it can't be done--the script executes as a different process from the shell it was started from. Changes to a -process are not reflected in its parent, only in its own children +process are not reflected in its parent--only in any children created after the change. There is shell magic that may allow you to fake it by eval()ing the script's output in your shell; check out the comp.unix.questions FAQ for details. @@ -868,7 +871,7 @@ comp.unix.questions FAQ for details. =head2 How do I close a process's filehandle without waiting for it to complete? Assuming your system supports such things, just send an appropriate signal -to the process (see L<perlfunc/"kill">. It's common to first send a TERM +to the process (see L<perlfunc/"kill">). It's common to first send a TERM signal, wait a little bit, and then send a KILL signal to finish it off. =head2 How do I fork a daemon process? @@ -906,10 +909,6 @@ Background yourself like this: The Proc::Daemon module, available from CPAN, provides a function to perform these actions for you. -=head2 How do I make my program run with sh and csh? - -See the F<eg/nih> script (part of the perl source distribution). - =head2 How do I find out if I'm running interactively or not? Good question. Sometimes C<-t STDIN> and C<-t STDOUT> can give clues, @@ -935,9 +934,9 @@ the current process group of your controlling terminal as follows: =head2 How do I timeout a slow event? Use the alarm() function, probably in conjunction with a signal -handler, as documented in L<perlipc/"Signals"> and chapter 6 of the -Camel. You may instead use the more flexible Sys::AlarmCall module -available from CPAN. +handler, as documented in L<perlipc/"Signals"> and the section on +``Signals'' in the Camel. You may instead use the more flexible +Sys::AlarmCall module available from CPAN. =head2 How do I set CPU limits? @@ -976,9 +975,6 @@ sysopen(): sysopen(FH, "/tmp/somefile", O_WRONLY|O_NDELAY|O_CREAT, 0644) or die "can't open /tmp/somefile: $!": - - - =head2 How do I install a module from CPAN? The easiest way is to have a module also named CPAN do it for you. @@ -1015,26 +1011,27 @@ just need to replace step 3 (B<make>) with B<make perl> and you will get a new F<perl> binary with your extension linked in. See L<ExtUtils::MakeMaker> for more details on building extensions. -See also the next question. +See also the next question, ``What's the difference between require +and use?''. =head2 What's the difference between require and use? Perl offers several different ways to include code from one file into another. Here are the deltas between the various inclusion constructs: - 1) do $file is like eval `cat $file`, except the former: + 1) do $file is like eval `cat $file`, except the former 1.1: searches @INC and updates %INC. 1.2: bequeaths an *unrelated* lexical scope on the eval'ed code. - 2) require $file is like do $file, except the former: + 2) require $file is like do $file, except the former 2.1: checks for redundant loading, skipping already loaded files. 2.2: raises an exception on failure to find, compile, or execute $file. - 3) require Module is like require "Module.pm", except the former: + 3) require Module is like require "Module.pm", except the former 3.1: translates each "::" into your system's directory separator. 3.2: primes the parser to disambiguate class Module as an indirect object. - 4) use Module is like require Module, except the former: + 4) use Module is like require Module, except the former 4.1: loads the module at compile time, not run-time. 4.2: imports symbols and semantics from that package to the current one. @@ -1052,7 +1049,7 @@ scripts that use the modules/libraries (see L<perlrun>) or say use lib '/u/mydir/perl'; -This is almost the same as: +This is almost the same as BEGIN { unshift(@INC, '/u/mydir/perl'); diff --git a/contrib/perl5/pod/perlfaq9.pod b/contrib/perl5/pod/perlfaq9.pod index 16a803c997c2..96763802c527 100644 --- a/contrib/perl5/pod/perlfaq9.pod +++ b/contrib/perl5/pod/perlfaq9.pod @@ -7,7 +7,7 @@ perlfaq9 - Networking ($Revision: 1.26 $, $Date: 1999/05/23 16:08:30 $) This section deals with questions related to networking, the internet, and a few on the web. -=head2 My CGI script runs from the command line but not the browser. (500 Server Error) +=head2 My CGI script runs from the command line but not the browser. (500 Server Error) If you can demonstrate that you've read the following FAQs and that your problem isn't something simple that can be easily answered, you'll @@ -84,8 +84,8 @@ attempts to do a little simple formatting of the resulting plain text. Many folks attempt a simple-minded regular expression approach, like C<< s/<.*?>//g >>, but that fails in many cases because the tags may continue over line breaks, they may contain quoted angle-brackets, -or HTML comment may be present. Plus folks forget to convert -entities, like C<<> for example. +or HTML comment may be present. Plus, folks forget to convert +entities--like C<<> for example. Here's one "simple-minded" approach, that works for most files: @@ -209,27 +209,35 @@ the content appropriately. =head2 How do I decode or create those %-encodings on the web? -Here's an example of decoding: - $string = "http://altavista.digital.com/cgi-bin/query?pg=q&what=news&fmt=.&q=%2Bcgi-bin+%2Bperl.exe"; - $string =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/ge; +If you are writing a CGI script, you should be using the CGI.pm module +that comes with perl, or some other equivalent module. The CGI module +automatically decodes queries for you, and provides an escape() +function to handle encoding. -Encoding is a bit harder, because you can't just blindly change -all the non-alphanumunder character (C<\W>) into their hex escapes. -It's important that characters with special meaning like C</> and C<?> -I<not> be translated. Probably the easiest way to get this right is -to avoid reinventing the wheel and just use the URI::Escape module, -available from CPAN. + +The best source of detailed information on URI encoding is RFC 2396. +Basically, the following substitutions do it: + + s/([^\w()'*~!.-])/sprintf '%%%02x', $1/eg; # encode + + s/%([A-Fa-f\d]{2})/chr hex $1/eg; # decode + +However, you should only apply them to individual URI components, not +the entire URI, otherwise you'll lose information and generally mess +things up. If that didn't explain it, don't worry. Just go read +section 2 of the RFC, it's probably the best explanation there is. + +RFC 2396 also contains a lot of other useful information, including a +regexp for breaking any arbitrary URI into components (Appendix B). =head2 How do I redirect to another page? -Instead of sending back a C<Content-Type> as the headers of your -reply, send back a C<Location:> header. Officially this should be a -C<URI:> header, so the CGI.pm module (available from CPAN) sends back -both: +According to RFC 2616, "Hypertext Transfer Protocol -- HTTP/1.1", the +preferred method is to send a C<Location:> header instead of a +C<Content-Type:> header: Location: http://www.domain.com/newpage - URI: http://www.domain.com/newpage Note that relative URLs in these headers can cause strange effects because of "optimizations" that servers do. @@ -247,12 +255,12 @@ in the header. EOF -To be correct to the spec, each of those virtual newlines should really be -physical C<"\015\012"> sequences by the time you hit the client browser. -Except for NPH scripts, though, that local newline should get translated -by your server into standard form, so you shouldn't have a problem -here, even if you are stuck on MacOS. Everybody else probably won't -even notice. +To be correct to the spec, each of those virtual newlines should +really be physical C<"\015\012"> sequences by the time your message is +received by the client browser. Except for NPH scripts, though, that +local newline should get translated by your server into standard form, +so you shouldn't have a problem here, even if you are stuck on MacOS. +Everybody else probably won't even notice. =head2 How do I put a password on my web pages? @@ -275,9 +283,9 @@ DBI compatible driver. HTTPD::UserAdmin supports files used by the =head2 How do I make sure users can't enter values into a form that cause my CGI script to do bad things? Read the CGI security FAQ, at -http://www-genome.wi.mit.edu/WWW/faqs/www-security-faq.html, and the +http://www-genome.wi.mit.edu/WWW/faqs/www-security-faq.html , and the Perl/CGI FAQ at -http://www.perl.com/CPAN/doc/FAQs/cgi/perl-cgi-faq.html. +http://www.perl.com/CPAN/doc/FAQs/cgi/perl-cgi-faq.html . In brief: use tainting (see L<perlsec>), which makes sure that data from outside your script (eg, CGI parameters) are never used in @@ -288,7 +296,7 @@ command and arguments as a list, which prevents shell globbing. =head2 How do I parse a mail header? For a quick-and-dirty solution, try this solution derived -from page 222 of the 2nd edition of "Programming Perl": +from L<perlfunc/split>: $/ = ''; $header = <MSG>; @@ -344,10 +352,10 @@ deliverable which are compliant. Many are tempted to try to eliminate many frequently-invalid mail addresses with a simple regex, such as -C</^[\w.-]+\@([\w.-]\.)+\w+$/>. It's a very bad idea. However, +C</^[\w.-]+\@(?:[\w-]+\.)+\w+$/>. It's a very bad idea. However, this also throws out many valid ones, and says nothing about -potential deliverability, so is not suggested. Instead, see -http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/ckaddr.gz , +potential deliverability, so it is not suggested. Instead, see +http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/ckaddr.gz, which actually checks against the full RFC spec (except for nested comments), looks for addresses you may not wish to accept mail to (say, Bill Clinton or your postmaster), and then makes sure that the @@ -380,13 +388,18 @@ with the characters reversed, one added or subtracted to each digit, etc. =head2 How do I decode a MIME/BASE64 string? -The MIME-tools package (available from CPAN) handles this and a lot -more. Decoding BASE64 becomes as simple as: +The MIME-Base64 package (available from CPAN) handles this as well as +the MIME/QP encoding. Decoding BASE64 becomes as simple as: - use MIME::base64; + use MIME::Base64; $decoded = decode_base64($encoded); -A more direct approach is to use the unpack() function's "u" +The MIME-Tools package (available from CPAN) supports extraction with +decoding of BASE64 encoded attachments and content directly from email +messages. + +If the string to decode is short (less than 84 bytes long) +a more direct approach is to use the unpack() function's "u" format after minor transliterations: tr#A-Za-z0-9+/##cd; # remove non-base64 chars @@ -396,7 +409,7 @@ format after minor transliterations: =head2 How do I return the user's mail address? -On systems that support getpwuid, the $< variable and the +On systems that support getpwuid, the $< variable, and the Sys::Hostname module (which is part of the standard perl distribution), you can probably try using something like this: @@ -460,11 +473,45 @@ Mail::Mailer, but less reliable. Avoid raw SMTP commands. There are many reasons to use a mail transport agent like sendmail. These include queueing, MX records, and security. +=head2 How do I use MIME to make an attachment to a mail message? + +This answer is extracted directly from the MIME::Lite documentation. +Create a multipart message (i.e., one with attachments). + + use MIME::Lite; + + ### Create a new multipart message: + $msg = MIME::Lite->new( + From =>'me@myhost.com', + To =>'you@yourhost.com', + Cc =>'some@other.com, some@more.com', + Subject =>'A message with 2 parts...', + Type =>'multipart/mixed' + ); + + ### Add parts (each "attach" has same arguments as "new"): + $msg->attach(Type =>'TEXT', + Data =>"Here's the GIF file you wanted" + ); + $msg->attach(Type =>'image/gif', + Path =>'aaa000123.gif', + Filename =>'logo.gif' + ); + + $text = $msg->as_string; + +MIME::Lite also includes a method for sending these things. + + $msg->send; + +This defaults to using L<sendmail(1)> but can be customized to use +SMTP via L<Net::SMTP>. + =head2 How do I read mail? While you could use the Mail::Folder module from CPAN (part of the MailFolder package) or the Mail::Internet module from CPAN (also part -of the MailTools package), often a module is overkill, though. Here's a +of the MailTools package), often a module is overkill. Here's a mail sorter. #!/usr/bin/perl @@ -519,7 +566,7 @@ systems.) =head2 How do I fetch a news article or the active newsgroups? Use the Net::NNTP or News::NNTPClient modules, both available from CPAN. -This can make tasks like fetching the newsgroup list as simple as: +This can make tasks like fetching the newsgroup list as simple as perl -MNews::NNTPClient -e 'print News::NNTPClient->new->list("newsgroups")' @@ -531,7 +578,7 @@ available from CPAN) is more complex but can put as well as fetch. =head2 How can I do RPC in Perl? -A DCE::RPC module is being developed (but is not yet available), and +A DCE::RPC module is being developed (but is not yet available) and will be released as part of the DCE-Perl package (available from CPAN). The rpcgen suite, available from CPAN/authors/id/JAKE/, is an RPC stub generator and includes an RPC::ONC module. diff --git a/contrib/perl5/pod/perlfilter.pod b/contrib/perl5/pod/perlfilter.pod index c3c83153adfa..4327809ec95a 100644 --- a/contrib/perl5/pod/perlfilter.pod +++ b/contrib/perl5/pod/perlfilter.pod @@ -2,7 +2,6 @@ perlfilter - Source Filters - =head1 DESCRIPTION This article is about a little-known feature of Perl called diff --git a/contrib/perl5/pod/perlfork.pod b/contrib/perl5/pod/perlfork.pod index d930e9396e87..dc0a82bfd642 100644 --- a/contrib/perl5/pod/perlfork.pod +++ b/contrib/perl5/pod/perlfork.pod @@ -1,9 +1,14 @@ =head1 NAME -perlfork - Perl's fork() emulation +perlfork - Perl's fork() emulation (EXPERIMENTAL, subject to change) =head1 SYNOPSIS + WARNING: As of the 5.6.1 release, the fork() emulation continues + to be an experimental feature. Use in production applications is + not recommended. See the "BUGS" and "CAVEATS AND LIMITATIONS" + sections below. + Perl provides a fork() keyword that corresponds to the Unix system call of the same name. On most Unix-like platforms where the fork() system call is available, Perl's fork() simply calls it. @@ -11,7 +16,7 @@ call is available, Perl's fork() simply calls it. On some platforms such as Windows where the fork() system call is not available, Perl can be built to emulate fork() at the interpreter level. While the emulation is designed to be as compatible as possible with the -real fork() at the the level of the Perl program, there are certain +real fork() at the level of the Perl program, there are certain important differences that stem from the fact that all the pseudo child "processes" created this way live in the same real process as far as the operating system is concerned. @@ -51,7 +56,7 @@ pseudo-processes are launched after others have been wait()-ed on. =item %ENV -Each pseudo-process maintains its own virtual enviroment. Modifications +Each pseudo-process maintains its own virtual environment. Modifications to %ENV affect the virtual environment, and are only visible within that pseudo-process, and in any processes (or pseudo-processes) launched from it. @@ -274,6 +279,17 @@ are expected to be fixed for thread-safety. =item * +Perl's regular expression engine currently does not play very nicely +with the fork() emulation. There are known race conditions arising +from the regular expression engine modifying state carried in the opcode +tree at run time (the fork() emulation relies on the opcode tree being +immutable). This typically happens when the regex contains paren groups +or variables interpolated within it that force a run time recompilation +of the regex. Due to this major bug, the fork() emulation is not +recommended for use in production applications at this time. + +=item * + Having pseudo-process IDs be negative integers breaks down for the integer C<-1> because the wait() and waitpid() functions treat this number as being special. The tacit assumption in the current implementation is that diff --git a/contrib/perl5/pod/perlfunc.pod b/contrib/perl5/pod/perlfunc.pod index 5396fd19450e..e959abc3ffec 100644 --- a/contrib/perl5/pod/perlfunc.pod +++ b/contrib/perl5/pod/perlfunc.pod @@ -91,7 +91,7 @@ functions, like some keywords and named operators) arranged by category. Some functions appear in more than one place. -=over +=over 4 =item Functions for SCALARs or strings @@ -146,11 +146,11 @@ C<goto>, C<last>, C<next>, C<redo>, C<return>, C<sub>, C<wantarray> =item Keywords related to scoping -C<caller>, C<import>, C<local>, C<my>, C<package>, C<use> +C<caller>, C<import>, C<local>, C<my>, C<our>, C<package>, C<use> =item Miscellaneous functions -C<defined>, C<dump>, C<eval>, C<formline>, C<local>, C<my>, C<reset>, +C<defined>, C<dump>, C<eval>, C<formline>, C<local>, C<my>, C<our>, C<reset>, C<scalar>, C<undef>, C<wantarray> =item Functions for processes and process groups @@ -200,8 +200,8 @@ C<gmtime>, C<localtime>, C<time>, C<times> =item Functions new in perl5 C<abs>, C<bless>, C<chomp>, C<chr>, C<exists>, C<formline>, C<glob>, -C<import>, C<lc>, C<lcfirst>, C<map>, C<my>, C<no>, C<prototype>, C<qx>, -C<qw>, C<readline>, C<readpipe>, C<ref>, C<sub*>, C<sysopen>, C<tie>, +C<import>, C<lc>, C<lcfirst>, C<map>, C<my>, C<no>, C<our>, C<prototype>, +C<qx>, C<qw>, C<readline>, C<readpipe>, C<ref>, C<sub*>, C<sysopen>, C<tie>, C<tied>, C<uc>, C<ucfirst>, C<untie>, C<use> * - C<sub> was a keyword in perl4, but in perl5 it is an @@ -274,8 +274,8 @@ X<-S>X<-b>X<-c>X<-t>X<-u>X<-g>X<-k>X<-T>X<-B>X<-M>X<-A>X<-C> -O File is owned by real uid. -e File exists. - -z File has zero size. - -s File has nonzero size (returns size). + -z File has zero size (is empty). + -s File has nonzero size (returns size in bytes). -f File is a plain file. -d File is a directory. @@ -300,7 +300,7 @@ X<-S>X<-b>X<-c>X<-t>X<-u>X<-g>X<-k>X<-T>X<-B>X<-M>X<-A>X<-C> Example: while (<>) { - chop; + chomp; next unless -f $_; # ignore specials #... } @@ -488,7 +488,7 @@ files, but it can be disastrous for binary files. Another consequence of using binmode() (on some systems) is that special end-of-file markers will be seen as part of the data stream. For systems from the Microsoft family this means that if your binary -data contains C<\cZ>, the I/O subsystem will ragard it as the end of +data contains C<\cZ>, the I/O subsystem will regard it as the end of the file, unless you use binmode(). binmode() is not only important for readline() and print() operations, @@ -539,9 +539,10 @@ Here $subroutine may be C<(eval)> if the frame is not a subroutine call, but an C<eval>. In such a case additional elements $evaltext and C<$is_require> are set: C<$is_require> is true if the frame is created by a C<require> or C<use> statement, $evaltext contains the text of the -C<eval EXPR> statement. In particular, for a C<eval BLOCK> statement, +C<eval EXPR> statement. In particular, for an C<eval BLOCK> statement, $filename is C<(eval)>, but $evaltext is undefined. (Note also that each C<use> statement creates a C<require> frame inside an C<eval EXPR>) +frame. C<$hasargs> is true if a new instance of C<@_> was set up for the frame. C<$hints> and C<$bitmask> contain pragmatic hints that the caller was compiled with. The C<$hints> and C<$bitmask> values are subject to change between versions of Perl, and are not meant for external use. @@ -611,6 +612,8 @@ If VARIABLE is omitted, it chomps C<$_>. Example: # ... } +If VARIABLE is a hash, it chomps the hash's values, but not its keys. + You can actually chomp anything that's an lvalue, including an assignment: chomp($cwd = `pwd`); @@ -626,21 +629,11 @@ characters removed is returned. =item chop Chops off the last character of a string and returns the character -chopped. It's used primarily to remove the newline from the end of an -input record, but is much more efficient than C<s/\n//> because it neither +chopped. It is much more efficient than C<s/.$//s> because it neither scans nor copies the string. If VARIABLE is omitted, chops C<$_>. -Example: +If VARIABLE is a hash, it chops the hash's values, but not its keys. - while (<>) { - chop; # avoid \n on last field - @array = split(/:/); - #... - } - -You can actually chop anything that's an lvalue, including an assignment: - - chop($cwd = `pwd`); - chop($answer = <STDIN>); +You can actually chop anything that's an lvalue, including an assignment. If you chop a list, each element is chopped. Only the value of the last C<chop> is returned. @@ -791,6 +784,8 @@ to check the condition at the top of the loop. =item cos EXPR +=item cos + Returns the cosine of EXPR (expressed in radians). If EXPR is omitted, takes cosine of C<$_>. @@ -913,7 +908,10 @@ element to return happens to be C<undef>. You may also use C<defined(&func)> to check whether subroutine C<&func> has ever been defined. The return value is unaffected by any forward -declarations of C<&foo>. +declarations of C<&foo>. Note that a subroutine which is not defined +may still be callable: its package may have an C<AUTOLOAD> method that +makes it spring into existence the first time that it is called -- see +L<perlsub>. Use of C<defined> on aggregates (hashes and arrays) is deprecated. It used to report whether memory for that aggregate has ever been @@ -1055,7 +1053,7 @@ If C<$@> is empty then the string C<"Died"> is used. die() can also be called with a reference argument. If this happens to be trapped within an eval(), $@ contains the reference. This behavior permits a more elaborate exception handling implementation using objects that -maintain arbitary state about the nature of the exception. Such a scheme +maintain arbitrary state about the nature of the exception. Such a scheme is sometimes preferable to matching particular string values of $@ using regular expressions. Here's an example: @@ -1183,7 +1181,7 @@ make your program I<appear> to run faster. When called in list context, returns a 2-element list consisting of the key and value for the next element of a hash, so that you can iterate over -it. When called in scalar context, returns the key for only the "next" +it. When called in scalar context, returns only the key for the next element in the hash. Entries are returned in an apparently random order. The actual random @@ -1198,7 +1196,14 @@ again. There is a single iterator for each hash, shared by all C<each>, C<keys>, and C<values> function calls in the program; it can be reset by reading all the elements from the hash, or by evaluating C<keys HASH> or C<values HASH>. If you add or delete elements of a hash while you're -iterating over it, you may get entries skipped or duplicated, so don't. +iterating over it, you may get entries skipped or duplicated, so +don't. Exception: It is always safe to delete the item most recently +returned by C<each()>, which means that the following code will work: + + while (($key, $value) = each %hash) { + print $key, "\n"; + delete $hash{$key}; # This is safe + } The following prints out your environment like the printenv(1) program, only in a different order: @@ -1264,11 +1269,11 @@ there was an error. In the first form, the return value of EXPR is parsed and executed as if it were a little Perl program. The value of the expression (which is itself determined within scalar context) is first parsed, and if there weren't any -errors, executed in the context of the current Perl program, so that any -variable settings or subroutine and format definitions remain afterwards. -Note that the value is parsed every time the eval executes. If EXPR is -omitted, evaluates C<$_>. This form is typically used to delay parsing -and subsequent execution of the text of EXPR until run time. +errors, executed in the lexical context of the current Perl program, so +that any variable settings or subroutine and format definitions remain +afterwards. Note that the value is parsed every time the eval executes. +If EXPR is omitted, evaluates C<$_>. This form is typically used to +delay parsing and subsequent execution of the text of EXPR until run time. In the second form, the code within the BLOCK is parsed only once--at the same time the code surrounding the eval itself was parsed--and executed @@ -1462,7 +1467,10 @@ it exists, but the reverse doesn't necessarily hold true. Given an expression that specifies the name of a subroutine, returns true if the specified subroutine has ever been declared, even if it is undefined. Mentioning a subroutine name for exists or defined -does not count as declaring it. +does not count as declaring it. Note that a subroutine which does not +exist may still be callable: its package may have an C<AUTOLOAD> +method that makes it spring into existence the first time that it is +called -- see L<perlsub>. print "Exists\n" if exists &subroutine; print "Defined\n" if defined &subroutine; @@ -1863,7 +1871,7 @@ The exact meaning of the $gcos field varies but it usually contains the real name of the user (as opposed to the login name) and other information pertaining to the user. Beware, however, that in many system users are able to change this information and therefore it -cannot be trusted and therefore the $gcos is is tainted (see +cannot be trusted and therefore the $gcos is tainted (see L<perlsec>). The $passwd and $shell, user's encrypted password and login shell, are also tainted, because of the same reason. @@ -1896,8 +1904,10 @@ by using the C<Config> module and the values C<d_pwquota>, C<d_pwage>, C<d_pwchange>, C<d_pwcomment>, and C<d_pwexpire>. Shadow password files are only supported if your vendor has implemented them in the intuitive fashion that calling the regular C library routines gets the -shadow versions if you're running under privilege. Those that -incorrectly implement a separate library call are not supported. +shadow versions if you're running under privilege or if there exists +the shadow(3) functions as found in System V ( this includes Solaris +and Linux.) Those systems which implement a proprietary shadow password +facility are unlikely to be supported. The $members value returned by I<getgr*()> is a space separated list of the login names of the members of the group. @@ -1983,7 +1993,7 @@ itself, in the range C<0..11> with 0 indicating January and 11 indicating December. $year is the number of years since 1900. That is, $year is C<123> in year 2023. $wday is the day of the week, with 0 indicating Sunday and 3 indicating Wednesday. $yday is the day of -the year, in the range C<1..365> (or C<1..366> in leap years.) +the year, in the range C<0..364> (or C<0..365> in leap years.) Note that the $year element is I<not> simply the last two digits of the year. If you assume it is, then you create non-Y2K-compliant @@ -2075,9 +2085,9 @@ or equivalently, @foo = grep {!/^#/} @bar; # weed out comments -Note that, because C<$_> is a reference into the list value, it can -be used to modify the elements of the array. While this is useful and -supported, it can cause bizarre results if the LIST is not a named array. +Note that C<$_> is an alias to the list value, so it can be used to +modify the elements of the LIST. While this is useful and supported, +it can cause bizarre results if the elements of LIST are not variables. Similarly, grep returns aliases into the original list, much as a for loop's index variable aliases the list elements. That is, modifying an element of a list returned by grep (for example, in a C<foreach>, C<map> @@ -2105,7 +2115,7 @@ integer overflow trigger a warning. There is no builtin C<import> function. It is just an ordinary method (subroutine) defined (or inherited) by modules that wish to export names to another module. The C<use> function calls the C<import> method -for the package used. See also L</use()>, L<perlmod>, and L<Exporter>. +for the package used. See also L</use>, L<perlmod>, and L<Exporter>. =item index STR,SUBSTR,POSITION @@ -2214,6 +2224,9 @@ or how about sorted by key: print $key, '=', $ENV{$key}, "\n"; } +The returned values are copies of the original keys in the hash, so +modifying them will not affect the original hash. Compare L</values>. + To sort a hash by value, you'll need to use a C<sort> function. Here's a descending numeric sort of a hash by its values: @@ -2321,13 +2334,14 @@ success, false otherwise. =item listen SOCKET,QUEUESIZE Does the same thing that the listen system call does. Returns true if -it succeeded, false otherwise. See the example in L<perlipc/"Sockets: Client/Server Communication">. +it succeeded, false otherwise. See the example in +L<perlipc/"Sockets: Client/Server Communication">. =item local EXPR You really probably want to be using C<my> instead, because C<local> isn't -what most people think of as "local". See L<perlsub/"Private Variables -via my()"> for details. +what most people think of as "local". See +L<perlsub/"Private Variables via my()"> for details. A local modifies the listed variables to be local to the enclosing block, file, or eval. If more than one value is listed, the list must @@ -2351,7 +2365,7 @@ itself, in the range C<0..11> with 0 indicating January and 11 indicating December. $year is the number of years since 1900. That is, $year is C<123> in year 2023. $wday is the day of the week, with 0 indicating Sunday and 3 indicating Wednesday. $yday is the day of -the year, in the range C<1..365> (or C<1..366> in leap years.) $isdst +the year, in the range C<0..364> (or C<0..365> in leap years.) $isdst is true if the specified time occurs during daylight savings time, false otherwise. @@ -2456,13 +2470,36 @@ is just a funny way to write $hash{getkey($_)} = $_; } -Note that, because C<$_> is a reference into the list value, it can -be used to modify the elements of the array. While this is useful and -supported, it can cause bizarre results if the LIST is not a named array. +Note that C<$_> is an alias to the list value, so it can be used to +modify the elements of the LIST. While this is useful and supported, +it can cause bizarre results if the elements of LIST are not variables. Using a regular C<foreach> loop for this purpose would be clearer in most cases. See also L</grep> for an array composed of those items of the original list for which the BLOCK or EXPR evaluates to true. +C<{> starts both hash references and blocks, so C<map { ...> could be either +the start of map BLOCK LIST or map EXPR, LIST. Because perl doesn't look +ahead for the closing C<}> it has to take a guess at which its dealing with +based what it finds just after the C<{>. Usually it gets it right, but if it +doesn't it won't realize something is wrong until it gets to the C<}> and +encounters the missing (or unexpected) comma. The syntax error will be +reported close to the C<}> but you'll need to change something near the C<{> +such as using a unary C<+> to give perl some help: + + %hash = map { "\L$_", 1 } @array # perl guesses EXPR. wrong + %hash = map { +"\L$_", 1 } @array # perl guesses BLOCK. right + %hash = map { ("\L$_", 1) } @array # this also works + %hash = map { lc($_), 1 } @array # as does this. + %hash = map +( lc($_), 1 ), @array # this is EXPR and works! + + %hash = map ( lc($_), 1 ), @array # evaluates to (1, @array) + +or to force an anon hash constructor use C<+{> + + @hashes = map +{ lc($_), 1 }, @array # EXPR, so needs , at end + +and you get list of anonymous hashes each with only 1 entry. + =item mkdir FILENAME,MASK =item mkdir FILENAME @@ -2489,13 +2526,13 @@ first to get the correct constant definitions. If CMD is C<IPC_STAT>, then ARG must be a variable which will hold the returned C<msqid_ds> structure. Returns like C<ioctl>: the undefined value for error, C<"0 but true"> for zero, or the actual return value otherwise. See also -C<IPC::SysV> and C<IPC::Semaphore> documentation. +L<perlipc/"SysV IPC">, C<IPC::SysV>, and C<IPC::Semaphore> documentation. =item msgget KEY,FLAGS Calls the System V IPC function msgget(2). Returns the message queue -id, or the undefined value if there is an error. See also C<IPC::SysV> -and C<IPC::Msg> documentation. +id, or the undefined value if there is an error. See also +L<perlipc/"SysV IPC"> and C<IPC::SysV> and C<IPC::Msg> documentation. =item msgrcv ID,VAR,SIZE,TYPE,FLAGS @@ -2505,7 +2542,8 @@ SIZE. Note that when a message is received, the message type as a native long integer will be the first thing in VAR, followed by the actual message. This packing may be opened with C<unpack("l! a*")>. Taints the variable. Returns true if successful, or false if there is -an error. See also C<IPC::SysV> and C<IPC::SysV::Msg> documentation. +an error. See also L<perlipc/"SysV IPC">, C<IPC::SysV>, and +C<IPC::SysV::Msg> documentation. =item msgsnd ID,MSG,FLAGS @@ -2809,8 +2847,8 @@ otherwise it's necessary to protect any leading and trailing whitespace: $file =~ s#^(\s)#./$1#; open(FOO, "< $file\0"); -(this may not work on some bizzare filesystems). One should -conscientiously choose between the the I<magic> and 3-arguments form +(this may not work on some bizarre filesystems). One should +conscientiously choose between the I<magic> and 3-arguments form of open(): open IN, $ARGV[0]; @@ -2832,7 +2870,7 @@ another way to protect your filenames from interpretation. For example: sysopen(HANDLE, $path, O_RDWR|O_CREAT|O_EXCL) or die "sysopen $path: $!"; $oldfh = select(HANDLE); $| = 1; select($oldfh); - print HANDLE "stuff $$\n"); + print HANDLE "stuff $$\n"; seek(HANDLE, 0, 0); print "File contains: ", <HANDLE>; @@ -2923,7 +2961,7 @@ sequence of characters that give the order and type of values, as follows: a A string with arbitrary binary data, will be null padded. - A An ascii string, will be space padded. + A An ASCII string, will be space padded. Z A null terminated (asciz) string, will be null padded. b A bit string (ascending bit order inside each byte, like vec()). @@ -3143,13 +3181,13 @@ because they obey the native byteorder and endianness. For example a 4-byte integer 0x12345678 (305419896 decimal) be ordered natively (arranged in and handled by the CPU registers) into bytes as - 0x12 0x34 0x56 0x78 # little-endian - 0x78 0x56 0x34 0x12 # big-endian + 0x12 0x34 0x56 0x78 # big-endian + 0x78 0x56 0x34 0x12 # little-endian -Basically, the Intel, Alpha, and VAX CPUs are little-endian, while -everybody else, for example Motorola m68k/88k, PPC, Sparc, HP PA, -Power, and Cray are big-endian. MIPS can be either: Digital used it -in little-endian mode; SGI uses it in big-endian mode. +Basically, the Intel and VAX CPUs are little-endian, while everybody +else, for example Motorola m68k/88k, PPC, Sparc, HP PA, Power, and +Cray are big-endian. Alpha and MIPS can be either: Digital/Compaq +used/uses them in little-endian mode; SGI/Cray uses them in big-endian mode. The names `big-endian' and `little-endian' are comic references to the classic "Gulliver's Travels" (via the paper "On Holy Wars and a @@ -3196,6 +3234,15 @@ equal $foo). =item * +If the pattern begins with a C<U>, the resulting string will be treated +as Unicode-encoded. You can force UTF8 encoding on in a string with an +initial C<U0>, and the bytes that follow will be interpreted as Unicode +characters. If you don't want this to happen, you can begin your pattern +with C<C0> (or anything else) to force Perl not to UTF8 encode your +string, and then follow this with a C<U*> somewhere in your pattern. + +=item * + You must yourself do any alignment or padding by inserting for example enough C<'x'>es while packing. There is no way to pack() and unpack() could know where the bytes are going to or coming from. Therefore @@ -3266,10 +3313,10 @@ Examples: The same template may generally also be used in unpack(). -=item package - =item package NAMESPACE +=item package + Declares the compilation unit as being in the given namespace. The scope of the package declaration is from the declaration itself through the end of the enclosing block, file, or eval (the same as the C<my> operator). @@ -3327,7 +3374,7 @@ array in subroutines, just like C<shift>. =item pos Returns the offset of where the last C<m//g> search left off for the variable -is in question (C<$_> is used when the variable is not specified). May be +in question (C<$_> is used when the variable is not specified). May be modified to change that offset. Such modification will also influence the C<\G> zero-width assertion in regular expressions. See L<perlre> and L<perlop>. @@ -3420,7 +3467,7 @@ Generalized quotes. See L<perlop/"Regexp Quote-Like Operators">. =item quotemeta -Returns the value of EXPR with all non-alphanumeric +Returns the value of EXPR with all non-"word" characters backslashed. (That is, all characters not matching C</[A-Za-z_0-9]/> will be preceded by a backslash in the returned string, regardless of any locale settings.) @@ -3447,12 +3494,13 @@ with the wrong number of RANDBITS.) =item read FILEHANDLE,SCALAR,LENGTH Attempts to read LENGTH bytes of data into variable SCALAR from the -specified FILEHANDLE. Returns the number of bytes actually read, -C<0> at end of file, or undef if there was an error. SCALAR will be grown -or shrunk to the length actually read. An OFFSET may be specified to -place the read data at some other place than the beginning of the -string. This call is actually implemented in terms of stdio's fread(3) -call. To get a true read(2) system call, see C<sysread>. +specified FILEHANDLE. Returns the number of bytes actually read, C<0> +at end of file, or undef if there was an error. SCALAR will be grown +or shrunk to the length actually read. If SCALAR needs growing, the +new bytes will be zero bytes. An OFFSET may be specified to place +the read data into some other place in SCALAR than the beginning. +The call is actually implemented in terms of stdio's fread(3) call. +To get a true read(2) system call, see C<sysread>. =item readdir DIRHANDLE @@ -3927,14 +3975,16 @@ GETALL, then ARG must be a variable which will hold the returned semid_ds structure or semaphore value array. Returns like C<ioctl>: the undefined value for error, "C<0 but true>" for zero, or the actual return value otherwise. The ARG must consist of a vector of native -short integers, which may may be created with C<pack("s!",(0)x$nsem)>. -See also C<IPC::SysV> and C<IPC::Semaphore> documentation. +short integers, which may be created with C<pack("s!",(0)x$nsem)>. +See also L<perlipc/"SysV IPC">, C<IPC::SysV>, C<IPC::Semaphore> +documentation. =item semget KEY,NSEMS,FLAGS Calls the System V IPC function semget. Returns the semaphore id, or -the undefined value if there is an error. See also C<IPC::SysV> and -C<IPC::SysV::Semaphore> documentation. +the undefined value if there is an error. See also +L<perlipc/"SysV IPC">, C<IPC::SysV>, C<IPC::SysV::Semaphore> +documentation. =item semop KEY,OPSTRING @@ -3949,8 +3999,9 @@ following code waits on semaphore $semnum of semaphore id $semid: $semop = pack("sss", $semnum, -1, 0); die "Semaphore trouble: $!\n" unless semop($semid, $semop); -To signal the semaphore, replace C<-1> with C<1>. See also C<IPC::SysV> -and C<IPC::SysV::Semaphore> documentation. +To signal the semaphore, replace C<-1> with C<1>. See also +L<perlipc/"SysV IPC">, C<IPC::SysV>, and C<IPC::SysV::Semaphore> +documentation. =item send SOCKET,MSG,FLAGS,TO @@ -3996,7 +4047,7 @@ C<@ARGV> array at file scopes or within the lexical scopes established by the C<eval ''>, C<BEGIN {}>, C<INIT {}>, C<CHECK {}>, and C<END {}> constructs. -See also C<unshift>, C<push>, and C<pop>. C<Shift()> and C<unshift> do the +See also C<unshift>, C<push>, and C<pop>. C<shift> and C<unshift> do the same thing to the left end of an array that C<pop> and C<push> do to the right end. @@ -4010,13 +4061,13 @@ first to get the correct constant definitions. If CMD is C<IPC_STAT>, then ARG must be a variable which will hold the returned C<shmid_ds> structure. Returns like ioctl: the undefined value for error, "C<0> but true" for zero, or the actual return value otherwise. -See also C<IPC::SysV> documentation. +See also L<perlipc/"SysV IPC"> and C<IPC::SysV> documentation. =item shmget KEY,SIZE,FLAGS Calls the System V IPC function shmget. Returns the shared memory segment id, or the undefined value if there is an error. -See also C<IPC::SysV> documentation. +See also L<perlipc/"SysV IPC"> and C<IPC::SysV> documentation. =item shmread ID,VAR,POS,SIZE @@ -4028,8 +4079,8 @@ detaching from it. When reading, VAR must be a variable that will hold the data read. When writing, if STRING is too long, only SIZE bytes are used; if STRING is too short, nulls are written to fill out SIZE bytes. Return true if successful, or false if there is an error. -shmread() taints the variable. See also C<IPC::SysV> documentation and -the C<IPC::Shareable> module from CPAN. +shmread() taints the variable. See also L<perlipc/"SysV IPC">, +C<IPC::SysV> documentation, and the C<IPC::Shareable> module from CPAN. =item shutdown SOCKET,HOW @@ -4079,7 +4130,7 @@ C<syscall> interface to access setitimer(2) if your system supports it, or else see L</select> above. The Time::HiRes module from CPAN may also help. -See also the POSIX module's C<sigpause> function. +See also the POSIX module's C<pause> function. =item socket SOCKET,DOMAIN,TYPE,PROTOCOL @@ -4231,15 +4282,12 @@ Examples: If you're using strict, you I<must not> declare $a and $b as lexicals. They are package globals. That means -if you're in the C<main> package, it's - - @articles = sort {$main::b <=> $main::a} @files; +if you're in the C<main> package and type -or just - - @articles = sort {$::b <=> $::a} @files; + @articles = sort {$b <=> $a} @files; -but if you're in the C<FooPack> package, it's +then C<$a> and C<$b> are C<$main::a> and C<$main::b> (or C<$::a> and C<$::b>), +but if you're in the C<FooPack> package, it's the same as typing @articles = sort {$FooPack::b <=> $FooPack::a} @files; @@ -4298,11 +4346,9 @@ Example, assuming array lengths are passed before arrays: Splits a string into a list of strings and returns that list. By default, empty leading fields are preserved, and empty trailing ones are deleted. -If not in list context, returns the number of fields found and splits into -the C<@_> array. (In list context, you can force the split into C<@_> by -using C<??> as the pattern delimiters, but it still returns the list -value.) The use of implicit split to C<@_> is deprecated, however, because -it clobbers your subroutine arguments. +In scalar context, returns the number of fields found and splits into +the C<@_> array. Use of split in scalar context is deprecated, however, +because it clobbers your subroutine arguments. If EXPR is omitted, splits the C<$_> string. If PATTERN is also omitted, splits on whitespace (after skipping any leading whitespace). Anything @@ -4324,6 +4370,15 @@ characters at each point it matches that way. For example: produces the output 'h:i:t:h:e:r:e'. +Empty leading (or trailing) fields are produced when there positive width +matches at the beginning (or end) of the string; a zero-width match at the +beginning (or end) of the string does not produce an empty field. For +example: + + print join(':', split(/(?=\w)/, 'hi there!')); + +produces the output 'h:i :t:h:e:r:e!'. + The LIMIT parameter can be used to split a line partially ($login, $passwd, $remainder) = split(/:/, $_, 3); @@ -4361,23 +4416,34 @@ A C<split> on C</\s+/> is like a C<split(' ')> except that any leading whitespace produces a null first field. A C<split> with no arguments really does a C<split(' ', $_)> internally. +A PATTERN of C</^/> is treated as if it were C</^/m>, since it isn't +much use otherwise. + Example: open(PASSWD, '/etc/passwd'); while (<PASSWD>) { - ($login, $passwd, $uid, $gid, + chomp; + ($login, $passwd, $uid, $gid, $gcos, $home, $shell) = split(/:/); #... } -(Note that $shell above will still have a newline on it. See L</chop>, -L</chomp>, and L</join>.) =item sprintf FORMAT, LIST -Returns a string formatted by the usual C<printf> conventions of the -C library function C<sprintf>. See L<sprintf(3)> or L<printf(3)> -on your system for an explanation of the general principles. +Returns a string formatted by the usual C<printf> conventions of the C +library function C<sprintf>. See below for more details +and see L<sprintf(3)> or L<printf(3)> on your system for an explanation of +the general principles. + +For example: + + # Format number with up to 8 leading zeroes + $result = sprintf("%08d", $number); + + # Round number to 3 digits after decimal point + $rounded = sprintf("%.3f", $number); Perl does its own C<sprintf> formatting--it emulates the C function C<sprintf>, but it doesn't use it (except for floating-point @@ -4385,6 +4451,12 @@ numbers, and even then only the standard modifiers are allowed). As a result, any non-standard extensions in your local C<sprintf> are not available from Perl. +Unlike C<printf>, C<sprintf> does not do what you probably mean when you +pass it an array as your first argument. The array is given scalar context, +and instead of using the 0th element of the array as the format, Perl will +use the count of elements in the array as the format, which is almost never +useful. + Perl's C<sprintf> permits the following universally-known conversions: %% a percent sign @@ -4417,6 +4489,12 @@ permits these unnecessary but widely-supported conversions: %O a synonym for %lo %F a synonym for %f +Note that the number of exponent digits in the scientific notation by +C<%e>, C<%E>, C<%g> and C<%G> for numbers with the modulus of the +exponent less than 100 is system-dependent: it may be three or less +(zero-padded as necessary). In other words, 1.23 times ten to the +99th may be either "1.23e99" or "1.23e099". + Perl permits the following universally-known flags between the C<%> and the conversion letter: @@ -4654,7 +4732,7 @@ The commonly available S_IF* constants are and the S_IF* functions are - S_IFMODE($mode) the part of $mode containg the permission bits + S_IFMODE($mode) the part of $mode containing the permission bits and the setuid/setgid/sticky bits S_IFMT($mode) the part of $mode containing the file type @@ -4998,9 +5076,13 @@ case the SCALAR is empty you can use OFFSET but only zero offset. =item tell -Returns the current position for FILEHANDLE. FILEHANDLE may be an -expression whose value gives the name of the actual filehandle. If -FILEHANDLE is omitted, assumes the file last read. +Returns the current position for FILEHANDLE, or -1 on error. FILEHANDLE +may be an expression whose value gives the name of the actual filehandle. +If FILEHANDLE is omitted, assumes the file last read. + +The return value of tell() for the standard streams like the STDIN +depends on the operating system: it may return -1 or something else. +tell() on pipes, fifos, and sockets usually returns -1. There is no C<systell> function. Use C<sysseek(FH, 0, 1)> for that. @@ -5046,6 +5128,7 @@ A class implementing a hash should have the following methods: FIRSTKEY this NEXTKEY this, lastkey DESTROY this + UNTIE this A class implementing an ordinary array should have the following methods: @@ -5062,6 +5145,7 @@ A class implementing an ordinary array should have the following methods: SPLICE this, offset, length, LIST EXTEND this, count DESTROY this + UNTIE this A class implementing a file handle should have the following methods: @@ -5072,8 +5156,15 @@ A class implementing a file handle should have the following methods: WRITE this, scalar, length, offset PRINT this, LIST PRINTF this, format, LIST + BINMODE this + EOF this + FILENO this + SEEK this, position, whence + TELL this + OPEN this, mode, LIST CLOSE this DESTROY this + UNTIE this A class implementing a scalar should have the following methods: @@ -5081,6 +5172,7 @@ A class implementing a scalar should have the following methods: FETCH this, STORE this, value DESTROY this + UNTIE this Not all methods indicated above need be implemented. See L<perltie>, L<Tie::Hash>, L<Tie::Array>, L<Tie::Scalar>, and L<Tie::Handle>. @@ -5349,7 +5441,8 @@ derive their C<import> method via inheritance from the C<Exporter> class that is defined in the C<Exporter> module. See L<Exporter>. If no C<import> method can be found then the call is skipped. -If you don't want your namespace altered, explicitly supply an empty list: +If you do not want to call the package's C<import> method (for instance, +to stop your namespace from being altered), explicitly supply the empty list: use Module (); @@ -5370,8 +5463,9 @@ called). Note that there is no comma after VERSION! Because this is a wide-open interface, pragmas (compiler directives) are also implemented this way. Currently implemented pragmas are: - use integer; + use constant; use diagnostics; + use integer; use sigtrap qw(SEGV BUS); use strict qw(subs vars refs); use subs qw(afunc blurfl); @@ -5391,7 +5485,9 @@ by C<use>, i.e., it calls C<unimport Module LIST> instead of C<import>. If no C<unimport> method can be found the call fails with a fatal error. -See L<perlmod> for a list of standard modules and pragmas. +See L<perlmodlib> for a list of standard modules and pragmas. See L<perlrun> +for the C<-M> and C<-m> command-line options to perl that give C<use> +functionality from the command-line. =item utime LIST @@ -5415,12 +5511,11 @@ subject to change in future versions of perl, but it is guaranteed to be the same order as either the C<keys> or C<each> function would produce on the same (unmodified) hash. -Note that you cannot modify the values of a hash this way, because the -returned list is just a copy. You need to use a hash slice for that, -since it's lvaluable in a way that values() is not. +Note that the values are not copied, which means modifying them will +modify the contents of the hash: - for (values %hash) { s/foo/bar/g } # FAILS! - for (@hash{keys %hash}) { s/foo/bar/g } # ok + for (values %hash) { s/foo/bar/g } # modifies %hash values + for (@hash{keys %hash}) { s/foo/bar/g } # same As a side effect, calling values() resets the HASH's internal iterator. See also C<keys>, C<each>, and C<sort>. @@ -5438,7 +5533,7 @@ If BITS is 8, "elements" coincide with bytes of the input string. If BITS is 16 or more, bytes of the input string are grouped into chunks of size BITS/8, and each group is converted to a number as with -pack()/unpack() with big-endian formats C<n>/C<N> (and analoguously +pack()/unpack() with big-endian formats C<n>/C<N> (and analogously for BITS==64). See L<"pack"> for details. If bits is 4 or less, the string is broken into bytes, then the bits @@ -5453,9 +5548,18 @@ to give the expression the correct precedence as in vec($image, $max_x * $x + $y, 8) = 3; -If the selected element is off the end of the string, the value 0 is -returned. If an element off the end of the string is written to, -Perl will first extend the string with sufficiently many zero bytes. +If the selected element is outside the string, the value 0 is returned. +If an element off the end of the string is written to, Perl will first +extend the string with sufficiently many zero bytes. It is an error +to try to write off the beginning of the string (i.e. negative OFFSET). + +The string should not contain any character with the value > 255 (which +can only happen if you're using UTF8 encoding). If it does, it will be +treated as something which is not UTF8 encoded. When the C<vec> was +assigned to, other parts of your program will also no longer consider the +string to be UTF8 encoded. In other words, if you do have such characters +in your string, vec() will operate on the actual byte string, and not the +conceptual character string. Strings created with C<vec> can also be manipulated with the logical operators C<|>, C<&>, C<^>, and C<~>. These operators will assume a bit diff --git a/contrib/perl5/pod/perlguts.pod b/contrib/perl5/pod/perlguts.pod index 2900b442eb71..9993cc114ea6 100644 --- a/contrib/perl5/pod/perlguts.pod +++ b/contrib/perl5/pod/perlguts.pod @@ -4,10 +4,10 @@ perlguts - Introduction to the Perl API =head1 DESCRIPTION -This document attempts to describe how to use the Perl API, as well as containing -some info on the basic workings of the Perl core. It is far from complete -and probably contains many errors. Please refer any questions or -comments to the author below. +This document attempts to describe how to use the Perl API, as well as +containing some info on the basic workings of the Perl core. It is far +from complete and probably contains many errors. Please refer any +questions or comments to the author below. =head1 Variables @@ -34,8 +34,8 @@ as well.) =head2 Working with SVs An SV can be created and loaded with one command. There are four types of -values that can be loaded: an integer value (IV), a double (NV), a string, -(PV), and another scalar (SV). +values that can be loaded: an integer value (IV), a double (NV), +a string (PV), and another scalar (SV). The six routines are: @@ -76,6 +76,10 @@ L<perlsec>). This pointer may be NULL if that information is not important. Note that this function requires you to specify the length of the format. +STRLEN is an integer type (Size_t, usually defined as size_t in +config.h) guaranteed to be large enough to represent the size of +any string that perl can handle. + The C<sv_set*()> functions are not generic enough to operate on values that have "magic". See L<Magic Virtual Tables> later in this document. @@ -210,6 +214,48 @@ line and all will be well. To free an SV that you've created, call C<SvREFCNT_dec(SV*)>. Normally this call is not necessary (see L<Reference Counts and Mortality>). +=head2 Offsets + +Perl provides the function C<sv_chop> to efficiently remove characters +from the beginning of a string; you give it an SV and a pointer to +somewhere inside the the PV, and it discards everything before the +pointer. The efficiency comes by means of a little hack: instead of +actually removing the characters, C<sv_chop> sets the flag C<OOK> +(offset OK) to signal to other functions that the offset hack is in +effect, and it puts the number of bytes chopped off into the IV field +of the SV. It then moves the PV pointer (called C<SvPVX>) forward that +many bytes, and adjusts C<SvCUR> and C<SvLEN>. + +Hence, at this point, the start of the buffer that we allocated lives +at C<SvPVX(sv) - SvIV(sv)> in memory and the PV pointer is pointing +into the middle of this allocated storage. + +This is best demonstrated by example: + + % ./perl -Ilib -MDevel::Peek -le '$a="12345"; $a=~s/.//; Dump($a)' + SV = PVIV(0x8128450) at 0x81340f0 + REFCNT = 1 + FLAGS = (POK,OOK,pPOK) + IV = 1 (OFFSET) + PV = 0x8135781 ( "1" . ) "2345"\0 + CUR = 4 + LEN = 5 + +Here the number of bytes chopped off (1) is put into IV, and +C<Devel::Peek::Dump> helpfully reminds us that this is an offset. The +portion of the string between the "real" and the "fake" beginnings is +shown in parentheses, and the values of C<SvCUR> and C<SvLEN> reflect +the fake beginning, not the real one. + +Something similar to the offset hack is perfomed on AVs to enable +efficient shifting and splicing off the beginning of the array; while +C<AvARRAY> points to the first element in the array that is visible from +Perl, C<AvALLOC> points to the real start of the C array. These are +usually the same, but a C<shift> operation can be carried out by +increasing C<AvARRAY> by one and decreasing C<AvFILL> and C<AvLEN>. +Again, the location of the real start of the C array only comes into +play when freeing the array. See C<av_shift> in F<av.c>. + =head2 What's Really Stored in an SV? Recall that the usual method of determining the type of scalar you have is @@ -832,6 +878,8 @@ The current kinds of Magic Virtual Tables are: a vtbl_amagicelem %OVERLOAD hash element c (none) Holds overload table (AMT) on stash B vtbl_bm Boyer-Moore (fast string search) + D vtbl_regdata Regex match position data (@+ and @- vars) + d vtbl_regdatum Regex match position data element E vtbl_env %ENV hash e vtbl_envelem %ENV hash element f vtbl_fm Formline ('compiled' format) @@ -1053,7 +1101,7 @@ an C<ENTER>/C<LEAVE> pair. Inside such a I<pseudo-block> the following service is available: -=over +=over 4 =item C<SAVEINT(int i)> @@ -1078,8 +1126,20 @@ and back. =item C<SAVEFREESV(SV *sv)> The refcount of C<sv> would be decremented at the end of -I<pseudo-block>. This is similar to C<sv_2mortal>, which should (?) be -used instead. +I<pseudo-block>. This is similar to C<sv_2mortal> in that it is also a +mechanism for doing a delayed C<SvREFCNT_dec>. However, while C<sv_2mortal> +extends the lifetime of C<sv> until the beginning of the next statement, +C<SAVEFREESV> extends it until the end of the enclosing scope. These +lifetimes can be wildly different. + +Also compare C<SAVEMORTALIZESV>. + +=item C<SAVEMORTALIZESV(SV *sv)> + +Just like C<SAVEFREESV>, but mortalizes C<sv> at the end of the current +scope instead of decrementing its reference count. This usually has the +effect of keeping C<sv> alive until the statement that called the currently +live scope has finished executing. =item C<SAVEFREEOP(OP *op)> @@ -1126,7 +1186,7 @@ provide pointers to the modifiable data explicitly (either C pointers, or Perlish C<GV *>s). Where the above macros take C<int>, a similar function takes C<int *>. -=over +=over 4 =item C<SV* save_scalar(GV *gv)> @@ -1215,6 +1275,7 @@ to use the macros: These macros automatically adjust the stack for you, if needed. Thus, you do not need to call C<EXTEND> to extend the stack. +However, see L</Putting a C value on Perl stack> For more information, consult L<perlxs> and L<perlxstut>. @@ -1344,6 +1405,23 @@ The macro to put this target on stack is C<PUSHTARG>, and it is directly used in some opcodes, as well as indirectly in zillions of others, which use it via C<(X)PUSH[pni]>. +Because the target is reused, you must be careful when pushing multiple +values on the stack. The following code will not do what you think: + + XPUSHi(10); + XPUSHi(20); + +This translates as "set C<TARG> to 10, push a pointer to C<TARG> onto +the stack; set C<TARG> to 20, push a pointer to C<TARG> onto the stack". +At the end of the operation, the stack does not contain the values 10 +and 20, but actually contains two pointers to C<TARG>, which we have set +to 20. If you need to push multiple different values, use C<XPUSHs>, +which bypasses C<TARG>. + +On a related note, if you do use C<(X)PUSH[npi]>, then you're going to +need a C<dTARG> in your variable declarations so that the C<*PUSH*> +macros can make use of the local variable C<TARG>. + =head2 Scratchpads The question remains on when the SVs which are I<target>s for opcodes @@ -1461,15 +1539,40 @@ The execution order is indicated by C<===E<gt>> marks, thus it is C<3 4 5 6> (node C<6> is not included into above listing), i.e., C<gvsv gvsv add whatever>. +Each of these nodes represents an op, a fundamental operation inside the +Perl core. The code which implements each operation can be found in the +F<pp*.c> files; the function which implements the op with type C<gvsv> +is C<pp_gvsv>, and so on. As the tree above shows, different ops have +different numbers of children: C<add> is a binary operator, as one would +expect, and so has two children. To accommodate the various different +numbers of children, there are various types of op data structure, and +they link together in different ways. + +The simplest type of op structure is C<OP>: this has no children. Unary +operators, C<UNOP>s, have one child, and this is pointed to by the +C<op_first> field. Binary operators (C<BINOP>s) have not only an +C<op_first> field but also an C<op_last> field. The most complex type of +op is a C<LISTOP>, which has any number of children. In this case, the +first child is pointed to by C<op_first> and the last child by +C<op_last>. The children in between can be found by iteratively +following the C<op_sibling> pointer from the first child to the last. + +There are also two other op types: a C<PMOP> holds a regular expression, +and has no children, and a C<LOOP> may or may not have children. If the +C<op_children> field is non-zero, it behaves like a C<LISTOP>. To +complicate matters, if a C<UNOP> is actually a C<null> op after +optimization (see L</Compile pass 2: context propagation>) it will still +have children in accordance with its former type. + =head2 Compile pass 1: check routines -The tree is created by the I<pseudo-compiler> while yacc code feeds it -the constructions it recognizes. Since yacc works bottom-up, so does +The tree is created by the compiler while I<yacc> code feeds it +the constructions it recognizes. Since I<yacc> works bottom-up, so does the first pass of perl compilation. What makes this pass interesting for perl developers is that some optimization may be performed on this pass. This is optimization by -so-called I<check routines>. The correspondence between node names +so-called "check routines". The correspondence between node names and corresponding check routines is described in F<opcode.pl> (do not forget to run C<make regen_headers> if you modify this file). @@ -1521,10 +1624,42 @@ additional complications for conditionals). These optimizations are done in the subroutine peep(). Optimizations performed at this stage are subject to the same restrictions as in the pass 2. -=head1 How multiple interpreters and concurrency are supported +=head1 Examining internal data structures with the C<dump> functions + +To aid debugging, the source file F<dump.c> contains a number of +functions which produce formatted output of internal data structures. + +The most commonly used of these functions is C<Perl_sv_dump>; it's used +for dumping SVs, AVs, HVs, and CVs. The C<Devel::Peek> module calls +C<sv_dump> to produce debugging output from Perl-space, so users of that +module should already be familiar with its format. + +C<Perl_op_dump> can be used to dump an C<OP> structure or any of its +derivatives, and produces output similiar to C<perl -Dx>; in fact, +C<Perl_dump_eval> will dump the main root of the code being evaluated, +exactly like C<-Dx>. + +Other useful functions are C<Perl_dump_sub>, which turns a C<GV> into an +op tree, C<Perl_dump_packsubs> which calls C<Perl_dump_sub> on all the +subroutines in a package like so: (Thankfully, these are all xsubs, so +there is no op tree) + + (gdb) print Perl_dump_packsubs(PL_defstash) + + SUB attributes::bootstrap = (xsub 0x811fedc 0) + + SUB UNIVERSAL::can = (xsub 0x811f50c 0) -WARNING: This information is subject to radical changes prior to -the Perl 5.6 release. Use with caution. + SUB UNIVERSAL::isa = (xsub 0x811f304 0) + + SUB UNIVERSAL::VERSION = (xsub 0x811f7ac 0) + + SUB DynaLoader::boot_DynaLoader = (xsub 0x805b188 0) + +and C<Perl_dump_all>, which dumps all the subroutines in the stash and +the op tree of the main root. + +=head1 How multiple interpreters and concurrency are supported =head2 Background and PERL_IMPLICIT_CONTEXT @@ -1540,8 +1675,8 @@ interpreter. Three macros control the major Perl build flavors: MULTIPLICITY, USE_THREADS and PERL_OBJECT. The MULTIPLICITY build has a C structure that packages all the interpreter state, there is a similar thread-specific -data structure under USE_THREADS, and the PERL_OBJECT build has a C++ -class to maintain interpreter state. In all three cases, +data structure under USE_THREADS, and the (now deprecated) PERL_OBJECT +build has a C++ class to maintain interpreter state. In all three cases, PERL_IMPLICIT_CONTEXT is also normally defined, and enables the support for passing in a "hidden" first argument that represents all three data structures. @@ -1557,17 +1692,11 @@ First problem: deciding which functions will be public API functions and which will be private. All functions whose names begin C<S_> are private (think "S" for "secret" or "static"). All other functions begin with "Perl_", but just because a function begins with "Perl_" does not mean it is -part of the API. The easiest way to be B<sure> a function is part of the API -is to find its entry in L<perlapi>. If it exists in L<perlapi>, it's part -of the API. If it doesn't, and you think it should be (i.e., you need it fo -r your extension), send mail via L<perlbug> explaining why you think it -should be. - -(L<perlapi> itself is generated by embed.pl, a Perl script that generates -significant portions of the Perl source code. It has a list of almost -all the functions defined by the Perl interpreter along with their calling -characteristics and some flags. Functions that are part of the public API -are marked with an 'A' in its flags.) +part of the API. (See L</Internal Functions>.) The easiest way to be B<sure> a +function is part of the API is to find its entry in L<perlapi>. +If it exists in L<perlapi>, it's part of the API. If it doesn't, and you +think it should be (i.e., you need it for your extension), send mail via +L<perlbug> explaining why you think it should be. Second problem: there must be a syntax so that the same subroutine declarations and calls can pass a structure as their first argument, @@ -1590,10 +1719,11 @@ C<pTHX_> is one of a number of macros (in perl.h) that hide the details of the interpreter's context. THX stands for "thread", "this", or "thingy", as the case may be. (And no, George Lucas is not involved. :-) The first character could be 'p' for a B<p>rototype, 'a' for B<a>rgument, -or 'd' for B<d>eclaration. +or 'd' for B<d>eclaration, so we have C<pTHX>, C<aTHX> and C<dTHX>, and +their variants. -When Perl is built without PERL_IMPLICIT_CONTEXT, there is no first -argument containing the interpreter's context. The trailing underscore +When Perl is built without options that set PERL_IMPLICIT_CONTEXT, there is no +first argument containing the interpreter's context. The trailing underscore in the pTHX_ macro indicates that the macro expansion needs a comma after the context argument because other arguments follow it. If PERL_IMPLICIT_CONTEXT is not defined, pTHX_ will be ignored, and the @@ -1602,14 +1732,14 @@ macro without the trailing underscore is used when there are no additional explicit arguments. When a core function calls another, it must pass the context. This -is normally hidden via macros. Consider C<sv_setsv>. It expands +is normally hidden via macros. Consider C<sv_setsv>. It expands into something like this: ifdef PERL_IMPLICIT_CONTEXT - define sv_setsv(a,b) Perl_sv_setsv(aTHX_ a, b) + define sv_setsv(a,b) Perl_sv_setsv(aTHX_ a, b) /* can't do this for vararg functions, see below */ else - define sv_setsv Perl_sv_setsv + define sv_setsv Perl_sv_setsv endif This works well, and means that XS authors can gleefully write: @@ -1629,8 +1759,8 @@ Under PERL_OBJECT in the core, that will translate to either: # see objXSUB.h Under PERL_OBJECT in extensions (aka PERL_CAPI), or under -MULTIPLICITY/USE_THREADS w/ PERL_IMPLICIT_CONTEXT in both core -and extensions, it will be: +MULTIPLICITY/USE_THREADS with PERL_IMPLICIT_CONTEXT in both core +and extensions, it will become: Perl_sv_setsv(aTHX_ foo, bar); # the canonical Perl "API" # for all build flavors @@ -1652,6 +1782,14 @@ You can ignore [pad]THX[xo] when browsing the Perl headers/sources. Those are strictly for use within the core. Extensions and embedders need only be aware of [pad]THX. +=head2 So what happened to dTHR? + +C<dTHR> was introduced in perl 5.005 to support the older thread model. +The older thread model now uses the C<THX> mechanism to pass context +pointers around, so C<dTHR> is not useful any more. Perl 5.6.0 and +later still have it for backward source compatibility, but it is defined +to be a no-op. + =head2 How do I use all this in extensions? When Perl is built with PERL_IMPLICIT_CONTEXT, extensions that call @@ -1668,7 +1806,7 @@ Thus, something like: sv_setsv(asv, bsv); -in your extesion will translate to this when PERL_IMPLICIT_CONTEXT is +in your extension will translate to this when PERL_IMPLICIT_CONTEXT is in effect: Perl_sv_setsv(Perl_get_context(), asv, bsv); @@ -1684,31 +1822,31 @@ work. The second, more efficient way is to use the following template for your Foo.xs: - #define PERL_NO_GET_CONTEXT /* we want efficiency */ - #include "EXTERN.h" - #include "perl.h" - #include "XSUB.h" + #define PERL_NO_GET_CONTEXT /* we want efficiency */ + #include "EXTERN.h" + #include "perl.h" + #include "XSUB.h" static my_private_function(int arg1, int arg2); - static SV * - my_private_function(int arg1, int arg2) - { - dTHX; /* fetch context */ - ... call many Perl API functions ... - } + static SV * + my_private_function(int arg1, int arg2) + { + dTHX; /* fetch context */ + ... call many Perl API functions ... + } [... etc ...] - MODULE = Foo PACKAGE = Foo + MODULE = Foo PACKAGE = Foo - /* typical XSUB */ + /* typical XSUB */ - void - my_xsub(arg) - int arg - CODE: - my_private_function(arg, 10); + void + my_xsub(arg) + int arg + CODE: + my_private_function(arg, 10); Note that the only two changes from the normal way of writing an extension is the addition of a C<#define PERL_NO_GET_CONTEXT> before @@ -1723,32 +1861,32 @@ The third, even more efficient way is to ape how it is done within the Perl guts: - #define PERL_NO_GET_CONTEXT /* we want efficiency */ - #include "EXTERN.h" - #include "perl.h" - #include "XSUB.h" + #define PERL_NO_GET_CONTEXT /* we want efficiency */ + #include "EXTERN.h" + #include "perl.h" + #include "XSUB.h" /* pTHX_ only needed for functions that call Perl API */ static my_private_function(pTHX_ int arg1, int arg2); - static SV * - my_private_function(pTHX_ int arg1, int arg2) - { - /* dTHX; not needed here, because THX is an argument */ - ... call Perl API functions ... - } + static SV * + my_private_function(pTHX_ int arg1, int arg2) + { + /* dTHX; not needed here, because THX is an argument */ + ... call Perl API functions ... + } [... etc ...] - MODULE = Foo PACKAGE = Foo + MODULE = Foo PACKAGE = Foo - /* typical XSUB */ + /* typical XSUB */ - void - my_xsub(arg) - int arg - CODE: - my_private_function(aTHX_ arg, 10); + void + my_xsub(arg) + int arg + CODE: + my_private_function(aTHX_ arg, 10); This implementation never has to fetch the context using a function call, since it is always passed as an extra argument. Depending on @@ -1759,15 +1897,34 @@ Never add a comma after C<pTHX> yourself--always use the form of the macro with the underscore for functions that take explicit arguments, or the form without the argument for functions with no explicit arguments. +=head2 Should I do anything special if I call perl from multiple threads? + +If you create interpreters in one thread and then proceed to call them in +another, you need to make sure perl's own Thread Local Storage (TLS) slot is +initialized correctly in each of those threads. + +The C<perl_alloc> and C<perl_clone> API functions will automatically set +the TLS slot to the interpreter they created, so that there is no need to do +anything special if the interpreter is always accessed in the same thread that +created it, and that thread did not create or call any other interpreters +afterwards. If that is not the case, you have to set the TLS slot of the +thread before calling any functions in the Perl API on that particular +interpreter. This is done by calling the C<PERL_SET_CONTEXT> macro in that +thread as the first thing you do: + + /* do this before doing anything else with some_perl */ + PERL_SET_CONTEXT(some_perl); + + ... other Perl API calls on some_perl go here ... + =head2 Future Plans and PERL_IMPLICIT_SYS Just as PERL_IMPLICIT_CONTEXT provides a way to bundle up everything that the interpreter knows about itself and pass it around, so too are there plans to allow the interpreter to bundle up everything it knows about the environment it's running on. This is enabled with the -PERL_IMPLICIT_SYS macro. Currently it only works with PERL_OBJECT, -but is mostly there for MULTIPLICITY and USE_THREADS (see inside -iperlsys.h). +PERL_IMPLICIT_SYS macro. Currently it only works with PERL_OBJECT +and USE_THREADS on Windows (see inside iperlsys.h). This allows the ability to provide an extra pointer (called the "host" environment) for all the system calls. This makes it possible for @@ -1782,6 +1939,364 @@ The Perl engine/interpreter and the host are orthogonal entities. There could be one or more interpreters in a process, and one or more "hosts", with free association between them. +=head1 Internal Functions + +All of Perl's internal functions which will be exposed to the outside +world are be prefixed by C<Perl_> so that they will not conflict with XS +functions or functions used in a program in which Perl is embedded. +Similarly, all global variables begin with C<PL_>. (By convention, +static functions start with C<S_>) + +Inside the Perl core, you can get at the functions either with or +without the C<Perl_> prefix, thanks to a bunch of defines that live in +F<embed.h>. This header file is generated automatically from +F<embed.pl>. F<embed.pl> also creates the prototyping header files for +the internal functions, generates the documentation and a lot of other +bits and pieces. It's important that when you add a new function to the +core or change an existing one, you change the data in the table at the +end of F<embed.pl> as well. Here's a sample entry from that table: + + Apd |SV** |av_fetch |AV* ar|I32 key|I32 lval + +The second column is the return type, the third column the name. Columns +after that are the arguments. The first column is a set of flags: + +=over 3 + +=item A + +This function is a part of the public API. + +=item p + +This function has a C<Perl_> prefix; ie, it is defined as C<Perl_av_fetch> + +=item d + +This function has documentation using the C<apidoc> feature which we'll +look at in a second. + +=back + +Other available flags are: + +=over 3 + +=item s + +This is a static function and is defined as C<S_whatever>, and usually +called within the sources as C<whatever(...)>. + +=item n + +This does not use C<aTHX_> and C<pTHX> to pass interpreter context. (See +L<perlguts/Background and PERL_IMPLICIT_CONTEXT>.) + +=item r + +This function never returns; C<croak>, C<exit> and friends. + +=item f + +This function takes a variable number of arguments, C<printf> style. +The argument list should end with C<...>, like this: + + Afprd |void |croak |const char* pat|... + +=item M + +This function is part of the experimental development API, and may change +or disappear without notice. + +=item o + +This function should not have a compatibility macro to define, say, +C<Perl_parse> to C<parse>. It must be called as C<Perl_parse>. + +=item j + +This function is not a member of C<CPerlObj>. If you don't know +what this means, don't use it. + +=item x + +This function isn't exported out of the Perl core. + +=back + +If you edit F<embed.pl>, you will need to run C<make regen_headers> to +force a rebuild of F<embed.h> and other auto-generated files. + +=head2 Formatted Printing of IVs, UVs, and NVs + +If you are printing IVs, UVs, or NVS instead of the stdio(3) style +formatting codes like C<%d>, C<%ld>, C<%f>, you should use the +following macros for portability + + IVdf IV in decimal + UVuf UV in decimal + UVof UV in octal + UVxf UV in hexadecimal + NVef NV %e-like + NVff NV %f-like + NVgf NV %g-like + +These will take care of 64-bit integers and long doubles. +For example: + + printf("IV is %"IVdf"\n", iv); + +The IVdf will expand to whatever is the correct format for the IVs. + +If you are printing addresses of pointers, use UVxf combined +with PTR2UV(), do not use %lx or %p. + +=head2 Pointer-To-Integer and Integer-To-Pointer + +Because pointer size does not necessarily equal integer size, +use the follow macros to do it right. + + PTR2UV(pointer) + PTR2IV(pointer) + PTR2NV(pointer) + INT2PTR(pointertotype, integer) + +For example: + + IV iv = ...; + SV *sv = INT2PTR(SV*, iv); + +and + + AV *av = ...; + UV uv = PTR2UV(av); + +=head2 Source Documentation + +There's an effort going on to document the internal functions and +automatically produce reference manuals from them - L<perlapi> is one +such manual which details all the functions which are available to XS +writers. L<perlintern> is the autogenerated manual for the functions +which are not part of the API and are supposedly for internal use only. + +Source documentation is created by putting POD comments into the C +source, like this: + + /* + =for apidoc sv_setiv + + Copies an integer into the given SV. Does not handle 'set' magic. See + C<sv_setiv_mg>. + + =cut + */ + +Please try and supply some documentation if you add functions to the +Perl core. + +=head1 Unicode Support + +Perl 5.6.0 introduced Unicode support. It's important for porters and XS +writers to understand this support and make sure that the code they +write does not corrupt Unicode data. + +=head2 What B<is> Unicode, anyway? + +In the olden, less enlightened times, we all used to use ASCII. Most of +us did, anyway. The big problem with ASCII is that it's American. Well, +no, that's not actually the problem; the problem is that it's not +particularly useful for people who don't use the Roman alphabet. What +used to happen was that particular languages would stick their own +alphabet in the upper range of the sequence, between 128 and 255. Of +course, we then ended up with plenty of variants that weren't quite +ASCII, and the whole point of it being a standard was lost. + +Worse still, if you've got a language like Chinese or +Japanese that has hundreds or thousands of characters, then you really +can't fit them into a mere 256, so they had to forget about ASCII +altogether, and build their own systems using pairs of numbers to refer +to one character. + +To fix this, some people formed Unicode, Inc. and +produced a new character set containing all the characters you can +possibly think of and more. There are several ways of representing these +characters, and the one Perl uses is called UTF8. UTF8 uses +a variable number of bytes to represent a character, instead of just +one. You can learn more about Unicode at http://www.unicode.org/ + +=head2 How can I recognise a UTF8 string? + +You can't. This is because UTF8 data is stored in bytes just like +non-UTF8 data. The Unicode character 200, (C<0xC8> for you hex types) +capital E with a grave accent, is represented by the two bytes +C<v196.172>. Unfortunately, the non-Unicode string C<chr(196).chr(172)> +has that byte sequence as well. So you can't tell just by looking - this +is what makes Unicode input an interesting problem. + +The API function C<is_utf8_string> can help; it'll tell you if a string +contains only valid UTF8 characters. However, it can't do the work for +you. On a character-by-character basis, C<is_utf8_char> will tell you +whether the current character in a string is valid UTF8. + +=head2 How does UTF8 represent Unicode characters? + +As mentioned above, UTF8 uses a variable number of bytes to store a +character. Characters with values 1...128 are stored in one byte, just +like good ol' ASCII. Character 129 is stored as C<v194.129>; this +continues up to character 191, which is C<v194.191>. Now we've run out of +bits (191 is binary C<10111111>) so we move on; 192 is C<v195.128>. And +so it goes on, moving to three bytes at character 2048. + +Assuming you know you're dealing with a UTF8 string, you can find out +how long the first character in it is with the C<UTF8SKIP> macro: + + char *utf = "\305\233\340\240\201"; + I32 len; + + len = UTF8SKIP(utf); /* len is 2 here */ + utf += len; + len = UTF8SKIP(utf); /* len is 3 here */ + +Another way to skip over characters in a UTF8 string is to use +C<utf8_hop>, which takes a string and a number of characters to skip +over. You're on your own about bounds checking, though, so don't use it +lightly. + +All bytes in a multi-byte UTF8 character will have the high bit set, so +you can test if you need to do something special with this character +like this: + + UV uv; + + if (utf & 0x80) + /* Must treat this as UTF8 */ + uv = utf8_to_uv(utf); + else + /* OK to treat this character as a byte */ + uv = *utf; + +You can also see in that example that we use C<utf8_to_uv> to get the +value of the character; the inverse function C<uv_to_utf8> is available +for putting a UV into UTF8: + + if (uv > 0x80) + /* Must treat this as UTF8 */ + utf8 = uv_to_utf8(utf8, uv); + else + /* OK to treat this character as a byte */ + *utf8++ = uv; + +You B<must> convert characters to UVs using the above functions if +you're ever in a situation where you have to match UTF8 and non-UTF8 +characters. You may not skip over UTF8 characters in this case. If you +do this, you'll lose the ability to match hi-bit non-UTF8 characters; +for instance, if your UTF8 string contains C<v196.172>, and you skip +that character, you can never match a C<chr(200)> in a non-UTF8 string. +So don't do that! + +=head2 How does Perl store UTF8 strings? + +Currently, Perl deals with Unicode strings and non-Unicode strings +slightly differently. If a string has been identified as being UTF-8 +encoded, Perl will set a flag in the SV, C<SVf_UTF8>. You can check and +manipulate this flag with the following macros: + + SvUTF8(sv) + SvUTF8_on(sv) + SvUTF8_off(sv) + +This flag has an important effect on Perl's treatment of the string: if +Unicode data is not properly distinguished, regular expressions, +C<length>, C<substr> and other string handling operations will have +undesirable results. + +The problem comes when you have, for instance, a string that isn't +flagged is UTF8, and contains a byte sequence that could be UTF8 - +especially when combining non-UTF8 and UTF8 strings. + +Never forget that the C<SVf_UTF8> flag is separate to the PV value; you +need be sure you don't accidentally knock it off while you're +manipulating SVs. More specifically, you cannot expect to do this: + + SV *sv; + SV *nsv; + STRLEN len; + char *p; + + p = SvPV(sv, len); + frobnicate(p); + nsv = newSVpvn(p, len); + +The C<char*> string does not tell you the whole story, and you can't +copy or reconstruct an SV just by copying the string value. Check if the +old SV has the UTF8 flag set, and act accordingly: + + p = SvPV(sv, len); + frobnicate(p); + nsv = newSVpvn(p, len); + if (SvUTF8(sv)) + SvUTF8_on(nsv); + +In fact, your C<frobnicate> function should be made aware of whether or +not it's dealing with UTF8 data, so that it can handle the string +appropriately. + +=head2 How do I convert a string to UTF8? + +If you're mixing UTF8 and non-UTF8 strings, you might find it necessary +to upgrade one of the strings to UTF8. If you've got an SV, the easiest +way to do this is: + + sv_utf8_upgrade(sv); + +However, you must not do this, for example: + + if (!SvUTF8(left)) + sv_utf8_upgrade(left); + +If you do this in a binary operator, you will actually change one of the +strings that came into the operator, and, while it shouldn't be noticeable +by the end user, it can cause problems. + +Instead, C<bytes_to_utf8> will give you a UTF8-encoded B<copy> of its +string argument. This is useful for having the data available for +comparisons and so on, without harming the original SV. There's also +C<utf8_to_bytes> to go the other way, but naturally, this will fail if +the string contains any characters above 255 that can't be represented +in a single byte. + +=head2 Is there anything else I need to know? + +Not really. Just remember these things: + +=over 3 + +=item * + +There's no way to tell if a string is UTF8 or not. You can tell if an SV +is UTF8 by looking at is C<SvUTF8> flag. Don't forget to set the flag if +something should be UTF8. Treat the flag as part of the PV, even though +it's not - if you pass on the PV to somewhere, pass on the flag too. + +=item * + +If a string is UTF8, B<always> use C<utf8_to_uv> to get at the value, +unless C<!(*s & 0x80)> in which case you can use C<*s>. + +=item * + +When writing to a UTF8 string, B<always> use C<uv_to_utf8>, unless +C<uv < 0x80> in which case you can use C<*s = uv>. + +=item * + +Mixing UTF8 and non-UTF8 strings is tricky. Use C<bytes_to_utf8> to get +a new string which is UTF8 encoded. There are tricks you can use to +delay deciding whether you need to use a UTF8 string until you get to a +high character - C<HALF_UPGRADE> is one of those. + +=back + =head1 AUTHORS Until May 1997, this document was maintained by Jeff Okamoto diff --git a/contrib/perl5/pod/perlhack.pod b/contrib/perl5/pod/perlhack.pod index c64087026412..d524fe55f5fd 100644 --- a/contrib/perl5/pod/perlhack.pod +++ b/contrib/perl5/pod/perlhack.pod @@ -194,6 +194,8 @@ around. It refers to the standard distribution. ``Hacking on the core'' means you're changing the C source code to the Perl interpreter. ``A core module'' is one that ships with Perl. +=head2 Keeping in sync + The source code to the Perl interpreter, in its different versions, is kept in a repository managed by a revision control system (which is currently the Perforce program, see http://perforce.com/). The @@ -206,20 +208,256 @@ public release are available at this location: ftp://ftp.linux.activestate.com/pub/staff/gsar/APC/ -Selective parts are also visible via the rsync protocol. To get all -the individual changes to the mainline since the last development -release, use the following command: - - rsync -avuz rsync://ftp.linux.activestate.com/perl-diffs perl-diffs - -Use this to get the latest source tree in full: - - rsync -avuz rsync://ftp.linux.activestate.com/perl-current perl-current +If you are a member of the perl5-porters mailing list, it is a good +thing to keep in touch with the most recent changes. If not only to +verify if what you would have posted as a bug report isn't already +solved in the most recent available perl development branch, also +known as perl-current, bleading edge perl, bleedperl or bleadperl. Needless to say, the source code in perl-current is usually in a perpetual state of evolution. You should expect it to be very buggy. Do B<not> use it for any purpose other than testing and development. +Keeping in sync with the most recent branch can be done in several ways, +but the most convenient and reliable way is using B<rsync>, available at +ftp://rsync.samba.org/pub/rsync/ . (You can also get the most recent +branch by FTP.) + +If you choose to keep in sync using rsync, there are two approaches +to doing so: + +=over 4 + +=item rsync'ing the source tree + +Presuming you are in the directory where your perl source resides +and you have rsync installed and available, you can `upgrade' to +the bleadperl using: + + # rsync -avz rsync://ftp.linux.activestate.com/perl-current/ . + +This takes care of updating every single item in the source tree to +the latest applied patch level, creating files that are new (to your +distribution) and setting date/time stamps of existing files to +reflect the bleadperl status. + +You can than check what patch was the latest that was applied by +looking in the file B<.patch>, which will show the number of the +latest patch. + +If you have more than one machine to keep in sync, and not all of +them have access to the WAN (so you are not able to rsync all the +source trees to the real source), there are some ways to get around +this problem. + +=over 4 + +=item Using rsync over the LAN + +Set up a local rsync server which makes the rsynced source tree +available to the LAN and sync the other machines against this +directory. + +From http://rsync.samba.org/README.html: + + "Rsync uses rsh or ssh for communication. It does not need to be + setuid and requires no special privileges for installation. It + does not require a inetd entry or a deamon. You must, however, + have a working rsh or ssh system. Using ssh is recommended for + its security features." + +=item Using pushing over the NFS + +Having the other systems mounted over the NFS, you can take an +active pushing approach by checking the just updated tree against +the other not-yet synced trees. An example would be + + #!/usr/bin/perl -w + + use strict; + use File::Copy; + + my %MF = map { + m/(\S+)/; + $1 => [ (stat $1)[2, 7, 9] ]; # mode, size, mtime + } `cat MANIFEST`; + + my %remote = map { $_ => "/$_/pro/3gl/CPAN/perl-5.7.1" } qw(host1 host2); + + foreach my $host (keys %remote) { + unless (-d $remote{$host}) { + print STDERR "Cannot Xsync for host $host\n"; + next; + } + foreach my $file (keys %MF) { + my $rfile = "$remote{$host}/$file"; + my ($mode, $size, $mtime) = (stat $rfile)[2, 7, 9]; + defined $size or ($mode, $size, $mtime) = (0, 0, 0); + $size == $MF{$file}[1] && $mtime == $MF{$file}[2] and next; + printf "%4s %-34s %8d %9d %8d %9d\n", + $host, $file, $MF{$file}[1], $MF{$file}[2], $size, $mtime; + unlink $rfile; + copy ($file, $rfile); + utime time, $MF{$file}[2], $rfile; + chmod $MF{$file}[0], $rfile; + } + } + +though this is not perfect. It could be improved with checking +file checksums before updating. Not all NFS systems support +reliable utime support (when used over the NFS). + +=back + +=item rsync'ing the patches + +The source tree is maintained by the pumpking who applies patches to +the files in the tree. These patches are either created by the +pumpking himself using C<diff -c> after updating the file manually or +by applying patches sent in by posters on the perl5-porters list. +These patches are also saved and rsync'able, so you can apply them +yourself to the source files. + +Presuming you are in a directory where your patches reside, you can +get them in sync with + + # rsync -avz rsync://ftp.linux.activestate.com/perl-current-diffs/ . + +This makes sure the latest available patch is downloaded to your +patch directory. + +It's then up to you to apply these patches, using something like + + # last=`ls -rt1 *.gz | tail -1` + # rsync -avz rsync://ftp.linux.activestate.com/perl-current-diffs/ . + # find . -name '*.gz' -newer $last -exec gzcat {} \; >blead.patch + # cd ../perl-current + # patch -p1 -N <../perl-current-diffs/blead.patch + +or, since this is only a hint towards how it works, use CPAN-patchaperl +from Andreas König to have better control over the patching process. + +=back + +=head2 Why rsync the source tree + +=over 4 + +=item It's easier + +Since you don't have to apply the patches yourself, you are sure all +files in the source tree are in the right state. + +=item It's more recent + +According to Gurusamy Sarathy: + + "... The rsync mirror is automatic and syncs with the repository + every five minutes. + + "Updating the patch area still requires manual intervention + (with all the goofiness that implies, which you've noted) and + is typically on a daily cycle. Making this process automatic + is on my tuit list, but don't ask me when." + +=item It's more reliable + +Well, since the patches are updated by hand, I don't have to say any +more ... (see Sarathy's remark). + +=back + +=head2 Why rsync the patches + +=over 4 + +=item It's easier + +If you have more than one machine that you want to keep in track with +bleadperl, it's easier to rsync the patches only once and then apply +them to all the source trees on the different machines. + +In case you try to keep in pace on 5 different machines, for which +only one of them has access to the WAN, rsync'ing all the source +trees should than be done 5 times over the NFS. Having +rsync'ed the patches only once, I can apply them to all the source +trees automatically. Need you say more ;-) + +=item It's a good reference + +If you do not only like to have the most recent development branch, +but also like to B<fix> bugs, or extend features, you want to dive +into the sources. If you are a seasoned perl core diver, you don't +need no manuals, tips, roadmaps, perlguts.pod or other aids to find +your way around. But if you are a starter, the patches may help you +in finding where you should start and how to change the bits that +bug you. + +The file B<Changes> is updated on occasions the pumpking sees as his +own little sync points. On those occasions, he releases a tar-ball of +the current source tree (i.e. perl@7582.tar.gz), which will be an +excellent point to start with when choosing to use the 'rsync the +patches' scheme. Starting with perl@7582, which means a set of source +files on which the latest applied patch is number 7582, you apply all +succeeding patches available from then on (7583, 7584, ...). + +You can use the patches later as a kind of search archive. + +=over 4 + +=item Finding a start point + +If you want to fix/change the behaviour of function/feature Foo, just +scan the patches for patches that mention Foo either in the subject, +the comments, or the body of the fix. A good chance the patch shows +you the files that are affected by that patch which are very likely +to be the starting point of your journey into the guts of perl. + +=item Finding how to fix a bug + +If you've found I<where> the function/feature Foo misbehaves, but you +don't know how to fix it (but you do know the change you want to +make), you can, again, peruse the patches for similar changes and +look how others apply the fix. + +=item Finding the source of misbehaviour + +When you keep in sync with bleadperl, the pumpking would love to +I<see> that the community efforts realy work. So after each of his +sync points, you are to 'make test' to check if everything is still +in working order. If it is, you do 'make ok', which will send an OK +report to perlbug@perl.org. (If you do not have access to a mailer +from the system you just finished successfully 'make test', you can +do 'make okfile', which creates the file C<perl.ok>, which you can +than take to your favourite mailer and mail yourself). + +But of course, as always, things will not allways lead to a success +path, and one or more test do not pass the 'make test'. Before +sending in a bug report (using 'make nok' or 'make nokfile'), check +the mailing list if someone else has reported the bug already and if +so, confirm it by replying to that message. If not, you might want to +trace the source of that misbehaviour B<before> sending in the bug, +which will help all the other porters in finding the solution. + +Here the saved patches come in very handy. You can check the list of +patches to see which patch changed what file and what change caused +the misbehaviour. If you note that in the bug report, it saves the +one trying to solve it, looking for that point. + +=back + +If searching the patches is too bothersome, you might consider using +perl's bugtron to find more information about discussions and +ramblings on posted bugs. + +=back + +If you want to get the best of both worlds, rsync both the source +tree for convenience, reliability and ease and rsync the patches +for reference. + +=head2 Submitting patches + Always submit patches to I<perl5-porters@perl.org>. This lets other porters review your patch, which catches a surprising number of errors in patches. Either use the diff program (available in source code @@ -237,7 +475,7 @@ Your patch should update the documentation and test suite. To report a bug in Perl, use the program I<perlbug> which comes with Perl (if you can't get Perl to work, send mail to the address -I<perlbug@perl.com> or I<perlbug@perl.org>). Reporting bugs through +I<perlbug@perl.org> or I<perlbug@perl.com>). Reporting bugs through I<perlbug> feeds into the automated bug-tracking system, access to which is provided through the web at I<http://bugs.perl.org/>. It often pays to check the archives of the perl5-porters mailing list to @@ -251,31 +489,6 @@ volunteers who test CPAN modules on a variety of platforms. Perl Labs platforms and gives feedback to the CPAN testers mailing list. Both efforts welcome volunteers. -To become an active and patching Perl porter, you'll need to learn how -Perl works on the inside. Chip Salzenberg, a pumpking, has written -articles on Perl internals for The Perl Journal -(I<http://www.tpj.com/>) which explain how various parts of the Perl -interpreter work. The C<perlguts> manpage explains the internal data -structures. And, of course, the C source code (sometimes sparsely -commented, sometimes commented well) is a great place to start (begin -with C<perl.c> and see where it goes from there). A lot of the style -of the Perl source is explained in the I<Porting/pumpkin.pod> file in -the source distribution. - -It is essential that you be comfortable using a good debugger -(e.g. gdb, dbx) before you can patch perl. Stepping through perl -as it executes a script is perhaps the best (if sometimes tedious) -way to gain a precise understanding of the overall architecture of -the language. - -If you build a version of the Perl interpreter with C<-DDEBUGGING>, -Perl's B<-D> command line flag will cause copious debugging information -to be emitted (see the C<perlrun> manpage). If you build a version of -Perl with compiler debugging information (e.g. with the C compiler's -C<-g> option instead of C<-O>) then you can step through the execution -of the interpreter with your favourite C symbolic debugger, setting -breakpoints on particular functions. - It's a good idea to read and lurk for a while before chipping in. That way you'll get to see the dynamic of the conversations, learn the personalities of the players, and hopefully be better prepared to make @@ -285,6 +498,1223 @@ If after all this you still think you want to join the perl5-porters mailing list, send mail to I<perl5-porters-subscribe@perl.org>. To unsubscribe, send mail to I<perl5-porters-unsubscribe@perl.org>. +To hack on the Perl guts, you'll need to read the following things: + +=over 3 + +=item L<perlguts> + +This is of paramount importance, since it's the documentation of what +goes where in the Perl source. Read it over a couple of times and it +might start to make sense - don't worry if it doesn't yet, because the +best way to study it is to read it in conjunction with poking at Perl +source, and we'll do that later on. + +You might also want to look at Gisle Aas's illustrated perlguts - +there's no guarantee that this will be absolutely up-to-date with the +latest documentation in the Perl core, but the fundamentals will be +right. (http://gisle.aas.no/perl/illguts/) + +=item L<perlxstut> and L<perlxs> + +A working knowledge of XSUB programming is incredibly useful for core +hacking; XSUBs use techniques drawn from the PP code, the portion of the +guts that actually executes a Perl program. It's a lot gentler to learn +those techniques from simple examples and explanation than from the core +itself. + +=item L<perlapi> + +The documentation for the Perl API explains what some of the internal +functions do, as well as the many macros used in the source. + +=item F<Porting/pumpkin.pod> + +This is a collection of words of wisdom for a Perl porter; some of it is +only useful to the pumpkin holder, but most of it applies to anyone +wanting to go about Perl development. + +=item The perl5-porters FAQ + +This is posted to perl5-porters at the beginning on every month, and +should be available from http://perlhacker.org/p5p-faq; alternatively, +you can get the FAQ emailed to you by sending mail to +C<perl5-porters-faq@perl.org>. It contains hints on reading +perl5-porters, information on how perl5-porters works and how Perl +development in general works. + +=back + +=head2 Finding Your Way Around + +Perl maintenance can be split into a number of areas, and certain people +(pumpkins) will have responsibility for each area. These areas sometimes +correspond to files or directories in the source kit. Among the areas are: + +=over 3 + +=item Core modules + +Modules shipped as part of the Perl core live in the F<lib/> and F<ext/> +subdirectories: F<lib/> is for the pure-Perl modules, and F<ext/> +contains the core XS modules. + +=item Documentation + +Documentation maintenance includes looking after everything in the +F<pod/> directory, (as well as contributing new documentation) and +the documentation to the modules in core. + +=item Configure + +The configure process is the way we make Perl portable across the +myriad of operating systems it supports. Responsibility for the +configure, build and installation process, as well as the overall +portability of the core code rests with the configure pumpkin - others +help out with individual operating systems. + +The files involved are the operating system directories, (F<win32/>, +F<os2/>, F<vms/> and so on) the shell scripts which generate F<config.h> +and F<Makefile>, as well as the metaconfig files which generate +F<Configure>. (metaconfig isn't included in the core distribution.) + +=item Interpreter + +And of course, there's the core of the Perl interpreter itself. Let's +have a look at that in a little more detail. + +=back + +Before we leave looking at the layout, though, don't forget that +F<MANIFEST> contains not only the file names in the Perl distribution, +but short descriptions of what's in them, too. For an overview of the +important files, try this: + + perl -lne 'print if /^[^\/]+\.[ch]\s+/' MANIFEST + +=head2 Elements of the interpreter + +The work of the interpreter has two main stages: compiling the code +into the internal representation, or bytecode, and then executing it. +L<perlguts/Compiled code> explains exactly how the compilation stage +happens. + +Here is a short breakdown of perl's operation: + +=over 3 + +=item Startup + +The action begins in F<perlmain.c>. (or F<miniperlmain.c> for miniperl) +This is very high-level code, enough to fit on a single screen, and it +resembles the code found in L<perlembed>; most of the real action takes +place in F<perl.c> + +First, F<perlmain.c> allocates some memory and constructs a Perl +interpreter: + + 1 PERL_SYS_INIT3(&argc,&argv,&env); + 2 + 3 if (!PL_do_undump) { + 4 my_perl = perl_alloc(); + 5 if (!my_perl) + 6 exit(1); + 7 perl_construct(my_perl); + 8 PL_perl_destruct_level = 0; + 9 } + +Line 1 is a macro, and its definition is dependent on your operating +system. Line 3 references C<PL_do_undump>, a global variable - all +global variables in Perl start with C<PL_>. This tells you whether the +current running program was created with the C<-u> flag to perl and then +F<undump>, which means it's going to be false in any sane context. + +Line 4 calls a function in F<perl.c> to allocate memory for a Perl +interpreter. It's quite a simple function, and the guts of it looks like +this: + + my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); + +Here you see an example of Perl's system abstraction, which we'll see +later: C<PerlMem_malloc> is either your system's C<malloc>, or Perl's +own C<malloc> as defined in F<malloc.c> if you selected that option at +configure time. + +Next, in line 7, we construct the interpreter; this sets up all the +special variables that Perl needs, the stacks, and so on. + +Now we pass Perl the command line options, and tell it to go: + + exitstatus = perl_parse(my_perl, xs_init, argc, argv, (char **)NULL); + if (!exitstatus) { + exitstatus = perl_run(my_perl); + } + + +C<perl_parse> is actually a wrapper around C<S_parse_body>, as defined +in F<perl.c>, which processes the command line options, sets up any +statically linked XS modules, opens the program and calls C<yyparse> to +parse it. + +=item Parsing + +The aim of this stage is to take the Perl source, and turn it into an op +tree. We'll see what one of those looks like later. Strictly speaking, +there's three things going on here. + +C<yyparse>, the parser, lives in F<perly.c>, although you're better off +reading the original YACC input in F<perly.y>. (Yes, Virginia, there +B<is> a YACC grammar for Perl!) The job of the parser is to take your +code and `understand' it, splitting it into sentences, deciding which +operands go with which operators and so on. + +The parser is nobly assisted by the lexer, which chunks up your input +into tokens, and decides what type of thing each token is: a variable +name, an operator, a bareword, a subroutine, a core function, and so on. +The main point of entry to the lexer is C<yylex>, and that and its +associated routines can be found in F<toke.c>. Perl isn't much like +other computer languages; it's highly context sensitive at times, it can +be tricky to work out what sort of token something is, or where a token +ends. As such, there's a lot of interplay between the tokeniser and the +parser, which can get pretty frightening if you're not used to it. + +As the parser understands a Perl program, it builds up a tree of +operations for the interpreter to perform during execution. The routines +which construct and link together the various operations are to be found +in F<op.c>, and will be examined later. + +=item Optimization + +Now the parsing stage is complete, and the finished tree represents +the operations that the Perl interpreter needs to perform to execute our +program. Next, Perl does a dry run over the tree looking for +optimisations: constant expressions such as C<3 + 4> will be computed +now, and the optimizer will also see if any multiple operations can be +replaced with a single one. For instance, to fetch the variable C<$foo>, +instead of grabbing the glob C<*foo> and looking at the scalar +component, the optimizer fiddles the op tree to use a function which +directly looks up the scalar in question. The main optimizer is C<peep> +in F<op.c>, and many ops have their own optimizing functions. + +=item Running + +Now we're finally ready to go: we have compiled Perl byte code, and all +that's left to do is run it. The actual execution is done by the +C<runops_standard> function in F<run.c>; more specifically, it's done by +these three innocent looking lines: + + while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX))) { + PERL_ASYNC_CHECK(); + } + +You may be more comfortable with the Perl version of that: + + PERL_ASYNC_CHECK() while $Perl::op = &{$Perl::op->{function}}; + +Well, maybe not. Anyway, each op contains a function pointer, which +stipulates the function which will actually carry out the operation. +This function will return the next op in the sequence - this allows for +things like C<if> which choose the next op dynamically at run time. +The C<PERL_ASYNC_CHECK> makes sure that things like signals interrupt +execution if required. + +The actual functions called are known as PP code, and they're spread +between four files: F<pp_hot.c> contains the `hot' code, which is most +often used and highly optimized, F<pp_sys.c> contains all the +system-specific functions, F<pp_ctl.c> contains the functions which +implement control structures (C<if>, C<while> and the like) and F<pp.c> +contains everything else. These are, if you like, the C code for Perl's +built-in functions and operators. + +=back + +=head2 Internal Variable Types + +You should by now have had a look at L<perlguts>, which tells you about +Perl's internal variable types: SVs, HVs, AVs and the rest. If not, do +that now. + +These variables are used not only to represent Perl-space variables, but +also any constants in the code, as well as some structures completely +internal to Perl. The symbol table, for instance, is an ordinary Perl +hash. Your code is represented by an SV as it's read into the parser; +any program files you call are opened via ordinary Perl filehandles, and +so on. + +The core L<Devel::Peek|Devel::Peek> module lets us examine SVs from a +Perl program. Let's see, for instance, how Perl treats the constant +C<"hello">. + + % perl -MDevel::Peek -e 'Dump("hello")' + 1 SV = PV(0xa041450) at 0xa04ecbc + 2 REFCNT = 1 + 3 FLAGS = (POK,READONLY,pPOK) + 4 PV = 0xa0484e0 "hello"\0 + 5 CUR = 5 + 6 LEN = 6 + +Reading C<Devel::Peek> output takes a bit of practise, so let's go +through it line by line. + +Line 1 tells us we're looking at an SV which lives at C<0xa04ecbc> in +memory. SVs themselves are very simple structures, but they contain a +pointer to a more complex structure. In this case, it's a PV, a +structure which holds a string value, at location C<0xa041450>. Line 2 +is the reference count; there are no other references to this data, so +it's 1. + +Line 3 are the flags for this SV - it's OK to use it as a PV, it's a +read-only SV (because it's a constant) and the data is a PV internally. +Next we've got the contents of the string, starting at location +C<0xa0484e0>. + +Line 5 gives us the current length of the string - note that this does +B<not> include the null terminator. Line 6 is not the length of the +string, but the length of the currently allocated buffer; as the string +grows, Perl automatically extends the available storage via a routine +called C<SvGROW>. + +You can get at any of these quantities from C very easily; just add +C<Sv> to the name of the field shown in the snippet, and you've got a +macro which will return the value: C<SvCUR(sv)> returns the current +length of the string, C<SvREFCOUNT(sv)> returns the reference count, +C<SvPV(sv, len)> returns the string itself with its length, and so on. +More macros to manipulate these properties can be found in L<perlguts>. + +Let's take an example of manipulating a PV, from C<sv_catpvn>, in F<sv.c> + + 1 void + 2 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) + 3 { + 4 STRLEN tlen; + 5 char *junk; + + 6 junk = SvPV_force(sv, tlen); + 7 SvGROW(sv, tlen + len + 1); + 8 if (ptr == junk) + 9 ptr = SvPVX(sv); + 10 Move(ptr,SvPVX(sv)+tlen,len,char); + 11 SvCUR(sv) += len; + 12 *SvEND(sv) = '\0'; + 13 (void)SvPOK_only_UTF8(sv); /* validate pointer */ + 14 SvTAINT(sv); + 15 } + +This is a function which adds a string, C<ptr>, of length C<len> onto +the end of the PV stored in C<sv>. The first thing we do in line 6 is +make sure that the SV B<has> a valid PV, by calling the C<SvPV_force> +macro to force a PV. As a side effect, C<tlen> gets set to the current +value of the PV, and the PV itself is returned to C<junk>. + +In line 7, we make sure that the SV will have enough room to accommodate +the old string, the new string and the null terminator. If C<LEN> isn't +big enough, C<SvGROW> will reallocate space for us. + +Now, if C<junk> is the same as the string we're trying to add, we can +grab the string directly from the SV; C<SvPVX> is the address of the PV +in the SV. + +Line 10 does the actual catenation: the C<Move> macro moves a chunk of +memory around: we move the string C<ptr> to the end of the PV - that's +the start of the PV plus its current length. We're moving C<len> bytes +of type C<char>. After doing so, we need to tell Perl we've extended the +string, by altering C<CUR> to reflect the new length. C<SvEND> is a +macro which gives us the end of the string, so that needs to be a +C<"\0">. + +Line 13 manipulates the flags; since we've changed the PV, any IV or NV +values will no longer be valid: if we have C<$a=10; $a.="6";> we don't +want to use the old IV of 10. C<SvPOK_only_utf8> is a special UTF8-aware +version of C<SvPOK_only>, a macro which turns off the IOK and NOK flags +and turns on POK. The final C<SvTAINT> is a macro which launders tainted +data if taint mode is turned on. + +AVs and HVs are more complicated, but SVs are by far the most common +variable type being thrown around. Having seen something of how we +manipulate these, let's go on and look at how the op tree is +constructed. + +=head2 Op Trees + +First, what is the op tree, anyway? The op tree is the parsed +representation of your program, as we saw in our section on parsing, and +it's the sequence of operations that Perl goes through to execute your +program, as we saw in L</Running>. + +An op is a fundamental operation that Perl can perform: all the built-in +functions and operators are ops, and there are a series of ops which +deal with concepts the interpreter needs internally - entering and +leaving a block, ending a statement, fetching a variable, and so on. + +The op tree is connected in two ways: you can imagine that there are two +"routes" through it, two orders in which you can traverse the tree. +First, parse order reflects how the parser understood the code, and +secondly, execution order tells perl what order to perform the +operations in. + +The easiest way to examine the op tree is to stop Perl after it has +finished parsing, and get it to dump out the tree. This is exactly what +the compiler backends L<B::Terse|B::Terse> and L<B::Debug|B::Debug> do. + +Let's have a look at how Perl sees C<$a = $b + $c>: + + % perl -MO=Terse -e '$a=$b+$c' + 1 LISTOP (0x8179888) leave + 2 OP (0x81798b0) enter + 3 COP (0x8179850) nextstate + 4 BINOP (0x8179828) sassign + 5 BINOP (0x8179800) add [1] + 6 UNOP (0x81796e0) null [15] + 7 SVOP (0x80fafe0) gvsv GV (0x80fa4cc) *b + 8 UNOP (0x81797e0) null [15] + 9 SVOP (0x8179700) gvsv GV (0x80efeb0) *c + 10 UNOP (0x816b4f0) null [15] + 11 SVOP (0x816dcf0) gvsv GV (0x80fa460) *a + +Let's start in the middle, at line 4. This is a BINOP, a binary +operator, which is at location C<0x8179828>. The specific operator in +question is C<sassign> - scalar assignment - and you can find the code +which implements it in the function C<pp_sassign> in F<pp_hot.c>. As a +binary operator, it has two children: the add operator, providing the +result of C<$b+$c>, is uppermost on line 5, and the left hand side is on +line 10. + +Line 10 is the null op: this does exactly nothing. What is that doing +there? If you see the null op, it's a sign that something has been +optimized away after parsing. As we mentioned in L</Optimization>, +the optimization stage sometimes converts two operations into one, for +example when fetching a scalar variable. When this happens, instead of +rewriting the op tree and cleaning up the dangling pointers, it's easier +just to replace the redundant operation with the null op. Originally, +the tree would have looked like this: + + 10 SVOP (0x816b4f0) rv2sv [15] + 11 SVOP (0x816dcf0) gv GV (0x80fa460) *a + +That is, fetch the C<a> entry from the main symbol table, and then look +at the scalar component of it: C<gvsv> (C<pp_gvsv> into F<pp_hot.c>) +happens to do both these things. + +The right hand side, starting at line 5 is similar to what we've just +seen: we have the C<add> op (C<pp_add> also in F<pp_hot.c>) add together +two C<gvsv>s. + +Now, what's this about? + + 1 LISTOP (0x8179888) leave + 2 OP (0x81798b0) enter + 3 COP (0x8179850) nextstate + +C<enter> and C<leave> are scoping ops, and their job is to perform any +housekeeping every time you enter and leave a block: lexical variables +are tidied up, unreferenced variables are destroyed, and so on. Every +program will have those first three lines: C<leave> is a list, and its +children are all the statements in the block. Statements are delimited +by C<nextstate>, so a block is a collection of C<nextstate> ops, with +the ops to be performed for each statement being the children of +C<nextstate>. C<enter> is a single op which functions as a marker. + +That's how Perl parsed the program, from top to bottom: + + Program + | + Statement + | + = + / \ + / \ + $a + + / \ + $b $c + +However, it's impossible to B<perform> the operations in this order: +you have to find the values of C<$b> and C<$c> before you add them +together, for instance. So, the other thread that runs through the op +tree is the execution order: each op has a field C<op_next> which points +to the next op to be run, so following these pointers tells us how perl +executes the code. We can traverse the tree in this order using +the C<exec> option to C<B::Terse>: + + % perl -MO=Terse,exec -e '$a=$b+$c' + 1 OP (0x8179928) enter + 2 COP (0x81798c8) nextstate + 3 SVOP (0x81796c8) gvsv GV (0x80fa4d4) *b + 4 SVOP (0x8179798) gvsv GV (0x80efeb0) *c + 5 BINOP (0x8179878) add [1] + 6 SVOP (0x816dd38) gvsv GV (0x80fa468) *a + 7 BINOP (0x81798a0) sassign + 8 LISTOP (0x8179900) leave + +This probably makes more sense for a human: enter a block, start a +statement. Get the values of C<$b> and C<$c>, and add them together. +Find C<$a>, and assign one to the other. Then leave. + +The way Perl builds up these op trees in the parsing process can be +unravelled by examining F<perly.y>, the YACC grammar. Let's take the +piece we need to construct the tree for C<$a = $b + $c> + + 1 term : term ASSIGNOP term + 2 { $$ = newASSIGNOP(OPf_STACKED, $1, $2, $3); } + 3 | term ADDOP term + 4 { $$ = newBINOP($2, 0, scalar($1), scalar($3)); } + +If you're not used to reading BNF grammars, this is how it works: You're +fed certain things by the tokeniser, which generally end up in upper +case. Here, C<ADDOP>, is provided when the tokeniser sees C<+> in your +code. C<ASSIGNOP> is provided when C<=> is used for assigning. These are +`terminal symbols', because you can't get any simpler than them. + +The grammar, lines one and three of the snippet above, tells you how to +build up more complex forms. These complex forms, `non-terminal symbols' +are generally placed in lower case. C<term> here is a non-terminal +symbol, representing a single expression. + +The grammar gives you the following rule: you can make the thing on the +left of the colon if you see all the things on the right in sequence. +This is called a "reduction", and the aim of parsing is to completely +reduce the input. There are several different ways you can perform a +reduction, separated by vertical bars: so, C<term> followed by C<=> +followed by C<term> makes a C<term>, and C<term> followed by C<+> +followed by C<term> can also make a C<term>. + +So, if you see two terms with an C<=> or C<+>, between them, you can +turn them into a single expression. When you do this, you execute the +code in the block on the next line: if you see C<=>, you'll do the code +in line 2. If you see C<+>, you'll do the code in line 4. It's this code +which contributes to the op tree. + + | term ADDOP term + { $$ = newBINOP($2, 0, scalar($1), scalar($3)); } + +What this does is creates a new binary op, and feeds it a number of +variables. The variables refer to the tokens: C<$1> is the first token in +the input, C<$2> the second, and so on - think regular expression +backreferences. C<$$> is the op returned from this reduction. So, we +call C<newBINOP> to create a new binary operator. The first parameter to +C<newBINOP>, a function in F<op.c>, is the op type. It's an addition +operator, so we want the type to be C<ADDOP>. We could specify this +directly, but it's right there as the second token in the input, so we +use C<$2>. The second parameter is the op's flags: 0 means `nothing +special'. Then the things to add: the left and right hand side of our +expression, in scalar context. + +=head2 Stacks + +When perl executes something like C<addop>, how does it pass on its +results to the next op? The answer is, through the use of stacks. Perl +has a number of stacks to store things it's currently working on, and +we'll look at the three most important ones here. + +=over 3 + +=item Argument stack + +Arguments are passed to PP code and returned from PP code using the +argument stack, C<ST>. The typical way to handle arguments is to pop +them off the stack, deal with them how you wish, and then push the result +back onto the stack. This is how, for instance, the cosine operator +works: + + NV value; + value = POPn; + value = Perl_cos(value); + XPUSHn(value); + +We'll see a more tricky example of this when we consider Perl's macros +below. C<POPn> gives you the NV (floating point value) of the top SV on +the stack: the C<$x> in C<cos($x)>. Then we compute the cosine, and push +the result back as an NV. The C<X> in C<XPUSHn> means that the stack +should be extended if necessary - it can't be necessary here, because we +know there's room for one more item on the stack, since we've just +removed one! The C<XPUSH*> macros at least guarantee safety. + +Alternatively, you can fiddle with the stack directly: C<SP> gives you +the first element in your portion of the stack, and C<TOP*> gives you +the top SV/IV/NV/etc. on the stack. So, for instance, to do unary +negation of an integer: + + SETi(-TOPi); + +Just set the integer value of the top stack entry to its negation. + +Argument stack manipulation in the core is exactly the same as it is in +XSUBs - see L<perlxstut>, L<perlxs> and L<perlguts> for a longer +description of the macros used in stack manipulation. + +=item Mark stack + +I say `your portion of the stack' above because PP code doesn't +necessarily get the whole stack to itself: if your function calls +another function, you'll only want to expose the arguments aimed for the +called function, and not (necessarily) let it get at your own data. The +way we do this is to have a `virtual' bottom-of-stack, exposed to each +function. The mark stack keeps bookmarks to locations in the argument +stack usable by each function. For instance, when dealing with a tied +variable, (internally, something with `P' magic) Perl has to call +methods for accesses to the tied variables. However, we need to separate +the arguments exposed to the method to the argument exposed to the +original function - the store or fetch or whatever it may be. Here's how +the tied C<push> is implemented; see C<av_push> in F<av.c>: + + 1 PUSHMARK(SP); + 2 EXTEND(SP,2); + 3 PUSHs(SvTIED_obj((SV*)av, mg)); + 4 PUSHs(val); + 5 PUTBACK; + 6 ENTER; + 7 call_method("PUSH", G_SCALAR|G_DISCARD); + 8 LEAVE; + 9 POPSTACK; + +The lines which concern the mark stack are the first, fifth and last +lines: they save away, restore and remove the current position of the +argument stack. + +Let's examine the whole implementation, for practice: + + 1 PUSHMARK(SP); + +Push the current state of the stack pointer onto the mark stack. This is +so that when we've finished adding items to the argument stack, Perl +knows how many things we've added recently. + + 2 EXTEND(SP,2); + 3 PUSHs(SvTIED_obj((SV*)av, mg)); + 4 PUSHs(val); + +We're going to add two more items onto the argument stack: when you have +a tied array, the C<PUSH> subroutine receives the object and the value +to be pushed, and that's exactly what we have here - the tied object, +retrieved with C<SvTIED_obj>, and the value, the SV C<val>. + + 5 PUTBACK; + +Next we tell Perl to make the change to the global stack pointer: C<dSP> +only gave us a local copy, not a reference to the global. + + 6 ENTER; + 7 call_method("PUSH", G_SCALAR|G_DISCARD); + 8 LEAVE; + +C<ENTER> and C<LEAVE> localise a block of code - they make sure that all +variables are tidied up, everything that has been localised gets +its previous value returned, and so on. Think of them as the C<{> and +C<}> of a Perl block. + +To actually do the magic method call, we have to call a subroutine in +Perl space: C<call_method> takes care of that, and it's described in +L<perlcall>. We call the C<PUSH> method in scalar context, and we're +going to discard its return value. + + 9 POPSTACK; + +Finally, we remove the value we placed on the mark stack, since we +don't need it any more. + +=item Save stack + +C doesn't have a concept of local scope, so perl provides one. We've +seen that C<ENTER> and C<LEAVE> are used as scoping braces; the save +stack implements the C equivalent of, for example: + + { + local $foo = 42; + ... + } + +See L<perlguts/Localising Changes> for how to use the save stack. + +=back + +=head2 Millions of Macros + +One thing you'll notice about the Perl source is that it's full of +macros. Some have called the pervasive use of macros the hardest thing +to understand, others find it adds to clarity. Let's take an example, +the code which implements the addition operator: + + 1 PP(pp_add) + 2 { + 3 dSP; dATARGET; tryAMAGICbin(add,opASSIGN); + 4 { + 5 dPOPTOPnnrl_ul; + 6 SETn( left + right ); + 7 RETURN; + 8 } + 9 } + +Every line here (apart from the braces, of course) contains a macro. The +first line sets up the function declaration as Perl expects for PP code; +line 3 sets up variable declarations for the argument stack and the +target, the return value of the operation. Finally, it tries to see if +the addition operation is overloaded; if so, the appropriate subroutine +is called. + +Line 5 is another variable declaration - all variable declarations start +with C<d> - which pops from the top of the argument stack two NVs (hence +C<nn>) and puts them into the variables C<right> and C<left>, hence the +C<rl>. These are the two operands to the addition operator. Next, we +call C<SETn> to set the NV of the return value to the result of adding +the two values. This done, we return - the C<RETURN> macro makes sure +that our return value is properly handled, and we pass the next operator +to run back to the main run loop. + +Most of these macros are explained in L<perlapi>, and some of the more +important ones are explained in L<perlxs> as well. Pay special attention +to L<perlguts/Background and PERL_IMPLICIT_CONTEXT> for information on +the C<[pad]THX_?> macros. + + +=head2 Poking at Perl + +To really poke around with Perl, you'll probably want to build Perl for +debugging, like this: + + ./Configure -d -D optimize=-g + make + +C<-g> is a flag to the C compiler to have it produce debugging +information which will allow us to step through a running program. +F<Configure> will also turn on the C<DEBUGGING> compilation symbol which +enables all the internal debugging code in Perl. There are a whole bunch +of things you can debug with this: L<perlrun> lists them all, and the +best way to find out about them is to play about with them. The most +useful options are probably + + l Context (loop) stack processing + t Trace execution + o Method and overloading resolution + c String/numeric conversions + +Some of the functionality of the debugging code can be achieved using XS +modules. + + -Dr => use re 'debug' + -Dx => use O 'Debug' + +=head2 Using a source-level debugger + +If the debugging output of C<-D> doesn't help you, it's time to step +through perl's execution with a source-level debugger. + +=over 3 + +=item * + +We'll use C<gdb> for our examples here; the principles will apply to any +debugger, but check the manual of the one you're using. + +=back + +To fire up the debugger, type + + gdb ./perl + +You'll want to do that in your Perl source tree so the debugger can read +the source code. You should see the copyright message, followed by the +prompt. + + (gdb) + +C<help> will get you into the documentation, but here are the most +useful commands: + +=over 3 + +=item run [args] + +Run the program with the given arguments. + +=item break function_name + +=item break source.c:xxx + +Tells the debugger that we'll want to pause execution when we reach +either the named function (but see L<perlguts/Internal Functions>!) or the given +line in the named source file. + +=item step + +Steps through the program a line at a time. + +=item next + +Steps through the program a line at a time, without descending into +functions. + +=item continue + +Run until the next breakpoint. + +=item finish + +Run until the end of the current function, then stop again. + +=item 'enter' + +Just pressing Enter will do the most recent operation again - it's a +blessing when stepping through miles of source code. + +=item print + +Execute the given C code and print its results. B<WARNING>: Perl makes +heavy use of macros, and F<gdb> is not aware of macros. You'll have to +substitute them yourself. So, for instance, you can't say + + print SvPV_nolen(sv) + +but you have to say + + print Perl_sv_2pv_nolen(sv) + +You may find it helpful to have a "macro dictionary", which you can +produce by saying C<cpp -dM perl.c | sort>. Even then, F<cpp> won't +recursively apply the macros for you. + +=back + +=head2 Dumping Perl Data Structures + +One way to get around this macro hell is to use the dumping functions in +F<dump.c>; these work a little like an internal +L<Devel::Peek|Devel::Peek>, but they also cover OPs and other structures +that you can't get at from Perl. Let's take an example. We'll use the +C<$a = $b + $c> we used before, but give it a bit of context: +C<$b = "6XXXX"; $c = 2.3;>. Where's a good place to stop and poke around? + +What about C<pp_add>, the function we examined earlier to implement the +C<+> operator: + + (gdb) break Perl_pp_add + Breakpoint 1 at 0x46249f: file pp_hot.c, line 309. + +Notice we use C<Perl_pp_add> and not C<pp_add> - see L<perlguts/Internal Functions>. +With the breakpoint in place, we can run our program: + + (gdb) run -e '$b = "6XXXX"; $c = 2.3; $a = $b + $c' + +Lots of junk will go past as gdb reads in the relevant source files and +libraries, and then: + + Breakpoint 1, Perl_pp_add () at pp_hot.c:309 + 309 dSP; dATARGET; tryAMAGICbin(add,opASSIGN); + (gdb) step + 311 dPOPTOPnnrl_ul; + (gdb) + +We looked at this bit of code before, and we said that C<dPOPTOPnnrl_ul> +arranges for two C<NV>s to be placed into C<left> and C<right> - let's +slightly expand it: + + #define dPOPTOPnnrl_ul NV right = POPn; \ + SV *leftsv = TOPs; \ + NV left = USE_LEFT(leftsv) ? SvNV(leftsv) : 0.0 + +C<POPn> takes the SV from the top of the stack and obtains its NV either +directly (if C<SvNOK> is set) or by calling the C<sv_2nv> function. +C<TOPs> takes the next SV from the top of the stack - yes, C<POPn> uses +C<TOPs> - but doesn't remove it. We then use C<SvNV> to get the NV from +C<leftsv> in the same way as before - yes, C<POPn> uses C<SvNV>. + +Since we don't have an NV for C<$b>, we'll have to use C<sv_2nv> to +convert it. If we step again, we'll find ourselves there: + + Perl_sv_2nv (sv=0xa0675d0) at sv.c:1669 + 1669 if (!sv) + (gdb) + +We can now use C<Perl_sv_dump> to investigate the SV: + + SV = PV(0xa057cc0) at 0xa0675d0 + REFCNT = 1 + FLAGS = (POK,pPOK) + PV = 0xa06a510 "6XXXX"\0 + CUR = 5 + LEN = 6 + $1 = void + +We know we're going to get C<6> from this, so let's finish the +subroutine: + + (gdb) finish + Run till exit from #0 Perl_sv_2nv (sv=0xa0675d0) at sv.c:1671 + 0x462669 in Perl_pp_add () at pp_hot.c:311 + 311 dPOPTOPnnrl_ul; + +We can also dump out this op: the current op is always stored in +C<PL_op>, and we can dump it with C<Perl_op_dump>. This'll give us +similar output to L<B::Debug|B::Debug>. + + { + 13 TYPE = add ===> 14 + TARG = 1 + FLAGS = (SCALAR,KIDS) + { + TYPE = null ===> (12) + (was rv2sv) + FLAGS = (SCALAR,KIDS) + { + 11 TYPE = gvsv ===> 12 + FLAGS = (SCALAR) + GV = main::b + } + } + +< finish this later > + +=head2 Patching + +All right, we've now had a look at how to navigate the Perl sources and +some things you'll need to know when fiddling with them. Let's now get +on and create a simple patch. Here's something Larry suggested: if a +C<U> is the first active format during a C<pack>, (for example, +C<pack "U3C8", @stuff>) then the resulting string should be treated as +UTF8 encoded. + +How do we prepare to fix this up? First we locate the code in question - +the C<pack> happens at runtime, so it's going to be in one of the F<pp> +files. Sure enough, C<pp_pack> is in F<pp.c>. Since we're going to be +altering this file, let's copy it to F<pp.c~>. + +Now let's look over C<pp_pack>: we take a pattern into C<pat>, and then +loop over the pattern, taking each format character in turn into +C<datum_type>. Then for each possible format character, we swallow up +the other arguments in the pattern (a field width, an asterisk, and so +on) and convert the next chunk input into the specified format, adding +it onto the output SV C<cat>. + +How do we know if the C<U> is the first format in the C<pat>? Well, if +we have a pointer to the start of C<pat> then, if we see a C<U> we can +test whether we're still at the start of the string. So, here's where +C<pat> is set up: + + STRLEN fromlen; + register char *pat = SvPVx(*++MARK, fromlen); + register char *patend = pat + fromlen; + register I32 len; + I32 datumtype; + SV *fromstr; + +We'll have another string pointer in there: + + STRLEN fromlen; + register char *pat = SvPVx(*++MARK, fromlen); + register char *patend = pat + fromlen; + + char *patcopy; + register I32 len; + I32 datumtype; + SV *fromstr; + +And just before we start the loop, we'll set C<patcopy> to be the start +of C<pat>: + + items = SP - MARK; + MARK++; + sv_setpvn(cat, "", 0); + + patcopy = pat; + while (pat < patend) { + +Now if we see a C<U> which was at the start of the string, we turn on +the UTF8 flag for the output SV, C<cat>: + + + if (datumtype == 'U' && pat==patcopy+1) + + SvUTF8_on(cat); + if (datumtype == '#') { + while (pat < patend && *pat != '\n') + pat++; + +Remember that it has to be C<patcopy+1> because the first character of +the string is the C<U> which has been swallowed into C<datumtype!> + +Oops, we forgot one thing: what if there are spaces at the start of the +pattern? C<pack(" U*", @stuff)> will have C<U> as the first active +character, even though it's not the first thing in the pattern. In this +case, we have to advance C<patcopy> along with C<pat> when we see spaces: + + if (isSPACE(datumtype)) + continue; + +needs to become + + if (isSPACE(datumtype)) { + patcopy++; + continue; + } + +OK. That's the C part done. Now we must do two additional things before +this patch is ready to go: we've changed the behaviour of Perl, and so +we must document that change. We must also provide some more regression +tests to make sure our patch works and doesn't create a bug somewhere +else along the line. + +The regression tests for each operator live in F<t/op/>, and so we make +a copy of F<t/op/pack.t> to F<t/op/pack.t~>. Now we can add our tests +to the end. First, we'll test that the C<U> does indeed create Unicode +strings: + + print 'not ' unless "1.20.300.4000" eq sprintf "%vd", pack("U*",1,20,300,4000); + print "ok $test\n"; $test++; + +Now we'll test that we got that space-at-the-beginning business right: + + print 'not ' unless "1.20.300.4000" eq + sprintf "%vd", pack(" U*",1,20,300,4000); + print "ok $test\n"; $test++; + +And finally we'll test that we don't make Unicode strings if C<U> is B<not> +the first active format: + + print 'not ' unless v1.20.300.4000 ne + sprintf "%vd", pack("C0U*",1,20,300,4000); + print "ok $test\n"; $test++; + +Mustn't forget to change the number of tests which appears at the top, or +else the automated tester will get confused: + + -print "1..156\n"; + +print "1..159\n"; + +We now compile up Perl, and run it through the test suite. Our new +tests pass, hooray! + +Finally, the documentation. The job is never done until the paperwork is +over, so let's describe the change we've just made. The relevant place +is F<pod/perlfunc.pod>; again, we make a copy, and then we'll insert +this text in the description of C<pack>: + + =item * + + If the pattern begins with a C<U>, the resulting string will be treated + as Unicode-encoded. You can force UTF8 encoding on in a string with an + initial C<U0>, and the bytes that follow will be interpreted as Unicode + characters. If you don't want this to happen, you can begin your pattern + with C<C0> (or anything else) to force Perl not to UTF8 encode your + string, and then follow this with a C<U*> somewhere in your pattern. + +All done. Now let's create the patch. F<Porting/patching.pod> tells us +that if we're making major changes, we should copy the entire directory +to somewhere safe before we begin fiddling, and then do + + diff -ruN old new > patch + +However, we know which files we've changed, and we can simply do this: + + diff -u pp.c~ pp.c > patch + diff -u t/op/pack.t~ t/op/pack.t >> patch + diff -u pod/perlfunc.pod~ pod/perlfunc.pod >> patch + +We end up with a patch looking a little like this: + + --- pp.c~ Fri Jun 02 04:34:10 2000 + +++ pp.c Fri Jun 16 11:37:25 2000 + @@ -4375,6 +4375,7 @@ + register I32 items; + STRLEN fromlen; + register char *pat = SvPVx(*++MARK, fromlen); + + char *patcopy; + register char *patend = pat + fromlen; + register I32 len; + I32 datumtype; + @@ -4405,6 +4406,7 @@ + ... + +And finally, we submit it, with our rationale, to perl5-porters. Job +done! + +=head1 EXTERNAL TOOLS FOR DEBUGGING PERL + +Sometimes it helps to use external tools while debugging and +testing Perl. This section tries to guide you through using +some common testing and debugging tools with Perl. This is +meant as a guide to interfacing these tools with Perl, not +as any kind of guide to the use of the tools themselves. + +=head2 Rational Software's Purify + +Purify is a commercial tool that is helpful in identifying +memory overruns, wild pointers, memory leaks and other such +badness. Perl must be compiled in a specific way for +optimal testing with Purify. Purify is available under +Windows NT, Solaris, HP-UX, SGI, and Siemens Unix. + +The only currently known leaks happen when there are +compile-time errors within eval or require. (Fixing these +is non-trivial, unfortunately, but they must be fixed +eventually.) + +=head2 Purify on Unix + +On Unix, Purify creates a new Perl binary. To get the most +benefit out of Purify, you should create the perl to Purify +using: + + sh Configure -Accflags=-DPURIFY -Doptimize='-g' \ + -Uusemymalloc -Dusemultiplicity + +where these arguments mean: + +=over 4 + +=item -Accflags=-DPURIFY + +Disables Perl's arena memory allocation functions, as well as +forcing use of memory allocation functions derived from the +system malloc. + +=item -Doptimize='-g' + +Adds debugging information so that you see the exact source +statements where the problem occurs. Without this flag, all +you will see is the source filename of where the error occurred. + +=item -Uusemymalloc + +Disable Perl's malloc so that Purify can more closely monitor +allocations and leaks. Using Perl's malloc will make Purify +report most leaks in the "potential" leaks category. + +=item -Dusemultiplicity + +Enabling the multiplicity option allows perl to clean up +thoroughly when the interpreter shuts down, which reduces the +number of bogus leak reports from Purify. + +=back + +Once you've compiled a perl suitable for Purify'ing, then you +can just: + + make pureperl + +which creates a binary named 'pureperl' that has been Purify'ed. +This binary is used in place of the standard 'perl' binary +when you want to debug Perl memory problems. + +As an example, to show any memory leaks produced during the +standard Perl testset you would create and run the Purify'ed +perl as: + + make pureperl + cd t + ../pureperl -I../lib harness + +which would run Perl on test.pl and report any memory problems. + +Purify outputs messages in "Viewer" windows by default. If +you don't have a windowing environment or if you simply +want the Purify output to unobtrusively go to a log file +instead of to the interactive window, use these following +options to output to the log file "perl.log": + + setenv PURIFYOPTIONS "-chain-length=25 -windows=no \ + -log-file=perl.log -append-logfile=yes" + +If you plan to use the "Viewer" windows, then you only need this option: + + setenv PURIFYOPTIONS "-chain-length=25" + +=head2 Purify on NT + +Purify on Windows NT instruments the Perl binary 'perl.exe' +on the fly. There are several options in the makefile you +should change to get the most use out of Purify: + +=over 4 + +=item DEFINES + +You should add -DPURIFY to the DEFINES line so the DEFINES +line looks something like: + + DEFINES = -DWIN32 -D_CONSOLE -DNO_STRICT $(CRYPT_FLAG) -DPURIFY=1 + +to disable Perl's arena memory allocation functions, as +well as to force use of memory allocation functions derived +from the system malloc. + +=item USE_MULTI = define + +Enabling the multiplicity option allows perl to clean up +thoroughly when the interpreter shuts down, which reduces the +number of bogus leak reports from Purify. + +=item #PERL_MALLOC = define + +Disable Perl's malloc so that Purify can more closely monitor +allocations and leaks. Using Perl's malloc will make Purify +report most leaks in the "potential" leaks category. + +=item CFG = Debug + +Adds debugging information so that you see the exact source +statements where the problem occurs. Without this flag, all +you will see is the source filename of where the error occurred. + +=back + +As an example, to show any memory leaks produced during the +standard Perl testset you would create and run Purify as: + + cd win32 + make + cd ../t + purify ../perl -I../lib harness + +which would instrument Perl in memory, run Perl on test.pl, +then finally report any memory problems. + +=head2 CONCLUSION + +We've had a brief look around the Perl source, an overview of the stages +F<perl> goes through when it's running your code, and how to use a +debugger to poke at the Perl guts. We took a very simple problem and +demonstrated how to solve it fully - with documentation, regression +tests, and finally a patch for submission to p5p. Finally, we talked +about how to use external tools to debug and test Perl. + +I'd now suggest you read over those references again, and then, as soon +as possible, get your hands dirty. The best way to learn is by doing, +so: + +=over 3 + +=item * + +Subscribe to perl5-porters, follow the patches and try and understand +them; don't be afraid to ask if there's a portion you're not clear on - +who knows, you may unearth a bug in the patch... + +=item * + +Keep up to date with the bleeding edge Perl distributions and get +familiar with the changes. Try and get an idea of what areas people are +working on and the changes they're making. + +=item * + +Do read the README associated with your operating system, e.g. README.aix +on the IBM AIX OS. Don't hesitate to supply patches to that README if +you find anything missing or changed over a new OS release. + +=item * + +Find an area of Perl that seems interesting to you, and see if you can +work out how it works. Scan through the source, and step over it in the +debugger. Play, poke, investigate, fiddle! You'll probably get to +understand not just your chosen area but a much wider range of F<perl>'s +activity as well, and probably sooner than you'd think. + +=back + +=over 3 + +=item I<The Road goes ever on and on, down from the door where it began.> + +=back + +If you can do these things, you've started on the long road to Perl porting. +Thanks for wanting to help make Perl better - and happy hacking! + =head1 AUTHOR This document was written by Nathan Torkington, and is maintained by diff --git a/contrib/perl5/pod/perlhist.pod b/contrib/perl5/pod/perlhist.pod index 4311ee28137c..914c9639ed43 100644 --- a/contrib/perl5/pod/perlhist.pod +++ b/contrib/perl5/pod/perlhist.pod @@ -1,5 +1,3 @@ -=pod - =head1 NAME perlhist - the Perl history records @@ -36,7 +34,7 @@ Perl history in brief, by Larry Wall: Larry Wall, Andy Dougherty, Tom Christiansen, Charles Bailey, Nick Ing-Simmons, Chip Salzenberg, Tim Bunce, Malcolm Beattie, Gurusamy -Sarathy, Graham Barr. +Sarathy, Graham Barr, Jarkko Hietaniemi. =head2 PUMPKIN? @@ -341,6 +339,14 @@ the strings?). 5.6.0-RC3 2000-Mar-21 release candidate 3 5.6.0 2000-Mar-22 + Sarathy 5.6.1-TRIAL1 2000-Dec-18 The 5.6 maintenance track. + 5.6.1-TRIAL2 2001-Jan-31 + 5.6.1-TRIAL3 2001-Mar-19 + 5.6.1-foolish 2001-Apr-01 The "fools-gold" release. + 5.6.1 2001-Apr-08 + + Jarkko 5.7.0 2000-Sep-02 The 5.7 track: Development. + =head2 SELECTED RELEASE SIZES For example the notation "core: 212 29" in the release 1.000 means that diff --git a/contrib/perl5/pod/perlintern.pod b/contrib/perl5/pod/perlintern.pod index 58eeac6e954c..e50be288287e 100644 --- a/contrib/perl5/pod/perlintern.pod +++ b/contrib/perl5/pod/perlintern.pod @@ -6,17 +6,111 @@ perlintern - autogenerated documentation of purely B<internal> =head1 DESCRIPTION This file is the autogenerated documentation of functions in the -Perl intrepreter that are documented using Perl's internal documentation +Perl interpreter that are documented using Perl's internal documentation format but are not marked as part of the Perl API. In other words, B<they are not for use in extensions>! =over 8 +=item is_gv_magical + +Returns C<TRUE> if given the name of a magical GV. + +Currently only useful internally when determining if a GV should be +created even in rvalue contexts. + +C<flags> is not used at present but available for future extension to +allow selecting particular classes of magical variable. + + bool is_gv_magical(char *name, STRLEN len, U32 flags) + +=for hackers +Found in file gv.c + +=item LVRET + +True if this op will be the return value of an lvalue subroutine + +=for hackers +Found in file pp.h + +=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. +Single-stepping is automatically turned on after every step. This is the C +variable which corresponds to Perl's $DB::single variable. See +C<PL_DBsub>. + + SV * PL_DBsingle + +=for hackers +Found in file intrpvar.h + +=item PL_DBsub + +When Perl is run in debugging mode, with the B<-d> switch, this GV contains +the SV which holds the name of the sub being debugged. This is the C +variable which corresponds to Perl's $DB::sub variable. See +C<PL_DBsingle>. + + GV * PL_DBsub + +=for hackers +Found in file intrpvar.h + +=item PL_DBtrace + +Trace variable used when Perl is run in debugging mode, with the B<-d> +switch. This is the C variable which corresponds to Perl's $DB::trace +variable. See C<PL_DBsingle>. + + SV * PL_DBtrace + +=for hackers +Found in file intrpvar.h + +=item PL_dowarn + +The C variable which corresponds to Perl's $^W warning variable. + + bool PL_dowarn + +=for hackers +Found in file intrpvar.h + +=item PL_last_in_gv + +The GV which was last used for a filehandle input operation. (C<< <FH> >>) + + GV* PL_last_in_gv + +=for hackers +Found in file thrdvar.h + +=item PL_ofs_sv + +The output field separator - C<$,> in Perl space. + + SV* PL_ofs_sv + +=for hackers +Found in file thrdvar.h + +=item PL_rs + +The input record separator - C<$/> in Perl space. + + SV* PL_rs + +=for hackers +Found in file thrdvar.h + =back =head1 AUTHORS -The autodocumentation system was orignally added to the Perl core by +The autodocumentation system was originally added to the Perl core by Benjamin Stuhl. Documentation is by whoever was kind enough to document their functions. diff --git a/contrib/perl5/pod/perlipc.pod b/contrib/perl5/pod/perlipc.pod index 87602578218d..a1df3e42e015 100644 --- a/contrib/perl5/pod/perlipc.pod +++ b/contrib/perl5/pod/perlipc.pod @@ -234,8 +234,7 @@ prepared to clean up core dumps now and again. To forbid signal handlers altogether would bars you from many interesting programs, including virtually everything in this manpage, -since you could no longer even write SIGCHLD handlers. Their dodginess -is expected to be addresses in the 5.005 release. +since you could no longer even write SIGCHLD handlers. =head1 Using open() for IPC @@ -661,13 +660,14 @@ instead. BEGIN { $ENV{PATH} = '/usr/ucb:/bin' } use Socket; use Carp; - $EOL = "\015\012"; + my $EOL = "\015\012"; sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" } my $port = shift || 2345; my $proto = getprotobyname('tcp'); - $port = $1 if $port =~ /(\d+)/; # untaint port number + + ($port) = $port =~ /^(\d+)$/ or die "invalid port"; socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, @@ -703,14 +703,15 @@ go back to service a new client. BEGIN { $ENV{PATH} = '/usr/ucb:/bin' } use Socket; use Carp; - $EOL = "\015\012"; + my $EOL = "\015\012"; sub spawn; # forward declaration sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" } my $port = shift || 2345; my $proto = getprotobyname('tcp'); - $port = $1 if $port =~ /(\d+)/; # untaint port number + + ($port) = $port =~ /^(\d+)$/ or die "invalid port"; socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, @@ -744,6 +745,7 @@ go back to service a new client. at port $port"; spawn sub { + $|=1; print "Hello there, $name, it's now ", scalar localtime, $EOL; exec '/usr/games/fortune' # XXX: `wrong' line terminators or confess "can't exec fortune: $!"; @@ -835,7 +837,7 @@ domain sockets can show up in the file system with an ls(1) listing. You can test for these with Perl's B<-S> file test: unless ( -S '/dev/log' ) { - die "something's wicked with the print system"; + die "something's wicked with the log system"; } Here's a sample Unix-domain client: @@ -863,6 +865,7 @@ to be on the localhost, and thus everything works right. use Carp; BEGIN { $ENV{PATH} = '/usr/ucb:/bin' } + sub spawn; # forward declaration sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" } my $NAME = '/tmp/catsock'; @@ -899,6 +902,29 @@ to be on the localhost, and thus everything works right. }; } + sub spawn { + my $coderef = shift; + + unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') { + confess "usage: spawn CODEREF"; + } + + my $pid; + if (!defined($pid = fork)) { + logmsg "cannot fork: $!"; + return; + } elsif ($pid) { + logmsg "begat $pid"; + return; # I'm the parent + } + # else I'm the child -- go spawn + + open(STDIN, "<&Client") || die "can't dup client to stdin"; + open(STDOUT, ">&Client") || die "can't dup client to stdout"; + ## open(STDERR, ">&STDOUT") || die "can't dup stdout to stderr"; + exit &$coderef(); + } + As you see, it's remarkably similar to the Internet domain TCP server, so much so, in fact, that we've omitted several duplicate functions--spawn(), logmsg(), ctime(), and REAPER()--which are exactly the same as in the @@ -922,7 +948,7 @@ For those preferring a higher-level interface to socket programming, the IO::Socket module provides an object-oriented approach. IO::Socket is included as part of the standard Perl distribution as of the 5.004 release. If you're running an earlier version of Perl, just fetch -IO::Socket from CPAN, where you'll also find find modules providing easy +IO::Socket from CPAN, where you'll also find modules providing easy interfaces to the following systems: DNS, FTP, Ident (RFC 931), NIS and NISPlus, NNTP, Ping, POP3, SMTP, SNMP, SSLeay, Telnet, and Time--just to name a few. @@ -950,7 +976,7 @@ looks like this: Here are what those parameters to the C<new> constructor mean: -=over +=over 4 =item C<Proto> @@ -1022,7 +1048,7 @@ something to the server before fetching the server's response. } The web server handing the "http" service, which is assumed to be at -its standard port, number 80. If your the web server you're trying to +its standard port, number 80. If the web server you're trying to connect to is at a different port (like 1080 or 8080), you should specify as the named-parameter pair, C<< PeerPort => 8080 >>. The C<autoflush> method is used on the socket because otherwise the system would buffer @@ -1145,7 +1171,7 @@ does nothing but listen on a particular port for incoming connections. It does this by calling the C<< IO::Socket::INET->new() >> method with slightly different arguments than the client did. -=over +=over 4 =item Proto @@ -1245,6 +1271,11 @@ find yourself overly concerned about reliability and start building checks into your message system, then you probably should use just TCP to start with. +Note that UDP datagrams are I<not> a bytestream and should not be treated +as such. This makes using I/O mechanisms with internal buffering +like stdio (i.e. print() and friends) especially cumbersome. Use syswrite(), +or better send(), like in the example below. + Here's a UDP program similar to the sample Internet TCP client given earlier. However, instead of checking one host at a time, the UDP version will check many of them asynchronously by simulating a multicast and then @@ -1295,6 +1326,11 @@ with TCP, you'd have to use a different socket handle for each host. $count--; } +Note that this example does not include any retries and may consequently +fail to contact a reachable host. The most prominent reason for this +is congestion of the queues on the sending host if the number of +list of hosts to contact is sufficiently large. + =head1 SysV IPC While System V IPC isn't so widely used as sockets, it still has some diff --git a/contrib/perl5/pod/perllexwarn.pod b/contrib/perl5/pod/perllexwarn.pod index cee16875377f..951a470b2e59 100644 --- a/contrib/perl5/pod/perllexwarn.pod +++ b/contrib/perl5/pod/perllexwarn.pod @@ -9,7 +9,7 @@ flag B<-w> and the equivalent Perl variable, C<$^W>. The pragma works just like the existing "strict" pragma. This means that the scope of the warning pragma is limited to the -enclosing block. It also means that that the pragma setting will not +enclosing block. It also means that the pragma setting will not leak across files (via C<use>, C<require> or C<do>). This allows authors to independently define the degree of warning checks that will be applied to their module. @@ -30,18 +30,17 @@ Similarly all warnings are disabled in a block by either of these: For example, consider the code below: use warnings ; - my $a ; - my $b ; + my @a ; { no warnings ; - $b = 2 if $a EQ 3 ; + my $b = @a[0] ; } - $b = 1 if $a NE 3 ; + my $c = @a[0]; The code in the enclosing block has warnings enabled, but the inner -block has them disabled. In this case that means that the use of the C<EQ> -operator won't trip a C<"Use of EQ is deprecated"> warning, but the use of -C<NE> will produce a C<"Use of NE is deprecated"> warning. +block has them disabled. In this case that means the assignment to the +scalar C<$c> will trip the C<"Scalar value @a[0] better written as $a[0]"> +warning, but the assignment to the scalar C<$b> will not. =head2 Default Warnings and Optional Warnings @@ -100,7 +99,7 @@ disable compile-time warnings you need to rewrite the code like this: my $b ; chop $b ; } -The other big problem with C<$^W> is that way you can inadvertently +The other big problem with C<$^W> is the way you can inadvertently change the warning setting in unexpected places in your code. For example, when the code below is run (without the B<-w> flag), the second call to C<doit> will trip a C<"Use of uninitialized value"> warning, whereas @@ -195,7 +194,7 @@ or B<-X> command line flags. =back -The combined effect of 3 & 4 is that it will will allow code which uses +The combined effect of 3 & 4 is that it will allow code which uses the C<warnings> pragma to control the warning behavior of $^W-type code (using a C<local $^W=0>) if it really wants to, but not vice-versa. @@ -321,27 +320,38 @@ L<perldiag>. The presence of the word "FATAL" in the category list will escalate any warnings detected from the categories specified in the lexical scope -into fatal errors. In the code below, there are 3 places where a -deprecated warning will be detected, the middle one will produce a -fatal error. - +into fatal errors. In the code below, the use of C<time>, C<length> +and C<join> can all produce a C<"Useless use of xxx in void context"> +warning. use warnings ; - $a = 1 if $a EQ $b ; + time ; { - use warnings FATAL => qw(deprecated) ; - $a = 1 if $a EQ $b ; + use warnings FATAL => qw(void) ; + length "abc" ; } - $a = 1 if $a EQ $b ; + join "", 1,2,3 ; + + print "done\n" ; + +When run it produces this output + + Useless use of time in void context at fatal line 3. + Useless use of length in void context at fatal line 7. + +The scope where C<length> is used has escalated the C<void> warnings +category into a fatal error, so the program terminates immediately it +encounters the warning. + =head2 Reporting Warnings from a Module The C<warnings> pragma provides a number of functions that are useful for module authors. These are used when you want to report a module-specific -warning when the calling module has enabled warnings via the C<warnings> +warning to a calling module has enabled warnings via the C<warnings> pragma. Consider the module C<MyMod::Abc> below. @@ -361,11 +371,11 @@ Consider the module C<MyMod::Abc> below. 1 ; The call to C<warnings::register> will create a new warnings category -called "MyMod::abc", i.e. the new category name matches the module -name. The C<open> function in the module will display a warning message -if it gets given a relative path as a parameter. This warnings will only -be displayed if the code that uses C<MyMod::Abc> has actually enabled -them with the C<warnings> pragma like below. +called "MyMod::abc", i.e. the new category name matches the current +package name. The C<open> function in the module will display a warning +message if it gets given a relative path as a parameter. This warnings +will only be displayed if the code that uses C<MyMod::Abc> has actually +enabled them with the C<warnings> pragma like below. use MyMod::Abc; use warnings 'MyMod::Abc'; @@ -379,10 +389,8 @@ this snippet of code: package MyMod::Abc; sub open { - if (warnings::enabled("deprecated")) { - warnings::warn("deprecated", - "open is deprecated, use new instead") ; - } + warnings::warnif("deprecated", + "open is deprecated, use new instead") ; new(@_) ; } @@ -399,18 +407,89 @@ display a warning message whenever the calling module has (at least) the ... MyMod::Abc::open($filename) ; -The C<warnings::warn> function should be used to actually display the -warnings message. This is because they can make use of the feature that -allows warnings to be escalated into fatal errors. So in this case +Either the C<warnings::warn> or C<warnings::warnif> function should be +used to actually display the warnings message. This is because they can +make use of the feature that allows warnings to be escalated into fatal +errors. So in this case use MyMod::Abc; use warnings FATAL => 'MyMod::Abc'; ... MyMod::Abc::open('../fred.txt'); -the C<warnings::warn> function will detect this and die after +the C<warnings::warnif> function will detect this and die after displaying the warning message. +The three warnings functions, C<warnings::warn>, C<warnings::warnif> +and C<warnings::enabled> can optionally take an object reference in place +of a category name. In this case the functions will use the class name +of the object as the warnings category. + +Consider this example: + + package Original ; + + no warnings ; + use warnings::register ; + + sub new + { + my $class = shift ; + bless [], $class ; + } + + sub check + { + my $self = shift ; + my $value = shift ; + + if ($value % 2 && warnings::enabled($self)) + { warnings::warn($self, "Odd numbers are unsafe") } + } + + sub doit + { + my $self = shift ; + my $value = shift ; + $self->check($value) ; + # ... + } + + 1 ; + + package Derived ; + + use warnings::register ; + use Original ; + our @ISA = qw( Original ) ; + sub new + { + my $class = shift ; + bless [], $class ; + } + + + 1 ; + +The code below makes use of both modules, but it only enables warnings from +C<Derived>. + + use Original ; + use Derived ; + use warnings 'Derived'; + my $a = new Original ; + $a->doit(1) ; + my $b = new Derived ; + $a->doit(1) ; + +When this code is run only the C<Derived> object, C<$b>, will generate +a warning. + + Odd numbers are unsafe at main.pl line 7 + +Notice also that the warning is reported at the line where the object is first +used. + =head1 TODO perl5db.pl @@ -424,6 +503,8 @@ displaying the warning message. around the limitations of C<$^W>. Now that those limitations are gone, the module should be revisited. + document calling the warnings::* functions from XS + =head1 SEE ALSO L<warnings>, L<perldiag>. diff --git a/contrib/perl5/pod/perllocale.pod b/contrib/perl5/pod/perllocale.pod index be3738573cb8..9964b331c35c 100644 --- a/contrib/perl5/pod/perllocale.pod +++ b/contrib/perl5/pod/perllocale.pod @@ -124,8 +124,8 @@ B<The POSIX date formatting function> (strftime()) uses C<LC_TIME>. =back -C<LC_COLLATE>, C<LC_CTYPE>, and so on, are discussed further in L<LOCALE -CATEGORIES>. +C<LC_COLLATE>, C<LC_CTYPE>, and so on, are discussed further in +L<LOCALE CATEGORIES>. The default behavior is restored with the S<C<no locale>> pragma, or upon reaching the end of block enclosing C<use locale>. @@ -289,7 +289,7 @@ than the PERL_BADLANG approach, but setting LC_ALL (or other locale variables) may affect other programs as well, not just Perl. In particular, external programs run from within Perl will see these changes. If you make the new settings permanent (read on), all -programs you run see the changes. See L<ENVIRONMENT> for for +programs you run see the changes. See L<ENVIRONMENT> for the full list of relevant environment variables and L<USING LOCALES> for their effects in Perl. Effects in other programs are easily deducible. For example, the variable LC_COLLATE may well affect @@ -348,8 +348,8 @@ commands. You may see things like "en_US.ISO8859-1", but that isn't the same. In this case, try running under a locale that you can list and which somehow matches what you tried. The rules for matching locale names are a bit vague because -standardization is weak in this area. See again the L<Finding -locales> about general rules. +standardization is weak in this area. See again the +L<Finding locales> about general rules. =head2 Fixing system locale configuration @@ -381,7 +381,7 @@ with a single parameter--see L<The setlocale function>.) localeconv() takes no arguments, and returns B<a reference to> a hash. The keys of this hash are variable names for formatting, such as C<decimal_point> and C<thousands_sep>. The values are the -corresponding, er, values. See L<POSIX (3)/localeconv> for a longer +corresponding, er, values. See L<POSIX/localeconv> for a longer example listing the categories an implementation might be expected to provide; some provide more and others fewer. You don't need an explicit C<use locale>, because localeconv() always observes the @@ -445,21 +445,21 @@ The following collations all make sense and you may meet any of them if you "use locale". A B C D E a b c d e - A a B b C c D d D e + A a B b C c D d E e a A b B c C d D e E a b c d e A B C D E -Here is a code snippet to tell what alphanumeric +Here is a code snippet to tell what "word" characters are in the current locale, in that locale's order: use locale; - print +(sort grep /\w/, map { chr() } 0..255), "\n"; + print +(sort grep /\w/, map { chr } 0..255), "\n"; Compare this with the characters that you see and their order if you state explicitly that the locale should be ignored: no locale; - print +(sort grep /\w/, map { chr() } 0..255), "\n"; + print +(sort grep /\w/, map { chr } 0..255), "\n"; This machine-native collation (which is what you get unless S<C<use locale>> has appeared earlier in the same block) must be used for @@ -518,8 +518,9 @@ results, and so always obey the current C<LC_COLLATE> locale. In the scope of S<C<use locale>>, Perl obeys the C<LC_CTYPE> locale setting. This controls the application's notion of which characters are alphabetic. This affects Perl's C<\w> regular expression metanotation, -which stands for alphanumeric characters--that is, alphabetic and -numeric characters. (Consult L<perlre> for more information about +which stands for alphanumeric characters--that is, alphabetic, +numeric, and including other special characters such as the underscore or +hyphen. (Consult L<perlre> for more information about regular expressions.) Thanks to C<LC_CTYPE>, depending on your locale setting, characters like 'E<aelig>', 'E<eth>', 'E<szlig>', and 'E<oslash>' may be understood as C<\w> characters. @@ -553,20 +554,20 @@ change the character used for the decimal point--perhaps from '.' to ','. These functions aren't aware of such niceties as thousands separation and so on. (See L<The localeconv function> if you care about these things.) -Output produced by print() is B<never> affected by the -current locale: it is independent of whether C<use locale> or C<no -locale> is in effect, and corresponds to what you'd get from printf() -in the "C" locale. The same is true for Perl's internal conversions -between numeric and string formats: +Output produced by print() is also affected by the current locale: it +depends on whether C<use locale> or C<no locale> is in effect, and +corresponds to what you'd get from printf() in the "C" locale. The +same is true for Perl's internal conversions between numeric and +string formats: use POSIX qw(strtod); use locale; $n = 5/2; # Assign numeric 2.5 to $n - $a = " $n"; # Locale-independent conversion to string + $a = " $n"; # Locale-dependent conversion to string - print "half five is $n\n"; # Locale-independent output + print "half five is $n\n"; # Locale-dependent output printf "half five is %g\n", $n; # Locale-dependent output @@ -579,11 +580,12 @@ The C standard defines the C<LC_MONETARY> category, but no function that is affected by its contents. (Those with experience of standards committees will recognize that the working group decided to punt on the issue.) Consequently, Perl takes no notice of it. If you really want -to use C<LC_MONETARY>, you can query its contents--see L<The localeconv -function>--and use the information that it returns in your application's -own formatting of currency amounts. However, you may well find that -the information, voluminous and complex though it may be, still does not -quite meet your requirements: currency formatting is a hard nut to crack. +to use C<LC_MONETARY>, you can query its contents--see +L<The localeconv function>--and use the information that it returns in your +application's own formatting of currency amounts. However, you may well +find that the information, voluminous and complex though it may be, still +does not quite meet your requirements: currency formatting is a hard nut +to crack. =head2 LC_TIME @@ -641,15 +643,6 @@ case-mapping table is in effect. =item * -Some systems are broken in that they allow the "C" locale to be -overridden by users. If the decimal point character in the -C<LC_NUMERIC> category of the "C" locale is surreptitiously changed -from a dot to a comma, C<sprintf("%g", 0.123456e3)> produces a -string result of "123,456". Many people would interpret this as -one hundred and twenty-three thousand, four hundred and fifty-six. - -=item * - A sneaky C<LC_COLLATE> locale could result in the names of students with "D" grades appearing ahead of those with "A"s. @@ -685,16 +678,22 @@ the locale: =over 4 -=item B<Comparison operators> (C<lt>, C<le>, C<ge>, C<gt> and C<cmp>): +=item * + +B<Comparison operators> (C<lt>, C<le>, C<ge>, C<gt> and C<cmp>): Scalar true/false (or less/equal/greater) result is never tainted. -=item B<Case-mapping interpolation> (with C<\l>, C<\L>, C<\u> or C<\U>) +=item * + +B<Case-mapping interpolation> (with C<\l>, C<\L>, C<\u> or C<\U>) Result string containing interpolated material is tainted if C<use locale> is in effect. -=item B<Matching operator> (C<m//>): +=item * + +B<Matching operator> (C<m//>): Scalar true/false result never tainted. @@ -707,7 +706,9 @@ expression contains C<\w> (to match an alphanumeric character), C<\W> C<use locale> is in effect and the regular expression contains C<\w>, C<\W>, C<\s>, or C<\S>. -=item B<Substitution operator> (C<s///>): +=item * + +B<Substitution operator> (C<s///>): Has the same behavior as the match operator. Also, the left operand of C<=~> becomes tainted when C<use locale> in effect @@ -715,20 +716,30 @@ if modified as a result of a substitution based on a regular expression match involving C<\w>, C<\W>, C<\s>, or C<\S>; or of case-mapping with C<\l>, C<\L>,C<\u> or C<\U>. -=item B<Output formatting functions> (printf() and write()): +=item * -Success/failure result is never tainted. +B<Output formatting functions> (printf() and write()): -=item B<Case-mapping functions> (lc(), lcfirst(), uc(), ucfirst()): +Results are never tainted because otherwise even output from print, +for example C<print(1/7)>, should be tainted if C<use locale> is in +effect. + +=item * + +B<Case-mapping functions> (lc(), lcfirst(), uc(), ucfirst()): Results are tainted if C<use locale> is in effect. -=item B<POSIX locale-dependent functions> (localeconv(), strcoll(), +=item * + +B<POSIX locale-dependent functions> (localeconv(), strcoll(), strftime(), strxfrm()): Results are never tainted. -=item B<POSIX character class tests> (isalnum(), isalpha(), isdigit(), +=item * + +B<POSIX character class tests> (isalnum(), isalpha(), isdigit(), isgraph(), islower(), isprint(), ispunct(), isspace(), isupper(), isxdigit()): @@ -946,44 +957,19 @@ In certain systems, the operating system's locale support is broken and cannot be fixed or used by Perl. Such deficiencies can and will result in mysterious hangs and/or Perl core dumps when the C<use locale> is in effect. When confronted with such a system, -please report in excruciating detail to <F<perlbug@perl.com>>, and +please report in excruciating detail to <F<perlbug@perl.org>>, and complain to your vendor: bug fixes may exist for these problems in your operating system. Sometimes such bug fixes are called an operating system upgrade. =head1 SEE ALSO -L<POSIX (3)/isalnum> - -L<POSIX (3)/isalpha> - -L<POSIX (3)/isdigit> - -L<POSIX (3)/isgraph> - -L<POSIX (3)/islower> - -L<POSIX (3)/isprint>, - -L<POSIX (3)/ispunct> - -L<POSIX (3)/isspace> - -L<POSIX (3)/isupper>, - -L<POSIX (3)/isxdigit> - -L<POSIX (3)/localeconv> - -L<POSIX (3)/setlocale>, - -L<POSIX (3)/strcoll> - -L<POSIX (3)/strftime> - -L<POSIX (3)/strtod>, - -L<POSIX (3)/strxfrm> +L<POSIX/isalnum>, L<POSIX/isalpha>, L<POSIX/isdigit>, +L<POSIX/isgraph>, L<POSIX/islower>, L<POSIX/isprint>, +L<POSIX/ispunct>, L<POSIX/isspace>, L<POSIX/isupper>, +L<POSIX/isxdigit>, L<POSIX/localeconv>, L<POSIX/setlocale>, +L<POSIX/strcoll>, L<POSIX/strftime>, L<POSIX/strtod>, +L<POSIX/strxfrm>. =head1 HISTORY diff --git a/contrib/perl5/pod/perllol.pod b/contrib/perl5/pod/perllol.pod index f015a20bc4eb..5c16bfddff74 100644 --- a/contrib/perl5/pod/perllol.pod +++ b/contrib/perl5/pod/perllol.pod @@ -4,7 +4,7 @@ perllol - Manipulating Arrays of Arrays in Perl =head1 DESCRIPTION -=head1 Declaration and Access of Arrays of Arrays +=head2 Declaration and Access of Arrays of Arrays The simplest thing to build an array of arrays (sometimes imprecisely called a list of lists). It's reasonably easy to understand, and @@ -58,7 +58,7 @@ square or curly), you are free to omit the pointer dereferencing arrow. But you cannot do so for the very first one if it's a scalar containing a reference, which means that $ref_to_AoA always needs it. -=head1 Growing Your Own +=head2 Growing Your Own That's all well and good for declaration of a fixed data structure, but what if you wanted to add new elements on the fly, or build @@ -174,7 +174,7 @@ Notice that I I<couldn't> say just: In fact, that wouldn't even compile. How come? Because the argument to push() must be a real array, not just a reference to such. -=head1 Access and Printing +=head2 Access and Printing Now it's time to print your data structure out. How are you going to do that? Well, if you want only one @@ -231,7 +231,7 @@ Hmm... that's still a bit ugly. How about this: } } -=head1 Slices +=head2 Slices If you want to get at a slice (part of a row) in a multidimensional array, you're going to have to do some fancy subscripting. That's diff --git a/contrib/perl5/pod/perlmod.pod b/contrib/perl5/pod/perlmod.pod index 63324a41f45c..01056f1d98a1 100644 --- a/contrib/perl5/pod/perlmod.pod +++ b/contrib/perl5/pod/perlmod.pod @@ -8,7 +8,7 @@ perlmod - Perl modules (packages and symbol tables) Perl provides a mechanism for alternative namespaces to protect packages from stomping on each other's variables. In fact, there's -really no such thing as a global variable in Perl . The package +really no such thing as a global variable in Perl. The package statement declares the compilation unit as being in the given namespace. The scope of the package declaration is from the declaration itself through the end of the enclosing block, C<eval>, @@ -61,8 +61,8 @@ as a pattern match, a substitution, or a transliteration. Variables beginning with underscore used to be forced into package main, but we decided it was more useful for package writers to be able to use leading underscore to indicate private variables and method names. -$_ is still global though. See also L<perlvar/"Technical Note on the -Syntax of Variable Names">. +$_ is still global though. See also +L<perlvar/"Technical Note on the Syntax of Variable Names">. C<eval>ed strings are compiled in the package in which the eval() was compiled. (Assignments to C<$SIG{}>, however, assume the signal @@ -85,7 +85,7 @@ and L<perlref> regarding closures. The symbol table for a package happens to be stored in the hash of that name with two colons appended. The main symbol table's name is thus -C<%main::>, or C<%::> for short. Likewise symbol table for the nested +C<%main::>, or C<%::> for short. Likewise the symbol table for the nested package mentioned earlier is named C<%OUTER::INNER::>. The value in each entry of the hash is what you are referring to when you @@ -96,8 +96,14 @@ table lookups at compile time: local *main::foo = *main::bar; local $main::{foo} = $main::{bar}; +(Be sure to note the B<vast> difference between the second line above +and C<local $main::foo = $main::bar>. The former is accessing the hash +C<%main::>, which is the symbol table of package C<main>. The latter is +simply assigning scalar C<$bar> in package C<main> to scalar C<$foo> of +the same package.) + You can use this to print out all the variables in a package, for -instance. The standard but antequated F<dumpvar.pl> library and +instance. The standard but antiquated F<dumpvar.pl> library and the CPAN module Devel::Symdump make use of this. Assignment to a typeglob performs an aliasing operation, i.e., @@ -115,7 +121,7 @@ Which makes $richard and $dick the same variable, but leaves @richard and @dick as separate arrays. Tricky, eh? This mechanism may be used to pass and return cheap references -into or from subroutines if you won't want to copy the whole +into or from subroutines if you don't want to copy the whole thing. It only works when assigning to dynamic variables, not lexicals. @@ -132,18 +138,18 @@ lexicals. On return, the reference will overwrite the hash slot in the symbol table specified by the *some_hash typeglob. This is a somewhat tricky way of passing around references cheaply -when you won't want to have to remember to dereference variables +when you don't want to have to remember to dereference variables explicitly. Another use of symbol tables is for making "constant" scalars. *PI = \3.14159265358979; -Now you cannot alter $PI, which is probably a good thing all in all. +Now you cannot alter C<$PI>, which is probably a good thing all in all. This isn't the same as a constant subroutine, which is subject to -optimization at compile-time. This isn't. A constant subroutine is one -prototyped to take no arguments and to return a constant expression. -See L<perlsub> for details on these. The C<use constant> pragma is a +optimization at compile-time. A constant subroutine is one prototyped +to take no arguments and to return a constant expression. See +L<perlsub> for details on these. The C<use constant> pragma is a convenient shorthand for these. You can say C<*foo{PACKAGE}> and C<*foo{NAME}> to find out what name and @@ -163,7 +169,7 @@ This prints You gave me bar::baz The C<*foo{THING}> notation can also be used to obtain references to the -individual elements of *foo, see L<perlref>. +individual elements of *foo. See L<perlref>. Subroutine definitions (and declarations, for that matter) need not necessarily be situated in the package whose symbol table they @@ -233,7 +239,7 @@ being blown out of the water by a signal--you have to trap that yourself (if you can).) You may have multiple C<END> blocks within a file--they will execute in reverse order of definition; that is: last in, first out (LIFO). C<END> blocks are not executed when you run perl with the -C<-c> switch. +C<-c> switch, or if compilation fails. Inside an C<END> subroutine, C<$?> contains the value that the program is going to pass to C<exit()>. You can modify C<$?> to change the exit @@ -251,10 +257,10 @@ LIFO order. C<CHECK> blocks are again useful in the Perl compiler suite to save the compiled state of the program. When you use the B<-n> and B<-p> switches to Perl, C<BEGIN> and -C<END> work just as they do in B<awk>, as a degenerate case. As currently -implemented (and subject to change, since its inconvenient at best), -both C<BEGIN> and<END> blocks are run when you use the B<-c> switch -for a compile-only syntax check, although your main code is not. +C<END> work just as they do in B<awk>, as a degenerate case. +Both C<BEGIN> and C<CHECK> blocks are run when you use the B<-c> +switch for a compile-only syntax check, although your main code +is not. =head2 Perl Classes @@ -268,14 +274,14 @@ For more on this, see L<perltoot> and L<perlobj>. =head2 Perl Modules -A module is just a set of related function in a library file a Perl -package with the same name as the file. It is specifically designed -to be reusable by other modules or programs. It may do this by -providing a mechanism for exporting some of its symbols into the +A module is just a set of related functions in a library file, i.e., +a Perl package with the same name as the file. It is specifically +designed to be reusable by other modules or programs. It may do this +by providing a mechanism for exporting some of its symbols into the symbol table of any package using it. Or it may function as a class definition and make its semantics available implicitly through method calls on the class and its objects, without explicitly -exportating anything. Or it can do a little of both. +exporting anything. Or it can do a little of both. For example, to start a traditional, non-OO module called Some::Module, create a file called F<Some/Module.pm> and start with this template: @@ -304,6 +310,10 @@ create a file called F<Some/Module.pm> and start with this template: } our @EXPORT_OK; + # exported package globals go here + our $Var1; + our %Hashit; + # non-exported package globals go here our @more; our $stuff; @@ -419,19 +429,19 @@ that other module. In that case, it's easy to use C<require>s instead. Perl packages may be nested inside other package names, so we can have package names containing C<::>. But if we used that package name -directly as a filename it would makes for unwieldy or impossible +directly as a filename it would make for unwieldy or impossible filenames on some systems. Therefore, if a module's name is, say, C<Text::Soundex>, then its definition is actually found in the library file F<Text/Soundex.pm>. Perl modules always have a F<.pm> file, but there may also be dynamically linked executables (often ending in F<.so>) or autoloaded -subroutine definitions (often ending in F<.al> associated with the +subroutine definitions (often ending in F<.al>) associated with the module. If so, these will be entirely transparent to the user of the module. It is the responsibility of the F<.pm> file to load (or arrange to autoload) any additional functionality. For example, although the POSIX module happens to do both dynamic loading and -autoloading, but the user can say just C<use POSIX> to get it all. +autoloading, the user can say just C<use POSIX> to get it all. =head1 SEE ALSO diff --git a/contrib/perl5/pod/perlmodinstall.pod b/contrib/perl5/pod/perlmodinstall.pod index 19ffac98c9ca..0fc359e913d8 100644 --- a/contrib/perl5/pod/perlmodinstall.pod +++ b/contrib/perl5/pod/perlmodinstall.pod @@ -47,7 +47,7 @@ Makefile.PL PREFIX=/my/perl_directory> to install the modules into C</my/perl_directory>. Then you can use the modules from your Perl programs with C<use lib "/my/perl_directory/lib/site_perl"> or sometimes just C<use -"/my/perl_directory">. +"/my/perl_directory">. =over 4 @@ -55,16 +55,16 @@ from your Perl programs with C<use lib B<If you're on Unix,> -You can use Andreas Koenig's CPAN module +You can use Andreas Koenig's CPAN module (which comes standard with Perl, or can itself be downloaded -from http://www.perl.com/CPAN/modules/by-module/CPAN) +from http://www.perl.com/CPAN/modules/by-module/CPAN) to automate the following steps, from DECOMPRESS through INSTALL. -A. DECOMPRESS +A. DECOMPRESS Decompress the file with C<gzip -d yourmodule.tar.gz> -You can get gzip from ftp://prep.ai.mit.edu/pub/gnu. +You can get gzip from ftp://prep.ai.mit.edu/pub/gnu. Or, you can combine this step with the next to save disk space: @@ -126,13 +126,14 @@ CPAN for others to use. If it doesn't, go to INSTALL. D. INSTALL Copy the module into your Perl's I<lib> directory. That'll be one -of the directories you see when you type +of the directories you see when you type perl -e 'print "@INC"' =item * -B<If you're running Windows 95 or NT with the core Windows distribution of Perl,> +B<If you're running Windows 95 or NT with the core Windows distribution of +Perl,> A. DECOMPRESS @@ -185,63 +186,66 @@ B<If you're using a Macintosh,> A. DECOMPRESS -In general, all Macintosh decompression utilities mentioned here -can be found in the Info-Mac Hyperarchive -( http://hyperarchive.lcs.mit.edu/HyperArchive.html ). -Specificly the "Commpress & Translate" listing -( http://hyperarchive.lcs.mit.edu/HyperArchive/Abstracts/cmp/HyperArchive.html ). +First thing you should do is make sure you have the latest B<cpan-mac> +distribution ( http://www.cpan.org/authors/id/CNANDOR/ ), which has +utilities for doing all of the steps. Read the cpan-mac directions +carefully and install it. If you choose not to use cpan-mac +for some reason, there are alternatives listed here. +After installing cpan-mac, drop the module archive on the +B<untarzipme> droplet, which will decompress and unpack for you. -You can either use the shareware B<StuffIt Expander> program -( http://www.aladdinsys.com/expander/ ) -in combination with I<DropStuff with Expander Enhancer> -( http://www.aladdinsys.com/dropstuff/ ) +B<Or>, you can either use the shareware B<StuffIt Expander> program +( http://www.aladdinsys.com/expander/ ) +in combination with B<DropStuff with Expander Enhancer> +( http://www.aladdinsys.com/dropstuff/ ) or the freeware B<MacGzip> program ( http://persephone.cps.unizar.es/general/gente/spd/gzip/gzip.html ). - B. UNPACK -If you're using DropStuff or Stuffit, you can just extract the tar -archive. Otherwise, you can use the freeware B<suntar> or I<Tar> ( +If you're using untarzipme or StuffIt, the archive should be extracted +now. B<Or>, you can use the freeware B<suntar> or I<Tar> ( http://hyperarchive.lcs.mit.edu/HyperArchive/Archive/cmp/ ). C. BUILD -Does the module require compilation? - -1. If it does, +Check the contents of the distribution. +Read the module's documentation, looking for +reasons why you might have trouble using it with MacPerl. Look for +F<.xs> and F<.c> files, which normally denote that the distribution +must be compiled, and you cannot install it "out of the box." +(See L<"PORTABILITY">.) + +If a module does not work on MacPerl but should, or needs to be +compiled, see if the module exists already as a port on the +MacPerl Module Porters site (http://pudge.net/mmp/). +For more information on doing XS with MacPerl yourself, see +Arved Sandstrom's XS tutorial (http://macperl.com/depts/Tutorials/), +and then consider uploading your binary to the CPAN and +registering it on the MMP site. -Overview: You need MPW and a combination of new and old CodeWarrior -compilers for MPW and libraries. Makefiles created for building under -MPW use Metrowerks compilers. It's most likely possible to build -without other compilers, but it has not been done successfully, to our -knowledge. Read the documentation in I<MacPerl: Power and Ease> ( -http://www.ptf.com/macperl/ ) on porting/building extensions, or find -an existing precompiled binary, or hire someone to build it for you. +D. INSTALL -Or, ask someone on the mac-perl mailing list (mac-perl@iis.ee.ethz.ch) -to build it for you. To subscribe to the mac-perl mailing list, send -mail to mac-perl-request@iis.ee.ethz.ch. +If you are using cpan-mac, just drop the folder on the +B<installme> droplet, and use the module. -2. If the module doesn't require compilation, go to INSTALL. - -D. INSTALL +B<Or>, if you aren't using cpan-mac, do some manual labor. Make sure the newlines for the modules are in Mac format, not Unix format. If they are not then you might have decompressed them incorrectly. Check your decompression and unpacking utilities settings to make sure they are translating text files properly. -As a last resort, you can use the perl one-liner: +As a last resort, you can use the perl one-liner: - perl -i.bak -pe 's/(?:\015)?\012/\015/g' <filenames> + perl -i.bak -pe 's/(?:\015)?\012/\015/g' <filenames> on the source files. -Move the files manually into the correct folders. - -Move the files to their final destination: This will +Then move the files (probably just the F<.pm> files, though there +may be some additional ones, too; check the module documentation) +to their final destination: This will most likely be in C<$ENV{MACPERL}site_lib:> (i.e., C<HD:MacPerl folder:site_lib:>). You can add new paths to the default C<@INC> in the Preferences menu item in the @@ -251,16 +255,13 @@ automagically). Create whatever directory structures are required C<$ENV{MACPERL}site_lib:Some:> and put C<Module.pm> in that directory). -Run the following script (or something like it): +Then run the following script (or something like it): #!perl -w use AutoSplit; my $dir = "${MACPERL}site_perl"; autosplit("$dir:Some:Module.pm", "$dir:auto", 0, 1, 1); -Eventually there should be a way to automate the installation process; some -solutions exist, but none are ready for the general public yet. - =item * B<If you're on the DJGPP port of DOS,> @@ -268,7 +269,7 @@ B<If you're on the DJGPP port of DOS,> A. DECOMPRESS djtarx ( ftp://ftp.simtel.net/pub/simtelnet/gnu/djgpp/v2/ ) -will both uncompress and unpack. +will both uncompress and unpack. B. UNPACK @@ -289,7 +290,7 @@ in the Perl distribution. While still in that directory, type: - make install + make install You will need the packages mentioned in F<README.dos> in the Perl distribution. @@ -313,17 +314,17 @@ C<Your-Module-1_33.tgz>. A. DECOMPRESS -Type +Type gzip -d Your-Module.tgz -or, for zipped modules, type +or, for zipped modules, type unzip Your-Module.zip Executables for gzip, zip, and VMStar ( Alphas: http://www.openvms.digital.com/freeware/000TOOLS/ALPHA/ and Vaxen: -http://www.openvms.digital.com/freeware/000TOOLS/VAX/ ). +http://www.openvms.digital.com/freeware/000TOOLS/VAX/ ). gzip and tar are also available at ftp://ftp.digital.com/pub/VMS. @@ -342,10 +343,11 @@ Or, if you're fond of VMS command syntax: tar/extract/verbose Your_Module.tar -C. BUILD +C. BUILD -Make sure you have MMS (from Digital) or the freeware MMK ( available from MadGoat at http://www.madgoat.com ). Then type this to create the -DESCRIP.MMS for the module: +Make sure you have MMS (from Digital) or the freeware MMK ( available from +MadGoat at http://www.madgoat.com ). Then type this to create the +DESCRIP.MMS for the module: perl Makefile.PL @@ -358,7 +360,7 @@ Substitute C<mmk> for C<mms> above if you're using MMK. D. INSTALL -Type +Type mms install @@ -371,16 +373,16 @@ B<If you're on MVS>, Introduce the F<.tar.gz> file into an HFS as binary; don't translate from ASCII to EBCDIC. -A. DECOMPRESS +A. DECOMPRESS Decompress the file with C<gzip -d yourmodule.tar.gz> - You can get gzip from + You can get gzip from http://www.s390.ibm.com/products/oe/bpxqp1.html. B. UNPACK -Unpack the result with +Unpack the result with pax -o to=IBM-1047,from=ISO8859-1 -r < yourmodule.tar @@ -390,6 +392,52 @@ available from http://www.mks.com/s390/gnu/index.htm. =back + +=head1 PORTABILITY + +Note that not all modules will work with on all platforms. +See L<perlport> for more information on portability issues. +Read the documentation to see if the module will work on your +system. There are basically three categories +of modules that will not work "out of the box" with all +platforms (with some possibility of overlap): + +=over 4 + +=item * + +B<Those that should, but don't.> These need to be fixed; consider +contacting the author and possibly writing a patch. + +=item * + +B<Those that need to be compiled, where the target platform +doesn't have compilers readily available.> (These modules contain +F<.xs> or F<.c> files, usually.) You might be able to find +existing binaries on the CPAN or elsewhere, or you might +want to try getting compilers and building it yourself, and then +release the binary for other poor souls to use. + +=item * + +B<Those that are targeted at a specific platform.> +(Such as the Win32:: modules.) If the module is targeted +specifically at a platform other than yours, you're out +of luck, most likely. + +=back + + + +Check the CPAN Testers if a module should work with your platform +but it doesn't behave as you'd expect, or you aren't sure whether or +not a module will work under your platform. If the module you want +isn't listed there, you can test it yourself and let CPAN Testers know, +you can join CPAN Testers, or you can request it be tested. + + http://testers.cpan.org/ + + =head1 HEY If you have any suggested changes for this page, let me know. Please @@ -401,7 +449,7 @@ familiar with Perl on your operating system. =head1 AUTHOR -Jon Orwant +Jon Orwant orwant@tpj.com @@ -413,11 +461,13 @@ Nick Ing-Simmons, Tuomas J. Lukka, Laszlo Molnar, Chris Nandor, Alan Olsen, Peter Prymmer, Gurusamy Sarathy, Christoph Spalinger, Dan Sugalski, Larry Virden, and Ilya Zakharevich. -July 22, 1998 +First version July 22, 1998 + +Last Modified August 22, 2000 =head1 COPYRIGHT -Copyright (C) 1998 Jon Orwant. All Rights Reserved. +Copyright (C) 1998, 2000 Jon Orwant. All Rights Reserved. Permission is granted to make and distribute verbatim copies of this documentation provided the copyright notice and this permission notice are @@ -434,4 +484,3 @@ to this one. Permission is granted to copy and distribute translations of this documentation into another language, under the above conditions for modified versions. - diff --git a/contrib/perl5/pod/perlmodlib.pod b/contrib/perl5/pod/perlmodlib.pod index b42a2d881ca2..90bdb4395044 100644 --- a/contrib/perl5/pod/perlmodlib.pod +++ b/contrib/perl5/pod/perlmodlib.pod @@ -1,3 +1,5 @@ +# Generated by perlmodlib.PL DO NOT EDIT! + =head1 NAME perlmodlib - constructing new Perl modules and finding existing ones @@ -66,9 +68,9 @@ Establish IS-A relationship with base class at compile time Use MakeMaker's uninstalled version of a package -=item caller +=item bytes -Inherit pragmatic attributes from caller's context +Force byte semantics rather than character semantics =item charnames @@ -80,23 +82,23 @@ Declare constants =item diagnostics -Force verbose warning diagnostics +Perl compiler pragma to force verbose warning diagnostics =item fields -Declare a class's attribute fields at compile-time +Compile-time class fields =item filetest -Control the filetest operators like C<-r>, C<-w> for AFS, etc. +Control the filetest permission operators =item integer -Compute arithmetic in integer instead of double +Use integer arithmetic instead of floating point =item less -Request less of something from the compiler (unimplemented) +Request less of something from the compiler =item lib @@ -104,7 +106,11 @@ Manipulate @INC at compile time =item locale -Use or avoid POSIX locales for built-in operations +Use and avoid POSIX locales for built-in operations + +=item open + +Set default disciplines for input and output =item ops @@ -112,11 +118,11 @@ Restrict unsafe operations when compiling =item overload -Overload Perl operations +Package for overloading perl operations =item re -Alter regular expression behavior +Alter regular expression behaviour =item sigtrap @@ -128,20 +134,24 @@ Restrict unsafe constructs =item subs -Predeclare subroutine names +Predeclare sub names =item utf8 -Turn on UTF-8 and Unicode support +Enable/disable UTF-8 in source code =item vars -Predeclare global variable names (obsoleted by our()) +Predeclare global variable names (obsolete) =item warnings Control optional warnings +=item warnings::register + +Warnings import function + =back =head2 Standard Modules @@ -154,7 +164,7 @@ Exporter module. See their own documentation for details. =item AnyDBM_File -Provide framework for multiple DBM libraries +Provide framework for multiple DBMs =item AutoLoader @@ -166,7 +176,7 @@ Split a package for autoloading =item B -Guts of the Perl code generator (aka compiler) +The Perl Compiler =item B::Asmdata @@ -192,13 +202,17 @@ Perl compiler's C backend Perl compiler's optimized C translation backend +=item B::Concise + +Walk Perl syntax tree, printing concise info about ops + =item B::Debug Walk Perl syntax tree, printing debug info about ops =item B::Deparse -Perl compiler backend to produce Perl code +Perl compiler backend to produce perl code =item B::Disassembler @@ -206,7 +220,7 @@ Disassemble Perl bytecode =item B::Lint -Module to catch dubious constructs +Perl lint =item B::Showlex @@ -216,7 +230,9 @@ Show lexical variables used in functions or files Helper module for CC backend -B::Stash -- XXX NFI XXX +=item B::Stash + +Show what stashes are loaded =item B::Terse @@ -228,19 +244,19 @@ Generates cross reference reports for Perl programs =item Benchmark -Benchmark running times of code +Benchmark running times of Perl code =item ByteLoader -Load byte-compiled Perl code +Load byte compiled perl code =item CGI -Simple Common Gateway Interface class +Simple Common Gateway Interface Class =item CGI::Apache -Make things work with CGI.pm against Perl-Apache API +Backward compatibility module for CGI.pm =item CGI::Carp @@ -264,15 +280,19 @@ Simple Interface to Server Push =item CGI::Switch -Try more than one constructors and return the first object available +Backward compatibility module for defunct CGI::Switch + +=item CGI::Util + +Internal utilities used by CGI module =item CPAN -Query, download, and build Perl modules from CPAN sites +Query, download and build perl modules from CPAN sites =item CPAN::FirstTime -Utility for CPAN::Config file initialization +Utility for CPAN::Config file Initialization =item CPAN::Nox @@ -280,7 +300,7 @@ Wrapper around CPAN.pm without using any XS module =item Carp -Act like warn/die from perspective of caller +Warn of errors (from perspective of caller) =item Carp::Heavy @@ -290,34 +310,18 @@ Carp guts Declare struct-like datatypes as Perl classes -=item Config - -Access Perl configuration information - =item Cwd Get pathname of current working directory =item DB -Programmatic interface to the Perl debugging API (experimental) +Programmatic interface to the Perl debugging API (draft, subject to =item DB_File Perl5 access to Berkeley DB version 1.x -=item Data::Dumper - -Serialize Perl data structures - -=item Devel::DProf - -A Perl execution profiler - -=item Devel::Peek - -A data debugging tool for the XS programmer - =item Devel::SelfStubber Generate stubs for a SelfLoading module @@ -328,27 +332,19 @@ Supply object methods for directory handles =item Dumpvalue -Provide screen dump of Perl data - -=item DynaLoader - -Dynamically load C libraries into Perl code +Provides screen dump of Perl data. =item English -Use English (or awk) names for ugly punctuation variables +Use nice English (or awk) names for ugly punctuation variables =item Env -Access environment variables as regular ones - -=item Errno - -Load the libc errno.h defines +Perl module that imports environment variables as scalars or arrays =item Exporter -Implement default import method for modules +Implements default import method for modules =item Exporter::Heavy @@ -356,11 +352,11 @@ Exporter guts =item ExtUtils::Command -Utilities to replace common Unix commands in Makefiles etc. +Utilities to replace common UNIX commands in Makefiles etc. =item ExtUtils::Embed -Utilities for embedding Perl in C/C++ programs +Utilities for embedding Perl in C/C++ applications =item ExtUtils::Install @@ -376,11 +372,11 @@ Determine libraries to use and how to use them =item ExtUtils::MM_Cygwin -Methods to override Unix behavior in ExtUtils::MakeMaker +Methods to override UN*X behaviour in ExtUtils::MakeMaker =item ExtUtils::MM_OS2 -Methods to override Unix behavior in ExtUtils::MakeMaker +Methods to override UN*X behaviour in ExtUtils::MakeMaker =item ExtUtils::MM_Unix @@ -388,11 +384,11 @@ Methods used by ExtUtils::MakeMaker =item ExtUtils::MM_VMS -Methods to override Unix behavior in ExtUtils::MakeMaker +Methods to override UN*X behaviour in ExtUtils::MakeMaker =item ExtUtils::MM_Win32 -Methods to override Unix behavior in ExtUtils::MakeMaker +Methods to override UN*X behaviour in ExtUtils::MakeMaker =item ExtUtils::MakeMaker @@ -402,8 +398,6 @@ Create an extension Makefile Utilities to write and check a MANIFEST file -ExtUtils::Miniperl, writemain - Write the C code for perlmain.c - =item ExtUtils::Mkbootstrap Make a bootstrap file for use by DynaLoader @@ -426,7 +420,7 @@ Replace functions with equivalents which succeed or die =item Fcntl -Load the libc fcntl.h defines +Load the C Fcntl.h defines =item File::Basename @@ -446,24 +440,24 @@ Copy files or filehandles =item File::DosGlob -DOS-like globbing and then some +DOS like globbing and then some =item File::Find -Traverse a file tree - -=item File::Glob - -Perl extension for BSD filename globbing +Traverse a file tree =item File::Path -Create or remove a series of directories +Create or remove directory trees =item File::Spec Portably perform operations on file names +=item File::Spec::Epoc + +Methods for Epoc file specs + =item File::Spec::Functions Portably perform operations on file names @@ -488,6 +482,10 @@ Methods for VMS file specs Methods for Win32 file specs +=item File::Temp + +Return name and handle of a temporary file safely + =item File::stat By-name interface to Perl's built-in stat() functions @@ -502,11 +500,11 @@ Supply object methods for filehandles =item FindBin -Locate installation directory of running Perl program +Locate directory of original perl script =item GDBM_File -Access to the gdbm library +Perl5 access to the gdbm library. =item Getopt::Long @@ -518,55 +516,11 @@ Process single-character switches with switch clustering =item I18N::Collate -Compare 8-bit scalar data according to current locale +Compare 8-bit scalar data according to the current locale =item IO -Front-end to load various IO modules - -=item IO::Dir - -Supply object methods for directory handles - -=item IO::File - -Supply object methods for filehandles - -=item IO::Handle - -Supply object methods for I/O handles - -=item IO::Pipe - -Supply object methods for pipes - -=item IO::Poll - -Object interface to system poll call - -=item IO::Seekable - -Supply seek based methods for I/O objects - -=item IO::Select - -OO interface to the select system call - -=item IO::Socket - -Object interface to socket communications - -=item IO::Socket::INET - -Object interface for AF_INET domain sockets - -=item IO::Socket::UNIX - -Object interface for AF_UNIX domain sockets - -=item IPC::Msg - -SysV Msg IPC object class +Load various IO modules =item IPC::Open2 @@ -576,14 +530,6 @@ Open a process for both reading and writing Open a process for reading, writing, and error handling -=item IPC::Semaphore - -SysV Semaphore IPC object class - -=item IPC::SysV - -SysV IPC constants - =item Math::BigFloat Arbitrary length float math package @@ -626,7 +572,7 @@ Generic interface to Perl Compiler backends =item Opcode -Disable named opcodes when compiling Perl code +Disable named opcodes when compiling perl code =item POSIX @@ -636,22 +582,38 @@ Perl interface to IEEE Std 1003.1 Check pod documents for syntax errors +=item Pod::Find + +Find POD documents in directory trees + =item Pod::Html Module to convert pod files to HTML =item Pod::InputObjects -Manage POD objects +Objects representing POD input paragraphs, commands, etc. + +=item Pod::LaTeX + +Convert Pod data to formatted Latex =item Pod::Man Convert POD data to formatted *roff input +=item Pod::ParseUtils + +Helpers for POD parsing and conversion + =item Pod::Parser Base class for creating POD filters and translators +=item Pod::Plainer + +Perl extension for converting Pod to old style Pod. + =item Pod::Select Extract selected sections of POD from input @@ -664,6 +626,14 @@ Convert POD data to formatted ASCII text Convert POD data to formatted color ASCII text +=item Pod::Text::Overstrike + +Convert POD data to formatted overstrike text + +=item Pod::Text::Termcap + +Convert POD data to ASCII text with format escapes + =item Pod::Usage Print a usage message from embedded pod documentation @@ -690,35 +660,31 @@ Load functions only on demand =item Shell -Run shell commands transparently within Perl +Run shell commands transparently within perl =item Socket -Load the libc socket.h defines and structure manipulators +Load the C socket.h defines and structure manipulators =item Symbol Manipulate Perl symbols and their names -=item Sys::Hostname - -Try every conceivable way to get hostname +=item Term::ANSIColor -=item Sys::Syslog - -Interface to the libc syslog(3) calls +Color screen output using ANSI escape sequences =item Term::Cap -Termcap interface +Perl termcap interface =item Term::Complete -Word completion module +Perl word completion module =item Term::ReadLine -Interface to various `readline' packages. +Perl interface to various C<readline> packages. If =item Test @@ -726,7 +692,7 @@ Provides a simple framework for writing test scripts =item Test::Harness -Run Perl standard test scripts with statistics +Run perl standard test scripts with statistics =item Text::Abbrev @@ -734,18 +700,40 @@ Create an abbreviation table from a list =item Text::ParseWords -Parse text into a list of tokens or array of arrays +Parse text into an array of tokens or array of arrays =item Text::Soundex -Implementation of the Soundex Algorithm as described by Knuth +Implementation of the Soundex Algorithm as Described by Knuth + +=item Text::Tabs -Text::Tabs -- expand and unexpand tabs per expand(1) and unexpand(1) +Expand and unexpand tabs per the unix expand(1) and unexpand(1) =item Text::Wrap Line wrapping to form simple paragraphs +=item Thread + +Manipulate threads in Perl (EXPERIMENTAL, subject to change) + +=item Thread::Queue + +Thread-safe queues + +=item Thread::Semaphore + +Thread-safe semaphores + +=item Thread::Signal + +Start a thread which runs signal handlers reliably + +=item Thread::Specific + +Thread-specific keys + =item Tie::Array Base class for tied arrays @@ -798,26 +786,25 @@ By-name interface to Perl's built-in getgr*() functions By-name interface to Perl's built-in getpw*() functions +=item Win32 + +Interfaces to some Win32 API Functions + =back To find out I<all> modules installed on your system, including -those without documentation or outside the standard release, +those without documentation or outside the standard release, just do this: % find `perl -e 'print "@INC"'` -name '*.pm' -print -To get a log of all module distributions which have been installed -since perl was installed, just do: - - % perldoc perllocal - -Modules should all have their own documentation installed and accessible -via your system man(1) command, or via the C<perldoc> program. If you do -not have a B<find> +They should all have their own documentation installed and accessible +via your system man(1) command. If you do not have a B<find> program, you can use the Perl B<find2perl> program instead, which generates Perl code as output you can run through perl. If you have a B<man> program but it doesn't find your modules, you'll have -to fix your manpath. See L<perl> for details. +to fix your manpath. See L<perl> for details. If you have no +system B<man> command, you might try the B<perldoc> program. =head2 Extension Modules @@ -837,7 +824,7 @@ like Alta Vista or Deja News. CPAN stands for Comprehensive Perl Archive Network; it's a globally replicated trove of Perl materials, including documentation, style -guides, tricks and trap, alternate ports to non-Unix systems and +guides, tricks and traps, alternate ports to non-Unix systems and occasional binary distributions for these. Search engines for CPAN can be found at http://cpan.perl.com/ and at http://theory.uwinnipeg.ca/mod_perl/cpan-search.pl . @@ -849,66 +836,87 @@ modules are: =over =item * + Language Extensions and Documentation Tools =item * + Development Support =item * + Operating System Interfaces =item * + Networking, Device Control (modems) and InterProcess Communication =item * + Data Types and Data Type Utilities =item * + Database Interfaces =item * + User Interfaces =item * + Interfaces to / Emulations of Other Programming Languages =item * + File Names, File Systems and File Locking (see also File Handles) =item * + String Processing, Language Text Processing, Parsing, and Searching =item * + Option, Argument, Parameter, and Configuration File Processing =item * + Internationalization and Locale =item * + Authentication, Security, and Encryption =item * + World Wide Web, HTML, HTTP, CGI, MIME =item * + Server and Daemon Utilities =item * + Archiving and Compression =item * + Images, Pixmap and Bitmap Manipulation, Drawing, and Graphing =item * + Mail and Usenet News =item * + Control Flow Utilities (callbacks and exceptions etc) =item * + File Handle and Input/Output Stream Utilities =item * + Miscellaneous Modules =back @@ -916,172 +924,645 @@ Miscellaneous Modules Registered CPAN sites as of this writing include the following. You should try to choose one close to you: -=over +=head2 Africa + +=over 4 + +=item * -=item Africa - - South Africa ftp://ftp.is.co.za/programming/perl/CPAN/ - ftp://ftp.saix.net/pub/CPAN/ - ftp://ftp.sun.ac.za/CPAN/ - ftp://ftpza.co.za/pub/mirrors/cpan/ - - -=item Asia - - China ftp://freesoft.cei.gov.cn/pub/languages/perl/CPAN/ - Hong Kong ftp://ftp.pacific.net.hk/pub/mirror/CPAN/ - Indonesia ftp://malone.piksi.itb.ac.id/pub/CPAN/ - Israel ftp://bioinfo.weizmann.ac.il/pub/software/perl/CPAN/ - Japan ftp://ftp.dti.ad.jp/pub/lang/CPAN/ - ftp://ftp.jaist.ac.jp/pub/lang/perl/CPAN/ - ftp://ftp.lab.kdd.co.jp/lang/perl/CPAN/ - ftp://ftp.meisei-u.ac.jp/pub/CPAN/ - ftp://ftp.ring.gr.jp/pub/lang/perl/CPAN/ - ftp://mirror.nucba.ac.jp/mirror/Perl/ - Saudi-Arabia ftp://ftp.isu.net.sa/pub/CPAN/ - Singapore ftp://ftp.nus.edu.sg/pub/unix/perl/CPAN/ - South Korea ftp://ftp.bora.net/pub/CPAN/ - ftp://ftp.kornet.net/pub/CPAN/ - ftp://ftp.nuri.net/pub/CPAN/ - Taiwan ftp://coda.nctu.edu.tw/computer-languages/perl/CPAN/ - ftp://ftp.ee.ncku.edu.tw/pub3/perl/CPAN/ - ftp://ftp1.sinica.edu.tw/pub1/perl/CPAN/ - Thailand ftp://ftp.nectec.or.th/pub/mirrors/CPAN/ - - -=item Australasia - - Australia ftp://cpan.topend.com.au/pub/CPAN/ - ftp://ftp.labyrinth.net.au/pub/perl-CPAN/ - ftp://ftp.sage-au.org.au/pub/compilers/perl/CPAN/ - ftp://mirror.aarnet.edu.au/pub/perl/CPAN/ - New Zealand ftp://ftp.auckland.ac.nz/pub/perl/CPAN/ - ftp://sunsite.net.nz/pub/languages/perl/CPAN/ - - -=item Central America - - Costa Rica ftp://ftp.ucr.ac.cr/pub/Unix/CPAN/ - - -=item Europe - - Austria ftp://ftp.tuwien.ac.at/pub/languages/perl/CPAN/ - Belgium ftp://ftp.kulnet.kuleuven.ac.be/pub/mirror/CPAN/ - Bulgaria ftp://ftp.ntrl.net/pub/mirrors/CPAN/ - Croatia ftp://ftp.linux.hr/pub/CPAN/ - Czech Republic ftp://ftp.fi.muni.cz/pub/perl/ - ftp://sunsite.mff.cuni.cz/Languages/Perl/CPAN/ - Denmark ftp://sunsite.auc.dk/pub/languages/perl/CPAN/ - Estonia ftp://ftp.ut.ee/pub/languages/perl/CPAN/ - Finland ftp://ftp.funet.fi/pub/languages/perl/CPAN/ - France ftp://ftp.grolier.fr/pub/perl/CPAN/ - ftp://ftp.lip6.fr/pub/perl/CPAN/ - ftp://ftp.oleane.net/pub/mirrors/CPAN/ - ftp://ftp.pasteur.fr/pub/computing/CPAN/ - ftp://ftp.uvsq.fr/pub/perl/CPAN/ - German ftp://ftp.gigabell.net/pub/CPAN/ - Germany ftp://ftp.archive.de.uu.net/pub/CPAN/ - ftp://ftp.freenet.de/pub/ftp.cpan.org/pub/ - ftp://ftp.gmd.de/packages/CPAN/ - ftp://ftp.gwdg.de/pub/languages/perl/CPAN/ - ftp://ftp.leo.org/pub/comp/general/programming/languages/script/perl/CPAN/ - ftp://ftp.mpi-sb.mpg.de/pub/perl/CPAN/ - ftp://ftp.rz.ruhr-uni-bochum.de/pub/CPAN/ - ftp://ftp.uni-erlangen.de/pub/source/CPAN/ - ftp://ftp.uni-hamburg.de/pub/soft/lang/perl/CPAN/ - Germany ftp://ftp.archive.de.uu.net/pub/CPAN/ - ftp://ftp.freenet.de/pub/ftp.cpan.org/pub/ - ftp://ftp.gmd.de/packages/CPAN/ - ftp://ftp.gwdg.de/pub/languages/perl/CPAN/ - ftp://ftp.leo.org/pub/comp/general/programming/languages/script/perl/CPAN/ - ftp://ftp.mpi-sb.mpg.de/pub/perl/CPAN/ - ftp://ftp.rz.ruhr-uni-bochum.de/pub/CPAN/ - ftp://ftp.uni-erlangen.de/pub/source/CPAN/ - ftp://ftp.uni-hamburg.de/pub/soft/lang/perl/CPAN/ - Greece ftp://ftp.ntua.gr/pub/lang/perl/ - Hungary ftp://ftp.kfki.hu/pub/packages/perl/CPAN/ - Iceland ftp://ftp.gm.is/pub/CPAN/ - Ireland ftp://cpan.indigo.ie/pub/CPAN/ - ftp://sunsite.compapp.dcu.ie/pub/perl/ - Italy ftp://cis.uniRoma2.it/CPAN/ - ftp://ftp.flashnet.it/pub/CPAN/ - ftp://ftp.unina.it/pub/Other/CPAN/ - ftp://ftp.unipi.it/pub/mirror/perl/CPAN/ - Netherlands ftp://ftp.cs.uu.nl/mirror/CPAN/ - ftp://ftp.nluug.nl/pub/languages/perl/CPAN/ - Norway ftp://ftp.uit.no/pub/languages/perl/cpan/ - ftp://sunsite.uio.no/pub/languages/perl/CPAN/ - Poland ftp://ftp.man.torun.pl/pub/CPAN/ - ftp://ftp.pk.edu.pl/pub/lang/perl/CPAN/ - ftp://sunsite.icm.edu.pl/pub/CPAN/ - Portugal ftp://ftp.ci.uminho.pt/pub/mirrors/cpan/ - ftp://ftp.ist.utl.pt/pub/CPAN/ - ftp://ftp.ua.pt/pub/CPAN/ - Romania ftp://ftp.dnttm.ro/pub/CPAN/ - Russia ftp://ftp.chg.ru/pub/lang/perl/CPAN/ - ftp://ftp.sai.msu.su/pub/lang/perl/CPAN/ - Slovakia ftp://ftp.entry.sk/pub/languages/perl/CPAN/ - Slovenia ftp://ftp.arnes.si/software/perl/CPAN/ - Spain ftp://ftp.etse.urv.es/pub/perl/ - ftp://ftp.rediris.es/mirror/CPAN/ - Sweden ftp://ftp.sunet.se/pub/lang/perl/CPAN/ - Switzerland ftp://sunsite.cnlab-switch.ch/mirror/CPAN/ - Turkey ftp://sunsite.bilkent.edu.tr/pub/languages/CPAN/ - United Kingdom ftp://ftp.demon.co.uk/pub/mirrors/perl/CPAN/ - ftp://ftp.flirble.org/pub/languages/perl/CPAN/ - ftp://ftp.mirror.ac.uk/sites/ftp.funet.fi/pub/languages/perl/CPAN/ - ftp://ftp.plig.org/pub/CPAN/ - ftp://sunsite.doc.ic.ac.uk/packages/CPAN/ - - -=item North America - - Alberta ftp://sunsite.ualberta.ca/pub/Mirror/CPAN/ - California ftp://cpan.nas.nasa.gov/pub/perl/CPAN/ - ftp://cpan.valueclick.com/CPAN/ - ftp://ftp.cdrom.com/pub/perl/CPAN/ - http://download.sourceforge.net/mirrors/CPAN/ - Colorado ftp://ftp.cs.colorado.edu/pub/perl/CPAN/ - Florida ftp://ftp.cise.ufl.edu/pub/perl/CPAN/ - Georgia ftp://ftp.twoguys.org/CPAN/ - Illinois ftp://uiarchive.uiuc.edu/pub/lang/perl/CPAN/ - Indiana ftp://csociety-ftp.ecn.purdue.edu/pub/CPAN/ - ftp://ftp.uwsg.indiana.edu/pub/perl/CPAN/ - Kentucky ftp://ftp.uky.edu/CPAN/ - Manitoba ftp://theoryx5.uwinnipeg.ca/pub/CPAN/ - Massachusetts ftp://ftp.ccs.neu.edu/net/mirrors/ftp.funet.fi/pub/languages/perl/CPAN/ - ftp://ftp.iguide.com/pub/mirrors/packages/perl/CPAN/ - Mexico ftp://ftp.msg.com.mx/pub/CPAN/ - New York ftp://ftp.deao.net/pub/CPAN/ - ftp://ftp.rge.com/pub/languages/perl/ - North Carolina ftp://ftp.duke.edu/pub/perl/ - Nova Scotia ftp://cpan.chebucto.ns.ca/pub/CPAN/ - Oklahoma ftp://ftp.ou.edu/mirrors/CPAN/ - Ontario ftp://ftp.crc.ca/pub/packages/lang/perl/CPAN/ - Oregon ftp://ftp.orst.edu/pub/packages/CPAN/ - Pennsylvania ftp://ftp.epix.net/pub/languages/perl/ - Tennessee ftp://ftp.sunsite.utk.edu/pub/CPAN/ - Texas ftp://ftp.sedl.org/pub/mirrors/CPAN/ - ftp://jhcloos.com/pub/mirror/CPAN/ - Utah ftp://mirror.xmission.com/CPAN/ - Virginia ftp://ftp.perl.org/pub/perl/CPAN/ - ftp://ruff.cs.jmu.edu/pub/CPAN/ - Washington ftp://ftp-mirror.internap.com/pub/CPAN/ - ftp://ftp.llarian.net/pub/CPAN/ - ftp://ftp.spu.edu/pub/CPAN/ - - -=item South America - - Brazil ftp://cpan.if.usp.br/pub/mirror/CPAN/ - ftp://ftp.matrix.com.br/pub/perl/ - Chile ftp://sunsite.dcc.uchile.cl/pub/Lang/PERL/ +South Africa + + ftp://ftp.is.co.za/programming/perl/CPAN/ + ftp://ftp.saix.net/pub/CPAN/ + ftp://ftpza.co.za/pub/mirrors/cpan/ + ftp://ftp.sun.ac.za/CPAN/ + +=back + +=head2 Asia + +=over 4 + +=item * + +China + + ftp://freesoft.cei.gov.cn/pub/languages/perl/CPAN/ + http://www2.linuxforum.net/mirror/CPAN/ + http://cpan.shellhung.org/ + ftp://ftp.shellhung.org/pub/CPAN + +=item * + +Hong Kong + + http://CPAN.pacific.net.hk/ + ftp://ftp.pacific.net.hk/pub/mirror/CPAN/ + +=item * + +Indonesia + + http://piksi.itb.ac.id/CPAN/ + ftp://mirrors.piksi.itb.ac.id/CPAN/ + http://CPAN.mweb.co.id/ + ftp://ftp.mweb.co.id/pub/languages/perl/CPAN/ + +=item * + +Israel + + http://www.iglu.org.il:/pub/CPAN/ + ftp://ftp.iglu.org.il/pub/CPAN/ + http://bioinfo.weizmann.ac.il/pub/software/perl/CPAN/ + ftp://bioinfo.weizmann.ac.il/pub/software/perl/CPAN/ + +=item * + +Japan + + ftp://ftp.u-aizu.ac.jp/pub/lang/perl/CPAN/ + ftp://ftp.kddlabs.co.jp/CPAN/ + http://mirror.nucba.ac.jp/mirror/Perl/ + ftp://mirror.nucba.ac.jp/mirror/Perl/ + ftp://ftp.meisei-u.ac.jp/pub/CPAN/ + ftp://ftp.jaist.ac.jp/pub/lang/perl/CPAN/ + ftp://ftp.dti.ad.jp/pub/lang/CPAN/ + ftp://ftp.ring.gr.jp/pub/lang/perl/CPAN/ + +=item * + +Saudi Arabia + + ftp://ftp.isu.net.sa/pub/CPAN/ + +=item * + +Singapore + + http://cpan.hjc.edu.sg + http://ftp.nus.edu.sg/unix/perl/CPAN/ + ftp://ftp.nus.edu.sg/pub/unix/perl/CPAN/ + +=item * + +South Korea + + http://CPAN.bora.net/ + ftp://ftp.bora.net/pub/CPAN/ + http://ftp.kornet.net/CPAN/ + ftp://ftp.kornet.net/pub/CPAN/ + ftp://ftp.nuri.net/pub/CPAN/ + +=item * + +Taiwan + + ftp://coda.nctu.edu.tw/UNIX/perl/CPAN + ftp://ftp.ee.ncku.edu.tw/pub/perl/CPAN/ + ftp://ftp1.sinica.edu.tw/pub1/perl/CPAN/ + +=item * + +Thailand + + http://download.nectec.or.th/CPAN/ + ftp://ftp.nectec.or.th/pub/languages/CPAN/ + ftp://ftp.cs.riubon.ac.th/pub/mirrors/CPAN/ + +=back + +=head2 Central America + +=over 4 + +=item * + +Costa Rica + + ftp://ftp.linux.co.cr/mirrors/CPAN/ + http://ftp.ucr.ac.cr/Unix/CPAN/ + ftp://ftp.ucr.ac.cr/pub/Unix/CPAN/ + +=back + +=head2 Europe + +=over 4 + +=item * + +Austria + + ftp://ftp.tuwien.ac.at/pub/languages/perl/CPAN/ + +=item * + +Belgium + + http://ftp.easynet.be/CPAN/ + ftp://ftp.easynet.be/CPAN/ + ftp://ftp.kulnet.kuleuven.ac.be/pub/mirror/CPAN/ + +=item * + +Bulgaria + + ftp://ftp.ntrl.net/pub/mirrors/CPAN/ + +=item * + +Croatia + + ftp://ftp.linux.hr/pub/CPAN/ + +=item * + +Czech Republic + + http://www.fi.muni.cz/pub/perl/ + ftp://ftp.fi.muni.cz/pub/perl/ + ftp://sunsite.mff.cuni.cz/MIRRORS/ftp.funet.fi/pub/languages/perl/CPAN/ + +=item * + +Denmark + + ftp://sunsite.auc.dk/pub/languages/perl/CPAN/ + http://www.cpan.dk/CPAN/ + ftp://www.cpan.dk/ftp.cpan.org/CPAN/ + +=item * + +England + + http://www.mirror.ac.uk/sites/ftp.funet.fi/pub/languages/perl/CPAN + ftp://ftp.mirror.ac.uk/sites/ftp.funet.fi/pub/languages/perl/CPAN/ + ftp://ftp.demon.co.uk/pub/mirrors/perl/CPAN/ + ftp://ftp.flirble.org/pub/languages/perl/CPAN/ + ftp://ftp.plig.org/pub/CPAN/ + ftp://sunsite.doc.ic.ac.uk/packages/CPAN/ + http://mirror.uklinux.net/CPAN/ + ftp://mirror.uklinux.net/pub/CPAN/ + ftp://usit.shef.ac.uk/pub/packages/CPAN/ + +=item * + +Estonia + + ftp://ftp.ut.ee/pub/languages/perl/CPAN/ + +=item * + +Finland + + ftp://ftp.funet.fi/pub/languages/perl/CPAN/ + +=item * + +France + + ftp://cpan.ftp.worldonline.fr/pub/CPAN/ + ftp://ftp.club-internet.fr/pub/perl/CPAN/ + ftp://ftp.lip6.fr/pub/perl/CPAN/ + ftp://ftp.oleane.net/pub/mirrors/CPAN/ + ftp://ftp.pasteur.fr/pub/computing/CPAN/ + ftp://cpan.cict.fr/pub/CPAN/ + ftp://ftp.uvsq.fr/pub/perl/CPAN/ + +=item * + +Germany + + ftp://ftp.rz.ruhr-uni-bochum.de/pub/CPAN/ + ftp://ftp.freenet.de/pub/ftp.cpan.org/pub/CPAN/ + ftp://ftp.uni-erlangen.de/pub/source/CPAN/ + ftp://ftp-stud.fht-esslingen.de/pub/Mirrors/CPAN + ftp://ftp.gigabell.net/pub/CPAN/ + http://ftp.gwdg.de/pub/languages/perl/CPAN/ + ftp://ftp.gwdg.de/pub/languages/perl/CPAN/ + ftp://ftp.uni-hamburg.de/pub/soft/lang/perl/CPAN/ + ftp://ftp.leo.org/pub/comp/general/programming/languages/script/perl/CPAN/ + ftp://ftp.mpi-sb.mpg.de/pub/perl/CPAN/ + ftp://ftp.gmd.de/mirrors/CPAN/ + +=item * + +Greece + + ftp://ftp.forthnet.gr/pub/languages/perl/CPAN + ftp://ftp.ntua.gr/pub/lang/perl/ + +=item * + +Hungary + + http://cpan.artifact.hu/ + ftp://cpan.artifact.hu/CPAN/ + ftp://ftp.kfki.hu/pub/packages/perl/CPAN/ + +=item * + +Iceland + + http://cpan.gm.is/ + ftp://ftp.gm.is/pub/CPAN/ + +=item * + +Ireland + + http://cpan.indigo.ie/ + ftp://cpan.indigo.ie/pub/CPAN/ + http://sunsite.compapp.dcu.ie/pub/perl/ + ftp://sunsite.compapp.dcu.ie/pub/perl/ + +=item * + +Italy + + http://cpan.nettuno.it/ + http://gusp.dyndns.org/CPAN/ + ftp://gusp.dyndns.org/pub/CPAN + http://softcity.iol.it/cpan + ftp://softcity.iol.it/pub/cpan + ftp://ftp.unina.it/pub/Other/CPAN/ + ftp://ftp.unipi.it/pub/mirror/perl/CPAN/ + ftp://cis.uniRoma2.it/CPAN/ + ftp://ftp.edisontel.it/pub/CPAN_Mirror/ + ftp://ftp.flashnet.it/pub/CPAN/ + +=item * + +Latvia + + http://kvin.lv/pub/CPAN/ + +=item * + +Netherlands + + ftp://download.xs4all.nl/pub/mirror/CPAN/ + ftp://ftp.nl.uu.net/pub/CPAN/ + ftp://ftp.nluug.nl/pub/languages/perl/CPAN/ + ftp://ftp.cpan.nl/pub/CPAN/ + http://www.cs.uu.nl/mirror/CPAN/ + ftp://ftp.cs.uu.nl/mirror/CPAN/ + +=item * + +Norway + + ftp://sunsite.uio.no/pub/languages/perl/CPAN/ + ftp://ftp.uit.no/pub/languages/perl/cpan/ + +=item * + +Poland + + ftp://ftp.pk.edu.pl/pub/lang/perl/CPAN/ + ftp://ftp.mega.net.pl/pub/mirrors/ftp.perl.com/ + ftp://ftp.man.torun.pl/pub/doc/CPAN/ + ftp://sunsite.icm.edu.pl/pub/CPAN/ + +=item * + +Portugal + + ftp://ftp.ua.pt/pub/CPAN/ + ftp://perl.di.uminho.pt/pub/CPAN/ + ftp://ftp.ist.utl.pt/pub/CPAN/ + ftp://ftp.netc.pt/pub/CPAN/ + +=item * + +Romania + + ftp://archive.logicnet.ro/mirrors/ftp.cpan.org/CPAN/ + ftp://ftp.kappa.ro/pub/mirrors/ftp.perl.org/pub/CPAN/ + ftp://ftp.dntis.ro/pub/cpan/ + ftp://ftp.opsynet.com/cpan/ + ftp://ftp.dnttm.ro/pub/CPAN/ + ftp://ftp.timisoara.roedu.net/mirrors/CPAN/ + +=item * + +Russia + + ftp://ftp.chg.ru/pub/lang/perl/CPAN/ + http://cpan.rinet.ru/ + ftp://cpan.rinet.ru/pub/mirror/CPAN/ + ftp://ftp.aha.ru/pub/CPAN/ + ftp://ftp.sai.msu.su/pub/lang/perl/CPAN/ + +=item * + +Slovakia + + ftp://ftp.entry.sk/pub/languages/perl/CPAN/ + +=item * + +Slovenia + + ftp://ftp.arnes.si/software/perl/CPAN/ + +=item * + +Spain + + ftp://ftp.rediris.es/mirror/CPAN/ + ftp://ftp.etse.urv.es/pub/perl/ + +=item * + +Sweden + + http://ftp.du.se/CPAN/ + ftp://ftp.du.se/pub/CPAN/ + ftp://ftp.sunet.se/pub/lang/perl/CPAN/ + +=item * + +Switzerland + + ftp://ftp.danyk.ch/CPAN/ + ftp://sunsite.cnlab-switch.ch/mirror/CPAN/ + +=item * + +Turkey + + ftp://sunsite.bilkent.edu.tr/pub/languages/CPAN/ + +=back + +=head2 North America + +=over 4 + +=item * + +Canada + +=over 8 + +=item * + +Alberta + + http://sunsite.ualberta.ca/pub/Mirror/CPAN/ + ftp://sunsite.ualberta.ca/pub/Mirror/CPAN/ + +=item * + +Manitoba + + http://theoryx5.uwinnipeg.ca/pub/CPAN/ + ftp://theoryx5.uwinnipeg.ca/pub/CPAN/ + +=item * + +Nova Scotia + + ftp://cpan.chebucto.ns.ca/pub/CPAN/ + +=item * + +Ontario + + ftp://ftp.crc.ca/pub/packages/lang/perl/CPAN/ + +=item * + +Mexico + + http://www.msg.com.mx/CPAN/ + ftp://ftp.msg.com.mx/pub/CPAN/ + +=back + +=item * + +United States + +=over 8 + +=item * + +Alabama + + http://mirror.hiwaay.net/CPAN/ + ftp://mirror.hiwaay.net/CPAN/ + +=item * + +California + + http://www.cpan.org/ + ftp://ftp.cpan.org/CPAN/ + ftp://cpan.nas.nasa.gov/pub/perl/CPAN/ + ftp://ftp.digital.com/pub/plan/perl/CPAN/ + http://www.kernel.org/pub/mirrors/cpan/ + ftp://ftp.kernel.org/pub/mirrors/cpan/ + http://www.perl.com/CPAN/ + http://download.sourceforge.net/mirrors/CPAN/ + +=item * + +Colorado + + ftp://ftp.cs.colorado.edu/pub/perl/CPAN/ + +=item * + +Florida + + ftp://ftp.cise.ufl.edu/pub/perl/CPAN/ + +=item * + +Georgia + + ftp://ftp.twoguys.org/CPAN/ + +=item * + +Illinois + + http://www.neurogames.com/mirrors/CPAN + http://uiarchive.uiuc.edu/mirrors/ftp/ftp.cpan.org/pub/CPAN/ + ftp://uiarchive.uiuc.edu/mirrors/ftp/ftp.cpan.org/pub/CPAN/ + +=item * + +Indiana + + ftp://ftp.uwsg.indiana.edu/pub/perl/CPAN/ + http://cpan.nitco.com/ + ftp://cpan.nitco.com/pub/CPAN/ + ftp://cpan.in-span.net/ + http://csociety-ftp.ecn.purdue.edu/pub/CPAN + ftp://csociety-ftp.ecn.purdue.edu/pub/CPAN + +=item * + +Kentucky + + http://cpan.uky.edu/ + ftp://cpan.uky.edu/pub/CPAN/ + +=item * + +Massachusetts + + ftp://ftp.ccs.neu.edu/net/mirrors/ftp.funet.fi/pub/languages/perl/CPAN/ + ftp://ftp.iguide.com/pub/mirrors/packages/perl/CPAN/ + +=item * + +New Jersey + + ftp://ftp.cpanel.net/pub/CPAN/ + +=item * + +New York + + ftp://ftp.freesoftware.com/pub/perl/CPAN/ + http://www.deao.net/mirrors/CPAN/ + ftp://ftp.deao.net/pub/CPAN/ + ftp://ftp.stealth.net/pub/mirrors/ftp.cpan.org/pub/CPAN/ + http://mirror.nyc.anidea.com/CPAN/ + ftp://mirror.nyc.anidea.com/pub/CPAN/ + http://www.rge.com/pub/languages/perl/ + ftp://ftp.rge.com/pub/languages/perl/ + ftp://mirrors.cloud9.net/pub/mirrors/CPAN/ + +=item * + +North Carolina + + ftp://ftp.duke.edu/pub/perl/ + +=item * + +Ohio + + ftp://ftp.loaded.net/pub/CPAN/ + +=item * + +Oklahoma + + ftp://ftp.ou.edu/mirrors/CPAN/ + +=item * + +Oregon + + ftp://ftp.orst.edu/pub/packages/CPAN/ + +=item * + +Pennsylvania + + http://ftp.epix.net/CPAN/ + ftp://ftp.epix.net/pub/languages/perl/ + ftp://carroll.cac.psu.edu/pub/CPAN/ + +=item * + +Tennessee + + ftp://ftp.sunsite.utk.edu/pub/CPAN/ + +=item * + +Texas + + http://ftp.sedl.org/pub/mirrors/CPAN/ + http://jhcloos.com/pub/mirror/CPAN/ + ftp://jhcloos.com/pub/mirror/CPAN/ + +=item * + +Utah + + ftp://mirror.xmission.com/CPAN/ + +=item * + +Virginia + + http://mirrors.rcn.net/pub/lang/CPAN/ + ftp://mirrors.rcn.net/pub/lang/CPAN/ + ftp://ruff.cs.jmu.edu/pub/CPAN/ + http://perl.Liquidation.com/CPAN/ + +=item * + +Washington + + http://cpan.llarian.net/ + ftp://cpan.llarian.net/pub/CPAN/ + ftp://ftp-mirror.internap.com/pub/CPAN/ + ftp://ftp.spu.edu/pub/CPAN/ + +=back + +=back + +=head2 Oceania + +=over 4 + +=item * + +Australia + + http://ftp.planetmirror.com/pub/CPAN/ + ftp://ftp.planetmirror.com/pub/CPAN/ + ftp://mirror.aarnet.edu.au/pub/perl/CPAN/ + ftp://cpan.topend.com.au/pub/CPAN/ + +=item * + +New Zealand + + ftp://ftp.auckland.ac.nz/pub/perl/CPAN/ + +=back + +=head2 South America + +=over 4 + +=item * + +Argentina + + ftp://mirrors.bannerlandia.com.ar/mirrors/CPAN/ + +=item * + +Brazil + + ftp://cpan.pop-mg.com.br/pub/CPAN/ + ftp://ftp.matrix.com.br/pub/perl/ + ftp://cpan.if.usp.br/pub/mirror/CPAN/ + +=item * + +Chile + + ftp://ftp.psinet.cl/pub/programming/perl/CPAN/ + ftp://sunsite.dcc.uchile.cl/pub/lang/perl/ =back For an up-to-date listing of CPAN sites, -see http://www.perl.com/perl/CPAN/SITES or ftp://www.perl.com/CPAN/SITES . +see http://www.cpan.org/SITES or ftp://www.cpan.org/SITES . =head1 Modules: Creation, Use, and Abuse @@ -1102,14 +1583,16 @@ its methods by loading dynamic C or C++ objects, but that should be totally transparent to the user of the module. Likewise, the module might set up an AUTOLOAD function to slurp in subroutine definitions on demand, but this is also transparent. Only the F<.pm> file is required to -exist. See L<perlsub>, L<perltoot>, and L<AutoLoader> for details about +exist. See L<perlsub>, L<perltoot>, and L<AutoLoader> for details about the AUTOLOAD mechanism. =head2 Guidelines for Module Creation =over 4 -=item Do similar modules already exist in some form? +=item * + +Do similar modules already exist in some form? If so, please try to reuse the existing modules either in whole or by inheriting useful features into a new class. If this is not @@ -1123,28 +1606,30 @@ modules, please coordinate with the author of the package. It helps if you follow the same naming scheme and module interaction scheme as the original author. -=item Try to design the new module to be easy to extend and reuse. +=item * + +Try to design the new module to be easy to extend and reuse. Try to C<use warnings;> (or C<use warnings qw(...);>). Remember that you can add C<no warnings qw(...);> to individual blocks -of code that need less warnings. +of code that need less warnings. Use blessed references. Use the two argument form of bless to bless into the class name given as the first parameter of the constructor, e.g.,: sub new { - my $class = shift; - return bless {}, $class; + my $class = shift; + return bless {}, $class; } or even this if you'd like it to be used as either a static or a virtual method. sub new { - my $self = shift; - my $class = ref($self) || $self; - return bless {}, $class; + my $self = shift; + my $class = ref($self) || $self; + return bless {}, $class; } Pass arrays as references so more parameters can be added later @@ -1176,19 +1661,21 @@ Avoid keeping any state information in your packages. It makes it difficult for multiple other packages to use yours. Keep state information in objects. -Always use B<-w>. +Always use B<-w>. Try to C<use strict;> (or C<use strict qw(...);>). Remember that you can add C<no strict qw(...);> to individual blocks -of code that need less strictness. +of code that need less strictness. -Always use B<-w>. +Always use B<-w>. Follow the guidelines in the perlstyle(1) manual. Always use B<-w>. -=item Some simple style guidelines +=item * + +Some simple style guidelines The perlstyle manual supplied with Perl has many helpful points. @@ -1220,7 +1707,9 @@ e.g., C<< $obj->as_string() >>. You can use a leading underscore to indicate that a variable or function should not be used outside the package that defined it. -=item Select what to export. +=item * + +Select what to export. Do NOT export method names! @@ -1244,7 +1733,9 @@ As a general rule, if the module is trying to be object oriented then export nothing. If it's just a collection of functions then @EXPORT_OK anything but use @EXPORT with caution. -=item Select a name for the module. +=item * + +Select a name for the module. This name should be as descriptive, accurate, and complete as possible. Avoid any risk of ambiguity. Always try to use two or @@ -1268,11 +1759,19 @@ If adding a new module to a set, follow the original author's standards for naming modules and the interface to methods in those modules. +If developing modules for private internal or project specific use, +that will never be released to the public, then you should ensure +that their names will not clash with any future public module. You +can do this either by using the reserved Local::* category or by +using a category name that includes an underscore like Foo_Corp::*. + To be portable each component of a module name should be limited to 11 characters. If it might be used on MS-DOS then try to ensure each is unique in the first 8 characters. Nested modules make this easier. -=item Have you got it right? +=item * + +Have you got it right? How do you know that you've made the right decisions? Have you picked an interface design that will cause problems later? Have @@ -1291,7 +1790,9 @@ Don't worry about posting if you can't say when the module will be ready - just say so in the message. It might be worth inviting others to help you, they may be able to complete it for you! -=item README and other Additional Files. +=item * + +README and other Additional Files. It's well known that software developers usually fully document the software they write. If, however, the world is in urgent need of @@ -1301,24 +1802,31 @@ documentation please at least provide a README file containing: =over 10 =item * + A description of the module/package/extension etc. =item * + A copyright notice - see below. =item * + Prerequisites - what else you may need to have. =item * + How to build it - possible changes to Makefile.PL etc. =item * + How to install it. =item * + Recent changes in this release, especially incompatibilities =item * + Changes / enhancements you plan to make in the future. =back @@ -1331,6 +1839,7 @@ Copying, ToDo etc. =item Adding a Copyright Notice. + How you choose to license your work is a personal decision. The general mechanism is to assert your Copyright and then make a declaration of how others may copy/use/modify your work. @@ -1350,7 +1859,9 @@ This statement should at least appear in the README file. You may also wish to include it in a Copying file and your source files. Remember to include the other words in addition to the Copyright. -=item Give the module a version/issue/release number. +=item * + +Give the module a version/issue/release number. To be fully compatible with the Exporter and MakeMaker modules you should store your module's version number in a non-my package @@ -1364,14 +1875,16 @@ Use the number in announcements and archive file names when releasing the module (ModuleName-1.02.tar.Z). See perldoc ExtUtils::MakeMaker.pm for details. -=item How to release and distribute a module. +=item * + +How to release and distribute a module. It's good idea to post an announcement of the availability of your module (or the module itself if small) to the comp.lang.perl.announce Usenet newsgroup. This will at least ensure very wide once-off distribution. -If possible, register the module with CPAN. You should +If possible, register the module with CPAN. You should include details of its location in your announcement. Some notes about ftp archives: Please use a long descriptive file @@ -1387,8 +1900,8 @@ FTP Archives for Perl Modules: Follow the instructions and links on: - http://www.perl.com/CPAN/modules/00modlist.long.html - http://www.perl.com/CPAN/modules/04pause.html + http://www.cpan.org/modules/00modlist.long.html + http://www.cpan.org/modules/04pause.html or upload to one of these sites: @@ -1403,7 +1916,9 @@ CPAN! Please remember to send me an updated entry for the Module list! -=item Take care when changing a released module. +=item * + +Take care when changing a released module. Always strive to remain compatible with previous released versions. Otherwise try to add a mechanism to revert to the @@ -1417,26 +1932,34 @@ old behavior if people rely on it. Document incompatible changes. =over 4 -=item There is no requirement to convert anything. +=item * + +There is no requirement to convert anything. If it ain't broke, don't fix it! Perl 4 library scripts should continue to work with no problems. You may need to make some minor changes (like escaping non-array @'s in double quoted strings) but there is no need to convert a .pl file into a Module for just that. -=item Consider the implications. +=item * + +Consider the implications. All Perl applications that make use of the script will need to be changed (slightly) if the script is converted into a module. Is it worth it unless you plan to make other changes at the same time? -=item Make the most of the opportunity. +=item * + +Make the most of the opportunity. If you are going to convert the script to a module you can use the opportunity to redesign the interface. The guidelines for module creation above include many of the issues you should consider. -=item The pl2pm utility will get you started. +=item * + +The pl2pm utility will get you started. This utility will read *.pl files (given as parameters) and write corresponding *.pm files. The pl2pm utilities does the following: @@ -1444,15 +1967,19 @@ corresponding *.pm files. The pl2pm utilities does the following: =over 10 =item * + Adds the standard Module prologue lines =item * + Converts package specifiers from ' to :: =item * + Converts die(...) to croak(...) =item * + Several other minor changes =back @@ -1467,18 +1994,28 @@ Don't delete the original .pl file till the new .pm one works! =over 4 -=item Complete applications rarely belong in the Perl Module Library. +=item * + +Complete applications rarely belong in the Perl Module Library. + +=item * -=item Many applications contain some Perl code that could be reused. +Many applications contain some Perl code that could be reused. Help save the world! Share your code in a form that makes it easy to reuse. -=item Break-out the reusable code into one or more separate module files. +=item * + +Break-out the reusable code into one or more separate module files. + +=item * + +Take the opportunity to reconsider and redesign the interfaces. -=item Take the opportunity to reconsider and redesign the interfaces. +=item * -=item In some cases the 'application' can then be reduced to a small +In some cases the 'application' can then be reduced to a small fragment of code built on top of the reusable modules. In these cases the application could invoked as: diff --git a/contrib/perl5/pod/perlnumber.pod b/contrib/perl5/pod/perlnumber.pod index c83e053203d5..44d921cfe633 100644 --- a/contrib/perl5/pod/perlnumber.pod +++ b/contrib/perl5/pod/perlnumber.pod @@ -39,7 +39,7 @@ the maximal and the minimal supported true integral quantities are close to powers of 2. However, "native" floats have a most fundamental restriction: they may represent only those numbers which have a relatively "short" representation when converted to a binary fraction. For example, -0.9 cannot be respresented by a native float, since the binary fraction +0.9 cannot be represented by a native float, since the binary fraction for 0.9 is infinite: binary0.1110011001100... @@ -59,7 +59,7 @@ finite decimal expansion. Being strings, and thus of arbitrary length, there is no practical limit for the exponent or number of decimal digits for these numbers. (But realize that what we are discussing the rules for just the I<storage> of these numbers. The fact that you can store such "large" numbers -does not mean that that the I<operations> over these numbers will use all +does not mean that the I<operations> over these numbers will use all of the significant digits. See L<"Numeric operators and numeric conversions"> for details.) @@ -91,7 +91,7 @@ Six such conversions are possible: These conversions are governed by the following general rules: -=over +=over 4 =item * @@ -141,7 +141,7 @@ argument as in modular arithmetic, e.g., C<mod 2**32> on a 32-bit architecture. C<sprintf "%u", -1> therefore provides the same result as C<sprintf "%u", ~0>. -=over +=over 4 =item Arithmetic operators except, C<no integer> diff --git a/contrib/perl5/pod/perlobj.pod b/contrib/perl5/pod/perlobj.pod index 4e45aff7c6a4..285ed9975eda 100644 --- a/contrib/perl5/pod/perlobj.pod +++ b/contrib/perl5/pod/perlobj.pod @@ -168,6 +168,12 @@ the method that was intended to be called. If none of that works, Perl finally gives up and complains. +If you want to stop the AUTOLOAD inheritance say simply + + sub AUTOLOAD; + +and the call will die using the name of the sub being called. + Perl classes do method inheritance only. Data inheritance is left up to the class itself. By and large, this is not a problem in Perl, because most classes model the attributes of their object using an @@ -553,8 +559,8 @@ breaks the circularities in the self-referential structure. =head1 SEE ALSO -A kinder, gentler tutorial on object-oriented programming in Perl -can be found in L<perltoot> and L<perltootc>. You should also check -out L<perlbot> for other object tricks, traps, and tips, as well -as L<perlmodlib> for some style guides on constructing both modules -and classes. +A kinder, gentler tutorial on object-oriented programming in Perl can +be found in L<perltoot>, L<perlbootc> and L<perltootc>. You should +also check out L<perlbot> for other object tricks, traps, and tips, as +well as L<perlmodlib> for some style guides on constructing both +modules and classes. diff --git a/contrib/perl5/pod/perlop.pod b/contrib/perl5/pod/perlop.pod index ce6fb66bc99d..9cae3a216365 100644 --- a/contrib/perl5/pod/perlop.pod +++ b/contrib/perl5/pod/perlop.pod @@ -119,7 +119,7 @@ you increment a variable that is numeric, or that has ever been used in a numeric context, you get a normal increment. If, however, the variable has been used in only string contexts since it was set, and has a value that is not the empty string and matches the pattern -C</^[a-zA-Z]*[0-9]*$/>, the increment is done as a string, preserving each +C</^[a-zA-Z]*[0-9]*\z/>, the increment is done as a string, preserving each character within its range, with carry: print ++($foo = '99'); # prints '100' @@ -196,7 +196,7 @@ C<$a> minus the largest multiple of C<$b> that is not greater than C<$a>. If C<$b> is negative, then C<$a % $b> is C<$a> minus the smallest multiple of C<$b> that is not less than C<$a> (i.e. the result will be less than or equal to zero). -Note than when C<use integer> is in scope, "%" give you direct access +Note than when C<use integer> is in scope, "%" gives you direct access to the modulus operator as implemented by your C compiler. This operator is not as well defined for negative operands, but it will execute faster. @@ -242,14 +242,15 @@ operators, like C<-f>, C<-M>, etc. See L<perlfunc>. If any list operator (print(), etc.) or any unary operator (chdir(), etc.) is followed by a left parenthesis as the next token, the operator and arguments within parentheses are taken to be of highest precedence, -just like a normal function call. Examples: +just like a normal function call. For example, +because named unary operators are higher precedence than ||: chdir $foo || die; # (chdir $foo) || die chdir($foo) || die; # (chdir $foo) || die chdir ($foo) || die; # (chdir $foo) || die chdir +($foo) || die; # (chdir $foo) || die -but, because * is higher precedence than ||: +but, because * is higher precedence than named operators: chdir $foo * 20; # chdir ($foo * 20) chdir($foo) * 20; # (chdir $foo) * 20 @@ -299,7 +300,14 @@ to the right argument. Binary "<=>" returns -1, 0, or 1 depending on whether the left argument is numerically less than, equal to, or greater than the right -argument. +argument. If your platform supports NaNs (not-a-numbers) as numeric +values, using them with "<=>" returns undef. NaN is not "<", "==", ">", +"<=" or ">=" anything (even NaN), so those 5 return false. NaN != NaN +returns true, as does NaN != anything else. If your platform doesn't +support NaNs then NaN is just a string with numeric value 0. + + perl -le '$a = NaN; print "No NaN support here" if $a == $a' + perl -le '$a = NaN; print "NaN support here" if $a != $a' Binary "eq" returns true if the left argument is stringwise equal to the right argument. @@ -307,8 +315,9 @@ the right argument. Binary "ne" returns true if the left argument is stringwise not equal to the right argument. -Binary "cmp" returns -1, 0, or 1 depending on whether the left argument is stringwise -less than, equal to, or greater than the right argument. +Binary "cmp" returns -1, 0, or 1 depending on whether the left +argument is stringwise less than, equal to, or greater than the right +argument. "lt", "le", "ge", "gt" and "cmp" use the collation (sort) order specified by the current locale if C<use locale> is in effect. See L<perllocale>. @@ -707,7 +716,7 @@ on a Mac, these are reversed, and on systems without line terminator, printing C<"\n"> may emit no actual data. In general, use C<"\n"> when you mean a "newline" for your system, but use the literal ASCII when you need an exact character. For example, most networking protocols expect -and prefer a CR+LF (C<"\012\015"> or C<"\cJ\cM">) for line terminators, +and prefer a CR+LF (C<"\015\012"> or C<"\cM\cJ">) for line terminators, and although they often accept just C<"\012">, they seldom tolerate just C<"\015">. If you get in the habit of using C<"\n"> for networking, you may be burned some day. @@ -752,7 +761,7 @@ patterns local to the current package are reset. reset if eof; # clear ?? status for next file } -This usage is vaguely depreciated, which means it just might possibly +This usage is vaguely deprecated, which means it just might possibly be removed in some distant future version of Perl, perhaps somewhere around the year 2168. @@ -788,14 +797,14 @@ If "'" is the delimiter, no interpolation is performed on the PATTERN. PATTERN may contain variables, which will be interpolated (and the pattern recompiled) every time the pattern search is evaluated, except -for when the delimiter is a single quote. (Note that C<$)> and C<$|> -might not be interpolated because they look like end-of-string tests.) +for when the delimiter is a single quote. (Note that C<$(>, C<$)>, and +C<$|> are not interpolated because they look like end-of-string tests.) If you want such a pattern to be compiled only once, add a C</o> after the trailing delimiter. This avoids expensive run-time recompilations, and is useful when the value you are interpolating won't change over the life of the script. However, mentioning C</o> constitutes a promise that you won't change the variables in the pattern. If you change them, -Perl won't even notice. See also L<"qr//">. +Perl won't even notice. See also L<"qr/STRING/imosx">. If the PATTERN evaluates to the empty string, the last I<successfully> matched regular expression is used instead. @@ -848,9 +857,11 @@ string also resets the search position. You can intermix C<m//g> matches with C<m/\G.../g>, where C<\G> is a zero-width assertion that matches the exact position where the previous -C<m//g>, if any, left off. The C<\G> assertion is not supported without -the C</g> modifier. (Currently, without C</g>, C<\G> behaves just like -C<\A>, but that's accidental and may change in the future.) +C<m//g>, if any, left off. Without the C</g> modifier, the C<\G> assertion +still anchors at pos(), but the match is of course only attempted once. +Using C<\G> without C</g> on a target string that has not previously had a +C</g> match applied to it is the same as using the C<\A> assertion to match +the beginning of the string. Examples: @@ -858,7 +869,7 @@ Examples: ($one,$five,$fifteen) = (`uptime` =~ /(\d+\.\d+)/g); # scalar context - $/ = ""; $* = 1; # $* deprecated in modern perls + $/ = ""; while (defined($paragraph = <>)) { while ($paragraph =~ /[a-z]['")]*[.!?]+['")]*\s/g) { $sentences++; @@ -876,6 +887,7 @@ Examples: print "3: '"; print $1 while /(p)/gc; print "', pos=", pos, "\n"; } + print "Final: '$1', pos=",pos,"\n" if /\G(.)/; The last example should print: @@ -885,6 +897,13 @@ The last example should print: 1: '', pos=7 2: 'q', pos=8 3: '', pos=8 + Final: 'q', pos=8 + +Notice that the final match matched C<q> instead of C<p>, which a match +without the C<\G> anchor would have done. Also note that the final match +did not update C<pos> -- C<pos> is only updated on a C</g> match. If the +final match did indeed match C<p>, it's a good bet that you're running an +older (pre-5.6.0) Perl. A useful idiom for C<lex>-like scanners is C</\G.../gc>. You can combine several regexps like this to process a string part-by-part, @@ -938,7 +957,7 @@ A double-quoted, interpolated string. =item qr/STRING/imosx -This operators quotes--and compiles--its I<STRING> as a regular +This operator quotes (and possibly compiles) its I<STRING> as a regular expression. I<STRING> is interpolated the same way as I<PATTERN> in C<m/PATTERN/>. If "'" is used as the delimiter, no interpolation is done. Returns a Perl value which may be used instead of the @@ -997,13 +1016,14 @@ for a detailed look at the semantics of regular expressions. =item `STRING` -A string which is (possibly) interpolated and then executed as a system -command with C</bin/sh> or its equivalent. Shell wildcards, pipes, -and redirections will be honored. The collected standard output of the -command is returned; standard error is unaffected. In scalar context, -it comes back as a single (potentially multi-line) string. In list -context, returns a list of lines (however you've defined lines with $/ -or $INPUT_RECORD_SEPARATOR). +A string which is (possibly) interpolated and then executed as a +system command with C</bin/sh> or its equivalent. Shell wildcards, +pipes, and redirections will be honored. The collected standard +output of the command is returned; standard error is unaffected. In +scalar context, it comes back as a single (potentially multi-line) +string, or undef if the command failed. In list context, returns a +list of lines (however you've defined lines with $/ or +$INPUT_RECORD_SEPARATOR), or an empty list if the command failed. Because backticks do not affect standard error, use shell file descriptor syntax (assuming the shell supports this) if you care to address this. @@ -1207,9 +1227,9 @@ to occur that you might want. Here are two common cases: # expand tabs to 8-column spacing 1 while s/\t+/' ' x (length($&)*8 - length($`)%8)/e; -=item tr/SEARCHLIST/REPLACEMENTLIST/cdsUC +=item tr/SEARCHLIST/REPLACEMENTLIST/cds -=item y/SEARCHLIST/REPLACEMENTLIST/cdsUC +=item y/SEARCHLIST/REPLACEMENTLIST/cds Transliterates all occurrences of the characters found in the search list with the corresponding character in the replacement list. It returns @@ -1225,6 +1245,12 @@ SEARCHLIST is delimited by bracketing quotes, the REPLACEMENTLIST has its own pair of quotes, which may or may not be bracketing quotes, e.g., C<tr[A-Z][a-z]> or C<tr(+\-*/)/ABCD/>. +Note that C<tr> does B<not> do regular expression character classes +such as C<\d> or C<[:lower:]>. The <tr> operator is not equivalent to +the tr(1) utility. If you want to map strings between lower/upper +cases, see L<perlfunc/lc> and L<perlfunc/uc>, and in general consider +using the C<s> operator if you need regular expressions. + Note also that the whole range idea is rather unportable between character sets--and even within character sets they may cause results you probably didn't expect. A sound principle is to use only ranges @@ -1237,8 +1263,6 @@ Options: c Complement the SEARCHLIST. d Delete found but unreplaced characters. s Squash duplicate replaced characters. - U Translate to/from UTF-8. - C Translate to/from 8-bit char (octet). If the C</c> modifier is specified, the SEARCHLIST character set is complemented. If the C</d> modifier is specified, any characters @@ -1256,10 +1280,6 @@ enough. If the REPLACEMENTLIST is empty, the SEARCHLIST is replicated. This latter is useful for counting characters in a class or for squashing character sequences in a class. -The first C</U> or C</C> modifier applies to the left side of the translation. -The second one applies to the right side. If present, these modifiers override -the current utf8 state. - Examples: $ARGV[1] =~ tr/A-Z/a-z/; # canonicalize to lower case @@ -1279,9 +1299,6 @@ Examples: tr [\200-\377] [\000-\177]; # delete 8th bit - tr/\0-\xFF//CU; # change Latin-1 to Unicode - tr/\0-\x{FF}//UC; # change Unicode to Latin-1 - If multiple transliterations are given for a character, only the first one is used: @@ -1327,7 +1344,7 @@ their results are the same, we consider them individually. For different quoting constructs, Perl performs different numbers of passes, from one to five, but these passes are always performed in the same order. -=over +=over 4 =item Finding the end @@ -1381,7 +1398,7 @@ used in parsing. The next step is interpolation in the text obtained, which is now delimiter-independent. There are four different cases. -=over +=over 4 =item C<<<'EOF'>, C<m''>, C<s'''>, C<tr///>, C<y///> @@ -1412,7 +1429,7 @@ as C<"\\\t"> (since TAB is not alphanumeric). Note also that: may be closer to the conjectural I<intention> of the writer of C<"\Q\t\E">. Interpolated scalars and arrays are converted internally to the C<join> and -C<.> catentation operations. Thus, C<"$foo XXX '@arr'"> becomes: +C<.> catenation operations. Thus, C<"$foo XXX '@arr'"> becomes: $foo . " XXX '" . (join $", @arr) . "'"; @@ -1546,19 +1563,19 @@ There are several I/O operators you should know about. A string enclosed by backticks (grave accents) first undergoes double-quote interpolation. It is then interpreted as an external command, and the output of that command is the value of the -pseudo-literal, j -string consisting of all output is returned. In list context, a -list of values is returned, one per line of output. (You can set -C<$/> to use a different line terminator.) The command is executed -each time the pseudo-literal is evaluated. The status value of the -command is returned in C<$?> (see L<perlvar> for the interpretation -of C<$?>). Unlike in B<csh>, no translation is done on the return -data--newlines remain newlines. Unlike in any of the shells, single -quotes do not hide variable names in the command from interpretation. -To pass a literal dollar-sign through to the shell you need to hide -it with a backslash. The generalized form of backticks is C<qx//>. -(Because backticks always undergo shell expansion as well, see -L<perlsec> for security concerns.) +backtick string, like in a shell. In scalar context, a single string +consisting of all output is returned. In list context, a list of +values is returned, one per line of output. (You can set C<$/> to use +a different line terminator.) The command is executed each time the +pseudo-literal is evaluated. The status value of the command is +returned in C<$?> (see L<perlvar> for the interpretation of C<$?>). +Unlike in B<csh>, no translation is done on the return data--newlines +remain newlines. Unlike in any of the shells, single quotes do not +hide variable names in the command from interpretation. To pass a +literal dollar-sign through to the shell you need to hide it with a +backslash. The generalized form of backticks is C<qx//>. (Because +backticks always undergo shell expansion as well, see L<perlsec> for +security concerns.) In scalar context, evaluating a filehandle in angle brackets yields the next line from that file (the newline, if any, included), or @@ -1573,7 +1590,7 @@ of a C<while> statement (even if disguised as a C<for(;;)> loop), the value is automatically assigned to the global variable $_, destroying whatever was there previously. (This may seem like an odd thing to you, but you'll use the construct in almost every Perl -script you write.) The $_ variables is not implicitly localized. +script you write.) The $_ variable is not implicitly localized. You'll have to put a C<local $_;> before the loop if you want that to happen. @@ -1718,7 +1735,7 @@ is roughly equivalent to: open(FOO, "echo *.c | tr -s ' \t\r\f' '\\012\\012\\012\\012'|"); while (<FOO>) { - chop; + chomp; chmod 0644, $_; } @@ -1731,7 +1748,7 @@ A (file)glob evaluates its (embedded) argument only when it is starting a new list. All values must be read before it will start over. In list context, this isn't important because you automatically get them all anyway. However, in scalar context the operator returns -the next value each time it's called, or C +the next value each time it's called, or C<undef> when the list has run out. As with filehandle reads, an automatic C<defined> is generated when the glob occurs in the test part of a C<while>, because legal glob returns (e.g. a file called F<0>) would otherwise @@ -1831,8 +1848,8 @@ integer>, if you take the C<sqrt(2)>, you'll still get C<1.4142135623731> or so. Used on numbers, the bitwise operators ("&", "|", "^", "~", "<<", -and ">>") always produce integral results. (But see also L<Bitwise -String Operators>.) However, C<use integer> still has meaning for +and ">>") always produce integral results. (But see also +L<Bitwise String Operators>.) However, C<use integer> still has meaning for them. By default, their results are interpreted as unsigned integers, but if C<use integer> is in effect, their results are interpreted as signed integers. For example, C<~0> usually evaluates to a large @@ -1885,7 +1902,7 @@ need yourself. The standard Math::BigInt and Math::BigFloat modules provide variable-precision arithmetic and overloaded operators, although -they're currently pretty slow. At the cost of some space and +they're currently pretty slow. At the cost of some space and considerable speed, they avoid the normal pitfalls associated with limited-precision representations. @@ -1895,8 +1912,25 @@ limited-precision representations. # prints +15241578780673678515622620750190521 -The non-standard modules SSLeay::BN and Math::Pari provide -equivalent functionality (and much more) with a substantial -performance savings. +There are several modules that let you calculate with (bound only by +memory and cpu-time) unlimited or fixed precision. There are also +some non-standard modules that provide faster implementations via +external C libraries. + +Here is a short, but incomplete summary: + + Math::Fraction big, unlimited fractions like 9973 / 12967 + Math::String treat string sequences like numbers + Math::FixedPrecision calculate with a fixed precision + Math::Currency for currency calculations + Bit::Vector manipulate bit vectors fast (uses C) + Math::BigIntFast Bit::Vector wrapper for big numbers + Math::Pari provides access to the Pari C library + Math::BigInteger uses an external C library + Math::Cephes uses external Cephes C library (no big numbers) + Math::Cephes::Fraction fractions via the Cephes library + Math::GMP another one using an external C library + +Choose wisely. =cut diff --git a/contrib/perl5/pod/perlopentut.pod b/contrib/perl5/pod/perlopentut.pod index 9cb9f6738a7a..b4003f4f2efb 100644 --- a/contrib/perl5/pod/perlopentut.pod +++ b/contrib/perl5/pod/perlopentut.pod @@ -73,8 +73,8 @@ from a different file, and forget to trim it before opening: This is not a bug, but a feature. Because C<open> mimics the shell in its style of using redirection arrows to specify how to open the file, it also does so with respect to extra white space around the filename itself -as well. For accessing files with naughty names, see L<"Dispelling -the Dweomer">. +as well. For accessing files with naughty names, see +L<"Dispelling the Dweomer">. =head2 Pipe Opens @@ -107,13 +107,13 @@ In most systems, such an C<open> will not return an error. That's because in the traditional C<fork>/C<exec> model, running the other program happens only in the forked child process, which means that the failed C<exec> can't be reflected in the return value of C<open>. -Only a failed C<fork> shows up there. See L<perlfaq8/"Why doesn't open() -return an error when a pipe open fails?"> to see how to cope with this. -There's also an explanation in L<perlipc>. +Only a failed C<fork> shows up there. See +L<perlfaq8/"Why doesn't open() return an error when a pipe open fails?"> +to see how to cope with this. There's also an explanation in L<perlipc>. If you would like to open a bidirectional pipe, the IPC::Open2 -library will handle this for you. Check out L<perlipc/"Bidirectional -Communication with Another Process"> +library will handle this for you. Check out +L<perlipc/"Bidirectional Communication with Another Process"> =head2 The Minus File @@ -126,8 +126,8 @@ access the standard output. If minus can be used as the default input or default output, what happens if you open a pipe into or out of minus? What's the default command it would run? The same script as you're currently running! This is actually -a stealth C<fork> hidden inside an C<open> call. See L<perlipc/"Safe Pipe -Opens"> for details. +a stealth C<fork> hidden inside an C<open> call. See +L<perlipc/"Safe Pipe Opens"> for details. =head2 Mixing Reads and Writes @@ -309,7 +309,7 @@ C<O_DEFER>, C<O_SYNC>, C<O_ASYNC>, C<O_DSYNC>, C<O_RSYNC>, C<O_NOCTTY>, C<O_NDELAY> and C<O_LARGEFILE>. Consult your open(2) manpage or its local equivalent for details. (Note: starting from Perl release 5.6 the O_LARGEFILE flag, if available, is automatically -added to the sysopen() flags because large files are the the default.) +added to the sysopen() flags because large files are the default.) Here's how to use C<sysopen> to emulate the simple C<open> calls we had before. We'll omit the C<|| die $!> checks for clarity, but make sure @@ -684,9 +684,9 @@ also some high-level modules on CPAN that can help you with these games. Check out Term::ReadKey and Term::ReadLine. What else can you open? To open a connection using sockets, you won't use -one of Perl's two open functions. See L<perlipc/"Sockets: Client/Server -Communication"> for that. Here's an example. Once you have it, -you can use FH as a bidirectional filehandle. +one of Perl's two open functions. See +L<perlipc/"Sockets: Client/Server Communication"> for that. Here's an +example. Once you have it, you can use FH as a bidirectional filehandle. use IO::Socket; local *FH = IO::Socket::INET->new("www.perl.com:80"); diff --git a/contrib/perl5/pod/perlpod.pod b/contrib/perl5/pod/perlpod.pod index 6c0c5348c4db..1076ffe4cb03 100644 --- a/contrib/perl5/pod/perlpod.pod +++ b/contrib/perl5/pod/perlpod.pod @@ -63,15 +63,17 @@ Item, over, and back require a little more explanation: "=over" starts a section specifically for the generation of a list using "=item" commands. At the end of your list, use "=back" to end it. You will probably want to give "4" as the number to "=over", as some formatters will use this for indentation. -This should probably be a default. Note also that there are some basic rules -to using =item: don't use them outside of an =over/=back block, use at least -one inside an =over/=back block, you don't _have_ to include the =back if -the list just runs off the document, and perhaps most importantly, keep the -items consistent: either use "=item *" for all of them, to produce bullets, -or use "=item 1.", "=item 2.", etc., to produce numbered lists, or use -"=item foo", "=item bar", etc., i.e., things that looks nothing like bullets -or numbers. If you start with bullets or numbers, stick with them, as many -formatters use the first "=item" type to decide how to format the list. +The unit of indentation is optional. If the unit is not given the natural +indentation of the formatting system applied will be used. Note also that +there are some basic rules to using =item: don't use them outside of +an =over/=back block, use at least one inside an =over/=back block, you don't +_have_ to include the =back if the list just runs off the document, and +perhaps most importantly, keep the items consistent: either use "=item *" for +all of them, to produce bullets, or use "=item 1.", "=item 2.", etc., to +produce numbered lists, or use "=item foo", "=item bar", etc., i.e., things +that looks nothing like bullets or numbers. If you start with bullets or +numbers, stick with them, as many formatters use the first "=item" type to +decide how to format the list. =item =for diff --git a/contrib/perl5/pod/perlport.pod b/contrib/perl5/pod/perlport.pod index 6892b6a777f2..9ae89e0799a0 100644 --- a/contrib/perl5/pod/perlport.pod +++ b/contrib/perl5/pod/perlport.pod @@ -94,6 +94,26 @@ from) C<\015\012>, depending on whether you're reading or writing. Unix does the same thing on ttys in canonical mode. C<\015\012> is commonly referred to as CRLF. +A common cause of unportable programs is the misuse of chop() to trim +newlines: + + # XXX UNPORTABLE! + while(<FILE>) { + chop; + @array = split(/:/); + #... + } + +You can get away with this on Unix and MacOS (they have a single +character end-of-line), but the same program will break under DOSish +perls because you're only chop()ing half the end-of-line. Instead, +chomp() should be used to trim newlines. The Dunce::Files module can +help audit your code for misuses of chop(). + +When dealing with binary files (or text files in binary mode) be sure +to explicitly set $/ to the appropriate value for your file format +before using chomp(). + Because of the "text" mode translation, DOSish perls have limitations in using C<seek> and C<tell> on a file accessed in "text" mode. Stick to C<seek>-ing to locations you got from C<tell> (and no @@ -181,10 +201,12 @@ numbers to secondary storage such as a disk file or tape. Conflicting storage orders make utter mess out of the numbers. If a little-endian host (Intel, VAX) stores 0x12345678 (305419896 in -decimal), a big-endian host (Motorola, MIPS, Sparc, PA) reads it as -0x78563412 (2018915346 in decimal). To avoid this problem in network -(socket) connections use the C<pack> and C<unpack> formats C<n> -and C<N>, the "network" orders. These are guaranteed to be portable. +decimal), a big-endian host (Motorola, Sparc, PA) reads it as +0x78563412 (2018915346 in decimal). Alpha and MIPS can be either: +Digital/Compaq used/uses them in little-endian mode; SGI/Cray uses +them in big-endian mode. To avoid this problem in network (socket) +connections use the C<pack> and C<unpack> formats C<n> and C<N>, the +"network" orders. These are guaranteed to be portable. You can explore the endianness of your platform by unpacking a data structure packed in native format such as: @@ -197,7 +219,7 @@ If you need to distinguish between endian architectures you could use either of the variables set like so: $is_big_endian = unpack("h*", pack("s", 1)) =~ /01/; - $is_litte_endian = unpack("h*", pack("s", 1)) =~ /^1/; + $is_little_endian = unpack("h*", pack("s", 1)) =~ /^1/; Differing widths can cause truncation even between platforms of equal endianness. The platform of shorter width loses the upper parts of the @@ -217,7 +239,7 @@ So, it is reasonably safe to assume that all platforms support the notion of a "path" to uniquely identify a file on the system. How that path is really written, though, differs considerably. -Atlhough similar, file path specifications differ between Unix, +Although similar, file path specifications differ between Unix, Windows, S<Mac OS>, OS/2, VMS, VOS, S<RISC OS>, and probably others. Unix, for example, is one of the few OSes that has the elegant idea of a single root directory. @@ -332,7 +354,10 @@ operating systems put mandatory locks on such files. Don't count on a specific environment variable existing in C<%ENV>. Don't count on C<%ENV> entries being case-sensitive, or even -case-preserving. +case-preserving. Don't try to clear %ENV by saying C<%ENV = ();>, or, +if you really have to, make it conditional on C<$^O ne 'VMS'> since in +VMS the C<%ENV> table is much more than a per-process key-value string +table. Don't count on signals or C<%SIG> for anything. @@ -355,7 +380,7 @@ Commands that launch external processes are generally supported on most platforms (though many of them do not support any type of forking). The problem with using them arises from what you invoke them on. External tools are often named differently on different -platforms, may not be available in the same location, migth accept +platforms, may not be available in the same location, might accept different arguments, can behave differently, and often present their results in a platform-dependent way. Thus, you should seldom depend on them to produce consistent results. (Then again, if you're calling @@ -650,6 +675,15 @@ DOSish perls are as follows: Windows NT MSWin32 MSWin32-ppc Cygwin cygwin +The various MSWin32 Perl's can distinguish the OS they are running on +via the value of the fifth element of the list returned from +Win32::GetOSVersion(). For example: + + if ($^O eq 'MSWin32') { + my @os_version_info = Win32::GetOSVersion(); + print +('3.1','95','NT')[$os_version_info[4]],"\n"; + } + Also see: =over 4 @@ -681,15 +715,16 @@ The ActiveState Pages, http://www.activestate.com/ =item * The Cygwin environment for Win32; F<README.cygwin> (installed -as L<perlcygwin>), http://sourceware.cygnus.com/cygwin/ +as L<perlcygwin>), http://www.cygwin.com/ =item * The U/WIN environment for Win32, -<http://www.research.att.com/sw/tools/uwin/ +http://www.research.att.com/sw/tools/uwin/ -=item Build instructions for OS/2, L<perlos2> +=item * +Build instructions for OS/2, L<perlos2> =back @@ -888,9 +923,9 @@ vmsperl on the web, http://www.sidhe.org/vmsperl/index.html =head2 VOS -Perl on VOS is discussed in F<README.vos> in the perl distribution. -Perl on VOS can accept either VOS- or Unix-style file -specifications as in either of the following: +Perl on VOS is discussed in F<README.vos> in the perl distribution +(installed as L<perlvos>). Perl on VOS can accept either VOS- or +Unix-style file specifications as in either of the following: $ perl -ne "print if /perl_setup/i" >system>notices $ perl -ne "print if /perl_setup/i" /system/notices @@ -906,12 +941,11 @@ contain a slash character cannot be processed. Such files must be renamed before they can be processed by Perl. Note that VOS limits file names to 32 or fewer characters. -The following C functions are unimplemented on VOS, and any attempt by -Perl to use them will result in a fatal error message and an immediate -exit from Perl: dup, do_aspawn, do_spawn, fork, waitpid. Once these -functions become available in the VOS POSIX.1 implementation, you can -either recompile and rebind Perl, or you can download a newer port from -ftp.stratus.com. +See F<README.vos> for restrictions that apply when Perl is built +with the alpha version of VOS POSIX.1 support. + +Perl on VOS is built without any extensions and does not support +dynamic loading. The value of C<$^O> on VOS is "VOS". To determine the architecture that you are running on without resorting to loading all of C<%Config> you @@ -1042,7 +1076,8 @@ Also see: * -L<perlos390>, F<README.os390>, F<README.posix-bc>, F<README.vmesa> +L<perlos390>, F<README.os390>, F<perlbs2000>, F<README.vmesa>, +L<perlebcdic>. =item * @@ -1053,7 +1088,7 @@ general usage issues for all EBCDIC Perls. Send a message body of =item * AS/400 Perl information at -ttp://as400.rochester.ibm.com/ +http://as400.rochester.ibm.com/ as well as on CPAN in the F<ports/> directory. =back @@ -1200,7 +1235,7 @@ Be OS, F<README.beos> =item * HP 300 MPE/iX, F<README.mpeix> and Mark Bixby's web page -http://www.cccd.edu/~markb/perlix.html +http://www.bixby.org/mark/perlix.html =item * @@ -1208,7 +1243,7 @@ A free perl5-based PERL.NLM for Novell Netware is available in precompiled binary and source code form from http://www.novell.com/ as well as from CPAN. -=item +=item * Plan 9, F<README.plan9> @@ -1640,6 +1675,10 @@ Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>, VOS, VM/ESA) =item stat +Platforms that do not have rdev, blksize, or blocks will return these +as '', so numeric comparison or manipulation of these fields may cause +'not numeric' warnings. + mtime and atime are the same thing, and ctime is creation time instead of inode change time. (S<Mac OS>) @@ -1650,6 +1689,9 @@ device and inode are not necessarily reliable. (VMS) mtime, atime and ctime all return the last modification time. Device and inode are not necessarily reliable. (S<RISC OS>) +dev, rdev, blksize, and blocks are not available. inode is not +meaningful and will differ between stat calls on the same file. (os2) + =item symlink OLDFILE,NEWFILE Not implemented. (Win32, VMS, S<RISC OS>) @@ -1746,7 +1788,7 @@ two seconds. (Win32) Not implemented. (S<Mac OS>, VOS) Can only be applied to process handles returned for processes spawned -using C<system(1, ...)>. (Win32) +using C<system(1, ...)> or pseudo processes created with C<fork()>. (Win32) Not useful. (S<RISC OS>) @@ -1756,6 +1798,11 @@ Not useful. (S<RISC OS>) =over 4 +=item v1.48, 02 February 2001 + +Various updates from perl5-porters over the past year, supported +platforms update from Jarkko Hietaniemi. + =item v1.47, 22 March 2000 Various cleanups from Tom Christiansen, including migration of @@ -1838,96 +1885,98 @@ First public release with perl5.005. =head1 Supported Platforms -As of early March 2000 (the Perl release 5.6.0), the following -platforms are able to build Perl from the standard source code -distribution available at http://www.perl.com/CPAN/src/index.html +As of early 2001 (the Perl release 5.6.1), the following platforms are +able to build Perl from the standard source code distribution +available at http://www.perl.com/CPAN/src/index.html AIX + AmigaOS + Darwin (Rhapsody) + DG/UX DOS DJGPP 1) + DYNIX/ptx + EPOC FreeBSD HP-UX IRIX Linux - LynxOS MachTen - MPE/iX - NetBSD + MacOS Classic 2) + NonStop-UX + ReliantUNIX (SINIX) OpenBSD + OpenVMS (VMS) OS/2 + OS X QNX - Rhapsody/Darwin 2) - SCO SV - SINIX Solaris - SVR4 - Tru64 UNIX 3) + Tru64 UNIX (DEC OSF/1, Digital UNIX) UNICOS UNICOS/mk - Unixware - VMS VOS - Windows 3.1 1) - Windows 95 1) 4) - Windows 98 1) 4) - Windows NT 1) 4) + Win32/NT/2K 3) 1) in DOS mode either the DOS or OS/2 ports can be used - 2) new in 5.6.0: the BSD/NeXT-based UNIX of Mac OS X - 3) formerly known as Digital UNIX and before that DEC OSF/1 - 4) compilers: Borland, Cygwin, Mingw32 EGCS/GCC, VC++ + 2) Mac OS Classic (pre-X) is almost 5.6.1-ready; building from + the source does work with 5.6.1, but additional MacOS specific + source code is needed for a complete build. Contact the mailing + list macperl-porters@macperl.org for more information. + 3) compilers: Borland, Cygwin, Mingw32 EGCS/GCC, VC++ -The following platforms worked for the previous major release -(5.005_03 being the latest maintenance release of that, as of early -March 2000), but be did not manage to test these in time for the 5.6.0 -release of Perl. There is a very good chance that these will work -just fine with 5.6.0. +The following platforms worked for the previous release (5.6.0), +but we did not manage to test these in time for the 5.6.1 release. +There is a very good chance that these will work fine with 5.6.1. - A/UX - BeOS - BSD/OS - DG/UX - DYNIX/ptx DomainOS Hurd - NextSTEP - OpenSTEP + LynxOS + MinGW + MPE/iX + NetBSD PowerMAX - SCO ODT/OSR + SCO SV SunOS - Ultrix + SVR4 + Unixware + Windows 3.1 + Windows 95 + Windows 98 + Windows Me -The following platform worked for the previous major release (5.005_03 -being the latest maintenance release of that, as of early March 2000). -However, standardization on UTF-8 as the internal string representation -in 5.6.0 has introduced incompatibilities in this EBCDIC platform. -Support for this platform may be enabled in a future release: +The following platform worked for the 5.005_03 major release but not +5.6.0. Standardization on UTF-8 as the internal string representation +in 5.6.0 and 5.6.1 has introduced incompatibilities in this EBCDIC +platform. While Perl 5.6.1 will build on this platform some +regression tests may fail and the C<use utf8;> pragma typically +introduces text handling errors. UTF-8 support for this platform may +be enabled in a future release: - OS390 1) + OS/390 1) - 1) Previously known as MVS, or OpenEdition MVS. + 1) previously known as MVS, about to become z/OS. -Strongly related to the OS390 platform by also being EBCDIC-based +Strongly related to the OS/390 platform by also being EBCDIC-based mainframe platforms are the following platforms: - BS2000 + POSIX-BC (BS2000) VM/ESA -These are also not expected to work under 5.6.0 for the same reasons -as OS390. Contact the mailing list perl-mvs@perl.org for more details. - -MacOS (Classic, pre-X) is almost 5.6.0-ready; building from the source -does work with 5.6.0, but additional MacOS specific source code is needed -for a complete port. Contact the mailing list macperl-porters@macperl.org -for more information. +These are also expected to work, albeit with no UTF-8 support, under 5.6.1 +for the same reasons as OS/390. Contact the mailing list perl-mvs@perl.org +for more details. The following platforms have been known to build Perl from source in -the past, but we haven't been able to verify their status for the -current release, either because the hardware/software platforms are -rare or because we don't have an active champion on these -platforms--or both: +the past (5.005_03 and earlier), but we haven't been able to verify +their status for the current release, either because the +hardware/software platforms are rare or because we don't have an +active champion on these platforms--or both. They used to work, +though, so go ahead and try compiling them, and let perlbug@perl.org +of any trouble. 3b1 - AmigaOS + A/UX + BeOS + BSD/OS ConvexOS CX/UX DC/OSx @@ -1944,16 +1993,21 @@ platforms--or both: MiNT MPC NEWS-OS + NextSTEP + OpenSTEP Opus Plan 9 PowerUX RISC/os + SCO ODT/OSR Stellar SVR2 TI1500 TitanOS + Ultrix Unisys Dynix Unixware + UTS Support for the following platform is planned for a future Perl release: @@ -1964,8 +2018,8 @@ binaries available via http://www.perl.com/CPAN/ports/index.html: Perl release - AS/400 5.003 Netware 5.003_07 + OS/400 5.005_02 Tandem Guardian 5.004 The following platforms have only binaries available via @@ -1984,8 +2038,9 @@ http://www.perl.com/CPAN/ports/index.html for binary distributions. =head1 SEE ALSO -L<perlamiga>, L<perlcygwin>, L<perldos>, L<perlhpux>, L<perlos2>, -L<perlos390>, L<perlwin32>, L<perlvms>, and L<Win32>. +L<perlaix>, L<perlamiga>, L<perlcygwin>, L<perldos>, L<perlepoc>, +L<perlebcdic>, L<perlhpux>, L<perlos2>, L<perlos390>, L<perlbs2000>, +L<perlwin32>, L<perlvms>, L<perlvos>, and L<Win32>. =head1 AUTHORS / CONTRIBUTORS @@ -2001,7 +2056,7 @@ Neale Ferguson <neale@mailbox.tabnsw.com.au>, David J. Fiander <davidf@mks.com>, Paul Green <Paul_Green@stratus.com>, M.J.T. Guy <mjtg@cus.cam.ac.uk>, -Jarkko Hietaniemi <jhi@iki.fi<gt>, +Jarkko Hietaniemi <jhi@iki.fi>, Luther Huffman <lutherh@stratcom.com>, Nick Ing-Simmons <nick@ni-s.u-net.com>, Andreas J. KE<ouml>nig <koenig@kulturbox.de>, diff --git a/contrib/perl5/pod/perlre.pod b/contrib/perl5/pod/perlre.pod index e1f30a324aff..ce2b9bd952e6 100644 --- a/contrib/perl5/pod/perlre.pod +++ b/contrib/perl5/pod/perlre.pod @@ -40,7 +40,7 @@ is, no matter what C<$*> contains, C</s> without C</m> will force "^" to match only at the beginning of the string and "$" to match only at the end (or just before a newline at the end) of the string. Together, as /ms, they let the "." match any character whatsoever, -while yet allowing "^" and "$" to match, respectively, just after +while still allowing "^" and "$" to match, respectively, just after and just before newlines within the string. =item x @@ -169,7 +169,7 @@ You'll need to write something like C<m/\Quser\E\@\Qhost/>. In addition, Perl defines the following: \w Match a "word" character (alphanumeric plus "_") - \W Match a non-word character + \W Match a non-"word" character \s Match a whitespace character \S Match a non-whitespace character \d Match a digit character @@ -180,7 +180,7 @@ In addition, Perl defines the following: equivalent to C<(?:\PM\pM*)> \C Match a single C char (octet) even under utf8. -A C<\w> matches a single alphanumeric character, not a whole word. +A C<\w> matches a single alphanumeric character or C<_>, not a whole word. Use C<\w+> to match a string of Perl-identifier characters (which isn't the same as matching an English word). If C<use locale> is in effect, the list of alphabetic characters generated by C<\w> is taken from the @@ -199,38 +199,47 @@ equivalents (if available) are as follows: alpha alnum ascii + blank [1] cntrl digit \d graph lower print punct - space \s + space \s [2] upper - word \w + word \w [3] xdigit + [1] A GNU extension equivalent to C<[ \t]>, `all horizontal whitespace'. + [2] Not I<exactly equivalent> to C<\s> since the C<[[:space:]]> includes + also the (very rare) `vertical tabulator', "\ck", chr(11). + [3] A Perl extension. + For example use C<[:upper:]> to match all the uppercase characters. -Note that the C<[]> are part of the C<[::]> construct, not part of the whole -character class. For example: +Note that the C<[]> are part of the C<[::]> construct, not part of the +whole character class. For example: [01[:alpha:]%] -matches one, zero, any alphabetic character, and the percentage sign. +matches zero, one, any alphabetic character, and the percentage sign. If the C<utf8> pragma is used, the following equivalences to Unicode -\p{} constructs hold: +\p{} constructs and equivalent backslash character classes (if available), +will hold: alpha IsAlpha alnum IsAlnum ascii IsASCII + blank IsSpace cntrl IsCntrl - digit IsDigit + digit IsDigit \d graph IsGraph lower IsLower print IsPrint punct IsPunct space IsSpace + IsSpacePerl \s upper IsUpper word IsWord xdigit IsXDigit @@ -238,8 +247,8 @@ If the C<utf8> pragma is used, the following equivalences to Unicode For example C<[:lower:]> and C<\p{IsLower}> are equivalent. If the C<utf8> pragma is not used but the C<locale> pragma is, the -classes correlate with the isalpha(3) interface (except for `word', -which is a Perl extension, mirroring C<\w>). +classes correlate with the usual isalpha(3) interface (except for +`word' and `blank'). The assumedly non-obviously named classes are: @@ -250,23 +259,24 @@ The assumedly non-obviously named classes are: Any control character. Usually characters that don't produce output as such but instead control the terminal somehow: for example newline and backspace are control characters. All characters with ord() less than -32 are most often classified as control characters. +32 are most often classified as control characters (assuming ASCII, +the ISO Latin character sets, and Unicode). =item graph -Any alphanumeric or punctuation character. +Any alphanumeric or punctuation (special) character. =item print -Any alphanumeric or punctuation character or space. +Any alphanumeric or punctuation (special) character or space. =item punct -Any punctuation character. +Any punctuation (special) character. =item xdigit -Any hexadecimal digit. Though this may feel silly (/0-9a-f/i would +Any hexadecimal digit. Though this may feel silly ([0-9A-Fa-f] would work just fine) it is included for completeness. =back @@ -323,12 +333,14 @@ I<backreference>. There is no limit to the number of captured substrings that you may use. However Perl also uses \10, \11, etc. as aliases for \010, -\011, etc. (Recall that 0 means octal, so \011 is the 9'th ASCII -character, a tab.) Perl resolves this ambiguity by interpreting -\10 as a backreference only if at least 10 left parentheses have -opened before it. Likewise \11 is a backreference only if at least -11 left parentheses have opened before it. And so on. \1 through -\9 are always interpreted as backreferences." +\011, etc. (Recall that 0 means octal, so \011 is the character at +number 9 in your coded character set; which would be the 10th character, +a horizontal tab under ASCII.) Perl resolves this +ambiguity by interpreting \10 as a backreference only if at least 10 +left parentheses have opened before it. Likewise \11 is a +backreference only if at least 11 left parentheses have opened +before it. And so on. \1 through \9 are always interpreted as +backreferences. Examples: @@ -352,7 +364,7 @@ everything before the matched string. And C<$'> returns everything after the matched string. The numbered variables ($1, $2, $3, etc.) and the related punctuation -set (C<<$+>, C<$&>, C<$`>, and C<$'>) are all dynamically scoped +set (C<$+>, C<$&>, C<$`>, and C<$'>) are all dynamically scoped until the end of the enclosing block or until the next successful match, whichever comes first. (See L<perlsyn/"Compound Statements">.) @@ -377,10 +389,11 @@ that looks like \\, \(, \), \<, \>, \{, or \} is always interpreted as a literal character, not a metacharacter. This was once used in a common idiom to disable or quote the special meanings of regular expression metacharacters in a string that you want to -use for a pattern. Simply quote all non-alphanumeric characters: +use for a pattern. Simply quote all non-"word" characters: $pattern =~ s/(\W)/\\$1/g; +(If C<use locale> is set, then this depends on the current locale.) Today it is more common to use the quotemeta() function or the C<\Q> metaquoting escape sequence to disable all metacharacters' special meanings like this: @@ -673,7 +686,7 @@ The "grab all you can, and do not give anything back" semantic is desirable in many situations where on the first sight a simple C<()*> looks like the correct solution. Suppose we parse text with comments being delimited by C<#> followed by some optional (horizontal) whitespace. Contrary to -its appearence, C<#[ \t]*> I<is not> the correct subexpression to match +its appearance, C<#[ \t]*> I<is not> the correct subexpression to match the comment delimiter, because it may "give up" some whitespace if the remainder of the pattern can be made to match that way. The correct answer is either one of these: @@ -901,10 +914,14 @@ ways they can use backtracking to try match. For example, without internal optimizations done by the regular expression engine, this will take a painfully long time to run: - 'aaaaaaaaaaaa' =~ /((a{0,5}){0,5}){0,5}[c]/ + 'aaaaaaaaaaaa' =~ /((a{0,5}){0,5})*[c]/ -And if you used C<*>'s instead of limiting it to 0 through 5 matches, -then it would take forever--or until you ran out of stack space. +And if you used C<*>'s in the internal groups instead of limiting them +to 0 through 5 matches, then it would take forever--or until you ran +out of stack space. Moreover, these internal optimizations are not +always applicable. For example, if you put C<{0,5}> instead of C<*> +on the external group, no current optimization is applicable, and the +match takes a long time to finish. A powerful tool for optimizing such beasts is what is known as an "independent group", @@ -939,10 +956,10 @@ escape it with a backslash. "-" is also taken literally when it is at the end of the list, just before the closing "]". (The following all specify the same class of three characters: C<[-az]>, C<[az-]>, and C<[a\-z]>. All are different from C<[a-z]>, which -specifies a class containing twenty-six characters.) -Also, if you try to use the character classes C<\w>, C<\W>, C<\s>, -C<\S>, C<\d>, or C<\D> as endpoints of a range, that's not a range, -the "-" is understood literally. +specifies a class containing twenty-six characters, even on EBCDIC +based coded character sets.) Also, if you try to use the character +classes C<\w>, C<\W>, C<\s>, C<\S>, C<\d>, or C<\D> as endpoints of +a range, that's not a range, the "-" is understood literally. Note also that the whole range idea is rather unportable between character sets--and even within character sets they may cause results @@ -954,11 +971,11 @@ spell out the character sets in full. Characters may be specified using a metacharacter syntax much like that used in C: "\n" matches a newline, "\t" a tab, "\r" a carriage return, "\f" a form feed, etc. More generally, \I<nnn>, where I<nnn> is a string -of octal digits, matches the character whose ASCII value is I<nnn>. -Similarly, \xI<nn>, where I<nn> are hexadecimal digits, matches the -character whose ASCII value is I<nn>. The expression \cI<x> matches the -ASCII character control-I<x>. Finally, the "." metacharacter matches any -character except "\n" (unless you use C</s>). +of octal digits, matches the character whose coded character set value +is I<nnn>. Similarly, \xI<nn>, where I<nn> are hexadecimal digits, +matches the character whose numeric value is I<nn>. The expression \cI<x> +matches the character control-I<x>. Finally, the "." metacharacter +matches any character except "\n" (unless you use C</s>). You can specify a series of alternatives for a pattern using "|" to separate them, so that C<fee|fie|foe> will match any of "fee", "fie", @@ -1080,7 +1097,7 @@ For example: $_ = 'bar'; s/\w??/<$&>/g; -results in C<"<><b><><a><><r><>">. At each position of the string the best +results in C<< <><b><><a><><r><> >>. At each position of the string the best match given by non-greedy C<??> is the zero-length match, and the I<second best> match is what is matched by C<\w>. Thus zero-length matches alternate with one-character-long matches. @@ -1120,7 +1137,7 @@ one match at a given position is possible. This section describes the notion of better/worse for combining operators. In the description below C<S> and C<T> are regular subexpressions. -=over +=over 4 =item C<ST> @@ -1262,5 +1279,7 @@ L<perlfunc/pos>. L<perllocale>. +L<perlebcdic>. + I<Mastering Regular Expressions> by Jeffrey Friedl, published by O'Reilly and Associates. diff --git a/contrib/perl5/pod/perlreftut.pod b/contrib/perl5/pod/perlreftut.pod index c8593fb1ce68..073d358da55e 100644 --- a/contrib/perl5/pod/perlreftut.pod +++ b/contrib/perl5/pod/perlreftut.pod @@ -386,7 +386,7 @@ to do with references. =head1 Credits -Author: Mark-Jason Dominus, Plover Systems (C<mjd-perl-ref@plover.com>) +Author: Mark-Jason Dominus, Plover Systems (C<mjd-perl-ref+@plover.com>) This article originally appeared in I<The Perl Journal> (http://tpj.com) volume 3, #2. Reprinted with permission. diff --git a/contrib/perl5/pod/perlrun.pod b/contrib/perl5/pod/perlrun.pod index f1e2c9a62ecb..30e82fc1b8c8 100644 --- a/contrib/perl5/pod/perlrun.pod +++ b/contrib/perl5/pod/perlrun.pod @@ -284,11 +284,15 @@ be skipped. runs the program under the Perl debugger. See L<perldebug>. -=item B<-d:>I<foo> +=item B<-d:>I<foo[=bar,baz]> runs the program under the control of a debugging, profiling, or tracing module installed as Devel::foo. E.g., B<-d:DProf> executes -the program using the Devel::DProf profiler. See L<perldebug>. +the program using the Devel::DProf profiler. As with the B<-M> +flag, options may be passed to the Devel::foo package where they +will be received and interpreted by the Devel::foo::import routine. +The comma-separated list of options must follow a C<=> character. +See L<perldebug>. =item B<-D>I<letters> @@ -307,7 +311,7 @@ equivalent to B<-Dtls>): 8 t Trace execution 16 o Method and overloading resolution 32 c String/numeric conversions - 64 P Print preprocessor command for -P + 64 P Print preprocessor command for -P, source file input state 128 m Memory allocation 256 f Format processing 512 r Regular expression parsing and execution @@ -318,6 +322,7 @@ equivalent to B<-Dtls>): 16384 X Scratchpad allocation 32768 D Cleaning up 65536 S Thread synchronization + 131072 T Tokenising All these flags require B<-DDEBUGGING> when you compile the Perl executable. See the F<INSTALL> file in the Perl source distribution @@ -445,8 +450,7 @@ specified in the extension then it will skip that file and continue on with the next one (if it exists). For a discussion of issues surrounding file permissions and B<-i>, -see L<perlfaq5/Why does Perl let me delete read-only files? Why -does -i clobber protected files? Isn't this a bug in Perl?>. +see L<perlfaq5/Why does Perl let me delete read-only files? Why does -i clobber protected files? Isn't this a bug in Perl?>. You cannot use B<-i> to create directories or to strip extensions from files. @@ -565,15 +569,30 @@ the implicit loop, just as in B<awk>. =item B<-P> causes your program to be run through the C preprocessor before -compilation by Perl. (Because both comments and B<cpp> directives begin +compilation by Perl. Because both comments and B<cpp> directives begin with the # character, you should avoid starting comments with any words -recognized by the C preprocessor such as "if", "else", or "define".) +recognized by the C preprocessor such as C<"if">, C<"else">, or C<"define">. +Also, in some platforms the C preprocessor knows too much: it knows +about the C++ -style until-end-of-line comments starting with C<"//">. +This will cause problems with common Perl constructs like + + s/foo//; + +because after -P this will became illegal code + + s/foo + +The workaround is to use some other quoting separator than C<"/">, +like for example C<"!">: + + s!foo!!; =item B<-s> enables rudimentary switch parsing for switches on the command line after the program name but before any filename arguments (or before -a B<-->). Any switch found there is removed from @ARGV and sets the +an argument of B<-->). This means you can have switches with two leading +dashes (B<--help>). Any switch found there is removed from @ARGV and sets the corresponding variable in the Perl program. The following program prints "1" if the program is invoked with a B<-xyz> switch, and "abc" if it is invoked with B<-xyz=abc>. @@ -581,6 +600,9 @@ if it is invoked with B<-xyz=abc>. #!/usr/bin/perl -s if ($xyz) { print "$xyz\n" } +Do note that B<--help> creates the variable ${-help}, which is not compliant +with C<strict refs>. + =item B<-S> makes Perl use the PATH environment variable to search for the @@ -809,6 +831,18 @@ Relevant only if your perl executable was built with B<-DDEBUGGING>, this controls the behavior of global destruction of objects and other references. +=item PERL_ROOT (specific to the VMS port) + +A translation concealed rooted logical name that contains perl and the +logical device for the @INC path on VMS only. Other logical names that +affect perl on VMS include PERLSHR, PERL_ENV_TABLES, and +SYS$TIMEZONE_DIFFERENTIAL but are optional and discussed further in +L<perlvms> and in F<README.vms> in the Perl source distribution. + +=item SYS$LOGIN (specific to the VMS port) + +Used if chdir has no argument and HOME and LOGDIR are not set. + =back Perl also has environment variables that control how Perl handles data diff --git a/contrib/perl5/pod/perlsec.pod b/contrib/perl5/pod/perlsec.pod index 4185e848036f..3870c2ef709d 100644 --- a/contrib/perl5/pod/perlsec.pod +++ b/contrib/perl5/pod/perlsec.pod @@ -38,9 +38,22 @@ msgrcv(), the password, gcos and shell fields returned by the getpwxxx() calls), and all file input are marked as "tainted". Tainted data may not be used directly or indirectly in any command that invokes a sub-shell, nor in any command that modifies files, -directories, or processes. (B<Important exception>: If you pass a list -of arguments to either C<system> or C<exec>, the elements of that list -are B<NOT> checked for taintedness.) Any variable set to a value +directories, or processes, B<with the following exceptions>: + +=over 4 + +=item * + +If you pass a list of arguments to either C<system> or C<exec>, +the elements of that list are B<not> checked for taintedness. + +=item * + +Arguments to C<print> and C<syswrite> are B<not> checked for taintedness. + +=back + +Any variable set to a value derived from tainted data will itself be tainted, even if it is logically impossible for the tainted data to alter the variable. Because taintedness is associated with each scalar value, some @@ -217,25 +230,31 @@ not called with a string that the shell could expand. This is by far the best way to call something that might be subjected to shell escapes: just never call the shell at all. - use English; - die "Can't fork: $!" unless defined $pid = open(KID, "-|"); - if ($pid) { # parent - while (<KID>) { - # do something - } - close KID; - } else { - my @temp = ($EUID, $EGID); - $EUID = $UID; - $EGID = $GID; # initgroups() also called! - # Make sure privs are really gone - ($EUID, $EGID) = @temp; - die "Can't drop privileges" - unless $UID == $EUID && $GID eq $EGID; - $ENV{PATH} = "/bin:/usr/bin"; - exec 'myprog', 'arg1', 'arg2' - or die "can't exec myprog: $!"; - } + use English; + die "Can't fork: $!" unless defined($pid = open(KID, "-|")); + if ($pid) { # parent + while (<KID>) { + # do something + } + close KID; + } else { + my @temp = ($EUID, $EGID); + my $orig_uid = $UID; + my $orig_gid = $GID; + $EUID = $UID; + $EGID = $GID; + # Drop privileges + $UID = $orig_uid; + $GID = $orig_gid; + # Make sure privs are really gone + ($EUID, $EGID) = @temp; + die "Can't drop privileges" + unless $UID == $EUID && $GID eq $EGID; + $ENV{PATH} = "/bin:/usr/bin"; # Minimal PATH. + # Consider sanitizing the environment even more. + exec 'myprog', 'arg1', 'arg2' + or die "can't exec myprog: $!"; + } A similar strategy would work for wildcard expansion via C<glob>, although you can use C<readdir> instead. @@ -291,12 +310,6 @@ in C: Compile this wrapper into a binary executable and then make I<it> rather than your script setuid or setgid. -See the program B<wrapsuid> in the F<eg> directory of your Perl -distribution for a convenient way to do this automatically for all your -setuid Perl programs. It moves setuid scripts into files with the same -name plus a leading dot, and then compiles a wrapper like the one above -for each of them. - In recent years, vendors have begun to supply systems free of this inherent security bug. On such systems, when the kernel passes the name of the set-id script to open to the interpreter, rather than using a @@ -308,9 +321,8 @@ program that builds Perl tries to figure this out for itself, so you should never have to specify this yourself. Most modern releases of SysVr4 and BSD 4.4 use this approach to avoid the kernel race condition. -Prior to release 5.003 of Perl, a bug in the code of B<suidperl> could -introduce a security hole in systems compiled with strict POSIX -compliance. +Prior to release 5.6.1 of Perl, bugs in the code of B<suidperl> could +introduce a security hole. =head2 Protecting Your Programs diff --git a/contrib/perl5/pod/perlsub.pod b/contrib/perl5/pod/perlsub.pod index 46d1a2a2b0e0..b440cd1d9302 100644 --- a/contrib/perl5/pod/perlsub.pod +++ b/contrib/perl5/pod/perlsub.pod @@ -39,7 +39,7 @@ To call subroutines: Like many languages, Perl provides for user-defined subroutines. These may be located anywhere in the main program, loaded in from other files via the C<do>, C<require>, or C<use> keywords, or -generated on the fly using C<eval> or anonymous subroutines (closures). +generated on the fly using C<eval> or anonymous subroutines. You can even call a function indirectly using a variable containing its name or a CODE reference. @@ -154,7 +154,7 @@ of changing them in place: } Notice how this (unprototyped) function doesn't care whether it was -passed real scalars or arrays. Perl sees all arugments as one big, +passed real scalars or arrays. Perl sees all arguments as one big, long, flat parameter list in C<@_>. This is one area where Perl's simple argument-passing style shines. The C<upcase()> function would work perfectly well without changing the C<upcase()> @@ -169,8 +169,8 @@ Do not, however, be tempted to do this: Like the flattened incoming parameter list, the return list is also flattened on return. So all you have managed to do here is stored -everything in C<@a> and made C<@b> an empty list. See L<Pass by -Reference> for alternatives. +everything in C<@a> and made C<@b> an empty list. See +L<Pass by Reference> for alternatives. A subroutine may be called using an explicit C<&> prefix. The C<&> is optional in modern Perl, as are parentheses if the @@ -357,7 +357,7 @@ A compilation error results otherwise. An inner block may countermand this with C<no strict 'vars'>. A C<my> has both a compile-time and a run-time effect. At compile -time, the compiler takes notice of it. The principle usefulness +time, the compiler takes notice of it. The principal usefulness of this is to quiet C<use strict 'vars'>, but it is also essential for generation of closures as detailed in L<perlref>. Actual initialization is delayed until run time, though, so it gets executed @@ -645,10 +645,6 @@ and in: all the subroutines are called in a list context. -The current implementation does not allow arrays and hashes to be -returned from lvalue subroutines directly. You may return a -reference instead. This restriction may be lifted in future. - =head2 Passing Symbol Table Entries (typeglobs) B<WARNING>: The mechanism described in this section was originally @@ -697,9 +693,11 @@ Despite the existence of C<my>, there are still three places where the C<local> operator still shines. In fact, in these three places, you I<must> use C<local> instead of C<my>. -=over +=over 4 + +=item 1. -=item 1. You need to give a global variable a temporary value, especially $_. +You need to give a global variable a temporary value, especially $_. The global variables, like C<@ARGV> or the punctuation variables, must be C<local>ized with C<local()>. This block reads in F</etc/motd>, and splits @@ -716,7 +714,9 @@ in C<@Fields>. It particular, it's important to C<local>ize $_ in any routine that assigns to it. Look out for implicit assignments in C<while> conditionals. -=item 2. You need to create a local file or directory handle or a local function. +=item 2. + +You need to create a local file or directory handle or a local function. A function that needs a filehandle of its own must use C<local()> on a complete typeglob. This can be used to create new symbol @@ -746,7 +746,9 @@ a local alias. See L<perlref/"Function Templates"> for more about manipulating functions by name in this way. -=item 3. You want to temporarily change just one element of an array or hash. +=item 3. + +You want to temporarily change just one element of an array or hash. You can C<local>ize just one element of an aggregate. Usually this is done on dynamics: @@ -1270,7 +1272,7 @@ see L<attributes>. See L<perlref/"Function Templates"> for more about references and closures. See L<perlxs> if you'd like to learn about calling C subroutines from Perl. -See L<perlembed> if you'd like to learn about calling PErl subroutines from C. +See L<perlembed> if you'd like to learn about calling Perl subroutines from C. See L<perlmod> to learn about bundling up your functions in separate files. See L<perlmodlib> to learn what library modules come standard on your system. See L<perltoot> to learn how to make object method calls. diff --git a/contrib/perl5/pod/perlsyn.pod b/contrib/perl5/pod/perlsyn.pod index 724ba12ac0fa..aad4efd2f771 100644 --- a/contrib/perl5/pod/perlsyn.pod +++ b/contrib/perl5/pod/perlsyn.pod @@ -53,8 +53,8 @@ subroutine without defining it by saying C<sub name>, thus: sub myname; $me = myname $0 or die "can't get myname"; -Note that my() functions as a list operator, not as a unary operator; so -be careful to use C<or> instead of C<||> in this case. However, if +Note that myname() functions as a list operator, not as a unary operator; +so be careful to use C<or> instead of C<||> in this case. However, if you were to declare the subroutine as C<sub myname ($)>, then C<myname> would function as a unary operator, so either C<or> or C<||> would work. @@ -172,7 +172,7 @@ If the LABEL is omitted, the loop control statement refers to the innermost enclosing loop. This may include dynamically looking back your call-stack at run time to find the LABEL. Such desperate behavior triggers a warning if you use the C<use warnings> -praga or the B<-w> flag. +pragma or the B<-w> flag. Unlike a C<foreach> statement, a C<while> statement never implicitly localises any variables. @@ -263,7 +263,7 @@ available. Replace any occurrence of C<if BLOCK> by C<if (do BLOCK)>. =head2 For Loops -Perl's C-style C<for> loop works exactly like the corresponding C<while> loop; +Perl's C-style C<for> loop works like the corresponding C<while> loop; that means that this: for ($i = 1; $i < 10; $i++) { @@ -279,8 +279,10 @@ is the same as this: $i++; } -(There is one minor difference: The first form implies a lexical scope -for variables declared with C<my> in the initialization expression.) +There is one minor difference: if variables are declared with C<my> +in the initialization section of the C<for>, the lexical scope of +those variables is exactly the C<for> loop (the body of the loop +and the control sections). Besides the normal array index looping, C<for> can lend itself to many other interesting applications. Here's one that avoids the @@ -309,9 +311,12 @@ The C<foreach> keyword is actually a synonym for the C<for> keyword, so you can use C<foreach> for readability or C<for> for brevity. (Or because the Bourne shell is more familiar to you than I<csh>, so writing C<for> comes more naturally.) If VAR is omitted, C<$_> is set to each value. -If any element of LIST is an lvalue, you can modify it by modifying VAR -inside the loop. That's because the C<foreach> loop index variable is -an implicit alias for each item in the list that you're looping over. + +If any element of LIST is an lvalue, you can modify it by modifying +VAR inside the loop. Conversely, if any element of LIST is NOT an +lvalue, any attempt to modify that element will fail. In other words, +the C<foreach> loop index variable is an implicit alias for each item +in the list that you're looping over. If any part of LIST is an array, C<foreach> will get very confused if you add or remove elements within the loop body, for example with @@ -483,7 +488,7 @@ Or Or if you are certainly that all the C<&&> clauses are true, you can use something like this, which "switches" on the value of the -C<HTTP_USER_AGENT> envariable. +C<HTTP_USER_AGENT> environment variable. #!/usr/bin/perl # pick out jargon file page based on browser @@ -598,6 +603,11 @@ C</^#\s*line\s+(\d+)\s*(?:\s"([^"]+)")?\s*$/> with C<$1> being the line number for the next line, and C<$2> being the optional filename (specified within quotes). +There is a fairly obvious gotcha included with the line directive: +Debuggers and profilers will only show the last source line to appear +at a particular line number in a given file. Care should be taken not +to cause line number collisions in code you'd like to debug later. + Here are some examples that you should be able to type into your command shell: diff --git a/contrib/perl5/pod/perlthrtut.pod b/contrib/perl5/pod/perlthrtut.pod index 0f15d57de76e..0b7092b39dca 100644 --- a/contrib/perl5/pod/perlthrtut.pod +++ b/contrib/perl5/pod/perlthrtut.pod @@ -718,7 +718,7 @@ In addition to synchronizing access to data or resources, you might find it useful to synchronize access to subroutines. You may be accessing a singular machine resource (perhaps a vector processor), or find it easier to serialize calls to a particular subroutine than to -have a set of locks and sempahores. +have a set of locks and semaphores. One of the additions to Perl 5.005 is subroutine attributes. The Thread package uses these to provide several flavors of @@ -991,7 +991,7 @@ the explanation is much longer than the program. A complete thread tutorial could fill a book (and has, many times), but this should get you well on your way. The final authority on how -Perl's threads behave is the documention bundled with the Perl +Perl's threads behave is the documentation bundled with the Perl distribution, but with what we've covered in this article, you should be well on your way to becoming a threaded Perl expert. @@ -1029,7 +1029,7 @@ LoVerso. Programming under Mach. Addison-Wesley, 1994, ISBN 0-201-52739-1. Tanenbaum, Andrew S. Distributed Operating Systems. Prentice Hall, -1995, ISBN 0-13-143934-0 (great textbook). +1995, ISBN 0-13-219908-4 (great textbook). Silberschatz, Abraham, and Peter B. Galvin. Operating System Concepts, 4th ed. Addison-Wesley, 1995, ISBN 0-201-59292-4 diff --git a/contrib/perl5/pod/perltie.pod b/contrib/perl5/pod/perltie.pod index c835738573f9..1bba005be59f 100644 --- a/contrib/perl5/pod/perltie.pod +++ b/contrib/perl5/pod/perltie.pod @@ -48,7 +48,7 @@ for you--you need to do that explicitly yourself. =head2 Tying Scalars A class implementing a tied scalar should define the following methods: -TIESCALAR, FETCH, STORE, and possibly DESTROY. +TIESCALAR, FETCH, STORE, and possibly UNTIE and/or DESTROY. Let's look at each in turn, using as an example a tie class for scalars that allows the user to do something like: @@ -71,7 +71,7 @@ calls. Here's the preamble of the class. use strict; $Nice::DEBUG = 0 unless defined $Nice::DEBUG; -=over +=over 4 =item TIESCALAR classname, LIST @@ -157,6 +157,12 @@ argument--the new value the user is trying to assign. return $new_nicety; } +=item UNTIE this + +This method will be triggered when the C<untie> occurs. This can be useful +if the class needs to know when no further calls will be made. (Except DESTROY +of course.) See below for more details. + =item DESTROY this This method will be triggered when the tied variable needs to be destructed. @@ -180,7 +186,7 @@ TIESCALAR classes are certainly possible. =head2 Tying Arrays A class implementing a tied ordinary array should define the following -methods: TIEARRAY, FETCH, STORE, FETCHSIZE, STORESIZE and perhaps DESTROY. +methods: TIEARRAY, FETCH, STORE, FETCHSIZE, STORESIZE and perhaps UNTIE and/or DESTROY. FETCHSIZE and STORESIZE are used to provide C<$#array> and equivalent C<scalar(@array)> access. @@ -192,34 +198,25 @@ base class to implement the first five of these in terms of the basic methods above. The default implementations of DELETE and EXISTS in B<Tie::Array> simply C<croak>. -In addition EXTEND will be called when perl would have pre-extended +In addition EXTEND will be called when perl would have pre-extended allocation in a real array. -This means that tied arrays are now I<complete>. The example below needs -upgrading to illustrate this. (The documentation in B<Tie::Array> is more -complete.) - -For this discussion, we'll implement an array whose indices are fixed at -its creation. If you try to access anything beyond those bounds, you'll -take an exception. For example: +For this discussion, we'll implement an array whose elements are a fixed +size at creation. If you try to create an element larger than the fixed +size, you'll take an exception. For example: - require Bounded_Array; - tie @ary, 'Bounded_Array', 2; - $| = 1; - for $i (0 .. 10) { - print "setting index $i: "; - $ary[$i] = 10 * $i; - $ary[$i] = 10 * $i; - print "value of elt $i now $ary[$i]\n"; - } + use FixedElem_Array; + tie @array, 'FixedElem_Array', 3; + $array[0] = 'cat'; # ok. + $array[1] = 'dogs'; # exception, length('dogs') > 3. The preamble code for the class is as follows: - package Bounded_Array; + package FixedElem_Array; use Carp; use strict; -=over +=over 4 =item TIEARRAY classname, LIST @@ -229,21 +226,22 @@ anonymous ARRAY ref) will be accessed. In our example, just to show you that you don't I<really> have to return an ARRAY reference, we'll choose a HASH reference to represent our object. -A HASH works out well as a generic record type: the C<{BOUND}> field will -store the maximum bound allowed, and the C<{ARRAY}> field will hold the +A HASH works out well as a generic record type: the C<{ELEMSIZE}> field will +store the maximum element size allowed, and the C<{ARRAY}> field will hold the true ARRAY ref. If someone outside the class tries to dereference the object returned (doubtless thinking it an ARRAY ref), they'll blow up. This just goes to show you that you should respect an object's privacy. sub TIEARRAY { - my $class = shift; - my $bound = shift; - confess "usage: tie(\@ary, 'Bounded_Array', max_subscript)" - if @_ || $bound =~ /\D/; - return bless { - BOUND => $bound, - ARRAY => [], - }, $class; + my $class = shift; + my $elemsize = shift; + if ( @_ || $elemsize =~ /\D/ ) { + croak "usage: tie ARRAY, '" . __PACKAGE__ . "', elem_size"; + } + return bless { + ELEMSIZE => $elemsize, + ARRAY => [], + }, $class; } =item FETCH this, index @@ -253,13 +251,15 @@ is accessed (read). It takes one argument beyond its self reference: the index whose value we're trying to fetch. sub FETCH { - my($self,$idx) = @_; - if ($idx > $self->{BOUND}) { - confess "Array OOB: $idx > $self->{BOUND}"; - } - return $self->{ARRAY}[$idx]; + my $self = shift; + my $index = shift; + return $self->{ARRAY}->[$index]; } +If a negative array index is used to read from an array, the index +will be translated to a positive one internally by calling FETCHSIZE +before being passed to FETCH. + As you may have noticed, the name of the FETCH method (et al.) is the same for all accesses, even though the constructors differ in names (TIESCALAR vs TIEARRAY). While in theory you could have the same class servicing @@ -271,17 +271,189 @@ to keep them at simply one tie type per class. This method will be triggered every time an element in the tied array is set (written). It takes two arguments beyond its self reference: the index at which we're trying to store something and the value we're trying to put -there. For example: +there. + +In our example, C<undef> is really C<$self-E<gt>{ELEMSIZE}> number of +spaces so we have a little more work to do here: sub STORE { - my($self, $idx, $value) = @_; - print "[STORE $value at $idx]\n" if _debug; - if ($idx > $self->{BOUND} ) { - confess "Array OOB: $idx > $self->{BOUND}"; + my $self = shift; + my( $index, $value ) = @_; + if ( length $value > $self->{ELEMSIZE} ) { + croak "length of $value is greater than $self->{ELEMSIZE}"; + } + # fill in the blanks + $self->EXTEND( $index ) if $index > $self->FETCHSIZE(); + # right justify to keep element size for smaller elements + $self->{ARRAY}->[$index] = sprintf "%$self->{ELEMSIZE}s", $value; + } + +Negative indexes are treated the same as with FETCH. + +=item FETCHSIZE this + +Returns the total number of items in the tied array associated with +object I<this>. (Equivalent to C<scalar(@array)>). For example: + + sub FETCHSIZE { + my $self = shift; + return scalar @{$self->{ARRAY}}; + } + +=item STORESIZE this, count + +Sets the total number of items in the tied array associated with +object I<this> to be I<count>. If this makes the array larger then +class's mapping of C<undef> should be returned for new positions. +If the array becomes smaller then entries beyond count should be +deleted. + +In our example, 'undef' is really an element containing +C<$self-E<gt>{ELEMSIZE}> number of spaces. Observe: + + sub STORESIZE { + my $self = shift; + my $count = shift; + if ( $count > $self->FETCHSIZE() ) { + foreach ( $count - $self->FETCHSIZE() .. $count ) { + $self->STORE( $_, '' ); + } + } elsif ( $count < $self->FETCHSIZE() ) { + foreach ( 0 .. $self->FETCHSIZE() - $count - 2 ) { + $self->POP(); + } + } + } + +=item EXTEND this, count + +Informative call that array is likely to grow to have I<count> entries. +Can be used to optimize allocation. This method need do nothing. + +In our example, we want to make sure there are no blank (C<undef>) +entries, so C<EXTEND> will make use of C<STORESIZE> to fill elements +as needed: + + sub EXTEND { + my $self = shift; + my $count = shift; + $self->STORESIZE( $count ); + } + +=item EXISTS this, key + +Verify that the element at index I<key> exists in the tied array I<this>. + +In our example, we will determine that if an element consists of +C<$self-E<gt>{ELEMSIZE}> spaces only, it does not exist: + + sub EXISTS { + my $self = shift; + my $index = shift; + return 0 if ! defined $self->{ARRAY}->[$index] || + $self->{ARRAY}->[$index] eq ' ' x $self->{ELEMSIZE}; + return 1; + } + +=item DELETE this, key + +Delete the element at index I<key> from the tied array I<this>. + +In our example, a deleted item is C<$self->{ELEMSIZE}> spaces: + + sub DELETE { + my $self = shift; + my $index = shift; + return $self->STORE( $index, '' ); + } + +=item CLEAR this + +Clear (remove, delete, ...) all values from the tied array associated with +object I<this>. For example: + + sub CLEAR { + my $self = shift; + return $self->{ARRAY} = []; + } + +=item PUSH this, LIST + +Append elements of I<LIST> to the array. For example: + + sub PUSH { + my $self = shift; + my @list = @_; + my $last = $self->FETCHSIZE(); + $self->STORE( $last + $_, $list[$_] ) foreach 0 .. $#list; + return $self->FETCHSIZE(); + } + +=item POP this + +Remove last element of the array and return it. For example: + + sub POP { + my $self = shift; + return pop @{$self->{ARRAY}}; + } + +=item SHIFT this + +Remove the first element of the array (shifting other elements down) +and return it. For example: + + sub SHIFT { + my $self = shift; + return shift @{$self->{ARRAY}}; + } + +=item UNSHIFT this, LIST + +Insert LIST elements at the beginning of the array, moving existing elements +up to make room. For example: + + sub UNSHIFT { + my $self = shift; + my @list = @_; + my $size = scalar( @list ); + # make room for our list + @{$self->{ARRAY}}[ $size .. $#{$self->{ARRAY}} + $size ] + = @{$self->{ARRAY}}; + $self->STORE( $_, $list[$_] ) foreach 0 .. $#list; + } + +=item SPLICE this, offset, length, LIST + +Perform the equivalent of C<splice> on the array. + +I<offset> is optional and defaults to zero, negative values count back +from the end of the array. + +I<length> is optional and defaults to rest of the array. + +I<LIST> may be empty. + +Returns a list of the original I<length> elements at I<offset>. + +In our example, we'll use a little shortcut if there is a I<LIST>: + + sub SPLICE { + my $self = shift; + my $offset = shift || 0; + my $length = shift || $self->FETCHSIZE() - $offset; + my @list = (); + if ( @_ ) { + tie @list, __PACKAGE__, $self->{ELEMSIZE}; + @list = @_; } - return $self->{ARRAY}[$idx] = $value; + return splice @{$self->{ARRAY}}, $offset, $length, @list; } +=item UNTIE this + +Will be called when C<untie> happens. (See below.) + =item DESTROY this This method will be triggered when the tied variable needs to be destructed. @@ -291,27 +463,16 @@ just leave it out. =back -The code we presented at the top of the tied array class accesses many -elements of the array, far more than we've set the bounds to. Therefore, -it will blow up once they try to access beyond the 2nd element of @ary, as -the following output demonstrates: - - setting index 0: value of elt 0 now 0 - setting index 1: value of elt 1 now 10 - setting index 2: value of elt 2 now 20 - setting index 3: Array OOB: 3 > 2 at Bounded_Array.pm line 39 - Bounded_Array::FETCH called at testba line 12 - =head2 Tying Hashes -As the first Perl data type to be tied (see dbmopen()), hashes have the -most complete and useful tie() implementation. A class implementing a -tied hash should define the following methods: TIEHASH is the constructor. -FETCH and STORE access the key and value pairs. EXISTS reports whether a -key is present in the hash, and DELETE deletes one. CLEAR empties the -hash by deleting all the key and value pairs. FIRSTKEY and NEXTKEY -implement the keys() and each() functions to iterate over all the keys. -And DESTROY is called when the tied variable is garbage collected. +Hashes were the first Perl data type to be tied (see dbmopen()). A class +implementing a tied hash should define the following methods: TIEHASH is +the constructor. FETCH and STORE access the key and value pairs. EXISTS +reports whether a key is present in the hash, and DELETE deletes one. +CLEAR empties the hash by deleting all the key and value pairs. FIRSTKEY +and NEXTKEY implement the keys() and each() functions to iterate over all +the keys. UNTIE is called when C<untie> happens, and DESTROY is called when +the tied variable is garbage collected. If this seems like a lot, then feel free to inherit from merely the standard Tie::Hash module for most of your methods, redefining only the @@ -384,7 +545,7 @@ that calls it. Here are the methods for the DotFiles tied hash. -=over +=over 4 =item TIEHASH classname, LIST @@ -593,6 +754,10 @@ thing, but we'll have to go through the LIST field indirectly. return each %{ $self->{LIST} } } +=item UNTIE this + +This is called when C<untie> occurs. + =item DESTROY this This method is triggered when a tied hash is about to go out of @@ -623,7 +788,7 @@ This is partially implemented now. A class implementing a tied filehandle should define the following methods: TIEHANDLE, at least one of PRINT, PRINTF, WRITE, READLINE, GETC, -READ, and possibly CLOSE and DESTROY. The class can also provide: BINMODE, +READ, and possibly CLOSE, UNTIE and DESTROY. The class can also provide: BINMODE, OPEN, EOF, FILENO, SEEK, TELL - if the corresponding perl operators are used on the handle. @@ -635,7 +800,7 @@ In our example we're going to create a shouting handle. package Shout; -=over +=over 4 =item TIEHANDLE classname, LIST @@ -712,6 +877,11 @@ function. sub CLOSE { print "CLOSE called.\n" } +=item UNTIE this + +As with the other types of ties, this method will be called when C<untie> happens. +It may be appropriate to "auto CLOSE" when this occurs. + =item DESTROY this As with the other types of ties, this method will be called when the @@ -730,6 +900,11 @@ Here's how to use our little example: print FOO $a, " plus ", $b, " equals ", $a + $b, "\n"; print <FOO>; +=head2 UNTIE this + +You can define for all tie types an UNTIE method that will be called +at untie(). + =head2 The C<untie> Gotcha If you intend making use of the object returned from either tie() or @@ -844,7 +1019,8 @@ closed. The reason there is no output is because the file buffers have not been flushed to disk. Now that you know what the problem is, what can you do to avoid it? -Well, the good old C<-w> flag will spot any instances where you call +Prior to the introduction of the optional UNTIE method the only way +was the good old C<-w> flag. Which will spot any instances where you call untie() and there are still valid references to the tied object. If the second script above this near the top C<use warnings 'untie'> or was run with the C<-w> flag, Perl prints this @@ -859,17 +1035,33 @@ called: undef $x; untie $fred; +Now that UNTIE exists the class designer can decide which parts of the +class functionality are really associated with C<untie> and which with +the object being destroyed. What makes sense for a given class depends +on whether the inner references are being kept so that non-tie-related +methods can be called on the object. But in most cases it probably makes +sense to move the functionality that would have been in DESTROY to the UNTIE +method. + +If the UNTIE method exists then the warning above does not occur. Instead the +UNTIE method is passed the count of "extra" references and can issue its own +warning if appropriate. e.g. to replicate the no UNTIE case this method can +be used: + + sub UNTIE + { + my ($obj,$count) = @_; + carp "untie attempted while $count inner references still exist" if $count; + } + =head1 SEE ALSO See L<DB_File> or L<Config> for some interesting tie() implementations. +A good starting point for many tie() implementations is with one of the +modules L<Tie::Scalar>, L<Tie::Array>, L<Tie::Hash>, or L<Tie::Handle>. =head1 BUGS -Tied arrays are I<incomplete>. They are also distinctly lacking something -for the C<$#ARRAY> access (which is hard, as it's an lvalue), as well as -the other obvious array functions, like push(), pop(), shift(), unshift(), -and splice(). - You cannot easily tie a multilevel data structure (such as a hash of hashes) to a dbm file. The first problem is that all but GDBM and Berkeley DB have size limitations, but beyond that, you also have problems @@ -878,8 +1070,15 @@ module that does attempt to address this need partially is the MLDBM module. Check your nearest CPAN site as described in L<perlmodlib> for source code to MLDBM. +Tied filehandles are still incomplete. sysopen(), truncate(), +flock(), fcntl(), stat() and -X can't currently be trapped. + =head1 AUTHOR Tom Christiansen TIEHANDLE by Sven Verdoolaege <F<skimo@dns.ufsia.ac.be>> and Doug MacEachern <F<dougm@osf.org>> + +UNTIE by Nick Ing-Simmons <F<nick@ing-simmons.net>> + +Tying Arrays by Casey Tweten <F<crt@kiski.net>> diff --git a/contrib/perl5/pod/perltoc.pod b/contrib/perl5/pod/perltoc.pod index 798a24d19363..7bae86ed639f 100644 --- a/contrib/perl5/pod/perltoc.pod +++ b/contrib/perl5/pod/perltoc.pod @@ -13,22 +13,12 @@ through to locate the proper section you're looking for. =head2 perl - Practical Extraction and Report Language -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -modularity and reusability using innumerable modules, embeddable and -extensible, roll-your-own magic variables (including multiple simultaneous -DBM implementations), subroutines can now be overridden, autoloaded, and -prototyped, arbitrarily nested data structures and anonymous functions, -object-oriented programming, compilability into C code or Perl bytecode, -support for light-weight processes (threads), support for -internationalization, localization, and Unicode, lexical scoping, regular -expression enhancements, enhanced debugger and interactive Perl -environment, with integrated editor support, POSIX 1003.1 compliant library - =item AVAILABILITY =item ENVIRONMENT @@ -50,232 +40,41 @@ environment, with integrated editor support, POSIX 1003.1 compliant library =head2 perlfaq - frequently asked questions about Perl ($Date: 1999/05/23 20:38:02 $) -=over - -=item DESCRIPTION - -perlfaq: Structural overview of the FAQ, L<perlfaq1>: General Questions -About Perl, What is Perl?, Who supports Perl? Who develops it? Why is it -free?, Which version of Perl should I use?, What are perl4 and perl5?, What -is perl6?, How stable is Perl?, Is Perl difficult to learn?, How does Perl -compare with other languages like Java, Python, REXX, Scheme, or Tcl?, Can -I do [task] in Perl?, When shouldn't I program in Perl?, What's the -difference between "perl" and "Perl"?, Is it a Perl program or a Perl -script?, What is a JAPH?, Where can I get a list of Larry Wall witticisms?, -How can I convince my sysadmin/supervisor/employees to use version -(5/5.005/Perl instead of some other language)?, L<perlfaq2>: Obtaining and -Learning about Perl, What machines support Perl? Where do I get it?, How -can I get a binary version of Perl?, I don't have a C compiler on my -system. How can I compile perl?, I copied the Perl binary from one machine -to another, but scripts don't work, I grabbed the sources and tried to -compile but gdbm/dynamic loading/malloc/linking/... failed. How do I make -it work?, What modules and extensions are available for Perl? What is -CPAN? What does CPAN/src/... mean?, Is there an ISO or ANSI certified -version of Perl?, Where can I get information on Perl?, What are the Perl -newsgroups on USENET? Where do I post questions?, Where should I post -source code?, Perl Books, Perl in Magazines, Perl on the Net: FTP and WWW -Access, What mailing lists are there for perl?, Archives of -comp.lang.perl.misc, Where can I buy a commercial version of Perl?, Where -do I send bug reports?, What is perl.com?, L<perlfaq3>: Programming Tools, -How do I do (anything)?, How can I use Perl interactively?, Is there a Perl -shell?, How do I debug my Perl programs?, How do I profile my Perl -programs?, How do I cross-reference my Perl programs?, Is there a -pretty-printer (formatter) for Perl?, Is there a ctags for Perl?, Is there -an IDE or Windows Perl Editor?, Where can I get Perl macros for vi?, Where -can I get perl-mode for emacs?, How can I use curses with Perl?, How can I -use X or Tk with Perl?, How can I generate simple menus without using CGI -or Tk?, What is undump?, How can I make my Perl program run faster?, How -can I make my Perl program take less memory?, Is it unsafe to return a -pointer to local data?, How can I free an array or hash so my program -shrinks?, How can I make my CGI script more efficient?, How can I hide the -source for my Perl program?, How can I compile my Perl program into byte -code or C?, How can I compile Perl into Java?, How can I get C<#!perl> to -work on [MS-DOS,NT,...]?, Can I write useful perl programs on the command -line?, Why don't perl one-liners work on my DOS/Mac/VMS system?, Where can -I learn about CGI or Web programming in Perl?, Where can I learn about -object-oriented Perl programming?, Where can I learn about linking C with -Perl? [h2xs, xsubpp], I've read perlembed, perlguts, etc., but I can't -embed perl inmy C program, what am I doing wrong?, When I tried to run my -script, I got this message. What does itmean?, What's MakeMaker?, -L<perlfaq4>: Data Manipulation, Why am I getting long decimals (eg, -19.9499999999999) instead of the numbers I should be getting (eg, 19.95)?, -Why isn't my octal data interpreted correctly?, Does Perl have a round() -function? What about ceil() and floor()? Trig functions?, How do I -convert bits into ints?, Why doesn't & work the way I want it to?, How do I -multiply matrices?, How do I perform an operation on a series of integers?, -How can I output Roman numerals?, Why aren't my random numbers random?, How -do I find the week-of-the-year/day-of-the-year?, How do I find the current -century or millennium?, How can I compare two dates and find the -difference?, How can I take a string and turn it into epoch seconds?, How -can I find the Julian Day?, How do I find yesterday's date?, Does Perl have -a year 2000 problem? Is Perl Y2K compliant?, How do I validate input?, How -do I unescape a string?, How do I remove consecutive pairs of characters?, -How do I expand function calls in a string?, How do I find matching/nesting -anything?, How do I reverse a string?, How do I expand tabs in a string?, -How do I reformat a paragraph?, How can I access/change the first N letters -of a string?, How do I change the Nth occurrence of something?, How can I -count the number of occurrences of a substring within a string?, How do I -capitalize all the words on one line?, How can I split a [character] -delimited string except when inside[character]? (Comma-separated files), -How do I strip blank space from the beginning/end of a string?, How do I -pad a string with blanks or pad a number with zeroes?, How do I extract -selected columns from a string?, How do I find the soundex value of a -string?, How can I expand variables in text strings?, What's wrong with -always quoting "$vars"?, Why don't my <<HERE documents work?, What is the -difference between a list and an array?, What is the difference between -$array[1] and @array[1]?, How can I remove duplicate elements from a list -or array?, How can I tell whether a list or array contains a certain -element?, How do I compute the difference of two arrays? How do I compute -the intersection of two arrays?, How do I test whether two arrays or hashes -are equal?, How do I find the first array element for which a condition is -true?, How do I handle linked lists?, How do I handle circular lists?, How -do I shuffle an array randomly?, How do I process/modify each element of an -array?, How do I select a random element from an array?, How do I permute N -elements of a list?, How do I sort an array by (anything)?, How do I -manipulate arrays of bits?, Why does defined() return true on empty arrays -and hashes?, How do I process an entire hash?, What happens if I add or -remove keys from a hash while iterating over it?, How do I look up a hash -element by value?, How can I know how many entries are in a hash?, How do I -sort a hash (optionally by value instead of key)?, How can I always keep my -hash sorted?, What's the difference between "delete" and "undef" with -hashes?, Why don't my tied hashes make the defined/exists distinction?, How -do I reset an each() operation part-way through?, How can I get the unique -keys from two hashes?, How can I store a multidimensional array in a DBM -file?, How can I make my hash remember the order I put elements into it?, -Why does passing a subroutine an undefined element in a hash create it?, -How can I make the Perl equivalent of a C structure/C++ class/hash or array -of hashes or arrays?, How can I use a reference as a hash key?, How do I -handle binary data correctly?, How do I determine whether a scalar is a -number/whole/integer/float?, How do I keep persistent data across program -calls?, How do I print out or copy a recursive data structure?, How do I -define methods for every class/object?, How do I verify a credit card -checksum?, How do I pack arrays of doubles or floats for XS code?, -L<perlfaq5>: Files and Formats, How do I flush/unbuffer an output -filehandle? Why must I do this?, How do I change one line in a file/delete -a line in a file/insert a line in the middle of a file/append to the -beginning of a file?, How do I count the number of lines in a file?, How do -I make a temporary file name?, How can I manipulate fixed-record-length -files?, How can I make a filehandle local to a subroutine? How do I pass -filehandles between subroutines? How do I make an array of filehandles?, -How can I use a filehandle indirectly?, How can I set up a footer format to -be used with write()?, How can I write() into a string?, How can I output -my numbers with commas added?, How can I translate tildes (~) in a -filename?, How come when I open a file read-write it wipes it out?, Why do -I sometimes get an "Argument list too long" when I use <*>?, Is there a -leak/bug in glob()?, How can I open a file with a leading ">" or trailing -blanks?, How can I reliably rename a file?, How can I lock a file?, Why -can't I just open(FH, ">file.lock")?, I still don't get locking. I just -want to increment the number in the file. How can I do this?, How do I -randomly update a binary file?, How do I get a file's timestamp in perl?, -How do I set a file's timestamp in perl?, How do I print to more than one -file at once?, How can I read in an entire file all at once?, How can I -read in a file by paragraphs?, How can I read a single character from a -file? From the keyboard?, How can I tell whether there's a character -waiting on a filehandle?, How do I do a C<tail -f> in perl?, How do I dup() -a filehandle in Perl?, How do I close a file descriptor by number?, Why -can't I use "C:\temp\foo" in DOS paths? What doesn't `C:\temp\foo.exe` -work?, Why doesn't glob("*.*") get all the files?, Why does Perl let me -delete read-only files? Why does C<-i> clobber protected files? Isn't -this a bug in Perl?, How do I select a random line from a file?, Why do I -get weird spaces when I print an array of lines?, L<perlfaq6>: Regexps, How -can I hope to use regular expressions without creating illegible and -unmaintainable code?, I'm having trouble matching over more than one line. -What's wrong?, How can I pull out lines between two patterns that are -themselves on different lines?, I put a regular expression into $/ but it -didn't work. What's wrong?, How do I substitute case insensitively on the -LHS, but preserving case on the RHS?, How can I make C<\w> match national -character sets?, How can I match a locale-smart version of C</[a-zA-Z]/>?, -How can I quote a variable to use in a regex?, What is C</o> really for?, -How do I use a regular expression to strip C style comments from a file?, -Can I use Perl regular expressions to match balanced text?, What does it -mean that regexes are greedy? How can I get around it?, How do I process -each word on each line?, How can I print out a word-frequency or -line-frequency summary?, How can I do approximate matching?, How do I -efficiently match many regular expressions at once?, Why don't -word-boundary searches with C<\b> work for me?, Why does using $&, $`, or -$' slow my program down?, What good is C<\G> in a regular expression?, Are -Perl regexes DFAs or NFAs? Are they POSIX compliant?, What's wrong with -using grep or map in a void context?, How can I match strings with -multibyte characters?, How do I match a pattern that is supplied by the -user?, L<perlfaq7>: General Perl Language Issues, Can I get a BNF/yacc/RE -for the Perl language?, What are all these $@%&* punctuation signs, and how -do I know when to use them?, Do I always/never have to quote my strings or -use semicolons and commas?, How do I skip some return values?, How do I -temporarily block warnings?, What's an extension?, Why do Perl operators -have different precedence than C operators?, How do I declare/create a -structure?, How do I create a module?, How do I create a class?, How can I -tell if a variable is tainted?, What's a closure?, What is variable suicide -and how can I prevent it?, How can I pass/return a {Function, FileHandle, -Array, Hash, Method, Regex}?, How do I create a static variable?, What's -the difference between dynamic and lexical (static) scoping? Between -local() and my()?, How can I access a dynamic variable while a similarly -named lexical is in scope?, What's the difference between deep and shallow -binding?, Why doesn't "my($foo) = <FILE>;" work right?, How do I redefine a -builtin function, operator, or method?, What's the difference between -calling a function as &foo and foo()?, How do I create a switch or case -statement?, How can I catch accesses to undefined -variables/functions/methods?, Why can't a method included in this same file -be found?, How can I find out my current package?, How can I comment out a -large block of perl code?, How do I clear a package?, How can I use a -variable as a variable name?, L<perlfaq8>: System Interaction, How do I -find out which operating system I'm running under?, How come exec() doesn't -return?, How do I do fancy stuff with the keyboard/screen/mouse?, How do I -print something out in color?, How do I read just one key without waiting -for a return key?, How do I check whether input is ready on the keyboard?, -How do I clear the screen?, How do I get the screen size?, How do I ask the -user for a password?, How do I read and write the serial port?, How do I -decode encrypted password files?, How do I start a process in the -background?, How do I trap control characters/signals?, How do I modify the -shadow password file on a Unix system?, How do I set the time and date?, -How can I sleep() or alarm() for under a second?, How can I measure time -under a second?, How can I do an atexit() or setjmp()/longjmp()? (Exception -handling), Why doesn't my sockets program work under System V (Solaris)? -What does the error message "Protocol not supported" mean?, How can I call -my system's unique C functions from Perl?, Where do I get the include files -to do ioctl() or syscall()?, Why do setuid perl scripts complain about -kernel problems?, How can I open a pipe both to and from a command?, Why -can't I get the output of a command with system()?, How can I capture -STDERR from an external command?, Why doesn't open() return an error when a -pipe open fails?, What's wrong with using backticks in a void context?, How -can I call backticks without shell processing?, Why can't my script read -from STDIN after I gave it EOF (^D on Unix, ^Z on MS-DOS)?, How can I -convert my shell script to perl?, Can I use perl to run a telnet or ftp -session?, How can I write expect in Perl?, Is there a way to hide perl's -command line from programs such as "ps"?, I {changed directory, modified my -environment} in a perl script. How come the change disappeared when I -exited the script? How do I get my changes to be visible?, How do I close -a process's filehandle without waiting for it to complete?, How do I fork a -daemon process?, How do I make my program run with sh and csh?, How do I -find out if I'm running interactively or not?, How do I timeout a slow -event?, How do I set CPU limits?, How do I avoid zombies on a Unix system?, -How do I use an SQL database?, How do I make a system() exit on control-C?, -How do I open a file without blocking?, How do I install a module from -CPAN?, What's the difference between require and use?, How do I keep my own -module/library directory?, How do I add the directory my program lives in -to the module/library search path?, How do I add a directory to my include -path at runtime?, What is socket.ph and where do I get it?, L<perlfaq9>: -Networking, My CGI script runs from the command line but not the browser. -(500 Server Error), How can I get better error messages from a CGI -program?, How do I remove HTML from a string?, How do I extract URLs?, How -do I download a file from the user's machine? How do I open a file on -another machine?, How do I make a pop-up menu in HTML?, How do I fetch an -HTML file?, How do I automate an HTML form submission?, How do I decode or -create those %-encodings on the web?, How do I redirect to another page?, -How do I put a password on my web pages?, How do I edit my .htpasswd and -.htgroup files with Perl?, How do I make sure users can't enter values into -a form that cause my CGI script to do bad things?, How do I parse a mail -header?, How do I decode a CGI form?, How do I check a valid mail address?, -How do I decode a MIME/BASE64 string?, How do I return the user's mail -address?, How do I send mail?, How do I read mail?, How do I find out my -hostname/domainname/IP address?, How do I fetch a news article or the -active newsgroups?, How do I fetch/put an FTP file?, How can I do RPC in -Perl? - -=over - -=item Where to get this document - -=item How to contribute to this document +=over 4 + +=item DESCRIPTION + +=over 4 + +=item perlfaq: Structural overview of the FAQ. + +=item L<perlfaq1>: General Questions About Perl + +=item L<perlfaq2>: Obtaining and Learning about Perl + +=item L<perlfaq3>: Programming Tools + +=item L<perlfaq4>: Data Manipulation + +=item L<perlfaq5>: Files and Formats + +=item L<perlfaq6>: Regexps + +=item L<perlfaq7>: General Perl Language Issues + +=item L<perlfaq8>: System Interaction + +=item L<perlfaq9>: Networking + +=back + +=item About the perlfaq documents + +=over 4 + +=item Where to get the perlfaq + +=item How to contribute to the perlfaq =item What will happen if you mail your Perl programming problems to the authors @@ -286,7 +85,7 @@ authors =item Author and Copyright Information -=over +=over 4 =item Bundled Distributions @@ -296,19 +95,2244 @@ authors =item Changes -23/May/99, 13/April/99, 7/January/99, 22/June/98, 24/April/97, 23/April/97, -25/March/97, 18/March/97, 17/March/97 Version, Initial Release: 11/March/97 +1/November/2000, 23/May/99, 13/April/99, 7/January/99, 22/June/98, +24/April/97, 23/April/97, 25/March/97, 18/March/97, 17/March/97 Version, +Initial Release: 11/March/97 + +=back + +=head2 perlbook - Perl book information + +=over 4 + +=item DESCRIPTION + +=back + +=head2 perlsyn - Perl syntax + +=over 4 + +=item DESCRIPTION + +=over 4 + +=item Declarations + +=item Simple statements + +=item Compound statements + +=item Loop Control + +=item For Loops + +=item Foreach Loops + +=item Basic BLOCKs and Switch Statements + +=item Goto + +=item PODs: Embedded Documentation + +=item Plain Old Comments (Not!) + +=back + +=back + +=head2 perldata - Perl data types + +=over 4 + +=item DESCRIPTION + +=over 4 + +=item Variable names + +=item Context + +=item Scalar values + +=item Scalar value constructors + +=item List value constructors + +=item Slices + +=item Typeglobs and Filehandles + +=back + +=item SEE ALSO + +=back + +=head2 perlop - Perl operators and precedence + +=over 4 + +=item SYNOPSIS + +=item DESCRIPTION + +=over 4 + +=item Terms and List Operators (Leftward) + +=item The Arrow Operator + +=item Auto-increment and Auto-decrement + +=item Exponentiation + +=item Symbolic Unary Operators + +=item Binding Operators + +=item Multiplicative Operators + +=item Additive Operators + +=item Shift Operators + +=item Named Unary Operators + +=item Relational Operators + +=item Equality Operators + +=item Bitwise And + +=item Bitwise Or and Exclusive Or + +=item C-style Logical And + +=item C-style Logical Or + +=item Range Operators + +=item Conditional Operator + +=item Assignment Operators + +=item Comma Operator + +=item List Operators (Rightward) + +=item Logical Not + +=item Logical And + +=item Logical or and Exclusive Or + +=item C Operators Missing From Perl + +unary &, unary *, (TYPE) + +=item Quote and Quote-like Operators + +=item Regexp Quote-Like Operators + +?PATTERN?, m/PATTERN/cgimosx, /PATTERN/cgimosx, q/STRING/, C<'STRING'>, +qq/STRING/, "STRING", qr/STRING/imosx, qx/STRING/, `STRING`, qw/STRING/, +s/PATTERN/REPLACEMENT/egimosx, tr/SEARCHLIST/REPLACEMENTLIST/cds, +y/SEARCHLIST/REPLACEMENTLIST/cds + +=item Gory details of parsing quoted constructs + +Finding the end, Removal of backslashes before delimiters, Interpolation, +C<<<'EOF'>, C<m''>, C<s'''>, C<tr///>, C<y///>, C<''>, C<q//>, C<"">, +C<``>, C<qq//>, C<qx//>, C<< <file*glob> >>, C<?RE?>, C</RE/>, C<m/RE/>, +C<s/RE/foo/>,, Interpolation of regular expressions, Optimization of +regular expressions + +=item I/O Operators + +=item Constant Folding + +=item Bitwise String Operators + +=item Integer Arithmetic + +=item Floating-point Arithmetic + +=item Bigger Numbers + +=back + +=back + +=head2 perlsub - Perl subroutines + +=over 4 + +=item SYNOPSIS + +=item DESCRIPTION + +=over 4 + +=item Private Variables via my() + +=item Persistent Private Variables + +=item Temporary Values via local() + +=item Lvalue subroutines + +=item Passing Symbol Table Entries (typeglobs) + +=item When to Still Use local() + +=item Pass by Reference + +=item Prototypes + +=item Constant Functions + +=item Overriding Built-in Functions + +=item Autoloading + +=item Subroutine Attributes + +=back + +=item SEE ALSO + +=back + +=head2 perlfunc - Perl builtin functions + +=over 4 + +=item DESCRIPTION + +=over 4 + +=item Perl Functions by Category + +Functions for SCALARs or strings, Regular expressions and pattern matching, +Numeric functions, Functions for real @ARRAYs, Functions for list data, +Functions for real %HASHes, Input and output functions, Functions for fixed +length data or records, Functions for filehandles, files, or directories, +Keywords related to the control flow of your perl program, Keywords related +to scoping, Miscellaneous functions, Functions for processes and process +groups, Keywords related to perl modules, Keywords related to classes and +object-orientedness, Low-level socket functions, System V interprocess +communication functions, Fetching user and group info, Fetching network +info, Time-related functions, Functions new in perl5, Functions obsoleted +in perl5 + +=item Portability + +=item Alphabetical Listing of Perl Functions + +I<-X> FILEHANDLE, I<-X> EXPR, I<-X>, abs VALUE, abs, accept +NEWSOCKET,GENERICSOCKET, alarm SECONDS, alarm, atan2 Y,X, bind SOCKET,NAME, +binmode FILEHANDLE, DISCIPLINE, binmode FILEHANDLE, bless REF,CLASSNAME, +bless REF, caller EXPR, caller, chdir EXPR, chmod LIST, chomp VARIABLE, +chomp LIST, chomp, chop VARIABLE, chop LIST, chop, chown LIST, chr NUMBER, +chr, chroot FILENAME, chroot, close FILEHANDLE, close, closedir DIRHANDLE, +connect SOCKET,NAME, continue BLOCK, cos EXPR, cos, crypt PLAINTEXT,SALT, +dbmclose HASH, dbmopen HASH,DBNAME,MASK, defined EXPR, defined, delete +EXPR, die LIST, do BLOCK, do SUBROUTINE(LIST), do EXPR, dump LABEL, dump, +each HASH, eof FILEHANDLE, eof (), eof, eval EXPR, eval BLOCK, exec LIST, +exec PROGRAM LIST, exists EXPR, exit EXPR, exp EXPR, exp, fcntl +FILEHANDLE,FUNCTION,SCALAR, fileno FILEHANDLE, flock FILEHANDLE,OPERATION, +fork, format, formline PICTURE,LIST, getc FILEHANDLE, getc, getlogin, +getpeername SOCKET, getpgrp PID, getppid, getpriority WHICH,WHO, getpwnam +NAME, getgrnam NAME, gethostbyname NAME, getnetbyname NAME, getprotobyname +NAME, getpwuid UID, getgrgid GID, getservbyname NAME,PROTO, gethostbyaddr +ADDR,ADDRTYPE, getnetbyaddr ADDR,ADDRTYPE, getprotobynumber NUMBER, +getservbyport PORT,PROTO, getpwent, getgrent, gethostent, getnetent, +getprotoent, getservent, setpwent, setgrent, sethostent STAYOPEN, setnetent +STAYOPEN, setprotoent STAYOPEN, setservent STAYOPEN, endpwent, endgrent, +endhostent, endnetent, endprotoent, endservent, getsockname SOCKET, +getsockopt SOCKET,LEVEL,OPTNAME, glob EXPR, glob, gmtime EXPR, goto LABEL, +goto EXPR, goto &NAME, grep BLOCK LIST, grep EXPR,LIST, hex EXPR, hex, +import, index STR,SUBSTR,POSITION, index STR,SUBSTR, int EXPR, int, ioctl +FILEHANDLE,FUNCTION,SCALAR, join EXPR,LIST, keys HASH, kill SIGNAL, LIST, +last LABEL, last, lc EXPR, lc, lcfirst EXPR, lcfirst, length EXPR, length, +link OLDFILE,NEWFILE, listen SOCKET,QUEUESIZE, local EXPR, localtime EXPR, +lock, log EXPR, log, lstat FILEHANDLE, lstat EXPR, lstat, m//, map BLOCK +LIST, map EXPR,LIST, mkdir FILENAME,MASK, mkdir FILENAME, msgctl +ID,CMD,ARG, msgget KEY,FLAGS, msgrcv ID,VAR,SIZE,TYPE,FLAGS, msgsnd +ID,MSG,FLAGS, my EXPR, my EXPR : ATTRIBUTES, next LABEL, next, no Module +LIST, oct EXPR, oct, open FILEHANDLE,MODE,LIST, open FILEHANDLE,EXPR, open +FILEHANDLE, opendir DIRHANDLE,EXPR, ord EXPR, ord, our EXPR, pack +TEMPLATE,LIST, package NAMESPACE, package, pipe READHANDLE,WRITEHANDLE, pop +ARRAY, pop, pos SCALAR, pos, print FILEHANDLE LIST, print LIST, print, +printf FILEHANDLE FORMAT, LIST, printf FORMAT, LIST, prototype FUNCTION, +push ARRAY,LIST, q/STRING/, qq/STRING/, qr/STRING/, qx/STRING/, qw/STRING/, +quotemeta EXPR, quotemeta, rand EXPR, rand, read +FILEHANDLE,SCALAR,LENGTH,OFFSET, read FILEHANDLE,SCALAR,LENGTH, readdir +DIRHANDLE, readline EXPR, readlink EXPR, readlink, readpipe EXPR, recv +SOCKET,SCALAR,LENGTH,FLAGS, redo LABEL, redo, ref EXPR, ref, rename +OLDNAME,NEWNAME, require VERSION, require EXPR, require, reset EXPR, reset, +return EXPR, return, reverse LIST, rewinddir DIRHANDLE, rindex +STR,SUBSTR,POSITION, rindex STR,SUBSTR, rmdir FILENAME, rmdir, s///, scalar +EXPR, seek FILEHANDLE,POSITION,WHENCE, seekdir DIRHANDLE,POS, select +FILEHANDLE, select, select RBITS,WBITS,EBITS,TIMEOUT, semctl +ID,SEMNUM,CMD,ARG, semget KEY,NSEMS,FLAGS, semop KEY,OPSTRING, send +SOCKET,MSG,FLAGS,TO, send SOCKET,MSG,FLAGS, setpgrp PID,PGRP, setpriority +WHICH,WHO,PRIORITY, setsockopt SOCKET,LEVEL,OPTNAME,OPTVAL, shift ARRAY, +shift, shmctl ID,CMD,ARG, shmget KEY,SIZE,FLAGS, shmread ID,VAR,POS,SIZE, +shmwrite ID,STRING,POS,SIZE, shutdown SOCKET,HOW, sin EXPR, sin, sleep +EXPR, sleep, socket SOCKET,DOMAIN,TYPE,PROTOCOL, socketpair +SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL, sort SUBNAME LIST, sort BLOCK LIST, +sort LIST, splice ARRAY,OFFSET,LENGTH,LIST, splice ARRAY,OFFSET,LENGTH, +splice ARRAY,OFFSET, splice ARRAY, split /PATTERN/,EXPR,LIMIT, split +/PATTERN/,EXPR, split /PATTERN/, split, sprintf FORMAT, LIST, sqrt EXPR, +sqrt, srand EXPR, srand, stat FILEHANDLE, stat EXPR, stat, study SCALAR, +study, sub BLOCK, sub NAME, sub NAME BLOCK, substr +EXPR,OFFSET,LENGTH,REPLACEMENT, substr EXPR,OFFSET,LENGTH, substr +EXPR,OFFSET, symlink OLDFILE,NEWFILE, syscall LIST, sysopen +FILEHANDLE,FILENAME,MODE, sysopen FILEHANDLE,FILENAME,MODE,PERMS, sysread +FILEHANDLE,SCALAR,LENGTH,OFFSET, sysread FILEHANDLE,SCALAR,LENGTH, sysseek +FILEHANDLE,POSITION,WHENCE, system LIST, system PROGRAM LIST, syswrite +FILEHANDLE,SCALAR,LENGTH,OFFSET, syswrite FILEHANDLE,SCALAR,LENGTH, +syswrite FILEHANDLE,SCALAR, tell FILEHANDLE, tell, telldir DIRHANDLE, tie +VARIABLE,CLASSNAME,LIST, tied VARIABLE, time, times, tr///, truncate +FILEHANDLE,LENGTH, truncate EXPR,LENGTH, uc EXPR, uc, ucfirst EXPR, +ucfirst, umask EXPR, umask, undef EXPR, undef, unlink LIST, unlink, unpack +TEMPLATE,EXPR, untie VARIABLE, unshift ARRAY,LIST, use Module VERSION LIST, +use Module VERSION, use Module LIST, use Module, use VERSION, utime LIST, +values HASH, vec EXPR,OFFSET,BITS, wait, waitpid PID,FLAGS, wantarray, warn +LIST, write FILEHANDLE, write EXPR, write, y/// + +=back + +=back + +=head2 perlreftut - Mark's very short tutorial about references + +=over 4 + +=item DESCRIPTION + +=item Who Needs Complicated Data Structures? + +=item The Solution + +=item Syntax + +=over 4 + +=item Making References + +=item Using References + +=back + +=item An Example + +=item Arrow Rule + +=item Solution + +=item The Rest + +=item Summary + +=item Credits + +=over 4 + +=item Distribution Conditions + +=back + +=back + +=head2 perldsc - Perl Data Structures Cookbook + +=over 4 + +=item DESCRIPTION + +arrays of arrays, hashes of arrays, arrays of hashes, hashes of hashes, +more elaborate constructs + +=item REFERENCES + +=item COMMON MISTAKES + +=item CAVEAT ON PRECEDENCE + +=item WHY YOU SHOULD ALWAYS C<use strict> + +=item DEBUGGING + +=item CODE EXAMPLES + +=item ARRAYS OF ARRAYS + +=over 4 + +=item Declaration of a ARRAY OF ARRAYS + +=item Generation of a ARRAY OF ARRAYS + +=item Access and Printing of a ARRAY OF ARRAYS + +=back + +=item HASHES OF ARRAYS + +=over 4 + +=item Declaration of a HASH OF ARRAYS + +=item Generation of a HASH OF ARRAYS + +=item Access and Printing of a HASH OF ARRAYS + +=back + +=item ARRAYS OF HASHES + +=over 4 + +=item Declaration of a ARRAY OF HASHES + +=item Generation of a ARRAY OF HASHES + +=item Access and Printing of a ARRAY OF HASHES + +=back + +=item HASHES OF HASHES + +=over 4 + +=item Declaration of a HASH OF HASHES + +=item Generation of a HASH OF HASHES + +=item Access and Printing of a HASH OF HASHES + +=back + +=item MORE ELABORATE RECORDS + +=over 4 + +=item Declaration of MORE ELABORATE RECORDS + +=item Declaration of a HASH OF COMPLEX RECORDS + +=item Generation of a HASH OF COMPLEX RECORDS + +=back + +=item Database Ties + +=item SEE ALSO + +=item AUTHOR + +=back + +=head2 perlrequick - Perl regular expressions quick start + +=over 4 + +=item DESCRIPTION + +=item The Guide + +=over 4 + +=item Simple word matching + +=item Using character classes + +=item Matching this or that + +=item Grouping things and hierarchical matching + +=item Extracting matches + +=item Matching repetitions + +=item More matching + +=item Search and replace + +=item The split operator + +=back + +=item BUGS + +=item SEE ALSO + +=item AUTHOR AND COPYRIGHT + +=over 4 + +=item Acknowledgments + +=back + +=back + +=head2 perlpod - plain old documentation + +=over 4 + +=item DESCRIPTION + +=over 4 + +=item Verbatim Paragraph + +=item Command Paragraph + +=item Ordinary Block of Text + +=item The Intent + +=item Embedding Pods in Perl Modules + +=item Common Pod Pitfalls + +=back + +=item SEE ALSO + +=item AUTHOR + +=back + +=head2 perlstyle - Perl style guide + +=over 4 + +=item DESCRIPTION + +=back + +=head2 perltrap - Perl traps for the unwary + +=over 4 + +=item DESCRIPTION + +=over 4 + +=item Awk Traps + +=item C Traps + +=item Sed Traps + +=item Shell Traps + +=item Perl Traps + +=item Perl4 to Perl5 Traps + +Discontinuance, Deprecation, and BugFix traps, Parsing Traps, Numerical +Traps, General data type traps, Context Traps - scalar, list contexts, +Precedence Traps, General Regular Expression Traps using s///, etc, +Subroutine, Signal, Sorting Traps, OS Traps, DBM Traps, Unclassified Traps + +=item Discontinuance, Deprecation, and BugFix traps + +Discontinuance, Deprecation, BugFix, Discontinuance, Discontinuance, +Discontinuance, BugFix, Discontinuance, Discontinuance, BugFix, +Discontinuance, Deprecation, Discontinuance, Discontinuance + +=item Parsing Traps + +Parsing, Parsing, Parsing, Parsing + +=item Numerical Traps + +Numerical, Numerical, Numerical, Bitwise string ops + +=item General data type traps + +(Arrays), (Arrays), (Hashes), (Globs), (Globs), (Scalar String), +(Constants), (Scalars), (Variable Suicide) + +=item Context Traps - scalar, list contexts + +(list context), (scalar context), (scalar context), (list, builtin) + +=item Precedence Traps + +Precedence, Precedence, Precedence, Precedence, Precedence, Precedence, +Precedence + +=item General Regular Expression Traps using s///, etc. + +Regular Expression, Regular Expression, Regular Expression, Regular +Expression, Regular Expression, Regular Expression, Regular Expression, +Regular Expression + +=item Subroutine, Signal, Sorting Traps + +(Signals), (Sort Subroutine), warn() won't let you specify a filehandle + +=item OS Traps + +(SysV), (SysV) + +=item Interpolation Traps + +Interpolation, Interpolation, Interpolation, Interpolation, Interpolation, +Interpolation, Interpolation, Interpolation, Interpolation + +=item DBM Traps + +DBM, DBM + +=item Unclassified Traps + +C<require>/C<do> trap using returned value, C<split> on empty string with +LIMIT specified + +=back + +=back + +=head2 perlrun - how to execute the Perl interpreter + +=over 4 + +=item SYNOPSIS + +=item DESCRIPTION + +=over 4 + +=item #! and quoting on non-Unix systems + +OS/2, MS-DOS, Win95/NT, Macintosh, VMS + +=item Location of Perl + +=item Command Switches + +B<-0>[I<digits>], B<-a>, B<-C>, B<-c>, B<-d>, B<-d:>I<foo[=bar,baz]>, +B<-D>I<letters>, B<-D>I<number>, B<-e> I<commandline>, B<-F>I<pattern>, +B<-h>, B<-i>[I<extension>], B<-I>I<directory>, B<-l>[I<octnum>], +B<-m>[B<->]I<module>, B<-M>[B<->]I<module>, B<-M>[B<->]I<'module ...'>, +B<-[mM]>[B<->]I<module=arg[,arg]...>, B<-n>, B<-p>, B<-P>, B<-s>, B<-S>, +B<-T>, B<-u>, B<-U>, B<-v>, B<-V>, B<-V:>I<name>, B<-w>, B<-W>, B<-X>, +B<-x> I<directory> + +=back + +=item ENVIRONMENT + +HOME, LOGDIR, PATH, PERL5LIB, PERL5OPT, PERLLIB, PERL5DB, PERL5SHELL +(specific to the Win32 port), PERL_DEBUG_MSTATS, PERL_DESTRUCT_LEVEL, +PERL_ROOT (specific to the VMS port), SYS$LOGIN (specific to the VMS port) + +=back + +=head2 perldiag - various Perl diagnostics + +=over 4 + +=item DESCRIPTION + +=back + +=head2 perllexwarn - Perl Lexical Warnings + +=over 4 + +=item DESCRIPTION + +=over 4 + +=item Default Warnings and Optional Warnings + +=item What's wrong with B<-w> and C<$^W> + +=item Controlling Warnings from the Command Line + +B<-w>, B<-W>, B<-X> + +=item Backward Compatibility + +=item Category Hierarchy + +=item Fatal Warnings + +=item Reporting Warnings from a Module + +=back + +=item TODO + +=item SEE ALSO + +=item AUTHOR + +=back + +=head2 perldebtut - Perl debugging tutorial + +=over 4 + +=item DESCRIPTION + +=item use strict + +=item Looking at data and -w and w + +=item help + +=item Stepping through code + +=item Placeholder for a, w, t, T + +=item REGULAR EXPRESSIONS + +=item OUTPUT TIPS + +=item CGI + +=item GUIs + +=item SUMMARY + +=item SEE ALSO + +=item AUTHOR + +=item CONTRIBUTORS + +=back + +=head2 perldebug - Perl debugging + +=over 4 + +=item DESCRIPTION + +=item The Perl Debugger + +=over 4 + +=item Debugger Commands + +h [command], p expr, x expr, V [pkg [vars]], X [vars], T, s [expr], n +[expr], r, <CR>, c [line|sub], l, l min+incr, l min-max, l line, l subname, +-, w [line], f filename, /pattern/, ?pattern?, L, S [[!]regex], t, t expr, +b [line] [condition], b subname [condition], b postpone subname +[condition], b load filename, b compile subname, d [line], D, a [line] +command, a [line], A, W expr, W, O booloption .., O anyoption? .., O +option=value .., < ?, < [ command ], << command, > ?, > command, >> +command, { ?, { [ command ], {{ command, ! number, ! -number, ! pattern, !! +cmd, H -number, q or ^D, R, |dbcmd, ||dbcmd, command, m expr, man [manpage] + +=item Configurable Options + +C<recallCommand>, C<ShellBang>, C<pager>, C<tkRunning>, C<signalLevel>, +C<warnLevel>, C<dieLevel>, C<AutoTrace>, C<LineInfo>, C<inhibit_exit>, +C<PrintRet>, C<ornaments>, C<frame>, C<maxTraceLen>, C<arrayDepth>, +C<hashDepth>, C<compactDump>, C<veryCompact>, C<globPrint>, C<DumpDBFiles>, +C<DumpPackages>, C<DumpReused>, C<quote>, C<HighBit>, C<undefPrint>, +C<UsageOnly>, C<TTY>, C<noTTY>, C<ReadLine>, C<NonStop> + +=item Debugger input/output + +Prompt, Multiline commands, Stack backtrace, Line Listing Format, Frame +listing + +=item Debugging compile-time statements + +=item Debugger Customization + +=item Readline Support + +=item Editor Support for Debugging + +=item The Perl Profiler + +=back + +=item Debugging regular expressions + +=item Debugging memory usage + +=item SEE ALSO + +=item BUGS + +=back + +=head2 perlvar - Perl predefined variables + +=over 4 + +=item DESCRIPTION + +=over 4 + +=item Predefined Names + +$ARG, $_, $<I<digits>>, $MATCH, $&, $PREMATCH, $`, $POSTMATCH, $', +$LAST_PAREN_MATCH, $+, @LAST_MATCH_END, @+, $MULTILINE_MATCHING, $*, +input_line_number HANDLE EXPR, $INPUT_LINE_NUMBER, $NR, $, +input_record_separator HANDLE EXPR, $INPUT_RECORD_SEPARATOR, $RS, $/, +autoflush HANDLE EXPR, $OUTPUT_AUTOFLUSH, $|, output_field_separator HANDLE +EXPR, $OUTPUT_FIELD_SEPARATOR, $OFS, $,, output_record_separator HANDLE +EXPR, $OUTPUT_RECORD_SEPARATOR, $ORS, $\, $LIST_SEPARATOR, $", +$SUBSCRIPT_SEPARATOR, $SUBSEP, $;, $OFMT, $#, format_page_number HANDLE +EXPR, $FORMAT_PAGE_NUMBER, $%, format_lines_per_page HANDLE EXPR, +$FORMAT_LINES_PER_PAGE, $=, format_lines_left HANDLE EXPR, +$FORMAT_LINES_LEFT, $-, @LAST_MATCH_START, @-, C<$`> is the same as +C<substr($var, 0, $-[0])>, C<$&> is the same as C<substr($var, $-[0], $+[0] +- $-[0])>, C<$'> is the same as C<substr($var, $+[0])>, C<$1> is the same +as C<substr($var, $-[1], $+[1] - $-[1])>, C<$2> is the same as +C<substr($var, $-[2], $+[2] - $-[2])>, C<$3> is the same as C<substr $var, +$-[3], $+[3] - $-[3])>, format_name HANDLE EXPR, $FORMAT_NAME, $~, +format_top_name HANDLE EXPR, $FORMAT_TOP_NAME, $^, +format_line_break_characters HANDLE EXPR, $FORMAT_LINE_BREAK_CHARACTERS, +$:, format_formfeed HANDLE EXPR, $FORMAT_FORMFEED, $^L, $ACCUMULATOR, $^A, +$CHILD_ERROR, $?, $OS_ERROR, $ERRNO, $!, $EXTENDED_OS_ERROR, $^E, +$EVAL_ERROR, $@, $PROCESS_ID, $PID, $$, $REAL_USER_ID, $UID, $<, +$EFFECTIVE_USER_ID, $EUID, $>, $REAL_GROUP_ID, $GID, $(, +$EFFECTIVE_GROUP_ID, $EGID, $), $PROGRAM_NAME, $0, $[, $], $COMPILING, $^C, +$DEBUGGING, $^D, $SYSTEM_FD_MAX, $^F, $^H, %^H, $INPLACE_EDIT, $^I, $^M, +$OSNAME, $^O, $PERLDB, $^P, 0x01, 0x02, 0x04, 0x08, 0x10, 0x20, 0x40, 0x80, +0x100, 0x200, $LAST_REGEXP_CODE_RESULT, $^R, $EXCEPTIONS_BEING_CAUGHT, $^S, +$BASETIME, $^T, $PERL_VERSION, $^V, $WARNING, $^W, ${^WARNING_BITS}, +${^WIDE_SYSTEM_CALLS}, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @INC, @_, %INC, +%ENV, $ENV{expr}, %SIG, $SIG{expr} + +=item Error Indicators + +=item Technical Note on the Syntax of Variable Names + +=back + +=item BUGS + +=back + +=head2 perllol - Manipulating Arrays of Arrays in Perl + +=over 4 + +=item DESCRIPTION + +=over 4 + +=item Declaration and Access of Arrays of Arrays + +=item Growing Your Own + +=item Access and Printing + +=item Slices + +=back + +=item SEE ALSO + +=item AUTHOR + +=back + +=head2 perlopentut - tutorial on opening things in Perl + +=over 4 + +=item DESCRIPTION + +=item Open E<agrave> la shell + +=over 4 + +=item Simple Opens + +=item Pipe Opens + +=item The Minus File + +=item Mixing Reads and Writes + +=item Filters + +=back + +=item Open E<agrave> la C + +=over 4 + +=item Permissions E<agrave> la mode + +=back + +=item Obscure Open Tricks + +=over 4 + +=item Re-Opening Files (dups) + +=item Dispelling the Dweomer + +=item Paths as Opens + +=item Single Argument Open + +=item Playing with STDIN and STDOUT + +=back + +=item Other I/O Issues + +=over 4 + +=item Opening Non-File Files + +=item Binary Files + +=item File Locking + +=back + +=item SEE ALSO + +=item AUTHOR and COPYRIGHT + +=item HISTORY + +=back + +=head2 perlretut - Perl regular expressions tutorial + +=over 4 + +=item DESCRIPTION + +=item Part 1: The basics + +=over 4 + +=item Simple word matching + +=item Using character classes + +=item Matching this or that + +=item Grouping things and hierarchical matching + +=item Extracting matches + +=item Matching repetitions + +=item Building a regexp + +=item Using regular expressions in Perl + +=back + +=item Part 2: Power tools + +=over 4 + +=item More on characters, strings, and character classes + +=item Compiling and saving regular expressions + +=item Embedding comments and modifiers in a regular expression + +=item Non-capturing groupings + +=item Looking ahead and looking behind + +=item Using independent subexpressions to prevent backtracking + +=item Conditional expressions + +=item A bit of magic: executing Perl code in a regular expression + +=item Pragmas and debugging + +=back + +=item BUGS + +=item SEE ALSO + +=item AUTHOR AND COPYRIGHT + +=over 4 + +=item Acknowledgments + +=back + +=back + +=head2 perlre - Perl regular expressions + +=over 4 + +=item DESCRIPTION + +i, m, s, x + +=over 4 + +=item Regular Expressions + +cntrl, graph, print, punct, xdigit + +=item Extended Patterns + +C<(?#text)>, C<(?imsx-imsx)>, C<(?:pattern)>, C<(?imsx-imsx:pattern)>, +C<(?=pattern)>, C<(?!pattern)>, C<(?<=pattern)>, C<(?<!pattern)>, C<(?{ +code })>, C<(??{ code })>, C<< (?>pattern) >>, +C<(?(condition)yes-pattern|no-pattern)>, C<(?(condition)yes-pattern)> + +=item Backtracking + +=item Version 8 Regular Expressions + +=item Warning on \1 vs $1 + +=item Repeated patterns matching zero-length substring + +=item Combining pieces together + +C<ST>, C<S|T>, C<S{REPEAT_COUNT}>, C<S{min,max}>, C<S{min,max}?>, C<S?>, +C<S*>, C<S+>, C<S??>, C<S*?>, C<S+?>, C<< (?>S) >>, C<(?=S)>, C<(?<=S)>, +C<(?!S)>, C<(?<!S)>, C<(??{ EXPR })>, +C<(?(condition)yes-pattern|no-pattern)> + +=item Creating custom RE engines + +=back + +=item BUGS + +=item SEE ALSO + +=back + +=head2 perlref - Perl references and nested data structures + +=over 4 + +=item NOTE + +=item DESCRIPTION + +=over 4 + +=item Making References + +=item Using References + +=item Symbolic references + +=item Not-so-symbolic references + +=item Pseudo-hashes: Using an array as a hash + +=item Function Templates + +=back + +=item WARNING + +=item SEE ALSO + +=back + +=head2 perlform - Perl formats + +=over 4 + +=item DESCRIPTION + +=over 4 + +=item Format Variables + +=back + +=item NOTES + +=over 4 + +=item Footers + +=item Accessing Formatting Internals + +=back + +=item WARNINGS + +=back + +=head2 perlboot - Beginner's Object-Oriented Tutorial + +=over 4 + +=item DESCRIPTION + +=over 4 + +=item If we could talk to the animals... + +=item Introducing the method invocation arrow + +=item Invoking a barnyard + +=item The extra parameter of method invocation + +=item Calling a second method to simplify things + +=item Inheriting the windpipes + +=item A few notes about @ISA + +=item Overriding the methods + +=item Starting the search from a different place + +=item The SUPER way of doing things + +=item Where we're at so far... + +=item A horse is a horse, of course of course -- or is it? + +=item Invoking an instance method + +=item Accessing the instance data + +=item How to build a horse + +=item Inheriting the constructor + +=item Making a method work with either classes or instances + +=item Adding parameters to a method + +=item More interesting instances + +=item A horse of a different color + +=item Summary + +=back + +=item SEE ALSO + +=item COPYRIGHT + +=back + +=head2 perltoot - Tom's object-oriented tutorial for perl + +=over 4 + +=item DESCRIPTION + +=item Creating a Class + +=over 4 + +=item Object Representation + +=item Class Interface + +=item Constructors and Instance Methods + +=item Planning for the Future: Better Constructors + +=item Destructors + +=item Other Object Methods + +=back + +=item Class Data + +=over 4 + +=item Accessing Class Data + +=item Debugging Methods + +=item Class Destructors + +=item Documenting the Interface + +=back + +=item Aggregation + +=item Inheritance + +=over 4 + +=item Overridden Methods + +=item Multiple Inheritance + +=item UNIVERSAL: The Root of All Objects + +=back + +=item Alternate Object Representations + +=over 4 + +=item Arrays as Objects + +=item Closures as Objects + +=back + +=item AUTOLOAD: Proxy Methods + +=over 4 + +=item Autoloaded Data Methods + +=item Inherited Autoloaded Data Methods + +=back + +=item Metaclassical Tools + +=over 4 + +=item Class::Struct + +=item Data Members as Variables + +=back + +=item NOTES + +=over 4 + +=item Object Terminology + +=back + +=item SEE ALSO + +=item AUTHOR AND COPYRIGHT + +=item COPYRIGHT + +=over 4 + +=item Acknowledgments + +=back + +=back + +=head2 perltootc - Tom's OO Tutorial for Class Data in Perl + +=over 4 + +=item DESCRIPTION + +=item Class Data in a Can + +=item Class Data as Package Variables + +=over 4 + +=item Putting All Your Eggs in One Basket + +=item Inheritance Concerns + +=item The Eponymous Meta-Object + +=item Indirect References to Class Data + +=item Monadic Classes + +=item Translucent Attributes + +=back + +=item Class Data as Lexical Variables + +=over 4 + +=item Privacy and Responsibility + +=item File-Scoped Lexicals + +=item More Inheritance Concerns + +=item Locking the Door and Throwing Away the Key + +=item Translucency Revisited + +=back + +=item NOTES + +=item SEE ALSO + +=item AUTHOR AND COPYRIGHT + +=item ACKNOWLEDGEMENTS + +=item HISTORY + +=back + +=head2 perlobj - Perl objects + +=over 4 + +=item DESCRIPTION + +=over 4 + +=item An Object is Simply a Reference + +=item A Class is Simply a Package + +=item A Method is Simply a Subroutine + +=item Method Invocation + +=item WARNING + +=item Default UNIVERSAL methods + +isa(CLASS), can(METHOD), VERSION( [NEED] ) + +=item Destructors + +=item Summary + +=item Two-Phased Garbage Collection + +=back + +=item SEE ALSO + +=back + +=head2 perlbot - Bag'o Object Tricks (the BOT) + +=over 4 + +=item DESCRIPTION + +=item OO SCALING TIPS + +=item INSTANCE VARIABLES + +=item SCALAR INSTANCE VARIABLES + +=item INSTANCE VARIABLE INHERITANCE + +=item OBJECT RELATIONSHIPS + +=item OVERRIDING SUPERCLASS METHODS + +=item USING RELATIONSHIP WITH SDBM + +=item THINKING OF CODE REUSE + +=item CLASS CONTEXT AND THE OBJECT + +=item INHERITING A CONSTRUCTOR + +=item DELEGATION + +=back + +=head2 perltie - how to hide an object class in a simple variable + +=over 4 + +=item SYNOPSIS + +=item DESCRIPTION + +=over 4 + +=item Tying Scalars + +TIESCALAR classname, LIST, FETCH this, STORE this, value, UNTIE this, +DESTROY this + +=item Tying Arrays + +TIEARRAY classname, LIST, FETCH this, index, STORE this, index, value, +FETCHSIZE this, STORESIZE this, count, EXTEND this, count, EXISTS this, +key, DELETE this, key, CLEAR this, PUSH this, LIST, POP this, SHIFT this, +UNSHIFT this, LIST, SPLICE this, offset, length, LIST, UNTIE this, DESTROY +this + +=item Tying Hashes + +USER, HOME, CLOBBER, LIST, TIEHASH classname, LIST, FETCH this, key, STORE +this, key, value, DELETE this, key, CLEAR this, EXISTS this, key, FIRSTKEY +this, NEXTKEY this, lastkey, UNTIE this, DESTROY this + +=item Tying FileHandles + +TIEHANDLE classname, LIST, WRITE this, LIST, PRINT this, LIST, PRINTF this, +LIST, READ this, LIST, READLINE this, GETC this, CLOSE this, UNTIE this, +DESTROY this + +=item UNTIE this + +=item The C<untie> Gotcha + +=back + +=item SEE ALSO + +=item BUGS + +=item AUTHOR + +=back + +=head2 perlipc - Perl interprocess communication (signals, fifos, pipes, +safe subprocesses, sockets, and semaphores) + +=over 4 + +=item DESCRIPTION + +=item Signals + +=item Named Pipes + +=over 4 + +=item WARNING + +=back + +=item Using open() for IPC + +=over 4 + +=item Filehandles + +=item Background Processes + +=item Complete Dissociation of Child from Parent + +=item Safe Pipe Opens + +=item Bidirectional Communication with Another Process + +=item Bidirectional Communication with Yourself + +=back + +=item Sockets: Client/Server Communication + +=over 4 + +=item Internet Line Terminators + +=item Internet TCP Clients and Servers + +=item Unix-Domain TCP Clients and Servers + +=back + +=item TCP Clients with IO::Socket + +=over 4 + +=item A Simple Client + +C<Proto>, C<PeerAddr>, C<PeerPort> + +=item A Webget Client + +=item Interactive Client with IO::Socket + +=back + +=item TCP Servers with IO::Socket + +Proto, LocalPort, Listen, Reuse + +=item UDP: Message Passing + +=item SysV IPC + +=item NOTES + +=item BUGS + +=item AUTHOR + +=item SEE ALSO + +=back + +=head2 perlfork - Perl's fork() emulation (EXPERIMENTAL, subject to change) + +=over 4 + +=item SYNOPSIS + +=item DESCRIPTION + +=over 4 + +=item Behavior of other Perl features in forked pseudo-processes + +$$ or $PROCESS_ID, %ENV, chdir() and all other builtins that accept +filenames, wait() and waitpid(), kill(), exec(), exit(), Open handles to +files, directories and network sockets + +=item Resource limits + +=item Killing the parent process + +=item Lifetime of the parent process and pseudo-processes + +=item CAVEATS AND LIMITATIONS + +BEGIN blocks, Open filehandles, Forking pipe open() not yet implemented, +Global state maintained by XSUBs, Interpreter embedded in larger +application, Thread-safety of extensions + +=back + +=item BUGS + +=item AUTHOR + +=item SEE ALSO + +=back + +=head2 perlnumber - semantics of numbers and numeric operations in Perl + +=over 4 + +=item SYNOPSIS + +=item DESCRIPTION + +=item Storing numbers + +=item Numeric operators and numeric conversions + +=item Flavors of Perl numeric operations + +Arithmetic operators except, C<no integer>, Arithmetic operators except, +C<use integer>, Bitwise operators, C<no integer>, Bitwise operators, C<use +integer>, Operators which expect an integer, Operators which expect a +string + +=item AUTHOR + +=item SEE ALSO + +=back + +=head2 perlthrtut - tutorial on threads in Perl + +=over 4 + +=item DESCRIPTION + +=item What Is A Thread Anyway? + +=item Threaded Program Models + +=over 4 + +=item Boss/Worker + +=item Work Crew + +=item Pipeline + +=back + +=item Native threads + +=item What kind of threads are perl threads? + +=item Threadsafe Modules + +=item Thread Basics + +=over 4 + +=item Basic Thread Support + +=item Creating Threads + +=item Giving up control + +=item Waiting For A Thread To Exit + +=item Errors In Threads + +=item Ignoring A Thread + +=back + +=item Threads And Data + +=over 4 + +=item Shared And Unshared Data + +=item Thread Pitfall: Races + +=item Controlling access: lock() + +=item Thread Pitfall: Deadlocks + +=item Queues: Passing Data Around + +=back + +=item Threads And Code + +=over 4 + +=item Semaphores: Synchronizing Data Access + +Basic semaphores, Advanced Semaphores + +=item Attributes: Restricting Access To Subroutines + +=item Subroutine Locks + +=item Methods + +=item Locking A Subroutine + +=back + +=item General Thread Utility Routines + +=over 4 + +=item What Thread Am I In? + +=item Thread IDs + +=item Are These Threads The Same? + +=item What Threads Are Running? + +=back + +=item A Complete Example + +=item Conclusion + +=item Bibliography + +=over 4 + +=item Introductory Texts + +=item OS-Related References + +=item Other References + +=back + +=item Acknowledgements + +=item AUTHOR + +=item Copyrights + +=back + +=head2 perlport - Writing portable Perl + +=over 4 + +=item DESCRIPTION + +Not all Perl programs have to be portable, Nearly all of Perl already I<is> +portable + +=item ISSUES + +=over 4 + +=item Newlines + +=item Numbers endianness and Width + +=item Files and Filesystems + +=item System Interaction + +=item Interprocess Communication (IPC) + +=item External Subroutines (XS) + +=item Standard Modules + +=item Time and Date + +=item Character sets and character encoding + +=item Internationalisation + +=item System Resources + +=item Security + +=item Style + +=back + +=item CPAN Testers + +Mailing list: cpan-testers@perl.org, Testing results: +http://testers.cpan.org/ + +=item PLATFORMS + +=over 4 + +=item Unix + +=item DOS and Derivatives + +=item S<Mac OS> + +=item VMS + +=item VOS + +=item EBCDIC Platforms + +=item Acorn RISC OS + +=item Other perls + +=back + +=item FUNCTION IMPLEMENTATIONS + +=over 4 + +=item Alphabetical Listing of Perl Functions + +-I<X> FILEHANDLE, -I<X> EXPR, -I<X>, alarm SECONDS, alarm, binmode +FILEHANDLE, chmod LIST, chown LIST, chroot FILENAME, chroot, crypt +PLAINTEXT,SALT, dbmclose HASH, dbmopen HASH,DBNAME,MODE, dump LABEL, exec +LIST, fcntl FILEHANDLE,FUNCTION,SCALAR, flock FILEHANDLE,OPERATION, fork, +getlogin, getpgrp PID, getppid, getpriority WHICH,WHO, getpwnam NAME, +getgrnam NAME, getnetbyname NAME, getpwuid UID, getgrgid GID, getnetbyaddr +ADDR,ADDRTYPE, getprotobynumber NUMBER, getservbyport PORT,PROTO, getpwent, +getgrent, gethostent, getnetent, getprotoent, getservent, setpwent, +setgrent, sethostent STAYOPEN, setnetent STAYOPEN, setprotoent STAYOPEN, +setservent STAYOPEN, endpwent, endgrent, endhostent, endnetent, +endprotoent, endservent, getsockopt SOCKET,LEVEL,OPTNAME, glob EXPR, glob, +ioctl FILEHANDLE,FUNCTION,SCALAR, kill SIGNAL, LIST, link OLDFILE,NEWFILE, +lstat FILEHANDLE, lstat EXPR, lstat, msgctl ID,CMD,ARG, msgget KEY,FLAGS, +msgsnd ID,MSG,FLAGS, msgrcv ID,VAR,SIZE,TYPE,FLAGS, open FILEHANDLE,EXPR, +open FILEHANDLE, pipe READHANDLE,WRITEHANDLE, readlink EXPR, readlink, +select RBITS,WBITS,EBITS,TIMEOUT, semctl ID,SEMNUM,CMD,ARG, semget +KEY,NSEMS,FLAGS, semop KEY,OPSTRING, setgrent, setpgrp PID,PGRP, +setpriority WHICH,WHO,PRIORITY, setpwent, setsockopt +SOCKET,LEVEL,OPTNAME,OPTVAL, shmctl ID,CMD,ARG, shmget KEY,SIZE,FLAGS, +shmread ID,VAR,POS,SIZE, shmwrite ID,STRING,POS,SIZE, socketpair +SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL, stat FILEHANDLE, stat EXPR, stat, +symlink OLDFILE,NEWFILE, syscall LIST, sysopen +FILEHANDLE,FILENAME,MODE,PERMS, system LIST, times, truncate +FILEHANDLE,LENGTH, truncate EXPR,LENGTH, umask EXPR, umask, utime LIST, +wait, waitpid PID,FLAGS + +=back + +=item CHANGES + +v1.48, 02 February 2001, v1.47, 22 March 2000, v1.46, 12 February 2000, +v1.45, 20 December 1999, v1.44, 19 July 1999, v1.43, 24 May 1999, v1.42, 22 +May 1999, v1.41, 19 May 1999, v1.40, 11 April 1999, v1.39, 11 February +1999, v1.38, 31 December 1998, v1.37, 19 December 1998, v1.36, 9 September +1998, v1.35, 13 August 1998, v1.33, 06 August 1998, v1.32, 05 August 1998, +v1.30, 03 August 1998, v1.23, 10 July 1998 + +=item Supported Platforms + +=item SEE ALSO + +=item AUTHORS / CONTRIBUTORS + +=item VERSION + +=back + +=head2 perllocale - Perl locale handling (internationalization and +localization) + +=over 4 + +=item DESCRIPTION + +=item PREPARING TO USE LOCALES + +=item USING LOCALES + +=over 4 + +=item The use locale pragma + +=item The setlocale function + +=item Finding locales + +=item LOCALE PROBLEMS + +=item Temporarily fixing locale problems + +=item Permanently fixing locale problems + +=item Permanently fixing your system's locale configuration + +=item Fixing system locale configuration + +=item The localeconv function + +=back + +=item LOCALE CATEGORIES + +=over 4 + +=item Category LC_COLLATE: Collation + +=item Category LC_CTYPE: Character Types + +=item Category LC_NUMERIC: Numeric Formatting + +=item Category LC_MONETARY: Formatting of monetary amounts + +=item LC_TIME + +=item Other categories + +=back + +=item SECURITY + +=item ENVIRONMENT + +PERL_BADLANG, LC_ALL, LANGUAGE, LC_CTYPE, LC_COLLATE, LC_MONETARY, +LC_NUMERIC, LC_TIME, LANG + +=item NOTES + +=over 4 + +=item Backward compatibility + +=item I18N:Collate obsolete + +=item Sort speed and memory use impacts + +=item write() and LC_NUMERIC + +=item Freely available locale definitions + +=item I18n and l10n + +=item An imperfect standard + +=back + +=item BUGS + +=over 4 + +=item Broken systems + +=back + +=item SEE ALSO + +=item HISTORY + +=back + +=head2 perlunicode - Unicode support in Perl (EXPERIMENTAL, subject to +change) + +=over 4 + +=item DESCRIPTION + +=over 4 + +=item Important Caveat + +Input and Output Disciplines, Regular Expressions, C<use utf8> still needed +to enable a few features + +=item Byte and Character semantics + +=item Effects of character semantics + +=item Character encodings for input and output + +=back + +=item CAVEATS + +=item SEE ALSO + +=back + +=head2 perlebcdic - Considerations for running Perl on EBCDIC platforms + +=over 4 + +=item DESCRIPTION + +=item COMMON CHARACTER CODE SETS + +=over 4 + +=item ASCII + +=item ISO 8859 + +=item Latin 1 (ISO 8859-1) + +=item EBCDIC + +=item 13 variant characters + +=item 0037 + +=item 1047 + +=item POSIX-BC + +=back + +=item SINGLE OCTET TABLES + +recipe 0, recipe 1, recipe 2, recipe 3, recipe 4 + +=item IDENTIFYING CHARACTER CODE SETS + +=item CONVERSIONS + +=over 4 + +=item tr/// + +=item iconv + +=item C RTL + +=back + +=item OPERATOR DIFFERENCES + +=item FUNCTION DIFFERENCES + +chr(), ord(), pack(), print(), printf(), sort(), sprintf(), unpack() + +=item REGULAR EXPRESSION DIFFERENCES + +=item SOCKETS + +=item SORTING + +=over 4 + +=item Ignore ASCII vs. EBCDIC sort differences. + +=item MONO CASE then sort data. + +=item Convert, sort data, then re convert. + +=item Perform sorting on one type of machine only. + +=back + +=item TRANFORMATION FORMATS + +=over 4 + +=item URL decoding and encoding + +=item uu encoding and decoding + +=item Quoted-Printable encoding and decoding + +=item Caesarian cyphers + +=back + +=item Hashing order and checksums + +=item I18N AND L10N + +=item MULTI OCTET CHARACTER SETS + +=item OS ISSUES + +=over 4 + +=item OS/400 + +IFS access + +=item OS/390 + +chcp, dataset access, OS/390 iconv, locales + +=item VM/ESA? + +=item POSIX-BC? + +=back + +=item BUGS + +=item SEE ALSO + +=item REFERENCES + +=item AUTHOR + +=back + +=head2 perlsec - Perl security + +=over 4 + +=item DESCRIPTION + +=over 4 + +=item Laundering and Detecting Tainted Data + +=item Switches On the "#!" Line + +=item Cleaning Up Your Path + +=item Security Bugs + +=item Protecting Your Programs + +=back + +=item SEE ALSO + +=back + +=head2 perlmod - Perl modules (packages and symbol tables) + +=over 4 + +=item DESCRIPTION + +=over 4 + +=item Packages + +=item Symbol Tables + +=item Package Constructors and Destructors + +=item Perl Classes + +=item Perl Modules + +=back + +=item SEE ALSO + +=back + +=head2 perlmodlib - constructing new Perl modules and finding existing ones + +=over 4 + +=item DESCRIPTION + +=item THE PERL MODULE LIBRARY + +=over 4 + +=item Pragmatic Modules + +attributes, attrs, autouse, base, blib, bytes, charnames, constant, +diagnostics, fields, filetest, integer, less, lib, locale, open, ops, +overload, re, sigtrap, strict, subs, utf8, vars, warnings, +warnings::register + +=item Standard Modules + +AnyDBM_File, AutoLoader, AutoSplit, B, B::Asmdata, B::Assembler, B::Bblock, +B::Bytecode, B::C, B::CC, B::Concise, B::Debug, B::Deparse, +B::Disassembler, B::Lint, B::Showlex, B::Stackobj, B::Stash, B::Terse, +B::Xref, Benchmark, ByteLoader, CGI, CGI::Apache, CGI::Carp, CGI::Cookie, +CGI::Fast, CGI::Pretty, CGI::Push, CGI::Switch, CGI::Util, CPAN, +CPAN::FirstTime, CPAN::Nox, Carp, Carp::Heavy, Class::Struct, Cwd, DB, +DB_File, Devel::SelfStubber, DirHandle, Dumpvalue, English, Env, Exporter, +Exporter::Heavy, ExtUtils::Command, ExtUtils::Embed, ExtUtils::Install, +ExtUtils::Installed, ExtUtils::Liblist, ExtUtils::MM_Cygwin, +ExtUtils::MM_OS2, ExtUtils::MM_Unix, ExtUtils::MM_VMS, ExtUtils::MM_Win32, +ExtUtils::MakeMaker, ExtUtils::Manifest, ExtUtils::Mkbootstrap, +ExtUtils::Mksymlists, ExtUtils::Packlist, ExtUtils::testlib, Fatal, Fcntl, +File::Basename, File::CheckTree, File::Compare, File::Copy, File::DosGlob, +File::Find, File::Path, File::Spec, File::Spec::Epoc, +File::Spec::Functions, File::Spec::Mac, File::Spec::OS2, File::Spec::Unix, +File::Spec::VMS, File::Spec::Win32, File::Temp, File::stat, FileCache, +FileHandle, FindBin, GDBM_File, Getopt::Long, Getopt::Std, I18N::Collate, +IO, IPC::Open2, IPC::Open3, Math::BigFloat, Math::BigInt, Math::Complex, +Math::Trig, Net::Ping, Net::hostent, Net::netent, Net::protoent, +Net::servent, O, Opcode, POSIX, Pod::Checker, Pod::Find, Pod::Html, +Pod::InputObjects, Pod::LaTeX, Pod::Man, Pod::ParseUtils, Pod::Parser, +Pod::Plainer, Pod::Select, Pod::Text, Pod::Text::Color, +Pod::Text::Overstrike, Pod::Text::Termcap, Pod::Usage, SDBM_File, Safe, +Search::Dict, SelectSaver, SelfLoader, Shell, Socket, Symbol, +Term::ANSIColor, Term::Cap, Term::Complete, Term::ReadLine, Test, +Test::Harness, Text::Abbrev, Text::ParseWords, Text::Soundex, Text::Tabs, +Text::Wrap, Thread, Thread::Queue, Thread::Semaphore, Thread::Signal, +Thread::Specific, Tie::Array, Tie::Handle, Tie::Hash, Tie::RefHash, +Tie::Scalar, Tie::SubstrHash, Time::Local, Time::gmtime, Time::localtime, +Time::tm, UNIVERSAL, User::grent, User::pwent, Win32 + +=item Extension Modules + +=back + +=item CPAN + +=over 4 + +=item Africa + +=item Asia + +=item Central America + +=item Europe + +=item North America + +=item Oceania + +=item South America + +=back + +=item Modules: Creation, Use, and Abuse + +=over 4 + +=item Guidelines for Module Creation + +Adding a Copyright Notice + +=item Guidelines for Converting Perl 4 Library Scripts into Modules + +=item Guidelines for Reusing Application Code + +=back + +=item NOTE + +=back + +=head2 perlmodinstall - Installing CPAN Modules + +=over 4 + +=item DESCRIPTION + +=over 4 + +=item PREAMBLE + +B<DECOMPRESS> the file, B<UNPACK> the file into a directory, B<BUILD> the +module (sometimes unnecessary), B<INSTALL> the module + +=back + +=item PORTABILITY + +=item HEY + +=item AUTHOR + +=item COPYRIGHT + +=back + +=head2 perlnewmod - preparing a new module for distribution + +=over 4 + +=item DESCRIPTION + +=over 4 + +=item Warning + +=item What should I make into a module? + +=item Step-by-step: Preparing the ground + +Look around, Check it's new, Discuss the need, Choose a name, Check again + +=item Step-by-step: Making the module + +Start with F<h2xs>, Use L<strict|strict> and L<warnings|warnings>, Use +L<Carp|Carp>, Use L<Exporter|Exporter> - wisely!, Use L<plain old +documentation|perlpod>, Write tests, Write the README + +=item Step-by-step: Distributing your module + +Get a CPAN user ID, C<perl Makefile.PL; make test; make dist>, Upload the +tarball, Announce to the modules list, Announce to clpa, Fix bugs! + +=back + +=item AUTHOR + +=item SEE ALSO =back =head2 perlfaq1 - General Questions About Perl ($Revision: 1.23 $, $Date: 1999/05/23 16:08:30 $) -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item What is Perl? @@ -340,7 +2364,7 @@ Scheme, or Tcl? =item Where can I get a list of Larry Wall witticisms? =item How can I convince my sysadmin/supervisor/employees to use version -(5/5.005/Perl instead of some other language)? +5/5.005/Perl instead of some other language? =back @@ -351,11 +2375,11 @@ Scheme, or Tcl? =head2 perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.32 $, $Date: 1999/10/14 18:46:09 $) -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item What machines support Perl? Where do I get it? @@ -407,11 +2431,11 @@ References, Tutorials, Task-Oriented, Special Topics =head2 perlfaq3 - Programming Tools ($Revision: 1.38 $, $Date: 1999/05/23 16:08:30 $) -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item How do I do (anything)? @@ -431,6 +2455,10 @@ References, Tutorials, Task-Oriented, Special Topics =item Is there an IDE or Windows Perl Editor? +CodeMagicCD, Komodo, The Object System, PerlBuilder, Perl code magic, +visiPerl+, GNU Emacs, MicroEMACS, XEmacs, Elvis, Vile, Vim, Codewright, +MultiEdit, SlickEdit, Bash, Ksh, Tcsh, Zsh, BBEdit and BBEdit Lite, Alpha + =item Where can I get Perl macros for vi? =item Where can I get perl-mode for emacs? @@ -472,7 +2500,7 @@ References, Tutorials, Task-Oriented, Special Topics =item Where can I learn about linking C with Perl? [h2xs, xsubpp] =item I've read perlembed, perlguts, etc., but I can't embed perl in -my C program, what am I doing wrong? +my C program; what am I doing wrong? =item When I tried to run my script, I got this message. What does it mean? @@ -488,13 +2516,13 @@ mean? =head2 perlfaq4 - Data Manipulation ($Revision: 1.49 $, $Date: 1999/05/23 20:37:49 $) -=over +=over 4 =item DESCRIPTION =item Data: Numbers -=over +=over 4 =item Why am I getting long decimals (eg, 19.9499999999999) instead of the numbers I should be getting (eg, 19.95)? @@ -520,7 +2548,7 @@ Trig functions? =item Data: Dates -=over +=over 4 =item How do I find the week-of-the-year/day-of-the-year? @@ -540,7 +2568,7 @@ Trig functions? =item Data: Strings -=over +=over 4 =item How do I validate input? @@ -592,7 +2620,7 @@ the tag =item Data: Arrays -=over +=over 4 =item What is the difference between a list and an array? @@ -600,11 +2628,7 @@ the tag =item How can I remove duplicate elements from a list or array? -a) If @in is sorted, and you want @out to be sorted:(this assumes all true -values in the array), b) If you don't know whether @in is sorted:, c) Like -(b), but @in contains only small integers:, d) A way to do (b) without any -loops or greps:, e) Like (d), but @in contains only small positive -integers: +a), b), c), d), e) =item How can I tell whether a list or array contains a certain element? @@ -637,7 +2661,7 @@ intersection of two arrays? =item Data: Hashes (Associative Arrays) -=over +=over 4 =item How do I process an entire hash? @@ -676,7 +2700,7 @@ array of hashes or arrays? =item Data: Misc -=over +=over 4 =item How do I handle binary data correctly? @@ -701,11 +2725,11 @@ array of hashes or arrays? =head2 perlfaq5 - Files and Formats ($Revision: 1.38 $, $Date: 1999/05/23 16:08:30 $) -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item How do I flush/unbuffer an output filehandle? Why must I do this? @@ -790,11 +2814,11 @@ protected files? Isn't this a bug in Perl? =head2 perlfaq6 - Regexes ($Revision: 1.27 $, $Date: 1999/05/23 16:08:30 $) -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item How can I hope to use regular expressions without creating illegible and unmaintainable code? @@ -808,7 +2832,7 @@ different lines? =item I put a regular expression into $/ but it didn't work. What's wrong? -=item How do I substitute case insensitively on the LHS, but preserving +=item How do I substitute case insensitively on the LHS while preserving case on the RHS? =item How can I make C<\w> match national character sets? @@ -826,7 +2850,7 @@ file? =item What does it mean that regexes are greedy? How can I get around it? -=item How do I process each word on each line? +=item How do I process each word on each line? =item How can I print out a word-frequency or line-frequency summary? @@ -857,11 +2881,11 @@ file? =head2 perlfaq7 - Perl Language Issues ($Revision: 1.28 $, $Date: 1999/05/23 20:36:18 $) -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Can I get a BNF/yacc/RE for the Perl language? @@ -936,11 +2960,11 @@ is in scope? =head2 perlfaq8 - System Interaction ($Revision: 1.39 $, $Date: 1999/05/23 18:37:57 $) -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item How do I find out which operating system I'm running under? @@ -984,7 +3008,7 @@ STDIN, STDOUT, and STDERR are shared, Signals, Zombies =item How can I do an atexit() or setjmp()/longjmp()? (Exception handling) -=item Why doesn't my sockets program work under System V (Solaris)? What +=item Why doesn't my sockets program work under System V (Solaris)? What does the error message "Protocol not supported" mean? =item How can I call my system's unique C functions from Perl? @@ -1028,8 +3052,6 @@ complete? =item How do I fork a daemon process? -=item How do I make my program run with sh and csh? - =item How do I find out if I'm running interactively or not? =item How do I timeout a slow event? @@ -1066,13 +3088,13 @@ search path? =head2 perlfaq9 - Networking ($Revision: 1.26 $, $Date: 1999/05/23 16:08:30 $) -=over +=over 4 =item DESCRIPTION -=over +=over 4 -=item My CGI script runs from the command line but not the browser. (500 +=item My CGI script runs from the command line but not the browser. (500 Server Error) =item How can I get better error messages from a CGI program? @@ -1113,6 +3135,8 @@ CGI script to do bad things? =item How do I send mail? +=item How do I use MIME to make an attachment to a mail message? + =item How do I read mail? =item How do I find out my hostname/domainname/IP address? @@ -1129,417 +3153,370 @@ CGI script to do bad things? =back -=head2 perldelta - what's new for perl v5.6.0 +=head2 perlcompile - Introduction to the Perl Compiler-Translator -=over +=over 4 =item DESCRIPTION -=item Core Enhancements +=over 4 -=over +=item Layout -=item Interpreter cloning, threads, and concurrency +B::Bytecode, B::C, B::CC, B::Lint, B::Deparse, B::Xref -=item Lexically scoped warning categories +=back -=item Unicode and UTF-8 support +=item Using The Back Ends -=item Support for interpolating named characters +=over 4 -=item "our" declarations +=item The Cross Referencing Back End -=item Support for strings represented as a vector of ordinals +i, &, s, r -=item Improved Perl version numbering system +=item The Decompiling Back End -=item New syntax for declaring subroutine attributes +=item The Lint Back End -=item File and directory handles can be autovivified +=item The Simple C Back End -=item open() with more than two arguments +=item The Bytecode Back End -=item 64-bit support +=item The Optimized C Back End -=item Large file support +B, O, B::Asmdata, B::Assembler, B::Bblock, B::Bytecode, B::C, B::CC, +B::Debug, B::Deparse, B::Disassembler, B::Lint, B::Showlex, B::Stackobj, +B::Stash, B::Terse, B::Xref -=item Long doubles +=back -=item "more bits" +=item KNOWN PROBLEMS -=item Enhanced support for sort() subroutines +=item AUTHOR -=item C<sort $coderef @foo> allowed +=back -=item File globbing implemented internally +=head2 perlembed - how to embed perl in your C program -Support for CHECK blocks +=over 4 -=item POSIX character class syntax [: :] supported +=item DESCRIPTION -Better pseudo-random number generator +=over 4 -=item Improved C<qw//> operator +=item PREAMBLE -Better worst-case behavior of hashes +B<Use C from Perl?>, B<Use a Unix program from Perl?>, B<Use Perl from +Perl?>, B<Use C from C?>, B<Use Perl from C?> -=item pack() format 'Z' supported +=item ROADMAP -=item pack() format modifier '!' supported +=item Compiling your C program -=item pack() and unpack() support counted strings +=item Adding a Perl interpreter to your C program -=item Comments in pack() templates +=item Calling a Perl subroutine from your C program -=item Weak references +=item Evaluating a Perl statement from your C program -=item Binary numbers supported +=item Performing Perl pattern matches and substitutions from your C program -=item Lvalue subroutines +=item Fiddling with the Perl stack from your C program -=item Some arrows may be omitted in calls through references +=item Maintaining a persistent interpreter -=item Boolean assignment operators are legal lvalues +=item Maintaining multiple interpreter instances -=item exists() is supported on subroutine names +=item Using Perl modules, which themselves use C libraries, from your C +program -=item exists() and delete() are supported on array elements +=back -=item Pseudo-hashes work better +=item Embedding Perl under Win32 -=item Automatic flushing of output buffers +=item MORAL -=item Better diagnostics on meaningless filehandle operations +=item AUTHOR -=item Where possible, buffered data discarded from duped input filehandle +=item COPYRIGHT -=item eof() has the same old magic as <> +=back -=item binmode() can be used to set :crlf and :raw modes +=head2 perldebguts - Guts of Perl debugging -=item C<-T> filetest recognizes UTF-8 encoded files as "text" +=over 4 -=item system(), backticks and pipe open now reflect exec() failure +=item DESCRIPTION -=item Improved diagnostics +=item Debugger Internals -=item Diagnostics follow STDERR +=over 4 -More consistent close-on-exec behavior +=item Writing Your Own Debugger -=item syswrite() ease-of-use +=back -=item Better syntax checks on parenthesized unary operators +=item Frame Listing Output Examples -=item Bit operators support full native integer width +=item Debugging regular expressions -=item Improved security features +=over 4 -More functional bareword prototype (*) +=item Compile-time output -=item C<require> and C<do> may be overridden +C<anchored> I<STRING> C<at> I<POS>, C<floating> I<STRING> C<at> +I<POS1..POS2>, C<matching floating/anchored>, C<minlen>, C<stclass> +I<TYPE>, C<noscan>, C<isall>, C<GPOS>, C<plus>, C<implicit>, C<with eval>, +C<anchored(TYPE)> -=item $^X variables may now have names longer than one character +=item Types of nodes -=item New variable $^C reflects C<-c> switch +=item Run-time output -=item New variable $^V contains Perl version as a string +=back -=item Optional Y2K warnings +=item Debugging Perl memory usage -=back +=over 4 -=item Modules and Pragmata +=item Using C<$ENV{PERL_DEBUG_MSTATS}> -=over +C<buckets SMALLEST(APPROX)..GREATEST(APPROX)>, Free/Used, C<Total sbrk(): +SBRKed/SBRKs:CONTINUOUS>, C<pad: 0>, C<heads: 2192>, C<chain: 0>, C<tail: +6144> -=item Modules +=item Example of using B<-DL> switch -attributes, B, Benchmark, ByteLoader, constant, charnames, Data::Dumper, -DB, DB_File, Devel::DProf, Devel::Peek, Dumpvalue, DynaLoader, English, -Env, Fcntl, File::Compare, File::Find, File::Glob, File::Spec, -File::Spec::Functions, Getopt::Long, IO, JPL, lib, Math::BigInt, -Math::Complex, Math::Trig, Pod::Parser, Pod::InputObjects, Pod::Checker, -podchecker, Pod::ParseUtils, Pod::Find, Pod::Select, podselect, Pod::Usage, -pod2usage, Pod::Text and Pod::Man, SDBM_File, Sys::Syslog, Sys::Hostname, -Term::ANSIColor, Time::Local, Win32, XSLoader, DBM Filters +C<717>, C<002>, C<054>, C<602>, C<702>, C<704> -=item Pragmata +=item B<-DL> details + +C<!!!>, C<!!>, C<!> + +=item Limitations of B<-DL> statistics =back -=item Utility Changes +=item SEE ALSO -=over +=back -=item dprofpp +=head2 perlxstut, perlXStut - Tutorial for writing XSUBs -=item find2perl +=over 4 -=item h2xs +=item DESCRIPTION -=item perlcc +=item SPECIAL NOTES -=item perldoc +=over 4 -=item The Perl Debugger +=item make + +=item Version caveat + +=item Dynamic Loading versus Static Loading =back -=item Improved Documentation +=item TUTORIAL -perlapi.pod, perlboot.pod, perlcompile.pod, perldbmfilter.pod, -perldebug.pod, perldebguts.pod, perlfork.pod, perlfilter.pod, perlhack.pod, -perlintern.pod, perllexwarn.pod, perlnumber.pod, perlopentut.pod, -perlreftut.pod, perltootc.pod, perltodo.pod, perlunicode.pod +=over 4 -=item Performance enhancements +=item EXAMPLE 1 -=over +=item EXAMPLE 2 -=item Simple sort() using { $a <=> $b } and the like are optimized +=item What has gone on? -=item Optimized assignments to lexical variables +=item Writing good test scripts -=item Faster subroutine calls +=item EXAMPLE 3 -delete(), each(), values() and hash iteration are faster +=item What's new here? -=back +=item Input and Output Parameters -=item Installation and Configuration Improvements +=item The XSUBPP Program -=over +=item The TYPEMAP file -=item -Dusethreads means something different +=item Warning about Output Arguments -=item New Configure flags +=item EXAMPLE 4 -=item Threadedness and 64-bitness now more daring +=item What has happened here? -=item Long Doubles +=item Anatomy of .xs file -=item -Dusemorebits +=item Getting the fat out of XSUBs -=item -Duselargefiles +=item More about XSUB arguments -=item installusrbinperl +=item The Argument Stack -=item SOCKS support +=item Extending your Extension -=item C<-A> flag +=item Documenting your Extension -=item Enhanced Installation Directories +=item Installing your Extension -=back +=item EXAMPLE 5 -=item Platform specific changes +=item New Things in this Example -=over +=item EXAMPLE 6 -=item Supported platforms +=item New Things in this Example -=item DOS +=item EXAMPLE 7 (Coming Soon) -=item OS390 (OpenEdition MVS) +=item EXAMPLE 8 (Coming Soon) -=item VMS +=item EXAMPLE 9 (Coming Soon) -=item Win32 +=item Troubleshooting these Examples =back -=item Significant bug fixes +=item See also -=over +=item Author -=item <HANDLE> on empty files +=over 4 -=item C<eval '...'> improvements +=item Last Changed -=item All compilation errors are true errors +=back -=item Implicitly closed filehandles are safer +=back -=item Behavior of list slices is more consistent +=head2 perlxs - XS language reference manual -=item C<(\$)> prototype and C<$foo{a}> +=over 4 -=item C<goto &sub> and AUTOLOAD +=item DESCRIPTION -=item C<-bareword> allowed under C<use integer> +=over 4 -=item Failures in DESTROY() +=item Introduction -=item Locale bugs fixed +=item On The Road -=item Memory leaks +=item The Anatomy of an XSUB -=item Spurious subroutine stubs after failed subroutine calls +=item The Argument Stack -=item Taint failures under C<-U> +=item The RETVAL Variable -=item END blocks and the C<-c> switch +=item The MODULE Keyword -=item Potential to leak DATA filehandles +=item The PACKAGE Keyword -=back +=item The PREFIX Keyword -=item New or Changed Diagnostics +=item The OUTPUT: Keyword -"%s" variable %s masks earlier declaration in same %s, "my sub" not yet -implemented, "our" variable %s redeclared, '!' allowed only after types %s, -/ cannot take a count, / must be followed by a, A or Z, / must be followed -by a*, A* or Z*, / must follow a numeric type, /%s/: Unrecognized escape -\\%c passed through, /%s/: Unrecognized escape \\%c in character class -passed through, /%s/ should probably be written as "%s", %s() called too -early to check prototype, %s argument is not a HASH or ARRAY element, %s -argument is not a HASH or ARRAY element or slice, %s argument is not a -subroutine name, %s package attribute may clash with future reserved word: -%s, (in cleanup) %s, <> should be quotes, Attempt to join self, Bad evalled -substitution pattern, Bad realloc() ignored, Bareword found in conditional, -Binary number > 0b11111111111111111111111111111111 non-portable, Bit vector -size > 32 non-portable, Buffer overflow in prime_env_iter: %s, Can't check -filesystem of script "%s", Can't declare class for non-scalar %s in "%s", -Can't declare %s in "%s", Can't ignore signal CHLD, forcing to default, -Can't modify non-lvalue subroutine call, Can't read CRTL environ, Can't -remove %s: %s, skipping file, Can't return %s from lvalue subroutine, Can't -weaken a nonreference, Character class [:%s:] unknown, Character class -syntax [%s] belongs inside character classes, Constant is not %s reference, -constant(%s): %s, CORE::%s is not a keyword, defined(@array) is deprecated, -defined(%hash) is deprecated, Did not produce a valid header, (Did you mean -"local" instead of "our"?), Document contains no data, entering effective -%s failed, false [] range "%s" in regexp, Filehandle %s opened only for -output, flock() on closed filehandle %s, Global symbol "%s" requires -explicit package name, Hexadecimal number > 0xffffffff non-portable, -Ill-formed CRTL environ value "%s", Ill-formed message in prime_env_iter: -|%s|, Illegal binary digit %s, Illegal binary digit %s ignored, Illegal -number of bits in vec, Integer overflow in %s number, Invalid %s attribute: -%s, Invalid %s attributes: %s, invalid [] range "%s" in regexp, Invalid -separator character %s in attribute list, Invalid separator character %s in -subroutine attribute list, leaving effective %s failed, Lvalue subs -returning %s not implemented yet, Method %s not permitted, Missing -%sbrace%s on \N{}, Missing command in piped open, Missing name in "my sub", -No %s specified for -%c, No package name allowed for variable %s in "our", -No space allowed after -%c, no UTC offset information; assuming local time -is UTC, Octal number > 037777777777 non-portable, panic: del_backref, -panic: kid popen errno read, panic: magic_killbackrefs, Parentheses missing -around "%s" list, Possible Y2K bug: %s, pragma "attrs" is deprecated, use -"sub NAME : ATTRS" instead, Premature end of script headers, Repeat count -in pack overflows, Repeat count in unpack overflows, realloc() of freed -memory ignored, Reference is already weak, setpgrp can't take arguments, -Strange *+?{} on zero-length expression, switching effective %s is not -implemented, This Perl can't reset CRTL environ elements (%s), This Perl -can't set CRTL environ elements (%s=%s), Too late to run %s block, Unknown -open() mode '%s', Unknown process %x sent message to prime_env_iter: %s, -Unrecognized escape \\%c passed through, Unterminated attribute parameter -in attribute list, Unterminated attribute list, Unterminated attribute -parameter in subroutine attribute list, Unterminated subroutine attribute -list, Value of CLI symbol "%s" too long, Version number must be a constant -number +=item The NO_OUTPUT Keyword -=item New tests +=item The CODE: Keyword -=item Incompatible Changes +=item The INIT: Keyword -=over +=item The NO_INIT Keyword -=item Perl Source Incompatibilities +=item Initializing Function Parameters -CHECK is a new keyword, Treatment of list slices of undef has changed +=item Default Parameter Values -=item Format of $English::PERL_VERSION is different +=item The PREINIT: Keyword -Literals of the form C<1.2.3> parse differently, Possibly changed -pseudo-random number generator, Hashing function for hash keys has changed, -C<undef> fails on read only values, Close-on-exec bit may be set on pipe -and socket handles, Writing C<"$$1"> to mean C<"${$}1"> is unsupported, -delete(), values() and C<\(%h)> operate on aliases to values, not copies, -vec(EXPR,OFFSET,BITS) enforces powers-of-two BITS, Text of some diagnostic -output has changed, C<%@> has been removed, Parenthesized not() behaves -like a list operator, Semantics of bareword prototype C<(*)> have changed +=item The SCOPE: Keyword -=item Semantics of bit operators may have changed on 64-bit platforms +=item The INPUT: Keyword -=item More builtins taint their results +=item The IN/OUTLIST/IN_OUTLIST/OUT/IN_OUT Keywords -=item C Source Incompatibilities +=item Variable-length Parameter Lists -C<PERL_POLLUTE>, C<PERL_IMPLICIT_CONTEXT>, C<PERL_POLLUTE_MALLOC> +=item The C_ARGS: Keyword -=item Compatible C Source API Changes +=item The PPCODE: Keyword -C<PATCHLEVEL> is now C<PERL_VERSION> +=item Returning Undef And Empty Lists -=item Binary Incompatibilities +=item The REQUIRE: Keyword -=back +=item The CLEANUP: Keyword -=item Known Problems +=item The POST_CALL: Keyword -=over +=item The BOOT: Keyword -=item Thread test failures +=item The VERSIONCHECK: Keyword -=item EBCDIC platforms not supported +=item The PROTOTYPES: Keyword -=item In 64-bit HP-UX the lib/io_multihomed test may hang +=item The PROTOTYPE: Keyword -=item NEXTSTEP 3.3 POSIX test failure +=item The ALIAS: Keyword -=item Tru64 (aka Digital UNIX, aka DEC OSF/1) lib/sdbm test failure with -gcc +=item The INTERFACE: Keyword -=item UNICOS/mk CC failures during Configure run +=item The INTERFACE_MACRO: Keyword -=item Arrow operator and arrays +=item The INCLUDE: Keyword -=item Windows 2000 +=item The CASE: Keyword -=item Experimental features +=item The & Unary Operator -Threads, Unicode, 64-bit support, Lvalue subroutines, Weak references, The -pseudo-hash data type, The Compiler suite, Internal implementation of file -globbing, The DB module, The regular expression constructs C<(?{ code })> -and C<(??{ code })> +=item Inserting POD, Comments and C Preprocessor Directives -=back +=item Using XS With C++ -=item Obsolete Diagnostics +=item Interface Strategy -Character class syntax [: :] is reserved for future extensions, Ill-formed -logical name |%s| in prime_env_iter, Probable precedence problem on %s, -regexp too big, Use of "$$<digit>" to mean "${$}<digit>" is deprecated +=item Perl Objects And C Structures -=item Reporting Bugs +=item The Typemap -=item SEE ALSO +=back -=item HISTORY +=item EXAMPLES + +=item XS VERSION + +=item AUTHOR =back -=head2 perldata - Perl data types +=head2 perlclib - Internal replacements for standard C library functions -=over +=over 4 =item DESCRIPTION -=over +=over 4 -=item Variable names +=item Conventions -=item Context +C<t>, C<p>, C<n>, C<s> -=item Scalar values +=item File Operations -=item Scalar value constructors +=item File Input and Output -=item List value constructors +=item File Positioning -=item Slices +=item Memory Management and String Handling -=item Typeglobs and Filehandles +=item Character Class Tests + +=item F<stdlib.h> functions + +=item Miscellaneous functions =back @@ -1547,2128 +3524,2362 @@ regexp too big, Use of "$$<digit>" to mean "${$}<digit>" is deprecated =back -=head2 perlsyn - Perl syntax +=head2 perlguts - Introduction to the Perl API -=over +=over 4 =item DESCRIPTION -=over +=item Variables -=item Declarations +=over 4 -=item Simple statements +=item Datatypes -=item Compound statements +=item What is an "IV"? -=item Loop Control +=item Working with SVs -=item For Loops +=item Offsets -=item Foreach Loops +=item What's Really Stored in an SV? -=item Basic BLOCKs and Switch Statements +=item Working with AVs -=item Goto +=item Working with HVs -=item PODs: Embedded Documentation +=item Hash API Extensions -=item Plain Old Comments (Not!) +=item References -=back +=item Blessed References and Class Objects + +=item Creating New Variables + +=item Reference Counts and Mortality + +=item Stashes and Globs + +=item Double-Typed SVs + +=item Magic Variables + +=item Assigning Magic + +=item Magic Virtual Tables + +=item Finding Magic + +=item Understanding the Magic of Tied Hashes and Arrays + +=item Localizing changes + +C<SAVEINT(int i)>, C<SAVEIV(IV i)>, C<SAVEI32(I32 i)>, C<SAVELONG(long i)>, +C<SAVESPTR(s)>, C<SAVEPPTR(p)>, C<SAVEFREESV(SV *sv)>, C<SAVEMORTALIZESV(SV +*sv)>, C<SAVEFREEOP(OP *op)>, C<SAVEFREEPV(p)>, C<SAVECLEARSV(SV *sv)>, +C<SAVEDELETE(HV *hv, char *key, I32 length)>, +C<SAVEDESTRUCTOR(DESTRUCTORFUNC_NOCONTEXT_t f, void *p)>, +C<SAVEDESTRUCTOR_X(DESTRUCTORFUNC_t f, void *p)>, C<SAVESTACK_POS()>, C<SV* +save_scalar(GV *gv)>, C<AV* save_ary(GV *gv)>, C<HV* save_hash(GV *gv)>, +C<void save_item(SV *item)>, C<void save_list(SV **sarg, I32 maxsarg)>, +C<SV* save_svref(SV **sptr)>, C<void save_aptr(AV **aptr)>, C<void +save_hptr(HV **hptr)> =back -=head2 perlop - Perl operators and precedence +=item Subroutines -=over +=over 4 -=item SYNOPSIS +=item XSUBs and the Argument Stack -=item DESCRIPTION +=item Calling Perl Routines from within C Programs -=over +=item Memory Allocation -=item Terms and List Operators (Leftward) +=item PerlIO -=item The Arrow Operator +=item Putting a C value on Perl stack -=item Auto-increment and Auto-decrement +=item Scratchpads -=item Exponentiation +=item Scratchpads and recursion -=item Symbolic Unary Operators +=back -=item Binding Operators +=item Compiled code -=item Multiplicative Operators +=over 4 -=item Additive Operators +=item Code tree -=item Shift Operators +=item Examining the tree -=item Named Unary Operators +=item Compile pass 1: check routines -=item Relational Operators +=item Compile pass 1a: constant folding -=item Equality Operators +=item Compile pass 2: context propagation -=item Bitwise And +=item Compile pass 3: peephole optimization -=item Bitwise Or and Exclusive Or +=back -=item C-style Logical And +=item Examining internal data structures with the C<dump> functions -=item C-style Logical Or +=item How multiple interpreters and concurrency are supported -=item Range Operators +=over 4 -=item Conditional Operator +=item Background and PERL_IMPLICIT_CONTEXT -=item Assignment Operators +=item So what happened to dTHR? -=item Comma Operator +=item How do I use all this in extensions? -=item List Operators (Rightward) +=item Should I do anything special if I call perl from multiple threads? -=item Logical Not +=item Future Plans and PERL_IMPLICIT_SYS -=item Logical And +=back -=item Logical or and Exclusive Or +=item Internal Functions -=item C Operators Missing From Perl +A, p, d, s, n, r, f, M, o, j, x -unary &, unary *, (TYPE) +=over 4 -=item Quote and Quote-like Operators +=item Formatted Printing of IVs, UVs, and NVs -=item Regexp Quote-Like Operators +=item Pointer-To-Integer and Integer-To-Pointer -?PATTERN?, m/PATTERN/cgimosx, /PATTERN/cgimosx, q/STRING/, C<'STRING'>, -qq/STRING/, "STRING", qr/STRING/imosx, qx/STRING/, `STRING`, qw/STRING/, -s/PATTERN/REPLACEMENT/egimosx, tr/SEARCHLIST/REPLACEMENTLIST/cdsUC, -y/SEARCHLIST/REPLACEMENTLIST/cdsUC +=item Source Documentation -=item Gory details of parsing quoted constructs +=back -Finding the end, Removal of backslashes before delimiters, Interpolation, -C<<<'EOF'>, C<m''>, C<s'''>, C<tr///>, C<y///>, C<''>, C<q//>, C<"">, -C<``>, C<qq//>, C<qx//>, C<< <file*glob> >>, C<?RE?>, C</RE/>, C<m/RE/>, -C<s/RE/foo/>,, Interpolation of regular expressions, Optimization of -regular expressions +=item Unicode Support -=item I/O Operators +=over 4 -=item Constant Folding +=item What B<is> Unicode, anyway? -=item Bitwise String Operators +=item How can I recognise a UTF8 string? -=item Integer Arithmetic +=item How does UTF8 represent Unicode characters? -=item Floating-point Arithmetic +=item How does Perl store UTF8 strings? -=item Bigger Numbers +=item How do I convert a string to UTF8? + +=item Is there anything else I need to know? =back +=item AUTHORS + +=item SEE ALSO + =back -=head2 perlre - Perl regular expressions +=head2 perlcall - Perl calling conventions from C -=over +=over 4 =item DESCRIPTION -i, m, s, x +An Error Handler, An Event Driven Program -=over +=item THE CALL_ FUNCTIONS -=item Regular Expressions +call_sv, call_pv, call_method, call_argv -cntrl, graph, print, punct, xdigit +=item FLAG VALUES -=item Extended Patterns +=over 4 -C<(?#text)>, C<(?imsx-imsx)>, C<(?:pattern)>, C<(?imsx-imsx:pattern)>, -C<(?=pattern)>, C<(?!pattern)>, C<(?<=pattern)>, C<(?<!pattern)>, C<(?{ -code })>, C<(??{ code })>, C<< (?>pattern) >>, -C<(?(condition)yes-pattern|no-pattern)>, C<(?(condition)yes-pattern)> +=item G_VOID -=item Backtracking +=item G_SCALAR -=item Version 8 Regular Expressions +=item G_ARRAY -=item Warning on \1 vs $1 +=item G_DISCARD -=item Repeated patterns matching zero-length substring +=item G_NOARGS -=item Combining pieces together +=item G_EVAL -C<ST>, C<S|T>, C<S{REPEAT_COUNT}>, C<S{min,max}>, C<S{min,max}?>, C<S?>, -C<S*>, C<S+>, C<S??>, C<S*?>, C<S+?>, C<< (?>S) >>, C<(?=S)>, C<(?<=S)>, -C<(?!S)>, C<(?<!S)>, C<(??{ EXPR })>, -C<(?(condition)yes-pattern|no-pattern)> +=item G_KEEPERR -=item Creating custom RE engines +=item Determining the Context =back -=item BUGS +=item KNOWN PROBLEMS -=item SEE ALSO +=item EXAMPLES -=back +=over 4 -=head2 perlrun - how to execute the Perl interpreter +=item No Parameters, Nothing returned -=over +=item Passing Parameters -=item SYNOPSIS +=item Returning a Scalar -=item DESCRIPTION +=item Returning a list of values -=over +=item Returning a list in a scalar context -=item #! and quoting on non-Unix systems +=item Returning Data from Perl via the parameter list -OS/2, MS-DOS, Win95/NT, Macintosh, VMS +=item Using G_EVAL -=item Location of Perl +=item Using G_KEEPERR -=item Command Switches +=item Using call_sv -B<-0>[I<digits>], B<-a>, B<-C>, B<-c>, B<-d>, B<-d:>I<foo>, -B<-D>I<letters>, B<-D>I<number>, B<-e> I<commandline>, B<-F>I<pattern>, -B<-h>, B<-i>[I<extension>], B<-I>I<directory>, B<-l>[I<octnum>], -B<-m>[B<->]I<module>, B<-M>[B<->]I<module>, B<-M>[B<->]I<'module ...'>, -B<-[mM]>[B<->]I<module=arg[,arg]...>, B<-n>, B<-p>, B<-P>, B<-s>, B<-S>, -B<-T>, B<-u>, B<-U>, B<-v>, B<-V>, B<-V:>I<name>, B<-w>, B<-W>, B<-X>, -B<-x> I<directory> +=item Using call_argv + +=item Using call_method + +=item Using GIMME_V + +=item Using Perl to dispose of temporaries + +=item Strategies for storing Callback Context Information + +1. Ignore the problem - Allow only 1 callback, 2. Create a sequence of +callbacks - hard wired limit, 3. Use a parameter to map to the Perl +callback + +=item Alternate Stack Manipulation + +=item Creating and calling an anonymous subroutine in C =back -=item ENVIRONMENT +=item SEE ALSO -HOME, LOGDIR, PATH, PERL5LIB, PERL5OPT, PERLLIB, PERL5DB, PERL5SHELL -(specific to the Win32 port), PERL_DEBUG_MSTATS, PERL_DESTRUCT_LEVEL +=item AUTHOR + +=item DATE =back -=head2 perlfunc - Perl builtin functions +=head2 perlutil - utilities packaged with the Perl distribution -=over +=over 4 =item DESCRIPTION -=over +=over 4 -=item Perl Functions by Category +=item DOCUMENTATION -Functions for SCALARs or strings, Regular expressions and pattern matching, -Numeric functions, Functions for real @ARRAYs, Functions for list data, -Functions for real %HASHes, Input and output functions, Functions for fixed -length data or records, Functions for filehandles, files, or directories, -Keywords related to the control flow of your perl program, Keywords related -to scoping, Miscellaneous functions, Functions for processes and process -groups, Keywords related to perl modules, Keywords related to classes and -object-orientedness, Low-level socket functions, System V interprocess -communication functions, Fetching user and group info, Fetching network -info, Time-related functions, Functions new in perl5, Functions obsoleted -in perl5 +L<perldoc|perldoc>, L<pod2man|pod2man> and L<pod2text|pod2text>, +L<pod2html|pod2html> and L<pod2latex|pod2latex>, L<pod2usage|pod2usage>, +L<podselect|podselect>, L<podchecker|podchecker>, L<splain|splain>, +L<roffitall|roffitall> -=item Portability +=item CONVERTORS -=item Alphabetical Listing of Perl Functions +L<a2p|a2p>, L<s2p|s2p>, L<find2perl|find2perl> -I<-X> FILEHANDLE, I<-X> EXPR, I<-X>, abs VALUE, abs, accept -NEWSOCKET,GENERICSOCKET, alarm SECONDS, alarm, atan2 Y,X, bind SOCKET,NAME, -binmode FILEHANDLE, DISCIPLINE, binmode FILEHANDLE, bless REF,CLASSNAME, -bless REF, caller EXPR, caller, chdir EXPR, chmod LIST, chomp VARIABLE, -chomp LIST, chomp, chop VARIABLE, chop LIST, chop, chown LIST, chr NUMBER, -chr, chroot FILENAME, chroot, close FILEHANDLE, close, closedir DIRHANDLE, -connect SOCKET,NAME, continue BLOCK, cos EXPR, crypt PLAINTEXT,SALT, -dbmclose HASH, dbmopen HASH,DBNAME,MASK, defined EXPR, defined, delete -EXPR, die LIST, do BLOCK, do SUBROUTINE(LIST), do EXPR, dump LABEL, dump, -each HASH, eof FILEHANDLE, eof (), eof, eval EXPR, eval BLOCK, exec LIST, -exec PROGRAM LIST, exists EXPR, exit EXPR, exp EXPR, exp, fcntl -FILEHANDLE,FUNCTION,SCALAR, fileno FILEHANDLE, flock FILEHANDLE,OPERATION, -fork, format, formline PICTURE,LIST, getc FILEHANDLE, getc, getlogin, -getpeername SOCKET, getpgrp PID, getppid, getpriority WHICH,WHO, getpwnam -NAME, getgrnam NAME, gethostbyname NAME, getnetbyname NAME, getprotobyname -NAME, getpwuid UID, getgrgid GID, getservbyname NAME,PROTO, gethostbyaddr -ADDR,ADDRTYPE, getnetbyaddr ADDR,ADDRTYPE, getprotobynumber NUMBER, -getservbyport PORT,PROTO, getpwent, getgrent, gethostent, getnetent, -getprotoent, getservent, setpwent, setgrent, sethostent STAYOPEN, setnetent -STAYOPEN, setprotoent STAYOPEN, setservent STAYOPEN, endpwent, endgrent, -endhostent, endnetent, endprotoent, endservent, getsockname SOCKET, -getsockopt SOCKET,LEVEL,OPTNAME, glob EXPR, glob, gmtime EXPR, goto LABEL, -goto EXPR, goto &NAME, grep BLOCK LIST, grep EXPR,LIST, hex EXPR, hex, -import, index STR,SUBSTR,POSITION, index STR,SUBSTR, int EXPR, int, ioctl -FILEHANDLE,FUNCTION,SCALAR, join EXPR,LIST, keys HASH, kill SIGNAL, LIST, -last LABEL, last, lc EXPR, lc, lcfirst EXPR, lcfirst, length EXPR, length, -link OLDFILE,NEWFILE, listen SOCKET,QUEUESIZE, local EXPR, localtime EXPR, -lock, log EXPR, log, lstat FILEHANDLE, lstat EXPR, lstat, m//, map BLOCK -LIST, map EXPR,LIST, mkdir FILENAME,MASK, mkdir FILENAME, msgctl -ID,CMD,ARG, msgget KEY,FLAGS, msgrcv ID,VAR,SIZE,TYPE,FLAGS, msgsnd -ID,MSG,FLAGS, my EXPR, my EXPR : ATTRIBUTES, next LABEL, next, no Module -LIST, oct EXPR, oct, open FILEHANDLE,MODE,LIST, open FILEHANDLE,EXPR, open -FILEHANDLE, opendir DIRHANDLE,EXPR, ord EXPR, ord, our EXPR, pack -TEMPLATE,LIST, package, package NAMESPACE, pipe READHANDLE,WRITEHANDLE, pop -ARRAY, pop, pos SCALAR, pos, print FILEHANDLE LIST, print LIST, print, -printf FILEHANDLE FORMAT, LIST, printf FORMAT, LIST, prototype FUNCTION, -push ARRAY,LIST, q/STRING/, qq/STRING/, qr/STRING/, qx/STRING/, qw/STRING/, -quotemeta EXPR, quotemeta, rand EXPR, rand, read -FILEHANDLE,SCALAR,LENGTH,OFFSET, read FILEHANDLE,SCALAR,LENGTH, readdir -DIRHANDLE, readline EXPR, readlink EXPR, readlink, readpipe EXPR, recv -SOCKET,SCALAR,LENGTH,FLAGS, redo LABEL, redo, ref EXPR, ref, rename -OLDNAME,NEWNAME, require VERSION, require EXPR, require, reset EXPR, reset, -return EXPR, return, reverse LIST, rewinddir DIRHANDLE, rindex -STR,SUBSTR,POSITION, rindex STR,SUBSTR, rmdir FILENAME, rmdir, s///, scalar -EXPR, seek FILEHANDLE,POSITION,WHENCE, seekdir DIRHANDLE,POS, select -FILEHANDLE, select, select RBITS,WBITS,EBITS,TIMEOUT, semctl -ID,SEMNUM,CMD,ARG, semget KEY,NSEMS,FLAGS, semop KEY,OPSTRING, send -SOCKET,MSG,FLAGS,TO, send SOCKET,MSG,FLAGS, setpgrp PID,PGRP, setpriority -WHICH,WHO,PRIORITY, setsockopt SOCKET,LEVEL,OPTNAME,OPTVAL, shift ARRAY, -shift, shmctl ID,CMD,ARG, shmget KEY,SIZE,FLAGS, shmread ID,VAR,POS,SIZE, -shmwrite ID,STRING,POS,SIZE, shutdown SOCKET,HOW, sin EXPR, sin, sleep -EXPR, sleep, socket SOCKET,DOMAIN,TYPE,PROTOCOL, socketpair -SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL, sort SUBNAME LIST, sort BLOCK LIST, -sort LIST, splice ARRAY,OFFSET,LENGTH,LIST, splice ARRAY,OFFSET,LENGTH, -splice ARRAY,OFFSET, splice ARRAY, split /PATTERN/,EXPR,LIMIT, split -/PATTERN/,EXPR, split /PATTERN/, split, sprintf FORMAT, LIST, sqrt EXPR, -sqrt, srand EXPR, srand, stat FILEHANDLE, stat EXPR, stat, study SCALAR, -study, sub BLOCK, sub NAME, sub NAME BLOCK, substr -EXPR,OFFSET,LENGTH,REPLACEMENT, substr EXPR,OFFSET,LENGTH, substr -EXPR,OFFSET, symlink OLDFILE,NEWFILE, syscall LIST, sysopen -FILEHANDLE,FILENAME,MODE, sysopen FILEHANDLE,FILENAME,MODE,PERMS, sysread -FILEHANDLE,SCALAR,LENGTH,OFFSET, sysread FILEHANDLE,SCALAR,LENGTH, sysseek -FILEHANDLE,POSITION,WHENCE, system LIST, system PROGRAM LIST, syswrite -FILEHANDLE,SCALAR,LENGTH,OFFSET, syswrite FILEHANDLE,SCALAR,LENGTH, -syswrite FILEHANDLE,SCALAR, tell FILEHANDLE, tell, telldir DIRHANDLE, tie -VARIABLE,CLASSNAME,LIST, tied VARIABLE, time, times, tr///, truncate -FILEHANDLE,LENGTH, truncate EXPR,LENGTH, uc EXPR, uc, ucfirst EXPR, -ucfirst, umask EXPR, umask, undef EXPR, undef, unlink LIST, unlink, unpack -TEMPLATE,EXPR, untie VARIABLE, unshift ARRAY,LIST, use Module VERSION LIST, -use Module VERSION, use Module LIST, use Module, use VERSION, utime LIST, -values HASH, vec EXPR,OFFSET,BITS, wait, waitpid PID,FLAGS, wantarray, warn -LIST, write FILEHANDLE, write EXPR, write, y/// +=item Development + +L<perlbug|perlbug>, L<h2ph|h2ph>, L<c2ph|c2ph> and L<pstruct|pstruct>, +L<h2xs|h2xs>, L<dprofpp|dprofpp>, L<perlcc|perlcc> + +=item SEE ALSO =back =back -=head2 perlvar - Perl predefined variables +=head2 perlfilter - Source Filters -=over +=over 4 =item DESCRIPTION -=over +=item CONCEPTS -=item Predefined Names +=item USING FILTERS -$ARG, $_, $<I<digits>>, $MATCH, $&, $PREMATCH, $`, $POSTMATCH, $', -$LAST_PAREN_MATCH, $+, @+, $MULTILINE_MATCHING, $*, input_line_number -HANDLE EXPR, $INPUT_LINE_NUMBER, $NR, $, input_record_separator HANDLE -EXPR, $INPUT_RECORD_SEPARATOR, $RS, $/, autoflush HANDLE EXPR, -$OUTPUT_AUTOFLUSH, $|, output_field_separator HANDLE EXPR, -$OUTPUT_FIELD_SEPARATOR, $OFS, $,, output_record_separator HANDLE EXPR, -$OUTPUT_RECORD_SEPARATOR, $ORS, $\, $LIST_SEPARATOR, $", -$SUBSCRIPT_SEPARATOR, $SUBSEP, $;, $OFMT, $#, format_page_number HANDLE -EXPR, $FORMAT_PAGE_NUMBER, $%, format_lines_per_page HANDLE EXPR, -$FORMAT_LINES_PER_PAGE, $=, format_lines_left HANDLE EXPR, -$FORMAT_LINES_LEFT, $-, @-, C<$`> is the same as C<substr($var, 0, $-[0]>), -C<$&> is the same as C<substr($var, $-[0], $+[0] - $-[0]>), C<$'> is the -same as C<substr($var, $+[0]>), C<$1> is the same as C<substr($var, $-[1], -$+[1] - $-[1])>, C<$2> is the same as C<substr($var, $-[2], $+[2] - -$-[2])>, C<$3> is the same as C<substr $var, $-[3], $+[3] - $-[3]>), -format_name HANDLE EXPR, $FORMAT_NAME, $~, format_top_name HANDLE EXPR, -$FORMAT_TOP_NAME, $^, format_line_break_characters HANDLE EXPR, -$FORMAT_LINE_BREAK_CHARACTERS, $:, format_formfeed HANDLE EXPR, -$FORMAT_FORMFEED, $^L, $ACCUMULATOR, $^A, $CHILD_ERROR, $?, $OS_ERROR, -$ERRNO, $!, $EXTENDED_OS_ERROR, $^E, $EVAL_ERROR, $@, $PROCESS_ID, $PID, -$$, $REAL_USER_ID, $UID, $<, $EFFECTIVE_USER_ID, $EUID, $>, $REAL_GROUP_ID, -$GID, $(, $EFFECTIVE_GROUP_ID, $EGID, $), $PROGRAM_NAME, $0, $[, $], -$COMPILING, $^C, $DEBUGGING, $^D, $SYSTEM_FD_MAX, $^F, $^H, %^H, -$INPLACE_EDIT, $^I, $^M, $OSNAME, $^O, $PERLDB, $^P, 0x01, 0x02, 0x04, -0x08, 0x10, 0x20, 0x40, 0x80, 0x100, 0x200, $LAST_REGEXP_CODE_RESULT, $^R, -$EXCEPTIONS_BEING_CAUGHT, $^S, $BASETIME, $^T, $PERL_VERSION, $^V, -$WARNING, $^W, ${^WARNING_BITS}, ${^WIDE_SYSTEM_CALLS}, $EXECUTABLE_NAME, -$^X, $ARGV, @ARGV, @INC, @_, %INC, %ENV, $ENV{expr}, %SIG, $SIG{expr} +=item WRITING A SOURCE FILTER -=item Error Indicators +=item WRITING A SOURCE FILTER IN C -=item Technical Note on the Syntax of Variable Names +B<Decryption Filters> -=back +=item CREATING A SOURCE FILTER AS A SEPARATE EXECUTABLE -=item BUGS +=item WRITING A SOURCE FILTER IN PERL + +=item USING CONTEXT: THE DEBUG FILTER + +=item CONCLUSION + +=item REQUIREMENTS + +=item AUTHOR + +=item Copyrights =back -=head2 perlsub - Perl subroutines +=head2 perldbmfilter - Perl DBM Filters -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over - -=item Private Variables via my() +B<filter_store_key>, B<filter_store_value>, B<filter_fetch_key>, +B<filter_fetch_value> -=item Persistent Private Variables +=over 4 -=item Temporary Values via local() +=item The Filter -=item Lvalue subroutines +=item An Example -- the NULL termination problem. -=item Passing Symbol Table Entries (typeglobs) +=item Another Example -- Key is a C int. -=item When to Still Use local() +=back -1. You need to give a global variable a temporary value, especially $_, 2. -You need to create a local file or directory handle or a local function, 3. -You want to temporarily change just one element of an array or hash +=item SEE ALSO -=item Pass by Reference +=item AUTHOR -=item Prototypes +=back -=item Constant Functions +=head2 perlapi - autogenerated documentation for the perl public API -=item Overriding Built-in Functions +=over 4 -=item Autoloading +=item DESCRIPTION -=item Subroutine Attributes +AvFILL, av_clear, av_delete, av_exists, av_extend, av_fetch, av_fill, +av_len, av_make, av_pop, av_push, av_shift, av_store, av_undef, av_unshift, +bytes_from_utf8, bytes_to_utf8, call_argv, call_method, call_pv, call_sv, +CLASS, Copy, croak, CvSTASH, dMARK, dORIGMARK, dSP, dXSARGS, dXSI32, ENTER, +eval_pv, eval_sv, EXTEND, fbm_compile, fbm_instr, FREETMPS, get_av, get_cv, +get_hv, get_sv, GIMME, GIMME_V, GvSV, gv_fetchmeth, gv_fetchmethod, +gv_fetchmethod_autoload, gv_stashpv, gv_stashsv, G_ARRAY, G_DISCARD, +G_EVAL, G_NOARGS, G_SCALAR, G_VOID, HEf_SVKEY, HeHASH, HeKEY, HeKLEN, HePV, +HeSVKEY, HeSVKEY_force, HeSVKEY_set, HeVAL, HvNAME, hv_clear, hv_delete, +hv_delete_ent, hv_exists, hv_exists_ent, hv_fetch, hv_fetch_ent, +hv_iterinit, hv_iterkey, hv_iterkeysv, hv_iternext, hv_iternextsv, +hv_iterval, hv_magic, hv_store, hv_store_ent, hv_undef, isALNUM, isALPHA, +isDIGIT, isLOWER, isSPACE, isUPPER, is_utf8_char, is_utf8_string, items, +ix, LEAVE, looks_like_number, MARK, mg_clear, mg_copy, mg_find, mg_free, +mg_get, mg_length, mg_magical, mg_set, Move, New, newAV, Newc, newCONSTSUB, +newHV, newRV_inc, newRV_noinc, NEWSV, newSViv, newSVnv, newSVpv, newSVpvf, +newSVpvn, newSVrv, newSVsv, newSVuv, newXS, newXSproto, Newz, Nullav, +Nullch, Nullcv, Nullhv, Nullsv, ORIGMARK, perl_alloc, perl_construct, +perl_destruct, perl_free, perl_parse, perl_run, PL_modglobal, PL_na, +PL_sv_no, PL_sv_undef, PL_sv_yes, POPi, POPl, POPn, POPp, POPs, PUSHi, +PUSHMARK, PUSHn, PUSHp, PUSHs, PUSHu, PUTBACK, Renew, Renewc, require_pv, +RETVAL, Safefree, savepv, savepvn, SAVETMPS, SP, SPAGAIN, ST, strEQ, strGE, +strGT, strLE, strLT, strNE, strnEQ, strnNE, StructCopy, SvCUR, SvCUR_set, +SvEND, SvGETMAGIC, SvGROW, SvIOK, SvIOKp, SvIOK_notUV, SvIOK_off, SvIOK_on, +SvIOK_only, SvIOK_only_UV, SvIOK_UV, SvIV, SvIVX, SvLEN, SvNIOK, SvNIOKp, +SvNIOK_off, SvNOK, SvNOKp, SvNOK_off, SvNOK_on, SvNOK_only, SvNV, SvNVX, +SvOK, SvOOK, SvPOK, SvPOKp, SvPOK_off, SvPOK_on, SvPOK_only, +SvPOK_only_UTF8, SvPV, SvPVX, SvPV_force, SvPV_nolen, SvREFCNT, +SvREFCNT_dec, SvREFCNT_inc, SvROK, SvROK_off, SvROK_on, SvRV, SvSETMAGIC, +SvSetSV, SvSetSV_nosteal, SvSTASH, SvTAINT, SvTAINTED, SvTAINTED_off, +SvTAINTED_on, SvTRUE, svtype, SvTYPE, SVt_IV, SVt_NV, SVt_PV, SVt_PVAV, +SVt_PVCV, SVt_PVHV, SVt_PVMG, SvUPGRADE, SvUTF8, SvUTF8_off, SvUTF8_on, +SvUV, SvUVX, sv_2mortal, sv_bless, sv_catpv, sv_catpvf, sv_catpvf_mg, +sv_catpvn, sv_catpvn_mg, sv_catpv_mg, sv_catsv, sv_catsv_mg, sv_chop, +sv_clear, sv_cmp, sv_cmp_locale, sv_dec, sv_derived_from, sv_eq, sv_free, +sv_gets, sv_grow, sv_inc, sv_insert, sv_isa, sv_isobject, sv_len, +sv_len_utf8, sv_magic, sv_mortalcopy, sv_newmortal, sv_pvn_force, +sv_pvutf8n_force, sv_reftype, sv_replace, sv_rvweaken, sv_setiv, +sv_setiv_mg, sv_setnv, sv_setnv_mg, sv_setpv, sv_setpvf, sv_setpvf_mg, +sv_setpviv, sv_setpviv_mg, sv_setpvn, sv_setpvn_mg, sv_setpv_mg, +sv_setref_iv, sv_setref_nv, sv_setref_pv, sv_setref_pvn, sv_setsv, +sv_setsv_mg, sv_setuv, sv_setuv_mg, sv_true, sv_unmagic, sv_unref, +sv_upgrade, sv_usepvn, sv_usepvn_mg, sv_utf8_downgrade, sv_utf8_encode, +sv_utf8_upgrade, sv_vcatpvfn, sv_vsetpvfn, THIS, toLOWER, toUPPER, +utf8_distance, utf8_hop, utf8_length, utf8_to_bytes, utf8_to_uv, +utf8_to_uv_simple, uv_to_utf8, warn, XPUSHi, XPUSHn, XPUSHp, XPUSHs, +XPUSHu, XS, XSRETURN, XSRETURN_EMPTY, XSRETURN_IV, XSRETURN_NO, +XSRETURN_NV, XSRETURN_PV, XSRETURN_UNDEF, XSRETURN_YES, XST_mIV, XST_mNO, +XST_mNV, XST_mPV, XST_mUNDEF, XST_mYES, XS_VERSION, XS_VERSION_BOOTCHECK, +Zero -=back +=item AUTHORS =item SEE ALSO =back -=head2 perlmod - Perl modules (packages and symbol tables) +=head2 perlintern - autogenerated documentation of purely B<internal> + Perl functions -=over +=over 4 =item DESCRIPTION -=over +is_gv_magical, LVRET, PL_DBsingle, PL_DBsub, PL_DBtrace, PL_dowarn, +PL_last_in_gv, PL_ofs_sv, PL_rs -=item Packages +=item AUTHORS -=item Symbol Tables +=item SEE ALSO -=item Package Constructors and Destructors +=back -=item Perl Classes +=head2 perlapio - perl's IO abstraction interface. -=item Perl Modules +=over 4 -=back +=item SYNOPSIS -=item SEE ALSO +=item DESCRIPTION + +B<PerlIO *>, B<PerlIO_stdin()>, B<PerlIO_stdout()>, B<PerlIO_stderr()>, +B<PerlIO_open(path, mode)>, B<PerlIO_fdopen(fd,mode)>, +B<PerlIO_printf(f,fmt,...)>, B<PerlIO_vprintf(f,fmt,a)>, +B<PerlIO_stdoutf(fmt,...)>, B<PerlIO_read(f,buf,count)>, +B<PerlIO_write(f,buf,count)>, B<PerlIO_close(f)>, B<PerlIO_puts(f,s)>, +B<PerlIO_putc(f,c)>, B<PerlIO_ungetc(f,c)>, B<PerlIO_getc(f)>, +B<PerlIO_eof(f)>, B<PerlIO_error(f)>, B<PerlIO_fileno(f)>, +B<PerlIO_clearerr(f)>, B<PerlIO_flush(f)>, B<PerlIO_tell(f)>, +B<PerlIO_seek(f,o,w)>, B<PerlIO_getpos(f,p)>, B<PerlIO_setpos(f,p)>, +B<PerlIO_rewind(f)>, B<PerlIO_tmpfile()> + +=over 4 + +=item Co-existence with stdio + +B<PerlIO_importFILE(f,flags)>, B<PerlIO_exportFILE(f,flags)>, +B<PerlIO_findFILE(f)>, B<PerlIO_releaseFILE(p,f)>, B<PerlIO_setlinebuf(f)>, +B<PerlIO_has_cntptr(f)>, B<PerlIO_get_ptr(f)>, B<PerlIO_get_cnt(f)>, +B<PerlIO_canset_cnt(f)>, B<PerlIO_fast_gets(f)>, +B<PerlIO_set_ptrcnt(f,p,c)>, B<PerlIO_set_cnt(f,c)>, B<PerlIO_has_base(f)>, +B<PerlIO_get_base(f)>, B<PerlIO_get_bufsiz(f)> =back -=head2 perlmodlib - constructing new Perl modules and finding existing ones +=back -=over +=head2 perltodo - Perl TO-DO List -=item DESCRIPTION +=over 4 -=item THE PERL MODULE LIBRARY +=item DESCRIPTION -=over +=item Infrastructure -=item Pragmatic Modules +=over 4 -attributes, attrs, autouse, base, blib, caller, charnames, constant, -diagnostics, fields, filetest, integer, less, lib, locale, ops, overload, -re, sigtrap, strict, subs, utf8, vars, warnings +=item Mailing list archives -=item Standard Modules +=item Bug tracking system -AnyDBM_File, AutoLoader, AutoSplit, B, B::Asmdata, B::Assembler, B::Bblock, -B::Bytecode, B::C, B::CC, B::Debug, B::Deparse, B::Disassembler, B::Lint, -B::Showlex, B::Stackobj, B::Terse, B::Xref, Benchmark, ByteLoader, CGI, -CGI::Apache, CGI::Carp, CGI::Cookie, CGI::Fast, CGI::Pretty, CGI::Push, -CGI::Switch, CPAN, CPAN::FirstTime, CPAN::Nox, Carp, Carp::Heavy, -Class::Struct, Config, Cwd, DB, DB_File, Data::Dumper, Devel::DProf, -Devel::Peek, Devel::SelfStubber, DirHandle, Dumpvalue, DynaLoader, English, -Env, Errno, Exporter, Exporter::Heavy, ExtUtils::Command, ExtUtils::Embed, -ExtUtils::Install, ExtUtils::Installed, ExtUtils::Liblist, -ExtUtils::MM_Cygwin, ExtUtils::MM_OS2, ExtUtils::MM_Unix, ExtUtils::MM_VMS, -ExtUtils::MM_Win32, ExtUtils::MakeMaker, ExtUtils::Manifest, -ExtUtils::Mkbootstrap, ExtUtils::Mksymlists, ExtUtils::Packlist, -ExtUtils::testlib, Fatal, Fcntl, File::Basename, File::CheckTree, -File::Compare, File::Copy, File::DosGlob, File::Find, File::Glob, -File::Path, File::Spec, File::Spec::Functions, File::Spec::Mac, -File::Spec::OS2, File::Spec::Unix, File::Spec::VMS, File::Spec::Win32, -File::stat, FileCache, FileHandle, FindBin, GDBM_File, Getopt::Long, -Getopt::Std, I18N::Collate, IO, IO::Dir, IO::File, IO::Handle, IO::Pipe, -IO::Poll, IO::Seekable, IO::Select, IO::Socket, IO::Socket::INET, -IO::Socket::UNIX, IPC::Msg, IPC::Open2, IPC::Open3, IPC::Semaphore, -IPC::SysV, Math::BigFloat, Math::BigInt, Math::Complex, Math::Trig, -Net::Ping, Net::hostent, Net::netent, Net::protoent, Net::servent, O, -Opcode, POSIX, Pod::Checker, Pod::Html, Pod::InputObjects, Pod::Man, -Pod::Parser, Pod::Select, Pod::Text, Pod::Text::Color, Pod::Usage, -SDBM_File, Safe, Search::Dict, SelectSaver, SelfLoader, Shell, Socket, -Symbol, Sys::Hostname, Sys::Syslog, Term::Cap, Term::Complete, -Term::ReadLine, Test, Test::Harness, Text::Abbrev, Text::ParseWords, -Text::Soundex, Text::Wrap, Tie::Array, Tie::Handle, Tie::Hash, -Tie::RefHash, Tie::Scalar, Tie::SubstrHash, Time::Local, Time::gmtime, -Time::localtime, Time::tm, UNIVERSAL, User::grent, User::pwent +=item Regression Tests -=item Extension Modules +Coverage, Regression, __DIE__, suidperl, The 25% slowdown from perl4 to +perl5 =back -=item CPAN - -Language Extensions and Documentation Tools, Development Support, Operating -System Interfaces, Networking, Device Control (modems) and InterProcess -Communication, Data Types and Data Type Utilities, Database Interfaces, -User Interfaces, Interfaces to / Emulations of Other Programming Languages, -File Names, File Systems and File Locking (see also File Handles), String -Processing, Language Text Processing, Parsing, and Searching, Option, -Argument, Parameter, and Configuration File Processing, -Internationalization and Locale, Authentication, Security, and Encryption, -World Wide Web, HTML, HTTP, CGI, MIME, Server and Daemon Utilities, -Archiving and Compression, Images, Pixmap and Bitmap Manipulation, Drawing, -and Graphing, Mail and Usenet News, Control Flow Utilities (callbacks and -exceptions etc), File Handle and Input/Output Stream Utilities, -Miscellaneous Modules, Africa, Asia, Australasia, Central America, Europe, -North America, South America +=item Configure -=item Modules: Creation, Use, and Abuse +=over 4 -=over +=item Install HTML -=item Guidelines for Module Creation +=back -Do similar modules already exist in some form?, Try to design the new -module to be easy to extend and reuse, Some simple style guidelines, Select -what to export, Select a name for the module, Have you got it right?, -README and other Additional Files, A description of the -module/package/extension etc, A copyright notice - see below, Prerequisites -- what else you may need to have, How to build it - possible changes to -Makefile.PL etc, How to install it, Recent changes in this release, -especially incompatibilities, Changes / enhancements you plan to make in -the future, Adding a Copyright Notice, Give the module a -version/issue/release number, How to release and distribute a module, Take -care when changing a released module +=item Perl Language -=item Guidelines for Converting Perl 4 Library Scripts into Modules +=over 4 -There is no requirement to convert anything, Consider the implications, -Make the most of the opportunity, The pl2pm utility will get you started, -Adds the standard Module prologue lines, Converts package specifiers from ' -to ::, Converts die(...) to croak(...), Several other minor changes +=item 64-bit Perl -=item Guidelines for Reusing Application Code +=item Prototypes -Complete applications rarely belong in the Perl Module Library, Many -applications contain some Perl code that could be reused, Break-out the -reusable code into one or more separate module files, Take the opportunity -to reconsider and redesign the interfaces, In some cases the 'application' -can then be reduced to a small +Named prototypes, Indirect objects, Method calls, Context, Scoped subs =back -=item NOTE +=item Perl Internals -=back +=over 4 -=head2 perlmodinstall - Installing CPAN Modules +=item magic_setisa -=over +=item Garbage Collection -=item DESCRIPTION +=item Reliable signals -=over +Alternate runops() for signal despatch, Figure out how to die() in delayed +sighandler, Add tests for Thread::Signal, Automatic tests against CPAN -=item PREAMBLE +=item Interpolated regex performance bugs -B<DECOMPRESS> the file, B<UNPACK> the file into a directory, B<BUILD> the -module (sometimes unnecessary), B<INSTALL> the module +=item Memory leaks from failed eval/regcomp -=back +=item Make XS easier to use -=item HEY +=item Make embedded Perl easier to use -=item AUTHOR +=item Namespace cleanup -=item COPYRIGHT +=item MULTIPLICITY + +=item MacPerl =back -=head2 perlfork - Perl's fork() emulation +=item Documentation -=over +=over 4 -=item SYNOPSIS +=item A clear division into tutorial and reference -=item DESCRIPTION +=item Remove the artificial distinction between operators and functions -=over +=item More tutorials -=item Behavior of other Perl features in forked pseudo-processes +Regular expressions, I/O, pack/unpack, Debugging -$$ or $PROCESS_ID, %ENV, chdir() and all other builtins that accept -filenames, wait() and waitpid(), kill(), exec(), exit(), Open handles to -files, directories and network sockets +=item Include a search tool -=item Resource limits +=item Include a locate tool -=item Killing the parent process +=item Separate function manpages by default -=item Lifetime of the parent process and pseudo-processes +=item Users can't find the manpages -=item CAVEATS AND LIMITATIONS +=item Install ALL Documentation -BEGIN blocks, Open filehandles, Forking pipe open() not yet implemented, -Global state maintained by XSUBs, Interpreter embedded in larger -application, Thread-safety of extensions - -=back +=item Outstanding issues to be documented -=item BUGS +=item Adapt www.linuxhq.com for Perl -=item AUTHOR +=item Replace man with a perl program -=item SEE ALSO +=item Unicode tutorial =back -=head2 perlform - Perl formats +=item Modules -=over +=over 4 -=item DESCRIPTION +=item Update the POSIX extension to conform with the POSIX 1003.1 Edition 2 -=over +=item Module versions -=item Format Variables +=item New modules -=back +=item Profiler -=item NOTES +=item Tie Modules -=over +VecArray, SubstrArray, VirtualArray, ShiftSplice -=item Footers +=item Procedural options -=item Accessing Formatting Internals +=item RPC -=back +=item y2k localtime/gmtime -=item WARNINGS +=item Export File::Find variables -=back +=item Ioctl -=head2 perllocale - Perl locale handling (internationalization and -localization) +=item Debugger attach/detach -=over +=item Regular Expression debugger -=item DESCRIPTION +=item Alternative RE Syntax -=item PREPARING TO USE LOCALES +=item Bundled modules -=item USING LOCALES +=item Expect -=over +=item GUI::Native -=item The use locale pragma +=item Update semibroken auxiliary tools; h2ph, a2p, etc. -=item The setlocale function +=item pod2html -=item Finding locales +=item Podchecker -=item LOCALE PROBLEMS +=back -=item Temporarily fixing locale problems +=item Tom's Wishes -=item Permanently fixing locale problems +=over 4 -=item Permanently fixing your system's locale configuration +=item Webperl -=item Fixing system locale configuration +=item Mobile agents -=item The localeconv function +=item POSIX on non-POSIX + +=item Portable installations =back -=item LOCALE CATEGORIES +=item Win32 Stuff -=over +=over 4 -=item Category LC_COLLATE: Collation +=item Rename new headers to be consistent with the rest -=item Category LC_CTYPE: Character Types +=item Sort out the spawnvp() mess -=item Category LC_NUMERIC: Numeric Formatting +=item Work out DLL versioning -=item Category LC_MONETARY: Formatting of monetary amounts +=item Style-check -=item LC_TIME +=back -=item Other categories +=item Would be nice to have -=back +C<pack "(stuff)*">, Contiguous bitfields in pack/unpack, lexperl, Bundled +perl preprocessor, Use posix calls internally where possible, format +BOTTOM, -i rename file only when successfully changed, All ARGV input +should act like <>, report HANDLE [formats], support in perlmain to rerun +debugger, lvalue functions -=item SECURITY +=item Possible pragmas -B<Comparison operators> (C<lt>, C<le>, C<ge>, C<gt> and C<cmp>):, -B<Case-mapping interpolation> (with C<\l>, C<\L>, C<\u> or C<\U>), -B<Matching operator> (C<m//>):, B<Substitution operator> (C<s///>):, -B<Output formatting functions> (printf() and write()):, B<Case-mapping -functions> (lc(), lcfirst(), uc(), ucfirst()):, B<POSIX locale-dependent -functions> (localeconv(), strcoll(),strftime(), strxfrm()):, B<POSIX -character class tests> (isalnum(), isalpha(), isdigit(),isgraph(), -islower(), isprint(), ispunct(), isspace(), isupper(), -isxdigit()): +=over 4 -=item ENVIRONMENT +=item 'less' -PERL_BADLANG, LC_ALL, LANGUAGE, LC_CTYPE, LC_COLLATE, LC_MONETARY, -LC_NUMERIC, LC_TIME, LANG +=back -=item NOTES +=item Optimizations -=over +=over 4 -=item Backward compatibility +=item constant function cache -=item I18N:Collate obsolete +=item foreach(reverse...) -=item Sort speed and memory use impacts +=item Cache eval tree -=item write() and LC_NUMERIC +=item rcatmaybe -=item Freely available locale definitions +=item Shrink opcode tables -=item I18n and l10n +=item Cache hash value -=item An imperfect standard +=item Optimize away @_ where possible + +=item Optimize sort by { $a <=> $b } + +=item Rewrite regexp parser for better integrated optimization =back -=item BUGS +=item Vague possibilities -=over +ref function in list context, make tr/// return histogram in list context?, +Loop control on do{} et al, Explicit switch statements, compile to real +threaded code, structured types, Modifiable $1 et al -=item Broken systems +=item To Do Or Not To Do -=back +=over 4 -=item SEE ALSO +=item Making my() work on "package" variables -=item HISTORY +=item "or" testing defined not truth -=back +=item "dynamic" lexicals -=head2 perlref - Perl references and nested data structures +=item "class"-based, rather than package-based "lexicals" -=over +=back -=item NOTE +=item Threading -=item DESCRIPTION +=over 4 -=over +=item Modules -=item Making References +=item Testing -=item Using References +=item $AUTOLOAD -=item Symbolic references +=item exit/die -=item Not-so-symbolic references +=item External threads -=item Pseudo-hashes: Using an array as a hash +=item Thread::Pool -=item Function Templates +=item thread-safety + +=item Per-thread GVs =back -=item WARNING +=item Compiler -=item SEE ALSO +=over 4 -=back +=item Optimization -=head2 perlreftut - Mark's very short tutorial about references +=item Byteperl -=over +=item Precompiled modules -=item DESCRIPTION +=item Executables -=item Who Needs Complicated Data Structures? +=item Typed lexicals -=item The Solution +=item Win32 -=item Syntax +=item END blocks -=over +=item _AUTOLOAD -=item Making References +=item comppadlist -=item Using References +=item Cached compilation =back -=item An Example +=item Recently Finished Tasks -=item Arrow Rule +=over 4 -=item Solution +=item Figure a way out of $^(capital letter) -=item The Rest +=item Filenames -=item Summary +=item Foreign lines -=item Credits +=item Namespace cleanup -=over +=item ISA.pm -=item Distribution Conditions +=item gettimeofday + +=item autocroak? =back =back -=head2 perldsc - Perl Data Structures Cookbook +=head2 perlhack - How to hack at the Perl internals -=over +=over 4 =item DESCRIPTION -arrays of arrays, hashes of arrays, arrays of hashes, hashes of hashes, -more elaborate constructs +Does concept match the general goals of Perl?, Where is the +implementation?, Backwards compatibility, Could it be a module instead?, Is +the feature generic enough?, Does it potentially introduce new bugs?, Does +it preclude other desirable features?, Is the implementation robust?, Is +the implementation generic enough to be portable?, Is there enough +documentation?, Is there another way to do it?, Does it create too much +work?, Patches speak louder than words -=item REFERENCES +=over 4 -=item COMMON MISTAKES +=item Keeping in sync -=item CAVEAT ON PRECEDENCE +rsync'ing the source tree, Using rsync over the LAN, Using pushing over the +NFS, rsync'ing the patches -=item WHY YOU SHOULD ALWAYS C<use strict> +=item Why rsync the source tree -=item DEBUGGING +It's easier, It's more recent, It's more reliable -=item CODE EXAMPLES +=item Why rsync the patches -=item ARRAYS OF ARRAYS +It's easier, It's a good reference, Finding a start point, Finding how to +fix a bug, Finding the source of misbehaviour -=over +=item Submitting patches -=item Declaration of a ARRAY OF ARRAYS +L<perlguts>, L<perlxstut> and L<perlxs>, L<perlapi>, +F<Porting/pumpkin.pod>, The perl5-porters FAQ -=item Generation of a ARRAY OF ARRAYS +=item Finding Your Way Around -=item Access and Printing of a ARRAY OF ARRAYS +Core modules, Documentation, Configure, Interpreter -=back +=item Elements of the interpreter -=item HASHES OF ARRAYS +Startup, Parsing, Optimization, Running -=over +=item Internal Variable Types -=item Declaration of a HASH OF ARRAYS +=item Op Trees -=item Generation of a HASH OF ARRAYS +=item Stacks -=item Access and Printing of a HASH OF ARRAYS +Argument stack, Mark stack, Save stack -=back +=item Millions of Macros -=item ARRAYS OF HASHES +=item Poking at Perl -=over +=item Using a source-level debugger -=item Declaration of a ARRAY OF HASHES +run [args], break function_name, break source.c:xxx, step, next, continue, +finish, 'enter', print -=item Generation of a ARRAY OF HASHES +=item Dumping Perl Data Structures -=item Access and Printing of a ARRAY OF HASHES +=item Patching =back -=item HASHES OF HASHES +=item EXTERNAL TOOLS FOR DEBUGGING PERL -=over +=over 4 -=item Declaration of a HASH OF HASHES +=item Rational Software's Purify -=item Generation of a HASH OF HASHES +=item Purify on Unix -=item Access and Printing of a HASH OF HASHES +-Accflags=-DPURIFY, -Doptimize='-g', -Uusemymalloc, -Dusemultiplicity + +=item Purify on NT + +DEFINES, USE_MULTI = define, #PERL_MALLOC = define, CFG = Debug + +=item CONCLUSION + +I<The Road goes ever on and on, down from the door where it began.> =back -=item MORE ELABORATE RECORDS +=item AUTHOR -=over +=back -=item Declaration of MORE ELABORATE RECORDS +=head2 perlhist - the Perl history records -=item Declaration of a HASH OF COMPLEX RECORDS +=over 4 -=item Generation of a HASH OF COMPLEX RECORDS +=item DESCRIPTION + +=item INTRODUCTION + +=item THE KEEPERS OF THE PUMPKIN + +=over 4 + +=item PUMPKIN? =back -=item Database Ties +=item THE RECORDS -=item SEE ALSO +=over 4 -=item AUTHOR +=item SELECTED RELEASE SIZES + +=item SELECTED PATCH SIZES =back -=head2 perllol - Manipulating Arrays of Arrays in Perl +=item THE KEEPERS OF THE RECORDS + +=back + +=head2 perldelta - what's new for perl v5.6 -=over +=over 4 =item DESCRIPTION -=item Declaration and Access of Arrays of Arrays +=item Summary of changes between 5.6.0 and 5.6.1 -=item Growing Your Own +=over 4 -=item Access and Printing +=item Security Issues -=item Slices +=item Core bug fixes -=item SEE ALSO +C<UNIVERSAL::isa()>, Memory leaks, Numeric conversions, qw(a\\b), caller(), +Bugs in regular expressions, "slurp" mode, Autovivification of symbolic +references to special variables, Lexical warnings, Spurious warnings and +errors, glob(), Tainting, sort(), #line directives, Subroutine prototypes, +map(), Debugger, Locales, PERL5OPT, chop(), Unicode support, 64-bit +support, Compiler, Lvalue subroutines, IO::Socket, File::Find, xsubpp, C<no +Module;>, Tests -=item AUTHOR +=item Core features -=back +=item Configuration issues -=head2 perlboot - Beginner's Object-Oriented Tutorial +=item Documentation -=over +=item Bundled modules -=item DESCRIPTION +B::Concise, File::Temp, Pod::LaTeX, Pod::Text::Overstrike, CGI, CPAN, +Class::Struct, DB_File, Devel::Peek, File::Find, Getopt::Long, IO::Poll, +IPC::Open3, Math::BigFloat, Math::Complex, Net::Ping, Opcode, Pod::Parser, +Pod::Text, SDBM_File, Sys::Syslog, Tie::RefHash, Tie::SubstrHash -=over +=item Platform-specific improvements -=item If we could talk to the animals... +NCR MP-RAS, NonStop-UX -=item Introducing the method invocation arrow +=item Interpreter cloning, threads, and concurrency -=item Invoking a barnyard +=item Lexically scoped warning categories -=item The extra parameter of method invocation +=item Unicode and UTF-8 support -=item Calling a second method to simplify things +=item Support for interpolating named characters -=item Inheriting the windpipes +=item "our" declarations -=item A few notes about @ISA +=item Support for strings represented as a vector of ordinals -=item Overriding the methods +=item Improved Perl version numbering system -=item Starting the search from a different place +=item New syntax for declaring subroutine attributes -=item The SUPER way of doing things +=item File and directory handles can be autovivified -=item Where we're at so far... +=item open() with more than two arguments -=item A horse is a horse, of course of course -- or is it? +=item 64-bit support -=item Invoking an instance method +=item Large file support -=item Accessing the instance data +=item Long doubles -=item How to build a horse +=item "more bits" -=item Inheriting the constructor +=item Enhanced support for sort() subroutines -=item Making a method work with either classes or instances +=item C<sort $coderef @foo> allowed -=item Adding parameters to a method +=item File globbing implemented internally -=item More interesting instances +=item Support for CHECK blocks -=item A horse of a different color +=item POSIX character class syntax [: :] supported -=item Summary +=item Better pseudo-random number generator -=back +=item Improved C<qw//> operator -=item SEE ALSO +=item Better worst-case behavior of hashes -=item COPYRIGHT +=item pack() format 'Z' supported -=back +=item pack() format modifier '!' supported -=head2 perltoot - Tom's object-oriented tutorial for perl +=item pack() and unpack() support counted strings -=over +=item Comments in pack() templates -=item DESCRIPTION +=item Weak references -=item Creating a Class +=item Binary numbers supported -=over +=item Lvalue subroutines -=item Object Representation +=item Some arrows may be omitted in calls through references -=item Class Interface +=item Boolean assignment operators are legal lvalues -=item Constructors and Instance Methods +=item exists() is supported on subroutine names -=item Planning for the Future: Better Constructors +=item exists() and delete() are supported on array elements -=item Destructors +=item Pseudo-hashes work better -=item Other Object Methods +=item Automatic flushing of output buffers -=back +=item Better diagnostics on meaningless filehandle operations -=item Class Data +=item Where possible, buffered data discarded from duped input filehandle -=over +=item eof() has the same old magic as <> -=item Accessing Class Data +=item binmode() can be used to set :crlf and :raw modes -=item Debugging Methods +=item C<-T> filetest recognizes UTF-8 encoded files as "text" -=item Class Destructors +=item system(), backticks and pipe open now reflect exec() failure -=item Documenting the Interface +=item Improved diagnostics -=back +=item Diagnostics follow STDERR -=item Aggregation +=item More consistent close-on-exec behavior -=item Inheritance +=item syswrite() ease-of-use -=over +=item Better syntax checks on parenthesized unary operators -=item Overridden Methods +=item Bit operators support full native integer width -=item Multiple Inheritance +=item Improved security features -=item UNIVERSAL: The Root of All Objects +=item More functional bareword prototype (*) -=back +=item C<require> and C<do> may be overridden -=item Alternate Object Representations +=item $^X variables may now have names longer than one character -=over +=item New variable $^C reflects C<-c> switch -=item Arrays as Objects +=item New variable $^V contains Perl version as a string -=item Closures as Objects +=item Optional Y2K warnings + +=item Arrays now always interpolate into double-quoted strings =back -=item AUTOLOAD: Proxy Methods +=item Modules and Pragmata -=over +=over 4 -=item Autoloaded Data Methods +=item Modules -=item Inherited Autoloaded Data Methods +attributes, B, Benchmark, ByteLoader, constant, charnames, Data::Dumper, +DB, DB_File, Devel::DProf, Devel::Peek, Dumpvalue, DynaLoader, English, +Env, Fcntl, File::Compare, File::Find, File::Glob, File::Spec, +File::Spec::Functions, Getopt::Long, IO, JPL, lib, Math::BigInt, +Math::Complex, Math::Trig, Pod::Parser, Pod::InputObjects, Pod::Checker, +podchecker, Pod::ParseUtils, Pod::Find, Pod::Select, podselect, Pod::Usage, +pod2usage, Pod::Text and Pod::Man, SDBM_File, Sys::Syslog, Sys::Hostname, +Term::ANSIColor, Time::Local, Win32, XSLoader, DBM Filters + +=item Pragmata =back -=item Metaclassical Tools +=item Utility Changes -=over +=over 4 -=item Class::Struct +=item dprofpp -=item Data Members as Variables +=item find2perl -=item NOTES +=item h2xs -=item Object Terminology +=item perlcc + +=item perldoc + +=item The Perl Debugger =back -=item SEE ALSO +=item Improved Documentation -=item AUTHOR AND COPYRIGHT +perlapi.pod, perlboot.pod, perlcompile.pod, perldbmfilter.pod, +perldebug.pod, perldebguts.pod, perlfork.pod, perlfilter.pod, perlhack.pod, +perlintern.pod, perllexwarn.pod, perlnumber.pod, perlopentut.pod, +perlreftut.pod, perltootc.pod, perltodo.pod, perlunicode.pod -=item COPYRIGHT +=item Performance enhancements -=over +=over 4 -=item Acknowledgments +=item Simple sort() using { $a <=> $b } and the like are optimized -=back +=item Optimized assignments to lexical variables + +=item Faster subroutine calls + +=item delete(), each(), values() and hash iteration are faster =back -=head2 perltootc - Tom's OO Tutorial for Class Data in Perl +=item Installation and Configuration Improvements -=over +=over 4 -=item DESCRIPTION +=item -Dusethreads means something different -=item Class Data as Package Variables +=item New Configure flags -=over +=item Threadedness and 64-bitness now more daring -=item Putting All Your Eggs in One Basket +=item Long Doubles -=item Inheritance Concerns +=item -Dusemorebits -=item The Eponymous Meta-Object +=item -Duselargefiles -=item Indirect References to Class Data +=item installusrbinperl -=item Monadic Classes +=item SOCKS support -=item Translucent Attributes +=item C<-A> flag + +=item Enhanced Installation Directories + +=item gcc automatically tried if 'cc' does not seem to be working =back -=item Class Data as Lexical Variables +=item Platform specific changes -=over +=over 4 -=item Privacy and Responsibility +=item Supported platforms -=item File-Scoped Lexicals +=item DOS -=item More Inheritance Concerns +=item OS390 (OpenEdition MVS) -=item Locking the Door and Throwing Away the Key +=item VMS -=item Translucency Revisited +=item Win32 =back -=item NOTES +=item Significant bug fixes -=item SEE ALSO +=over 4 -=item AUTHOR AND COPYRIGHT +=item <HANDLE> on empty files -=item ACKNOWLEDGEMENTS +=item C<eval '...'> improvements -=item HISTORY +=item All compilation errors are true errors -=back +=item Implicitly closed filehandles are safer -=head2 perlobj - Perl objects +=item Behavior of list slices is more consistent -=over +=item C<(\$)> prototype and C<$foo{a}> -=item DESCRIPTION +=item C<goto &sub> and AUTOLOAD -=over +=item C<-bareword> allowed under C<use integer> -=item An Object is Simply a Reference +=item Failures in DESTROY() -=item A Class is Simply a Package +=item Locale bugs fixed -=item A Method is Simply a Subroutine +=item Memory leaks -=item Method Invocation +=item Spurious subroutine stubs after failed subroutine calls -=item WARNING +=item Taint failures under C<-U> -=item Default UNIVERSAL methods +=item END blocks and the C<-c> switch -isa(CLASS), can(METHOD), VERSION( [NEED] ) +=item Potential to leak DATA filehandles -=item Destructors +=back -=item Summary +=item New or Changed Diagnostics -=item Two-Phased Garbage Collection +"%s" variable %s masks earlier declaration in same %s, "my sub" not yet +implemented, "our" variable %s redeclared, '!' allowed only after types %s, +/ cannot take a count, / must be followed by a, A or Z, / must be followed +by a*, A* or Z*, / must follow a numeric type, /%s/: Unrecognized escape +\\%c passed through, /%s/: Unrecognized escape \\%c in character class +passed through, /%s/ should probably be written as "%s", %s() called too +early to check prototype, %s argument is not a HASH or ARRAY element, %s +argument is not a HASH or ARRAY element or slice, %s argument is not a +subroutine name, %s package attribute may clash with future reserved word: +%s, (in cleanup) %s, <> should be quotes, Attempt to join self, Bad evalled +substitution pattern, Bad realloc() ignored, Bareword found in conditional, +Binary number > 0b11111111111111111111111111111111 non-portable, Bit vector +size > 32 non-portable, Buffer overflow in prime_env_iter: %s, Can't check +filesystem of script "%s", Can't declare class for non-scalar %s in "%s", +Can't declare %s in "%s", Can't ignore signal CHLD, forcing to default, +Can't modify non-lvalue subroutine call, Can't read CRTL environ, Can't +remove %s: %s, skipping file, Can't return %s from lvalue subroutine, Can't +weaken a nonreference, Character class [:%s:] unknown, Character class +syntax [%s] belongs inside character classes, Constant is not %s reference, +constant(%s): %s, CORE::%s is not a keyword, defined(@array) is deprecated, +defined(%hash) is deprecated, Did not produce a valid header, (Did you mean +"local" instead of "our"?), Document contains no data, entering effective +%s failed, false [] range "%s" in regexp, Filehandle %s opened only for +output, flock() on closed filehandle %s, Global symbol "%s" requires +explicit package name, Hexadecimal number > 0xffffffff non-portable, +Ill-formed CRTL environ value "%s", Ill-formed message in prime_env_iter: +|%s|, Illegal binary digit %s, Illegal binary digit %s ignored, Illegal +number of bits in vec, Integer overflow in %s number, Invalid %s attribute: +%s, Invalid %s attributes: %s, invalid [] range "%s" in regexp, Invalid +separator character %s in attribute list, Invalid separator character %s in +subroutine attribute list, leaving effective %s failed, Lvalue subs +returning %s not implemented yet, Method %s not permitted, Missing +%sbrace%s on \N{}, Missing command in piped open, Missing name in "my sub", +No %s specified for -%c, No package name allowed for variable %s in "our", +No space allowed after -%c, no UTC offset information; assuming local time +is UTC, Octal number > 037777777777 non-portable, panic: del_backref, +panic: kid popen errno read, panic: magic_killbackrefs, Parentheses missing +around "%s" list, Possible unintended interpolation of %s in string, +Possible Y2K bug: %s, pragma "attrs" is deprecated, use "sub NAME : ATTRS" +instead, Premature end of script headers, Repeat count in pack overflows, +Repeat count in unpack overflows, realloc() of freed memory ignored, +Reference is already weak, setpgrp can't take arguments, Strange *+?{} on +zero-length expression, switching effective %s is not implemented, This +Perl can't reset CRTL environ elements (%s), This Perl can't set CRTL +environ elements (%s=%s), Too late to run %s block, Unknown open() mode +'%s', Unknown process %x sent message to prime_env_iter: %s, Unrecognized +escape \\%c passed through, Unterminated attribute parameter in attribute +list, Unterminated attribute list, Unterminated attribute parameter in +subroutine attribute list, Unterminated subroutine attribute list, Value of +CLI symbol "%s" too long, Version number must be a constant number -=back +=item New tests -=item SEE ALSO +=item Incompatible Changes -=back +=over 4 -=head2 perltie - how to hide an object class in a simple variable +=item Perl Source Incompatibilities -=over +CHECK is a new keyword, Treatment of list slices of undef has changed, +Format of $English::PERL_VERSION is different, Literals of the form +C<1.2.3> parse differently, Possibly changed pseudo-random number +generator, Hashing function for hash keys has changed, C<undef> fails on +read only values, Close-on-exec bit may be set on pipe and socket handles, +Writing C<"$$1"> to mean C<"${$}1"> is unsupported, delete(), each(), +values() and C<\(%h)>, vec(EXPR,OFFSET,BITS) enforces powers-of-two BITS, +Text of some diagnostic output has changed, C<%@> has been removed, +Parenthesized not() behaves like a list operator, Semantics of bareword +prototype C<(*)> have changed, Semantics of bit operators may have changed +on 64-bit platforms, More builtins taint their results -=item SYNOPSIS +=item C Source Incompatibilities -=item DESCRIPTION +C<PERL_POLLUTE>, C<PERL_IMPLICIT_CONTEXT>, C<PERL_POLLUTE_MALLOC> -=over +=item Compatible C Source API Changes -=item Tying Scalars +C<PATCHLEVEL> is now C<PERL_VERSION> -TIESCALAR classname, LIST, FETCH this, STORE this, value, DESTROY this +=item Binary Incompatibilities -=item Tying Arrays +=back -TIEARRAY classname, LIST, FETCH this, index, STORE this, index, value, -DESTROY this +=item Known Problems -=item Tying Hashes +=over 4 -USER, HOME, CLOBBER, LIST, TIEHASH classname, LIST, FETCH this, key, STORE -this, key, value, DELETE this, key, CLEAR this, EXISTS this, key, FIRSTKEY -this, NEXTKEY this, lastkey, DESTROY this +=item Localizing a tied hash element may leak memory -=item Tying FileHandles +=item Known test failures -TIEHANDLE classname, LIST, WRITE this, LIST, PRINT this, LIST, PRINTF this, -LIST, READ this, LIST, READLINE this, GETC this, CLOSE this, DESTROY this +64-bit builds, Failure of Thread tests, NEXTSTEP 3.3 POSIX test failure, +Tru64 (aka Digital UNIX, aka DEC OSF/1) lib/sdbm test failure with gcc -=item The C<untie> Gotcha +=item EBCDIC platforms not fully supported + +=item UNICOS/mk CC failures during Configure run + +=item Arrow operator and arrays + +=item Experimental features + +Threads, Unicode, 64-bit support, Lvalue subroutines, Weak references, The +pseudo-hash data type, The Compiler suite, Internal implementation of file +globbing, The DB module, The regular expression code constructs: =back -=item SEE ALSO +=item Obsolete Diagnostics -=item BUGS +Character class syntax [: :] is reserved for future extensions, Ill-formed +logical name |%s| in prime_env_iter, In string, @%s now must be written as +\@%s, Probable precedence problem on %s, regexp too big, Use of "$$<digit>" +to mean "${$}<digit>" is deprecated -=item AUTHOR +=item Reporting Bugs + +=item SEE ALSO + +=item HISTORY =back -=head2 perlbot - Bag'o Object Tricks (the BOT) +=head2 perl5005delta, perldelta - what's new for perl5.005 -=over +=over 4 =item DESCRIPTION -=item OO SCALING TIPS +=item About the new versioning system -=item INSTANCE VARIABLES +=item Incompatible Changes -=item SCALAR INSTANCE VARIABLES +=over 4 -=item INSTANCE VARIABLE INHERITANCE +=item WARNING: This version is not binary compatible with Perl 5.004. -=item OBJECT RELATIONSHIPS +=item Default installation structure has changed -=item OVERRIDING SUPERCLASS METHODS +=item Perl Source Compatibility -=item USING RELATIONSHIP WITH SDBM +=item C Source Compatibility -=item THINKING OF CODE REUSE +=item Binary Compatibility -=item CLASS CONTEXT AND THE OBJECT +=item Security fixes may affect compatibility -=item INHERITING A CONSTRUCTOR +=item Relaxed new mandatory warnings introduced in 5.004 -=item DELEGATION +=item Licensing =back -=head2 perlipc - Perl interprocess communication (signals, fifos, pipes, -safe subprocesses, sockets, and semaphores) +=item Core Changes -=over +=over 4 -=item DESCRIPTION +=item Threads -=item Signals +=item Compiler -=item Named Pipes +=item Regular Expressions -=over +Many new and improved optimizations, Many bug fixes, New regular expression +constructs, New operator for precompiled regular expressions, Other +improvements, Incompatible changes -=item WARNING +=item Improved malloc() -=back +=item Quicksort is internally implemented -=item Using open() for IPC +=item Reliable signals -=over +=item Reliable stack pointers -=item Filehandles +=item More generous treatment of carriage returns -=item Background Processes +=item Memory leaks -=item Complete Dissociation of Child from Parent +=item Better support for multiple interpreters -=item Safe Pipe Opens +=item Behavior of local() on array and hash elements is now well-defined -=item Bidirectional Communication with Another Process +=item C<%!> is transparently tied to the L<Errno> module -=item Bidirectional Communication with Yourself +=item Pseudo-hashes are supported -=back +=item C<EXPR foreach EXPR> is supported -=item Sockets: Client/Server Communication +=item Keywords can be globally overridden -=over +=item C<$^E> is meaningful on Win32 -=item Internet Line Terminators +=item C<foreach (1..1000000)> optimized -=item Internet TCP Clients and Servers +=item C<Foo::> can be used as implicitly quoted package name -=item Unix-Domain TCP Clients and Servers +=item C<exists $Foo::{Bar::}> tests existence of a package -=back +=item Better locale support -=item TCP Clients with IO::Socket +=item Experimental support for 64-bit platforms -=over +=item prototype() returns useful results on builtins -=item A Simple Client +=item Extended support for exception handling -C<Proto>, C<PeerAddr>, C<PeerPort> +=item Re-blessing in DESTROY() supported for chaining DESTROY() methods -=item A Webget Client +=item All C<printf> format conversions are handled internally -=item Interactive Client with IO::Socket +=item New C<INIT> keyword -=back +=item New C<lock> keyword -=item TCP Servers with IO::Socket +=item New C<qr//> operator -Proto, LocalPort, Listen, Reuse +=item C<our> is now a reserved word -=item UDP: Message Passing +=item Tied arrays are now fully supported -=item SysV IPC +=item Tied handles support is better -=item NOTES +=item 4th argument to substr -=item BUGS +=item Negative LENGTH argument to splice -=item AUTHOR +=item Magic lvalues are now more magical -=item SEE ALSO +=item <> now reads in records =back -=head2 perldbmfilter - Perl DBM Filters +=item Supported Platforms -=over +=over 4 -=item SYNOPSIS +=item New Platforms -=item DESCRIPTION +=item Changes in existing support -B<filter_store_key>, B<filter_store_value>, B<filter_fetch_key>, -B<filter_fetch_value> +=back -=over +=item Modules and Pragmata -=item The Filter +=over 4 -=item An Example -- the NULL termination problem. +=item New Modules -=item Another Example -- Key is a C int. +B, Data::Dumper, Dumpvalue, Errno, File::Spec, ExtUtils::Installed, +ExtUtils::Packlist, Fatal, IPC::SysV, Test, Tie::Array, Tie::Handle, +Thread, attrs, fields, re + +=item Changes in existing modules + +Benchmark, Carp, CGI, Fcntl, Math::Complex, Math::Trig, POSIX, DB_File, +MakeMaker, CPAN, Cwd =back +=item Utility Changes + +=item Documentation Changes + +=item New Diagnostics + +Ambiguous call resolved as CORE::%s(), qualify as such or use &, Bad index +while coercing array into hash, Bareword "%s" refers to nonexistent +package, Can't call method "%s" on an undefined value, Can't check +filesystem of script "%s" for nosuid, Can't coerce array into hash, Can't +goto subroutine from an eval-string, Can't localize pseudo-hash element, +Can't use %%! because Errno.pm is not available, Cannot find an opnumber +for "%s", Character class syntax [. .] is reserved for future extensions, +Character class syntax [: :] is reserved for future extensions, Character +class syntax [= =] is reserved for future extensions, %s: Eval-group in +insecure regular expression, %s: Eval-group not allowed, use re 'eval', %s: +Eval-group not allowed at run time, Explicit blessing to '' (assuming +package main), Illegal hex digit ignored, No such array field, No such +field "%s" in variable %s of type %s, Out of memory during ridiculously +large request, Range iterator outside integer range, Recursive inheritance +detected while looking for method '%s' %s, Reference found where even-sized +list expected, Undefined value assigned to typeglob, Use of reserved word +"%s" is deprecated, perl: warning: Setting locale failed + +=item Obsolete Diagnostics + +Can't mktemp(), Can't write to temp file for B<-e>: %s, Cannot open +temporary file, regexp too big + +=item Configuration Changes + +=item BUGS + =item SEE ALSO -=item AUTHOR +=item HISTORY =back -=head2 perldebug - Perl debugging +=head2 perl5004delta, perldelta - what's new for perl5.004 -=over +=over 4 =item DESCRIPTION -=item The Perl Debugger +=item Supported Environments -=over +=item Core Changes -=item Debugger Commands +=over 4 -h [command], p expr, x expr, V [pkg [vars]], X [vars], T, s [expr], n -[expr], r, <CR>, c [line|sub], l, l min+incr, l min-max, l line, l subname, --, w [line], f filename, /pattern/, ?pattern?, L, S [[!]regex], t, t expr, -b [line] [condition], b subname [condition], b postpone subname -[condition], b load filename, b compile subname, d [line], D, a [line] -command, a [line], A, W expr, W, O booloption .., O anyoption? .., O -option=value .., < ?, < [ command ], << command, > ?, > command, >> -command, { ?, { [ command ], {{ command, ! number, ! -number, ! pattern, !! -cmd, H -number, q or ^D, R, |dbcmd, ||dbcmd, command, m expr, man [manpage] +=item List assignment to %ENV works -=item Configurable Options +=item Change to "Can't locate Foo.pm in @INC" error -C<recallCommand>, C<ShellBang>, C<pager>, C<tkRunning>, C<signalLevel>, -C<warnLevel>, C<dieLevel>, C<AutoTrace>, C<LineInfo>, C<inhibit_exit>, -C<PrintRet>, C<ornaments>, C<frame>, C<maxTraceLen>, C<arrayDepth>, -C<hashDepth>, C<compactDump>, C<veryCompact>, C<globPrint>, C<DumpDBFiles>, -C<DumpPackages>, C<DumpReused>, C<quote>, C<HighBit>, C<undefPrint>, -C<UsageOnly>, C<TTY>, C<noTTY>, C<ReadLine>, C<NonStop> +=item Compilation option: Binary compatibility with 5.003 -=item Debugger input/output +=item $PERL5OPT environment variable -Prompt, Multiline commands, Stack backtrace, Line Listing Format, Frame -listing +=item Limitations on B<-M>, B<-m>, and B<-T> options -=item Debugging compile-time statements +=item More precise warnings -=item Debugger Customization +=item Deprecated: Inherited C<AUTOLOAD> for non-methods -=item Readline Support +=item Previously deprecated %OVERLOAD is no longer usable -=item Editor Support for Debugging +=item Subroutine arguments created only when they're modified -=item The Perl Profiler +=item Group vector changeable with C<$)> -=back +=item Fixed parsing of $$<digit>, &$<digit>, etc. -=item Debugging regular expressions +=item Fixed localization of $<digit>, $&, etc. -=item Debugging memory usage +=item No resetting of $. on implicit close -=item SEE ALSO +=item C<wantarray> may return undef -=item BUGS +=item C<eval EXPR> determines value of EXPR in scalar context -=back +=item Changes to tainting checks -=head2 perlnumber - semantics of numbers and numeric operations in Perl +No glob() or <*>, No spawning if tainted $CDPATH, $ENV, $BASH_ENV, No +spawning if tainted $TERM doesn't look like a terminal name -=over +=item New Opcode module and revised Safe module -=item SYNOPSIS +=item Embedding improvements -=item DESCRIPTION +=item Internal change: FileHandle class based on IO::* classes -=item Storing numbers +=item Internal change: PerlIO abstraction interface -=item Numeric operators and numeric conversions +=item New and changed syntax -=item Flavors of Perl numeric operations +$coderef->(PARAMS) -Arithmetic operators except, C<no integer>, Arithmetic operators except, -C<use integer>, Bitwise operators, C<no integer>, Bitwise operators, C<use -integer>, Operators which expect an integer, Operators which expect a -string +=item New and changed builtin constants -=item AUTHOR +__PACKAGE__ -=item SEE ALSO +=item New and changed builtin variables -=back +$^E, $^H, $^M -=head2 perldebguts - Guts of Perl debugging +=item New and changed builtin functions -=over +delete on slices, flock, printf and sprintf, keys as an lvalue, my() in +Control Structures, pack() and unpack(), sysseek(), use VERSION, use Module +VERSION LIST, prototype(FUNCTION), srand, $_ as Default, C<m//gc> does not +reset search position on failure, C<m//x> ignores whitespace before ?*+{}, +nested C<sub{}> closures work now, formats work right on changing lexicals -=item DESCRIPTION +=item New builtin methods -=item Debugger Internals +isa(CLASS), can(METHOD), VERSION( [NEED] ) -=over +=item TIEHANDLE now supported -=item Writing Your Own Debugger +TIEHANDLE classname, LIST, PRINT this, LIST, PRINTF this, LIST, READ this +LIST, READLINE this, GETC this, DESTROY this -=back +=item Malloc enhancements -=item Frame Listing Output Examples +-DPERL_EMERGENCY_SBRK, -DPACK_MALLOC, -DTWO_POT_OPTIMIZE -=item Debugging regular expressions +=item Miscellaneous efficiency enhancements -=over +=back -=item Compile-time output +=item Support for More Operating Systems -C<anchored> I<STRING> C<at> I<POS>, C<floating> I<STRING> C<at> -I<POS1..POS2>, C<matching floating/anchored>, C<minlen>, C<stclass> -I<TYPE>, C<noscan>, C<isall>, C<GPOS>, C<plus>, C<implicit>, C<with eval>, -C<anchored(TYPE)> +=over 4 -=item Types of nodes +=item Win32 -=item Run-time output +=item Plan 9 + +=item QNX + +=item AmigaOS =back -=item Debugging Perl memory usage +=item Pragmata -=over +use autouse MODULE => qw(sub1 sub2 sub3), use blib, use blib 'dir', use +constant NAME => VALUE, use locale, use ops, use vmsish -=item Using C<$ENV{PERL_DEBUG_MSTATS}> +=item Modules -C<buckets SMALLEST(APPROX)..GREATEST(APPROX)>, Free/Used, C<Total sbrk(): -SBRKed/SBRKs:CONTINUOUS>, C<pad: 0>, C<heads: 2192>, C<chain: 0>, C<tail: -6144> +=over 4 -=item Example of using B<-DL> switch +=item Required Updates -C<717>, C<002>, C<054>, C<602>, C<702>, C<704> +=item Installation directories -=item B<-DL> details +=item Module information summary -C<!!!>, C<!!>, C<!> +=item Fcntl -=item Limitations of B<-DL> statistics +=item IO -=back +=item Math::Complex -=item SEE ALSO +=item Math::Trig + +=item DB_File + +=item Net::Ping + +=item Object-oriented overrides for builtin operators =back -=head2 perldiag - various Perl diagnostics +=item Utility Changes -=over +=over 4 -=item DESCRIPTION +=item pod2html -=back +Sends converted HTML to standard output -=head2 perlsec - Perl security +=item xsubpp -=over +C<void> XSUBs now default to returning nothing -=item DESCRIPTION +=back -=over +=item C Language API Changes -=item Laundering and Detecting Tainted Data +C<gv_fetchmethod> and C<perl_call_sv>, C<perl_eval_pv>, Extended API for +manipulating hashes -=item Switches On the "#!" Line +=item Documentation Changes -=item Cleaning Up Your Path +L<perldelta>, L<perlfaq>, L<perllocale>, L<perltoot>, L<perlapio>, +L<perlmodlib>, L<perldebug>, L<perlsec> -=item Security Bugs +=item New Diagnostics -=item Protecting Your Programs +"my" variable %s masks earlier declaration in same scope, %s argument is +not a HASH element or slice, Allocation too large: %lx, Allocation too +large, Applying %s to %s will act on scalar(%s), Attempt to free +nonexistent shared string, Attempt to use reference as lvalue in substr, +Bareword "%s" refers to nonexistent package, Can't redefine active sort +subroutine %s, Can't use bareword ("%s") as %s ref while "strict refs" in +use, Cannot resolve method `%s' overloading `%s' in package `%s', Constant +subroutine %s redefined, Constant subroutine %s undefined, Copy method did +not return a reference, Died, Exiting pseudo-block via %s, Identifier too +long, Illegal character %s (carriage return), Illegal switch in PERL5OPT: +%s, Integer overflow in hex number, Integer overflow in octal number, +internal error: glob failed, Invalid conversion in %s: "%s", Invalid type +in pack: '%s', Invalid type in unpack: '%s', Name "%s::%s" used only once: +possible typo, Null picture in formline, Offset outside string, Out of +memory!, Out of memory during request for %s, panic: frexp, Possible +attempt to put comments in qw() list, Possible attempt to separate words +with commas, Scalar value @%s{%s} better written as $%s{%s}, Stub found +while resolving method `%s' overloading `%s' in %s, Too late for "B<-T>" +option, untie attempted while %d inner references still exist, Unrecognized +character %s, Unsupported function fork, Use of "$$<digit>" to mean +"${$}<digit>" is deprecated, Value of %s can be "0"; test with defined(), +Variable "%s" may be unavailable, Variable "%s" will not stay shared, +Warning: something's wrong, Ill-formed logical name |%s| in prime_env_iter, +Got an error from DosAllocMem, Malformed PERLLIB_PREFIX, PERL_SH_DIR too +long, Process terminated by SIG%s -=back +=item BUGS =item SEE ALSO +=item HISTORY + =back -=head2 perltrap - Perl traps for the unwary +=head2 perlaix, README.aix - Perl version 5 on IBM Unix (AIX) systems -=over +=over 4 =item DESCRIPTION -=over +=over 4 -=item Awk Traps +=item Compiling Perl 5 on AIX -=item C Traps +=item OS level -=item Sed Traps +=item Building Dynamic Extensions on AIX -=item Shell Traps +=item The IBM ANSI C Compiler -=item Perl Traps +=item Using GNU's gcc for building perl -=item Perl4 to Perl5 Traps +=item Using Large Files with Perl -Discontinuance, Deprecation, and BugFix traps, Parsing Traps, Numerical -Traps, General data type traps, Context Traps - scalar, list contexts, -Precedence Traps, General Regular Expression Traps using s///, etc, -Subroutine, Signal, Sorting Traps, OS Traps, DBM Traps, Unclassified Traps +=item Threaded Perl -=item Discontinuance, Deprecation, and BugFix traps +=item 64-bit Perl -Discontinuance, Deprecation, BugFix, Discontinuance, Discontinuance, -Discontinuance, BugFix, Discontinuance, Discontinuance, BugFix, -Discontinuance, Deprecation, Discontinuance +=item GDBM and Threads -=item Parsing Traps +=item NFS filesystems and utime(2) -Parsing, Parsing, Parsing, Parsing +=back -=item Numerical Traps +=item AUTHOR -Numerical, Numerical, Numerical, Bitwise string ops +=item DATE -=item General data type traps +=back -(Arrays), (Arrays), (Hashes), (Globs), (Globs), (Scalar String), -(Constants), (Scalars), (Variable Suicide) +=head2 perlamiga - Perl under Amiga OS -=item Context Traps - scalar, list contexts +=over 4 -(list context), (scalar context), (scalar context), (list, builtin) +=item SYNOPSIS -=item Precedence Traps +=back -Precedence, Precedence, Precedence, Precedence, Precedence, Precedence, -Precedence +=over 4 -=item General Regular Expression Traps using s///, etc. +=item DESCRIPTION -Regular Expression, Regular Expression, Regular Expression, Regular -Expression, Regular Expression, Regular Expression, Regular Expression, -Regular Expression +=over 4 -=item Subroutine, Signal, Sorting Traps +=item Prerequisites -(Signals), (Sort Subroutine), warn() won't let you specify a filehandle +B<Unix emulation for AmigaOS: ixemul.library>, B<Version of Amiga OS> -=item OS Traps +=item Starting Perl programs under AmigaOS -(SysV), (SysV) +=item Shortcomings of Perl under AmigaOS -=item Interpolation Traps +=back -Interpolation, Interpolation, Interpolation, Interpolation, Interpolation, -Interpolation, Interpolation, Interpolation, Interpolation +=item INSTALLATION -=item DBM Traps +=item Accessing documentation -DBM, DBM +=over 4 -=item Unclassified Traps +=item Manpages -C<require>/C<do> trap using returned value, C<split> on empty string with -LIMIT specified +=item B<HTML> + +=item B<GNU> C<info> files + +=item C<LaTeX> docs =back +=item BUILD + +=over 4 + +=item Prerequisites + +=item Getting the perl source + +=item Making + +sh Configure -Dprefix=/ade -Dloclibpth=/ade/lib + +=item Testing + +=item Installing the built perl + =back -=head2 perlport - Writing portable Perl +=item AUTHORS -=over +=item SEE ALSO + +=back + +=head2 perlbs2000, README.BS2000 - building and installing Perl for BS2000. + +=over 4 + +=item SYNOPSIS =item DESCRIPTION -Not all Perl programs have to be portable, Nearly all of Perl already I<is> -portable +=over 4 -=item ISSUES +=item gzip -=over +=item bison -=item Newlines +=item Unpacking -=item Numbers endianness and Width +=item Compiling -=item Files and Filesystems +=item Testing -=item System Interaction +=item Install -=item Interprocess Communication (IPC) +=item Using Perl in the Posix-Shell -=item External Subroutines (XS) +=item Using Perl in "native" BS2000 -=item Standard Modules +=item Floating point anomalies -=item Time and Date +=back -=item Character sets and character encoding +=item AUTHORS -=item Internationalisation +=item SEE ALSO -=item System Resources +=over 4 -=item Security +=item Mailing list -=item Style +=back + +=item HISTORY =back -=item CPAN Testers +=head2 perlcygwin, README.cygwin - Perl for Cygwin -Mailing list: cpan-testers@perl.org, Testing results: -http://testers.cpan.org/ +=over 4 -=item PLATFORMS +=item SYNOPSIS -=over +=item PREREQUISITES -=item Unix +=over 4 -=item DOS and Derivatives +=item Cygwin = GNU+Cygnus+Windows (Don't leave UNIX without it) -Build instructions for OS/2, L<perlos2> +=item Cygwin Configuration -=item S<Mac OS> +C<PATH>, I<nroff>, Permissions -=item VMS +=back -=item VOS +=item CONFIGURE -=item EBCDIC Platforms +=over 4 -=item Acorn RISC OS +=item Strip Binaries -=item Other perls +=item Optional Libraries + +C<-lcrypt>, C<-lgdbm> (C<use GDBM_File>), C<-ldb> (C<use DB_File>), +C<-lcygipc> (C<use IPC::SysV>) + +=item Configure-time Options + +C<-Uusedl>, C<-Uusemymalloc>, C<-Dusemultiplicity>, C<-Duseperlio>, +C<-Duse64bitint>, C<-Duselongdouble>, C<-Dusethreads>, C<-Duselargefiles> + +=item Suspicious Warnings + +I<dlsym()>, Win9x and C<d_eofnblk>, Compiler/Preprocessor defines =back -=item FUNCTION IMPLEMENTATIONS +=item MAKE -=over +=over 4 -=item Alphabetical Listing of Perl Functions +=item Warnings --I<X> FILEHANDLE, -I<X> EXPR, -I<X>, alarm SECONDS, alarm, binmode -FILEHANDLE, chmod LIST, chown LIST, chroot FILENAME, chroot, crypt -PLAINTEXT,SALT, dbmclose HASH, dbmopen HASH,DBNAME,MODE, dump LABEL, exec -LIST, fcntl FILEHANDLE,FUNCTION,SCALAR, flock FILEHANDLE,OPERATION, fork, -getlogin, getpgrp PID, getppid, getpriority WHICH,WHO, getpwnam NAME, -getgrnam NAME, getnetbyname NAME, getpwuid UID, getgrgid GID, getnetbyaddr -ADDR,ADDRTYPE, getprotobynumber NUMBER, getservbyport PORT,PROTO, getpwent, -getgrent, gethostent, getnetent, getprotoent, getservent, setpwent, -setgrent, sethostent STAYOPEN, setnetent STAYOPEN, setprotoent STAYOPEN, -setservent STAYOPEN, endpwent, endgrent, endhostent, endnetent, -endprotoent, endservent, getsockopt SOCKET,LEVEL,OPTNAME, glob EXPR, glob, -ioctl FILEHANDLE,FUNCTION,SCALAR, kill SIGNAL, LIST, link OLDFILE,NEWFILE, -lstat FILEHANDLE, lstat EXPR, lstat, msgctl ID,CMD,ARG, msgget KEY,FLAGS, -msgsnd ID,MSG,FLAGS, msgrcv ID,VAR,SIZE,TYPE,FLAGS, open FILEHANDLE,EXPR, -open FILEHANDLE, pipe READHANDLE,WRITEHANDLE, readlink EXPR, readlink, -select RBITS,WBITS,EBITS,TIMEOUT, semctl ID,SEMNUM,CMD,ARG, semget -KEY,NSEMS,FLAGS, semop KEY,OPSTRING, setgrent, setpgrp PID,PGRP, -setpriority WHICH,WHO,PRIORITY, setpwent, setsockopt -SOCKET,LEVEL,OPTNAME,OPTVAL, shmctl ID,CMD,ARG, shmget KEY,SIZE,FLAGS, -shmread ID,VAR,POS,SIZE, shmwrite ID,STRING,POS,SIZE, socketpair -SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL, stat FILEHANDLE, stat EXPR, stat, -symlink OLDFILE,NEWFILE, syscall LIST, sysopen -FILEHANDLE,FILENAME,MODE,PERMS, system LIST, times, truncate -FILEHANDLE,LENGTH, truncate EXPR,LENGTH, umask EXPR, umask, utime LIST, -wait, waitpid PID,FLAGS +=item ld2 =back -=item CHANGES +=item TEST -v1.47, 22 March 2000, v1.46, 12 February 2000, v1.45, 20 December 1999, -v1.44, 19 July 1999, v1.43, 24 May 1999, v1.42, 22 May 1999, v1.41, 19 May -1999, v1.40, 11 April 1999, v1.39, 11 February 1999, v1.38, 31 December -1998, v1.37, 19 December 1998, v1.36, 9 September 1998, v1.35, 13 August -1998, v1.33, 06 August 1998, v1.32, 05 August 1998, v1.30, 03 August 1998, -v1.23, 10 July 1998 +=over 4 -=item Supported Platforms +=item File Permissions -=item SEE ALSO +=item Hard Links -=item AUTHORS / CONTRIBUTORS +=item Filetime Granularity -=item VERSION +=item Tainting Checks + +=item /etc/group + +=item Script Portability + +Pathnames, Text/Binary, F<.exe>, chown(), Miscellaneous =back -=head2 perlstyle - Perl style guide +=item INSTALL -=over +=item MANIFEST -=item DESCRIPTION +Documentation, Build, Configure, Make, Install, Tests, Compiled Perl +Source, Compiled Module Source, Perl Modules/Scripts + +=item BUGS + +=item AUTHORS + +=item HISTORY =back -=head2 perlpod - plain old documentation +=head2 perldos - Perl under DOS, W31, W95. + +=over 4 -=over +=item SYNOPSIS =item DESCRIPTION -=over +=over 4 -=item Verbatim Paragraph +=item Prerequisites -=item Command Paragraph +DJGPP, Pthreads -=item Ordinary Block of Text +=item Shortcomings of Perl under DOS -=item The Intent +=item Building -=item Embedding Pods in Perl Modules +=item Testing -=item Common Pod Pitfalls +=item Installation =back -=item SEE ALSO +=item BUILDING AND INSTALLING MODULES + +=over 4 + +=item Prerequisites + +=item Unpacking CPAN Modules + +=item Building Non-XS Modules + +=item Building XS Modules + +=back =item AUTHOR +=item SEE ALSO + =back -=head2 perlbook - Perl book information +=head2 perlepoc, README.epoc - Perl for EPOC -=over +=over 4 -=item DESCRIPTION +=item SYNOPSIS + +=item INTRODUCTION + +=item INSTALLING PERL ON EPOC + +=item STARTING PERL ON EPOC + +=item STOPPING PERL ON EPOC + +=item USING PERL ON EPOC + +=over 4 + +=item I/O Redirection + +=item PATH Names + +=item Editors + +=item Features + +=item Restrictions + +=item Compiling Perl 5 on the EPOC cross compiling environment =back -=head2 perlembed - how to embed perl in your C program +=item SUPPORT STATUS -=over +=item AUTHOR + +=item LAST UPDATE + +=back + +=head2 perlhpux, README.hpux - Perl version 5 on Hewlett-Packard Unix +(HP-UX) systems + +=over 4 =item DESCRIPTION -=over +=over 4 -=item PREAMBLE +=item Compiling Perl 5 on HP-UX -B<Use C from Perl?>, B<Use a Unix program from Perl?>, B<Use Perl from -Perl?>, B<Use C from C?>, B<Use Perl from C?> +=item PA-RISC -=item ROADMAP +=item PA-RISC 1.0 -=item Compiling your C program +=item PA-RISC 1.1 -=item Adding a Perl interpreter to your C program +=item PA-RISC 2.0 -=item Calling a Perl subroutine from your C program +=item Portability Between PA-RISC Versions -=item Evaluating a Perl statement from your C program +=item Building Dynamic Extensions on HP-UX -=item Performing Perl pattern matches and substitutions from your C program +=item The HP ANSI C Compiler -=item Fiddling with the Perl stack from your C program +=item Using Large Files with Perl -=item Maintaining a persistent interpreter +=item Threaded Perl -=item Maintaining multiple interpreter instances +=item 64-bit Perl -=item Using Perl modules, which themselves use C libraries, from your C -program +=item GDBM and Threads -=back +=item NFS filesystems and utime(2) -=item Embedding Perl under Win32 +=item perl -P and // -=item MORAL +=back =item AUTHOR -=item COPYRIGHT +=item DATE =back -=head2 perlapio - perl's IO abstraction interface. - -=over +=head2 perlmachten, README.machten - Perl version 5 on Power MachTen +systems -=item SYNOPSIS +=over 4 =item DESCRIPTION -B<PerlIO *>, B<PerlIO_stdin()>, B<PerlIO_stdout()>, B<PerlIO_stderr()>, -B<PerlIO_open(path, mode)>, B<PerlIO_fdopen(fd,mode)>, -B<PerlIO_printf(f,fmt,...)>, B<PerlIO_vprintf(f,fmt,a)>, -B<PerlIO_stdoutf(fmt,...)>, B<PerlIO_read(f,buf,count)>, -B<PerlIO_write(f,buf,count)>, B<PerlIO_close(f)>, B<PerlIO_puts(f,s)>, -B<PerlIO_putc(f,c)>, B<PerlIO_ungetc(f,c)>, B<PerlIO_getc(f)>, -B<PerlIO_eof(f)>, B<PerlIO_error(f)>, B<PerlIO_fileno(f)>, -B<PerlIO_clearerr(f)>, B<PerlIO_flush(f)>, B<PerlIO_tell(f)>, -B<PerlIO_seek(f,o,w)>, B<PerlIO_getpos(f,p)>, B<PerlIO_setpos(f,p)>, -B<PerlIO_rewind(f)>, B<PerlIO_tmpfile()> +=over 4 -=over +=item Compiling Perl 5 on MachTen -=item Co-existence with stdio +=item Failures during C<make test> -B<PerlIO_importFILE(f,flags)>, B<PerlIO_exportFILE(f,flags)>, -B<PerlIO_findFILE(f)>, B<PerlIO_releaseFILE(p,f)>, B<PerlIO_setlinebuf(f)>, -B<PerlIO_has_cntptr(f)>, B<PerlIO_get_ptr(f)>, B<PerlIO_get_cnt(f)>, -B<PerlIO_canset_cnt(f)>, B<PerlIO_fast_gets(f)>, -B<PerlIO_set_ptrcnt(f,p,c)>, B<PerlIO_set_cnt(f,c)>, B<PerlIO_has_base(f)>, -B<PerlIO_get_base(f)>, B<PerlIO_get_bufsiz(f)> +op/lexassign.t, pragma/warnings.t + +=item Building external modules =back +=item AUTHOR + +=item DATE + =back -=head2 perlxs - XS language reference manual +=head2 perlmacos, README.macos - Perl under Mac OS (Classic) + +=over 4 -=over +=item SYNOPSIS =item DESCRIPTION -=over +=item AUTHOR -=item Introduction +=item DATE -=item On The Road +=back -=item The Anatomy of an XSUB +=head2 perlmpeix, README.mpeix - Perl/iX for HP e3000 MPE -=item The Argument Stack +=head1 SYNOPSIS -=item The RETVAL Variable +=over 4 -=item The MODULE Keyword +=item What's New -=item The PACKAGE Keyword +=item System Requirements -=item The PREFIX Keyword +=item How to Obtain Perl/iX -=item The OUTPUT: Keyword +=item Distribution Contents Highlights -=item The CODE: Keyword +README, public_html/feedback.cgi, 4, 6 -=item The INIT: Keyword +=item Getting Started with Perl/iX -=item The NO_INIT Keyword +=item MPE/iX Implementation Considerations -=item Initializing Function Parameters +=item Change History -=item Default Parameter Values +=back -=item The PREINIT: Keyword +=head2 perlos2 - Perl under OS/2, DOS, Win0.3*, Win0.95 and WinNT. -=item The SCOPE: Keyword +=over 4 -=item The INPUT: Keyword +=item SYNOPSIS -=item Variable-length Parameter Lists +=back -=item The C_ARGS: Keyword +=over 4 -=item The PPCODE: Keyword +=item DESCRIPTION -=item Returning Undef And Empty Lists +=over 4 -=item The REQUIRE: Keyword +=item Target -=item The CLEANUP: Keyword +=item Other OSes -=item The BOOT: Keyword +=item Prerequisites -=item The VERSIONCHECK: Keyword +EMX, RSX, HPFS, pdksh -=item The PROTOTYPES: Keyword +=item Starting Perl programs under OS/2 (and DOS and...) -=item The PROTOTYPE: Keyword +=item Starting OS/2 (and DOS) programs under Perl -=item The ALIAS: Keyword +=back -=item The INTERFACE: Keyword +=item Frequently asked questions -=item The INTERFACE_MACRO: Keyword +=over 4 -=item The INCLUDE: Keyword +=item "It does not work" -=item The CASE: Keyword +=item I cannot run external programs -=item The & Unary Operator +=item I cannot embed perl into my program, or use F<perl.dll> from my +program. -=item Inserting Comments and C Preprocessor Directives +Is your program EMX-compiled with C<-Zmt -Zcrtdll>?, Did you use +L<ExtUtils::Embed>? -=item Using XS With C++ +=item C<``> and pipe-C<open> do not work under DOS. -=item Interface Strategy +=item Cannot start C<find.exe "pattern" file> -=item Perl Objects And C Structures +=back -=item The Typemap +=item INSTALLATION -=back +=over 4 -=item EXAMPLES +=item Automatic binary installation -=item XS VERSION +C<PERL_BADLANG>, C<PERL_BADFREE>, F<Config.pm> -=item AUTHOR +=item Manual binary installation + +Perl VIO and PM executables (dynamically linked), Perl_ VIO executable +(statically linked), Executables for Perl utilities, Main Perl library, +Additional Perl modules, Tools to compile Perl modules, Manpages for Perl +and utilities, Manpages for Perl modules, Source for Perl documentation, +Perl manual in F<.INF> format, Pdksh + +=item B<Warning> =back -=head2 perlxstut, perlXStut - Tutorial for writing XSUBs +=item Accessing documentation -=over +=over 4 -=item DESCRIPTION +=item OS/2 F<.INF> file -=item SPECIAL NOTES +=item Plain text -=over +=item Manpages -=item make +=item HTML -=item Version caveat +=item GNU C<info> files -=item Dynamic Loading versus Static Loading +=item F<.PDF> files + +=item C<LaTeX> docs =back -=item TUTORIAL +=item BUILD -=over +=over 4 -=item EXAMPLE 1 +=item The short story -=item EXAMPLE 2 +=item Prerequisites -=item What has gone on? +=item Getting perl source -=item Writing good test scripts +=item Application of the patches -=item EXAMPLE 3 +=item Hand-editing -=item What's new here? +=item Making -=item Input and Output Parameters +=item Testing -=item The XSUBPP Program +A lot of C<bad free>, Process terminated by SIGTERM/SIGINT, F<op/fs.t>, +F<op/stat.t> -=item The TYPEMAP file +=item Installing the built perl -=item Warning about Output Arguments +=item C<a.out>-style build -=item EXAMPLE 4 +=back -=item What has happened here? +=item Build FAQ -=item Anatomy of .xs file +=over 4 -=item Getting the fat out of XSUBs +=item Some C</> became C<\> in pdksh. -=item More about XSUB arguments +=item C<'errno'> - unresolved external -=item The Argument Stack +=item Problems with tr or sed -=item Extending your Extension +=item Some problem (forget which ;-) -=item Documenting your Extension +=item Library ... not found -=item Installing your Extension +=item Segfault in make -=item EXAMPLE 5 +=item op/sprintf test failure -=item New Things in this Example +=back -=item EXAMPLE 6 (Coming Soon) +=item Specific (mis)features of OS/2 port -=item EXAMPLE 7 (Coming Soon) +=over 4 -=item EXAMPLE 8 (Coming Soon) +=item C<setpriority>, C<getpriority> -=item EXAMPLE 9 (Coming Soon) +=item C<system()> -=item Troubleshooting these Examples +=item C<extproc> on the first line -=back +=item Additional modules: -=item See also +=item Prebuilt methods: -=item Author +C<File::Copy::syscopy>, C<DynaLoader::mod2fname>, C<Cwd::current_drive()>, + C<Cwd::sys_chdir(name)>, C<Cwd::change_drive(name)>, +C<Cwd::sys_is_absolute(name)>, C<Cwd::sys_is_rooted(name)>, +C<Cwd::sys_is_relative(name)>, C<Cwd::sys_cwd(name)>, +C<Cwd::sys_abspath(name, dir)>, C<Cwd::extLibpath([type])>, +C<Cwd::extLibpath_set( path [, type ] )>, +C<OS2::Error(do_harderror,do_exception)>, C<OS2::Errors2Drive(drive)>, +OS2::SysInfo(), OS2::BootDrive(), C<OS2::MorphPM(serve)>, +C<OS2::UnMorphPM(serve)>, C<OS2::Serve_Messages(force)>, +C<OS2::Process_Messages(force [, cnt])>, C<OS2::_control87(new,mask)>, +OS2::get_control87(), C<OS2::set_control87_em(new=MCW_EM,mask=MCW_EM)> -=over +=item Prebuilt variables: -=item Last Changed +$OS2::emx_rev, $OS2::emx_env, $OS2::os_ver -=back +=item Misfeatures -=back +=item Modifications -=head2 perlguts - Introduction to the Perl API +C<popen>, C<tmpnam>, C<tmpfile>, C<ctermid>, C<stat>, C<mkdir>, C<rmdir>, +C<flock> -=over +=item Identifying DLLs -=item DESCRIPTION +=item Centralized management of resources -=item Variables +C<HAB>, C<HMQ> -=over +=back -=item Datatypes +=item Perl flavors -=item What is an "IV"? +=over 4 -=item Working with SVs +=item F<perl.exe> -=item What's Really Stored in an SV? +=item F<perl_.exe> -=item Working with AVs +=item F<perl__.exe> -=item Working with HVs +=item F<perl___.exe> -=item Hash API Extensions +=item Why strange names? -=item References +=item Why dynamic linking? -=item Blessed References and Class Objects +=item Why chimera build? -=item Creating New Variables +=back -=item Reference Counts and Mortality +=item ENVIRONMENT -=item Stashes and Globs +=over 4 -=item Double-Typed SVs +=item C<PERLLIB_PREFIX> -=item Magic Variables +=item C<PERL_BADLANG> -=item Assigning Magic +=item C<PERL_BADFREE> -=item Magic Virtual Tables +=item C<PERL_SH_DIR> -=item Finding Magic +=item C<USE_PERL_FLOCK> -=item Understanding the Magic of Tied Hashes and Arrays +=item C<TMP> or C<TEMP> -=item Localizing changes +=back -C<SAVEINT(int i)>, C<SAVEIV(IV i)>, C<SAVEI32(I32 i)>, C<SAVELONG(long i)>, -C<SAVESPTR(s)>, C<SAVEPPTR(p)>, C<SAVEFREESV(SV *sv)>, C<SAVEFREEOP(OP -*op)>, C<SAVEFREEPV(p)>, C<SAVECLEARSV(SV *sv)>, C<SAVEDELETE(HV *hv, char -*key, I32 length)>, C<SAVEDESTRUCTOR(DESTRUCTORFUNC_NOCONTEXT_t f, void -*p)>, C<SAVEDESTRUCTOR_X(DESTRUCTORFUNC_t f, void *p)>, C<SAVESTACK_POS()>, -C<SV* save_scalar(GV *gv)>, C<AV* save_ary(GV *gv)>, C<HV* save_hash(GV -*gv)>, C<void save_item(SV *item)>, C<void save_list(SV **sarg, I32 -maxsarg)>, C<SV* save_svref(SV **sptr)>, C<void save_aptr(AV **aptr)>, -C<void save_hptr(HV **hptr)> +=item Evolution -=back +=over 4 -=item Subroutines +=item Priorities -=over +=item DLL name mangling -=item XSUBs and the Argument Stack +=item Threading -=item Calling Perl Routines from within C Programs +=item Calls to external programs -=item Memory Allocation +=item Memory allocation -=item PerlIO +=item Threads -=item Putting a C value on Perl stack +C<COND_WAIT>, F<os2.c> -=item Scratchpads +=back -=item Scratchpads and recursion +=back + +=over 4 + +=item AUTHOR + +=item SEE ALSO =back -=item Compiled code +=head2 perlos390, README.os390 - building and installing Perl for OS/390. -=over +=over 4 -=item Code tree +=item SYNOPSIS -=item Examining the tree +=item DESCRIPTION -=item Compile pass 1: check routines +=over 4 -=item Compile pass 1a: constant folding +=item Unpacking -=item Compile pass 2: context propagation +=item Setup and utilities -=item Compile pass 3: peephole optimization +=item Configure -=back +=item Build, test, install -=item How multiple interpreters and concurrency are supported +=item build anomalies -=over +=item testing anomalies -=item Background and PERL_IMPLICIT_CONTEXT +=item installation anomalies -=item How do I use all this in extensions? +=item Usage Hints -=item Future Plans and PERL_IMPLICIT_SYS +=item Floating point anomalies + +=item Modules and Extensions =back @@ -3676,234 +5887,297 @@ C<void save_hptr(HV **hptr)> =item SEE ALSO +=over 4 + +=item Mailing list + =back -=head2 perlcall - Perl calling conventions from C +=item HISTORY -=over +=back + +=head2 perlsolaris, README.solaris - Perl version 5 on Solaris systems + +=over 4 =item DESCRIPTION -An Error Handler, An Event Driven Program +=over 4 -=item THE CALL_ FUNCTIONS +=item Solaris Version Numbers. -call_sv, call_pv, call_method, call_argv +=back -=item FLAG VALUES +=item RESOURCES -=over +Solaris FAQ, Precompiled Binaries, Solaris Documentation -=item G_VOID +=item SETTING UP -=item G_SCALAR +=over 4 -=item G_ARRAY +=item File Extraction Problems. -=item G_DISCARD +=item Compiler and Related Tools. -=item G_NOARGS +=item Environment -=item G_EVAL +=back -=item G_KEEPERR +=item RUN CONFIGURE. -=item Determining the Context +=over 4 + +=item 64-bit Issues. + +=item Threads. + +=item Malloc Issues. =back -=item KNOWN PROBLEMS +=item MAKE PROBLEMS. -=item EXAMPLES +Dynamic Loading Problems With GNU as and GNU ld, ld.so.1: ./perl: fatal: +relocation error:, dlopen: stub interception failed, #error "No +DATAMODEL_NATIVE specified", sh: ar: not found -=over +=item MAKE TEST -=item No Parameters, Nothing returned +=over 4 -=item Passing Parameters +=item op/stat.t test 4 -=item Returning a Scalar +=back -=item Returning a list of values +=item PREBUILT BINARIES. -=item Returning a list in a scalar context +=item RUNTIME ISSUES. -=item Returning Data from Perl via the parameter list +=over 4 -=item Using G_EVAL +=item Limits on Numbers of Open Files. -=item Using G_KEEPERR +=back -=item Using call_sv +=item SOLARIS-SPECIFIC MODULES. -=item Using call_argv +=item SOLARIS-SPECIFIC PROBLEMS WITH MODULES. -=item Using call_method +=over 4 -=item Using GIMME_V +=item Proc::ProcessTable -=item Using Perl to dispose of temporaries +=item BSD::Resource -=item Strategies for storing Callback Context Information +=item Net::SSLeay -1. Ignore the problem - Allow only 1 callback, 2. Create a sequence of -callbacks - hard wired limit, 3. Use a parameter to map to the Perl -callback +=back -=item Alternate Stack Manipulation +=item AUTHOR -=item Creating and calling an anonymous subroutine in C +=item LAST MODIFIED + +=back + +=head2 perlvmesa, README.vmesa - building and installing Perl for VM/ESA. + +=over 4 + +=item SYNOPSIS + +=item DESCRIPTION + +=over 4 + +=item Unpacking + +=item Setup and utilities + +=item Configure + +Don't turn on the compiler optimization flag "-O". There's a bug in the +compiler (APAR PQ18812) that generates some bad code the optimizer is on, +As VM/ESA doesn't fully support the fork() API programs relying on this +call will not work. I've replaced fork()/exec() with spawn() and the +standalone exec() with spawn(). This has a side effect when opening unnamed +pipes in a shell script: there is no child process generated under + +=item testing anomalies + +=item Usage Hints + +When using perl on VM/ESA 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. =back +=item AUTHORS + =item SEE ALSO -=item AUTHOR +=over 4 -=item DATE +=item Mailing list =back -=head2 perlcompile - Introduction to the Perl Compiler-Translator +=back -=over +=head2 perlvms - VMS-specific documentation for Perl + +=over 4 =item DESCRIPTION -=over +=item Installation -=item Layout +=item Organization of Perl Images -B::Bytecode, B::C, B::CC, B::Lint, B::Deparse, B::Xref +=over 4 + +=item Core Images + +=item Perl Extensions + +=item Installing static extensions + +=item Installing dynamic extensions =back -=item Using The Back Ends +=item File specifications -=over +=over 4 -=item The Cross Referencing Back End +=item Syntax -i, &, s, r +=item Wildcard expansion -=item The Decompiling Back End +=item Pipes -=item The Lint Back End +=back -=item The Simple C Back End +=item PERL5LIB and PERLLIB -=item The Bytecode Back End +=item Command line -=item The Optimized C Back End +=over 4 -B, O, B::Asmdata, B::Assembler, B::Bblock, B::Bytecode, B::C, B::CC, -B::Debug, B::Deparse, B::Disassembler, B::Lint, B::Showlex, B::Stackobj, -B::Stash, B::Terse, B::Xref +=item I/O redirection and backgrounding + +=item Command line switches + +-i, -S, -u =back -=item KNOWN PROBLEMS +=item Perl functions + +File tests, backticks, binmode FILEHANDLE, crypt PLAINTEXT, USER, dump, +exec LIST, fork, getpwent, getpwnam, getpwuid, gmtime, kill, qx//, select +(system call), stat EXPR, system LIST, time, times, unlink LIST, utime +LIST, waitpid PID,FLAGS + +=item Perl variables + +%ENV, CRTL_ENV, CLISYM_[LOCAL], Any other string, $!, $^E, $?, $^S, $| + +=item Standard modules with VMS-specific differences + +=over 4 + +=item SDBM_File + +=back + +=item Revision date =item AUTHOR =back -=head2 perlapi - autogenerated documentation for the perl public API +=head2 perlvos, README.vos - Perl for Stratus VOS -=over +=over 4 -=item DESCRIPTION +=item SYNOPSIS -AvFILL, av_clear, av_extend, av_fetch, av_len, av_make, av_pop, av_push, -av_shift, av_store, av_undef, av_unshift, call_argv, call_method, call_pv, -call_sv, CLASS, Copy, croak, CvSTASH, dMARK, dORIGMARK, dSP, dXSARGS, -dXSI32, ENTER, eval_pv, eval_sv, EXTEND, fbm_compile, fbm_instr, FREETMPS, -get_av, get_cv, get_hv, get_sv, GIMME, GIMME_V, GvSV, gv_fetchmeth, -gv_fetchmethod, gv_fetchmethod_autoload, gv_stashpv, gv_stashsv, G_ARRAY, -G_DISCARD, G_EVAL, G_NOARGS, G_SCALAR, G_VOID, HEf_SVKEY, HeHASH, HeKEY, -HeKLEN, HePV, HeSVKEY, HeSVKEY_force, HeSVKEY_set, HeVAL, HvNAME, hv_clear, -hv_delete, hv_delete_ent, hv_exists, hv_exists_ent, hv_fetch, hv_fetch_ent, -hv_iterinit, hv_iterkey, hv_iterkeysv, hv_iternext, hv_iternextsv, -hv_iterval, hv_magic, hv_store, hv_store_ent, hv_undef, isALNUM, isALPHA, -isDIGIT, isLOWER, isSPACE, isUPPER, items, ix, LEAVE, looks_like_number, -MARK, mg_clear, mg_copy, mg_find, mg_free, mg_get, mg_length, mg_magical, -mg_set, Move, New, newAV, Newc, newCONSTSUB, newHV, newRV_inc, newRV_noinc, -NEWSV, newSViv, newSVnv, newSVpv, newSVpvf, newSVpvn, newSVrv, newSVsv, -newSVuv, newXS, newXSproto, Newz, Nullav, Nullch, Nullcv, Nullhv, Nullsv, -ORIGMARK, perl_alloc, perl_construct, perl_destruct, perl_free, perl_parse, -perl_run, PL_DBsingle, PL_DBsub, PL_DBtrace, PL_dowarn, PL_modglobal, -PL_na, PL_sv_no, PL_sv_undef, PL_sv_yes, POPi, POPl, POPn, POPp, POPs, -PUSHi, PUSHMARK, PUSHn, PUSHp, PUSHs, PUSHu, PUTBACK, Renew, Renewc, -require_pv, RETVAL, Safefree, savepv, savepvn, SAVETMPS, SP, SPAGAIN, ST, -strEQ, strGE, strGT, strLE, strLT, strNE, strnEQ, strnNE, StructCopy, -SvCUR, SvCUR_set, SvEND, SvGETMAGIC, SvGROW, SvIOK, SvIOKp, SvIOK_off, -SvIOK_on, SvIOK_only, SvIV, SvIVX, SvLEN, SvNIOK, SvNIOKp, SvNIOK_off, -SvNOK, SvNOKp, SvNOK_off, SvNOK_on, SvNOK_only, SvNV, SvNVX, SvOK, SvOOK, -SvPOK, SvPOKp, SvPOK_off, SvPOK_on, SvPOK_only, SvPV, SvPVX, SvPV_force, -SvPV_nolen, SvREFCNT, SvREFCNT_dec, SvREFCNT_inc, SvROK, SvROK_off, -SvROK_on, SvRV, SvSETMAGIC, SvSetSV, SvSetSV_nosteal, SvSTASH, SvTAINT, -SvTAINTED, SvTAINTED_off, SvTAINTED_on, SvTRUE, SvTYPE, svtype, SVt_IV, -SVt_NV, SVt_PV, SVt_PVAV, SVt_PVCV, SVt_PVHV, SVt_PVMG, SvUPGRADE, SvUV, -SvUVX, sv_2mortal, sv_bless, sv_catpv, sv_catpvf, sv_catpvf_mg, sv_catpvn, -sv_catpvn_mg, sv_catpv_mg, sv_catsv, sv_catsv_mg, sv_chop, sv_cmp, sv_dec, -sv_derived_from, sv_eq, sv_grow, sv_inc, sv_insert, sv_isa, sv_isobject, -sv_len, sv_magic, sv_mortalcopy, sv_newmortal, sv_setiv, sv_setiv_mg, -sv_setnv, sv_setnv_mg, sv_setpv, sv_setpvf, sv_setpvf_mg, sv_setpviv, -sv_setpviv_mg, sv_setpvn, sv_setpvn_mg, sv_setpv_mg, sv_setref_iv, -sv_setref_nv, sv_setref_pv, sv_setref_pvn, sv_setsv, sv_setsv_mg, sv_setuv, -sv_setuv_mg, sv_unref, sv_upgrade, sv_usepvn, sv_usepvn_mg, sv_vcatpvfn, -sv_vsetpvfn, THIS, toLOWER, toUPPER, warn, XPUSHi, XPUSHn, XPUSHp, XPUSHs, -XPUSHu, XS, XSRETURN, XSRETURN_EMPTY, XSRETURN_IV, XSRETURN_NO, -XSRETURN_NV, XSRETURN_PV, XSRETURN_UNDEF, XSRETURN_YES, XST_mIV, XST_mNO, -XST_mNV, XST_mPV, XST_mUNDEF, XST_mYES, XS_VERSION, XS_VERSION_BOOTCHECK, -Zero +=over 4 -=item AUTHORS +=item Stratus POSIX Support -=item SEE ALSO +=back + +=item INSTALLING PERL IN VOS + +=over 4 + +=item Compiling Perl 5 on VOS + +=item Installing Perl 5 on VOS =back -=head2 perlintern - autogenerated documentation of purely B<internal> - Perl functions +=item USING PERL IN VOS -=over +=over 4 -=item DESCRIPTION +=item Unimplemented Features -=item AUTHORS +=item Restrictions -=item SEE ALSO +=back + +=item SUPPORT STATUS + +=item AUTHOR + +=item LAST UPDATE =back -=head2 perlhist - the Perl history records +=head2 perlwin32 - Perl under Win32 -=over +=over 4 + +=item SYNOPSIS =item DESCRIPTION -=item INTRODUCTION +=over 4 -=item THE KEEPERS OF THE PUMPKIN +=item Setting Up -=over +Make, Command Shell, Borland C++, Microsoft Visual C++, Mingw32 with GCC -=item PUMPKIN? - -=back +=item Building -=item THE RECORDS +=item Testing -=over +=item Installation -=item SELECTED RELEASE SIZES +=item Usage Hints -=item SELECTED PATCH SIZES +Environment Variables, File Globbing, Using perl from the command line, +Building Extensions, Command-line Wildcard Expansion, Win32 Specific +Extensions, Running Perl Scripts, Miscellaneous Things =back -=item THE KEEPERS OF THE RECORDS +=item BUGS AND CAVEATS + +=item AUTHORS + +Gary Ng E<lt>71564.1743@CompuServe.COME<gt>, Gurusamy Sarathy +E<lt>gsar@activestate.comE<gt>, Nick Ing-Simmons +E<lt>nick@ni-s.u-net.comE<gt> + +=item SEE ALSO + +=item HISTORY =back @@ -3911,7 +6185,7 @@ Zero =head2 attrs - set/get attributes of a subroutine (deprecated) -=over +=over 4 =item SYNOPSIS @@ -3923,7 +6197,7 @@ method, locked =head2 re - Perl pragma to alter regular expression behaviour -=over +=over 4 =item SYNOPSIS @@ -3933,13 +6207,13 @@ method, locked =head2 attributes - get/set subroutine or variable attributes -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Built-in Attributes @@ -3959,7 +6233,7 @@ FETCH_I<type>_ATTRIBUTES, MODIFY_I<type>_ATTRIBUTES =item EXPORTS -=over +=over 4 =item Default exports @@ -3977,7 +6251,7 @@ FETCH_I<type>_ATTRIBUTES, MODIFY_I<type>_ATTRIBUTES =head2 attrs - set/get attributes of a subroutine (deprecated) -=over +=over 4 =item SYNOPSIS @@ -3989,7 +6263,7 @@ method, locked =head2 autouse - postpone load of modules until a function is used -=over +=over 4 =item SYNOPSIS @@ -4005,7 +6279,7 @@ method, locked =head2 base - Establish IS-A relationship with base class at compile time -=over +=over 4 =item SYNOPSIS @@ -4019,7 +6293,7 @@ method, locked =head2 blib - Use MakeMaker's uninstalled version of a package -=over +=over 4 =item SYNOPSIS @@ -4034,7 +6308,7 @@ method, locked =head2 bytes - Perl pragma to force byte semantics rather than character semantics -=over +=over 4 =item SYNOPSIS @@ -4047,7 +6321,7 @@ semantics =head2 charnames - define character names for C<\N{named}> string literal escape. -=over +=over 4 =item SYNOPSIS @@ -4061,7 +6335,7 @@ escape. =head2 constant - Perl pragma to declare constants -=over +=over 4 =item SYNOPSIS @@ -4082,13 +6356,13 @@ escape. =head2 diagnostics - Perl compiler pragma to force verbose warning diagnostics -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item The C<diagnostics> Pragma @@ -4108,7 +6382,7 @@ diagnostics =head2 fields - compile-time class fields -=over +=over 4 =item SYNOPSIS @@ -4122,13 +6396,13 @@ new, phash =head2 filetest - Perl pragma to control the filetest permission operators -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item subpragma access @@ -4136,10 +6410,10 @@ new, phash =back -=head2 integer - Perl pragma to compute arithmetic in integer instead of -double +=head2 integer - Perl pragma to use integer arithmetic instead of floating +point -=over +=over 4 =item SYNOPSIS @@ -4149,7 +6423,7 @@ double =head2 less - perl pragma to request less of something from the compiler -=over +=over 4 =item SYNOPSIS @@ -4159,13 +6433,13 @@ double =head2 lib - manipulate @INC at compile time -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Adding directories to @INC @@ -4184,7 +6458,7 @@ double =head2 locale - Perl pragma to use and avoid POSIX locales for built-in operations -=over +=over 4 =item SYNOPSIS @@ -4194,7 +6468,7 @@ operations =head2 open - perl pragma to set default disciplines for input and output -=over +=over 4 =item SYNOPSIS @@ -4208,7 +6482,7 @@ operations =head2 ops - Perl pragma to restrict unsafe operations when compiling -=over +=over 4 =item SYNOPSIS @@ -4220,13 +6494,13 @@ operations =head2 overload - Package for overloading perl operations -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Declaration of overloaded functions @@ -4255,11 +6529,11 @@ is inherited by derived classes =item SPECIAL SYMBOLS FOR C<use overload> -=over +=over 4 =item Last Resort -=item Fallback +=item Fallback C<undef>, TRUE, defined, but FALSE @@ -4294,7 +6568,7 @@ integer, float, binary, q, qr =item Cookbook -=over +=over 4 =item Two-face scalars @@ -4310,13 +6584,16 @@ integer, float, binary, q, qr =item DIAGNOSTICS +Odd number of arguments for overload::constant, `%s' is not an overloadable +type, `%s' is not a code reference + =item BUGS =back =head2 re - Perl pragma to alter regular expression behaviour -=over +=over 4 =item SYNOPSIS @@ -4326,7 +6603,7 @@ integer, float, binary, q, qr =head2 sigtrap - Perl pragma to enable simple signal handling -=over +=over 4 =item SYNOPSIS @@ -4334,7 +6611,7 @@ integer, float, binary, q, qr =item OPTIONS -=over +=over 4 =item SIGNAL HANDLERS @@ -4356,7 +6633,7 @@ B<untrapped>, B<any>, I<signal>, I<number> =head2 strict - Perl pragma to restrict unsafe constructs -=over +=over 4 =item SYNOPSIS @@ -4368,7 +6645,7 @@ C<strict refs>, C<strict vars>, C<strict subs> =head2 subs - Perl pragma to predeclare sub names -=over +=over 4 =item SYNOPSIS @@ -4378,7 +6655,7 @@ C<strict refs>, C<strict vars>, C<strict subs> =head2 utf8 - Perl pragma to enable/disable UTF-8 in source code -=over +=over 4 =item SYNOPSIS @@ -4390,7 +6667,7 @@ C<strict refs>, C<strict vars>, C<strict subs> =head2 vars - Perl pragma to predeclare global variable names (obsolete) -=over +=over 4 =item SYNOPSIS @@ -4400,28 +6677,33 @@ C<strict refs>, C<strict vars>, C<strict subs> =head2 warnings - Perl pragma to control optional warnings -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -use warnings::register, warnings::enabled([$category]), -warnings::warn([$category,] $message) +use warnings::register, warnings::enabled(), warnings::enabled($category), +warnings::enabled($object), warnings::warn($message), +warnings::warn($category, $message), warnings::warn($object, $message), +warnings::warnif($message), warnings::warnif($category, $message), +warnings::warnif($object, $message) =back +=head2 warnings::register - warnings import function + =head1 MODULE DOCUMENTATION =head2 AnyDBM_File - provide framework for multiple DBMs -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item DBM Comparisons @@ -4435,13 +6717,13 @@ warnings::warn([$category,] $message) =head2 AutoLoader - load subroutines only on demand -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Subroutine Stubs @@ -4451,6 +6733,8 @@ warnings::warn([$category,] $message) =item Package Lexicals +=item Not Using AutoLoader + =item B<AutoLoader> vs. B<SelfLoader> =back @@ -4463,7 +6747,7 @@ warnings::warn([$category,] $message) =head2 AutoSplit - split a package for autoloading -=over +=over 4 =item SYNOPSIS @@ -4471,7 +6755,7 @@ warnings::warn([$category,] $message) $keep, $check, $modtime -=over +=over 4 =item Multiple packages @@ -4483,7 +6767,7 @@ $keep, $check, $modtime =head2 B - The Perl Compiler -=over +=over 4 =item SYNOPSIS @@ -4491,7 +6775,7 @@ $keep, $check, $modtime =item OVERVIEW OF CLASSES -=over +=over 4 =item SV-RELATED CLASSES @@ -4501,7 +6785,7 @@ REFCNT, FLAGS =item B::IV METHODS -IV, IVX, needs64bits, packiv +IV, IVX, UVX, int_value, needs64bits, packiv =item B::NV METHODS @@ -4513,7 +6797,7 @@ RV =item B::PV METHODS -PV +PV, PVX =item B::PVMG METHODS @@ -4533,8 +6817,8 @@ USEFUL, PREVIOUS, RARE, TABLE =item B::GV METHODS -is_empty, NAME, STASH, SV, IO, FORM, AV, HV, EGV, CV, CVGEN, LINE, FILE, -FILEGV, GvREFCNT, FLAGS +is_empty, NAME, SAFENAME, STASH, SV, IO, FORM, AV, HV, EGV, CV, CVGEN, +LINE, FILE, FILEGV, GvREFCNT, FLAGS =item B::IO METHODS @@ -4616,7 +6900,7 @@ hash(STR), cast_I32(I), minus_c, cstring(STR), class(OBJ), threadsv_names =head2 B::Asmdata - Autogenerated data about Perl ops, used to generate bytecode -=over +=over 4 =item SYNOPSIS @@ -4628,19 +6912,19 @@ bytecode =head2 B::Assembler - Assemble Perl bytecode -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=item AUTHOR +=item AUTHORS =back =head2 B::Bblock - Walk basic blocks -=over +=over 4 =item SYNOPSIS @@ -4652,7 +6936,7 @@ bytecode =head2 B::Bytecode - Perl compiler's bytecode backend -=over +=over 4 =item SYNOPSIS @@ -4661,20 +6945,21 @@ bytecode =item OPTIONS B<-ofilename>, B<-afilename>, B<-->, B<-f>, B<-fcompress-nullops>, -B<-fomit-sequence-numbers>, B<-fbypass-nullops>, B<-fstrip-syntax-tree>, -B<-On>, B<-D>, B<-Do>, B<-Db>, B<-Da>, B<-DC>, B<-S>, B<-m> +B<-fomit-sequence-numbers>, B<-fbypass-nullops>, B<-On>, B<-D>, B<-Do>, +B<-Db>, B<-Da>, B<-DC>, B<-S>, B<-upackage> Stores package in the +output. =back =item EXAMPLES =item BUGS -=item AUTHOR +=item AUTHORS =back =head2 B::C - Perl compiler's C backend -=over +=over 4 =item SYNOPSIS @@ -4695,7 +6980,7 @@ B<-DC>, B<-DM>, B<-f>, B<-fcog>, B<-fno-cog>, B<-On>, B<-llimit> =head2 B::CC - Perl compiler's optimized C translation backend -=over +=over 4 =item SYNOPSIS @@ -4713,7 +6998,7 @@ B<-ffreetmps-each-bblock>, B<-ffreetmps-each-loop>, B<-fomit-taint>, B<-On> =item DIFFERENCES -=over +=over 4 =item Loops @@ -4729,9 +7014,48 @@ B<-ffreetmps-each-bblock>, B<-ffreetmps-each-loop>, B<-fomit-taint>, B<-On> =back +=head2 B::Concise - Walk Perl syntax tree, printing concise info about ops + +=over 4 + +=item SYNOPSIS + +=item DESCRIPTION + +=item OPTIONS + +B<-basic>, B<-exec>, B<-tree>, B<-compact>, B<-loose>, B<-vt>, B<-ascii>, +B<-main>, B<-base>I<n>, B<-bigendian>, B<-littleendian>, B<-concise>, +B<-terse>, B<-linenoise>, B<-debug>, B<-env> + +=item FORMATTING SPECIFICATIONS + +B<(x(>I<exec_text>B<;>I<basic_text>B<)x)>, B<(*(>I<text>B<)*)>, +B<(*(>I<text1>B<;>I<text2>B<)*)>, B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)>, +B<#>I<var>, B<#>I<var>I<N>, B<~>, B<#addr>, B<#arg>, B<#class>, +B<#classym>, B<#coplabel>, B<#exname>, B<#extarg>, B<#firstaddr>, +B<#flags>, B<#flagval>, B<#hyphenseq>, B<#label>, B<#lastaddr>, B<#name>, +B<#NAME>, B<#next>, B<#nextaddr>, B<#noise>, B<#private>, B<#privval>, +B<#seq>, B<#seqnum>, B<#sibaddr>, B<#svaddr>, B<#svclass>, B<#svval>, +B<#targ>, B<#targarg>, B<#targarglife>, B<#typenum> + +=item ABBREVIATIONS + +=over 4 + +=item OP flags abbreviations + +=item OP class abbreviations + +=back + +=item AUTHOR + +=back + =head2 B::Debug - Walk Perl syntax tree, printing debug info about ops -=over +=over 4 =item SYNOPSIS @@ -4743,7 +7067,7 @@ B<-ffreetmps-each-bblock>, B<-ffreetmps-each-loop>, B<-fomit-taint>, B<-On> =head2 B::Deparse - Perl compiler backend to produce perl code -=over +=over 4 =item SYNOPSIS @@ -4752,11 +7076,11 @@ B<-ffreetmps-each-bblock>, B<-ffreetmps-each-loop>, B<-fomit-taint>, B<-On> =item OPTIONS B<-l>, B<-p>, B<-q>, B<-u>I<PACKAGE>, B<-s>I<LETTERS>, B<C>, B<i>I<NUMBER>, -B<T>, B<v>I<STRING>B<.> +B<T>, B<v>I<STRING>B<.>, B<-x>I<LEVEL> =item USING B::Deparse AS A MODULE -=over +=over 4 =item Synopsis @@ -4776,7 +7100,7 @@ B<T>, B<v>I<STRING>B<.> =head2 B::Disassembler - Disassemble Perl bytecode -=over +=over 4 =item SYNOPSIS @@ -4788,7 +7112,7 @@ B<T>, B<v>I<STRING>B<.> =head2 B::Lint - Perl lint -=over +=over 4 =item SYNOPSIS @@ -4811,7 +7135,7 @@ B<-u Package> =head2 B::O, O - Generic interface to Perl Compiler backends -=over +=over 4 =item SYNOPSIS @@ -4827,7 +7151,7 @@ B<-u Package> =head2 B::Showlex - Show lexical variables used in functions or files -=over +=over 4 =item SYNOPSIS @@ -4839,7 +7163,7 @@ B<-u Package> =head2 B::Stackobj - Helper module for CC backend -=over +=over 4 =item SYNOPSIS @@ -4849,9 +7173,11 @@ B<-u Package> =back +=head2 B::Stash - show what stashes are loaded + =head2 B::Terse - Walk Perl syntax tree, printing terse info about ops -=over +=over 4 =item SYNOPSIS @@ -4863,7 +7189,7 @@ B<-u Package> =head2 B::Xref - Generates cross reference reports for Perl programs -=over +=over 4 =item SYNOPSIS @@ -4881,7 +7207,7 @@ C<-oFILENAME>, C<-r>, C<-D[tO]> =head2 Bblock, B::Bblock - Walk basic blocks -=over +=over 4 =item SYNOPSIS @@ -4893,13 +7219,13 @@ C<-oFILENAME>, C<-r>, C<-D[tO]> =head2 Benchmark - benchmark running times of Perl code -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Methods @@ -4937,7 +7263,7 @@ STYLE ] ), cmpthese ( RESULTSHASHREF ), countit(TIME, CODE), disablecache ( =head2 ByteLoader - load byte compiled perl code -=over +=over 4 =item SYNOPSIS @@ -4951,7 +7277,7 @@ STYLE ] ), cmpthese ( RESULTSHASHREF ), countit(TIME, CODE), disablecache ( =head2 Bytecode, B::Bytecode - Perl compiler's bytecode backend -=over +=over 4 =item SYNOPSIS @@ -4960,20 +7286,21 @@ STYLE ] ), cmpthese ( RESULTSHASHREF ), countit(TIME, CODE), disablecache ( =item OPTIONS B<-ofilename>, B<-afilename>, B<-->, B<-f>, B<-fcompress-nullops>, -B<-fomit-sequence-numbers>, B<-fbypass-nullops>, B<-fstrip-syntax-tree>, -B<-On>, B<-D>, B<-Do>, B<-Db>, B<-Da>, B<-DC>, B<-S>, B<-m> +B<-fomit-sequence-numbers>, B<-fbypass-nullops>, B<-On>, B<-D>, B<-Do>, +B<-Db>, B<-Da>, B<-DC>, B<-S>, B<-upackage> Stores package in the +output. =back =item EXAMPLES =item BUGS -=item AUTHOR +=item AUTHORS =back =head2 CGI - Simple Common Gateway Interface Class -=over +=over 4 =item SYNOPSIS @@ -4981,16 +7308,12 @@ B<-On>, B<-D>, B<-Do>, B<-Db>, B<-Da>, B<-DC>, B<-S>, B<-m> =item DESCRIPTION -=over +=over 4 =item PROGRAMMING STYLE =item CALLING CGI.PM ROUTINES -1. Use another name for the argument, if one is available. Forexample, --value is an alias for -values, 2. Change the capitalization, e.g. -Values, -3. Put quotes around the argument name, e.g. '-values' - =item CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE): =item CREATING A NEW QUERY OBJECT FROM AN INPUT FILE @@ -5026,8 +7349,8 @@ B<:standard>, B<:all> =item PRAGMAS --any, -compile, -nph, -newstyle_urls, -autoload, -no_debug, --private_tempfiles +-any, -compile, -nosticky, -no_xhtml, -nph, -newstyle_urls, -oldstyle_urls, +-autoload, -no_debug, -debug, -private_tempfiles =item SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS @@ -5039,7 +7362,7 @@ a </UL> tag) =item GENERATING DYNAMIC DOCUMENTS -=over +=over 4 =item CREATING A STANDARD HTTP HEADER: @@ -5056,7 +7379,7 @@ B<Parameters:>, 4, 5, 6.. =item OBTAINING THE SCRIPT'S URL B<-absolute>, B<-relative>, B<-full>, B<-path> (B<-path_info>), B<-query> -(B<-query_string>) +(B<-query_string>), B<-base> =item MIXING POST AND URL PARAMETERS @@ -5064,7 +7387,7 @@ B<-absolute>, B<-relative>, B<-full>, B<-path> (B<-path_info>), B<-query> =item CREATING STANDARD HTML ELEMENTS: -=over +=over 4 =item PROVIDING ARGUMENTS TO HTML SHORTCUTS @@ -5074,13 +7397,18 @@ B<-absolute>, B<-relative>, B<-full>, B<-path> (B<-path_info>), B<-query> =item NON-STANDARD HTML SHORTCUTS +=item AUTOESCAPING HTML + +$escaped_string = escapeHTML("unescaped string");, $charset = +charset([$charset]);, $flag = autoEscape([$flag]); + =item PRETTY-PRINTING HTML =back =item CREATING FILL-OUT FORMS: -=over +=over 4 =item CREATING AN ISINDEX TAG @@ -5132,9 +7460,7 @@ B<Parameters:> =item CREATING A CLICKABLE IMAGE BUTTON -B<Parameters:>, 3.The third option (-align, optional) is an alignment type, -and may be -TOP, BOTTOM or MIDDLE +B<Parameters:> =item CREATING A JAVASCRIPT ACTION BUTTON @@ -5155,7 +7481,7 @@ the <FORM> tag =item DEBUGGING -=over +=over 4 =item DUMPING OUT ALL THE NAME/VALUE PAIRS @@ -5164,20 +7490,19 @@ the <FORM> tag =item FETCHING ENVIRONMENT VARIABLES B<Accept()>, B<raw_cookie()>, B<user_agent()>, B<path_info()>, -B<path_translated()>, B<remote_host()>, B<script_name()>Return the script -name as a partial URL, for self-refering -scripts, B<referer()>, B<auth_type ()>, B<server_name ()>, B<virtual_host -()>, B<server_software ()>, B<remote_user ()>, B<user_name ()>, +B<path_translated()>, B<remote_host()>, B<script_name()>, B<referer()>, +B<auth_type ()>, B<server_name ()>, B<virtual_host ()>, B<server_port ()>, +B<server_software ()>, B<remote_user ()>, B<user_name ()>, B<request_method()>, B<content_type()>, B<http()>, B<https()> =item USING NPH SCRIPTS In the B<use> statement, By calling the B<nph()> method:, By using B<-nph> -parameters in the B<header()> and B<redirect()> statements: +parameters =item Server Push -multipart_init(), multipart_start(), multipart_end() +multipart_init(), multipart_start(), multipart_end(), multipart_final() =item Avoiding Denial of Service Attacks @@ -5213,7 +7538,7 @@ MacEachern (dougm@opengroup.org), Robin Houston (robin@oneworld.org), =head2 CGI::Apache - Backward compatibility module for CGI.pm -=over +=over 4 =item SYNOPSIS @@ -5232,7 +7557,7 @@ MacEachern (dougm@opengroup.org), Robin Houston (robin@oneworld.org), =head2 CGI::Carp, B<CGI::Carp> - CGI routines for writing to the HTTPD (or other) error log -=over +=over 4 =item SYNOPSIS @@ -5242,12 +7567,14 @@ other) error log =item MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW -=over +=over 4 =item Changing the default message =back +=item MAKING WARNINGS APPEAR AS HTML COMMENTS + =item CHANGE LOG =item AUTHORS @@ -5258,7 +7585,7 @@ other) error log =head2 CGI::Cookie - Interface to Netscape Cookies -=over +=over 4 =item SYNOPSIS @@ -5268,7 +7595,7 @@ other) error log B<1. expiration date>, B<2. domain>, B<3. path>, B<4. secure flag> -=over +=over 4 =item Creating New Cookies @@ -5292,7 +7619,7 @@ B<name()>, B<value()>, B<domain()>, B<path()>, B<expires()> =head2 CGI::Fast - CGI Interface for Fast CGI -=over +=over 4 =item SYNOPSIS @@ -5318,13 +7645,13 @@ B<name()>, B<value()>, B<domain()>, B<path()>, B<expires()> =head2 CGI::Pretty - module to produce nicely formatted HTML code -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Tags that won't be formatted @@ -5342,7 +7669,7 @@ B<name()>, B<value()>, B<domain()>, B<path()>, B<expires()> =head2 CGI::Push - Simple Interface to Server Push -=over +=over 4 =item SYNOPSIS @@ -5350,9 +7677,9 @@ B<name()>, B<value()>, B<domain()>, B<path()>, B<expires()> =item USING CGI::Push --next_page, -last_page, -type, -delay, -cookie, -target, -expires +-next_page, -last_page, -type, -delay, -cookie, -target, -expires, -nph -=over +=over 4 =item Heterogeneous Pages @@ -5372,7 +7699,7 @@ B<name()>, B<value()>, B<domain()>, B<path()>, B<expires()> =head2 CGI::Switch - Backward compatibility module for defunct CGI::Switch -=over +=over 4 =item SYNOPSIS @@ -5388,21 +7715,35 @@ B<name()>, B<value()>, B<domain()>, B<path()>, B<expires()> =back +=head2 CGI::Util - Internal utilities used by CGI module + +=over 4 + +=item SYNOPSIS + +=item DESCRIPTION + +=item AUTHOR INFORMATION + +=item SEE ALSO + +=back + =head2 CPAN - query, download and build perl modules from CPAN sites -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Interactive Mode Searching for authors, bundles, distribution files and modules, make, test, install, clean modules or distributions, get, readme, look module or -distribution, Signals +distribution, ls author, Signals =item CPAN::Shell @@ -5412,11 +7753,38 @@ distribution, Signals =item The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution -=item ProgrammerE<39>s interface - -expand($type,@things), Programming Examples - -=item Methods in the four Classes +=item Programmer's interface + +expand($type,@things), expandany(@things), Programming Examples + +=item Methods in the other Classes + +CPAN::Author::as_glimpse(), CPAN::Author::as_string(), +CPAN::Author::email(), CPAN::Author::fullname(), CPAN::Author::name(), +CPAN::Bundle::as_glimpse(), CPAN::Bundle::as_string(), +CPAN::Bundle::clean(), CPAN::Bundle::contains(), +CPAN::Bundle::force($method,@args), CPAN::Bundle::get(), +CPAN::Bundle::inst_file(), CPAN::Bundle::inst_version(), +CPAN::Bundle::uptodate(), CPAN::Bundle::install(), CPAN::Bundle::make(), +CPAN::Bundle::readme(), CPAN::Bundle::test(), +CPAN::Distribution::as_glimpse(), CPAN::Distribution::as_string(), +CPAN::Distribution::clean(), CPAN::Distribution::containsmods(), +CPAN::Distribution::cvs_import(), CPAN::Distribution::dir(), +CPAN::Distribution::force($method,@args), CPAN::Distribution::get(), +CPAN::Distribution::install(), CPAN::Distribution::isa_perl(), +CPAN::Distribution::look(), CPAN::Distribution::make(), +CPAN::Distribution::prereq_pm(), CPAN::Distribution::readme(), +CPAN::Distribution::test(), CPAN::Distribution::uptodate(), +CPAN::Index::force_reload(), CPAN::Index::reload(), CPAN::InfoObj::dump(), +CPAN::Module::as_glimpse(), CPAN::Module::as_string(), +CPAN::Module::clean(), CPAN::Module::cpan_file(), +CPAN::Module::cpan_version(), CPAN::Module::cvs_import(), +CPAN::Module::description(), CPAN::Module::force($method,@args), +CPAN::Module::get(), CPAN::Module::inst_file(), +CPAN::Module::inst_version(), CPAN::Module::install(), +CPAN::Module::look(), CPAN::Module::make(), +CPAN::Module::manpage_headline(), CPAN::Module::readme(), +CPAN::Module::test(), CPAN::Module::uptodate(), CPAN::Module::userid() =item Cache Manager @@ -5439,7 +7807,7 @@ E<lt>valueE<gt>>, C<o conf E<lt>list optionE<gt>>, C<o conf E<lt>list optionE<gt> [shift|pop]>, C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>> -=over +=over 4 =item Note on urllist parameter's format @@ -5455,19 +7823,33 @@ optionE<gt> [shift|pop]>, C<o conf E<lt>list optionE<gt> =item WORKING WITH CPAN.pm BEHIND FIREWALLS +=over 4 + +=item Three basic types of firewalls + http firewall, ftp firewall, One way visibility, SOCKS, IP Masquerade +=item Configuring lynx or ncftp for going through a firewall + +=back + +=item FAQ + +1), 2), 3), 4), 5), 6), 7), 8), 9), 10) + =item BUGS =item AUTHOR +=item TRANSLATIONS + =item SEE ALSO =back =head2 CPAN::FirstTime - Utility for CPAN::Config file Initialization -=over +=over 4 =item SYNOPSIS @@ -5478,7 +7860,7 @@ http firewall, ftp firewall, One way visibility, SOCKS, IP Masquerade =head2 CPANox, CPAN::Nox - Wrapper around CPAN.pm without using any XS module -=over +=over 4 =item SYNOPSIS @@ -5490,13 +7872,13 @@ module =head2 Carp, carp - warn of errors (from perspective of caller) -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Forcing a Stack Trace @@ -5508,7 +7890,7 @@ module =head2 Carp::Heavy - Carp guts -=over +=over 4 =item SYNOPIS @@ -5518,16 +7900,18 @@ module =head2 Class::Struct - declare struct-like datatypes as Perl classes -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item The C<struct()> function +=item Class Creation at Compile Time + =item Element Types and Accessor Methods Scalar (C<'$'> or C<'*$'>), Array (C<'@'> or C<'*@'>), Hash (C<'%'> or @@ -5547,7 +7931,7 @@ Example 1, Example 2, Example 3 =head2 Config - access Perl configuration information -=over +=over 4 =item SYNOPSIS @@ -5561,7 +7945,7 @@ myconfig(), config_sh(), config_vars(@names) =item GLOSSARY -=over +=over 4 =item _ @@ -5581,8 +7965,9 @@ C<byacc>, C<byteorder> =item c C<c>, C<castflags>, C<cat>, C<cc>, C<cccdlflags>, C<ccdlflags>, C<ccflags>, -C<ccsymbols>, C<cf_by>, C<cf_email>, C<cf_time>, C<charsize>, C<chgrp>, -C<chmod>, C<chown>, C<clocktype>, C<comm>, C<compress> +C<ccflags_uselargefiles>, C<ccname>, C<ccsymbols>, C<ccversion>, C<cf_by>, +C<cf_email>, C<cf_time>, C<charsize>, C<chgrp>, C<chmod>, C<chown>, +C<clocktype>, C<comm>, C<compress> =item C @@ -5592,63 +7977,68 @@ C<cppstdin>, C<cppsymbols>, C<crosscompile>, C<cryptlib>, C<csh> =item d -C<d_access>, C<d_accessx>, C<d_alarm>, C<d_archlib>, C<d_atolf>, -C<d_atoll>, C<d_attribut>, C<d_bcmp>, C<d_bcopy>, C<d_bincompat5005>, -C<d_bsd>, C<d_bsdgetpgrp>, C<d_bsdsetpgrp>, C<d_bzero>, C<d_casti32>, -C<d_castneg>, C<d_charvspr>, C<d_chown>, C<d_chroot>, C<d_chsize>, -C<d_closedir>, C<d_const>, C<d_crypt>, C<d_csh>, C<d_cuserid>, +C<d__fwalk>, C<d_access>, C<d_accessx>, C<d_alarm>, C<d_archlib>, +C<d_atolf>, C<d_atoll>, C<d_attribut>, C<d_bcmp>, C<d_bcopy>, +C<d_bincompat5005>, C<d_bsd>, C<d_bsdgetpgrp>, C<d_bsdsetpgrp>, C<d_bzero>, +C<d_casti32>, C<d_castneg>, C<d_charvspr>, C<d_chown>, C<d_chroot>, +C<d_chsize>, C<d_closedir>, C<d_const>, C<d_crypt>, C<d_csh>, C<d_cuserid>, C<d_dbl_dig>, C<d_difftime>, C<d_dirnamlen>, C<d_dlerror>, C<d_dlopen>, C<d_dlsymun>, C<d_dosuid>, C<d_drand48proto>, C<d_dup2>, C<d_eaccess>, C<d_endgrent>, C<d_endhent>, C<d_endnent>, C<d_endpent>, C<d_endpwent>, -C<d_endsent>, C<d_endspent>, C<d_eofnblk>, C<d_eunice>, C<d_fchmod>, -C<d_fchown>, C<d_fcntl>, C<d_fd_macros>, C<d_fd_set>, C<d_fds_bits>, -C<d_fgetpos>, C<d_flexfnam>, C<d_flock>, C<d_fork>, C<d_fpathconf>, -C<d_fpos64_t>, C<d_fs_data_s>, C<d_fseeko>, C<d_fsetpos>, C<d_fstatfs>, -C<d_fstatvfs>, C<d_ftello>, C<d_ftime>, C<d_Gconvert>, C<d_getcwd>, -C<d_getfsstat>, C<d_getgrent>, C<d_getgrps>, C<d_gethbyaddr>, -C<d_gethbyname>, C<d_gethent>, C<d_gethname>, C<d_gethostprotos>, -C<d_getlogin>, C<d_getmnt>, C<d_getmntent>, C<d_getnbyaddr>, -C<d_getnbyname>, C<d_getnent>, C<d_getnetprotos>, C<d_getpbyname>, +C<d_endsent>, C<d_eofnblk>, C<d_eunice>, C<d_fchmod>, C<d_fchown>, +C<d_fcntl>, C<d_fcntl_can_lock>, C<d_fd_macros>, C<d_fd_set>, +C<d_fds_bits>, C<d_fgetpos>, C<d_flexfnam>, C<d_flock>, C<d_fork>, +C<d_fpathconf>, C<d_fpos64_t>, C<d_frexpl>, C<d_fs_data_s>, C<d_fseeko>, +C<d_fsetpos>, C<d_fstatfs>, C<d_fstatvfs>, C<d_fsync>, C<d_ftello>, +C<d_ftime>, C<d_Gconvert>, C<d_getcwd>, C<d_getespwnam>, C<d_getfsstat>, +C<d_getgrent>, C<d_getgrps>, C<d_gethbyaddr>, C<d_gethbyname>, +C<d_gethent>, C<d_gethname>, C<d_gethostprotos>, C<d_getlogin>, +C<d_getmnt>, C<d_getmntent>, C<d_getnbyaddr>, C<d_getnbyname>, +C<d_getnent>, C<d_getnetprotos>, C<d_getpagsz>, C<d_getpbyname>, C<d_getpbynumber>, C<d_getpent>, C<d_getpgid>, C<d_getpgrp2>, C<d_getpgrp>, -C<d_getppid>, C<d_getprior>, C<d_getprotoprotos>, C<d_getpwent>, -C<d_getsbyname>, C<d_getsbyport>, C<d_getsent>, C<d_getservprotos>, -C<d_getspent>, C<d_getspnam>, C<d_gettimeod>, C<d_gnulibc>, C<d_grpasswd>, -C<d_hasmntopt>, C<d_htonl>, C<d_iconv>, C<d_index>, C<d_inetaton>, -C<d_int64_t>, C<d_isascii>, C<d_killpg>, C<d_lchown>, C<d_ldbl_dig>, -C<d_link>, C<d_locconv>, C<d_lockf>, C<d_longdbl>, C<d_longlong>, -C<d_lseekproto>, C<d_lstat>, C<d_madvise>, C<d_mblen>, C<d_mbstowcs>, -C<d_mbtowc>, C<d_memchr>, C<d_memcmp>, C<d_memcpy>, C<d_memmove>, -C<d_memset>, C<d_mkdir>, C<d_mkdtemp>, C<d_mkfifo>, C<d_mkstemp>, -C<d_mkstemps>, C<d_mktime>, C<d_mmap>, C<d_mprotect>, C<d_msg>, -C<d_msg_ctrunc>, C<d_msg_dontroute>, C<d_msg_oob>, C<d_msg_peek>, -C<d_msg_proxy>, C<d_msgctl>, C<d_msgget>, C<d_msgrcv>, C<d_msgsnd>, -C<d_msync>, C<d_munmap>, C<d_mymalloc>, C<d_nice>, C<d_nv_preserves_uv>, -C<d_off64_t>, C<d_old_pthread_create_joinable>, C<d_oldpthreads>, -C<d_oldsock>, C<d_open3>, C<d_pathconf>, C<d_pause>, C<d_phostname>, -C<d_pipe>, C<d_poll>, C<d_portable>, C<d_PRId64>, C<d_PRIeldbl>, -C<d_PRIEldbl>, C<d_PRIfldbl>, C<d_PRIFldbl>, C<d_PRIgldbl>, C<d_PRIGldbl>, -C<d_PRIi64>, C<d_PRIo64>, C<d_PRIu64>, C<d_PRIx64>, C<d_PRIX64>, -C<d_pthread_yield>, C<d_pwage>, C<d_pwchange>, C<d_pwclass>, -C<d_pwcomment>, C<d_pwexpire>, C<d_pwgecos>, C<d_pwpasswd>, C<d_pwquota>, -C<d_qgcvt>, C<d_quad>, C<d_readdir>, C<d_readlink>, C<d_rename>, -C<d_rewinddir>, C<d_rmdir>, C<d_safebcpy>, C<d_safemcpy>, C<d_sanemcmp>, -C<d_sched_yield>, C<d_scm_rights>, C<d_seekdir>, C<d_select>, C<d_sem>, +C<d_getppid>, C<d_getprior>, C<d_getprotoprotos>, C<d_getprpwnam>, +C<d_getpwent>, C<d_getsbyname>, C<d_getsbyport>, C<d_getsent>, +C<d_getservprotos>, C<d_getspnam>, C<d_gettimeod>, C<d_gnulibc>, +C<d_grpasswd>, C<d_hasmntopt>, C<d_htonl>, C<d_iconv>, C<d_index>, +C<d_inetaton>, C<d_int64_t>, C<d_isascii>, C<d_isnan>, C<d_isnanl>, +C<d_killpg>, C<d_lchown>, C<d_ldbl_dig>, C<d_link>, C<d_locconv>, +C<d_lockf>, C<d_longdbl>, C<d_longlong>, C<d_lseekproto>, C<d_lstat>, +C<d_madvise>, C<d_mblen>, C<d_mbstowcs>, C<d_mbtowc>, C<d_memchr>, +C<d_memcmp>, C<d_memcpy>, C<d_memmove>, C<d_memset>, C<d_mkdir>, +C<d_mkdtemp>, C<d_mkfifo>, C<d_mkstemp>, C<d_mkstemps>, C<d_mktime>, +C<d_mmap>, C<d_modfl>, C<d_mprotect>, C<d_msg>, C<d_msg_ctrunc>, +C<d_msg_dontroute>, C<d_msg_oob>, C<d_msg_peek>, C<d_msg_proxy>, +C<d_msgctl>, C<d_msgget>, C<d_msgrcv>, C<d_msgsnd>, C<d_msync>, +C<d_munmap>, C<d_mymalloc>, C<d_nice>, C<d_nv_preserves_uv>, +C<d_nv_preserves_uv_bits>, C<d_off64_t>, C<d_old_pthread_create_joinable>, +C<d_oldpthreads>, C<d_oldsock>, C<d_open3>, C<d_pathconf>, C<d_pause>, +C<d_perl_otherlibdirs>, C<d_phostname>, C<d_pipe>, C<d_poll>, +C<d_portable>, C<d_PRId64>, C<d_PRIeldbl>, C<d_PRIEUldbl>, C<d_PRIfldbl>, +C<d_PRIFUldbl>, C<d_PRIgldbl>, C<d_PRIGUldbl>, C<d_PRIi64>, C<d_PRIo64>, +C<d_PRIu64>, C<d_PRIx64>, C<d_PRIXU64>, C<d_pthread_yield>, C<d_pwage>, +C<d_pwchange>, C<d_pwclass>, C<d_pwcomment>, C<d_pwexpire>, C<d_pwgecos>, +C<d_pwpasswd>, C<d_pwquota>, C<d_qgcvt>, C<d_quad>, C<d_readdir>, +C<d_readlink>, C<d_rename>, C<d_rewinddir>, C<d_rmdir>, C<d_safebcpy>, +C<d_safemcpy>, C<d_sanemcmp>, C<d_sbrkproto>, C<d_sched_yield>, +C<d_scm_rights>, C<d_SCNfldbl>, C<d_seekdir>, C<d_select>, C<d_sem>, C<d_semctl>, C<d_semctl_semid_ds>, C<d_semctl_semun>, C<d_semget>, C<d_semop>, C<d_setegid>, C<d_seteuid>, C<d_setgrent>, C<d_setgrps>, C<d_sethent>, C<d_setlinebuf>, C<d_setlocale>, C<d_setnent>, C<d_setpent>, -C<d_setpgid>, C<d_setpgrp2>, C<d_setpgrp>, C<d_setprior>, C<d_setpwent>, -C<d_setregid>, C<d_setresgid>, C<d_setresuid>, C<d_setreuid>, C<d_setrgid>, -C<d_setruid>, C<d_setsent>, C<d_setsid>, C<d_setspent>, C<d_setvbuf>, -C<d_sfio>, C<d_shm>, C<d_shmat>, C<d_shmatprototype>, C<d_shmctl>, -C<d_shmdt>, C<d_shmget>, C<d_sigaction>, C<d_sigsetjmp>, C<d_socket>, -C<d_socklen_t>, C<d_sockpair>, C<d_sqrtl>, C<d_statblks>, +C<d_setpgid>, C<d_setpgrp2>, C<d_setpgrp>, C<d_setprior>, +C<d_setproctitle>, C<d_setpwent>, C<d_setregid>, C<d_setresgid>, +C<d_setresuid>, C<d_setreuid>, C<d_setrgid>, C<d_setruid>, C<d_setsent>, +C<d_setsid>, C<d_setvbuf>, C<d_sfio>, C<d_shm>, C<d_shmat>, +C<d_shmatprototype>, C<d_shmctl>, C<d_shmdt>, C<d_shmget>, C<d_sigaction>, +C<d_sigprocmask>, C<d_sigsetjmp>, C<d_socket>, C<d_socklen_t>, +C<d_sockpair>, C<d_socks5_init>, C<d_sqrtl>, C<d_statblks>, C<d_statfs_f_flags>, C<d_statfs_s>, C<d_statvfs>, C<d_stdio_cnt_lval>, -C<d_stdio_ptr_lval>, C<d_stdio_stream_array>, C<d_stdiobase>, +C<d_stdio_ptr_lval>, C<d_stdio_ptr_lval_nochange_cnt>, +C<d_stdio_ptr_lval_sets_cnt>, C<d_stdio_stream_array>, C<d_stdiobase>, C<d_stdstdio>, C<d_strchr>, C<d_strcoll>, C<d_strctcpy>, C<d_strerrm>, C<d_strerror>, C<d_strtod>, C<d_strtol>, C<d_strtold>, C<d_strtoll>, -C<d_strtoul>, C<d_strtoull>, C<d_strtouq>, C<d_strxfrm>, C<d_suidsafe>, -C<d_symlink>, C<d_syscall>, C<d_sysconf>, C<d_sysernlst>, C<d_syserrlst>, -C<d_system>, C<d_tcgetpgrp>, C<d_tcsetpgrp>, C<d_telldir>, +C<d_strtoq>, C<d_strtoul>, C<d_strtoull>, C<d_strtouq>, C<d_strxfrm>, +C<d_suidsafe>, C<d_symlink>, C<d_syscall>, C<d_sysconf>, C<d_sysernlst>, +C<d_syserrlst>, C<d_system>, C<d_tcgetpgrp>, C<d_tcsetpgrp>, C<d_telldir>, C<d_telldirproto>, C<d_time>, C<d_times>, C<d_truncate>, C<d_tzname>, C<d_umask>, C<d_uname>, C<d_union_semun>, C<d_ustat>, C<d_vendorarch>, C<d_vendorbin>, C<d_vendorlib>, C<d_vfork>, C<d_void_closedir>, @@ -5669,38 +8059,39 @@ C<fpossize>, C<fpostype>, C<freetype>, C<full_ar>, C<full_csh>, C<full_sed> =item g -C<gccversion>, C<gidformat>, C<gidsign>, C<gidsize>, C<gidtype>, -C<glibpth>, C<grep>, C<groupcat>, C<groupstype>, C<gzip> +C<gccosandvers>, C<gccversion>, C<gidformat>, C<gidsign>, C<gidsize>, +C<gidtype>, C<glibpth>, C<grep>, C<groupcat>, C<groupstype>, C<gzip> =item h -C<h_fcntl>, C<h_sysfile>, C<hint>, C<hostcat>, C<huge> +C<h_fcntl>, C<h_sysfile>, C<hint>, C<hostcat> =item i C<i16size>, C<i16type>, C<i32size>, C<i32type>, C<i64size>, C<i64type>, C<i8size>, C<i8type>, C<i_arpainet>, C<i_bsdioctl>, C<i_db>, C<i_dbm>, C<i_dirent>, C<i_dld>, C<i_dlfcn>, C<i_fcntl>, C<i_float>, C<i_gdbm>, -C<i_grp>, C<i_iconv>, C<i_ieeefp>, C<i_inttypes>, C<i_limits>, C<i_locale>, -C<i_machcthr>, C<i_malloc>, C<i_math>, C<i_memory>, C<i_mntent>, C<i_ndbm>, -C<i_netdb>, C<i_neterrno>, C<i_netinettcp>, C<i_niin>, C<i_poll>, -C<i_pthread>, C<i_pwd>, C<i_rpcsvcdbm>, C<i_sfio>, C<i_sgtty>, C<i_shadow>, -C<i_socks>, C<i_stdarg>, C<i_stddef>, C<i_stdlib>, C<i_string>, -C<i_sunmath>, C<i_sysaccess>, C<i_sysdir>, C<i_sysfile>, C<i_sysfilio>, -C<i_sysin>, C<i_sysioctl>, C<i_syslog>, C<i_sysmman>, C<i_sysmode>, -C<i_sysmount>, C<i_sysndir>, C<i_sysparam>, C<i_sysresrc>, C<i_syssecrt>, -C<i_sysselct>, C<i_syssockio>, C<i_sysstat>, C<i_sysstatfs>, -C<i_sysstatvfs>, C<i_systime>, C<i_systimek>, C<i_systimes>, C<i_systypes>, -C<i_sysuio>, C<i_sysun>, C<i_sysutsname>, C<i_sysvfs>, C<i_syswait>, -C<i_termio>, C<i_termios>, C<i_time>, C<i_unistd>, C<i_ustat>, C<i_utime>, -C<i_values>, C<i_varargs>, C<i_varhdr>, C<i_vfork>, -C<ignore_versioned_solibs>, C<inc_version_list>, C<inc_version_list_init>, -C<incpath>, C<inews>, C<installarchlib>, C<installbin>, C<installman1dir>, -C<installman3dir>, C<installprefix>, C<installprefixexp>, -C<installprivlib>, C<installscript>, C<installsitearch>, C<installsitebin>, -C<installsitelib>, C<installstyle>, C<installusrbinperl>, -C<installvendorarch>, C<installvendorbin>, C<installvendorlib>, C<intsize>, -C<ivdformat>, C<ivsize>, C<ivtype> +C<i_grp>, C<i_iconv>, C<i_ieeefp>, C<i_inttypes>, C<i_libutil>, +C<i_limits>, C<i_locale>, C<i_machcthr>, C<i_malloc>, C<i_math>, +C<i_memory>, C<i_mntent>, C<i_ndbm>, C<i_netdb>, C<i_neterrno>, +C<i_netinettcp>, C<i_niin>, C<i_poll>, C<i_prot>, C<i_pthread>, C<i_pwd>, +C<i_rpcsvcdbm>, C<i_sfio>, C<i_sgtty>, C<i_shadow>, C<i_socks>, +C<i_stdarg>, C<i_stddef>, C<i_stdlib>, C<i_string>, C<i_sunmath>, +C<i_sysaccess>, C<i_sysdir>, C<i_sysfile>, C<i_sysfilio>, C<i_sysin>, +C<i_sysioctl>, C<i_syslog>, C<i_sysmman>, C<i_sysmode>, C<i_sysmount>, +C<i_sysndir>, C<i_sysparam>, C<i_sysresrc>, C<i_syssecrt>, C<i_sysselct>, +C<i_syssockio>, C<i_sysstat>, C<i_sysstatfs>, C<i_sysstatvfs>, +C<i_systime>, C<i_systimek>, C<i_systimes>, C<i_systypes>, C<i_sysuio>, +C<i_sysun>, C<i_sysutsname>, C<i_sysvfs>, C<i_syswait>, C<i_termio>, +C<i_termios>, C<i_time>, C<i_unistd>, C<i_ustat>, C<i_utime>, C<i_values>, +C<i_varargs>, C<i_varhdr>, C<i_vfork>, C<ignore_versioned_solibs>, +C<inc_version_list>, C<inc_version_list_init>, C<incpath>, C<inews>, +C<installarchlib>, C<installbin>, C<installman1dir>, C<installman3dir>, +C<installprefix>, C<installprefixexp>, C<installprivlib>, C<installscript>, +C<installsitearch>, C<installsitebin>, C<installsitelib>, C<installstyle>, +C<installusrbinperl>, C<installvendorarch>, C<installvendorbin>, +C<installvendorlib>, C<intsize>, C<issymlink>, C<ivdformat>, C<ivsize>, +C<ivtype> =item k @@ -5708,12 +8099,12 @@ C<known_extensions>, C<ksh> =item l -C<large>, C<ld>, C<lddlflags>, C<ldflags>, C<ldlibpthname>, C<less>, -C<lib_ext>, C<libc>, C<libperl>, C<libpth>, C<libs>, C<libsdirs>, -C<libsfiles>, C<libsfound>, C<libspath>, C<libswanted>, C<line>, C<lint>, -C<lkflags>, C<ln>, C<lns>, C<locincpth>, C<loclibpth>, C<longdblsize>, -C<longlongsize>, C<longsize>, C<lp>, C<lpr>, C<ls>, C<lseeksize>, -C<lseektype> +C<ld>, C<lddlflags>, C<ldflags>, C<ldflags_uselargefiles>, C<ldlibpthname>, +C<less>, C<lib_ext>, C<libc>, C<libperl>, C<libpth>, C<libs>, C<libsdirs>, +C<libsfiles>, C<libsfound>, C<libspath>, C<libswanted>, +C<libswanted_uselargefiles>, C<line>, C<lint>, C<lkflags>, C<ln>, C<lns>, +C<locincpth>, C<loclibpth>, C<longdblsize>, C<longlongsize>, C<longsize>, +C<lp>, C<lpr>, C<ls>, C<lseeksize>, C<lseektype> =item m @@ -5723,20 +8114,20 @@ C<man3direxp>, C<man3ext> =item M -C<Mcc>, C<medium>, C<mips_type>, C<mkdir>, C<mmaptype>, C<models>, -C<modetype>, C<more>, C<multiarch>, C<mv>, C<myarchname>, C<mydomain>, -C<myhostname>, C<myuname> +C<Mcc>, C<mips_type>, C<mkdir>, C<mmaptype>, C<modetype>, C<more>, +C<multiarch>, C<mv>, C<myarchname>, C<mydomain>, C<myhostname>, C<myuname> =item n -C<n>, C<netdb_hlen_type>, C<netdb_host_type>, C<netdb_name_type>, -C<netdb_net_type>, C<nm>, C<nm_opt>, C<nm_so_opt>, C<nonxs_ext>, C<nroff>, -C<nvsize>, C<nvtype> +C<n>, C<need_va_copy>, C<netdb_hlen_type>, C<netdb_host_type>, +C<netdb_name_type>, C<netdb_net_type>, C<nm>, C<nm_opt>, C<nm_so_opt>, +C<nonxs_ext>, C<nroff>, C<nveformat>, C<nvEUformat>, C<nvfformat>, +C<nvFUformat>, C<nvgformat>, C<nvGUformat>, C<nvsize>, C<nvtype> =item o C<o_nonblock>, C<obj_ext>, C<old_pthread_create_joinable>, C<optimize>, -C<orderlib>, C<osname>, C<osvers> +C<orderlib>, C<osname>, C<osvers>, C<otherlibdirs> =item p @@ -5746,9 +8137,9 @@ C<perl> =item P C<PERL_REVISION>, C<PERL_SUBVERSION>, C<PERL_VERSION>, C<perladmin>, -C<perlpath>, C<pg>, C<phostname>, C<pidtype>, C<plibpth>, C<pm_apiversion>, -C<pmake>, C<pr>, C<prefix>, C<prefixexp>, C<privlib>, C<privlibexp>, -C<prototype>, C<ptrsize> +C<perllibs>, C<perlpath>, C<pg>, C<phostname>, C<pidtype>, C<plibpth>, +C<pm_apiversion>, C<pmake>, C<pr>, C<prefix>, C<prefixexp>, C<privlib>, +C<privlibexp>, C<prototype>, C<ptrsize> =item q @@ -5764,14 +8155,14 @@ C<revision>, C<rm>, C<rmail>, C<runnm> C<sched_yield>, C<scriptdir>, C<scriptdirexp>, C<sed>, C<seedfunc>, C<selectminbits>, C<selecttype>, C<sendmail>, C<sh>, C<shar>, C<sharpbang>, C<shmattype>, C<shortsize>, C<shrpenv>, C<shsharp>, C<sig_count>, -C<sig_name>, C<sig_name_init>, C<sig_num>, C<sig_num_init>, C<signal_t>, -C<sitearch>, C<sitearchexp>, C<sitebin>, C<sitebinexp>, C<sitelib>, -C<sitelib_stem>, C<sitelibexp>, C<siteprefix>, C<siteprefixexp>, -C<sizesize>, C<sizetype>, C<sleep>, C<smail>, C<small>, C<so>, +C<sig_name>, C<sig_name_init>, C<sig_num>, C<sig_num_init>, C<sig_size>, +C<signal_t>, C<sitearch>, C<sitearchexp>, C<sitebin>, C<sitebinexp>, +C<sitelib>, C<sitelib_stem>, C<sitelibexp>, C<siteprefix>, +C<siteprefixexp>, C<sizesize>, C<sizetype>, C<sleep>, C<smail>, C<so>, C<sockethdr>, C<socketlib>, C<socksizetype>, C<sort>, C<spackage>, -C<spitshell>, C<split>, C<sPRId64>, C<sPRIeldbl>, C<sPRIEldbl>, -C<sPRIfldbl>, C<sPRIFldbl>, C<sPRIgldbl>, C<sPRIGldbl>, C<sPRIi64>, -C<sPRIo64>, C<sPRIu64>, C<sPRIx64>, C<sPRIX64>, C<src>, C<ssizetype>, +C<spitshell>, C<sPRId64>, C<sPRIeldbl>, C<sPRIEUldbl>, C<sPRIfldbl>, +C<sPRIFUldbl>, C<sPRIgldbl>, C<sPRIGUldbl>, C<sPRIi64>, C<sPRIo64>, +C<sPRIu64>, C<sPRIx64>, C<sPRIXU64>, C<src>, C<sSCNfldbl>, C<ssizetype>, C<startperl>, C<startsh>, C<static_ext>, C<stdchar>, C<stdio_base>, C<stdio_bufsiz>, C<stdio_cnt>, C<stdio_filbuf>, C<stdio_ptr>, C<stdio_stream_array>, C<strings>, C<submit>, C<subversion>, C<sysman> @@ -5791,13 +8182,13 @@ C<uselongdouble>, C<usemorebits>, C<usemultiplicity>, C<usemymalloc>, C<usenm>, C<useopcode>, C<useperlio>, C<useposix>, C<usesfio>, C<useshrplib>, C<usesocks>, C<usethreads>, C<usevendorprefix>, C<usevfork>, C<usrinc>, C<uuname>, C<uvoformat>, C<uvsize>, C<uvtype>, C<uvuformat>, -C<uvxformat> +C<uvxformat>, C<uvXUformat> =item v C<vendorarch>, C<vendorarchexp>, C<vendorbin>, C<vendorbinexp>, C<vendorlib>, C<vendorlib_stem>, C<vendorlibexp>, C<vendorprefix>, -C<vendorprefixexp>, C<version>, C<vi>, C<voidflags> +C<vendorprefixexp>, C<version>, C<versiononly>, C<vi>, C<voidflags> =item x @@ -5813,9 +8204,9 @@ C<zcat>, C<zip> =back -=head2 Cwd, getcwd - get pathname of current working directory +=head2 Cwd - get pathname of current working directory -=over +=over 4 =item SYNOPSIS @@ -5827,13 +8218,13 @@ C<zcat>, C<zip> subject to change) -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Global Variables @@ -5862,7 +8253,7 @@ CLIENT->output(LIST) =head2 DB_File - Perl5 access to Berkeley DB version 1.x -=over +=over 4 =item SYNOPSIS @@ -5870,7 +8261,7 @@ CLIENT->output(LIST) B<DB_HASH>, B<DB_BTREE>, B<DB_RECNO> -=over +=over 4 =item Using DB_File with Berkeley DB version 2 or 3 @@ -5886,7 +8277,7 @@ B<DB_HASH>, B<DB_BTREE>, B<DB_RECNO> =item DB_HASH -=over +=over 4 =item A Simple Example @@ -5894,7 +8285,7 @@ B<DB_HASH>, B<DB_BTREE>, B<DB_RECNO> =item DB_BTREE -=over +=over 4 =item Changing the BTREE sort order @@ -5912,7 +8303,7 @@ B<DB_HASH>, B<DB_BTREE>, B<DB_RECNO> =item DB_RECNO -=over +=over 4 =item The 'bval' Option @@ -5939,7 +8330,7 @@ $value, $flags) ;>, B<$status = $X-E<gt>sync([$flags]) ;> B<filter_store_key>, B<filter_store_value>, B<filter_fetch_key>, B<filter_fetch_value> -=over +=over 4 =item The Filter @@ -5951,7 +8342,7 @@ B<filter_fetch_value> =item HINTS AND TIPS -=over +=over 4 =item Locking: The Trouble with fd @@ -5967,7 +8358,7 @@ B<Tie::DB_Lock>, B<Tie::DB_LockFile>, B<DB_File::Lock> =item COMMON QUESTIONS -=over +=over 4 =item Why is there Perl source in my database? @@ -5998,13 +8389,13 @@ B<Tie::DB_Lock>, B<Tie::DB_LockFile>, B<DB_File::Lock> =head2 Data::Dumper - stringified perl data structures, suitable for both printing and C<eval> -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Methods @@ -6052,7 +8443,7 @@ Dumper =head2 Devel::DProf - a Perl code profiler -=over +=over 4 =item SYNOPSIS @@ -6072,15 +8463,21 @@ Dumper =head2 Devel::Peek - A data debugging tool for the XS programmer -=over +=over 4 =item SYNOPSIS =item DESCRIPTION +=over 4 + +=item Memory footprint debugging + +=back + =item EXAMPLES -=over +=over 4 =item A simple scalar string @@ -6114,7 +8511,7 @@ Dumper =head2 Devel::SelfStubber - generate stubs for a SelfLoading module -=over +=over 4 =item SYNOPSIS @@ -6124,7 +8521,7 @@ Dumper =head2 DirHandle - supply object methods for directory handles -=over +=over 4 =item SYNOPSIS @@ -6134,13 +8531,13 @@ Dumper =head2 Dumpvalue - provides screen dump of Perl data. -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Creation @@ -6160,7 +8557,7 @@ veryCompact, set, get =head2 DynaLoader - Dynamically load C libraries into Perl code -=over +=over 4 =item SYNOPSIS @@ -6179,7 +8576,7 @@ bootstrap() =head2 DynaLoader::XSLoader, XSLoader - Dynamically load C libraries into Perl code -=over +=over 4 =item SYNOPSIS @@ -6192,7 +8589,7 @@ Perl code =head2 English - use nice English (or awk) names for ugly punctuation variables -=over +=over 4 =item SYNOPSIS @@ -6205,7 +8602,7 @@ variables =head2 Env - perl module that imports environment variables as scalars or arrays -=over +=over 4 =item SYNOPSIS @@ -6219,7 +8616,7 @@ arrays =head2 Errno - System errno constants -=over +=over 4 =item SYNOPSIS @@ -6235,13 +8632,13 @@ arrays =head2 Exporter - Implements default import method for modules -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item How to Export @@ -6263,7 +8660,7 @@ arrays =head2 Exporter::Heavy - Exporter guts -=over +=over 4 =item SYNOPIS @@ -6274,7 +8671,7 @@ arrays =head2 ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc. -=over +=over 4 =item SYNOPSIS @@ -6302,7 +8699,7 @@ mkpath directory.. test_f file -=over +=over 4 =item BUGS @@ -6314,7 +8711,7 @@ test_f file =head2 ExtUtils::Embed - Utilities for embedding Perl in C/C++ applications -=over +=over 4 =item SYNOPSIS @@ -6337,7 +8734,7 @@ ccopts(), xsi_header(), xsi_protos(@modules), xsi_body(@modules) =head2 ExtUtils::Install - install files from here to there -=over +=over 4 =item SYNOPSIS @@ -6347,7 +8744,7 @@ ccopts(), xsi_header(), xsi_protos(@modules), xsi_body(@modules) =head2 ExtUtils::Installed - Inventory management of installed modules -=over +=over 4 =item SYNOPSIS @@ -6368,7 +8765,7 @@ packlist(), version() =head2 ExtUtils::Liblist - determine libraries to use and how to use them -=over +=over 4 =item SYNOPSIS @@ -6376,7 +8773,7 @@ packlist(), version() For static extensions, For dynamic extensions, For dynamic extensions -=over +=over 4 =item EXTRALIBS @@ -6388,7 +8785,7 @@ For static extensions, For dynamic extensions, For dynamic extensions =item PORTABILITY -=over +=over 4 =item VMS implementation @@ -6403,7 +8800,7 @@ For static extensions, For dynamic extensions, For dynamic extensions =head2 ExtUtils::MM_Cygwin - methods to override UN*X behaviour in ExtUtils::MakeMaker -=over +=over 4 =item SYNOPSIS @@ -6413,10 +8810,12 @@ canonpath, cflags, manifypods, perl_archive =back +perl_archive_after + =head2 ExtUtils::MM_OS2 - methods to override UN*X behaviour in ExtUtils::MakeMaker -=over +=over 4 =item SYNOPSIS @@ -6426,7 +8825,7 @@ ExtUtils::MakeMaker =head2 ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker -=over +=over 4 =item SYNOPSIS @@ -6434,7 +8833,7 @@ ExtUtils::MakeMaker =item METHODS -=over +=over 4 =item Preloaded methods @@ -6454,7 +8853,7 @@ rootdir updir -=over +=over 4 =item SelfLoaded methods @@ -6506,7 +8905,7 @@ file_name_is_absolute find_perl -=over +=over 4 =item Methods to actually produce chunks of text for the Makefile @@ -6622,9 +9021,11 @@ xs_o (o) perl_archive +perl_archive_after + export_list -=over +=over 4 =item SEE ALSO @@ -6633,13 +9034,13 @@ export_list =head2 ExtUtils::MM_VMS - methods to override UN*X behaviour in ExtUtils::MakeMaker -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Methods always loaded @@ -6651,7 +9052,7 @@ wraplist rootdir (override) -=over +=over 4 =item SelfLoaded methods @@ -6748,7 +9149,7 @@ nicetext (override) =head2 ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker -=over +=over 4 =item SYNOPSIS @@ -6794,13 +9195,13 @@ pasthru (o) =head2 ExtUtils::MakeMaker - create an extension Makefile -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item How To Write A Makefile.PL @@ -6824,21 +9225,21 @@ pasthru (o) =item Using Attributes and Parameters -AUTHOR, ABSTRACT, ABSTRACT_FROM, BINARY_LOCATION, C, CAPI, CCFLAGS, CONFIG, +ABSTRACT, ABSTRACT_FROM, AUTHOR, BINARY_LOCATION, C, CAPI, CCFLAGS, CONFIG, CONFIGURE, DEFINE, DIR, DISTNAME, DL_FUNCS, DL_VARS, EXCLUDE_EXT, EXE_FILES, FIRST_MAKEFILE, FULLPERL, FUNCLIST, H, HTMLLIBPODS, HTMLSCRIPTPODS, IMPORTS, INC, INCLUDE_EXT, INSTALLARCHLIB, INSTALLBIN, INSTALLDIRS, INSTALLHTMLPRIVLIBDIR, INSTALLHTMLSCRIPTDIR, INSTALLHTMLSITELIBDIR, INSTALLMAN1DIR, INSTALLMAN3DIR, INSTALLPRIVLIB, INSTALLSCRIPT, INSTALLSITEARCH, INSTALLSITELIB, INST_ARCHLIB, INST_BIN, -INST_EXE, INST_LIB, INST_HTMLLIBDIR, INST_HTMLSCRIPTDIR, INST_MAN1DIR, -INST_MAN3DIR, INST_SCRIPT, PERL_MALLOC_OK, LDFROM, LIB, LIBPERL_A, LIBS, -LINKTYPE, MAKEAPERL, MAKEFILE, MAN1PODS, MAN3PODS, MAP_TARGET, MYEXTLIB, -NAME, NEEDS_LINKING, NOECHO, NORECURS, NO_VC, OBJECT, OPTIMIZE, PERL, -PERLMAINCC, PERL_ARCHLIB, PERL_LIB, PERL_SRC, PERM_RW, PERM_RWX, PL_FILES, -PM, PMLIBDIRS, POLLUTE, PPM_INSTALL_EXEC, PPM_INSTALL_SCRIPT, PREFIX, -PREREQ_PM, SKIP, TYPEMAPS, VERSION, VERSION_FROM, XS, XSOPT, XSPROTOARG, -XS_VERSION +INST_EXE, INST_HTMLLIBDIR, INST_HTMLSCRIPTDIR, INST_LIB, INST_MAN1DIR, +INST_MAN3DIR, INST_SCRIPT, LDFROM, LIB, LIBPERL_A, LIBS, LINKTYPE, +MAKEAPERL, MAKEFILE, MAN1PODS, MAN3PODS, MAP_TARGET, MYEXTLIB, NAME, +NEEDS_LINKING, NOECHO, NORECURS, NO_VC, OBJECT, OPTIMIZE, PERL, PERLMAINCC, +PERL_ARCHLIB, PERL_LIB, PERL_MALLOC_OK, PERL_SRC, PERM_RW, PERM_RWX, +PL_FILES, PM, PMLIBDIRS, PM_FILTER, POLLUTE, PPM_INSTALL_EXEC, +PPM_INSTALL_SCRIPT, PREFIX, PREREQ_PM, SKIP, TYPEMAPS, VERSION, +VERSION_FROM, XS, XSOPT, XSPROTOARG, XS_VERSION =item Additional lowercase attributes @@ -6871,7 +9272,7 @@ PERL_MM_OPT =head2 ExtUtils::Manifest - utilities to write and check a MANIFEST file -=over +=over 4 =item SYNOPSIS @@ -6896,7 +9297,7 @@ C<Added to MANIFEST:> I<file> =head2 ExtUtils::Miniperl, writemain - write the C code for perlmain.c -=over +=over 4 =item SYNOPSIS @@ -6908,7 +9309,7 @@ C<Added to MANIFEST:> I<file> =head2 ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader -=over +=over 4 =item SYNOPSIS @@ -6919,7 +9320,7 @@ C<Added to MANIFEST:> I<file> =head2 ExtUtils::Mksymlists - write linker options files for dynamic extension -=over +=over 4 =item SYNOPSIS @@ -6935,7 +9336,7 @@ DLBASE, DL_FUNCS, DL_VARS, FILE, FUNCLIST, IMPORTS, NAME =head2 ExtUtils::Packlist - manage .packlist files -=over +=over 4 =item SYNOPSIS @@ -6955,7 +9356,7 @@ new(), read(), write(), validate(), packlist_file() =head2 ExtUtils::testlib - add blib/* directories to @INC -=over +=over 4 =item SYNOPSIS @@ -6965,7 +9366,7 @@ new(), read(), write(), validate(), packlist_file() =head2 Fatal - replace functions with equivalents which succeed or die -=over +=over 4 =item SYNOPSIS @@ -6977,7 +9378,7 @@ new(), read(), write(), validate(), packlist_file() =head2 Fcntl - load the C Fcntl.h defines -=over +=over 4 =item SYNOPSIS @@ -6991,7 +9392,7 @@ new(), read(), write(), validate(), packlist_file() =head2 File::Basename, fileparse - split a pathname into pieces -=over +=over 4 =item SYNOPSIS @@ -7007,7 +9408,7 @@ C<basename>, C<dirname> =head2 File::CheckTree, validate - run many filetest checks on a tree -=over +=over 4 =item SYNOPSIS @@ -7017,7 +9418,7 @@ C<basename>, C<dirname> =head2 File::Compare - Compare files or filehandles -=over +=over 4 =item SYNOPSIS @@ -7031,13 +9432,13 @@ C<basename>, C<dirname> =head2 File::Copy - Copy files or filehandles -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32) @@ -7053,7 +9454,7 @@ rmscopy($from,$to[,$date_flag]) =head2 File::DosGlob - DOS like globbing and then some -=over +=over 4 =item SYNOPSIS @@ -7073,14 +9474,15 @@ rmscopy($from,$to[,$date_flag]) =head2 File::Find, find - traverse a file tree -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -C<wanted>, C<bydepth>, C<follow>, C<follow_fast>, C<follow_skip>, -C<no_chdir>, C<untaint>, C<untaint_pattern>, C<untaint_skip> +C<wanted>, C<bydepth>, C<preprocess>, C<postprocess>, C<follow>, +C<follow_fast>, C<follow_skip>, C<no_chdir>, C<untaint>, +C<untaint_pattern>, C<untaint_skip> =item CAVEAT @@ -7088,14 +9490,15 @@ C<no_chdir>, C<untaint>, C<untaint_pattern>, C<untaint_skip> =head2 File::Glob - Perl extension for BSD glob routine -=over +=over 4 =item SYNOPSIS =item DESCRIPTION C<GLOB_ERR>, C<GLOB_MARK>, C<GLOB_NOCASE>, C<GLOB_NOCHECK>, C<GLOB_NOSORT>, -C<GLOB_BRACE>, C<GLOB_NOMAGIC>, C<GLOB_QUOTE>, C<GLOB_TILDE>, C<GLOB_CSH> +C<GLOB_BRACE>, C<GLOB_NOMAGIC>, C<GLOB_QUOTE>, C<GLOB_TILDE>, C<GLOB_CSH>, +C<GLOB_ALPHASORT> =item DIAGNOSTICS @@ -7109,7 +9512,7 @@ C<GLOB_NOSPACE>, C<GLOB_ABEND> =head2 File::Path - create or remove directory trees -=over +=over 4 =item SYNOPSIS @@ -7121,7 +9524,7 @@ C<GLOB_NOSPACE>, C<GLOB_ABEND> =head2 File::Spec - portably perform operations on file names -=over +=over 4 =item SYNOPSIS @@ -7133,15 +9536,49 @@ C<GLOB_NOSPACE>, C<GLOB_ABEND> =back +=head2 File::Spec::Epoc - methods for Epoc file specs + +=over 4 + +=item SYNOPSIS + +=item DESCRIPTION + +devnull + +=back + +tmpdir + +path + +canonpath + +splitpath + +splitdir + +catpath + +abs2rel + +rel2abs + +=over 4 + +=item SEE ALSO + +=back + =head2 File::Spec::Functions - portably perform operations on file names -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Exports @@ -7153,7 +9590,7 @@ C<GLOB_NOSPACE>, C<GLOB_ABEND> =head2 File::Spec::Mac - File::Spec for MacOS -=over +=over 4 =item SYNOPSIS @@ -7193,7 +9630,7 @@ abs2rel rel2abs -=over +=over 4 =item SEE ALSO @@ -7201,7 +9638,7 @@ rel2abs =head2 File::Spec::OS2 - methods for OS/2 file specs -=over +=over 4 =item SYNOPSIS @@ -7211,7 +9648,7 @@ rel2abs =head2 File::Spec::Unix - methods used by File::Spec -=over +=over 4 =item SYNOPSIS @@ -7257,7 +9694,7 @@ abs2rel rel2abs -=over +=over 4 =item SEE ALSO @@ -7265,7 +9702,7 @@ rel2abs =head2 File::Spec::VMS - methods for VMS file specs -=over +=over 4 =item SYNOPSIS @@ -7277,7 +9714,7 @@ eliminate_macros fixpath -=over +=over 4 =item Methods always loaded @@ -7315,7 +9752,7 @@ abs2rel (override) rel2abs (override) -=over +=over 4 =item SEE ALSO @@ -7323,7 +9760,7 @@ rel2abs (override) =head2 File::Spec::Win32 - methods for Win32 file specs -=over +=over 4 =item SYNOPSIS @@ -7345,19 +9782,105 @@ splitdir catpath -abs2rel +=over 4 -rel2abs +=item SEE ALSO -=over +=back + +=head2 File::Temp - return name and handle of a temporary file safely + +=over 4 + +=item PORTABILITY + +=item SYNOPSIS + +=item DESCRIPTION + +=back + +=over 4 + +=item FUNCTIONS + +B<tempfile> + +=back + +B<tempdir> + +=over 4 + +=item MKTEMP FUNCTIONS + +B<mkstemp> + +=back + +B<mkstemps> + +B<mkdtemp> + +B<mktemp> + +=over 4 + +=item POSIX FUNCTIONS + +B<tmpnam> + +=back + +B<tmpfile> + +=over 4 + +=item ADDITIONAL FUNCTIONS + +B<tempnam> + +=back + +=over 4 + +=item UTILITY FUNCTIONS + +B<unlink0> + +=back + +=over 4 + +=item PACKAGE VARIABLES + +B<safe_level>, STANDARD, MEDIUM, HIGH + +=back + +TopSystemUID + +=over 4 + +=item WARNING + +=over 4 + +=item Temporary files and NFS + +=back + +=item HISTORY =item SEE ALSO +=item AUTHOR + =back =head2 File::stat - by-name interface to Perl's built-in stat() functions -=over +=over 4 =item SYNOPSIS @@ -7371,7 +9894,7 @@ rel2abs =head2 FileCache - keep more files open than the system permits -=over +=over 4 =item SYNOPSIS @@ -7383,7 +9906,7 @@ rel2abs =head2 FileHandle - supply object methods for filehandles -=over +=over 4 =item SYNOPSIS @@ -7397,7 +9920,7 @@ $fh->print, $fh->printf, $fh->getline, $fh->getlines =head2 FindBin - Locate directory of original perl script -=over +=over 4 =item SYNOPSIS @@ -7415,7 +9938,7 @@ $fh->print, $fh->printf, $fh->getline, $fh->getlines =head2 GDBM_File - Perl5 access to the gdbm library. -=over +=over 4 =item SYNOPSIS @@ -7431,7 +9954,7 @@ $fh->print, $fh->printf, $fh->getline, $fh->getlines =head2 Getopt::Long - Extended processing of command line options -=over +=over 4 =item SYNOPSIS @@ -7441,7 +9964,7 @@ $fh->print, $fh->printf, $fh->getline, $fh->getlines =item Getting Started with Getopt::Long -=over +=over 4 =item Simple options @@ -7469,7 +9992,9 @@ $fh->print, $fh->printf, $fh->getline, $fh->getlines =item Advanced Possibilities -=over +=over 4 + +=item Object oriented interface =item Documentation and help texts @@ -7485,16 +10010,17 @@ $fh->print, $fh->printf, $fh->getline, $fh->getlines =item Configuring Getopt::Long -default, auto_abbrev, getopt_compat, require_order, permute, bundling -(default: reset), bundling_override (default: reset), ignore_case -(default: set), ignore_case_always (default: reset), pass_through (default: -reset), prefix, prefix_pattern, debug (default: reset) +default, posix_default, auto_abbrev, getopt_compat, gnu_compat, gnu_getopt, +require_order, permute, bundling (default: disabled), bundling_override +(default: disabled), ignore_case (default: enabled), ignore_case_always +(default: disabled), pass_through (default: disabled), prefix, +prefix_pattern, debug (default: disabled) =item Return values and Errors =item Legacy -=over +=over 4 =item Default destinations @@ -7504,6 +10030,17 @@ reset), prefix, prefix_pattern, debug (default: reset) =back +=item Trouble Shooting + +=over 4 + +=item Warning: Ignoring '!' modifier for short option + +=item GetOptions does not return a false result when an option is not +supplied + +=back + =item AUTHOR =item COPYRIGHT AND DISCLAIMER @@ -7513,7 +10050,7 @@ reset), prefix, prefix_pattern, debug (default: reset) =head2 Getopt::Std, getopt - Process single-character switches with switch clustering -=over +=over 4 =item SYNOPSIS @@ -7524,7 +10061,7 @@ clustering =head2 I18N::Collate - compare 8-bit scalar data according to the current locale -=over +=over 4 =item SYNOPSIS @@ -7534,7 +10071,7 @@ locale =head2 IO - load various IO modules -=over +=over 4 =item SYNOPSIS @@ -7544,7 +10081,7 @@ locale =head2 IO::Dir - supply object methods for directory handles -=over +=over 4 =item SYNOPSIS @@ -7563,7 +10100,7 @@ rewind (), close (), tie %hash, IO::Dir, DIRNAME [, OPTIONS ] =head2 IO::File - supply object methods for filehandles -=over +=over 4 =item SYNOPSIS @@ -7585,7 +10122,7 @@ open( FILENAME [,MODE [,PERMS]] ) =head2 IO::Handle - supply object methods for I/O handles -=over +=over 4 =item SYNOPSIS @@ -7614,7 +10151,7 @@ $io->blocking ( [ BOOL ] ), $io->untaint =head2 IO::Pipe - supply object methods for pipes -=over +=over 4 =item SYNOPSIS @@ -7638,7 +10175,7 @@ reader ([ARGS]), writer ([ARGS]), handles () =head2 IO::Poll - Object interface to system poll call -=over +=over 4 =item SYNOPSIS @@ -7659,13 +10196,15 @@ IO ), handles( [ EVENT_MASK ] ) =head2 IO::Seekable - supply seek based methods for I/O objects -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=item SEE ALSO +$io->getpos, $io->setpos, $io->setpos ( POS, WHENCE ), WHENCE=0 (SEEK_SET), +WHENCE=1 (SEEK_CUR), WHENCE=1 (SEEK_END), $io->sysseek( POS, WHENCE ), +$io->tell =item HISTORY @@ -7673,7 +10212,7 @@ IO ), handles( [ EVENT_MASK ] ) =head2 IO::Select - OO interface to the select system call -=over +=over 4 =item SYNOPSIS @@ -7699,7 +10238,7 @@ count (), bits(), select ( READ, WRITE, ERROR [, TIMEOUT ] ) =head2 IO::Socket - Object interface to socket communications -=over +=over 4 =item SYNOPSIS @@ -7724,7 +10263,7 @@ sockopt(OPT [, VAL]), sockdomain, socktype, protocol, connected =head2 IO::Socket::INET - Object interface for AF_INET domain sockets -=over +=over 4 =item SYNOPSIS @@ -7734,7 +10273,7 @@ sockopt(OPT [, VAL]), sockdomain, socktype, protocol, connected new ( [ARGS] ) -=over +=over 4 =item METHODS @@ -7753,7 +10292,7 @@ sockaddr (), sockport (), sockhost (), peeraddr (), peerport (), peerhost =head2 IO::Socket::UNIX - Object interface for AF_UNIX domain sockets -=over +=over 4 =item SYNOPSIS @@ -7778,7 +10317,7 @@ hostpath(), peerpath() =head2 IO::lib::IO::Dir, IO::Dir - supply object methods for directory handles -=over +=over 4 =item SYNOPSIS @@ -7797,7 +10336,7 @@ rewind (), close (), tie %hash, IO::Dir, DIRNAME [, OPTIONS ] =head2 IO::lib::IO::File, IO::File - supply object methods for filehandles -=over +=over 4 =item SYNOPSIS @@ -7820,7 +10359,7 @@ open( FILENAME [,MODE [,PERMS]] ) =head2 IO::lib::IO::Handle, IO::Handle - supply object methods for I/O handles -=over +=over 4 =item SYNOPSIS @@ -7849,7 +10388,7 @@ $io->blocking ( [ BOOL ] ), $io->untaint =head2 IO::lib::IO::Pipe, IO::Pipe - supply object methods for pipes -=over +=over 4 =item SYNOPSIS @@ -7873,7 +10412,7 @@ reader ([ARGS]), writer ([ARGS]), handles () =head2 IO::lib::IO::Poll, IO::Poll - Object interface to system poll call -=over +=over 4 =item SYNOPSIS @@ -7895,13 +10434,15 @@ IO ), handles( [ EVENT_MASK ] ) =head2 IO::lib::IO::Seekable, IO::Seekable - supply seek based methods for I/O objects -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=item SEE ALSO +$io->getpos, $io->setpos, $io->setpos ( POS, WHENCE ), WHENCE=0 (SEEK_SET), +WHENCE=1 (SEEK_CUR), WHENCE=1 (SEEK_END), $io->sysseek( POS, WHENCE ), +$io->tell =item HISTORY @@ -7910,7 +10451,7 @@ I/O objects =head2 IO::lib::IO::Select, IO::Select - OO interface to the select system call -=over +=over 4 =item SYNOPSIS @@ -7937,7 +10478,7 @@ count (), bits(), select ( READ, WRITE, ERROR [, TIMEOUT ] ) =head2 IO::lib::IO::Socket, IO::Socket - Object interface to socket communications -=over +=over 4 =item SYNOPSIS @@ -7963,7 +10504,7 @@ sockopt(OPT [, VAL]), sockdomain, socktype, protocol, connected =head2 IO::lib::IO::Socket::INET, IO::Socket::INET - Object interface for AF_INET domain sockets -=over +=over 4 =item SYNOPSIS @@ -7973,7 +10514,7 @@ AF_INET domain sockets new ( [ARGS] ) -=over +=over 4 =item METHODS @@ -7993,7 +10534,7 @@ sockaddr (), sockport (), sockhost (), peeraddr (), peerport (), peerhost =head2 IO::lib::IO::Socket::UNIX, IO::Socket::UNIX - Object interface for AF_UNIX domain sockets -=over +=over 4 =item SYNOPSIS @@ -8017,7 +10558,7 @@ hostpath(), peerpath() =head2 IPC::Msg - SysV Msg IPC object class -=over +=over 4 =item SYNOPSIS @@ -8039,7 +10580,7 @@ FLAGS ] ), stat =head2 IPC::Open2, open2 - open a process for both reading and writing -=over +=over 4 =item SYNOPSIS @@ -8054,7 +10595,7 @@ FLAGS ] ), stat =head2 IPC::Open3, open3 - open a process for reading, writing, and error handling -=over +=over 4 =item SYNOPSIS @@ -8066,7 +10607,7 @@ handling =head2 IPC::Semaphore - SysV Semaphore IPC object class -=over +=over 4 =item SYNOPSIS @@ -8089,7 +10630,7 @@ set ( NAME => VALUE [, NAME => VALUE ...] ), setall ( VALUES ), setval ( N =head2 IPC::SysV - SysV IPC constants -=over +=over 4 =item SYNOPSIS @@ -8107,7 +10648,7 @@ ftok( PATH, ID ) =head2 IPC::SysV::Msg, IPC::Msg - SysV Msg IPC object class -=over +=over 4 =item SYNOPSIS @@ -8130,7 +10671,7 @@ FLAGS ] ), stat =head2 IPC::SysV::Semaphore, IPC::Semaphore - SysV Semaphore IPC object class -=over +=over 4 =item SYNOPSIS @@ -8153,7 +10694,7 @@ set ( NAME => VALUE [, NAME => VALUE ...] ), setall ( VALUES ), setval ( N =head2 Math::BigFloat - Arbitrary length float math package -=over +=over 4 =item SYNOPSIS @@ -8170,7 +10711,7 @@ performed =head2 Math::BigInt - Arbitrary size integer math package -=over +=over 4 =item SYNOPSIS @@ -8188,9 +10729,42 @@ Canonical notation, Input, Output =back +=head2 Math::Complex - complex numbers and associated mathematical +functions + +=over 4 + +=item SYNOPSIS + +=item DESCRIPTION + +=item OPERATIONS + +=item CREATION + +=item STRINGIFICATION + +=over 4 + +=item CHANGED IN PERL 5.6 + +=back + +=item USAGE + +=item ERRORS DUE TO DIVISION BY ZERO OR LOGARITHM OF ZERO + +=item ERRORS DUE TO INDIGESTIBLE ARGUMENTS + +=item BUGS + +=item AUTHORS + +=back + =head2 Math::Trig - trigonometric functions -=over +=over 4 =item SYNOPSIS @@ -8200,7 +10774,7 @@ Canonical notation, Input, Output B<tan> -=over +=over 4 =item ERRORS DUE TO DIVISION BY ZERO @@ -8212,7 +10786,7 @@ B<tan> =item RADIAL COORDINATE CONVERSIONS -=over +=over 4 =item COORDINATE SYSTEMS @@ -8235,23 +10809,33 @@ cylindrical_to_spherical, spherical_to_cartesian, spherical_to_cylindrical =head2 NDBM_File - Tied access to ndbm files -=over +=over 4 =item SYNOPSIS -=item DESCRIPTION +C<O_RDONLY>, C<O_WRONLY>, C<O_RDWR> + +=item DIAGNOSTICS + +=over 4 + +=item C<ndbm store returned -1, errno 22, key "..." at ...> + +=back + +=item BUGS AND WARNINGS =back =head2 Net::Ping - check a remote host for reachability -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Functions @@ -8269,7 +10853,7 @@ $timeout]);, $p->close();, pingecho($host [, $timeout]); =head2 Net::hostent - by-name interface to Perl's built-in gethost*() functions -=over +=over 4 =item SYNOPSIS @@ -8286,7 +10870,7 @@ functions =head2 Net::netent - by-name interface to Perl's built-in getnet*() functions -=over +=over 4 =item SYNOPSIS @@ -8303,7 +10887,7 @@ functions =head2 Net::protoent - by-name interface to Perl's built-in getproto*() functions -=over +=over 4 =item SYNOPSIS @@ -8318,7 +10902,7 @@ functions =head2 Net::servent - by-name interface to Perl's built-in getserv*() functions -=over +=over 4 =item SYNOPSIS @@ -8334,7 +10918,7 @@ functions =head2 O - Generic interface to Perl Compiler backends -=over +=over 4 =item SYNOPSIS @@ -8350,17 +10934,27 @@ functions =head2 ODBM_File - Tied access to odbm files -=over +=over 4 =item SYNOPSIS -=item DESCRIPTION +C<O_RDONLY>, C<O_WRONLY>, C<O_RDWR> + +=item DIAGNOSTICS + +=over 4 + +=item C<odbm store returned -1, errno 22, key "..." at ...> + +=back + +=item BUGS AND WARNINGS =back =head2 Opcode - Disable named opcodes when compiling perl code -=over +=over 4 =item SYNOPSIS @@ -8388,7 +10982,7 @@ opdump (PAT) =back -=over +=over 4 =item Predefined Opcode Tags @@ -8406,7 +11000,7 @@ opdump (PAT) =head2 Opcode::Safe, Safe - Compile and execute code in restricted compartments -=over +=over 4 =item SYNOPSIS @@ -8416,7 +11010,7 @@ a new namespace, an operator mask =item WARNING -=over +=over 4 =item RECENT CHANGES @@ -8440,7 +11034,7 @@ Memory, CPU, Snooping, Signals, State Changes =head2 Opcode::ops, ops - Perl pragma to restrict unsafe operations when compiling -=over +=over 4 =item SYNOPSIS @@ -8452,7 +11046,7 @@ compiling =head2 POSIX - Perl interface to IEEE Std 1003.1 -=over +=over 4 =item SYNOPSIS @@ -8484,16 +11078,16 @@ rewinddir, rmdir, scanf, setgid, setjmp, setlocale, setpgid, setsid, setuid, sigaction, siglongjmp, sigpending, sigprocmask, sigsetjmp, sigsuspend, sin, sinh, sleep, sprintf, sqrt, srand, sscanf, stat, strcat, strchr, strcmp, strcoll, strcpy, strcspn, strerror, strftime, strlen, -strncat, strncmp, strncpy, stroul, strpbrk, strrchr, strspn, strstr, -strtod, strtok, strtol, strtoul, strxfrm, sysconf, system, tan, tanh, -tcdrain, tcflow, tcflush, tcgetpgrp, tcsendbreak, tcsetpgrp, time, times, -tmpfile, tmpnam, tolower, toupper, ttyname, tzname, tzset, umask, uname, -ungetc, unlink, utime, vfprintf, vprintf, vsprintf, wait, waitpid, -wcstombs, wctomb, write +strncat, strncmp, strncpy, strpbrk, strrchr, strspn, strstr, strtod, +strtok, strtol, strtoul, strxfrm, sysconf, system, tan, tanh, tcdrain, +tcflow, tcflush, tcgetpgrp, tcsendbreak, tcsetpgrp, time, times, tmpfile, +tmpnam, tolower, toupper, ttyname, tzname, tzset, umask, uname, ungetc, +unlink, utime, vfprintf, vprintf, vsprintf, wait, waitpid, wcstombs, +wctomb, write =item CLASSES -=over +=over 4 =item POSIX::SigAction @@ -8577,19 +11171,17 @@ Constants Constants, Macros -=item CREATION - =back =head2 Pod::Checker, podchecker() - check pod documents for syntax errors -=over +=over 4 =item SYNOPSIS =item OPTIONS/ARGUMENTS -=over +=over 4 =item podchecker() @@ -8601,7 +11193,7 @@ B<-warnings> =E<gt> I<val> =item DIAGNOSTICS -=over +=over 4 =item Errors @@ -8618,12 +11210,16 @@ after =back =item Warnings multiple occurence of link target I<name>, line containing nothing but -whitespace in paragraph, file does not start with =head, No numeric -argument for =over, previous =item has no contents, preceding non-item -paragraph(s), =item type mismatch (I<one> vs. I<two>), I<N> unescaped -C<E<lt>E<gt>> in paragraph, Unknown entity, No items in =over, No argument -for =item, empty section in previous paragraph, Verbatim paragraph in NAME -section, Hyperlinks +whitespace in paragraph, file does not start with =head, previous =item has +no contents, preceding non-item paragraph(s), =item type mismatch (I<one> +vs. I<two>), I<N> unescaped C<E<lt>E<gt>> in paragraph, Unknown entity, No +items in =over, No argument for =item, empty section in previous paragraph, +Verbatim paragraph in NAME section + +=item Hyperlinks + +ignoring leading/trailing whitespace in link, (section) in '$page' +deprecated, alternative text/node '%s' contains non-escaped | or / =back @@ -8635,6 +11231,8 @@ section, Hyperlinks =back +C<Pod::Checker-E<gt>new( %options )> + C<$checker-E<gt>poderror( @args )>, C<$checker-E<gt>poderror( {%opts}, @args )> @@ -8648,7 +11246,7 @@ C<$checker-E<gt>idx()> C<$checker-E<gt>hyperlink()> -=over +=over 4 =item AUTHOR @@ -8656,15 +11254,45 @@ C<$checker-E<gt>hyperlink()> =head2 Pod::Find - find POD documents in directory trees -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=item OPTIONS +=back + +=over 4 + +=item C<pod_find( { %opts } , @directories )> + +C<-verbose =E<gt> 1>, C<-perl =E<gt> 1>, C<-script =E<gt> 1>, C<-inc =E<gt> +1> + +=back + +=over 4 + +=item C<simplify_name( $str )> + +=back + +=over 4 + +=item C<pod_where( { %opts }, $pod )> + +C<-inc =E<gt> 1>, C<-dirs =E<gt> [ $dir1, $dir2, ... ]>, C<-verbose =E<gt> +1> + +=back -B<-verbose>, B<-perl>, B<-script>, B<-inc> +=over 4 + +=item C<contains_pod( $file , $verbose )> + +=back + +=over 4 =item AUTHOR @@ -8674,7 +11302,7 @@ B<-verbose>, B<-perl>, B<-script>, B<-inc> =head2 Pod::Html - module to convert pod files to HTML -=over +=over 4 =item SYNOPSIS @@ -8701,7 +11329,7 @@ verbose =head2 Pod::InputObjects - objects representing POD input paragraphs, commands, etc. -=over +=over 4 =item SYNOPSIS @@ -8711,216 +11339,216 @@ commands, etc. =item DESCRIPTION -B<Pod::InputSource>, B<Pod::Paragraph>, B<Pod::InteriorSequence>, -B<Pod::ParseTree> +package B<Pod::InputSource>, package B<Pod::Paragraph>, package +B<Pod::InteriorSequence>, package B<Pod::ParseTree> =back -=over +=over 4 =item B<Pod::InputSource> =back -=over +=over 4 =item B<new()> =back -=over +=over 4 =item B<name()> =back -=over +=over 4 =item B<handle()> =back -=over +=over 4 =item B<was_cutting()> =back -=over +=over 4 =item B<Pod::Paragraph> =back -=over +=over 4 -=item B<new()> +=item Pod::Paragraph-E<gt>B<new()> =back -=over +=over 4 -=item B<cmd_name()> +=item $pod_para-E<gt>B<cmd_name()> =back -=over +=over 4 -=item B<text()> +=item $pod_para-E<gt>B<text()> =back -=over +=over 4 -=item B<raw_text()> +=item $pod_para-E<gt>B<raw_text()> =back -=over +=over 4 -=item B<cmd_prefix()> +=item $pod_para-E<gt>B<cmd_prefix()> =back -=over +=over 4 -=item B<cmd_separator()> +=item $pod_para-E<gt>B<cmd_separator()> =back -=over +=over 4 -=item B<parse_tree()> +=item $pod_para-E<gt>B<parse_tree()> =back -=over +=over 4 -=item B<file_line()> +=item $pod_para-E<gt>B<file_line()> =back -=over +=over 4 =item B<Pod::InteriorSequence> =back -=over +=over 4 -=item B<new()> +=item Pod::InteriorSequence-E<gt>B<new()> =back -=over +=over 4 -=item B<cmd_name()> +=item $pod_seq-E<gt>B<cmd_name()> =back -=over +=over 4 -=item B<prepend()> +=item $pod_seq-E<gt>B<prepend()> =back -=over +=over 4 -=item B<append()> +=item $pod_seq-E<gt>B<append()> =back -=over +=over 4 -=item B<nested()> +=item $pod_seq-E<gt>B<nested()> =back -=over +=over 4 -=item B<raw_text()> +=item $pod_seq-E<gt>B<raw_text()> =back -=over +=over 4 -=item B<left_delimiter()> +=item $pod_seq-E<gt>B<left_delimiter()> =back -=over +=over 4 -=item B<right_delimiter()> +=item $pod_seq-E<gt>B<right_delimiter()> =back -=over +=over 4 -=item B<parse_tree()> +=item $pod_seq-E<gt>B<parse_tree()> =back -=over +=over 4 -=item B<file_line()> +=item $pod_seq-E<gt>B<file_line()> =back -=over +=over 4 -=item B<DESTROY()> +=item Pod::InteriorSequence::B<DESTROY()> =back -=over +=over 4 =item B<Pod::ParseTree> =back -=over +=over 4 -=item B<new()> +=item Pod::ParseTree-E<gt>B<new()> =back -=over +=over 4 -=item B<top()> +=item $ptree-E<gt>B<top()> =back -=over +=over 4 -=item B<children()> +=item $ptree-E<gt>B<children()> =back -=over +=over 4 -=item B<prepend()> +=item $ptree-E<gt>B<prepend()> =back -=over +=over 4 -=item B<append()> +=item $ptree-E<gt>B<append()> =back -=over +=over 4 -=item B<raw_text()> +=item $ptree-E<gt>B<raw_text()> =back -=over +=over 4 -=item B<DESTROY()> +=item Pod::ParseTree::B<DESTROY()> =back -=over +=over 4 =item SEE ALSO @@ -8928,21 +11556,141 @@ B<Pod::ParseTree> =back +=head2 Pod::LaTeX - Convert Pod data to formatted Latex + +=over 4 + +=item SYNOPSIS + +=item DESCRIPTION + +=back + +=over 4 + +=item OBJECT METHODS + +C<initialize> + +=back + +=over 4 + +=item Data Accessors + +B<AddPreamble> + +=back + +B<AddPostamble> + +B<Head1Level> + +B<Label> + +B<LevelNoNum> + +B<MakeIndex> + +B<ReplaceNAMEwithSection> + +B<StartWithNewPage> + +B<TableOfContents> + +B<UniqueLabels> + +B<UserPreamble> + +B<UserPostamble> + +B<Lists> + +=over 4 + +=item Subclassed methods + +=back + +B<begin_pod> + +B<end_pod> + +B<command> + +B<verbatim> + +B<textblock> + +B<interior_sequence> + +=over 4 + +=item List Methods + +B<begin_list> + +=back + +B<end_list> + +B<add_item> + +=over 4 + +=item Methods for headings + +B<head> + +=back + +=over 4 + +=item Internal methods + +B<_output> + +=back + +B<_replace_special_chars> + +B<_create_label> + +B<_create_index> + +B<_clean_latex_commands> + +=over 4 + +=item NOTES + +=item SEE ALSO + +=item AUTHORS + +=item COPYRIGHT + +=item REVISION + +=back + =head2 Pod::Man - Convert POD data to formatted *roff input -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -center, date, fixed, fixedbold, fixeditalic, fixedbolditalic, release, -section +center, date, fixed, fixedbold, fixeditalic, fixedbolditalic, quotes, +release, section =item DIAGNOSTICS -roff font should be 1 or 2 chars, not `%s', Invalid link %s, Unknown escape -EE<lt>%sE<gt>, Unknown sequence %s, Unmatched =back +roff font should be 1 or 2 chars, not "%s", Invalid link %s, Invalid quote +specification "%s", %s:%d: Unknown command paragraph "%s", Unknown escape +EE<lt>%sE<gt>, Unknown sequence %s, %s: Unknown command paragraph "%s" on +line %d, Unmatched =back =item BUGS @@ -8954,7 +11702,7 @@ EE<lt>%sE<gt>, Unknown sequence %s, Unmatched =back =head2 Pod::ParseUtils - helpers for POD parsing and conversion -=over +=over 4 =item SYNOPSIS @@ -8962,93 +11710,93 @@ EE<lt>%sE<gt>, Unknown sequence %s, Unmatched =back =back -=over +=over 4 =item Pod::List -new() +Pod::List-E<gt>new() =back -file() +$list-E<gt>file() -start() +$list-E<gt>start() -indent() +$list-E<gt>indent() -type() +$list-E<gt>type() -rx() +$list-E<gt>rx() -item() +$list-E<gt>item() -parent() +$list-E<gt>parent() -tag() +$list-E<gt>tag() -=over +=over 4 =item Pod::Hyperlink -new() +Pod::Hyperlink-E<gt>new() =back -parse($string) +$link-E<gt>parse($string) -markup($string) +$link-E<gt>markup($string) -text() +$link-E<gt>text() -warning() +$link-E<gt>warning() -line(), file() +$link-E<gt>file(), $link-E<gt>line() -page() +$link-E<gt>page() -node() +$link-E<gt>node() -alttext() +$link-E<gt>alttext() -type() +$link-E<gt>type() -link() +$link-E<gt>link() -=over +=over 4 =item Pod::Cache -new() +Pod::Cache-E<gt>new() =back -item() +$cache-E<gt>item() -find_page($name) +$cache-E<gt>find_page($name) -=over +=over 4 =item Pod::Cache::Item -new() +Pod::Cache::Item-E<gt>new() =back -page() +$cacheitem-E<gt>page() -description() +$cacheitem-E<gt>description() -path() +$cacheitem-E<gt>path() -file() +$cacheitem-E<gt>file() -nodes() +$cacheitem-E<gt>nodes() -find_node($name) +$cacheitem-E<gt>find_node($name) -idx() +$cacheitem-E<gt>idx() -=over +=over 4 =item AUTHOR @@ -9058,7 +11806,7 @@ idx() =head2 Pod::Parser - base class for creating POD filters and translators -=over +=over 4 =item SYNOPSIS @@ -9077,13 +11825,13 @@ B<-warnings> (default: unset) =back -=over +=over 4 =item RECOMMENDED SUBROUTINE/METHOD OVERRIDES =back -=over +=over 4 =item B<command()> @@ -9091,7 +11839,7 @@ C<$cmd>, C<$text>, C<$line_num>, C<$pod_para> =back -=over +=over 4 =item B<verbatim()> @@ -9099,7 +11847,7 @@ C<$text>, C<$line_num>, C<$pod_para> =back -=over +=over 4 =item B<textblock()> @@ -9107,73 +11855,73 @@ C<$text>, C<$line_num>, C<$pod_para> =back -=over +=over 4 =item B<interior_sequence()> =back -=over +=over 4 =item OPTIONAL SUBROUTINE/METHOD OVERRIDES =back -=over +=over 4 =item B<new()> =back -=over +=over 4 =item B<initialize()> =back -=over +=over 4 =item B<begin_pod()> =back -=over +=over 4 =item B<begin_input()> =back -=over +=over 4 =item B<end_input()> =back -=over +=over 4 =item B<end_pod()> =back -=over +=over 4 =item B<preprocess_line()> =back -=over +=over 4 =item B<preprocess_paragraph()> =back -=over +=over 4 =item METHODS FOR PARSING AND PROCESSING =back -=over +=over 4 =item B<parse_text()> @@ -9183,109 +11931,109 @@ I<code-ref>|I<method-name> =back -=over +=over 4 =item B<interpolate()> =back -=over +=over 4 =item B<parse_paragraph()> =back -=over +=over 4 =item B<parse_from_filehandle()> =back -=over +=over 4 =item B<parse_from_file()> =back -=over +=over 4 =item ACCESSOR METHODS =back -=over +=over 4 =item B<errorsub()> =back -=over +=over 4 =item B<cutting()> =back -=over +=over 4 =item B<parseopts()> =back -=over +=over 4 =item B<output_file()> =back -=over +=over 4 =item B<output_handle()> =back -=over +=over 4 =item B<input_file()> =back -=over +=over 4 =item B<input_handle()> =back -=over +=over 4 =item B<input_streams()> =back -=over +=over 4 =item B<top_stream()> =back -=over +=over 4 =item PRIVATE METHODS AND DATA =back -=over +=over 4 =item B<_push_input_stream()> =back -=over +=over 4 =item B<_pop_input_stream()> =back -=over +=over 4 =item TREE-BASED PARSING @@ -9297,13 +12045,13 @@ I<code-ref>|I<method-name> =head2 Pod::Plainer - Perl extension for converting Pod to old style Pod. -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item EXPORT @@ -9318,7 +12066,7 @@ I<code-ref>|I<method-name> =head2 Pod::Select, podselect() - extract selected sections of POD from input -=over +=over 4 =item SYNOPSIS @@ -9334,55 +12082,55 @@ input =back -=over +=over 4 =item OBJECT METHODS =back -=over +=over 4 =item B<curr_headings()> =back -=over +=over 4 =item B<select()> =back -=over +=over 4 =item B<add_selection()> =back -=over +=over 4 =item B<clear_selections()> =back -=over +=over 4 =item B<match_section()> =back -=over +=over 4 =item B<is_selected()> =back -=over +=over 4 =item EXPORTED FUNCTIONS =back -=over +=over 4 =item B<podselect()> @@ -9390,31 +12138,31 @@ B<-output>, B<-sections>, B<-ranges> =back -=over +=over 4 =item PRIVATE METHODS AND DATA =back -=over +=over 4 =item B<_compile_section_spec()> =back -=over +=over 4 =item $self->{_SECTION_HEADINGS} =back -=over +=over 4 =item $self->{_SELECTED_SECTIONS} =back -=over +=over 4 =item SEE ALSO @@ -9424,18 +12172,19 @@ B<-output>, B<-sections>, B<-ranges> =head2 Pod::Text - Convert POD data to formatted ASCII text -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -alt, indent, loose, sentence, width +alt, indent, loose, quotes, sentence, width =item DIAGNOSTICS -Bizarre space in item, Can't open %s for reading: %s, Unknown escape: %s, -Unknown sequence: %s, Unmatched =back +Bizarre space in item, Can't open %s for reading: %s, Invalid quote +specification "%s", %s:%d: Unknown command paragraph "%s", Unknown escape: +%s, Unknown sequence: %s, Unmatched =back =item RESTRICTIONS @@ -9449,7 +12198,24 @@ Unknown sequence: %s, Unmatched =back =head2 Pod::Text::Color - Convert POD data to formatted color ASCII text -=over +=over 4 + +=item SYNOPSIS + +=item DESCRIPTION + +=item BUGS + +=item SEE ALSO + +=item AUTHOR + +=back + +=head2 Pod::Text::Overstrike - Convert POD data to formatted overstrike +text + +=over 4 =item SYNOPSIS @@ -9466,7 +12232,7 @@ Unknown sequence: %s, Unmatched =back =head2 Pod::Text::Termcap, Pod::Text::Color - Convert POD data to ASCII text with format escapes -=over +=over 4 =item SYNOPSIS @@ -9481,7 +12247,7 @@ text with format escapes =head2 Pod::Usage, pod2usage() - print a usage message from embedded pod documentation -=over +=over 4 =item SYNOPSIS @@ -9494,7 +12260,7 @@ C<-pathlist> =item EXAMPLES -=over +=over 4 =item Recommended Use @@ -9510,17 +12276,29 @@ C<-pathlist> =head2 SDBM_File - Tied access to sdbm files -=over +=over 4 =item SYNOPSIS =item DESCRIPTION +C<O_RDONLY>, C<O_WRONLY>, C<O_RDWR> + +=item DIAGNOSTICS + +=over 4 + +=item C<sdbm store returned -1, errno 22, key "..." at ...> + +=back + +=item BUGS AND WARNINGS + =back =head2 Safe - Compile and execute code in restricted compartments -=over +=over 4 =item SYNOPSIS @@ -9530,7 +12308,7 @@ a new namespace, an operator mask =item WARNING -=over +=over 4 =item RECENT CHANGES @@ -9553,7 +12331,7 @@ Memory, CPU, Snooping, Signals, State Changes =head2 Search::Dict, look - search for key in dictionary file -=over +=over 4 =item SYNOPSIS @@ -9563,7 +12341,7 @@ Memory, CPU, Snooping, Signals, State Changes =head2 SelectSaver - save and restore selected file handle -=over +=over 4 =item SYNOPSIS @@ -9573,13 +12351,13 @@ Memory, CPU, Snooping, Signals, State Changes =head2 SelfLoader - load functions only on demand -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item The __DATA__ token @@ -9601,12 +12379,18 @@ Memory, CPU, Snooping, Signals, State Changes =head2 Shell - run shell commands transparently within perl -=over +=over 4 =item SYNOPSIS =item DESCRIPTION +=over 4 + +=item OBJECT ORIENTED SYNTAX + +=back + =item AUTHOR =back @@ -9614,7 +12398,7 @@ Memory, CPU, Snooping, Signals, State Changes =head2 Socket, sockaddr_in, sockaddr_un, inet_aton, inet_ntoa - load the C socket.h defines and structure manipulators -=over +=over 4 =item SYNOPSIS @@ -9630,7 +12414,7 @@ pack_sockaddr_un PATH, unpack_sockaddr_un SOCKADDR_UN =head2 Symbol - manipulate Perl symbols and their names -=over +=over 4 =item SYNOPSIS @@ -9640,7 +12424,7 @@ pack_sockaddr_un PATH, unpack_sockaddr_un SOCKADDR_UN =head2 Sys::Hostname - Try every conceivable way to get hostname -=over +=over 4 =item SYNOPSIS @@ -9653,7 +12437,7 @@ pack_sockaddr_un PATH, unpack_sockaddr_un SOCKADDR_UN =head2 Syslog, Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls -=over +=over 4 =item SYNOPSIS @@ -9674,7 +12458,7 @@ closelog =head2 Syslog::Syslog, Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls -=over +=over 4 =item SYNOPSIS @@ -9694,7 +12478,7 @@ closelog =head2 Term::ANSIColor - Color screen output using ANSI escape sequences -=over +=over 4 =item SYNOPSIS @@ -9702,19 +12486,21 @@ closelog =item DIAGNOSTICS -Invalid attribute name %s, Identifier %s used only once: possible typo, No -comma allowed after filehandle, Bareword %s not allowed while "strict subs" -in use +Invalid attribute name %s, Name "%s" used only once: possible typo, No +comma allowed after filehandle, Bareword "%s" not allowed while "strict +subs" in use =item RESTRICTIONS +=item NOTES + =item AUTHORS =back =head2 Term::Cap - Perl termcap interface -=over +=over 4 =item SYNOPSIS @@ -9726,7 +12512,7 @@ in use =head2 Term::Complete - Perl word completion module -=over +=over 4 =item SYNOPSIS @@ -9745,7 +12531,7 @@ E<lt>tabE<gt>, ^D, ^U, E<lt>delE<gt>, E<lt>bsE<gt> =head2 Term::ReadLine - Perl interface to various C<readline> packages. If no real package is found, substitutes stubs instead of basic functions. -=over +=over 4 =item SYNOPSIS @@ -9768,7 +12554,7 @@ C<tkRunning>, C<ornaments>, C<newTTY> =head2 Test - provides a simple framework for writing test scripts -=over +=over 4 =item SYNOPSIS @@ -9790,13 +12576,13 @@ NORMAL TESTS, SKIPPED TESTS, TODO TESTS =head2 Test::Harness - run perl standard test scripts with statistics -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item The test script output @@ -9823,7 +12609,7 @@ C<All tests successful.\nFiles=%d, Tests=%d, %s>, C<FAILED tests =head2 Text::Abbrev, abbrev - create an abbreviation table from a list -=over +=over 4 =item SYNOPSIS @@ -9836,7 +12622,7 @@ C<All tests successful.\nFiles=%d, Tests=%d, %s>, C<FAILED tests =head2 Text::ParseWords - parse text into an array of tokens or array of arrays -=over +=over 4 =item SYNOPSIS @@ -9844,12 +12630,6 @@ arrays =item EXAMPLES -0a simple word, 1multiple spaces are skipped because of our $delim, 2use of -quotes to include a space in a word, 3use of a backslash to include a space -in a word, 4use of a backslash to remove the special meaning of a -double-quote, 5another simple word (note the lack of effect of the -backslashed double-quote) - =item AUTHORS =back @@ -9857,7 +12637,7 @@ backslashed double-quote) =head2 Text::Soundex - Implementation of the Soundex Algorithm as Described by Knuth -=over +=over 4 =item SYNOPSIS @@ -9874,7 +12654,7 @@ by Knuth =head2 Text::Tabs -- expand and unexpand tabs per the unix expand(1) and unexpand(1) -=over +=over 4 =item SYNOPSIS @@ -9888,7 +12668,7 @@ unexpand(1) =head2 Text::Wrap - line wrapping to form simple paragraphs -=over +=over 4 =item SYNOPSIS @@ -9903,7 +12683,9 @@ unexpand(1) =head2 Thread - manipulate threads in Perl (EXPERIMENTAL, subject to change) -=over +=over 4 + +=item CAVEAT =item SYNOPSIS @@ -9927,7 +12709,7 @@ join, eval, detach, equal, tid =head2 Thread::Queue - thread-safe queues -=over +=over 4 =item SYNOPSIS @@ -9943,7 +12725,7 @@ new, enqueue LIST, dequeue, dequeue_nb, pending =head2 Thread::Semaphore - thread-safe semaphores -=over +=over 4 =item SYNOPSIS @@ -9957,7 +12739,7 @@ new, new NUMBER, down, down NUMBER, up, up NUMBER =head2 Thread::Signal - Start a thread which runs signal handlers reliably -=over +=over 4 =item SYNOPSIS @@ -9969,7 +12751,7 @@ new, new NUMBER, down, down NUMBER, up, up NUMBER =head2 Thread::Specific - thread-specific keys -=over +=over 4 =item SYNOPSIS @@ -9979,11 +12761,11 @@ new, new NUMBER, down, down NUMBER, up, up NUMBER =head2 Tie::Array - base class for tied arrays -=over +=over 4 -=item SYNOPSIS +=item SYNOPSIS -=item DESCRIPTION +=item DESCRIPTION TIEARRAY classname, LIST, STORE this, index, value, FETCH this, index, FETCHSIZE this, STORESIZE this, count, EXTEND this, count, EXISTS this, @@ -9992,14 +12774,14 @@ SHIFT this, UNSHIFT this, LIST, SPLICE this, offset, length, LIST =item CAVEATS -=item AUTHOR +=item AUTHOR =back =head2 Tie::Handle, Tie::StdHandle - base class definitions for tied handles -=over +=over 4 =item SYNOPSIS @@ -10012,11 +12794,13 @@ EOF this, TELL this, SEEK this, offset, whence, DESTROY this =item MORE INFORMATION +=item COMPATIBILITY + =back =head2 Tie::Hash, Tie::StdHash - base class definitions for tied hashes -=over +=over 4 =item SYNOPSIS @@ -10033,7 +12817,7 @@ this, NEXTKEY this, lastkey, EXISTS this, key, DELETE this, key, CLEAR this =head2 Tie::RefHash - use references as hash keys -=over +=over 4 =item SYNOPSIS @@ -10052,7 +12836,7 @@ this, NEXTKEY this, lastkey, EXISTS this, key, DELETE this, key, CLEAR this =head2 Tie::Scalar, Tie::StdScalar - base class definitions for tied scalars -=over +=over 4 =item SYNOPSIS @@ -10066,7 +12850,7 @@ TIESCALAR classname, LIST, FETCH this, STORE this, value, DESTROY this =head2 Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing -=over +=over 4 =item SYNOPSIS @@ -10078,7 +12862,7 @@ TIESCALAR classname, LIST, FETCH this, STORE this, value, DESTROY this =head2 Time::Local - efficiently compute time from local and GMT time -=over +=over 4 =item SYNOPSIS @@ -10093,7 +12877,7 @@ TIESCALAR classname, LIST, FETCH this, STORE this, value, DESTROY this =head2 Time::gmtime - by-name interface to Perl's built-in gmtime() function -=over +=over 4 =item SYNOPSIS @@ -10108,7 +12892,7 @@ function =head2 Time::localtime - by-name interface to Perl's built-in localtime() function -=over +=over 4 =item SYNOPSIS @@ -10122,7 +12906,7 @@ function =head2 Time::tm - internal object used by Time::gmtime and Time::localtime -=over +=over 4 =item SYNOPSIS @@ -10134,7 +12918,7 @@ function =head2 UNIVERSAL - base class for ALL classes (blessed references) -=over +=over 4 =item SYNOPSIS @@ -10148,7 +12932,7 @@ VAL, TYPE ), UNIVERSAL::can ( VAL, METHOD ) =head2 User::grent - by-name interface to Perl's built-in getgr*() functions -=over +=over 4 =item SYNOPSIS @@ -10163,13 +12947,13 @@ functions =head2 User::pwent - by-name interface to Perl's built-in getpw*() functions -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item System Specifics @@ -10185,9 +12969,40 @@ March 18th, 2000 =back +=head2 Win32 - Interfaces to some Win32 API Functions + +=over 4 + +=item DESCRIPTION + +=over 4 + +=item Alphabetical Listing of Win32 Functions + +Win32::AbortSystemShutdown(MACHINE), Win32::BuildNumber(), +Win32::CopyFile(FROM, TO, OVERWRITE), Win32::DomainName(), +Win32::ExpandEnvironmentStrings(STRING), Win32::FormatMessage(ERRORCODE), +Win32::FsType(), Win32::FreeLibrary(HANDLE), Win32::GetArchName(), +Win32::GetChipName(), Win32::GetCwd(), Win32::GetFullPathName(FILENAME), +Win32::GetLastError(), Win32::GetLongPathName(PATHNAME), +Win32::GetNextAvailDrive(), Win32::GetOSVersion(), +Win32::GetShortPathName(PATHNAME), Win32::GetProcAddress(INSTANCE, +PROCNAME), Win32::GetTickCount(), Win32::InitiateSystemShutdown, +Win32::IsWinNT(), Win32::IsWin95(), Win32::LoadLibrary(LIBNAME), +Win32::LoginName(), Win32::LookupAccountName(SYSTEM, ACCOUNT, DOMAIN, SID, +SIDTYPE), Win32::LookupAccountSID(SYSTEM, SID, ACCOUNT, DOMAIN, SIDTYPE), +Win32::MsgBox(MESSAGE [, FLAGS [, TITLE]]), Win32::NodeName(), +Win32::RegisterServer(LIBRARYNAME), Win32::SetCwd(NEWDIRECTORY), +Win32::SetLastError(ERROR), Win32::Sleep(TIME), Win32::Spawn(COMMAND, ARGS, +PID), Win32::UnregisterServer(LIBRARYNAME) + +=back + +=back + =head2 XSLoader - Dynamically load C libraries into Perl code -=over +=over 4 =item SYNOPSIS @@ -10202,7 +13017,7 @@ March 18th, 2000 Here should be listed all the extra programs' documentation, but they don't all have manual pages yet: -=over +=over 4 =item a2p diff --git a/contrib/perl5/pod/perltodo.pod b/contrib/perl5/pod/perltodo.pod index f22d4737f811..f38ba88bf363 100644 --- a/contrib/perl5/pod/perltodo.pod +++ b/contrib/perl5/pod/perltodo.pod @@ -85,7 +85,7 @@ We need regression/sanity tests for suidperl This value may or may not be accurate, but it certainly is eye-catching. For some things perl5 is faster than perl4, but often -the reliability and extensability have come at a cost of speed. The +the reliability and extensibility have come at a cost of speed. The benchmark suite that Gisle released earlier has been hailed as both a fantastic solution and as a source of entirely meaningless figures. Do we need to test "real applications"? Can you do so? Anyone have @@ -111,10 +111,6 @@ problem for free. =head1 Perl Language -=head2 our ($var) - -Declare global variables (lexically or otherwise). - =head2 64-bit Perl Verify complete 64 bit support so that the value of sysseek, or C<-s>, or @@ -161,7 +157,7 @@ Sarathy, I believe, did the work. Here's what he has to say: Yeah, I hope to implement it someday too. The points that were raised in TPC2 were all to do with calling DESTROY() methods, but -I think we can accomodate that by extending bless() to stash +I think we can accommodate that by extending bless() to stash extra information for objects so we track their lifetime accurately for those that want their DESTROY() to be predictable (this will be a speed hit, naturally, and will therefore be optional, naturally. :) @@ -532,14 +528,6 @@ Kurt Starsinic is working on h2ph. mjd has fixed bugs in a2p in the past. a2p apparently doesn't work on nawk and gawk extensions. Graham Barr has an Include module that does h2ph work at runtime. -=head2 POD Converters - -Brad's PodParser code needs to become part of the core, and the Pod::* -and pod2* programs rewritten to use this standard parser. Currently -the converters take different options, some behave in different -fashions, and some are more picky than others in terms of the POD -files they accept. - =head2 pod2html A short-term fix: pod2html generates absolute HTML links. Make it @@ -863,7 +851,7 @@ See Time::HiRes. =head2 autocroak? -This is the Fatal.pm module, so any builtin that that does +This is the Fatal.pm module, so any builtin that does not return success automatically die()s. If you're feeling brave, tie this in with the unified exceptions scheme. diff --git a/contrib/perl5/pod/perltoot.pod b/contrib/perl5/pod/perltoot.pod index 31a7c76353bd..38cc1f3e6597 100644 --- a/contrib/perl5/pod/perltoot.pod +++ b/contrib/perl5/pod/perltoot.pod @@ -425,6 +425,10 @@ this could be done: Notice how there's no memory to deallocate in the destructor? That's something that Perl takes care of for you all by itself. +Alternatively, you could use the Class::Data::Inheritable module from +CPAN. + + =head2 Accessing Class Data It turns out that this is not really a good way to go about handling @@ -1700,7 +1704,7 @@ as with any other local(). It would be nice to combine Alias with something like Class::Struct or Class::MethodMaker. -=head2 NOTES +=head1 NOTES =head2 Object Terminology @@ -1727,7 +1731,7 @@ as a class or object method is by usage only. You could accidentally call a class method (one expecting a string argument) on an object (one expecting a reference), or vice versa. -Z<>From the C++ perspective, all methods in Perl are virtual. +From the C++ perspective, all methods in Perl are virtual. This, by the way, is why they are never checked for function prototypes in the argument list as regular builtin and user-defined functions can be. @@ -1750,6 +1754,16 @@ L<perltie>, and L<overload>. +L<perlboot> is a kinder, gentler introduction to object-oriented +programming. + +L<perltootc> provides more detail on class data. + +Some modules which might prove interesting are Class::Accessor, +Class::Class, Class::Contract, Class::Data::Inheritable, +Class::MethodMaker and Tie::SecureHash + + =head1 AUTHOR AND COPYRIGHT Copyright (c) 1997, 1998 Tom Christiansen diff --git a/contrib/perl5/pod/perltootc.pod b/contrib/perl5/pod/perltootc.pod index 64f8233fdbcd..d2d881c99901 100644 --- a/contrib/perl5/pod/perltootc.pod +++ b/contrib/perl5/pod/perltootc.pod @@ -12,7 +12,7 @@ the class itself. Here are a few examples where class attributes might come in handy: -=over +=over 4 =item * @@ -74,6 +74,15 @@ you can elect to permit access to them from anywhere in the entire file scope, or you can limit direct data access exclusively to the methods implementing those attributes. +=head1 Class Data in a Can + +One of the easiest ways to solve a hard problem is to let someone else +do it for you! In this case, Class::Data::Inheritable (available on a +CPAN near you) offers a canned solution to the class data problem +using closures. So before you wade into this document, consider +having a look at that module. + + =head1 Class Data as Package Variables Because a class in Perl is really just a package, using package variables @@ -184,7 +193,7 @@ to which beginning Perl programmers attempt to put symbolic references, we have much better approaches, like nested hashes or hashes of arrays. But there's nothing wrong with using symbolic references to manipulate something that is meaningful only from the perspective of the package -symbol symbol table, like method names or package variables. In other +symbol table, like method names or package variables. In other words, when you want to refer to the symbol table, use symbol references. Clustering all the class attributes in one place has several advantages. @@ -1302,7 +1311,8 @@ would just confuse the examples. L<perltoot>, L<perlobj>, L<perlmod>, and L<perlbot>. -The Tie::SecureHash module from CPAN is worth checking out. +The Tie::SecureHash and Class::Data::Inheritable modules from CPAN are +worth checking out. =head1 AUTHOR AND COPYRIGHT @@ -1334,4 +1344,4 @@ object-oriented languages enforce. =head1 HISTORY -Last edit: Fri May 21 15:47:56 MDT 1999 +Last edit: Sun Feb 4 20:50:28 EST 2001 diff --git a/contrib/perl5/pod/perltrap.pod b/contrib/perl5/pod/perltrap.pod index 261a20fb03e4..753e721fcbf0 100644 --- a/contrib/perl5/pod/perltrap.pod +++ b/contrib/perl5/pod/perltrap.pod @@ -4,10 +4,11 @@ perltrap - Perl traps for the unwary =head1 DESCRIPTION -The biggest trap of all is forgetting to use the B<-w> switch; see -L<perlrun>. The second biggest trap is not making your entire program -runnable under C<use strict>. The third biggest trap is not reading -the list of changes in this version of Perl; see L<perldelta>. +The biggest trap of all is forgetting to C<use warnings> or use the B<-w> +switch; see L<perllexwarn> and L<perlrun>. The second biggest trap is not +making your entire program runnable under C<use strict>. The third biggest +trap is not reading the list of changes in this version of Perl; see +L<perldelta>. =head2 Awk Traps @@ -116,7 +117,7 @@ The C<next>, C<exit>, and C<continue> keywords work differently. The following variables work differently: Awk Perl - ARGC $#ARGV or scalar @ARGV + ARGC scalar @ARGV (compare with $#ARGV) ARGV[0] $0 FILENAME $ARGV FNR $. - something @@ -172,12 +173,6 @@ Variables begin with "$", "@" or "%" in Perl. =item * -C<printf()> does not implement the "*" format for interpolating -field widths, but it's trivial to use interpolation of double-quoted -strings to achieve the same effect. - -=item * - Comments begin with "#", not "/*". =item * @@ -193,7 +188,7 @@ ends up in C<$0>. =item * System calls such as link(), unlink(), rename(), etc. return nonzero for -success, not 0. +success, not 0. (system(), however, returns zero for success.) =item * @@ -284,8 +279,8 @@ parentheses on function calls, you won't ever get them confused. You cannot discern from mere inspection which builtins are unary operators (like chop() and chdir()) and which are list operators (like print() and unlink()). -(User-defined subroutines can be B<only> list operators, never -unary ones.) See L<perlop>. +(Unless prototyped, user-defined subroutines can B<only> be list +operators, never unary ones.) See L<perlop> and L<perlsub>. =item * @@ -392,7 +387,7 @@ Everything else. =back If you find an example of a conversion trap that is not listed here, -please submit it to Bill Middleton <F<wjm@best.com>> for inclusion. +please submit it to <F<perlbug@perl.org>> for inclusion. Also note that at least some of these can be caught with the C<use warnings> pragma or the B<-w> switch. @@ -473,7 +468,7 @@ You can't do a C<goto> into a block that is optimized away. Darn. } # perl4 prints: Here I is! - # perl5 dumps core (SEGV) + # perl5 errors: Can't "goto" into the middle of a foreach loop =item * Discontinuance @@ -592,6 +587,12 @@ Some error messages will be different. =item * Discontinuance +In Perl 4, if in list context the delimiters to the first argument of +C<split()> were C<??>, the result would be placed in C<@_> as well as +being returned. Perl 5 has more respect for your subroutine arguments. + +=item * Discontinuance + Some bugs may have been inadvertently removed. :-) =back @@ -638,7 +639,7 @@ Better parsing in perl 5 String interpolation of the C<$#array> construct differs when braces are to used around the name. - @ = (1..3); + @a = (1..3); print "${#a}"; # perl4 prints: 2 @@ -788,7 +789,19 @@ variable is localized subsequent to the assignment Assigning C<undef> to a glob has no effect in Perl 5. In Perl 4 it undefines the associated scalar (but may have other side effects -including SEGVs). +including SEGVs). Perl 5 will also warn if C<undef> is assigned to a +typeglob. (Note that assigning C<undef> to a typeglob is different +than calling the C<undef> function on a typeglob (C<undef *foo>), which +has quite a few effects. + + $foo = "bar"; + *foo = undef; + print $foo; + + # perl4 prints: + # perl4 warns: "Use of uninitialized variable" if using -w + # perl5 prints: bar + # perl5 warns: "Undefined value assigned to typeglob" if using -w =item * (Scalar String) @@ -922,26 +935,25 @@ scalar context to its arguments. =item * (list, builtin) -C<sprintf()> funkiness (array argument converted to scalar array count) -This test could be added to t/op/sprintf.t +C<sprintf()> is prototyped as ($;@), so its first argument is given scalar +context. Thus, if passed an array, it will probably not do what you want, +unlike Perl 4: @z = ('%s%s', 'foo', 'bar'); $x = sprintf(@z); - if ($x eq 'foobar') {print "ok 2\n";} else {print "not ok 2 '$x'\n";} + print $x; - # perl4 prints: ok 2 - # perl5 prints: not ok 2 + # perl4 prints: foobar + # perl5 prints: 3 -C<printf()> works fine, though: +C<printf()> works the same as it did in Perl 4, though: + @z = ('%s%s', 'foo', 'bar'); printf STDOUT (@z); - print "\n"; # perl4 prints: foobar # perl5 prints: foobar -Probably a bug. - =back =head2 Precedence Traps @@ -1013,7 +1025,7 @@ Otherwise, perl5 leaves the statement as its default precedence: open(FOO || die); # perl4 opens or dies - # perl5 errors: Precedence problem: open FOO should be open(FOO) + # perl5 opens FOO, dying only if 'FOO' is false, i.e. never =item * Precedence @@ -1089,7 +1101,7 @@ state of the searched string is lost) } sub doit{local($_) = shift; print "Got $_ "} - # perl4 prints: blah blah blah + # perl4 prints: Got blah Got blah Got blah Got blah # perl5 prints: infinite loop blah... =item * Regular Expression @@ -1103,13 +1115,21 @@ the very first time in any such closure. For instance, if you say my($left,$right) = @_; return sub { $_[0] =~ /$left stuff $right/o; }; } + $good = build_match('foo','bar'); + $bad = build_match('baz','blarch'); + print $good->('foo stuff bar') ? "ok\n" : "not ok\n"; + print $bad->('baz stuff blarch') ? "ok\n" : "not ok\n"; + print $bad->('foo stuff bar') ? "not ok\n" : "ok\n"; + +For most builds of Perl5, this will print: +ok +not ok +not ok build_match() will always return a sub which matches the contents of $left and $right as they were the I<first> time that build_match() was called, not as they are in the current call. -This is probably a bug, and may change in future versions of Perl. - =item * Regular Expression If no parentheses are used in a match, Perl4 sets C<$+> to @@ -1207,8 +1227,8 @@ calls if a subroutine by that name is defined before the compiler sees them. $SIG{'TERM'} = SeeYa; print "SIGTERM is now $SIG{'TERM'}\n"; - # perl4 prints: SIGTERM is main'SeeYa - # perl5 prints: SIGTERM is now main::1 + # perl4 prints: SIGTERM is now main'SeeYa + # perl5 prints: SIGTERM is now main::1 (and warns "Hasta la vista, baby!") Use B<-w> to catch this one @@ -1217,10 +1237,11 @@ Use B<-w> to catch this one reverse is no longer allowed as the name of a sort subroutine. sub reverse{ print "yup "; $a <=> $b } - print sort reverse a,b,c; + print sort reverse (2,1,3); - # perl4 prints: yup yup yup yup abc - # perl5 prints: abc + # perl4 prints: yup yup 123 + # perl5 prints: 123 + # perl5 warns (if using -w): Ambiguous call resolved as CORE::reverse() =item * warn() won't let you specify a filehandle. @@ -1302,7 +1323,8 @@ within certain expressions, statements, contexts, or whatever. print "To: someone@somewhere.com\n"; # perl4 prints: To:someone@somewhere.com - # perl5 errors : In string, @somewhere now must be written as \@somewhere + # perl < 5.6.1, error : In string, @somewhere now must be written as \@somewhere + # perl >= 5.6.1, warning : Possible unintended interpolation of @somewhere in string =item * Interpolation @@ -1336,14 +1358,15 @@ Note that you can C<use strict;> to ward off such trappiness under perl5. =item * Interpolation -The construct "this is $$x" used to interpolate the pid at that -point, but now apparently tries to dereference $x. C<$$> by itself still -works fine, however. +The construct "this is $$x" used to interpolate the pid at that point, but +now tries to dereference $x. C<$$> by itself still works fine, however. + $s = "a reference"; + $x = *s; print "this is $$x\n"; # perl4 prints: this is XXXx (XXX is the current pid) - # perl5 prints: this is + # perl5 prints: this is a reference =item * Interpolation @@ -1408,14 +1431,14 @@ You also have to be careful about array references. Similarly, watch out for: - $foo = "array"; + $foo = "baz"; print "\$$foo{bar}\n"; - # perl4 prints: $array{bar} + # perl4 prints: $baz{bar} # perl5 prints: $ -Perl 5 is looking for C<$array{bar}> which doesn't exist, but perl 4 is -happy just to expand $foo to "array" by itself. Watch out for this +Perl 5 is looking for C<$foo{bar}> which doesn't exist, but perl 4 is +happy just to expand $foo to "baz" by itself. Watch out for this especially in C<eval>'s. =item * Interpolation @@ -1502,7 +1525,7 @@ Same behavior if you replace C<do> with C<require>. =item * C<split> on empty string with LIMIT specified - $string = ''; + $string = ''; @list = split(/foo/, $string, 2) Perl4 returns a one element list containing the empty string but Perl5 diff --git a/contrib/perl5/pod/perlunicode.pod b/contrib/perl5/pod/perlunicode.pod index 5333ac495c08..5b0fe2faaf26 100644 --- a/contrib/perl5/pod/perlunicode.pod +++ b/contrib/perl5/pod/perlunicode.pod @@ -1,16 +1,18 @@ =head1 NAME -perlunicode - Unicode support in Perl +perlunicode - Unicode support in Perl (EXPERIMENTAL, subject to change) =head1 DESCRIPTION =head2 Important Caveat -WARNING: The implementation of Unicode support in Perl is incomplete. + WARNING: As of the 5.6.1 release, the implementation of Unicode + support in Perl is incomplete, and continues to be highly experimental. -The following areas need further work. +The following areas need further work. They are being rapidly addressed +in the 5.7.x development branch. -=over +=over 4 =item Input and Output Disciplines @@ -114,13 +116,7 @@ will typically occur directly within the literal strings as UTF-8 characters, but you can also specify a particular character with an extension of the C<\x> notation. UTF-8 characters are specified by putting the hexadecimal code within curlies after the C<\x>. For instance, -a Unicode smiley face is C<\x{263A}>. A character in the Latin-1 range -(128..255) should be written C<\x{ab}> rather than C<\xab>, since the -former will turn into a two-byte UTF-8 code, while the latter will -continue to be interpreted as generating a 8-bit byte rather than a -character. In fact, if the C<use warnings> pragma of the C<-w> switch -is turned on, it will produce a warning -that you might be generating invalid UTF-8. +a Unicode smiley face is C<\x{263A}>. =item * @@ -163,20 +159,10 @@ C<(?:\PM\pM*)>. =item * -The C<tr///> operator translates characters instead of bytes. It can also -be forced to translate between 8-bit codes and UTF-8. For instance, if you -know your input in Latin-1, you can say: - - while (<>) { - tr/\0-\xff//CU; # latin1 char to utf8 - ... - } - -Similarly you could translate your output with - - tr/\0-\x{ff}//UC; # utf8 to latin1 char - -No, C<s///> doesn't take /U or /C (yet?). +The C<tr///> operator translates characters instead of bytes. Note +that the C<tr///CU> functionality has been removed, as the interface +was a mistake. For similar functionality see pack('U0', ...) and +pack('C0', ...). =item * @@ -214,6 +200,18 @@ byte-oriented C<chr()> and C<ord()> under utf8. =item * +The bit string operators C<& | ^ ~> can operate on character data. +However, for backward compatibility reasons (bit string operations +when the characters all are less than 256 in ordinal value) one cannot +mix C<~> (the bit complement) and characters both less than 256 and +equal or greater than 256. Most importantly, the DeMorgan's laws +(C<~($x|$y) eq ~$x&~$y>, C<~($x&$y) eq ~$x|~$y>) won't hold. +Another way to look at this is that the complement cannot return +B<both> the 8-bit (byte) wide bit complement, and the full character +wide bit complement. + +=item * + And finally, C<scalar reverse()> reverses by character rather than by byte. =back diff --git a/contrib/perl5/pod/perlvar.pod b/contrib/perl5/pod/perlvar.pod index e6b6b92f5ecf..765ff0482502 100644 --- a/contrib/perl5/pod/perlvar.pod +++ b/contrib/perl5/pod/perlvar.pod @@ -174,6 +174,8 @@ example: (Mnemonic: be positive and forward looking.) This variable is read-only and dynamically scoped to the current BLOCK. +=item @LAST_MATCH_END + =item @+ This array holds the offsets of the ends of the last successful @@ -191,17 +193,22 @@ examples given for the C<@-> variable. =item $* -Set to 1 to do multi-line matching within a string, 0 to tell Perl -that it can assume that strings contain a single line, for the purpose -of optimizing pattern matches. Pattern matches on strings containing -multiple newlines can produce confusing results when C<$*> is 0. Default -is 0. (Mnemonic: * matches multiple things.) This variable -influences the interpretation of only C<^> and C<$>. A literal newline can -be searched for even when C<$* == 0>. +Set to a non-zero integer value to do multi-line matching within a +string, 0 (or undefined) to tell Perl that it can assume that strings +contain a single line, for the purpose of optimizing pattern matches. +Pattern matches on strings containing multiple newlines can produce +confusing results when C<$*> is 0 or undefined. Default is undefined. +(Mnemonic: * matches multiple things.) This variable influences the +interpretation of only C<^> and C<$>. A literal newline can be searched +for even when C<$* == 0>. Use of C<$*> is deprecated in modern Perl, supplanted by the C</s> and C</m> modifiers on pattern matching. +Assigning a non-numerical value to C<$*> triggers a warning (and makes +C<$*> act if C<$* == 0>), while assigning a numerical value to C<$*> +makes that an implicit C<int> is applied on the value. + =item input_line_number HANDLE EXPR =item $INPUT_LINE_NUMBER @@ -412,6 +419,8 @@ channel. Used with formats. (Mnemonic: lines_on_page - lines_printed.) +=item @LAST_MATCH_START + =item @- $-[0] is the offset of the start of the last successful match. @@ -439,17 +448,17 @@ After a match against some variable $var: =over 5 -=item C<$`> is the same as C<substr($var, 0, $-[0]>) +=item C<$`> is the same as C<substr($var, 0, $-[0])> -=item C<$&> is the same as C<substr($var, $-[0], $+[0] - $-[0]>) +=item C<$&> is the same as C<substr($var, $-[0], $+[0] - $-[0])> -=item C<$'> is the same as C<substr($var, $+[0]>) +=item C<$'> is the same as C<substr($var, $+[0])> =item C<$1> is the same as C<substr($var, $-[1], $+[1] - $-[1])> =item C<$2> is the same as C<substr($var, $-[2], $+[2] - $-[2])> -=item C<$3> is the same as C<substr $var, $-[3], $+[3] - $-[3]>) +=item C<$3> is the same as C<substr $var, $-[3], $+[3] - $-[3])> =back @@ -819,10 +828,10 @@ Then $^M = 'a' x (1 << 16); -would allocate a 64K buffer for use when in emergency. See the +would allocate a 64K buffer for use in an emergency. See the F<INSTALL> file in the Perl distribution for information on how to enable this option. To discourage casual use of this advanced -feature, there is no L<English> long name for this variable. +feature, there is no L<English|English> long name for this variable. =item $OSNAME @@ -925,7 +934,7 @@ This can be used to determine whether the Perl interpreter executing a script is in the right range of versions. (Mnemonic: use ^V for Version Control.) Example: - warn "No "our" declarations!\n" if $^V and $^V lt v5.6.0; + warn "No \"our\" declarations!\n" if $^V and $^V lt v5.6.0; See the documentation of C<use VERSION> and C<require VERSION> for a convenient way to fail if the running Perl interpreter is too old. diff --git a/contrib/perl5/pod/perlxs.pod b/contrib/perl5/pod/perlxs.pod index 3c0927e28d14..541f75e535f4 100644 --- a/contrib/perl5/pod/perlxs.pod +++ b/contrib/perl5/pod/perlxs.pod @@ -66,14 +66,15 @@ for the library being linked. A file in XS format starts with a C language section which goes until the first C<MODULE =Z<>> directive. Other XS directives and XSUB definitions may follow this line. The "language" used in this part of the file -is usually referred to as the XS language. +is usually referred to as the XS language. B<xsubpp> recognizes and +skips POD (see L<perlpod>) in both the C and XS language sections, which +allows the XS file to contain embedded documentation. See L<perlxstut> for a tutorial on the whole extension creation process. Note: For some extensions, Dave Beazley's SWIG system may provide a -significantly more convenient mechanism for creating the extension glue -code. See L<http://www.swig.org> for more -information. +significantly more convenient mechanism for creating the extension +glue code. See http://www.swig.org/ for more information. =head2 On The Road @@ -167,21 +168,37 @@ argument and returns a single value. sin(x) double x -When using parameters with C pointer types, as in +Optionally, one can merge the description of types and the list of +argument names, rewriting this as - double string_to_double(char *s); + double + sin(double x) + +This makes this XSUB look similar to an ANSI C declaration. An optional +semicolon is allowed after the argument list, as in + + double + sin(double x); + +Parameters with C pointer types can have different semantic: C functions +with similar declarations -there may be two ways to describe this argument to B<xsubpp>: + bool string_looks_as_a_number(char *s); + bool make_char_uppercase(char *c); + +are used in absolutely incompatible manner. Parameters to these functions +could be described B<xsubpp> like this: char * s - char &s + char &c Both these XS declarations correspond to the C<char*> C type, but they have -different semantics. It is convenient to think that the indirection operator +different semantics, see L<"The & Unary Operator">. + +It is convenient to think that the indirection operator C<*> should be considered as a part of the type and the address operator C<&> -should be considered part of the variable. See L<"The Typemap"> and -L<"The & Unary Operator"> for more info about handling qualifiers and unary -operators in C types. +should be considered part of the variable. See L<"The Typemap"> +for more info about handling qualifiers and unary operators in C types. The function name and the return type must be placed on separate lines and should be flush left-adjusted. @@ -192,9 +209,9 @@ separate lines and should be flush left-adjusted. double x sin(x) double x -The function body may be indented or left-adjusted. The following example -shows a function with its body left-adjusted. Most examples in this -document will indent the body for better readability. +The rest of the function description may be indented or left-adjusted. The +following example shows a function with its body left-adjusted. Most +examples in this document will indent the body for better readability. CORRECT @@ -261,16 +278,14 @@ mercy of this heuristics unless you use C<SV *> as return value.) =head2 The MODULE Keyword -The MODULE keyword is used to start the XS code and to -specify the package of the functions which are being -defined. All text preceding the first MODULE keyword is -considered C code and is passed through to the output -untouched. Every XS module will have a bootstrap function -which is used to hook the XSUBs into Perl. The package name -of this bootstrap function will match the value of the last -MODULE statement in the XS source files. The value of -MODULE should always remain constant within the same XS -file, though this is not required. +The MODULE keyword is used to start the XS code and to specify the package +of the functions which are being defined. All text preceding the first +MODULE keyword is considered C code and is passed through to the output with +POD stripped, but otherwise untouched. Every XS module will have a +bootstrap function which is used to hook the XSUBs into Perl. The package +name of this bootstrap function will match the value of the last MODULE +statement in the XS source files. The value of MODULE should always remain +constant within the same XS file, though this is not required. The following example will start the XS code and will place all functions in a package named RPC. @@ -365,6 +380,31 @@ Likewise, C<SETMAGIC: ENABLE> can be used to reenable it for the remainder of the OUTPUT section. See L<perlguts> for more details about 'set' magic. +=head2 The NO_OUTPUT Keyword + +The NO_OUTPUT can be placed as the first token of the XSUB. This keyword +indicates that while the C subroutine we provide an interface to has +a non-C<void> return type, the return value of this C subroutine should not +be returned from the generated Perl subroutine. + +With this keyword present L<The RETVAL Variable> is created, and in the +generated call to the subroutine this variable is assigned to, but the value +of this variable is not going to be used in the auto-generated code. + +This keyword makes sense only if C<RETVAL> is going to be accessed by the +user-supplied code. It is especially useful to make a function interface +more Perl-like, especially when the C return value is just an error condition +indicator. For example, + + NO_OUTPUT int + delete_file(char *name) + POST_CALL: + if (RETVAL != 0) + croak("Error %d while deleting file '%s'", RETVAL, name); + +Here the generated XS function returns nothing on success, and will die() +with a meaningful error message on error. + =head2 The CODE: Keyword This keyword is used in more complicated XSUBs which require @@ -534,7 +574,7 @@ the parameters in the correct order for that function. =head2 The PREINIT: Keyword The PREINIT: keyword allows extra variables to be declared immediately -before or after the declartions of the parameters from the INPUT: section +before or after the declarations of the parameters from the INPUT: section are emitted. If a variable is declared inside a CODE: section it will follow any typemap @@ -714,6 +754,91 @@ thus C<host> is initialized on the declaration line, and our assignment C<h = host> is not performed too early. Otherwise one would need to have the assignment C<h = host> in a CODE: or INIT: section.) +=head2 The IN/OUTLIST/IN_OUTLIST/OUT/IN_OUT Keywords + +In the list of parameters for an XSUB, one can precede parameter names +by the C<IN>/C<OUTLIST>/C<IN_OUTLIST>/C<OUT>/C<IN_OUT> keywords. +C<IN> keyword is the default, the other keywords indicate how the Perl +interface should differ from the C interface. + +Parameters preceded by C<OUTLIST>/C<IN_OUTLIST>/C<OUT>/C<IN_OUT> +keywords are considered to be used by the C subroutine I<via +pointers>. C<OUTLIST>/C<OUT> keywords indicate that the C subroutine +does not inspect the memory pointed by this parameter, but will write +through this pointer to provide additional return values. + +Parameters preceded by C<OUTLIST> keyword do not appear in the usage +signature of the generated Perl function. + +Parameters preceded by C<IN_OUTLIST>/C<IN_OUT>/C<OUT> I<do> appear as +parameters to the Perl function. With the exception of +C<OUT>-parameters, these parameters are converted to the corresponding +C type, then pointers to these data are given as arguments to the C +function. It is expected that the C function will write through these +pointers. + +The return list of the generated Perl function consists of the C return value +from the function (unless the XSUB is of C<void> return type or +C<The NO_OUTPUT Keyword> was used) followed by all the C<OUTLIST> +and C<IN_OUTLIST> parameters (in the order of appearance). On the +return from the XSUB the C<IN_OUT>/C<OUT> Perl parameter will be +modified to have the values written by the C function. + +For example, an XSUB + + void + day_month(OUTLIST day, IN unix_time, OUTLIST month) + int day + int unix_time + int month + +should be used from Perl as + + my ($day, $month) = day_month(time); + +The C signature of the corresponding function should be + + void day_month(int *day, int unix_time, int *month); + +The C<IN>/C<OUTLIST>/C<IN_OUTLIST>/C<IN_OUT>/C<OUT> keywords can be +mixed with ANSI-style declarations, as in + + void + day_month(OUTLIST int day, int unix_time, OUTLIST int month) + +(here the optional C<IN> keyword is omitted). + +The C<IN_OUT> parameters are identical with parameters introduced with +L<The & Unary Operator> and put into the C<OUTPUT:> section (see +L<The OUTPUT: Keyword>). The C<IN_OUTLIST> parameters are very similar, +the only difference being that the value C function writes through the +pointer would not modify the Perl parameter, but is put in the output +list. + +The C<OUTLIST>/C<OUT> parameter differ from C<IN_OUTLIST>/C<IN_OUT> +parameters only by the the initial value of the Perl parameter not +being read (and not being given to the C function - which gets some +garbage instead). For example, the same C function as above can be +interfaced with as + + void day_month(OUT int day, int unix_time, OUT int month); + +or + + void + day_month(day, unix_time, month) + int &day = NO_INIT + int unix_time + int &month = NO_INIT + OUTPUT: + day + month + +However, the generated Perl function is called in very C-ish style: + + my ($day, $month); + day_month($day, time, $month); + =head2 Variable-length Parameter Lists XSUBs can have variable-length parameter lists by specifying an ellipsis @@ -928,14 +1053,14 @@ rewrite this example as: OUTPUT: RETVAL -In fact, one can put this check into a CLEANUP: section as well. Together +In fact, one can put this check into a POST_CALL: section as well. Together with PREINIT: simplifications, this leads to: int rpcb_gettime(host) char *host time_t timep; - CLEANUP: + POST_CALL: if (RETVAL == 0) XSRETURN_UNDEF; @@ -956,6 +1081,16 @@ any CODE:, PPCODE:, or OUTPUT: blocks which are present in the XSUB. The code specified for the cleanup block will be added as the last statements in the XSUB. +=head2 The POST_CALL: Keyword + +This keyword can be used when an XSUB requires special procedures +executed after the C subroutine call is performed. When the POST_CALL: +keyword is used it must precede OUTPUT: and CLEANUP: blocks which are +present in the XSUB. + +The POST_CALL: block does not make a lot of sense when the C subroutine +call is supplied by user by providing either CODE: or PPCODE: section. + =head2 The BOOT: Keyword The BOOT: keyword is used to add code to the extension's bootstrap @@ -1233,13 +1368,19 @@ C<&> through, so the function call looks like C<rpcb_gettime(host, &timep)>. OUTPUT: timep -=head2 Inserting Comments and C Preprocessor Directives +=head2 Inserting POD, Comments and C Preprocessor Directives -C preprocessor directives are allowed within BOOT:, PREINIT: INIT:, -CODE:, PPCODE:, and CLEANUP: blocks, as well as outside the functions. -Comments are allowed anywhere after the MODULE keyword. The compiler -will pass the preprocessor directives through untouched and will remove -the commented lines. +C preprocessor directives are allowed within BOOT:, PREINIT: INIT:, CODE:, +PPCODE:, POST_CALL:, and CLEANUP: blocks, as well as outside the functions. +Comments are allowed anywhere after the MODULE keyword. The compiler will +pass the preprocessor directives through untouched and will remove the +commented lines. POD documentation is allowed at any point, both in the +C and XS language sections. POD must be terminated with a C<=cut> command; +C<xsubpp> will exit with an error if it does not. It is very unlikely that +human generated C code will be mistaken for POD, as most indenting styles +result in whitespace in front of any line starting with C<=>. Machine +generated XS files may fall into this trap unless care is taken to +ensure that a space breaks the sequence "\n=". Comments can be added to XSUBs by placing a C<#> as the first non-whitespace of a line. Care should be taken to avoid making the @@ -1391,7 +1532,7 @@ of failure. They may be candidates to return undef or an empty list in case of failure. If the failure may be detected without a call to the C function, you may want to use an INIT: section to report the failure. For failures detectable after the C -function returns one may want to use a CLEANUP: section to process the +function returns one may want to use a POST_CALL: section to process the failure. In more complicated cases use CODE: or PPCODE: sections. If many functions use the same failure indication based on the return value, @@ -1499,7 +1640,7 @@ getnetconfigent() XSUB and an object created by a normal Perl subroutine. The typemap is a collection of code fragments which are used by the B<xsubpp> compiler to map C function parameters and values to Perl values. The -typemap file may consist of three sections labeled C<TYPEMAP>, C<INPUT>, and +typemap file may consist of three sections labelled C<TYPEMAP>, C<INPUT>, and C<OUTPUT>. An unlabelled initial section is assumed to be a C<TYPEMAP> section. The INPUT section tells the compiler how to translate Perl values @@ -1510,10 +1651,10 @@ OUTPUT code fragments should be used to map a given C type to a Perl value. The section labels C<TYPEMAP>, C<INPUT>, or C<OUTPUT> must begin in the first column on a line by themselves, and must be in uppercase. -The default typemap in the C<ext> directory of the Perl source contains many -useful types which can be used by Perl extensions. Some extensions define -additional typemaps which they keep in their own directory. These -additional typemaps may reference INPUT and OUTPUT maps in the main +The default typemap in the C<lib/ExtUtils> directory of the Perl source +contains many useful types which can be used by Perl extensions. Some +extensions define additional typemaps which they keep in their own directory. +These additional typemaps may reference INPUT and OUTPUT maps in the main typemap. The B<xsubpp> compiler will allow the extension's own typemap to override any mappings which are in the default typemap. @@ -1636,4 +1777,4 @@ This document covers features supported by C<xsubpp> 1.935. Originally written by Dean Roehrich <F<roehrich@cray.com>>. -Maintained since 1996 by The Perl Porters <F<perlbug@perl.com>>. +Maintained since 1996 by The Perl Porters <F<perlbug@perl.org>>. diff --git a/contrib/perl5/pod/perlxstut.pod b/contrib/perl5/pod/perlxstut.pod index d79f4b989ad3..f06e16632690 100644 --- a/contrib/perl5/pod/perlxstut.pod +++ b/contrib/perl5/pod/perlxstut.pod @@ -5,8 +5,8 @@ perlXStut - Tutorial for writing XSUBs =head1 DESCRIPTION This tutorial will educate the reader on the steps involved in creating -a Perl extension. The reader is assumed to have access to L<perlguts> and -L<perlxs>. +a Perl extension. The reader is assumed to have access to L<perlguts>, +L<perlapi> and L<perlxs>. This tutorial starts with very simple examples and becomes more complex, with each new example adding new features. Certain concepts may not be @@ -187,7 +187,8 @@ been deleted): Manifying ./blib/man3/Mytest.3 % -You can safely ignore the line about "prototyping behavior". +You can safely ignore the line about "prototyping behavior" - it is +explained in the section "The PROTOTYPES: Keyword" in L<perlxs>. If you are on a Win32 system, and the build process fails with linker errors for functions in the C library, check if your Perl is configured @@ -476,7 +477,7 @@ section on the argument stack. In general, it's not a good idea to write extensions that modify their input parameters, as in Example 3. Instead, you should probably return multiple values in an array and let the caller handle them (we'll do this in a later -example). However, in order to better accomodate calling pre-existing C +example). However, in order to better accommodate calling pre-existing C routines, which often do modify their input parameters, this behavior is tolerated. @@ -681,7 +682,8 @@ the meaning of these elements, pay attention to the line which reads Anything before this line is plain C code which describes which headers to include, and defines some convenience functions. No translations are -performed on this part, it goes into the generated output C file as is. +performed on this part, apart from having embedded POD documentation +skipped over (see L<perlpod>) it goes into the generated output C file as is. Anything after this line is the description of XSUB functions. These descriptions are translated by B<xsubpp> into C code which @@ -1056,9 +1058,143 @@ the stack is I<always> large enough to take one return value. =back -=head2 EXAMPLE 6 (Coming Soon) +=head2 EXAMPLE 6 -Passing in and returning references to arrays and/or hashes +In this example, we will accept a reference to an array as an input +parameter, and return a reference to an array of hashes. This will +demonstrate manipulation of complex Perl data types from an XSUB. + +This extension is somewhat contrived. It is based on the code in +the previous example. It calls the statfs function multiple times, +accepting a reference to an array of filenames as input, and returning +a reference to an array of hashes containing the data for each of the +filesystems. + +Return to the Mytest directory and add the following code to the end of +Mytest.xs: + + SV * + multi_statfs(paths) + SV * paths + INIT: + AV * results; + I32 numpaths = 0; + int i, n; + struct statfs buf; + + if ((!SvROK(paths)) + || (SvTYPE(SvRV(paths)) != SVt_PVAV) + || ((numpaths = av_len((AV *)SvRV(paths))) < 0)) + { + XSRETURN_UNDEF; + } + results = (AV *)sv_2mortal((SV *)newAV()); + CODE: + for (n = 0; n <= numpaths; n++) { + HV * rh; + STRLEN l; + char * fn = SvPV(*av_fetch((AV *)SvRV(paths), n, 0), l); + + i = statfs(fn, &buf); + if (i != 0) { + av_push(results, newSVnv(errno)); + continue; + } + + rh = (HV *)sv_2mortal((SV *)newHV()); + + hv_store(rh, "f_bavail", 8, newSVnv(buf.f_bavail), 0); + hv_store(rh, "f_bfree", 7, newSVnv(buf.f_bfree), 0); + hv_store(rh, "f_blocks", 8, newSVnv(buf.f_blocks), 0); + hv_store(rh, "f_bsize", 7, newSVnv(buf.f_bsize), 0); + hv_store(rh, "f_ffree", 7, newSVnv(buf.f_ffree), 0); + hv_store(rh, "f_files", 7, newSVnv(buf.f_files), 0); + hv_store(rh, "f_type", 6, newSVnv(buf.f_type), 0); + + av_push(results, newRV((SV *)rh)); + } + RETVAL = newRV((SV *)results); + OUTPUT: + RETVAL + +And add the following code to test.pl, while incrementing the "1..11" +string in the BEGIN block to "1..13": + + $results = Mytest::multi_statfs([ '/', '/blech' ]); + print ((ref $results->[0]) ? "ok 12\n" : "not ok 12\n"); + print ((! ref $results->[1]) ? "ok 13\n" : "not ok 13\n"); + +=head2 New Things in this Example + +There are a number of new concepts introduced here, described below: + +=over 4 + +=item * + +This function does not use a typemap. Instead, we declare it as accepting +one SV* (scalar) parameter, and returning an SV* value, and we take care of +populating these scalars within the code. Because we are only returning +one value, we don't need a C<PPCODE:> directive - instead, we use C<CODE:> +and C<OUTPUT:> directives. + +=item * + +When dealing with references, it is important to handle them with caution. +The C<INIT:> block first checks that +C<SvROK> returns true, which indicates that paths is a valid reference. It +then verifies that the object referenced by paths is an array, using C<SvRV> +to dereference paths, and C<SvTYPE> to discover its type. As an added test, +it checks that the array referenced by paths is non-empty, using the C<av_len> +function (which returns -1 if the array is empty). The XSRETURN_UNDEF macro +is used to abort the XSUB and return the undefined value whenever all three of +these conditions are not met. + +=item * + +We manipulate several arrays in this XSUB. Note that an array is represented +internally by an AV* pointer. The functions and macros for manipulating +arrays are similar to the functions in Perl: C<av_len> returns the highest +index in an AV*, much like $#array; C<av_fetch> fetches a single scalar value +from an array, given its index; C<av_push> pushes a scalar value onto the +end of the array, automatically extending the array as necessary. + +Specifically, we read pathnames one at a time from the input array, and +store the results in an output array (results) in the same order. If +statfs fails, the element pushed onto the return array is the value of +errno after the failure. If statfs succeeds, though, the value pushed +onto the return array is a reference to a hash containing some of the +information in the statfs structure. + +As with the return stack, it would be possible (and a small performance win) +to pre-extend the return array before pushing data into it, since we know +how many elements we will return: + + av_extend(results, numpaths); + +=item * + +We are performing only one hash operation in this function, which is storing +a new scalar under a key using C<hv_store>. A hash is represented by an HV* +pointer. Like arrays, the functions for manipulating hashes from an XSUB +mirror the functionality available from Perl. See L<perlguts> and L<perlapi> +for details. + +=item * + +To create a reference, we use the C<newRV> function. Note that you can +cast an AV* or an HV* to type SV* in this case (and many others). This +allows you to take references to arrays, hashes and scalars with the same +function. Conversely, the C<SvRV> function always returns an SV*, which may +need to be be cast to the appropriate type if it is something other than a +scalar (check with C<SvTYPE>). + +=item * + +At this point, xsubpp is doing very little work - the differences between +Mytest.xs and Mytest.c are minimal. + +=back =head2 EXAMPLE 7 (Coming Soon) @@ -1112,7 +1248,7 @@ Some systems may have installed Perl version 5 as "perl5". =head1 See also -For more information, consult L<perlguts>, L<perlxs>, L<perlmod>, +For more information, consult L<perlguts>, L<perlapi>, L<perlxs>, L<perlmod>, and L<perlpod>. =head1 Author diff --git a/contrib/perl5/pod/pod2latex.PL b/contrib/perl5/pod/pod2latex.PL index 71115f3f2144..3d3cfb65bcdd 100644 --- a/contrib/perl5/pod/pod2latex.PL +++ b/contrib/perl5/pod/pod2latex.PL @@ -34,676 +34,314 @@ $Config{startperl} # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; -# -# pod2latex, version 1.1 -# by Taro Kawagish (kawagish@imslab.co.jp), Jan 11, 1995. -# -# pod2latex filters Perl pod documents to LaTeX documents. -# -# What pod2latex does: -# 1. Pod file 'perl_doc_entry.pod' is filtered to 'perl_doc_entry.tex'. -# 2. Indented paragraphs are translated into -# '\begin{verbatim} ... \end{verbatim}'. -# 3. '=head1 heading' command is translated into '\section{heading}' -# 4. '=head2 heading' command is translated into '\subsection*{heading}' -# 5. '=over N' command is translated into -# '\begin{itemize}' if following =item starts with *, -# '\begin{enumerate}' if following =item starts with 1., -# '\begin{description}' if else. -# (indentation level N is ignored.) -# 6. '=item * heading' command is translated into '\item heading', -# '=item 1. heading' command is translated into '\item heading', -# '=item heading' command(other) is translated into '\item[heading]'. -# 7. '=back' command is translated into -# '\end{itemize}' if started with '\begin{itemize}', -# '\end{enumerate}' if started with '\begin{enumerate}', -# '\end{description}' if started with '\begin{description}'. -# 8. other paragraphs are translated into strings with TeX special characters -# escaped. -# 9. In heading text, and other paragraphs, the following translation of pod -# quotes are done, and then TeX special characters are escaped after that. -# I<text> to {\em text\/}, -# B<text> to {\bf text}, -# S<text> to text1, -# where text1 is a string with blank characters replaced with ~, -# C<text> to {\tt text2}, -# where text2 is a string with TeX special characters escaped to -# obtain a literal printout, -# E<text> (HTML escape) to TeX escaped string, -# L<text> to referencing string as is done by pod2man, -# F<file> to {\em file\/}, -# Z<> to a null string, -# 10. those headings are indexed: -# '=head1 heading' => \section{heading}\index{heading} -# '=head2 heading' => \subsection*{heading}\index{heading} -# only when heading does not match frequent patterns such as -# DESCRIPTION, DIAGNOSTICS,... -# '=item heading' => \item{heading}\index{heading} -# -# Usage: -# pod2latex perl_doc_entry.pod -# this will write to a file 'perl_doc_entry.tex'. -# -# To LaTeX: -# The following commands need to be defined in the preamble of the LaTeX -# document: -# \def\C++{{\rm C\kern-.05em\raise.3ex\hbox{\footnotesize ++}}} -# \def\underscore{\leavevmode\kern.04em\vbox{\hrule width 0.4em height 0.3pt}} -# and \parindent should be set zero: -# \setlength{\parindent}{0pt} -# -# Note: -# This script was written modifing pod2man. -# -# Bug: -# If HTML escapes E<text> other than E<amp>,E<lt>,E<gt>,E<quot> are used -# in C<>, translation will produce wrong character strings. -# Translation of HTML escapes of various European accents might be wrong. - - -# TeX special characters. -##$tt_ables = "!@*()-=+|;:'\"`,./?<>"; -$backslash_escapables = "#\$%&{}_"; -$backslash_escapables2 = "#\$%&{}"; # except _ -##$nonverbables = "^\\~"; -##$bracketesc = "[]"; -##@tex_verb_fences = unpack("aaaaaaaaa","|#@!*+?:;"); - -@head1_freq_patterns # =head1 patterns which need not be index'ed - = ("AUTHOR","Author","BUGS","DATE","DESCRIPTION","DIAGNOSTICS", - "ENVIRONMENT","EXAMPLES","FILES","INTRODUCTION","NAME","NOTE", - "SEE ALSO","SYNOPSIS","WARNING"); - -$indent = 0; - -# parse the pods, produce LaTeX. - -use Pod::Plainer; -open(POD,"-|") or Pod::Plainer -> new() -> parse_from_file($ARGV[0]), exit; - -($pod=$ARGV[0]) =~ s/\.pod$//; -open(LATEX,">$pod.tex"); -&do_hdr(); - -$cutting = 1; -$begun = ""; -$/ = ""; # record separator is blank lines -while (<POD>) { - if ($cutting) { - next unless /^=/; - $cutting = 0; - } - if ($begun) { - if (/^=end\s+$begun/) { - $begun = ""; - } - elsif ($begun =~ /^(tex|latex)$/) { - print LATEX $_; - } - next; - } - chop; - length || (print LATEX "\n") && next; - - # translate indented lines as a verabatim paragraph - if (/^\s/) { - @lines = split(/\n/); - print LATEX "\\begin{verbatim}\n"; - for (@lines) { - 1 while s - {^( [^\t]* ) \t ( \t* ) } - { $1 . ' ' x (8 - (length($1)%8) + 8*(length($2))) }ex; - print LATEX $_,"\n"; - } - print LATEX "\\end{verbatim}\n"; - next; - } - if (/^=for\s+(\S+)\s*/s) { - if ($1 eq "tex" or $1 eq "latex") { - print LATEX $',"\n"; - } else { - # ignore unknown for - } - next; - } - elsif (/^=begin\s+(\S+)\s*/s) { - $begun = $1; - if ($1 eq "tex" or $1 eq "latex") { - print LATEX $'."\n"; - } - next; - } +# pod2latex conversion program + +use Pod::LaTeX; +use Pod::Find qw/ pod_find /; +use Pod::Usage; +use Getopt::Long; +use File::Basename; + +# Read command line arguments + +my %options = ( + "help" => 0, + "man" => 0, + "sections" => [], + "full" => 0, + "out" => undef, + "verbose" => 0, + "modify" => 0, + ); + +GetOptions(\%options, + "help", + "man", + "verbose", + "full", + "sections=s@", + "out=s", + "modify", + ) || pod2usage(2); + +pod2usage(1) if ($options{help}); +pod2usage(-verbose => 2) if ($options{man}); + + +# Read all the files from the command line +my @files = @ARGV; + +# Now find which ones are real pods and convert +# directories to their contents. + +# Extract the pods from each arg since some of them might +# be directories +# This is not as efficient as using pod_find to search through +# everything at once but it allows us to preserve the order +# supplied by the user + +my @pods; +foreach my $arg (@files) { + my %pods = pod_find($arg); + push(@pods, sort keys %pods); +} - # preserve '=item' line with pod quotes as they are. - if (/^=item/) { - ($bareitem = $_) =~ s/^=item\s*//; - } +# Abort if nothing to do +if ($#pods == -1) { + warn "None of the supplied Pod files actually exist\n"; + exit; +} - # check for things that'll hosed our noremap scheme; affects $_ - &init_noremap(); - - # expand strings "func()" as pod quotes. - if (!/^=item/) { - # first hide pod escapes. - # escaped strings are mapped into the ones with the MSB's on. - s/([A-Z]<[^<>]*>)/noremap($1)/ge; - - # func() is a reference to a perl function - s{\b([:\w]+\(\))}{I<$1>}g; - # func(n) is a reference to a man page - s{(\w+)(\([^\s,\051]+\))}{I<$1>$2}g; - # convert simple variable references -# s/([\$\@%][\w:]+)/C<$1>/g; -# s/\$[\w:]+\[[0-9]+\]/C<$&>/g; - - if (m{ ([\-\w]+\([^\051]*?[\@\$,][^\051]*?\)) - }x && $` !~ /([LCI]<[^<>]*|-)$/ && !/^=\w/) - { - warn "``$1'' should be a [LCI]<$1> ref"; - } - while (/(-[a-zA-Z])\b/g && $` !~ /[\w\-]$/) { - warn "``$1'' should be [CB]<$1> ref"; - } - - # put back pod quotes so we get the inside of <> processed; - $_ = &clear_noremap($_); - } - # process TeX special characters - - # First hide HTML quotes E<> since they can be included in C<>. - s/(E<[^<>]+>)/noremap($1)/ge; - - # Then hide C<> type literal quotes. - # String inside of C<> will later be expanded into {\tt ..} strings - # with TeX special characters escaped as needed. - s/(C<[^<>]*>)/&noremap($1)/ge; - - # Next escape TeX special characters including other pod quotes B< >,... - # - # NOTE: s/re/&func($str)/e evaluates $str just once in perl5. - # (in perl4 evaluation takes place twice before getting passed to func().) - - # - hyphen => --- - s/(\S+)(\s+)-+(\s+)(\S+)/"$1".&noremap(" --- ")."$4"/ge; - # '-', '--', "-" => '{\tt -}', '{\tt --}', "{\tt -}" -## s/("|')(\s*)(-+)(\s*)\1/&noremap("$1$2\{\\tt $3\}$4$1")/ge; -## changed Wed Jan 25 15:26:39 JST 1995 - # '-', '--', "-" => '$-$', '$--$', "$-$" - s/(\s+)(['"])(-+)([^'"\-]*)\2(\s+|[,.])/"$1$2".&noremap("\$$3\$")."$4$2$5"/ge; - s/(\s+)(['"])([^'"\-]*)(-+)(\s*)\2(\s+|[,.])/"$1$2$3".&noremap("\$$4\$")."$5$2$6"/ge; - # (--|-) => ($--$|$-$) - s/(\s+)\((-+)([=@%\$\+\\\|\w]*)(-*)([=@%\$\+\\\|\w]*)\)(\s+|[,.])/"$1\(".&noremap("\$$2\$")."$3".&noremap("\$$4\$")."$5\)$6"/ge; - # numeral - => $-$ - s/(\(|[0-9]+|\s+)-(\s*\(?\s*[0-9]+)/&noremap("$1\$-\$$2")/ge; - # -- in quotes => two separate - - s/B<([^<>]*)--([^<>]*)>/&noremap("B<$1\{\\tt --\}$2>")/ge; - - # backslash escapable characters except _. - s/([$backslash_escapables2])/&noremap("\\$1")/ge; - s/_/&noremap("\\underscore{}")/ge; # a litle thicker than \_. - # quote TeX special characters |, ^, ~, \. - s/\|/&noremap("\$|\$")/ge; - s/\^/&noremap("\$\\hat{\\hspace{0.4em}}\$")/ge; - s/\~/&noremap("\$\\tilde{\\hspace{0.4em}}\$")/ge; - s/\\/&noremap("\$\\backslash{}\$")/ge; - # quote [ and ] to be used in \item[] - s/([\[\]])/&noremap("{\\tt $1}")/ge; - # characters need to be treated differently in TeX - # keep * if an item heading - s/^(=item[ \t]+)[*]((.|\n)*)/"$1" . &noremap("*") . "$2"/ge; - s/[*]/&noremap("\$\\ast\$")/ge; # other * - - # hide other pod quotes. - s/([ABD-Z]<[^<>]*>)/&noremap($1)/ge; - - # escape < and > as math strings, - # now that we are done with hiding pod <> quotes. - s/</&noremap("\$<\$")/ge; - s/>/&noremap("\$>\$")/ge; - - # put it back so we get the <> processed again; - $_ = &clear_noremap($_); - - - # Expand pod quotes recursively: - # (1) type face directives [BIFS]<[^<>]*> to appropriate TeX commands, - # (2) L<[^<>]*> to reference strings, - # (3) C<[^<>]*> to TeX literal quotes, - # (4) HTML quotes E<> inside of C<> quotes. - - # Hide E<> again since they can be included in C<>. - s/(E<[^<>]+>)/noremap($1)/ge; - - $maxnest = 10; - while ($maxnest-- && /[A-Z]</) { - - # bold and italic quotes - s/B<([^<>]*)>/"{\\bf $1}"/eg; - s#I<([^<>]*)>#"{\\em $1\\/}"#eg; - - # files and filelike refs in italics - s#F<([^<>]*)>#"{\\em $1\\/}"#eg; - - # no break quote -- usually we want C<> for this - s/S<([^<>]*)>/&nobreak($1)/eg; - - # LREF: a manpage(3f) - s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the {\\em $1\\/}$2 manpage:g; - - # LREF: an =item on another manpage - s{ - L<([^/]+)/([:\w]+(\(\))?)> - } {the C<$2> entry in the I<$1> manpage}gx; - - # LREF: an =item on this manpage - s{ - ((?:L</([:\w]+(\(\))?)> - (,?\s+(and\s+)?)?)+) - } { &internal_lrefs($1) }gex; - - # LREF: a =head2 (head1?), maybe on a manpage, maybe right here - # the "func" can disambiguate - s{ - L<(?:([a-zA-Z]\S+?) /)?"?(.*?)"?> - }{ - do { - $1 # if no $1, assume it means on this page. - ? "the section on I<$2> in the I<$1> manpage" - : "the section on I<$2>" - } - }gex; - - s/X<([^<>]*)>/\\index{$1}/g; - - s/Z<>/\\&/g; # the "don't format me" thing - - # comes last because not subject to reprocessing - s{ - C<([^<>]*)> - }{ - do { - ($str = $1) =~ tr/\200-\377/\000-\177/; #normalize hidden stuff - # expand HTML escapes if any; - # WARNING: if HTML escapes other than E<amp>,E<lt>,E<gt>, - # E<quot> are in C<>, they will not be printed correctly. - $str = &expand_HTML_escapes($str); - $strverb = &alltt($str); # Tex verbatim escape of a string. - &noremap("$strverb"); - } - }gex; - -# if ( /C<([^<>]*)/ ) { -# $str = $1; -# if ($str !~ /\|/) { # if includes | -# s/C<([^<>]*)>/&noremap("\\verb|$str|")/eg; -# } else { -# print STDERR "found \| in C<.*> at paragraph $.\n"; -# # find a character not contained in $str to use it as a -# # separator of the \verb -# ($chars = $str) =~ s/(\W)/\\$1/g; -# ## ($chars = $str) =~ s/([\$<>,\|"'\-^{}()*+?\\])/\\$1/g; -# @fence = grep(!/[ $chars]/,@tex_verb_fences); -# s/C<([^<>]*)>/&noremap("\\verb$fence[0]$str$fence[0]")/eg; -# } -# } - } +# If $options{'out'} is set we are processing to a single output file +my $multi_documents; +if (exists $options{'out'} && defined $options{'out'}) { + $multi_documents = 0; +} else { + $multi_documents = 1; +} + +# If the output file is not specified it is assumed that +# a single output file is required per input file using +# a .tex extension rather than any exisiting extension + +if ($multi_documents) { + + # Case where we just generate one input per output + + foreach my $pod (@pods) { + + if (-f $pod) { + + my $output = $pod; + $output = basename($output, '.pm', '.pod','.pl') . '.tex'; + # Create a new parser object + my $parser = new Pod::LaTeX( + AddPreamble => $options{'full'}, + AddPostamble => $options{'full'}, + MakeIndex => $options{'full'}, + TableOfContents => $options{'full'}, + ReplaceNAMEwithSection => $options{'modify'}, + UniqueLabels => $options{'modify'}, + ); - # process each pod command - if (s/^=//) { # if a command - s/\n/ /g; - ($cmd, $rest) = split(' ', $_, 2); - $rest =~ s/^\s*//; - $rest =~ s/\s*$//; - - if (defined $rest) { - &escapes; - } - - $rest = &clear_noremap($rest); - $rest = &expand_HTML_escapes($rest); - - if ($cmd eq 'cut') { - $cutting = 1; - $lastcmd = 'cut'; - } - elsif ($cmd eq 'head1') { # heading type 1 - $rest =~ s/^\s*//; $rest =~ s/\s*$//; - print LATEX "\n\\subsection*{$rest}"; - # put index entry - ($index = $rest) =~ s/^(An?\s+|The\s+)//i; # remove 'A' and 'The' - # index only those heads not matching the frequent patterns. - foreach $pat (@head1_freq_patterns) { - if ($index =~ /^$pat/) { - goto freqpatt; - } - } - print LATEX "%\n\\index{$index}\n" if ($index); - freqpatt: - $lastcmd = 'head1'; - } - elsif ($cmd eq 'head2') { # heading type 2 - $rest =~ s/^\s*//; $rest =~ s/\s*$//; - print LATEX "\n\\subsubsection*{$rest}"; - # put index entry - ($index = $rest) =~ s/^(An?\s+|The\s+)//i; # remove 'A' and 'The' - $index =~ s/^Example\s*[1-9][0-9]*\s*:\s*//; # remove 'Example :' - print LATEX "%\n\\index{$index}\n" if ($index); - $lastcmd = 'head2'; - } - elsif ($cmd eq 'over') { # 1 level within a listing environment - push(@indent,$indent); - $indent = $rest + 0; - $lastcmd = 'over'; - } - elsif ($cmd eq 'back') { # 1 level out of a listing environment - $indent = pop(@indent); - warn "Unmatched =back\n" unless defined $indent; - $listingcmd = pop(@listingcmd); - print LATEX "\n\\end{$listingcmd}\n" if ($listingcmd); - $lastcmd = 'back'; - } - elsif ($cmd eq 'item') { # an item paragraph starts - if ($lastcmd eq 'over') { # if we have just entered listing env - # see what type of list environment we are in. - if ($rest =~ /^[0-9]\.?/) { # if numeral heading - $listingcmd = 'enumerate'; - } elsif ($rest =~ /^\*\s*/) { # if * heading - $listingcmd = 'itemize'; - } elsif ($rest =~ /^[^*]/) { # if other headings - $listingcmd = 'description'; - } else { - warn "unknown list type for item $rest"; - } - print LATEX "\n\\begin{$listingcmd}\n"; - push(@listingcmd,$listingcmd); - } elsif ( !@listingcmd ) { - warn "Illegal '=item' command without preceding 'over':"; - warn "=item $bareitem"; - } - - if ($listingcmd eq 'enumerate') { - $rest =~ s/^[0-9]+\.?\s*//; # remove numeral heading - print LATEX "\n\\item"; - print LATEX "{\\bf $rest}" if $rest; - } elsif ($listingcmd eq 'itemize') { - $rest =~ s/^\*\s*//; # remove * heading - print LATEX "\n\\item"; - print LATEX "{\\bf $rest}" if $rest; - } else { # description item - print LATEX "\n\\item[$rest]"; - } - $lastcmd = 'item'; - $rightafter_item = 'yes'; - - # check if the item heading is short or long. - ($itemhead = $rest) =~ s/{\\bf (\S*)}/$1/g; - if (length($itemhead) < 4) { - $itemshort = "yes"; - } else { - $itemshort = "no"; - } - # write index entry - if ($pod =~ "perldiag") { # skip 'perldiag.pod' - goto noindex; - } - # strip out the item of pod quotes and get a plain text entry - $bareitem =~ s/\n/ /g; # remove newlines - $bareitem =~ s/\s*$//; # remove trailing space - $bareitem =~ s/[A-Z]<([^<>]*)>/$1/g; # remove <> quotes - ($index = $bareitem) =~ s/^\*\s+//; # remove leading '*' - $index =~ s/^(An?\s+|The\s+)//i; # remove 'A' and 'The' - $index =~ s/^\s*[1-9][0-9]*\s*[.]\s*$//; # remove numeral only - $index =~ s/^\s*\w\s*$//; # remove 1 char only's - # quote ", @ and ! with " to be used in makeindex. - $index =~ s/"/""/g; # quote " - $index =~ s/@/"@/g; # quote @ - $index =~ s/!/"!/g; # quote ! - ($rest2=$rest) =~ s/^\*\s+//; # remove * - $rest2 =~ s/"/""/g; # quote " - $rest2 =~ s/@/"@/g; # quote @ - $rest2 =~ s/!/"!/g; # quote ! - if ($pod =~ "(perlfunc|perlvar)") { # when doc is perlfunc,perlvar - # take only the 1st word of item heading - $index =~ s/^([^{}\s]*)({.*})?([^{}\s]*)\s+.*/\1\2\3/; - $rest2 =~ s/^([^{}\s]*)({.*})?([^{}\s]*)\s+.*/\1\2\3/; - } - if ($index =~ /[A-Za-z\$@%]/) { - # write \index{plain_text_entry@TeX_string_entry} - print LATEX "%\n\\index{$index\@$rest2}%\n"; - } - noindex: - ; - } - elsif ($cmd eq 'pod') { - ; # recognise the pod directive, as no op (hs) - } - elsif ($cmd eq 'pod') { - ; # recognise the pod directive, as no op (hs) - } - else { - warn "Unrecognized directive: $cmd\n"; - } + # Select sections if supplied + $parser->select(@{ $options{'sections'}}) + if @{$options{'sections'}}; + + # Derive the input file from the output file + $parser->parse_from_file($pod, $output); + + print "Written output to $output\n" if $options{'verbose'}; + + } else { + warn "File $pod not found\n"; } - else { # if not command - &escapes; - $_ = &clear_noremap($_); - $_ = &expand_HTML_escapes($_); - - # if the present paragraphs follows an =item declaration, - # put a line break. - if ($lastcmd eq 'item' && - $rightafter_item eq 'yes' && $itemshort eq "no") { - print LATEX "\\hfil\\\\"; - $rightafter_item = 'no'; - } - print LATEX "\n",$_; + + } +} else { + + # Case where we want everything to be in a single document + + # Need to open the output file ourselves + my $output = $options{'out'}; + $output .= '.tex' unless $output =~ /\.tex$/; + + # Use auto-vivified file handle in perl 5.6 + use Symbol; + my $outfh = gensym; + open ($outfh, ">$output") || die "Could not open output file: $!\n"; + + # Flag to indicate whether we have converted at least one file + # indicates how many files have been converted + my $converted = 0; + + # Loop over the input files + foreach my $pod (@pods) { + + if (-f $pod) { + + warn "Converting $pod\n" if $options{'verbose'}; + + # Open the file (need the handle) + # Use auto-vivified handle in perl 5.6 + my $podfh = gensym; + open ($podfh, "<$pod") || die "Could not open pod file $pod: $!\n"; + + # if this is the first file to be converted we may want to add + # a preamble (controlled by command line option) + if ($converted == 0 && $options{'full'}) { + $preamble = 1; + } else { + $preamble = 0; + } + + # if this is the last file to be converted may want to add + # a postamble (controlled by command line option) + # relies on a previous pass to check existence of all pods we + # are converting. + my $postamble = ( ($converted == $#pods && $options{'full'}) ? 1 : 0 ); + + # Open parser object + # May want to start with a preamble for the first one and + # end with an index for the last + my $parser = new Pod::LaTeX( + MakeIndex => $options{'full'}, + TableOfContents => $preamble, + ReplaceNAMEwithSection => $options{'modify'}, + UniqueLabels => $options{'modify'}, + StartWithNewPage => $options{'full'}, + AddPreamble => $preamble, + AddPostamble => $postamble, + ); + + # Store the file name for error messages + # This is a kluge that breaks the data hiding of the object + $parser->{_INFILE} = $pod; + + # Select sections if supplied + $parser->select(@{ $options{'sections'}}) + if @{$options{'sections'}}; + + # Parse it + $parser->parse_from_filehandle($podfh, $outfh); + + # We have converted at least one file + $converted++; + + } else { + warn "File $pod not found\n"; } -} -print LATEX "\n"; -close(POD); -close(LATEX); + } + # Should unlink the file if we didn't convert anything! + # dont check for return status of unlink + # since there is not a lot to be done if the unlink failed + # and the program does not rely upon it. + unlink "$output" unless $converted; -######################################################################### + # If verbose + warn "Converted $converted files\n" if $options{'verbose'}; -sub do_hdr { - print LATEX "% LaTeX document produced by pod2latex from \"$pod.pod\".\n"; - print LATEX "% The followings need be defined in the preamble of this document:\n"; - print LATEX "%\\def\\C++{{\\rm C\\kern-.05em\\raise.3ex\\hbox{\\footnotesize ++}}}\n"; - print LATEX "%\\def\\underscore{\\leavevmode\\kern.04em\\vbox{\\hrule width 0.4em height 0.3pt}}\n"; - print LATEX "%\\setlength{\\parindent}{0pt}\n"; - print LATEX "\n"; - $podq = &escape_tex_specials("\U$pod\E"); - print LATEX "\\section{$podq}%\n"; - print LATEX "\\index{$podq}"; - print LATEX "\n"; } -sub nobreak { - my $string = shift; - $string =~ s/ +/~/g; # TeX no line break - $string; -} +exit; -sub noremap { - local($thing_to_hide) = shift; - $thing_to_hide =~ tr/\000-\177/\200-\377/; - return $thing_to_hide; -} +__END__ -sub init_noremap { - # escape high bit characters in input stream - s/([\200-\377])/"E<".ord($1).">"/ge; -} +=head1 NAME -sub clear_noremap { - local($tmp) = shift; - $tmp =~ tr/\200-\377/\000-\177/; - return $tmp; -} +pod2latex - convert pod documentation to latex format -sub expand_HTML_escapes { - local($s) = $_[0]; - $s =~ s { E<((\d+)|([A-Za-z]+))> } - { - do { - defined($2) - ? do { chr($2) } - : - exists $HTML_Escapes{$3} - ? do { $HTML_Escapes{$3} } - : do { - warn "Unknown escape: $& in $_"; - "E<$1>"; - } - } - }egx; - return $s; -} +=head1 SYNOPSIS -sub escapes { - # make C++ into \C++, which is to be defined as - # \def\C++{{\rm C\kern-.05em\raise.3ex\hbox{\footnotesize ++}}} - s/\bC\+\+/\\C++{}/g; -} + pod2latex *.pm -# Translate a string into a TeX \tt string to obtain a verbatim print out. -# TeX special characters are escaped by \. -# This can be used inside of LaTeX command arguments. -# We don't use LaTeX \verb since it doesn't work inside of command arguments. -sub alltt { - local($str) = shift; - # other chars than #,\,$,%,&,{,},_,\,^,~ ([ and ] included). - $str =~ s/([^${backslash_escapables}\\\^\~]+)/&noremap("$&")/eg; - # chars #,\,$,%,&,{,} => \# , ... - $str =~ s/([$backslash_escapables2])/&noremap("\\$&")/eg; - # chars _,\,^,~ => \char`\_ , ... - $str =~ s/_/&noremap("\\char`\\_")/eg; - $str =~ s/\\/&noremap("\\char`\\\\")/ge; - $str =~ s/\^/\\char`\\^/g; - $str =~ s/\~/\\char`\\~/g; - - $str =~ tr/\200-\377/\000-\177/; # put back - $str = "{\\tt ".$str."}"; # make it a \tt string - return $str; -} + pod2latex -out mytex.tex *.pod -sub escape_tex_specials { - local($str) = shift; - # other chars than #,\,$,%,&,{,}, _,\,^,~ ([ and ] included). - # backslash escapable characters #,\,$,%,&,{,} except _. - $str =~ s/([$backslash_escapables2])/&noremap("\\$1")/ge; - $str =~ s/_/&noremap("\\underscore{}")/ge; # \_ is too thin. - # quote TeX special characters |, ^, ~, \. - $str =~ s/\|/&noremap("\$|\$")/ge; - $str =~ s/\^/&noremap("\$\\hat{\\hspace{0.4em}}\$")/ge; - $str =~ s/\~/&noremap("\$\\tilde{\\hspace{0.4em}}\$")/ge; - $str =~ s/\\/&noremap("\$\\backslash{}\$")/ge; - # characters need to be treated differently in TeX - # * - $str =~ s/[*]/&noremap("\$\\ast\$")/ge; - # escape < and > as math string, - $str =~ s/</&noremap("\$<\$")/ge; - $str =~ s/>/&noremap("\$>\$")/ge; - $str =~ tr/\200-\377/\000-\177/; # put back - return $str; -} + pod2latex -full -sections 'DESCRIPTION|NAME' SomeDir -sub internal_lrefs { - local($_) = shift; - - s{L</([^>]+)>}{$1}g; - my(@items) = split( /(?:,?\s+(?:and\s+)?)/ ); - my $retstr = "the "; - my $i; - for ($i = 0; $i <= $#items; $i++) { - $retstr .= "C<$items[$i]>"; - $retstr .= ", " if @items > 2 && $i != $#items; - $retstr .= " and " if $i+2 == @items; - } - $retstr .= " entr" . ( @items > 1 ? "ies" : "y" ) - . " elsewhere in this document"; +=head1 DESCRIPTION - return $retstr; -} +C<pod2latex> is a program to convert POD format documentation +(L<perlpod>) into latex. It can process multiple input documents at a +time and either generate a latex file per input document or a single +combined output file. + +=head1 OPTIONS AND ARGUMENTS + +This section describes the supported command line options. Minium +matching is supported. + +=over 4 + +=item B<-out> + +Name of the output file to be used. If there are multiple input pods +it is assumed that the intention is to write all translated output +into a single file. C<.tex> is appended if not present. If the +argument is not supplied, a single document will be created for each +input file. + +=item B<-full> + +Creates a complete C<latex> file that can be processed immediately +(unless C<=for/=begin> directives are used that rely on extra packages). +Table of contents and index generation commands are included in the +wrapper C<latex> code. + +=item B<-sections> + +Specify pod sections to include (or remove if negated) in the +translation. See L<Pod::Select/"SECTION SPECIFICATIONS"> for the +format to use for I<section-spec>. This option may be given multiple +times on the command line.This is identical to the similar option in +the C<podselect()> command. + +=item B<-modify> + +This option causes the output C<latex> to be slightly +modified from the input pod such that when a C<=head1 NAME> +is encountered a section is created containing the actual +pod name (rather than B<NAME>) and all subsequent C<=head1> +directives are treated as subsections. This has the advantage +that the description of a module will be in its own section +which is helpful for including module descriptions in documentation. +Also forces C<latex> label and index entries to be prefixed by the +name of the module. + +=item B<-help> + +Print a brief help message and exit. + +=item B<-man> + +Print the manual page and exit. + +=item B<-verbose> + +Print information messages as each document is processed. + +=back + +=head1 BUGS + +Known bugs are: + +=over 4 + +=item * + +Cross references between documents are not resolved when multiple +pod documents are converted into a single output C<latex> file. + +=item * + +Functions and variables are not automatically recognized +and they will therefore not be marked up in any special way +unless instructed by an explicit pod command. + +=back + +=head1 SEE ALSO + +L<Pod::LaTeX> + +=head1 AUTHOR + +Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt> + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +Copyright (C) 2000 Tim Jenness. + +=cut -# map of HTML escapes to TeX escapes. -BEGIN { -%HTML_Escapes = ( - 'amp' => '&', # ampersand - 'lt' => '<', # left chevron, less-than - 'gt' => '>', # right chevron, greater-than - 'quot' => '"', # double quote - - "Aacute" => "\\'{A}", # capital A, acute accent - "aacute" => "\\'{a}", # small a, acute accent - "Acirc" => "\\^{A}", # capital A, circumflex accent - "acirc" => "\\^{a}", # small a, circumflex accent - "AElig" => '\\AE', # capital AE diphthong (ligature) - "aelig" => '\\ae', # small ae diphthong (ligature) - "Agrave" => "\\`{A}", # capital A, grave accent - "agrave" => "\\`{a}", # small a, grave accent - "Aring" => '\\u{A}', # capital A, ring - "aring" => '\\u{a}', # small a, ring - "Atilde" => '\\~{A}', # capital A, tilde - "atilde" => '\\~{a}', # small a, tilde - "Auml" => '\\"{A}', # capital A, dieresis or umlaut mark - "auml" => '\\"{a}', # small a, dieresis or umlaut mark - "Ccedil" => '\\c{C}', # capital C, cedilla - "ccedil" => '\\c{c}', # small c, cedilla - "Eacute" => "\\'{E}", # capital E, acute accent - "eacute" => "\\'{e}", # small e, acute accent - "Ecirc" => "\\^{E}", # capital E, circumflex accent - "ecirc" => "\\^{e}", # small e, circumflex accent - "Egrave" => "\\`{E}", # capital E, grave accent - "egrave" => "\\`{e}", # small e, grave accent - "ETH" => '\\OE', # capital Eth, Icelandic - "eth" => '\\oe', # small eth, Icelandic - "Euml" => '\\"{E}', # capital E, dieresis or umlaut mark - "euml" => '\\"{e}', # small e, dieresis or umlaut mark - "Iacute" => "\\'{I}", # capital I, acute accent - "iacute" => "\\'{i}", # small i, acute accent - "Icirc" => "\\^{I}", # capital I, circumflex accent - "icirc" => "\\^{i}", # small i, circumflex accent - "Igrave" => "\\`{I}", # capital I, grave accent - "igrave" => "\\`{i}", # small i, grave accent - "Iuml" => '\\"{I}', # capital I, dieresis or umlaut mark - "iuml" => '\\"{i}', # small i, dieresis or umlaut mark - "Ntilde" => '\\~{N}', # capital N, tilde - "ntilde" => '\\~{n}', # small n, tilde - "Oacute" => "\\'{O}", # capital O, acute accent - "oacute" => "\\'{o}", # small o, acute accent - "Ocirc" => "\\^{O}", # capital O, circumflex accent - "ocirc" => "\\^{o}", # small o, circumflex accent - "Ograve" => "\\`{O}", # capital O, grave accent - "ograve" => "\\`{o}", # small o, grave accent - "Oslash" => "\\O", # capital O, slash - "oslash" => "\\o", # small o, slash - "Otilde" => "\\~{O}", # capital O, tilde - "otilde" => "\\~{o}", # small o, tilde - "Ouml" => '\\"{O}', # capital O, dieresis or umlaut mark - "ouml" => '\\"{o}', # small o, dieresis or umlaut mark - "szlig" => '\\ss{}', # small sharp s, German (sz ligature) - "THORN" => '\\L', # capital THORN, Icelandic - "thorn" => '\\l',, # small thorn, Icelandic - "Uacute" => "\\'{U}", # capital U, acute accent - "uacute" => "\\'{u}", # small u, acute accent - "Ucirc" => "\\^{U}", # capital U, circumflex accent - "ucirc" => "\\^{u}", # small u, circumflex accent - "Ugrave" => "\\`{U}", # capital U, grave accent - "ugrave" => "\\`{u}", # small u, grave accent - "Uuml" => '\\"{U}', # capital U, dieresis or umlaut mark - "uuml" => '\\"{u}', # small u, dieresis or umlaut mark - "Yacute" => "\\'{Y}", # capital Y, acute accent - "yacute" => "\\'{y}", # small y, acute accent - "yuml" => '\\"{y}', # small y, dieresis or umlaut mark -); -} !NO!SUBS! close OUT or die "Can't close $file: $!"; diff --git a/contrib/perl5/pod/pod2man.PL b/contrib/perl5/pod/pod2man.PL index bf35cff4ccbd..f320a3c295e8 100644 --- a/contrib/perl5/pod/pod2man.PL +++ b/contrib/perl5/pod/pod2man.PL @@ -36,7 +36,7 @@ $Config{startperl} print OUT <<'!NO!SUBS!'; # pod2man -- Convert POD data to formatted *roff input. -# $Id: pod2man.PL,v 1.2 2000/03/16 21:08:23 eagle Exp $ +# $Id: pod2man.PL,v 1.4 2000/11/19 05:47:46 eagle Exp $ # # Copyright 1999, 2000 by Russ Allbery <rra@stanford.edu> # @@ -63,7 +63,8 @@ my %options; Getopt::Long::config ('bundling_override'); GetOptions (\%options, 'section|s=s', 'release|r=s', 'center|c=s', 'date|d=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s', - 'fixedbolditalic=s', 'official|o', 'lax|l', 'help|h') or exit 1; + 'fixedbolditalic=s', 'official|o', 'quotes|q=s', 'lax|l', + 'help|h') or exit 1; pod2usage (0) if $options{help}; # Official sets --center, but don't override things explicitly set. @@ -71,10 +72,15 @@ if ($options{official} && !defined $options{center}) { $options{center} = 'Perl Programmers Reference Guide'; } -# Initialize and run the formatter. +# Initialize and run the formatter, pulling a pair of input and output off +# at a time. my $parser = Pod::Man->new (%options); -$parser->parse_from_file (@ARGV); - +my @files; +do { + @files = splice (@ARGV, 0, 2); + $parser->parse_from_file (@files); +} while (@ARGV); + __END__ =head1 NAME @@ -86,8 +92,8 @@ pod2man - Convert POD data to formatted *roff input pod2man [B<--section>=I<manext>] [B<--release>=I<version>] [B<--center>=I<string>] [B<--date>=I<string>] [B<--fixed>=I<font>] [B<--fixedbold>=I<font>] [B<--fixeditalic>=I<font>] -[B<--fixedbolditalic>=I<font>] [B<--official>] [B<--lax>] [I<input> -[I<output>]] +[B<--fixedbolditalic>=I<font>] [B<--official>] [B<--lax>] +[B<--quotes>=I<quotes>] [I<input> [I<output>] ...] pod2man B<--help> @@ -100,7 +106,10 @@ terminal using nroff(1), normally via man(1), or printing using troff(1). I<input> is the file to read for POD source (the POD can be embedded in code). If I<input> isn't given, it defaults to STDIN. I<output>, if given, is the file to which to write the formatted output. If I<output> isn't -given, the formatted output is written to STDOUT. +given, the formatted output is written to STDOUT. Several POD files can be +processed in the same B<pod2man> invocation (saving module load and compile +times) by providing multiple pairs of I<input> and I<output> files on the +command line. B<--section>, B<--release>, B<--center>, B<--date>, and B<--official> can be used to set the headers and footers to use; if not given, Pod::Man will @@ -173,6 +182,19 @@ POD checking functionality is not yet implemented in Pod::Man. Set the default header to indicate that this page is part of the standard Perl release, if B<--center> is not also given. +=item B<-q> I<quotes>, B<--quotes>=I<quotes> + +Sets the quote marks used to surround CE<lt>> text to I<quotes>. If +I<quotes> is a single character, it is used as both the left and right +quote; if I<quotes> is two characters, the first character is used as the +left quote and the second as the right quoted; and if I<quotes> is four +characters, the first two are used as the left quote and the second two as +the right quote. + +I<quotes> may also be set to the special value C<none>, in which case no +quote marks are added around CE<lt>> text (but the font is still changed for +troff output). + =item B<-r>, B<--release> Set the centered footer. By default, this is the version of Perl you run diff --git a/contrib/perl5/pod/pod2text.PL b/contrib/perl5/pod/pod2text.PL index c5460aef30e4..7b5727decc0b 100644 --- a/contrib/perl5/pod/pod2text.PL +++ b/contrib/perl5/pod/pod2text.PL @@ -75,7 +75,8 @@ my %options; $options{sentence} = 0; Getopt::Long::config ('bundling'); GetOptions (\%options, 'alt|a', 'color|c', 'help|h', 'indent|i=i', - 'loose|l', 'sentence|s', 'termcap|t', 'width|w=i') or exit 1; + 'loose|l', 'overstrike|o', 'quotes|q=s', 'sentence|s', + 'termcap|t', 'width|w=i') or exit 1; pod2usage (1) if $options{help}; # Figure out what formatter we're going to use. -c overrides -t. @@ -88,8 +89,11 @@ if ($options{color}) { } elsif ($options{termcap}) { $formatter = 'Pod::Text::Termcap'; require Pod::Text::Termcap; +} elsif ($options{overstrike}) { + $formatter = 'Pod::Text::Overstrike'; + require Pod::Text::Overstrike; } -delete @options{'color', 'termcap'}; +delete @options{'color', 'termcap', 'overstrike'}; # Initialize and run the formatter. my $parser = $formatter->new (%options); @@ -103,7 +107,8 @@ pod2text - Convert POD data to formatted ASCII text =head1 SYNOPSIS -pod2text [B<-aclst>] [B<-i> I<indent>] [B<-w> I<width>] [I<input> [I<output>]] +pod2text [B<-aclost>] [B<-i> I<indent>] [B<-q> I<quotes>] [B<-w> I<width>] +[I<input> [I<output>]] pod2text B<-h> @@ -148,6 +153,25 @@ printed after C<=head1>, although one is still printed after C<=head2>, because this is the expected formatting for manual pages; if you're formatting arbitrary text documents, using this option is recommended. +=item B<-o>, B<--overstrike> + +Format the output with overstruck printing. Bold text is rendered as +character, backspace, character. Italics and file names are rendered as +underscore, backspace, character. Many pagers, such as B<less>, know how +to convert this to bold or underlined text. + +=item B<-q> I<quotes>, B<--quotes>=I<quotes> + +Sets the quote marks used to surround CE<lt>> text to I<quotes>. If +I<quotes> is a single character, it is used as both the left and right +quote; if I<quotes> is two characters, the first character is used as the +left quote and the second as the right quoted; and if I<quotes> is four +characters, the first two are used as the left quote and the second two as +the right quote. + +I<quotes> may also be set to the special value C<none>, in which case no +quote marks are added around CE<lt>> text. + =item B<-s>, B<--sentence> Assume each sentence ends with two spaces and try to preserve that spacing. diff --git a/contrib/perl5/pod/pod2usage.PL b/contrib/perl5/pod/pod2usage.PL index e0f70b2ca4fa..1c1296a19f3b 100644 --- a/contrib/perl5/pod/pod2usage.PL +++ b/contrib/perl5/pod/pod2usage.PL @@ -39,7 +39,7 @@ print OUT <<'!NO!SUBS!'; ############################################################################# # pod2usage -- command to print usage messages from embedded pod docs # -# Copyright (c) 1996-1999 by Bradford Appleton. All rights reserved. +# Copyright (c) 1996-2000 by Bradford Appleton. All rights reserved. # This file is part of "PodParser". PodParser is free software; # you can redistribute it and/or modify it under the same terms # as Perl itself. diff --git a/contrib/perl5/pod/podchecker.PL b/contrib/perl5/pod/podchecker.PL index a7f96434ca68..20d5e94c2e02 100644 --- a/contrib/perl5/pod/podchecker.PL +++ b/contrib/perl5/pod/podchecker.PL @@ -39,7 +39,7 @@ print OUT <<'!NO!SUBS!'; ############################################################################# # podchecker -- command to invoke the podchecker function in Pod::Checker # -# Copyright (c) 1998-1999 by Bradford Appleton. All rights reserved. +# Copyright (c) 1998-2000 by Bradford Appleton. All rights reserved. # This file is part of "PodParser". PodParser is free software; # you can redistribute it and/or modify it under the same terms # as Perl itself. @@ -70,7 +70,9 @@ Print the manual page and exit. =item B<-warnings> B<-nowarnings> -Turn on/off printing of warnings. +Turn on/off printing of warnings. Repeating B<-warnings> increases the +warning level, i.e. more warnings are printed. Currently increasing to +level two causes flagging of unescaped "E<lt>,E<gt>" characters. =item I<file> @@ -85,6 +87,8 @@ syntax errors in the POD documentation and will print any errors it find to STDERR. At the end, it will print a status message indicating the number of errors found. +Directories are ignored, an appropriate warning message is printed. + B<podchecker> invokes the B<podchecker()> function exported by B<Pod::Checker> Please see L<Pod::Checker/podchecker()> for more details. @@ -124,24 +128,34 @@ use Pod::Usage; use Getopt::Long; ## Define options -my %options = ( - "help" => 0, - "man" => 0, - "warnings" => 1, -); +my %options; ## Parse options -GetOptions(\%options, "help", "man", "warnings!") || pod2usage(2); +GetOptions(\%options, qw(help man warnings+ nowarnings)) || pod2usage(2); pod2usage(1) if ($options{help}); pod2usage(-verbose => 2) if ($options{man}); +if($options{nowarnings}) { + $options{warnings} = 0; +} +elsif(!defined $options{warnings}) { + $options{warnings} = 1; # default is warnings on +} + ## Dont default to STDIN if connected to a terminal pod2usage(2) if ((@ARGV == 0) && (-t STDIN)); ## Invoke podchecker() my $status = 0; -@ARGV = ("<&STDIN") unless(@ARGV); +@ARGV = qw(-) unless(@ARGV); for (@ARGV) { + if($_ eq '-') { + $_ = "<&STDIN"; + } + elsif(-d) { + warn "podchecker: Warning: Ignoring directory '$_'\n"; + next; + } my $s = podchecker($_, undef, '-warnings' => $options{warnings}); if($s > 0) { # errors occurred diff --git a/contrib/perl5/pod/podselect.PL b/contrib/perl5/pod/podselect.PL index f2ba80a73b59..b6b8c9b9e430 100644 --- a/contrib/perl5/pod/podselect.PL +++ b/contrib/perl5/pod/podselect.PL @@ -39,7 +39,7 @@ print OUT <<'!NO!SUBS!'; ############################################################################# # podselect -- command to invoke the podselect function in Pod::Select # -# Copyright (c) 1996-1999 by Bradford Appleton. All rights reserved. +# Copyright (c) 1996-2000 by Bradford Appleton. All rights reserved. # This file is part of "PodParser". PodParser is free software; # you can redistribute it and/or modify it under the same terms # as Perl itself. diff --git a/contrib/perl5/pod/roffitall b/contrib/perl5/pod/roffitall index 018c0b3475b1..396da6fae235 100644 --- a/contrib/perl5/pod/roffitall +++ b/contrib/perl5/pod/roffitall @@ -27,70 +27,82 @@ case "$1" in ;; esac +# NEEDS TO BE BUILT BASED ON Makefile (or Makefile.SH, should such happen) toroff=` echo \ - $mandir/perl.1 \ - $mandir/perldata.1 \ - $mandir/perlsyn.1 \ - $mandir/perlop.1 \ - $mandir/perlre.1 \ - $mandir/perlrun.1 \ - $mandir/perlfunc.1 \ - $mandir/perlvar.1 \ - $mandir/perlsub.1 \ - $mandir/perlopentut.1 \ - $mandir/perlmod.1 \ - $mandir/perlmodlib.1 \ - $mandir/perlmodinstall.1 \ - $mandir/perlfork.1 \ - $mandir/perlform.1 \ - $mandir/perllocale.1 \ - $mandir/perlref.1 \ - $mandir/perlreftut.1 \ - $mandir/perldsc.1 \ - $mandir/perllol.1 \ - $mandir/perlboot.1 \ - $mandir/perltoot.1 \ - $mandir/perlobj.1 \ - $mandir/perltie.1 \ - $mandir/perlbot.1 \ - $mandir/perlipc.1 \ - $mandir/perlthrtut.1 \ - $mandir/perldebguts.1 \ - $mandir/perldebug.1 \ - $mandir/perlnumber.1 \ - $mandir/perldiag.1 \ - $mandir/perlsec.1 \ - $mandir/perltrap.1 \ - $mandir/perlport.1 \ - $mandir/perlstyle.1 \ - $mandir/perlpod.1 \ - $mandir/perlbook.1 \ - $mandir/perlembed.1 \ - $mandir/perlapio.1 \ - $mandir/perlxs.1 \ - $mandir/perlxstut.1 \ - $mandir/perlguts.1 \ - $mandir/perlcall.1 \ - $mandir/perlcompile.1 \ - $mandir/perltodo.1 \ - $mandir/perlapi.1 \ - $mandir/perlintern.1 \ - $mandir/perlhack.1 \ - $mandir/perlhist.1 \ - $mandir/perldelta.1 \ - $mandir/perl5004delta.1 \ - $mandir/perl5005delta.1 \ - $mandir/perlfaq.1 \ - $mandir/perlfaq1.1 \ - $mandir/perlfaq2.1 \ - $mandir/perlfaq3.1 \ - $mandir/perlfaq4.1 \ - $mandir/perlfaq5.1 \ - $mandir/perlfaq6.1 \ - $mandir/perlfaq7.1 \ - $mandir/perlfaq8.1 \ - $mandir/perlfaq9.1 \ + $mandir/perl.1 \ + $mandir/perl5004delta.1 \ + $mandir/perl5005delta.1 \ + $mandir/perl56delta.1 \ + $mandir/perlapi.1 \ + $mandir/perlapio.1 \ + $mandir/perlbook.1 \ + $mandir/perlboot.1 \ + $mandir/perlbot.1 \ + $mandir/perlcall.1 \ + $mandir/perlcompile.1 \ + $mandir/perldata.1 \ + $mandir/perldbmfilter.1 \ + $mandir/perldebguts.1 \ + $mandir/perldebug.1 \ + $mandir/perldelta.1 \ + $mandir/perldiag.1 \ + $mandir/perldsc.1 \ + $mandir/perlembed.1 \ + $mandir/perlfaq.1 \ + $mandir/perlfaq1.1 \ + $mandir/perlfaq2.1 \ + $mandir/perlfaq3.1 \ + $mandir/perlfaq4.1 \ + $mandir/perlfaq5.1 \ + $mandir/perlfaq6.1 \ + $mandir/perlfaq7.1 \ + $mandir/perlfaq8.1 \ + $mandir/perlfaq9.1 \ + $mandir/perlfilter.1 \ + $mandir/perlfork.1 \ + $mandir/perlform.1 \ + $mandir/perlfunc.1 \ + $mandir/perlguts.1 \ + $mandir/perlhack.1 \ + $mandir/perlhist.1 \ + $mandir/perlintern.1 \ + $mandir/perlipc.1 \ + $mandir/perllexwarn.1 \ + $mandir/perllocale.1 \ + $mandir/perllol.1 \ + $mandir/perlmod.1 \ + $mandir/perlmodinstall.1 \ + $mandir/perlmodlib.1 \ + $mandir/perlnewmod.1 \ + $mandir/perlnumber.1 \ + $mandir/perlobj.1 \ + $mandir/perlop.1 \ + $mandir/perlopentut.1 \ + $mandir/perlpod.1 \ + $mandir/perlport.1 \ + $mandir/perlre.1 \ + $mandir/perlref.1 \ + $mandir/perlreftut.1 \ + $mandir/perlrequick.1 \ + $mandir/perlretut.1 \ + $mandir/perlrun.1 \ + $mandir/perlsec.1 \ + $mandir/perlstyle.1 \ + $mandir/perlsub.1 \ + $mandir/perlsyn.1 \ + $mandir/perlthrtut.1 \ + $mandir/perltie.1 \ + $mandir/perltoc.1 \ + $mandir/perltodo.1 \ + $mandir/perltoot.1 \ + $mandir/perltootc.1 \ + $mandir/perltrap.1 \ + $mandir/perlunicode.1 \ + $mandir/perlutil.1 \ + $mandir/perlvar.1 \ + $mandir/perlxs.1 \ + $mandir/perlxstut.1 \ \ $mandir/a2p.1 \ $mandir/c2ph.1 \ diff --git a/contrib/perl5/pp.c b/contrib/perl5/pp.c index a59664e4d1f8..cc9a05389ce8 100644 --- a/contrib/perl5/pp.c +++ b/contrib/perl5/pp.c @@ -1,6 +1,6 @@ /* pp.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. @@ -82,10 +82,6 @@ static double UV_MAX_cxux = ((double)UV_MAX); /* variations on pp_null */ -#ifdef I_UNISTD -#include <unistd.h> -#endif - /* XXX I can't imagine anyone who doesn't have this actually _needs_ it, since pid_t is an integral type. --AD 2/20/1998 @@ -96,7 +92,7 @@ extern Pid_t getpid (void); PP(pp_stub) { - djSP; + dSP; if (GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef); RETURN; @@ -111,13 +107,18 @@ PP(pp_scalar) PP(pp_padav) { - djSP; dTARGET; + dSP; dTARGET; if (PL_op->op_private & OPpLVAL_INTRO) SAVECLEARSV(PL_curpad[PL_op->op_targ]); EXTEND(SP, 1); if (PL_op->op_flags & OPf_REF) { PUSHs(TARG); RETURN; + } else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); + PUSHs(TARG); + RETURN; } if (GIMME == G_ARRAY) { I32 maxarg = AvFILL((AV*)TARG) + 1; @@ -145,7 +146,7 @@ PP(pp_padav) PP(pp_padhv) { - djSP; dTARGET; + dSP; dTARGET; I32 gimme; XPUSHs(TARG); @@ -153,6 +154,11 @@ PP(pp_padhv) SAVECLEARSV(PL_curpad[PL_op->op_targ]); if (PL_op->op_flags & OPf_REF) RETURN; + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); + RETURN; + } gimme = GIMME_V; if (gimme == G_ARRAY) { RETURNOP(do_kv()); @@ -178,7 +184,7 @@ PP(pp_padany) PP(pp_rv2gv) { - djSP; dTOPss; + dSP; dTOPss; if (SvROK(sv)) { wasref: @@ -198,7 +204,7 @@ PP(pp_rv2gv) else { if (SvTYPE(sv) != SVt_PVGV) { char *sym; - STRLEN n_a; + STRLEN len; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -236,13 +242,17 @@ PP(pp_rv2gv) report_uninit(); RETSETUNDEF; } - sym = SvPV(sv, n_a); + sym = SvPV(sv,len); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV); - if (!sv) + if (!sv + && (!is_gv_magical(sym,len,0) + || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV)))) + { RETSETUNDEF; + } } else { if (PL_op->op_private & HINT_STRICT_REFS) @@ -259,7 +269,7 @@ PP(pp_rv2gv) PP(pp_rv2sv) { - djSP; dTOPss; + dSP; dTOPss; if (SvROK(sv)) { wasref: @@ -276,7 +286,7 @@ PP(pp_rv2sv) else { GV *gv = (GV*)sv; char *sym; - STRLEN n_a; + STRLEN len; if (SvTYPE(gv) != SVt_PVGV) { if (SvGMAGICAL(sv)) { @@ -292,13 +302,17 @@ PP(pp_rv2sv) report_uninit(); RETSETUNDEF; } - sym = SvPV(sv, n_a); + sym = SvPV(sv, len); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV); - if (!gv) + if (!gv + && (!is_gv_magical(sym,len,0) + || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV)))) + { RETSETUNDEF; + } } else { if (PL_op->op_private & HINT_STRICT_REFS) @@ -320,7 +334,7 @@ PP(pp_rv2sv) PP(pp_av2arylen) { - djSP; + dSP; AV *av = (AV*)TOPs; SV *sv = AvARYLEN(av); if (!sv) { @@ -334,9 +348,9 @@ PP(pp_av2arylen) PP(pp_pos) { - djSP; dTARGET; dPOPss; + dSP; dTARGET; dPOPss; - if (PL_op->op_flags & OPf_MOD) { + if (PL_op->op_flags & OPf_MOD || LVRET) { if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); sv_magic(TARG, Nullsv, '.', Nullch, 0); @@ -370,7 +384,7 @@ PP(pp_pos) PP(pp_rv2cv) { - djSP; + dSP; GV *gv; HV *stash; @@ -380,8 +394,12 @@ PP(pp_rv2cv) if (cv) { if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); - if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv)) - DIE(aTHX_ "Can't modify non-lvalue subroutine call"); + if ((PL_op->op_private & OPpLVAL_INTRO)) { + if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE))) + cv = GvCV(gv); + if (!CvLVALUE(cv)) + DIE(aTHX_ "Can't modify non-lvalue subroutine call"); + } } else cv = (CV*)&PL_sv_undef; @@ -391,7 +409,7 @@ PP(pp_rv2cv) PP(pp_prototype) { - djSP; + dSP; CV *cv; HV *stash; GV *gv; @@ -457,7 +475,7 @@ PP(pp_prototype) PP(pp_anoncode) { - djSP; + dSP; CV* cv = (CV*)PL_curpad[PL_op->op_targ]; if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); @@ -468,14 +486,14 @@ PP(pp_anoncode) PP(pp_srefgen) { - djSP; + dSP; *SP = refto(*SP); RETURN; } PP(pp_refgen) { - djSP; dMARK; + dSP; dMARK; if (GIMME != G_ARRAY) { if (++MARK <= SP) *MARK = *SP; @@ -525,7 +543,7 @@ S_refto(pTHX_ SV *sv) PP(pp_ref) { - djSP; dTARGET; + dSP; dTARGET; SV *sv; char *pv; @@ -545,7 +563,7 @@ PP(pp_ref) PP(pp_bless) { - djSP; + dSP; HV *stash; if (MAXARG == 1) @@ -570,7 +588,7 @@ PP(pp_gelem) SV *sv; SV *tmpRef; char *elem; - djSP; + dSP; STRLEN n_a; sv = POPs; @@ -631,7 +649,7 @@ PP(pp_gelem) PP(pp_study) { - djSP; dPOPss; + dSP; dPOPss; register unsigned char *s; register I32 pos; register I32 ch; @@ -693,7 +711,7 @@ PP(pp_study) PP(pp_trans) { - djSP; dTARG; + dSP; dTARG; SV *sv; if (PL_op->op_flags & OPf_STACKED) @@ -711,7 +729,7 @@ PP(pp_trans) PP(pp_schop) { - djSP; dTARGET; + dSP; dTARGET; do_chop(TARG, TOPs); SETTARG; RETURN; @@ -719,23 +737,24 @@ PP(pp_schop) PP(pp_chop) { - djSP; dMARK; dTARGET; - while (SP > MARK) - do_chop(TARG, POPs); + dSP; dMARK; dTARGET; dORIGMARK; + while (MARK < SP) + do_chop(TARG, *++MARK); + SP = ORIGMARK; PUSHTARG; RETURN; } PP(pp_schomp) { - djSP; dTARGET; + dSP; dTARGET; SETi(do_chomp(TOPs)); RETURN; } PP(pp_chomp) { - djSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; register I32 count = 0; while (SP > MARK) @@ -746,7 +765,7 @@ PP(pp_chomp) PP(pp_defined) { - djSP; + dSP; register SV* sv; sv = POPs; @@ -776,7 +795,7 @@ PP(pp_defined) PP(pp_undef) { - djSP; + dSP; SV *sv; if (!PL_op->op_private) { @@ -808,7 +827,7 @@ PP(pp_undef) case SVt_PVFM: { /* let user-undef'd sub keep its identity */ - GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv)); + GV* gv = CvGV((CV*)sv); cv_undef((CV*)sv); CvGV((CV*)sv) = gv; } @@ -843,7 +862,7 @@ PP(pp_undef) PP(pp_predec) { - djSP; + dSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && @@ -860,7 +879,7 @@ PP(pp_predec) PP(pp_postinc) { - djSP; dTARGET; + dSP; dTARGET; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); @@ -881,7 +900,7 @@ PP(pp_postinc) PP(pp_postdec) { - djSP; dTARGET; + dSP; dTARGET; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); @@ -902,7 +921,7 @@ PP(pp_postdec) PP(pp_pow) { - djSP; dATARGET; tryAMAGICbin(pow,opASSIGN); + dSP; dATARGET; tryAMAGICbin(pow,opASSIGN); { dPOPTOPnnrl; SETn( Perl_pow( left, right) ); @@ -912,7 +931,7 @@ PP(pp_pow) PP(pp_multiply) { - djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); + dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); { dPOPTOPnnrl; SETn( left * right ); @@ -922,7 +941,7 @@ PP(pp_multiply) PP(pp_divide) { - djSP; dATARGET; tryAMAGICbin(div,opASSIGN); + dSP; dATARGET; tryAMAGICbin(div,opASSIGN); { dPOPPOPnnrl; NV value; @@ -951,7 +970,7 @@ PP(pp_divide) PP(pp_modulo) { - djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { UV left; UV right; @@ -961,7 +980,7 @@ PP(pp_modulo) NV dright; NV dleft; - if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { + if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { IV i = SvIVX(POPs); right = (right_neg = (i < 0)) ? -i : i; } @@ -973,7 +992,7 @@ PP(pp_modulo) dright = -dright; } - if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { + if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { IV i = SvIVX(POPs); left = (left_neg = (i < 0)) ? -i : i; } @@ -1051,9 +1070,9 @@ PP(pp_modulo) PP(pp_repeat) { - djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); + dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); { - register I32 count = POPi; + register IV count = POPi; if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { dMARK; I32 items = SP - MARK; @@ -1076,12 +1095,13 @@ PP(pp_repeat) SP -= items; } else { /* Note: mark already snarfed by pp_list */ - SV *tmpstr; + SV *tmpstr = POPs; STRLEN len; + bool isutf; - tmpstr = POPs; SvSetSV(TARG, tmpstr); SvPV_force(TARG, len); + isutf = DO_UTF8(TARG); if (count != 1) { if (count < 1) SvCUR_set(TARG, 0); @@ -1092,7 +1112,10 @@ PP(pp_repeat) } *SvEND(TARG) = '\0'; } - (void)SvPOK_only(TARG); + if (isutf) + (void)SvPOK_only_UTF8(TARG); + else + (void)SvPOK_only(TARG); PUSHTARG; } RETURN; @@ -1101,7 +1124,7 @@ PP(pp_repeat) PP(pp_subtract) { - djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); + dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { dPOPTOPnnrl_ul; SETn( left - right ); @@ -1111,7 +1134,7 @@ PP(pp_subtract) PP(pp_left_shift) { - djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); + dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); { IV shift = POPi; if (PL_op->op_private & HINT_INTEGER) { @@ -1128,7 +1151,7 @@ PP(pp_left_shift) PP(pp_right_shift) { - djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); + dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); { IV shift = POPi; if (PL_op->op_private & HINT_INTEGER) { @@ -1145,7 +1168,7 @@ PP(pp_right_shift) PP(pp_lt) { - djSP; tryAMAGICbinSET(lt,0); + dSP; tryAMAGICbinSET(lt,0); { dPOPnv; SETs(boolSV(TOPn < value)); @@ -1155,7 +1178,7 @@ PP(pp_lt) PP(pp_gt) { - djSP; tryAMAGICbinSET(gt,0); + dSP; tryAMAGICbinSET(gt,0); { dPOPnv; SETs(boolSV(TOPn > value)); @@ -1165,7 +1188,7 @@ PP(pp_gt) PP(pp_le) { - djSP; tryAMAGICbinSET(le,0); + dSP; tryAMAGICbinSET(le,0); { dPOPnv; SETs(boolSV(TOPn <= value)); @@ -1175,7 +1198,7 @@ PP(pp_le) PP(pp_ge) { - djSP; tryAMAGICbinSET(ge,0); + dSP; tryAMAGICbinSET(ge,0); { dPOPnv; SETs(boolSV(TOPn >= value)); @@ -1185,7 +1208,7 @@ PP(pp_ge) PP(pp_ne) { - djSP; tryAMAGICbinSET(ne,0); + dSP; tryAMAGICbinSET(ne,0); { dPOPnv; SETs(boolSV(TOPn != value)); @@ -1195,19 +1218,12 @@ PP(pp_ne) PP(pp_ncmp) { - djSP; dTARGET; tryAMAGICbin(ncmp,0); + dSP; dTARGET; tryAMAGICbin(ncmp,0); { dPOPTOPnnrl; I32 value; -#ifdef __osf__ /* XXX Configure probe for isnan and isnanl needed XXX */ -#if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) -#define Perl_isnan isnanl -#else -#define Perl_isnan isnan -#endif -#endif -#ifdef __osf__ /* XXX fix in 5.6.1 --jhi */ +#ifdef Perl_isnan if (Perl_isnan(left) || Perl_isnan(right)) { SETs(&PL_sv_undef); RETURN; @@ -1232,7 +1248,7 @@ PP(pp_ncmp) PP(pp_slt) { - djSP; tryAMAGICbinSET(slt,0); + dSP; tryAMAGICbinSET(slt,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) @@ -1245,7 +1261,7 @@ PP(pp_slt) PP(pp_sgt) { - djSP; tryAMAGICbinSET(sgt,0); + dSP; tryAMAGICbinSET(sgt,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) @@ -1258,7 +1274,7 @@ PP(pp_sgt) PP(pp_sle) { - djSP; tryAMAGICbinSET(sle,0); + dSP; tryAMAGICbinSET(sle,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) @@ -1271,7 +1287,7 @@ PP(pp_sle) PP(pp_sge) { - djSP; tryAMAGICbinSET(sge,0); + dSP; tryAMAGICbinSET(sge,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) @@ -1284,7 +1300,7 @@ PP(pp_sge) PP(pp_seq) { - djSP; tryAMAGICbinSET(seq,0); + dSP; tryAMAGICbinSET(seq,0); { dPOPTOPssrl; SETs(boolSV(sv_eq(left, right))); @@ -1294,7 +1310,7 @@ PP(pp_seq) PP(pp_sne) { - djSP; tryAMAGICbinSET(sne,0); + dSP; tryAMAGICbinSET(sne,0); { dPOPTOPssrl; SETs(boolSV(!sv_eq(left, right))); @@ -1304,7 +1320,7 @@ PP(pp_sne) PP(pp_scmp) { - djSP; dTARGET; tryAMAGICbin(scmp,0); + dSP; dTARGET; tryAMAGICbin(scmp,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) @@ -1317,7 +1333,7 @@ PP(pp_scmp) PP(pp_bit_and) { - djSP; dATARGET; tryAMAGICbin(band,opASSIGN); + dSP; dATARGET; tryAMAGICbin(band,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { @@ -1340,7 +1356,7 @@ PP(pp_bit_and) PP(pp_bit_xor) { - djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); + dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { @@ -1363,7 +1379,7 @@ PP(pp_bit_xor) PP(pp_bit_or) { - djSP; dATARGET; tryAMAGICbin(bor,opASSIGN); + dSP; dATARGET; tryAMAGICbin(bor,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { @@ -1386,7 +1402,7 @@ PP(pp_bit_or) PP(pp_negate) { - djSP; dTARGET; tryAMAGICun(neg); + dSP; dTARGET; tryAMAGICun(neg); { dTOPss; if (SvGMAGICAL(sv)) @@ -1420,7 +1436,7 @@ PP(pp_negate) sv_setsv(TARG, sv); *SvPV_force(TARG, len) = *s == '-' ? '+' : '-'; } - else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) { + else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) { sv_setpvn(TARG, "-", 1); sv_catsv(TARG, sv); } @@ -1436,14 +1452,14 @@ PP(pp_negate) PP(pp_not) { - djSP; tryAMAGICunSET(not); + dSP; tryAMAGICunSET(not); *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp)); return NORMAL; } PP(pp_complement) { - djSP; dTARGET; tryAMAGICun(compl); + dSP; dTARGET; tryAMAGICun(compl); { dTOPss; if (SvNIOKp(sv)) { @@ -1457,21 +1473,72 @@ PP(pp_complement) } } else { - register char *tmps; - register long *tmpl; + register U8 *tmps; register I32 anum; STRLEN len; SvSetSV(TARG, sv); - tmps = SvPV_force(TARG, len); + tmps = (U8*)SvPV_force(TARG, len); anum = len; + if (SvUTF8(TARG)) { + /* Calculate exact length, let's not estimate. */ + STRLEN targlen = 0; + U8 *result; + U8 *send; + STRLEN l; + UV nchar = 0; + UV nwide = 0; + + send = tmps + len; + while (tmps < send) { + UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV); + tmps += UTF8SKIP(tmps); + targlen += UNISKIP(~c); + nchar++; + if (c > 0xff) + nwide++; + } + + /* Now rewind strings and write them. */ + tmps -= len; + + if (nwide) { + Newz(0, result, targlen + 1, U8); + while (tmps < send) { + UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV); + tmps += UTF8SKIP(tmps); + result = uv_to_utf8(result, ~c); + } + *result = '\0'; + result -= targlen; + sv_setpvn(TARG, (char*)result, targlen); + SvUTF8_on(TARG); + } + else { + Newz(0, result, nchar + 1, U8); + while (tmps < send) { + U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY); + tmps += UTF8SKIP(tmps); + *result++ = ~c; + } + *result = '\0'; + result -= nchar; + sv_setpvn(TARG, (char*)result, nchar); + } + Safefree(result); + SETs(TARG); + RETURN; + } #ifdef LIBERAL - for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++) - *tmps = ~*tmps; - tmpl = (long*)tmps; - for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++) - *tmpl = ~*tmpl; - tmps = (char*)tmpl; + { + register long *tmpl; + for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++) + *tmps = ~*tmps; + tmpl = (long*)tmps; + for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++) + *tmpl = ~*tmpl; + tmps = (U8*)tmpl; + } #endif for ( ; anum > 0; anum--, tmps++) *tmps = ~*tmps; @@ -1486,7 +1553,7 @@ PP(pp_complement) PP(pp_i_multiply) { - djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); + dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); { dPOPTOPiirl; SETi( left * right ); @@ -1496,7 +1563,7 @@ PP(pp_i_multiply) PP(pp_i_divide) { - djSP; dATARGET; tryAMAGICbin(div,opASSIGN); + dSP; dATARGET; tryAMAGICbin(div,opASSIGN); { dPOPiv; if (value == 0) @@ -1509,7 +1576,7 @@ PP(pp_i_divide) PP(pp_i_modulo) { - djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { dPOPTOPiirl; if (!right) @@ -1521,9 +1588,9 @@ PP(pp_i_modulo) PP(pp_i_add) { - djSP; dATARGET; tryAMAGICbin(add,opASSIGN); + dSP; dATARGET; tryAMAGICbin(add,opASSIGN); { - dPOPTOPiirl; + dPOPTOPiirl_ul; SETi( left + right ); RETURN; } @@ -1531,9 +1598,9 @@ PP(pp_i_add) PP(pp_i_subtract) { - djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); + dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { - dPOPTOPiirl; + dPOPTOPiirl_ul; SETi( left - right ); RETURN; } @@ -1541,7 +1608,7 @@ PP(pp_i_subtract) PP(pp_i_lt) { - djSP; tryAMAGICbinSET(lt,0); + dSP; tryAMAGICbinSET(lt,0); { dPOPTOPiirl; SETs(boolSV(left < right)); @@ -1551,7 +1618,7 @@ PP(pp_i_lt) PP(pp_i_gt) { - djSP; tryAMAGICbinSET(gt,0); + dSP; tryAMAGICbinSET(gt,0); { dPOPTOPiirl; SETs(boolSV(left > right)); @@ -1561,7 +1628,7 @@ PP(pp_i_gt) PP(pp_i_le) { - djSP; tryAMAGICbinSET(le,0); + dSP; tryAMAGICbinSET(le,0); { dPOPTOPiirl; SETs(boolSV(left <= right)); @@ -1571,7 +1638,7 @@ PP(pp_i_le) PP(pp_i_ge) { - djSP; tryAMAGICbinSET(ge,0); + dSP; tryAMAGICbinSET(ge,0); { dPOPTOPiirl; SETs(boolSV(left >= right)); @@ -1581,7 +1648,7 @@ PP(pp_i_ge) PP(pp_i_eq) { - djSP; tryAMAGICbinSET(eq,0); + dSP; tryAMAGICbinSET(eq,0); { dPOPTOPiirl; SETs(boolSV(left == right)); @@ -1591,7 +1658,7 @@ PP(pp_i_eq) PP(pp_i_ne) { - djSP; tryAMAGICbinSET(ne,0); + dSP; tryAMAGICbinSET(ne,0); { dPOPTOPiirl; SETs(boolSV(left != right)); @@ -1601,7 +1668,7 @@ PP(pp_i_ne) PP(pp_i_ncmp) { - djSP; dTARGET; tryAMAGICbin(ncmp,0); + dSP; dTARGET; tryAMAGICbin(ncmp,0); { dPOPTOPiirl; I32 value; @@ -1619,7 +1686,7 @@ PP(pp_i_ncmp) PP(pp_i_negate) { - djSP; dTARGET; tryAMAGICun(neg); + dSP; dTARGET; tryAMAGICun(neg); SETi(-TOPi); RETURN; } @@ -1628,7 +1695,7 @@ PP(pp_i_negate) PP(pp_atan2) { - djSP; dTARGET; tryAMAGICbin(atan2,0); + dSP; dTARGET; tryAMAGICbin(atan2,0); { dPOPTOPnnrl; SETn(Perl_atan2(left, right)); @@ -1638,7 +1705,7 @@ PP(pp_atan2) PP(pp_sin) { - djSP; dTARGET; tryAMAGICun(sin); + dSP; dTARGET; tryAMAGICun(sin); { NV value; value = POPn; @@ -1650,7 +1717,7 @@ PP(pp_sin) PP(pp_cos) { - djSP; dTARGET; tryAMAGICun(cos); + dSP; dTARGET; tryAMAGICun(cos); { NV value; value = POPn; @@ -1677,7 +1744,7 @@ extern double drand48 (void); PP(pp_rand) { - djSP; dTARGET; + dSP; dTARGET; NV value; if (MAXARG < 1) value = 1.0; @@ -1696,7 +1763,7 @@ PP(pp_rand) PP(pp_srand) { - djSP; + dSP; UV anum; if (MAXARG < 1) anum = seed(); @@ -1733,7 +1800,6 @@ S_seed(pTHX) #define SEED_C3 269 #define SEED_C5 26107 - dTHR; #ifndef PERL_NO_DEV_RANDOM int fd; #endif @@ -1792,7 +1858,7 @@ S_seed(pTHX) PP(pp_exp) { - djSP; dTARGET; tryAMAGICun(exp); + dSP; dTARGET; tryAMAGICun(exp); { NV value; value = POPn; @@ -1804,12 +1870,12 @@ PP(pp_exp) PP(pp_log) { - djSP; dTARGET; tryAMAGICun(log); + dSP; dTARGET; tryAMAGICun(log); { NV value; value = POPn; if (value <= 0.0) { - RESTORE_NUMERIC_STANDARD(); + SET_NUMERIC_STANDARD(); DIE(aTHX_ "Can't take log of %g", value); } value = Perl_log(value); @@ -1820,12 +1886,12 @@ PP(pp_log) PP(pp_sqrt) { - djSP; dTARGET; tryAMAGICun(sqrt); + dSP; dTARGET; tryAMAGICun(sqrt); { NV value; value = POPn; if (value < 0.0) { - RESTORE_NUMERIC_STANDARD(); + SET_NUMERIC_STANDARD(); DIE(aTHX_ "Can't take sqrt of %g", value); } value = Perl_sqrt(value); @@ -1836,7 +1902,7 @@ PP(pp_sqrt) PP(pp_int) { - djSP; dTARGET; + dSP; dTARGET; { NV value = TOPn; IV iv; @@ -1846,11 +1912,24 @@ PP(pp_int) SETi(iv); } else { - if (value >= 0.0) - (void)Perl_modf(value, &value); + if (value >= 0.0) { +#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE) + (void)Perl_modf(value, &value); +#else + double tmp = (double)value; + (void)Perl_modf(tmp, &tmp); + value = (NV)tmp; +#endif + } else { - (void)Perl_modf(-value, &value); - value = -value; +#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE) + (void)Perl_modf(-value, &value); + value = -value; +#else + double tmp = (double)value; + (void)Perl_modf(-tmp, &tmp); + value = -(NV)tmp; +#endif } iv = I_V(value); if (iv == value) @@ -1864,7 +1943,7 @@ PP(pp_int) PP(pp_abs) { - djSP; dTARGET; tryAMAGICun(abs); + dSP; dTARGET; tryAMAGICun(abs); { NV value = TOPn; IV iv; @@ -1886,35 +1965,37 @@ PP(pp_abs) PP(pp_hex) { - djSP; dTARGET; + dSP; dTARGET; char *tmps; - I32 argtype; - STRLEN n_a; + STRLEN argtype; + STRLEN len; - tmps = POPpx; - XPUSHn(scan_hex(tmps, 99, &argtype)); + tmps = (SvPVx(POPs, len)); + argtype = 1; /* allow underscores */ + XPUSHn(scan_hex(tmps, len, &argtype)); RETURN; } PP(pp_oct) { - djSP; dTARGET; + dSP; dTARGET; NV value; - I32 argtype; + STRLEN argtype; char *tmps; - STRLEN n_a; + STRLEN len; - tmps = POPpx; - while (*tmps && isSPACE(*tmps)) - tmps++; + tmps = (SvPVx(POPs, len)); + while (*tmps && len && isSPACE(*tmps)) + tmps++, len--; if (*tmps == '0') - tmps++; + tmps++, len--; + argtype = 1; /* allow underscores */ if (*tmps == 'x') - value = scan_hex(++tmps, 99, &argtype); + value = scan_hex(++tmps, --len, &argtype); else if (*tmps == 'b') - value = scan_bin(++tmps, 99, &argtype); + value = scan_bin(++tmps, --len, &argtype); else - value = scan_oct(tmps, 99, &argtype); + value = scan_oct(tmps, len, &argtype); XPUSHn(value); RETURN; } @@ -1923,7 +2004,7 @@ PP(pp_oct) PP(pp_length) { - djSP; dTARGET; + dSP; dTARGET; SV *sv = TOPs; if (DO_UTF8(sv)) @@ -1935,48 +2016,61 @@ PP(pp_length) PP(pp_substr) { - djSP; dTARGET; + dSP; dTARGET; SV *sv; I32 len; STRLEN curlen; - STRLEN utfcurlen; + STRLEN utf8_curlen; I32 pos; I32 rem; I32 fail; - I32 lvalue = PL_op->op_flags & OPf_MOD; + I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; char *tmps; I32 arybase = PL_curcop->cop_arybase; + SV *repl_sv = NULL; char *repl = 0; STRLEN repl_len; + int num_args = PL_op->op_private & 7; + bool repl_need_utf8_upgrade = FALSE; + bool repl_is_utf8 = FALSE; SvTAINTED_off(TARG); /* decontaminate */ SvUTF8_off(TARG); /* decontaminate */ - if (MAXARG > 2) { - if (MAXARG > 3) { - sv = POPs; - repl = SvPV(sv, repl_len); + if (num_args > 2) { + if (num_args > 3) { + repl_sv = POPs; + repl = SvPV(repl_sv, repl_len); + repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv); } len = POPi; } pos = POPi; sv = POPs; PUTBACK; + if (repl_sv) { + if (repl_is_utf8) { + if (!DO_UTF8(sv)) + sv_utf8_upgrade(sv); + } + else if (DO_UTF8(sv)) + repl_need_utf8_upgrade = TRUE; + } tmps = SvPV(sv, curlen); if (DO_UTF8(sv)) { - utfcurlen = sv_len_utf8(sv); - if (utfcurlen == curlen) - utfcurlen = 0; + utf8_curlen = sv_len_utf8(sv); + if (utf8_curlen == curlen) + utf8_curlen = 0; else - curlen = utfcurlen; + curlen = utf8_curlen; } else - utfcurlen = 0; + utf8_curlen = 0; if (pos >= arybase) { pos -= arybase; rem = curlen-pos; fail = rem; - if (MAXARG > 2) { + if (num_args > 2) { if (len < 0) { rem += len; if (rem < 0) @@ -1988,7 +2082,7 @@ PP(pp_substr) } else { pos += curlen; - if (MAXARG < 3) + if (num_args < 3) rem = curlen; else if (len >= 0) { rem = pos+len; @@ -2013,14 +2107,29 @@ PP(pp_substr) RETPUSHUNDEF; } else { - if (utfcurlen) { + I32 upos = pos; + I32 urem = rem; + if (utf8_curlen) sv_pos_u2b(sv, &pos, &rem); - SvUTF8_on(TARG); - } tmps += pos; sv_setpvn(TARG, tmps, rem); - if (repl) + if (utf8_curlen) + SvUTF8_on(TARG); + if (repl) { + SV* repl_sv_copy = NULL; + + if (repl_need_utf8_upgrade) { + repl_sv_copy = newSVsv(repl_sv); + sv_utf8_upgrade(repl_sv_copy); + repl = SvPV(repl_sv_copy, repl_len); + repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv); + } sv_insert(sv, pos, rem, repl, repl_len); + if (repl_is_utf8) + SvUTF8_on(sv); + if (repl_sv_copy) + SvREFCNT_dec(repl_sv_copy); + } else if (lvalue) { /* it's an lvalue! */ if (!SvGMAGICAL(sv)) { if (SvROK(sv)) { @@ -2031,7 +2140,7 @@ PP(pp_substr) "Attempt to use reference as lvalue in substr"); } if (SvOK(sv)) /* is it defined ? */ - (void)SvPOK_only(sv); + (void)SvPOK_only_UTF8(sv); else sv_setpvn(sv,"",0); /* avoid lexical reincarnation */ } @@ -2047,8 +2156,8 @@ PP(pp_substr) SvREFCNT_dec(LvTARG(TARG)); LvTARG(TARG) = SvREFCNT_inc(sv); } - LvTARGOFF(TARG) = pos; - LvTARGLEN(TARG) = rem; + LvTARGOFF(TARG) = upos; + LvTARGLEN(TARG) = urem; } } SPAGAIN; @@ -2058,11 +2167,11 @@ PP(pp_substr) PP(pp_vec) { - djSP; dTARGET; - register I32 size = POPi; - register I32 offset = POPi; + dSP; dTARGET; + register IV size = POPi; + register IV offset = POPi; register SV *src = POPs; - I32 lvalue = PL_op->op_flags & OPf_MOD; + I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; SvTAINTED_off(TARG); /* decontaminate */ if (lvalue) { /* it's an lvalue! */ @@ -2087,7 +2196,7 @@ PP(pp_vec) PP(pp_index) { - djSP; dTARGET; + dSP; dTARGET; SV *big; SV *little; I32 offset; @@ -2123,7 +2232,7 @@ PP(pp_index) PP(pp_rindex) { - djSP; dTARGET; + dSP; dTARGET; SV *big; SV *little; STRLEN blen; @@ -2164,7 +2273,7 @@ PP(pp_rindex) PP(pp_sprintf) { - djSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; do_sprintf(TARG, SP-MARK, MARK+1); TAINT_IF(SvTAINTED(TARG)); SP = ORIGMARK; @@ -2174,26 +2283,20 @@ PP(pp_sprintf) PP(pp_ord) { - djSP; dTARGET; - UV value; - STRLEN n_a; - SV *tmpsv = POPs; - U8 *tmps = (U8*)SvPVx(tmpsv,n_a); - I32 retlen; + dSP; dTARGET; + SV *argsv = POPs; + STRLEN len; + U8 *s = (U8*)SvPVx(argsv, len); - if ((*tmps & 0x80) && DO_UTF8(tmpsv)) - value = utf8_to_uv(tmps, &retlen); - else - value = (UV)(*tmps & 255); - XPUSHu(value); + XPUSHu(DO_UTF8(argsv) ? utf8_to_uv_simple(s, 0) : (*s & 0xff)); RETURN; } PP(pp_chr) { - djSP; dTARGET; + dSP; dTARGET; char *tmps; - U32 value = POPu; + UV value = POPu; (void)SvUPGRADE(TARG,SVt_PV); @@ -2214,7 +2317,6 @@ PP(pp_chr) tmps = SvPVX(TARG); *tmps++ = value; *tmps = '\0'; - SvUTF8_off(TARG); /* decontaminate */ (void)SvPOK_only(TARG); XPUSHs(TARG); RETURN; @@ -2222,7 +2324,7 @@ PP(pp_chr) PP(pp_crypt) { - djSP; dTARGET; dPOPTOPssrl; + dSP; dTARGET; dPOPTOPssrl; STRLEN n_a; #ifdef HAS_CRYPT char *tmps = SvPV(left, n_a); @@ -2241,16 +2343,16 @@ PP(pp_crypt) PP(pp_ucfirst) { - djSP; + dSP; SV *sv = TOPs; register U8 *s; STRLEN slen; - if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { - I32 ulen; - U8 tmpbuf[UTF8_MAXLEN]; + if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) { + STRLEN ulen; + U8 tmpbuf[UTF8_MAXLEN+1]; U8 *tend; - UV uv = utf8_to_uv(s, &ulen); + UV uv = utf8_to_uv(s, slen, &ulen, 0); if (PL_op->op_private & OPpLOCALE) { TAINT; @@ -2300,16 +2402,16 @@ PP(pp_ucfirst) PP(pp_lcfirst) { - djSP; + dSP; SV *sv = TOPs; register U8 *s; STRLEN slen; - if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { - I32 ulen; - U8 tmpbuf[UTF8_MAXLEN]; + if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) { + STRLEN ulen; + U8 tmpbuf[UTF8_MAXLEN+1]; U8 *tend; - UV uv = utf8_to_uv(s, &ulen); + UV uv = utf8_to_uv(s, slen, &ulen, 0); if (PL_op->op_private & OPpLOCALE) { TAINT; @@ -2359,14 +2461,14 @@ PP(pp_lcfirst) PP(pp_uc) { - djSP; + dSP; SV *sv = TOPs; register U8 *s; STRLEN len; if (DO_UTF8(sv)) { dTARGET; - I32 ulen; + STRLEN ulen; register U8 *d; U8 *send; @@ -2386,7 +2488,7 @@ PP(pp_uc) TAINT; SvTAINTED_on(TARG); while (s < send) { - d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen))); + d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0))); s += ulen; } } @@ -2433,14 +2535,14 @@ PP(pp_uc) PP(pp_lc) { - djSP; + dSP; SV *sv = TOPs; register U8 *s; STRLEN len; if (DO_UTF8(sv)) { dTARGET; - I32 ulen; + STRLEN ulen; register U8 *d; U8 *send; @@ -2460,7 +2562,7 @@ PP(pp_lc) TAINT; SvTAINTED_on(TARG); while (s < send) { - d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen))); + d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0))); s += ulen; } } @@ -2508,7 +2610,7 @@ PP(pp_lc) PP(pp_quotemeta) { - djSP; dTARGET; + dSP; dTARGET; SV *sv = TOPs; STRLEN len; register char *s = SvPV(sv,len); @@ -2521,7 +2623,7 @@ PP(pp_quotemeta) d = SvPVX(TARG); if (DO_UTF8(sv)) { while (len) { - if (*s & 0x80) { + if (UTF8_IS_CONTINUED(*s)) { STRLEN ulen = UTF8SKIP(s); if (ulen > len) ulen = len; @@ -2547,7 +2649,7 @@ PP(pp_quotemeta) } *d = '\0'; SvCUR_set(TARG, d - SvPVX(TARG)); - (void)SvPOK_only(TARG); + (void)SvPOK_only_UTF8(TARG); } else sv_setpvn(TARG, s, len); @@ -2561,10 +2663,10 @@ PP(pp_quotemeta) PP(pp_aslice) { - djSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; register SV** svp; register AV* av = (AV*)POPs; - register I32 lval = PL_op->op_flags & OPf_MOD; + register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); I32 arybase = PL_curcop->cop_arybase; I32 elem; @@ -2606,7 +2708,7 @@ PP(pp_aslice) PP(pp_each) { - djSP; + dSP; HV *hash = (HV*)POPs; HE *entry; I32 gimme = GIMME_V; @@ -2648,7 +2750,7 @@ PP(pp_keys) PP(pp_delete) { - djSP; + dSP; I32 gimme = GIMME_V; I32 discard = (gimme == G_VOID) ? G_DISCARD : 0; SV *sv; @@ -2712,7 +2814,7 @@ PP(pp_delete) PP(pp_exists) { - djSP; + dSP; SV *tmpsv; HV *hv; @@ -2749,9 +2851,9 @@ PP(pp_exists) PP(pp_hslice) { - djSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; register HV *hv = (HV*)POPs; - register I32 lval = PL_op->op_flags & OPf_MOD; + register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); I32 realhv = (SvTYPE(hv) == SVt_PVHV); if (!realhv && PL_op->op_private & OPpLVAL_INTRO) @@ -2791,7 +2893,7 @@ PP(pp_hslice) PP(pp_list) { - djSP; dMARK; + dSP; dMARK; if (GIMME != G_ARRAY) { if (++MARK <= SP) *MARK = *SP; /* unwanted list, return last item */ @@ -2804,7 +2906,7 @@ PP(pp_list) PP(pp_lslice) { - djSP; + dSP; SV **lastrelem = PL_stack_sp; SV **lastlelem = PL_stack_base + POPMARK; SV **firstlelem = PL_stack_base + POPMARK + 1; @@ -2859,7 +2961,7 @@ PP(pp_lslice) PP(pp_anonlist) { - djSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; I32 items = SP - MARK; SV *av = sv_2mortal((SV*)av_make(items, MARK+1)); SP = ORIGMARK; /* av_make() might realloc stack_sp */ @@ -2869,7 +2971,7 @@ PP(pp_anonlist) PP(pp_anonhash) { - djSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; HV* hv = (HV*)sv_2mortal((SV*)newHV()); while (MARK < SP) { @@ -2888,7 +2990,7 @@ PP(pp_anonhash) PP(pp_splice) { - djSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; register AV *ary = (AV*)*++MARK; register SV **src; register SV **dst; @@ -3090,7 +3192,7 @@ PP(pp_splice) PP(pp_push) { - djSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; register AV *ary = (AV*)*++MARK; register SV *sv = &PL_sv_undef; MAGIC *mg; @@ -3120,7 +3222,7 @@ PP(pp_push) PP(pp_pop) { - djSP; + dSP; AV *av = (AV*)POPs; SV *sv = av_pop(av); if (AvREAL(av)) @@ -3131,7 +3233,7 @@ PP(pp_pop) PP(pp_shift) { - djSP; + dSP; AV *av = (AV*)POPs; SV *sv = av_shift(av); EXTEND(SP, 1); @@ -3145,7 +3247,7 @@ PP(pp_shift) PP(pp_unshift) { - djSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; register AV *ary = (AV*)*++MARK; register SV *sv; register I32 i = 0; @@ -3175,7 +3277,7 @@ PP(pp_unshift) PP(pp_reverse) { - djSP; dMARK; + dSP; dMARK; register SV *tmp; SV **oldsp = SP; @@ -3207,20 +3309,17 @@ PP(pp_reverse) U8* s = (U8*)SvPVX(TARG); U8* send = (U8*)(s + len); while (s < send) { - if (*s < 0x80) { + if (UTF8_IS_ASCII(*s)) { s++; continue; } else { + if (!utf8_to_uv_simple(s, 0)) + break; up = (char*)s; s += UTF8SKIP(s); down = (char*)(s - 1); - if (s > send || !((*down & 0xc0) == 0x80)) { - if (ckWARN_d(WARN_UTF8)) - Perl_warner(aTHX_ WARN_UTF8, - "Malformed UTF-8 character"); - break; - } + /* reverse this character */ while (down > up) { tmp = *up; *up++ = *down; @@ -3236,7 +3335,7 @@ PP(pp_reverse) *up++ = *down; *down-- = tmp; } - (void)SvPOK_only(TARG); + (void)SvPOK_only_UTF8(TARG); } SP = MARK + 1; SETTARG; @@ -3286,7 +3385,7 @@ S_mul128(pTHX_ SV *sv, U8 m) PP(pp_unpack) { - djSP; + dSP; dPOPPOPssrl; I32 start_sp_offset = SP - PL_stack_base; I32 gimme = GIMME_V; @@ -3304,9 +3403,9 @@ PP(pp_unpack) register char *str; /* These must not be in registers: */ - I16 ashort; + short ashort; int aint; - I32 along; + long along; #ifdef HAS_QUAD Quad_t aquad; #endif @@ -3602,7 +3701,9 @@ PP(pp_unpack) len = strend - s; if (checksum) { while (len-- > 0 && s < strend) { - auint = utf8_to_uv((U8*)s, &along); + STRLEN alen; + auint = utf8_to_uv((U8*)s, strend - s, &alen, 0); + along = alen; s += along; if (checksum > 32) cdouble += (NV)auint; @@ -3614,7 +3715,9 @@ PP(pp_unpack) EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0 && s < strend) { - auint = utf8_to_uv((U8*)s, &along); + STRLEN alen; + auint = utf8_to_uv((U8*)s, strend - s, &alen, 0); + along = alen; s += along; sv = NEWSV(37, 0); sv_setuv(sv, (UV)auint); @@ -3855,7 +3958,6 @@ PP(pp_unpack) if (checksum) { #if LONGSIZE != SIZE32 if (natint) { - long along; while (len-- > 0) { COPYNN(s, &along, sizeof(long)); s += sizeof(long); @@ -3869,6 +3971,9 @@ PP(pp_unpack) #endif { while (len-- > 0) { +#if LONGSIZE > SIZE32 && INTSIZE == SIZE32 + I32 along; +#endif COPY32(s, &along); #if LONGSIZE > SIZE32 if (along > 2147483647) @@ -3887,7 +3992,6 @@ PP(pp_unpack) EXTEND_MORTAL(len); #if LONGSIZE != SIZE32 if (natint) { - long along; while (len-- > 0) { COPYNN(s, &along, sizeof(long)); s += sizeof(long); @@ -3900,6 +4004,9 @@ PP(pp_unpack) #endif { while (len-- > 0) { +#if LONGSIZE > SIZE32 && INTSIZE == SIZE32 + I32 along; +#endif COPY32(s, &along); #if LONGSIZE > SIZE32 if (along > 2147483647) @@ -4021,7 +4128,7 @@ PP(pp_unpack) while ((len > 0) && (s < strend)) { auv = (auv << 7) | (*s & 0x7f); - if (!(*s++ & 0x80)) { + if (UTF8_IS_ASCII(*s++)) { bytes = 0; sv = NEWSV(40, 0); sv_setuv(sv, auv); @@ -4033,7 +4140,7 @@ PP(pp_unpack) char *t; STRLEN n_a; - sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv); + sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv); while (s < strend) { sv = mul128(sv, *s & 0x7f); if (!(*s++ & 0x80)) { @@ -4365,11 +4472,12 @@ S_div128(pTHX_ SV *pnum, bool *done) PP(pp_pack) { - djSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; register SV *cat = TARG; register I32 items; STRLEN fromlen; register char *pat = SvPVx(*++MARK, fromlen); + char *patcopy; register char *patend = pat + fromlen; register I32 len; I32 datumtype; @@ -4400,6 +4508,7 @@ PP(pp_pack) items = SP - MARK; MARK++; sv_setpvn(cat, "", 0); + patcopy = pat; while (pat < patend) { SV *lengthcode = Nullsv; #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no) @@ -4407,8 +4516,12 @@ PP(pp_pack) #ifdef PERL_NATINT_PACK natint = 0; #endif - if (isSPACE(datumtype)) + if (isSPACE(datumtype)) { + patcopy++; continue; + } + if (datumtype == 'U' && pat == patcopy+1) + SvUTF8_on(cat); if (datumtype == '#') { while (pat < patend && *pat != '\n') pat++; @@ -4445,7 +4558,8 @@ PP(pp_pack) if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*') DIE(aTHX_ "/ must be followed by a*, A* or Z*"); lengthcode = sv_2mortal(newSViv(sv_len(items > 0 - ? *MARK : &PL_sv_no))); + ? *MARK : &PL_sv_no) + + (*pat == 'Z' ? 1 : 0))); } switch(datumtype) { default: @@ -4639,7 +4753,7 @@ PP(pp_pack) while (len-- > 0) { fromstr = NEXTFROM; auint = SvUV(fromstr); - SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN); + SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1); SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint) - SvPVX(cat)); } @@ -4743,10 +4857,14 @@ PP(pp_pack) DIE(aTHX_ "Cannot compress negative numbers"); if ( -#ifdef CXUX_BROKEN_CONSTANT_CONVERT - adouble <= UV_MAX_cxux +#if UVSIZE > 4 && UVSIZE >= NVSIZE + adouble <= 0xffffffff #else +# ifdef CXUX_BROKEN_CONSTANT_CONVERT + adouble <= UV_MAX_cxux +# else adouble <= UV_MAX +# endif #endif ) { @@ -4789,8 +4907,9 @@ PP(pp_pack) do { double next = floor(adouble / 128); *--in = (unsigned char)(adouble - (next * 128)) | 0x80; - if (--in < buf) /* this cannot happen ;-) */ + if (in <= buf) /* this cannot happen ;-) */ DIE(aTHX_ "Cannot compress integer"); + in--; adouble = next; } while (adouble > 0); buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ @@ -4947,19 +5066,21 @@ PP(pp_pack) PP(pp_split) { - djSP; dTARG; + dSP; dTARG; AV *ary; - register I32 limit = POPi; /* note, negative is forever */ + register IV limit = POPi; /* note, negative is forever */ SV *sv = POPs; STRLEN len; register char *s = SvPV(sv, len); + bool do_utf8 = DO_UTF8(sv); char *strend = s + len; register PMOP *pm; register REGEXP *rx; register SV *dstr; register char *m; I32 iters = 0; - I32 maxiters = (strend - s) + 10; + STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s); + I32 maxiters = slen + 10; I32 i; char *orig; I32 origlimit = limit; @@ -4977,7 +5098,7 @@ PP(pp_split) pm = (PMOP*)POPs; #endif if (!pm || !s) - DIE(aTHX_ "panic: do_split"); + DIE(aTHX_ "panic: pp_split"); rx = pm->op_pmregexp; TAINT_IF((pm->op_pmflags & PMf_LOCALE) && @@ -5053,6 +5174,8 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); s = m + 1; @@ -5073,6 +5196,8 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); s = m; } @@ -5082,11 +5207,11 @@ PP(pp_split) && !(rx->reganch & ROPT_ANCH)) { int tail = (rx->reganch & RE_INTUIT_TAIL); SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx); - char c; len = rx->minlen; - if (len == 1 && !tail) { - c = *SvPV(csv,len); + if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) { + STRLEN n_a; + char c = *SvPV(csv, n_a); while (--limit) { /*SUPPRESS 530*/ for (m = s; m < strend && *m != c; m++) ; @@ -5096,8 +5221,15 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); - s = m + 1; + /* The rx->minlen is in characters but we want to step + * s ahead by bytes. */ + if (do_utf8) + s = (char*)utf8_hop((U8*)m, len); + else + s = m + len; /* Fake \n at the end */ } } else { @@ -5111,13 +5243,20 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); - s = m + len; /* Fake \n at the end */ + /* The rx->minlen is in characters but we want to step + * s ahead by bytes. */ + if (do_utf8) + s = (char*)utf8_hop((U8*)m, len); + else + s = m + len; /* Fake \n at the end */ } } } else { - maxiters += (strend - s) * rx->nparens; + maxiters += slen * rx->nparens; while (s < strend && --limit /* && (!rx->check_substr || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend, @@ -5138,6 +5277,8 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); if (rx->nparens) { for (i = 1; i <= rx->nparens; i++) { @@ -5151,6 +5292,8 @@ PP(pp_split) dstr = NEWSV(33, 0); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); } } @@ -5165,10 +5308,13 @@ PP(pp_split) /* keep field after final delim? */ if (s < strend || (iters && origlimit)) { - dstr = NEWSV(34, strend-s); - sv_setpvn(dstr, s, strend-s); + STRLEN l = strend - s; + dstr = NEWSV(34, l); + sv_setpvn(dstr, s, l); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); iters++; } @@ -5225,7 +5371,6 @@ PP(pp_split) void Perl_unlock_condpair(pTHX_ void *svv) { - dTHR; MAGIC *mg = mg_find((SV*)svv, 'm'); if (!mg) @@ -5243,28 +5388,11 @@ Perl_unlock_condpair(pTHX_ void *svv) PP(pp_lock) { - djSP; + dSP; dTOPss; SV *retsv = sv; #ifdef USE_THREADS - MAGIC *mg; - - if (SvROK(sv)) - sv = SvRV(sv); - - mg = condpair_magic(sv); - MUTEX_LOCK(MgMUTEXP(mg)); - if (MgOWNER(mg) == thr) - MUTEX_UNLOCK(MgMUTEXP(mg)); - else { - while (MgOWNER(mg)) - COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); - MgOWNER(mg) = thr; - DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n", - PTR2UV(thr), PTR2UV(sv));) - MUTEX_UNLOCK(MgMUTEXP(mg)); - SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); - } + sv_lock(sv); #endif /* USE_THREADS */ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV || SvTYPE(retsv) == SVt_PVCV) { @@ -5277,7 +5405,7 @@ PP(pp_lock) PP(pp_threadsv) { #ifdef USE_THREADS - djSP; + dSP; EXTEND(SP, 1); if (PL_op->op_private & OPpLVAL_INTRO) PUSHs(*save_threadsv(PL_op->op_targ)); diff --git a/contrib/perl5/pp.h b/contrib/perl5/pp.h index bdc0b1a6c1c9..10da9644924a 100644 --- a/contrib/perl5/pp.h +++ b/contrib/perl5/pp.h @@ -1,6 +1,6 @@ /* pp.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. @@ -49,6 +49,7 @@ Refetch the stack pointer. Used after a callback. See L<perlcall>. =cut */ +#undef SP /* Solaris 2.7 i386 has this in /usr/include/sys/reg.h */ #define SP sp #define MARK mark #define TARG targ @@ -60,8 +61,8 @@ Refetch the stack pointer. Used after a callback. See L<perlcall>. #define TOPMARK (*PL_markstack_ptr) #define POPMARK (*PL_markstack_ptr--) -#define djSP register SV **sp = PL_stack_sp -#define dSP dTHR; djSP +#define dSP register SV **sp = PL_stack_sp +#define djSP dSP #define dMARK register SV **mark = PL_stack_base + POPMARK #define dORIGMARK I32 origmark = mark - PL_stack_base #define SETORIGMARK origmark = mark - PL_stack_base @@ -143,11 +144,11 @@ Pops a long off the stack. /* =for apidoc Am|void|EXTEND|SP|int nitems Used to extend the argument stack for an XSUB's return values. Once -used, guarrantees that there is room for at least C<nitems> to be pushed +used, guarantees that there is room for at least C<nitems> to be pushed onto the stack. =for apidoc Am|void|PUSHs|SV* sv -Push an SV onto the stack. The stack must have room for this element. +Push an SV onto the stack. The stack must have room for this element. Does not handle 'set' magic. See C<XPUSHs>. =for apidoc Am|void|PUSHp|char* str|STRLEN len @@ -185,7 +186,7 @@ Push an integer onto the stack, extending the stack if necessary. Handles 'set' magic. See C<PUSHi>. =for apidoc Am|void|XPUSHu|UV uv -Push an unsigned integer onto the stack, extending the stack if necessary. +Push an unsigned integer onto the stack, extending the stack if necessary. See C<PUSHu>. =cut @@ -342,10 +343,13 @@ See C<PUSHu>. { dTARGETSTACKED; \ { dSP; tryAMAGICunW(meth,FORCE_SETs,shift,RETURN);}}} -#define setAGAIN(ref) sv = arg = ref; \ - if (!SvROK(ref)) \ +#define setAGAIN(ref) sv = ref; \ + if (!SvROK(ref)) \ Perl_croak(aTHX_ "Overloaded dereference did not return a reference"); \ - goto am_again; + if (ref != arg && SvRV(ref) != SvRV(arg)) { \ + arg = ref; \ + goto am_again; \ + } #define tryAMAGICunDEREF(meth) tryAMAGICunW(meth,setAGAIN,0,(void)0) @@ -370,3 +374,10 @@ See C<PUSHu>. SvREFCNT_dec(tmpRef); \ SvRV(rv)=AMG_CALLun(rv,copy); \ } } STMT_END + +/* +=for apidoc mU||LVRET +True if this op will be the return value of an lvalue subroutine + +=cut */ +#define LVRET ((PL_op->op_private & OPpMAYBE_LVSUB) && is_lvalue_sub()) diff --git a/contrib/perl5/pp.sym b/contrib/perl5/pp.sym index 0e6c056611a2..2bd39221536e 100644 --- a/contrib/perl5/pp.sym +++ b/contrib/perl5/pp.sym @@ -30,6 +30,7 @@ Perl_ck_null Perl_ck_open Perl_ck_repeat Perl_ck_require +Perl_ck_return Perl_ck_rfun Perl_ck_rvconst Perl_ck_sassign @@ -40,6 +41,7 @@ Perl_ck_sort Perl_ck_spair Perl_ck_split Perl_ck_subr +Perl_ck_substr Perl_ck_svconst Perl_ck_trunc Perl_pp_null diff --git a/contrib/perl5/pp_ctl.c b/contrib/perl5/pp_ctl.c index acbcc7e72f74..b26706019a65 100644 --- a/contrib/perl5/pp_ctl.c +++ b/contrib/perl5/pp_ctl.c @@ -1,6 +1,6 @@ /* pp_ctl.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. @@ -47,7 +47,7 @@ static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b); PP(pp_wantarray) { - djSP; + dSP; I32 cxix; EXTEND(SP, 1); @@ -80,7 +80,7 @@ PP(pp_regcreset) PP(pp_regcomp) { - djSP; + dSP; register PMOP *pm = (PMOP*)cLOGOP->op_other; register char *t; SV *tmpstr; @@ -149,7 +149,7 @@ PP(pp_regcomp) PP(pp_substcont) { - djSP; + dSP; register PMOP *pm = (PMOP*) cLOGOP->op_other; register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; register SV *dstr = cx->sb_dstr; @@ -176,8 +176,9 @@ PP(pp_substcont) : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST)))) { SV *targ = cx->sb_targ; - sv_catpvn(dstr, s, cx->sb_strend - s); + bool isutf8; + sv_catpvn(dstr, s, cx->sb_strend - s); cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); (void)SvOOK_off(targ); @@ -185,6 +186,7 @@ PP(pp_substcont) SvPVX(targ) = SvPVX(dstr); SvCUR_set(targ, SvCUR(dstr)); SvLEN_set(targ, SvLEN(dstr)); + isutf8 = DO_UTF8(dstr); SvPVX(dstr) = 0; sv_free(dstr); @@ -192,6 +194,8 @@ PP(pp_substcont) PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); (void)SvPOK_only(targ); + if (isutf8) + SvUTF8_on(targ); TAINT_IF(cx->sb_rxtainted); SvSETMAGIC(targ); SvTAINT(targ); @@ -211,6 +215,21 @@ PP(pp_substcont) cx->sb_m = m = rx->startp[0] + orig; sv_catpvn(dstr, s, m-s); cx->sb_s = rx->endp[0] + orig; + { /* Update the pos() information. */ + SV *sv = cx->sb_targ; + MAGIC *mg; + I32 i; + if (SvTYPE(sv) < SVt_PVMG) + SvUPGRADE(sv, SVt_PVMG); + if (!(mg = mg_find(sv, 'g'))) { + sv_magic(sv, Nullsv, 'g', Nullch, 0); + mg = mg_find(sv, 'g'); + } + i = m - orig; + if (DO_UTF8(sv)) + sv_pos_b2u(sv, &i); + mg->mg_len = i; + } cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); rxres_save(&cx->sb_rxres, rx); RETURNOP(pm->op_pmreplstart); @@ -279,7 +298,7 @@ Perl_rxres_free(pTHX_ void **rsp) PP(pp_formline) { - djSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; register SV *tmpForm = *++MARK; register U16 *fpc; register char *t; @@ -524,7 +543,7 @@ PP(pp_formline) s = item; if (item_is_utf) { while (arg--) { - if (*s & 0x80) { + if (UTF8_IS_CONTINUED(*s)) { switch (UTF8SKIP(s)) { case 7: *t++ = *s++; case 6: *t++ = *s++; @@ -598,7 +617,7 @@ PP(pp_formline) value = SvNV(sv); /* Formats aren't yet marked for locales, so assume "yes". */ { - RESTORE_NUMERIC_LOCAL(); + STORE_NUMERIC_STANDARD_SET_LOCAL(); #if defined(USE_LONG_DOUBLE) if (arg & 256) { sprintf(t, "%#*.*" PERL_PRIfldbl, @@ -687,7 +706,7 @@ PP(pp_formline) PP(pp_grepstart) { - djSP; + dSP; SV *src; if (PL_stack_base + *PL_markstack_ptr == SP) { @@ -724,37 +743,61 @@ PP(pp_mapstart) PP(pp_mapwhile) { - djSP; - I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr; + dSP; + I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */ I32 count; I32 shift; SV** src; SV** dst; + /* first, move source pointer to the next item in the source list */ ++PL_markstack_ptr[-1]; - if (diff) { - if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) { - shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]); - count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2; + + /* if there are new items, push them into the destination list */ + if (items) { + /* might need to make room back there first */ + if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) { + /* XXX this implementation is very pessimal because the stack + * is repeatedly extended for every set of items. Is possible + * to do this without any stack extension or copying at all + * by maintaining a separate list over which the map iterates + * (like foreach does). --gsar */ + + /* everything in the stack after the destination list moves + * towards the end the stack by the amount of room needed */ + shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]); + + /* items to shift up (accounting for the moved source pointer) */ + count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1); + + /* This optimization is by Ben Tilly and it does + * things differently from what Sarathy (gsar) + * is describing. The downside of this optimization is + * that leaves "holes" (uninitialized and hopefully unused areas) + * to the Perl stack, but on the other hand this + * shouldn't be a problem. If Sarathy's idea gets + * implemented, this optimization should become + * irrelevant. --jhi */ + if (shift < count) + shift = count; /* Avoid shifting too often --Ben Tilly */ EXTEND(SP,shift); src = SP; dst = (SP += shift); PL_markstack_ptr[-1] += shift; *PL_markstack_ptr += shift; - while (--count) + while (count--) *dst-- = *src--; } - dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1; - ++diff; - while (--diff) + /* copy the new items down to the destination list */ + dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; + while (items--) *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); } LEAVE; /* exit inner scope */ /* All done yet? */ if (PL_markstack_ptr[-1] > *PL_markstack_ptr) { - I32 items; I32 gimme = GIMME_V; (void)POPMARK; /* pop top */ @@ -777,6 +820,7 @@ PP(pp_mapwhile) ENTER; /* enter inner scope */ SAVEVPTR(PL_curpm); + /* set $_ to the new source item */ src = PL_stack_base[PL_markstack_ptr[-1]]; SvTEMP_off(src); DEFSV = src; @@ -787,7 +831,7 @@ PP(pp_mapwhile) PP(pp_sort) { - djSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; register SV **up; SV **myorigmark = ORIGMARK; register I32 max; @@ -883,15 +927,22 @@ PP(pp_sort) CATCH_SET(TRUE); PUSHSTACKi(PERLSI_SORT); - if (PL_sortstash != stash) { - PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV); - PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV); - PL_sortstash = stash; + if (!hasargs && !is_xsub) { + if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) { + SAVESPTR(PL_firstgv); + SAVESPTR(PL_secondgv); + PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV); + PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV); + PL_sortstash = stash; + } +#ifdef USE_THREADS + sv_lock((SV *)PL_firstgv); + sv_lock((SV *)PL_secondgv); +#endif + SAVESPTR(GvSV(PL_firstgv)); + SAVESPTR(GvSV(PL_secondgv)); } - SAVESPTR(GvSV(PL_firstgv)); - SAVESPTR(GvSV(PL_secondgv)); - PUSHBLOCK(cx, CXt_NULL, PL_stack_base); if (!(PL_op->op_flags & OPf_SPECIAL)) { cx->cx_type = CXt_SUB; @@ -910,6 +961,7 @@ PP(pp_sort) cx->blk_sub.savearray = GvAV(PL_defgv); GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); #endif /* USE_THREADS */ + cx->blk_sub.oldcurpad = PL_curpad; cx->blk_sub.argarray = av; } qsortsv((myorigmark+1), max, @@ -964,7 +1016,7 @@ PP(pp_range) PP(pp_flip) { - djSP; + dSP; if (GIMME == G_ARRAY) { RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); @@ -972,10 +1024,17 @@ PP(pp_flip) else { dTOPss; SV *targ = PAD_SV(PL_op->op_targ); - - if ((PL_op->op_private & OPpFLIP_LINENUM) - ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv))) - : SvTRUE(sv) ) { + int flip; + + if (PL_op->op_private & OPpFLIP_LINENUM) { + struct io *gp_io; + flip = PL_last_in_gv + && (gp_io = GvIOp(PL_last_in_gv)) + && SvIV(sv) == (IV)IoLINES(gp_io); + } else { + flip = SvTRUE(sv); + } + if (flip) { sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); if (PL_op->op_flags & OPf_SPECIAL) { sv_setiv(targ, 1); @@ -996,7 +1055,7 @@ PP(pp_flip) PP(pp_flop) { - djSP; + dSP; if (GIMME == G_ARRAY) { dPOPPOPssrl; @@ -1067,7 +1126,6 @@ PP(pp_flop) STATIC I32 S_dopoptolabel(pTHX_ char *label) { - dTHR; register I32 i; register PERL_CONTEXT *cx; @@ -1123,7 +1181,6 @@ Perl_dowantarray(pTHX) I32 Perl_block_gimme(pTHX) { - dTHR; I32 cxix; cxix = dopoptosub(cxstack_ix); @@ -1144,17 +1201,29 @@ Perl_block_gimme(pTHX) } } +I32 +Perl_is_lvalue_sub(pTHX) +{ + I32 cxix; + + cxix = dopoptosub(cxstack_ix); + assert(cxix >= 0); /* We should only be called from inside subs */ + + if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv)) + return cxstack[cxix].blk_sub.lval; + else + return 0; +} + STATIC I32 S_dopoptosub(pTHX_ I32 startingblock) { - dTHR; return dopoptosub_at(cxstack, startingblock); } STATIC I32 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock) { - dTHR; I32 i; register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { @@ -1175,7 +1244,6 @@ S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock) STATIC I32 S_dopoptoeval(pTHX_ I32 startingblock) { - dTHR; I32 i; register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { @@ -1194,7 +1262,6 @@ S_dopoptoeval(pTHX_ I32 startingblock) STATIC I32 S_dopoptoloop(pTHX_ I32 startingblock) { - dTHR; I32 i; register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { @@ -1236,7 +1303,6 @@ S_dopoptoloop(pTHX_ I32 startingblock) void Perl_dounwind(pTHX_ I32 cxix) { - dTHR; register PERL_CONTEXT *cx; I32 optype; @@ -1270,42 +1336,6 @@ Perl_dounwind(pTHX_ I32 cxix) } } -/* - * Closures mentioned at top level of eval cannot be referenced - * again, and their presence indirectly causes a memory leak. - * (Note that the fact that compcv and friends are still set here - * is, AFAIK, an accident.) --Chip - * - * XXX need to get comppad et al from eval's cv rather than - * relying on the incidental global values. - */ -STATIC void -S_free_closures(pTHX) -{ - dTHR; - SV **svp = AvARRAY(PL_comppad_name); - I32 ix; - for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) { - SV *sv = svp[ix]; - if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') { - SvREFCNT_dec(sv); - svp[ix] = &PL_sv_undef; - - sv = PL_curpad[ix]; - if (CvCLONE(sv)) { - SvREFCNT_dec(CvOUTSIDE(sv)); - CvOUTSIDE(sv) = Nullcv; - } - else { - SvREFCNT_dec(sv); - sv = NEWSV(0,0); - SvPADTMP_on(sv); - PL_curpad[ix] = sv; - } - } - } -} - void Perl_qerror(pTHX_ SV *err) { @@ -1384,6 +1414,12 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) LEAVE; + /* LEAVE could clobber PL_curcop (see save_re_context()) + * XXX it might be better to find a way to avoid messing with + * PL_curcop in save_re_context() instead, but this is a more + * minimal fix --GSAR */ + PL_curcop = cx->blk_oldcop; + if (optype == OP_REQUIRE) { char* msg = SvPVx(ERRSV, n_a); DIE(aTHX_ "%sCompilation failed in require", @@ -1414,7 +1450,7 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) PP(pp_xor) { - djSP; dPOPTOPssrl; + dSP; dPOPTOPssrl; if (SvTRUE(left) != SvTRUE(right)) RETSETYES; else @@ -1423,7 +1459,7 @@ PP(pp_xor) PP(pp_andassign) { - djSP; + dSP; if (!SvTRUE(TOPs)) RETURN; else @@ -1432,7 +1468,7 @@ PP(pp_andassign) PP(pp_orassign) { - djSP; + dSP; if (SvTRUE(TOPs)) RETURN; else @@ -1441,7 +1477,7 @@ PP(pp_orassign) PP(pp_caller) { - djSP; + dSP; register I32 cxix = dopoptosub(cxstack_ix); register PERL_CONTEXT *cx; register PERL_CONTEXT *ccstack = cxstack; @@ -1521,15 +1557,21 @@ PP(pp_caller) else PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY))); if (CxTYPE(cx) == CXt_EVAL) { + /* eval STRING */ if (cx->blk_eval.old_op_type == OP_ENTEREVAL) { PUSHs(cx->blk_eval.cur_text); PUSHs(&PL_sv_no); } - /* try blocks have old_namesv == 0 */ + /* require */ else if (cx->blk_eval.old_namesv) { PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv))); PUSHs(&PL_sv_yes); } + /* eval BLOCK (try blocks have old_namesv == 0) */ + else { + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); + } } else { PUSHs(&PL_sv_undef); @@ -1546,7 +1588,7 @@ PP(pp_caller) PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE, SVt_PVAV))); GvMULTI_on(tmpgv); - AvREAL_off(PL_dbargs); /* XXX Should be REIFY */ + AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */ } if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) @@ -1562,9 +1604,12 @@ PP(pp_caller) { SV * mask ; SV * old_warnings = cx->blk_oldcop->cop_warnings ; - if (old_warnings == pWARN_NONE || old_warnings == pWARN_STD) + + if (old_warnings == pWARN_NONE || + (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)) mask = newSVpvn(WARN_NONEstring, WARNsize) ; - else if (old_warnings == pWARN_ALL) + else if (old_warnings == pWARN_ALL || + (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) mask = newSVpvn(WARN_ALLstring, WARNsize) ; else mask = newSVsv(old_warnings); @@ -1575,7 +1620,7 @@ PP(pp_caller) PP(pp_reset) { - djSP; + dSP; char *tmps; STRLEN n_a; @@ -1602,7 +1647,7 @@ PP(pp_dbstate) if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) { - djSP; + dSP; register CV *cv; register PERL_CONTEXT *cx; I32 gimme = G_ARRAY; @@ -1646,7 +1691,7 @@ PP(pp_scope) PP(pp_enteriter) { - djSP; dMARK; + dSP; dMARK; register PERL_CONTEXT *cx; I32 gimme = GIMME_V; SV **svp; @@ -1660,7 +1705,6 @@ PP(pp_enteriter) #ifdef USE_THREADS if (PL_op->op_flags & OPf_SPECIAL) { - dTHR; svp = &THREADSV(PL_op->op_targ); /* per-thread variable */ SAVEGENERICSV(*svp); *svp = NEWSV(0,0); @@ -1668,9 +1712,11 @@ PP(pp_enteriter) else #endif /* USE_THREADS */ if (PL_op->op_targ) { +#ifndef USE_ITHREADS svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */ SAVESPTR(*svp); -#ifdef USE_ITHREADS +#else + SAVEPADSV(PL_op->op_targ); iterdata = (void*)PL_op->op_targ; cxtype |= CXp_PADVAR; #endif @@ -1724,7 +1770,7 @@ PP(pp_enteriter) PP(pp_enterloop) { - djSP; + dSP; register PERL_CONTEXT *cx; I32 gimme = GIMME_V; @@ -1740,7 +1786,7 @@ PP(pp_enterloop) PP(pp_leaveloop) { - djSP; + dSP; register PERL_CONTEXT *cx; I32 gimme; SV **newsp; @@ -1780,7 +1826,7 @@ PP(pp_leaveloop) PP(pp_return) { - djSP; dMARK; + dSP; dMARK; I32 cxix; register PERL_CONTEXT *cx; bool popsub2 = FALSE; @@ -1820,8 +1866,6 @@ PP(pp_return) POPEVAL(cx); if (CxTRYBLOCK(cx)) break; - if (AvFILLp(PL_comppad_name) >= 0) - free_closures(); lex_end(); if (optype == OP_REQUIRE && (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) @@ -1891,7 +1935,7 @@ PP(pp_return) PP(pp_last) { - djSP; + dSP; I32 cxix; register PERL_CONTEXT *cx; I32 pop2 = 0; @@ -1979,7 +2023,7 @@ PP(pp_next) { I32 cxix; register PERL_CONTEXT *cx; - I32 oldsave; + I32 inner; if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); @@ -1994,13 +2038,12 @@ PP(pp_next) if (cxix < cxstack_ix) dounwind(cxix); + /* clear off anything above the scope we're re-entering, but + * save the rest until after a possible continue block */ + inner = PL_scopestack_ix; TOPBLOCK(cx); - - /* clean scope, but only if there's no continue block */ - if (!(cx->blk_loop.last_op->op_private & OPpLOOP_CONTINUE)) { - oldsave = PL_scopestack[PL_scopestack_ix - 1]; - LEAVE_SCOPE(oldsave); - } + if (PL_scopestack_ix < inner) + leave_scope(PL_scopestack[PL_scopestack_ix]); return cx->blk_loop.next_op; } @@ -2049,7 +2092,6 @@ S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit) } *ops = 0; if (o->op_flags & OPf_KIDS) { - dTHR; /* First try all the kids at this level, since that's likeliest. */ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && @@ -2080,7 +2122,7 @@ PP(pp_dump) PP(pp_goto) { - djSP; + dSP; OP *retop = 0; I32 ix; register PERL_CONTEXT *cx; @@ -2297,6 +2339,7 @@ PP(pp_goto) cx->blk_sub.savearray = GvAV(PL_defgv); GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); #endif /* USE_THREADS */ + cx->blk_sub.oldcurpad = PL_curpad; cx->blk_sub.argarray = av; ++mark; @@ -2456,7 +2499,7 @@ PP(pp_goto) PP(pp_exit) { - djSP; + dSP; I32 anum; if (MAXARG < 1) @@ -2477,7 +2520,7 @@ PP(pp_exit) #ifdef NOTYET PP(pp_nswitch) { - djSP; + dSP; NV value = SvNVx(GvSV(cCOP->cop_gv)); register I32 match = I_32(value); @@ -2496,7 +2539,7 @@ PP(pp_nswitch) PP(pp_cswitch) { - djSP; + dSP; register I32 match; if (PL_multiline) @@ -2559,7 +2602,6 @@ S_docatch_body(pTHX) STATIC OP * S_docatch(pTHX_ OP *o) { - dTHR; int ret; OP *oldop = PL_op; volatile PERL_SI *cursi = PL_curstackinfo; @@ -2623,11 +2665,9 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) /* switch to eval mode */ if (PL_curcop == &PL_compiling) { - SAVECOPSTASH(&PL_compiling); + SAVECOPSTASH_FREE(&PL_compiling); CopSTASH_set(&PL_compiling, PL_curstash); } - SAVECOPFILE(&PL_compiling); - SAVECOPLINE(&PL_compiling); if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { SV *sv = sv_newmortal(); Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]", @@ -2637,7 +2677,9 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) } else sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq); + SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tmpbuf+2); + SAVECOPLINE(&PL_compiling); CopLINE_set(&PL_compiling, 1); /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up deleting the eval's FILEGV from the stash before gv_check() runs @@ -2657,7 +2699,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) PL_op = &dummy; PL_op->op_type = OP_ENTEREVAL; PL_op->op_flags = 0; /* Avoid uninit warning. */ - PUSHBLOCK(cx, CXt_EVAL, SP); + PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP); PUSHEVAL(cx, 0, Nullgv); rop = doeval(G_SCALAR, startop); POPBLOCK(cx,PL_curpm); @@ -2686,7 +2728,9 @@ S_doeval(pTHX_ int gimme, OP** startop) AV* comppadlist; I32 i; - PL_in_eval = EVAL_INEVAL; + PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE) + ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) + : EVAL_INEVAL); PUSHMARK(SP); @@ -2746,7 +2790,7 @@ S_doeval(pTHX_ int gimme, OP** startop) CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller); } - SAVEFREESV(PL_compcv); + SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ /* make sure we compile in the right package */ @@ -2757,6 +2801,7 @@ S_doeval(pTHX_ int gimme, OP** startop) SAVESPTR(PL_beginav); PL_beginav = newAV(); SAVEFREESV(PL_beginav); + SAVEI32(PL_error_count); /* try to compile it */ @@ -2848,6 +2893,7 @@ S_doeval(pTHX_ int gimme, OP** startop) CvDEPTH(PL_compcv) = 1; SP = PL_stack_base + POPMARK; /* pop original mark */ PL_op = saveop; /* The caller may need it. */ + PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */ #ifdef USE_THREADS MUTEX_LOCK(&PL_eval_mutex); PL_eval_owner = 0; @@ -2892,7 +2938,7 @@ S_doopen_pmc(pTHX_ const char *name, const char *mode) PP(pp_require) { - djSP; + dSP; register PERL_CONTEXT *cx; SV *sv; char *name; @@ -2910,27 +2956,21 @@ PP(pp_require) sv = POPs; if (SvNIOKp(sv)) { - UV rev, ver, sver; - if (SvPOKp(sv)) { /* require v5.6.1 */ - I32 len; + if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */ + UV rev = 0, ver = 0, sver = 0; + STRLEN len; U8 *s = (U8*)SvPVX(sv); U8 *end = (U8*)SvPVX(sv) + SvCUR(sv); if (s < end) { - rev = utf8_to_uv(s, &len); + rev = utf8_to_uv(s, end - s, &len, 0); s += len; if (s < end) { - ver = utf8_to_uv(s, &len); + ver = utf8_to_uv(s, end - s, &len, 0); s += len; if (s < end) - sver = utf8_to_uv(s, &len); - else - sver = 0; + sver = utf8_to_uv(s, end - s, &len, 0); } - else - ver = 0; } - else - rev = 0; if (PERL_REVISION < rev || (PERL_REVISION == rev && (PERL_VERSION < ver @@ -2941,6 +2981,7 @@ PP(pp_require) "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION, PERL_VERSION, PERL_SUBVERSION); } + RETPUSHYES; } else if (!SvPOKp(sv)) { /* require 5.005_03 */ if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000) @@ -2969,8 +3010,8 @@ PP(pp_require) PERL_SUBVERSION); } } + RETPUSHYES; } - RETPUSHYES; } name = SvPV(sv, len); if (!(name && len > 0 && *name)) @@ -2983,6 +3024,21 @@ PP(pp_require) /* prepare to compile file */ +#ifdef MACOS_TRADITIONAL + if (PERL_FILE_IS_ABSOLUTE(name) + || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))) + { + tryname = name; + tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE); + /* We consider paths of the form :a:b ambiguous and interpret them first + as global then as local + */ + if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':')) + goto trylocal; + } + else +trylocal: { +#else if (PERL_FILE_IS_ABSOLUTE(name) || (*name == '.' && (name[1] == '/' || (name[1] == '.' && name[2] == '/')))) @@ -2991,6 +3047,7 @@ PP(pp_require) tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE); } else { +#endif AV *ar = GvAVn(PL_incgv); I32 i; #ifdef VMS @@ -3023,7 +3080,10 @@ PP(pp_require) PUSHs(dirsv); PUSHs(sv); PUTBACK; - count = call_sv(loader, G_ARRAY); + if (sv_isobject(loader)) + count = call_method("INC", G_ARRAY); + else + count = call_sv(loader, G_ARRAY); SPAGAIN; if (count > 0) { @@ -3044,7 +3104,7 @@ PP(pp_require) if (io) { tryrsfp = IoIFP(io); - if (IoTYPE(io) == '|') { + if (IoTYPE(io) == IoTYPE_PIPE) { /* reading from a child process doesn't nest -- when returning from reading the inner module, the outer one is @@ -3108,6 +3168,10 @@ PP(pp_require) } else { char *dir = SvPVx(dirsv, n_a); +#ifdef MACOS_TRADITIONAL + char buf[256]; + Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':')); +#else #ifdef VMS char *unixdir; if ((unixdir = tounixpath(dir, Nullch)) == Nullch) @@ -3117,8 +3181,17 @@ PP(pp_require) #else Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); #endif +#endif TAINT_PROPER("require"); tryname = SvPVX(namesv); +#ifdef MACOS_TRADITIONAL + { + /* Convert slashes in the name part, but not the directory part, to colons */ + char * colon; + for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); ) + *colon++ = ':'; + } +#endif tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE); if (tryrsfp) { if (tryname[0] == '.' && tryname[1] == '/') @@ -3129,7 +3202,7 @@ PP(pp_require) } } } - SAVECOPFILE(&PL_compiling); + SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tryrsfp ? tryname : name); SvREFCNT_dec(namesv); if (!tryrsfp) { @@ -3219,7 +3292,7 @@ PP(pp_dofile) PP(pp_entereval) { - djSP; + dSP; register PERL_CONTEXT *cx; dPOPss; I32 gimme = GIMME_V, was = PL_sub_generation; @@ -3239,7 +3312,6 @@ PP(pp_entereval) /* switch to eval mode */ - SAVECOPFILE(&PL_compiling); if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { SV *sv = sv_newmortal(); Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]", @@ -3249,7 +3321,9 @@ PP(pp_entereval) } else sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq); + SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tmpbuf+2); + SAVECOPLINE(&PL_compiling); CopLINE_set(&PL_compiling, 1); /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up deleting the eval's FILEGV from the stash before gv_check() runs @@ -3261,9 +3335,11 @@ PP(pp_entereval) SAVEHINTS(); PL_hints = PL_op->op_targ; SAVESPTR(PL_compiling.cop_warnings); - if (!specialWARN(PL_compiling.cop_warnings)) { - PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; - SAVEFREESV(PL_compiling.cop_warnings) ; + if (specialWARN(PL_curcop->cop_warnings)) + PL_compiling.cop_warnings = PL_curcop->cop_warnings; + else { + PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings); + SAVEFREESV(PL_compiling.cop_warnings); } push_return(PL_op->op_next); @@ -3293,7 +3369,7 @@ PP(pp_entereval) PP(pp_leaveeval) { - djSP; + dSP; register SV **mark; SV **newsp; PMOP *newpm; @@ -3335,9 +3411,6 @@ PP(pp_leaveeval) } PL_curpm = newpm; /* Don't pop $1 et al till now */ - if (AvFILLp(PL_comppad_name) >= 0) - free_closures(); - #ifdef DEBUGGING assert(CvDEPTH(PL_compcv) == 1); #endif @@ -3364,7 +3437,7 @@ PP(pp_leaveeval) PP(pp_entertry) { - djSP; + dSP; register PERL_CONTEXT *cx; I32 gimme = GIMME_V; @@ -3384,7 +3457,7 @@ PP(pp_entertry) PP(pp_leavetry) { - djSP; + dSP; register SV **mark; SV **newsp; PMOP *newpm; @@ -4297,7 +4370,6 @@ S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare) static I32 sortcv(pTHXo_ SV *a, SV *b) { - dTHR; I32 oldsaveix = PL_savestack_ix; I32 oldscopeix = PL_scopestack_ix; I32 result; @@ -4321,7 +4393,6 @@ sortcv(pTHXo_ SV *a, SV *b) static I32 sortcv_stacked(pTHXo_ SV *a, SV *b) { - dTHR; I32 oldsaveix = PL_savestack_ix; I32 oldscopeix = PL_scopestack_ix; I32 result; @@ -4527,7 +4598,7 @@ run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen) } if (filter_sub && len >= 0) { - djSP; + dSP; int count; ENTER; diff --git a/contrib/perl5/pp_hot.c b/contrib/perl5/pp_hot.c index c888ea5e71ea..aecfaba7456e 100644 --- a/contrib/perl5/pp_hot.c +++ b/contrib/perl5/pp_hot.c @@ -1,6 +1,6 @@ /* pp_hot.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. @@ -19,10 +19,6 @@ #define PERL_IN_PP_HOT_C #include "perl.h" -#ifdef I_UNISTD -#include <unistd.h> -#endif - /* Hot code. */ #ifdef USE_THREADS @@ -31,7 +27,7 @@ static void unset_cvowner(pTHXo_ void *cvarg); PP(pp_const) { - djSP; + dSP; XPUSHs(cSVOP_sv); RETURN; } @@ -47,7 +43,7 @@ PP(pp_nextstate) PP(pp_gvsv) { - djSP; + dSP; EXTEND(SP,1); if (PL_op->op_private & OPpLVAL_INTRO) PUSHs(save_scalar(cGVOP_gv)); @@ -75,27 +71,29 @@ PP(pp_pushmark) PP(pp_stringify) { - djSP; dTARGET; + dSP; dTARGET; STRLEN len; char *s; s = SvPV(TOPs,len); sv_setpvn(TARG,s,len); - if (SvUTF8(TOPs) && !IN_BYTE) + if (SvUTF8(TOPs)) SvUTF8_on(TARG); + else + SvUTF8_off(TARG); SETTARG; RETURN; } PP(pp_gv) { - djSP; + dSP; XPUSHs((SV*)cGVOP_gv); RETURN; } PP(pp_and) { - djSP; + dSP; if (!SvTRUE(TOPs)) RETURN; else { @@ -106,7 +104,7 @@ PP(pp_and) PP(pp_sassign) { - djSP; dPOPTOPssrl; + dSP; dPOPTOPssrl; if (PL_op->op_private & OPpASSIGN_BACKWARDS) { SV *temp; @@ -121,7 +119,7 @@ PP(pp_sassign) PP(pp_cond_expr) { - djSP; + dSP; if (SvTRUEx(POPs)) RETURNOP(cLOGOP->op_other); else @@ -141,54 +139,55 @@ PP(pp_unstack) PP(pp_concat) { - djSP; dATARGET; tryAMAGICbin(concat,opASSIGN); + dSP; dATARGET; tryAMAGICbin(concat,opASSIGN); { dPOPTOPssrl; - STRLEN len; - char *s; + SV* rcopy = Nullsv; - if (TARG != left) { - s = SvPV(left,len); - if (TARG == right) { - sv_insert(TARG, 0, 0, s, len); - SETs(TARG); - RETURN; + if (SvGMAGICAL(left)) + mg_get(left); + if (TARG == right && SvGMAGICAL(right)) + mg_get(right); + + if (TARG == right && left != right) + /* Clone since otherwise we cannot prepend. */ + rcopy = sv_2mortal(newSVsv(right)); + + if (TARG != left) + sv_setsv(TARG, left); + + if (TARG == right) { + if (left == right) { + /* $right = $right . $right; */ + STRLEN rlen; + char *rpv = SvPV(right, rlen); + + sv_catpvn(TARG, rpv, rlen); } - sv_setpvn(TARG,s,len); + else /* $right = $left . $right; */ + sv_catsv(TARG, rcopy); } - else if (SvGMAGICAL(TARG)) - mg_get(TARG); - else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) { - sv_setpv(TARG, ""); /* Suppress warning. */ - s = SvPV_force(TARG, len); + else { + if (!SvOK(TARG)) /* Avoid warning when concatenating to undef. */ + sv_setpv(TARG, ""); + /* $other = $left . $right; */ + /* $left = $left . $right; */ + sv_catsv(TARG, right); } - s = SvPV(right,len); - if (SvOK(TARG)) { + #if defined(PERL_Y2KWARN) - if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) { - STRLEN n; - char *s = SvPV(TARG,n); - if (n >= 2 && s[n-2] == '1' && s[n-1] == '9' - && (n == 2 || !isDIGIT(s[n-3]))) - { - Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s", - "about to append an integer to '19'"); - } - } -#endif - if (DO_UTF8(right)) - sv_utf8_upgrade(TARG); - sv_catpvn(TARG,s,len); - if (!IN_BYTE) { - if (SvUTF8(right)) - SvUTF8_on(TARG); - } - else if (!SvUTF8(right)) { - SvUTF8_off(TARG); + if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) { + STRLEN n; + char *s = SvPV(TARG,n); + if (n >= 2 && s[n-2] == '1' && s[n-1] == '9' + && (n == 2 || !isDIGIT(s[n-3]))) + { + Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s", + "about to append an integer to '19'"); } } - else - sv_setpvn(TARG,s,len); /* suppress warning */ +#endif + SETTARG; RETURN; } @@ -196,7 +195,7 @@ PP(pp_concat) PP(pp_padsv) { - djSP; dTARGET; + dSP; dTARGET; XPUSHs(TARG); if (PL_op->op_flags & OPf_MOD) { if (PL_op->op_private & OPpLVAL_INTRO) @@ -230,7 +229,7 @@ PP(pp_readline) PP(pp_eq) { - djSP; tryAMAGICbinSET(eq,0); + dSP; tryAMAGICbinSET(eq,0); { dPOPnv; SETs(boolSV(TOPn == value)); @@ -240,7 +239,7 @@ PP(pp_eq) PP(pp_preinc) { - djSP; + dSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && @@ -257,7 +256,7 @@ PP(pp_preinc) PP(pp_or) { - djSP; + dSP; if (SvTRUE(TOPs)) RETURN; else { @@ -268,7 +267,7 @@ PP(pp_or) PP(pp_add) { - djSP; dATARGET; tryAMAGICbin(add,opASSIGN); + dSP; dATARGET; tryAMAGICbin(add,opASSIGN); { dPOPTOPnnrl_ul; SETn( left + right ); @@ -278,7 +277,7 @@ PP(pp_add) PP(pp_aelemfast) { - djSP; + dSP; AV *av = GvAV(cGVOP_gv); U32 lval = PL_op->op_flags & OPf_MOD; SV** svp = av_fetch(av, PL_op->op_private, lval); @@ -292,7 +291,7 @@ PP(pp_aelemfast) PP(pp_join) { - djSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; MARK++; do_join(TARG, *MARK, MARK, SP); SP = MARK; @@ -302,7 +301,7 @@ PP(pp_join) PP(pp_pushre) { - djSP; + dSP; #ifdef DEBUGGING /* * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs @@ -323,7 +322,7 @@ PP(pp_pushre) PP(pp_print) { - djSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; GV *gv; IO *io; register PerlIO *fp; @@ -335,6 +334,7 @@ PP(pp_print) else gv = PL_defoutgv; if ((mg = SvTIED_mg((SV*)gv, 'q'))) { + had_magic: if (MARK == ORIGMARK) { /* If using default handle then we need to make space to * pass object as 1st arg, so move other args up ... @@ -357,26 +357,32 @@ PP(pp_print) RETURN; } if (!(io = GvIO(gv))) { - if (ckWARN(WARN_UNOPENED)) { - SV* sv = sv_newmortal(); - gv_efullname3(sv, gv, Nullch); - Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened", - SvPV(sv,n_a)); - } + if ((GvEGV(gv)) && (mg = SvTIED_mg((SV*)GvEGV(gv),'q'))) + goto had_magic; + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS$_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { if (ckWARN2(WARN_CLOSED, WARN_IO)) { if (IoIFP(io)) { - SV* sv = sv_newmortal(); - gv_efullname3(sv, gv, Nullch); - Perl_warner(aTHX_ WARN_IO, - "Filehandle %s opened only for input", - SvPV(sv,n_a)); + /* integrate with report_evil_fh()? */ + char *name = NULL; + if (isGV(gv)) { + SV* sv = sv_newmortal(); + gv_efullname4(sv, gv, Nullch, FALSE); + name = SvPV_nolen(sv); + } + if (name && *name) + Perl_warner(aTHX_ WARN_IO, + "Filehandle %s opened only for input", name); + else + Perl_warner(aTHX_ WARN_IO, + "Filehandle opened only for input"); } - else if (ckWARN(WARN_CLOSED)) - report_closed_fh(gv, io, "print", "filehandle"); + else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; @@ -427,7 +433,7 @@ PP(pp_print) PP(pp_rv2av) { - djSP; dTOPss; + dSP; dTOPss; AV *av; if (SvROK(sv)) { @@ -441,6 +447,12 @@ PP(pp_rv2av) SETs((SV*)av); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); + SETs((SV*)av); + RETURN; + } } else { if (SvTYPE(sv) == SVt_PVAV) { @@ -449,13 +461,20 @@ PP(pp_rv2av) SETs((SV*)av); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return array to lvalue" + " scalar context"); + SETs((SV*)av); + RETURN; + } } else { GV *gv; if (SvTYPE(sv) != SVt_PVGV) { char *sym; - STRLEN n_a; + STRLEN len; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -474,13 +493,17 @@ PP(pp_rv2av) } RETSETUNDEF; } - sym = SvPV(sv,n_a); + sym = SvPV(sv,len); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV); - if (!gv) + if (!gv + && (!is_gv_magical(sym,len,0) + || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV)))) + { RETSETUNDEF; + } } else { if (PL_op->op_private & HINT_STRICT_REFS) @@ -498,6 +521,13 @@ PP(pp_rv2av) SETs((SV*)av); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return array to lvalue" + " scalar context"); + SETs((SV*)av); + RETURN; + } } } @@ -527,7 +557,7 @@ PP(pp_rv2av) PP(pp_rv2hv) { - djSP; dTOPss; + dSP; dTOPss; HV *hv; if (SvROK(sv)) { @@ -541,6 +571,12 @@ PP(pp_rv2hv) SETs((SV*)hv); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); + SETs((SV*)hv); + RETURN; + } } else { if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) { @@ -549,13 +585,20 @@ PP(pp_rv2hv) SETs((SV*)hv); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return hash to lvalue" + " scalar context"); + SETs((SV*)hv); + RETURN; + } } else { GV *gv; if (SvTYPE(sv) != SVt_PVGV) { char *sym; - STRLEN n_a; + STRLEN len; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -574,13 +617,17 @@ PP(pp_rv2hv) } RETSETUNDEF; } - sym = SvPV(sv,n_a); + sym = SvPV(sv,len); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV); - if (!gv) + if (!gv + && (!is_gv_magical(sym,len,0) + || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV)))) + { RETSETUNDEF; + } } else { if (PL_op->op_private & HINT_STRICT_REFS) @@ -598,6 +645,13 @@ PP(pp_rv2hv) SETs((SV*)hv); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return hash to lvalue" + " scalar context"); + SETs((SV*)hv); + RETURN; + } } } @@ -708,7 +762,7 @@ S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) PP(pp_aassign) { - djSP; + dSP; SV **lastlelem = PL_stack_sp; SV **lastrelem = PL_stack_base + POPMARK; SV **firstrelem = PL_stack_base + POPMARK + 1; @@ -919,7 +973,7 @@ PP(pp_aassign) PP(pp_qr) { - djSP; + dSP; register PMOP *pm = cPMOP; SV *rv = sv_newmortal(); SV *sv = newSVrv(rv, "Regexp"); @@ -929,7 +983,7 @@ PP(pp_qr) PP(pp_match) { - djSP; dTARG; + dSP; dTARG; register PMOP *pm = cPMOP; register char *t; register char *s; @@ -956,7 +1010,7 @@ PP(pp_match) s = SvPV(TARG, len); strend = s + len; if (!s) - DIE(aTHX_ "panic: do_match"); + DIE(aTHX_ "panic: pp_match"); rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); TAINT_NOT; @@ -993,7 +1047,7 @@ PP(pp_match) } } } - if ((gimme != G_ARRAY && !global && rx->nparens) + if ((!global && rx->nparens) || SvTEMP(TARG) || PL_sawampersand) r_flags |= REXEC_COPY_STR; if (SvSCREAM(TARG)) @@ -1012,7 +1066,8 @@ play_it_again: if (update_minmatch++) minmatch = had_zerolen; } - if (rx->reganch & RE_USE_INTUIT) { + if (rx->reganch & RE_USE_INTUIT && + DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) { s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL); if (!s) @@ -1021,7 +1076,8 @@ play_it_again: && !PL_sawampersand && ((rx->reganch & ROPT_NOSCAN) || !((rx->reganch & RE_INTUIT_TAIL) - && (r_flags & REXEC_SCREAM)))) + && (r_flags & REXEC_SCREAM))) + && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */ goto yup; } if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags)) @@ -1274,7 +1330,7 @@ Perl_do_readline(pTHX) } else { PerlIO_rewind(tmpfp); - IoTYPE(io) = '<'; + IoTYPE(io) = IoTYPE_RDONLY; IoIFP(io) = fp = tmpfp; IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */ } @@ -1328,23 +1384,33 @@ Perl_do_readline(pTHX) else if (type == OP_GLOB) SP--; else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */ - && (IoTYPE(io) == '>' || fp == PerlIO_stdout() + && (IoTYPE(io) == IoTYPE_WRONLY || fp == PerlIO_stdout() || fp == PerlIO_stderr())) { - SV* sv = sv_newmortal(); - gv_efullname3(sv, PL_last_in_gv, Nullch); - Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output", - SvPV_nolen(sv)); + /* integrate with report_evil_fh()? */ + char *name = NULL; + if (isGV(PL_last_in_gv)) { /* can this ever fail? */ + SV* sv = sv_newmortal(); + gv_efullname4(sv, PL_last_in_gv, Nullch, FALSE); + name = SvPV_nolen(sv); + } + if (name && *name) + Perl_warner(aTHX_ WARN_IO, + "Filehandle %s opened only for output", name); + else + Perl_warner(aTHX_ WARN_IO, + "Filehandle opened only for output"); } } if (!fp) { - if (ckWARN2(WARN_GLOB,WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) { + if (ckWARN2(WARN_GLOB, WARN_CLOSED) + && (!io || !(IoFLAGS(io) & IOf_START))) { if (type == OP_GLOB) Perl_warner(aTHX_ WARN_GLOB, "glob failed (can't start child: %s)", Strerror(errno)); else - report_closed_fh(PL_last_in_gv, io, "readline", "filehandle"); + report_evil_fh(PL_last_in_gv, io, PL_op->op_type); } if (gimme == G_SCALAR) { (void)SvOK_off(TARG); @@ -1371,11 +1437,17 @@ Perl_do_readline(pTHX) offset = 0; } + /* This should not be marked tainted if the fp is marked clean */ +#define MAYBE_TAINT_LINE(io, sv) \ + if (!(IoFLAGS(io) & IOf_UNTAINT)) { \ + TAINT; \ + SvTAINTED_on(sv); \ + } + /* delay EOF state for a snarfed empty file */ #define SNARF_EOF(gimme,rs,io,sv) \ (gimme != G_SCALAR || SvCUR(sv) \ - || !RsSNARF(rs) || (IoFLAGS(io) & IOf_NOLINE) \ - || ((IoFLAGS(io) |= IOf_NOLINE), FALSE)) + || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs)) for (;;) { if (!sv_gets(sv, fp, offset) @@ -1400,14 +1472,12 @@ Perl_do_readline(pTHX) (void)SvOK_off(TARG); PUSHTARG; } + MAYBE_TAINT_LINE(io, sv); RETURN; } - /* This should not be marked tainted if the fp is marked clean */ - if (!(IoFLAGS(io) & IOf_UNTAINT)) { - TAINT; - SvTAINTED_on(sv); - } + MAYBE_TAINT_LINE(io, sv); IoLINES(io)++; + IoFLAGS(io) |= IOf_NOLINE; SvSETMAGIC(sv); XPUSHs(sv); if (type == OP_GLOB) { @@ -1451,7 +1521,7 @@ Perl_do_readline(pTHX) PP(pp_enter) { - djSP; + dSP; register PERL_CONTEXT *cx; I32 gimme = OP_GIMME(PL_op, -1); @@ -1472,12 +1542,12 @@ PP(pp_enter) PP(pp_helem) { - djSP; + dSP; HE* he; SV **svp; SV *keysv = POPs; HV *hv = (HV*)POPs; - U32 lval = PL_op->op_flags & OPf_MOD; + U32 lval = PL_op->op_flags & OPf_MOD || LVRET; U32 defer = PL_op->op_private & OPpLVAL_DEFER; SV *sv; @@ -1535,7 +1605,7 @@ PP(pp_helem) PP(pp_leave) { - djSP; + dSP; register PERL_CONTEXT *cx; register SV **mark; SV **newsp; @@ -1591,7 +1661,7 @@ PP(pp_leave) PP(pp_iter) { - djSP; + dSP; register PERL_CONTEXT *cx; SV* sv; AV* av; @@ -1693,10 +1763,10 @@ PP(pp_iter) PP(pp_subst) { - djSP; dTARG; + dSP; dTARG; register PMOP *pm = cPMOP; PMOP *rpm = pm; - register SV *dstr; + register SV *dstr, *rstr; register char *s; char *strend; register char *m; @@ -1714,15 +1784,20 @@ PP(pp_subst) STRLEN len; int force_on_match = 0; I32 oldsave = PL_savestack_ix; + bool do_utf8; + STRLEN slen; /* known replacement string? */ - dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv; + rstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv; if (PL_op->op_flags & OPf_STACKED) TARG = POPs; else { TARG = DEFSV; EXTEND(SP,1); - } + } + do_utf8 = DO_UTF8(TARG); + if (SvFAKE(TARG) && SvREADONLY(TARG)) + sv_force_normal(TARG); if (SvREADONLY(TARG) || (SvTYPE(TARG) > SVt_PVLV && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))) @@ -1740,12 +1815,13 @@ PP(pp_subst) force_it: if (!pm || !s) - DIE(aTHX_ "panic: do_subst"); + DIE(aTHX_ "panic: pp_subst"); strend = s + len; - maxiters = 2*(strend - s) + 10; /* We can match twice at each - position, once with zero-length, - second time with non-zero. */ + slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len; + maxiters = 2 * slen + 10; /* We can match twice at each + position, once with zero-length, + second time with non-zero. */ if (!rx->prelen && PL_curpm) { pm = PL_curpm; @@ -1779,10 +1855,11 @@ PP(pp_subst) once = !(rpm->op_pmflags & PMf_GLOBAL); /* known replacement string? */ - c = dstr ? SvPV(dstr, clen) : Nullch; + c = rstr ? SvPV(rstr, clen) : Nullch; /* can do inplace substitution? */ if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR)) + && do_utf8 == DO_UTF8(rstr) && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) { if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, r_flags | REXEC_CHECKED)) @@ -1871,7 +1948,7 @@ PP(pp_subst) SPAGAIN; PUSHs(sv_2mortal(newSViv((I32)iters))); } - (void)SvPOK_only(TARG); + (void)SvPOK_only_UTF8(TARG); TAINT_IF(rxtainted); if (SvSMAGICAL(TARG)) { PUTBACK; @@ -1886,6 +1963,8 @@ PP(pp_subst) if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, r_flags | REXEC_CHECKED)) { + bool isutf8; + if (force_on_match) { force_on_match = 0; s = SvPV_force(TARG, len); @@ -1894,6 +1973,8 @@ PP(pp_subst) rxtainted |= RX_MATCH_TAINTED(rx); dstr = NEWSV(25, len); sv_setpvn(dstr, m, s-m); + if (do_utf8) + SvUTF8_on(dstr); PL_curpm = pm; if (!c) { register PERL_CONTEXT *cx; @@ -1917,7 +1998,7 @@ PP(pp_subst) sv_catpvn(dstr, s, m-s); s = rx->endp[0] + orig; if (clen) - sv_catpvn(dstr, c, clen); + sv_catsv(dstr, rstr); if (once) break; } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags)); @@ -1928,6 +2009,7 @@ PP(pp_subst) SvPVX(TARG) = SvPVX(dstr); SvCUR_set(TARG, SvCUR(dstr)); SvLEN_set(TARG, SvLEN(dstr)); + isutf8 = DO_UTF8(dstr); SvPVX(dstr) = 0; sv_free(dstr); @@ -1936,6 +2018,8 @@ PP(pp_subst) PUSHs(sv_2mortal(newSViv((I32)iters))); (void)SvPOK_only(TARG); + if (isutf8) + SvUTF8_on(TARG); TAINT_IF(rxtainted); SvSETMAGIC(TARG); SvTAINT(TARG); @@ -1954,7 +2038,7 @@ ret_no: PP(pp_grepwhile) { - djSP; + dSP; if (SvTRUEx(POPs)) PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; @@ -1995,7 +2079,7 @@ PP(pp_grepwhile) PP(pp_leavesub) { - djSP; + dSP; SV **mark; SV **newsp; PMOP *newpm; @@ -2053,7 +2137,7 @@ PP(pp_leavesub) * get any slower by more conditions */ PP(pp_leavesublv) { - djSP; + dSP; SV **mark; SV **newsp; PMOP *newpm; @@ -2206,7 +2290,6 @@ PP(pp_leavesublv) STATIC CV * S_get_db_sub(pTHX_ SV **svp, CV *cv) { - dTHR; SV *dbsv = GvSV(PL_DBsub); if (!PERLDB_SUB_NN) { @@ -2220,7 +2303,9 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv) && (gv = (GV*)*svp) ))) { /* Use GV from the stack as a fallback. */ /* GV is potentially non-unique, or contain different CV. */ - sv_setsv(dbsv, newRV((SV*)cv)); + SV *tmp = newRV((SV*)cv); + sv_setsv(dbsv, tmp); + SvREFCNT_dec(tmp); } else { gv_efullname3(dbsv, gv, Nullch); @@ -2241,7 +2326,7 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv) PP(pp_entersub) { - djSP; dPOPss; + dSP; dPOPss; GV *gv; HV *stash; register CV *cv; @@ -2643,6 +2728,7 @@ try_autoload: cx->blk_sub.savearray = GvAV(PL_defgv); GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); #endif /* USE_THREADS */ + cx->blk_sub.oldcurpad = PL_curpad; cx->blk_sub.argarray = av; ++MARK; @@ -2698,11 +2784,11 @@ Perl_sub_crush_depth(pTHX_ CV *cv) PP(pp_aelem) { - djSP; + dSP; SV** svp; - I32 elem = POPi; + IV elem = POPi; AV* av = (AV*)POPs; - U32 lval = PL_op->op_flags & OPf_MOD; + U32 lval = PL_op->op_flags & OPf_MOD || LVRET; U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av)); SV *sv; @@ -2771,7 +2857,7 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) PP(pp_method) { - djSP; + dSP; SV* sv = TOPs; if (SvROK(sv)) { @@ -2788,7 +2874,7 @@ PP(pp_method) PP(pp_method_named) { - djSP; + dSP; SV* sv = cSVOP->op_sv; U32 hash = SvUVX(sv); @@ -2811,6 +2897,9 @@ S_method_common(pTHX_ SV* meth, U32* hashp) name = SvPV(meth, namelen); sv = *(PL_stack_base + TOPMARK + 1); + if (!sv) + Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name); + if (SvGMAGICAL(sv)) mg_get(sv); if (SvROK(sv)) @@ -2824,8 +2913,8 @@ S_method_common(pTHX_ SV* meth, U32* hashp) !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) || !(ob=(SV*)GvIO(iogv))) { - if (!packname || - ((*(U8*)packname >= 0xc0 && DO_UTF8(sv)) + if (!packname || + ((UTF8_IS_START(*packname) && DO_UTF8(sv)) ? !isIDFIRST_utf8((U8*)packname) : !isIDFIRST(*packname) )) @@ -2867,6 +2956,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) char* leaf = name; char* sep = Nullch; char* p; + GV* gv; for (p = name; *p; p++) { if (*p == '\'') @@ -2882,9 +2972,18 @@ S_method_common(pTHX_ SV* meth, U32* hashp) packname = name; packlen = sep - name; } - Perl_croak(aTHX_ - "Can't locate object method \"%s\" via package \"%s\"", - leaf, packname); + gv = gv_fetchpv(packname, 0, SVt_PVHV); + if (gv && isGV(gv)) { + Perl_croak(aTHX_ + "Can't locate object method \"%s\" via package \"%s\"", + leaf, packname); + } + else { + Perl_croak(aTHX_ + "Can't locate object method \"%s\" via package \"%s\"" + " (perhaps you forgot to load \"%s\"?)", + leaf, packname, packname); + } } return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv; } @@ -2894,9 +2993,6 @@ static void unset_cvowner(pTHXo_ void *cvarg) { register CV* cv = (CV *) cvarg; -#ifdef DEBUGGING - dTHR; -#endif /* DEBUGGING */ DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n", thr, cv, SvPEEK((SV*)cv)))); diff --git a/contrib/perl5/pp_proto.h b/contrib/perl5/pp_proto.h index 4ce9d7459462..c3b24e864ba8 100644 --- a/contrib/perl5/pp_proto.h +++ b/contrib/perl5/pp_proto.h @@ -29,6 +29,7 @@ PERL_CKDEF(Perl_ck_null) PERL_CKDEF(Perl_ck_open) PERL_CKDEF(Perl_ck_repeat) PERL_CKDEF(Perl_ck_require) +PERL_CKDEF(Perl_ck_return) PERL_CKDEF(Perl_ck_rfun) PERL_CKDEF(Perl_ck_rvconst) PERL_CKDEF(Perl_ck_sassign) @@ -39,6 +40,7 @@ PERL_CKDEF(Perl_ck_sort) PERL_CKDEF(Perl_ck_spair) PERL_CKDEF(Perl_ck_split) PERL_CKDEF(Perl_ck_subr) +PERL_CKDEF(Perl_ck_substr) PERL_CKDEF(Perl_ck_svconst) PERL_CKDEF(Perl_ck_trunc) diff --git a/contrib/perl5/pp_sys.c b/contrib/perl5/pp_sys.c index 0ec539d51fc7..8423bd04cf9a 100644 --- a/contrib/perl5/pp_sys.c +++ b/contrib/perl5/pp_sys.c @@ -1,6 +1,6 @@ /* pp_sys.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,22 +21,22 @@ #ifdef I_SHADOW /* Shadow password support for solaris - pdo@cs.umd.edu * Not just Solaris: at least HP-UX, IRIX, Linux. - * the API is from SysV. --jhi */ -#ifdef __hpux__ + * The API is from SysV. + * + * There are at least two more shadow interfaces, + * see the comments in pp_gpwent(). + * + * --jhi */ +# ifdef __hpux__ /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h> - * and another MAXINT from "perl.h" <- <sys/param.h>. */ -#undef MAXINT -#endif -#include <shadow.h> -#endif - -/* XXX If this causes problems, set i_unistd=undef in the hint file. */ -#ifdef I_UNISTD -# include <unistd.h> + * and another MAXINT from "perl.h" <- <sys/param.h>. */ +# undef MAXINT +# endif +# include <shadow.h> #endif -#ifdef HAS_SYSCALL -#ifdef __cplusplus +#ifdef HAS_SYSCALL +#ifdef __cplusplus extern "C" int syscall(unsigned long,...); #endif #endif @@ -49,25 +49,10 @@ extern "C" int syscall(unsigned long,...); # include <sys/resource.h> #endif -#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */ -# include <sys/socket.h> -# if defined(USE_SOCKS) && defined(I_SOCKS) -# include <socks.h> -# endif -# ifdef I_NETDB -# include <netdb.h> -# endif -# ifndef ENOTSOCK -# ifdef I_NET_ERRNO -# include <net/errno.h> -# endif -# endif -#endif - #ifdef HAS_SELECT -#ifdef I_SYS_SELECT -#include <sys/select.h> -#endif +# ifdef I_SYS_SELECT +# include <sys/select.h> +# endif #endif /* XXX Configure test needed. @@ -137,7 +122,7 @@ extern int h_errno; # include <fcntl.h> # endif -# if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW) +# if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK) # define FLOCK fcntl_emulate_flock # define FCNTL_EMULATE_FLOCK # else /* no flock() or fcntl(F_SETLK,...) */ @@ -195,10 +180,9 @@ static char zero_but_true[ZBTLEN + 1] = "0 but true"; #endif #if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS) -# if defined(I_SYS_SECURITY) +# ifdef I_SYS_SECURITY # include <sys/security.h> # endif - /* XXX Configure test needed for eaccess */ # ifdef ACC_SELF /* HP SecureWare */ # define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF)) @@ -299,7 +283,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) PP(pp_backtick) { - djSP; dTARGET; + dSP; dTARGET; PerlIO *fp; STRLEN n_a; char *tmps = POPpx; @@ -411,7 +395,7 @@ PP(pp_rcatline) PP(pp_warn) { - djSP; dMARK; + dSP; dMARK; SV *tmpsv; char *tmps; STRLEN len; @@ -442,7 +426,7 @@ PP(pp_warn) PP(pp_die) { - djSP; dMARK; + dSP; dMARK; char *tmps; SV *tmpsv; STRLEN len; @@ -501,10 +485,10 @@ PP(pp_die) PP(pp_open) { - djSP; dTARGET; + dSP; dTARGET; GV *gv; SV *sv; - SV *name; + SV *name = Nullsv; I32 have_name = 0; char *tmps; STRLEN len; @@ -552,7 +536,7 @@ PP(pp_open) PP(pp_close) { - djSP; + dSP; GV *gv; MAGIC *mg; @@ -578,7 +562,7 @@ PP(pp_close) PP(pp_pipe_op) { - djSP; + dSP; #ifdef HAS_PIPE GV *rgv; GV *wgv; @@ -608,8 +592,8 @@ PP(pp_pipe_op) IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"); IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"); IoIFP(wstio) = IoOFP(wstio); - IoTYPE(rstio) = '<'; - IoTYPE(wstio) = '>'; + IoTYPE(rstio) = IoTYPE_RDONLY; + IoTYPE(wstio) = IoTYPE_WRONLY; if (!IoIFP(rstio) || !IoOFP(wstio)) { if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio)); @@ -633,7 +617,7 @@ badexit: PP(pp_fileno) { - djSP; dTARGET; + dSP; dTARGET; GV *gv; IO *io; PerlIO *fp; @@ -662,7 +646,7 @@ PP(pp_fileno) PP(pp_umask) { - djSP; dTARGET; + dSP; dTARGET; Mode_t anum; #ifdef HAS_UMASK @@ -687,7 +671,7 @@ PP(pp_umask) PP(pp_binmode) { - djSP; + dSP; GV *gv; IO *io; PerlIO *fp; @@ -699,7 +683,7 @@ PP(pp_binmode) if (MAXARG > 1) discp = POPs; - gv = (GV*)POPs; + gv = (GV*)POPs; if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) { PUSHMARK(SP); @@ -718,7 +702,7 @@ PP(pp_binmode) if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) RETPUSHUNDEF; - if (do_binmode(fp,IoTYPE(io),mode_from_discipline(discp))) + if (do_binmode(fp,IoTYPE(io),mode_from_discipline(discp))) RETPUSHYES; else RETPUSHUNDEF; @@ -726,7 +710,7 @@ PP(pp_binmode) PP(pp_tie) { - djSP; + dSP; dMARK; SV *varsv; HV* stash; @@ -765,7 +749,7 @@ PP(pp_tie) PUSHs(*MARK++); PUTBACK; call_method(methname, G_SCALAR); - } + } else { /* Not clear why we don't call call_method here too. * perhaps to get different error message ? @@ -773,7 +757,7 @@ PP(pp_tie) stash = gv_stashsv(*MARK, FALSE); if (!stash || !(gv = gv_fetchmethod(stash, methname))) { DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"", - methname, SvPV(*MARK,n_a)); + methname, SvPV(*MARK,n_a)); } ENTER; PUSHSTACKi(PERLSI_MAGIC); @@ -800,27 +784,40 @@ PP(pp_tie) PP(pp_untie) { - djSP; + dSP; SV *sv = POPs; char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q'; - if (ckWARN(WARN_UNTIE)) { MAGIC * mg ; if ((mg = SvTIED_mg(sv, how))) { - if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1) + SV *obj = SvRV(mg->mg_obj); + GV *gv; + CV *cv = NULL; + if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) && + isGV(gv) && (cv = GvCV(gv))) { + PUSHMARK(SP); + XPUSHs(SvTIED_obj((SV*)gv, mg)); + XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1))); + PUTBACK; + ENTER; + call_sv((SV *)cv, G_VOID); + LEAVE; + SPAGAIN; + } + else if (ckWARN(WARN_UNTIE)) { + if (mg && SvREFCNT(obj) > 1) Perl_warner(aTHX_ WARN_UNTIE, "untie attempted while %"UVuf" inner references still exist", - (UV)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ; + (UV)SvREFCNT(obj) - 1 ) ; } } - sv_unmagic(sv, how); RETPUSHYES; } PP(pp_tied) { - djSP; + dSP; SV *sv = POPs; char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q'; MAGIC *mg; @@ -837,7 +834,7 @@ PP(pp_tied) PP(pp_dbmopen) { - djSP; + dSP; HV *hv; dPOPPOPssrl; HV* stash; @@ -885,7 +882,7 @@ PP(pp_dbmopen) } if (sv_isobject(TOPs)) { - sv_unmagic((SV *) hv, 'P'); + sv_unmagic((SV *) hv, 'P'); sv_magic((SV*)hv, TOPs, 'P', Nullch, 0); } LEAVE; @@ -899,7 +896,7 @@ PP(pp_dbmclose) PP(pp_sselect) { - djSP; dTARGET; + dSP; dTARGET; #ifdef HAS_SELECT register I32 i; register I32 j; @@ -1041,7 +1038,6 @@ PP(pp_sselect) void Perl_setdefout(pTHX_ GV *gv) { - dTHR; if (gv) (void)SvREFCNT_inc(gv); if (PL_defoutgv) @@ -1051,7 +1047,7 @@ Perl_setdefout(pTHX_ GV *gv) PP(pp_select) { - djSP; dTARGET; + dSP; dTARGET; GV *newdefout, *egv; HV *hv; @@ -1066,7 +1062,7 @@ PP(pp_select) else { GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE); if (gvp && *gvp == egv) { - gv_efullname3(TARG, PL_defoutgv, Nullch); + gv_efullname4(TARG, PL_defoutgv, Nullch, TRUE); XPUSHTARG; } else { @@ -1085,7 +1081,7 @@ PP(pp_select) PP(pp_getc) { - djSP; dTARGET; + dSP; dTARGET; GV *gv; MAGIC *mg; @@ -1124,7 +1120,6 @@ PP(pp_read) STATIC OP * S_doform(pTHX_ CV *cv, GV *gv, OP *retop) { - dTHR; register PERL_CONTEXT *cx; I32 gimme = GIMME_V; AV* padlist = CvPADLIST(cv); @@ -1145,7 +1140,7 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) PP(pp_enterwrite) { - djSP; + dSP; register GV *gv; register IO *io; GV *fgv; @@ -1170,11 +1165,14 @@ PP(pp_enterwrite) cv = GvFORM(fgv); if (!cv) { + char *name = NULL; if (fgv) { SV *tmpsv = sv_newmortal(); - gv_efullname3(tmpsv, fgv, Nullch); - DIE(aTHX_ "Undefined format \"%s\" called",SvPVX(tmpsv)); + gv_efullname4(tmpsv, fgv, Nullch, FALSE); + name = SvPV_nolen(tmpsv); } + if (name && *name) + DIE(aTHX_ "Undefined format \"%s\" called", name); DIE(aTHX_ "Not a format reference"); } if (CvCLONE(cv)) @@ -1186,7 +1184,7 @@ PP(pp_enterwrite) PP(pp_leavewrite) { - djSP; + dSP; GV *gv = cxstack[cxstack_ix].blk_sub.gv; register IO *io = GvIOp(gv); PerlIO *ofp = IoOFP(io); @@ -1251,10 +1249,19 @@ PP(pp_leavewrite) if (!fgv) DIE(aTHX_ "bad top format reference"); cv = GvFORM(fgv); - if (!cv) { - SV *tmpsv = sv_newmortal(); - gv_efullname3(tmpsv, fgv, Nullch); - DIE(aTHX_ "Undefined top format \"%s\" called",SvPVX(tmpsv)); + { + char *name = NULL; + if (!cv) { + SV *sv = sv_newmortal(); + gv_efullname4(sv, fgv, Nullch, FALSE); + name = SvPV_nolen(sv); + } + if (name && *name) + DIE(aTHX_ "Undefined top format \"%s\" called",name); + /* why no: + else + DIE(aTHX_ "Undefined top format called"); + ?*/ } if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); @@ -1270,14 +1277,22 @@ PP(pp_leavewrite) if (!fp) { if (ckWARN2(WARN_CLOSED,WARN_IO)) { if (IoIFP(io)) { - SV* sv = sv_newmortal(); - gv_efullname3(sv, gv, Nullch); - Perl_warner(aTHX_ WARN_IO, - "Filehandle %s opened only for input", - SvPV_nolen(sv)); + /* integrate with report_evil_fh()? */ + char *name = NULL; + if (isGV(gv)) { + SV* sv = sv_newmortal(); + gv_efullname4(sv, gv, Nullch, FALSE); + name = SvPV_nolen(sv); + } + if (name && *name) + Perl_warner(aTHX_ WARN_IO, + "Filehandle %s opened only for input", name); + else + Perl_warner(aTHX_ WARN_IO, + "Filehandle opened only for input"); } else if (ckWARN(WARN_CLOSED)) - report_closed_fh(gv, io, "write", "filehandle"); + report_evil_fh(gv, io, PL_op->op_type); } PUSHs(&PL_sv_no); } @@ -1305,7 +1320,7 @@ PP(pp_leavewrite) PP(pp_prtf) { - djSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; GV *gv; IO *io; PerlIO *fp; @@ -1340,24 +1355,29 @@ PP(pp_prtf) sv = NEWSV(0,0); if (!(io = GvIO(gv))) { - if (ckWARN(WARN_UNOPENED)) { - gv_efullname3(sv, gv, Nullch); - Perl_warner(aTHX_ WARN_UNOPENED, - "Filehandle %s never opened", SvPV(sv,n_a)); - } + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS$_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { if (ckWARN2(WARN_CLOSED,WARN_IO)) { + /* integrate with report_evil_fh()? */ if (IoIFP(io)) { - gv_efullname3(sv, gv, Nullch); - Perl_warner(aTHX_ WARN_IO, - "Filehandle %s opened only for input", - SvPV(sv,n_a)); + char *name = NULL; + if (isGV(gv)) { + gv_efullname4(sv, gv, Nullch, FALSE); + name = SvPV_nolen(sv); + } + if (name && *name) + Perl_warner(aTHX_ WARN_IO, + "Filehandle %s opened only for input", name); + else + Perl_warner(aTHX_ WARN_IO, + "Filehandle opened only for input"); } else if (ckWARN(WARN_CLOSED)) - report_closed_fh(gv, io, "printf", "filehandle"); + report_evil_fh(gv, io, PL_op->op_type); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; @@ -1385,7 +1405,7 @@ PP(pp_prtf) PP(pp_sysopen) { - djSP; + dSP; GV *gv; SV *sv; char *tmps; @@ -1415,7 +1435,7 @@ PP(pp_sysopen) PP(pp_sysread) { - djSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; int offset; GV *gv; IO *io; @@ -1473,16 +1493,16 @@ PP(pp_sysread) if (bufsize >= 256) bufsize = 255; #endif -#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */ - if (bufsize >= 256) - bufsize = 255; -#endif buffer = SvGROW(bufsv, length+1); /* 'offset' means 'flags' here */ length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset, (struct sockaddr *)namebuf, &bufsize); if (length < 0) RETPUSHUNDEF; +#ifdef EPOC + /* Bogus return without padding */ + bufsize = sizeof (struct sockaddr_in); +#endif SvCUR_set(bufsv, length); *SvEND(bufsv) = '\0'; (void)SvPOK_only(bufsv); @@ -1511,7 +1531,7 @@ PP(pp_sysread) } if (PL_op->op_type == OP_SYSREAD) { #ifdef PERL_SOCK_SYSREAD_IS_RECV - if (IoTYPE(io) == 's') { + if (IoTYPE(io) == IoTYPE_SOCKET) { length = PerlSock_recv(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0); } @@ -1524,7 +1544,7 @@ PP(pp_sysread) } else #ifdef HAS_SOCKET__bad_code_maybe - if (IoTYPE(io) == 's') { + if (IoTYPE(io) == IoTYPE_SOCKET) { char namebuf[MAXPATHLEN]; #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS) bufsize = sizeof (struct sockaddr_in); @@ -1543,13 +1563,22 @@ PP(pp_sysread) length = -1; } if (length < 0) { - if ((IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout() + if ((IoTYPE(io) == IoTYPE_WRONLY || IoIFP(io) == PerlIO_stdout() || IoIFP(io) == PerlIO_stderr()) && ckWARN(WARN_IO)) { - SV* sv = sv_newmortal(); - gv_efullname3(sv, gv, Nullch); - Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output", - SvPV_nolen(sv)); + /* integrate with report_evil_fh()? */ + char *name = NULL; + if (isGV(gv)) { + SV* sv = sv_newmortal(); + gv_efullname4(sv, gv, Nullch, FALSE); + name = SvPV_nolen(sv); + } + if (name && *name) + Perl_warner(aTHX_ WARN_IO, + "Filehandle %s opened only for output", name); + else + Perl_warner(aTHX_ WARN_IO, + "Filehandle opened only for output"); } goto say_undef; } @@ -1571,7 +1600,7 @@ PP(pp_sysread) PP(pp_syswrite) { - djSP; + dSP; int items = (SP - PL_stack_base) - TOPMARK; if (items == 2) { SV *sv; @@ -1585,7 +1614,7 @@ PP(pp_syswrite) PP(pp_send) { - djSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; GV *gv; IO *io; SV *bufsv; @@ -1626,12 +1655,8 @@ PP(pp_send) io = GvIO(gv); if (!io || !IoIFP(io)) { retval = -1; - if (ckWARN(WARN_CLOSED)) { - if (PL_op->op_type == OP_SYSWRITE) - report_closed_fh(gv, io, "syswrite", "filehandle"); - else - report_closed_fh(gv, io, "send", "socket"); - } + if (ckWARN(WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); } else if (PL_op->op_type == OP_SYSWRITE) { if (MARK < SP) { @@ -1647,7 +1672,7 @@ PP(pp_send) if (length > blen - offset) length = blen - offset; #ifdef PERL_SOCK_SYSWRITE_IS_SEND - if (IoTYPE(io) == 's') { + if (IoTYPE(io) == IoTYPE_SOCKET) { retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0); } @@ -1696,7 +1721,7 @@ PP(pp_recv) PP(pp_eof) { - djSP; + dSP; GV *gv; MAGIC *mg; @@ -1740,8 +1765,8 @@ PP(pp_eof) PP(pp_tell) { - djSP; dTARGET; - GV *gv; + dSP; dTARGET; + GV *gv; MAGIC *mg; if (MAXARG == 0) @@ -1775,7 +1800,7 @@ PP(pp_seek) PP(pp_sysseek) { - djSP; + dSP; GV *gv; int whence = POPi; #if LSEEKSIZE > IVSIZE @@ -1826,7 +1851,7 @@ PP(pp_sysseek) PP(pp_truncate) { - djSP; + dSP; /* There seems to be no consensus on the length type of truncate() * and ftruncate(), both off_t and size_t have supporters. In * general one would think that when using large files, off_t is @@ -1843,7 +1868,7 @@ PP(pp_truncate) len = (Off_t)POPi; #endif /* Checking for length < 0 is problematic as the type might or - * might not be signed: if it is not, clever compilers will moan. */ + * might not be signed: if it is not, clever compilers will moan. */ /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */ SETERRNO(0,0); #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP) @@ -1857,7 +1882,7 @@ PP(pp_truncate) PerlIO_flush(IoIFP(GvIOp(tmpgv))); #ifdef HAS_TRUNCATE if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) -#else +#else if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) #endif result = 0; @@ -1913,7 +1938,7 @@ PP(pp_fcntl) PP(pp_ioctl) { - djSP; dTARGET; + dSP; dTARGET; SV *argsv = POPs; unsigned int func = U_I(POPn); int optype = PL_op->op_type; @@ -1958,7 +1983,7 @@ PP(pp_ioctl) retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s); #else retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s); -#endif +#endif #else DIE(aTHX_ "fcntl is not implemented"); #endif @@ -1984,10 +2009,11 @@ PP(pp_ioctl) PP(pp_flock) { - djSP; dTARGET; + dSP; dTARGET; I32 value; int argtype; GV *gv; + IO *io = NULL; PerlIO *fp; #ifdef FLOCK @@ -1996,19 +2022,21 @@ PP(pp_flock) gv = PL_last_in_gv; else gv = (GV*)POPs; - if (gv && GvIO(gv)) - fp = IoIFP(GvIOp(gv)); - else + if (gv && (io = GvIO(gv))) + fp = IoIFP(io); + else { fp = Nullfp; + io = NULL; + } if (fp) { (void)PerlIO_flush(fp); value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0); } else { + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); value = 0; SETERRNO(EBADF,RMS$_IFI); - if (ckWARN(WARN_CLOSED)) - report_closed_fh(gv, GvIO(gv), "flock", "filehandle"); } PUSHi(value); RETURN; @@ -2021,7 +2049,7 @@ PP(pp_flock) PP(pp_socket) { - djSP; + dSP; #ifdef HAS_SOCKET GV *gv; register IO *io; @@ -2047,7 +2075,7 @@ PP(pp_socket) RETPUSHUNDEF; IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */ IoOFP(io) = PerlIO_fdopen(fd, "w"); - IoTYPE(io) = 's'; + IoTYPE(io) = IoTYPE_SOCKET; if (!IoIFP(io) || !IoOFP(io)) { if (IoIFP(io)) PerlIO_close(IoIFP(io)); if (IoOFP(io)) PerlIO_close(IoOFP(io)); @@ -2058,6 +2086,10 @@ PP(pp_socket) fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ #endif +#ifdef EPOC + setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */ +#endif + RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "socket"); @@ -2066,7 +2098,7 @@ PP(pp_socket) PP(pp_sockpair) { - djSP; + dSP; #ifdef HAS_SOCKETPAIR GV *gv1; GV *gv2; @@ -2094,10 +2126,10 @@ PP(pp_sockpair) RETPUSHUNDEF; IoIFP(io1) = PerlIO_fdopen(fd[0], "r"); IoOFP(io1) = PerlIO_fdopen(fd[0], "w"); - IoTYPE(io1) = 's'; + IoTYPE(io1) = IoTYPE_SOCKET; IoIFP(io2) = PerlIO_fdopen(fd[1], "r"); IoOFP(io2) = PerlIO_fdopen(fd[1], "w"); - IoTYPE(io2) = 's'; + IoTYPE(io2) = IoTYPE_SOCKET; if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) { if (IoIFP(io1)) PerlIO_close(IoIFP(io1)); if (IoOFP(io1)) PerlIO_close(IoOFP(io1)); @@ -2120,7 +2152,7 @@ PP(pp_sockpair) PP(pp_bind) { - djSP; + dSP; #ifdef HAS_SOCKET #ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */ extern GETPRIVMODE(); @@ -2169,7 +2201,7 @@ PP(pp_bind) nuts: if (ckWARN(WARN_CLOSED)) - report_closed_fh(gv, io, "bind", "socket"); + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else @@ -2179,7 +2211,7 @@ nuts: PP(pp_connect) { - djSP; + dSP; #ifdef HAS_SOCKET SV *addrsv = POPs; char *addr; @@ -2199,7 +2231,7 @@ PP(pp_connect) nuts: if (ckWARN(WARN_CLOSED)) - report_closed_fh(gv, io, "connect", "socket"); + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else @@ -2209,7 +2241,7 @@ nuts: PP(pp_listen) { - djSP; + dSP; #ifdef HAS_SOCKET int backlog = POPi; GV *gv = (GV*)POPs; @@ -2225,7 +2257,7 @@ PP(pp_listen) nuts: if (ckWARN(WARN_CLOSED)) - report_closed_fh(gv, io, "listen", "socket"); + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else @@ -2235,7 +2267,7 @@ nuts: PP(pp_accept) { - djSP; dTARGET; + dSP; dTARGET; #ifdef HAS_SOCKET GV *ngv; GV *ggv; @@ -2266,7 +2298,7 @@ PP(pp_accept) goto badexit; IoIFP(nstio) = PerlIO_fdopen(fd, "r"); IoOFP(nstio) = PerlIO_fdopen(fd, "w"); - IoTYPE(nstio) = 's'; + IoTYPE(nstio) = IoTYPE_SOCKET; if (!IoIFP(nstio) || !IoOFP(nstio)) { if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio)); if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio)); @@ -2277,12 +2309,17 @@ PP(pp_accept) fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ #endif +#ifdef EPOC + len = sizeof saddr; /* EPOC somehow truncates info */ + setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */ +#endif + PUSHp((char *)&saddr, len); RETURN; nuts: if (ckWARN(WARN_CLOSED)) - report_closed_fh(ggv, ggv ? GvIO(ggv) : 0, "accept", "socket"); + report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type); SETERRNO(EBADF,SS$_IVCHAN); badexit: @@ -2295,7 +2332,7 @@ badexit: PP(pp_shutdown) { - djSP; dTARGET; + dSP; dTARGET; #ifdef HAS_SOCKET int how = POPi; GV *gv = (GV*)POPs; @@ -2309,7 +2346,7 @@ PP(pp_shutdown) nuts: if (ckWARN(WARN_CLOSED)) - report_closed_fh(gv, io, "shutdown", "socket"); + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else @@ -2328,7 +2365,7 @@ PP(pp_gsockopt) PP(pp_ssockopt) { - djSP; + dSP; #ifdef HAS_SOCKET int optype = PL_op->op_type; SV *sv; @@ -2388,9 +2425,7 @@ PP(pp_ssockopt) nuts: if (ckWARN(WARN_CLOSED)) - report_closed_fh(gv, io, - optype == OP_GSOCKOPT ? "getsockopt" : "setsockopt", - "socket"); + report_evil_fh(gv, io, optype); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; @@ -2411,7 +2446,7 @@ PP(pp_getsockname) PP(pp_getpeername) { - djSP; + dSP; #ifdef HAS_SOCKET int optype = PL_op->op_type; SV *sv; @@ -2444,7 +2479,7 @@ PP(pp_getpeername) if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET && !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere, sizeof(u_short) + sizeof(struct in_addr))) { - goto nuts2; + goto nuts2; } } #endif @@ -2463,10 +2498,7 @@ PP(pp_getpeername) nuts: if (ckWARN(WARN_CLOSED)) - report_closed_fh(gv, io, - optype == OP_GETSOCKNAME ? "getsockname" - : "getpeername", - "socket"); + report_evil_fh(gv, io, optype); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; @@ -2485,33 +2517,36 @@ PP(pp_lstat) PP(pp_stat) { - djSP; - GV *tmpgv; + dSP; + GV *gv; I32 gimme; I32 max = 13; STRLEN n_a; if (PL_op->op_flags & OPf_REF) { - tmpgv = cGVOP_gv; + gv = cGVOP_gv; do_fstat: - if (tmpgv != PL_defgv) { + if (gv != PL_defgv) { PL_laststype = OP_STAT; - PL_statgv = tmpgv; + PL_statgv = gv; sv_setpv(PL_statname, ""); - PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv)) - ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1); + PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv)) + ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1); } - if (PL_laststatval < 0) + if (PL_laststatval < 0) { + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, GvIO(gv), PL_op->op_type); max = 0; + } } else { SV* sv = POPs; if (SvTYPE(sv) == SVt_PVGV) { - tmpgv = (GV*)sv; + gv = (GV*)sv; goto do_fstat; } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { - tmpgv = (GV*)SvRV(sv); + gv = (GV*)SvRV(sv); goto do_fstat; } sv_setpv(PL_statname, SvPV(sv,n_a)); @@ -2552,7 +2587,7 @@ PP(pp_stat) PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid))); # endif #endif -#if Gid_t_size > IVSIZE +#if Gid_t_size > IVSIZE PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid))); #else # if Gid_t_sign <= 0 @@ -2594,7 +2629,7 @@ PP(pp_stat) PP(pp_ftrread) { I32 result; - djSP; + dSP; #if defined(HAS_ACCESS) && defined(R_OK) STRLEN n_a; if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { @@ -2621,7 +2656,7 @@ PP(pp_ftrread) PP(pp_ftrwrite) { I32 result; - djSP; + dSP; #if defined(HAS_ACCESS) && defined(W_OK) STRLEN n_a; if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { @@ -2648,7 +2683,7 @@ PP(pp_ftrwrite) PP(pp_ftrexec) { I32 result; - djSP; + dSP; #if defined(HAS_ACCESS) && defined(X_OK) STRLEN n_a; if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { @@ -2675,7 +2710,7 @@ PP(pp_ftrexec) PP(pp_fteread) { I32 result; - djSP; + dSP; #ifdef PERL_EFF_ACCESS_R_OK STRLEN n_a; if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { @@ -2702,7 +2737,7 @@ PP(pp_fteread) PP(pp_ftewrite) { I32 result; - djSP; + dSP; #ifdef PERL_EFF_ACCESS_W_OK STRLEN n_a; if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { @@ -2729,7 +2764,7 @@ PP(pp_ftewrite) PP(pp_fteexec) { I32 result; - djSP; + dSP; #ifdef PERL_EFF_ACCESS_X_OK STRLEN n_a; if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { @@ -2756,7 +2791,7 @@ PP(pp_fteexec) PP(pp_ftis) { I32 result = my_stat(); - djSP; + dSP; if (result < 0) RETPUSHUNDEF; RETPUSHYES; @@ -2770,7 +2805,7 @@ PP(pp_fteowned) PP(pp_ftrowned) { I32 result = my_stat(); - djSP; + dSP; if (result < 0) RETPUSHUNDEF; if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? @@ -2782,7 +2817,7 @@ PP(pp_ftrowned) PP(pp_ftzero) { I32 result = my_stat(); - djSP; + dSP; if (result < 0) RETPUSHUNDEF; if (PL_statcache.st_size == 0) @@ -2793,7 +2828,7 @@ PP(pp_ftzero) PP(pp_ftsize) { I32 result = my_stat(); - djSP; dTARGET; + dSP; dTARGET; if (result < 0) RETPUSHUNDEF; #if Off_t_size > IVSIZE @@ -2807,7 +2842,7 @@ PP(pp_ftsize) PP(pp_ftmtime) { I32 result = my_stat(); - djSP; dTARGET; + dSP; dTARGET; if (result < 0) RETPUSHUNDEF; PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 ); @@ -2817,7 +2852,7 @@ PP(pp_ftmtime) PP(pp_ftatime) { I32 result = my_stat(); - djSP; dTARGET; + dSP; dTARGET; if (result < 0) RETPUSHUNDEF; PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 ); @@ -2827,7 +2862,7 @@ PP(pp_ftatime) PP(pp_ftctime) { I32 result = my_stat(); - djSP; dTARGET; + dSP; dTARGET; if (result < 0) RETPUSHUNDEF; PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 ); @@ -2837,7 +2872,7 @@ PP(pp_ftctime) PP(pp_ftsock) { I32 result = my_stat(); - djSP; + dSP; if (result < 0) RETPUSHUNDEF; if (S_ISSOCK(PL_statcache.st_mode)) @@ -2848,7 +2883,7 @@ PP(pp_ftsock) PP(pp_ftchr) { I32 result = my_stat(); - djSP; + dSP; if (result < 0) RETPUSHUNDEF; if (S_ISCHR(PL_statcache.st_mode)) @@ -2859,7 +2894,7 @@ PP(pp_ftchr) PP(pp_ftblk) { I32 result = my_stat(); - djSP; + dSP; if (result < 0) RETPUSHUNDEF; if (S_ISBLK(PL_statcache.st_mode)) @@ -2870,7 +2905,7 @@ PP(pp_ftblk) PP(pp_ftfile) { I32 result = my_stat(); - djSP; + dSP; if (result < 0) RETPUSHUNDEF; if (S_ISREG(PL_statcache.st_mode)) @@ -2881,7 +2916,7 @@ PP(pp_ftfile) PP(pp_ftdir) { I32 result = my_stat(); - djSP; + dSP; if (result < 0) RETPUSHUNDEF; if (S_ISDIR(PL_statcache.st_mode)) @@ -2892,7 +2927,7 @@ PP(pp_ftdir) PP(pp_ftpipe) { I32 result = my_stat(); - djSP; + dSP; if (result < 0) RETPUSHUNDEF; if (S_ISFIFO(PL_statcache.st_mode)) @@ -2903,7 +2938,7 @@ PP(pp_ftpipe) PP(pp_ftlink) { I32 result = my_lstat(); - djSP; + dSP; if (result < 0) RETPUSHUNDEF; if (S_ISLNK(PL_statcache.st_mode)) @@ -2913,7 +2948,7 @@ PP(pp_ftlink) PP(pp_ftsuid) { - djSP; + dSP; #ifdef S_ISUID I32 result = my_stat(); SPAGAIN; @@ -2927,7 +2962,7 @@ PP(pp_ftsuid) PP(pp_ftsgid) { - djSP; + dSP; #ifdef S_ISGID I32 result = my_stat(); SPAGAIN; @@ -2941,7 +2976,7 @@ PP(pp_ftsgid) PP(pp_ftsvtx) { - djSP; + dSP; #ifdef S_ISVTX I32 result = my_stat(); SPAGAIN; @@ -2955,7 +2990,7 @@ PP(pp_ftsvtx) PP(pp_fttty) { - djSP; + dSP; int fd; GV *gv; char *tmps = Nullch; @@ -2991,7 +3026,7 @@ PP(pp_fttty) PP(pp_fttext) { - djSP; + dSP; I32 i; I32 len; I32 odd = 0; @@ -3053,10 +3088,9 @@ PP(pp_fttext) len = 512; } else { - if (ckWARN(WARN_UNOPENED)) { + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) { gv = cGVOP_gv; - Perl_warner(aTHX_ WARN_UNOPENED, "Test on unopened file <%s>", - GvENAME(gv)); + report_evil_fh(gv, GvIO(gv), PL_op->op_type); } SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; @@ -3078,7 +3112,7 @@ PP(pp_fttext) (void)PerlIO_close(fp); RETPUSHUNDEF; } - do_binmode(fp, '<', TRUE); + do_binmode(fp, '<', O_BINARY); len = PerlIO_read(fp, tbuf, sizeof(tbuf)); (void)PerlIO_close(fp); if (len <= 0) { @@ -3104,7 +3138,7 @@ PP(pp_fttext) break; } #ifdef EBCDIC - else if (!(isPRINT(*s) || isSPACE(*s))) + else if (!(isPRINT(*s) || isSPACE(*s))) odd++; #else else if (*s & 128) { @@ -3113,12 +3147,12 @@ PP(pp_fttext) continue; #endif /* utf8 characters don't count as odd */ - if (*s & 0x40) { + if (UTF8_IS_START(*s)) { int ulen = UTF8SKIP(s); if (ulen < len - i) { int j; for (j = 1; j < ulen; j++) { - if ((s[j] & 0xc0) != 0x80) + if (!UTF8_IS_CONTINUATION(s[j])) goto not_utf8; } --ulen; /* loop does extra increment */ @@ -3152,7 +3186,7 @@ PP(pp_ftbinary) PP(pp_chdir) { - djSP; dTARGET; + dSP; dTARGET; char *tmps; SV **svp; STRLEN n_a; @@ -3190,7 +3224,7 @@ PP(pp_chdir) PP(pp_chown) { - djSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; I32 value; #ifdef HAS_CHOWN value = (I32)apply(PL_op->op_type, MARK, SP); @@ -3204,7 +3238,7 @@ PP(pp_chown) PP(pp_chroot) { - djSP; dTARGET; + dSP; dTARGET; char *tmps; #ifdef HAS_CHROOT STRLEN n_a; @@ -3219,7 +3253,7 @@ PP(pp_chroot) PP(pp_unlink) { - djSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; I32 value; value = (I32)apply(PL_op->op_type, MARK, SP); SP = MARK; @@ -3229,7 +3263,7 @@ PP(pp_unlink) PP(pp_chmod) { - djSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; I32 value; value = (I32)apply(PL_op->op_type, MARK, SP); SP = MARK; @@ -3239,7 +3273,7 @@ PP(pp_chmod) PP(pp_utime) { - djSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; I32 value; value = (I32)apply(PL_op->op_type, MARK, SP); SP = MARK; @@ -3249,7 +3283,7 @@ PP(pp_utime) PP(pp_rename) { - djSP; dTARGET; + dSP; dTARGET; int anum; STRLEN n_a; @@ -3276,7 +3310,7 @@ PP(pp_rename) PP(pp_link) { - djSP; dTARGET; + dSP; dTARGET; #ifdef HAS_LINK STRLEN n_a; char *tmps2 = POPpx; @@ -3291,7 +3325,7 @@ PP(pp_link) PP(pp_symlink) { - djSP; dTARGET; + dSP; dTARGET; #ifdef HAS_SYMLINK STRLEN n_a; char *tmps2 = POPpx; @@ -3306,7 +3340,7 @@ PP(pp_symlink) PP(pp_readlink) { - djSP; dTARGET; + dSP; dTARGET; #ifdef HAS_SYMLINK char *tmps; char buf[MAXPATHLEN]; @@ -3418,7 +3452,7 @@ S_dooneliner(pTHX_ char *cmd, char *filename) PP(pp_mkdir) { - djSP; dTARGET; + dSP; dTARGET; int mode; #ifndef HAS_MKDIR int oldumask; @@ -3447,7 +3481,7 @@ PP(pp_mkdir) PP(pp_rmdir) { - djSP; dTARGET; + dSP; dTARGET; char *tmps; STRLEN n_a; @@ -3465,7 +3499,7 @@ PP(pp_rmdir) PP(pp_open_dir) { - djSP; + dSP; #if defined(Direntry_t) && defined(HAS_READDIR) STRLEN n_a; char *dirname = POPpx; @@ -3492,7 +3526,7 @@ nope: PP(pp_readdir) { - djSP; + dSP; #if defined(Direntry_t) && defined(HAS_READDIR) #ifndef I_DIRENT Direntry_t *readdir (DIR *); @@ -3550,7 +3584,7 @@ nope: PP(pp_telldir) { - djSP; dTARGET; + dSP; dTARGET; #if defined(HAS_TELLDIR) || defined(telldir) /* XXX does _anyone_ need this? --AD 2/20/1998 */ /* XXX netbsd still seemed to. @@ -3578,7 +3612,7 @@ nope: PP(pp_seekdir) { - djSP; + dSP; #if defined(HAS_SEEKDIR) || defined(seekdir) long along = POPl; GV *gv = (GV*)POPs; @@ -3601,7 +3635,7 @@ nope: PP(pp_rewinddir) { - djSP; + dSP; #if defined(HAS_REWINDDIR) || defined(rewinddir) GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); @@ -3622,7 +3656,7 @@ nope: PP(pp_closedir) { - djSP; + dSP; #if defined(Direntry_t) && defined(HAS_READDIR) GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); @@ -3655,7 +3689,7 @@ nope: PP(pp_fork) { #ifdef HAS_FORK - djSP; dTARGET; + dSP; dTARGET; Pid_t childpid; GV *tmpgv; @@ -3674,12 +3708,14 @@ PP(pp_fork) RETURN; #else # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) - djSP; dTARGET; + dSP; dTARGET; Pid_t childpid; EXTEND(SP, 1); PERL_FLUSHALL_FOR_CHILD; childpid = PerlProc_fork(); + if (childpid == -1) + RETSETUNDEF; PUSHi(childpid); RETURN; # else @@ -3690,13 +3726,18 @@ PP(pp_fork) PP(pp_wait) { -#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) - djSP; dTARGET; +#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) + dSP; dTARGET; Pid_t childpid; int argflags; childpid = wait4pid(-1, &argflags, 0); +# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) + /* 0 and -1 are both error returns (the former applies to WNOHANG case) */ + STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1); +# else STATUS_NATIVE_SET((childpid > 0) ? argflags : -1); +# endif XPUSHi(childpid); RETURN; #else @@ -3706,8 +3747,8 @@ PP(pp_wait) PP(pp_waitpid) { -#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) - djSP; dTARGET; +#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) + dSP; dTARGET; Pid_t childpid; int optype; int argflags; @@ -3715,7 +3756,12 @@ PP(pp_waitpid) optype = POPi; childpid = TOPi; childpid = wait4pid(childpid, &argflags, optype); +# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) + /* 0 and -1 are both error returns (the former applies to WNOHANG case) */ + STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1); +# else STATUS_NATIVE_SET((childpid > 0) ? argflags : -1); +# endif SETi(childpid); RETURN; #else @@ -3725,7 +3771,7 @@ PP(pp_waitpid) PP(pp_system) { - djSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; I32 value; Pid_t childpid; int result; @@ -3743,7 +3789,7 @@ PP(pp_system) } } PERL_FLUSHALL_FOR_CHILD; -#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) +#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__) if (PerlProc_pipe(pp) >= 0) did_pipes = 1; while ((childpid = vfork()) == -1) { @@ -3812,6 +3858,8 @@ PP(pp_system) } PerlProc__exit(-1); #else /* ! FORK or VMS or OS/2 */ + PL_statusvalue = 0; + result = 0; if (PL_op->op_flags & OPf_STACKED) { SV *really = *++MARK; value = (I32)do_aspawn(really, (void **)MARK, (void **)SP); @@ -3821,17 +3869,19 @@ PP(pp_system) else { value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a)); } + if (PL_statusvalue == -1) /* hint that value must be returned as is */ + result = 1; STATUS_NATIVE_SET(value); do_execfree(); SP = ORIGMARK; - PUSHi(STATUS_CURRENT); + PUSHi(result ? value : STATUS_CURRENT); #endif /* !FORK or VMS */ RETURN; } PP(pp_exec) { - djSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; I32 value; STRLEN n_a; @@ -3883,7 +3933,7 @@ PP(pp_exec) PP(pp_kill) { - djSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; I32 value; #ifdef HAS_KILL value = (I32)apply(PL_op->op_type, MARK, SP); @@ -3898,7 +3948,7 @@ PP(pp_kill) PP(pp_getppid) { #ifdef HAS_GETPPID - djSP; dTARGET; + dSP; dTARGET; XPUSHi( getppid() ); RETURN; #else @@ -3909,7 +3959,7 @@ PP(pp_getppid) PP(pp_getpgrp) { #ifdef HAS_GETPGRP - djSP; dTARGET; + dSP; dTARGET; Pid_t pid; Pid_t pgrp; @@ -3934,7 +3984,7 @@ PP(pp_getpgrp) PP(pp_setpgrp) { #ifdef HAS_SETPGRP - djSP; dTARGET; + dSP; dTARGET; Pid_t pgrp; Pid_t pid; if (MAXARG < 2) { @@ -3965,7 +4015,7 @@ PP(pp_setpgrp) PP(pp_getpriority) { - djSP; dTARGET; + dSP; dTARGET; int which; int who; #ifdef HAS_GETPRIORITY @@ -3980,7 +4030,7 @@ PP(pp_getpriority) PP(pp_setpriority) { - djSP; dTARGET; + dSP; dTARGET; int which; int who; int niceval; @@ -4000,7 +4050,7 @@ PP(pp_setpriority) PP(pp_time) { - djSP; dTARGET; + dSP; dTARGET; #ifdef BIG_TIME XPUSHn( time(Null(Time_t*)) ); #else @@ -4027,7 +4077,7 @@ PP(pp_time) PP(pp_tms) { - djSP; + dSP; #ifndef HAS_TIMES DIE(aTHX_ "times not implemented"); @@ -4059,7 +4109,7 @@ PP(pp_localtime) PP(pp_gmtime) { - djSP; + dSP; Time_t when; struct tm *tmbuf; static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"}; @@ -4112,7 +4162,7 @@ PP(pp_gmtime) PP(pp_alarm) { - djSP; dTARGET; + dSP; dTARGET; int anum; #ifdef HAS_ALARM anum = POPi; @@ -4129,7 +4179,7 @@ PP(pp_alarm) PP(pp_sleep) { - djSP; dTARGET; + dSP; dTARGET; I32 duration; Time_t lasttime; Time_t when; @@ -4166,7 +4216,7 @@ PP(pp_shmread) PP(pp_shmwrite) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - djSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0); SP = MARK; PUSHi(value); @@ -4191,7 +4241,7 @@ PP(pp_msgctl) PP(pp_msgsnd) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - djSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; I32 value = (I32)(do_msgsnd(MARK, SP) >= 0); SP = MARK; PUSHi(value); @@ -4204,7 +4254,7 @@ PP(pp_msgsnd) PP(pp_msgrcv) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - djSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; I32 value = (I32)(do_msgrcv(MARK, SP) >= 0); SP = MARK; PUSHi(value); @@ -4219,7 +4269,7 @@ PP(pp_msgrcv) PP(pp_semget) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - djSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; int anum = do_ipcget(PL_op->op_type, MARK, SP); SP = MARK; if (anum == -1) @@ -4234,7 +4284,7 @@ PP(pp_semget) PP(pp_semctl) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - djSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; int anum = do_ipcctl(PL_op->op_type, MARK, SP); SP = MARK; if (anum == -1) @@ -4254,7 +4304,7 @@ PP(pp_semctl) PP(pp_semop) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - djSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; I32 value = (I32)(do_semop(MARK, SP) >= 0); SP = MARK; PUSHi(value); @@ -4286,7 +4336,7 @@ PP(pp_ghbyaddr) PP(pp_ghostent) { - djSP; + dSP; #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT) I32 which = PL_op->op_type; register char **elem; @@ -4395,7 +4445,7 @@ PP(pp_gnbyaddr) PP(pp_gnetent) { - djSP; + dSP; #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT) I32 which = PL_op->op_type; register char **elem; @@ -4483,11 +4533,11 @@ PP(pp_gpbynumber) PP(pp_gprotoent) { - djSP; + dSP; #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT) I32 which = PL_op->op_type; register char **elem; - register SV *sv; + register SV *sv; #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */ struct protoent *PerlSock_getprotobyname(Netdb_name_t); struct protoent *PerlSock_getprotobynumber(int); @@ -4566,7 +4616,7 @@ PP(pp_gsbyport) PP(pp_gservent) { - djSP; + dSP; #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT) I32 which = PL_op->op_type; register char **elem; @@ -4656,7 +4706,7 @@ PP(pp_gservent) PP(pp_shostent) { - djSP; + dSP; #ifdef HAS_SETHOSTENT PerlSock_sethostent(TOPi); RETSETYES; @@ -4667,7 +4717,7 @@ PP(pp_shostent) PP(pp_snetent) { - djSP; + dSP; #ifdef HAS_SETNETENT PerlSock_setnetent(TOPi); RETSETYES; @@ -4678,7 +4728,7 @@ PP(pp_snetent) PP(pp_sprotoent) { - djSP; + dSP; #ifdef HAS_SETPROTOENT PerlSock_setprotoent(TOPi); RETSETYES; @@ -4689,7 +4739,7 @@ PP(pp_sprotoent) PP(pp_sservent) { - djSP; + dSP; #ifdef HAS_SETSERVENT PerlSock_setservent(TOPi); RETSETYES; @@ -4700,7 +4750,7 @@ PP(pp_sservent) PP(pp_ehostent) { - djSP; + dSP; #ifdef HAS_ENDHOSTENT PerlSock_endhostent(); EXTEND(SP,1); @@ -4712,7 +4762,7 @@ PP(pp_ehostent) PP(pp_enetent) { - djSP; + dSP; #ifdef HAS_ENDNETENT PerlSock_endnetent(); EXTEND(SP,1); @@ -4724,7 +4774,7 @@ PP(pp_enetent) PP(pp_eprotoent) { - djSP; + dSP; #ifdef HAS_ENDPROTOENT PerlSock_endprotoent(); EXTEND(SP,1); @@ -4736,7 +4786,7 @@ PP(pp_eprotoent) PP(pp_eservent) { - djSP; + dSP; #ifdef HAS_ENDSERVENT PerlSock_endservent(); EXTEND(SP,1); @@ -4766,54 +4816,92 @@ PP(pp_gpwuid) PP(pp_gpwent) { - djSP; + dSP; #ifdef HAS_PASSWD I32 which = PL_op->op_type; register SV *sv; - struct passwd *pwent; STRLEN n_a; -#if defined(HAS_GETSPENT) || defined(HAS_GETSPNAM) - struct spwd *spwent = NULL; -#endif + struct passwd *pwent = NULL; + /* + * We currently support only the SysV getsp* shadow password interface. + * The interface is declared in <shadow.h> and often one needs to link + * with -lsecurity or some such. + * This interface is used at least by Solaris, HP-UX, IRIX, and Linux. + * (and SCO?) + * + * AIX getpwnam() is clever enough to return the encrypted password + * only if the caller (euid?) is root. + * + * There are at least two other shadow password APIs. Many platforms + * seem to contain more than one interface for accessing the shadow + * password databases, possibly for compatibility reasons. + * The getsp*() is by far he simplest one, the other two interfaces + * are much more complicated, but also very similar to each other. + * + * <sys/types.h> + * <sys/security.h> + * <prot.h> + * struct pr_passwd *getprpw*(); + * The password is in + * char getprpw*(...).ufld.fd_encrypt[] + * Mention HAS_GETPRPWNAM here so that Configure probes for it. + * + * <sys/types.h> + * <sys/security.h> + * <prot.h> + * struct es_passwd *getespw*(); + * The password is in + * char *(getespw*(...).ufld.fd_encrypt) + * Mention HAS_GETESPWNAM here so that Configure probes for it. + * + * Mention I_PROT here so that Configure probes for it. + * + * In HP-UX for getprpw*() the manual page claims that one should include + * <hpsecurity.h> instead of <sys/security.h>, but that is not needed + * if one includes <shadow.h> as that includes <hpsecurity.h>, + * and pp_sys.c already includes <shadow.h> if there is such. + * + * Note that <sys/security.h> is already probed for, but currently + * it is only included in special cases. + * + * In Digital UNIX/Tru64 if using the getespw*() (which seems to be + * be preferred interface, even though also the getprpw*() interface + * is available) one needs to link with -lsecurity -ldb -laud -lm. + * One also needs to call set_auth_parameters() in main() before + * doing anything else, whether one is using getespw*() or getprpw*(). + * + * Note that accessing the shadow databases can be magnitudes + * slower than accessing the standard databases. + * + * --jhi + */ - if (which == OP_GPWNAM) - pwent = getpwnam(POPpx); - else if (which == OP_GPWUID) - pwent = getpwuid(POPi); - else -#ifdef HAS_GETPWENT - pwent = (struct passwd *)getpwent(); -#else + switch (which) { + case OP_GPWNAM: + pwent = getpwnam(POPpx); + break; + case OP_GPWUID: + pwent = getpwuid((Uid_t)POPi); + break; + case OP_GPWENT: +# ifdef HAS_GETPWENT + pwent = getpwent(); +# else DIE(aTHX_ PL_no_func, "getpwent"); -#endif - -#ifdef HAS_GETSPNAM - if (which == OP_GPWNAM) { - if (pwent) - spwent = getspnam(pwent->pw_name); - } -# ifdef HAS_GETSPUID /* AFAIK there isn't any anywhere. --jhi */ - else if (which == OP_GPWUID) { - if (pwent) - spwent = getspnam(pwent->pw_name); - } -# endif -# ifdef HAS_GETSPENT - else - spwent = (struct spwd *)getspent(); # endif -#endif + break; + } EXTEND(SP, 10); if (GIMME != G_ARRAY) { PUSHs(sv = sv_newmortal()); if (pwent) { if (which == OP_GPWNAM) -#if Uid_t_sign <= 0 +# if Uid_t_sign <= 0 sv_setiv(sv, (IV)pwent->pw_uid); -#else +# else sv_setuv(sv, (UV)pwent->pw_uid); -#endif +# endif else sv_setpv(sv, pwent->pw_name); } @@ -4825,81 +4913,114 @@ PP(pp_gpwent) sv_setpv(sv, pwent->pw_name); PUSHs(sv = sv_mortalcopy(&PL_sv_no)); -#ifdef PWPASSWD -# if defined(HAS_GETSPENT) || defined(HAS_GETSPNAM) - if (spwent) - sv_setpv(sv, spwent->sp_pwdp); - else - sv_setpv(sv, pwent->pw_passwd); -# else - sv_setpv(sv, pwent->pw_passwd); + SvPOK_off(sv); + /* If we have getspnam(), we try to dig up the shadow + * password. If we are underprivileged, the shadow + * interface will set the errno to EACCES or similar, + * and return a null pointer. If this happens, we will + * use the dummy password (usually "*" or "x") from the + * standard password database. + * + * In theory we could skip the shadow call completely + * if euid != 0 but in practice we cannot know which + * security measures are guarding the shadow databases + * on a random platform. + * + * Resist the urge to use additional shadow interfaces. + * Divert the urge to writing an extension instead. + * + * --jhi */ +# ifdef HAS_GETSPNAM + { + struct spwd *spwent; + int saverrno; /* Save and restore errno so that + * underprivileged attempts seem + * to have never made the unsccessful + * attempt to retrieve the shadow password. */ + + saverrno = errno; + spwent = getspnam(pwent->pw_name); + errno = saverrno; + if (spwent && spwent->sp_pwdp) + sv_setpv(sv, spwent->sp_pwdp); + } +# endif +# ifdef PWPASSWD + if (!SvPOK(sv)) /* Use the standard password, then. */ + sv_setpv(sv, pwent->pw_passwd); # endif -#endif -#ifndef INCOMPLETE_TAINTS - /* passwd is tainted because user himself can diddle with it. */ + +# ifndef INCOMPLETE_TAINTS + /* passwd is tainted because user himself can diddle with it. + * admittedly not much and in a very limited way, but nevertheless. */ SvTAINTED_on(sv); -#endif +# endif PUSHs(sv = sv_mortalcopy(&PL_sv_no)); -#if Uid_t_sign <= 0 +# if Uid_t_sign <= 0 sv_setiv(sv, (IV)pwent->pw_uid); -#else +# else sv_setuv(sv, (UV)pwent->pw_uid); -#endif +# endif PUSHs(sv = sv_mortalcopy(&PL_sv_no)); -#if Uid_t_sign <= 0 +# if Uid_t_sign <= 0 sv_setiv(sv, (IV)pwent->pw_gid); -#else +# else sv_setuv(sv, (UV)pwent->pw_gid); -#endif - /* pw_change, pw_quota, and pw_age are mutually exclusive. */ +# endif + /* pw_change, pw_quota, and pw_age are mutually exclusive-- + * because of the poor interface of the Perl getpw*(), + * not because there's some standard/convention saying so. + * A better interface would have been to return a hash, + * but we are accursed by our history, alas. --jhi. */ PUSHs(sv = sv_mortalcopy(&PL_sv_no)); -#ifdef PWCHANGE +# ifdef PWCHANGE sv_setiv(sv, (IV)pwent->pw_change); -#else -# ifdef PWQUOTA +# else +# ifdef PWQUOTA sv_setiv(sv, (IV)pwent->pw_quota); -# else -# ifdef PWAGE +# else +# ifdef PWAGE sv_setpv(sv, pwent->pw_age); -# endif -# endif -#endif +# endif +# endif +# endif - /* pw_class and pw_comment are mutually exclusive. */ + /* pw_class and pw_comment are mutually exclusive--. + * see the above note for pw_change, pw_quota, and pw_age. */ PUSHs(sv = sv_mortalcopy(&PL_sv_no)); -#ifdef PWCLASS +# ifdef PWCLASS sv_setpv(sv, pwent->pw_class); -#else -# ifdef PWCOMMENT +# else +# ifdef PWCOMMENT sv_setpv(sv, pwent->pw_comment); -# endif -#endif +# endif +# endif PUSHs(sv = sv_mortalcopy(&PL_sv_no)); -#ifdef PWGECOS +# ifdef PWGECOS sv_setpv(sv, pwent->pw_gecos); -#endif -#ifndef INCOMPLETE_TAINTS +# endif +# ifndef INCOMPLETE_TAINTS /* pw_gecos is tainted because user himself can diddle with it. */ SvTAINTED_on(sv); -#endif +# endif PUSHs(sv = sv_mortalcopy(&PL_sv_no)); sv_setpv(sv, pwent->pw_dir); PUSHs(sv = sv_mortalcopy(&PL_sv_no)); sv_setpv(sv, pwent->pw_shell); -#ifndef INCOMPLETE_TAINTS +# ifndef INCOMPLETE_TAINTS /* pw_shell is tainted because user himself can diddle with it. */ SvTAINTED_on(sv); -#endif +# endif -#ifdef PWEXPIRE +# ifdef PWEXPIRE PUSHs(sv = sv_mortalcopy(&PL_sv_no)); sv_setiv(sv, (IV)pwent->pw_expire); -#endif +# endif } RETURN; #else @@ -4909,12 +5030,9 @@ PP(pp_gpwent) PP(pp_spwent) { - djSP; + dSP; #if defined(HAS_PASSWD) && defined(HAS_SETPWENT) setpwent(); -# ifdef HAS_SETSPENT - setspent(); -# endif RETPUSHYES; #else DIE(aTHX_ PL_no_func, "setpwent"); @@ -4923,12 +5041,9 @@ PP(pp_spwent) PP(pp_epwent) { - djSP; + dSP; #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT) endpwent(); -# ifdef HAS_ENDSPENT - endspent(); -# endif RETPUSHYES; #else DIE(aTHX_ PL_no_func, "endpwent"); @@ -4955,7 +5070,7 @@ PP(pp_ggrgid) PP(pp_ggrent) { - djSP; + dSP; #ifdef HAS_GROUP I32 which = PL_op->op_type; register char **elem; @@ -5014,7 +5129,7 @@ PP(pp_ggrent) PP(pp_sgrent) { - djSP; + dSP; #if defined(HAS_GROUP) && defined(HAS_SETGRENT) setgrent(); RETPUSHYES; @@ -5025,7 +5140,7 @@ PP(pp_sgrent) PP(pp_egrent) { - djSP; + dSP; #if defined(HAS_GROUP) && defined(HAS_ENDGRENT) endgrent(); RETPUSHYES; @@ -5036,7 +5151,7 @@ PP(pp_egrent) PP(pp_getlogin) { - djSP; dTARGET; + dSP; dTARGET; #ifdef HAS_GETLOGIN char *tmps; EXTEND(SP, 1); @@ -5054,7 +5169,7 @@ PP(pp_getlogin) PP(pp_syscall) { #ifdef HAS_SYSCALL - djSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; register I32 items = SP - MARK; unsigned long a[20]; register I32 i = 0; @@ -5081,7 +5196,7 @@ PP(pp_syscall) a[i++] = SvIV(*MARK); else if (*MARK == &PL_sv_undef) a[i++] = 0; - else + else a[i++] = (unsigned long)SvPV_force(*MARK, n_a); if (i > 15) break; @@ -5149,7 +5264,7 @@ PP(pp_syscall) } #ifdef FCNTL_EMULATE_FLOCK - + /* XXX Emulate flock() with fcntl(). What's really needed is a good file locking module. */ @@ -5158,7 +5273,7 @@ static int fcntl_emulate_flock(int fd, int operation) { struct flock flock; - + switch (operation & ~LOCK_NB) { case LOCK_SH: flock.l_type = F_RDLCK; @@ -5175,7 +5290,7 @@ fcntl_emulate_flock(int fd, int operation) } flock.l_whence = SEEK_SET; flock.l_start = flock.l_len = (Off_t)0; - + return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock); } diff --git a/contrib/perl5/proto.h b/contrib/perl5/proto.h index 1be9992ffb82..879495195d9e 100644 --- a/contrib/perl5/proto.h +++ b/contrib/perl5/proto.h @@ -61,6 +61,7 @@ PERL_CALLCONV bool Perl_Gv_AMupdate(pTHX_ HV* stash); PERL_CALLCONV OP* Perl_append_elem(pTHX_ I32 optype, OP* head, OP* tail); PERL_CALLCONV OP* Perl_append_list(pTHX_ I32 optype, LISTOP* first, LISTOP* last); PERL_CALLCONV I32 Perl_apply(pTHX_ I32 type, SV** mark, SV** sp); +PERL_CALLCONV void Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, char *attrstr, STRLEN len); PERL_CALLCONV SV* Perl_avhv_delete_ent(pTHX_ AV *ar, SV* keysv, I32 flags, U32 hash); PERL_CALLCONV bool Perl_avhv_exists_ent(pTHX_ AV *ar, SV* keysv, U32 hash); PERL_CALLCONV SV** Perl_avhv_fetch_ent(pTHX_ AV *ar, SV* keysv, I32 lval, U32 hash); @@ -129,11 +130,7 @@ PERL_CALLCONV char* Perl_form_nocontext(const char* pat, ...) __attribute__((format(printf,1,2))) #endif ; -PERL_CALLCONV void Perl_load_module_nocontext(U32 flags, SV* name, SV* ver, ...) -#ifdef CHECK_FORMAT - __attribute__((format(printf,3,4))) -#endif -; +PERL_CALLCONV void Perl_load_module_nocontext(U32 flags, SV* name, SV* ver, ...); PERL_CALLCONV SV* Perl_mess_nocontext(const char* pat, ...) #ifdef CHECK_FORMAT __attribute__((format(printf,1,2))) @@ -179,6 +176,11 @@ PERL_CALLCONV int Perl_fprintf_nocontext(PerlIO* stream, const char* fmt, ...) __attribute__((format(printf,2,3))) #endif ; +PERL_CALLCONV int Perl_printf_nocontext(const char* fmt, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,1,2))) +#endif +; #endif PERL_CALLCONV void Perl_cv_ckproto(pTHX_ CV* cv, GV* gv, char* p); PERL_CALLCONV CV* Perl_cv_clone(pTHX_ CV* proto); @@ -217,7 +219,7 @@ PERL_CALLCONV OP* Perl_die_where(pTHX_ char* message, STRLEN msglen); PERL_CALLCONV void Perl_dounwind(pTHX_ I32 cxix); PERL_CALLCONV bool Perl_do_aexec(pTHX_ SV* really, SV** mark, SV** sp); PERL_CALLCONV bool Perl_do_aexec5(pTHX_ SV* really, SV** mark, SV** sp, int fd, int flag); -PERL_CALLCONV int Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int flag); +PERL_CALLCONV int Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode); PERL_CALLCONV void Perl_do_chop(pTHX_ SV* asv, SV* sv); PERL_CALLCONV bool Perl_do_close(pTHX_ GV* gv, bool not_implicit); PERL_CALLCONV bool Perl_do_eof(pTHX_ GV* gv); @@ -280,7 +282,7 @@ PERL_CALLCONV char* Perl_vform(pTHX_ const char* pat, va_list* args); PERL_CALLCONV void Perl_free_tmps(pTHX); PERL_CALLCONV OP* Perl_gen_constant_list(pTHX_ OP* o); #if !defined(HAS_GETENV_LEN) -PERL_CALLCONV char* Perl_getenv_len(pTHX_ char* key, unsigned long *len); +PERL_CALLCONV char* Perl_getenv_len(pTHX_ const char* key, unsigned long *len); #endif PERL_CALLCONV void Perl_gp_free(pTHX_ GV* gv); PERL_CALLCONV GP* Perl_gp_ref(pTHX_ GP* gp); @@ -291,6 +293,7 @@ PERL_CALLCONV GV* Perl_gv_autoload4(pTHX_ HV* stash, const char* name, STRLEN le PERL_CALLCONV void Perl_gv_check(pTHX_ HV* stash); PERL_CALLCONV void Perl_gv_efullname(pTHX_ SV* sv, GV* gv); PERL_CALLCONV void Perl_gv_efullname3(pTHX_ SV* sv, GV* gv, const char* prefix); +PERL_CALLCONV void Perl_gv_efullname4(pTHX_ SV* sv, GV* gv, const char* prefix, bool keepmain); PERL_CALLCONV GV* Perl_gv_fetchfile(pTHX_ const char* name); PERL_CALLCONV GV* Perl_gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level); PERL_CALLCONV GV* Perl_gv_fetchmethod(pTHX_ HV* stash, const char* name); @@ -298,6 +301,7 @@ PERL_CALLCONV GV* Perl_gv_fetchmethod_autoload(pTHX_ HV* stash, const char* name PERL_CALLCONV GV* Perl_gv_fetchpv(pTHX_ const char* name, I32 add, I32 sv_type); PERL_CALLCONV void Perl_gv_fullname(pTHX_ SV* sv, GV* gv); PERL_CALLCONV void Perl_gv_fullname3(pTHX_ SV* sv, GV* gv, const char* prefix); +PERL_CALLCONV void Perl_gv_fullname4(pTHX_ SV* sv, GV* gv, const char* prefix, bool keepmain); PERL_CALLCONV void Perl_gv_init(pTHX_ GV* gv, HV* stash, const char* name, STRLEN len, int multi); PERL_CALLCONV HV* Perl_gv_stashpv(pTHX_ const char* name, I32 create); PERL_CALLCONV HV* Perl_gv_stashpvn(pTHX_ const char* name, U32 namelen, I32 create); @@ -331,6 +335,8 @@ PERL_CALLCONV U32 Perl_intro_my(pTHX); PERL_CALLCONV char* Perl_instr(pTHX_ const char* big, const char* little); PERL_CALLCONV bool Perl_io_close(pTHX_ IO* io, bool not_implicit); PERL_CALLCONV OP* Perl_invert(pTHX_ OP* cmd); +PERL_CALLCONV bool Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags); +PERL_CALLCONV I32 Perl_is_lvalue_sub(pTHX); PERL_CALLCONV bool Perl_is_uni_alnum(pTHX_ U32 c); PERL_CALLCONV bool Perl_is_uni_alnumc(pTHX_ U32 c); PERL_CALLCONV bool Perl_is_uni_idfirst(pTHX_ U32 c); @@ -365,7 +371,8 @@ PERL_CALLCONV bool Perl_is_uni_xdigit_lc(pTHX_ U32 c); PERL_CALLCONV U32 Perl_to_uni_upper_lc(pTHX_ U32 c); PERL_CALLCONV U32 Perl_to_uni_title_lc(pTHX_ U32 c); PERL_CALLCONV U32 Perl_to_uni_lower_lc(pTHX_ U32 c); -PERL_CALLCONV int Perl_is_utf8_char(pTHX_ U8 *p); +PERL_CALLCONV STRLEN Perl_is_utf8_char(pTHX_ U8 *p); +PERL_CALLCONV bool Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len); PERL_CALLCONV bool Perl_is_utf8_alnum(pTHX_ U8 *p); PERL_CALLCONV bool Perl_is_utf8_alnumc(pTHX_ U8 *p); PERL_CALLCONV bool Perl_is_utf8_idfirst(pTHX_ U8 *p); @@ -389,11 +396,7 @@ PERL_CALLCONV void Perl_lex_start(pTHX_ SV* line); PERL_CALLCONV OP* Perl_linklist(pTHX_ OP* o); PERL_CALLCONV OP* Perl_list(pTHX_ OP* o); PERL_CALLCONV OP* Perl_listkids(pTHX_ OP* o); -PERL_CALLCONV void Perl_load_module(pTHX_ U32 flags, SV* name, SV* ver, ...) -#ifdef CHECK_FORMAT - __attribute__((format(printf,pTHX_3,pTHX_4))) -#endif -; +PERL_CALLCONV void Perl_load_module(pTHX_ U32 flags, SV* name, SV* ver, ...); PERL_CALLCONV void Perl_vload_module(pTHX_ U32 flags, SV* name, SV* ver, va_list* args); PERL_CALLCONV OP* Perl_localize(pTHX_ OP* arg, I32 lexical); PERL_CALLCONV I32 Perl_looks_like_number(pTHX_ SV* sv); @@ -422,6 +425,7 @@ PERL_CALLCONV int Perl_magic_mutexfree(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV int Perl_magic_nextpack(pTHX_ SV* sv, MAGIC* mg, SV* key); PERL_CALLCONV U32 Perl_magic_regdata_cnt(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV int Perl_magic_regdatum_get(pTHX_ SV* sv, MAGIC* mg); +PERL_CALLCONV int Perl_magic_regdatum_set(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV int Perl_magic_set(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV int Perl_magic_setamagic(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV int Perl_magic_setarylen(pTHX_ SV* sv, MAGIC* mg); @@ -596,9 +600,9 @@ PERL_CALLCONV HV* Perl_get_hv(pTHX_ const char* name, I32 create); PERL_CALLCONV CV* Perl_get_cv(pTHX_ const char* name, I32 create); PERL_CALLCONV int Perl_init_i18nl10n(pTHX_ int printwarn); PERL_CALLCONV int Perl_init_i18nl14n(pTHX_ int printwarn); -PERL_CALLCONV void Perl_new_collate(pTHX_ const char* newcoll); -PERL_CALLCONV void Perl_new_ctype(pTHX_ const char* newctype); -PERL_CALLCONV void Perl_new_numeric(pTHX_ const char* newcoll); +PERL_CALLCONV void Perl_new_collate(pTHX_ char* newcoll); +PERL_CALLCONV void Perl_new_ctype(pTHX_ char* newctype); +PERL_CALLCONV void Perl_new_numeric(pTHX_ char* newcoll); PERL_CALLCONV void Perl_set_numeric_local(pTHX); PERL_CALLCONV void Perl_set_numeric_radix(pTHX); PERL_CALLCONV void Perl_set_numeric_standard(pTHX); @@ -650,6 +654,7 @@ PERL_CALLCONV void Perl_save_freesv(pTHX_ SV* sv); PERL_CALLCONV void Perl_save_freeop(pTHX_ OP* o); PERL_CALLCONV void Perl_save_freepv(pTHX_ char* pv); PERL_CALLCONV void Perl_save_generic_svref(pTHX_ SV** sptr); +PERL_CALLCONV void Perl_save_generic_pvref(pTHX_ char** str); PERL_CALLCONV void Perl_save_gp(pTHX_ GV* gv, I32 empty); PERL_CALLCONV HV* Perl_save_hash(pTHX_ GV* gv); PERL_CALLCONV void Perl_save_helem(pTHX_ HV* hv, SV *key, SV **sptr); @@ -663,12 +668,14 @@ PERL_CALLCONV void Perl_save_item(pTHX_ SV* item); PERL_CALLCONV void Perl_save_iv(pTHX_ IV* iv); PERL_CALLCONV void Perl_save_list(pTHX_ SV** sarg, I32 maxsarg); PERL_CALLCONV void Perl_save_long(pTHX_ long* longp); +PERL_CALLCONV void Perl_save_mortalizesv(pTHX_ SV* sv); PERL_CALLCONV void Perl_save_nogv(pTHX_ GV* gv); PERL_CALLCONV void Perl_save_op(pTHX); PERL_CALLCONV SV* Perl_save_scalar(pTHX_ GV* gv); PERL_CALLCONV void Perl_save_pptr(pTHX_ char** pptr); PERL_CALLCONV void Perl_save_vptr(pTHX_ void* pptr); PERL_CALLCONV void Perl_save_re_context(pTHX); +PERL_CALLCONV void Perl_save_padsv(pTHX_ PADOFFSET off); PERL_CALLCONV void Perl_save_sptr(pTHX_ SV** sptr); PERL_CALLCONV SV* Perl_save_svref(pTHX_ SV** sptr); PERL_CALLCONV SV** Perl_save_threadsv(pTHX_ PADOFFSET i); @@ -677,10 +684,10 @@ PERL_CALLCONV OP* Perl_scalar(pTHX_ OP* o); PERL_CALLCONV OP* Perl_scalarkids(pTHX_ OP* o); PERL_CALLCONV OP* Perl_scalarseq(pTHX_ OP* o); PERL_CALLCONV OP* Perl_scalarvoid(pTHX_ OP* o); -PERL_CALLCONV NV Perl_scan_bin(pTHX_ char* start, I32 len, I32* retlen); -PERL_CALLCONV NV Perl_scan_hex(pTHX_ char* start, I32 len, I32* retlen); -PERL_CALLCONV char* Perl_scan_num(pTHX_ char* s); -PERL_CALLCONV NV Perl_scan_oct(pTHX_ char* start, I32 len, I32* retlen); +PERL_CALLCONV NV Perl_scan_bin(pTHX_ char* start, STRLEN len, STRLEN* retlen); +PERL_CALLCONV NV Perl_scan_hex(pTHX_ char* start, STRLEN len, STRLEN* retlen); +PERL_CALLCONV char* Perl_scan_num(pTHX_ char* s, YYSTYPE *lvalp); +PERL_CALLCONV NV Perl_scan_oct(pTHX_ char* start, STRLEN len, STRLEN* retlen); PERL_CALLCONV OP* Perl_scope(pTHX_ OP* o); PERL_CALLCONV char* Perl_screaminstr(pTHX_ SV* bigsv, SV* littlesv, I32 start_shift, I32 end_shift, I32 *state, I32 last); #if !defined(VMS) @@ -723,7 +730,7 @@ PERL_CALLCONV void Perl_sv_catpv(pTHX_ SV* sv, const char* ptr); PERL_CALLCONV void Perl_sv_catpvn(pTHX_ SV* sv, const char* ptr, STRLEN len); PERL_CALLCONV void Perl_sv_catsv(pTHX_ SV* dsv, SV* ssv); PERL_CALLCONV void Perl_sv_chop(pTHX_ SV* sv, char* ptr); -PERL_CALLCONV void Perl_sv_clean_all(pTHX); +PERL_CALLCONV I32 Perl_sv_clean_all(pTHX); PERL_CALLCONV void Perl_sv_clean_objs(pTHX); PERL_CALLCONV void Perl_sv_clear(pTHX_ SV* sv); PERL_CALLCONV I32 Perl_sv_cmp(pTHX_ SV* sv1, SV* sv2); @@ -803,16 +810,21 @@ PERL_CALLCONV void Perl_unlock_condpair(pTHX_ void* svv); PERL_CALLCONV void Perl_unsharepvn(pTHX_ const char* sv, I32 len, U32 hash); PERL_CALLCONV void Perl_unshare_hek(pTHX_ HEK* hek); PERL_CALLCONV void Perl_utilize(pTHX_ int aver, I32 floor, OP* version, OP* id, OP* arg); -PERL_CALLCONV U8* Perl_utf16_to_utf8(pTHX_ U16* p, U8 *d, I32 bytelen); -PERL_CALLCONV U8* Perl_utf16_to_utf8_reversed(pTHX_ U16* p, U8 *d, I32 bytelen); -PERL_CALLCONV I32 Perl_utf8_distance(pTHX_ U8 *a, U8 *b); +PERL_CALLCONV U8* Perl_utf16_to_utf8(pTHX_ U8* p, U8 *d, I32 bytelen, I32 *newlen); +PERL_CALLCONV U8* Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8 *d, I32 bytelen, I32 *newlen); +PERL_CALLCONV STRLEN Perl_utf8_length(pTHX_ U8* s, U8 *e); +PERL_CALLCONV IV Perl_utf8_distance(pTHX_ U8 *a, U8 *b); PERL_CALLCONV U8* Perl_utf8_hop(pTHX_ U8 *s, I32 off); -PERL_CALLCONV UV Perl_utf8_to_uv(pTHX_ U8 *s, I32* retlen); +PERL_CALLCONV U8* Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len); +PERL_CALLCONV U8* Perl_bytes_from_utf8(pTHX_ U8 *s, STRLEN *len, bool *is_utf8); +PERL_CALLCONV U8* Perl_bytes_to_utf8(pTHX_ U8 *s, STRLEN *len); +PERL_CALLCONV UV Perl_utf8_to_uv_simple(pTHX_ U8 *s, STRLEN* retlen); +PERL_CALLCONV UV Perl_utf8_to_uv(pTHX_ U8 *s, STRLEN curlen, STRLEN* retlen, U32 flags); PERL_CALLCONV U8* Perl_uv_to_utf8(pTHX_ U8 *d, UV uv); PERL_CALLCONV void Perl_vivify_defelem(pTHX_ SV* sv); PERL_CALLCONV void Perl_vivify_ref(pTHX_ SV* sv, U32 to_what); PERL_CALLCONV I32 Perl_wait4pid(pTHX_ Pid_t pid, int* statusp, int flags); -PERL_CALLCONV void Perl_report_closed_fh(pTHX_ GV *gv, IO *io, const char *func, const char *obj); +PERL_CALLCONV void Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op); PERL_CALLCONV void Perl_report_uninit(pTHX); PERL_CALLCONV void Perl_warn(pTHX_ const char* pat, ...) #ifdef CHECK_FORMAT @@ -829,11 +841,10 @@ PERL_CALLCONV void Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args); PERL_CALLCONV void Perl_watch(pTHX_ char** addr); PERL_CALLCONV I32 Perl_whichsig(pTHX_ char* sig); PERL_CALLCONV int Perl_yyerror(pTHX_ char* s); -#if defined(USE_PURE_BISON) -PERL_CALLCONV int Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp); -#else -PERL_CALLCONV int Perl_yylex(pTHX); +#ifdef USE_PURE_BISON +PERL_CALLCONV int Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp); #endif +PERL_CALLCONV int Perl_yylex(pTHX); PERL_CALLCONV int Perl_yyparse(pTHX); PERL_CALLCONV int Perl_yywarn(pTHX_ char* s); #if defined(MYMALLOC) @@ -855,6 +866,9 @@ PERL_CALLCONV struct perl_vars * Perl_GetVars(pTHX); #endif PERL_CALLCONV int Perl_runops_standard(pTHX); PERL_CALLCONV int Perl_runops_debug(pTHX); +#if defined(USE_THREADS) +PERL_CALLCONV SV* Perl_sv_lock(pTHX_ SV *sv); +#endif PERL_CALLCONV void Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...) #ifdef CHECK_FORMAT __attribute__((format(printf,pTHX_2,pTHX_3))) @@ -910,6 +924,8 @@ PERL_CALLCONV bool Perl_sv_utf8_downgrade(pTHX_ SV *sv, bool fail_ok); PERL_CALLCONV void Perl_sv_utf8_encode(pTHX_ SV *sv); PERL_CALLCONV bool Perl_sv_utf8_decode(pTHX_ SV *sv); PERL_CALLCONV void Perl_sv_force_normal(pTHX_ SV *sv); +PERL_CALLCONV void Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv); +PERL_CALLCONV void Perl_sv_del_backref(pTHX_ SV *sv); PERL_CALLCONV void Perl_tmps_grow(pTHX_ I32 n); PERL_CALLCONV SV* Perl_sv_rvweaken(pTHX_ SV *sv); PERL_CALLCONV int Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg); @@ -937,6 +953,12 @@ PERL_CALLCONV PTR_TBL_t* Perl_ptr_table_new(pTHX); PERL_CALLCONV void* Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv); PERL_CALLCONV void Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldsv, void *newsv); PERL_CALLCONV void Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl); +PERL_CALLCONV void Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl); +PERL_CALLCONV void Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl); +#endif +#if defined(HAVE_INTERP_INTERN) +PERL_CALLCONV void Perl_sys_intern_clear(pTHX); +PERL_CALLCONV void Perl_sys_intern_init(pTHX); #endif #if defined(PERL_OBJECT) @@ -951,16 +973,12 @@ STATIC I32 S_avhv_index(pTHX_ AV* av, SV* sv, U32 hash); #endif #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) -STATIC I32 S_do_trans_CC_simple(pTHX_ SV *sv); -STATIC I32 S_do_trans_CC_count(pTHX_ SV *sv); -STATIC I32 S_do_trans_CC_complex(pTHX_ SV *sv); -STATIC I32 S_do_trans_UU_simple(pTHX_ SV *sv); -STATIC I32 S_do_trans_UU_count(pTHX_ SV *sv); -STATIC I32 S_do_trans_UU_complex(pTHX_ SV *sv); -STATIC I32 S_do_trans_UC_simple(pTHX_ SV *sv); -STATIC I32 S_do_trans_CU_simple(pTHX_ SV *sv); -STATIC I32 S_do_trans_UC_trivial(pTHX_ SV *sv); -STATIC I32 S_do_trans_CU_trivial(pTHX_ SV *sv); +STATIC I32 S_do_trans_simple(pTHX_ SV *sv); +STATIC I32 S_do_trans_count(pTHX_ SV *sv); +STATIC I32 S_do_trans_complex(pTHX_ SV *sv); +STATIC I32 S_do_trans_simple_utf8(pTHX_ SV *sv); +STATIC I32 S_do_trans_count_utf8(pTHX_ SV *sv); +STATIC I32 S_do_trans_complex_utf8(pTHX_ SV *sv); #endif #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT) @@ -993,6 +1011,7 @@ STATIC OP* S_no_fh_allowed(pTHX_ OP *o); STATIC OP* S_scalarboolean(pTHX_ OP *o); STATIC OP* S_too_few_arguments(pTHX_ OP *o, char* name); STATIC OP* S_too_many_arguments(pTHX_ OP *o, char* name); +STATIC U8* S_trlist_upgrade(pTHX_ U8** sp, U8** ep); STATIC void S_op_clear(pTHX_ OP* o); STATIC void S_null(pTHX_ OP* o); STATIC PADOFFSET S_pad_addlex(pTHX_ SV* name); @@ -1069,7 +1088,6 @@ STATIC I32 S_dopoptolabel(pTHX_ char *label); STATIC I32 S_dopoptoloop(pTHX_ I32 startingblock); STATIC I32 S_dopoptosub(pTHX_ I32 startingblock); STATIC I32 S_dopoptosub_at(pTHX_ PERL_CONTEXT* cxstk, I32 startingblock); -STATIC void S_free_closures(pTHX); STATIC void S_save_lines(pTHX_ AV *array, SV *sv); STATIC OP* S_doeval(pTHX_ int gimme, OP** startop); STATIC PerlIO * S_doopen_pmc(pTHX_ const char *name, const char *mode); @@ -1096,7 +1114,7 @@ STATIC regnode* S_reg(pTHX_ I32, I32 *); STATIC regnode* S_reganode(pTHX_ U8, U32); STATIC regnode* S_regatom(pTHX_ I32 *); STATIC regnode* S_regbranch(pTHX_ I32 *, I32); -STATIC void S_reguni(pTHX_ UV, char *, I32*); +STATIC void S_reguni(pTHX_ UV, char *, STRLEN*); STATIC regnode* S_regclass(pTHX); STATIC regnode* S_regclassutf8(pTHX); STATIC I32 S_regcurly(pTHX_ char *); @@ -1189,9 +1207,7 @@ STATIC void S_del_xpvbm(pTHX_ XPVBM* p); STATIC void S_del_xrv(pTHX_ XRV* p); STATIC void S_sv_unglob(pTHX_ SV* sv); STATIC void S_not_a_number(pTHX_ SV *sv); -STATIC void S_visit(pTHX_ SVFUNC_t f); -STATIC void S_sv_add_backref(pTHX_ SV *tsv, SV *sv); -STATIC void S_sv_del_backref(pTHX_ SV *sv); +STATIC I32 S_visit(pTHX_ SVFUNC_t f); # if defined(DEBUGGING) STATIC void S_del_sv(pTHX_ SV *p); # endif @@ -1214,6 +1230,7 @@ STATIC char* S_scan_subst(pTHX_ char *start); STATIC char* S_scan_trans(pTHX_ char *start); STATIC char* S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp); STATIC char* S_skipspace(pTHX_ char *s); +STATIC char* S_swallow_bom(pTHX_ U8 *s); STATIC void S_checkcomma(pTHX_ char *s, char *name, char *what); STATIC void S_force_ident(pTHX_ char *s, int kind); STATIC void S_incline(pTHX_ char *s); @@ -1227,6 +1244,7 @@ STATIC I32 S_sublex_done(pTHX); STATIC I32 S_sublex_push(pTHX); STATIC I32 S_sublex_start(pTHX); STATIC char * S_filter_gets(pTHX_ SV *sv, PerlIO *fp, STRLEN append); +STATIC HV * S_find_in_my_stash(pTHX_ char *pkgname, I32 len); STATIC SV* S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, const char *type); STATIC int S_ao(pTHX_ int toketype); STATIC void S_depcom(pTHX); @@ -1248,6 +1266,7 @@ STATIC SV* S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level); #endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) +STATIC char* S_stdize_locale(pTHX_ char* locs); STATIC SV* S_mess_alloc(pTHX); # if defined(LEAKTEST) STATIC void S_xstat(pTHX_ int); diff --git a/contrib/perl5/regcomp.c b/contrib/perl5/regcomp.c index c0425b766d20..b0d238f168df 100644 --- a/contrib/perl5/regcomp.c +++ b/contrib/perl5/regcomp.c @@ -69,7 +69,7 @@ * **** Alterations to Henry's code are... **** - **** 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,11 +114,6 @@ #define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?') #define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \ ((*s) == '{' && regcurly(s))) -#ifdef atarist -#define PERL_META "^$.[()|?+*\\" -#else -#define META "^$.[()|?+*\\" -#endif #ifdef SPSTART #undef SPSTART /* dratted cpp namespace... */ @@ -151,6 +146,7 @@ typedef struct scan_data_t { I32 offset_float_max; I32 flags; I32 whilem_c; + I32 *last_closep; struct regnode_charclass_class *start_class; } scan_data_t; @@ -159,7 +155,7 @@ typedef struct scan_data_t { */ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0 }; + 0, 0, 0, 0, 0, 0}; #define SF_BEFORE_EOL (SF_BEFORE_SEOL|SF_BEFORE_MEOL) #define SF_BEFORE_SEOL 0x1 @@ -188,6 +184,7 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, #define SCF_DO_STCLASS_AND 0x0800 #define SCF_DO_STCLASS_OR 0x1000 #define SCF_DO_STCLASS (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR) +#define SCF_WHILEM_VISITED_POS 0x2000 #define RF_utf8 8 #define UTF (PL_reg_flags & RF_utf8) @@ -201,6 +198,185 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv)) #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b) + +/* length of regex to show in messages that don't mark a position within */ +#define RegexLengthToShowInErrorMessages 127 + +/* + * If MARKER[12] are adjusted, be sure to adjust the constants at the top + * of t/op/regmesg.t, the tests in t/op/re_tests, and those in + * op/pragma/warn/regcomp. + */ +#define MARKER1 "HERE" /* marker as it appears in the description */ +#define MARKER2 " << HERE " /* marker as it appears within the regex */ + +#define REPORT_LOCATION " before " MARKER1 " mark in regex m/%.*s" MARKER2 "%s/" + +/* + * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given + * arg. Show regex, up to a maximum length. If it's too long, chop and add + * "...". + */ +#define FAIL(msg) \ + STMT_START { \ + char *ellipses = ""; \ + unsigned len = strlen(PL_regprecomp); \ + \ + if (!SIZE_ONLY) \ + SAVEDESTRUCTOR_X(clear_re,(void*)PL_regcomp_rx); \ + \ + if (len > RegexLengthToShowInErrorMessages) { \ + /* chop 10 shorter than the max, to ensure meaning of "..." */ \ + len = RegexLengthToShowInErrorMessages - 10; \ + ellipses = "..."; \ + } \ + Perl_croak(aTHX_ "%s in regex m/%.*s%s/", \ + msg, (int)len, PL_regprecomp, ellipses); \ + } STMT_END + +/* + * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given + * args. Show regex, up to a maximum length. If it's too long, chop and add + * "...". + */ +#define FAIL2(pat,msg) \ + STMT_START { \ + char *ellipses = ""; \ + unsigned len = strlen(PL_regprecomp); \ + \ + if (!SIZE_ONLY) \ + SAVEDESTRUCTOR_X(clear_re,(void*)PL_regcomp_rx); \ + \ + if (len > RegexLengthToShowInErrorMessages) { \ + /* chop 10 shorter than the max, to ensure meaning of "..." */ \ + len = RegexLengthToShowInErrorMessages - 10; \ + ellipses = "..."; \ + } \ + S_re_croak2(aTHX_ pat, " in regex m/%.*s%s/", \ + msg, (int)len, PL_regprecomp, ellipses); \ + } STMT_END + + +/* + * Simple_vFAIL -- like FAIL, but marks the current location in the scan + */ +#define Simple_vFAIL(m) \ + STMT_START { \ + unsigned offset = strlen(PL_regprecomp)-(PL_regxend-PL_regcomp_parse); \ + \ + Perl_croak(aTHX_ "%s" REPORT_LOCATION, \ + m, (int)offset, PL_regprecomp, PL_regprecomp + offset); \ + } STMT_END + +/* + * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL() + */ +#define vFAIL(m) \ + STMT_START { \ + if (!SIZE_ONLY) \ + SAVEDESTRUCTOR_X(clear_re,(void*)PL_regcomp_rx); \ + Simple_vFAIL(m); \ + } STMT_END + +/* + * Like Simple_vFAIL(), but accepts two arguments. + */ +#define Simple_vFAIL2(m,a1) \ + STMT_START { \ + unsigned offset = strlen(PL_regprecomp)-(PL_regxend-PL_regcomp_parse); \ + \ + S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, \ + (int)offset, PL_regprecomp, PL_regprecomp + offset); \ + } STMT_END + +/* + * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2(). + */ +#define vFAIL2(m,a1) \ + STMT_START { \ + if (!SIZE_ONLY) \ + SAVEDESTRUCTOR_X(clear_re,(void*)PL_regcomp_rx); \ + Simple_vFAIL2(m, a1); \ + } STMT_END + + +/* + * Like Simple_vFAIL(), but accepts three arguments. + */ +#define Simple_vFAIL3(m, a1, a2) \ + STMT_START { \ + unsigned offset = strlen(PL_regprecomp)-(PL_regxend-PL_regcomp_parse); \ + \ + S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, \ + (int)offset, PL_regprecomp, PL_regprecomp + offset); \ + } STMT_END + +/* + * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3(). + */ +#define vFAIL3(m,a1,a2) \ + STMT_START { \ + if (!SIZE_ONLY) \ + SAVEDESTRUCTOR_X(clear_re,(void*)PL_regcomp_rx); \ + Simple_vFAIL3(m, a1, a2); \ + } STMT_END + +/* + * Like Simple_vFAIL(), but accepts four arguments. + */ +#define Simple_vFAIL4(m, a1, a2, a3) \ + STMT_START { \ + unsigned offset = strlen(PL_regprecomp)-(PL_regxend-PL_regcomp_parse); \ + \ + S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,\ + (int)offset, PL_regprecomp, PL_regprecomp + offset); \ + } STMT_END + +/* + * Like Simple_vFAIL(), but accepts five arguments. + */ +#define Simple_vFAIL5(m, a1, a2, a3, a4) \ + STMT_START { \ + unsigned offset = strlen(PL_regprecomp)-(PL_regxend-PL_regcomp_parse); \ + S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3, a4,\ + (int)offset, PL_regprecomp, PL_regprecomp + offset); \ + } STMT_END + + +#define vWARN(loc,m) \ + STMT_START { \ + unsigned offset = strlen(PL_regprecomp)-(PL_regxend-(loc)); \ + Perl_warner(aTHX_ WARN_REGEXP, "%s" REPORT_LOCATION,\ + m, (int)offset, PL_regprecomp, PL_regprecomp + offset); \ + } STMT_END \ + + +#define vWARN2(loc, m, a1) \ + STMT_START { \ + unsigned offset = strlen(PL_regprecomp)-(PL_regxend-(loc)); \ + Perl_warner(aTHX_ WARN_REGEXP, m REPORT_LOCATION,\ + a1, \ + (int)offset, PL_regprecomp, PL_regprecomp + offset); \ + } STMT_END + +#define vWARN3(loc, m, a1, a2) \ + STMT_START { \ + unsigned offset = strlen(PL_regprecomp) - (PL_regxend - (loc)); \ + Perl_warner(aTHX_ WARN_REGEXP, m REPORT_LOCATION, \ + a1, a2, \ + (int)offset, PL_regprecomp, PL_regprecomp + offset); \ + } STMT_END + +#define vWARN4(loc, m, a1, a2, a3) \ + STMT_START { \ + unsigned offset = strlen(PL_regprecomp)-(PL_regxend-(loc)); \ + Perl_warner(aTHX_ WARN_REGEXP, m REPORT_LOCATION,\ + a1, a2, a3, \ + (int)offset, PL_regprecomp, PL_regprecomp + offset); \ + } STMT_END + + + /* Allow for side effects in s */ #define REGC(c,s) STMT_START { if (!SIZE_ONLY) *(s) = (c); else (s);} STMT_END @@ -213,7 +389,6 @@ static void clear_re(pTHXo_ void *r); STATIC void S_scan_commit(pTHX_ scan_data_t *data) { - dTHR; STRLEN l = CHR_SVLEN(data->last_found); STRLEN old_l = CHR_SVLEN(*data->longest); @@ -264,7 +439,7 @@ S_cl_is_anything(pTHX_ struct regnode_charclass_class *cl) { int value; - for (value = 0; value < ANYOF_MAX; value += 2) + for (value = 0; value <= ANYOF_MAX; value += 2) if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1)) return 1; for (value = 0; value < 256; ++value) @@ -378,7 +553,6 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da /* deltap: Write maxlen-minlen here. */ /* last: Stop before this one. */ { - dTHR; I32 min = 0, pars = 0, code; regnode *scan = *scanp, *next; I32 delta = 0; @@ -417,21 +591,19 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da #endif n = regnext(n); } - else { + else if (stringok) { int oldl = STR_LEN(scan); regnode *nnext = regnext(n); - + if (oldl + STR_LEN(n) > U8_MAX) break; NEXT_OFF(scan) += NEXT_OFF(n); STR_LEN(scan) += STR_LEN(n); next = n + NODE_SZ_STR(n); /* Now we can overwrite *n : */ - Move(STRING(n), STRING(scan) + oldl, - STR_LEN(n), char); + Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char); #ifdef DEBUGGING - if (stringok) - stop = next - 1; + stop = next - 1; #endif n = nnext; } @@ -486,13 +658,17 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da if (flags & SCF_DO_STCLASS) cl_init_zero(&accum); while (OP(scan) == code) { - I32 deltanext, minnext, f = 0; + I32 deltanext, minnext, f = 0, fake = 0; struct regnode_charclass_class this_class; num++; data_fake.flags = 0; - if (data) + if (data) { data_fake.whilem_c = data->whilem_c; + data_fake.last_closep = data->last_closep; + } + else + data_fake.last_closep = &fake; next = regnext(scan); scan = NEXTOPER(scan); if (code != BRANCH) @@ -502,6 +678,8 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da data_fake.start_class = &this_class; f = SCF_DO_STCLASS_AND; } + if (flags & SCF_WHILEM_VISITED_POS) + f |= SCF_WHILEM_VISITED_POS; /* we suppose the run is continuous, last=next...*/ minnext = study_chunk(&scan, &deltanext, next, &data_fake, f); @@ -664,8 +842,8 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da flags &= ~SCF_DO_STCLASS; } else if (strchr((char*)PL_varies,OP(scan))) { - I32 mincount, maxcount, minnext, deltanext, pos_before, fl; - I32 f = flags; + I32 mincount, maxcount, minnext, deltanext, fl; + I32 f = flags, pos_before = 0; regnode *oscan = scan; struct regnode_charclass_class this_class; struct regnode_charclass_class *oclass = NULL; @@ -708,6 +886,11 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da mincount = ARG1(scan); maxcount = ARG2(scan); next = regnext(scan); + if (OP(scan) == CURLYX) { + I32 lp = (data ? *(data->last_closep) : 0); + + scan->flags = ((lp <= U8_MAX) ? lp : U8_MAX); + } scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS; do_curly: if (flags & SCF_DO_SUBSTR) { @@ -727,6 +910,14 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da f |= SCF_DO_STCLASS_AND; f &= ~SCF_DO_STCLASS_OR; } + /* These are the cases when once a subexpression + fails at a particular position, it cannot succeed + even after backtracking at the enclosing scope. + + XXXX what if minimal match and we are at the + initial run of {n,m}? */ + if ((mincount != maxcount - 1) && (maxcount != REG_INFTY)) + f &= ~SCF_WHILEM_VISITED_POS; /* This will finish on WHILEM, setting scan, or on NULL: */ minnext = study_chunk(&scan, &deltanext, last, data, @@ -764,8 +955,11 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da if (ckWARN(WARN_REGEXP) && (minnext + deltanext == 0) && !(data->flags & (SF_HAS_PAR|SF_IN_PAR)) && maxcount <= REG_INFTY/3) /* Complement check for big count */ - Perl_warner(aTHX_ WARN_REGEXP, - "Strange *+?{} on zero-length expression"); + { + vWARN(PL_regcomp_parse, + "Quantifier unexpected on zero-length expression"); + } + min += minnext * mincount; is_inf_internal |= ((maxcount == REG_INFTY && (minnext + deltanext) > 0) @@ -828,7 +1022,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/ if (OP(nxt) != CLOSE) - FAIL("panic opt close"); + FAIL("Panic opt close"); oscan->flags = ARG(nxt); OP(nxt1) = OPTIMIZED; /* was OPEN. */ OP(nxt) = OPTIMIZED; /* was CLOSE. */ @@ -859,8 +1053,14 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da else oscan->flags = 0; } - else if (OP(oscan) == CURLYX && data && ++data->whilem_c < 16) { - /* This stays as CURLYX, and can put the count/of pair. */ + else if ((OP(oscan) == CURLYX) + && (flags & SCF_WHILEM_VISITED_POS) + /* See the comment on a similar expression above. + However, this time it not a subexpression + we care about, but the expression itself. */ + && (maxcount == REG_INFTY) + && data && ++data->whilem_c < 16) { + /* This stays as CURLYX, we can put the count/of pair. */ /* Find WHILEM (as in regexec.c) */ regnode *nxt = oscan + NEXT_OFF(oscan); @@ -901,6 +1101,11 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da sv_catsv(data->last_found, last_str); data->last_end += l * (mincount - 1); } + } else { + /* start offset must point into the last copy */ + data->last_start_min += minnext * (mincount - 1); + data->last_start_max += is_inf ? 0 : (maxcount - 1) + * (minnext + data->pos_delta); } } /* It is counted once already... */ @@ -1169,29 +1374,35 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da && (scan->flags || data || (flags & SCF_DO_STCLASS)) && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) { /* Lookahead/lookbehind */ - I32 deltanext, minnext; + I32 deltanext, minnext, fake = 0; regnode *nscan; struct regnode_charclass_class intrnl; int f = 0; data_fake.flags = 0; - if (data) + if (data) { data_fake.whilem_c = data->whilem_c; + data_fake.last_closep = data->last_closep; + } + else + data_fake.last_closep = &fake; if ( flags & SCF_DO_STCLASS && !scan->flags && OP(scan) == IFMATCH ) { /* Lookahead */ cl_init(&intrnl); data_fake.start_class = &intrnl; - f = SCF_DO_STCLASS_AND; + f |= SCF_DO_STCLASS_AND; } + if (flags & SCF_WHILEM_VISITED_POS) + f |= SCF_WHILEM_VISITED_POS; next = regnext(scan); nscan = NEXTOPER(NEXTOPER(scan)); minnext = study_chunk(&nscan, &deltanext, last, &data_fake, f); if (scan->flags) { if (deltanext) { - FAIL("variable length lookbehind not implemented"); + vFAIL("Variable length lookbehind not implemented"); } else if (minnext > U8_MAX) { - FAIL2("lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX); + vFAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX); } scan->flags = minnext; } @@ -1201,7 +1412,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da data->flags |= SF_HAS_EVAL; if (data) data->whilem_c = data_fake.whilem_c; - if (f) { + if (f & SCF_DO_STCLASS_AND) { int was = (data->start_class->flags & ANYOF_EOS); cl_and(data->start_class, &intrnl); @@ -1212,11 +1423,15 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da else if (OP(scan) == OPEN) { pars++; } - else if (OP(scan) == CLOSE && ARG(scan) == is_par) { - next = regnext(scan); + else if (OP(scan) == CLOSE) { + if (ARG(scan) == is_par) { + next = regnext(scan); - if ( next && (OP(next) != WHILEM) && next < last) - is_par = 0; /* Disable optimization */ + if ( next && (OP(next) != WHILEM) && next < last) + is_par = 0; /* Disable optimization */ + } + if (data) + *(data->last_closep) = ARG(scan); } else if (OP(scan) == EVAL) { if (data) @@ -1259,7 +1474,6 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da STATIC I32 S_add_data(pTHX_ I32 n, char *s) { - dTHR; if (PL_regcomp_rx->data) { Renewc(PL_regcomp_rx->data, sizeof(*PL_regcomp_rx->data) + sizeof(void*) * (PL_regcomp_rx->data->count + n - 1), @@ -1280,7 +1494,6 @@ S_add_data(pTHX_ I32 n, char *s) void Perl_reginitcolors(pTHX) { - dTHR; int i = 0; char *s = PerlEnv_getenv("PERL_RE_COLORS"); @@ -1302,6 +1515,7 @@ Perl_reginitcolors(pTHX) PL_colorset = 1; } + /* - pregcomp - compile a regular expression into internal code * @@ -1320,7 +1534,6 @@ Perl_reginitcolors(pTHX) regexp * Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) { - dTHR; register regexp *r; regnode *scan; regnode *first; @@ -1339,7 +1552,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) else PL_reg_flags = 0; - PL_regprecomp = savepvn(exp, xend - exp); + PL_regprecomp = exp; DEBUG_r(if (!PL_colorset) reginitcolors()); DEBUG_r(PerlIO_printf(Perl_debug_log, "%sCompiling REx%s `%s%*s%s'\n", PL_colors[4],PL_colors[5],PL_colors[0], @@ -1365,7 +1578,6 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) REGC((U8)REG_MAGIC, (char*)PL_regcode); #endif if (reg(0, &flags) == NULL) { - Safefree(PL_regprecomp); PL_regprecomp = Nullch; return(NULL); } @@ -1384,14 +1596,15 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) Newc(1001, r, sizeof(regexp) + (unsigned)PL_regsize * sizeof(regnode), char, regexp); if (r == NULL) - FAIL("regexp out of space"); + FAIL("Regexp out of space"); + #ifdef DEBUGGING /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */ Zero(r, sizeof(regexp) + (unsigned)PL_regsize * sizeof(regnode), char); #endif r->refcnt = 1; r->prelen = xend - exp; - r->precomp = PL_regprecomp; + r->precomp = savepvn(PL_regprecomp, r->prelen); r->subbeg = NULL; r->reganch = pm->op_pmflags & PMf_COMPILETIME; r->nparens = PL_regnpar - 1; /* set early to validate backrefs */ @@ -1436,6 +1649,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) STRLEN longest_float_length, longest_fixed_length; struct regnode_charclass_class ch_class; int stclass_flag; + I32 last_close = 0; first = scan; /* Skip introductions and multiplicators >= 1. */ @@ -1528,9 +1742,10 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) stclass_flag = SCF_DO_STCLASS_AND; } else /* XXXX Check for BOUND? */ stclass_flag = 0; + data.last_closep = &last_close; minlen = study_chunk(&first, &fake, scan + PL_regsize, /* Up to end */ - &data, SCF_DO_SUBSTR | stclass_flag); + &data, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag); if ( PL_regnpar == 1 && data.longest == &(data.longest_fixed) && data.last_start_min == 0 && data.last_end > 0 && !PL_seen_zerolen @@ -1632,12 +1847,14 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) /* Several toplevels. Best we can is to set minlen. */ I32 fake; struct regnode_charclass_class ch_class; + I32 last_close = 0; DEBUG_r(PerlIO_printf(Perl_debug_log, "\n")); scan = r->program + 1; cl_init(&ch_class); data.start_class = &ch_class; - minlen = study_chunk(&scan, &fake, scan + PL_regsize, &data, SCF_DO_STCLASS_AND); + data.last_closep = &last_close; + minlen = study_chunk(&scan, &fake, scan + PL_regsize, &data, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS); r->check_substr = r->anchored_substr = r->float_substr = Nullsv; if (!(data.start_class->flags & ANYOF_EOS) && !cl_is_anything(data.start_class)) { @@ -1667,6 +1884,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) r->reganch |= ROPT_EVAL_SEEN; Newz(1002, r->startp, PL_regnpar, I32); Newz(1002, r->endp, PL_regnpar, I32); + PL_regdata = r->data; /* for regprop() ANYOFUTF8 */ DEBUG_r(regdump(r)); return(r); } @@ -1684,13 +1902,13 @@ STATIC regnode * S_reg(pTHX_ I32 paren, I32 *flagp) /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */ { - dTHR; register regnode *ret; /* Will be the head of the group. */ register regnode *br; register regnode *lastbr; register regnode *ender = 0; register I32 parno = 0; I32 flags, oregflags = PL_regflags, have_branch = 0, open = 0; + char *oregcomp_parse = PL_regcomp_parse; char c; *flagp = 0; /* Tentatively. */ @@ -1701,6 +1919,7 @@ S_reg(pTHX_ I32 paren, I32 *flagp) U16 posflags = 0, negflags = 0; U16 *flagsp = &posflags; int logical = 0; + char *seqstart = PL_regcomp_parse; PL_regcomp_parse++; paren = *PL_regcomp_parse++; @@ -1721,7 +1940,7 @@ S_reg(pTHX_ I32 paren, I32 *flagp) break; case '$': case '@': - FAIL2("Sequence (?%c...) not implemented", (int)paren); + vFAIL2("Sequence (?%c...) not implemented", (int)paren); break; case '#': while (*PL_regcomp_parse && *PL_regcomp_parse != ')') @@ -1733,8 +1952,7 @@ S_reg(pTHX_ I32 paren, I32 *flagp) return NULL; case 'p': if (SIZE_ONLY) - Perl_warner(aTHX_ WARN_REGEXP, - "(?p{}) is deprecated - use (??{})"); + vWARN(PL_regcomp_parse, "(?p{}) is deprecated - use (??{})"); /* FALL THROUGH*/ case '?': logical = 1; @@ -1742,7 +1960,6 @@ S_reg(pTHX_ I32 paren, I32 *flagp) /* FALL THROUGH */ case '{': { - dTHR; I32 count = 1, n = 0; char c; char *s = PL_regcomp_parse; @@ -1761,7 +1978,10 @@ S_reg(pTHX_ I32 paren, I32 *flagp) PL_regcomp_parse++; } if (*PL_regcomp_parse != ')') - FAIL("Sequence (?{...}) not terminated or not {}-balanced"); + { + PL_regcomp_parse = s; + vFAIL("Sequence (?{...}) not terminated or not {}-balanced"); + } if (!SIZE_ONLY) { AV *av; @@ -1770,7 +1990,10 @@ S_reg(pTHX_ I32 paren, I32 *flagp) else sv = newSVpvn("", 0); + ENTER; + Perl_save_re_context(aTHX); rop = sv_compile_2op(sv, &sop, "re", &av); + LEAVE; n = add_data(3, "nop"); PL_regcomp_rx->data->data[n] = (void*)rop; @@ -1820,7 +2043,7 @@ S_reg(pTHX_ I32 paren, I32 *flagp) PL_regcomp_parse++; ret = reganode(GROUPP, parno); if ((c = *nextchar()) != ')') - FAIL2("Switch (?(number%c not recognized", c); + vFAIL("Switch condition not recognized"); insert_if: regtail(ret, reganode(IFTHEN, 0)); br = regbranch(&flags, 1); @@ -1842,7 +2065,7 @@ S_reg(pTHX_ I32 paren, I32 *flagp) else lastbr = NULL; if (c != ')') - FAIL("Switch (?(condition)... contains too many branches"); + vFAIL("Switch (?(condition)... contains too many branches"); ender = reg_node(TAIL); regtail(br, ender); if (lastbr) { @@ -1854,11 +2077,12 @@ S_reg(pTHX_ I32 paren, I32 *flagp) return ret; } else { - FAIL2("Unknown condition for (?(%.2s", PL_regcomp_parse); + vFAIL2("Unknown switch condition (?(%.2s", PL_regcomp_parse); } } case 0: - FAIL("Sequence (? incomplete"); + PL_regcomp_parse--; /* for vFAIL to print correctly */ + vFAIL("Sequence (? incomplete"); break; default: --PL_regcomp_parse; @@ -1881,8 +2105,10 @@ S_reg(pTHX_ I32 paren, I32 *flagp) break; } unknown: - if (*PL_regcomp_parse != ')') - FAIL2("Sequence (?%c...) not recognized", *PL_regcomp_parse); + if (*PL_regcomp_parse != ')') { + PL_regcomp_parse++; + vFAIL3("Sequence (%.*s...) not recognized", PL_regcomp_parse-seqstart, seqstart); + } nextchar(); *flagp = TRYAGAIN; return NULL; @@ -1994,15 +2220,17 @@ S_reg(pTHX_ I32 paren, I32 *flagp) if (paren) { PL_regflags = oregflags; if (PL_regcomp_parse >= PL_regxend || *nextchar() != ')') { - FAIL("unmatched () in regexp"); + PL_regcomp_parse = oregcomp_parse; + vFAIL("Unmatched ("); } } else if (!paren && PL_regcomp_parse < PL_regxend) { if (*PL_regcomp_parse == ')') { - FAIL("unmatched () in regexp"); + PL_regcomp_parse++; + vFAIL("Unmatched )"); } else - FAIL("junk on end of regexp"); /* "Can't happen". */ + FAIL("Junk on end of regexp"); /* "Can't happen". */ /* NOTREACHED */ } @@ -2017,7 +2245,6 @@ S_reg(pTHX_ I32 paren, I32 *flagp) STATIC regnode * S_regbranch(pTHX_ I32 *flagp, I32 first) { - dTHR; register regnode *ret; register regnode *chain = NULL; register regnode *latest; @@ -2083,7 +2310,6 @@ S_regbranch(pTHX_ I32 *flagp, I32 first) STATIC regnode * S_regpiece(pTHX_ I32 *flagp) { - dTHR; register regnode *ret; register char op; register char *next; @@ -2127,7 +2353,7 @@ S_regpiece(pTHX_ I32 *flagp) if (!max && *maxpos != '0') max = REG_INFTY; /* meaning "infinity" */ else if (max >= REG_INFTY) - FAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1); + vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1); PL_regcomp_parse = next; nextchar(); @@ -2161,7 +2387,7 @@ S_regpiece(pTHX_ I32 *flagp) if (max > 0) *flagp |= HASWIDTH; if (max && max < min) - FAIL("Can't do {n,m} with n > m"); + vFAIL("Can't do {n,m} with n > m"); if (!SIZE_ONLY) { ARG1_SET(ret, min); ARG2_SET(ret, max); @@ -2177,8 +2403,19 @@ S_regpiece(pTHX_ I32 *flagp) } #if 0 /* Now runtime fix should be reliable. */ + + /* if this is reinstated, don't forget to put this back into perldiag: + + =item Regexp *+ operand could be empty at {#} in regex m/%s/ + + (F) The part of the regexp subject to either the * or + quantifier + could match an empty string. The {#} shows in the regular + expression about where the problem was discovered. + + */ + if (!(flags&HASWIDTH) && op != '?') - FAIL("regexp *+ operand could be empty"); + vFAIL("Regexp *+ operand could be empty"); #endif nextchar(); @@ -2209,8 +2446,10 @@ S_regpiece(pTHX_ I32 *flagp) } nest_check: if (ckWARN(WARN_REGEXP) && !SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3) { - Perl_warner(aTHX_ WARN_REGEXP, "%.*s matches null string many times", - PL_regcomp_parse - origparse, origparse); + vWARN3(PL_regcomp_parse, + "%.*s matches null string many times", + PL_regcomp_parse - origparse, + origparse); } if (*PL_regcomp_parse == '?') { @@ -2218,8 +2457,10 @@ S_regpiece(pTHX_ I32 *flagp) reginsert(MINMOD, ret); regtail(ret, ret + NODE_STEP_REGNODE); } - if (ISMULT2(PL_regcomp_parse)) - FAIL("nested *?+ in regexp"); + if (ISMULT2(PL_regcomp_parse)) { + PL_regcomp_parse++; + vFAIL("Nested quantifiers"); + } return(ret); } @@ -2232,12 +2473,10 @@ S_regpiece(pTHX_ I32 *flagp) * faster to run. Backslashed characters are exceptions, each becoming a * separate node; the code is simpler that way and it's not worth fixing. * - * [Yes, it is worth fixing, some scripts can run twice the speed.] - */ + * [Yes, it is worth fixing, some scripts can run twice the speed.] */ STATIC regnode * S_regatom(pTHX_ I32 *flagp) { - dTHR; register regnode *ret = 0; I32 flags; @@ -2256,9 +2495,9 @@ tryagain: ret = reg_node(BOL); break; case '$': - if (PL_regcomp_parse[1]) - PL_seen_zerolen++; nextchar(); + if (*PL_regcomp_parse) + PL_seen_zerolen++; if (PL_regflags & PMf_MULTILINE) ret = reg_node(MEOL); else if (PL_regflags & PMf_SINGLELINE) @@ -2285,19 +2524,29 @@ tryagain: PL_regnaughty++; break; case '[': - PL_regcomp_parse++; + { + char *oregcomp_parse = ++PL_regcomp_parse; ret = (UTF ? regclassutf8() : regclass()); - if (*PL_regcomp_parse != ']') - FAIL("unmatched [] in regexp"); + if (*PL_regcomp_parse != ']') { + PL_regcomp_parse = oregcomp_parse; + vFAIL("Unmatched ["); + } nextchar(); *flagp |= HASWIDTH|SIMPLE; break; + } case '(': nextchar(); ret = reg(1, &flags); if (ret == NULL) { - if (flags & TRYAGAIN) + if (flags & TRYAGAIN) { + if (PL_regcomp_parse == PL_regxend) { + /* Make parent create an empty node if needed. */ + *flagp |= TRYAGAIN; + return(NULL); + } goto tryagain; + } return(NULL); } *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE); @@ -2308,7 +2557,7 @@ tryagain: *flagp |= TRYAGAIN; return NULL; } - FAIL2("internal urp in regexp at /%s/", PL_regcomp_parse); + vFAIL("Internal urp"); /* Supposed to be caught earlier. */ break; case '{': @@ -2320,7 +2569,8 @@ tryagain: case '?': case '+': case '*': - FAIL("?+*{} follows nothing in regexp"); + PL_regcomp_parse++; + vFAIL("Quantifier follows nothing"); break; case '\\': switch (*++PL_regcomp_parse) { @@ -2444,8 +2694,11 @@ tryagain: if (PL_regcomp_parse[1] == '{') { PL_regxend = strchr(PL_regcomp_parse, '}'); - if (!PL_regxend) - FAIL("Missing right brace on \\p{}"); + if (!PL_regxend) { + PL_regcomp_parse += 2; + PL_regxend = oldregxend; + vFAIL("Missing right brace on \\p{}"); + } PL_regxend++; } else @@ -2478,15 +2731,16 @@ tryagain: if (num > 9 && num >= PL_regnpar) goto defchar; else { + while (isDIGIT(*PL_regcomp_parse)) + PL_regcomp_parse++; + if (!SIZE_ONLY && num > PL_regcomp_rx->nparens) - FAIL("reference to nonexistent group"); + vFAIL("Reference to nonexistent group"); PL_regsawback = 1; ret = reganode(FOLD ? (LOC ? REFFL : REFF) : REF, num); *flagp |= HASWIDTH; - while (isDIGIT(*PL_regcomp_parse)) - PL_regcomp_parse++; PL_regcomp_parse--; nextchar(); } @@ -2494,7 +2748,7 @@ tryagain: break; case '\0': if (PL_regcomp_parse >= PL_regxend) - FAIL("trailing \\ in regexp"); + FAIL("Trailing \\"); /* FALL THROUGH */ default: /* Do not generate `unrecognized' warnings here, we fall @@ -2512,11 +2766,11 @@ tryagain: /* FALL THROUGH */ default: { - register I32 len; + register STRLEN len; register UV ender; register char *p; char *oldp, *s; - I32 numlen; + STRLEN numlen; PL_regcomp_parse++; @@ -2596,20 +2850,23 @@ tryagain: if (*++p == '{') { char* e = strchr(p, '}'); - if (!e) - FAIL("Missing right brace on \\x{}"); - else if (UTF) { - ender = (UV)scan_hex(p + 1, e - p, &numlen); - if (numlen + len >= 127) { /* numlen is generous */ + if (!e) { + PL_regcomp_parse = p + 1; + vFAIL("Missing right brace on \\x{}"); + } + else { + numlen = 1; /* allow underscores */ + ender = (UV)scan_hex(p + 1, e - p - 1, &numlen); + /* numlen is generous */ + if (numlen + len >= 127) { p--; goto loopdone; } p = e + 1; } - else - FAIL("Can't use \\x{} without 'use utf8' declaration"); } else { + numlen = 0; /* disallow underscores */ ender = (UV)scan_hex(p, 2, &numlen); p += numlen; } @@ -2623,6 +2880,7 @@ tryagain: case '5': case '6': case '7': case '8':case '9': if (*p == '0' || (isDIGIT(p[1]) && atoi(p) >= PL_regnpar) ) { + numlen = 0; /* disallow underscores */ ender = (UV)scan_oct(p, 3, &numlen); p += numlen; } @@ -2633,21 +2891,19 @@ tryagain: break; case '\0': if (p >= PL_regxend) - FAIL("trailing \\ in regexp"); + FAIL("Trailing \\"); /* FALL THROUGH */ default: if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(*p)) - Perl_warner(aTHX_ WARN_REGEXP, - "/%.127s/: Unrecognized escape \\%c passed through", - PL_regprecomp, - *p); + vWARN2(p +1, "Unrecognized escape \\%c passed through", *p); goto normal_default; } break; default: normal_default: - if ((*p & 0xc0) == 0xc0 && UTF) { - ender = utf8_to_uv((U8*)p, &numlen); + if (UTF8_IS_START(*p) && UTF) { + ender = utf8_to_uv((U8*)p, PL_regxend - p, + &numlen, 0); p += numlen; } else @@ -2665,6 +2921,8 @@ tryagain: if (ISMULT2(p)) { /* Back off on ?+*. */ if (len) p = oldp; + /* ender is a Unicode value so it can be > 0xff -- + * in other words, do not use UTF8_IS_CONTINUED(). */ else if (ender >= 0x80 && UTF) { reguni(ender, s, &numlen); s += numlen; @@ -2676,6 +2934,8 @@ tryagain: } break; } + /* ender is a Unicode value so it can be > 0xff -- + * in other words, do not use UTF8_IS_CONTINUED(). */ if (ender >= 0x80 && UTF) { reguni(ender, s, &numlen); s += numlen; @@ -2687,8 +2947,12 @@ tryagain: loopdone: PL_regcomp_parse = p - 1; nextchar(); - if (len < 0) - FAIL("internal disaster in regexp"); + { + /* len is STRLEN which is unsigned, need to copy to signed */ + IV iv = len; + if (iv < 0) + vFAIL("Internal disaster"); + } if (len > 0) *flagp |= HASWIDTH; if (len == 1) @@ -2731,7 +2995,6 @@ S_regwhite(pTHX_ char *p, char *e) STATIC I32 S_regpposixcc(pTHX_ I32 value) { - dTHR; char *posixcc = 0; I32 namedclass = OOB_NAMEDCLASS; @@ -2770,6 +3033,11 @@ S_regpposixcc(pTHX_ I32 value) namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII; break; + case 'b': + if (strnEQ(posixcc, "blank", 5)) + namedclass = + complement ? ANYOF_NBLANK : ANYOF_BLANK; + break; case 'c': if (strnEQ(posixcc, "cntrl", 5)) namedclass = @@ -2801,7 +3069,8 @@ S_regpposixcc(pTHX_ I32 value) case 's': if (strnEQ(posixcc, "space", 5)) namedclass = - complement ? ANYOF_NSPACE : ANYOF_SPACE; + complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC; + break; case 'u': if (strnEQ(posixcc, "upper", 5)) namedclass = @@ -2825,13 +3094,19 @@ S_regpposixcc(pTHX_ I32 value) if (namedclass == OOB_NAMEDCLASS || posixcc[skip] != ':' || posixcc[skip+1] != ']') - Perl_croak(aTHX_ - "Character class [:%.*s:] unknown", - t - s - 1, s + 1); - } else if (ckWARN(WARN_REGEXP) && !SIZE_ONLY) + { + Simple_vFAIL3("POSIX class [:%.*s:] unknown", + t - s - 1, s + 1); + } + } else if (!SIZE_ONLY) { /* [[=foo=]] and [[.foo.]] are still future. */ - Perl_warner(aTHX_ WARN_REGEXP, - "Character class syntax [%c %c] is reserved for future extensions", c, c); + + /* adjust PL_regcomp_parse so the warning shows after + the class closes */ + while (*PL_regcomp_parse && *PL_regcomp_parse != ']') + PL_regcomp_parse++; + Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c); + } } else { /* Maternal grandfather: * "[:" ending in ":" but not in ":]" */ @@ -2856,11 +3131,17 @@ S_checkposixcc(pTHX) while(*s && isALNUM(*s)) s++; if (*s && c == *s && s[1] == ']') { - Perl_warner(aTHX_ WARN_REGEXP, - "Character class syntax [%c %c] belongs inside character classes", c, c); + vWARN3(s+2, "POSIX syntax [%c %c] belongs inside character classes", c, c); + + /* [[=foo=]] and [[.foo.]] are still future. */ if (c == '=' || c == '.') - Perl_warner(aTHX_ WARN_REGEXP, - "Character class syntax [%c %c] is reserved for future extensions", c, c); + { + /* adjust PL_regcomp_parse so the error shows after + the class closes */ + while (*PL_regcomp_parse && *PL_regcomp_parse++ != ']') + ; + Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c); + } } } } @@ -2868,12 +3149,11 @@ S_checkposixcc(pTHX) STATIC regnode * S_regclass(pTHX) { - dTHR; register U32 value; register I32 lastvalue = OOB_CHAR8; register I32 range = 0; register regnode *ret; - I32 numlen; + STRLEN numlen; I32 namedclass; char *rangebegin; bool need_class = 0; @@ -2913,7 +3193,7 @@ S_regclass(pTHX) else if (value == '\\') { value = UCHARAT(PL_regcomp_parse++); /* Some compilers cannot handle switching on 64-bit integer - * values, therefore value cannot be an UV. --jhi */ + * values, therefore the 'value' cannot be an UV. --jhi */ switch (value) { case 'w': namedclass = ANYOF_ALNUM; break; case 'W': namedclass = ANYOF_NALNUM; break; @@ -2934,6 +3214,7 @@ S_regclass(pTHX) case 'a': value = '\057'; break; #endif case 'x': + numlen = 0; /* disallow underscores */ value = (UV)scan_hex(PL_regcomp_parse, 2, &numlen); PL_regcomp_parse += numlen; break; @@ -2943,15 +3224,14 @@ S_regclass(pTHX) break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': + numlen = 0; /* disallow underscores */ value = (UV)scan_oct(--PL_regcomp_parse, 3, &numlen); PL_regcomp_parse += numlen; break; default: if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(value)) - Perl_warner(aTHX_ WARN_REGEXP, - "/%.127s/: Unrecognized escape \\%c in character class passed through", - PL_regprecomp, - (int)value); + + vWARN2(PL_regcomp_parse, "Unrecognized escape \\%c in character class passed through", (int)value); break; } } @@ -2962,12 +3242,11 @@ S_regclass(pTHX) if (range) { /* a-\d, a-[:digit:] */ if (!SIZE_ONLY) { if (ckWARN(WARN_REGEXP)) - Perl_warner(aTHX_ WARN_REGEXP, - "/%.127s/: false [] range \"%*.*s\" in regexp", - PL_regprecomp, - PL_regcomp_parse - rangebegin, - PL_regcomp_parse - rangebegin, - rangebegin); + vWARN4(PL_regcomp_parse, + "False [] range \"%*.*s\"", + PL_regcomp_parse - rangebegin, + PL_regcomp_parse - rangebegin, + rangebegin); ANYOF_BITMAP_SET(ret, lastvalue); ANYOF_BITMAP_SET(ret, '-'); } @@ -3093,6 +3372,24 @@ S_regclass(pTHX) #endif /* EBCDIC */ } break; + case ANYOF_BLANK: + if (LOC) + ANYOF_CLASS_SET(ret, ANYOF_BLANK); + else { + for (value = 0; value < 256; value++) + if (isBLANK(value)) + ANYOF_BITMAP_SET(ret, value); + } + break; + case ANYOF_NBLANK: + if (LOC) + ANYOF_CLASS_SET(ret, ANYOF_NBLANK); + else { + for (value = 0; value < 256; value++) + if (!isBLANK(value)) + ANYOF_BITMAP_SET(ret, value); + } + break; case ANYOF_CNTRL: if (LOC) ANYOF_CLASS_SET(ret, ANYOF_CNTRL); @@ -3166,6 +3463,24 @@ S_regclass(pTHX) ANYOF_BITMAP_SET(ret, value); } break; + case ANYOF_PSXSPC: + if (LOC) + ANYOF_CLASS_SET(ret, ANYOF_PSXSPC); + else { + for (value = 0; value < 256; value++) + if (isPSXSPC(value)) + ANYOF_BITMAP_SET(ret, value); + } + break; + case ANYOF_NPSXSPC: + if (LOC) + ANYOF_CLASS_SET(ret, ANYOF_NPSXSPC); + else { + for (value = 0; value < 256; value++) + if (!isPSXSPC(value)) + ANYOF_BITMAP_SET(ret, value); + } + break; case ANYOF_PUNCT: if (LOC) ANYOF_CLASS_SET(ret, ANYOF_PUNCT); @@ -3221,7 +3536,7 @@ S_regclass(pTHX) } break; default: - FAIL("invalid [::] class in regexp"); + vFAIL("Invalid [::] class"); break; } if (LOC) @@ -3231,12 +3546,10 @@ S_regclass(pTHX) } if (range) { if (lastvalue > value) /* b-a */ { - Perl_croak(aTHX_ - "/%.127s/: invalid [] range \"%*.*s\" in regexp", - PL_regprecomp, - PL_regcomp_parse - rangebegin, - PL_regcomp_parse - rangebegin, - rangebegin); + Simple_vFAIL4("Invalid [] range \"%*.*s\"", + PL_regcomp_parse - rangebegin, + PL_regcomp_parse - rangebegin, + rangebegin); } range = 0; } @@ -3247,12 +3560,11 @@ S_regclass(pTHX) PL_regcomp_parse++; if (namedclass > OOB_NAMEDCLASS) { /* \w-, [:word:]- */ if (ckWARN(WARN_REGEXP)) - Perl_warner(aTHX_ WARN_REGEXP, - "/%.127s/: false [] range \"%*.*s\" in regexp", - PL_regprecomp, - PL_regcomp_parse - rangebegin, - PL_regcomp_parse - rangebegin, - rangebegin); + vWARN4(PL_regcomp_parse, + "False [] range \"%*.*s\"", + PL_regcomp_parse - rangebegin, + PL_regcomp_parse - rangebegin, + rangebegin); if (!SIZE_ONLY) ANYOF_BITMAP_SET(ret, '-'); } else @@ -3313,13 +3625,12 @@ S_regclass(pTHX) STATIC regnode * S_regclassutf8(pTHX) { - dTHR; register char *e; register U32 value; register U32 lastvalue = OOB_UTF8; register I32 range = 0; register regnode *ret; - I32 numlen; + STRLEN numlen; I32 n; SV *listsv; U8 flags = 0; @@ -3337,7 +3648,7 @@ S_regclassutf8(pTHX) flags |= ANYOF_FOLD; if (LOC) flags |= ANYOF_LOCALE; - listsv = newSVpvn("# comment\n",10); + listsv = newSVpvn("# comment\n", 10); } if (!SIZE_ONLY && ckWARN(WARN_REGEXP)) @@ -3351,12 +3662,16 @@ S_regclassutf8(pTHX) namedclass = OOB_NAMEDCLASS; if (!range) rangebegin = PL_regcomp_parse; - value = utf8_to_uv((U8*)PL_regcomp_parse, &numlen); + value = utf8_to_uv((U8*)PL_regcomp_parse, + PL_regxend - PL_regcomp_parse, + &numlen, 0); PL_regcomp_parse += numlen; if (value == '[') namedclass = regpposixcc(value); else if (value == '\\') { - value = (U32)utf8_to_uv((U8*)PL_regcomp_parse, &numlen); + value = (U32)utf8_to_uv((U8*)PL_regcomp_parse, + PL_regxend - PL_regcomp_parse, + &numlen, 0); PL_regcomp_parse += numlen; /* Some compilers cannot handle switching on 64-bit integer * values, therefore value cannot be an UV. Yes, this will @@ -3373,7 +3688,7 @@ S_regclassutf8(pTHX) if (*PL_regcomp_parse == '{') { e = strchr(PL_regcomp_parse++, '}'); if (!e) - FAIL("Missing right brace on \\p{}"); + vFAIL("Missing right brace on \\p{}"); n = e - PL_regcomp_parse; } else { @@ -3406,14 +3721,16 @@ S_regclassutf8(pTHX) case 'x': if (*PL_regcomp_parse == '{') { e = strchr(PL_regcomp_parse++, '}'); - if (!e) - FAIL("Missing right brace on \\x{}"); + if (!e) + vFAIL("Missing right brace on \\x{}"); + numlen = 1; /* allow underscores */ value = (UV)scan_hex(PL_regcomp_parse, e - PL_regcomp_parse, &numlen); PL_regcomp_parse = e + 1; } else { + numlen = 0; /* disallow underscores */ value = (UV)scan_hex(PL_regcomp_parse, 2, &numlen); PL_regcomp_parse += numlen; } @@ -3424,15 +3741,15 @@ S_regclassutf8(pTHX) break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': + numlen = 0; /* disallow underscores */ value = (UV)scan_oct(--PL_regcomp_parse, 3, &numlen); PL_regcomp_parse += numlen; break; default: if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(value)) - Perl_warner(aTHX_ WARN_REGEXP, - "/%.127s/: Unrecognized escape \\%c in character class passed through", - PL_regprecomp, - (int)value); + vWARN2(PL_regcomp_parse, + "Unrecognized escape \\%c in character class passed through", + (int)value); break; } } @@ -3440,12 +3757,11 @@ S_regclassutf8(pTHX) if (range) { /* a-\d, a-[:digit:] */ if (!SIZE_ONLY) { if (ckWARN(WARN_REGEXP)) - Perl_warner(aTHX_ WARN_REGEXP, - "/%.127s/: false [] range \"%*.*s\" in regexp", - PL_regprecomp, - PL_regcomp_parse - rangebegin, - PL_regcomp_parse - rangebegin, - rangebegin); + vWARN4(PL_regcomp_parse, + "False [] range \"%*.*s\"", + PL_regcomp_parse - rangebegin, + PL_regcomp_parse - rangebegin, + rangebegin); Perl_sv_catpvf(aTHX_ listsv, /* 0x002D is Unicode for '-' */ "%04"UVxf"\n002D\n", (UV)lastvalue); @@ -3495,8 +3811,16 @@ S_regclassutf8(pTHX) case ANYOF_NPUNCT: Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPunct\n"); break; case ANYOF_SPACE: - Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpace\n"); break; + Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpacePerl\n");break; case ANYOF_NSPACE: + Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpacePerl\n");break; + case ANYOF_BLANK: + Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsBlank\n"); break; + case ANYOF_NBLANK: + Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsBlank\n"); break; + case ANYOF_PSXSPC: + Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpace\n"); break; + case ANYOF_NPSXSPC: Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpace\n"); break; case ANYOF_UPPER: Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsUpper\n"); break; @@ -3512,12 +3836,10 @@ S_regclassutf8(pTHX) } if (range) { if (lastvalue > value) { /* b-a */ - Perl_croak(aTHX_ - "/%.127s/: invalid [] range \"%*.*s\" in regexp", - PL_regprecomp, - PL_regcomp_parse - rangebegin, - PL_regcomp_parse - rangebegin, - rangebegin); + Simple_vFAIL4("Invalid [] range \"%*.*s\"", + PL_regcomp_parse - rangebegin, + PL_regcomp_parse - rangebegin, + rangebegin); } range = 0; } @@ -3528,12 +3850,11 @@ S_regclassutf8(pTHX) PL_regcomp_parse++; if (namedclass > OOB_NAMEDCLASS) { /* \w-, [:word:]- */ if (ckWARN(WARN_REGEXP)) - Perl_warner(aTHX_ WARN_REGEXP, - "/%.127s/: false [] range \"%*.*s\" in regexp", - PL_regprecomp, - PL_regcomp_parse - rangebegin, - PL_regcomp_parse - rangebegin, - rangebegin); + vWARN4(PL_regcomp_parse, + "False [] range \"%*.*s\"", + PL_regcomp_parse - rangebegin, + PL_regcomp_parse - rangebegin, + rangebegin); if (!SIZE_ONLY) Perl_sv_catpvf(aTHX_ listsv, /* 0x002D is Unicode for '-' */ @@ -3554,7 +3875,14 @@ S_regclassutf8(pTHX) if (!SIZE_ONLY) { SV *rv = swash_init("utf8", "", listsv, 1, 0); +#ifdef DEBUGGING + AV *av = newAV(); + av_push(av, rv); + av_push(av, listsv); + rv = newRV_noinc((SV*)av); +#else SvREFCNT_dec(listsv); +#endif n = add_data(1,"s"); PL_regcomp_rx->data->data[n] = (void*)rv; ARG1_SET(ret, flags); @@ -3567,7 +3895,6 @@ S_regclassutf8(pTHX) STATIC char* S_nextchar(pTHX) { - dTHR; char* retval = PL_regcomp_parse++; for (;;) { @@ -3600,7 +3927,6 @@ S_nextchar(pTHX) STATIC regnode * /* Location. */ S_reg_node(pTHX_ U8 op) { - dTHR; register regnode *ret; register regnode *ptr; @@ -3625,7 +3951,6 @@ S_reg_node(pTHX_ U8 op) STATIC regnode * /* Location. */ S_reganode(pTHX_ U8 op, U32 arg) { - dTHR; register regnode *ret; register regnode *ptr; @@ -3648,16 +3973,9 @@ S_reganode(pTHX_ U8 op, U32 arg) - reguni - emit (if appropriate) a Unicode character */ STATIC void -S_reguni(pTHX_ UV uv, char* s, I32* lenp) +S_reguni(pTHX_ UV uv, char* s, STRLEN* lenp) { - dTHR; - if (SIZE_ONLY) { - U8 tmpbuf[UTF8_MAXLEN]; - *lenp = uv_to_utf8(tmpbuf, uv) - tmpbuf; - } - else - *lenp = uv_to_utf8((U8*)s, uv) - (U8*)s; - + *lenp = SIZE_ONLY ? UNISKIP(uv) : (uv_to_utf8((U8*)s, uv) - (U8*)s); } /* @@ -3668,7 +3986,6 @@ S_reguni(pTHX_ UV uv, char* s, I32* lenp) STATIC void S_reginsert(pTHX_ U8 op, regnode *opnd) { - dTHR; register regnode *src; register regnode *dst; register regnode *place; @@ -3699,7 +4016,6 @@ S_reginsert(pTHX_ U8 op, regnode *opnd) STATIC void S_regtail(pTHX_ regnode *p, regnode *val) { - dTHR; register regnode *scan; register regnode *temp; @@ -3729,7 +4045,6 @@ S_regtail(pTHX_ regnode *p, regnode *val) STATIC void S_regoptail(pTHX_ regnode *p, regnode *val) { - dTHR; /* "Operandless" and "op != BRANCH" are synonymous in practice. */ if (p == NULL || SIZE_ONLY) return; @@ -3843,7 +4158,6 @@ void Perl_regdump(pTHX_ regexp *r) { #ifdef DEBUGGING - dTHR; SV *sv = sv_newmortal(); (void)dumpuntil(r->program, r->program + 1, NULL, sv, 0); @@ -3910,7 +4224,7 @@ Perl_regdump(pTHX_ regexp *r) STATIC void S_put_byte(pTHX_ SV *sv, int c) { - if (c <= ' ' || c == 127 || c == 255) + if (isCNTRL(c) || c == 127 || c == 255) Perl_sv_catpvf(aTHX_ sv, "\\%o", c); else if (c == '-' || c == ']' || c == '\\' || c == '^') Perl_sv_catpvf(aTHX_ sv, "\\%c", c); @@ -3925,12 +4239,11 @@ void Perl_regprop(pTHX_ SV *sv, regnode *o) { #ifdef DEBUGGING - dTHR; register int k; sv_setpvn(sv, "", 0); if (OP(o) >= reg_num) /* regnode.type is unsigned */ - FAIL("corrupted regexp opcode"); + FAIL("Corrupted regexp opcode"); sv_catpv(sv, (char*)reg_name[OP(o)]); /* Take off const! */ k = PL_regkind[(U8)OP(o)]; @@ -3939,7 +4252,7 @@ Perl_regprop(pTHX_ SV *sv, regnode *o) Perl_sv_catpvf(aTHX_ sv, " <%s%.*s%s>", PL_colors[0], STR_LEN(o), STRING(o), PL_colors[1]); else if (k == CURLY) { - if (OP(o) == CURLYM || OP(o) == CURLYN) + if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX) Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */ Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o)); } @@ -3951,8 +4264,10 @@ Perl_regprop(pTHX_ SV *sv, regnode *o) Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */ else if (k == ANYOF) { int i, rangestart = -1; - const char * const out[] = { /* Should be syncronized with - a table in regcomp.h */ + bool anyofutf8 = OP(o) == ANYOFUTF8; + U8 flags = anyofutf8 ? ARG1(o) : o->flags; + const char * const anyofs[] = { /* Should be syncronized with + * ANYOF_ #xdefines in regcomp.h */ "\\w", "\\W", "\\s", @@ -3976,38 +4291,94 @@ Perl_regprop(pTHX_ SV *sv, regnode *o) "[:punct:]", "[:^punct:]", "[:upper:]", - "[:!upper:]", + "[:^upper:]", "[:xdigit:]", - "[:^xdigit:]" + "[:^xdigit:]", + "[:space:]", + "[:^space:]", + "[:blank:]", + "[:^blank:]" }; - if (o->flags & ANYOF_LOCALE) + if (flags & ANYOF_LOCALE) sv_catpv(sv, "{loc}"); - if (o->flags & ANYOF_FOLD) + if (flags & ANYOF_FOLD) sv_catpv(sv, "{i}"); Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]); - if (o->flags & ANYOF_INVERT) + if (flags & ANYOF_INVERT) sv_catpv(sv, "^"); - for (i = 0; i <= 256; i++) { - if (i < 256 && ANYOF_BITMAP_TEST(o,i)) { - if (rangestart == -1) - rangestart = i; - } else if (rangestart != -1) { - if (i <= rangestart + 3) - for (; rangestart < i; rangestart++) + if (OP(o) == ANYOF) { + for (i = 0; i <= 256; i++) { + if (i < 256 && ANYOF_BITMAP_TEST(o,i)) { + if (rangestart == -1) + rangestart = i; + } else if (rangestart != -1) { + if (i <= rangestart + 3) + for (; rangestart < i; rangestart++) + put_byte(sv, rangestart); + else { put_byte(sv, rangestart); - else { - put_byte(sv, rangestart); - sv_catpv(sv, "-"); - put_byte(sv, i - 1); + sv_catpv(sv, "-"); + put_byte(sv, i - 1); + } + rangestart = -1; + } + } + if (o->flags & ANYOF_CLASS) + for (i = 0; i < sizeof(anyofs)/sizeof(char*); i++) + if (ANYOF_CLASS_TEST(o,i)) + sv_catpv(sv, anyofs[i]); + } + else { + SV *rv = (SV*)PL_regdata->data[ARG2(o)]; + AV *av = (AV*)SvRV((SV*)rv); + SV *sw = *av_fetch(av, 0, FALSE); + SV *lv = *av_fetch(av, 1, FALSE); + UV i; + U8 s[UTF8_MAXLEN+1]; + for (i = 0; i <= 256; i++) { /* just the first 256 */ + U8 *e = uv_to_utf8(s, i); + if (i < 256 && swash_fetch(sw, s)) { + if (rangestart == -1) + rangestart = i; + } else if (rangestart != -1) { + U8 *p; + + if (i <= rangestart + 3) + for (; rangestart < i; rangestart++) { + for(e = uv_to_utf8(s, rangestart), p = s; p < e; p++) + put_byte(sv, *p); + } + else { + for (e = uv_to_utf8(s, rangestart), p = s; p < e; p++) + put_byte(sv, *p); + sv_catpv(sv, "-"); + for (e = uv_to_utf8(s, i - 1), p = s; p < e; p++) + put_byte(sv, *p); + } + rangestart = -1; + } + } + sv_catpv(sv, "..."); + { + char *s = savepv(SvPVX(lv)); + + while(*s && *s != '\n') s++; + if (*s == '\n') { + char *t = ++s; + + while (*s) { + if (*s == '\n') + *s = ' '; + s++; + } + if (s[-1] == ' ') + s[-1] = 0; + + sv_catpv(sv, t); } - rangestart = -1; } } - if (o->flags & ANYOF_CLASS) - for (i = 0; i < sizeof(out)/sizeof(char*); i++) - if (ANYOF_CLASS_TEST(o,i)) - sv_catpv(sv, out[i]); Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]); } else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH)) @@ -4037,7 +4408,6 @@ Perl_re_intuit_string(pTHX_ regexp *prog) void Perl_pregfree(pTHX_ struct regexp *r) { - dTHR; DEBUG_r(if (!PL_colorset) reginitcolors()); if (!r || (--r->refcnt > 0)) @@ -4082,8 +4452,13 @@ Perl_pregfree(pTHX_ struct regexp *r) Perl_croak(aTHX_ "panic: pregfree comppad"); old_comppad = PL_comppad; old_curpad = PL_curpad; - PL_comppad = new_comppad; - PL_curpad = AvARRAY(new_comppad); + /* Watch out for global destruction's random ordering. */ + if (SvTYPE(new_comppad) == SVt_PVAV) { + PL_comppad = new_comppad; + PL_curpad = AvARRAY(new_comppad); + } + else + PL_curpad = NULL; op_free((OP_4tree*)r->data->data[n]); PL_comppad = old_comppad; PL_curpad = old_curpad; @@ -4113,7 +4488,6 @@ Perl_pregfree(pTHX_ struct regexp *r) regnode * Perl_regnext(pTHX_ register regnode *p) { - dTHR; register I32 offset; if (p == &PL_regdummy) @@ -4165,7 +4539,6 @@ S_re_croak2(pTHX_ const char* pat1,const char* pat2,...) void Perl_save_re_context(pTHX) { - dTHR; SAVEPPTR(PL_bostr); SAVEPPTR(PL_regprecomp); /* uncompiled string. */ SAVEI32(PL_regnpar); /* () count. */ @@ -4179,9 +4552,8 @@ Perl_save_re_context(pTHX) SAVEVPTR(PL_reglastparen); /* Similarly for lastparen. */ SAVEPPTR(PL_regtill); /* How far we are required to go. */ SAVEI8(PL_regprev); /* char before regbol, \n if none */ - SAVEVPTR(PL_reg_start_tmp); /* from regexec.c */ + SAVEGENERICPV(PL_reg_start_tmp); /* from regexec.c */ PL_reg_start_tmp = 0; - SAVEFREEPV(PL_reg_start_tmp); SAVEI32(PL_reg_start_tmpl); /* from regexec.c */ PL_reg_start_tmpl = 0; SAVEVPTR(PL_regdata); @@ -4207,6 +4579,7 @@ Perl_save_re_context(pTHX) SAVEI32(PL_reg_oldpos); /* from regexec.c */ SAVEVPTR(PL_reg_oldcurpm); /* from regexec.c */ SAVEVPTR(PL_reg_curpm); /* from regexec.c */ + SAVEI32(PL_regnpar); /* () count. */ #ifdef DEBUGGING SAVEPPTR(PL_reg_starttry); /* from regexec.c */ #endif diff --git a/contrib/perl5/regcomp.h b/contrib/perl5/regcomp.h index 3624917c6e2d..225ff74a269b 100644 --- a/contrib/perl5/regcomp.h +++ b/contrib/perl5/regcomp.h @@ -192,13 +192,13 @@ struct regnode_charclass_class { /* Should be synchronized with a table in regprop() */ /* 2n should pair with 2n+1 */ -#define ANYOF_ALNUM 0 /* \w, utf8::IsWord, isALNUM() */ +#define ANYOF_ALNUM 0 /* \w, PL_utf8_alnum, utf8::IsWord, ALNUM */ #define ANYOF_NALNUM 1 -#define ANYOF_SPACE 2 +#define ANYOF_SPACE 2 /* \s */ #define ANYOF_NSPACE 3 #define ANYOF_DIGIT 4 #define ANYOF_NDIGIT 5 -#define ANYOF_ALNUMC 6 /* isalnum(3), utf8::IsAlnum, isALNUMC() */ +#define ANYOF_ALNUMC 6 /* isalnum(3), utf8::IsAlnum, ALNUMC */ #define ANYOF_NALNUMC 7 #define ANYOF_ALPHA 8 #define ANYOF_NALPHA 9 @@ -218,8 +218,12 @@ struct regnode_charclass_class { #define ANYOF_NUPPER 23 #define ANYOF_XDIGIT 24 #define ANYOF_NXDIGIT 25 +#define ANYOF_PSXSPC 26 /* POSIX space: \s plus the vertical tab */ +#define ANYOF_NPSXSPC 27 +#define ANYOF_BLANK 28 /* GNU extension: space and tab */ +#define ANYOF_NBLANK 29 -#define ANYOF_MAX 31 +#define ANYOF_MAX 32 /* Backward source code compatibility. */ @@ -269,20 +273,6 @@ struct regnode_charclass_class { #define UCHARAT(p) PL_regdummy #endif /* lint */ -#define FAIL(m) \ - STMT_START { \ - if (!SIZE_ONLY) \ - SAVEDESTRUCTOR_X(clear_re,(void*)PL_regcomp_rx); \ - Perl_croak(aTHX_ "/%.127s/: %s", PL_regprecomp,m); \ - } STMT_END - -#define FAIL2(pat,m) \ - STMT_START { \ - if (!SIZE_ONLY) \ - SAVEDESTRUCTOR_X(clear_re,(void*)PL_regcomp_rx); \ - S_re_croak2(aTHX_ "/%.127s/: ",pat,PL_regprecomp,m); \ - } STMT_END - #define EXTRA_SIZE(guy) ((sizeof(guy)-1)/sizeof(struct regnode)) #define REG_SEEN_ZERO_LEN 1 diff --git a/contrib/perl5/regcomp.pl b/contrib/perl5/regcomp.pl index d7d07330109c..6ae847882d49 100644 --- a/contrib/perl5/regcomp.pl +++ b/contrib/perl5/regcomp.pl @@ -57,7 +57,7 @@ print OUT <<EOP; #ifdef REG_COMP_C -const static U8 regarglen[] = { +static const U8 regarglen[] = { EOP $ind = 0; @@ -73,7 +73,7 @@ EOP print OUT <<EOP; }; -const static char reg_off_by_arg[] = { +static const char reg_off_by_arg[] = { EOP $ind = 0; @@ -89,7 +89,7 @@ print OUT <<EOP; }; #ifdef DEBUGGING -const static char * const reg_name[] = { +static const char * const reg_name[] = { EOP $ind = 0; @@ -105,7 +105,7 @@ EOP print OUT <<EOP; }; -const static int reg_num = $tot; +static const int reg_num = $tot; #endif /* DEBUGGING */ #endif /* REG_COMP_C */ diff --git a/contrib/perl5/regexec.c b/contrib/perl5/regexec.c index 3b6d8577a7b8..f4db4e02c110 100644 --- a/contrib/perl5/regexec.c +++ b/contrib/perl5/regexec.c @@ -66,7 +66,7 @@ * **** Alterations to Henry's code are... **** - **** 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. @@ -106,7 +106,11 @@ */ #define REGINCLASS(p,c) (ANYOF_FLAGS(p) ? reginclass(p,c) : ANYOF_BITMAP_TEST(p,c)) -#define REGINCLASSUTF8(f,p) (ARG1(f) ? reginclassutf8(f,p) : swash_fetch((SV*)PL_regdata->data[ARG2(f)],p)) +#ifdef DEBUGGING +# define REGINCLASSUTF8(f,p) (ARG1(f) ? reginclassutf8(f,p) : swash_fetch(*av_fetch((AV*)SvRV((SV*)PL_regdata->data[ARG2(f)]),0,FALSE),p)) +#else +# define REGINCLASSUTF8(f,p) (ARG1(f) ? reginclassutf8(f,p) : swash_fetch((SV*)PL_regdata->data[ARG2(f)],p)) +#endif #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv)) #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b) @@ -124,50 +128,62 @@ static void restore_pos(pTHXo_ void *arg); STATIC CHECKPOINT S_regcppush(pTHX_ I32 parenfloor) { - dTHR; int retval = PL_savestack_ix; - int i = (PL_regsize - parenfloor) * 4; +#define REGCP_PAREN_ELEMS 4 + int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS; int p; - SSCHECK(i + 5); +#define REGCP_OTHER_ELEMS 5 + SSCHECK(paren_elems_to_push + REGCP_OTHER_ELEMS); for (p = PL_regsize; p > parenfloor; p--) { +/* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */ SSPUSHINT(PL_regendp[p]); SSPUSHINT(PL_regstartp[p]); SSPUSHPTR(PL_reg_start_tmp[p]); SSPUSHINT(p); } +/* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */ SSPUSHINT(PL_regsize); SSPUSHINT(*PL_reglastparen); SSPUSHPTR(PL_reginput); - SSPUSHINT(i + 3); - SSPUSHINT(SAVEt_REGCONTEXT); +#define REGCP_FRAME_ELEMS 2 +/* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and + * are needed for the regexp context stack bookkeeping. */ + SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS); + SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */ + return retval; } /* These are needed since we do not localize EVAL nodes: */ -# define REGCP_SET DEBUG_r(PerlIO_printf(Perl_debug_log, \ +# define REGCP_SET(cp) DEBUG_r(PerlIO_printf(Perl_debug_log, \ " Setting an EVAL scope, savestack=%"IVdf"\n", \ - (IV)PL_savestack_ix)); lastcp = PL_savestack_ix + (IV)PL_savestack_ix)); cp = PL_savestack_ix -# define REGCP_UNWIND DEBUG_r(lastcp != PL_savestack_ix ? \ +# define REGCP_UNWIND(cp) DEBUG_r(cp != PL_savestack_ix ? \ PerlIO_printf(Perl_debug_log, \ " Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \ - (IV)lastcp, (IV)PL_savestack_ix) : 0); regcpblow(lastcp) + (IV)(cp), (IV)PL_savestack_ix) : 0); regcpblow(cp) STATIC char * S_regcppop(pTHX) { - dTHR; - I32 i = SSPOPINT; + I32 i; U32 paren = 0; char *input; I32 tmps; - assert(i == SAVEt_REGCONTEXT); + + /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */ i = SSPOPINT; + assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */ + i = SSPOPINT; /* Parentheses elements to pop. */ input = (char *) SSPOPPTR; *PL_reglastparen = SSPOPINT; PL_regsize = SSPOPINT; - for (i -= 3; i > 0; i -= 4) { + + /* Now restore the parentheses context. */ + for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS); + i > 0; i -= REGCP_PAREN_ELEMS) { paren = (U32)SSPOPINT; PL_reg_start_tmp[paren] = (char *) SSPOPPTR; PL_regstartp[paren] = SSPOPINT; @@ -190,18 +206,29 @@ S_regcppop(pTHX) (IV)(*PL_reglastparen + 1), (IV)PL_regnpar); } ); +#if 1 + /* It would seem that the similar code in regtry() + * already takes care of this, and in fact it is in + * a better location to since this code can #if 0-ed out + * but the code in regtry() is needed or otherwise tests + * requiring null fields (pat.t#187 and split.t#{13,14} + * (as of patchlevel 7877) will fail. Then again, + * this code seems to be necessary or otherwise + * building DynaLoader will fail: + * "Error: '*' not in typemap in DynaLoader.xs, line 164" + * --jhi */ for (paren = *PL_reglastparen + 1; paren <= PL_regnpar; paren++) { if (paren > PL_regsize) PL_regstartp[paren] = -1; PL_regendp[paren] = -1; } +#endif return input; } STATIC char * S_regcp_set_to(pTHX_ I32 ss) { - dTHR; I32 tmp = PL_savestack_ix; PL_savestack_ix = ss; @@ -219,7 +246,23 @@ typedef struct re_cc_state regexp *re; } re_cc_state; -#define regcpblow(cp) LEAVE_SCOPE(cp) +#define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */ + +#define TRYPAREN(paren, n, input) { \ + if (paren) { \ + if (n) { \ + PL_regstartp[paren] = HOPc(input, -1) - PL_bostr; \ + PL_regendp[paren] = input - PL_bostr; \ + } \ + else \ + PL_regendp[paren] = -1; \ + } \ + if (regmatch(next)) \ + sayYES; \ + if (paren && n) \ + PL_regendp[paren] = -1; \ +} + /* * pregexec and friends @@ -244,7 +287,6 @@ Perl_pregexec(pTHX_ register regexp *prog, char *stringarg, register char *stren STATIC void S_cache_re(pTHX_ regexp *prog) { - dTHR; PL_regprecomp = prog->precomp; /* Needed for FAIL. */ #ifdef DEBUGGING PL_regprogram = prog->program; @@ -309,6 +351,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, register I32 end_shift; register char *s; register SV *check; + char *strbeg; char *t; I32 ml_anch; char *tmp; @@ -335,21 +378,25 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, DEBUG_r(PerlIO_printf(Perl_debug_log, "String too short...\n")); goto fail; } + strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos; check = prog->check_substr; if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */ ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE) || ( (prog->reganch & ROPT_ANCH_BOL) && !PL_multiline ) ); /* Check after \n? */ - if ((prog->check_offset_min == prog->check_offset_max) && !ml_anch) { + if (!ml_anch) { + if ( !(prog->reganch & ROPT_ANCH_GPOS) /* Checked by the caller */ + /* SvCUR is not set on references: SvRV and SvPVX overlap */ + && sv && !SvROK(sv) + && (strpos != strbeg)) { + DEBUG_r(PerlIO_printf(Perl_debug_log, "Not at start...\n")); + goto fail; + } + if (prog->check_offset_min == prog->check_offset_max) { /* Substring at constant offset from beg-of-str... */ I32 slen; - if ( !(prog->reganch & ROPT_ANCH_GPOS) /* Checked by the caller */ - && (sv && (strpos + SvCUR(sv) != strend)) ) { - DEBUG_r(PerlIO_printf(Perl_debug_log, "Not at start...\n")); - goto fail; - } PL_regeol = strend; /* Used in HOP() */ s = HOPc(strpos, prog->check_offset_min); if (SvTAIL(check)) { @@ -375,6 +422,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, && memNE(SvPVX(check), s, slen))) goto report_neq; goto success_at_start; + } } /* Match is anchored, but substr is not anchored wrt beg-of-str. */ s = strpos; @@ -405,10 +453,11 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, #endif restart: + other_last = Nullch; + /* Find a possible match in the region s..strend by looking for the "check" substring in the region corrected by start/end_shift. */ if (flags & REXEC_SCREAM) { - char *strbeg = SvPVX(sv); /* XXXX Assume PV_force() on SCREAM! */ I32 p = -1; /* Internal iterator of scream. */ I32 *pp = data ? data->scream_pos : &p; @@ -559,7 +608,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, DEBUG_r(PerlIO_printf(Perl_debug_log, ", trying anchored starting at offset %ld...\n", (long)(s1 + 1 - i_strpos))); - other_last = last + 1; + other_last = last; PL_regeol = strend; /* Used in HOP() */ s = HOPc(t, 1); goto restart; @@ -567,7 +616,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, else { DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n", (long)(s - i_strpos))); - other_last = s + 1; + other_last = s; /* Fix this later. --Hugo */ s = s1; if (t == strpos) goto try_at_start; @@ -597,9 +646,10 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, find_anchor: while (t < strend - prog->minlen) { if (*t == '\n') { - if (t < s - prog->check_offset_min) { + if (t < check_at - prog->check_offset_min) { if (prog->anchored_substr) { - /* We definitely contradict the found anchored + /* Since we moved from the found position, + we definitely contradict the found anchored substr. Due to the above check we do not contradict "check" substr. Thus we can arrive here only if check substr @@ -610,14 +660,19 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, PL_colors[0],PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset))); goto do_other_anchored; } + /* We don't contradict the found floating substring. */ + /* XXXX Why not check for STCLASS? */ s = t + 1; DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n", PL_colors[0],PL_colors[1], (long)(s - i_strpos))); goto set_useful; } - DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting at offset %ld...\n", + /* Position contradicts check-string */ + /* XXXX probably better to look for check-string + than for "\n", so one should lower the limit for t? */ + DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n", PL_colors[0],PL_colors[1], (long)(t + 1 - i_strpos))); - strpos = s = t + 1; + other_last = strpos = s = t + 1; goto restart; } t++; @@ -626,20 +681,25 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, PL_colors[0],PL_colors[1])); goto fail_finish; } + else { + DEBUG_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n", + PL_colors[0],PL_colors[1])); + } s = t; set_useful: ++BmUSEFUL(prog->check_substr); /* hooray/5 */ } else { PL_bostr = tmp; - /* The found string does not prohibit matching at beg-of-str + /* The found string does not prohibit matching at strpos, - no optimization of calling REx engine can be performed, - unless it was an MBOL and we are not after MBOL. */ + unless it was an MBOL and we are not after MBOL, + or a future STCLASS check will fail this. */ try_at_start: /* Even in this situation we may use MBOL flag if strpos is offset wrt the start of the string. */ - if (ml_anch && sv - && (strpos + SvCUR(sv) != strend) && strpos[-1] != '\n' + if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */ + && (strpos != strbeg) && strpos[-1] != '\n' /* May be due to an implicit anchor of m{.*foo} */ && !(prog->reganch & ROPT_IMPLICIT)) { @@ -647,8 +707,8 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, goto find_anchor; } DEBUG_r( if (ml_anch) - PerlIO_printf(Perl_debug_log, "Does not contradict /%s^%s/m...\n", - PL_colors[0],PL_colors[1]); + PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n", + (long)(strpos - i_strpos), PL_colors[0],PL_colors[1]); ); success_at_start: if (!(prog->reganch & ROPT_NAUGHTY) /* XXXX If strpos moved? */ @@ -657,9 +717,11 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, && prog->check_substr == prog->float_substr) { /* If flags & SOMETHING - do not do it many times on the same match */ + DEBUG_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n")); SvREFCNT_dec(prog->check_substr); prog->check_substr = Nullsv; /* disable */ prog->float_substr = Nullsv; /* clear */ + check = Nullsv; /* abort */ s = strpos; /* XXXX This is a remnant of the old implementation. It looks wasteful, since now INTUIT can use many @@ -688,7 +750,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, ? s + (prog->minlen? cl_l : 0) : (prog->float_substr ? check_at - start_shift + cl_l : strend) ; - char *startpos = sv && SvPOK(sv) ? strend - SvCUR(sv) : s; + char *startpos = strbeg; t = s; if (prog->reganch & ROPT_UTF8) { @@ -722,8 +784,10 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, "Could not match STCLASS...\n") ); goto fail; } + if (!check) + goto giveup; DEBUG_r( PerlIO_printf(Perl_debug_log, - "Trying %s substr starting at offset %ld...\n", + "Looking for %s substr starting at offset %ld...\n", what, (long)(s + start_shift - i_strpos)) ); goto restart; } @@ -732,8 +796,10 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, goto retry_floating_check; /* Recheck anchored substring, but not floating... */ s = check_at; + if (!check) + goto giveup; DEBUG_r( PerlIO_printf(Perl_debug_log, - "Trying anchored substr starting at offset %ld...\n", + "Looking for anchored substr starting at offset %ld...\n", (long)(other_last - i_strpos)) ); goto do_other_anchored; } @@ -741,9 +807,11 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, current position only: */ if (ml_anch) { s = t = t + 1; + if (!check) + goto giveup; DEBUG_r( PerlIO_printf(Perl_debug_log, - "Trying /^/m starting at offset %ld...\n", - (long)(t - i_strpos)) ); + "Looking for /%s^%s/m starting at offset %ld...\n", + PL_colors[0],PL_colors[1], (long)(t - i_strpos)) ); goto try_at_offset; } if (!prog->float_substr) /* Could have been deleted */ @@ -762,8 +830,10 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, PerlIO_printf(Perl_debug_log, "Does not contradict STCLASS...\n") ); } - DEBUG_r(PerlIO_printf(Perl_debug_log, "%sGuessed:%s match at offset %ld\n", - PL_colors[4], PL_colors[5], (long)(s - i_strpos)) ); + giveup: + DEBUG_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n", + PL_colors[4], (check ? "Guessed" : "Giving up"), + PL_colors[5], (long)(s - i_strpos)) ); return s; fail_finish: /* Substring not found */ @@ -875,8 +945,15 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta PL_reg_flags |= RF_tainted; /* FALL THROUGH */ case BOUNDUTF8: - tmp = (I32)(s != startpos) ? utf8_to_uv(reghop((U8*)s, -1), 0) : '\n'; - tmp = ((OP(c) == BOUNDUTF8 ? isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0); + if (s == startpos) + tmp = '\n'; + else { + U8 *r = reghop((U8*)s, -1); + + tmp = (I32)utf8_to_uv(r, s - (char*)r, 0, 0); + } + tmp = ((OP(c) == BOUNDUTF8 ? + isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0); while (s < strend) { if (tmp == !(OP(c) == BOUNDUTF8 ? swash_fetch(PL_utf8_alnum, (U8*)s) : @@ -911,8 +988,15 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta PL_reg_flags |= RF_tainted; /* FALL THROUGH */ case NBOUNDUTF8: - tmp = (I32)(s != startpos) ? utf8_to_uv(reghop((U8*)s, -1), 0) : '\n'; - tmp = ((OP(c) == NBOUNDUTF8 ? isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0); + if (s == startpos) + tmp = '\n'; + else { + U8 *r = reghop((U8*)s, -1); + + tmp = (I32)utf8_to_uv(r, s - (char*)r, 0, 0); + } + tmp = ((OP(c) == NBOUNDUTF8 ? + isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0); while (s < strend) { if (tmp == !(OP(c) == NBOUNDUTF8 ? swash_fetch(PL_utf8_alnum, (U8*)s) : @@ -1270,7 +1354,6 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * /* data: May be used for some additional optimizations. */ /* nosave: For optimizations. */ { - dTHR; register char *s; register regnode *c; register char *startpos = stringarg; @@ -1432,9 +1515,14 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * /* we have /x+whatever/ */ /* it must be a one character string (XXXX Except UTF?) */ char ch = SvPVX(prog->anchored_substr)[0]; +#ifdef DEBUGGING + int did_match = 0; +#endif + if (UTF) { while (s < strend) { if (*s == ch) { + DEBUG_r( did_match = 1 ); if (regtry(prog, s)) goto got_it; s += UTF8SKIP(s); while (s < strend && *s == ch) @@ -1446,6 +1534,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * else { while (s < strend) { if (*s == ch) { + DEBUG_r( did_match = 1 ); if (regtry(prog, s)) goto got_it; s++; while (s < strend && *s == ch) @@ -1454,6 +1543,9 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * s++; } } + DEBUG_r(did_match || + PerlIO_printf(Perl_debug_log, + "Did not find anchored character...\n")); } /*SUPPRESS 560*/ else if (prog->anchored_substr != Nullsv @@ -1469,6 +1561,9 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * -(I32)(CHR_SVLEN(must) - (SvTAIL(must) != 0) + back_min)); char *last1; /* Last position checked before */ +#ifdef DEBUGGING + int did_match = 0; +#endif if (s > PL_bostr) last1 = HOPc(s, -1); @@ -1487,6 +1582,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * : (s = fbm_instr((unsigned char*)HOP(s, back_min), (unsigned char*)strend, must, PL_multiline ? FBMrf_MULTILINE : 0))) ) { + DEBUG_r( did_match = 1 ); if (HOPc(s, -back_max) > last1) { last1 = HOPc(s, -back_min); s = HOPc(s, -back_max); @@ -1512,6 +1608,14 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * } } } + DEBUG_r(did_match || + PerlIO_printf(Perl_debug_log, "Did not find %s substr `%s%.*s%s'%s...\n", + ((must == prog->anchored_substr) + ? "anchored" : "floating"), + PL_colors[0], + (int)(SvCUR(must) - (SvTAIL(must)!=0)), + SvPVX(must), + PL_colors[1], (SvTAIL(must) ? "$" : ""))); goto phooey; } else if ((c = prog->regstclass)) { @@ -1520,6 +1624,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * strend = HOPc(strend, -(minlen - 1)); if (find_byclass(prog, c, s, strend, startpos, 0)) goto got_it; + DEBUG_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass...\n")); } else { dontbother = 0; @@ -1552,7 +1657,12 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * last = strend; /* matching `$' */ } } - if (last == NULL) goto phooey; /* Should not happen! */ + if (last == NULL) { + DEBUG_r(PerlIO_printf(Perl_debug_log, + "%sCan't trim the tail, match fails (should not happen)%s\n", + PL_colors[4],PL_colors[5])); + goto phooey; /* Should not happen! */ + } dontbother = strend - last + prog->float_min_offset; } if (minlen && (dontbother < minlen)) @@ -1614,6 +1724,8 @@ got_it: return 1; phooey: + DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n", + PL_colors[4],PL_colors[5])); if (PL_reg_eval_set) restore_pos(aTHXo_ 0); return 0; @@ -1625,12 +1737,14 @@ phooey: STATIC I32 /* 0 failure, 1 success */ S_regtry(pTHX_ regexp *prog, char *startpos) { - dTHR; register I32 i; register I32 *sp; register I32 *ep; CHECKPOINT lastcp; +#ifdef DEBUGGING + PL_regindent = 0; /* XXXX Not good when matches are reenterable... */ +#endif if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) { MAGIC *mg; @@ -1702,24 +1816,67 @@ S_regtry(pTHX_ regexp *prog, char *startpos) /* XXXX What this code is doing here?!!! There should be no need to do this again and again, PL_reglastparen should take care of - this! */ + this! --ilya*/ + + /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code. + * Actually, the code in regcppop() (which Ilya may be meaning by + * PL_reglastparen), is not needed at all by the test suite + * (op/regexp, op/pat, op/split), but that code is needed, oddly + * enough, for building DynaLoader, or otherwise this + * "Error: '*' not in typemap in DynaLoader.xs, line 164" + * will happen. Meanwhile, this code *is* needed for the + * above-mentioned test suite tests to succeed. The common theme + * on those tests seems to be returning null fields from matches. + * --jhi */ +#if 1 sp = prog->startp; ep = prog->endp; if (prog->nparens) { - for (i = prog->nparens; i >= 1; i--) { + for (i = prog->nparens; i > *PL_reglastparen; i--) { *++sp = -1; *++ep = -1; } } - REGCP_SET; +#endif + REGCP_SET(lastcp); if (regmatch(prog->program + 1)) { prog->endp[0] = PL_reginput - PL_bostr; return 1; } - REGCP_UNWIND; + REGCP_UNWIND(lastcp); return 0; } +#define RE_UNWIND_BRANCH 1 +#define RE_UNWIND_BRANCHJ 2 + +union re_unwind_t; + +typedef struct { /* XX: makes sense to enlarge it... */ + I32 type; + I32 prev; + CHECKPOINT lastcp; +} re_unwind_generic_t; + +typedef struct { + I32 type; + I32 prev; + CHECKPOINT lastcp; + I32 lastparen; + regnode *next; + char *locinput; + I32 nextchr; +#ifdef DEBUGGING + int regindent; +#endif +} re_unwind_branch_t; + +typedef union re_unwind_t { + I32 type; + re_unwind_generic_t generic; + re_unwind_branch_t branch; +} re_unwind_t; + /* - regmatch - main matching routine * @@ -1737,7 +1894,6 @@ S_regtry(pTHX_ regexp *prog, char *startpos) STATIC I32 /* 0 failure, 1 success */ S_regmatch(pTHX_ regnode *prog) { - dTHR; register regnode *scan; /* Current node. */ regnode *next; /* Next node. */ regnode *inner; /* Next node in internal branch. */ @@ -1749,6 +1905,9 @@ S_regmatch(pTHX_ regnode *prog) register char *locinput = PL_reginput; register I32 c1, c2, paren; /* case fold search, parenth */ int minmod = 0, sw = 0, logical = 0; + I32 unwind = 0; + I32 firstcp = PL_savestack_ix; + #ifdef DEBUGGING PL_regindent++; #endif @@ -1758,7 +1917,7 @@ S_regmatch(pTHX_ regnode *prog) scan = prog; while (scan != NULL) { #define sayNO_L (logical ? (logical = 0, sw = 0, goto cont) : sayNO) -#ifdef DEBUGGING +#if 1 # define sayYES goto yes # define sayNO goto no # define sayYES_FINAL goto yes_final @@ -1838,7 +1997,7 @@ S_regmatch(pTHX_ regnode *prog) } sayNO; case SBOL: - if (locinput == PL_regbol && PL_regprev == '\n') + if (locinput == PL_bostr) break; sayNO; case GPOS: @@ -1927,9 +2086,10 @@ S_regmatch(pTHX_ regnode *prog) while (s < e) { if (l >= PL_regeol) sayNO; - if (utf8_to_uv((U8*)s, 0) != (c1 ? - toLOWER_utf8((U8*)l) : - toLOWER_LC_utf8((U8*)l))) + if (utf8_to_uv((U8*)s, e - s, 0, 0) != + (c1 ? + toLOWER_utf8((U8*)l) : + toLOWER_LC_utf8((U8*)l))) { sayNO; } @@ -2064,8 +2224,13 @@ S_regmatch(pTHX_ regnode *prog) case BOUNDUTF8: case NBOUNDUTF8: /* was last char in word? */ - ln = (locinput != PL_regbol) - ? utf8_to_uv(reghop((U8*)locinput, -1), 0) : PL_regprev; + if (locinput == PL_regbol) + ln = PL_regprev; + else { + U8 *r = reghop((U8*)locinput, -1); + + ln = utf8_to_uv(r, s - (char*)r, 0, 0); + } if (OP(scan) == BOUNDUTF8 || OP(scan) == NBOUNDUTF8) { ln = isALNUM_uni(ln); n = swash_fetch(PL_utf8_alnum, (U8*)locinput); @@ -2363,7 +2528,7 @@ S_regmatch(pTHX_ regnode *prog) PL_regcc = 0; cp = regcppush(0); /* Save *all* the positions. */ - REGCP_SET; + REGCP_SET(lastcp); cache_re(re); state.ss = PL_savestack_ix; *PL_reglastparen = 0; @@ -2393,7 +2558,7 @@ S_regmatch(pTHX_ regnode *prog) sayYES; } ReREFCNT_dec(re); - REGCP_UNWIND; + REGCP_UNWIND(lastcp); regcppop(); PL_reg_call_cc = state.prev; PL_regcc = state.cc; @@ -2520,12 +2685,18 @@ S_regmatch(pTHX_ regnode *prog) case CURLYX: { CURCUR cc; CHECKPOINT cp = PL_savestack_ix; + /* No need to save/restore up to this paren */ + I32 parenfloor = scan->flags; if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */ next += ARG(next); cc.oldcc = PL_regcc; PL_regcc = &cc; - cc.parenfloor = *PL_reglastparen; + /* XXXX Probably it is better to teach regpush to support + parenfloor > PL_regsize... */ + if (parenfloor > *PL_reglastparen) + parenfloor = *PL_reglastparen; /* Pessimization... */ + cc.parenfloor = parenfloor; cc.cur = -1; cc.min = ARG1(scan); cc.max = ARG2(scan); @@ -2648,12 +2819,12 @@ S_regmatch(pTHX_ regnode *prog) if (PL_regcc) ln = PL_regcc->cur; cp = regcppush(cc->parenfloor); - REGCP_SET; + REGCP_SET(lastcp); if (regmatch(cc->next)) { regcpblow(cp); sayYES; /* All done. */ } - REGCP_UNWIND; + REGCP_UNWIND(lastcp); regcppop(); if (PL_regcc) PL_regcc->cur = ln; @@ -2680,12 +2851,12 @@ S_regmatch(pTHX_ regnode *prog) cc->cur = n; cc->lastloc = locinput; cp = regcppush(cc->parenfloor); - REGCP_SET; + REGCP_SET(lastcp); if (regmatch(cc->scan)) { regcpblow(cp); sayYES; } - REGCP_UNWIND; + REGCP_UNWIND(lastcp); regcppop(); cc->cur = n - 1; cc->lastloc = lastloc; @@ -2698,12 +2869,12 @@ S_regmatch(pTHX_ regnode *prog) cp = regcppush(cc->parenfloor); cc->cur = n; cc->lastloc = locinput; - REGCP_SET; + REGCP_SET(lastcp); if (regmatch(cc->scan)) { regcpblow(cp); sayYES; } - REGCP_UNWIND; + REGCP_UNWIND(lastcp); regcppop(); /* Restore some previous $<digit>s? */ PL_reginput = locinput; DEBUG_r( @@ -2749,30 +2920,30 @@ S_regmatch(pTHX_ regnode *prog) if (OP(next) != c1) /* No choice. */ next = inner; /* Avoid recursion. */ else { - int lastparen = *PL_reglastparen; + I32 lastparen = *PL_reglastparen; + I32 unwind1; + re_unwind_branch_t *uw; + + /* Put unwinding data on stack */ + unwind1 = SSNEWt(1,re_unwind_branch_t); + uw = SSPTRt(unwind1,re_unwind_branch_t); + uw->prev = unwind; + unwind = unwind1; + uw->type = ((c1 == BRANCH) + ? RE_UNWIND_BRANCH + : RE_UNWIND_BRANCHJ); + uw->lastparen = lastparen; + uw->next = next; + uw->locinput = locinput; + uw->nextchr = nextchr; +#ifdef DEBUGGING + uw->regindent = ++PL_regindent; +#endif - REGCP_SET; - do { - PL_reginput = locinput; - if (regmatch(inner)) - sayYES; - REGCP_UNWIND; - for (n = *PL_reglastparen; n > lastparen; n--) - PL_regendp[n] = -1; - *PL_reglastparen = n; - scan = next; - /*SUPPRESS 560*/ - if ((n = (c1 == BRANCH ? NEXT_OFF(next) : ARG(next)))) - next += n; - else - next = NULL; - inner = NEXTOPER(scan); - if (c1 == BRANCHJ) { - inner = NEXTOPER(inner); - } - } while (scan != NULL && OP(scan) == c1); - sayNO; - /* NOTREACHED */ + REGCP_SET(uw->lastcp); + + /* Now go into the first branch */ + next = inner; } } break; @@ -2822,7 +2993,7 @@ S_regmatch(pTHX_ regnode *prog) } else c1 = c2 = -1000; - REGCP_SET; + REGCP_SET(lastcp); /* This may be improved if l == 0. */ while (n >= ln || (n == REG_INFTY && ln > 0 && l)) { /* ln overflow ? */ /* If it could work, try it. */ @@ -2841,7 +3012,7 @@ S_regmatch(pTHX_ regnode *prog) } if (regmatch(next)) sayYES; - REGCP_UNWIND; + REGCP_UNWIND(lastcp); } /* Couldn't or didn't -- move forward. */ PL_reginput = locinput; @@ -2881,7 +3052,7 @@ S_regmatch(pTHX_ regnode *prog) else c1 = c2 = -1000; } - REGCP_SET; + REGCP_SET(lastcp); while (n >= ln) { /* If it could work, try it. */ if (c1 == -1000 || @@ -2903,7 +3074,7 @@ S_regmatch(pTHX_ regnode *prog) } if (regmatch(next)) sayYES; - REGCP_UNWIND; + REGCP_UNWIND(lastcp); } /* Couldn't or didn't -- back up. */ n--; @@ -2964,7 +3135,7 @@ S_regmatch(pTHX_ regnode *prog) if (ln && regrepeat(scan, ln) < ln) sayNO; locinput = PL_reginput; - REGCP_SET; + REGCP_SET(lastcp); if (c1 != -1000) { char *e = locinput + n - ln; /* Should not check after this */ char *old = locinput; @@ -2992,18 +3163,9 @@ S_regmatch(pTHX_ regnode *prog) sayNO; } /* PL_reginput == locinput now */ - if (paren) { - if (ln) { - PL_regstartp[paren] = HOPc(locinput, -1) - PL_bostr; - PL_regendp[paren] = locinput - PL_bostr; - } - else - PL_regendp[paren] = -1; - } - if (regmatch(next)) - sayYES; + TRYPAREN(paren, ln, locinput); PL_reginput = locinput; /* Could be reset... */ - REGCP_UNWIND; + REGCP_UNWIND(lastcp); /* Couldn't or didn't -- move forward. */ old = locinput++; } @@ -3015,17 +3177,8 @@ S_regmatch(pTHX_ regnode *prog) UCHARAT(PL_reginput) == c1 || UCHARAT(PL_reginput) == c2) { - if (paren) { - if (n) { - PL_regstartp[paren] = HOPc(PL_reginput, -1) - PL_bostr; - PL_regendp[paren] = PL_reginput - PL_bostr; - } - else - PL_regendp[paren] = -1; - } - if (regmatch(next)) - sayYES; - REGCP_UNWIND; + TRYPAREN(paren, n, PL_reginput); + REGCP_UNWIND(lastcp); } /* Couldn't or didn't -- move forward. */ PL_reginput = locinput; @@ -3050,7 +3203,7 @@ S_regmatch(pTHX_ regnode *prog) if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS) ln--; } - REGCP_SET; + REGCP_SET(lastcp); if (paren) { while (n >= ln) { /* If it could work, try it. */ @@ -3058,17 +3211,8 @@ S_regmatch(pTHX_ regnode *prog) UCHARAT(PL_reginput) == c1 || UCHARAT(PL_reginput) == c2) { - if (paren && n) { - if (n) { - PL_regstartp[paren] = HOPc(PL_reginput, -1) - PL_bostr; - PL_regendp[paren] = PL_reginput - PL_bostr; - } - else - PL_regendp[paren] = -1; - } - if (regmatch(next)) - sayYES; - REGCP_UNWIND; + TRYPAREN(paren, n, PL_reginput); + REGCP_UNWIND(lastcp); } /* Couldn't or didn't -- back up. */ n--; @@ -3082,9 +3226,8 @@ S_regmatch(pTHX_ regnode *prog) UCHARAT(PL_reginput) == c1 || UCHARAT(PL_reginput) == c2) { - if (regmatch(next)) - sayYES; - REGCP_UNWIND; + TRYPAREN(paren, n, PL_reginput); + REGCP_UNWIND(lastcp); } /* Couldn't or didn't -- back up. */ n--; @@ -3102,7 +3245,7 @@ S_regmatch(pTHX_ regnode *prog) CHECKPOINT cp, lastcp; cp = regcppush(0); /* Save *all* the positions. */ - REGCP_SET; + REGCP_SET(lastcp); regcp_set_to(PL_reg_call_cc->ss); /* Restore parens of the caller. */ PL_reginput = locinput; /* Make position available to @@ -3115,7 +3258,7 @@ S_regmatch(pTHX_ regnode *prog) regcpblow(cp); sayYES; } - REGCP_UNWIND; + REGCP_UNWIND(lastcp); regcppop(); PL_reg_call_cc = cur_call_cc; PL_regcc = cctmp; @@ -3222,6 +3365,7 @@ S_regmatch(pTHX_ regnode *prog) PTR2UV(scan), OP(scan)); Perl_croak(aTHX_ "regexp memory corruption"); } + reenter: scan = next; } @@ -3247,6 +3391,11 @@ yes: #ifdef DEBUGGING PL_regindent--; #endif + +#if 0 /* Breaks $^R */ + if (unwind) + regcpblow(firstcp); +#endif return 1; no: @@ -3258,6 +3407,55 @@ no: goto do_no; no_final: do_no: + if (unwind) { + re_unwind_t *uw = SSPTRt(unwind,re_unwind_t); + + switch (uw->type) { + case RE_UNWIND_BRANCH: + case RE_UNWIND_BRANCHJ: + { + re_unwind_branch_t *uwb = &(uw->branch); + I32 lastparen = uwb->lastparen; + + REGCP_UNWIND(uwb->lastcp); + for (n = *PL_reglastparen; n > lastparen; n--) + PL_regendp[n] = -1; + *PL_reglastparen = n; + scan = next = uwb->next; + if ( !scan || + OP(scan) != (uwb->type == RE_UNWIND_BRANCH + ? BRANCH : BRANCHJ) ) { /* Failure */ + unwind = uwb->prev; +#ifdef DEBUGGING + PL_regindent--; +#endif + goto do_no; + } + /* Have more choice yet. Reuse the same uwb. */ + /*SUPPRESS 560*/ + if ((n = (uwb->type == RE_UNWIND_BRANCH + ? NEXT_OFF(next) : ARG(next)))) + next += n; + else + next = NULL; /* XXXX Needn't unwinding in this case... */ + uwb->next = next; + next = NEXTOPER(scan); + if (uwb->type == RE_UNWIND_BRANCHJ) + next = NEXTOPER(next); + locinput = uwb->locinput; + nextchr = uwb->nextchr; +#ifdef DEBUGGING + PL_regindent = uwb->regindent; +#endif + + goto reenter; + } + /* NOT REACHED */ + default: + Perl_croak(aTHX_ "regexp unwind memory corruption"); + } + /* NOT REACHED */ + } #ifdef DEBUGGING PL_regindent--; #endif @@ -3275,7 +3473,6 @@ do_no: STATIC I32 S_regrepeat(pTHX_ regnode *p, I32 max) { - dTHR; register char *scan; register I32 c; register char *loceol = PL_regeol; @@ -3487,7 +3684,6 @@ S_regrepeat(pTHX_ regnode *p, I32 max) STATIC I32 S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp) { - dTHR; register char *scan; register char *start; register char *loceol = PL_regeol; @@ -3538,7 +3734,6 @@ S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp) STATIC bool S_reginclass(pTHX_ register regnode *p, register I32 c) { - dTHR; char flags = ANYOF_FLAGS(p); bool match = FALSE; @@ -3585,7 +3780,11 @@ S_reginclass(pTHX_ register regnode *p, register I32 c) (ANYOF_CLASS_TEST(p, ANYOF_UPPER) && isUPPER_LC(c)) || (ANYOF_CLASS_TEST(p, ANYOF_NUPPER) && !isUPPER_LC(c)) || (ANYOF_CLASS_TEST(p, ANYOF_XDIGIT) && isXDIGIT(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_NXDIGIT) && !isXDIGIT(c)) + (ANYOF_CLASS_TEST(p, ANYOF_NXDIGIT) && !isXDIGIT(c)) || + (ANYOF_CLASS_TEST(p, ANYOF_PSXSPC) && isPSXSPC(c)) || + (ANYOF_CLASS_TEST(p, ANYOF_NPSXSPC) && !isPSXSPC(c)) || + (ANYOF_CLASS_TEST(p, ANYOF_BLANK) && isBLANK(c)) || + (ANYOF_CLASS_TEST(p, ANYOF_NBLANK) && !isBLANK(c)) ) /* How's that for a conditional? */ { match = TRUE; @@ -3598,22 +3797,28 @@ S_reginclass(pTHX_ register regnode *p, register I32 c) STATIC bool S_reginclassutf8(pTHX_ regnode *f, U8 *p) { - dTHR; char flags = ARG1(f); bool match = FALSE; - SV *sv = (SV*)PL_regdata->data[ARG2(f)]; +#ifdef DEBUGGING + SV *rv = (SV*)PL_regdata->data[ARG2(f)]; + AV *av = (AV*)SvRV((SV*)rv); + SV *sw = *av_fetch(av, 0, FALSE); + SV *lv = *av_fetch(av, 1, FALSE); +#else + SV *sw = (SV*)PL_regdata->data[ARG2(f)]; +#endif - if (swash_fetch(sv, p)) + if (swash_fetch(sw, p)) match = TRUE; else if (flags & ANYOF_FOLD) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; if (flags & ANYOF_LOCALE) { PL_reg_flags |= RF_tainted; uv_to_utf8(tmpbuf, toLOWER_LC_utf8(p)); } else uv_to_utf8(tmpbuf, toLOWER_utf8(p)); - if (swash_fetch(sv, tmpbuf)) + if (swash_fetch(sw, tmpbuf)) match = TRUE; } @@ -3625,7 +3830,6 @@ S_reginclassutf8(pTHX_ regnode *f, U8 *p) STATIC U8 * S_reghop(pTHX_ U8 *s, I32 off) { - dTHR; if (off >= 0) { while (off-- && s < (U8*)PL_regeol) s += UTF8SKIP(s); @@ -3647,7 +3851,6 @@ S_reghop(pTHX_ U8 *s, I32 off) STATIC U8 * S_reghopmaybe(pTHX_ U8* s, I32 off) { - dTHR; if (off >= 0) { while (off-- && s < (U8*)PL_regeol) s += UTF8SKIP(s); @@ -3679,7 +3882,6 @@ S_reghopmaybe(pTHX_ U8* s, I32 off) static void restore_pos(pTHXo_ void *arg) { - dTHR; if (PL_reg_eval_set) { if (PL_reg_oldsaved) { PL_reg_re->subbeg = PL_reg_oldsaved; @@ -3691,4 +3893,3 @@ restore_pos(pTHXo_ void *arg) PL_curpm = PL_reg_oldcurpm; } } - diff --git a/contrib/perl5/regexp.h b/contrib/perl5/regexp.h index ca0e9ed5da33..3c71060a404d 100644 --- a/contrib/perl5/regexp.h +++ b/contrib/perl5/regexp.h @@ -19,6 +19,8 @@ typedef struct regnode regnode; struct reg_substr_data; +struct reg_data; + typedef struct regexp { I32 *startp; I32 *endp; diff --git a/contrib/perl5/regnodes.h b/contrib/perl5/regnodes.h index c5725cd70715..89c78e6bace2 100644 --- a/contrib/perl5/regnodes.h +++ b/contrib/perl5/regnodes.h @@ -173,7 +173,7 @@ EXTCONST U8 PL_regkind[] = { #ifdef REG_COMP_C -const static U8 regarglen[] = { +static const U8 regarglen[] = { 0, /* END */ 0, /* SUCCEED */ 0, /* BOL */ @@ -256,7 +256,7 @@ const static U8 regarglen[] = { 0, /* OPTIMIZED */ }; -const static char reg_off_by_arg[] = { +static const char reg_off_by_arg[] = { 0, /* END */ 0, /* SUCCEED */ 0, /* BOL */ @@ -340,7 +340,7 @@ const static char reg_off_by_arg[] = { }; #ifdef DEBUGGING -const static char * const reg_name[] = { +static const char * const reg_name[] = { "END", /* 0 */ "SUCCEED", /* 0x1 */ "BOL", /* 0x2 */ @@ -423,7 +423,7 @@ const static char * const reg_name[] = { "OPTIMIZED", /* 0x4f */ }; -const static int reg_num = 80; +static const int reg_num = 80; #endif /* DEBUGGING */ #endif /* REG_COMP_C */ diff --git a/contrib/perl5/run.c b/contrib/perl5/run.c index 728b761ff033..1b1e72b1a6c0 100644 --- a/contrib/perl5/run.c +++ b/contrib/perl5/run.c @@ -1,6 +1,6 @@ /* run.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. @@ -20,8 +20,6 @@ int Perl_runops_standard(pTHX) { - dTHR; - while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX))) { PERL_ASYNC_CHECK(); } @@ -34,7 +32,6 @@ int Perl_runops_debug(pTHX) { #ifdef DEBUGGING - dTHR; if (!PL_op) { if (ckWARN_d(WARN_DEBUGGING)) Perl_warner(aTHX_ WARN_DEBUGGING, "NULL OP IN RUN"); @@ -67,6 +64,7 @@ Perl_debop(pTHX_ OP *o) { #ifdef DEBUGGING SV *sv; + SV **svp; STRLEN n_a; Perl_deb(aTHX_ "%s", PL_op_name[o->op_type]); switch (o->op_type) { @@ -84,6 +82,16 @@ Perl_debop(pTHX_ OP *o) else PerlIO_printf(Perl_debug_log, "(NULL)"); break; + case OP_PADSV: + case OP_PADAV: + case OP_PADHV: + /* print the lexical's name */ + svp = av_fetch(PL_comppad_name, o->op_targ, FALSE); + if (svp) + PerlIO_printf(Perl_debug_log, "(%s)", SvPV(*svp,n_a)); + else + PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ); + break; default: break; } @@ -96,7 +104,6 @@ void Perl_watch(pTHX_ char **addr) { #ifdef DEBUGGING - dTHR; PL_watchaddr = addr; PL_watchok = *addr; PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n", diff --git a/contrib/perl5/scope.c b/contrib/perl5/scope.c index 3b9f0d108aa7..bb4143b079c8 100644 --- a/contrib/perl5/scope.c +++ b/contrib/perl5/scope.c @@ -1,6 +1,6 @@ /* scope.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. @@ -33,7 +33,6 @@ void * Perl_vdefault_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt, protect_body_t body, va_list *args) { - dTHR; int ex; void *ret; @@ -51,7 +50,6 @@ Perl_vdefault_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt, SV** Perl_stack_grow(pTHX_ SV **sp, SV **p, int n) { - dTHR; #if defined(DEBUGGING) && !defined(USE_THREADS) static int growing = 0; if (growing++) @@ -97,7 +95,6 @@ Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems) I32 Perl_cxinc(pTHX) { - dTHR; cxstack_max = GROW(cxstack_max); Renew(cxstack, cxstack_max + 1, PERL_CONTEXT); /* XXX should fix CXINC macro */ return cxstack_ix + 1; @@ -106,7 +103,6 @@ Perl_cxinc(pTHX) void Perl_push_return(pTHX_ OP *retop) { - dTHR; if (PL_retstack_ix == PL_retstack_max) { PL_retstack_max = GROW(PL_retstack_max); Renew(PL_retstack, PL_retstack_max, OP*); @@ -117,7 +113,6 @@ Perl_push_return(pTHX_ OP *retop) OP * Perl_pop_return(pTHX) { - dTHR; if (PL_retstack_ix > 0) return PL_retstack[--PL_retstack_ix]; else @@ -127,7 +122,6 @@ Perl_pop_return(pTHX) void Perl_push_scope(pTHX) { - dTHR; if (PL_scopestack_ix == PL_scopestack_max) { PL_scopestack_max = GROW(PL_scopestack_max); Renew(PL_scopestack, PL_scopestack_max, I32); @@ -139,7 +133,6 @@ Perl_push_scope(pTHX) void Perl_pop_scope(pTHX) { - dTHR; I32 oldsave = PL_scopestack[--PL_scopestack_ix]; LEAVE_SCOPE(oldsave); } @@ -147,7 +140,6 @@ Perl_pop_scope(pTHX) void Perl_markstack_grow(pTHX) { - dTHR; I32 oldmax = PL_markstack_max - PL_markstack; I32 newmax = GROW(oldmax); @@ -159,7 +151,6 @@ Perl_markstack_grow(pTHX) void Perl_savestack_grow(pTHX) { - dTHR; PL_savestack_max = GROW(PL_savestack_max) + 4; Renew(PL_savestack, PL_savestack_max, ANY); } @@ -169,7 +160,6 @@ Perl_savestack_grow(pTHX) void Perl_tmps_grow(pTHX_ I32 n) { - dTHR; #ifndef STRESS_REALLOC if (n < 128) n = (PL_tmps_max < 512) ? 128 : 512; @@ -182,7 +172,6 @@ Perl_tmps_grow(pTHX_ I32 n) void Perl_free_tmps(pTHX) { - dTHR; /* XXX should tmps_floor live in cxstack? */ I32 myfloor = PL_tmps_floor; while (PL_tmps_ix > myfloor) { /* clean up after last statement */ @@ -198,7 +187,6 @@ Perl_free_tmps(pTHX) STATIC SV * S_save_scalar_at(pTHX_ SV **sptr) { - dTHR; register SV *sv; SV *osv = *sptr; @@ -208,7 +196,7 @@ S_save_scalar_at(pTHX_ SV **sptr) if (SvGMAGICAL(osv)) { MAGIC* mg; bool oldtainted = PL_tainted; - mg_get(osv); + mg_get(osv); /* note, can croak! */ if (PL_tainting && PL_tainted && (mg = mg_find(osv, 't'))) { SAVESPTR(mg->mg_obj); mg->mg_obj = osv; @@ -219,6 +207,9 @@ S_save_scalar_at(pTHX_ SV **sptr) } SvMAGIC(sv) = SvMAGIC(osv); SvFLAGS(sv) |= SvMAGICAL(osv); + /* XXX SvMAGIC() is *shared* between osv and sv. This can + * lead to coredumps when both SVs are destroyed without one + * of their SvMAGIC() slots being NULLed. */ PL_localizing = 1; SvSETMAGIC(sv); PL_localizing = 0; @@ -229,7 +220,6 @@ S_save_scalar_at(pTHX_ SV **sptr) SV * Perl_save_scalar(pTHX_ GV *gv) { - dTHR; SV **sptr = &GvSV(gv); SSCHECK(3); SSPUSHPTR(SvREFCNT_inc(gv)); @@ -241,7 +231,6 @@ Perl_save_scalar(pTHX_ GV *gv) SV* Perl_save_svref(pTHX_ SV **sptr) { - dTHR; SSCHECK(3); SSPUSHPTR(sptr); SSPUSHPTR(SvREFCNT_inc(*sptr)); @@ -249,22 +238,32 @@ Perl_save_svref(pTHX_ SV **sptr) return save_scalar_at(sptr); } -/* Like save_svref(), but doesn't deal with magic. Can be used to +/* Like save_sptr(), but also SvREFCNT_dec()s the new value. Can be used to * restore a global SV to its prior contents, freeing new value. */ void Perl_save_generic_svref(pTHX_ SV **sptr) { - dTHR; SSCHECK(3); SSPUSHPTR(sptr); SSPUSHPTR(SvREFCNT_inc(*sptr)); SSPUSHINT(SAVEt_GENERIC_SVREF); } +/* Like save_pptr(), but also Safefree()s the new value if it is different + * from the old one. Can be used to restore a global char* to its prior + * contents, freeing new value. */ +void +Perl_save_generic_pvref(pTHX_ char **str) +{ + SSCHECK(3); + SSPUSHPTR(str); + SSPUSHPTR(*str); + SSPUSHINT(SAVEt_GENERIC_PVREF); +} + void Perl_save_gp(pTHX_ GV *gv, I32 empty) { - dTHR; SSCHECK(6); SSPUSHIV((IV)SvLEN(gv)); SvLEN(gv) = 0; /* forget that anything was allocated here */ @@ -289,6 +288,7 @@ Perl_save_gp(pTHX_ GV *gv, I32 empty) GvGP(gv) = gp_ref(gp); GvSV(gv) = NEWSV(72,0); GvLINE(gv) = CopLINE(PL_curcop); + GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : ""; GvEGV(gv) = gv; } else { @@ -300,7 +300,6 @@ Perl_save_gp(pTHX_ GV *gv, I32 empty) AV * Perl_save_ary(pTHX_ GV *gv) { - dTHR; AV *oav = GvAVn(gv); AV *av; @@ -328,7 +327,6 @@ Perl_save_ary(pTHX_ GV *gv) HV * Perl_save_hash(pTHX_ GV *gv) { - dTHR; HV *ohv, *hv; SSCHECK(3); @@ -353,7 +351,6 @@ Perl_save_hash(pTHX_ GV *gv) void Perl_save_item(pTHX_ register SV *item) { - dTHR; register SV *sv = NEWSV(0,0); sv_setsv(sv,item); @@ -366,7 +363,6 @@ Perl_save_item(pTHX_ register SV *item) void Perl_save_int(pTHX_ int *intp) { - dTHR; SSCHECK(3); SSPUSHINT(*intp); SSPUSHPTR(intp); @@ -376,7 +372,6 @@ Perl_save_int(pTHX_ int *intp) void Perl_save_long(pTHX_ long int *longp) { - dTHR; SSCHECK(3); SSPUSHLONG(*longp); SSPUSHPTR(longp); @@ -386,7 +381,6 @@ Perl_save_long(pTHX_ long int *longp) void Perl_save_I32(pTHX_ I32 *intp) { - dTHR; SSCHECK(3); SSPUSHINT(*intp); SSPUSHPTR(intp); @@ -396,7 +390,6 @@ Perl_save_I32(pTHX_ I32 *intp) void Perl_save_I16(pTHX_ I16 *intp) { - dTHR; SSCHECK(3); SSPUSHINT(*intp); SSPUSHPTR(intp); @@ -406,7 +399,6 @@ Perl_save_I16(pTHX_ I16 *intp) void Perl_save_I8(pTHX_ I8 *bytep) { - dTHR; SSCHECK(3); SSPUSHINT(*bytep); SSPUSHPTR(bytep); @@ -416,7 +408,6 @@ Perl_save_I8(pTHX_ I8 *bytep) void Perl_save_iv(pTHX_ IV *ivp) { - dTHR; SSCHECK(3); SSPUSHIV(*ivp); SSPUSHPTR(ivp); @@ -429,7 +420,6 @@ Perl_save_iv(pTHX_ IV *ivp) void Perl_save_pptr(pTHX_ char **pptr) { - dTHR; SSCHECK(3); SSPUSHPTR(*pptr); SSPUSHPTR(pptr); @@ -439,7 +429,6 @@ Perl_save_pptr(pTHX_ char **pptr) void Perl_save_vptr(pTHX_ void *ptr) { - dTHR; SSCHECK(3); SSPUSHPTR(*(char**)ptr); SSPUSHPTR(ptr); @@ -449,18 +438,26 @@ Perl_save_vptr(pTHX_ void *ptr) void Perl_save_sptr(pTHX_ SV **sptr) { - dTHR; SSCHECK(3); SSPUSHPTR(*sptr); SSPUSHPTR(sptr); SSPUSHINT(SAVEt_SPTR); } +void +Perl_save_padsv(pTHX_ PADOFFSET off) +{ + SSCHECK(4); + SSPUSHPTR(PL_curpad[off]); + SSPUSHPTR(PL_curpad); + SSPUSHLONG((long)off); + SSPUSHINT(SAVEt_PADSV); +} + SV ** Perl_save_threadsv(pTHX_ PADOFFSET i) { #ifdef USE_THREADS - dTHR; SV **svp = &THREADSV(i); /* XXX Change to save by offset */ DEBUG_S(PerlIO_printf(Perl_debug_log, "save_threadsv %"UVuf": %p %p:%s\n", (UV)i, svp, *svp, SvPEEK(*svp))); @@ -475,7 +472,6 @@ Perl_save_threadsv(pTHX_ PADOFFSET i) void Perl_save_nogv(pTHX_ GV *gv) { - dTHR; SSCHECK(2); SSPUSHPTR(gv); SSPUSHINT(SAVEt_NSTAB); @@ -484,7 +480,6 @@ Perl_save_nogv(pTHX_ GV *gv) void Perl_save_hptr(pTHX_ HV **hptr) { - dTHR; SSCHECK(3); SSPUSHPTR(*hptr); SSPUSHPTR(hptr); @@ -494,7 +489,6 @@ Perl_save_hptr(pTHX_ HV **hptr) void Perl_save_aptr(pTHX_ AV **aptr) { - dTHR; SSCHECK(3); SSPUSHPTR(*aptr); SSPUSHPTR(aptr); @@ -504,16 +498,22 @@ Perl_save_aptr(pTHX_ AV **aptr) void Perl_save_freesv(pTHX_ SV *sv) { - dTHR; SSCHECK(2); SSPUSHPTR(sv); SSPUSHINT(SAVEt_FREESV); } void +Perl_save_mortalizesv(pTHX_ SV *sv) +{ + SSCHECK(2); + SSPUSHPTR(sv); + SSPUSHINT(SAVEt_MORTALIZESV); +} + +void Perl_save_freeop(pTHX_ OP *o) { - dTHR; SSCHECK(2); SSPUSHPTR(o); SSPUSHINT(SAVEt_FREEOP); @@ -522,7 +522,6 @@ Perl_save_freeop(pTHX_ OP *o) void Perl_save_freepv(pTHX_ char *pv) { - dTHR; SSCHECK(2); SSPUSHPTR(pv); SSPUSHINT(SAVEt_FREEPV); @@ -531,7 +530,6 @@ Perl_save_freepv(pTHX_ char *pv) void Perl_save_clearsv(pTHX_ SV **svp) { - dTHR; SSCHECK(2); SSPUSHLONG((long)(svp-PL_curpad)); SSPUSHINT(SAVEt_CLEARSV); @@ -540,7 +538,6 @@ Perl_save_clearsv(pTHX_ SV **svp) void Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen) { - dTHR; SSCHECK(4); SSPUSHINT(klen); SSPUSHPTR(key); @@ -551,7 +548,6 @@ Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen) void Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg) { - dTHR; register SV *sv; register I32 i; @@ -568,7 +564,6 @@ Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg) void Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p) { - dTHR; SSCHECK(3); SSPUSHDPTR(f); SSPUSHPTR(p); @@ -578,7 +573,6 @@ Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p) void Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p) { - dTHR; SSCHECK(3); SSPUSHDXPTR(f); SSPUSHPTR(p); @@ -588,7 +582,6 @@ Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p) void Perl_save_aelem(pTHX_ AV *av, I32 idx, SV **sptr) { - dTHR; SSCHECK(4); SSPUSHPTR(SvREFCNT_inc(av)); SSPUSHINT(idx); @@ -600,7 +593,6 @@ Perl_save_aelem(pTHX_ AV *av, I32 idx, SV **sptr) void Perl_save_helem(pTHX_ HV *hv, SV *key, SV **sptr) { - dTHR; SSCHECK(4); SSPUSHPTR(SvREFCNT_inc(hv)); SSPUSHPTR(SvREFCNT_inc(key)); @@ -612,7 +604,6 @@ Perl_save_helem(pTHX_ HV *hv, SV *key, SV **sptr) void Perl_save_op(pTHX) { - dTHR; SSCHECK(2); SSPUSHPTR(PL_op); SSPUSHINT(SAVEt_OP); @@ -621,7 +612,6 @@ Perl_save_op(pTHX) I32 Perl_save_alloc(pTHX_ I32 size, I32 pad) { - dTHR; register I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix] - (char*)PL_savestack); register I32 elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack)); @@ -639,13 +629,13 @@ Perl_save_alloc(pTHX_ I32 size, I32 pad) void Perl_leave_scope(pTHX_ I32 base) { - dTHR; register SV *sv; register SV *value; register GV *gv; register AV *av; register HV *hv; register void* ptr; + register char* str; I32 i; if (base < -1) @@ -666,14 +656,20 @@ Perl_leave_scope(pTHX_ I32 base) ptr = &GvSV(gv); SvREFCNT_dec(gv); goto restore_sv; + case SAVEt_GENERIC_PVREF: /* generic pv */ + str = (char*)SSPOPPTR; + ptr = SSPOPPTR; + if (*(char**)ptr != str) { + Safefree(*(char**)ptr); + *(char**)ptr = str; + } + break; case SAVEt_GENERIC_SVREF: /* generic sv */ value = (SV*)SSPOPPTR; ptr = SSPOPPTR; - if (ptr) { - sv = *(SV**)ptr; - *(SV**)ptr = value; - SvREFCNT_dec(sv); - } + sv = *(SV**)ptr; + *(SV**)ptr = value; + SvREFCNT_dec(sv); SvREFCNT_dec(value); break; case SAVEt_SVREF: /* scalar reference */ @@ -693,12 +689,19 @@ Perl_leave_scope(pTHX_ I32 base) SvMAGICAL_off(sv); SvMAGIC(sv) = 0; } + /* XXX This branch is pretty bogus. This code irretrievably + * clears(!) the magic on the SV (either to avoid further + * croaking that might ensue when the SvSETMAGIC() below is + * called, or to avoid two different SVs pointing at the same + * SvMAGIC()). This needs a total rethink. --GSAR */ else if (SvTYPE(value) >= SVt_PVMG && SvMAGIC(value) && SvTYPE(value) != SVt_PVGV) { SvFLAGS(value) |= (SvFLAGS(value) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; SvMAGICAL_off(value); + /* XXX this is a leak when we get here because the + * mg_get() in save_scalar_at() croaked */ SvMAGIC(value) = 0; } SvREFCNT_dec(sv); @@ -808,6 +811,10 @@ Perl_leave_scope(pTHX_ I32 base) ptr = SSPOPPTR; SvREFCNT_dec((SV*)ptr); break; + case SAVEt_MORTALIZESV: + ptr = SSPOPPTR; + sv_2mortal((SV*)ptr); + break; case SAVEt_FREEOP: ptr = SSPOPPTR; if (PL_comppad) @@ -927,10 +934,6 @@ Perl_leave_scope(pTHX_ I32 base) PL_op = (OP*)SSPOPPTR; break; case SAVEt_HINTS: - if (GvHV(PL_hintgv)) { - SvREFCNT_dec((SV*)GvHV(PL_hintgv)); - GvHV(PL_hintgv) = NULL; - } *(I32*)&PL_hints = (I32)SSPOPINT; break; case SAVEt_COMPPAD: @@ -940,6 +943,14 @@ Perl_leave_scope(pTHX_ I32 base) else PL_curpad = Null(SV**); break; + case SAVEt_PADSV: + { + PADOFFSET off = (PADOFFSET)SSPOPLONG; + ptr = SSPOPPTR; + if (ptr) + ((SV**)ptr)[off] = (SV*)SSPOPPTR; + } + break; default: Perl_croak(aTHX_ "panic: leave_scope inconsistency"); } @@ -950,7 +961,6 @@ void Perl_cx_dump(pTHX_ PERL_CONTEXT *cx) { #ifdef DEBUGGING - dTHR; PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]); if (CxTYPE(cx) != CXt_SUBST) { PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp); diff --git a/contrib/perl5/scope.h b/contrib/perl5/scope.h index f33154abeda4..798304d0e15f 100644 --- a/contrib/perl5/scope.h +++ b/contrib/perl5/scope.h @@ -32,6 +32,9 @@ #define SAVEt_VPTR 31 #define SAVEt_I8 32 #define SAVEt_COMPPAD 33 +#define SAVEt_GENERIC_PVREF 34 +#define SAVEt_PADSV 35 +#define SAVEt_MORTALIZESV 36 #define SSCHECK(need) if (PL_savestack_ix + need > PL_savestack_max) savestack_grow() #define SSPUSHINT(i) (PL_savestack[PL_savestack_ix++].any_i32 = (I32)(i)) @@ -100,11 +103,14 @@ Closing bracket on a callback. See C<ENTER> and L<perlcall>. #define SAVESPTR(s) save_sptr((SV**)&(s)) #define SAVEPPTR(s) save_pptr(SOFT_CAST(char**)&(s)) #define SAVEVPTR(s) save_vptr((void*)&(s)) +#define SAVEPADSV(s) save_padsv(s) #define SAVEFREESV(s) save_freesv((SV*)(s)) +#define SAVEMORTALIZESV(s) save_mortalizesv((SV*)(s)) #define SAVEFREEOP(o) save_freeop(SOFT_CAST(OP*)(o)) #define SAVEFREEPV(p) save_freepv(SOFT_CAST(char*)(p)) #define SAVECLEARSV(sv) save_clearsv(SOFT_CAST(SV**)&(sv)) #define SAVEGENERICSV(s) save_generic_svref((SV**)&(s)) +#define SAVEGENERICPV(s) save_generic_pvref((char**)&(s)) #define SAVEDELETE(h,k,l) \ save_delete(SOFT_CAST(HV*)(h), SOFT_CAST(char*)(k), (I32)(l)) #define SAVEDESTRUCTOR(f,p) \ @@ -147,14 +153,18 @@ Closing bracket on a callback. See C<ENTER> and L<perlcall>. } STMT_END #ifdef USE_ITHREADS -# define SAVECOPSTASH(cop) SAVEPPTR(CopSTASHPV(cop)) -# define SAVECOPFILE(cop) SAVEPPTR(CopFILE(cop)) +# define SAVECOPSTASH(c) SAVEPPTR(CopSTASHPV(c)) +# define SAVECOPSTASH_FREE(c) SAVEGENERICPV(CopSTASHPV(c)) +# define SAVECOPFILE(c) SAVEPPTR(CopFILE(c)) +# define SAVECOPFILE_FREE(c) SAVEGENERICPV(CopFILE(c)) #else -# define SAVECOPSTASH(cop) SAVESPTR(CopSTASH(cop)) -# define SAVECOPFILE(cop) SAVESPTR(CopFILEGV(cop)) +# define SAVECOPSTASH(c) SAVESPTR(CopSTASH(c)) +# define SAVECOPSTASH_FREE(c) SAVECOPSTASH(c) /* XXX not refcounted */ +# define SAVECOPFILE(c) SAVESPTR(CopFILEGV(c)) +# define SAVECOPFILE_FREE(c) SAVEGENERICSV(CopFILEGV(c)) #endif -#define SAVECOPLINE(cop) SAVEI16(CopLINE(cop)) +#define SAVECOPLINE(c) SAVEI16(CopLINE(c)) /* SSNEW() temporarily allocates a specified number of bytes of data on the * savestack. It returns an integer index into the savestack, because a @@ -167,11 +177,14 @@ Closing bracket on a callback. See C<ENTER> and L<perlcall>. * SSPTR() converts the index returned by SSNEW/SSNEWa() into a pointer. */ -#define SSNEW(size) save_alloc(size, 0) -#define SSNEWa(size,align) save_alloc(size, \ +#define SSNEW(size) Perl_save_alloc(aTHX_ (size), 0) +#define SSNEWt(n,t) SSNEW((n)*sizeof(t)) +#define SSNEWa(size,align) Perl_save_alloc(aTHX_ (size), \ (align - ((int)((caddr_t)&PL_savestack[PL_savestack_ix]) % align)) % align) +#define SSNEWat(n,t,align) SSNEWa((n)*sizeof(t), align) -#define SSPTR(off,type) ((type) ((char*)PL_savestack + off)) +#define SSPTR(off,type) ((type) ((char*)PL_savestack + off)) +#define SSPTRt(off,type) ((type*) ((char*)PL_savestack + off)) /* A jmpenv packages the state required to perform a proper non-local jump. * Note that there is a start_env initialized when perl starts, and top_env @@ -280,7 +293,7 @@ typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env, OP_REG_TO_MEM; \ } STMT_END -#define JMPENV_PUSH_INIT(THROWFUNC) JMPENV_PUSH_INIT_ENV(*(JMPENV*)pcur_env,THROWFUNC) +#define JMPENV_PUSH_INIT(THROWFUNC) JMPENV_PUSH_INIT_ENV(*(JMPENV*)pcur_env,THROWFUNC) #define JMPENV_POST_CATCH_ENV(ce) \ STMT_START { \ @@ -305,7 +318,7 @@ typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env, (v) = EXCEPT_GET_ENV(ce); \ } STMT_END -#define JMPENV_PUSH(v) JMPENV_PUSH_ENV(*(JMPENV*)pcur_env,v) +#define JMPENV_PUSH(v) JMPENV_PUSH_ENV(*(JMPENV*)pcur_env,v) #define JMPENV_POP_ENV(ce) \ STMT_START { \ @@ -313,7 +326,7 @@ typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env, PL_top_env = (ce).je_prev; \ } STMT_END -#define JMPENV_POP JMPENV_POP_ENV(*(JMPENV*)pcur_env) +#define JMPENV_POP JMPENV_POP_ENV(*(JMPENV*)pcur_env) #define JMPENV_JUMP(v) \ STMT_START { \ diff --git a/contrib/perl5/sv.c b/contrib/perl5/sv.c index 3eebc9ad4513..7b8263b60118 100644 --- a/contrib/perl5/sv.c +++ b/contrib/perl5/sv.c @@ -1,6 +1,6 @@ /* sv.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. @@ -147,20 +147,24 @@ S_more_sv(pTHX) return sv; } -STATIC void +STATIC I32 S_visit(pTHX_ SVFUNC_t f) { SV* sva; SV* sv; register SV* svend; + I32 visited = 0; for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { svend = &sva[SvREFCNT(sva)]; for (sv = sva + 1; sv < svend; ++sv) { - if (SvTYPE(sv) != SVTYPEMASK) + if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) { (FCALL)(aTHXo_ sv); + ++visited; + } } } + return visited; } void @@ -181,12 +185,14 @@ Perl_sv_clean_objs(pTHX) PL_in_clean_objs = FALSE; } -void +I32 Perl_sv_clean_all(pTHX) { + I32 cleaned; PL_in_clean_all = TRUE; - visit(do_clean_all); + cleaned = visit(do_clean_all); PL_in_clean_all = FALSE; + return cleaned; } void @@ -194,6 +200,7 @@ Perl_sv_free_arenas(pTHX) { SV* sva; SV* svanext; + XPV *arena, *arenanext; /* Free arenas here, but be careful about fake ones. (We assume contiguity of the fake ones with the corresponding real ones.) */ @@ -207,6 +214,84 @@ Perl_sv_free_arenas(pTHX) Safefree((void *)sva); } + for (arena = PL_xiv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xiv_arenaroot = 0; + + for (arena = PL_xnv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xnv_arenaroot = 0; + + for (arena = PL_xrv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xrv_arenaroot = 0; + + for (arena = PL_xpv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpv_arenaroot = 0; + + for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpviv_arenaroot = 0; + + for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvnv_arenaroot = 0; + + for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvcv_arenaroot = 0; + + for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvav_arenaroot = 0; + + for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvhv_arenaroot = 0; + + for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvmg_arenaroot = 0; + + for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvlv_arenaroot = 0; + + for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvbm_arenaroot = 0; + + for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_he_arenaroot = 0; + if (PL_nice_chunk) Safefree(PL_nice_chunk); PL_nice_chunk = Nullch; @@ -300,7 +385,12 @@ S_more_xnv(pTHX) { register NV* xnv; register NV* xnvend; - New(711, xnv, 1008/sizeof(NV), NV); + XPV *ptr; + New(711, ptr, 1008/sizeof(XPV), XPV); + ptr->xpv_pv = (char*)PL_xnv_arenaroot; + PL_xnv_arenaroot = ptr; + + xnv = (NV*) ptr; xnvend = &xnv[1008 / sizeof(NV) - 1]; xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */ PL_xnv_root = xnv; @@ -338,9 +428,15 @@ S_more_xrv(pTHX) { register XRV* xrv; register XRV* xrvend; - New(712, PL_xrv_root, 1008/sizeof(XRV), XRV); - xrv = PL_xrv_root; + XPV *ptr; + New(712, ptr, 1008/sizeof(XPV), XPV); + ptr->xpv_pv = (char*)PL_xrv_arenaroot; + PL_xrv_arenaroot = ptr; + + xrv = (XRV*) ptr; xrvend = &xrv[1008 / sizeof(XRV) - 1]; + xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1; + PL_xrv_root = xrv; while (xrv < xrvend) { xrv->xrv_rv = (SV*)(xrv + 1); xrv++; @@ -375,9 +471,12 @@ S_more_xpv(pTHX) { register XPV* xpv; register XPV* xpvend; - New(713, PL_xpv_root, 1008/sizeof(XPV), XPV); - xpv = PL_xpv_root; + New(713, xpv, 1008/sizeof(XPV), XPV); + xpv->xpv_pv = (char*)PL_xpv_arenaroot; + PL_xpv_arenaroot = xpv; + xpvend = &xpv[1008 / sizeof(XPV) - 1]; + PL_xpv_root = ++xpv; while (xpv < xpvend) { xpv->xpv_pv = (char*)(xpv + 1); xpv++; @@ -407,15 +506,17 @@ S_del_xpviv(pTHX_ XPVIV *p) UNLOCK_SV_MUTEX; } - STATIC void S_more_xpviv(pTHX) { register XPVIV* xpviv; register XPVIV* xpvivend; - New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV); - xpviv = PL_xpviv_root; + New(714, xpviv, 1008/sizeof(XPVIV), XPVIV); + xpviv->xpv_pv = (char*)PL_xpviv_arenaroot; + PL_xpviv_arenaroot = xpviv; + xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1]; + PL_xpviv_root = ++xpviv; while (xpviv < xpvivend) { xpviv->xpv_pv = (char*)(xpviv + 1); xpviv++; @@ -423,7 +524,6 @@ S_more_xpviv(pTHX) xpviv->xpv_pv = 0; } - STATIC XPVNV* S_new_xpvnv(pTHX) { @@ -446,15 +546,17 @@ S_del_xpvnv(pTHX_ XPVNV *p) UNLOCK_SV_MUTEX; } - STATIC void S_more_xpvnv(pTHX) { register XPVNV* xpvnv; register XPVNV* xpvnvend; - New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV); - xpvnv = PL_xpvnv_root; + New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV); + xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot; + PL_xpvnv_arenaroot = xpvnv; + xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1]; + PL_xpvnv_root = ++xpvnv; while (xpvnv < xpvnvend) { xpvnv->xpv_pv = (char*)(xpvnv + 1); xpvnv++; @@ -462,8 +564,6 @@ S_more_xpvnv(pTHX) xpvnv->xpv_pv = 0; } - - STATIC XPVCV* S_new_xpvcv(pTHX) { @@ -486,15 +586,17 @@ S_del_xpvcv(pTHX_ XPVCV *p) UNLOCK_SV_MUTEX; } - STATIC void S_more_xpvcv(pTHX) { register XPVCV* xpvcv; register XPVCV* xpvcvend; - New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV); - xpvcv = PL_xpvcv_root; + New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV); + xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot; + PL_xpvcv_arenaroot = xpvcv; + xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1]; + PL_xpvcv_root = ++xpvcv; while (xpvcv < xpvcvend) { xpvcv->xpv_pv = (char*)(xpvcv + 1); xpvcv++; @@ -502,8 +604,6 @@ S_more_xpvcv(pTHX) xpvcv->xpv_pv = 0; } - - STATIC XPVAV* S_new_xpvav(pTHX) { @@ -526,15 +626,17 @@ S_del_xpvav(pTHX_ XPVAV *p) UNLOCK_SV_MUTEX; } - STATIC void S_more_xpvav(pTHX) { register XPVAV* xpvav; register XPVAV* xpvavend; - New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV); - xpvav = PL_xpvav_root; + New(717, xpvav, 1008/sizeof(XPVAV), XPVAV); + xpvav->xav_array = (char*)PL_xpvav_arenaroot; + PL_xpvav_arenaroot = xpvav; + xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1]; + PL_xpvav_root = ++xpvav; while (xpvav < xpvavend) { xpvav->xav_array = (char*)(xpvav + 1); xpvav++; @@ -542,8 +644,6 @@ S_more_xpvav(pTHX) xpvav->xav_array = 0; } - - STATIC XPVHV* S_new_xpvhv(pTHX) { @@ -566,15 +666,17 @@ S_del_xpvhv(pTHX_ XPVHV *p) UNLOCK_SV_MUTEX; } - STATIC void S_more_xpvhv(pTHX) { register XPVHV* xpvhv; register XPVHV* xpvhvend; - New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV); - xpvhv = PL_xpvhv_root; + New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV); + xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot; + PL_xpvhv_arenaroot = xpvhv; + xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1]; + PL_xpvhv_root = ++xpvhv; while (xpvhv < xpvhvend) { xpvhv->xhv_array = (char*)(xpvhv + 1); xpvhv++; @@ -582,7 +684,6 @@ S_more_xpvhv(pTHX) xpvhv->xhv_array = 0; } - STATIC XPVMG* S_new_xpvmg(pTHX) { @@ -605,15 +706,17 @@ S_del_xpvmg(pTHX_ XPVMG *p) UNLOCK_SV_MUTEX; } - STATIC void S_more_xpvmg(pTHX) { register XPVMG* xpvmg; register XPVMG* xpvmgend; - New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG); - xpvmg = PL_xpvmg_root; + New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG); + xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot; + PL_xpvmg_arenaroot = xpvmg; + xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1]; + PL_xpvmg_root = ++xpvmg; while (xpvmg < xpvmgend) { xpvmg->xpv_pv = (char*)(xpvmg + 1); xpvmg++; @@ -621,8 +724,6 @@ S_more_xpvmg(pTHX) xpvmg->xpv_pv = 0; } - - STATIC XPVLV* S_new_xpvlv(pTHX) { @@ -645,15 +746,17 @@ S_del_xpvlv(pTHX_ XPVLV *p) UNLOCK_SV_MUTEX; } - STATIC void S_more_xpvlv(pTHX) { register XPVLV* xpvlv; register XPVLV* xpvlvend; - New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV); - xpvlv = PL_xpvlv_root; + New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV); + xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot; + PL_xpvlv_arenaroot = xpvlv; + xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1]; + PL_xpvlv_root = ++xpvlv; while (xpvlv < xpvlvend) { xpvlv->xpv_pv = (char*)(xpvlv + 1); xpvlv++; @@ -661,7 +764,6 @@ S_more_xpvlv(pTHX) xpvlv->xpv_pv = 0; } - STATIC XPVBM* S_new_xpvbm(pTHX) { @@ -684,15 +786,17 @@ S_del_xpvbm(pTHX_ XPVBM *p) UNLOCK_SV_MUTEX; } - STATIC void S_more_xpvbm(pTHX) { register XPVBM* xpvbm; register XPVBM* xpvbmend; - New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM); - xpvbm = PL_xpvbm_root; + New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM); + xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot; + PL_xpvbm_arenaroot = xpvbm; + xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1]; + PL_xpvbm_root = ++xpvbm; while (xpvbm < xpvbmend) { xpvbm->xpv_pv = (char*)(xpvbm + 1); xpvbm++; @@ -1183,11 +1287,8 @@ Perl_sv_setiv(pTHX_ register SV *sv, IV i) case SVt_PVCV: case SVt_PVFM: case SVt_PVIO: - { - dTHR; - Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), - PL_op_desc[PL_op->op_type]); - } + Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), + PL_op_desc[PL_op->op_type]); } (void)SvIOK_only(sv); /* validate number */ SvIVX(sv) = i; @@ -1271,11 +1372,8 @@ Perl_sv_setnv(pTHX_ register SV *sv, NV num) case SVt_PVCV: case SVt_PVFM: case SVt_PVIO: - { - dTHR; - Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), - PL_op_name[PL_op->op_type]); - } + Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), + PL_op_name[PL_op->op_type]); } SvNVX(sv) = num; (void)SvNOK_only(sv); /* validate number */ @@ -1300,7 +1398,6 @@ Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num) STATIC void S_not_a_number(pTHX_ SV *sv) { - dTHR; char tmpbuf[64]; char *d = tmpbuf; char *s; @@ -1359,6 +1456,7 @@ S_not_a_number(pTHX_ SV *sv) #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */ #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */ #define IS_NUMBER_NEG 0x08 /* not good to cache UV */ +#define IS_NUMBER_INFINITY 0x10 /* this is big */ /* Actually, ISO C leaves conversion of UV to IV undefined, but until proven guilty, assume that things are not that bad... */ @@ -1379,7 +1477,6 @@ Perl_sv_2iv(pTHX_ register SV *sv) return asIV(sv); if (!SvROK(sv)) { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) report_uninit(); } @@ -1389,12 +1486,12 @@ Perl_sv_2iv(pTHX_ register SV *sv) if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && + (SvRV(tmpstr) != SvRV(sv))) return SvIV(tmpstr); return PTR2IV(SvRV(sv)); } if (SvREADONLY(sv) && !SvOK(sv)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED)) report_uninit(); return 0; @@ -1470,27 +1567,17 @@ Perl_sv_2iv(pTHX_ register SV *sv) goto ret_iv_max; } } - else if (numtype) { - /* The NV may be reconstructed from IV - safe to cache IV, - which may be calculated by atol(). */ - if (SvTYPE(sv) == SVt_PV) - sv_upgrade(sv, SVt_PVIV); - (void)SvIOK_on(sv); - SvIVX(sv) = Atol(SvPVX(sv)); - } - else { /* Not a number. Cache 0. */ - dTHR; - + else { /* The NV may be reconstructed from IV - safe to cache IV, + which may be calculated by atol(). */ if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); - SvIVX(sv) = 0; (void)SvIOK_on(sv); - if (ckWARN(WARN_NUMERIC)) + SvIVX(sv) = Atol(SvPVX(sv)); + if (! numtype && ckWARN(WARN_NUMERIC)) not_a_number(sv); } } else { - dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) report_uninit(); if (SvTYPE(sv) < SVt_IV) @@ -1518,7 +1605,6 @@ Perl_sv_2uv(pTHX_ register SV *sv) return asUV(sv); if (!SvROK(sv)) { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) report_uninit(); } @@ -1528,12 +1614,12 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && + (SvRV(tmpstr) != SvRV(sv))) return SvUV(tmpstr); return PTR2UV(SvRV(sv)); } if (SvREADONLY(sv) && !SvOK(sv)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED)) report_uninit(); return 0; @@ -1633,21 +1719,18 @@ Perl_sv_2uv(pTHX_ register SV *sv) #endif } else { /* Not a number. Cache 0. */ - dTHR; - if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); - SvUVX(sv) = 0; /* We assume that 0s have the - same bitmap in IV and UV. */ (void)SvIOK_on(sv); (void)SvIsUV_on(sv); + SvUVX(sv) = 0; /* We assume that 0s have the + same bitmap in IV and UV. */ if (ckWARN(WARN_NUMERIC)) not_a_number(sv); } } else { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) report_uninit(); } @@ -1672,7 +1755,6 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (SvNOKp(sv)) return SvNVX(sv); if (SvPOKp(sv) && SvLEN(sv)) { - dTHR; if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); return Atof(SvPVX(sv)); @@ -1685,7 +1767,6 @@ Perl_sv_2nv(pTHX_ register SV *sv) } if (!SvROK(sv)) { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) report_uninit(); } @@ -1695,12 +1776,12 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer))) + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && + (SvRV(tmpstr) != SvRV(sv))) return SvNV(tmpstr); return PTR2NV(SvRV(sv)); } if (SvREADONLY(sv) && !SvOK(sv)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED)) report_uninit(); return 0.0; @@ -1713,7 +1794,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) sv_upgrade(sv, SVt_NV); #if defined(USE_LONG_DOUBLE) DEBUG_c({ - RESTORE_NUMERIC_STANDARD(); + STORE_NUMERIC_LOCAL_SET_STANDARD(); PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%" PERL_PRIgldbl ")\n", PTR2UV(sv), SvNVX(sv)); @@ -1721,7 +1802,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) }); #else DEBUG_c({ - RESTORE_NUMERIC_STANDARD(); + STORE_NUMERIC_LOCAL_SET_STANDARD(); PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); @@ -1736,13 +1817,11 @@ Perl_sv_2nv(pTHX_ register SV *sv) SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv); } else if (SvPOKp(sv) && SvLEN(sv)) { - dTHR; if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SvNVX(sv) = Atof(SvPVX(sv)); } else { - dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) report_uninit(); if (SvTYPE(sv) < SVt_NV) @@ -1753,14 +1832,14 @@ Perl_sv_2nv(pTHX_ register SV *sv) SvNOK_on(sv); #if defined(USE_LONG_DOUBLE) DEBUG_c({ - RESTORE_NUMERIC_STANDARD(); + STORE_NUMERIC_LOCAL_SET_STANDARD(); PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); }); #else DEBUG_c({ - RESTORE_NUMERIC_STANDARD(); + STORE_NUMERIC_LOCAL_SET_STANDARD(); PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); @@ -1778,7 +1857,6 @@ S_asIV(pTHX_ SV *sv) if (numtype & IS_NUMBER_TO_INT_BY_ATOL) return Atol(SvPVX(sv)); if (!numtype) { - dTHR; if (ckWARN(WARN_NUMERIC)) not_a_number(sv); } @@ -1796,7 +1874,6 @@ S_asUV(pTHX_ SV *sv) return Strtoul(SvPVX(sv), Null(char**), 10); #endif if (!numtype) { - dTHR; if (ckWARN(WARN_NUMERIC)) not_a_number(sv); } @@ -1813,6 +1890,7 @@ S_asUV(pTHX_ SV *sv) * IS_NUMBER_TO_INT_BY_ATOL 123 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0 + * IS_NUMBER_INFINITY * with a possible addition of IS_NUMBER_NEG. */ @@ -1833,7 +1911,11 @@ Perl_looks_like_number(pTHX_ SV *sv) register char *sbegin; register char *nbegin; I32 numtype = 0; + I32 sawinf = 0; STRLEN len; +#ifdef USE_LOCALE_NUMERIC + bool specialradix = FALSE; +#endif if (SvPOK(sv)) { sbegin = SvPVX(sv); @@ -1862,7 +1944,7 @@ Perl_looks_like_number(pTHX_ SV *sv) * (int)atof(). */ - /* next must be digit or the radix separator */ + /* next must be digit or the radix separator or beginning of infinity */ if (isDIGIT(*s)) { do { s++; @@ -1874,22 +1956,32 @@ Perl_looks_like_number(pTHX_ SV *sv) numtype |= IS_NUMBER_TO_INT_BY_ATOL; if (*s == '.' -#ifdef USE_LOCALE_NUMERIC - || IS_NUMERIC_RADIX(*s) +#ifdef USE_LOCALE_NUMERIC + || (specialradix = IS_NUMERIC_RADIX(s)) #endif ) { - s++; +#ifdef USE_LOCALE_NUMERIC + if (specialradix) + s += SvCUR(PL_numeric_radix_sv); + else +#endif + s++; numtype |= IS_NUMBER_NOT_IV; while (isDIGIT(*s)) /* optional digits after the radix */ s++; } } else if (*s == '.' -#ifdef USE_LOCALE_NUMERIC - || IS_NUMERIC_RADIX(*s) +#ifdef USE_LOCALE_NUMERIC + || (specialradix = IS_NUMERIC_RADIX(s)) #endif ) { - s++; +#ifdef USE_LOCALE_NUMERIC + if (specialradix) + s += SvCUR(PL_numeric_radix_sv); + else +#endif + s++; numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV; /* no digits before the radix means we need digits after it */ if (isDIGIT(*s)) { @@ -1900,23 +1992,38 @@ Perl_looks_like_number(pTHX_ SV *sv) else return 0; } + else if (*s == 'I' || *s == 'i') { + s++; if (*s != 'N' && *s != 'n') return 0; + s++; if (*s != 'F' && *s != 'f') return 0; + s++; if (*s == 'I' || *s == 'i') { + s++; if (*s != 'N' && *s != 'n') return 0; + s++; if (*s != 'I' && *s != 'i') return 0; + s++; if (*s != 'T' && *s != 't') return 0; + s++; if (*s != 'Y' && *s != 'y') return 0; + } + sawinf = 1; + } else return 0; - /* we can have an optional exponent part */ - if (*s == 'e' || *s == 'E') { - numtype &= ~IS_NUMBER_NEG; - numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV; - s++; - if (*s == '+' || *s == '-') + if (sawinf) + numtype = IS_NUMBER_INFINITY; + else { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + numtype &= ~IS_NUMBER_NEG; + numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV; s++; - if (isDIGIT(*s)) { - do { - s++; - } while (isDIGIT(*s)); - } - else - return 0; + if (*s == '+' || *s == '-') + s++; + if (isDIGIT(*s)) { + do { + s++; + } while (isDIGIT(*s)); + } + else + return 0; + } } while (isSPACE(*s)) s++; @@ -1994,7 +2101,6 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) } if (!SvROK(sv)) { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) report_uninit(); } @@ -2005,7 +2111,8 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string))) + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) && + (SvRV(tmpstr) != SvRV(sv))) return SvPV(tmpstr,*lp); sv = (SV*)SvRV(sv); if (!sv) @@ -2020,7 +2127,6 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) == (SVs_OBJECT|SVs_RMG)) && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp") && (mg = mg_find(sv, 'r'))) { - dTHR; regexp *re = (regexp *)mg->mg_obj; if (!mg->mg_ptr) { @@ -2088,7 +2194,6 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) return s; } if (SvREADONLY(sv) && !SvOK(sv)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED)) report_uninit(); *lp = 0; @@ -2097,12 +2202,13 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) } if (SvNOKp(sv)) { /* See note in sv_2uv() */ /* XXXX 64-bit? IV may have better precision... */ - /* I tried changing this for to be 64-bit-aware and + /* I tried changing this to be 64-bit-aware and * the t/op/numconvert.t became very, very, angry. * --jhi Sep 1999 */ if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); - SvGROW(sv, 28); + /* The +20 is pure guesswork. Configure test needed. --jhi */ + SvGROW(sv, NV_DIG + 20); s = SvPVX(sv); olderrno = errno; /* some Xenix systems wipe out errno here */ #ifdef apollo @@ -2150,12 +2256,9 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) SvPOK_on(sv); } else { - dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - { report_uninit(); - } *lp = 0; if (SvTYPE(sv) < SVt_PV) /* Typically the caller expects that sv_any is not NULL now. */ @@ -2233,7 +2336,7 @@ char * Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) { sv_utf8_upgrade(sv); - return sv_2pv(sv,lp); + return SvPV(sv,*lp); } /* This function is only called on magical items */ @@ -2246,9 +2349,9 @@ Perl_sv_2bool(pTHX_ register SV *sv) if (!SvOK(sv)) return 0; if (SvROK(sv)) { - dTHR; SV* tmpsv; - if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_))) + if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) && + (SvRV(tmpsv) != SvRV(sv))) return SvTRUE(tmpsv); return SvRV(sv) != 0; } @@ -2274,96 +2377,102 @@ Perl_sv_2bool(pTHX_ register SV *sv) } } +/* +=for apidoc sv_utf8_upgrade + +Convert the PV of an SV to its UTF8-encoded form. + +=cut +*/ + void Perl_sv_utf8_upgrade(pTHX_ register SV *sv) { - int hicount; - char *c; + char *s, *t, *e; + int hibit = 0; if (!sv || !SvPOK(sv) || SvUTF8(sv)) return; - /* This function could be much more efficient if we had a FLAG - * to signal if there are any hibit chars in the string + /* This function could be much more efficient if we had a FLAG in SVs + * to signal if there are any hibit chars in the PV. + * Given that there isn't make loop fast as possible */ - hicount = 0; - for (c = SvPVX(sv); c < SvEND(sv); c++) { - if (*c & 0x80) - hicount++; + s = SvPVX(sv); + e = SvEND(sv); + t = s; + while (t < e) { + if ((hibit = UTF8_IS_CONTINUED(*t++))) + break; } - if (hicount) { - char *src, *dst; - SvGROW(sv, SvCUR(sv) + hicount + 1); - - src = SvEND(sv) - 1; - SvCUR_set(sv, SvCUR(sv) + hicount); - dst = SvEND(sv) - 1; + if (hibit) { + STRLEN len; - while (src < dst) { - if (*src & 0x80) { - dst--; - uv_to_utf8((U8*)dst, (U8)*src--); - dst--; - } - else { - *dst-- = *src--; - } + if (SvREADONLY(sv) && SvFAKE(sv)) { + sv_force_normal(sv); + s = SvPVX(sv); } - + len = SvCUR(sv) + 1; /* Plus the \0 */ + SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len); + SvCUR(sv) = len - 1; + if (SvLEN(sv) != 0) + Safefree(s); /* No longer using what was there before. */ + SvLEN(sv) = len; /* No longer know the real size. */ SvUTF8_on(sv); } } +/* +=for apidoc sv_utf8_downgrade + +Attempt to convert the PV of an SV from UTF8-encoded to byte encoding. +This may not be possible if the PV contains non-byte encoding characters; +if this is the case, either returns false or, if C<fail_ok> is not +true, croaks. + +=cut +*/ + bool Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) { if (SvPOK(sv) && SvUTF8(sv)) { - char *c = SvPVX(sv); - char *first_hi = 0; - /* need to figure out if this is possible at all first */ - while (c < SvEND(sv)) { - if (*c & 0x80) { - I32 len; - UV uv = utf8_to_uv((U8*)c, &len); - if (uv >= 256) { - if (fail_ok) - return FALSE; - else { - /* XXX might want to make a callback here instead */ - Perl_croak(aTHX_ "Big byte"); - } + if (SvCUR(sv)) { + char *s; + STRLEN len; + + if (SvREADONLY(sv) && SvFAKE(sv)) + sv_force_normal(sv); + s = SvPV(sv, len); + if (!utf8_to_bytes((U8*)s, &len)) { + if (fail_ok) + return FALSE; + else { + if (PL_op) + Perl_croak(aTHX_ "Wide character in %s", + PL_op_desc[PL_op->op_type]); + else + Perl_croak(aTHX_ "Wide character"); } - if (!first_hi) - first_hi = c; - c += len; - } - else { - c++; - } - } - - if (first_hi) { - char *src = first_hi; - char *dst = first_hi; - while (src < SvEND(sv)) { - if (*src & 0x80) { - I32 len; - U8 u = (U8)utf8_to_uv((U8*)src, &len); - *dst++ = u; - src += len; - } - else { - *dst++ = *src++; - } - } - SvCUR_set(sv, dst - SvPVX(sv)); - } - SvUTF8_off(sv); + } + SvCUR(sv) = len; + } + SvUTF8_off(sv); } + return TRUE; } +/* +=for apidoc sv_utf8_encode + +Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8> +flag so that it looks like bytes again. Nothing calls this. + +=cut +*/ + void Perl_sv_utf8_encode(pTHX_ register SV *sv) { @@ -2376,6 +2485,7 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv) { if (SvPOK(sv)) { char *c; + char *e; bool has_utf = FALSE; if (!sv_utf8_downgrade(sv, TRUE)) return FALSE; @@ -2384,24 +2494,15 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv) * we want to make sure everything inside is valid utf8 first. */ c = SvPVX(sv); - while (c < SvEND(sv)) { - if (*c & 0x80) { - I32 len; - (void)utf8_to_uv((U8*)c, &len); - if (len == 1) { - /* bad utf8 */ - return FALSE; - } - c += len; - has_utf = TRUE; - } - else { - c++; - } + if (!is_utf8_string((U8*)c, SvCUR(sv)+1)) + return FALSE; + e = SvEND(sv); + while (c < e) { + if (UTF8_IS_CONTINUED(*c++)) { + SvUTF8_on(sv); + break; + } } - - if (has_utf) - SvUTF8_on(sv); } return TRUE; } @@ -2426,7 +2527,6 @@ C<sv_setsv_mg>. void Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) { - dTHR; register U32 sflags; register int dtype; register int stype; @@ -2469,7 +2569,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) SvIVX(dstr) = SvIVX(sstr); if (SvIsUV(sstr)) SvIsUV_on(dstr); - SvTAINT(dstr); + if (SvTAINTED(sstr)) + SvTAINT(dstr); return; } goto undef_sstr; @@ -2489,7 +2590,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) } SvNVX(dstr) = SvNVX(sstr); (void)SvNOK_only(dstr); - SvTAINT(dstr); + if (SvTAINTED(sstr)) + SvTAINT(dstr); return; } goto undef_sstr; @@ -2543,7 +2645,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) char *name = GvNAME(sstr); STRLEN len = GvNAMELEN(sstr); sv_upgrade(dstr, SVt_PVGV); - sv_magic(dstr, dstr, '*', name, len); + sv_magic(dstr, dstr, '*', Nullch, 0); GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr)); GvNAME(dstr) = savepvn(name, len); GvNAMELEN(dstr) = len; @@ -2558,7 +2660,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) GvINTRO_off(dstr); /* one-shot flag */ gp_free((GV*)dstr); GvGP(dstr) = gp_ref(GvGP(sstr)); - SvTAINT(dstr); + if (SvTAINTED(sstr)) + SvTAINT(dstr); if (GvIMPORTED(dstr) != GVf_IMPORTED && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { @@ -2704,7 +2807,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) SvREFCNT_dec(dref); if (intro) SAVEFREESV(sref); - SvTAINT(dstr); + if (SvTAINTED(sstr)) + SvTAINT(dstr); return; } if (SvPVX(dstr)) { @@ -2724,7 +2828,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) if (sflags & SVp_IOK) { (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); - if (SvIsUV(sstr)) + if (sflags & SVf_IVisUV) SvIsUV_on(dstr); } if (SvAMAGIC(sstr)) { @@ -2756,13 +2860,9 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) SvPV_set(dstr, SvPVX(sstr)); SvLEN_set(dstr, SvLEN(sstr)); SvCUR_set(dstr, SvCUR(sstr)); - if (SvUTF8(sstr)) - SvUTF8_on(dstr); - else - SvUTF8_off(dstr); SvTEMP_off(dstr); - (void)SvOK_off(sstr); + (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */ SvPV_set(sstr, Nullch); SvLEN_set(sstr, 0); SvCUR_set(sstr, 0); @@ -2777,7 +2877,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) *SvEND(dstr) = '\0'; (void)SvPOK_only(dstr); } - if (DO_UTF8(sstr)) + if (sflags & SVf_UTF8) SvUTF8_on(dstr); /*SUPPRESS 560*/ if (sflags & SVp_NOK) { @@ -2787,25 +2887,25 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) if (sflags & SVp_IOK) { (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); - if (SvIsUV(sstr)) + if (sflags & SVf_IVisUV) SvIsUV_on(dstr); } } else if (sflags & SVp_NOK) { SvNVX(dstr) = SvNVX(sstr); (void)SvNOK_only(dstr); - if (SvIOK(sstr)) { + if (sflags & SVf_IOK) { (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ - if (SvIsUV(sstr)) + if (sflags & SVf_IVisUV) SvIsUV_on(dstr); } } else if (sflags & SVp_IOK) { (void)SvIOK_only(dstr); SvIVX(dstr) = SvIVX(sstr); - if (SvIsUV(sstr)) + if (sflags & SVf_IVisUV) SvIsUV_on(dstr); } else { @@ -2816,7 +2916,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) else (void)SvOK_off(dstr); } - SvTAINT(dstr); + if (SvTAINTED(sstr)) + SvTAINT(dstr); } /* @@ -2847,13 +2948,17 @@ void Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) { register char *dptr; - assert(len >= 0); /* STRLEN is probably unsigned, so this may - elicit a warning, but it won't hurt. */ + SV_CHECK_THINKFIRST(sv); if (!ptr) { (void)SvOK_off(sv); return; } + else { + /* len is STRLEN which is unsigned, need to copy to signed */ + IV iv = len; + assert(iv >= 0); + } (void)SvUPGRADE(sv, SVt_PV); SvGROW(sv, len + 1); @@ -2978,7 +3083,6 @@ void Perl_sv_force_normal(pTHX_ register SV *sv) { if (SvREADONLY(sv)) { - dTHR; if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); } @@ -3076,25 +3180,42 @@ Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRL /* =for apidoc sv_catsv -Concatenates the string from SV C<ssv> onto the end of the string in SV -C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>. +Concatenates the string from SV C<ssv> onto the end of the string in +SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but +not 'set' magic. See C<sv_catsv_mg>. -=cut -*/ +=cut */ void Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr) { - char *s; - STRLEN len; + char *spv; + STRLEN slen; if (!sstr) return; - if ((s = SvPV(sstr, len))) { - if (SvUTF8(sstr)) - sv_utf8_upgrade(dstr); - sv_catpvn(dstr,s,len); - if (SvUTF8(sstr)) - SvUTF8_on(dstr); + if ((spv = SvPV(sstr, slen))) { + bool dutf8 = DO_UTF8(dstr); + bool sutf8 = DO_UTF8(sstr); + + if (dutf8 == sutf8) + sv_catpvn(dstr,spv,slen); + else { + if (dutf8) { + SV* cstr = newSVsv(sstr); + char *cpv; + STRLEN clen; + + sv_utf8_upgrade(cstr); + cpv = SvPV(cstr,clen); + sv_catpvn(dstr,cpv,clen); + sv_2mortal(cstr); + } + else { + sv_utf8_upgrade(dstr); + sv_catpvn(dstr,spv,slen); + SvUTF8_on(dstr); + } + } } } @@ -3186,7 +3307,6 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam MAGIC* mg; if (SvREADONLY(sv)) { - dTHR; if (PL_curcop != &PL_compiling && !strchr("gBf", how)) Perl_croak(aTHX_ PL_no_modify); } @@ -3202,12 +3322,21 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam } Newz(702,mg, 1, MAGIC); mg->mg_moremagic = SvMAGIC(sv); - SvMAGIC(sv) = mg; - if (!obj || obj == sv || how == '#' || how == 'r') + + /* Some magic sontains a reference loop, where the sv and object refer to + each other. To prevent a avoid a reference loop that would prevent such + objects being freed, we look for such loops and if we find one we avoid + incrementing the object refcount. */ + if (!obj || obj == sv || how == '#' || how == 'r' || + (SvTYPE(obj) == SVt_PVGV && + (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv || + GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv || + GvFORM(obj) == (CV*)sv))) + { mg->mg_obj = obj; + } else { - dTHR; mg->mg_obj = SvREFCNT_inc(obj); mg->mg_flags |= MGf_REFCOUNTED; } @@ -3337,6 +3466,14 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); } +/* +=for apidoc sv_unmagic + +Removes magic from an SV. + +=cut +*/ + int Perl_sv_unmagic(pTHX_ SV *sv, int type) { @@ -3371,6 +3508,14 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type) return 0; } +/* +=for apidoc sv_rvweaken + +Weaken a reference. + +=cut +*/ + SV * Perl_sv_rvweaken(pTHX_ SV *sv) { @@ -3380,7 +3525,6 @@ Perl_sv_rvweaken(pTHX_ SV *sv) if (!SvROK(sv)) Perl_croak(aTHX_ "Can't weaken a nonreference"); else if (SvWEAKREF(sv)) { - dTHR; if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ WARN_MISC, "Reference is already weak"); return sv; @@ -3392,8 +3536,8 @@ Perl_sv_rvweaken(pTHX_ SV *sv) return sv; } -STATIC void -S_sv_add_backref(pTHX_ SV *tsv, SV *sv) +void +Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv) { AV *av; MAGIC *mg; @@ -3407,8 +3551,8 @@ S_sv_add_backref(pTHX_ SV *tsv, SV *sv) av_push(av,sv); } -STATIC void -S_sv_del_backref(pTHX_ SV *sv) +void +Perl_sv_del_backref(pTHX_ SV *sv) { AV *av; SV **svp; @@ -3451,6 +3595,7 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN if (!bigstr) Perl_croak(aTHX_ "Can't modify non-existent substring"); SvPV_force(bigstr, curlen); + (void)SvPOK_only_UTF8(bigstr); if (offset + len > curlen) { SvGROW(bigstr, offset+len+1); Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); @@ -3521,12 +3666,17 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN SvSETMAGIC(bigstr); } -/* make sv point to what nstr did */ +/* +=for apidoc sv_replace + +Make the first argument a copy of the second, then delete the original. + +=cut +*/ void Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) { - dTHR; U32 refcnt = SvREFCNT(sv); SV_CHECK_THINKFIRST(sv); if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL)) @@ -3550,6 +3700,15 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) del_SV(nsv); } +/* +=for apidoc sv_clear + +Clear an SV, making it empty. Does not free the memory used by the SV +itself. + +=cut +*/ + void Perl_sv_clear(pTHX_ register SV *sv) { @@ -3558,9 +3717,8 @@ Perl_sv_clear(pTHX_ register SV *sv) assert(SvREFCNT(sv) == 0); if (SvOBJECT(sv)) { - dTHR; if (PL_defstash) { /* Still have a symbol table? */ - djSP; + dSP; GV* destructor; SV tmpref; @@ -3743,10 +3901,17 @@ Perl_sv_newref(pTHX_ SV *sv) return sv; } +/* +=for apidoc sv_free + +Free the memory used by an SV. + +=cut +*/ + void Perl_sv_free(pTHX_ SV *sv) { - dTHR; int refcount_is_zero; if (!sv) @@ -3811,29 +3976,32 @@ Perl_sv_len(pTHX_ register SV *sv) return len; } +/* +=for apidoc sv_len_utf8 + +Returns the number of characters in the string in an SV, counting wide +UTF8 bytes as a single character. + +=cut +*/ + STRLEN Perl_sv_len_utf8(pTHX_ register SV *sv) { - U8 *s; - U8 *send; - STRLEN len; - if (!sv) return 0; #ifdef NOTYET if (SvGMAGICAL(sv)) - len = mg_length(sv); + return mg_length(sv); else #endif - s = (U8*)SvPV(sv, len); - send = s + len; - len = 0; - while (s < send) { - s += UTF8SKIP(s); - len++; + { + STRLEN len; + U8 *s = (U8*)SvPV(sv, len); + + return Perl_utf8_length(aTHX_ s, s + len); } - return len; } void @@ -3879,18 +4047,18 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) s = (U8*)SvPV(sv, len); if (len < *offsetp) - Perl_croak(aTHX_ "panic: bad byte offset"); + Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset"); send = s + *offsetp; len = 0; while (s < send) { - s += UTF8SKIP(s); - ++len; - } - if (s != send) { - dTHR; - if (ckWARN_d(WARN_UTF8)) - Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); - --len; + STRLEN n; + + if (utf8_to_uv(s, UTF8SKIP(s), &n, 0)) { + s += n; + len++; + } + else + break; } *offsetp = len; return; @@ -3906,29 +4074,57 @@ identical. */ I32 -Perl_sv_eq(pTHX_ register SV *str1, register SV *str2) +Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) { char *pv1; STRLEN cur1; char *pv2; STRLEN cur2; + I32 eq = 0; + bool pv1tmp = FALSE; + bool pv2tmp = FALSE; - if (!str1) { + if (!sv1) { pv1 = ""; cur1 = 0; } else - pv1 = SvPV(str1, cur1); + pv1 = SvPV(sv1, cur1); - if (!str2) - return !cur1; + if (!sv2){ + pv2 = ""; + cur2 = 0; + } else - pv2 = SvPV(str2, cur2); + pv2 = SvPV(sv2, cur2); - if (cur1 != cur2) - return 0; + /* do not utf8ize the comparands as a side-effect */ + if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) { + bool is_utf8 = TRUE; + + if (SvUTF8(sv1)) { + char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8); + + if ((pv1tmp = (pv != pv1))) + pv1 = pv; + } + else { + char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8); - return memEQ(pv1, pv2, cur1); + if ((pv2tmp = (pv != pv2))) + pv2 = pv; + } + } + + if (cur1 == cur2) + eq = memEQ(pv1, pv2, cur1); + + if (pv1tmp) + Safefree(pv1); + if (pv2tmp) + Safefree(pv2); + + return eq; } /* @@ -3942,60 +4138,72 @@ C<sv2>. */ I32 -Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2) +Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) { STRLEN cur1, cur2; char *pv1, *pv2; - I32 retval; + I32 cmp; + bool pv1tmp = FALSE; + bool pv2tmp = FALSE; - if (str1) { - pv1 = SvPV(str1, cur1); - } - else { + if (!sv1) { + pv1 = ""; cur1 = 0; } + else + pv1 = SvPV(sv1, cur1); + + if (!sv2){ + pv2 = ""; + cur2 = 0; + } + else + pv2 = SvPV(sv2, cur2); - if (str2) { - if (SvPOK(str2)) { - if (SvPOK(str1) && SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) { - /* must upgrade other to UTF8 first */ - if (SvUTF8(str1)) { - sv_utf8_upgrade(str2); - } - else { - sv_utf8_upgrade(str1); - /* refresh pointer and length */ - pv1 = SvPVX(str1); - cur1 = SvCUR(str1); - } - } - pv2 = SvPVX(str2); - cur2 = SvCUR(str2); - } + /* do not utf8ize the comparands as a side-effect */ + if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) { + if (SvUTF8(sv1)) { + pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2); + pv2tmp = TRUE; + } else { - pv2 = sv_2pv(str2, &cur2); + pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1); + pv1tmp = TRUE; } } - else { - cur2 = 0; + + if (!cur1) { + cmp = cur2 ? -1 : 0; + } else if (!cur2) { + cmp = 1; + } else { + I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2); + + if (retval) { + cmp = retval < 0 ? -1 : 1; + } else if (cur1 == cur2) { + cmp = 0; + } else { + cmp = cur1 < cur2 ? -1 : 1; + } } - if (!cur1) - return cur2 ? -1 : 0; + if (pv1tmp) + Safefree(pv1); + if (pv2tmp) + Safefree(pv2); - if (!cur2) - return 1; + return cmp; +} - retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2); +/* +=for apidoc sv_cmp_locale - if (retval) - return retval < 0 ? -1 : 1; +Compares the strings in two SVs in a locale-aware manner. See +L</sv_cmp_locale> - if (cur1 == cur2) - return 0; - else - return cur1 < cur2 ? -1 : 1; -} +=cut +*/ I32 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2) @@ -4098,10 +4306,18 @@ Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) #endif /* USE_LOCALE_COLLATE */ +/* +=for apidoc sv_gets + +Get a line from the filehandle and store it into the SV, optionally +appending to the currently-stored string. + +=cut +*/ + char * Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) { - dTHR; char *rsptr; STRLEN rslen; register STDCHAR rslast; @@ -4137,14 +4353,23 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) #endif SvCUR_set(sv, bytesread); buffer[bytesread] = '\0'; + SvUTF8_off(sv); return(SvCUR(sv) ? SvPVX(sv) : Nullch); } else if (RsPARA(PL_rs)) { rsptr = "\n\n"; rslen = 2; } - else + else { + /* Get $/ i.e. PL_rs into same encoding as stream wants */ + if (SvUTF8(PL_rs)) { + if (!sv_utf8_downgrade(PL_rs, TRUE)) { + Perl_croak(aTHX_ "Wide character in $/"); + } + } rsptr = SvPV(PL_rs, rslen); + } + rslast = rslen ? rsptr[rslen - 1] : '\0'; if (RsPARA(PL_rs)) { /* have to do this both before and after */ @@ -4363,6 +4588,8 @@ screamer2: } } + SvUTF8_off(sv); + return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; } @@ -4387,7 +4614,6 @@ Perl_sv_inc(pTHX_ register SV *sv) mg_get(sv); if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) { - dTHR; if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); } @@ -4495,7 +4721,6 @@ Perl_sv_dec(pTHX_ register SV *sv) mg_get(sv); if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) { - dTHR; if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); } @@ -4561,7 +4786,6 @@ as mortal. SV * Perl_sv_mortalcopy(pTHX_ SV *oldstr) { - dTHR; register SV *sv; new_SV(sv); @@ -4583,7 +4807,6 @@ Creates a new SV which is mortal. The reference count of the SV is set to 1. SV * Perl_sv_newmortal(pTHX) { - dTHR; register SV *sv; new_SV(sv); @@ -4607,7 +4830,6 @@ ends. SV * Perl_sv_2mortal(pTHX_ register SV *sv) { - dTHR; if (!sv) return sv; if (SvREADONLY(sv) && SvIMMORTAL(sv)) @@ -4773,7 +4995,6 @@ SV is B<not> incremented. SV * Perl_newRV_noinc(pTHX_ SV *tmpRef) { - dTHR; register SV *sv; new_SV(sv); @@ -4804,7 +5025,6 @@ Creates a new SV which is an exact duplicate of the original SV. SV * Perl_newSVsv(pTHX_ register SV *old) { - dTHR; register SV *sv; if (!old) @@ -4887,7 +5107,7 @@ Perl_sv_reset(pTHX_ register char *s, HV *stash) } if (GvHV(gv) && !HvNAME(GvHV(gv))) { hv_clear(GvHV(gv)); -#ifndef VMS /* VMS has no environ array */ +#ifdef USE_ENVIRON_ARRAY if (gv == PL_envgv) environ[0] = Nullch; #endif @@ -4959,7 +5179,6 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) if (SvGMAGICAL(sv)) mg_get(sv); if (SvROK(sv)) { - dTHR; SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ tryAMAGICunDEREF(to_cv); @@ -5004,10 +5223,17 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) } } +/* +=for apidoc sv_true + +Returns true if the SV has a true value by Perl's rules. + +=cut +*/ + I32 Perl_sv_true(pTHX_ register SV *sv) { - dTHR; if (!sv) return 0; if (SvPOK(sv)) { @@ -5082,6 +5308,14 @@ Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) return sv_2pv(sv, lp); } +/* +=for apidoc sv_pvn_force + +Get a sensible string out of the SV somehow. + +=cut +*/ + char * Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) { @@ -5095,7 +5329,6 @@ Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) } else { if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) { - dTHR; Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), PL_op_name[PL_op->op_type]); } @@ -5154,6 +5387,15 @@ Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp) return sv_pvn(sv,lp); } +/* +=for apidoc sv_pvutf8n_force + +Get a sensible UTF8-encoded string out of the SV somehow. See +L</sv_pvn_force>. + +=cut +*/ + char * Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp) { @@ -5161,6 +5403,14 @@ Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp) return sv_pvn_force(sv,lp); } +/* +=for apidoc sv_reftype + +Returns a string describing what the SV is a reference to. + +=cut +*/ + char * Perl_sv_reftype(pTHX_ SV *sv, int ob) { @@ -5258,7 +5508,6 @@ reference count is 1. SV* Perl_newSVrv(pTHX_ SV *rv, const char *classname) { - dTHR; SV *sv; new_SV(sv); @@ -5266,8 +5515,23 @@ Perl_newSVrv(pTHX_ SV *rv, const char *classname) SV_CHECK_THINKFIRST(rv); SvAMAGIC_off(rv); + if (SvTYPE(rv) >= SVt_PVMG) { + U32 refcnt = SvREFCNT(rv); + SvREFCNT(rv) = 0; + sv_clear(rv); + SvFLAGS(rv) = 0; + SvREFCNT(rv) = refcnt; + } + if (SvTYPE(rv) < SVt_RV) - sv_upgrade(rv, SVt_RV); + sv_upgrade(rv, SVt_RV); + else if (SvTYPE(rv) > SVt_RV) { + (void)SvOOK_off(rv); + if (SvPVX(rv) && SvLEN(rv)) + Safefree(SvPVX(rv)); + SvCUR_set(rv, 0); + SvLEN_set(rv, 0); + } (void)SvOK_off(rv); SvRV(rv) = sv; @@ -5383,7 +5647,6 @@ of the SV is unaffected. SV* Perl_sv_bless(pTHX_ SV *sv, HV *stash) { - dTHR; SV *tmpRef; if (!SvROK(sv)) Perl_croak(aTHX_ "Can't bless non-reference value"); @@ -5706,7 +5969,6 @@ locales). void Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted) { - dTHR; char *p; char *q; char *patend; @@ -5763,7 +6025,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV bool is_utf = FALSE; char esignbuf[4]; - U8 utf8buf[UTF8_MAXLEN]; + U8 utf8buf[UTF8_MAXLEN+1]; STRLEN esignlen = 0; char *eptr = Nullch; @@ -5839,17 +6101,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV case 'v': vectorize = TRUE; q++; - if (args) - vecsv = va_arg(*args, SV*); - else if (svix < svmax) - vecsv = svargs[svix++]; - else { - vecstr = (U8*)""; - veclen = 0; - continue; - } - vecstr = (U8*)SvPVx(vecsv,veclen); - utf = DO_UTF8(vecsv); continue; default: @@ -5900,19 +6151,39 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV has_precis = TRUE; } + if (vectorize) { + if (args) { + vecsv = va_arg(*args, SV*); + vecstr = (U8*)SvPVx(vecsv,veclen); + utf = DO_UTF8(vecsv); + } + else if (svix < svmax) { + vecsv = svargs[svix++]; + vecstr = (U8*)SvPVx(vecsv,veclen); + utf = DO_UTF8(vecsv); + } + else { + vecstr = (U8*)""; + veclen = 0; + } + } + /* SIZE */ switch (*q) { -#ifdef HAS_QUAD +#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)) case 'L': /* Ld */ + /* FALL THROUGH */ +#endif +#ifdef HAS_QUAD case 'q': /* qd */ intsize = 'q'; q++; break; #endif case 'l': -#ifdef HAS_QUAD - if (*(q + 1) == 'l') { /* lld */ +#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)) + if (*(q + 1) == 'l') { /* lld, llf */ intsize = 'q'; q += 2; break; @@ -6009,6 +6280,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* INTEGERS */ case 'p': + if (alt) + goto unknown; if (args) uv = PTR2UV(va_arg(*args, void*)); else @@ -6026,13 +6299,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV case 'd': case 'i': if (vectorize) { - I32 ulen; + STRLEN ulen; if (!veclen) { vectorize = FALSE; break; } if (utf) - iv = (IV)utf8_to_uv(vecstr, &ulen); + iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0); else { iv = *vecstr; ulen = 1; @@ -6055,7 +6328,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; switch (intsize) { case 'h': iv = (short)iv; break; - default: iv = (int)iv; break; + default: break; case 'l': iv = (long)iv; break; case 'V': break; #ifdef HAS_QUAD @@ -6107,14 +6380,14 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV uns_integer: if (vectorize) { - I32 ulen; + STRLEN ulen; vector: if (!veclen) { vectorize = FALSE; break; } if (utf) - uv = utf8_to_uv(vecstr, &ulen); + uv = utf8_to_uv(vecstr, veclen, &ulen, 0); else { uv = *vecstr; ulen = 1; @@ -6137,7 +6410,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0; switch (intsize) { case 'h': uv = (unsigned short)uv; break; - default: uv = (unsigned)uv; break; + default: break; case 'l': uv = (unsigned long)uv; break; case 'V': break; #ifdef HAS_QUAD @@ -6252,11 +6525,14 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV eptr = ebuf + sizeof ebuf; *--eptr = '\0'; *--eptr = c; -#ifdef USE_LONG_DOUBLE +#if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl) { - static char const my_prifldbl[] = PERL_PRIfldbl; - char const *p = my_prifldbl + sizeof my_prifldbl - 3; - while (p >= my_prifldbl) { *--eptr = *p--; } + /* Copy the one or more characters in a long double + * format before the 'base' ([efgEFG]) character to + * the format string. */ + static char const prifldbl[] = PERL_PRIfldbl; + char const *p = prifldbl + sizeof(prifldbl) - 3; + while (p >= prifldbl) { *--eptr = *p--; } } #endif if (has_precis) { @@ -6278,11 +6554,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV *--eptr = '#'; *--eptr = '%'; - { - RESTORE_NUMERIC_STANDARD(); - (void)sprintf(PL_efloatbuf, eptr, nv); - RESTORE_NUMERIC_LOCAL(); - } + /* No taint. Otherwise we are in the strange situation + * where printf() taints but print($float) doesn't. + * --jhi */ + (void)sprintf(PL_efloatbuf, eptr, nv); eptr = PL_efloatbuf; elen = strlen(PL_efloatbuf); @@ -6305,7 +6580,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } else if (svix < svmax) - sv_setuv(svargs[svix++], (UV)i); + sv_setuv_mg(svargs[svix++], (UV)i); continue; /* not "break" */ /* UNKNOWN */ @@ -6489,8 +6764,8 @@ Perl_gp_dup(pTHX_ GP *gp) MAGIC * Perl_mg_dup(pTHX_ MAGIC *mg) { - MAGIC *mgret = (MAGIC*)NULL; - MAGIC *mgprev; + MAGIC *mgprev = (MAGIC*)NULL; + MAGIC *mgret; if (!mg) return (MAGIC*)NULL; /* look for it in the table first */ @@ -6501,10 +6776,10 @@ Perl_mg_dup(pTHX_ MAGIC *mg) for (; mg; mg = mg->mg_moremagic) { MAGIC *nmg; Newz(0, nmg, 1, MAGIC); - if (!mgret) - mgret = nmg; - else + if (mgprev) mgprev->mg_moremagic = nmg; + else + mgret = nmg; nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */ nmg->mg_private = mg->mg_private; nmg->mg_type = mg->mg_type; @@ -6623,6 +6898,51 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl) } } +void +Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl) +{ + register PTR_TBL_ENT_t **array; + register PTR_TBL_ENT_t *entry; + register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*); + UV riter = 0; + UV max; + + if (!tbl || !tbl->tbl_items) { + return; + } + + array = tbl->tbl_ary; + entry = array[0]; + max = tbl->tbl_max; + + for (;;) { + if (entry) { + oentry = entry; + entry = entry->next; + Safefree(oentry); + } + if (!entry) { + if (++riter > max) { + break; + } + entry = array[riter]; + } + } + + tbl->tbl_items = 0; +} + +void +Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl) +{ + if (!tbl) { + return; + } + ptr_table_clear(tbl); + Safefree(tbl->tbl_ary); + Safefree(tbl); +} + #ifdef DEBUGGING char *PL_watch_pvx; #endif @@ -6906,7 +7226,7 @@ dup_pvcv: CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr)); CvXSUB(dstr) = CvXSUB(sstr); CvXSUBANY(dstr) = CvXSUBANY(sstr); - CvGV(dstr) = gv_dup_inc(CvGV(sstr)); + CvGV(dstr) = gv_dup(CvGV(sstr)); CvDEPTH(dstr) = CvDEPTH(sstr); if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) { /* XXX padlists are real, but pretend to be not */ @@ -6917,7 +7237,10 @@ dup_pvcv: } else CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr)); - CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr)); + if (!CvANON(sstr) || CvCLONED(sstr)) + CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr)); + else + CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr)); CvFLAGS(dstr) = CvFLAGS(sstr); break; default: @@ -6971,7 +7294,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max) ncx->blk_sub.argarray = (cx->blk_sub.hasargs ? av_dup_inc(cx->blk_sub.argarray) : Nullav); - ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray); + ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray); ncx->blk_sub.olddepth = cx->blk_sub.olddepth; ncx->blk_sub.hasargs = cx->blk_sub.hasargs; ncx->blk_sub.lval = cx->blk_sub.lval; @@ -7126,6 +7449,12 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) gv = (GV*)POPPTR(ss,ix); TOPPTR(nss,ix) = gv_dup_inc(gv); break; + case SAVEt_GENERIC_PVREF: /* generic char* */ + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup(c); + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + break; case SAVEt_GENERIC_SVREF: /* generic sv */ case SAVEt_SVREF: /* scalar reference */ sv = (SV*)POPPTR(ss,ix); @@ -7219,6 +7548,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) TOPIV(nss,ix) = iv; break; case SAVEt_FREESV: + case SAVEt_MORTALIZESV: sv = (SV*)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv); break; @@ -7311,6 +7641,14 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) av = (AV*)POPPTR(ss,ix); TOPPTR(nss,ix) = av_dup(av); break; + case SAVEt_PADSV: + longval = (long)POPLONG(ss,ix); + TOPLONG(nss,ix) = longval; + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup(sv); + break; default: Perl_croak(aTHX_ "panic: ss_dup inconsistency"); } @@ -7404,17 +7742,29 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* arena roots */ PL_xiv_arenaroot = NULL; PL_xiv_root = NULL; + PL_xnv_arenaroot = NULL; PL_xnv_root = NULL; + PL_xrv_arenaroot = NULL; PL_xrv_root = NULL; + PL_xpv_arenaroot = NULL; PL_xpv_root = NULL; + PL_xpviv_arenaroot = NULL; PL_xpviv_root = NULL; + PL_xpvnv_arenaroot = NULL; PL_xpvnv_root = NULL; + PL_xpvcv_arenaroot = NULL; PL_xpvcv_root = NULL; + PL_xpvav_arenaroot = NULL; PL_xpvav_root = NULL; + PL_xpvhv_arenaroot = NULL; PL_xpvhv_root = NULL; + PL_xpvmg_arenaroot = NULL; PL_xpvmg_root = NULL; + PL_xpvlv_arenaroot = NULL; PL_xpvlv_root = NULL; + PL_xpvbm_arenaroot = NULL; PL_xpvbm_root = NULL; + PL_he_arenaroot = NULL; PL_he_root = NULL; PL_nice_chunk = NULL; PL_nice_chunk_size = 0; @@ -7528,7 +7878,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_defgv = gv_dup(proto_perl->Idefgv); PL_argvgv = gv_dup(proto_perl->Iargvgv); PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv); - PL_argvout_stack = av_dup(proto_perl->Iargvout_stack); + PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack); /* shortcuts to regexp stuff */ PL_replgv = gv_dup(proto_perl->Ireplgv); @@ -7740,7 +8090,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_numeric_name = SAVEPV(proto_perl->Inumeric_name); PL_numeric_standard = proto_perl->Inumeric_standard; PL_numeric_local = proto_perl->Inumeric_local; - PL_numeric_radix = proto_perl->Inumeric_radix; + PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv); #endif /* !USE_LOCALE_NUMERIC */ /* utf8 character classes */ @@ -7798,7 +8148,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* thrdvar.h stuff */ - if (flags & 1) { + if (flags & CLONEf_COPY_STACKS) { /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ PL_tmps_ix = proto_perl->Ttmps_ix; PL_tmps_max = proto_perl->Ttmps_max; @@ -7856,6 +8206,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } else { init_stacks(); + ENTER; /* perl_destruct() wants to LEAVE; */ } PL_start_env = proto_perl->Tstart_env; /* XXXXXX */ @@ -7984,6 +8335,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_reginterp_cnt = 0; PL_reg_starttry = 0; + if (!(flags & CLONEf_KEEP_PTR_TABLE)) { + ptr_table_free(PL_ptr_table); + PL_ptr_table = NULL; + } + #ifdef PERL_OBJECT return (PerlInterpreter*)pPerl; #else @@ -8015,9 +8371,15 @@ do_clean_objs(pTHXo_ SV *sv) if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));) - SvROK_off(sv); - SvRV(sv) = 0; - SvREFCNT_dec(rv); + if (SvWEAKREF(sv)) { + sv_del_backref(sv); + SvWEAKREF_off(sv); + SvRV(sv) = 0; + } else { + SvROK_off(sv); + SvRV(sv) = 0; + SvREFCNT_dec(rv); + } } /* XXX Might want to check arrays, etc. */ diff --git a/contrib/perl5/sv.h b/contrib/perl5/sv.h index 245199fbfc81..32418f97e52c 100644 --- a/contrib/perl5/sv.h +++ b/contrib/perl5/sv.h @@ -1,6 +1,6 @@ /* sv.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. @@ -61,7 +61,7 @@ typedef enum { /* Using C's structural equivalence to help emulate C++ inheritance here... */ -struct sv { +struct STRUCT_SV { void* sv_any; /* pointer to something */ U32 sv_refcnt; /* how many references to us */ U32 sv_flags; /* what we are */ @@ -123,21 +123,26 @@ perform the upgrade if necessary. See C<svtype>. #ifdef USE_THREADS -# ifdef EMULATE_ATOMIC_REFCOUNTS -# define ATOMIC_INC(count) STMT_START { \ - MUTEX_LOCK(&PL_svref_mutex); \ - ++count; \ - MUTEX_UNLOCK(&PL_svref_mutex); \ - } STMT_END -# define ATOMIC_DEC_AND_TEST(res,count) STMT_START { \ - MUTEX_LOCK(&PL_svref_mutex); \ - res = (--count == 0); \ - MUTEX_UNLOCK(&PL_svref_mutex); \ - } STMT_END -# else -# define ATOMIC_INC(count) atomic_inc(&count) -# define ATOMIC_DEC_AND_TEST(res,count) (res = atomic_dec_and_test(&count)) -# endif /* EMULATE_ATOMIC_REFCOUNTS */ +# if defined(VMS) +# define ATOMIC_INC(count) __ATOMIC_INCREMENT_LONG(&count) +# define ATOMIC_DEC_AND_TEST(res,count) res=(1==__ATOMIC_DECREMENT_LONG(&count)) + # else +# ifdef EMULATE_ATOMIC_REFCOUNTS + # define ATOMIC_INC(count) STMT_START { \ + MUTEX_LOCK(&PL_svref_mutex); \ + ++count; \ + MUTEX_UNLOCK(&PL_svref_mutex); \ + } STMT_END +# define ATOMIC_DEC_AND_TEST(res,count) STMT_START { \ + MUTEX_LOCK(&PL_svref_mutex); \ + res = (--count == 0); \ + MUTEX_UNLOCK(&PL_svref_mutex); \ + } STMT_END +# else +# define ATOMIC_INC(count) atomic_inc(&count) +# define ATOMIC_DEC_AND_TEST(res,count) (res = atomic_dec_and_test(&count)) +# endif /* EMULATE_ATOMIC_REFCOUNTS */ +# endif /* VMS */ #else # define ATOMIC_INC(count) (++count) # define ATOMIC_DEC_AND_TEST(res, count) (res = (--count == 0)) @@ -153,7 +158,12 @@ perform the upgrade if necessary. See C<svtype>. }) #else # if defined(CRIPPLED_CC) || defined(USE_THREADS) -# define SvREFCNT_inc(sv) sv_newref((SV*)sv) +# if defined(VMS) && defined(__ALPHA) +# define SvREFCNT_inc(sv) \ + (PL_Sv=(SV*)(sv), (PL_Sv && __ATOMIC_INCREMENT_LONG(&(SvREFCNT(PL_Sv)))), (SV *)PL_Sv) +# else +# define SvREFCNT_inc(sv) sv_newref((SV*)sv) +# endif # else # define SvREFCNT_inc(sv) \ ((PL_Sv=(SV*)(sv)), (PL_Sv && ATOMIC_INC(SvREFCNT(PL_Sv))), (SV*)PL_Sv) @@ -353,7 +363,19 @@ struct xpvio { PerlIO * xio_ifp; /* ifp and ofp are normally the same */ PerlIO * xio_ofp; /* but sockets need separate streams */ - DIR * xio_dirp; /* for opendir, readdir, etc */ + /* Cray addresses everything by word boundaries (64 bits) and + * code and data pointers cannot be mixed (which is exactly what + * Perl_filter_add() tries to do with the dirp), hence the following + * union trick (as suggested by Gurusamy Sarathy). + * For further information see Geir Johansen's problem report titled + [ID 20000612.002] Perl problem on Cray system + * The any pointer (known as IoANY()) will also be a good place + * to hang any IO disciplines to. + */ + union { + DIR * xiou_dirp; /* for opendir, readdir, etc */ + void * xiou_any; /* for alignment */ + } xio_dirpu; long xio_lines; /* $. */ long xio_page; /* $% */ long xio_page_len; /* $= */ @@ -368,6 +390,8 @@ struct xpvio { char xio_type; char xio_flags; }; +#define xio_dirp xio_dirpu.xiou_dirp +#define xio_any xio_dirpu.xiou_any #define IOf_ARGV 1 /* this fp iterates over ARGV */ #define IOf_START 2 /* check for null ARGV and substitute '-' */ @@ -418,6 +442,15 @@ Unsets the IV status of an SV. =for apidoc Am|void|SvIOK_only|SV* sv Tells an SV that it is an integer and disables all other OK bits. +=for apidoc Am|void|SvIOK_only_UV|SV* sv +Tells and SV that it is an unsigned integer and disables all other OK bits. + +=for apidoc Am|void|SvIOK_UV|SV* sv +Returns a boolean indicating whether the SV contains an unsigned integer. + +=for apidoc Am|void|SvIOK_notUV|SV* sv +Returns a boolean indicating whether the SV contains an signed integer. + =for apidoc Am|bool|SvNOK|SV* sv Returns a boolean indicating whether the SV contains a double. @@ -481,7 +514,8 @@ string. Returns the length of the string which is in the SV. See C<SvLEN>. =for apidoc Am|STRLEN|SvLEN|SV* sv -Returns the size of the string buffer in the SV. See C<SvCUR>. +Returns the size of the string buffer in the SV, not including any part +attributable to C<SvOOK>. See C<SvCUR>. =for apidoc Am|char*|SvEND|SV* sv Returns a pointer to the last character in the string which is in the SV. @@ -541,6 +575,23 @@ Set the length of the string which is in the SV. See C<SvCUR>. #define SvNOK_only(sv) ((void)SvOK_off(sv), \ SvFLAGS(sv) |= (SVf_NOK|SVp_NOK)) +/* +=for apidoc Am|void|SvUTF8|SV* sv +Returns a boolean indicating whether the SV contains UTF-8 encoded data. + +=for apidoc Am|void|SvUTF8_on|SV *sv +Tells an SV that it is a string and encoded in UTF8. Do not use frivolously. + +=for apidoc Am|void|SvUTF8_off|SV *sv +Unsets the UTF8 status of an SV. + +=for apidoc Am|void|SvPOK_only_UTF8|SV* sv +Tells an SV that it is a UTF8 string (do not use frivolously) +and disables all other OK bits. + +=cut + */ + #define SvUTF8(sv) (SvFLAGS(sv) & SVf_UTF8) #define SvUTF8_on(sv) (SvFLAGS(sv) |= (SVf_UTF8)) #define SvUTF8_off(sv) (SvFLAGS(sv) &= ~(SVf_UTF8)) @@ -587,6 +638,8 @@ Set the length of the string which is in the SV. See C<SvCUR>. #define SvAMAGIC_on(sv) (SvFLAGS(sv) |= SVf_AMAGIC) #define SvAMAGIC_off(sv) (SvFLAGS(sv) &= ~SVf_AMAGIC) +#define SvGAMAGIC(sv) (SvFLAGS(sv) & (SVs_GMG|SVf_AMAGIC)) + /* #define Gv_AMG(stash) \ (HV_AMAGICmb(stash) && \ @@ -694,6 +747,7 @@ Set the length of the string which is in the SV. See C<SvCUR>. #define IoIFP(sv) ((XPVIO*) SvANY(sv))->xio_ifp #define IoOFP(sv) ((XPVIO*) SvANY(sv))->xio_ofp #define IoDIRP(sv) ((XPVIO*) SvANY(sv))->xio_dirp +#define IoANY(sv) ((XPVIO*) SvANY(sv))->xio_any #define IoLINES(sv) ((XPVIO*) SvANY(sv))->xio_lines #define IoPAGE(sv) ((XPVIO*) SvANY(sv))->xio_page #define IoPAGE_LEN(sv) ((XPVIO*) SvANY(sv))->xio_page_len @@ -708,6 +762,16 @@ Set the length of the string which is in the SV. See C<SvCUR>. #define IoTYPE(sv) ((XPVIO*) SvANY(sv))->xio_type #define IoFLAGS(sv) ((XPVIO*) SvANY(sv))->xio_flags +/* IoTYPE(sv) is a single character telling the type of I/O connection. */ +#define IoTYPE_RDONLY '<' +#define IoTYPE_WRONLY '>' +#define IoTYPE_RDWR '+' +#define IoTYPE_APPEND 'a' +#define IoTYPE_PIPE '|' +#define IoTYPE_STD '-' /* stdin or stdout */ +#define IoTYPE_SOCKET 's' +#define IoTYPE_CLOSED ' ' + /* =for apidoc Am|bool|SvTAINTED|SV* sv Checks to see if an SV is tainted. Returns TRUE if it is, FALSE if @@ -737,7 +801,6 @@ Taints an SV if tainting is enabled #define SvTAINT(sv) \ STMT_START { \ if (PL_tainting) { \ - dTHR; \ if (PL_tainted) \ SvTAINTED_on(sv); \ } \ @@ -1032,3 +1095,7 @@ Returns a pointer to the character buffer. #define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv)) #define Sv_Grow sv_grow + +#define CLONEf_COPY_STACKS 1 +#define CLONEf_KEEP_PTR_TABLE 2 + diff --git a/contrib/perl5/t/README b/contrib/perl5/t/README index 838434917916..0953026607cc 100644 --- a/contrib/perl5/t/README +++ b/contrib/perl5/t/README @@ -13,4 +13,4 @@ will fail, you may want to use Test::Harness thusly: ./perl -I../lib harness This method pinpoints failed tests automatically. -If you come up with new tests, please send them to larry@wall.org. +If you come up with new tests, please send them to perlbug@perl.org. diff --git a/contrib/perl5/t/TEST b/contrib/perl5/t/TEST index 0b674af3e7ca..bce95454d52e 100755 --- a/contrib/perl5/t/TEST +++ b/contrib/perl5/t/TEST @@ -24,10 +24,10 @@ $ENV{EMXSHELL} = 'sh'; # For OS/2 if ($#ARGV == -1) { @ARGV = split(/[ \n]/, - `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`); + `echo base/*.t comp/*.t cmd/*.t run/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`); } -%infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); +# %infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); _testprogs('perl', @ARGV); _testprogs('compile', @ARGV) if (-e "../testcompile"); @@ -90,9 +90,10 @@ EOT open(RESULTS,"./perl$switch $test |") or print "can't run.\n"; } else { - open(RESULTS, "./perl -I../lib ../utils/perlcc ./$test " - ."-run -verbose dcf -log ../compilelog |") + open(RESULTS, "./perl -I../lib ../utils/perlcc -o ./$test.plc ./$test " + ." && ./$test.plc |") or print "can't compile.\n"; + unlink "./$test.plc"; } $ok = 0; diff --git a/contrib/perl5/t/UTEST b/contrib/perl5/t/UTEST index b5f285bd5999..9c1dfc0d800a 100755 --- a/contrib/perl5/t/UTEST +++ b/contrib/perl5/t/UTEST @@ -81,7 +81,10 @@ EOT if ($type eq 'perl') { open(RESULTS, "./$test |") || (print "can't run.\n"); } else { - open(RESULTS, "./perl -I../lib ../utils/perlcc ./$test -run -verbose dcf -log ../compilelog |") or print "can't compile.\n"; + open(RESULTS, "./perl -I../lib ../utils/perlcc -o ./$test.plc ./$test " + ." && ./$test.plc |") + or print "can't compile.\n"; + unlink "./$test.plc"; } } else { diff --git a/contrib/perl5/t/base/lex.t b/contrib/perl5/t/base/lex.t index d90d404cac91..c7fb0e4cf32a 100755 --- a/contrib/perl5/t/base/lex.t +++ b/contrib/perl5/t/base/lex.t @@ -1,6 +1,6 @@ #!./perl -print "1..46\n"; +print "1..51\n"; $x = 'x'; @@ -206,3 +206,42 @@ EOT print "# $@\nnot ok $test\n" if $@; T '^main:plink:53$', $test++; } + +# tests 47--51 start here +# tests for new array interpolation semantics: +# arrays now *always* interpolate into "..." strings. +# 20000522 MJD (mjd@plover.com) +{ + my $test = 47; + eval(q(">@nosuch<" eq "><")) || print "# $@", "not "; + print "ok $test\n"; + ++$test; + + # Look at this! This is going to be a common error in the future: + eval(q("fred@example.com" eq "fred.com")) || print "# $@", "not "; + print "ok $test\n"; + ++$test; + + # Let's make sure that normal array interpolation still works right + # For some reason, this appears not to be tested anywhere else. + my @a = (1,2,3); + print +((">@a<" eq ">1 2 3<") ? '' : 'not '), "ok $test\n"; + ++$test; + + # Ditto. + eval(q{@nosuch = ('a', 'b', 'c'); ">@nosuch<" eq ">a b c<"}) + || print "# $@", "not "; + print "ok $test\n"; + ++$test; + + # This isn't actually a lex test, but it's testing the same feature + sub makearray { + my @array = ('fish', 'dog', 'carrot'); + *R::crackers = \@array; + } + + eval(q{makearray(); ">@R::crackers<" eq ">fish dog carrot<"}) + || print "# $@", "not "; + print "ok $test\n"; + ++$test; +} diff --git a/contrib/perl5/t/base/rs.t b/contrib/perl5/t/base/rs.t index 021d699e2e87..e470f3a30c11 100755 --- a/contrib/perl5/t/base/rs.t +++ b/contrib/perl5/t/base/rs.t @@ -6,6 +6,8 @@ print "1..14\n"; $teststring = "1\n12\n123\n1234\n1234\n12345\n\n123456\n1234567\n"; # Create our test datafile +1 while unlink 'foo'; # in case junk left around +rmdir 'foo'; open TESTFILE, ">./foo" or die "error $! $^E opening"; binmode TESTFILE; print TESTFILE $teststring; diff --git a/contrib/perl5/t/base/term.t b/contrib/perl5/t/base/term.t index 638069482f83..818eb711a675 100755 --- a/contrib/perl5/t/base/term.t +++ b/contrib/perl5/t/base/term.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Config; @@ -51,5 +51,5 @@ else { die "/dev/null IS NOT A CHARACTER SPECIAL FILE!!!!\n" unless -c '/dev/null'; } -open(try, "../Configure") || (die "Can't open ../Configure."); +open(try, "harness") || (die "Can't open harness."); if (<try> ne '') {print "ok 7\n";} else {print "not ok 7\n";} diff --git a/contrib/perl5/t/comp/bproto.t b/contrib/perl5/t/comp/bproto.t index 01efb8401cc0..70748be551c2 100755 --- a/contrib/perl5/t/comp/bproto.t +++ b/contrib/perl5/t/comp/bproto.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..10\n"; diff --git a/contrib/perl5/t/comp/colon.t b/contrib/perl5/t/comp/colon.t index dee5330ff27b..d2c64fe4c535 100755 --- a/contrib/perl5/t/comp/colon.t +++ b/contrib/perl5/t/comp/colon.t @@ -9,7 +9,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use strict; diff --git a/contrib/perl5/t/comp/cpp.t b/contrib/perl5/t/comp/cpp.t index bbff38c55379..5b061ee18199 100755 --- a/contrib/perl5/t/comp/cpp.t +++ b/contrib/perl5/t/comp/cpp.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Config; diff --git a/contrib/perl5/t/comp/proto.t b/contrib/perl5/t/comp/proto.t index ee17088be2e6..99dd3ea8ba74 100755 --- a/contrib/perl5/t/comp/proto.t +++ b/contrib/perl5/t/comp/proto.t @@ -11,12 +11,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use strict; -print "1..107\n"; +print "1..122\n"; my $i = 1; @@ -293,6 +293,25 @@ printf "ok %d\n",$i++; ## ## +testing \&a_subx, '\&'; + +sub a_subx (\&) { + print "# \@_ = (",join(",",@_),")\n"; + &{$_[0]}; +} + +sub tmp_sub_2 { printf "ok %d\n",$i++ } +a_subx &tmp_sub_2; + +@array = ( \&tmp_sub_2 ); +eval 'a_subx @array'; +print "not " unless $@; +printf "ok %d\n",$i++; + +## +## +## + testing \&sub_aref, '&\@'; sub sub_aref (&\@) { @@ -466,3 +485,14 @@ sub sreftest (\$$) { sreftest($helem{$i}, $i++); sreftest $aelem[0], $i++; } + +# test prototypes when they are evaled and there is a syntax error +# +for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) { + no warnings 'redefine'; + my $eval = "sub evaled_subroutine $p { &void *; }"; + eval $eval; + # The /Syntax error/ is seen on OS/390. It's /syntax error/ elsewhere + print "# eval[$eval]\nnot " unless $@ && $@ =~ /[Ss]yntax error/; + print "ok ", $i++, "\n"; +} diff --git a/contrib/perl5/t/comp/require.t b/contrib/perl5/t/comp/require.t index 1d9268735569..1b0af9ff5e80 100755 --- a/contrib/perl5/t/comp/require.t +++ b/contrib/perl5/t/comp/require.t @@ -2,12 +2,21 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, ('.', '../lib'); + @INC = '.'; + push @INC, '../lib'; } # don't make this lexical $i = 1; -print "1..20\n"; +# Tests 21 .. 23 work only with non broken UTF16-as-code implementations, +# i.e. not EBCDIC Perls. +my $Is_EBCDIC = ord('A') == 193 ? 1 : 0; +if ($Is_EBCDIC) { + print "1..20\n"; +} +else { + print "1..23\n"; +} sub do_require { %INC = (); @@ -19,6 +28,8 @@ sub do_require { sub write_file { my $f = shift; open(REQ,">$f") or die "Can't write '$f': $!"; + binmode REQ; + use bytes; print REQ @_; close REQ; } @@ -122,7 +133,21 @@ do "bleah.do"; dofile(); sub dofile { do "bleah.do"; }; print $x; -$i++; + +exit if $Is_EBCDIC; + +# UTF-encoded things +my $utf8 = chr(0xFEFF); + +$i++; do_require(qq(${utf8}print "ok $i\n"; 1;\n)); + +sub bytes_to_utf16 { + my $utf16 = pack("$_[0]*", unpack("C*", $_[1])); + return @_ == 3 && $_[2] ? pack("$_[0]", 0xFEFF) . $utf16 : $utf16; +} + +$i++; do_require(bytes_to_utf16('n', qq(print "ok $i\\n"; 1;\n), 1)); # BE +$i++; do_require(bytes_to_utf16('v', qq(print "ok $i\\n"; 1;\n), 1)); # LE END { 1 while unlink 'bleah.pm'; 1 while unlink 'bleah.do'; } diff --git a/contrib/perl5/t/comp/use.t b/contrib/perl5/t/comp/use.t index 1f5fae39a217..fb597770d0a8 100755 --- a/contrib/perl5/t/comp/use.t +++ b/contrib/perl5/t/comp/use.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..27\n"; diff --git a/contrib/perl5/t/harness b/contrib/perl5/t/harness index e1a4dd7861b2..c24d46f34da6 100644 --- a/contrib/perl5/t/harness +++ b/contrib/perl5/t/harness @@ -42,12 +42,12 @@ foreach (keys %datahandle) { Test::Harness::runtests @tests; exit(0) unless -e "../testcompile"; -%infinite = qw ( - op/bop.t 1 - lib/hostname.t 1 - op/lex_assign.t 1 - lib/ph.t 1 - ); +# %infinite = qw ( +# op/bop.t 1 +# lib/hostname.t 1 +# op/lex_assign.t 1 +# lib/ph.t 1 +# ); my $dhwrapper = <<'EOT'; open DATA,"<".__FILE__; diff --git a/contrib/perl5/t/io/argv.t b/contrib/perl5/t/io/argv.t index d6093f90ef54..2b8f23b426e7 100755 --- a/contrib/perl5/t/io/argv.t +++ b/contrib/perl5/t/io/argv.t @@ -2,10 +2,10 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -print "1..20\n"; +print "1..21\n"; use File::Spec; @@ -107,18 +107,20 @@ print "ok 15\n"; local $/; open F, 'Io_argv1.tmp' or die; <F>; # set $. = 1 + print "not " if defined(<F>); # should hit eof + print "ok 16\n"; open F, $devnull or die; print "not " unless defined(<F>); - print "ok 16\n"; - print "not " if defined(<F>); print "ok 17\n"; print "not " if defined(<F>); print "ok 18\n"; + print "not " if defined(<F>); + print "ok 19\n"; open F, $devnull or die; # restart cycle again print "not " unless defined(<F>); - print "ok 19\n"; - print "not " if defined(<F>); print "ok 20\n"; + print "not " if defined(<F>); + print "ok 21\n"; close F; } diff --git a/contrib/perl5/t/io/fs.t b/contrib/perl5/t/io/fs.t index 970e2f32aeca..8170b33eccef 100755 --- a/contrib/perl5/t/io/fs.t +++ b/contrib/perl5/t/io/fs.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Config; @@ -115,7 +115,15 @@ if ($wd =~ m#/afs/# || $^O eq 'amigaos' || $^O eq 'dos' || $^O eq 'MSWin32') {print "ok 18 # skipped: granularity of the filetime\n";} elsif ($atime == 500000000 && $mtime == 500000000 + $delta) {print "ok 18\n";} -else +elsif ($^O =~ /\blinux\b/i) { + # Maybe stat() cannot get the correct atime, as happens via NFS on linux? + $foo = (utime 400000000,500000000 + 2*$delta,'b'); + my ($new_atime, $new_mtime) = (stat('b'))[8,9]; + if ($new_atime == $atime && $new_mtime - $mtime == $delta) + {print "ok 18 # accounted for possible NFS/glibc2.2 bug on linux\n";} + else + {print "not ok 18 $atime/$new_atime $mtime/$new_mtime\n";} +} else {print "not ok 18 $atime $mtime\n";} if ((unlink 'b') == 1) {print "ok 19\n";} else {print "not ok 19\n";} @@ -129,10 +137,15 @@ chdir $wd || die "Can't cd back to $wd"; unlink 'c'; if ($^O ne 'MSWin32' and `ls -l perl 2>/dev/null` =~ /^l.*->/) { # we have symbolic links - if (symlink("TEST","c")) {print "ok 21\n";} else {print "not ok 21\n";} - $foo = `grep perl c`; + system("cp TEST TEST$$"); + # we have to copy because e.g. GNU grep 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) + if (symlink("TEST$$","c")) {print "ok 21\n";} else {print "not ok 21\n";} + $foo = `grep perl c 2>&1`; if ($foo) {print "ok 22\n";} else {print "not ok 22\n";} unlink 'c'; + unlink("TEST$$"); } else { print "ok 21\nok 22\n"; diff --git a/contrib/perl5/t/io/open.t b/contrib/perl5/t/io/open.t index 30db5988b6af..0e2d57cd757e 100755 --- a/contrib/perl5/t/io/open.t +++ b/contrib/perl5/t/io/open.t @@ -2,13 +2,14 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } # $RCSfile$ $| = 1; use warnings; $Is_VMS = $^O eq 'VMS'; +$Is_Dos = $^O eq 'dos'; print "1..66\n"; @@ -268,13 +269,21 @@ ok; { local *F; for (1..2) { - open(F, "echo #foo|") or print "not "; + if ($Is_Dos) { + open(F, "echo \\#foo|") or print "not "; + } else { + open(F, "echo #foo|") or print "not "; + } print <F>; close F; } ok; for (1..2) { - open(F, "-|", "echo #foo") or print "not "; + if ($Is_Dos) { + open(F, "-|", "echo \\#foo") or print "not "; + } else { + open(F, "-|", "echo #foo") or print "not "; + } print <F>; close F; } diff --git a/contrib/perl5/t/io/openpid.t b/contrib/perl5/t/io/openpid.t index 80c6bde5d1f0..7c04a29fe81f 100755 --- a/contrib/perl5/t/io/openpid.t +++ b/contrib/perl5/t/io/openpid.t @@ -9,17 +9,15 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; if ($^O eq 'dos') { print "1..0 # Skip: no multitasking\n"; exit 0; } } - -use FileHandle; use Config; -autoflush STDOUT 1; +$| = 1; $SIG{PIPE} = 'IGNORE'; print "1..10\n"; @@ -33,10 +31,8 @@ $perl = qq[$^X "-I../lib"]; # the other reader reads one line, waits a few seconds and then # exits to test the waitpid function. # -$cmd1 = qq/$perl -e "use FileHandle; autoflush STDOUT 1; / . - qq/print qq[first process\\n]; sleep 30;"/; -$cmd2 = qq/$perl -e "use FileHandle; autoflush STDOUT 1; / . - qq/print qq[second process\\n]; sleep 30;"/; +$cmd1 = qq/$perl -e "\$|=1; print qq[first process\\n]; sleep 30;"/; +$cmd2 = qq/$perl -e "\$|=1; print qq[second process\\n]; sleep 30;"/; $cmd3 = qq/$perl -e "print <>;"/; # hangs waiting for end of STDIN $cmd4 = qq/$perl -e "print scalar <>;"/; @@ -76,9 +72,9 @@ print "not " unless $kill_cnt == 2; print "ok 8\n"; # send one expected line of text to child process and then wait for it -autoflush FH4 1; +select(FH4); $| = 1; select(STDOUT); + print FH4 "ok 9\n"; -print "ok 9 # skip VMS\n" if $^O eq 'VMS'; print "# waiting for process $pid4 to exit\n"; $reap_pid = waitpid $pid4, 0; print "# reaped pid $reap_pid != $pid4\nnot " diff --git a/contrib/perl5/t/io/pipe.t b/contrib/perl5/t/io/pipe.t index 4559624ccaf2..96935e3f88c0 100755 --- a/contrib/perl5/t/io/pipe.t +++ b/contrib/perl5/t/io/pipe.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; unless ($Config{'d_fork'}) { print "1..0 # Skip: no fork\n"; diff --git a/contrib/perl5/t/io/tell.t b/contrib/perl5/t/io/tell.t index b89aefb23057..c840c9232a1b 100755 --- a/contrib/perl5/t/io/tell.t +++ b/contrib/perl5/t/io/tell.t @@ -2,14 +2,14 @@ # $RCSfile: tell.t,v $$Revision$$Date$ -print "1..21\n"; +print "1..23\n"; $TST = 'tst'; $Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2' or $^O eq 'mint' or $^O eq 'cygwin'); -open($TST, '../Configure') || (die "Can't open ../Configure"); +open($TST, 'harness') || (die "Can't open harness"); binmode $TST if $Is_Dosish; if (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; } @@ -49,7 +49,7 @@ unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; } if ($. == 0) { print "not ok 14\n"; } else { print "ok 14\n"; } $curline = $.; -open(other, '../Configure') || (die "Can't open ../Configure"); +open(other, 'harness') || (die "Can't open harness: $!"); binmode other if $^O eq 'MSWin32'; { @@ -82,3 +82,13 @@ if ($. == $curline) { print "ok 20\n"; } else { print "not ok 20\n"; } tell other; if ($. == 7) { print "ok 21\n"; } else { print "not ok 21\n"; } } + +close(other); +if (tell(other) == -1) { print "ok 22\n"; } else { print "not ok 22\n"; } + +if (tell(ether) == -1) { print "ok 23\n"; } else { print "not ok 23\n"; } + +# ftell(STDIN) (or any std streams) is undefined, it can return -1 or +# something else. ftell() on pipes, fifos, and sockets is defined to +# return -1. + diff --git a/contrib/perl5/t/lib/abbrev.t b/contrib/perl5/t/lib/abbrev.t index 05e5c70cac94..fb5a9841eb1b 100755 --- a/contrib/perl5/t/lib/abbrev.t +++ b/contrib/perl5/t/lib/abbrev.t @@ -4,7 +4,7 @@ print "1..7\n"; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Text::Abbrev; diff --git a/contrib/perl5/t/lib/ansicolor.t b/contrib/perl5/t/lib/ansicolor.t index 3e16dce653a9..f38e905cdd8c 100755 --- a/contrib/perl5/t/lib/ansicolor.t +++ b/contrib/perl5/t/lib/ansicolor.t @@ -1,8 +1,6 @@ -#!./perl - BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } # Test suite for the Term::ANSIColor Perl module. Before `make install' is @@ -13,7 +11,7 @@ BEGIN { # Ensure module can be loaded ############################################################################ -BEGIN { $| = 1; print "1..7\n" } +BEGIN { $| = 1; print "1..8\n" } END { print "not ok 1\n" unless $loaded } use Term::ANSIColor qw(:constants color colored); $loaded = 1; @@ -71,3 +69,13 @@ if (colored ("test\ntest\r\r\n\r\n", 'bold') } else { print "not ok 7\n"; } + +# Test the array ref form. +$Term::ANSIColor::EACHLINE = "\n"; +if (colored (['bold', 'on_green'], "test\n", "\n", "test") + eq "\e[1;42mtest\e[0m\n\n\e[1;42mtest\e[0m") { + print "ok 8\n"; +} else { + print colored (['bold', 'on_green'], "test\n", "\n", "test"); + print "not ok 8\n"; +} diff --git a/contrib/perl5/t/lib/anydbm.t b/contrib/perl5/t/lib/anydbm.t index e38c7e78604c..40c436628fed 100755 --- a/contrib/perl5/t/lib/anydbm.t +++ b/contrib/perl5/t/lib/anydbm.t @@ -4,10 +4,14 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; + require Config; import Config; + if (($Config{'extensions'} !~ /\b(DB|[A-Z]DBM)_File\b/) ){ + print "1..0 # Skipping (no DB_File or [A-Z]DBM_File)\n"; + exit 0; + } } require AnyDBM_File; -#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; print "1..12\n"; diff --git a/contrib/perl5/t/lib/attrs.t b/contrib/perl5/t/lib/attrs.t index eb8c8c4a1aa0..440122c2b4b3 100755 --- a/contrib/perl5/t/lib/attrs.t +++ b/contrib/perl5/t/lib/attrs.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; eval 'require attrs; 1' or do { print "1..0\n"; exit 0; diff --git a/contrib/perl5/t/lib/autoloader.t b/contrib/perl5/t/lib/autoloader.t index 3bf690bbdd96..b53b9feeae8a 100755 --- a/contrib/perl5/t/lib/autoloader.t +++ b/contrib/perl5/t/lib/autoloader.t @@ -3,7 +3,8 @@ BEGIN { chdir 't' if -d 't'; $dir = "auto-$$"; - unshift @INC, ("./$dir", "../lib"); + @INC = $dir; + push @INC, '../lib'; } print "1..11\n"; diff --git a/contrib/perl5/t/lib/basename.t b/contrib/perl5/t/lib/basename.t index 478e26a8a5ca..9bee1bfb8ba4 100755 --- a/contrib/perl5/t/lib/basename.t +++ b/contrib/perl5/t/lib/basename.t @@ -2,12 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use File::Basename qw(fileparse basename dirname); -print "1..36\n"; +print "1..41\n"; # import correctly? print +(defined(&basename) && !defined(&fileparse_set_fstype) ? @@ -96,29 +96,34 @@ print +(basename(':arma:virumque:cano.trojae') eq 'cano.trojae' ? '' : 'not '),"ok 25\n"; print +(dirname(':arma:virumque:cano.trojae') eq ':arma:virumque:' ? '' : 'not '),"ok 26\n"; -print +(dirname('arma:') eq 'arma:' ? '' : 'not '),"ok 27\n"; -print +(dirname(':') eq ':' ? '' : 'not '),"ok 28\n"; +print +(dirname(':arma:virumque:') eq ':arma:' ? '' : 'not '),"ok 27\n"; +print +(dirname(':arma:virumque') eq ':arma:' ? '' : 'not '),"ok 28\n"; +print +(dirname(':arma:') eq ':' ? '' : 'not '),"ok 29\n"; +print +(dirname(':arma') eq ':' ? '' : 'not '),"ok 30\n"; +print +(dirname('arma:') eq 'arma:' ? '' : 'not '),"ok 31\n"; +print +(dirname('arma') eq ':' ? '' : 'not '),"ok 32\n"; +print +(dirname(':') eq ':' ? '' : 'not '),"ok 33\n"; # Check quoting of metacharacters in suffix arg by basename() print +(basename(':arma:virumque:cano.trojae','.trojae') eq 'cano' ? - '' : 'not '),"ok 29\n"; + '' : 'not '),"ok 34\n"; print +(basename(':arma:virumque:cano_trojae','.trojae') eq 'cano_trojae' ? - '' : 'not '),"ok 30\n"; + '' : 'not '),"ok 35\n"; # extra tests for a few specific bugs File::Basename::fileparse_set_fstype 'MSDOS'; # perl5.003_18 gives C:/perl/.\ -print +((fileparse 'C:/perl/lib')[1] eq 'C:/perl/' ? '' : 'not '), "ok 31\n"; +print +((fileparse 'C:/perl/lib')[1] eq 'C:/perl/' ? '' : 'not '), "ok 36\n"; # perl5.003_18 gives C:\perl\ -print +(dirname('C:\\perl\\lib\\') eq 'C:\\perl' ? '' : 'not '), "ok 32\n"; +print +(dirname('C:\\perl\\lib\\') eq 'C:\\perl' ? '' : 'not '), "ok 37\n"; File::Basename::fileparse_set_fstype 'UNIX'; # perl5.003_18 gives '.' -print +(dirname('/perl/') eq '/' ? '' : 'not '), "ok 33\n"; +print +(dirname('/perl/') eq '/' ? '' : 'not '), "ok 38\n"; # perl5.003_18 gives '/perl/lib' -print +(dirname('/perl/lib//') eq '/perl' ? '' : 'not '), "ok 34\n"; +print +(dirname('/perl/lib//') eq '/perl' ? '' : 'not '), "ok 39\n"; # The empty tainted value, for tainting strings my $TAINT = substr($^X, 0, 0); @@ -134,6 +139,6 @@ sub all_tainted (@) { 1; } -print +(tainted(dirname($TAINT.'/perl/lib//')) ? '' : 'not '), "ok 35\n"; +print +(tainted(dirname($TAINT.'/perl/lib//')) ? '' : 'not '), "ok 40\n"; print +(all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+')) - ? '' : 'not '), "ok 36\n"; + ? '' : 'not '), "ok 41\n"; diff --git a/contrib/perl5/t/lib/bigfltpm.t b/contrib/perl5/t/lib/bigfltpm.t index 5d97f1b4f650..aa4565167d97 100755 --- a/contrib/perl5/t/lib/bigfltpm.t +++ b/contrib/perl5/t/lib/bigfltpm.t @@ -9,7 +9,7 @@ use Math::BigFloat; $test = 0; $| = 1; -print "1..362\n"; +print "1..370\n"; while (<DATA>) { chop; if (s/^&//) { @@ -51,6 +51,8 @@ while (<DATA>) { $try .= "\$x * \$y;"; } elsif ($f eq "fdiv") { $try .= "\$x / \$y;"; + } elsif ($f eq "fmod") { + $try .= "\$x % \$y;"; } else { warn "Unknown op"; } } #print ">>>",$try,"<<<\n"; @@ -65,22 +67,26 @@ while (<DATA>) { print "# '$try' expected: /$pat/ got: '$ans1'\n"; } } - elsif ("$ans1" eq $ans) { #bug! - print "ok $test\n"; - } else { - print "not ok $test\n"; - print "# '$try' expected: '$ans' got: '$ans1'\n"; - } + else { + + $ans1_str = defined $ans1? "$ans1" : ""; + if ($ans1_str eq $ans) { #bug! + print "ok $test\n"; + } else { + print "not ok $test\n"; + print "# '$try' expected: '$ans' got: '$ans1'\n"; + } + } } -} +} __END__ &fnorm -abc:NaN. - 1 a:NaN. -1bcd2:NaN. -11111b:NaN. -+1z:NaN. --1z:NaN. +abc:NaN + 1 a:NaN +1bcd2:NaN +11111b:NaN ++1z:NaN +-1z:NaN 0:0. +0:0. +00:0. @@ -98,7 +104,7 @@ abc:NaN. -001:-1. -123456789:-123456789. -00000100000:-100000. -123.456a:NaN. +123.456a:NaN 123.456:123.456 0.01:.01 .002:.002 @@ -113,7 +119,7 @@ abc:NaN. -3e111:-3000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000. -4e-1111:-.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004 &fneg -abd:NaN. +abc:NaN +0:0. +1:-1. -1:1. @@ -122,7 +128,7 @@ abd:NaN. +123.456789:-123.456789 -123456.789:123456.789 &fabs -abc:NaN. +abc:NaN +0:0. +1:1. -1:1. @@ -249,13 +255,13 @@ $Math::BigFloat::rnd_mode = 'even' -6.23:-1:/-6.2(?:0{5}\d+)? +6.27:-1:/6.(?:3|29{5}\d+) -6.27:-1:/-6.(?:3|29{5}\d+) -+6.25:-1:/6.2(?:0{5}\d+)? --6.25:-1:/-6.2(?:0{5}\d+)? -+6.35:-1:/6.(?:4|39{5}\d+) --6.35:-1:/-6.(?:4|39{5}\d+) ++6.25:-1:/6.(?:2(?:0{5}\d+)?|29{5}\d+) +-6.25:-1:/-6.(?:2(?:0{5}\d+)?|29{5}\d+) ++6.35:-1:/6.(?:4|39{5}\d+|29{8}\d+) +-6.35:-1:/-6.(?:4|39{5}\d+|29{8}\d+) -0.0065:-1:0 -0.0065:-2:/-0\.01|-1e-02 --0.0065:-3:/-0\.006|-6e-03 +-0.0065:-3:/-0\.006|-7e-03 -0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 &fcmp @@ -286,9 +292,9 @@ abc:+0: -123:-124:1 -124:-123:-1 &fadd -abc:abc:NaN. -abc:+0:NaN. -+0:abc:NaN. +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN +0:+0:0. +1:+0:1. +0:+1:1. @@ -324,9 +330,9 @@ abc:+0:NaN. -123456789:-987654321:-1111111110. +123456789:-987654321:-864197532. &fsub -abc:abc:NaN. -abc:+0:NaN. -+0:abc:NaN. +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN +0:+0:0. +1:+0:1. +0:+1:-1. @@ -362,9 +368,9 @@ abc:+0:NaN. -123456789:-987654321:864197532. +123456789:-987654321:1111111110. &fmul -abc:abc:NaN. -abc:+0:NaN. -+0:abc:NaN. +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN +0:+0:0. +0:+1:0. +1:+0:0. @@ -395,14 +401,14 @@ abc:+0:NaN. +88888888888:+9:799999999992. +99999999999:+9:899999999991. &fdiv -abc:abc:NaN. -abc:+1:abc:NaN. -+1:abc:NaN. -+0:+0:NaN. +abc:abc:NaN +abc:+1:abc:NaN ++1:abc:NaN ++0:+0:NaN +0:+1:0. -+1:+0:NaN. ++1:+0:NaN +0:-1:0. --1:+0:NaN. +-1:+0:NaN +1:+1:1. -1:-1:1. +1:-1:-1. @@ -461,3 +467,12 @@ $Math::BigFloat::div_scale = 40 +100:10. +123.456:11.11107555549866648462149404118219234119 +15241.383936:123.456 +&fmod ++0:0:NaN ++0:1:0. ++3:1:0. ++5:2:1. ++9:4:1. ++9:5:4. ++9000:56:40. ++56:9000:56. diff --git a/contrib/perl5/t/lib/bigint.t b/contrib/perl5/t/lib/bigint.t index d2d520ea3c5f..034c5c645710 100755 --- a/contrib/perl5/t/lib/bigint.t +++ b/contrib/perl5/t/lib/bigint.t @@ -1,6 +1,6 @@ #!./perl -BEGIN { unshift @INC, '../lib' } +BEGIN { @INC = '../lib' } require "bigint.pl"; $test = 0; diff --git a/contrib/perl5/t/lib/bigintpm.t b/contrib/perl5/t/lib/bigintpm.t index ae362e20c9f6..e76f246f1853 100755 --- a/contrib/perl5/t/lib/bigintpm.t +++ b/contrib/perl5/t/lib/bigintpm.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Math::BigInt; diff --git a/contrib/perl5/t/lib/cgi-form.t b/contrib/perl5/t/lib/cgi-form.t index e3cba5fc2054..292290349920 100755 --- a/contrib/perl5/t/lib/cgi-form.t +++ b/contrib/perl5/t/lib/cgi-form.t @@ -1,13 +1,14 @@ -#!./perl - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. +#!/usr/local/bin/perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + chdir('t') if -d 't'; + @INC = '../lib'; } +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. +use lib '../blib/lib','../blib/arch'; + BEGIN {$| = 1; print "1..17\n"; } END {print "not ok 1\n" unless $loaded;} use CGI (':standard','-no_debug'); @@ -23,6 +24,15 @@ sub test { print($true ? "ok $num\n" : "not ok $num $msg\n"); } +my $CRLF = "\015\012"; +if ($^O eq 'VMS') { + $CRLF = "\n"; # via web server carriage is inserted automatically +} +if (ord("\t") != 9) { # EBCDIC? + $CRLF = "\r\n"; +} + + # Set up a CGI environment $ENV{REQUEST_METHOD}='GET'; $ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; @@ -33,49 +43,48 @@ $ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; $ENV{SERVER_PORT} = 8080; $ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; -test(2,start_form(-action=>'foobar',-method=>GET) eq - qq(<FORM METHOD="GET" ACTION="foobar" ENCTYPE="application/x-www-form-urlencoded">\n), +test(2,start_form(-action=>'foobar',-method=>'get') eq + qq(<form method="get" action="foobar" enctype="application/x-www-form-urlencoded">\n), "start_form()"); -test(3,submit() eq qq(<INPUT TYPE="submit" NAME=".submit">),"submit()"); -test(4,submit(-name=>'foo',-value=>'bar') eq qq(<INPUT TYPE="submit" NAME="foo" VALUE="bar">),"submit(-name,-value)"); -test(5,submit({-name=>'foo',-value=>'bar'}) eq qq(<INPUT TYPE="submit" NAME="foo" VALUE="bar">),"submit({-name,-value})"); -test(6,textfield(-name=>'weather') eq qq(<INPUT TYPE="text" NAME="weather" VALUE="dull">),"textfield({-name})"); -test(7,textfield(-name=>'weather',-value=>'nice') eq qq(<INPUT TYPE="text" NAME="weather" VALUE="dull">),"textfield({-name,-value})"); -test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(<INPUT TYPE="text" NAME="weather" VALUE="nice">), +test(3,submit() eq qq(<input type="submit" name=".submit" />),"submit()"); +test(4,submit(-name=>'foo',-value=>'bar') eq qq(<input type="submit" name="foo" value="bar" />),"submit(-name,-value)"); +test(5,submit({-name=>'foo',-value=>'bar'}) eq qq(<input type="submit" name="foo" value="bar" />),"submit({-name,-value})"); +test(6,textfield(-name=>'weather') eq qq(<input type="text" name="weather" value="dull" />),"textfield({-name})"); +test(7,textfield(-name=>'weather',-value=>'nice') eq qq(<input type="text" name="weather" value="dull" />),"textfield({-name,-value})"); +test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(<input type="text" name="weather" value="nice" />), "textfield({-name,-value,-override})"); -test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">weather), +test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(<input type="checkbox" name="weather" value="nice" />weather), "checkbox()"); test(10,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast') eq - qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">forecast), + qq(<input type="checkbox" name="weather" value="nice" />forecast), "checkbox()"); test(11,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast',-checked=>1,-override=>1) eq - qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice" CHECKED>forecast), + qq(<input type="checkbox" name="weather" value="nice" checked />forecast), "checkbox()"); test(12,checkbox(-name=>'weather',-value=>'dull',-label=>'forecast') eq - qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="dull" CHECKED>forecast), + qq(<input type="checkbox" name="weather" value="dull" checked />forecast), "checkbox()"); test(13,radio_group(-name=>'game') eq - qq(<INPUT TYPE="radio" NAME="game" VALUE="chess" CHECKED>chess <INPUT TYPE="radio" NAME="game" VALUE="checkers">checkers), + qq(<input type="radio" name="game" value="chess" checked />chess <input type="radio" name="game" value="checkers" />checkers), 'radio_group()'); test(14,radio_group(-name=>'game',-labels=>{'chess'=>'ping pong'}) eq - qq(<INPUT TYPE="radio" NAME="game" VALUE="chess" CHECKED>ping pong <INPUT TYPE="radio" NAME="game" VALUE="checkers">checkers), + qq(<input type="radio" name="game" value="chess" checked />ping pong <input type="radio" name="game" value="checkers" />checkers), 'radio_group()'); test(15, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/]) eq - qq(<INPUT TYPE="checkbox" NAME="game" VALUE="checkers" CHECKED>checkers <INPUT TYPE="checkbox" NAME="game" VALUE="chess" CHECKED>chess <INPUT TYPE="checkbox" NAME="game" VALUE="cribbage">cribbage), + qq(<input type="checkbox" name="game" value="checkers" checked />checkers <input type="checkbox" name="game" value="chess" checked />chess <input type="checkbox" name="game" value="cribbage" />cribbage), 'checkbox_group()'); -test(16, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/],-Defaults=>['cribbage'],-override=>1) eq - qq(<INPUT TYPE="checkbox" NAME="game" VALUE="checkers">checkers <INPUT TYPE="checkbox" NAME="game" VALUE="chess">chess <INPUT TYPE="checkbox" NAME="game" VALUE="cribbage" CHECKED>cribbage), +test(16, checkbox_group(-name=>'game',-values=>[qw/checkers chess cribbage/],-defaults=>['cribbage'],-override=>1) eq + qq(<input type="checkbox" name="game" value="checkers" />checkers <input type="checkbox" name="game" value="chess" />chess <input type="checkbox" name="game" value="cribbage" checked />cribbage), 'checkbox_group()'); - -test(17, popup_menu(-name=>'game',-Values=>[qw/checkers chess cribbage/],-Default=>'cribbage',-override=>1) eq <<END,'checkbox_group()'); -<SELECT NAME="game"> -<OPTION VALUE="checkers">checkers -<OPTION VALUE="chess">chess -<OPTION SELECTED VALUE="cribbage">cribbage -</SELECT> +test(17, popup_menu(-name=>'game',-values=>[qw/checkers chess cribbage/],-default=>'cribbage',-override=>1) eq <<END,'checkbox_group()'); +<select name="game"> +<option value="checkers">checkers</option> +<option value="chess">chess</option> +<option selected value="cribbage">cribbage</option> +</select> END diff --git a/contrib/perl5/t/lib/cgi-function.t b/contrib/perl5/t/lib/cgi-function.t index b4cd56811f57..3b9722e3bd5e 100755 --- a/contrib/perl5/t/lib/cgi-function.t +++ b/contrib/perl5/t/lib/cgi-function.t @@ -1,14 +1,15 @@ -#!./perl - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. +#!/usr/local/bin/perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + chdir('t') if -d 't'; + @INC = '../lib'; } -BEGIN {$| = 1; print "1..24\n"; } +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. +use lib '../blib/lib','../blib/arch'; + +BEGIN {$| = 1; print "1..27\n"; } END {print "not ok 1\n" unless $loaded;} use Config; use CGI (':standard','keywords'); @@ -24,6 +25,22 @@ sub test { print($true ? "ok $num\n" : "not ok $num $msg\n"); } +my $CRLF = "\015\012"; + +# A peculiarity of sending "\n" through MBX|Socket|web-server on VMS +# is that a CR character gets inserted automatically in the web server +# case but not internal to perl's double quoted strings "\n". This +# test would need to be modified to use the "\015\012" on VMS if it +# were actually run through a web server. +# Thanks to Peter Prymmer for this + +if ($^O eq 'VMS') { $CRLF = "\n"; } + +# Web servers on EBCDIC hosts are typically set up to do an EBCDIC -> ASCII +# translation hence CRLF is used as \r\n within CGI.pm on such machines. + +if (ord("\t") != 9) { $CRLF = "\r\n"; } + # Set up a CGI environment $ENV{REQUEST_METHOD}='GET'; $ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; @@ -36,7 +53,7 @@ $ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; $ENV{HTTP_LOVE} = 'true'; test(2,request_method() eq 'GET',"CGI::request_method()"); -test(3,query_string() eq 'game=chess&game=checkers&weather=dull',"CGI::query_string()"); +test(3,query_string() eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()"); test(4,param() == 2,"CGI::param()"); test(5,join(' ',sort {$a cmp $b} param()) eq 'game weather',"CGI::param()"); test(6,param('game') eq 'chess',"CGI::param()"); @@ -44,18 +61,18 @@ test(7,param('weather') eq 'dull',"CGI::param()"); test(8,join(' ',param('game')) eq 'chess checkers',"CGI::param()"); test(9,param(-name=>'foo',-value=>'bar'),'CGI::param() put'); test(10,param(-name=>'foo') eq 'bar','CGI::param() get'); -test(11,query_string() eq 'game=chess&game=checkers&weather=dull&foo=bar',"CGI::query_string() redux"); +test(11,query_string() eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"); test(12,http('love') eq 'true',"CGI::http()"); test(13,script_name() eq '/cgi-bin/foo.cgi',"CGI::script_name()"); test(14,url() eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"); test(15,self_url() eq - 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess&game=checkers&weather=dull&foo=bar', + 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', "CGI::url()"); test(16,url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'); test(17,url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)'); test(18,url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'); test(19,url(-relative=>1,-path=>1,-query=>1) eq - 'foo.cgi/somewhere/else?game=chess&game=checkers&weather=dull&foo=bar', + 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', 'CGI::url(-relative=>1,-path=>1,-query=>1)'); Delete('foo'); test(20,!param('foo'),'CGI::delete()'); @@ -65,21 +82,25 @@ $ENV{QUERY_STRING}='mary+had+a+little+lamb'; test(21,join(' ',keywords()) eq 'mary had a little lamb','CGI::keywords'); test(22,join(' ',param('keywords')) eq 'mary had a little lamb','CGI::keywords'); -if (!$Config{d_fork} or $^O eq 'MSWin32' or $^O eq 'VMS') { - for (23,24) { print "ok $_ # Skipped: fork n/a\n" } -} -else { - CGI::_reset_globals; - $test_string = 'game=soccer&game=baseball&weather=nice'; - $ENV{REQUEST_METHOD}='POST'; - $ENV{CONTENT_LENGTH}=length($test_string); - $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; - if (open(CHILD,"|-")) { # cparent - print CHILD $test_string; - close CHILD; - exit 0; - } - # at this point, we're in a new (child) process - test(23,param('weather') eq 'nice',"CGI::param() from POST"); - test(24,url_param('big_balls') eq 'basketball',"CGI::url_param()"); +CGI::_reset_globals; +if ($Config{d_fork}) { + $test_string = 'game=soccer&game=baseball&weather=nice'; + $ENV{REQUEST_METHOD}='POST'; + $ENV{CONTENT_LENGTH}=length($test_string); + $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; + if (open(CHILD,"|-")) { # cparent + print CHILD $test_string; + close CHILD; + exit 0; + } + # at this point, we're in a new (child) process + test(23,param('weather') eq 'nice',"CGI::param() from POST"); + test(24,(url_param('big_balls') eq 'basketball'),"CGI::url_param()"); +} else { + print "ok 23 # Skip\n"; + print "ok 24 # Skip\n"; } +test(25,redirect('http://somewhere.else') eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}${CRLF}","CGI::redirect() 1"); +my $h = redirect(-Location=>'http://somewhere.else',-Type=>'text/html'); +test(26,$h eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2"); +test(27,redirect(-Location=>'http://somewhere.else/bin/foo&bar',-Type=>'text/html') eq "Status: 302 Moved${CRLF}location: http://somewhere.else/bin/foo&bar${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2"); diff --git a/contrib/perl5/t/lib/cgi-html.t b/contrib/perl5/t/lib/cgi-html.t index 43d41ec10fe4..93e5dac648a3 100755 --- a/contrib/perl5/t/lib/cgi-html.t +++ b/contrib/perl5/t/lib/cgi-html.t @@ -1,15 +1,15 @@ -#!./perl - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. +#!/usr/local/bin/perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; - require Config; import Config; + chdir('t') if -d 't'; + @INC = '../lib'; } -BEGIN {$| = 1; print "1..20\n"; } +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. +use lib '../blib/lib','../blib/arch'; + +BEGIN {$| = 1; print "1..24\n"; } END {print "not ok 1\n" unless $loaded;} use CGI (':standard','-no_debug','*h3','start_table'); $loaded = 1; @@ -17,8 +17,14 @@ print "ok 1\n"; ######################### End of black magic. -my $Is_EBCDIC = $Config{'ebcdic'} eq 'define'; -my $crlf = $CGI::CRLF; +my $CRLF = "\015\012"; +if ($^O eq 'VMS') { + $CRLF = "\n"; # via web server carriage is inserted automatically +} +if (ord("\t") != 9) { # EBCDIC? + $CRLF = "\r\n"; +} + # util sub test { @@ -28,48 +34,62 @@ sub test { } # all the automatic tags -test(2,h1() eq '<H1>',"single tag"); -test(3,h1('fred') eq '<H1>fred</H1>',"open/close tag"); -test(4,h1('fred','agnes','maura') eq '<H1>fred agnes maura</H1>',"open/close tag multiple"); -test(5,h1({-align=>'CENTER'},'fred') eq '<H1 ALIGN="CENTER">fred</H1>',"open/close tag with attribute"); -test(6,h1({-align=>undef},'fred') eq '<H1 ALIGN>fred</H1>',"open/close tag with orphan attribute"); +test(2,h1() eq '<h1 />',"single tag"); +test(3,h1('fred') eq '<h1>fred</h1>',"open/close tag"); +test(4,h1('fred','agnes','maura') eq '<h1>fred agnes maura</h1>',"open/close tag multiple"); +test(5,h1({-align=>'CENTER'},'fred') eq '<h1 align="CENTER">fred</h1>',"open/close tag with attribute"); +test(6,h1({-align=>undef},'fred') eq '<h1 align>fred</h1>',"open/close tag with orphan attribute"); test(7,h1({-align=>'CENTER'},['fred','agnes']) eq - '<H1 ALIGN="CENTER">fred</H1> <H1 ALIGN="CENTER">agnes</H1>', + '<h1 align="CENTER">fred</h1> <h1 align="CENTER">agnes</h1>', "distributive tag with attribute"); { local($") = '-'; - test(8,h1('fred','agnes','maura') eq '<H1>fred-agnes-maura</H1>',"open/close tag \$\" interpolation"); + test(8,h1('fred','agnes','maura') eq '<h1>fred-agnes-maura</h1>',"open/close tag \$\" interpolation"); } - -test(9,header() eq "Content-Type: text/html$crlf$crlf","header()"); -test(10,header(-type=>'image/gif') eq "Content-Type: image/gif$crlf$crlf","header()"); -test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${crlf}Content-Type: image/gif$crlf$crlf","header()"); -test(12,header(-nph=>1) eq "HTTP/1.0 200 OK${crlf}Content-Type: text/html$crlf$crlf","header()"); +test(9,header() eq "Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","header()"); +test(10,header(-type=>'image/gif') eq "Content-Type: image/gif${CRLF}${CRLF}","header()"); +test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${CRLF}Content-Type: image/gif${CRLF}${CRLF}","header()"); +test(12,header(-nph=>1) =~ m!HTTP/1.0 200 OK${CRLF}Server: cmdline${CRLF}Date:.+${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!,"header()"); test(13,start_html() ."\n" eq <<END,"start_html()"); -<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN"> -<HTML><HEAD><TITLE>Untitled Document</TITLE> -</HEAD><BODY> +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE html + PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" + "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title> +</head><body> END ; test(14,start_html(-dtd=>"-//IETF//DTD HTML 3.2//FR") ."\n" eq <<END,"start_html()"); -<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 3.2//FR"> -<HTML><HEAD><TITLE>Untitled Document</TITLE> -</HEAD><BODY> +<!DOCTYPE html + PUBLIC "-//IETF//DTD HTML 3.2//FR"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title> +</head><body> END ; test(15,start_html(-Title=>'The world of foo') ."\n" eq <<END,"start_html()"); -<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN"> -<HTML><HEAD><TITLE>The world of foo</TITLE> -</HEAD><BODY> +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE html + PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" + "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>The world of foo</title> +</head><body> END ; -test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq - 'fred=chocolate&chip; path=/',"cookie()"); -test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${crlf}Date:.*${crlf}Content-Type: text/html$crlf$crlf!s, - "header(-cookie)"); -test(18,start_h3 eq '<H3>'); -test(19,end_h3 eq '</H3>'); -test(20,start_table({-border=>undef}) eq '<TABLE BORDER>'); - - - +test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq 'fred=chocolate&chip; path=/',"cookie()"); +my $h = header(-Cookie=>$cookie); +test(17,$h =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${CRLF}Date:.*${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!s, + "header(-cookie)"); +test(18,start_h3 eq '<h3>'); +test(19,end_h3 eq '</h3>'); +test(20,start_table({-border=>undef}) eq '<table border>'); +test(21,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> ‹right›</h1>'); +charset('utf-8'); +if (ord("\t") == 9) { +test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> ‹right›</h1>'); +} +else { +test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> »rightº</h1>'); +} +test(23,i(p('hello there')) eq '<i><p>hello there</p></i>'); +my $q = new CGI; +test(24,$q->h1('hi') eq '<h1>hi</h1>'); diff --git a/contrib/perl5/t/lib/cgi-request.t b/contrib/perl5/t/lib/cgi-request.t index 9e8cdc290aca..fde3fd04cf27 100755 --- a/contrib/perl5/t/lib/cgi-request.t +++ b/contrib/perl5/t/lib/cgi-request.t @@ -1,17 +1,18 @@ -#!./perl - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. +#!/usr/local/bin/perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + chdir('t') if -d 't'; + @INC = '../lib'; } -BEGIN {$| = 1; print "1..31\n"; } +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. +use lib '../blib/lib','../blib/arch'; + +BEGIN {$| = 1; print "1..33\n"; } END {print "not ok 1\n" unless $loaded;} -use Config; use CGI (); +use Config; $loaded = 1; print "ok 1\n"; @@ -39,7 +40,7 @@ $ENV{HTTP_LOVE} = 'true'; $q = new CGI; test(2,$q,"CGI::new()"); test(3,$q->request_method eq 'GET',"CGI::request_method()"); -test(4,$q->query_string eq 'game=chess&game=checkers&weather=dull',"CGI::query_string()"); +test(4,$q->query_string eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()"); test(5,$q->param() == 2,"CGI::param()"); test(6,join(' ',sort $q->param()) eq 'game weather',"CGI::param()"); test(7,$q->param('game') eq 'chess',"CGI::param()"); @@ -47,18 +48,18 @@ test(8,$q->param('weather') eq 'dull',"CGI::param()"); test(9,join(' ',$q->param('game')) eq 'chess checkers',"CGI::param()"); test(10,$q->param(-name=>'foo',-value=>'bar'),'CGI::param() put'); test(11,$q->param(-name=>'foo') eq 'bar','CGI::param() get'); -test(12,$q->query_string eq 'game=chess&game=checkers&weather=dull&foo=bar',"CGI::query_string() redux"); +test(12,$q->query_string eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"); test(13,$q->http('love') eq 'true',"CGI::http()"); test(14,$q->script_name eq '/cgi-bin/foo.cgi',"CGI::script_name()"); test(15,$q->url eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"); test(16,$q->self_url eq - 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess&game=checkers&weather=dull&foo=bar', + 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', "CGI::url()"); test(17,$q->url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'); test(18,$q->url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)'); test(19,$q->url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'); test(20,$q->url(-relative=>1,-path=>1,-query=>1) eq - 'foo.cgi/somewhere/else?game=chess&game=checkers&weather=dull&foo=bar', + 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', 'CGI::url(-relative=>1,-path=>1,-query=>1)'); $q->delete('foo'); test(21,!$q->param('foo'),'CGI::delete()'); @@ -73,22 +74,30 @@ test(26,$q->param('foo') eq 'bar','CGI::param() redux'); test(27,$q=new CGI({'foo'=>'bar','bar'=>'froz'}),"CGI::new() redux 2"); test(28,$q->param('bar') eq 'froz',"CGI::param() redux 2"); -if (!$Config{d_fork} or $^O eq 'MSWin32' or $^O eq 'VMS') { - for (29..31) { print "ok $_ # Skipped: fork n/a\n" } -} -else { - $q->_reset_globals; - $test_string = 'game=soccer&game=baseball&weather=nice'; - $ENV{REQUEST_METHOD}='POST'; - $ENV{CONTENT_LENGTH}=length($test_string); - $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; - if (open(CHILD,"|-")) { # cparent - print CHILD $test_string; - close CHILD; - exit 0; - } - # at this point, we're in a new (child) process - test(29,$q=new CGI,"CGI::new() from POST"); - test(30,$q->param('weather') eq 'nice',"CGI::param() from POST"); - test(31,$q->url_param('big_balls') eq 'basketball',"CGI::url_param()"); +# test tied interface +my $p = $q->Vars; +test(29,$p->{bar} eq 'froz',"tied interface fetch"); +$p->{bar} = join("\0",qw(foo bar baz)); +test(30,join(' ',$q->param('bar')) eq 'foo bar baz','tied interface store'); + +# test posting +$q->_reset_globals; +if ($Config{d_fork}) { + $test_string = 'game=soccer&game=baseball&weather=nice'; + $ENV{REQUEST_METHOD}='POST'; + $ENV{CONTENT_LENGTH}=length($test_string); + $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; + if (open(CHILD,"|-")) { # cparent + print CHILD $test_string; + close CHILD; + exit 0; + } + # at this point, we're in a new (child) process + test(31,$q=new CGI,"CGI::new() from POST"); + test(32,$q->param('weather') eq 'nice',"CGI::param() from POST"); + test(33,$q->url_param('big_balls') eq 'basketball',"CGI::url_param()"); +} else { + print "ok 31 # Skip\n"; + print "ok 32 # Skip\n"; + print "ok 33 # Skip\n"; } diff --git a/contrib/perl5/t/lib/charnames.t b/contrib/perl5/t/lib/charnames.t index 764339012679..273113602181 100755 --- a/contrib/perl5/t/lib/charnames.t +++ b/contrib/perl5/t/lib/charnames.t @@ -3,12 +3,12 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } $| = 1; -print "1..12\n"; +print "1..15\n"; use charnames ':full'; @@ -42,15 +42,21 @@ EOE $encoded_be = "\320\261"; $encoded_alpha = "\316\261"; $encoded_bet = "\327\221"; +$encoded_deseng = "\360\220\221\215"; + +sub to_bytes { + pack"a*", shift; +} + { use charnames ':full'; - print "not " unless "\N{CYRILLIC SMALL LETTER BE}" eq $encoded_be; + print "not " unless to_bytes("\N{CYRILLIC SMALL LETTER BE}") eq $encoded_be; print "ok 4\n"; use charnames qw(cyrillic greek :short); - print "not " unless "\N{be},\N{alpha},\N{hebrew:bet}" + print "not " unless to_bytes("\N{be},\N{alpha},\N{hebrew:bet}") eq "$encoded_be,$encoded_alpha,$encoded_bet"; print "ok 5\n"; } @@ -72,3 +78,33 @@ $encoded_bet = "\327\221"; print "not " unless sprintf("%vx", "\x{ff}\N{WHITE SMILING FACE}") eq "ff.263a"; print "ok 12\n"; } + +{ + use charnames qw(:full); + use utf8; + + my $x = "\x{221b}"; + my $named = "\N{CUBE ROOT}"; + + print "not " unless ord($x) == ord($named); + print "ok 13\n"; +} + +{ + use charnames qw(:full); + use utf8; + print "not " unless "\x{100}\N{CENT SIGN}" eq "\x{100}"."\N{CENT SIGN}"; + print "ok 14\n"; +} + +{ + use charnames ':full'; + +# XXX this test breaks in 5.6.x because the Unicode database is missing +# "DESERET SMALL LETTER ENG". Uncomment after updating to Unicode 3.1 +# print "not " +# unless to_bytes("\N{DESERET SMALL LETTER ENG}") eq $encoded_deseng; + print "ok 15\n"; + +} + diff --git a/contrib/perl5/t/lib/checktree.t b/contrib/perl5/t/lib/checktree.t index 760357529bde..b5426ca261e7 100755 --- a/contrib/perl5/t/lib/checktree.t +++ b/contrib/perl5/t/lib/checktree.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..1\n"; diff --git a/contrib/perl5/t/lib/complex.t b/contrib/perl5/t/lib/complex.t index a636ff0ab6b4..334374d51936 100755 --- a/contrib/perl5/t/lib/complex.t +++ b/contrib/perl5/t/lib/complex.t @@ -9,12 +9,14 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Math::Complex; -my $VERSION = sprintf("%s", q$Id: complex.t,v 1.9 1998/11/01 00:00:00 dsl Exp $ =~ /(\d+\.d+)/); +use vars qw($VERSION); + +$VERSION = 1.91; my ($args, $op, $target, $test, $test_set, $try, $val, $zvalue, @set, @val); @@ -27,7 +29,7 @@ my @script = ( my $eps = 1e-13; if ($^O eq 'unicos') { # For some reason root() produces very inaccurate - $eps = 1e-11; # results in Cray UNICOS, and occasionally also + $eps = 1e-10; # results in Cray UNICOS, and occasionally also } # cos(), sin(), cosh(), sinh(). The division # of doubles is the current suspect. @@ -159,20 +161,18 @@ test_dbz( 'acsch(0)', 'asec(0)', 'asech(0)', - 'atan(-$i)', 'atan($i)', # 'atanh(-1)', # Log of zero. 'atanh(+1)', 'cot(0)', 'coth(0)', 'csc(0)', - 'tan($pip2)', 'csch(0)', - 'tan($pip2)', ); test_loz( 'log($zero)', + 'atan(-$i)', 'acot(-$i)', 'atanh(-1)', 'acoth(-1)', @@ -187,7 +187,7 @@ sub test_broot { eval 'root(2, $op)'; (\$bad) = (\$@ =~ /(.+)/); print "# $test op = $op badroot? \$bad...\n"; - print 'not ' unless (\$@ =~ /root must be/); + print 'not ' unless (\$@ =~ /root rank must be/); EOT push(@script, qq(print "ok $test\\n";\n)); } @@ -196,6 +196,13 @@ EOT test_broot(qw(-3 -2.1 0 0.99)); sub test_display_format { + $test++; + push @script, <<EOS; + print "# package display_format cartesian?\n"; + print "not " unless Math::Complex->display_format eq 'cartesian'; + print "ok $test\n"; +EOS + push @script, <<EOS; my \$j = (root(1,3))[1]; @@ -204,7 +211,7 @@ EOS $test++; push @script, <<EOS; - print "# display_format polar?\n"; + print "# j display_format polar?\n"; print "not " unless \$j->display_format eq 'polar'; print "ok $test\n"; EOS @@ -264,7 +271,7 @@ EOS $test++; push @script, <<EOS; print "# j = \$j\n"; - print "not " unless "\$j" =~ /^-0\\.5\\+0.86602540\\d+i\$/; + print "not " unless "\$j" =~ /^-0(?:\\.5(?:0000\\d+)?|\\.49999\\d+)\\+0.86602540\\d+i\$/; print "ok $test\n"; \$j->display_format('style' => 'polar', 'polar_pretty_print' => 0); @@ -278,12 +285,20 @@ EOS \$j->display_format('style' => 'cartesian', 'format' => '(%.5g)'); EOS + $test++; push @script, <<EOS; print "# j = \$j\n"; print "not " unless "\$j" eq "(-0.5)+(0.86603)i"; print "ok $test\n"; EOS + + $test++; + push @script, <<EOS; + print "# j display_format cartesian?\n"; + print "not " unless \$j->display_format eq 'cartesian'; + print "ok $test\n"; +EOS } test_display_format(); @@ -894,7 +909,7 @@ __END__ ( 2,-3):( 1.96863792579310, -0.96465850440760) &acosh -(-2.0,0):( -1.31695789692482, 3.14159265358979) +(-2.0,0):( 1.31695789692482, 3.14159265358979) (-1.0,0):( 0, 3.14159265358979) (-0.5,0):( 0, 2.09439510239320) ( 0.0,0):( 0, 1.57079632679490) @@ -904,8 +919,8 @@ __END__ &acosh ( 2, 3):( 1.98338702991654, 1.00014354247380) -(-2, 3):( -1.98338702991653, -2.14144911111600) -(-2,-3):( -1.98338702991653, 2.14144911111600) +(-2, 3):( 1.98338702991653, 2.14144911111600) +(-2,-3):( 1.98338702991653, -2.14144911111600) ( 2,-3):( 1.98338702991654, -1.00014354247380) &atanh @@ -924,15 +939,15 @@ __END__ &asech (-2.0,0):( 0 , 2.09439510239320) (-1.0,0):( 0 , 3.14159265358979) -(-0.5,0):( -1.31695789692482, 3.14159265358979) +(-0.5,0):( 1.31695789692482, 3.14159265358979) ( 0.5,0):( 1.31695789692482, 0 ) ( 1.0,0):( 0 , 0 ) ( 2.0,0):( 0 , 1.04719755119660) &asech ( 2, 3):( 0.23133469857397, -1.42041072246703) -(-2, 3):( -0.23133469857397, 1.72118193112276) -(-2,-3):( -0.23133469857397, -1.72118193112276) +(-2, 3):( 0.23133469857397, -1.72118193112276) +(-2,-3):( 0.23133469857397, 1.72118193112276) ( 2,-3):( 0.23133469857397, 1.42041072246703) &acsch diff --git a/contrib/perl5/t/lib/db-btree.t b/contrib/perl5/t/lib/db-btree.t index b13e50eab769..182282356318 100755 --- a/contrib/perl5/t/lib/db-btree.t +++ b/contrib/perl5/t/lib/db-btree.t @@ -1,7 +1,7 @@ #!./perl -w BEGIN { - unshift @INC, '../lib' if -d '../lib' ; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0 # Skip: DB_File was not built\n"; @@ -9,10 +9,12 @@ BEGIN { } } +use warnings; +use strict; use DB_File; use Fcntl; -print "1..155\n"; +print "1..157\n"; sub ok { @@ -82,7 +84,9 @@ sub docat_del } -$db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ; +my $db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ; +my $null_keys_allowed = ($DB_File::db_ver < 2.004010 + || $DB_File::db_ver >= 3.1 ); my $Dfile = "dbbtree.tmp"; unlink $Dfile; @@ -128,17 +132,19 @@ ok(16, $dbh->{prefix} == 1234 ); # Check that an invalid entry is caught both for store & fetch eval '$dbh->{fred} = 1234' ; ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ; -eval '$q = $dbh->{fred}' ; +eval 'my $q = $dbh->{fred}' ; ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ; # Now check the interface to BTREE +my ($X, %h) ; ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ; -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32'); +my ($key, $value, $i); while (($key,$value) = each(%h)) { $i++; } @@ -209,8 +215,8 @@ $h{'goner3'} = 'snork'; delete $h{'goner1'}; $X->DELETE('goner3'); -@keys = keys(%h); -@values = values(%h); +my @keys = keys(%h); +my @values = values(%h); ok(27, $#keys == 29 && $#values == 29) ; @@ -235,12 +241,19 @@ ok(30, ArrayCompare(\@b, \@c)) ; $h{'foo'} = ''; ok(31, $h{'foo'} eq '' ) ; -#$h{''} = 'bar'; -#ok(32, $h{''} eq 'bar' ); -ok(32,1) ; +# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. +# This feature was reenabled in version 3.1 of Berkeley DB. +my $result = 0 ; +if ($null_keys_allowed) { + $h{''} = 'bar'; + $result = ( $h{''} eq 'bar' ); +} +else + { $result = 1 } +ok(32, $result) ; # check cache overflow and numeric keys and contents -$ok = 1; +my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } ok(33, $ok); @@ -250,7 +263,7 @@ ok(33, $ok); ok(34, $size > 0 ); @h{0..200} = 200..400; -@foo = @h{0..200}; +my @foo = @h{0..200}; ok(35, join(':',200..400) eq join(':',@foo) ); # Now check all the non-tie specific stuff @@ -259,7 +272,7 @@ ok(35, join(':',200..400) eq join(':',@foo) ); # Check R_NOOVERWRITE flag will make put fail when attempting to overwrite # an existing record. -$status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; +my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; ok(36, $status == 1 ); # check that the value of the key 'x' has not been changed by the @@ -280,9 +293,12 @@ ok(40, $value eq 'value' ); $status = $X->del('q') ; ok(41, $status == 0 ); -#$status = $X->del('') ; -#ok(42, $status == 0 ); -ok(42,1) ; +if ($null_keys_allowed) { + $status = $X->del('') ; +} else { + $status = 0 ; +} +ok(42, $status == 0 ); # Make sure that the key deleted, cannot be retrieved ok(43, ! defined $h{'q'}) ; @@ -362,7 +378,7 @@ ok(65, 1) ; # hard-wire to always pass. the previous test ($status == 1) $status = $X->seq($key, $value, R_FIRST) ; ok(66, $status == 0 ); -$previous = $key ; +my $previous = $key ; $ok = 1 ; while (($status = $X->seq($key, $value, R_NEXT)) == 0) @@ -411,6 +427,7 @@ untie %h ; unlink $Dfile; # Now try an in memory file +my $Y; ok(74, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )); # fd with an in memory file should return failure @@ -424,6 +441,7 @@ untie %h ; # Duplicate keys my $bt = new DB_File::BTREEINFO ; $bt->{flags} = R_DUP ; +my ($YY, %hh); ok(76, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ; $hh{'Wall'} = 'Larry' ; @@ -469,34 +487,38 @@ unlink $Dfile; # test multiple callbacks -$Dfile1 = "btree1" ; -$Dfile2 = "btree2" ; -$Dfile3 = "btree3" ; +my $Dfile1 = "btree1" ; +my $Dfile2 = "btree2" ; +my $Dfile3 = "btree3" ; -$dbh1 = new DB_File::BTREEINFO ; -{ local $^W = 0 ; - $dbh1->{compare} = sub { $_[0] <=> $_[1] } ; } +my $dbh1 = new DB_File::BTREEINFO ; +$dbh1->{compare} = sub { + no warnings 'numeric' ; + $_[0] <=> $_[1] } ; -$dbh2 = new DB_File::BTREEINFO ; +my $dbh2 = new DB_File::BTREEINFO ; $dbh2->{compare} = sub { $_[0] cmp $_[1] } ; -$dbh3 = new DB_File::BTREEINFO ; +my $dbh3 = new DB_File::BTREEINFO ; $dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ; -tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ; +my (%g, %k); +tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ; tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ; tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ; -@Keys = qw( 0123 12 -1234 9 987654321 def ) ; -{ local $^W = 0 ; - @srt_1 = sort { $a <=> $b } @Keys ; } +my @Keys = qw( 0123 12 -1234 9 987654321 def ) ; +my (@srt_1, @srt_2, @srt_3); +{ + no warnings 'numeric' ; + @srt_1 = sort { $a <=> $b } @Keys ; +} @srt_2 = sort { $a cmp $b } @Keys ; @srt_3 = sort { length $a <=> length $b } @Keys ; foreach (@Keys) { - { local $^W = 0 ; - $h{$_} = 1 ; } + $h{$_} = 1 ; $g{$_} = 1 ; $k{$_} = 1 ; } @@ -566,6 +588,7 @@ unlink $Dfile1 ; package Another ; + use warnings ; use strict ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; @@ -573,6 +596,7 @@ unlink $Dfile1 ; package SubDB ; + use warnings ; use strict ; use vars qw( @ISA @EXPORT) ; @@ -656,6 +680,7 @@ EOM { # DBM Filter tests + use warnings ; use strict ; my (%h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -762,6 +787,7 @@ EOM { # DBM Filter with a closure + use warnings ; use strict ; my (%h, $db) ; @@ -824,6 +850,7 @@ EOM { # DBM Filter recursion detection + use warnings ; use strict ; my (%h, $db) ; unlink $Dfile; @@ -852,6 +879,7 @@ EOM # BTREE example 1 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; @@ -904,6 +932,7 @@ EOM # BTREE example 2 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; @@ -955,6 +984,7 @@ EOM # BTREE example 3 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; @@ -1010,6 +1040,7 @@ EOM # BTREE example 4 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; @@ -1058,6 +1089,7 @@ EOM # BTREE example 5 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; @@ -1092,6 +1124,7 @@ EOM # BTREE example 6 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; @@ -1126,6 +1159,7 @@ EOM # BTREE example 7 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; use Fcntl ; @@ -1217,4 +1251,46 @@ EOM # unlink $Dfile; #} +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE + or die "Can't open file: $!\n" ; + $h{ABC} = undef; + ok(156, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE + or die "Can't open file: $!\n" ; + %h = (); ; + ok(157, $a eq "") ; + untie %h ; + unlink $Dfile; +} + exit ; diff --git a/contrib/perl5/t/lib/db-hash.t b/contrib/perl5/t/lib/db-hash.t index c52d8ae9ddef..effc60b7ddf1 100755 --- a/contrib/perl5/t/lib/db-hash.t +++ b/contrib/perl5/t/lib/db-hash.t @@ -1,7 +1,7 @@ #!./perl -w BEGIN { - unshift @INC, '../lib' if -d '../lib' ; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0 # Skip: DB_File was not built\n"; @@ -9,10 +9,12 @@ BEGIN { } } +use strict; +use warnings; use DB_File; use Fcntl; -print "1..109\n"; +print "1..111\n"; sub ok { @@ -57,6 +59,9 @@ sub docat_del } my $Dfile = "dbhash.tmp"; +my $null_keys_allowed = ($DB_File::db_ver < 2.004010 + || $DB_File::db_ver >= 3.1 ); + unlink $Dfile; umask(0); @@ -98,13 +103,14 @@ ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ ); # Now check the interface to HASH - +my ($X, %h); ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32'); +my ($key, $value, $i); while (($key,$value) = each(%h)) { $i++; } @@ -176,8 +182,8 @@ $h{'goner3'} = 'snork'; delete $h{'goner1'}; $X->DELETE('goner3'); -@keys = keys(%h); -@values = values(%h); +my @keys = keys(%h); +my @values = values(%h); ok(23, $#keys == 29 && $#values == 29) ; @@ -197,14 +203,19 @@ ok(25, $#keys == 31) ; $h{'foo'} = ''; ok(26, $h{'foo'} eq '' ); -# Berkeley DB 2 from version 2.4.10 onwards does not allow null keys. -# This feature will be reenabled in a future version of Berkeley DB. -#$h{''} = 'bar'; -#ok(27, $h{''} eq 'bar' ); -ok(27,1) ; +# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. +# This feature was reenabled in version 3.1 of Berkeley DB. +my $result = 0 ; +if ($null_keys_allowed) { + $h{''} = 'bar'; + $result = ( $h{''} eq 'bar' ); +} +else + { $result = 1 } +ok(27, $result) ; # check cache overflow and numeric keys and contents -$ok = 1; +my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } ok(28, $ok ); @@ -214,7 +225,7 @@ ok(28, $ok ); ok(29, $size > 0 ); @h{0..200} = 200..400; -@foo = @h{0..200}; +my @foo = @h{0..200}; ok(30, join(':',200..400) eq join(':',@foo) ); @@ -223,7 +234,7 @@ ok(30, join(':',200..400) eq join(':',@foo) ); # Check NOOVERWRITE will make put fail when attempting to overwrite # an existing record. -$status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; +my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; ok(31, $status == 1 ); # check that the value of the key 'x' has not been changed by the @@ -246,9 +257,10 @@ $status = $X->del('q') ; ok(36, $status == 0 ); # Make sure that the key deleted, cannot be retrieved -$^W = 0 ; -ok(37, $h{'q'} eq undef ); -$^W = 1 ; +{ + no warnings 'uninitialized' ; + ok(37, $h{'q'} eq undef ); +} # Attempting to delete a non-existant key should fail @@ -361,6 +373,7 @@ untie %h ; package Another ; + use warnings ; use strict ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; @@ -368,6 +381,7 @@ untie %h ; package SubDB ; + use warnings ; use strict ; use vars qw( @ISA @EXPORT) ; @@ -451,6 +465,7 @@ EOM { # DBM Filter tests + use warnings ; use strict ; my (%h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -557,6 +572,7 @@ EOM { # DBM Filter with a closure + use warnings ; use strict ; my (%h, $db) ; @@ -619,6 +635,7 @@ EOM { # DBM Filter recursion detection + use warnings ; use strict ; my (%h, $db) ; unlink $Dfile; @@ -643,6 +660,7 @@ EOM { my $redirect = new Redirect $file ; + use warnings FATAL => qw(all); use strict ; use DB_File ; use vars qw( %h $k $v ) ; @@ -682,4 +700,44 @@ EOM } +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; + $h{ABC} = undef; + ok(110, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; + %h = (); ; + ok(111, $a eq "") ; + untie %h ; + unlink $Dfile; +} + exit ; diff --git a/contrib/perl5/t/lib/db-recno.t b/contrib/perl5/t/lib/db-recno.t index 276f38bc3ab7..8b5a88cc6de0 100755 --- a/contrib/perl5/t/lib/db-recno.t +++ b/contrib/perl5/t/lib/db-recno.t @@ -1,7 +1,7 @@ #!./perl -w BEGIN { - unshift @INC, '../lib' if -d '../lib' ; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0 # Skip: DB_File was not built\n"; @@ -12,6 +12,7 @@ BEGIN { use DB_File; use Fcntl; use strict ; +use warnings; use vars qw($dbh $Dfile $bad_ones $FA) ; # full tied array support started in Perl 5.004_57 @@ -99,7 +100,7 @@ sub bad_one EOM } -print "1..126\n"; +print "1..128\n"; my $Dfile = "recno.tmp"; unlink $Dfile ; @@ -340,6 +341,7 @@ unlink $Dfile; package Another ; + use warnings ; use strict ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; @@ -347,6 +349,7 @@ unlink $Dfile; package SubDB ; + use warnings ; use strict ; use vars qw( @ISA @EXPORT) ; @@ -487,6 +490,7 @@ EOM { # DBM Filter tests + use warnings ; use strict ; my (@h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -593,6 +597,7 @@ EOM { # DBM Filter with a closure + use warnings ; use strict ; my (@h, $db) ; @@ -655,6 +660,7 @@ EOM { # DBM Filter recursion detection + use warnings ; use strict ; my (@h, $db) ; unlink $Dfile; @@ -679,6 +685,7 @@ EOM { my $redirect = new Redirect $file ; + use warnings FATAL => qw(all); use strict ; use DB_File ; @@ -734,6 +741,7 @@ EOM { my $redirect = new Redirect $save_output ; + use warnings FATAL => qw(all); use strict ; use vars qw(@h $H $file $i) ; use DB_File ; @@ -836,4 +844,46 @@ EOM } +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my @h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + or die "Can't open file: $!\n" ; + $h[0] = undef; + ok(127, $a eq "") ; + untie @h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + unlink $Dfile; + my @h ; + + tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + or die "Can't open file: $!\n" ; + @h = (); ; + ok(128, $a eq "") ; + untie @h ; + unlink $Dfile; +} + exit ; diff --git a/contrib/perl5/t/lib/dirhand.t b/contrib/perl5/t/lib/dirhand.t index a8683c7fb8e3..aa7be356df3a 100755 --- a/contrib/perl5/t/lib/dirhand.t +++ b/contrib/perl5/t/lib/dirhand.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if (not $Config{'d_readdir'}) { print "1..0\n"; diff --git a/contrib/perl5/t/lib/dosglob.t b/contrib/perl5/t/lib/dosglob.t index ea537bf6d1cb..fd9bb1d1198d 100755 --- a/contrib/perl5/t/lib/dosglob.t +++ b/contrib/perl5/t/lib/dosglob.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..10\n"; @@ -39,7 +39,7 @@ while (defined($_ = <*/a*.t>)) { print "not " if @r != $r; print "ok 4\n"; -# check if array context works +# check if list context works @r = (); for (<*/a*.t>) { print "# $_\n"; diff --git a/contrib/perl5/t/lib/dprof.t b/contrib/perl5/t/lib/dprof.t index 4d6f7823c3c2..be711f133017 100755 --- a/contrib/perl5/t/lib/dprof.t +++ b/contrib/perl5/t/lib/dprof.t @@ -2,23 +2,28 @@ BEGIN { chdir( 't' ) if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bDevel\/DProf\b/){ + print "1..0 # Skip: Devel::DProf was not built\n"; + exit 0; + } } END { - unlink 'tmon.out', 'err'; + while(-e 'tmon.out' && unlink 'tmon.out') {} + while(-e 'err' && unlink 'err') {} } use Benchmark qw( timediff timestr ); use Getopt::Std 'getopts'; -use Config '%Config'; getopts('vI:p:'); # -v Verbose # -I Add to @INC # -p Name of perl binary -@tests = @ARGV ? @ARGV : sort <lib/dprof/*_t lib/dprof/*_v>; # glob-sort, for OS/2 +@tests = @ARGV ? @ARGV : sort (<lib/dprof/*_t>, <lib/dprof/*_v>); # glob-sort, for OS/2 $path_sep = $Config{path_sep} || ':'; $perl5lib = $opt_I || join( $path_sep, @INC ); @@ -42,7 +47,7 @@ sub profile { my $opt_d = '-d:DProf'; my $t_start = new Benchmark; - open( R, "$perl $opt_d $test |" ) || warn "$0: Can't run. $!\n"; + open( R, "$perl \"$opt_d\" $test |" ) || warn "$0: Can't run. $!\n"; @results = <R>; close R; my $t_total = timediff( new Benchmark, $t_start ); @@ -52,15 +57,17 @@ sub profile { print @results } - print timestr( $t_total, 'nop' ), "\n"; + print '# ',timestr( $t_total, 'nop' ), "\n"; } sub verify { my $test = shift; - system $perl, '-I../lib', '-I./lib/dprof', $test, - $opt_v?'-v':'', '-p', $perl; + my $command = $perl.' "-I../lib" "-I./lib/dprof" '.$test; + $command .= ' -v' if $opt_v; + $command .= ' -p '. $perl; + system $command; } @@ -68,6 +75,7 @@ $| = 1; print "1..18\n"; while( @tests ){ $test = shift @tests; + $test =~ s/\.$// if $^O eq 'VMS'; if( $test =~ /_t$/i ){ print "# $test" . '.' x (20 - length $test); profile $test; diff --git a/contrib/perl5/t/lib/dprof/V.pm b/contrib/perl5/t/lib/dprof/V.pm index 7e34da5d47cc..152cddc253de 100644 --- a/contrib/perl5/t/lib/dprof/V.pm +++ b/contrib/perl5/t/lib/dprof/V.pm @@ -13,15 +13,19 @@ $num = 0; $results = $expected = ''; $perl = $opt_p || $^X; $dpp = $opt_d || '../utils/dprofpp'; +$dpp .= '.com' if $^O eq 'VMS'; print "\nperl: $perl\n" if $opt_v; if( ! -f $perl ){ die "Where's Perl?" } -if( ! -f $dpp ){ die "Where's dprofpp?" } +if( ! -f $dpp ) { + ($dpp = $^X) =~ s@(^.*)[/|\\].*@$1/dprofpp@; + die "Where's dprofpp?" if( ! -f $dpp ); +} sub dprofpp { my $switches = shift; - open( D, "$perl -I../lib $dpp $switches 2> err |" ) || warn "$0: Can't run. $!\n"; + open( D, "$perl \"-I../lib\" $dpp \"$switches\" 2> err |" ) || warn "$0: Can't run. $!\n"; @results = <D>; close D; diff --git a/contrib/perl5/t/lib/dumper-ovl.t b/contrib/perl5/t/lib/dumper-ovl.t index 8c095e59be8d..d4b3a924ae43 100755 --- a/contrib/perl5/t/lib/dumper-ovl.t +++ b/contrib/perl5/t/lib/dumper-ovl.t @@ -2,7 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } } use Data::Dumper; diff --git a/contrib/perl5/t/lib/dumper.t b/contrib/perl5/t/lib/dumper.t index 3167535d78dc..be9732f1d67f 100755 --- a/contrib/perl5/t/lib/dumper.t +++ b/contrib/perl5/t/lib/dumper.t @@ -5,7 +5,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } } use Data::Dumper; @@ -257,11 +262,14 @@ EOT ## $WANT = <<'EOT'; #$VAR1 = { -# "abc\0'\efg" => "mno\0" +# "abc\0'\efg" => "mno\0", +# "reftest" => \\1 #}; EOT -$foo = { "abc\000\'\efg" => "mno\000" }; +$foo = { "abc\000\'\efg" => "mno\000", + "reftest" => \\1, + }; { local $Data::Dumper::Useqq = 1; TEST q(Dumper($foo)); @@ -269,7 +277,8 @@ $foo = { "abc\000\'\efg" => "mno\000" }; $WANT = <<"EOT"; #\$VAR1 = { -# 'abc\0\\'\efg' => 'mno\0' +# 'abc\0\\'\efg' => 'mno\0', +# 'reftest' => \\\\1 #}; EOT @@ -287,7 +296,7 @@ EOT package main; use Data::Dumper; $foo = 5; - @foo = (10,\*foo); + @foo = (-10,\*foo); %foo = (a=>1,b=>\$foo,c=>\@foo); $foo{d} = \%foo; $foo[2] = \%foo; @@ -299,7 +308,7 @@ EOT #*::foo = \5; #*::foo = [ # #0 -# 10, +# -10, # #1 # do{my $o}, # #2 @@ -330,7 +339,7 @@ EOT #$foo = \*::foo; #*::foo = \5; #*::foo = [ -# 10, +# -10, # do{my $o}, # { # 'a' => 1, @@ -356,7 +365,7 @@ EOT ## $WANT = <<'EOT'; #@bar = ( -# 10, +# -10, # \*::foo, # {} #); @@ -383,7 +392,7 @@ EOT ## $WANT = <<'EOT'; #$bar = [ -# 10, +# -10, # \*::foo, # {} #]; @@ -411,7 +420,7 @@ EOT $WANT = <<'EOT'; #$foo = \*::foo; #@bar = ( -# 10, +# -10, # $foo, # { # a => 1, @@ -433,7 +442,7 @@ EOT $WANT = <<'EOT'; #$foo = \*::foo; #$bar = [ -# 10, +# -10, # $foo, # { # a => 1, diff --git a/contrib/perl5/t/lib/english.t b/contrib/perl5/t/lib/english.t index dba68dbf94e2..0cbbdbf2852a 100755 --- a/contrib/perl5/t/lib/english.t +++ b/contrib/perl5/t/lib/english.t @@ -2,7 +2,7 @@ print "1..16\n"; -BEGIN { unshift @INC, '../lib' } +BEGIN { @INC = '../lib' } use English; use Config; my $threads = $Config{'use5005threads'} || 0; @@ -43,5 +43,5 @@ print $GID == $( ? "ok 12\n" : "not ok 12\n"; print $EUID == $> ? "ok 13\n" : "not ok 13\n"; print $EGID == $) ? "ok 14\n" : "not ok 14\n"; -print $PROGRAM_NAME == $0 ? "ok 15\n" : "not ok 15\n"; +print $PROGRAM_NAME eq $0 ? "ok 15\n" : "not ok 15\n"; print $BASETIME == $^T ? "ok 16\n" : "not ok 16\n"; diff --git a/contrib/perl5/t/lib/env-array.t b/contrib/perl5/t/lib/env-array.t index d90d89226f75..c5068fda14cf 100755 --- a/contrib/perl5/t/lib/env-array.t +++ b/contrib/perl5/t/lib/env-array.t @@ -4,7 +4,7 @@ $| = 1; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } if ($^O eq 'VMS') { diff --git a/contrib/perl5/t/lib/env.t b/contrib/perl5/t/lib/env.t index 25731648a0d4..ff6af2edb841 100755 --- a/contrib/perl5/t/lib/env.t +++ b/contrib/perl5/t/lib/env.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } BEGIN { diff --git a/contrib/perl5/t/lib/errno.t b/contrib/perl5/t/lib/errno.t index 6320f6b23666..02f5ce2ca680 100755 --- a/contrib/perl5/t/lib/errno.t +++ b/contrib/perl5/t/lib/errno.t @@ -3,7 +3,11 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + if ($^O eq 'MacOS') { + @INC = qw(: ::lib ::macos:lib); + } else { + @INC = '../lib'; + } } } diff --git a/contrib/perl5/t/lib/fatal.t b/contrib/perl5/t/lib/fatal.t index 4013fbd37136..f00b8766e842 100755 --- a/contrib/perl5/t/lib/fatal.t +++ b/contrib/perl5/t/lib/fatal.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; print "1..15\n"; } diff --git a/contrib/perl5/t/lib/fields.t b/contrib/perl5/t/lib/fields.t index 7709ee517749..a3f591acc442 100755 --- a/contrib/perl5/t/lib/fields.t +++ b/contrib/perl5/t/lib/fields.t @@ -4,7 +4,7 @@ my $w; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; $SIG{__WARN__} = sub { if ($_[0] =~ /^Hides field 'b1' in base class/) { $w++; diff --git a/contrib/perl5/t/lib/filecache.t b/contrib/perl5/t/lib/filecache.t index 019f3742c5bc..a97fdd532c6c 100755 --- a/contrib/perl5/t/lib/filecache.t +++ b/contrib/perl5/t/lib/filecache.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..1\n"; diff --git a/contrib/perl5/t/lib/filecopy.t b/contrib/perl5/t/lib/filecopy.t index b6fcbeafa612..3072c542b50d 100755 --- a/contrib/perl5/t/lib/filecopy.t +++ b/contrib/perl5/t/lib/filecopy.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } $| = 1; diff --git a/contrib/perl5/t/lib/filefind.t b/contrib/perl5/t/lib/filefind.t index e9a29167387f..362c1ebf07c2 100755 --- a/contrib/perl5/t/lib/filefind.t +++ b/contrib/perl5/t/lib/filefind.t @@ -6,7 +6,7 @@ my $symlink_exists = eval { symlink("",""); 1 }; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } if ( $symlink_exists ) { print "1..117\n"; } @@ -19,6 +19,7 @@ finddepth(sub { print "ok 2\n" if $_ eq 'filefind.t'; }, "."); my $case = 2; +my $FastFileTests_OK = 0; END { unlink 'fa/fa_ord','fa/fsl','fa/faa/faa_ord', @@ -57,8 +58,15 @@ sub wanted { print "# '$_' => 1\n"; s#\.$## if ($^O eq 'VMS' && $_ ne '.'); Check( $Expect{$_} ); - delete $Expect{$_}; + if ( $FastFileTests_OK ) { + delete $Expect{$_} + unless ( $Expect_Dir{$_} && ! -d _ ); + } else { + delete $Expect{$_} + unless ( $Expect_Dir{$_} && ! -d $_ ); + } $File::Find::prune=1 if $_ eq 'faba'; + } sub dn_wanted { @@ -106,6 +114,9 @@ touch('fa/fab/faba/faba_ord'); %Expect = ('.' => 1, 'fsl' => 1, 'fa_ord' => 1, 'fab' => 1, 'fab_ord' => 1, 'faba' => 1, 'faa' => 1, 'faa_ord' => 1); delete $Expect{'fsl'} unless $symlink_exists; +%Expect_Dir = ('fa' => 1, 'faa' => 1, 'fab' => 1, 'faba' => 1, + 'fb' => 1, 'fba' => 1); +delete @Expect_Dir{'fb','fba'} unless $symlink_exists; File::Find::find( {wanted => \&wanted, },'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -113,6 +124,9 @@ Check( scalar(keys %Expect) == 0 ); 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); delete $Expect{'fa/fsl'} unless $symlink_exists; +%Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); +delete @Expect_Dir{'fb','fb/fba'} unless $symlink_exists; File::Find::find( {wanted => \&wanted, no_chdir => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -122,6 +136,9 @@ Check( scalar(keys %Expect) == 0 ); './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); delete $Expect{'./fa/fsl'} unless $symlink_exists; +%Expect_Dir = ('./fa' => 1, './fa/faa' => 1, '/fa/fab' => 1, './fa/fab/faba' => 1, + './fb' => 1, './fb/fba' => 1); +delete @Expect_Dir{'./fb','./fb/fba'} unless $symlink_exists; File::Find::finddepth( {wanted => \&dn_wanted },'.' ); Check( scalar(keys %Expect) == 0 ); @@ -130,13 +147,19 @@ Check( scalar(keys %Expect) == 0 ); './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); delete $Expect{'./fa/fsl'} unless $symlink_exists; +%Expect_Dir = ('./fa' => 1, './fa/faa' => 1, '/fa/fab' => 1, './fa/fab/faba' => 1, + './fb' => 1, './fb/fba' => 1); +delete @Expect_Dir{'./fb','./fb/fba'} unless $symlink_exists; File::Find::finddepth( {wanted => \&d_wanted, no_chdir => 1 },'.' ); Check( scalar(keys %Expect) == 0 ); if ( $symlink_exists ) { + $FastFileTests_OK= 1; %Expect=('.' => 1, 'fa_ord' => 1, 'fsl' => 1, 'fb_ord' => 1, 'fba' => 1, 'fba_ord' => 1, 'fab' => 1, 'fab_ord' => 1, 'faba' => 1, 'faa' => 1, 'faa_ord' => 1); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::find( {wanted => \&wanted, follow_fast => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -145,6 +168,8 @@ if ( $symlink_exists ) { 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::find( {wanted => \&wanted, follow_fast => 1, no_chdir => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -152,6 +177,8 @@ if ( $symlink_exists ) { 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::finddepth( {wanted => \&dn_wanted, follow_fast => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -160,6 +187,8 @@ if ( $symlink_exists ) { 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::finddepth( {wanted => \&d_wanted, follow_fast => 1, no_chdir => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); diff --git a/contrib/perl5/t/lib/filefunc.t b/contrib/perl5/t/lib/filefunc.t index 46a1e35774a9..926812248c28 100755 --- a/contrib/perl5/t/lib/filefunc.t +++ b/contrib/perl5/t/lib/filefunc.t @@ -3,7 +3,7 @@ BEGIN { $^O = ''; chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..1\n"; diff --git a/contrib/perl5/t/lib/filehand.t b/contrib/perl5/t/lib/filehand.t index 22cff0ecb07d..0f3e177563fb 100755 --- a/contrib/perl5/t/lib/filehand.t +++ b/contrib/perl5/t/lib/filehand.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { print "1..0\n"; @@ -20,7 +20,7 @@ $| = 1; autoflush $mystdout; print "1..11\n"; -print $mystdout "ok ",fileno($mystdout),"\n"; +print $mystdout "ok ".fileno($mystdout)."\n"; $fh = (new FileHandle "./TEST", O_RDONLY or new FileHandle "TEST", O_RDONLY) diff --git a/contrib/perl5/t/lib/filepath.t b/contrib/perl5/t/lib/filepath.t index 5628d0c7265e..42e0ae9f934d 100755 --- a/contrib/perl5/t/lib/filepath.t +++ b/contrib/perl5/t/lib/filepath.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use File::Path; diff --git a/contrib/perl5/t/lib/filespec.t b/contrib/perl5/t/lib/filespec.t index da52ec5fb5b8..c6d155fac175 100755 --- a/contrib/perl5/t/lib/filespec.t +++ b/contrib/perl5/t/lib/filespec.t @@ -3,7 +3,7 @@ BEGIN { $^O = ''; chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } # Each element in this array is a single test. Storing them this way makes diff --git a/contrib/perl5/t/lib/findbin.t b/contrib/perl5/t/lib/findbin.t index f0939e94a919..3e742f9a4f79 100755 --- a/contrib/perl5/t/lib/findbin.t +++ b/contrib/perl5/t/lib/findbin.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..1\n"; diff --git a/contrib/perl5/t/lib/gdbm.t b/contrib/perl5/t/lib/gdbm.t index dc4e96e4d8cb..ecbd662f26bf 100755 --- a/contrib/perl5/t/lib/gdbm.t +++ b/contrib/perl5/t/lib/gdbm.t @@ -3,7 +3,7 @@ # $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ BEGIN { - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bGDBM_File\b/) { print "1..0 # Skip: GDBM_File was not built\n"; @@ -11,16 +11,21 @@ BEGIN { } } +use strict; +use warnings; + + use GDBM_File; -print "1..66\n"; +print "1..68\n"; unlink <Op.dbmx*>; umask(0); -print (tie(%h,GDBM_File,'Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 1\n" : "not ok 1\n"); +my %h ; +print (tie(%h,'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 1\n" : "not ok 1\n"); -$Dfile = "Op.dbmx.pag"; +my $Dfile = "Op.dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op.dbmx*>; } @@ -28,11 +33,12 @@ if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') { print "ok 2 # Skipped: different file permission semantics\n"; } else { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); } -while (($key,$value) = each(%h)) { +my $i = 0; +while (my ($key,$value) = each(%h)) { $i++; } print (!$i ? "ok 3\n" : "not ok 3\n"); @@ -57,7 +63,7 @@ $h{'goner2'} = 'snork'; delete $h{'goner2'}; untie(%h); -print (tie(%h,GDBM_File,'Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 4\n" : "not ok 4\n"); +print (tie(%h,'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 4\n" : "not ok 4\n"); $h{'j'} = 'J'; $h{'k'} = 'K'; @@ -82,12 +88,12 @@ $h{'goner3'} = 'snork'; delete $h{'goner1'}; delete $h{'goner3'}; -@keys = keys(%h); -@values = values(%h); +my @keys = keys(%h); +my @values = values(%h); if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} -while (($key,$value) = each(%h)) { +while (my ($key,$value) = each(%h)) { if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; @@ -103,17 +109,17 @@ $h{'foo'} = ''; $h{''} = 'bar'; # check cache overflow and numeric keys and contents -$ok = 1; +my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } print ($ok ? "ok 8\n" : "not ok 8\n"); -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print ($size > 0 ? "ok 9\n" : "not ok 9\n"); @h{0..200} = 200..400; -@foo = @h{0..200}; +my @foo = @h{0..200}; print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); @@ -137,6 +143,7 @@ sub ok package Another ; use strict ; + use warnings ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; print FILE <<'EOM' ; @@ -178,6 +185,7 @@ EOM close FILE ; BEGIN { push @INC, '.'; } + unlink <dbhash.tmp*> ; eval 'use SubDB ; '; main::ok(13, $@ eq "") ; @@ -210,6 +218,7 @@ EOM { # DBM Filter tests use strict ; + use warnings ; my (%h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -316,6 +325,7 @@ EOM # DBM Filter with a closure use strict ; + use warnings ; my (%h, $db) ; unlink <Op.dbmx*>; @@ -360,7 +370,7 @@ EOM ok(54, $result{"store key"} eq "store key - 2: [fred jim]"); ok(55, $result{"store value"} eq "store value - 2: [joe john]"); ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(57, $result{"fetch value"} eq ""); + ok(57, ! defined $result{"fetch value"} ); ok(58, $_ eq "original") ; ok(59, $h{"fred"} eq "joe"); @@ -378,6 +388,7 @@ EOM { # DBM Filter recursion detection use strict ; + use warnings ; my (%h, $db) ; unlink <Op.dbmx*>; @@ -392,3 +403,24 @@ EOM untie %h; unlink <Op.dbmx*>; } + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use GDBM_File ; + + unlink <Op.dbmx*>; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + ok(67, tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)); + $h{ABC} = undef; + ok(68, $a eq "") ; + untie %h; + unlink <Op.dbmx*>; +} diff --git a/contrib/perl5/t/lib/getopt.t b/contrib/perl5/t/lib/getopt.t index 035462722b3b..fb70f10aae87 100755 --- a/contrib/perl5/t/lib/getopt.t +++ b/contrib/perl5/t/lib/getopt.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..11\n"; diff --git a/contrib/perl5/t/lib/glob-basic.t b/contrib/perl5/t/lib/glob-basic.t index 47280831a9e1..a014bfd555b8 100755 --- a/contrib/perl5/t/lib/glob-basic.t +++ b/contrib/perl5/t/lib/glob-basic.t @@ -2,7 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + if ($^O eq 'MacOS') { + @INC = qw(: ::lib ::macos:lib); + } else { + @INC = '.'; + push @INC, '../lib'; + } require Config; import Config; if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { print "1..0\n"; @@ -26,8 +31,8 @@ sub array { $ENV{PATH} = "/bin"; delete @ENV{BASH_ENV, CDPATH, ENV, IFS}; @correct = (); -if (opendir(D, ".")) { - @correct = grep { !/^\.\.?$/ } sort readdir(D); +if (opendir(D, $^O eq "MacOS" ? ":" : ".")) { + @correct = grep { !/^\./ } sort readdir(D); closedir D; } @a = File::Glob::glob("*", 0); @@ -39,12 +44,12 @@ print "ok 2\n"; # look up the user's home directory # should return a list with one item, and not set ERROR -if ($^O ne 'MSWin32' || $^O ne 'VMS') { +if ($^O ne 'MSWin32' && $^O ne 'VMS') { eval { ($name, $home) = (getpwuid($>))[0,7]; 1; } and do { - @a = File::Glob::glob("~$name", GLOB_TILDE); + @a = bsd_glob("~$name", GLOB_TILDE); if (scalar(@a) != 1 || $a[0] ne $home || GLOB_ERROR) { print "not "; } @@ -54,7 +59,7 @@ print "ok 3\n"; # check backslashing # should return a list with one item, and not set ERROR -@a = File::Glob::glob('TEST', GLOB_QUOTE); +@a = bsd_glob('TEST', GLOB_QUOTE); if (scalar @a != 1 || $a[0] ne 'TEST' || GLOB_ERROR) { local $/ = "]["; print "# [@a]\n"; @@ -65,7 +70,7 @@ print "ok 4\n"; # check nonexistent checks # should return an empty list # XXX since errfunc is NULL on win32, this test is not valid there -@a = File::Glob::glob("asdfasdf", 0); +@a = bsd_glob("asdfasdf", 0); if ($^O ne 'MSWin32' and scalar @a != 0) { print "# |@a|\nnot "; } @@ -81,7 +86,7 @@ if ($^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'os2' or $^O eq 'VMS' else { $dir = "PtEeRsLt.dir"; mkdir $dir, 0; - @a = File::Glob::glob("$dir/*", GLOB_ERR); + @a = bsd_glob("$dir/*", GLOB_ERR); #print "\@a = ", array(@a); rmdir $dir; if (scalar(@a) != 0 || GLOB_ERROR == 0) { @@ -91,16 +96,21 @@ else { } # check for csh style globbing -@a = File::Glob::glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC); +@a = bsd_glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC); unless (@a == 2 and $a[0] eq 'a' and $a[1] eq 'b') { print "not "; } print "ok 7\n"; -@a = File::Glob::glob( +@a = bsd_glob( '{TES*,doesntexist*,a,b}', - GLOB_BRACE | GLOB_NOMAGIC + GLOB_BRACE | GLOB_NOMAGIC | ($^O eq 'VMS' ? GLOB_NOCASE : 0) ); + +# Working on t/TEST often causes this test to fail because it sees temp +# and RCS files. Filter them out, and .pm files too. +@a = grep !/(,v$|~$|\.pm$)/, @a; + unless (@a == 3 and $a[0] eq ($^O eq 'VMS'? 'test.' : 'TEST') and $a[1] eq 'a' @@ -112,8 +122,8 @@ print "ok 8\n"; # "~" should expand to $ENV{HOME} $ENV{HOME} = "sweet home"; -@a = File::Glob::glob('~', GLOB_TILDE | GLOB_NOMAGIC); -unless (@a == 1 and $a[0] eq $ENV{HOME}) { +@a = bsd_glob('~', GLOB_TILDE | GLOB_NOMAGIC); +unless ($^O eq "MacOS" || (@a == 1 and $a[0] eq $ENV{HOME})) { print "not "; } print "ok 9\n"; diff --git a/contrib/perl5/t/lib/glob-case.t b/contrib/perl5/t/lib/glob-case.t index 32719b2d9ac1..881470cf84de 100755 --- a/contrib/perl5/t/lib/glob-case.t +++ b/contrib/perl5/t/lib/glob-case.t @@ -2,7 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + if ($^O eq 'MacOS') { + @INC = qw(: ::lib ::macos:lib); + } else { + @INC = '.'; + push @INC, '../lib'; + } require Config; import Config; if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { print "1..0\n"; @@ -17,20 +22,22 @@ use File::Glob qw(:glob csh_glob); $loaded = 1; print "ok 1\n"; +my $pat = $^O eq "MacOS" ? ":lib:G*.t" : "lib/G*.t"; + # Test the actual use of the case sensitivity tags, via csh_glob() import File::Glob ':nocase'; -@a = csh_glob("lib/G*.t"); # At least glob-basic.t glob-case.t glob-global.t +@a = csh_glob($pat); # At least glob-basic.t glob-case.t glob-global.t print "not " unless @a >= 3; print "ok 2\n"; # This may fail on systems which are not case-PRESERVING import File::Glob ':case'; -@a = csh_glob("lib/G*.t"); # None should be uppercase +@a = csh_glob($pat); # None should be uppercase print "not " unless @a == 0; print "ok 3\n"; # Test the explicit use of the GLOB_NOCASE flag -@a = File::Glob::glob("lib/G*.t", GLOB_NOCASE); +@a = bsd_glob($pat, GLOB_NOCASE); print "not " unless @a >= 3; print "ok 4\n"; @@ -47,7 +54,7 @@ else { rmdir "[]"; print "# returned @a\nnot " unless @a == 1; print "ok 6\n"; - @a = File::Glob::glob("lib\\*", GLOB_QUOTE); + @a = bsd_glob("lib\\*", GLOB_QUOTE); print "not " if @a == 0; print "ok 7\n"; } diff --git a/contrib/perl5/t/lib/glob-global.t b/contrib/perl5/t/lib/glob-global.t index 9d273bd1ed14..1d7903275bc5 100755 --- a/contrib/perl5/t/lib/glob-global.t +++ b/contrib/perl5/t/lib/glob-global.t @@ -2,7 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + if ($^O eq 'MacOS') { + @INC = qw(: ::lib ::macos:lib); + } else { + @INC = '.'; + push @INC, '../lib'; + } require Config; import Config; if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { print "1..0\n"; @@ -31,9 +36,9 @@ use File::Glob ':globally'; $loaded = 1; print "ok 1\n"; -$_ = "lib/*.t"; +$_ = $^O eq "MacOS" ? ":lib:*.t" : "lib/*.t"; my @r = glob; -print "not " if $_ ne 'lib/*.t'; +print "not " if $_ ne ($^O eq "MacOS" ? ":lib:*.t" : "lib/*.t"); print "ok 2\n"; # we should have at least basic.t, global.t, taint.t @@ -41,7 +46,11 @@ print "# |@r|\nnot " if @r < 3; print "ok 3\n"; # check if <*/*> works -@r = <*/*.t>; +if ($^O eq "MacOS") { + @r = <:*:*.t>; +} else { + @r = <*/*.t>; +} # at least t/global.t t/basic.t, t/taint.t print "not " if @r < 3; print "ok 4\n"; @@ -49,34 +58,55 @@ my $r = scalar @r; # check if scalar context works @r = (); -while (defined($_ = <*/*.t>)) { - #print "# $_\n"; - push @r, $_; +if ($^O eq "MacOS") { + while (defined($_ = <:*:*.t>)) { + #print "# $_\n"; + push @r, $_; + } +} else { + while (defined($_ = <*/*.t>)) { + #print "# $_\n"; + push @r, $_; + } } print "not " if @r != $r; print "ok 5\n"; -# check if array context works +# check if list context works @r = (); -for (<*/*.t>) { - #print "# $_\n"; - push @r, $_; +if ($^O eq "MacOS") { + for (<:*:*.t>) { + #print "# $_\n"; + push @r, $_; + } +} else { + for (<*/*.t>) { + #print "# $_\n"; + push @r, $_; + } } print "not " if @r != $r; print "ok 6\n"; # test if implicit assign to $_ in while() works @r = (); -while (<*/*.t>) { - #print "# $_\n"; - push @r, $_; +if ($^O eq "MacOS") { + while (<:*:*.t>) { + #print "# $_\n"; + push @r, $_; + } +} else { + while (<*/*.t>) { + #print "# $_\n"; + push @r, $_; + } } print "not " if @r != $r; print "ok 7\n"; # test if explicit glob() gets assign magic too my @s = (); -while (glob '*/*.t') { +while (glob($^O eq 'MacOS' ? ':*:*.t' : '*/*.t')) { #print "# $_\n"; push @s, $_; } @@ -87,7 +117,7 @@ print "ok 8\n"; package Foo; use File::Glob ':globally'; @s = (); -while (glob '*/*.t') { +while (glob($^O eq 'MacOS' ? ':*:*.t' : '*/*.t')) { #print "# $_\n"; push @s, $_; } @@ -97,14 +127,26 @@ print "ok 9\n"; # test if different glob ops maintain independent contexts @s = (); my $i = 0; -while (<*/*.t>) { - #print "# $_ <"; - push @s, $_; - while (<bas*/*.t>) { - #print " $_"; - $i++; +if ($^O eq "MacOS") { + while (<:*:*.t>) { + #print "# $_ <"; + push @s, $_; + while (<:bas*:*.t>) { + #print " $_"; + $i++; + } + #print " >\n"; + } +} else { + while (<*/*.t>) { + #print "# $_ <"; + push @s, $_; + while (<bas*/*.t>) { + #print " $_"; + $i++; + } + #print " >\n"; } - #print " >\n"; } print "not " if "@r" ne "@s" or not $i; print "ok 10\n"; diff --git a/contrib/perl5/t/lib/glob-taint.t b/contrib/perl5/t/lib/glob-taint.t index a8dc21385306..4c0990358d0d 100755 --- a/contrib/perl5/t/lib/glob-taint.t +++ b/contrib/perl5/t/lib/glob-taint.t @@ -2,7 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + if ($^O eq 'MacOS') { + @INC = qw(: ::lib ::macos:lib); + } else { + @INC = '.'; + push @INC, '../lib'; + } require Config; import Config; if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { print "1..0\n"; @@ -18,7 +23,7 @@ $loaded = 1; print "ok 1\n"; # all filenames should be tainted -@a = File::Glob::glob("*"); +@a = File::Glob::bsd_glob("*"); eval { $a = join("",@a), kill 0; 1 }; unless ($@ =~ /Insecure dependency/) { print "not "; diff --git a/contrib/perl5/t/lib/gol-basic.t b/contrib/perl5/t/lib/gol-basic.t index 4b25322336f9..c5d857d5b8df 100755 --- a/contrib/perl5/t/lib/gol-basic.t +++ b/contrib/perl5/t/lib/gol-basic.t @@ -1,16 +1,18 @@ #!./perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; + chdir('t') if -d 't'; + @INC = '../lib'; } -use Getopt::Long 2.17; +use Getopt::Long qw(:config no_ignore_case); +die("Getopt::Long version 2.24 required--this is only version ". + $Getopt::Long::VERSION) + unless $Getopt::Long::VERSION >= 2.24; print "1..9\n"; @ARGV = qw(-Foo -baR --foo bar); -Getopt::Long::Configure ("no_ignore_case"); undef $opt_baR; undef $opt_bar; print "ok 1\n" if GetOptions ("foo", "Foo=s"); diff --git a/contrib/perl5/t/lib/gol-compat.t b/contrib/perl5/t/lib/gol-compat.t index a4f807c7dd42..0bbe386846e3 100755 --- a/contrib/perl5/t/lib/gol-compat.t +++ b/contrib/perl5/t/lib/gol-compat.t @@ -1,8 +1,8 @@ #!./perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; + chdir('t') if -d 't'; + @INC = '../lib'; } require "newgetopt.pl"; diff --git a/contrib/perl5/t/lib/gol-linkage.t b/contrib/perl5/t/lib/gol-linkage.t index a1b2c05be371..3bd81a35528d 100755 --- a/contrib/perl5/t/lib/gol-linkage.t +++ b/contrib/perl5/t/lib/gol-linkage.t @@ -1,8 +1,8 @@ #!./perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; + chdir('t') if -d 't'; + @INC = '../lib'; } use Getopt::Long; diff --git a/contrib/perl5/t/lib/h2ph.t b/contrib/perl5/t/lib/h2ph.t index acb150dfcd3a..15dc2b52c218 100755 --- a/contrib/perl5/t/lib/h2ph.t +++ b/contrib/perl5/t/lib/h2ph.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..2\n"; diff --git a/contrib/perl5/t/lib/hostname.t b/contrib/perl5/t/lib/hostname.t index 6f61fb9dad82..85a04cd488f2 100755 --- a/contrib/perl5/t/lib/hostname.t +++ b/contrib/perl5/t/lib/hostname.t @@ -2,7 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bSys\/Hostname\b/) { + print "1..0 # Skip: Sys::Hostname was not built\n"; + exit 0; + } } use Sys::Hostname; diff --git a/contrib/perl5/t/lib/io_const.t b/contrib/perl5/t/lib/io_const.t index 48cb6b5dc83a..db1a322453e8 100755 --- a/contrib/perl5/t/lib/io_const.t +++ b/contrib/perl5/t/lib/io_const.t @@ -2,7 +2,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_dir.t b/contrib/perl5/t/lib/io_dir.t index 11ec8bcbf92a..368987155571 100755 --- a/contrib/perl5/t/lib/io_dir.t +++ b/contrib/perl5/t/lib/io_dir.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } require Config; import Config; if ($] < 5.00326 || not $Config{'d_readdir'}) { diff --git a/contrib/perl5/t/lib/io_dup.t b/contrib/perl5/t/lib/io_dup.t index c895fb4c2576..0f17264dfa1f 100755 --- a/contrib/perl5/t/lib/io_dup.t +++ b/contrib/perl5/t/lib/io_dup.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_linenum.t b/contrib/perl5/t/lib/io_linenum.t index 350321520149..cf55c980eafb 100755 --- a/contrib/perl5/t/lib/io_linenum.t +++ b/contrib/perl5/t/lib/io_linenum.t @@ -13,7 +13,7 @@ BEGIN chdir 't'; $File =~ s/^t\W+//; # Remove first directory } - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; require strict; import strict; } diff --git a/contrib/perl5/t/lib/io_multihomed.t b/contrib/perl5/t/lib/io_multihomed.t index 7337a5f8d6b3..55030b5ad105 100755 --- a/contrib/perl5/t/lib/io_multihomed.t +++ b/contrib/perl5/t/lib/io_multihomed.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_pipe.t b/contrib/perl5/t/lib/io_pipe.t index bcb89a0daf3d..ae18224b1274 100755 --- a/contrib/perl5/t/lib/io_pipe.t +++ b/contrib/perl5/t/lib/io_pipe.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_poll.t b/contrib/perl5/t/lib/io_poll.t index 68ad7b74cba4..d391566a7fec 100755 --- a/contrib/perl5/t/lib/io_poll.t +++ b/contrib/perl5/t/lib/io_poll.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } @@ -15,7 +15,7 @@ if ($^O eq 'mpeix') { select(STDERR); $| = 1; select(STDOUT); $| = 1; -print "1..8\n"; +print "1..9\n"; use IO::Handle; use IO::Poll qw(/POLL/); @@ -75,3 +75,8 @@ $poll->poll(0.1); print "not " if $poll->events($stdout); print "ok 8\n"; + +$poll->remove($dupout); +print "not " + if $poll->handles; +print "ok 9\n"; diff --git a/contrib/perl5/t/lib/io_sel.t b/contrib/perl5/t/lib/io_sel.t index 85e14ab0c0c7..5d1dce3ef9b6 100755 --- a/contrib/perl5/t/lib/io_sel.t +++ b/contrib/perl5/t/lib/io_sel.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_sock.t b/contrib/perl5/t/lib/io_sock.t index 056d131ffabe..45c16c2a233e 100755 --- a/contrib/perl5/t/lib/io_sock.t +++ b/contrib/perl5/t/lib/io_sock.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } @@ -70,17 +70,15 @@ if($pid = fork()) { } elsif(defined $pid) { - # This can fail if localhost is undefined or the - # special 'loopback' address 127.0.0.1 is not configured - # on your system. (/etc/rc.config.d/netconfig on HP-UX.) - # As a shortcut (not recommended) you could change 'localhost' - # here to be the name of this machine eg 'myhost.mycompany.com'. - $sock = IO::Socket::INET->new(PeerPort => $port, Proto => 'tcp', PeerAddr => 'localhost' ) - or die "$! (maybe your system does not have the 'localhost' address defined)"; + || IO::Socket::INET->new(PeerPort => $port, + Proto => 'tcp', + PeerAddr => '127.0.0.1' + ) + or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; $sock->autoflush(1); @@ -114,7 +112,8 @@ if($pid = fork()) { $listen->close; } elsif (defined $pid) { # child, try various ways to connect - $sock = IO::Socket::INET->new("localhost:$port"); + $sock = IO::Socket::INET->new("localhost:$port") + || IO::Socket::INET->new("127.0.0.1:$port"); if ($sock) { print "not " unless $sock->connected; print "ok 6\n"; @@ -151,7 +150,9 @@ if($pid = fork()) { sleep(1); $sock = IO::Socket->new(Domain => AF_INET, - PeerAddr => "localhost:$port"); + PeerAddr => "localhost:$port") + || IO::Socket->new(Domain => AF_INET, + PeerAddr => "127.0.0.1:$port"); if ($sock) { $sock->print("ok 11\n"); $sock->print("quit\n"); @@ -166,7 +167,10 @@ if($pid = fork()) { # Then test UDP sockets $server = IO::Socket->new(Domain => AF_INET, Proto => 'udp', - LocalAddr => 'localhost'); + LocalAddr => 'localhost') + || IO::Socket->new(Domain => AF_INET, + Proto => 'udp', + LocalAddr => '127.0.0.1'); $port = $server->sockport; if ($^O eq 'mpeix') { @@ -179,7 +183,9 @@ if ($^O eq 'mpeix') { } elsif (defined($pid)) { #child $sock = IO::Socket::INET->new(Proto => 'udp', - PeerAddr => "localhost:$port"); + PeerAddr => "localhost:$port") + || IO::Socket::INET->new(Proto => 'udp', + PeerAddr => "127.0.0.1:$port"); $sock->send("ok 12\n"); sleep(1); $sock->send("ok 12\n"); # send another one to be sure diff --git a/contrib/perl5/t/lib/io_taint.t b/contrib/perl5/t/lib/io_taint.t index deaa6c7f61c2..19afa2fea4eb 100755 --- a/contrib/perl5/t/lib/io_taint.t +++ b/contrib/perl5/t/lib/io_taint.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_tell.t b/contrib/perl5/t/lib/io_tell.t index 8d7524225158..3aa4b031e17e 100755 --- a/contrib/perl5/t/lib/io_tell.t +++ b/contrib/perl5/t/lib/io_tell.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; $tell_file = "TEST"; } else { diff --git a/contrib/perl5/t/lib/io_udp.t b/contrib/perl5/t/lib/io_udp.t index 3d5145ec5ede..d63a5dcf7b2a 100755 --- a/contrib/perl5/t/lib/io_udp.t +++ b/contrib/perl5/t/lib/io_udp.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } @@ -57,19 +57,15 @@ print "1..7\n"; use Socket; use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); - # This can fail if localhost is undefined or the - # special 'loopback' address 127.0.0.1 is not configured - # on your system. (/etc/rc.config.d/netconfig on HP-UX.) - # As a shortcut (not recommended) you could change 'localhost' - # here to be the name of this machine eg 'myhost.mycompany.com'. - $udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') - or die "$! (maybe your system does not have the 'localhost' address defined)"; + || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1') + or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; print "ok 1\n"; $udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') - or die "$! (maybe your system does not have the 'localhost' address defined)"; + || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1') + or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; print "ok 2\n"; diff --git a/contrib/perl5/t/lib/io_unix.t b/contrib/perl5/t/lib/io_unix.t index 247647a70297..2f6def0af76e 100755 --- a/contrib/perl5/t/lib/io_unix.t +++ b/contrib/perl5/t/lib/io_unix.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_xs.t b/contrib/perl5/t/lib/io_xs.t index 6bbba16f8c4a..2449fc45c1fc 100755 --- a/contrib/perl5/t/lib/io_xs.t +++ b/contrib/perl5/t/lib/io_xs.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } @@ -40,3 +40,4 @@ print scalar <$x>; $! = 0; $x->setpos(undef); print $! ? "ok 4 # $!\n" : "not ok 4\n"; + diff --git a/contrib/perl5/t/lib/ipc_sysv.t b/contrib/perl5/t/lib/ipc_sysv.t index a4f3e3f36714..795ad5d6c70f 100755 --- a/contrib/perl5/t/lib/ipc_sysv.t +++ b/contrib/perl5/t/lib/ipc_sysv.t @@ -3,13 +3,15 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; my $reason; - if ($Config{'d_sem'} ne 'define') { + if ($Config{'extensions'} !~ /\bIPC\/SysV\b/) { + $reason = 'IPC::SysV was not built'; + } elsif ($Config{'d_sem'} ne 'define') { $reason = '$Config{d_sem} undefined'; } elsif ($Config{'d_msg'} ne 'define') { $reason = '$Config{d_msg} undefined'; diff --git a/contrib/perl5/t/lib/ndbm.t b/contrib/perl5/t/lib/ndbm.t index 39c3f400a043..e56fcd938a6d 100755 --- a/contrib/perl5/t/lib/ndbm.t +++ b/contrib/perl5/t/lib/ndbm.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bNDBM_File\b/) { print "1..0 # Skip: NDBM_File was not built\n"; @@ -12,18 +12,31 @@ BEGIN { } } +use strict; +use warnings; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + require NDBM_File; #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; -print "1..64\n"; +print "1..65\n"; unlink <Op.dbmx*>; umask(0); -print (tie(%h,NDBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640) ? "ok 1\n" : "not ok 1\n"); +my %h; +ok(1, tie(%h,'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)); -$Dfile = "Op.dbmx.pag"; +my $Dfile = "Op.dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op.dbmx*>; } @@ -31,11 +44,12 @@ if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { print "ok 2 # Skipped: different file permission semantics\n"; } else { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); } -while (($key,$value) = each(%h)) { +my $i = 0; +while (my ($key,$value) = each(%h)) { $i++; } print (!$i ? "ok 3\n" : "not ok 3\n"); @@ -60,7 +74,7 @@ $h{'goner2'} = 'snork'; delete $h{'goner2'}; untie(%h); -print (tie(%h,NDBM_File,'Op.dbmx', &O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); +print (tie(%h,'NDBM_File','Op.dbmx', &O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); $h{'j'} = 'J'; $h{'k'} = 'K'; @@ -85,12 +99,12 @@ $h{'goner3'} = 'snork'; delete $h{'goner1'}; delete $h{'goner3'}; -@keys = keys(%h); -@values = values(%h); +my @keys = keys(%h); +my @values = values(%h); if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} -while (($key,$value) = each(%h)) { +while (my ($key,$value) = each(%h)) { if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; @@ -106,17 +120,17 @@ $h{'foo'} = ''; $h{''} = 'bar'; # check cache overflow and numeric keys and contents -$ok = 1; +my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } print ($ok ? "ok 8\n" : "not ok 8\n"); -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print ($size > 0 ? "ok 9\n" : "not ok 9\n"); @h{0..200} = 200..400; -@foo = @h{0..200}; +my @foo = @h{0..200}; print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); @@ -125,21 +139,13 @@ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); untie %h; unlink 'Op.dbmx.dir', $Dfile; -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - { # sub-class test package Another ; use strict ; + use warnings ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; print FILE <<'EOM' ; @@ -147,6 +153,7 @@ sub ok package SubDB ; use strict ; + use warnings ; use vars qw(@ISA @EXPORT) ; require Exporter ; @@ -209,6 +216,7 @@ EOM { # DBM Filter tests use strict ; + use warnings ; my (%h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -315,6 +323,7 @@ EOM # DBM Filter with a closure use strict ; + use warnings ; my (%h, $db) ; unlink <Op.dbmx*>; @@ -359,7 +368,7 @@ EOM ok(52, $result{"store key"} eq "store key - 2: [fred jim]"); ok(53, $result{"store value"} eq "store value - 2: [joe john]"); ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(55, $result{"fetch value"} eq ""); + ok(55, ! defined $result{"fetch value"} ); ok(56, $_ eq "original") ; ok(57, $h{"fred"} eq "joe"); @@ -377,6 +386,7 @@ EOM { # DBM Filter recursion detection use strict ; + use warnings ; my (%h, $db) ; unlink <Op.dbmx*>; @@ -391,3 +401,20 @@ EOM untie %h; unlink <Op.dbmx*>; } + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use NDBM_File ; + + unlink <Op.dbmx*>; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + ok(65, tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; +} diff --git a/contrib/perl5/t/lib/odbm.t b/contrib/perl5/t/lib/odbm.t index f8b8a110adc4..b935d049e59b 100755 --- a/contrib/perl5/t/lib/odbm.t +++ b/contrib/perl5/t/lib/odbm.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bODBM_File\b/) { print "1..0 # Skip: ODBM_File was not built\n"; @@ -12,18 +12,31 @@ BEGIN { } } +use strict; +use warnings; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + require ODBM_File; #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; -print "1..64\n"; +print "1..66\n"; unlink <Op.dbmx*>; umask(0); -print (tie(%h,ODBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640) ? "ok 1\n" : "not ok 1\n"); +my %h; +ok(1, tie(%h,'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)); -$Dfile = "Op.dbmx.pag"; +my $Dfile = "Op.dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op.dbmx*>; } @@ -31,11 +44,12 @@ if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { print "ok 2 # Skipped: different file permission semantics\n"; } else { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); } -while (($key,$value) = each(%h)) { +my $i = 0; +while (my ($key,$value) = each(%h)) { $i++; } print (!$i ? "ok 3\n" : "not ok 3\n"); @@ -60,7 +74,7 @@ $h{'goner2'} = 'snork'; delete $h{'goner2'}; untie(%h); -print (tie(%h,ODBM_File,'Op.dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); +print (tie(%h,'ODBM_File','Op.dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); $h{'j'} = 'J'; $h{'k'} = 'K'; @@ -85,12 +99,12 @@ $h{'goner3'} = 'snork'; delete $h{'goner1'}; delete $h{'goner3'}; -@keys = keys(%h); -@values = values(%h); +my @keys = keys(%h); +my @values = values(%h); if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} -while (($key,$value) = each(%h)) { +while (my ($key,$value) = each(%h)) { if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; @@ -106,17 +120,17 @@ $h{'foo'} = ''; $h{''} = 'bar'; # check cache overflow and numeric keys and contents -$ok = 1; +my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } print ($ok ? "ok 8\n" : "not ok 8\n"); -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print ($size > 0 ? "ok 9\n" : "not ok 9\n"); @h{0..200} = 200..400; -@foo = @h{0..200}; +my @foo = @h{0..200}; print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); @@ -125,21 +139,13 @@ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); untie %h; unlink 'Op.dbmx.dir', $Dfile; -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - { # sub-class test package Another ; use strict ; + use warnings ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; print FILE <<'EOM' ; @@ -147,6 +153,7 @@ sub ok package SubDB ; use strict ; + use warnings ; use vars qw(@ISA @EXPORT) ; require Exporter ; @@ -209,6 +216,7 @@ EOM { # DBM Filter tests use strict ; + use warnings ; my (%h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -317,6 +325,7 @@ EOM # DBM Filter with a closure use strict ; + use warnings ; my (%h, $db) ; unlink <Op.dbmx*>; @@ -361,7 +370,7 @@ EOM ok(52, $result{"store key"} eq "store key - 2: [fred jim]"); ok(53, $result{"store value"} eq "store value - 2: [joe john]"); ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(55, $result{"fetch value"} eq ""); + ok(55, ! defined $result{"fetch value"} ); ok(56, $_ eq "original") ; ok(57, $h{"fred"} eq "joe"); @@ -379,6 +388,7 @@ EOM { # DBM Filter recursion detection use strict ; + use warnings ; my (%h, $db) ; unlink <Op.dbmx*>; @@ -394,6 +404,27 @@ EOM unlink <Op.dbmx*>; } +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use ODBM_File ; + + unlink <Op.dbmx*>; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + ok(65, tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; + $h{ABC} = undef; + ok(66, $a eq "") ; + untie %h; + unlink <Op.dbmx*>; +} + if ($^O eq 'hpux') { print <<EOM; # diff --git a/contrib/perl5/t/lib/opcode.t b/contrib/perl5/t/lib/opcode.t index f83a689f057d..a785fce48b66 100755 --- a/contrib/perl5/t/lib/opcode.t +++ b/contrib/perl5/t/lib/opcode.t @@ -4,7 +4,7 @@ $|=1; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; diff --git a/contrib/perl5/t/lib/open2.t b/contrib/perl5/t/lib/open2.t index 64431123e8af..85b807c98aae 100755 --- a/contrib/perl5/t/lib/open2.t +++ b/contrib/perl5/t/lib/open2.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if (!$Config{'d_fork'} # open2/3 supported on win32 (but not Borland due to CRT bugs) diff --git a/contrib/perl5/t/lib/open3.t b/contrib/perl5/t/lib/open3.t index 7cd0ca306c76..a0da34f25681 100755 --- a/contrib/perl5/t/lib/open3.t +++ b/contrib/perl5/t/lib/open3.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if (!$Config{'d_fork'} # open2/3 supported on win32 (but not Borland due to CRT bugs) @@ -20,7 +20,7 @@ use IO::Handle; use IPC::Open3; #require 'open3.pl'; use subs 'open3'; -my $perl = './perl'; +my $perl = $^X; sub ok { my ($n, $result, $info) = @_; diff --git a/contrib/perl5/t/lib/ops.t b/contrib/perl5/t/lib/ops.t index ce8b6d0d5f90..56b1bacabb09 100755 --- a/contrib/perl5/t/lib/ops.t +++ b/contrib/perl5/t/lib/ops.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; diff --git a/contrib/perl5/t/lib/parsewords.t b/contrib/perl5/t/lib/parsewords.t index 2c936f121fbe..261d81f3a4c0 100755 --- a/contrib/perl5/t/lib/parsewords.t +++ b/contrib/perl5/t/lib/parsewords.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use warnings; diff --git a/contrib/perl5/t/lib/ph.t b/contrib/perl5/t/lib/ph.t index dd24c79f2dde..de27dee5e23b 100755 --- a/contrib/perl5/t/lib/ph.t +++ b/contrib/perl5/t/lib/ph.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } # All the constants which Socket.pm tries to make available: diff --git a/contrib/perl5/t/lib/posix.t b/contrib/perl5/t/lib/posix.t index abc4563e1200..994704a30471 100755 --- a/contrib/perl5/t/lib/posix.t +++ b/contrib/perl5/t/lib/posix.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($^O ne 'VMS' and $Config{'extensions'} !~ /\bPOSIX\b/) { print "1..0\n"; @@ -17,6 +17,7 @@ $| = 1; print "1..27\n"; $Is_W32 = $^O eq 'MSWin32'; +$Is_Dos = $^O eq 'dos'; $testfd = open("TEST", O_RDONLY, 0) and print "ok 1\n"; read($testfd, $buffer, 9) if $testfd > 2; @@ -24,6 +25,11 @@ print $buffer eq "#!./perl\n" ? "ok 2\n" : "not ok 2\n"; write(1,"ok 3\nnot ok 3\n", 5); +if ($Is_Dos) { + for (4..5) { + print "ok $_ # skipped, no pipe() support on dos\n"; + } +} else { @fds = POSIX::pipe(); print $fds[0] > $testfd ? "ok 4\n" : "not ok 4\n"; CORE::open($reader = \*READER, "<&=".$fds[0]); @@ -32,10 +38,11 @@ print $writer "ok 5\n"; close $writer; print <$reader>; close $reader; +} -if ($Is_W32) { +if ($Is_W32 || $Is_Dos) { for (6..11) { - print "ok $_ # skipped, no sigaction support on win32\n"; + print "ok $_ # skipped, no sigaction support on win32/dos\n"; } } else { diff --git a/contrib/perl5/t/lib/safe1.t b/contrib/perl5/t/lib/safe1.t index 6e1287358584..27993d95c9f5 100755 --- a/contrib/perl5/t/lib/safe1.t +++ b/contrib/perl5/t/lib/safe1.t @@ -2,7 +2,7 @@ $|=1; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; diff --git a/contrib/perl5/t/lib/safe2.t b/contrib/perl5/t/lib/safe2.t index 293b5156926e..4d6c84a6926b 100755 --- a/contrib/perl5/t/lib/safe2.t +++ b/contrib/perl5/t/lib/safe2.t @@ -2,7 +2,7 @@ $|=1; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; diff --git a/contrib/perl5/t/lib/sdbm.t b/contrib/perl5/t/lib/sdbm.t index 2689d1962e52..3221ca46ed63 100755 --- a/contrib/perl5/t/lib/sdbm.t +++ b/contrib/perl5/t/lib/sdbm.t @@ -4,26 +4,39 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if (($Config{'extensions'} !~ /\bSDBM_File\b/) && ($^O ne 'VMS')){ print "1..0\n"; exit 0; } } + +use strict; +use warnings; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + require SDBM_File; #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; -print "1..66\n"; +print "1..68\n"; unlink <Op_dbmx.*>; umask(0); -print (tie(%h,SDBM_File,'Op_dbmx', O_RDWR|O_CREAT, 0640) - ? "ok 1\n" : "not ok 1\n"); +my %h ; +ok(1, tie %h,'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640); -$Dfile = "Op_dbmx.pag"; +my $Dfile = "Op_dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op_dbmx.*>; } @@ -31,11 +44,12 @@ if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') { print "ok 2 # Skipped: different file permission semantics\n"; } else { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); } -while (($key,$value) = each(%h)) { +my $i = 0; +while (my ($key,$value) = each(%h)) { $i++; } print (!$i ? "ok 3\n" : "not ok 3\n"); @@ -60,7 +74,7 @@ $h{'goner2'} = 'snork'; delete $h{'goner2'}; untie(%h); -print (tie(%h,SDBM_File,'Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); +print (tie(%h,'SDBM_File','Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); $h{'j'} = 'J'; $h{'k'} = 'K'; @@ -85,12 +99,12 @@ $h{'goner3'} = 'snork'; delete $h{'goner1'}; delete $h{'goner3'}; -@keys = keys(%h); -@values = values(%h); +my @keys = keys(%h); +my @values = values(%h); if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} -while (($key,$value) = each(%h)) { +while (my ($key,$value) = each(%h)) { if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; @@ -106,38 +120,30 @@ $h{'foo'} = ''; $h{''} = 'bar'; # check cache overflow and numeric keys and contents -$ok = 1; +my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } print ($ok ? "ok 8\n" : "not ok 8\n"); -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print ($size > 0 ? "ok 9\n" : "not ok 9\n"); @h{0..200} = 200..400; -@foo = @h{0..200}; +my @foo = @h{0..200}; print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - { # sub-class test package Another ; use strict ; + use warnings ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; print FILE <<'EOM' ; @@ -145,6 +151,7 @@ sub ok package SubDB ; use strict ; + use warnings ; use vars qw( @ISA @EXPORT) ; require Exporter ; @@ -213,6 +220,7 @@ unlink <Op_dbmx*>, $Dfile; { # DBM Filter tests use strict ; + use warnings ; my (%h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -319,6 +327,7 @@ unlink <Op_dbmx*>, $Dfile; # DBM Filter with a closure use strict ; + use warnings ; my (%h, $db) ; unlink <Op_dbmx*>; @@ -363,7 +372,7 @@ unlink <Op_dbmx*>, $Dfile; ok(54, $result{"store key"} eq "store key - 2: [fred jim]"); ok(55, $result{"store value"} eq "store value - 2: [joe john]"); ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(57, $result{"fetch value"} eq ""); + ok(57, ! defined $result{"fetch value"} ); ok(58, $_ eq "original") ; ok(59, $h{"fred"} eq "joe"); @@ -381,6 +390,7 @@ unlink <Op_dbmx*>, $Dfile; { # DBM Filter recursion detection use strict ; + use warnings ; my (%h, $db) ; unlink <Op_dbmx*>; @@ -396,3 +406,24 @@ unlink <Op_dbmx*>, $Dfile; unlink <Op_dbmx*>; } +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use SDBM_File ; + + unlink <Op_dbmx*>; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + ok(67, tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; + $h{ABC} = undef; + ok(68, $a eq "") ; + + untie %h; + unlink <Op_dbmx*>; +} diff --git a/contrib/perl5/t/lib/searchdict.t b/contrib/perl5/t/lib/searchdict.t index 46cea394bc6e..c36fdb8c34b3 100755 --- a/contrib/perl5/t/lib/searchdict.t +++ b/contrib/perl5/t/lib/searchdict.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..4\n"; diff --git a/contrib/perl5/t/lib/selectsaver.t b/contrib/perl5/t/lib/selectsaver.t index 677caec894b2..3b58d709ab3a 100755 --- a/contrib/perl5/t/lib/selectsaver.t +++ b/contrib/perl5/t/lib/selectsaver.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..3\n"; diff --git a/contrib/perl5/t/lib/socket.t b/contrib/perl5/t/lib/socket.t index d5e1848a3eb5..481fd8f3e0da 100755 --- a/contrib/perl5/t/lib/socket.t +++ b/contrib/perl5/t/lib/socket.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bSocket\b/ && !(($^O eq 'VMS') && $Config{d_socket})) { @@ -21,8 +21,8 @@ if (socket(T,PF_INET,SOCK_STREAM,6)) { if (connect(T,pack_sockaddr_in(7,inet_aton("localhost")))){ print "ok 2\n"; - print "# Connected to ", - inet_ntoa((unpack_sockaddr_in(getpeername(T)))[1]),"\n"; + print "# Connected to " . + inet_ntoa((unpack_sockaddr_in(getpeername(T)))[1])."\n"; syswrite(T,"hello",5); $read = sysread(T,$buff,10); # Connection may be granted, then closed! @@ -51,8 +51,8 @@ if( socket(S,PF_INET,SOCK_STREAM,6) ){ if (connect(S,pack_sockaddr_in(7,INADDR_LOOPBACK))){ print "ok 5\n"; - print "# Connected to ", - inet_ntoa((unpack_sockaddr_in(getpeername(S)))[1]),"\n"; + print "# Connected to " . + inet_ntoa((unpack_sockaddr_in(getpeername(S)))[1])."\n"; syswrite(S,"olleh",5); $read = sysread(S,$buff,10); # Connection may be granted, then closed! diff --git a/contrib/perl5/t/lib/soundex.t b/contrib/perl5/t/lib/soundex.t index a04cccd43c61..d35f264c7a67 100755 --- a/contrib/perl5/t/lib/soundex.t +++ b/contrib/perl5/t/lib/soundex.t @@ -18,7 +18,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Text::Soundex; diff --git a/contrib/perl5/t/lib/symbol.t b/contrib/perl5/t/lib/symbol.t index 14c919c0f36e..03449a3ed749 100755 --- a/contrib/perl5/t/lib/symbol.t +++ b/contrib/perl5/t/lib/symbol.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..8\n"; diff --git a/contrib/perl5/t/lib/syslfs.t b/contrib/perl5/t/lib/syslfs.t index 28571209428f..2bdb69d7e01c 100755 --- a/contrib/perl5/t/lib/syslfs.t +++ b/contrib/perl5/t/lib/syslfs.t @@ -4,16 +4,21 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; # Don't bother if there are no quad offsets. if ($Config{lseeksize} < 8) { - print "1..0\n# no 64-bit file offsets\n"; + print "1..0 # Skip: no 64-bit file offsets\n"; exit(0); } require Fcntl; import Fcntl qw(/^O_/ /^SEEK_/); } +use strict; + +our @s; +our $fail; + sub zap { close(BIG); unlink("big"); @@ -26,35 +31,42 @@ sub bye { exit(0); } +my $explained; + sub explain { - print <<EOM; + unless ($explained++) { + print <<EOM; # -# If the lfs (large file support: large meaning larger than two gigabytes) -# tests are skipped or fail, it may mean either that your process -# (or process group) is not allowed to write large files (resource -# limits) or that the file system you are running the tests on doesn't -# let your user/group have large files (quota) or the filesystem simply -# doesn't support large files. You may even need to reconfigure your kernel. -# (This is all very operating system and site-dependent.) +# If the lfs (large file support: large meaning larger than two +# gigabytes) tests are skipped or fail, it may mean either that your +# process (or process group) is not allowed to write large files +# (resource limits) or that the file system (the network filesystem?) +# you are running the tests on doesn't let your user/group have large +# files (quota) or the filesystem simply doesn't support large files. +# You may even need to reconfigure your kernel. (This is all very +# operating system and site-dependent.) # # Perl may still be able to support large files, once you have # such a process, enough quota, and such a (file) system. +# It is just that the test failed now. # EOM + } + print "1..0 # Skip: @_\n" if @_; } print "# checking whether we have sparse files...\n"; # Known have-nots. -if ($^O eq 'win32' || $^O eq 'vms') { - print "1..0\n# no sparse files (because this is $^O) \n"; +if ($^O eq 'MSWin32' || $^O eq 'VMS') { + print "1..0 # Skip: no sparse files in $^O\n"; bye(); } # Known haves that have problems running this test # (for example because they do not support sparse files, like UNICOS) if ($^O eq 'unicos') { - print "1..0\n# large files known to work but unable to test them here ($^O)\n"; + print "1..0 # Skip: no sparse files in $^0, unable to test large files\n"; bye(); } @@ -95,7 +107,7 @@ zap(); unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 && $s1[11] == $s2[11] && $s1[12] == $s2[12]) { - print "1..0\n#no sparse files?\n"; + print "1..0 # Skip: no sparse files?\n"; bye; } @@ -103,16 +115,25 @@ print "# we seem to have sparse files...\n"; # By now we better be sure that we do have sparse files: # if we are not, the following will hog 5 gigabytes of disk. Ooops. +# This may fail by producing some signal; run in a subprocess first for safety $ENV{LC_ALL} = "C"; +my $r = system '../perl', '-I../lib', '-e', <<'EOF'; +use Fcntl qw(/^O_/ /^SEEK_/); +sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or die $!; +my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET); +my $syswrite = syswrite(BIG, "big"); +exit 0; +EOF + sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or do { warn "sysopen 'big' failed: $!\n"; bye }; my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET); -unless (defined $sysseek && $sysseek == 5_000_000_000) { - print "1..0\n# seeking past 2GB failed: $! (sysseek returned ", - defined $sysseek ? $sysseek : 'undef', ")\n"; - explain(); +unless (! $r && defined $sysseek && $sysseek == 5_000_000_000) { + $sysseek = 'undef' unless defined $sysseek; + explain("seeking past 2GB failed: ", + $r ? 'signal '.($r & 0x7f) : "$! (sysseek returned $sysseek)"); bye(); } @@ -125,11 +146,12 @@ my $close = close BIG; print "# close failed: $!\n" unless $close; unless($syswrite && $close) { if ($! =~/too large/i) { - print "1..0\n# writing past 2GB failed: process limits?\n"; + explain("writing past 2GB failed: process limits?"); } elsif ($! =~ /quota/i) { - print "1..0\n# filesystem quota limits?\n"; + explain("filesystem quota limits?"); + } else { + explain("error: $!"); } - explain(); bye(); } @@ -138,8 +160,7 @@ unless($syswrite && $close) { print "# @s\n"; unless ($s[7] == 5_000_000_003) { - print "1..0\n# not configured to use large files?\n"; - explain(); + explain("kernel/fs not configured to use large files?"); bye(); } @@ -148,9 +169,30 @@ sub fail () { $fail++; } +sub offset ($$) { + my ($offset_will_be, $offset_want) = @_; + my $offset_is = eval $offset_will_be; + unless ($offset_is == $offset_want) { + print "# bad offset $offset_is, want $offset_want\n"; + my ($offset_func) = ($offset_will_be =~ /^(\w+)/); + if (unpack("L", pack("L", $offset_want)) == $offset_is) { + print "# 32-bit wraparound suspected in $offset_func() since\n"; + print "# $offset_want cast into 32 bits equals $offset_is.\n"; + } elsif ($offset_want - unpack("L", pack("L", $offset_want)) - 1 + == $offset_is) { + print "# 32-bit wraparound suspected in $offset_func() since\n"; + printf "# %s - unpack('L', pack('L', %s)) - 1 equals %s.\n", + $offset_want, + $offset_want, + $offset_is; + } + fail; + } +} + print "1..17\n"; -my $fail = 0; +$fail = 0; fail unless $s[7] == 5_000_000_003; # exercizes pp_stat print "ok 1\n"; @@ -166,28 +208,28 @@ print "ok 4\n"; sysopen(BIG, "big", O_RDONLY) or do { warn "sysopen failed: $!\n"; bye }; -fail unless sysseek(BIG, 4_500_000_000, SEEK_SET) == 4_500_000_000; +offset('sysseek(BIG, 4_500_000_000, SEEK_SET)', 4_500_000_000); print "ok 5\n"; -fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_000; +offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000); print "ok 6\n"; -fail unless sysseek(BIG, 1, SEEK_CUR) == 4_500_000_001; +offset('sysseek(BIG, 1, SEEK_CUR)', 4_500_000_001); print "ok 7\n"; -fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_001; +offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_001); print "ok 8\n"; -fail unless sysseek(BIG, -1, SEEK_CUR) == 4_500_000_000; +offset('sysseek(BIG, -1, SEEK_CUR)', 4_500_000_000); print "ok 9\n"; -fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_000; +offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000); print "ok 10\n"; -fail unless sysseek(BIG, -3, SEEK_END) == 5_000_000_000; +offset('sysseek(BIG, -3, SEEK_END)', 5_000_000_000); print "ok 11\n"; -fail unless sysseek(BIG, 0, SEEK_CUR) == 5_000_000_000; +offset('sysseek(BIG, 0, SEEK_CUR)', 5_000_000_000); print "ok 12\n"; my $big; @@ -199,7 +241,9 @@ fail unless $big eq "big"; print "ok 14\n"; # 705_032_704 = (I32)5_000_000_000 -fail unless seek(BIG, 705_032_704, SEEK_SET); +# See that we don't have "big" in the 705_... spot: +# that would mean that we have a wraparound. +fail unless sysseek(BIG, 705_032_704, SEEK_SET); print "ok 15\n"; my $zero; @@ -210,7 +254,7 @@ print "ok 16\n"; fail unless $zero eq "\0\0\0"; print "ok 17\n"; -explain if $fail; +explain() if $fail; bye(); # does the necessary cleanup diff --git a/contrib/perl5/t/lib/textfill.t b/contrib/perl5/t/lib/textfill.t index daeee2367cd5..5ff3850cafd2 100755 --- a/contrib/perl5/t/lib/textfill.t +++ b/contrib/perl5/t/lib/textfill.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Text::Wrap qw(&fill); diff --git a/contrib/perl5/t/lib/texttabs.t b/contrib/perl5/t/lib/texttabs.t index 80395f4c0279..c6ca123a8eec 100755 --- a/contrib/perl5/t/lib/texttabs.t +++ b/contrib/perl5/t/lib/texttabs.t @@ -1,28 +1,139 @@ -#!./perl +#!./perl -w BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -print "1..3\n"; +@tests = (split(/\nEND\n/s, <<DONE)); +TEST 1 u + x +END + x +END +TEST 2 e + x +END + x +END +TEST 3 e + x + y + z +END + x + y + z +END +TEST 4 u + x + y + z +END + x + y + z +END +TEST 5 u +This Is a test of a line with many embedded tabs +END +This Is a test of a line with many embedded tabs +END +TEST 6 e +This Is a test of a line with many embedded tabs +END +This Is a test of a line with many embedded tabs +END +TEST 7 u + x +END + x +END +TEST 8 e + + + -use Text::Tabs; + +END + + + + + +END +TEST 9 u + +END + +END +TEST 10 u + + + + + +END + + + + + +END +TEST 11 u +foobar IN A 140.174.82.12 + +END +foobar IN A 140.174.82.12 -$tabstop = 4; +END +DONE -$s1 = "foo\tbar\tb\tb"; -$s2 = expand $s1; -$s3 = unexpand $s2; +$| = 1; -print "not " unless $s2 eq "foo bar b b"; -print "ok 1\n"; +print "1..".scalar(@tests/2)."\n"; -print "not " unless $s3 eq "foo bar b\tb"; -print "ok 2\n"; +use Text::Tabs; + +$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; + +$tn = 1; +while (@tests) { + my $in = shift(@tests); + my $out = shift(@tests); + $in =~ s/^TEST\s*(\d+)?\s*(\S+)?\n//; -$tabstop = 8; + if ($2 eq 'e') { + $f = \&expand; + $fn = 'expand'; + } else { + $f = \&unexpand; + $fn = 'unexpand'; + } -print "not " unless unexpand(" foo") eq "\t\t foo"; -print "ok 3\n"; + my $back = &$f($in); + + if ($back eq $out) { + print "ok $tn\n"; + } elsif ($rerun) { + my $oi = $in; + foreach ($in, $back, $out) { + s/\t/^I\t/gs; + s/\n/\$\n/gs; + } + print "------------ input ------------\n"; + print $in; + print "\$\n------------ $fn -----------\n"; + print $back; + print "\$\n------------ expected ---------\n"; + print $out; + print "\$\n-------------------------------\n"; + $Text::Tabs::debug = 1; + my $back = &$f($in); + exit(1); + } else { + print "not ok $tn\n"; + } + $tn++; +} diff --git a/contrib/perl5/t/lib/textwrap.t b/contrib/perl5/t/lib/textwrap.t index bb1d5ca4a532..fee6ce070d44 100755 --- a/contrib/perl5/t/lib/textwrap.t +++ b/contrib/perl5/t/lib/textwrap.t @@ -2,9 +2,8 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -use Text::Wrap qw(&wrap); @tests = (split(/\nEND\n/s, <<DONE)); TEST1 @@ -84,21 +83,57 @@ END a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123 4567 END +TEST10 +my mother once said +"never eat paste my darling" +would that I heeded +END + my mother once said + "never eat paste my darling" + would that I heeded +END +TEST11 +This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_program_does_not_crash_and_burn +END + This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_pr + ogram_does_not_crash_and_burn +END +TEST12 +This + +Has + +Blank + +Lines + +END + This + + Has + + Blank + + Lines + +END DONE $| = 1; -print "1..", @tests/2, "\n"; +print "1..", 1 +@tests, "\n"; use Text::Wrap; $rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; $tn = 1; -while (@tests) { - my $in = shift(@tests); - my $out = shift(@tests); + +@st = @tests; +while (@st) { + my $in = shift(@st); + my $out = shift(@st); $in =~ s/^TEST(\d+)?\n//; @@ -126,4 +161,49 @@ while (@tests) { print "not ok $tn\n"; } $tn++; + +} + +@st = @tests; +while(@st) { + my $in = shift(@st); + my $out = shift(@st); + + $in =~ s/^TEST(\d+)?\n//; + + my @in = split("\n", $in, -1); + @in = ((map { "$_\n" } @in[0..$#in-1]), $in[-1]); + + my $back = wrap(' ', ' ', @in); + + if ($back eq $out) { + print "ok $tn\n"; + } elsif ($rerun) { + my $oi = $in; + foreach ($in, $back, $out) { + s/\t/^I\t/gs; + s/\n/\$\n/gs; + } + print "------------ input2 ------------\n"; + print $in; + print "\n------------ output2 -----------\n"; + print $back; + print "\n------------ expected2 ---------\n"; + print $out; + print "\n-------------------------------\n"; + $Text::Wrap::debug = 1; + wrap(' ', ' ', $oi); + exit(1); + } else { + print "not ok $tn\n"; + } + $tn++; } + +$Text::Wrap::huge = 'overflow'; + +my $tw = 'This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_program_does_not_crash_and_burn'; +my $w = wrap('zzz','yyy',$tw); +print (($w eq "zzz$tw") ? "ok $tn\n" : "not ok $tn"); +$tn++; + diff --git a/contrib/perl5/t/lib/thr5005.t b/contrib/perl5/t/lib/thr5005.t index 6b3c800f9bc0..680e1af3e728 100755 --- a/contrib/perl5/t/lib/thr5005.t +++ b/contrib/perl5/t/lib/thr5005.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if (! $Config{'use5005threads'}) { print "1..0 # Skip: not use5005threads\n"; @@ -13,7 +13,7 @@ BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } $| = 1; -print "1..21\n"; +print "1..22\n"; use Thread 'yield'; print "ok 1\n"; @@ -89,6 +89,18 @@ my $long = "This is short."; my $longe = " short."; my $thr1 = new Thread \&threaded, $short, $shorte, "19"; my $thr2 = new Thread \&threaded, $long, $longe, "20"; +my $thr3 = new Thread \&testsprintf, "21"; + +sub testsprintf { + my $testno = shift; + # this may coredump if thread vars are not properly initialised + my $same = sprintf "%.0f", $testno; + if ($testno eq $same) { + print "ok $testno\n"; + } else { + print "not ok $testno\t# '$testno' ne '$same'\n"; + } +} sub threaded { my ($string, $string_end, $testno) = @_; @@ -115,4 +127,5 @@ EOT } $thr1->join; $thr2->join; -print "ok 21\n"; +$thr3->join; +print "ok 22\n"; diff --git a/contrib/perl5/t/lib/tie-push.t b/contrib/perl5/t/lib/tie-push.t index 23a0a9403a4f..b19aa0d0e8fe 100755 --- a/contrib/perl5/t/lib/tie-push.t +++ b/contrib/perl5/t/lib/tie-push.t @@ -2,7 +2,8 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '.'; + push @INC, '../lib'; } { diff --git a/contrib/perl5/t/lib/tie-stdarray.t b/contrib/perl5/t/lib/tie-stdarray.t index 5a678a5a1ffc..c4ae07102ee8 100755 --- a/contrib/perl5/t/lib/tie-stdarray.t +++ b/contrib/perl5/t/lib/tie-stdarray.t @@ -2,7 +2,8 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '.'; + push @INC, '../lib'; } use Tie::Array; diff --git a/contrib/perl5/t/lib/tie-stdhandle.t b/contrib/perl5/t/lib/tie-stdhandle.t index cf3a1831d0d2..f03f5d92f6a0 100755 --- a/contrib/perl5/t/lib/tie-stdhandle.t +++ b/contrib/perl5/t/lib/tie-stdhandle.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Tie::Handle; @@ -10,16 +10,16 @@ tie *tst,Tie::StdHandle; $f = 'tst'; -print "1..13\n"; +print "1..13\n"; # my $file tests -unlink("afile.new") if -f "afile"; -print "$!\nnot " unless open($f,"+>afile"); +unlink("afile.new") if -f "afile"; +print "$!\nnot " unless open($f,"+>afile") && open($f, "+<", "afile"); print "ok 1\n"; print "$!\nnot " unless binmode($f); print "ok 2\n"; -print "not " unless -f "afile"; +print "not " unless -f "afile"; print "ok 3\n"; print "not " unless print $f "SomeData\n"; print "ok 4\n"; @@ -44,4 +44,4 @@ print "not " unless eof($f); print "ok 12\n"; print "not " unless close($f); print "ok 13\n"; -unlink("afile"); +unlink("afile"); diff --git a/contrib/perl5/t/lib/tie-stdpush.t b/contrib/perl5/t/lib/tie-stdpush.t index 35ae1b89a4f6..31af30c32c75 100755 --- a/contrib/perl5/t/lib/tie-stdpush.t +++ b/contrib/perl5/t/lib/tie-stdpush.t @@ -2,7 +2,8 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '.'; + push @INC, '../lib'; } use Tie::Array; diff --git a/contrib/perl5/t/lib/timelocal.t b/contrib/perl5/t/lib/timelocal.t index 359d71e64c3d..100e0768aa4e 100755 --- a/contrib/perl5/t/lib/timelocal.t +++ b/contrib/perl5/t/lib/timelocal.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Time::Local; diff --git a/contrib/perl5/t/lib/trig.t b/contrib/perl5/t/lib/trig.t index 20669f0bd97e..6949622f0aa1 100755 --- a/contrib/perl5/t/lib/trig.t +++ b/contrib/perl5/t/lib/trig.t @@ -10,7 +10,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Math::Trig; @@ -26,10 +26,11 @@ if ($^O eq 'unicos') { # See lib/Math/Complex.pm and t/lib/complex.t. } sub near ($$;$) { - abs($_[0] - $_[1]) < (defined $_[2] ? $_[2] : $eps); + my $e = defined $_[2] ? $_[2] : $eps; + $_[1] ? (abs($_[0]/$_[1] - 1) < $e) : abs($_[0]) < $e; } -print "1..20\n"; +print "1..23\n"; $x = 0.9; print 'not ' unless (near(tan($x), sin($x) / cos($x))); @@ -137,24 +138,42 @@ use Math::Trig ':radial'; } { - use Math::Trig 'great_circle_distance'; + use Math::Trig 'great_circle_distance'; - print 'not ' - unless (near(great_circle_distance(0, 0, 0, pi/2), pi/2)); - print "ok 18\n"; + print 'not ' + unless (near(great_circle_distance(0, 0, 0, pi/2), pi/2)); + print "ok 18\n"; - print 'not ' - unless (near(great_circle_distance(0, 0, pi, pi), pi)); - print "ok 19\n"; + print 'not ' + unless (near(great_circle_distance(0, 0, pi, pi), pi)); + print "ok 19\n"; - # London to Tokyo. - my @L = (deg2rad(-0.5), deg2rad(90 - 51.3)); - my @T = (deg2rad(139.8),deg2rad(90 - 35.7)); + # London to Tokyo. + my @L = (deg2rad(-0.5), deg2rad(90 - 51.3)); + my @T = (deg2rad(139.8),deg2rad(90 - 35.7)); - my $km = great_circle_distance(@L, @T, 6378); + my $km = great_circle_distance(@L, @T, 6378); - print 'not ' unless (near($km, 9605.26637021388)); - print "ok 20\n"; + print 'not ' unless (near($km, 9605.26637021388)); + print "ok 20\n"; +} + +{ + my $R2D = 57.295779513082320876798154814169; + + sub frac { $_[0] - int($_[0]) } + + my $lotta_radians = deg2rad(1E+20, 1); + print "not " unless near($lotta_radians, 1E+20/$R2D); + print "ok 21\n"; + + my $negat_degrees = rad2deg(-1E20, 1); + print "not " unless near($negat_degrees, -1E+20*$R2D); + print "ok 22\n"; + + my $posit_degrees = rad2deg(-10000, 1); + print "not " unless near($posit_degrees, -10000*$R2D); + print "ok 23\n"; } # eof diff --git a/contrib/perl5/t/op/64bitint.t b/contrib/perl5/t/op/64bitint.t index 60f72c3536e4..88fbc55c6712 100755 --- a/contrib/perl5/t/op/64bitint.t +++ b/contrib/perl5/t/op/64bitint.t @@ -3,20 +3,20 @@ BEGIN { eval { my $q = pack "q", 0 }; if ($@) { - print "1..0\n# no 64-bit types\n"; + print "1..0\n# Skip: no 64-bit types\n"; exit(0); } chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -# This could use a lot of more tests. +# This could use many more tests. # so that using > 0xfffffff constants and # 32+ bit integers don't cause noise no warnings qw(overflow portable); -print "1..48\n"; +print "1..55\n"; my $q = 12345678901; my $r = 23456789012; @@ -123,85 +123,106 @@ $x = $q - $r; print "not " unless $x == -11111110111 && -$x > $f; print "ok 22\n"; -$x = $q * 1234567; -print "not " unless $x == 15241567763770867 && $x > $f; -print "ok 23\n"; - -$x /= 1234567; -print "not " unless $x == $q && $x > $f; -print "ok 24\n"; - -$x = 98765432109 % 12345678901; -print "not " unless $x == 901; -print "ok 25\n"; - -# The following 12 tests adapted from op/inc. - -$a = 9223372036854775807; -$c = $a++; -print "not " unless $a == 9223372036854775808; -print "ok 26\n"; - -$a = 9223372036854775807; -$c = ++$a; -print "not " unless $a == 9223372036854775808 && $c == $a; -print "ok 27\n"; - -$a = 9223372036854775807; -$c = $a + 1; -print "not " unless $a == 9223372036854775807 && $c == 9223372036854775808; -print "ok 28\n"; - -$a = -9223372036854775808; -$c = $a--; -print "not " unless $a == -9223372036854775809 && $c == -9223372036854775808; -print "ok 29\n"; - -$a = -9223372036854775808; -$c = --$a; -print "not " unless $a == -9223372036854775809 && $c == $a; -print "ok 30\n"; - -$a = -9223372036854775808; -$c = $a - 1; -print "not " unless $a == -9223372036854775808 && $c == -9223372036854775809; -print "ok 31\n"; - -$a = 9223372036854775808; -$a = -$a; -$c = $a--; -print "not " unless $a == -9223372036854775809 && $c == -9223372036854775808; -print "ok 32\n"; - -$a = 9223372036854775808; -$a = -$a; -$c = --$a; -print "not " unless $a == -9223372036854775809 && $c == $a; -print "ok 33\n"; - -$a = 9223372036854775808; -$a = -$a; -$c = $a - 1; -print "not " unless $a == -9223372036854775808 && $c == -9223372036854775809; -print "ok 34\n"; - -$a = 9223372036854775808; -$b = -$a; -$c = $b--; -print "not " unless $b == -$a-1 && $c == -$a; -print "ok 35\n"; - -$a = 9223372036854775808; -$b = -$a; -$c = --$b; -print "not " unless $b == -$a-1 && $c == $b; -print "ok 36\n"; - -$a = 9223372036854775808; -$b = -$a; -$b = $b - 1; -print "not " unless $b == -(++$a); -print "ok 37\n"; +if ($^O ne 'unicos') { + $x = $q * 1234567; + print "not " unless $x == 15241567763770867 && $x > $f; + print "ok 23\n"; + + $x /= 1234567; + print "not " unless $x == $q && $x > $f; + print "ok 24\n"; + + $x = 98765432109 % 12345678901; + print "not " unless $x == 901; + print "ok 25\n"; + + # The following 12 tests adapted from op/inc. + + $a = 9223372036854775807; + $c = $a++; + print "not " unless $a == 9223372036854775808; + print "ok 26\n"; + + $a = 9223372036854775807; + $c = ++$a; + print "not " + unless $a == 9223372036854775808 && $c == $a; + print "ok 27\n"; + + $a = 9223372036854775807; + $c = $a + 1; + print "not " + unless $a == 9223372036854775807 && $c == 9223372036854775808; + print "ok 28\n"; + + $a = -9223372036854775808; + $c = $a--; + print "not " + unless $a == -9223372036854775809 && $c == -9223372036854775808; + print "ok 29\n"; + + $a = -9223372036854775808; + $c = --$a; + print "not " + unless $a == -9223372036854775809 && $c == $a; + print "ok 30\n"; + + $a = -9223372036854775808; + $c = $a - 1; + print "not " + unless $a == -9223372036854775808 && $c == -9223372036854775809; + print "ok 31\n"; + + $a = 9223372036854775808; + $a = -$a; + $c = $a--; + print "not " + unless $a == -9223372036854775809 && $c == -9223372036854775808; + print "ok 32\n"; + + $a = 9223372036854775808; + $a = -$a; + $c = --$a; + print "not " + unless $a == -9223372036854775809 && $c == $a; + print "ok 33\n"; + + $a = 9223372036854775808; + $a = -$a; + $c = $a - 1; + print "not " + unless $a == -9223372036854775808 && $c == -9223372036854775809; + print "ok 34\n"; + + $a = 9223372036854775808; + $b = -$a; + $c = $b--; + print "not " + unless $b == -$a-1 && $c == -$a; + print "ok 35\n"; + + $a = 9223372036854775808; + $b = -$a; + $c = --$b; + print "not " + unless $b == -$a-1 && $c == $b; + print "ok 36\n"; + + $a = 9223372036854775808; + $b = -$a; + $b = $b - 1; + print "not " + unless $b == -(++$a); + print "ok 37\n"; + +} else { + # Unicos has imprecise doubles (14 decimal digits or so), + # especially if operating near the UV/IV limits the low-order bits + # become mangled even by simple arithmetic operations. + for (23..37) { + print "ok $_ # skipped: too imprecise numbers\n"; + } +} $x = ''; @@ -233,10 +254,44 @@ print "ok 45\n"; print "not " unless (0x8000000000000000 | 1) == 0x8000000000000001; print "ok 46\n"; -print "not " unless (0xf000000000000000 & 0x8000000000000000) == 0x8000000000000000; +print "not " + unless (0xf000000000000000 & 0x8000000000000000) == 0x8000000000000000; print "ok 47\n"; -print "not " unless (0xf000000000000000 ^ 0xfffffffffffffff0) == 0x0ffffffffffffff0; +print "not " + unless (0xf000000000000000 ^ 0xfffffffffffffff0) == 0x0ffffffffffffff0; print "ok 48\n"; + +print "not " + unless (sprintf "%b", ~0) eq + '1111111111111111111111111111111111111111111111111111111111111111'; +print "ok 49\n"; + +print "not " + unless (sprintf "%64b", ~0) eq + '1111111111111111111111111111111111111111111111111111111111111111'; +print "ok 50\n"; + +print "not " unless (sprintf "%d", ~0>>1) eq '9223372036854775807'; +print "ok 51\n"; + +print "not " unless (sprintf "%u", ~0) eq '18446744073709551615'; +print "ok 52\n"; + +# If the 53..55 fail you have problems in the parser's string->int conversion, +# see toke.c:scan_num(). + +$q = -9223372036854775808; +print "# $q ne\n# -9223372036854775808\nnot " unless "$q" eq "-9223372036854775808"; +print "ok 53\n"; + +$q = 9223372036854775807; +print "# $q ne\n# 9223372036854775807\nnot " unless "$q" eq "9223372036854775807"; +print "ok 54\n"; + +$q = 18446744073709551615; +print "# $q ne\n# 18446744073709551615\nnot " unless "$q" eq "18446744073709551615"; +print "ok 55\n"; + # eof diff --git a/contrib/perl5/t/op/append.t b/contrib/perl5/t/op/append.t index d11514615ac2..5aa4bf900729 100755 --- a/contrib/perl5/t/op/append.t +++ b/contrib/perl5/t/op/append.t @@ -2,7 +2,7 @@ # $RCSfile: append.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:36 $ -print "1..3\n"; +print "1..13\n"; $a = 'ab' . 'c'; # compile time $b = 'def'; @@ -19,3 +19,41 @@ $_ = $a; $_ .= $b; print "#3\t:$_: eq :abcdef:\n"; if ($_ eq 'abcdef') {print "ok 3\n";} else {print "not ok 3\n";} + +# test that when right argument of concat is UTF8, and is the same +# variable as the target, and the left argument is not UTF8, it no +# longer frees the wrong string. +{ + sub r2 { + my $string = ''; + $string .= pack("U0a*", 'mnopqrstuvwx'); + $string = "abcdefghijkl$string"; + } + + r2() and print "ok $_\n" for qw/ 4 5 /; +} + +# test that nul bytes get copied +{ +# Character 'b' occurs at codepoint 130 decimal or \202 octal +# under an EBCDIC coded character set. +# my($a, $ab) = ("a", "a\000b"); + my($a, $ab) = ("\141", "\141\000\142"); + my($u, $ub) = map pack("U0a*", $_), $a, $ab; + my $t1 = $a; $t1 .= $ab; + print $t1 =~ /\142/ ? "ok 6\n" : "not ok 6\t# $t1\n"; + my $t2 = $a; $t2 .= $ub; + print $t2 =~ /\142/ ? "ok 7\n" : "not ok 7\t# $t2\n"; + my $t3 = $u; $t3 .= $ab; + print $t3 =~ /\142/ ? "ok 8\n" : "not ok 8\t# $t3\n"; + my $t4 = $u; $t4 .= $ub; + print $t4 =~ /\142/ ? "ok 9\n" : "not ok 9\t# $t4\n"; + my $t5 = $a; $t5 = $ab . $t5; + print $t5 =~ /\142/ ? "ok 10\n" : "not ok 10\t# $t5\n"; + my $t6 = $a; $t6 = $ub . $t6; + print $t6 =~ /\142/ ? "ok 11\n" : "not ok 11\t# $t6\n"; + my $t7 = $u; $t7 = $ab . $t7; + print $t7 =~ /\142/ ? "ok 12\n" : "not ok 12\t# $t7\n"; + my $t8 = $u; $t8 = $ub . $t8; + print $t8 =~ /\142/ ? "ok 13\n" : "not ok 13\t# $t8\n"; +} diff --git a/contrib/perl5/t/op/args.t b/contrib/perl5/t/op/args.t index 48bf5afec099..ce2c39886567 100755 --- a/contrib/perl5/t/op/args.t +++ b/contrib/perl5/t/op/args.t @@ -1,6 +1,6 @@ #!./perl -print "1..8\n"; +print "1..9\n"; # test various operations on @_ @@ -52,3 +52,24 @@ sub new4 { goto &new2 } print "# got [@$y], expected [a b c y]\nnot " unless "@$y" eq "a b c y"; print "ok $ord\n"; } + +# see if POPSUB gets to see the right pad across a dounwind() with +# a reified @_ + +sub methimpl { + my $refarg = \@_; + die( "got: @_\n" ); +} + +sub method { + &methimpl; +} + +sub try { + eval { method('foo', 'bar'); }; + print "# $@" if $@; +} + +for (1..5) { try() } +++$ord; +print "ok $ord\n"; diff --git a/contrib/perl5/t/op/arith.t b/contrib/perl5/t/op/arith.t index fe2f0f458b32..5b04f9365fd1 100755 --- a/contrib/perl5/t/op/arith.t +++ b/contrib/perl5/t/op/arith.t @@ -1,6 +1,6 @@ #!./perl -print "1..8\n"; +print "1..12\n"; sub try ($$) { print +($_[1] ? "ok" : "not ok"), " $_[0]\n"; @@ -21,3 +21,10 @@ try 5, abs( 13e21 % 4e21 - 1e21) < $limit; try 6, abs(-13e21 % 4e21 - 3e21) < $limit; try 7, abs( 13e21 % -4e21 - -3e21) < $limit; try 8, abs(-13e21 % -4e21 - -1e21) < $limit; + +# UVs should behave properly + +try 9, 4063328477 % 65535 == 27407; +try 10, 4063328477 % 4063328476 == 1; +try 11, 4063328477 % 2031664238 == 1; +try 12, 2031664238 % 4063328477 == 2031664238; diff --git a/contrib/perl5/t/op/array.t b/contrib/perl5/t/op/array.t index 1108f494f844..7cc84e32176c 100755 --- a/contrib/perl5/t/op/array.t +++ b/contrib/perl5/t/op/array.t @@ -1,6 +1,6 @@ #!./perl -print "1..66\n"; +print "1..70\n"; # # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them @@ -139,8 +139,8 @@ t("@foo" eq "bar burbl blah"); # 39 @foo = ('XXX',@foo, 'YYY'); t("@foo" eq "XXX bar burbl blah YYY"); # 40 -@foo = @foo = qw(foo bar burbl blah); -t("@foo" eq "foo bar burbl blah"); # 41 +@foo = @foo = qw(foo b\a\r bu\\rbl blah); +t("@foo" eq 'foo b\a\r bu\\rbl blah'); # 41 @bar = @foo = qw(foo bar); # 42 t("@foo" eq "foo bar"); @@ -216,3 +216,16 @@ reify('ok'); print "not " unless qw(foo bar snorfle)[2] eq 'snorfle'; print "ok 66\n"; +@ary = (12,23,34,45,56); + +print "not " unless shift(@ary) == 12; +print "ok 67\n"; + +print "not " unless pop(@ary) == 56; +print "ok 68\n"; + +print "not " unless push(@ary,56) == 4; +print "ok 69\n"; + +print "not " unless unshift(@ary,12) == 5; +print "ok 70\n"; diff --git a/contrib/perl5/t/op/assignwarn.t b/contrib/perl5/t/op/assignwarn.t index b95cec51a1fc..aff433c4643b 100755 --- a/contrib/perl5/t/op/assignwarn.t +++ b/contrib/perl5/t/op/assignwarn.t @@ -8,7 +8,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use strict; @@ -21,7 +21,7 @@ sub ok { print $_[1] ? "ok " : "not ok ", $_[0], "\n"; } sub uninitialized { $warn =~ s/Use of uninitialized value[^\n]+\n//s; } -print "1..23\n"; +print "1..32\n"; { my $x; $x ++; ok 1, ! uninitialized; } { my $x; $x --; ok 2, ! uninitialized; } @@ -55,7 +55,19 @@ print "1..23\n"; { my $x; $x |= "x"; ok 21, ! uninitialized; } { my $x; $x ^= "x"; ok 22, ! uninitialized; } -ok 23, $warn eq ''; +{ use integer; my $x; $x += 1; ok 23, ! uninitialized; } +{ use integer; my $x; $x -= 1; ok 24, ! uninitialized; } + +{ use integer; my $x; $x *= 1; ok 25, uninitialized; } +{ use integer; my $x; $x /= 1; ok 26, uninitialized; } +{ use integer; my $x; $x %= 1; ok 27, uninitialized; } + +{ use integer; my $x; $x ++; ok 28, ! uninitialized; } +{ use integer; my $x; $x --; ok 29, ! uninitialized; } +{ use integer; my $x; ++ $x; ok 30, ! uninitialized; } +{ use integer; my $x; -- $x; ok 31, ! uninitialized; } + +ok 32, $warn eq ''; # If we got any errors that we were not expecting, then print them print map "#$_\n", split /\n/, $warn if length $warn; diff --git a/contrib/perl5/t/op/attrs.t b/contrib/perl5/t/op/attrs.t index 615e4d33430a..270200488169 100755 --- a/contrib/perl5/t/op/attrs.t +++ b/contrib/perl5/t/op/attrs.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } sub NTESTS () ; diff --git a/contrib/perl5/t/op/avhv.t b/contrib/perl5/t/op/avhv.t index cd7c957619df..5b91fd21474b 100755 --- a/contrib/perl5/t/op/avhv.t +++ b/contrib/perl5/t/op/avhv.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } require Tie::Array; diff --git a/contrib/perl5/t/op/bop.t b/contrib/perl5/t/op/bop.t index 7bcabdfd5878..0354f009f973 100755 --- a/contrib/perl5/t/op/bop.t +++ b/contrib/perl5/t/op/bop.t @@ -6,10 +6,10 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -print "1..30\n"; +print "1..44\n"; # numerics print ((0xdead & 0xbeef) == 0x9ead ? "ok 1\n" : "not ok 1\n"); @@ -39,7 +39,7 @@ print (((1 << ($bits - 1)) == $cusp && do { use integer; 1 << ($bits - 1) } == -$cusp) ? "ok 11\n" : "not ok 11\n"); print ((($cusp >> 1) == ($cusp / 2) && - do { use integer; $cusp >> 1 } == -($cusp / 2)) + do { use integer; abs($cusp >> 1) } == ($cusp / 2)) ? "ok 12\n" : "not ok 12\n"); $Aaz = chr(ord("A") & ord("z")); @@ -81,3 +81,91 @@ print "ok 27\n" if sprintf("%vd", v4095 ^ v801) eq 3294; print "ok 28\n" if sprintf("%vd", v4095.801.4095 & v801.4095) eq '801.801'; print "ok 29\n" if sprintf("%vd", v4095.801.4095 | v801.4095) eq '4095.4095.4095'; print "ok 30\n" if sprintf("%vd", v801.4095 ^ v4095.801.4095) eq '3294.3294.4095'; +# +print "ok 31\n" if sprintf("%vd", v120.300 & v200.400) eq '72.256'; +print "ok 32\n" if sprintf("%vd", v120.300 | v200.400) eq '248.444'; +print "ok 33\n" if sprintf("%vd", v120.300 ^ v200.400) eq '176.188'; +# +my $a = v120.300; +my $b = v200.400; +$a ^= $b; +print "ok 34\n" if sprintf("%vd", $a) eq '176.188'; +my $a = v120.300; +my $b = v200.400; +$a |= $b; +print "ok 35\n" if sprintf("%vd", $a) eq '248.444'; + +# +# UTF8 ~ behaviour +# + +my @not36; + +for (0x100...0xFFF) { + $a = ~(chr $_); + push @not36, sprintf("%#03X", $_) + if $a ne chr(~$_) or length($a) != 1 or ~$a ne chr($_); +} +if (@not36) { + print "# test 36 failed\n"; + print "not "; +} +print "ok 36\n"; + +my @not37; + +for my $i (0xEEE...0xF00) { + for my $j (0x0..0x120) { + $a = ~(chr ($i) . chr $j); + push @not37, sprintf("%#03X %#03X", $i, $j) + if $a ne chr(~$i).chr(~$j) or + length($a) != 2 or + ~$a ne chr($i).chr($j); + } +} +if (@not37) { + print "# test 37 failed\n"; + print "not "; +} +print "ok 37\n"; + +print "not " unless ~chr(~0) eq "\0"; +print "ok 38\n"; + +my @not39; + +for my $i (0x100..0x120) { + for my $j (0x100...0x120) { + push @not39, sprintf("%#03X %#03X", $i, $j) + if ~(chr($i)|chr($j)) ne (~chr($i)&~chr($j)); + } +} +if (@not39) { + print "# test 39 failed\n"; + print "not "; +} +print "ok 39\n"; + +my @not40; + +for my $i (0x100..0x120) { + for my $j (0x100...0x120) { + push @not40, sprintf("%#03X %#03X", $i, $j) + if ~(chr($i)&chr($j)) ne (~chr($i)|~chr($j)); + } +} +if (@not40) { + print "# test 40 failed\n"; + print "not "; +} +print "ok 40\n"; + +# More variations on 19 and 22. +print "ok \xFF\x{FF}\n" & "ok 41\n"; +print "ok \x{FF}\xFF\n" & "ok 42\n"; + +# Tests to see if you really can do casts negative floats to unsigned properly +$neg1 = -1.0; +print ((~ $neg1 == 0) ? "ok 43\n" : "not ok 43\n"); +$neg7 = -7.0; +print ((~ $neg7 == 6) ? "ok 44\n" : "not ok 44\n"); diff --git a/contrib/perl5/t/op/chop.t b/contrib/perl5/t/op/chop.t index 6723ca3f1b4b..1b55f1183227 100755 --- a/contrib/perl5/t/op/chop.t +++ b/contrib/perl5/t/op/chop.t @@ -1,6 +1,6 @@ #!./perl -print "1..30\n"; +print "1..37\n"; # optimized @@ -89,3 +89,30 @@ $_ = "ab\n"; $/ = \3; print chomp() == 0 ? "ok 29\n" : "not ok 29\n"; print $_ eq "ab\n" ? "ok 30\n" : "not ok 30\n"; + +# Go Unicode. + +$_ = "abc\x{1234}"; +chop; +print $_ eq "abc" ? "ok 31\n" : "not ok 31\n"; + +$_ = "abc\x{1234}d"; +chop; +print $_ eq "abc\x{1234}" ? "ok 32\n" : "not ok 32\n"; + +$_ = "\x{1234}\x{2345}"; +chop; +print $_ eq "\x{1234}" ? "ok 33\n" : "not ok 33\n"; + +my @stuff = qw(this that); +print chop(@stuff[0,1]) eq 't' ? "ok 34\n" : "not ok 34\n"; + +# bug id 20010305.012 +@stuff = qw(ab cd ef); +print chop(@stuff = @stuff) eq 'f' ? "ok 35\n" : "not ok 35\n"; + +@stuff = qw(ab cd ef); +print chop(@stuff[0, 2]) eq 'f' ? "ok 36\n" : "not ok 36\n"; + +my %stuff = (1..4); +print chop(@stuff{1, 3}) eq '4' ? "ok 37\n" : "not ok 37\n"; diff --git a/contrib/perl5/t/op/closure.t b/contrib/perl5/t/op/closure.t index c691d6f034f0..5f3245fbc9f9 100755 --- a/contrib/perl5/t/op/closure.t +++ b/contrib/perl5/t/op/closure.t @@ -7,7 +7,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Config; diff --git a/contrib/perl5/t/op/defins.t b/contrib/perl5/t/op/defins.t index 9e714a718bc1..33c74ea28e8d 100755 --- a/contrib/perl5/t/op/defins.t +++ b/contrib/perl5/t/op/defins.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; $SIG{__WARN__} = sub { $warns++; warn $_[0] }; print "1..14\n"; } diff --git a/contrib/perl5/t/op/die_exit.t b/contrib/perl5/t/op/die_exit.t index cb0478b9b2e9..a389946fe37f 100755 --- a/contrib/perl5/t/op/die_exit.t +++ b/contrib/perl5/t/op/die_exit.t @@ -7,7 +7,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -e '../lib'; + @INC = '../lib'; } if ($^O eq 'mpeix') { diff --git a/contrib/perl5/t/op/exists_sub.t b/contrib/perl5/t/op/exists_sub.t index 3363dfd837a0..d4aa29251adb 100755 --- a/contrib/perl5/t/op/exists_sub.t +++ b/contrib/perl5/t/op/exists_sub.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..9\n"; diff --git a/contrib/perl5/t/op/filetest.t b/contrib/perl5/t/op/filetest.t index e00d5fb7b06b..f757c79c05fe 100755 --- a/contrib/perl5/t/op/filetest.t +++ b/contrib/perl5/t/op/filetest.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } use Config; diff --git a/contrib/perl5/t/op/flip.t b/contrib/perl5/t/op/flip.t index 20167f3333b8..99b22eff9470 100755 --- a/contrib/perl5/t/op/flip.t +++ b/contrib/perl5/t/op/flip.t @@ -2,7 +2,7 @@ # $RCSfile: flip.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:52 $ -print "1..9\n"; +print "1..10\n"; @a = (1,2,3,4,5,6,7,8,9,10,11,12); @@ -17,7 +17,7 @@ if ($y eq '12E0123E0') {print "ok 7\n";} else {print "not ok 7\n";} @a = ('a','b','c','d','e','f','g'); -open(of,'../Configure'); +open(of,'harness') or die "Can't open harness: $!"; while (<of>) { (3 .. 5) && ($foo .= $_); } @@ -27,3 +27,10 @@ if ($x eq 3) {print "ok 8\n";} else {print "not ok 8 $x:$foo:\n";} $x = 3.14; if (($x...$x) eq "1") {print "ok 9\n";} else {print "not ok 9\n";} + +{ + # coredump reported in bug 20001018.008 + readline(UNKNOWN); + $. = 1; + print "ok 10\n" unless 1 .. 10; +} diff --git a/contrib/perl5/t/op/fork.t b/contrib/perl5/t/op/fork.t index 80c0b723b637..88b6b4b74c39 100755 --- a/contrib/perl5/t/op/fork.t +++ b/contrib/perl5/t/op/fork.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; unless ($Config{'d_fork'} or ($^O eq 'MSWin32' and $Config{useithreads} @@ -184,6 +184,28 @@ child 3 [1] -2- -3- -1- -2- -3- ######## +$| = 1; +foreach my $c (1,2,3) { + if (fork) { + print "parent $c\n"; + } + else { + print "child $c\n"; + exit; + } +} +while (wait() != -1) { print "waited\n" } +EXPECT +child 1 +child 2 +child 3 +parent 1 +parent 2 +parent 3 +waited +waited +waited +######## use Config; $| = 1; $\ = "\n"; @@ -374,3 +396,28 @@ else { EXPECT pipe_from_fork pipe_to_fork +######## +$|=1; +if ($pid = fork()) { + print "forked first kid\n"; + print "waitpid() returned ok\n" if waitpid($pid,0) == $pid; +} +else { + print "first child\n"; + exit(0); +} +if ($pid = fork()) { + print "forked second kid\n"; + print "wait() returned ok\n" if wait() == $pid; +} +else { + print "second child\n"; + exit(0); +} +EXPECT +forked first kid +first child +waitpid() returned ok +forked second kid +second child +wait() returned ok diff --git a/contrib/perl5/t/op/glob.t b/contrib/perl5/t/op/glob.t index 4c2744590b33..fc0ba77124b5 100755 --- a/contrib/perl5/t/op/glob.t +++ b/contrib/perl5/t/op/glob.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..6\n"; diff --git a/contrib/perl5/t/op/goto_xs.t b/contrib/perl5/t/op/goto_xs.t index 8d9bca1cd6d9..cf2cafd4675f 100755 --- a/contrib/perl5/t/op/goto_xs.t +++ b/contrib/perl5/t/op/goto_xs.t @@ -10,7 +10,7 @@ # break correctly as well. chdir 't' if -d 't'; -unshift @INC, "../lib"; +@INC = '../lib'; $ENV{PERL5LIB} = "../lib"; # turn warnings into fatal errors diff --git a/contrib/perl5/t/op/grent.t b/contrib/perl5/t/op/grent.t index 761d8b9cf604..211dc911bba8 100755 --- a/contrib/perl5/t/op/grent.t +++ b/contrib/perl5/t/op/grent.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, "../lib" if -d "../lib"; + @INC = '../lib'; eval {my @n = getgrgid 0}; if ($@ && $@ =~ /(The \w+ function is unimplemented)/) { print "1..0 # Skip: $1\n"; @@ -54,9 +54,9 @@ BEGIN { } } -# By now GR filehandle should be open and full of juicy group entries. +# By now the GR filehandle should be open and full of juicy group entries. -print "1..1\n"; +print "1..2\n"; # Go through at most this many groups. # (note that the first entry has been read away by now) @@ -67,9 +67,11 @@ my $tst = 1; my %perfect; my %seen; +setgrent(); while (<GR>) { chomp; - my @s = split /:/; + # LIMIT -1 so that groups with no users don't fall off + my @s = split /:/, $_, -1; my ($name_s,$passwd_s,$gid_s,$members_s) = @s; if (@s) { push @{ $seen{$name_s} }, $.; @@ -111,6 +113,8 @@ while (<GR>) { $n++; } +endgrent(); + if (keys %perfect == 0) { $max++; print <<EOEX; @@ -136,4 +140,29 @@ print "ok ", $tst++; print "\t# (not necessarily serious: run t/op/grent.t by itself)" if $not; print "\n"; +# Test both the scalar and list contexts. + +my @gr1; + +setgrent(); +for (1..$max) { + my $gr = scalar getgrent(); + last unless defined $gr; + push @gr1, $gr; +} +endgrent(); + +my @gr2; + +setgrent(); +for (1..$max) { + my ($gr) = (getgrent()); + last unless defined $gr; + push @gr2, $gr; +} +endgrent(); + +print "not " unless "@gr1" eq "@gr2"; +print "ok ", $tst++, "\n"; + close(GR); diff --git a/contrib/perl5/t/op/groups.t b/contrib/perl5/t/op/groups.t index 4b655c8e9c3e..082d2d1d9f53 100755 --- a/contrib/perl5/t/op/groups.t +++ b/contrib/perl5/t/op/groups.t @@ -115,7 +115,8 @@ for (split(' ', $()) { } } -if ($^O eq "uwin") { # Or anybody else who can have spaces in group names. +if ($^O =~ /^(?:uwin|solaris)$/) { + # Or anybody else who can have spaces in group names. $gr1 = join(' ', grep(!$did{$_}++, sort split(' ', join(' ', @gr)))); } else { $gr1 = join(' ', sort @gr); diff --git a/contrib/perl5/t/op/gv.t b/contrib/perl5/t/op/gv.t index 04905cd40099..831124499a95 100755 --- a/contrib/perl5/t/op/gv.t +++ b/contrib/perl5/t/op/gv.t @@ -6,12 +6,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use warnings; -print "1..30\n"; +print "1..40\n"; # type coersion on assignment $foo = 'foo'; @@ -128,6 +128,42 @@ print {*x{FILEHANDLE}} "ok 23\n"; ++$test; &{$a}; } +# although it *should* if you're talking about magicals + +{ + my $test = 29; + + my $a = "]"; + print "not " unless defined ${$a}; + ++$test; print "ok $test\n"; + print "not " unless defined *{$a}; + ++$test; print "ok $test\n"; + + $a = "1"; + "o" =~ /(o)/; + print "not " unless ${$a}; + ++$test; print "ok $test\n"; + print "not " unless defined *{$a}; + ++$test; print "ok $test\n"; + $a = "2"; + print "not " if ${$a}; + ++$test; print "ok $test\n"; + print "not " unless defined *{$a}; + ++$test; print "ok $test\n"; + $a = "1x"; + print "not " if defined ${$a}; + ++$test; print "ok $test\n"; + print "not " if defined *{$a}; + ++$test; print "ok $test\n"; + $a = "11"; + "o" =~ /(((((((((((o)))))))))))/; + print "not " unless ${$a}; + ++$test; print "ok $test\n"; + print "not " unless defined *{$a}; + ++$test; print "ok $test\n"; +} + + # does pp_readline() handle glob-ness correctly? { @@ -137,4 +173,4 @@ print {*x{FILEHANDLE}} "ok 23\n"; } __END__ -ok 30 +ok 40 diff --git a/contrib/perl5/t/op/hashwarn.t b/contrib/perl5/t/op/hashwarn.t index 9182273ec3c6..8466a7196e57 100755 --- a/contrib/perl5/t/op/hashwarn.t +++ b/contrib/perl5/t/op/hashwarn.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use strict; diff --git a/contrib/perl5/t/op/int.t b/contrib/perl5/t/op/int.t index 6ac0866a2bc8..7d675a4291ea 100755 --- a/contrib/perl5/t/op/int.t +++ b/contrib/perl5/t/op/int.t @@ -2,10 +2,10 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -print "1..6\n"; +print "1..7\n"; # compile time evaluation @@ -28,3 +28,9 @@ print $x == -7 ? "ok 5\n" : "# expected -7, got $x\nnot ok 5\n"; $y = (3/-10)*-10; print $x+$y == 3 && abs($x) < 10 ? "ok 6\n" : "not ok 6\n"; } + +# check bad strings still get converted + +@x = ( 6, 8, 10); +print "not " if $x["1foo"] != 8; +print "ok 7\n"; diff --git a/contrib/perl5/t/op/join.t b/contrib/perl5/t/op/join.t index def5a9e9faad..0f849fda9c08 100755 --- a/contrib/perl5/t/op/join.t +++ b/contrib/perl5/t/op/join.t @@ -1,6 +1,6 @@ #!./perl -print "1..6\n"; +print "1..14\n"; @x = (1, 2, 3); if (join(':',@x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";} @@ -20,3 +20,48 @@ if ($f eq 'a,b,e') {print "ok 5\n";} else {print "not ok 5\n";} $f = 'a'; $f = join $f, 'b', 'e', 'k'; if ($f eq 'baeak') {print "ok 6\n";} else {print "# '$f'\nnot ok 6\n";} + +# 7,8 check for multiple read of tied objects +{ package X; + sub TIESCALAR { my $x = 7; bless \$x }; + sub FETCH { my $y = shift; $$y += 5 }; + tie my $t, 'X'; + my $r = join ':', $t, 99, $t, 99; + print "# expected '12:99:17:99' got '$r'\nnot " if $r ne '12:99:17:99'; + print "ok 7\n"; + $r = join '', $t, 99, $t, 99; + print "# expected '22992799' got '$r'\nnot " if $r ne '22992799'; + print "ok 8\n"; +}; + +# 9,10 and for multiple read of undef +{ my $s = 5; + local ($^W, $SIG{__WARN__}) = ( 1, sub { $s+=4 } ); + my $r = join ':', 'a', undef, $s, 'b', undef, $s, 'c'; + print "# expected 'a::9:b::13:c' got '$r'\nnot " if $r ne 'a::9:b::13:c'; + print "ok 9\n"; + my $r = join '', 'a', undef, $s, 'b', undef, $s, 'c'; + print "# expected 'a17b21c' got '$r'\nnot " if $r ne 'a17b21c'; + print "ok 10\n"; +}; + +{ my $s = join("", chr(0x1234), chr(0xff)); + print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}"; + print "ok 11\n"; +} + +{ my $s = join(chr(0xff), chr(0x1234), ""); + print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}"; + print "ok 12\n"; +} + +{ my $s = join(chr(0x1234), chr(0xff), chr(0x2345)); + print "not " unless length($s) == 3 && $s eq "\x{ff}\x{1234}\x{2345}"; + print "ok 13\n"; +} + +{ my $s = join(chr(0xff), chr(0x1234), chr(0xfe)); + print "not " unless length($s) == 3 && $s eq "\x{1234}\x{ff}\x{fe}"; + print "ok 14\n"; +} + diff --git a/contrib/perl5/t/op/lex_assign.t b/contrib/perl5/t/op/lex_assign.t index 2fb059d8d879..d761f73ce7c3 100755 --- a/contrib/perl5/t/op/lex_assign.t +++ b/contrib/perl5/t/op/lex_assign.t @@ -2,9 +2,8 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; umask 0; $xref = \ ""; @@ -112,11 +111,12 @@ for (@INPUT) { $ord++; ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/; $comment = $op unless defined $comment; + chomp; $op = "$op==$op" unless $op =~ /==/; ($op, $expectop) = $op =~ /(.*)==(.*)/; $skip = ($op =~ /^'\?\?\?'/ or $comment =~ /skip\(.*\Q$^O\E.*\)/i) - ? "skip" : "not"; + ? "skip" : "# '$_'\nnot"; $integer = ($comment =~ /^i_/) ? "use integer" : '' ; (print "#skipping $comment:\nok $ord\n"), next if $skip eq 'skip'; @@ -137,7 +137,7 @@ EOE print "# skipping $comment: unimplemented:\nok $ord\n"; } else { warn $@; - print "not ok $ord\n"; + print "# '$_'\nnot ok $ord\n"; } } } @@ -146,6 +146,7 @@ for (@simple_input) { $ord++; ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/; $comment = $op unless defined $comment; + chomp; ($operator, $variable) = /^\s*(\w+)\s*\$(\w+)/ or warn "misprocessed '$_'\n"; eval <<EOE; local \$SIG{__WARN__} = \\&wrn; @@ -164,14 +165,14 @@ EOE print "# skipping $comment: syntax not good for selfassign:\nok $ord\n"; } else { warn $@; - print "not ok $ord\n"; + print "# '$_'\nnot ok $ord\n"; } } } __END__ ref $xref # ref ref $cstr # ref nonref -`$runme -e "print qq[1\n]"` # backtick skip(MSWin32) +`$runme -e "print qq[1\\n]"` # backtick skip(MSWin32) `$undefed` # backtick undef skip(MSWin32) <*> # glob <OP> # readline @@ -242,7 +243,7 @@ lc $cstr # lc quotemeta $cstr # quotemeta @$aref # rv2av @$undefed # rv2av undef -each %h==1 # each +(each %h) % 2 == 1 # each values %h # values keys %h # keys %$href # rv2hv @@ -307,7 +308,7 @@ getpriority $$, $$ # getpriority time # time localtime $^T # localtime gmtime $^T # gmtime -sleep 1 # sleep +'???' # sleep: can randomly fail '???' # alarm '???' # shmget '???' # shmctl diff --git a/contrib/perl5/t/op/lfs.t b/contrib/perl5/t/op/lfs.t index e704f6f57b6e..0a1c3998401d 100755 --- a/contrib/perl5/t/op/lfs.t +++ b/contrib/perl5/t/op/lfs.t @@ -4,15 +4,20 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; # Don't bother if there are no quad offsets. require Config; import Config; if ($Config{lseeksize} < 8) { - print "1..0\n# no 64-bit file offsets\n"; + print "1..0 # Skip: no 64-bit file offsets\n"; exit(0); } } +use strict; + +our @s; +our $fail; + sub zap { close(BIG); unlink("big"); @@ -25,35 +30,42 @@ sub bye { exit(0); } +my $explained; + sub explain { - print <<EOM; + unless ($explained++) { + print <<EOM; # -# If the lfs (large file support: large meaning larger than two gigabytes) -# tests are skipped or fail, it may mean either that your process -# (or process group) is not allowed to write large files (resource -# limits) or that the file system you are running the tests on doesn't -# let your user/group have large files (quota) or the filesystem simply -# doesn't support large files. You may even need to reconfigure your kernel. -# (This is all very operating system and site-dependent.) +# If the lfs (large file support: large meaning larger than two +# gigabytes) tests are skipped or fail, it may mean either that your +# process (or process group) is not allowed to write large files +# (resource limits) or that the file system (the network filesystem?) +# you are running the tests on doesn't let your user/group have large +# files (quota) or the filesystem simply doesn't support large files. +# You may even need to reconfigure your kernel. (This is all very +# operating system and site-dependent.) # # Perl may still be able to support large files, once you have # such a process, enough quota, and such a (file) system. +# It is just that the test failed now. # EOM + } + print "1..0 # Skip: @_\n" if @_; } print "# checking whether we have sparse files...\n"; # Known have-nots. -if ($^O eq 'win32' || $^O eq 'vms') { - print "1..0\n# no sparse files (because this is $^O) \n"; +if ($^O eq 'MSWin32' || $^O eq 'VMS') { + print "1..0 # Skip: no sparse files in $^O\n"; bye(); } # Known haves that have problems running this test # (for example because they do not support sparse files, like UNICOS) if ($^O eq 'unicos') { - print "1..0\n# large files known to work but unable to test them here ($^O)\n"; + print "1..0 # Skip: no sparse files in $^0, unable to test large files\n"; bye(); } @@ -102,7 +114,7 @@ zap(); unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 && $s1[11] == $s2[11] && $s1[12] == $s2[12]) { - print "1..0\n#no sparse files?\n"; + print "1..0 # Skip: no sparse files?\n"; bye; } @@ -110,14 +122,22 @@ print "# we seem to have sparse files...\n"; # By now we better be sure that we do have sparse files: # if we are not, the following will hog 5 gigabytes of disk. Ooops. +# This may fail by producing some signal; run in a subprocess first for safety $ENV{LC_ALL} = "C"; +my $r = system '../perl', '-e', <<'EOF'; +open(BIG, ">big"); +seek(BIG, 5_000_000_000, 0); +print BIG "big"; +exit 0; +EOF + open(BIG, ">big") or do { warn "open failed: $!\n"; bye }; binmode BIG; -unless (seek(BIG, 5_000_000_000, $SEEK_SET)) { - print "1..0\n# seeking past 2GB failed: $!\n"; - explain(); +if ($r or not seek(BIG, 5_000_000_000, $SEEK_SET)) { + my $err = $r ? 'signal '.($r & 0x7f) : $!; + explain("seeking past 2GB failed: $err"); bye(); } @@ -129,11 +149,12 @@ my $close = close BIG; print "# close failed: $!\n" unless $close; unless ($print && $close) { if ($! =~/too large/i) { - print "1..0\n# writing past 2GB failed: process limits?\n"; + explain("writing past 2GB failed: process limits?"); } elsif ($! =~ /quota/i) { - print "1..0\n# filesystem quota limits?\n"; + explain("filesystem quota limits?"); + } else { + explain("error: $!"); } - explain(); bye(); } @@ -142,8 +163,7 @@ unless ($print && $close) { print "# @s\n"; unless ($s[7] == 5_000_000_003) { - print "1..0\n# not configured to use large files?\n"; - explain(); + explain("kernel/fs not configured to use large files?"); bye(); } @@ -152,9 +172,30 @@ sub fail () { $fail++; } +sub offset ($$) { + my ($offset_will_be, $offset_want) = @_; + my $offset_is = eval $offset_will_be; + unless ($offset_is == $offset_want) { + print "# bad offset $offset_is, want $offset_want\n"; + my ($offset_func) = ($offset_will_be =~ /^(\w+)/); + if (unpack("L", pack("L", $offset_want)) == $offset_is) { + print "# 32-bit wraparound suspected in $offset_func() since\n"; + print "# $offset_want cast into 32 bits equals $offset_is.\n"; + } elsif ($offset_want - unpack("L", pack("L", $offset_want)) - 1 + == $offset_is) { + print "# 32-bit wraparound suspected in $offset_func() since\n"; + printf "# %s - unpack('L', pack('L', %s)) - 1 equals %s.\n", + $offset_want, + $offset_want, + $offset_is; + } + fail; + } +} + print "1..17\n"; -my $fail = 0; +$fail = 0; fail unless $s[7] == 5_000_000_003; # exercizes pp_stat print "ok 1\n"; @@ -174,25 +215,28 @@ binmode BIG; fail unless seek(BIG, 4_500_000_000, $SEEK_SET); print "ok 5\n"; -fail unless tell(BIG) == 4_500_000_000; +offset('tell(BIG)', 4_500_000_000); print "ok 6\n"; fail unless seek(BIG, 1, $SEEK_CUR); print "ok 7\n"; -fail unless tell(BIG) == 4_500_000_001; +# If you get 205_032_705 from here it means that +# your tell() is returning 32-bit values since (I32)4_500_000_001 +# is exactly 205_032_705. +offset('tell(BIG)', 4_500_000_001); print "ok 8\n"; fail unless seek(BIG, -1, $SEEK_CUR); print "ok 9\n"; -fail unless tell(BIG) == 4_500_000_000; +offset('tell(BIG)', 4_500_000_000); print "ok 10\n"; fail unless seek(BIG, -3, $SEEK_END); print "ok 11\n"; -fail unless tell(BIG) == 5_000_000_000; +offset('tell(BIG)', 5_000_000_000); print "ok 12\n"; my $big; @@ -204,6 +248,8 @@ fail unless $big eq "big"; print "ok 14\n"; # 705_032_704 = (I32)5_000_000_000 +# See that we don't have "big" in the 705_... spot: +# that would mean that we have a wraparound. fail unless seek(BIG, 705_032_704, $SEEK_SET); print "ok 15\n"; @@ -215,7 +261,7 @@ print "ok 16\n"; fail unless $zero eq "\0\0\0"; print "ok 17\n"; -explain if $fail; +explain() if $fail; bye(); # does the necessary cleanup diff --git a/contrib/perl5/t/op/local.t b/contrib/perl5/t/op/local.t index b478e01993f0..cf606b75a35e 100755 --- a/contrib/perl5/t/op/local.t +++ b/contrib/perl5/t/op/local.t @@ -2,9 +2,6 @@ print "1..69\n"; -# XXX known to leak scalars -$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; - sub foo { local($a, $b) = @_; local($c, $d); diff --git a/contrib/perl5/t/op/lop.t b/contrib/perl5/t/op/lop.t index f15201ff096a..d57271abd62d 100755 --- a/contrib/perl5/t/op/lop.t +++ b/contrib/perl5/t/op/lop.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..7\n"; diff --git a/contrib/perl5/t/op/magic.t b/contrib/perl5/t/op/magic.t index 773927605665..c2a82115b461 100755 --- a/contrib/perl5/t/op/magic.t +++ b/contrib/perl5/t/op/magic.t @@ -3,7 +3,7 @@ BEGIN { $| = 1; chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; } @@ -189,16 +189,18 @@ if ($Is_VMS || $Is_Dos) { } else { $PATH = $ENV{PATH}; + $PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0; $ENV{foo} = "bar"; %ENV = (); $ENV{PATH} = $PATH; + $ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0; ok 29, ($Is_MSWin32 ? (`cmd /x /c set foo 2>NUL` eq "") : (`echo \$foo` eq "\n") ); - $ENV{NoNeSuCh} = "foo"; + $ENV{__NoNeSuCh} = "foo"; $0 = "bar"; - ok 30, ($Is_MSWin32 ? (`cmd /x /c set NoNeSuCh` eq "NoNeSuCh=foo\n") - : (`echo \$NoNeSuCh` eq "foo\n") ); + ok 30, ($Is_MSWin32 ? (`cmd /x /c set __NoNeSuCh` eq "__NoNeSuCh=foo\n") + : (`echo \$__NoNeSuCh` eq "foo\n") ); } { diff --git a/contrib/perl5/t/op/method.t b/contrib/perl5/t/op/method.t index 1c6f3c5d9d13..be4df75fe2ed 100755 --- a/contrib/perl5/t/op/method.t +++ b/contrib/perl5/t/op/method.t @@ -4,7 +4,12 @@ # test method calls and autoloading. # -print "1..49\n"; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..53\n"; @A::ISA = 'B'; @B::ISA = 'C'; @@ -167,3 +172,16 @@ test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined"); test(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1); test(A2->foo(), "foo"); } + +{ + test(do { use Config; eval 'Config->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); + test(do { use Config; eval '$d = bless {}, "Config"; $d->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); +} + +test(do { eval 'E->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1); +test(do { eval '$e = bless {}, "E"; $e->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1); + diff --git a/contrib/perl5/t/op/misc.t b/contrib/perl5/t/op/misc.t index ac1a44fadb8c..35437a4b9a1f 100755 --- a/contrib/perl5/t/op/misc.t +++ b/contrib/perl5/t/op/misc.t @@ -4,7 +4,7 @@ # separate executable and can't simply use eval. chdir 't' if -d 't'; -unshift @INC, "../lib"; +@INC = '../lib'; $ENV{PERL5LIB} = "../lib"; $|=1; @@ -15,7 +15,7 @@ print "1..", scalar @prgs, "\n"; $tmpfile = "misctmp000"; 1 while -f ++$tmpfile; -END { unlink $tmpfile if $tmpfile; } +END { while($tmpfile && unlink $tmpfile){} } $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); @@ -26,6 +26,9 @@ for (@prgs){ } my($prog,$expected) = split(/\nEXPECT\n/, $_); open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; + $prog =~ s#/dev/null#NL:# if $^O eq 'VMS'; + $prog =~ s#if \(-e _ and -f _ and -r _\)#if (-e _ and -f _)# if $^O eq 'VMS'; # VMS file locking + print TEST $prog, "\n"; close TEST or die "Cannot close $tmpfile: $!"; @@ -59,12 +62,12 @@ $a = ":="; split /($a)/o, "a:=b:=c"; print "@_" EXPECT a := b := c ######## -use integer; $cusp = ~0 ^ (~0 >> 1); +use integer; $, = " "; -print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, ($cusp + 1) % 8, "!\n"; +print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, 8 | (($cusp + 1) % 8 + 7), "!\n"; EXPECT --1 0 0 1 ! +7 0 0 8 ! ######## $foo=undef; $foo->go; EXPECT @@ -346,7 +349,7 @@ print "you die joe!\n" unless "@x" eq 'x y z'; /(?{"{"})/ # Check it outside of eval too EXPECT Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern -/(?{"{"})/: Sequence (?{...}) not terminated or not {}-balanced at - line 1. +Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/(?{ << HERE "{"})/ at - line 1. ######## /(?{"{"}})/ # Check it outside of eval too EXPECT @@ -371,8 +374,8 @@ argv <e> # fdopen from a system descriptor to a system descriptor used to close # the former. open STDERR, '>&=STDOUT' or die $!; -select STDOUT; $| = 1; print fileno STDOUT; -select STDERR; $| = 1; print fileno STDERR; +select STDOUT; $| = 1; print fileno STDOUT or die $!; +select STDERR; $| = 1; print fileno STDERR or die $!; EXPECT 1 2 @@ -545,3 +548,56 @@ ucfirst - World lcfirst - world uc - WORLD lc - world +######## +sub f { my $a = 1; my $b = 2; my $c = 3; my $d = 4; next } +my $x = "foo"; +{ f } continue { print $x, "\n" } +EXPECT +foo +######## +sub C () { 1 } +sub M { $_[0] = 2; } +eval "C"; +M(C); +EXPECT +Modification of a read-only value attempted at - line 2. +######## +print qw(ab a\b a\\b); +EXPECT +aba\ba\b +######## +# This test is here instead of pragma/locale.t because +# the bug depends on in the internal state of the locale +# settings and pragma/locale messes up that state pretty badly. +# We need a "fresh run". +BEGIN { + eval { require POSIX }; + if ($@) { + exit(0); # running minitest? + } +} +use Config; +my $have_setlocale = $Config{d_setlocale} eq 'define'; +$have_setlocale = 0 if $@; +# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1" +# and mingw32 uses said silly CRT +$have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i; +exit(0) unless $have_setlocale; +my @locales; +if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a|")) { + while(<LOCALES>) { + chomp; + push(@locales, $_); + } + close(LOCALES); +} +exit(0) unless @locales; +for (@locales) { + use POSIX qw(locale_h); + use locale; + setlocale(LC_NUMERIC, $_) or next; + my $s = sprintf "%g %g", 3.1, 3.1; + next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/; + print "$_ $s\n"; +} +EXPECT diff --git a/contrib/perl5/t/op/mkdir.t b/contrib/perl5/t/op/mkdir.t index cf8e55d75e42..c5a090ca7df4 100755 --- a/contrib/perl5/t/op/mkdir.t +++ b/contrib/perl5/t/op/mkdir.t @@ -4,7 +4,7 @@ print "1..9\n"; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use File::Path; diff --git a/contrib/perl5/t/op/my.t b/contrib/perl5/t/op/my.t index 1777e88266bc..601e1d6ae8d8 100755 --- a/contrib/perl5/t/op/my.t +++ b/contrib/perl5/t/op/my.t @@ -2,7 +2,7 @@ # $RCSfile: my.t,v $ -print "1..30\n"; +print "1..31\n"; sub foo { my($a, $b) = @_; @@ -92,3 +92,10 @@ print +(@x ? "not " : ""), "ok 29\n"; { @x = my %y } print +(@x ? "not " : ""), "ok 30\n"; +# Found in HTML::FormatPS +my %fonts = qw(nok 31); +for my $full (keys %fonts) { + $full =~ s/^n//; + # Supposed to be copy-on-write via force_normal after a THINKFIRST check. + print "$full $fonts{nok}\n"; +} diff --git a/contrib/perl5/t/op/nothr5005.t b/contrib/perl5/t/op/nothr5005.t index fd36e2e89ab4..411a0b470e75 100755 --- a/contrib/perl5/t/op/nothr5005.t +++ b/contrib/perl5/t/op/nothr5005.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, "../lib"; + @INC = '../lib'; require Config; import Config; if ($Config{'use5005threads'}) diff --git a/contrib/perl5/t/op/numconvert.t b/contrib/perl5/t/op/numconvert.t index 8eb9b6e3418f..f3c9867a911c 100755 --- a/contrib/perl5/t/op/numconvert.t +++ b/contrib/perl5/t/op/numconvert.t @@ -51,7 +51,13 @@ my $big_iv = do {use integer; $max_uv1 * 16}; # 16 is an arbitrary number here print "# max_uv1 = $max_uv1, max_uv2 = $max_uv2, big_iv = $big_iv\n"; if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1) { - print "1..0\n# Unsigned arithmetic is not sane\n"; + print "1..0 # skipped: unsigned perl arithmetic is not sane"; + eval { require Config; import Config }; + use vars qw(%Config); + if ($Config{d_quad} eq 'define') { + print " (common in 64-bit platforms)"; + } + print "\n"; exit 0; } diff --git a/contrib/perl5/t/op/oct.t b/contrib/perl5/t/op/oct.t index 27ac5aa0423e..fe155d3a2d27 100755 --- a/contrib/perl5/t/op/oct.t +++ b/contrib/perl5/t/op/oct.t @@ -1,53 +1,88 @@ #!./perl -print "1..36\n"; +print "1..50\n"; -print +(oct('0b10101') == 0b10101) ? "ok" : "not ok", " 1\n"; -print +(oct('0b10101') == 025) ? "ok" : "not ok", " 2\n"; -print +(oct('0b10101') == 21) ? "ok" : "not ok", " 3\n"; -print +(oct('0b10101') == 0x15) ? "ok" : "not ok", " 4\n"; +print +(oct('0b1_0101') == 0b101_01) ? "ok" : "not ok", " 1\n"; +print +(oct('0b10_101') == 0_2_5) ? "ok" : "not ok", " 2\n"; +print +(oct('0b101_01') == 2_1) ? "ok" : "not ok", " 3\n"; +print +(oct('0b1010_1') == 0x1_5) ? "ok" : "not ok", " 4\n"; -print +(oct('b10101') == 0b10101) ? "ok" : "not ok", " 5\n"; -print +(oct('b10101') == 025) ? "ok" : "not ok", " 6\n"; -print +(oct('b10101') == 21) ? "ok" : "not ok", " 7\n"; -print +(oct('b10101') == 0x15) ? "ok" : "not ok", " 8\n"; +print +(oct('b1_0101') == 0b10101) ? "ok" : "not ok", " 5\n"; +print +(oct('b10_101') == 025) ? "ok" : "not ok", " 6\n"; +print +(oct('b101_01') == 21) ? "ok" : "not ok", " 7\n"; +print +(oct('b1010_1') == 0x15) ? "ok" : "not ok", " 8\n"; -print +(oct('01234') == 0b1010011100) ? "ok" : "not ok", " 9\n"; -print +(oct('01234') == 01234) ? "ok" : "not ok", " 10\n"; -print +(oct('01234') == 668) ? "ok" : "not ok", " 11\n"; +print +(oct('01_234') == 0b10_1001_1100) ? "ok" : "not ok", " 9\n"; +print +(oct('012_34') == 01234) ? "ok" : "not ok", " 10\n"; +print +(oct('0123_4') == 668) ? "ok" : "not ok", " 11\n"; print +(oct('01234') == 0x29c) ? "ok" : "not ok", " 12\n"; -print +(oct('0x1234') == 0b1001000110100) ? "ok" : "not ok", " 13\n"; -print +(oct('0x1234') == 011064) ? "ok" : "not ok", " 14\n"; -print +(oct('0x1234') == 4660) ? "ok" : "not ok", " 15\n"; -print +(oct('0x1234') == 0x1234) ? "ok" : "not ok", " 16\n"; +print +(oct('0x1_234') == 0b10010_00110100) ? "ok" : "not ok", " 13\n"; +print +(oct('0x12_34') == 01_1064) ? "ok" : "not ok", " 14\n"; +print +(oct('0x123_4') == 4660) ? "ok" : "not ok", " 15\n"; +print +(oct('0x1234') == 0x12_34) ? "ok" : "not ok", " 16\n"; -print +(oct('x1234') == 0b1001000110100) ? "ok" : "not ok", " 17\n"; -print +(oct('x1234') == 011064) ? "ok" : "not ok", " 18\n"; -print +(oct('x1234') == 4660) ? "ok" : "not ok", " 19\n"; -print +(oct('x1234') == 0x1234) ? "ok" : "not ok", " 20\n"; +print +(oct('x1_234') == 0b100100011010_0) ? "ok" : "not ok", " 17\n"; +print +(oct('x12_34') == 0_11064) ? "ok" : "not ok", " 18\n"; +print +(oct('x123_4') == 4660) ? "ok" : "not ok", " 19\n"; +print +(oct('x1234') == 0x_1234) ? "ok" : "not ok", " 20\n"; -print +(hex('01234') == 0b1001000110100) ? "ok" : "not ok", " 21\n"; -print +(hex('01234') == 011064) ? "ok" : "not ok", " 22\n"; -print +(hex('01234') == 4660) ? "ok" : "not ok", " 23\n"; -print +(hex('01234') == 0x1234) ? "ok" : "not ok", " 24\n"; +print +(hex('01_234') == 0b_1001000110100) ? "ok" : "not ok", " 21\n"; +print +(hex('012_34') == 011064) ? "ok" : "not ok", " 22\n"; +print +(hex('0123_4') == 4660) ? "ok" : "not ok", " 23\n"; +print +(hex('01234_') == 0x1234) ? "ok" : "not ok", " 24\n"; -print +(hex('0x1234') == 0b1001000110100) ? "ok" : "not ok", " 25\n"; -print +(hex('0x1234') == 011064) ? "ok" : "not ok", " 26\n"; -print +(hex('0x1234') == 4660) ? "ok" : "not ok", " 27\n"; -print +(hex('0x1234') == 0x1234) ? "ok" : "not ok", " 28\n"; +print +(hex('0x_1234') == 0b1001000110100) ? "ok" : "not ok", " 25\n"; +print +(hex('0x1_234') == 011064) ? "ok" : "not ok", " 26\n"; +print +(hex('0x12_34') == 4660) ? "ok" : "not ok", " 27\n"; +print +(hex('0x1234_') == 0x1234) ? "ok" : "not ok", " 28\n"; -print +(hex('x1234') == 0b1001000110100) ? "ok" : "not ok", " 29\n"; -print +(hex('x1234') == 011064) ? "ok" : "not ok", " 30\n"; -print +(hex('x1234') == 4660) ? "ok" : "not ok", " 31\n"; -print +(hex('x1234') == 0x1234) ? "ok" : "not ok", " 32\n"; +print +(hex('x_1234') == 0b1001000110100) ? "ok" : "not ok", " 29\n"; +print +(hex('x12_34') == 011064) ? "ok" : "not ok", " 30\n"; +print +(hex('x123_4') == 4660) ? "ok" : "not ok", " 31\n"; +print +(hex('x1234_') == 0x1234) ? "ok" : "not ok", " 32\n"; -print +(oct('0b11111111111111111111111111111111') == 4294967295) ? +print +(oct('0b1111_1111_1111_1111_1111_1111_1111_1111') == 4294967295) ? "ok" : "not ok", " 33\n"; -print +(oct('037777777777') == 4294967295) ? +print +(oct('037_777_777_777') == 4294967295) ? "ok" : "not ok", " 34\n"; -print +(oct('0xffffffff') == 4294967295) ? +print +(oct('0xffff_ffff') == 4294967295) ? "ok" : "not ok", " 35\n"; -print +(hex('0xffffffff') == 4294967295) ? +print +(hex('0xff_ff_ff_ff') == 4294967295) ? "ok" : "not ok", " 36\n"; + +$_ = "\0_7_7"; +print length eq 5 ? "ok" : "not ok", " 37\n"; +print $_ eq "\0"."_"."7"."_"."7" ? "ok" : "not ok", " 38\n"; +chop, chop, chop, chop; +print $_ eq "\0" ? "ok" : "not ok", " 39\n"; +if (ord("\t") != 9) { + # question mark is 111 in 1047, 037, && POSIX-BC + print "\157_" eq "?_" ? "ok" : "not ok", " 40\n"; +} +else { + print "\077_" eq "?_" ? "ok" : "not ok", " 40\n"; +} + +$_ = "\x_7_7"; +print length eq 5 ? "ok" : "not ok", " 41\n"; +print $_ eq "\0"."_"."7"."_"."7" ? "ok" : "not ok", " 42\n"; +chop, chop, chop, chop; +print $_ eq "\0" ? "ok" : "not ok", " 43\n"; +if (ord("\t") != 9) { + # / is 97 in 1047, 037, && POSIX-BC + print "\x61_" eq "/_" ? "ok" : "not ok", " 44\n"; +} +else { + print "\x2F_" eq "/_" ? "ok" : "not ok", " 44\n"; +} + +print +(oct('0b'.( '0'x10).'1_0101') == 0b101_01) ? "ok" : "not ok", " 45\n"; +print +(oct('0b'.( '0'x100).'1_0101') == 0b101_01) ? "ok" : "not ok", " 46\n"; +print +(oct('0b'.('0'x1000).'1_0101') == 0b101_01) ? "ok" : "not ok", " 47\n"; + +print +(hex(( '0'x10).'01234') == 0x1234) ? "ok" : "not ok", " 48\n"; +print +(hex(( '0'x100).'01234') == 0x1234) ? "ok" : "not ok", " 49\n"; +print +(hex(('0'x1000).'01234') == 0x1234) ? "ok" : "not ok", " 50\n"; + diff --git a/contrib/perl5/t/op/pack.t b/contrib/perl5/t/op/pack.t index b336cb549cdb..67bd547c5bde 100755 --- a/contrib/perl5/t/op/pack.t +++ b/contrib/perl5/t/op/pack.t @@ -2,11 +2,11 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; require Config; import Config; } -print "1..156\n"; +print "1..159\n"; $format = "c2 x5 C C x s d i l a6"; # Need the expression in here to force ary[5] to be numeric. This avoids @@ -372,8 +372,9 @@ print $@ eq '' && $y eq 'z' ? "ok $test\n" : "not ok $test\n"; $test++; eval { ($x) = pack '/a*','hello' }; print 'not ' unless $@; print "ok $test\n"; $test++; -$z = pack 'n/a* w/A*','string','etc'; -print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++; +$z = pack 'n/a* N/Z* w/A*','string','hi there ','etc'; +print 'not ' unless $z eq "\000\006string\0\0\0\012hi there \000\003etc"; +print "ok $test\n"; $test++; eval { ($x) = unpack 'a/a*/a*', '212ab345678901234567' }; print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "#$x,$@\nnot ok $test\n"; @@ -405,3 +406,13 @@ $z = pack <<EOP,'string','etc'; w/A* # Count a BER integer EOP print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++; + +print 'not ' unless "1.20.300.4000" eq sprintf "%vd", pack("U*",1,20,300,4000); +print "ok $test\n"; $test++; +print 'not ' unless "1.20.300.4000" eq + sprintf "%vd", pack(" U*",1,20,300,4000); +print "ok $test\n"; $test++; +print 'not ' unless v1.20.300.4000 ne + sprintf "%vd", pack("C0U*",1,20,300,4000); +print "ok $test\n"; $test++; + diff --git a/contrib/perl5/t/op/pat.t b/contrib/perl5/t/op/pat.t index 188a3a3b13f0..ffbc945f63a8 100755 --- a/contrib/perl5/t/op/pat.t +++ b/contrib/perl5/t/op/pat.t @@ -4,17 +4,14 @@ # the format supported by op/regexp.t. If you want to add a test # that does fit that format, add it to op/re_tests, not here. -print "1..211\n"; +print "1..231\n"; BEGIN { chdir 't' if -d 't'; - unshift @INC, "../lib" if -d "../lib"; + @INC = '../lib'; } eval 'use Config'; # Defaults assumed if this fails -# XXX known to leak scalars -$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; - $x = "abc\ndef\n"; if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";} @@ -266,12 +263,12 @@ print "ok 68\n"; undef $@; eval "'aaa' =~ /a{1,$reg_infty}/"; -print "not " if $@ !~ m%^\Q/a{1,$reg_infty}/: Quantifier in {,} bigger than%; +print "not " if $@ !~ m%^\QQuantifier in {,} bigger than%; print "ok 69\n"; eval "'aaa' =~ /a{1,$reg_infty_p}/"; print "not " - if $@ !~ m%^\Q/a{1,$reg_infty_p}/: Quantifier in {,} bigger than%; + if $@ !~ m%^\QQuantifier in {,} bigger than%; print "ok 70\n"; undef $@; @@ -279,7 +276,7 @@ undef $@; $context = 'x' x 256; eval qq("${context}y" =~ /(?<=$context)y/); -print "not " if $@ !~ m%^\Q/(?<=\Ex+/: lookbehind longer than 255 not%; +print "not " if $@ !~ m%^\QLookbehind longer than 255 not%; print "ok 71\n"; # removed test @@ -496,7 +493,7 @@ $test++; $_ = 'xabcx'; foreach $ans ('', 'c') { /(?<=(?=a)..)((?=c)|.)/g; - print "not " unless $1 eq $ans; + print "# \$1 ='$1'\n# \$ans='$ans'\nnot " unless $1 eq $ans; print "ok $test\n"; $test++; } @@ -504,7 +501,7 @@ foreach $ans ('', 'c') { $_ = 'a'; foreach $ans ('', 'a', '') { /^|a|$/g; - print "not " unless $& eq $ans; + print "# \$& ='$&'\n# \$ans='$ans'\nnot " unless $& eq $ans; print "ok $test\n"; $test++; } @@ -545,6 +542,22 @@ $test++; print "ok $test\n"; $test++; + local $lex_a = 2; + my $lex_a = 43; + my $lex_b = 17; + my $lex_c = 27; + my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/); + print "not " unless $lex_res eq '1'; + print "ok $test\n"; + $test++; + print "not " unless $lex_a eq '44'; + print "ok $test\n"; + $test++; + print "not " unless $lex_c eq '43'; + print "ok $test\n"; + $test++; + + no re "eval"; $match = eval { /$a$c$a/ }; print "not " @@ -554,6 +567,23 @@ $test++; } { + local $lex_a = 2; + my $lex_a = 43; + my $lex_b = 17; + my $lex_c = 27; + my $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/); + print "not " unless $lex_res eq '1'; + print "ok $test\n"; + $test++; + print "not " unless $lex_a eq '44'; + print "ok $test\n"; + $test++; + print "not " unless $lex_c eq '43'; + print "ok $test\n"; + $test++; +} + +{ package aa; $c = 2; $::c = 3; @@ -588,8 +618,12 @@ sub make_must_warn { my $for_future = make_must_warn('reserved for future extensions'); &$for_future('q(a:[b]:) =~ /[x[:foo:]]/'); -&$for_future('q(a=[b]=) =~ /[x[=foo=]]/'); -&$for_future('q(a.[b].) =~ /[x[.foo.]]/'); + +#&$for_future('q(a=[b]=) =~ /[x[=foo=]]/'); +print "ok $test\n"; $test++; # now a fatal croak + +#&$for_future('q(a.[b].) =~ /[x[.foo.]]/'); +print "ok $test\n"; $test++; # now a fatal croak # test if failure of patterns returns empty list $_ = 'aaa'; @@ -689,6 +723,30 @@ print "not " print "ok $test\n"; $test++; +eval { $+[0] = 13; }; +print "not " + if $@ !~ /^Modification of a read-only value attempted/; +print "ok $test\n"; +$test++; + +eval { $-[0] = 13; }; +print "not " + if $@ !~ /^Modification of a read-only value attempted/; +print "ok $test\n"; +$test++; + +eval { @+ = (7, 6, 5); }; +print "not " + if $@ !~ /^Modification of a read-only value attempted/; +print "ok $test\n"; +$test++; + +eval { @- = qw(foo bar); }; +print "not " + if $@ !~ /^Modification of a read-only value attempted/; +print "ok $test\n"; +$test++; + /.(a)(ba*)?/; print "#$#-..$#+\nnot " if $#+ != 2 or $#- != 1; print "ok $test\n"; @@ -995,3 +1053,78 @@ $test++; "\n\n" =~ /\n+ $ \n/x or print "not "; print "ok $test\n"; $test++; + +[] =~ /^ARRAY/ or print "# [] \nnot "; +print "ok $test\n"; +$test++; + +eval << 'EOE'; +{ + package S; + use overload '""' => sub { 'Object S' }; + sub new { bless [] } +} +$a = 'S'->new; +EOE + +$a and $a =~ /^Object\sS/ or print "# '$a' \nnot "; +print "ok $test\n"; +$test++; + +# test result of match used as match (!) +'a1b' =~ ('xyz' =~ /y/) and $` eq 'a' or print "not "; +print "ok $test\n"; +$test++; + +'a1b' =~ ('xyz' =~ /t/) and $` eq 'a' or print "not "; +print "ok $test\n"; +$test++; + +$w = 0; +{ + local $SIG{__WARN__} = sub { $w = 1 }; + local $^W = 1; + $w = 1 if ("1\n" x 102) =~ /^\s*\n/m; +} +print $w ? "not " : "", "ok $test\n"; +$test++; + +my %space = ( spc => " ", + tab => "\t", + cr => "\r", + lf => "\n", + ff => "\f", +# There's no \v but the vertical tabulator seems miraculously +# be 11 both in ASCII and EBCDIC. + vt => chr(11), + false => "space" ); + +my @space0 = sort grep { $space{$_} =~ /\s/ } keys %space; +my @space1 = sort grep { $space{$_} =~ /[[:space:]]/ } keys %space; +my @space2 = sort grep { $space{$_} =~ /[[:blank:]]/ } keys %space; + +print "not " unless "@space0" eq "cr ff lf spc tab"; +print "ok $test # @space0\n"; +$test++; + +print "not " unless "@space1" eq "cr ff lf spc tab vt"; +print "ok $test # @space1\n"; +$test++; + +print "not " unless "@space2" eq "spc tab"; +print "ok $test # @space2\n"; +$test++; + +# bugid 20001021.005 - this caused a SEGV +print "not " unless undef =~ /^([^\/]*)(.*)$/; +print "ok $test\n"; +$test++; + +{ + # japhy -- added 03/03/2001 + () = (my $str = "abc") =~ /(...)/; + $str = "def"; + print "not " if $1 ne "abc"; + print "ok $test\n"; + $test++; +} diff --git a/contrib/perl5/t/op/pos.t b/contrib/perl5/t/op/pos.t index 46811b7bbc7d..f3bc23c84ac8 100755 --- a/contrib/perl5/t/op/pos.t +++ b/contrib/perl5/t/op/pos.t @@ -1,6 +1,6 @@ #!./perl -print "1..3\n"; +print "1..4\n"; $x='banana'; $x=~/.a/g; @@ -14,3 +14,10 @@ sub f { my $p=$_[0]; return $p } $x=~/.a/g; if (f(pos($x))==4) {print "ok 3\n"} else {print "not ok 3\n";} +# Is pos() set inside //g? (bug id 19990615.008) +$x = "test string?"; $x =~ s/\w/pos($x)/eg; +print "not " unless $x eq "0123 5678910?"; +print "ok 4\n"; + + + diff --git a/contrib/perl5/t/op/pwent.t b/contrib/perl5/t/op/pwent.t index ca14a99eec46..d811f06a33e1 100755 --- a/contrib/perl5/t/op/pwent.t +++ b/contrib/perl5/t/op/pwent.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, "../lib" if -d "../lib"; + @INC = '../lib'; eval {my @n = getpwuid 0}; if ($@ && $@ =~ /(The \w+ function is unimplemented)/) { print "1..0 # Skip: $1\n"; @@ -55,9 +55,9 @@ BEGIN { } } -# By now PW filehandle should be open and full of juicy password entries. +# By now the PW filehandle should be open and full of juicy password entries. -print "1..1\n"; +print "1..2\n"; # Go through at most this many users. # (note that the first entry has been read away by now) @@ -68,10 +68,17 @@ my $tst = 1; my %perfect; my %seen; +setpwent(); while (<PW>) { chomp; - my @s = split /:/; - my ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s; + # LIMIT -1 so that users with empty shells don't fall off + my @s = split /:/, $_, -1; + my ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s); + if ($^O eq 'darwin') { + ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s[0,1,2,3,7,8,9]; + } else { + ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s; + } next if /^\+/; # ignore NIS includes if (@s) { push @{ $seen{$name_s} }, $.; @@ -86,7 +93,7 @@ while (<PW>) { } # In principle we could whine if @s != 7 but do we know enough # of passwd file formats everywhere? - if (@s == 7) { + if (@s == 7 || ($^O eq 'darwin' && @s == 10)) { @n = getpwuid($uid_s); # 'nobody' et al. next unless @n; @@ -108,6 +115,7 @@ while (<PW>) { } $n++; } +endpwent(); if (keys %perfect == 0) { $max++; @@ -134,4 +142,29 @@ print "ok ", $tst++; print "\t# (not necessarily serious: run t/op/pwent.t by itself)" if $not; print "\n"; +# Test both the scalar and list contexts. + +my @pw1; + +setpwent(); +for (1..$max) { + my $pw = scalar getpwent(); + last unless defined $pw; + push @pw1, $pw; +} +endpwent(); + +my @pw2; + +setpwent(); +for (1..$max) { + my ($pw) = (getpwent()); + last unless defined $pw; + push @pw2, $pw; +} +endpwent(); + +print "not " unless "@pw1" eq "@pw2"; +print "ok ", $tst++, "\n"; + close(PW); diff --git a/contrib/perl5/t/op/quotemeta.t b/contrib/perl5/t/op/quotemeta.t index 60e5b7be0508..ea62ed8ecf6e 100755 --- a/contrib/perl5/t/op/quotemeta.t +++ b/contrib/perl5/t/op/quotemeta.t @@ -2,18 +2,18 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; require Config; import Config; } -print "1..15\n"; +print "1..17\n"; if ($Config{ebcdic} eq 'define') { $_=join "", map chr($_), 129..233; # 105 characters - 52 letters = 53 backslashes # 105 characters + 53 backslashes = 158 characters - $_=quotemeta $_; + $_= quotemeta $_; if ( length == 158 ){print "ok 1\n"} else {print "not ok 1\n"} # 104 non-backslash characters if (tr/\\//cd == 104){print "ok 2\n"} else {print "not ok 2\n"} @@ -22,7 +22,7 @@ if ($Config{ebcdic} eq 'define') { # 96 characters - 52 letters - 10 digits - 1 underscore = 33 backslashes # 96 characters + 33 backslashes = 129 characters - $_=quotemeta $_; + $_= quotemeta $_; if ( length == 129 ){print "ok 1\n"} else {print "not ok 1\n"} # 95 non-backslash characters if (tr/\\//cd == 95){print "ok 2\n"} else {print "not ok 2\n"} @@ -42,3 +42,6 @@ print "\Q\u\LpE.X.R\EL\E." eq "Pe\\.x\\.rL." ? "ok 12\n" : "not ok 12 \n"; print "\Q\l\UPe*x*r\El\E*" eq "pE\\*X\\*Rl*" ? "ok 13\n" : "not ok 13 \n"; print "\U\lPerl\E\E\E\E" eq "pERL" ? "ok 14\n" : "not ok 14 \n"; print "\l\UPerl\E\E\E\E" eq "pERL" ? "ok 15\n" : "not ok 15 \n"; + +print length(quotemeta("\x{263a}")) == 1 ? "ok 16\n" : "not ok 16\n"; +print quotemeta("\x{263a}") eq "\x{263a}" ? "ok 17\n" : "not ok 17\n"; diff --git a/contrib/perl5/t/op/rand.t b/contrib/perl5/t/op/rand.t index 97019bb09983..83186aeb664e 100755 --- a/contrib/perl5/t/op/rand.t +++ b/contrib/perl5/t/op/rand.t @@ -17,7 +17,7 @@ BEGIN { chdir "t" if -d "t"; - unshift @INC, "../lib" if -d "../lib"; + @INC = '../lib'; } use strict; diff --git a/contrib/perl5/t/op/re_tests b/contrib/perl5/t/op/re_tests index d506e6e07f89..6477d6733df0 100644 --- a/contrib/perl5/t/op/re_tests +++ b/contrib/perl5/t/op/re_tests @@ -45,9 +45,9 @@ a[b-d]e ace y $& ace a[b-d] aac y $& ac a[-b] a- y $& a- a[b-] a- y $& a- -a[b-a] - c - /a[b-a]/: invalid [] range "b-a" in regexp -a[]b - c - /a[]b/: unmatched [] in regexp -a[ - c - /a[/: unmatched [] in regexp +a[b-a] - c - Invalid [] range "b-a" before HERE mark in regex m/a[b-a << HERE ]/ +a[]b - c - Unmatched [ before HERE mark in regex m/a[ << HERE ]b/ +a[ - c - Unmatched [ before HERE mark in regex m/a[ << HERE / a] a] y $& a] a[]]b a]b y $& a]b a[^bc]d aed y $& aed @@ -95,21 +95,21 @@ a[\S]b a-b y - - ab|cd abc y $& ab ab|cd abcd y $& ab ()ef def y $&-$1 ef- -*a - c - /*a/: ?+*{} follows nothing in regexp -(*)b - c - /(*)b/: ?+*{} follows nothing in regexp +*a - c - Quantifier follows nothing before HERE mark in regex m/* << HERE a/ +(*)b - c - Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/ $b b n - - a\ - c - Search pattern not terminated a\(b a(b y $&-$1 a(b- a\(*b ab y $& ab a\(*b a((b y $& a((b a\\b a\b y $& a\b -abc) - c - /abc)/: unmatched () in regexp -(abc - c - /(abc/: unmatched () in regexp +abc) - c - Unmatched ) before HERE mark in regex m/abc) << HERE / +(abc - c - Unmatched ( before HERE mark in regex m/( << HERE abc/ ((a)) abc y $&-$1-$2 a-a-a (a)b(c) abc y $&-$1-$2 abc-a-c a+b+c aabbabc y $& abc a{1,}b{1,}c aabbabc y $& abc -a** - c - /a**/: nested *?+ in regexp +a** - c - Nested quantifiers before HERE mark in regex m/a** << HERE / a.+?c abcabc y $& abc (a+|b)* ab y $&-$1 ab-b (a+|b){0,} ab y $&-$1 ab-b @@ -117,7 +117,7 @@ a.+?c abcabc y $& abc (a+|b){1,} ab y $&-$1 ab-b (a+|b)? ab y $&-$1 a-a (a+|b){0,1} ab y $&-$1 a-a -)( - c - /)(/: unmatched () in regexp +)( - c - Unmatched ) before HERE mark in regex m/) << HERE (/ [^ab]* cde y $& cde abc n - - a* y $& @@ -164,11 +164,11 @@ a(bc)d abcd y $1-\$1-\\$1 bc-$1-\bc a[-]?c ac y $& ac (abc)\1 abcabc y $1 abc ([a-c]*)\1 abcabc y $1 abc -\1 - c - /\1/: reference to nonexistent group -\2 - c - /\2/: reference to nonexistent group +\1 - c - Reference to nonexistent group +\2 - c - Reference to nonexistent group (a)|\1 a y - - (a)|\1 x n - - -(a)|\2 - c - /(a)|\2/: reference to nonexistent group +(a)|\2 - c - Reference to nonexistent group (([a-c])b*?\2)* ababbbcbc y $&-$1-$2 ababb-bb-b (([a-c])b*?\2){3} ababbbcbc y $&-$1-$2 ababbbcbc-cbc-c ((\3|b)\2(a)x)+ aaxabxbaxbbx n - - @@ -218,9 +218,9 @@ a[-]?c ac y $& ac 'a[b-d]'i AAC y $& AC 'a[-b]'i A- y $& A- 'a[b-]'i A- y $& A- -'a[b-a]'i - c - /a[b-a]/: invalid [] range "b-a" in regexp -'a[]b'i - c - /a[]b/: unmatched [] in regexp -'a['i - c - /a[/: unmatched [] in regexp +'a[b-a]'i - c - Invalid [] range "b-a" before HERE mark in regex m/a[b-a << HERE ]/ +'a[]b'i - c - Unmatched [ before HERE mark in regex m/a[ << HERE ]b/ +'a['i - c - Unmatched [ before HERE mark in regex m/a[ << HERE / 'a]'i A] y $& A] 'a[]]b'i A]B y $& A]B 'a[^bc]d'i AED y $& AED @@ -232,21 +232,21 @@ a[-]?c ac y $& ac 'ab|cd'i ABC y $& AB 'ab|cd'i ABCD y $& AB '()ef'i DEF y $&-$1 EF- -'*a'i - c - /*a/: ?+*{} follows nothing in regexp -'(*)b'i - c - /(*)b/: ?+*{} follows nothing in regexp +'*a'i - c - Quantifier follows nothing before HERE mark in regex m/* << HERE a/ +'(*)b'i - c - Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/ '$b'i B n - - 'a\'i - c - Search pattern not terminated 'a\(b'i A(B y $&-$1 A(B- 'a\(*b'i AB y $& AB 'a\(*b'i A((B y $& A((B 'a\\b'i A\B y $& A\B -'abc)'i - c - /abc)/: unmatched () in regexp -'(abc'i - c - /(abc/: unmatched () in regexp +'abc)'i - c - Unmatched ) before HERE mark in regex m/abc) << HERE / +'(abc'i - c - Unmatched ( before HERE mark in regex m/( << HERE abc/ '((a))'i ABC y $&-$1-$2 A-A-A '(a)b(c)'i ABC y $&-$1-$2 ABC-A-C 'a+b+c'i AABBABC y $& ABC 'a{1,}b{1,}c'i AABBABC y $& ABC -'a**'i - c - /a**/: nested *?+ in regexp +'a**'i - c - Nested quantifiers before HERE mark in regex m/a** << HERE / 'a.+?c'i ABCABC y $& ABC 'a.*?c'i ABCABC y $& ABC 'a.{0,5}?c'i ABCABC y $& ABC @@ -257,7 +257,7 @@ a[-]?c ac y $& ac '(a+|b)?'i AB y $&-$1 A-A '(a+|b){0,1}'i AB y $&-$1 A-A '(a+|b){0,1}?'i AB y $&-$1 - -')('i - c - /)(/: unmatched () in regexp +')('i - c - Unmatched ) before HERE mark in regex m/) << HERE (/ '[^ab]*'i CDE y $& CDE 'abc'i n - - 'a*'i y $& @@ -318,7 +318,7 @@ a(?:b|c|d){2}(.) acdbcdbe y $1 b a(?:b|c|d){4,5}(.) acdbcdbe y $1 b a(?:b|c|d){4,5}?(.) acdbcdbe y $1 d ((foo)|(bar))* foobar y $1-$2-$3 bar-foo-bar -:(?: - c - /(?/: Sequence (? incomplete +:(?: - c - Sequence (? incomplete a(?:b|c|d){6,7}(.) acdbcdbe y $1 e a(?:b|c|d){6,7}?(.) acdbcdbe y $1 e a(?:b|c|d){5,6}(.) acdbcdbe y $1 e @@ -346,7 +346,7 @@ a(?:b|(c|e){1,2}?|d)+?(.) ace y $1$2 ce (?<!c)b cb n - - (?<!c)b b y - - (?<!c)b b y $& b -(?<%)b - c - /(?<%)b/: Sequence (?%...) not recognized +(?<%)b - c - Sequence (?<%...) not recognized before HERE mark in regex m/(?<% << HERE )b/ (?:..)*a aba y $& aba (?:..)*?a aba y $& a ^(?:b|a(?=(.)))*\1 abc y $& ab @@ -397,10 +397,10 @@ a(?:b|(c|e){1,2}?|d)+?(.) ace y $1$2 ce '(ab)\d\1'i ab4Ab y $1 ab foo\w*\d{4}baz foobar1234baz y $& foobar1234baz a(?{})b cabd y $& ab -a(?{)b - c - /a(?{)b/: Sequence (?{...}) not terminated or not {}-balanced -a(?{{})b - c - /a(?{{})b/: Sequence (?{...}) not terminated or not {}-balanced -a(?{}})b - c - /a(?{}})b/: Sequence (?{...}) not terminated or not {}-balanced -a(?{"{"})b - c - /a(?{"{"})b/: Sequence (?{...}) not terminated or not {}-balanced +a(?{)b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE )b/ +a(?{{})b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE {})b/ +a(?{}})b - c - +a(?{"{"})b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE "{"})b/ a(?{"\{"})b cabd y $& ab a(?{"{"}})b - c - Unmatched right curly bracket a(?{$bl="\{"}).b caxbd y $bl { @@ -441,8 +441,8 @@ x(~~)*(?:(?:F)?)? x~~ y - - ^(\(+)?blah(?(1)(\)))$ blah y ($2) () ^(\(+)?blah(?(1)(\)))$ blah) n - - ^(\(+)?blah(?(1)(\)))$ (blah n - - -(?(1?)a|b) a c - /(?(1?)a|b)/: Switch (?(number? not recognized -(?(1)a|b|c) a c - /(?(1)a|b|c)/: Switch (?(condition)... contains too many branches +(?(1?)a|b) a c - Switch condition not recognized before HERE mark in regex m/(?(1? << HERE )a|b)/ +(?(1)a|b|c) a c - Switch (?(condition)... contains too many branches (?(?{0})a|b) a n - - (?(?{0})b|a) a y $& a (?(?{1})b|a) a n - - @@ -473,10 +473,10 @@ $(?<=^(a)) a y $1 a ([[:]+) a:[b]: y $1 :[ ([[=]+) a=[b]= y $1 =[ ([[.]+) a.[b]. y $1 .[ -[a[:xyz: - c - /[a[:xyz:/: unmatched [] in regexp -[a[:xyz:] - c - Character class [:xyz:] unknown +[a[:xyz: - c - Unmatched [ before HERE mark in regex m/[ << HERE a[:xyz:/ +[a[:xyz:] - c - POSIX class [:xyz:] unknown before HERE mark in regex m/[a[:xyz:] << HERE / [a[:]b[:c] abc y $& abc -([a[:xyz:]b]+) pbaq c - Character class [:xyz:] unknown +([a[:xyz:]b]+) pbaq c - POSIX class [:xyz:] unknown before HERE mark in regex m/([a[:xyz:] << HERE b]+)/ [a[:]b[:c] abc y $& abc ([[:alpha:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd ([[:alnum:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy @@ -503,13 +503,13 @@ $(?<=^(a)) a y $1 a ([[:^word:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 -- ${nulnul}${ffff} ([[:^upper:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 cd01 ([[:^xdigit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 Xy__-- ${nulnul}${ffff} -[[:foo:]] - c - Character class [:foo:] unknown -[[:^foo:]] - c - Character class [:^foo:] unknown +[[:foo:]] - c - POSIX class [:foo:] unknown before HERE mark in regex m/[[:foo:] << HERE ]/ +[[:^foo:]] - c - POSIX class [:^foo:] unknown before HERE mark in regex m/[[:^foo:] << HERE ]/ ((?>a+)b) aaab y $1 aaab (?>(a+))b aaab y $1 aaa ((?>[^()]+)|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x -(?<=x+)y - c - /(?<=x+)y/: variable length lookbehind not implemented -a{37,17} - c - /a{37,17}/: Can't do {n,m} with n > m +(?<=x+)y - c - Variable length lookbehind not implemented +a{37,17} - c - Can't do {n,m} with n > m \Z a\nb\n y $-[0] 3 \z a\nb\n y $-[0] 4 $ a\nb\n y $-[0] 3 @@ -750,3 +750,37 @@ tt+$ xxxtt y - - ^([a-z]:) C:/ n - - '^\S\s+aa$'m \nx aa y - - (^|a)b ab y - - +^([ab]*?)(b)?(c)$ abac y -$2- -- +(\w)?(abc)\1b abcab n - - +^(?:.,){2}c a,b,c y - - +^(.,){2}c a,b,c y $1 b, +^(?:[^,]*,){2}c a,b,c y - - +^([^,]*,){2}c a,b,c y $1 b, +^([^,]*,){3}d aaa,b,c,d y $1 c, +^([^,]*,){3,}d aaa,b,c,d y $1 c, +^([^,]*,){0,3}d aaa,b,c,d y $1 c, +^([^,]{1,3},){3}d aaa,b,c,d y $1 c, +^([^,]{1,3},){3,}d aaa,b,c,d y $1 c, +^([^,]{1,3},){0,3}d aaa,b,c,d y $1 c, +^([^,]{1,},){3}d aaa,b,c,d y $1 c, +^([^,]{1,},){3,}d aaa,b,c,d y $1 c, +^([^,]{1,},){0,3}d aaa,b,c,d y $1 c, +^([^,]{0,3},){3}d aaa,b,c,d y $1 c, +^([^,]{0,3},){3,}d aaa,b,c,d y $1 c, +^([^,]{0,3},){0,3}d aaa,b,c,d y $1 c, +(?i) y - - +'(?!\A)x'm a\nxb\n y - - +^(a(b)?)+$ aba y -$1-$2- -a-- +^(aa(bb)?)+$ aabbaa y -$1-$2- -aa-- +'^.{9}abc.*\n'm 123\nabcabcabcabc\n y - - +^(a)?a$ a y -$1- -- +^(a)?(?(1)a|b)+$ a n - - +^(a\1?)(a\1?)(a\2?)(a\3?)$ aaaaaa y $1,$2,$3,$4 a,aa,a,aa +^(a\1?){4}$ aaaaaa y $1 aa +^(0+)?(?:x(1))? x1 y - - +^([0-9a-fA-F]+)(?:x([0-9a-fA-F]+)?)(?:x([0-9a-fA-F]+))? 012cxx0190 y - - +^(b+?|a){1,2}c bbbac y $1 a +^(b+?|a){1,2}c bbbbac y $1 a +\((\w\. \w+)\) cd. (A. Tw) y -$1- -A. Tw- +((?:aaaa|bbbb)cccc)? aaaacccc y - - +((?:aaaa|bbbb)cccc)? bbbbcccc y - - diff --git a/contrib/perl5/t/op/readdir.t b/contrib/perl5/t/op/readdir.t index d101c2f62212..00199b0fec15 100755 --- a/contrib/perl5/t/op/readdir.t +++ b/contrib/perl5/t/op/readdir.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } eval 'opendir(NOSUCH, "no/such/directory");'; @@ -20,7 +20,11 @@ if (opendir(OP, "op")) { print "ok 1\n"; } else { print "not ok 1\n"; } @D = grep(/^[^\.].*\.t$/i, readdir(OP)); closedir(OP); -if (@D > 20 && @D < 100) { print "ok 2\n"; } else { print "not ok 2\n"; } +## +## This range will have to adjust as the number of tests expands, +## as it's counting the number of .t files in src/t +## +if (@D > 90 && @D < 110) { print "ok 2\n"; } else { print "not ok 2\n"; } @R = sort @D; @G = sort <op/*.t>; diff --git a/contrib/perl5/t/op/regexp.t b/contrib/perl5/t/op/regexp.t index 4ffe1362c656..4a4d42fd98d8 100755 --- a/contrib/perl5/t/op/regexp.t +++ b/contrib/perl5/t/op/regexp.t @@ -1,8 +1,5 @@ #!./perl -# XXX known to leak scalars -$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; - # The tests are in a separate file 't/op/re_tests'. # Each line in that file is a separate test. # There are five columns, separated by tabs. @@ -26,6 +23,9 @@ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; # Column 5 contains the expected result of double-quote # interpolating that string after the match, or start of error message. # +# Column 6, if present, contains a reason why the test is skipped. +# This is printed with "skipped", for harness to pick up. +# # \n in the tests are interpolated, as are variables of the form ${\w+}. # # If you want to add a regular expression test that can't be expressed @@ -33,7 +33,7 @@ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } $iters = shift || 1; # Poor man performance suite, 10000 is OK. @@ -56,7 +56,7 @@ TEST: while (<TESTS>) { chomp; s/\\n/\n/g; - ($pat, $subject, $result, $repl, $expect) = split(/\t/,$_); + ($pat, $subject, $result, $repl, $expect, $reason) = split(/\t/,$_,6); $input = join(':',$pat,$subject,$result,$repl,$expect); infty_subst(\$pat); infty_subst(\$expect); @@ -70,7 +70,8 @@ while (<TESTS>) { $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/; $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//)); # Certain tests don't work with utf8 (the re_test should be in UTF8) - $skip = 1 if ($^H &= ~0x00000008) && $pat =~ /\[:\^(alnum|print|word):\]/; + $skip = 1, $reason = 'utf8' + if ($^H &= ~0x00000008) && $pat =~ /\[:\^(alnum|print|word|ascii|xdigit):\]/; $result =~ s/B//i unless $skip; for $study ('', 'study \$subject') { $c = $iters; @@ -81,7 +82,8 @@ while (<TESTS>) { last; # no need to study a syntax error } elsif ( $skip ) { - print "ok $. # skipped\n"; next TEST; + print "ok $. # skipped", length($reason) ? " $reason" : '', "\n"; + next TEST; } elsif ($@) { print "not ok $. $input => error `$err'\n"; next TEST; diff --git a/contrib/perl5/t/op/runlevel.t b/contrib/perl5/t/op/runlevel.t index e988ad9362a4..b6c128bcb911 100755 --- a/contrib/perl5/t/op/runlevel.t +++ b/contrib/perl5/t/op/runlevel.t @@ -7,7 +7,7 @@ ## chdir 't' if -d 't'; -unshift @INC, "../lib"; +@INC = '../lib'; $Is_VMS = $^O eq 'VMS'; $Is_MSWin32 = $^O eq 'MSWin32'; $ENV{PERL5LIB} = "../lib" unless $Is_VMS; @@ -349,3 +349,18 @@ A 1 bar B 2 bar +######## +sub n { 0 } +sub f { my $x = shift; d(); } +f(n()); +f(); + +sub d { + my $i = 0; my @a; + while (do { { package DB; @a = caller($i++) } } ) { + @a = @DB::args; + for (@a) { print "$_\n"; $_ = '' } + } +} +EXPECT +0 diff --git a/contrib/perl5/t/op/sort.t b/contrib/perl5/t/op/sort.t index ba0a4c2a2d2a..29aff1df5c7f 100755 --- a/contrib/perl5/t/op/sort.t +++ b/contrib/perl5/t/op/sort.t @@ -2,16 +2,10 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use warnings; -print "1..49\n"; - -# XXX known to leak scalars -{ - no warnings 'uninitialized'; - $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; -} +print "1..57\n"; # these shouldn't hang { @@ -270,3 +264,54 @@ print "# x = '@b'\n"; @b = sort main::Backwards_stacked @a; print ("@b" eq '90 5 255 1996 19' ? "ok 49\n" : "not ok 49\n"); print "# x = '@b'\n"; + +# check if context for sort arguments is handled right + +$test = 49; +sub test_if_list { + my $gimme = wantarray; + print "not " unless $gimme; + ++$test; + print "ok $test\n"; +} +my $m = sub { $a <=> $b }; + +sub cxt_one { sort $m test_if_list() } +cxt_one(); +sub cxt_two { sort { $a <=> $b } test_if_list() } +cxt_two(); +sub cxt_three { sort &test_if_list() } +cxt_three(); + +sub test_if_scalar { + my $gimme = wantarray; + print "not " if $gimme or !defined($gimme); + ++$test; + print "ok $test\n"; +} + +$m = \&test_if_scalar; +sub cxt_four { sort $m 1,2 } +@x = cxt_four(); +sub cxt_five { sort { test_if_scalar($a,$b); } 1,2 } +@x = cxt_five(); +sub cxt_six { sort test_if_scalar 1,2 } +@x = cxt_six(); + +# test against a reentrancy bug +{ + package Bar; + sub compare { $a cmp $b } + sub reenter { my @force = sort compare qw/a b/ } +} +{ + my($def, $init) = (0, 0); + @b = sort { + $def = 1 if defined $Bar::a; + Bar::reenter() unless $init++; + $a <=> $b + } qw/4 3 1 2/; + print ("@b" eq '1 2 3 4' ? "ok 56\n" : "not ok 56\n"); + print "# x = '@b'\n"; + print !$def ? "ok 57\n" : "not ok 57\n"; +} diff --git a/contrib/perl5/t/op/split.t b/contrib/perl5/t/op/split.t index 8b9f4ad2f9e9..9a6586da641e 100755 --- a/contrib/perl5/t/op/split.t +++ b/contrib/perl5/t/op/split.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: split.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:26 $ - -print "1..25\n"; +print "1..29\n"; $FS = ':'; @@ -109,3 +107,23 @@ print $_ eq "aa b |\naa d |" ? "ok 24\n" : "not ok 24\n# `$_'\n"; $_ = "a : b :c: d"; @ary = split(/\s*:\s*/); if (($res = join(".",@ary)) eq "a.b.c.d") {print "ok 25\n";} else {print "not ok 25\n# res=`$res' != `a.b.c.d'\n";} + +# use of match result as pattern (!) +'p:q:r:s' eq join ':', split('abc' =~ /b/, 'p1q1r1s') or print "not "; +print "ok 26\n"; + +# /^/ treated as /^/m +$_ = join ':', split /^/, "ab\ncd\nef\n"; +print "not " if $_ ne "ab\n:cd\n:ef\n"; +print "ok 27\n"; + +# see if @a = @b = split(...) optimization works +@list1 = @list2 = split ('p',"a p b c p"); +print "not " if @list1 != @list2 or "@list1" ne "@list2" + or @list1 != 2 or "@list1" ne "a b c "; +print "ok 28\n"; + +# zero-width assertion +$_ = join ':', split /(?=\w)/, "rm b"; +print "not" if $_ ne "r:m :b"; +print "ok 29\n"; diff --git a/contrib/perl5/t/op/sprintf.t b/contrib/perl5/t/op/sprintf.t index 4d54d2c31722..f4af3cda0a16 100755 --- a/contrib/perl5/t/op/sprintf.t +++ b/contrib/perl5/t/op/sprintf.t @@ -1,38 +1,310 @@ #!./perl -# $RCSfile: sprintf.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:27 $ +# Tests sprintf, excluding handling of 64-bit integers or long +# doubles (if supported), of machine-specific short and long +# integers, machine-specific floating point exceptions (infinity, +# not-a-number ...), of the effects of locale, and of features +# specific to multi-byte characters (under use utf8 and such). BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use warnings; -print "1..4\n"; +while (<DATA>) { + s/^\s*>//; s/<\s*$//; + push @tests, [split(/<\s*>/, $_, 4)]; +} + +print '1..', scalar @tests, "\n"; $SIG{__WARN__} = sub { if ($_[0] =~ /^Invalid conversion/) { - $w++; + $w = ' INVALID' } else { warn @_; } }; -$w = 0; -$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f %b %x %X %#b %#x %#X","hi",123,0,456,0,ord('A'),3.0999,11,171,171,11,171,171); -if ($x eq ' hi 123 %foo 456 0A3.1 1011 ab AB 0b1011 0xab 0XAB' && $w == 0) { - print "ok 1\n"; -} else { - print "not ok 1 '$x'\n"; -} +for ($i = 1; @tests; $i++) { + ($template, $data, $result, $comment) = @{shift @tests}; + $evalData = eval $data; + $w = undef; + $x = sprintf(">$template<", + defined @$evalData ? @$evalData : $evalData); + substr($x, -1, 0) = $w if $w; + # $x may have 3 exponent digits, not 2 + my $y = $x; + if ($y =~ s/([Ee][-+])0(\d)/$1$2/) { + # if result is left-adjusted, append extra space + if ($template =~ /%\+?\-/ and $result =~ / $/) { + $y =~ s/<$/ </; + } + # if result is zero-filled, add extra zero + elsif ($template =~ /%\+?0/ and $result =~ /^0/) { + $y =~ s/^>0/>00/; + } + # if result is right-adjusted, prepend extra space + elsif ($result =~ /^ /) { + $y =~ s/^>/> /; + } + } -for $i (2 .. 4) { - $f = ('%6 .6s', '%6. 6s', '%6.6 s')[$i - 2]; - $w = 0; - $x = sprintf($f, ''); - if ($x eq $f && $w == 1) { - print "ok $i\n"; - } else { - print "not ok $i '$x' '$f' '$w'\n"; + if ($x eq ">$result<") { + print "ok $i\n"; + } + elsif ($y eq ">$result<") # Some C libraries always give + { # three-digit exponent + print("ok $i # >$result< $x three-digit exponent accepted\n"); + } + elsif ($result =~ /[-+]\d{3}$/ && + # Suppress tests with modulo of exponent >= 100 on platforms + # which can't handle such magnitudes (or where we can't tell). + ((!eval {require POSIX}) || # Costly: only do this if we must! + (length(&POSIX::DBL_MAX) - rindex(&POSIX::DBL_MAX, '+')) == 3)) + { + print("ok $i # >$template< >$data< >$result<", + " Suppressed: exponent out of range?\n") + } + else { + $y = ($x eq $y ? "" : " => $y"); + print("not ok $i >$template< >$data< >$result< $x$y", + $comment ? " # $comment\n" : "\n"); } } + +# In each of the the following lines, there are three required fields: +# printf template, data to be formatted (as a Perl expression), and +# expected result of formatting. An optional fourth field can contain +# a comment. Each field is delimited by a starting '>' and a +# finishing '<'; any whitespace outside these start and end marks is +# not part of the field. If formatting requires more than one data +# item (for example, if variable field widths are used), the Perl data +# expression should return a reference to an array having the requisite +# number of elements. Even so, subterfuge is sometimes required: see +# tests for %n and %p. +# +# The following tests are not currently run, for the reasons stated: + +=pod + +=begin problematic + +>%.0f< >-0.1< >-0< >C library bug: no minus on VMS, HP-UX< +>%.0f< >1.5< >2< >Standard vague: no rounding rules< +>%.0f< >2.5< >2< >Standard vague: no rounding rules< + +=end problematic + +=cut + +# template data result +__END__ +>%6. 6s< >''< >%6. 6s INVALID< >(See use of $w in code above)< +>%6 .6s< >''< >%6 .6s INVALID< +>%6.6 s< >''< >%6.6 s INVALID< +>%A< >''< >%A INVALID< +>%B< >''< >%B INVALID< +>%C< >''< >%C INVALID< +>%D< >0x7fffffff< >2147483647< >Synonym for %ld< +>%E< >123456.789< >1.234568E+05< >Like %e, but using upper-case "E"< +>%F< >123456.789< >123456.789000< >Synonym for %f< +>%G< >1234567.89< >1.23457E+06< >Like %g, but using upper-case "E"< +>%G< >1234567e96< >1.23457E+102< +>%G< >.1234567e-101< >1.23457E-102< +>%G< >12345.6789< >12345.7< +>%H< >''< >%H INVALID< +>%I< >''< >%I INVALID< +>%J< >''< >%J INVALID< +>%K< >''< >%K INVALID< +>%L< >''< >%L INVALID< +>%M< >''< >%M INVALID< +>%N< >''< >%N INVALID< +>%O< >2**32-1< >37777777777< >Synonum for %lo< +>%P< >''< >%P INVALID< +>%Q< >''< >%Q INVALID< +>%R< >''< >%R INVALID< +>%S< >''< >%S INVALID< +>%T< >''< >%T INVALID< +>%U< >2**32-1< >4294967295< >Synonum for %lu< +>%V< >''< >%V INVALID< +>%W< >''< >%W INVALID< +>%X< >2**32-1< >FFFFFFFF< >Like %x, but with u/c letters< +>%#X< >2**32-1< >0XFFFFFFFF< +>%Y< >''< >%Y INVALID< +>%Z< >''< >%Z INVALID< +>%a< >''< >%a INVALID< +>%b< >2**32-1< >11111111111111111111111111111111< +>%+b< >2**32-1< >11111111111111111111111111111111< +>%#b< >2**32-1< >0b11111111111111111111111111111111< +>%34b< >2**32-1< > 11111111111111111111111111111111< +>%034b< >2**32-1< >0011111111111111111111111111111111< +>%-34b< >2**32-1< >11111111111111111111111111111111 < +>%-034b< >2**32-1< >11111111111111111111111111111111 < +>%c< >ord('A')< >A< +>%10c< >ord('A')< > A< +>%#10c< >ord('A')< > A< ># modifier: no effect< +>%010c< >ord('A')< >000000000A< +>%10lc< >ord('A')< > A< >l modifier: no effect< +>%10hc< >ord('A')< > A< >h modifier: no effect< +>%10.5c< >ord('A')< > A< >precision: no effect< +>%-10c< >ord('A')< >A < +>%d< >123456.789< >123456< +>%d< >-123456.789< >-123456< +>%d< >0< >0< +>%+d< >0< >+0< +>%0d< >0< >0< +>%.0d< >0< >< +>%+.0d< >0< >+< +>%.0d< >1< >1< +>%d< >1< >1< +>%+d< >1< >+1< +>%#3.2d< >1< > 01< ># modifier: no effect< +>%3.2d< >1< > 01< +>%03.2d< >1< >001< +>%-3.2d< >1< >01 < +>%-03.2d< >1< >01 < >zero pad + left just.: no effect< +>%d< >-1< >-1< +>%+d< >-1< >-1< +>%hd< >1< >1< >More extensive testing of< +>%ld< >1< >1< >length modifiers would be< +>%Vd< >1< >1< >platform-specific< +>%vd< >chr(1)< >1< +>%+vd< >chr(1)< >+1< +>%#vd< >chr(1)< >1< +>%vd< >"\01\02\03"< >1.2.3< +>%v.3d< >"\01\02\03"< >001.002.003< +>%v03d< >"\01\02\03"< >001.002.003< +>%v-3d< >"\01\02\03"< >1 .2 .3 < +>%v+-3d< >"\01\02\03"< >+1 .2 .3 < +>%v4.3d< >"\01\02\03"< > 001. 002. 003< +>%v04.3d< >"\01\02\03"< >0001.0002.0003< +>%*v02d< >['-', "\0\7\14"]< >00-07-12< +>%v.*d< >[3, "\01\02\03"]< >001.002.003< +>%v0*d< >[3, "\01\02\03"]< >001.002.003< +>%v-*d< >[3, "\01\02\03"]< >1 .2 .3 < +>%v+-*d< >[3, "\01\02\03"]< >+1 .2 .3 < +>%v*.*d< >[4, 3, "\01\02\03"]< > 001. 002. 003< +>%v0*.*d< >[4, 3, "\01\02\03"]< >0001.0002.0003< +>%*v0*d< >['-', 2, "\0\7\13"]< >00-07-11< +>%e< >1234.875< >1.234875e+03< +>%e< >0.000012345< >1.234500e-05< +>%e< >1234567E96< >1.234567e+102< +>%e< >0< >0.000000e+00< +>%e< >.1234567E-101< >1.234567e-102< +>%+e< >1234.875< >+1.234875e+03< +>%#e< >1234.875< >1.234875e+03< +>%e< >-1234.875< >-1.234875e+03< +>%+e< >-1234.875< >-1.234875e+03< +>%#e< >-1234.875< >-1.234875e+03< +>%.0e< >1234.875< >1e+03< +>%#.0e< >1234.875< >1.e+03< +>%.*e< >[0, 1234.875]< >1e+03< +>%.1e< >1234.875< >1.2e+03< +>%-12.4e< >1234.875< >1.2349e+03 < +>%12.4e< >1234.875< > 1.2349e+03< +>%+-12.4e< >1234.875< >+1.2349e+03 < +>%+12.4e< >1234.875< > +1.2349e+03< +>%+-12.4e< >-1234.875< >-1.2349e+03 < +>%+12.4e< >-1234.875< > -1.2349e+03< +>%f< >1234.875< >1234.875000< +>%+f< >1234.875< >+1234.875000< +>%#f< >1234.875< >1234.875000< +>%f< >-1234.875< >-1234.875000< +>%+f< >-1234.875< >-1234.875000< +>%#f< >-1234.875< >-1234.875000< +>%6f< >1234.875< >1234.875000< +>%*f< >[6, 1234.875]< >1234.875000< +>%.0f< >1234.875< >1235< +>%.1f< >1234.875< >1234.9< +>%-8.1f< >1234.875< >1234.9 < +>%8.1f< >1234.875< > 1234.9< +>%+-8.1f< >1234.875< >+1234.9 < +>%+8.1f< >1234.875< > +1234.9< +>%+-8.1f< >-1234.875< >-1234.9 < +>%+8.1f< >-1234.875< > -1234.9< +>%*.*f< >[5, 2, 12.3456]< >12.35< +>%f< >0< >0.000000< +>%.0f< >0< >0< +>%.0f< >2**38< >274877906944< >Should have exact int'l rep'n< +>%.0f< >0.1< >0< +>%.0f< >0.6< >1< >Known to fail with sfio and (irix|nonstop-ux|powerux)< +>%.0f< >-0.6< >-1< >Known to fail with sfio and (irix|nonstop-ux|powerux)< +>%.0f< >1< >1< +>%#.0f< >1< >1.< +>%g< >12345.6789< >12345.7< +>%+g< >12345.6789< >+12345.7< +>%#g< >12345.6789< >12345.7< +>%.0g< >12345.6789< >1e+04< +>%#.0g< >12345.6789< >1.e+04< +>%.2g< >12345.6789< >1.2e+04< +>%.*g< >[2, 12345.6789]< >1.2e+04< +>%.9g< >12345.6789< >12345.6789< +>%12.9g< >12345.6789< > 12345.6789< +>%012.9g< >12345.6789< >0012345.6789< +>%-12.9g< >12345.6789< >12345.6789 < +>%*.*g< >[-12, 9, 12345.6789]< >12345.6789 < +>%-012.9g< >12345.6789< >12345.6789 < +>%g< >-12345.6789< >-12345.7< +>%+g< >-12345.6789< >-12345.7< +>%g< >1234567.89< >1.23457e+06< +>%+g< >1234567.89< >+1.23457e+06< +>%#g< >1234567.89< >1.23457e+06< +>%g< >-1234567.89< >-1.23457e+06< +>%+g< >-1234567.89< >-1.23457e+06< +>%#g< >-1234567.89< >-1.23457e+06< +>%g< >0.00012345< >0.00012345< +>%g< >0.000012345< >1.2345e-05< +>%g< >1234567E96< >1.23457e+102< +>%g< >.1234567E-101< >1.23457e-102< +>%g< >0< >0< +>%13g< >1234567.89< > 1.23457e+06< +>%+13g< >1234567.89< > +1.23457e+06< +>%013g< >1234567.89< >001.23457e+06< +>%-13g< >1234567.89< >1.23457e+06 < +>%h< >''< >%h INVALID< +>%i< >123456.789< >123456< >Synonym for %d< +>%j< >''< >%j INVALID< +>%k< >''< >%k INVALID< +>%l< >''< >%l INVALID< +>%m< >''< >%m INVALID< +>%s< >sprintf('%%n%n %d', $n, $n)< >%n 2< >Slight sneakiness to test %n< +>%o< >2**32-1< >37777777777< +>%+o< >2**32-1< >37777777777< +>%#o< >2**32-1< >037777777777< +>%d< >$p=sprintf('%p',$p);$p=~/^[0-9a-f]+$/< >1< >Coarse hack: hex from %p?< +>%#p< >''< >%#p INVALID< +>%q< >''< >%q INVALID< +>%r< >''< >%r INVALID< +>%s< >'string'< >string< +>%10s< >'string'< > string< +>%+10s< >'string'< > string< +>%#10s< >'string'< > string< +>%010s< >'string'< >0000string< +>%0*s< >[10, 'string']< >0000string< +>%-10s< >'string'< >string < +>%3s< >'string'< >string< +>%.3s< >'string'< >str< +>%.*s< >[3, 'string']< >str< +>%t< >''< >%t INVALID< +>%u< >2**32-1< >4294967295< +>%+u< >2**32-1< >4294967295< +>%#u< >2**32-1< >4294967295< +>%12u< >2**32-1< > 4294967295< +>%012u< >2**32-1< >004294967295< +>%-12u< >2**32-1< >4294967295 < +>%-012u< >2**32-1< >4294967295 < +>%v< >''< >%v INVALID< +>%w< >''< >%w INVALID< +>%x< >2**32-1< >ffffffff< +>%+x< >2**32-1< >ffffffff< +>%#x< >2**32-1< >0xffffffff< +>%10x< >2**32-1< > ffffffff< +>%010x< >2**32-1< >00ffffffff< +>%-10x< >2**32-1< >ffffffff < +>%-010x< >2**32-1< >ffffffff < +>%0-10x< >2**32-1< >ffffffff < +>%0*x< >[-10, ,2**32-1]< >ffffffff < +>%y< >''< >%y INVALID< +>%z< >''< >%z INVALID< diff --git a/contrib/perl5/t/op/stat.t b/contrib/perl5/t/op/stat.t index af4920cd43a9..1d8c7a36eb83 100755 --- a/contrib/perl5/t/op/stat.t +++ b/contrib/perl5/t/op/stat.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Config; @@ -32,7 +32,7 @@ if (open(FOO, ">Op.stat.tmp")) { else { print "# res=$res, nlink=$nlink.\nnot ok 1\n"; } - if ($Is_MSWin32 or $Is_Cygwin || ($mtime && $mtime == $ctime)) { + if ($Is_MSWin32 or $Is_Cygwin or $Is_Dos || ($mtime && $mtime == $ctime)) { print "ok 2\n"; } else { @@ -80,6 +80,7 @@ else { print "not ok 4\n"; print "#4 If test op/stat.t fails test 4, check if you are on a tmpfs\n"; print "#4 of some sort. Building in /tmp sometimes has this problem.\n"; + print "#4 Also building on the ClearCase VOBS filesystem may cause this failure.\n"; } print "#4 :$mtime: should != :$ctime:\n"; @@ -177,14 +178,18 @@ if ($^O eq 'mpeix' or $^O eq 'amigaos' or $Is_Dosish or $Is_Cygwin) { $cnt = $uid = 0; die "Can't run op/stat.t test 35 without pwd working" unless $cwd; -($bin) = grep {-d} ($^O eq 'machten' ? qw(/usr/bin /bin) : qw(/bin /usr/bin)) - or print ("not ok 35\n"), goto tty_test; -opendir BIN, $bin or die "Can't opendir $bin: $!"; -while (defined($_ = readdir BIN)) { - $_ = "$bin/$_"; - $cnt++; - $uid++ if -u; - last if $uid && $uid < $cnt; +my @bin = grep {-d} ($^O eq 'machten' ? + qw(/usr/bin /bin) : + qw(/sbin /usr/sbin /bin /usr/bin)); +unless (@bin) { print ("not ok 35\n"), goto tty_test; } +for my $bin (@bin) { + opendir BIN, $bin or die "Can't opendir $bin: $!"; + while (defined($_ = readdir BIN)) { + $_ = "$bin/$_"; + $cnt++; + $uid++ if -u; + last if $uid && $uid < $cnt; + } } closedir BIN; diff --git a/contrib/perl5/t/op/subst.t b/contrib/perl5/t/op/subst.t index 9757f4c5951f..7dd7a1c92c37 100755 --- a/contrib/perl5/t/op/subst.t +++ b/contrib/perl5/t/op/subst.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; require Config; import Config; } diff --git a/contrib/perl5/t/op/subst_amp.t b/contrib/perl5/t/op/subst_amp.t index e2e7c0e54289..71895720f7f6 100755 --- a/contrib/perl5/t/op/subst_amp.t +++ b/contrib/perl5/t/op/subst_amp.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; require Config; import Config; } diff --git a/contrib/perl5/t/op/substr.t b/contrib/perl5/t/op/substr.t index 5764e67e7ab9..85574d56ec9f 100755 --- a/contrib/perl5/t/op/substr.t +++ b/contrib/perl5/t/op/substr.t @@ -1,10 +1,12 @@ +#!./perl -print "1..125\n"; +print "1..174\n"; #P = start of string Q = start of substr R = end of substr S = end of string BEGIN { - unshift @INC, '../lib' if -d '../lib' ; + chdir 't' if -d 't'; + @INC = '../lib'; } use warnings ; @@ -268,3 +270,318 @@ ok 123, $@ && $@ =~ /Can't modify substr/ && $a eq "foo"; $a = "abcdefgh"; ok 124, sub { shift }->(substr($a, 0, 4, "xxxx")) eq 'abcd'; ok 125, $a eq 'xxxxefgh'; + +{ + my $y = 10; + $y = "2" . $y; + ok 126, $y+0 == 210; +} + +# utf8 sanity +{ + my $x = substr("a\x{263a}b",0); + ok 127, length($x) == 3; + $x = substr($x,1,1); + ok 128, $x eq "\x{263a}"; + $x = $x x 2; + ok 129, length($x) == 2; + substr($x,0,1) = "abcd"; + ok 130, $x eq "abcd\x{263a}"; + ok 131, length($x) == 5; + $x = reverse $x; + ok 132, length($x) == 5; + ok 133, $x eq "\x{263a}dcba"; + + my $z = 10; + $z = "21\x{263a}" . $z; + ok 134, length($z) == 5; + ok 135, $z eq "21\x{263a}10"; +} + +# replacement should work on magical values +require Tie::Scalar; +my %data; +tie $data{'a'}, 'Tie::StdScalar'; # makes $data{'a'} magical +$data{a} = "firstlast"; +ok 136, substr($data{'a'}, 0, 5, "") eq "first" && $data{'a'} eq "last"; + +# more utf8 + +# The following two originally from Ignasi Roca. + +$x = "\xF1\xF2\xF3"; +substr($x, 0, 1) = "\x{100}"; # Ignasi had \x{FF} +ok 137, length($x) == 3 && + $x eq "\x{100}\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 0, 1) = "\x{100}\x{FF}"; # Ignasi had \x{FF} +ok 138, length($x) == 4 && + $x eq "\x{100}\x{FF}\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F2}" && + substr($x, 3, 1) eq "\x{F3}"; + +# more utf8 lval exercise + +$x = "\xF1\xF2\xF3"; +substr($x, 0, 2) = "\x{100}\xFF"; +ok 139, length($x) == 3 && + $x eq "\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 1, 1) = "\x{100}\xFF"; +ok 140, length($x) == 4 && + $x eq "\xF1\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{100}" && + substr($x, 2, 1) eq "\x{FF}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 2, 1) = "\x{100}\xFF"; +ok 141, length($x) == 4 && + $x eq "\xF1\xF2\x{100}\xFF" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 3, 1) = "\x{100}\xFF"; +ok 142, length($x) == 5 && + $x eq "\xF1\xF2\xF3\x{100}\xFF" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{F3}" && + substr($x, 3, 1) eq "\x{100}" && + substr($x, 4, 1) eq "\x{FF}"; + +$x = "\xF1\xF2\xF3"; +substr($x, -1, 1) = "\x{100}\xFF"; +ok 143, length($x) == 4 && + $x eq "\xF1\xF2\x{100}\xFF" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}"; + +$x = "\xF1\xF2\xF3"; +substr($x, -1, 0) = "\x{100}\xFF"; +ok 144, length($x) == 5 && + $x eq "\xF1\xF2\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}" && + substr($x, 4, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 0, -1) = "\x{100}\xFF"; +ok 145, length($x) == 3 && + $x eq "\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 0, -2) = "\x{100}\xFF"; +ok 146, length($x) == 4 && + $x eq "\x{100}\xFF\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F2}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 0, -3) = "\x{100}\xFF"; +ok 147, length($x) == 5 && + $x eq "\x{100}\xFF\xF1\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F1}" && + substr($x, 3, 1) eq "\x{F2}" && + substr($x, 4, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 1, -1) = "\x{100}\xFF"; +ok 148, length($x) == 4 && + $x eq "\xF1\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{100}" && + substr($x, 2, 1) eq "\x{FF}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, -1, -1) = "\x{100}\xFF"; +ok 149, length($x) == 5 && + $x eq "\xF1\xF2\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}" && + substr($x, 4, 1) eq "\x{F3}"; + +# And tests for already-UTF8 one + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, 1) = "\x{100}"; +ok 150, length($x) == 3 && + $x eq "\x{100}\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, 1) = "\x{100}\x{FF}"; +ok 151, length($x) == 4 && + $x eq "\x{100}\x{FF}\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F2}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, 2) = "\x{100}\xFF"; +ok 152, length($x) == 3 && + $x eq "\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 1, 1) = "\x{100}\xFF"; +ok 153, length($x) == 4 && + $x eq "\x{101}\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{100}" && + substr($x, 2, 1) eq "\x{FF}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 2, 1) = "\x{100}\xFF"; +ok 154, length($x) == 4 && + $x eq "\x{101}\xF2\x{100}\xFF" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 3, 1) = "\x{100}\xFF"; +ok 155, length($x) == 5 && + $x eq "\x{101}\x{F2}\x{F3}\x{100}\xFF" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{F3}" && + substr($x, 3, 1) eq "\x{100}" && + substr($x, 4, 1) eq "\x{FF}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, -1, 1) = "\x{100}\xFF"; +ok 156, length($x) == 4 && + $x eq "\x{101}\xF2\x{100}\xFF" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, -1, 0) = "\x{100}\xFF"; +ok 157, length($x) == 5 && + $x eq "\x{101}\xF2\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}" && + substr($x, 4, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, -1) = "\x{100}\xFF"; +ok 158, length($x) == 3 && + $x eq "\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, -2) = "\x{100}\xFF"; +ok 159, length($x) == 4 && + $x eq "\x{100}\xFF\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F2}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, -3) = "\x{100}\xFF"; +ok 160, length($x) == 5 && + $x eq "\x{100}\xFF\x{101}\x{F2}\x{F3}" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{101}" && + substr($x, 3, 1) eq "\x{F2}" && + substr($x, 4, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 1, -1) = "\x{100}\xFF"; +ok 161, length($x) == 4 && + $x eq "\x{101}\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{100}" && + substr($x, 2, 1) eq "\x{FF}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, -1, -1) = "\x{100}\xFF"; +ok 162, length($x) == 5 && + $x eq "\x{101}\xF2\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}" && + substr($x, 4, 1) eq "\x{F3}"; + +substr($x = "ab", 0, 0, "\x{100}\x{200}"); +ok 163, $x eq "\x{100}\x{200}ab"; + +substr($x = "\x{100}\x{200}", 0, 0, "ab"); +ok 164, $x eq "ab\x{100}\x{200}"; + +substr($x = "ab", 1, 0, "\x{100}\x{200}"); +ok 165, $x eq "a\x{100}\x{200}b"; + +substr($x = "\x{100}\x{200}", 1, 0, "ab"); +ok 166, $x eq "\x{100}ab\x{200}"; + +substr($x = "ab", 2, 0, "\x{100}\x{200}"); +ok 167, $x eq "ab\x{100}\x{200}"; + +substr($x = "\x{100}\x{200}", 2, 0, "ab"); +ok 168, $x eq "\x{100}\x{200}ab"; + +substr($x = "\xFFb", 0, 0, "\x{100}\x{200}"); +ok 169, $x eq "\x{100}\x{200}\xFFb"; + +substr($x = "\x{100}\x{200}", 0, 0, "\xFFb"); +ok 170, $x eq "\xFFb\x{100}\x{200}"; + +substr($x = "\xFFb", 1, 0, "\x{100}\x{200}"); +ok 171, $x eq "\xFF\x{100}\x{200}b"; + +substr($x = "\x{100}\x{200}", 1, 0, "\xFFb"); +ok 172, $x eq "\x{100}\xFFb\x{200}"; + +substr($x = "\xFFb", 2, 0, "\x{100}\x{200}"); +ok 173, $x eq "\xFFb\x{100}\x{200}"; + +substr($x = "\x{100}\x{200}", 2, 0, "\xFFb"); +ok 174, $x eq "\x{100}\x{200}\xFFb"; + diff --git a/contrib/perl5/t/op/taint.t b/contrib/perl5/t/op/taint.t index 6548b46f59e3..2958a37b87a7 100755 --- a/contrib/perl5/t/op/taint.t +++ b/contrib/perl5/t/op/taint.t @@ -9,7 +9,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } use strict; @@ -19,14 +19,20 @@ use Config; # just because Errno possibly failing. eval { require Errno; import Errno }; +use vars qw($ipcsysv); # did we manage to load IPC::SysV? + BEGIN { if ($^O eq 'VMS' && !defined($Config{d_setenv})) { $ENV{PATH} = $ENV{PATH}; $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy'; } - if ($Config{d_shm} || $Config{d_msg}) { - require IPC::SysV; - IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU)); + if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ + && ($Config{d_shm} || $Config{d_msg})) { + eval { require IPC::SysV }; + unless ($@) { + $ipcsysv++; + IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU)); + } } } @@ -98,7 +104,7 @@ print PROG 'print "@ARGV\n"', "\n"; close PROG; my $echo = "$Invoke_Perl $ECHO"; -print "1..151\n"; +print "1..155\n"; # First, let's make sure that Perl is checking the dangerous # environment variables. Maybe they aren't set yet, so we'll @@ -612,13 +618,17 @@ else { # test shmread { - if ($Config{d_shm}) { + unless ($ipcsysv) { + print "ok 150 # skipped: no IPC::SysV\n"; + last; + } + if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && $Config{d_shm}) { no strict 'subs'; my $sent = "foobar"; my $rcvd; my $size = 2000; - my $id = shmget(IPC_PRIVATE, $size, S_IRWXU) || - warn "# shmget failed: $!\n"; + my $id = shmget(IPC_PRIVATE, $size, S_IRWXU); + if (defined $id) { if (shmwrite($id, $sent, 0, 60)) { if (shmread($id, $rcvd, 0, 60)) { @@ -629,7 +639,7 @@ else { } else { warn "# shmwrite failed: $!\n"; } - shmctl($id, IPC_RMID, 0) || warn "# shmctl failed: $!\n"; + shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n"; } else { warn "# shmget failed: $!\n"; } @@ -646,7 +656,11 @@ else { # test msgrcv { - if ($Config{d_msg}) { + unless ($ipcsysv) { + print "ok 151 # skipped: no IPC::SysV\n"; + last; + } + if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && $Config{d_msg}) { no strict 'subs'; my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU); @@ -665,7 +679,7 @@ else { } else { warn "# msgsnd failed\n"; } - msgctl($id, IPC_RMID, 0) || warn "# msgctl failed: $!\n"; + msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n"; } else { warn "# msgget failed\n"; } @@ -680,3 +694,42 @@ else { } } +{ + # bug id 20001004.006 + + open IN, "./TEST" or warn "$0: cannot read ./TEST: $!" ; + local $/; + my $a = <IN>; + my $b = <IN>; + print "not " unless tainted($a) && tainted($b) && !defined($b); + print "ok 152\n"; + close IN; +} + +{ + # bug id 20001004.007 + + open IN, "./TEST" or warn "$0: cannot read ./TEST: $!" ; + my $a = <IN>; + + my $c = { a => 42, + b => $a }; + print "not " unless !tainted($c->{a}) && tainted($c->{b}); + print "ok 153\n"; + + my $d = { a => $a, + b => 42 }; + print "not " unless tainted($d->{a}) && !tainted($d->{b}); + print "ok 154\n"; + + my $e = { a => 42, + b => { c => $a, d => 42 } }; + print "not " unless !tainted($e->{a}) && + !tainted($e->{b}) && + tainted($e->{b}->{c}) && + !tainted($e->{b}->{d}); + print "ok 155\n"; + + close IN; +} + diff --git a/contrib/perl5/t/op/tie.t b/contrib/perl5/t/op/tie.t index 9543420a4222..cbf92c6d27f0 100755 --- a/contrib/perl5/t/op/tie.t +++ b/contrib/perl5/t/op/tie.t @@ -6,7 +6,7 @@ # Currently it only tests the untie warning chdir 't' if -d 't'; -unshift @INC, "../lib"; +@INC = '../lib'; $ENV{PERL5LIB} = "../lib"; $|=1; @@ -44,6 +44,21 @@ untie %h; EXPECT ######## +# standard behaviour, without any extra references +use Tie::Hash ; +{package Tie::HashUntie; + use base 'Tie::StdHash'; + sub UNTIE + { + warn "Untied\n"; + } +} +tie %h, Tie::HashUntie; +untie %h; +EXPECT +Untied +######## + # standard behaviour, with 1 extra reference use Tie::Hash ; $a = tie %h, Tie::StdHash; diff --git a/contrib/perl5/t/op/tiearray.t b/contrib/perl5/t/op/tiearray.t index 25fda3fb0346..8e78b2f76b0e 100755 --- a/contrib/perl5/t/op/tiearray.t +++ b/contrib/perl5/t/op/tiearray.t @@ -3,7 +3,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } my %seen; diff --git a/contrib/perl5/t/op/tiehandle.t b/contrib/perl5/t/op/tiehandle.t index 6ae3faaaecdf..b04bdb78977d 100755 --- a/contrib/perl5/t/op/tiehandle.t +++ b/contrib/perl5/t/op/tiehandle.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } my @expect; @@ -77,7 +77,7 @@ package main; use Symbol; -print "1..29\n"; +print "1..33\n"; my $fh = gensym; @@ -149,3 +149,19 @@ ok($data eq "qwerty"); @expect = (CLOSE => $ob); $r = close $fh; ok($r == 5); + +# Does aliasing work with tied FHs? +*ALIAS = *$fh; +@expect = (PRINT => $ob,"some","text"); +$r = print ALIAS @expect[2,3]; +ok($r == 1); + +{ + use warnings; + # Special case of aliasing STDERR, which used + # to dump core when warnings were enabled + *STDERR = *$fh; + @expect = (PRINT => $ob,"some","text"); + $r = print STDERR @expect[2,3]; + ok($r == 1); +} diff --git a/contrib/perl5/t/op/tr.t b/contrib/perl5/t/op/tr.t index 4e6667cd7fb2..c7ba0d8c55ff 100755 --- a/contrib/perl5/t/op/tr.t +++ b/contrib/perl5/t/op/tr.t @@ -2,10 +2,10 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, "../lib"; + @INC = '../lib'; } -print "1..4\n"; +print "1..54\n"; $_ = "abcdefghijklmnopqrstuvwxyz"; @@ -37,3 +37,275 @@ print "ok 3\n"; print "ok 4\n"; } # + +# make sure that tr cancels IOK and NOK +($x = 12) =~ tr/1/3/; +(my $y = 12) =~ tr/1/3/; +($f = 1.5) =~ tr/1/3/; +(my $g = 1.5) =~ tr/1/3/; +print "not " unless $x + $y + $f + $g == 71; +print "ok 5\n"; + +# make sure tr is harmless if not updating - see [ID 20000511.005] +$_ = 'fred'; +/([a-z]{2})/; +$1 =~ tr/A-Z//; +s/^(\s*)f/$1F/; +print "not " if $_ ne 'Fred'; +print "ok 6\n"; + +# check tr handles UTF8 correctly +($x = 256.65.258) =~ tr/a/b/; +print "not " if $x ne 256.65.258 or length $x != 3; +print "ok 7\n"; +$x =~ tr/A/B/; +if (ord("\t") == 9) { # ASCII + print "not " if $x ne 256.66.258 or length $x != 3; +} +else { + print "not " if $x ne 256.65.258 or length $x != 3; +} +print "ok 8\n"; +# EBCDIC variants of the above tests +($x = 256.193.258) =~ tr/a/b/; +print "not " if $x ne 256.193.258 or length $x != 3; +print "ok 9\n"; +$x =~ tr/A/B/; +if (ord("\t") == 9) { # ASCII + print "not " if $x ne 256.193.258 or length $x != 3; +} +else { + print "not " if $x ne 256.194.258 or length $x != 3; +} +print "ok 10\n"; + +{ +if (ord("\t") == 9) { # ASCII + use utf8; +} +# 11 - changing UTF8 characters in a UTF8 string, same length. +$l = chr(300); $r = chr(400); +$x = 200.300.400; +$x =~ tr/\x{12c}/\x{190}/; +printf "not (%vd) ", $x if $x ne 200.400.400 or length $x != 3; +print "ok 11\n"; + +# 12 - changing UTF8 characters in UTF8 string, more bytes. +$x = 200.300.400; +$x =~ tr/\x{12c}/\x{be8}/; +printf "not (%vd) ", $x if $x ne 200.3048.400 or length $x != 3; +print "ok 12\n"; + +# 13 - introducing UTF8 characters to non-UTF8 string. +$x = 100.125.60; +$x =~ tr/\x{64}/\x{190}/; +printf "not (%vd) ", $x if $x ne 400.125.60 or length $x != 3; +print "ok 13\n"; + +# 14 - removing UTF8 characters from UTF8 string +$x = 400.125.60; +$x =~ tr/\x{190}/\x{64}/; +printf "not (%vd) ", $x if $x ne 100.125.60 or length $x != 3; +print "ok 14\n"; + +# 15 - counting UTF8 chars in UTF8 string +$x = 400.125.60.400; +$y = $x =~ tr/\x{190}/\x{190}/; +print "not " if $y != 2; +print "ok 15\n"; + +# 16 - counting non-UTF8 chars in UTF8 string +$x = 60.400.125.60.400; +$y = $x =~ tr/\x{3c}/\x{3c}/; +print "not " if $y != 2; +print "ok 16\n"; + +# 17 - counting UTF8 chars in non-UTF8 string +$x = 200.125.60; +$y = $x =~ tr/\x{190}/\x{190}/; +print "not " if $y != 0; +print "ok 17\n"; +} + +# 18: test brokenness with tr/a-z-9//; +$_ = "abcdefghijklmnopqrstuvwxyz"; +eval "tr/a-z-9/ /"; +print (($@ =~ /^Ambiguous range in transliteration operator/ || $^V lt v5.7.0) + ? '' : 'not ', "ok 18\n"); + +# 19-21: Make sure leading and trailing hyphens still work +$_ = "car-rot9"; +tr/-a-m/./; +print (($_ eq '..r.rot9') ? '' : 'not ', "ok 19\n"); + +$_ = "car-rot9"; +tr/a-m-/./; +print (($_ eq '..r.rot9') ? '' : 'not ', "ok 20\n"); + +$_ = "car-rot9"; +tr/-a-m-/./; +print (($_ eq '..r.rot9') ? '' : 'not ', "ok 21\n"); + +$_ = "abcdefghijklmnop"; +tr/ae-hn/./; +print (($_ eq '.bcd....ijklm.op') ? '' : 'not ', "ok 22\n"); + +$_ = "abcdefghijklmnop"; +tr/a-cf-kn-p/./; +print (($_ eq '...de......lm...') ? '' : 'not ', "ok 23\n"); + +$_ = "abcdefghijklmnop"; +tr/a-ceg-ikm-o/./; +print (($_ eq '...d.f...j.l...p') ? '' : 'not ', "ok 24\n"); + +# 25: Test reversed range check +# 20000705 MJD +eval "tr/m-d/ /"; +print (($@ =~ /^Invalid \[\] range "m-d" in transliteration operator/ || $^V lt v5.7.0) + ? '' : 'not ', "ok 25\n"); + +# 26: test cannot update if read-only +eval '$1 =~ tr/x/y/'; +print (($@ =~ /^Modification of a read-only value attempted/) ? '' : 'not ', + "ok 26\n"); + +# 27: test can count read-only +'abcdef' =~ /(bcd)/; +print (( eval '$1 =~ tr/abcd//' == 3) ? '' : 'not ', "ok 27\n"); + +# 28: test lhs OK if not updating +print ((eval '"123" =~ tr/12//' == 2) ? '' : 'not ', "ok 28\n"); + +# 29: test lhs bad if updating +eval '"123" =~ tr/1/1/'; +print (($@ =~ m|^Can't modify constant item in transliteration \(tr///\)|) + ? '' : 'not ', "ok 29\n"); + +# v300 (0x12c) is UTF-8-encoded as 196 172 (0xc4 0xac) +# v400 (0x190) is UTF-8-encoded as 198 144 (0xc6 0x90) + +# Transliterate a byte to a byte, all four ways. + +($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/; +print "not " unless $a eq v300.197.172.300.197.172; +print "ok 30\n"; + +($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/; +print "not " unless $a eq v300.197.172.300.197.172; +print "ok 31\n"; + +($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/; +print "not " unless $a eq v300.197.172.300.197.172; +print "ok 32\n"; + +($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/; +print "not " unless $a eq v300.197.172.300.197.172; +print "ok 33\n"; + +# Transliterate a byte to a wide character. + +($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/; +print "not " unless $a eq v300.301.172.300.301.172; +print "ok 34\n"; + +# Transliterate a wide character to a byte. + +($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/; +print "not " unless $a eq v195.196.172.195.196.172; +print "ok 35\n"; + +# Transliterate a wide character to a wide character. + +($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/; +print "not " unless $a eq v301.196.172.301.196.172; +print "ok 36\n"; + +# Transliterate both ways. + +($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/; +print "not " unless $a eq v195.301.172.195.301.172; +print "ok 37\n"; + +# Transliterate all (four) ways. + +($a = v300.196.172.300.196.172.400.198.144) =~ + tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/; +print "not " unless $a eq v197.301.173.197.301.173.401.198.144; +print "ok 38\n"; + +# Transliterate and count. + +print "not " + unless (($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/) == 2; +print "ok 39\n"; + +print "not " + unless (($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/) == 2; +print "ok 40\n"; + +# Transliterate with complement. + +($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c; +print "not " unless $a eq v301.196.301.301.196.301; +print "ok 41\n"; + +($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c; +print "not " unless $a eq v300.197.197.300.197.197; +print "ok 42\n"; + +# Transliterate with deletion. + +($a = v300.196.172.300.196.172) =~ tr/\xc4//d; +print "not " unless $a eq v300.172.300.172; +print "ok 43\n"; + +($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d; +print "not " unless $a eq v196.172.196.172; +print "ok 44\n"; + +# Transliterate with squeeze. + +($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s; +print "not " unless $a eq v197.172.300.300.197.172; +print "ok 45\n"; + +($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s; +print "not " unless $a eq v196.172.301.196.172.172; +print "ok 46\n"; + +# Tricky cases by Simon Cozens. + +($a = v196.172.200) =~ tr/\x{12c}/a/; +print "not " unless sprintf("%vd", $a) eq '196.172.200'; +print "ok 47\n"; + +($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/; +print "not " unless sprintf("%vd", $a) eq '196.172.200'; +print "ok 48\n"; + +($a = v196.172.200) =~ tr/\x{12c}//d; +print "not " unless sprintf("%vd", $a) eq '196.172.200'; +print "ok 49\n"; + +# UTF8 range + +($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/; +print "not " unless $a eq v192.196.172.194.197.172; +print "ok 50\n"; + +($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/; +print "not " unless $a eq v300.300.172.302.301.172; +print "ok 51\n"; + +# misc +($a = "R0_001") =~ tr/R_//d; +print "not " if hex($a) != 1; +print "ok 52\n"; + +@a = (1,2); map { y/1/./ for $_ } @a; +print "not " if "@a" ne ". 2"; +print "ok 53\n"; + +@a = (1,2); map { y/1/./ for $_.'' } @a; +print "not " if "@a" ne "1 2"; +print "ok 54\n"; diff --git a/contrib/perl5/t/op/undef.t b/contrib/perl5/t/op/undef.t index 8944ee3976d8..f6e36a5bed43 100755 --- a/contrib/perl5/t/op/undef.t +++ b/contrib/perl5/t/op/undef.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..27\n"; diff --git a/contrib/perl5/t/op/universal.t b/contrib/perl5/t/op/universal.t index a6bd03dbe92f..e6db8e691f2c 100755 --- a/contrib/perl5/t/op/universal.t +++ b/contrib/perl5/t/op/universal.t @@ -5,10 +5,11 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; + $| = 1; } -print "1..73\n"; +print "1..80\n"; $a = {}; bless $a, "Bob"; @@ -28,6 +29,19 @@ sub new { bless {} } $Alice::VERSION = 2.718; +{ + package Cedric; + our @ISA; + use base qw(Human); +} + +{ + package Programmer; + our $VERSION = 1.667; + + sub write_perl { 1 } +} + package main; my $i = 2; @@ -45,12 +59,34 @@ test $a->isa("Human"); test ! $a->isa("Male"); +test ! $a->isa('Programmer'); + test $a->can("drink"); test $a->can("eat"); test ! $a->can("sleep"); +test (!Cedric->isa('Programmer')); + +test (Cedric->isa('Human')); + +push(@Cedric::ISA,'Programmer'); + +test (Cedric->isa('Programmer')); + +{ + package Alice; + base::->import('Programmer'); +} + +test $a->isa('Programmer'); +test $a->isa("Female"); + +@Cedric::ISA = qw(Bob); + +test (!Cedric->isa('Programmer')); + my $b = 'abc'; my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE); my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} ); @@ -88,7 +124,7 @@ eval "use UNIVERSAL"; test $a->isa("UNIVERSAL"); -my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; +my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; # XXX import being here is really a bug if ('a' lt 'A') { test $sub2 eq "can import isa VERSION"; diff --git a/contrib/perl5/t/op/vec.t b/contrib/perl5/t/op/vec.t index bf60fc4a083c..7fe097477043 100755 --- a/contrib/perl5/t/op/vec.t +++ b/contrib/perl5/t/op/vec.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: vec.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:36 $ - -print "1..15\n"; +print "1..30\n"; print vec($foo,0,1) == 0 ? "ok 1\n" : "not ok 1\n"; print length($foo) == 0 ? "ok 2\n" : "not ok 2\n"; @@ -25,3 +23,58 @@ vec($Vec, 0, 32) = 0xbaddacab; print $Vec eq "\xba\xdd\xac\xab" ? "ok 14\n" : "not ok 14\n"; print vec($Vec, 0, 32) == 3135089835 ? "ok 15\n" : "not ok 15\n"; +# ensure vec() handles numericalness correctly +$foo = $bar = $baz = 0; +vec($foo = 0,0,1) = 1; +vec($bar = 0,1,1) = 1; +$baz = $foo | $bar; +print $foo eq "1" && $foo == 1 ? "ok 16\n" : "not ok 16\n"; +print $bar eq "2" && $bar == 2 ? "ok 17\n" : "not ok 17\n"; +print "$foo $bar $baz" eq "1 2 3" ? "ok 18\n" : "not ok 18\n"; + +# error cases + +$x = eval { vec $foo, 0, 3 }; +print "not " if defined $x or $@ !~ /^Illegal number of bits in vec/; +print "ok 19\n"; +$x = eval { vec $foo, 0, 0 }; +print "not " if defined $x or $@ !~ /^Illegal number of bits in vec/; +print "ok 20\n"; +$x = eval { vec $foo, 0, -13 }; +print "not " if defined $x or $@ !~ /^Illegal number of bits in vec/; +print "ok 21\n"; +$x = eval { vec($foo, -1, 4) = 2 }; +print "not " if defined $x or $@ !~ /^Assigning to negative offset in vec/; +print "ok 22\n"; +print "not " if vec('abcd', 7, 8); +print "ok 23\n"; + +# UTF8 +# N.B. currently curiously coded to circumvent bugs elswhere in UTF8 handling + +$foo = "\x{100}" . "\xff\xfe"; +$x = substr $foo, 1; +print "not " if vec($x, 0, 8) != 255; +print "ok 24\n"; +eval { vec($foo, 1, 8) }; +print "not " if $@; +print "ok 25\n"; +eval { vec($foo, 1, 8) = 13 }; +print "not " if $@; +print "ok 26\n"; +print "not " if $foo ne "\xc4\x0d\xc3\xbf\xc3\xbe"; +print "ok 27\n"; +$foo = "\x{100}" . "\xff\xfe"; +$x = substr $foo, 1; +vec($x, 2, 4) = 7; +print "not " if $x ne "\xff\xf7"; +print "ok 28\n"; + +# mixed magic + +$foo = "\x61\x62\x63\x64\x65\x66"; +print "not " if vec(substr($foo, 2, 2), 0, 16) != 25444; +print "ok 29\n"; +vec(substr($foo, 1,3), 5, 4) = 3; +print "not " if $foo ne "\x61\x62\x63\x34\x65\x66"; +print "ok 30\n"; diff --git a/contrib/perl5/t/op/ver.t b/contrib/perl5/t/op/ver.t index b08849f53a49..edfebd20ffc7 100755 --- a/contrib/perl5/t/op/ver.t +++ b/contrib/perl5/t/op/ver.t @@ -2,10 +2,10 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, "../lib"; + @INC = '../lib'; } -print "1..22\n"; +print "1..28\n"; my $test = 1; @@ -14,13 +14,24 @@ require v5.5.640; print "ok $test\n"; ++$test; # printing characters should work -print v111; -print v107.32; -print "$test\n"; ++$test; - -# hash keys too -$h{v111.107} = "ok"; -print "$h{ok} $test\n"; ++$test; +if (ord("\t") == 9) { # ASCII + print v111; + print v107.32; + print "$test\n"; ++$test; + + # hash keys too + $h{v111.107} = "ok"; + print "$h{ok} $test\n"; ++$test; +} +else { # EBCDIC + print v150; + print v146.64; + print "$test\n"; ++$test; + + # hash keys too + $h{v150.146} = "ok"; + print "$h{ok} $test\n"; ++$test; +} # poetry optimization should also sub v77 { "ok" } @@ -28,7 +39,12 @@ $x = v77; print "$x $test\n"; ++$test; # but not when dots are involved -$x = v77.78.79; +if (ord("\t") == 9) { # ASCII + $x = v77.78.79; +} +else { + $x = v212.213.214; +} print "not " unless $x eq "MNO"; print "ok $test\n"; ++$test; @@ -42,10 +58,20 @@ require 5.5.640; print "ok $test\n"; ++$test; # hash keys too -$h{111.107.32} = "ok"; +if (ord("\t") == 9) { # ASCII + $h{111.107.32} = "ok"; +} +else { + $h{150.146.64} = "ok"; +} print "$h{ok } $test\n"; ++$test; -$x = 77.78.79; +if (ord("\t") == 9) { # ASCII + $x = 77.78.79; +} +else { + $x = 212.213.214; +} print "not " unless $x eq "MNO"; print "ok $test\n"; ++$test; @@ -53,44 +79,103 @@ print "not " unless 1.20.300.4000 eq "\x{1}\x{14}\x{12c}\x{fa0}"; print "ok $test\n"; ++$test; # test sprintf("%vd"...) etc -print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; +if (ord("\t") == 9) { # ASCII + print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; +} +else { + print "not " unless sprintf("%vd", "Perl") eq '215.133.153.147'; +} print "ok $test\n"; ++$test; print "not " unless sprintf("%vd", v1.22.333.4444) eq '1.22.333.4444'; print "ok $test\n"; ++$test; -print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c'; +if (ord("\t") == 9) { # ASCII + print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c'; +} +else { + print "not " unless sprintf("%vx", "Perl") eq 'd7.85.99.93'; +} print "ok $test\n"; ++$test; print "not " unless sprintf("%vX", 1.22.333.4444) eq '1.16.14D.115C'; print "ok $test\n"; ++$test; -print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154'; +if (ord("\t") == 9) { # ASCII + print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154'; +} +else { + print "not " unless sprintf("%*v#o", ":", "Perl") eq '0327:0205:0231:0223'; +} print "ok $test\n"; ++$test; print "not " unless sprintf("%*vb", "##", v1.22.333.4444) eq '1##10110##101001101##1000101011100'; print "ok $test\n"; ++$test; +print "not " unless sprintf("%vd", join("", map { chr } + unpack "U*", v2001.2002.2003)) + eq '2001.2002.2003'; +print "ok $test\n"; ++$test; + { use bytes; - print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; + if (ord("\t") == 9) { # ASCII + print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; + } + else { + print "not " unless sprintf("%vd", "Perl") eq '215.133.153.147'; + } print "ok $test\n"; ++$test; print "not " unless sprintf("%vd", 1.22.333.4444) eq '1.22.197.141.225.133.156'; print "ok $test\n"; ++$test; - print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c'; + if (ord("\t") == 9) { # ASCII + print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c'; + } + else { + print "not " unless sprintf("%vx", "Perl") eq 'd7.85.99.93'; + } print "ok $test\n"; ++$test; print "not " unless sprintf("%vX", v1.22.333.4444) eq '1.16.C5.8D.E1.85.9C'; print "ok $test\n"; ++$test; - print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154'; + if (ord("\t") == 9) { # ASCII + print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154'; + } + else { + print "not " unless sprintf("%*v#o", ":", "Perl") eq '0327:0205:0231:0223'; + } print "ok $test\n"; ++$test; print "not " unless sprintf("%*vb", "##", v1.22.333.4444) eq '1##10110##11000101##10001101##11100001##10000101##10011100'; print "ok $test\n"; ++$test; } + +{ + # bug id 20000323.056 + + print "not " unless "\x{41}" eq +v65; + print "ok $test\n"; + $test++; + + print "not " unless "\x41" eq +v65; + print "ok $test\n"; + $test++; + + print "not " unless "\x{c8}" eq +v200; + print "ok $test\n"; + $test++; + + print "not " unless "\xc8" eq +v200; + print "ok $test\n"; + $test++; + + print "not " unless "\x{221b}" eq v8731; + print "ok $test\n"; + $test++; +} diff --git a/contrib/perl5/t/op/wantarray.t b/contrib/perl5/t/op/wantarray.t index 0a47b6d3ba0b..4b6f37cf0fa4 100755 --- a/contrib/perl5/t/op/wantarray.t +++ b/contrib/perl5/t/op/wantarray.t @@ -1,6 +1,6 @@ #!./perl -print "1..3\n"; +print "1..7\n"; sub context { my ( $cona, $testnum ) = @_; my $conb = (defined wantarray) ? ( wantarray ? 'A' : 'S' ) : 'V'; @@ -13,4 +13,8 @@ sub context { context('V',1); $a = context('S',2); @a = context('A',3); +scalar context('S',4); +$a = scalar context('S',5); +($a) = context('A',6); +($a) = scalar context('S',7); 1; diff --git a/contrib/perl5/t/op/write.t b/contrib/perl5/t/op/write.t index 87d50429f41c..5b01eb78b756 100755 --- a/contrib/perl5/t/op/write.t +++ b/contrib/perl5/t/op/write.t @@ -1,6 +1,6 @@ #!./perl -print "1..8\n"; +print "1..9\n"; my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat'; @@ -200,4 +200,21 @@ $this,$that write LEX; $that = 8; write LEX; + close LEX; } +# LEX_INTERPNORMAL test +my %e = ( a => 1 ); +format OUT4 = +@<<<<<< +"$e{a}" +. +open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp"; +write (OUT4); +close OUT4; +if (`$CAT Op_write.tmp` eq "1\n") { + print "ok 9\n"; + unlink "Op_write.tmp"; + } +else { + print "not ok 9\n"; + } diff --git a/contrib/perl5/t/pod/emptycmd.t b/contrib/perl5/t/pod/emptycmd.t index d348a9d278a5..815eba2b21f8 100755 --- a/contrib/perl5/t/pod/emptycmd.t +++ b/contrib/perl5/t/pod/emptycmd.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/for.t b/contrib/perl5/t/pod/for.t index b8a6ec5c7398..4af528a5ab8a 100755 --- a/contrib/perl5/t/pod/for.t +++ b/contrib/perl5/t/pod/for.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/headings.t b/contrib/perl5/t/pod/headings.t index fc7b4b265b29..365aa7d02b7e 100755 --- a/contrib/perl5/t/pod/headings.t +++ b/contrib/perl5/t/pod/headings.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/include.t b/contrib/perl5/t/pod/include.t index 6d0b7e34e550..b6f1e31a0e07 100755 --- a/contrib/perl5/t/pod/include.t +++ b/contrib/perl5/t/pod/include.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/included.t b/contrib/perl5/t/pod/included.t index 0e31a090fc7d..a25b37b98b50 100755 --- a/contrib/perl5/t/pod/included.t +++ b/contrib/perl5/t/pod/included.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/lref.t b/contrib/perl5/t/pod/lref.t index e367d6dd66cb..1dd8c68b15cc 100755 --- a/contrib/perl5/t/pod/lref.t +++ b/contrib/perl5/t/pod/lref.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/multiline_items.t b/contrib/perl5/t/pod/multiline_items.t index 37e8d530698b..334832dff7af 100755 --- a/contrib/perl5/t/pod/multiline_items.t +++ b/contrib/perl5/t/pod/multiline_items.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/nested_items.t b/contrib/perl5/t/pod/nested_items.t index 9c098018d13b..0b86702ae815 100755 --- a/contrib/perl5/t/pod/nested_items.t +++ b/contrib/perl5/t/pod/nested_items.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/nested_seqs.t b/contrib/perl5/t/pod/nested_seqs.t index 6a5405bf47f6..9f30533547c2 100755 --- a/contrib/perl5/t/pod/nested_seqs.t +++ b/contrib/perl5/t/pod/nested_seqs.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/oneline_cmds.t b/contrib/perl5/t/pod/oneline_cmds.t index 3081ef4dc378..bba0e4adbbd1 100755 --- a/contrib/perl5/t/pod/oneline_cmds.t +++ b/contrib/perl5/t/pod/oneline_cmds.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/pod2usage.t b/contrib/perl5/t/pod/pod2usage.t index bceeeefce870..70cbacdebc27 100755 --- a/contrib/perl5/t/pod/pod2usage.t +++ b/contrib/perl5/t/pod/pod2usage.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/poderrs.t b/contrib/perl5/t/pod/poderrs.t index ec632c253858..1b92ede3bb00 100755 --- a/contrib/perl5/t/pod/poderrs.t +++ b/contrib/perl5/t/pod/poderrs.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testpchk.pl"; import TestPodChecker; } @@ -59,7 +59,7 @@ The above blank line contains tabs and spaces only =over 4 -=item oops +=item aaps =head2 end without begin @@ -75,6 +75,20 @@ The above blank line contains tabs and spaces only =end +second one results in end w/o begin + +=head2 begin w/o formatter + +=begin + +=end + +=head2 for w/o formatter + +=for + +something... + =head2 Nested sequences of the same type C<code I<italic C<code again!>>> @@ -84,6 +98,9 @@ C<code I<italic C<code again!>>> E<alea iacta est> E<C<auml>> E<abcI<bla>> +E<0x100> +E<07777> +E<300> =head2 Unresolved internal links @@ -96,12 +113,15 @@ L</OoPs> L<abc def> L<> +L< aha> +L<oho > L<"Warnings"> this one is ok +L</unescaped> ok too, this POD has an X of the same name =head2 Warnings L<passwd(5)> -L< some text|page/"section" > +L<some text with / in it|perlvar/$|> should give warnings as hell =over 4 @@ -109,17 +129,70 @@ L< some text|page/"section" > =back 200 +the 200 is evil + =begin html What? =end xml +X<unescaped>see these unescaped < and > in the text? + +=head2 Misc + +Z<ddd> should be empty + +X<> should not be empty + +=over four + +This paragrapgh is misplaced - it ought to be an item. + +=item four should be numeric! + +=item + +=item blah + +=item previous is all empty!!! + +=back + +All empty over/back: + +=over 4 + +=back + +item w/o name + +=cut + +=pod bla + +bla is evil + +=cut blub + +blub is evil + +=head2 reoccurence + =over 4 +=item Misc + +we already have a head Misc + =back -see these unescaped < and > in the text? +=head2 some heading + +=head2 another one + +previous section is empty! =cut + diff --git a/contrib/perl5/t/pod/poderrs.xr b/contrib/perl5/t/pod/poderrs.xr index b8e5e86fd576..a21efdbd7617 100644 --- a/contrib/perl5/t/pod/poderrs.xr +++ b/contrib/perl5/t/pod/poderrs.xr @@ -1,33 +1,46 @@ -*** ERROR: Unknown command 'unknown1' at line 25 in file pod/poderrs.t -*** ERROR: Unknown interior-sequence 'Q' at line 29 in file pod/poderrs.t -*** ERROR: Unknown interior-sequence 'A' at line 30 in file pod/poderrs.t -*** ERROR: Unknown interior-sequence 'Y' at line 31 in file pod/poderrs.t -*** ERROR: Unknown interior-sequence 'V' at line 31 in file pod/poderrs.t -*** ERROR: unterminated B<...> at line 35 in file pod/poderrs.t -*** ERROR: unterminated I<...> at line 34 in file pod/poderrs.t -*** ERROR: unterminated C<...> at line 37 in file pod/poderrs.t -*** WARNING: line containing nothing but whitespace in paragraph at line 45 in file pod/poderrs.t -*** ERROR: =item without previous =over at line 52 in file pod/poderrs.t -*** ERROR: =back without previous =over at line 56 in file pod/poderrs.t -*** ERROR: =over on line 60 without closing =back (at head2) at line 64 in file pod/poderrs.t -*** ERROR: =end without =begin at line 66 in file pod/poderrs.t -*** ERROR: Nested =begin's (first at line 70:html) at line 72 in file pod/poderrs.t -*** ERROR: =end without =begin at line 76 in file pod/poderrs.t -*** ERROR: nested commands C<...C<...>...> at line 80 in file pod/poderrs.t -*** ERROR: garbled entity E<alea iacta est> at line 84 in file pod/poderrs.t -*** ERROR: garbled entity E<C<auml>> at line 85 in file pod/poderrs.t -*** ERROR: garbled entity E<abcI<bla>> at line 86 in file pod/poderrs.t -*** WARNING: collapsing newlines to blanks at line 96 in file pod/poderrs.t -*** ERROR: malformed link L<> : empty link at line 98 in file pod/poderrs.t -*** WARNING: ignoring leading whitespace in link at line 104 in file pod/poderrs.t -*** WARNING: ignoring trailing whitespace in link at line 104 in file pod/poderrs.t -*** ERROR: Spurious character(s) after =back at line 110 in file pod/poderrs.t -*** WARNING: No items in =over (at line 118) / =back list at line 120 in file pod/poderrs.t -*** WARNING: 2 unescaped <> in paragraph at line 122 in file pod/poderrs.t -*** ERROR: unresolved internal link 'begin or begin' at line 90 in file pod/poderrs.t -*** ERROR: unresolved internal link 'end with begin' at line 91 in file pod/poderrs.t -*** ERROR: unresolved internal link 'OoPs' at line 92 in file pod/poderrs.t -*** ERROR: unresolved internal link 'abc def' at line 96 in file pod/poderrs.t -*** ERROR: unresolved internal link 'passwd(5)' at line 103 in file pod/poderrs.t -*** WARNING: multiple occurence of link target 'oops' at line - in file pod/poderrs.t -pod/poderrs.t has 25 pod syntax errors. +*** ERROR: Unknown command 'unknown1' at line 25 in file t/pod/poderrs.t +*** ERROR: Unknown interior-sequence 'Q' at line 29 in file t/pod/poderrs.t +*** ERROR: Unknown interior-sequence 'A' at line 30 in file t/pod/poderrs.t +*** ERROR: Unknown interior-sequence 'Y' at line 31 in file t/pod/poderrs.t +*** ERROR: Unknown interior-sequence 'V' at line 31 in file t/pod/poderrs.t +*** ERROR: unterminated B<...> at line 35 in file t/pod/poderrs.t +*** ERROR: unterminated I<...> at line 34 in file t/pod/poderrs.t +*** ERROR: unterminated C<...> at line 37 in file t/pod/poderrs.t +*** WARNING: line containing nothing but whitespace in paragraph at line 45 in file t/pod/poderrs.t +*** ERROR: =item without previous =over at line 52 in file t/pod/poderrs.t +*** ERROR: =back without previous =over at line 56 in file t/pod/poderrs.t +*** ERROR: =over on line 60 without closing =back (at head2) at line 64 in file t/pod/poderrs.t +*** ERROR: =end without =begin at line 66 in file t/pod/poderrs.t +*** ERROR: Nested =begin's (first at line 70:html) at line 72 in file t/pod/poderrs.t +*** ERROR: =end without =begin at line 76 in file t/pod/poderrs.t +*** ERROR: No argument for =begin at line 82 in file t/pod/poderrs.t +*** ERROR: =for without formatter specification at line 88 in file t/pod/poderrs.t +*** ERROR: nested commands C<...C<...>...> at line 94 in file t/pod/poderrs.t +*** ERROR: garbled entity E<alea iacta est> at line 98 in file t/pod/poderrs.t +*** ERROR: garbled entity E<C<auml>> at line 99 in file t/pod/poderrs.t +*** ERROR: garbled entity E<abcI<bla>> at line 100 in file t/pod/poderrs.t +*** ERROR: Entity number out of range E<0x100> at line 101 in file t/pod/poderrs.t +*** ERROR: Entity number out of range E<07777> at line 102 in file t/pod/poderrs.t +*** ERROR: Entity number out of range E<300> at line 103 in file t/pod/poderrs.t +*** ERROR: malformed link L<> : empty link at line 115 in file t/pod/poderrs.t +*** WARNING: ignoring leading whitespace in link at line 116 in file t/pod/poderrs.t +*** WARNING: ignoring trailing whitespace in link at line 117 in file t/pod/poderrs.t +*** WARNING: (section) in 'passwd(5)' deprecated at line 123 in file t/pod/poderrs.t +*** WARNING: node '$|' contains non-escaped | or / at line 124 in file t/pod/poderrs.t +*** WARNING: alternative text '$|' contains non-escaped | or / at line 124 in file t/pod/poderrs.t +*** ERROR: Spurious character(s) after =back at line 130 in file t/pod/poderrs.t +*** ERROR: Nonempty Z<> at line 144 in file t/pod/poderrs.t +*** ERROR: Empty X<> at line 146 in file t/pod/poderrs.t +*** WARNING: preceding non-item paragraph(s) at line 152 in file t/pod/poderrs.t +*** WARNING: No argument for =item at line 154 in file t/pod/poderrs.t +*** WARNING: previous =item has no contents at line 156 in file t/pod/poderrs.t +*** WARNING: No items in =over (at line 164) / =back list at line 166 in file t/pod/poderrs.t +*** ERROR: Spurious text after =pod at line 172 in file t/pod/poderrs.t +*** ERROR: Spurious text after =cut at line 176 in file t/pod/poderrs.t +*** WARNING: empty section in previous paragraph at line 192 in file t/pod/poderrs.t +*** ERROR: unresolved internal link 'begin or begin' at line 107 in file t/pod/poderrs.t +*** ERROR: unresolved internal link 'end with begin' at line 108 in file t/pod/poderrs.t +*** ERROR: unresolved internal link 'OoPs' at line 109 in file t/pod/poderrs.t +*** ERROR: unresolved internal link 'abc def' at line 113 in file t/pod/poderrs.t +*** WARNING: multiple occurence of link target 'Misc' at line - in file t/pod/poderrs.t +t/pod/poderrs.t has 33 pod syntax errors. diff --git a/contrib/perl5/t/pod/podselect.t b/contrib/perl5/t/pod/podselect.t index 30eb30c9b038..5d45cdb590c7 100755 --- a/contrib/perl5/t/pod/podselect.t +++ b/contrib/perl5/t/pod/podselect.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/special_seqs.t b/contrib/perl5/t/pod/special_seqs.t index b8af57ee0586..c6b2ce169845 100755 --- a/contrib/perl5/t/pod/special_seqs.t +++ b/contrib/perl5/t/pod/special_seqs.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } @@ -40,4 +40,7 @@ So things like C<<$self->method()>> and C<<$self->{FIELDNAME}>> wont end up doing what you might expect since the first > will still terminate the first < seen. +Lets make sure these work for empty ones too, like C<< >> and C<< >> >> +(just to be obnoxious) + =cut diff --git a/contrib/perl5/t/pod/special_seqs.xr b/contrib/perl5/t/pod/special_seqs.xr index a07f4cf417e2..a8c715ae0ac0 100644 --- a/contrib/perl5/t/pod/special_seqs.xr +++ b/contrib/perl5/t/pod/special_seqs.xr @@ -20,3 +20,6 @@ up doing what you might expect since the first > will still terminate the first < seen. + Lets make sure these work for empty ones too, like and `>>' (just to be + obnoxious) + diff --git a/contrib/perl5/t/pod/testp2pt.pl b/contrib/perl5/t/pod/testp2pt.pl index 2ff8aa427a35..8cfdbb93869f 100644 --- a/contrib/perl5/t/pod/testp2pt.pl +++ b/contrib/perl5/t/pod/testp2pt.pl @@ -42,8 +42,11 @@ BEGIN { sub catfile(@) { File::Spec->catfile(@_); } my $INSTDIR = abs_path(dirname $0); -$INSTDIR = VMS::Filespec::unixpath($INSTDIR) if $^O eq 'VMS'; -$INSTDIR =~ s#/$## if $^O eq 'VMS'; +if ($^O eq 'VMS') { # clean up directory spec + $INSTDIR = VMS::Filespec::unixpath($INSTDIR); + $INSTDIR =~ s#/$##; + $INSTDIR =~ s#/000000/#/#; +} $INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 'pod'); $INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 't'); my @PODINCDIRS = ( catfile($INSTDIR, 'lib', 'Pod'), @@ -51,6 +54,7 @@ my @PODINCDIRS = ( catfile($INSTDIR, 'lib', 'Pod'), catfile($INSTDIR, 'pod'), catfile($INSTDIR, 't', 'pod') ); +print "PODINCDIRS = ",join(', ',@PODINCDIRS),"\n"; ## Find the path to the file to =include sub findinclude { @@ -106,7 +110,7 @@ sub begin_input { sub podinc2plaintext( $ $ ) { my ($infile, $outfile) = @_; local $_; - my $text_parser = $MYPKG->new; + my $text_parser = $MYPKG->new(quotes => "`'"); $text_parser->parse_from_file($infile, $outfile); } diff --git a/contrib/perl5/t/pragma/constant.t b/contrib/perl5/t/pragma/constant.t index 6438332cff2e..6e6617b70191 100755 --- a/contrib/perl5/t/pragma/constant.t +++ b/contrib/perl5/t/pragma/constant.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } use warnings; diff --git a/contrib/perl5/t/pragma/diagnostics.t b/contrib/perl5/t/pragma/diagnostics.t index 15cd6b59276a..14014f6b6849 100755 --- a/contrib/perl5/t/pragma/diagnostics.t +++ b/contrib/perl5/t/pragma/diagnostics.t @@ -1,8 +1,8 @@ #!./perl BEGIN { - chdir '..' if -d '../pod'; - unshift @INC, './lib' if -d './lib'; + chdir '..' if -d '../pod' && -d '../t'; + @INC = 'lib'; } diff --git a/contrib/perl5/t/pragma/locale.t b/contrib/perl5/t/pragma/locale.t index 414ceffe96ac..068fedeac818 100755 --- a/contrib/perl5/t/pragma/locale.t +++ b/contrib/perl5/t/pragma/locale.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; unshift @INC, '.'; require Config; import Config; if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) { @@ -15,8 +15,18 @@ use strict; my $debug = 1; +use Dumpvalue; + +my $dumper = Dumpvalue->new( + tick => qq{"}, + quoteHighBit => 0, + unctrl => "quote" + ); sub debug { - print @_ if $debug; + return unless $debug; + my($mess) = join "", @_; + chop $mess; + print $dumper->stringify($mess,1), "\n"; } sub debugf { @@ -34,7 +44,9 @@ eval { # and mingw32 uses said silly CRT $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i; -print "1..", ($have_setlocale ? 116 : 98), "\n"; +my $last = $have_setlocale ? 116 : 98; + +print "1..$last\n"; use vars qw(&LC_ALL); @@ -242,13 +254,13 @@ Afrikaans:af:za:1 15 Arabic:ar:dz eg sa:6 arabic8 Brezhoneg Breton:br:fr:1 15 Bulgarski Bulgarian:bg:bg:5 -Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW GB2312 tw.EUC +Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW Big5 GB2312 tw.EUC Hrvatski Croatian:hr:hr:2 Cymraeg Welsh:cy:cy:1 14 15 Czech:cs:cz:2 Dansk Danish:dk:da:1 15 Nederlands Dutch:nl:be nl:1 15 -English American British:en:au ca gb ie nz us uk:1 15 cp850 +English American British:en:au ca gb ie nz us uk zw:1 15 cp850 Esperanto:eo:eo:3 Eesti Estonian:et:ee:4 6 13 Suomi Finnish:fi:fi:1 15 @@ -271,11 +283,12 @@ Latvian:lv:lv:4 6 13 Lithuanian:lt:lt:4 6 13 Macedonian:mk:mk:1 15 Maltese:mt:mt:3 -Norsk Norwegian:no:no:1 15 +Moldovan:mo:mo:2 +Norsk Norwegian:no no\@nynorsk:no:1 15 Occitan:oc:es:1 15 Polski Polish:pl:pl:2 Rumanian:ro:ro:2 -Russki Russian:ru:ru su ua:5 koi8 koi8r koi8u cp1251 +Russki Russian:ru:ru su ua:5 koi8 koi8r KOI8-R koi8u cp1251 cp866 Serbski Serbian:sr:yu:5 Slovak:sk:sk:2 Slovene Slovenian:sl:si:2 @@ -283,10 +296,11 @@ Sqhip Albanian:sq:sq:1 15 Svenska Swedish:sv:fi se:1 15 Thai:th:th:11 tis620 Turkish:tr:tr:9 turkish8 -Yiddish:::1 15 +Yiddish:yi::1 15 EOF if ($^O eq 'os390') { + # These cause heartburn. Broken locales? $locales =~ s/Svenska Swedish:sv:fi se:1 15\n//; $locales =~ s/Thai:th:th:11 tis620\n//; } @@ -326,6 +340,7 @@ sub decode_encodings { } } else { push @enc, $_; + push @enc, "$_.UTF-8"; } } if ($^O eq 'os390') { @@ -347,32 +362,61 @@ foreach (0..15) { trylocale("iso_latin_$_"); } -foreach my $locale (split(/\n/, $locales)) { - my ($locale_name, $language_codes, $country_codes, $encodings) = - split(/:/, $locale); - my @enc = decode_encodings($encodings); - foreach my $loc (split(/ /, $locale_name)) { - trylocale($loc); - foreach my $enc (@enc) { - trylocale("$loc.$enc"); - } - $loc = lc $loc; - foreach my $enc (@enc) { - trylocale("$loc.$enc"); - } +# Sanitize the environment so that we can run the external 'locale' +# program without the taint mode getting grumpy. + +# $ENV{PATH} is special in VMS. +delete $ENV{PATH} if $^O ne 'VMS' or $Config{d_setenv}; + +# Other subversive stuff. +delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; + +if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) { + while (<LOCALES>) { + chomp; + trylocale($_); } - foreach my $lang (split(/ /, $language_codes)) { - trylocale($lang); - foreach my $country (split(/ /, $country_codes)) { - my $lc = "${lang}_${country}"; - trylocale($lc); + close(LOCALES); +} elsif ($^O eq 'VMS' && defined($ENV{'SYS$I18N_LOCALE'}) && -d 'SYS$I18N_LOCALE') { +# The SYS$I18N_LOCALE logical name search list was not present on +# VAX VMS V5.5-12, but was on AXP && VAX VMS V6.2 as well as later versions. + opendir(LOCALES, "SYS\$I18N_LOCALE:"); + while ($_ = readdir(LOCALES)) { + chomp; + trylocale($_); + } + close(LOCALES); +} else { + + # This is going to be slow. + + foreach my $locale (split(/\n/, $locales)) { + my ($locale_name, $language_codes, $country_codes, $encodings) = + split(/:/, $locale); + my @enc = decode_encodings($encodings); + foreach my $loc (split(/ /, $locale_name)) { + trylocale($loc); foreach my $enc (@enc) { - trylocale("$lc.$enc"); + trylocale("$loc.$enc"); } - my $lC = "${lang}_\U${country}"; - trylocale($lC); + $loc = lc $loc; foreach my $enc (@enc) { - trylocale("$lC.$enc"); + trylocale("$loc.$enc"); + } + } + foreach my $lang (split(/ /, $language_codes)) { + trylocale($lang); + foreach my $country (split(/ /, $country_codes)) { + my $lc = "${lang}_${country}"; + trylocale($lc); + foreach my $enc (@enc) { + trylocale("$lc.$enc"); + } + my $lC = "${lang}_\U${country}"; + trylocale($lC); + foreach my $enc (@enc) { + trylocale("$lC.$enc"); + } } } } @@ -380,6 +424,8 @@ foreach my $locale (split(/\n/, $locales)) { setlocale(LC_ALL, "C"); +sub utf8locale { $_[0] =~ /utf-?8/i } + @Locale = sort @Locale; debug "# Locales = @Locale\n"; @@ -392,8 +438,6 @@ my %Neoalpha; sub tryneoalpha { my ($Locale, $i, $test) = @_; - debug "# testing $i with locale '$Locale'\n" - unless $Testing{$i}{$Locale}++; unless ($test) { $Problem{$i}{$Locale} = 1; debug "# failed $i with locale '$Locale'\n"; @@ -405,7 +449,7 @@ sub tryneoalpha { foreach $Locale (@Locale) { debug "# Locale = $Locale\n"; @Alnum_ = getalnum_(); - debug "# \\w = @Alnum_\n"; + debug "# w = ", join("",@Alnum_), "\n"; unless (setlocale(LC_ALL, $Locale)) { foreach (99..103) { @@ -440,9 +484,9 @@ foreach $Locale (@Locale) { delete $lower{$_}; } - debug "# UPPER = ", join(" ", sort keys %UPPER ), "\n"; - debug "# lower = ", join(" ", sort keys %lower ), "\n"; - debug "# BoThCaSe = ", join(" ", sort keys %BoThCaSe), "\n"; + debug "# UPPER = ", join("", sort keys %UPPER ), "\n"; + debug "# lower = ", join("", sort keys %lower ), "\n"; + debug "# BoThCaSe = ", join("", sort keys %BoThCaSe), "\n"; # Find the alphabets that are not alphabets in the default locale. @@ -458,7 +502,7 @@ foreach $Locale (@Locale) { @Neoalpha = sort @Neoalpha; - debug "# Neoalpha = @Neoalpha\n"; + debug "# Neoalpha = ", join("",@Neoalpha), "\n"; if (@Neoalpha == 0) { # If we have no Neoalphas the remaining tests are no-ops. @@ -470,7 +514,10 @@ foreach $Locale (@Locale) { # Test \w. - { + if (utf8locale($Locale)) { + # Until the polymorphic regexen arrive. + debug "# skipping UTF-8 locale '$Locale'\n"; + } else { my $word = join('', @Neoalpha); $word =~ /^(\w+)$/; @@ -622,7 +669,9 @@ foreach $Locale (@Locale) { tryneoalpha($Locale, 114, $f == $c); } - debug "# testing 115 with locale '$Locale'\n"; + # Does taking lc separately differ from taking + # the lc "in-line"? (This was the bug 19990704.002, change #3568.) + # The bug was in the caching of the 'o'-magic. { use locale; @@ -645,8 +694,13 @@ foreach $Locale (@Locale) { lcA($x, $z) == 0 && lcB($x, $z) == 0); } - debug "# testing 116 with locale '$Locale'\n"; - { + # Does lc of an UPPER (if different from the UPPER) match + # case-insensitively the UPPER, and does the UPPER match + # case-insensitively the lc of the UPPER. And vice versa. + if (utf8locale($Locale)) { + # Until the polymorphic regexen arrive. + debug "# skipping UTF-8 locale '$Locale'\n"; + } else { use locale; my @f = (); @@ -661,14 +715,16 @@ foreach $Locale (@Locale) { push @f, $x unless $x =~ /$y/i && $y =~ /$x/i; } tryneoalpha($Locale, 116, @f == 0); - print "# testing 116 failed for locale '$Locale' for characters @f\n" - if @f; + if (@f) { + print "# failed 116 locale '$Locale' characters @f\n" + } } + } # Recount the errors. -foreach (99..116) { +foreach (99..$last) { if ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) { if ($_ == 102) { print "# The failure of test 102 is not necessarily fatal.\n"; @@ -684,7 +740,7 @@ foreach (99..116) { my $didwarn = 0; -foreach (99..116) { +foreach (99..$last) { if ($Problem{$_}) { my @f = sort keys %{ $Problem{$_} }; my $f = join(" ", @f); @@ -709,26 +765,43 @@ EOW } } -# Tell which locales ere okay. +# Tell which locales were okay and which were not. if ($didwarn) { - my @s; + my (@s, @F); foreach my $l (@Locale) { my $p = 0; - foreach my $t (102..102) { + foreach my $t (102..$last) { $p++ if $Problem{$t}{$l}; } push @s, $l if $p == 0; + push @F, $l unless $p == 0; } - my $s = join(" ", @s); - $s =~ s/(.{50,60}) /$1\n#\t/g; + if (@s) { + my $s = join(" ", @s); + $s =~ s/(.{50,60}) /$1\n#\t/g; + + warn + "# The following locales\n#\n", + "#\t", $s, "\n#\n", + "# tested okay.\n#\n", + } else { + warn "# None of your locales were fully okay.\n"; + } - warn - "# The following locales\n#\n", - "#\t", $s, "\n#\n", - "# tested okay.\n#\n", + if (@F) { + my $F = join(" ", @F); + $F =~ s/(.{50,60}) /$1\n#\t/g; + + warn + "# The following locales\n#\n", + "#\t", $F, "\n#\n", + "# had problems.\n#\n", + } else { + warn "# None of your locales were broken.\n"; + } } # eof diff --git a/contrib/perl5/t/pragma/overload.t b/contrib/perl5/t/pragma/overload.t index f9a9c59c87ed..a3007ef55b11 100755 --- a/contrib/perl5/t/pragma/overload.t +++ b/contrib/perl5/t/pragma/overload.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } package Oscalar; @@ -919,14 +919,69 @@ test $bar->[3], 13; # 206 my $aaa; { my $bbbb = 0; $aaa = bless \$bbbb, B } -test !$aaa, 1; +test !$aaa, 1; # 207 unless ($aaa) { - test 'ok', 'ok'; + test 'ok', 'ok'; # 208 } else { - test 'is not', 'ok'; + test 'is not', 'ok'; # 208 } +# check that overload isn't done twice by join +{ my $c = 0; + package Join; + use overload '""' => sub { $c++ }; + my $x = join '', bless([]), 'pq', bless([]); + main::test $x, '0pq1'; # 209 +}; + +# Test module-specific warning +{ + # check the Odd number of arguments for overload::constant warning + my $a = "" ; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + $x = eval ' overload::constant "integer" ; ' ; + test($a eq "") ; # 210 + use warnings 'overload' ; + $x = eval ' overload::constant "integer" ; ' ; + test($a =~ /^Odd number of arguments for overload::constant at/) ; # 211 +} + +{ + # check the `$_[0]' is not an overloadable type warning + my $a = "" ; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + $x = eval ' overload::constant "fred" => sub {} ; ' ; + test($a eq "") ; # 212 + use warnings 'overload' ; + $x = eval ' overload::constant "fred" => sub {} ; ' ; + test($a =~ /^`fred' is not an overloadable type at/); # 213 +} + +{ + # check the `$_[1]' is not a code reference warning + my $a = "" ; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + $x = eval ' overload::constant "integer" => 1; ' ; + test($a eq "") ; # 214 + use warnings 'overload' ; + $x = eval ' overload::constant "integer" => 1; ' ; + test($a =~ /^`1' is not a code reference at/); # 215 +} + +# make sure that we don't inifinitely recurse +{ + my $c = 0; + package Recurse; + use overload '""' => sub { shift }, + '0+' => sub { shift }, + 'bool' => sub { shift }, + fallback => 1; + my $x = bless([]); + main::test("$x" =~ /Recurse=ARRAY/); # 216 + main::test($x); # 217 + main::test($x+0 =~ /Recurse=ARRAY/); # 218 +}; # Last test is: -sub last {208} +sub last {218} diff --git a/contrib/perl5/t/pragma/strict-vars b/contrib/perl5/t/pragma/strict-vars index ae09742fab51..40b55572b808 100644 --- a/contrib/perl5/t/pragma/strict-vars +++ b/contrib/perl5/t/pragma/strict-vars @@ -55,7 +55,7 @@ Execution of - aborted due to compilation errors. # strict vars - error use strict 'vars' ; -$fred ; +<$fred> ; EXPECT Global symbol "$fred" requires explicit package name at - line 4. Execution of - aborted due to compilation errors. @@ -151,8 +151,6 @@ $d = 1;$i = 1;$n = 1; $e = 1;$j = 1;$o = 1; $p = 0b12; --FILE-- -# known scalar leak -BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } use abc; EXPECT Global symbol "$f" requires explicit package name at abc.pm line 3. @@ -171,8 +169,8 @@ Global symbol "$o" requires explicit package name at abc.pm line 7. Global symbol "$p" requires explicit package name at abc.pm line 8. Illegal binary digit '2' at abc.pm line 8, at end of line abc.pm has too many errors. -Compilation failed in require at - line 3. -BEGIN failed--compilation aborted at - line 3. +Compilation failed in require at - line 1. +BEGIN failed--compilation aborted at - line 1. ######## # Check scope of pragma with eval @@ -387,6 +385,8 @@ EXPECT # multiple our declarations in same scope, same package, warning use strict 'vars'; use warnings; +{ our $x = 1 } +{ our $x = 0 } our $foo; { our $foo; @@ -394,6 +394,17 @@ our $foo; our $foo; } EXPECT -"our" variable $foo redeclared at - line 7. +"our" variable $foo redeclared at - line 9. (Did you mean "local" instead of "our"?) -Name "Foo::foo" used only once: possible typo at - line 9. +Name "Foo::foo" used only once: possible typo at - line 11. +######## + +# Make sure the strict vars failure still occurs +# now that the `@i should be written as \@i' failure does not occur +# 20000522 mjd@plover.com (MJD) +use strict 'vars'; +no warnings; +"@i_like_crackers"; +EXPECT +Global symbol "@i_like_crackers" requires explicit package name at - line 7. +Execution of - aborted due to compilation errors. diff --git a/contrib/perl5/t/pragma/strict.t b/contrib/perl5/t/pragma/strict.t index c4d64164e6ec..5b245d0ab45d 100755 --- a/contrib/perl5/t/pragma/strict.t +++ b/contrib/perl5/t/pragma/strict.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; $ENV{PERL5LIB} = '../lib'; } @@ -19,7 +19,7 @@ my @prgs = () ; foreach (sort glob("pragma/strict-*")) { - next if /(~|\.orig)$/; + next if /(~|\.orig|,v)$/; open F, "<$_" or die "Cannot open $_: $!\n" ; while (<F>) { diff --git a/contrib/perl5/t/pragma/sub_lval.t b/contrib/perl5/t/pragma/sub_lval.t index e96c329d8ef7..f19268b38487 100755 --- a/contrib/perl5/t/pragma/sub_lval.t +++ b/contrib/perl5/t/pragma/sub_lval.t @@ -1,12 +1,12 @@ -print "1..46\n"; +print "1..64\n"; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -sub a : lvalue { my $a = 34; bless \$a } # Return a temporary -sub b : lvalue { shift } +sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary +sub b : lvalue { ${\shift} } my $out = a(b()); # Check that temporaries are allowed. print "# `$out'\nnot " unless ref $out eq 'main'; # Not reached if error. @@ -34,9 +34,9 @@ print "ok 3\n"; sub get_lex : lvalue { $in } sub get_st : lvalue { $blah } -sub id : lvalue { shift } +sub id : lvalue { ${\shift} } sub id1 : lvalue { $_[0] } -sub inc : lvalue { ++$_[0] } +sub inc : lvalue { ${\++$_[0]} } $in = 5; $blah = 3; @@ -288,40 +288,41 @@ print "# '$_'.\nnot " print "ok 34\n"; $x = '1234567'; -sub lv1t : lvalue { index $x, 2 } $_ = undef; eval <<'EOE' or $_ = $@; + sub lv1t : lvalue { index $x, 2 } lv1t = (2,3); 1; EOE print "# '$_'.\nnot " - unless /Can\'t return a temporary from lvalue subroutine/; + unless /Can\'t modify index in lvalue subroutine return/; print "ok 35\n"; $_ = undef; eval <<'EOE' or $_ = $@; - (lv1t) = (2,3); + sub lv2t : lvalue { shift } + (lv2t) = (2,3); 1; EOE print "# '$_'.\nnot " - unless /Can\'t return a temporary from lvalue subroutine/; + unless /Can\'t modify shift in lvalue subroutine return/; print "ok 36\n"; $xxx = 'xxx'; sub xxx () { $xxx } # Not lvalue -sub lv1tmp : lvalue { xxx } # is it a TEMP? $_ = undef; eval <<'EOE' or $_ = $@; + sub lv1tmp : lvalue { xxx } # is it a TEMP? lv1tmp = (2,3); 1; EOE print "# '$_'.\nnot " - unless /Can\'t return a temporary from lvalue subroutine/; + unless /Can\'t modify non-lvalue subroutine call in lvalue subroutine return/; print "ok 37\n"; $_ = undef; @@ -334,17 +335,17 @@ print "# '$_'.\nnot " unless /Can\'t return a temporary from lvalue subroutine/; print "ok 38\n"; -sub xxx () { 'xxx' } # Not lvalue -sub lv1tmpr : lvalue { xxx } # is it a TEMP? +sub yyy () { 'yyy' } # Const, not lvalue $_ = undef; eval <<'EOE' or $_ = $@; + sub lv1tmpr : lvalue { yyy } # is it read-only? lv1tmpr = (2,3); 1; EOE print "# '$_'.\nnot " - unless /Can\'t return a readonly value from lvalue subroutine/; + unless /Can\'t modify constant item in lvalue subroutine return/; print "ok 39\n"; $_ = undef; @@ -357,8 +358,6 @@ print "# '$_'.\nnot " unless /Can\'t return a readonly value from lvalue subroutine/; print "ok 40\n"; -=for disabled constructs - sub lva : lvalue {@a} $_ = undef; @@ -369,8 +368,7 @@ eval <<'EOE' or $_ = $@; 1; EOE -print "# '$_'.\nnot " - unless /Can\'t return an uninitialized value from lvalue subroutine/; +print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; print "ok 41\n"; $_ = undef; @@ -397,10 +395,6 @@ EOE print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; print "ok 43\n"; -=cut - -print "ok $_\n" for 41..43; - sub lv1n : lvalue { $newvar } $_ = undef; @@ -427,3 +421,122 @@ $a = \&lv1nn; $a->() = 8; print "# '$nnewvar'.\nnot " unless $nnewvar eq '8'; print "ok 46\n"; + +# This must happen at run time +eval { + sub AUTOLOAD : lvalue { $newvar }; +}; +foobar() = 12; +print "# '$newvar'.\nnot " unless $newvar eq "12"; +print "ok 47\n"; + +# Testing DWIM of foo = bar; +sub foo : lvalue { + $a; +} +$a = "not ok 48\n"; +foo = "ok 48\n"; +print $a; + +open bar, ">nothing" or die $!; +bar = *STDOUT; +print bar "ok 49\n"; +unlink "nothing"; + +{ +my %hash; my @array; +sub alv : lvalue { $array[1] } +sub alv2 : lvalue { $array[$_[0]] } +sub hlv : lvalue { $hash{"foo"} } +sub hlv2 : lvalue { $hash{$_[0]} } +$array[1] = "not ok 51\n"; +alv() = "ok 50\n"; +print alv(); + +alv2(20) = "ok 51\n"; +print $array[20]; + +$hash{"foo"} = "not ok 52\n"; +hlv() = "ok 52\n"; +print $hash{foo}; + +$hash{bar} = "not ok 53\n"; +hlv("bar") = "ok 53\n"; +print hlv("bar"); + +sub array : lvalue { @array } +sub array2 : lvalue { @array2 } # This is a global. +sub hash : lvalue { %hash } +sub hash2 : lvalue { %hash2 } # So's this. +@array2 = qw(foo bar); +%hash2 = qw(foo bar); + +(array()) = qw(ok 54); +print "not " unless "@array" eq "ok 54"; +print "ok 54\n"; + +(array2()) = qw(ok 55); +print "not " unless "@array2" eq "ok 55"; +print "ok 55\n"; + +(hash()) = qw(ok 56); +print "not " unless $hash{ok} == 56; +print "ok 56\n"; + +(hash2()) = qw(ok 57); +print "not " unless $hash2{ok} == 57; +print "ok 57\n"; + +@array = qw(a b c d); +sub aslice1 : lvalue { @array[0,2] }; +(aslice1()) = ("ok", "already"); +print "# @array\nnot " unless "@array" eq "ok b already d"; +print "ok 58\n"; + +@array2 = qw(a B c d); +sub aslice2 : lvalue { @array2[0,2] }; +(aslice2()) = ("ok", "already"); +print "not " unless "@array2" eq "ok B already d"; +print "ok 59\n"; + +%hash = qw(a Alpha b Beta c Gamma); +sub hslice : lvalue { @hash{"c", "b"} } +(hslice()) = ("CISC", "BogoMIPS"); +print "not " unless join("/",@hash{"c","a","b"}) eq "CISC/Alpha/BogoMIPS"; +print "ok 60\n"; +} + +$str = "Hello, world!"; +sub sstr : lvalue { substr($str, 1, 4) } +sstr() = "i"; +print "not " unless $str eq "Hi, world!"; +print "ok 61\n"; + +$str = "Made w/ JavaScript"; +sub veclv : lvalue { vec($str, 2, 32) } +if (ord('A') != 193) { + veclv() = 0x5065726C; +} +else { # EBCDIC? + veclv() = 0xD7859993; +} +print "# $str\nnot " unless $str eq "Made w/ PerlScript"; +print "ok 62\n"; + +sub position : lvalue { pos } +@p = (); +$_ = "fee fi fo fum"; +while (/f/g) { + push @p, position; + position() += 6; +} +print "# @p\nnot " unless "@p" eq "1 8"; +print "ok 63\n"; + +# Bug 20001223.002: split thought that the list had only one element +@ary = qw(4 5 6); +sub lval1 : lvalue { $ary[0]; } +sub lval2 : lvalue { $ary[1]; } +(lval1(), lval2()) = split ' ', "1 2 3 4"; +print "not " unless join(':', @ary) eq "1:2:6"; +print "ok 64\n"; diff --git a/contrib/perl5/t/pragma/subs.t b/contrib/perl5/t/pragma/subs.t index fe84f5ef76f6..7e48e201a87c 100755 --- a/contrib/perl5/t/pragma/subs.t +++ b/contrib/perl5/t/pragma/subs.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; $ENV{PERL5LIB} = '../lib'; } @@ -114,6 +114,30 @@ EXPECT 3 ######## +# override a built-in function, call after definition +use subs qw( open ) ; +sub open { print $_[0] + $_[1], "\n" } +open 1,2 ; +EXPECT +3 +######## + +# override a built-in function, call with () +use subs qw( open ) ; +open (1,2) ; +sub open { print $_[0] + $_[1], "\n" } +EXPECT +3 +######## + +# override a built-in function, call with () after definition +use subs qw( open ) ; +sub open { print $_[0] + $_[1], "\n" } +open (1,2) ; +EXPECT +3 +######## + --FILE-- abc Fred 1,2 ; 1; diff --git a/contrib/perl5/t/pragma/utf8.t b/contrib/perl5/t/pragma/utf8.t index 0e55a67d6936..e0a321afe9c1 100755 --- a/contrib/perl5/t/pragma/utf8.t +++ b/contrib/perl5/t/pragma/utf8.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; $ENV{PERL5LIB} = '../lib'; if ( ord("\t") != 9 ) { # skip on ebcdic platforms print "1..0 # Skip utf8 tests on ebcdic platform.\n"; @@ -10,7 +10,7 @@ BEGIN { } } -print "1..60\n"; +print "1..90\n"; my $test = 1; @@ -20,234 +20,443 @@ sub ok { print "ok $test\n"; } +sub nok { + my ($got,$expect) = @_; + print "# expected not [$expect], got [$got]\nnot " if $got eq $expect; + print "ok $test\n"; +} + +sub ok_bytes { + use bytes; + my ($got,$expect) = @_; + print "# expected [$expect], got [$got]\nnot " if $got ne $expect; + print "ok $test\n"; +} + +sub nok_bytes { + use bytes; + my ($got,$expect) = @_; + print "# expected not [$expect], got [$got]\nnot " if $got eq $expect; + print "ok $test\n"; +} + { use utf8; $_ = ">\x{263A}<"; s/([\x{80}-\x{10ffff}])/"&#".ord($1).";"/eg; ok $_, '>☺<'; - $test++; + $test++; # 1 $_ = ">\x{263A}<"; my $rx = "\x{80}-\x{10ffff}"; s/([$rx])/"&#".ord($1).";"/eg; ok $_, '>☺<'; - $test++; + $test++; # 2 $_ = ">\x{263A}<"; my $rx = "\\x{80}-\\x{10ffff}"; s/([$rx])/"&#".ord($1).";"/eg; ok $_, '>☺<'; - $test++; + $test++; # 3 $_ = "alpha,numeric"; m/([[:alpha:]]+)/; ok $1, 'alpha'; - $test++; + $test++; # 4 $_ = "alphaNUMERICstring"; m/([[:^lower:]]+)/; ok $1, 'NUMERIC'; - $test++; + $test++; # 5 $_ = "alphaNUMERICstring"; m/(\p{Ll}+)/; ok $1, 'alpha'; - $test++; + $test++; # 6 $_ = "alphaNUMERICstring"; m/(\p{Lu}+)/; ok $1, 'NUMERIC'; - $test++; + $test++; # 7 $_ = "alpha,numeric"; m/([\p{IsAlpha}]+)/; ok $1, 'alpha'; - $test++; + $test++; # 8 $_ = "alphaNUMERICstring"; m/([^\p{IsLower}]+)/; ok $1, 'NUMERIC'; - $test++; + $test++; # 9 $_ = "alpha123numeric456"; m/([\p{IsDigit}]+)/; ok $1, '123'; - $test++; + $test++; # 10 $_ = "alpha123numeric456"; m/([^\p{IsDigit}]+)/; ok $1, 'alpha'; - $test++; + $test++; # 11 $_ = ",123alpha,456numeric"; m/([\p{IsAlnum}]+)/; ok $1, '123alpha'; - $test++; + $test++; # 12 } + { use utf8; $_ = "\x{263A}>\x{263A}\x{263A}"; ok length, 4; - $test++; + $test++; # 13 ok length((m/>(.)/)[0]), 1; - $test++; + $test++; # 14 ok length($&), 2; - $test++; + $test++; # 15 ok length($'), 1; - $test++; + $test++; # 16 ok length($`), 1; - $test++; + $test++; # 17 ok length($1), 1; - $test++; + $test++; # 18 ok length($tmp=$&), 2; - $test++; + $test++; # 19 ok length($tmp=$'), 1; - $test++; + $test++; # 20 ok length($tmp=$`), 1; - $test++; + $test++; # 21 ok length($tmp=$1), 1; - $test++; + $test++; # 22 - ok $&, pack("C*", ord(">"), 0342, 0230, 0272); - $test++; + { + use bytes; - ok $', pack("C*", 0342, 0230, 0272); - $test++; + my $tmp = $&; + ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272); + $test++; # 23 - ok $`, pack("C*", 0342, 0230, 0272); - $test++; + $tmp = $'; + ok $tmp, pack("C*", 0342, 0230, 0272); + $test++; # 24 - ok $1, pack("C*", 0342, 0230, 0272); - $test++; + $tmp = $`; + ok $tmp, pack("C*", 0342, 0230, 0272); + $test++; # 25 + + $tmp = $1; + ok $tmp, pack("C*", 0342, 0230, 0272); + $test++; # 26 + } + + ok_bytes $&, pack("C*", ord(">"), 0342, 0230, 0272); + $test++; # 27 + + ok_bytes $', pack("C*", 0342, 0230, 0272); + $test++; # 28 + + ok_bytes $`, pack("C*", 0342, 0230, 0272); + $test++; # 29 + + ok_bytes $1, pack("C*", 0342, 0230, 0272); + $test++; # 30 { use bytes; no utf8; ok length, 10; - $test++; + $test++; # 31 ok length((m/>(.)/)[0]), 1; - $test++; + $test++; # 32 ok length($&), 2; - $test++; + $test++; # 33 ok length($'), 5; - $test++; + $test++; # 34 ok length($`), 3; - $test++; + $test++; # 35 ok length($1), 1; - $test++; + $test++; # 36 ok $&, pack("C*", ord(">"), 0342); - $test++; + $test++; # 37 ok $', pack("C*", 0230, 0272, 0342, 0230, 0272); - $test++; + $test++; # 38 ok $`, pack("C*", 0342, 0230, 0272); - $test++; + $test++; # 39 ok $1, pack("C*", 0342); - $test++; - + $test++; # 40 } - { no utf8; $_="\342\230\272>\342\230\272\342\230\272"; } ok length, 10; - $test++; + $test++; # 41 ok length((m/>(.)/)[0]), 1; - $test++; + $test++; # 42 ok length($&), 2; - $test++; + $test++; # 43 ok length($'), 1; - $test++; + $test++; # 44 ok length($`), 1; - $test++; + $test++; # 45 ok length($1), 1; - $test++; + $test++; # 46 ok length($tmp=$&), 2; - $test++; + $test++; # 47 ok length($tmp=$'), 1; - $test++; + $test++; # 48 ok length($tmp=$`), 1; - $test++; + $test++; # 49 ok length($tmp=$1), 1; - $test++; + $test++; # 50 - ok $&, pack("C*", ord(">"), 0342, 0230, 0272); - $test++; + { + use bytes; - ok $', pack("C*", 0342, 0230, 0272); - $test++; + my $tmp = $&; + ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272); + $test++; # 51 - ok $`, pack("C*", 0342, 0230, 0272); - $test++; + $tmp = $'; + ok $tmp, pack("C*", 0342, 0230, 0272); + $test++; # 52 - ok $1, pack("C*", 0342, 0230, 0272); - $test++; + $tmp = $`; + ok $tmp, pack("C*", 0342, 0230, 0272); + $test++; # 53 + + $tmp = $1; + ok $tmp, pack("C*", 0342, 0230, 0272); + $test++; # 54 + } { use bytes; no utf8; ok length, 10; - $test++; + $test++; # 55 ok length((m/>(.)/)[0]), 1; - $test++; + $test++; # 56 ok length($&), 2; - $test++; + $test++; # 57 ok length($'), 5; - $test++; + $test++; # 58 ok length($`), 3; - $test++; + $test++; # 59 ok length($1), 1; - $test++; + $test++; # 60 ok $&, pack("C*", ord(">"), 0342); - $test++; + $test++; # 61 ok $', pack("C*", 0230, 0272, 0342, 0230, 0272); - $test++; + $test++; # 62 ok $`, pack("C*", 0342, 0230, 0272); - $test++; + $test++; # 63 ok $1, pack("C*", 0342); + $test++; # 64 + } + + ok "\x{ab}" =~ /^\x{ab}$/, 1; + $test++; # 65 +} + +{ + use utf8; + ok join(" ",unpack("C*",chr(128).chr(255))), "128 255"; + $test++; +} + +{ + use utf8; + my @a = map ord, split(//, join("", map chr, (1234, 123, 2345))); + ok "@a", "1234 123 2345"; + $test++; # 67 +} + +{ + use utf8; + my $x = chr(123); + my @a = map ord, split(/$x/, join("", map chr, (1234, 123, 2345))); + ok "@a", "1234 2345"; + $test++; # 68 +} + +{ + # bug id 20001009.001 + + my ($a, $b); + + { use bytes; $a = "\xc3\xa4" } + { use utf8; $b = "\xe4" } # \xXX must not produce UTF-8 + + print "not " if $a eq $b; + print "ok $test\n"; $test++; + + { use utf8; print "not " if $a eq $b; } + print "ok $test\n"; $test++; +} + +{ + # bug id 20001008.001 + + my @x = ("stra\337e 138","stra\337e 138"); + for (@x) { + s/(\d+)\s*([\w\-]+)/$1 . uc $2/e; + my($latin) = /^(.+)(?:\s+\d)/; + print $latin eq "stra\337e" ? "ok $test\n" : + "#latin[$latin]\nnot ok $test\n"; + $test++; + $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a + use utf8; + $latin =~ s!(s)tr(?:aß|s+e)!$1tr.!; # \303\237 after the a + } +} + +{ + # bug id 20000427.003 + + use utf8; + use warnings; + use strict; + + my $sushi = "\x{b36c}\x{5a8c}\x{ff5b}\x{5079}\x{505b}"; + + my @charlist = split //, $sushi; + my $r = ''; + foreach my $ch (@charlist) { + $r = $r . " " . sprintf "U+%04X", ord($ch); + } + + print "not " unless $r eq " U+B36C U+5A8C U+FF5B U+5079 U+505B"; + print "ok $test\n"; + $test++; +} + +{ + # bug id 20000426.003 + + use utf8; + + my $s = "\x20\x40\x{80}\x{100}\x{80}\x40\x20"; + + my ($a, $b, $c) = split(/\x40/, $s); + print "not " + unless $a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a; + print "ok $test\n"; + $test++; + + my ($a, $b) = split(/\x{100}/, $s); + print "not " unless $a eq "\x20\x40\x{80}" && $b eq "\x{80}\x40\x20"; + print "ok $test\n"; + $test++; + + my ($a, $b) = split(/\x{80}\x{100}\x{80}/, $s); + print "not " unless $a eq "\x20\x40" && $b eq "\x40\x20"; + print "ok $test\n"; + $test++; + + my ($a, $b) = split(/\x40\x{80}/, $s); + print "not " unless $a eq "\x20" && $b eq "\x{100}\x{80}\x40\x20"; + print "ok $test\n"; + $test++; + + my ($a, $b, $c) = split(/[\x40\x{80}]+/, $s); + print "not " unless $a eq "\x20" && $b eq "\x{100}" && $c eq "\x20"; + print "ok $test\n"; + $test++; +} + +{ + # bug id 20000730.004 + + use utf8; + + my $smiley = "\x{263a}"; + + for my $s ("\x{263a}", # 1 + $smiley, # 2 + + "" . $smiley, # 3 + "" . "\x{263a}", # 4 + + $smiley . "", # 5 + "\x{263a}" . "", # 6 + ) { + my $length_chars = length($s); + my $length_bytes; + { use bytes; $length_bytes = length($s) } + my @regex_chars = $s =~ m/(.)/g; + my $regex_chars = @regex_chars; + my @split_chars = split //, $s; + my $split_chars = @split_chars; + print "not " + unless "$length_chars/$regex_chars/$split_chars/$length_bytes" eq + "1/1/1/3"; + print "ok $test\n"; $test++; + } + for my $s ("\x{263a}" . "\x{263a}", # 7 + $smiley . $smiley, # 8 + + "\x{263a}\x{263a}", # 9 + "$smiley$smiley", # 10 + + "\x{263a}" x 2, # 11 + $smiley x 2, # 12 + ) { + my $length_chars = length($s); + my $length_bytes; + { use bytes; $length_bytes = length($s) } + my @regex_chars = $s =~ m/(.)/g; + my $regex_chars = @regex_chars; + my @split_chars = split //, $s; + my $split_chars = @split_chars; + print "not " + unless "$length_chars/$regex_chars/$split_chars/$length_bytes" eq + "2/2/2/6"; + print "ok $test\n"; + $test++; } } diff --git a/contrib/perl5/t/pragma/warn/2use b/contrib/perl5/t/pragma/warn/2use index 60a60c313cb0..b489d62e1991 100644 --- a/contrib/perl5/t/pragma/warn/2use +++ b/contrib/perl5/t/pragma/warn/2use @@ -120,175 +120,223 @@ Use of uninitialized value in scalar chop at - line 3. ######## # Check scope of pragma with eval -no warnings ; -eval { +use warnings; +{ + no warnings ; + eval { + my $b ; chop $b ; + }; print STDERR $@ ; my $b ; chop $b ; -}; print STDERR $@ ; -my $b ; chop $b ; +} EXPECT ######## # Check scope of pragma with eval -no warnings ; -eval { - use warnings 'uninitialized' ; +use warnings; +{ + no warnings ; + eval { + use warnings 'uninitialized' ; + my $b ; chop $b ; + }; print STDERR $@ ; my $b ; chop $b ; -}; print STDERR $@ ; -my $b ; chop $b ; +} EXPECT -Use of uninitialized value in scalar chop at - line 6. +Use of uninitialized value in scalar chop at - line 8. ######## # Check scope of pragma with eval -use warnings 'uninitialized' ; -eval { +no warnings; +{ + use warnings 'uninitialized' ; + eval { + my $b ; chop $b ; + }; print STDERR $@ ; my $b ; chop $b ; -}; print STDERR $@ ; -my $b ; chop $b ; +} EXPECT -Use of uninitialized value in scalar chop at - line 5. Use of uninitialized value in scalar chop at - line 7. +Use of uninitialized value in scalar chop at - line 9. ######## # Check scope of pragma with eval -use warnings 'uninitialized' ; -eval { - no warnings ; +no warnings; +{ + use warnings 'uninitialized' ; + eval { + no warnings ; + my $b ; chop $b ; + }; print STDERR $@ ; my $b ; chop $b ; -}; print STDERR $@ ; -my $b ; chop $b ; +} EXPECT -Use of uninitialized value in scalar chop at - line 8. +Use of uninitialized value in scalar chop at - line 10. ######## # Check scope of pragma with eval -no warnings ; -eval { +use warnings; +{ + no warnings ; + eval { + 1 if $a EQ $b ; + }; print STDERR $@ ; 1 if $a EQ $b ; -}; print STDERR $@ ; -1 if $a EQ $b ; +} EXPECT ######## # Check scope of pragma with eval -no warnings ; -eval { - use warnings 'deprecated' ; +use warnings; +{ + no warnings ; + eval { + use warnings 'deprecated' ; + 1 if $a EQ $b ; + }; print STDERR $@ ; 1 if $a EQ $b ; -}; print STDERR $@ ; -1 if $a EQ $b ; +} EXPECT -Use of EQ is deprecated at - line 6. +Use of EQ is deprecated at - line 8. ######## # Check scope of pragma with eval -use warnings 'deprecated' ; -eval { +no warnings; +{ + use warnings 'deprecated' ; + eval { + 1 if $a EQ $b ; + }; print STDERR $@ ; 1 if $a EQ $b ; -}; print STDERR $@ ; -1 if $a EQ $b ; +} EXPECT -Use of EQ is deprecated at - line 5. Use of EQ is deprecated at - line 7. +Use of EQ is deprecated at - line 9. ######## # Check scope of pragma with eval -use warnings 'deprecated' ; -eval { - no warnings ; +no warnings; +{ + use warnings 'deprecated' ; + eval { + no warnings ; + 1 if $a EQ $b ; + }; print STDERR $@ ; 1 if $a EQ $b ; -}; print STDERR $@ ; -1 if $a EQ $b ; +} EXPECT -Use of EQ is deprecated at - line 8. +Use of EQ is deprecated at - line 10. ######## # Check scope of pragma with eval -no warnings ; -eval ' +use warnings; +{ + no warnings ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; my $b ; chop $b ; -'; print STDERR $@ ; -my $b ; chop $b ; +} EXPECT ######## # Check scope of pragma with eval -no warnings ; -eval q[ - use warnings 'uninitialized' ; +use warnings; +{ + no warnings ; + eval q[ + use warnings 'uninitialized' ; + my $b ; chop $b ; + ]; print STDERR $@; my $b ; chop $b ; -]; print STDERR $@; -my $b ; chop $b ; +} EXPECT Use of uninitialized value in scalar chop at (eval 1) line 3. ######## # Check scope of pragma with eval -use warnings 'uninitialized' ; -eval ' +no warnings; +{ + use warnings 'uninitialized' ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; my $b ; chop $b ; -'; print STDERR $@ ; -my $b ; chop $b ; +} EXPECT Use of uninitialized value in scalar chop at (eval 1) line 2. -Use of uninitialized value in scalar chop at - line 7. +Use of uninitialized value in scalar chop at - line 9. ######## # Check scope of pragma with eval -use warnings 'uninitialized' ; -eval ' - no warnings ; +no warnings; +{ + use warnings 'uninitialized' ; + eval ' + no warnings ; + my $b ; chop $b ; + '; print STDERR $@ ; my $b ; chop $b ; -'; print STDERR $@ ; -my $b ; chop $b ; +} EXPECT -Use of uninitialized value in scalar chop at - line 8. +Use of uninitialized value in scalar chop at - line 10. ######## # Check scope of pragma with eval -no warnings ; -eval ' +use warnings; +{ + no warnings ; + eval ' + 1 if $a EQ $b ; + '; print STDERR $@ ; 1 if $a EQ $b ; -'; print STDERR $@ ; -1 if $a EQ $b ; +} EXPECT ######## # Check scope of pragma with eval -no warnings ; -eval q[ - use warnings 'deprecated' ; +use warnings; +{ + no warnings ; + eval q[ + use warnings 'deprecated' ; + 1 if $a EQ $b ; + ]; print STDERR $@; 1 if $a EQ $b ; -]; print STDERR $@; -1 if $a EQ $b ; +} EXPECT Use of EQ is deprecated at (eval 1) line 3. ######## # Check scope of pragma with eval -use warnings 'deprecated' ; -eval ' +no warnings; +{ + use warnings 'deprecated' ; + eval ' + 1 if $a EQ $b ; + '; print STDERR $@; 1 if $a EQ $b ; -'; print STDERR $@; -1 if $a EQ $b ; +} EXPECT -Use of EQ is deprecated at - line 7. +Use of EQ is deprecated at - line 9. Use of EQ is deprecated at (eval 1) line 2. ######## # Check scope of pragma with eval -use warnings 'deprecated' ; -eval ' - no warnings ; +no warnings; +{ + use warnings 'deprecated' ; + eval ' + no warnings ; + 1 if $a EQ $b ; + '; print STDERR $@; 1 if $a EQ $b ; -'; print STDERR $@; -1 if $a EQ $b ; +} EXPECT -Use of EQ is deprecated at - line 8. +Use of EQ is deprecated at - line 10. ######## # Check the additive nature of the pragma diff --git a/contrib/perl5/t/pragma/warn/3both b/contrib/perl5/t/pragma/warn/3both index 132b99b80fba..335e1b26b7a5 100644 --- a/contrib/perl5/t/pragma/warn/3both +++ b/contrib/perl5/t/pragma/warn/3both @@ -195,3 +195,72 @@ my $b ; chop $b ; EXPECT Use of uninitialized value in scalar chop at - line 7. +######## + +# Check scope of pragma with eval +BEGIN { $^W = 1 } +{ + no warnings ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; +} +EXPECT + +######## + +# Check scope of pragma with eval +BEGIN { $^W = 1 } +use warnings; +{ + no warnings ; + eval q[ + use warnings 'uninitialized' ; + my $b ; chop $b ; + ]; print STDERR $@; + my $b ; chop $b ; +} +EXPECT +Use of uninitialized value in scalar chop at (eval 1) line 3. +######## + +# Check scope of pragma with eval +BEGIN { $^W = 0 } +{ + use warnings 'uninitialized' ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; +} +EXPECT +Use of uninitialized value in scalar chop at (eval 1) line 2. +Use of uninitialized value in scalar chop at - line 9. +######## + +# Check scope of pragma with eval +BEGIN { $^W = 0 } +{ + use warnings 'uninitialized' ; + eval ' + no warnings ; + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; +} +EXPECT +Use of uninitialized value in scalar chop at - line 10. +######## + +# Check scope of pragma with eval +BEGIN { $^W = 1 } +{ + no warnings ; + eval ' + 1 if $a EQ $b ; + '; print STDERR $@ ; + 1 if $a EQ $b ; +} +EXPECT + diff --git a/contrib/perl5/t/pragma/warn/4lint b/contrib/perl5/t/pragma/warn/4lint index db54f31c7b4c..b2fa75fbbd94 100644 --- a/contrib/perl5/t/pragma/warn/4lint +++ b/contrib/perl5/t/pragma/warn/4lint @@ -9,14 +9,14 @@ $a = 1 if $a EQ $b ; close STDIN ; print STDIN "abc" ; EXPECT Use of EQ is deprecated at - line 5. -print() on closed filehandle main::STDIN at - line 6. +print() on closed filehandle STDIN at - line 6. ######## -W # lint: check runtime $^W is zapped $^W = 0 ; close STDIN ; print STDIN "abc" ; EXPECT -print() on closed filehandle main::STDIN at - line 4. +print() on closed filehandle STDIN at - line 4. ######## -W # lint: check runtime $^W is zapped @@ -25,7 +25,7 @@ print() on closed filehandle main::STDIN at - line 4. close STDIN ; print STDIN "abc" ; } EXPECT -print() on closed filehandle main::STDIN at - line 5. +print() on closed filehandle STDIN at - line 5. ######## -W # lint: check "no warnings" is zapped @@ -35,7 +35,7 @@ $a = 1 if $a EQ $b ; close STDIN ; print STDIN "abc" ; EXPECT Use of EQ is deprecated at - line 5. -print() on closed filehandle main::STDIN at - line 6. +print() on closed filehandle STDIN at - line 6. ######## -W # lint: check "no warnings" is zapped @@ -44,7 +44,7 @@ print() on closed filehandle main::STDIN at - line 6. close STDIN ; print STDIN "abc" ; } EXPECT -print() on closed filehandle main::STDIN at - line 5. +print() on closed filehandle STDIN at - line 5. ######## -Ww # lint: check combination of -w and -W @@ -53,7 +53,7 @@ print() on closed filehandle main::STDIN at - line 5. close STDIN ; print STDIN "abc" ; } EXPECT -print() on closed filehandle main::STDIN at - line 5. +print() on closed filehandle STDIN at - line 5. ######## -W --FILE-- abc.pm @@ -110,3 +110,107 @@ my $a ; chop $a ; EXPECT Use of EQ is deprecated at ./abc line 3. Use of uninitialized value in scalar chop at - line 3. +######## +-W +# Check scope of pragma with eval +{ + no warnings ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; +} +EXPECT +Use of uninitialized value in scalar chop at (eval 1) line 2. +Use of uninitialized value in scalar chop at - line 8. +######## +-W +# Check scope of pragma with eval +use warnings; +{ + no warnings ; + eval q[ + use warnings 'uninitialized' ; + my $b ; chop $b ; + ]; print STDERR $@; + my $b ; chop $b ; +} +EXPECT +Use of uninitialized value in scalar chop at (eval 1) line 3. +Use of uninitialized value in scalar chop at - line 10. +######## +-W +# Check scope of pragma with eval +no warnings; +{ + use warnings 'uninitialized' ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; +} +EXPECT +Use of uninitialized value in scalar chop at (eval 1) line 2. +Use of uninitialized value in scalar chop at - line 9. +######## +-W +# Check scope of pragma with eval +no warnings; +{ + use warnings 'uninitialized' ; + eval ' + no warnings ; + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; +} +EXPECT +Use of uninitialized value in scalar chop at (eval 1) line 3. +Use of uninitialized value in scalar chop at - line 10. +######## +-W +# Check scope of pragma with eval +use warnings; +{ + my $a = "1"; my $b = "2"; + no warnings ; + eval q[ + use warnings 'deprecated' ; + 1 if $a EQ $b ; + ]; print STDERR $@; + 1 if $a EQ $b ; +} +EXPECT +Use of EQ is deprecated at - line 11. +Use of EQ is deprecated at (eval 1) line 3. +######## +-W +# Check scope of pragma with eval +no warnings; +{ + my $a = "1"; my $b = "2"; + use warnings 'deprecated' ; + eval ' + 1 if $a EQ $b ; + '; print STDERR $@; + 1 if $a EQ $b ; +} +EXPECT +Use of EQ is deprecated at - line 10. +Use of EQ is deprecated at (eval 1) line 2. +######## +-W +# Check scope of pragma with eval +no warnings; +{ + my $a = "1"; my $b = "2"; + use warnings 'deprecated' ; + eval ' + no warnings ; + 1 if $a EQ $b ; + '; print STDERR $@; + 1 if $a EQ $b ; +} +EXPECT +Use of EQ is deprecated at - line 11. +Use of EQ is deprecated at (eval 1) line 3. diff --git a/contrib/perl5/t/pragma/warn/5nolint b/contrib/perl5/t/pragma/warn/5nolint index 994190a85593..2459968003d7 100644 --- a/contrib/perl5/t/pragma/warn/5nolint +++ b/contrib/perl5/t/pragma/warn/5nolint @@ -94,3 +94,111 @@ $^W = 1 ; require "./abc"; my $a ; chop $a ; EXPECT +######## +-X +# Check scope of pragma with eval +use warnings; +{ + no warnings ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; +} +EXPECT + +######## +-X +# Check scope of pragma with eval +use warnings; +{ + no warnings ; + eval q[ + use warnings 'uninitialized' ; + my $b ; chop $b ; + ]; print STDERR $@; + my $b ; chop $b ; +} +EXPECT + +######## +-X +# Check scope of pragma with eval +no warnings; +{ + use warnings 'uninitialized' ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; +} +EXPECT + +######## +-X +# Check scope of pragma with eval +no warnings; +{ + use warnings 'uninitialized' ; + eval ' + no warnings ; + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; +} +EXPECT + +######## +-X +# Check scope of pragma with eval +use warnings; +{ + no warnings ; + eval ' + 1 if $a EQ $b ; + '; print STDERR $@ ; + 1 if $a EQ $b ; +} +EXPECT + +######## +-X +# Check scope of pragma with eval +use warnings; +{ + no warnings ; + eval q[ + use warnings 'deprecated' ; + 1 if $a EQ $b ; + ]; print STDERR $@; + 1 if $a EQ $b ; +} +EXPECT + +######## +-X +# Check scope of pragma with eval +no warnings; +{ + use warnings 'deprecated' ; + eval ' + 1 if $a EQ $b ; + '; print STDERR $@; + 1 if $a EQ $b ; +} +EXPECT + +######## +-X +# Check scope of pragma with eval +no warnings; +{ + use warnings 'deprecated' ; + eval ' + no warnings ; + 1 if $a EQ $b ; + '; print STDERR $@; + 1 if $a EQ $b ; +} +EXPECT + diff --git a/contrib/perl5/t/pragma/warn/6default b/contrib/perl5/t/pragma/warn/6default index dd3d1825f442..a8aafeeb2256 100644 --- a/contrib/perl5/t/pragma/warn/6default +++ b/contrib/perl5/t/pragma/warn/6default @@ -51,3 +51,71 @@ EXPECT Integer overflow in binary number at - line 3. Illegal binary digit '2' ignored at - line 3. Binary number > 0b11111111111111111111111111111111 non-portable at - line 3. +######## + +# Check scope of pragma with eval +use warnings; +{ + no warnings ; + eval ' + my $a = oct "0xfffffffffffffffffg" ; + '; print STDERR $@ ; + my $a = oct "0xfffffffffffffffffg" ; +} +EXPECT + +######## + +# Check scope of pragma with eval +use warnings; +{ + no warnings ; + eval q[ + use warnings ; + my $a = oct "0xfffffffffffffffffg" ; + ]; print STDERR $@; + my $a = oct "0xfffffffffffffffffg" ; +} +EXPECT +Integer overflow in hexadecimal number at (eval 1) line 3. +Illegal hexadecimal digit 'g' ignored at (eval 1) line 3. +Hexadecimal number > 0xffffffff non-portable at (eval 1) line 3. +######## + +# Check scope of pragma with eval +no warnings; +{ + use warnings ; + eval ' + my $a = oct "0xfffffffffffffffffg" ; + '; print STDERR $@ ; +} +EXPECT +Integer overflow in hexadecimal number at (eval 1) line 2. +Illegal hexadecimal digit 'g' ignored at (eval 1) line 2. +Hexadecimal number > 0xffffffff non-portable at (eval 1) line 2. +######## + +# Check scope of pragma with eval +no warnings; +{ + use warnings; + eval ' + no warnings ; + my $a = oct "0xfffffffffffffffffg" ; + '; print STDERR $@ ; +} +EXPECT + +######## + +# Check scope of pragma with eval +no warnings; +{ + use warnings 'deprecated' ; + eval ' + my $a = oct "0xfffffffffffffffffg" ; + '; print STDERR $@; +} +EXPECT + diff --git a/contrib/perl5/t/pragma/warn/7fatal b/contrib/perl5/t/pragma/warn/7fatal index 943bb06fb34d..ed585c2fedab 100644 --- a/contrib/perl5/t/pragma/warn/7fatal +++ b/contrib/perl5/t/pragma/warn/7fatal @@ -14,6 +14,18 @@ EXPECT Use of EQ is deprecated at - line 8. ######## +# Check compile time warning +use warnings FATAL => 'all' ; +{ + no warnings ; + 1 if $a EQ $b ; +} +1 if $a EQ $b ; +print STDERR "The End.\n" ; +EXPECT +Use of EQ is deprecated at - line 8. +######## + # Check runtime scope of pragma use warnings FATAL => 'uninitialized' ; { @@ -27,6 +39,18 @@ Use of uninitialized value in scalar chop at - line 8. ######## # Check runtime scope of pragma +use warnings FATAL => 'all' ; +{ + no warnings ; + my $b ; chop $b ; +} +my $b ; chop $b ; +print STDERR "The End.\n" ; +EXPECT +Use of uninitialized value in scalar chop at - line 8. +######## + +# Check runtime scope of pragma no warnings ; { use warnings FATAL => 'uninitialized' ; @@ -38,6 +62,18 @@ EXPECT Use of uninitialized value in scalar chop at - line 6. ######## +# Check runtime scope of pragma +no warnings ; +{ + use warnings FATAL => 'all' ; + $a = sub { my $b ; chop $b ; } +} +&$a ; +print STDERR "The End.\n" ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + --FILE-- abc 1 if $a EQ $b ; 1; @@ -240,3 +276,37 @@ eval ' print STDERR "The End.\n" ; EXPECT Use of EQ is deprecated at - line 8. +######## + +use warnings 'void' ; + +time ; + +{ + use warnings FATAL => qw(void) ; + length "abc" ; +} + +join "", 1,2,3 ; + +print "done\n" ; +EXPECT +Useless use of time in void context at - line 4. +Useless use of length in void context at - line 8. +######## + +use warnings ; + +time ; + +{ + use warnings FATAL => qw(void) ; + length "abc" ; +} + +join "", 1,2,3 ; + +print "done\n" ; +EXPECT +Useless use of time in void context at - line 4. +Useless use of length in void context at - line 8. diff --git a/contrib/perl5/t/pragma/warn/9enabled b/contrib/perl5/t/pragma/warn/9enabled index 7facf996f5fd..f5579b2dded9 100755 --- a/contrib/perl5/t/pragma/warn/9enabled +++ b/contrib/perl5/t/pragma/warn/9enabled @@ -332,7 +332,17 @@ print $@ ; EXPECT Usage: warnings::warn([category,] 'message') at - line 4 unknown warnings category 'fred' at - line 6 - require 0 called at - line 6 +######## + +# check warnings::warnif +use warnings ; +eval { warnings::warnif() } ; +print $@ ; +eval { warnings::warnif("fred", "joe") } ; +print $@ ; +EXPECT +Usage: warnings::warnif([category,] 'message') at - line 4 +unknown warnings category 'fred' at - line 6 ######## --FILE-- abc.pm @@ -373,6 +383,7 @@ eval { abc::check() ; } ; print "[[$@]]\n"; EXPECT hello at - line 3 + eval {...} called at - line 3 [[]] ######## @@ -388,6 +399,7 @@ eval { abc::check() ; } ; print "[[$@]]\n"; EXPECT [[hello at - line 3 + eval {...} called at - line 3 ]] ######## -W @@ -431,7 +443,37 @@ use warnings 'syntax' ; use abc ; abc::check() ; EXPECT -package 'abc' not registered for warnings at - line 3 +package 'abc' not registered for warnings at abc.pm line 4 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +sub check { + warnings::warn("fred") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +abc::check() ; +EXPECT +package 'abc' not registered for warnings at abc.pm line 4 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +sub check { + warnings::warnif("fred") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +abc::check() ; +EXPECT +package 'abc' not registered for warnings at abc.pm line 4 ######## --FILE-- abc.pm @@ -617,6 +659,7 @@ eval { abc::check() ; } ; print "[[$@]]\n"; EXPECT hello at - line 3 + eval {...} called at - line 3 [[]] ######## @@ -632,6 +675,7 @@ eval { abc::check() ; } ; print "[[$@]]\n"; EXPECT [[hello at - line 3 + eval {...} called at - line 3 ]] ######## -W @@ -723,6 +767,10 @@ sub check { print "ok1\n" if !warnings::enabled() ; print "ok2\n" if !warnings::enabled("io") ; print "ok3\n" if !warnings::enabled("all") ; + warnings::warnif("my message 1") ; + warnings::warnif('abc', "my message 2") ; + warnings::warnif('io', "my message 3") ; + warnings::warnif('all', "my message 4") ; } 1; --FILE-- @@ -817,3 +865,298 @@ abc all not enabled def self enabled def abc not enabled def all not enabled +######## +-w +--FILE-- abc.pm +package abc ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled() ; + print "ok2\n" if warnings::enabled("io") ; + print "ok3\n" if warnings::enabled("all") ; +} +1; +--FILE-- +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## +-w +--FILE-- abc.pm +package abc ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; +} +1; +--FILE-- +use abc ; +use warnings 'abc'; +no warnings ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; + warnings::warnif("my message 1") ; + warnings::warnif('abc', "my message 2") ; + warnings::warnif('io', "my message 3") ; + warnings::warnif('all', "my message 4") ; +} +1; +--FILE-- +use abc ; +use warnings 'abc'; +no warnings ; +BEGIN { $^W = 1 ; } +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; +} +1; +--FILE-- +use abc ; +use warnings 'abc'; +no warnings ; +$^W = 1 ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +$| = 1; +package abc ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; + print "ok4\n" if warnings::enabled("abc") ; + warnings::warn("my message 1") ; + warnings::warnif("my message 2") ; + warnings::warnif('abc', "my message 3") ; + warnings::warnif('io', "my message 4") ; + warnings::warnif('all', "my message 5") ; +} +sub in2 { no warnings ; check() } +sub in1 { no warnings ; in2() } +1; +--FILE-- +use abc ; +use warnings 'abc'; +abc::in1() ; +EXPECT +ok1 +ok2 +ok3 +ok4 +my message 1 at - line 3 +my message 2 at - line 3 +my message 3 at - line 3 +######## + +--FILE-- def.pm +package def ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; + print "ok4\n" if warnings::enabled("def") ; + warnings::warn("my message 1") ; + warnings::warnif("my message 2") ; + warnings::warnif('def', "my message 3") ; + warnings::warnif('io', "my message 4") ; + warnings::warnif('all', "my message 5") ; +} +sub in2 { no warnings ; check() } +sub in1 { no warnings ; in2() } +1; +--FILE-- abc.pm +$| = 1; +package abc ; +use def ; +use warnings 'def'; +sub in1 { def::in1() ; } +1; +--FILE-- +use abc ; +no warnings; +abc::in1() ; +EXPECT +ok1 +ok2 +ok3 +ok4 +my message 1 at abc.pm line 5 + abc::in1() called at - line 3 +my message 2 at abc.pm line 5 + abc::in1() called at - line 3 +my message 3 at abc.pm line 5 + abc::in1() called at - line 3 +######## + +--FILE-- def.pm +$| = 1; +package def ; +no warnings ; +use warnings::register ; +require Exporter; +@ISA = qw( Exporter ) ; +@EXPORT = qw( in1 ) ; +sub check { + print "ok1\n" if warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; + print "ok4\n" if warnings::enabled("abc") ; + print "ok5\n" if !warnings::enabled("def") ; + warnings::warn("my message 1") ; + warnings::warnif("my message 2") ; + warnings::warnif('abc', "my message 3") ; + warnings::warnif('def', "my message 4") ; + warnings::warnif('io', "my message 5") ; + warnings::warnif('all', "my message 6") ; +} +sub in2 { no warnings ; check() } +sub in1 { no warnings ; in2() } +1; +--FILE-- abc.pm +package abc ; +use warnings::register ; +use def ; +#@ISA = qw(def) ; +1; +--FILE-- +use abc ; +no warnings; +use warnings 'abc'; +abc::in1() ; +EXPECT +ok2 +ok3 +ok4 +ok5 +my message 1 at - line 4 +my message 3 at - line 4 +######## + +--FILE-- def.pm +package def ; +no warnings ; +use warnings::register ; + +sub new +{ + my $class = shift ; + bless [], $class ; +} + +sub check +{ + my $self = shift ; + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; + print "ok4\n" if warnings::enabled("abc") ; + print "ok5\n" if !warnings::enabled("def") ; + print "ok6\n" if warnings::enabled($self) ; + + warnings::warn("my message 1") ; + warnings::warn($self, "my message 2") ; + + warnings::warnif("my message 3") ; + warnings::warnif('abc', "my message 4") ; + warnings::warnif('def', "my message 5") ; + warnings::warnif('io', "my message 6") ; + warnings::warnif('all', "my message 7") ; + warnings::warnif($self, "my message 8") ; +} +sub in2 +{ + no warnings ; + my $self = shift ; + $self->check() ; +} +sub in1 +{ + no warnings ; + my $self = shift ; + $self->in2(); +} +1; +--FILE-- abc.pm +$| = 1; +package abc ; +use warnings::register ; +use def ; +@ISA = qw(def) ; +sub new +{ + my $class = shift ; + bless [], $class ; +} + +1; +--FILE-- +use abc ; +no warnings; +use warnings 'abc'; +$a = new abc ; +$a->in1() ; +print "**\n"; +$b = new def ; +$b->in1() ; +EXPECT +ok1 +ok2 +ok3 +ok4 +ok5 +ok6 +my message 1 at - line 5 +my message 2 at - line 5 +my message 4 at - line 5 +my message 8 at - line 5 +** +ok1 +ok2 +ok3 +ok4 +ok5 +my message 1 at - line 8 +my message 2 at - line 8 +my message 4 at - line 8 diff --git a/contrib/perl5/t/pragma/warn/doio b/contrib/perl5/t/pragma/warn/doio index bd409721d265..2a357e275575 100644 --- a/contrib/perl5/t/pragma/warn/doio +++ b/contrib/perl5/t/pragma/warn/doio @@ -12,22 +12,22 @@ warn(warn_nl, "open"); [Perl_do_open9] open(F, "true\ncd") - Close on unopened file <%s> [Perl_do_close] <<TODO + close() on unopened filehandle %s [Perl_do_close] $a = "fred";close("$a") - tell() on unopened file [Perl_do_tell] + tell() on closed filehandle [Perl_do_tell] $a = "fred";$a = tell($a) - seek() on unopened file [Perl_do_seek] + seek() on closed filehandle [Perl_do_seek] $a = "fred";$a = seek($a,1,1) - sysseek() on unopened file [Perl_do_sysseek] + sysseek() on closed filehandle [Perl_do_sysseek] $a = "fred";$a = seek($a,1,1) warn(warn_uninit); [Perl_do_print] print $a ; - Stat on unopened file <%s> [Perl_my_stat] + -x on closed filehandle %s [Perl_my_stat] close STDIN ; -x STDIN ; warn(warn_nl, "stat"); [Perl_my_stat] @@ -96,7 +96,7 @@ close "fred" ; no warnings 'unopened' ; close "joe" ; EXPECT -Close on unopened file <fred> at - line 3. +close() on unopened filehandle fred at - line 3. ######## # doio.c [Perl_do_tell Perl_do_seek Perl_do_sysseek Perl_my_stat] use warnings 'io' ; @@ -105,17 +105,35 @@ tell(STDIN); $a = seek(STDIN,1,1); $a = sysseek(STDIN,1,1); -x STDIN ; +stat(STDIN) ; +$a = "fred"; +tell($a); +seek($a,1,1); +sysseek($a,1,1); +-x $a; # ok +stat($a); # ok no warnings 'io' ; close STDIN ; tell(STDIN); $a = seek(STDIN,1,1); $a = sysseek(STDIN,1,1); -x STDIN ; +stat(STDIN) ; +$a = "fred"; +tell($a); +seek($a,1,1); +sysseek($a,1,1); +-x $a; +stat($a); EXPECT -tell() on unopened file at - line 4. -seek() on unopened file at - line 5. -sysseek() on unopened file at - line 6. -Stat on unopened file <STDIN> at - line 7. +tell() on closed filehandle STDIN at - line 4. +seek() on closed filehandle STDIN at - line 5. +sysseek() on closed filehandle STDIN at - line 6. +-x on closed filehandle STDIN at - line 7. +stat() on closed filehandle STDIN at - line 8. +tell() on unopened filehandle at - line 10. +seek() on unopened filehandle at - line 11. +sysseek() on unopened filehandle at - line 12. ######## # doio.c [Perl_do_print] use warnings 'uninitialized' ; @@ -188,4 +206,4 @@ my $a = eof STDOUT ; no warnings 'io' ; $a = eof STDOUT ; EXPECT -Filehandle main::STDOUT opened only for output at - line 3. +Filehandle STDOUT opened only for output at - line 3. diff --git a/contrib/perl5/t/pragma/warn/op b/contrib/perl5/t/pragma/warn/op index 1a79b4ad23c4..1f41a98d6244 100644 --- a/contrib/perl5/t/pragma/warn/op +++ b/contrib/perl5/t/pragma/warn/op @@ -150,6 +150,17 @@ EXPECT # op.c use warnings 'closure' ; sub x { + our $x; + sub y { + $x + } + } +EXPECT + +######## +# op.c +use warnings 'closure' ; +sub x { my $x; sub y { sub { $x } @@ -267,7 +278,7 @@ Useless use of hash element in void context at - line 29. Useless use of hash slice in void context at - line 30. Useless use of unpack in void context at - line 31. Useless use of pack in void context at - line 32. -Useless use of join in void context at - line 33. +Useless use of join or string in void context at - line 33. Useless use of list slice in void context at - line 34. Useless use of sort in void context at - line 37. Useless use of reverse in void context at - line 38. @@ -558,7 +569,7 @@ Useless use of a constant in void context at - line 3. Useless use of a constant in void context at - line 4. ######## # op.c -BEGIN{ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } # known scalar leak +# use warnings 'misc' ; my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; @a =~ /abc/ ; @@ -592,7 +603,6 @@ my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; EXPECT Applying pattern match (m//) to @array will act on scalar(@array) at - line 5. Applying substitution (s///) to @array will act on scalar(@array) at - line 6. -Can't modify private array in substitution (s///) at - line 6, near "s/a/b/ ;" Applying transliteration (tr///) to @array will act on scalar(@array) at - line 7. Applying pattern match (m//) to @array will act on scalar(@array) at - line 8. Applying substitution (s///) to @array will act on scalar(@array) at - line 9. @@ -603,6 +613,7 @@ Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 13 Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 14. Applying substitution (s///) to %hash will act on scalar(%hash) at - line 15. Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 16. +Can't modify private array in substitution (s///) at - line 6, near "s/a/b/ ;" BEGIN not safe after errors--compilation aborted at - line 18. ######## # op.c diff --git a/contrib/perl5/t/pragma/warn/perl b/contrib/perl5/t/pragma/warn/perl index 45807499d6ae..b4a00bac4171 100644 --- a/contrib/perl5/t/pragma/warn/perl +++ b/contrib/perl5/t/pragma/warn/perl @@ -54,4 +54,19 @@ Name "main::z" used only once: possible typo at - line 6. use warnings 'once' ; $x = 3 ; EXPECT +######## +# perl.c +{ use warnings 'once' ; $x = 3 ; } +$y = 3 ; +EXPECT +Name "main::x" used only once: possible typo at - line 3. +######## + +# perl.c +$z = 3 ; +BEGIN { $^W = 1 } +{ no warnings 'once' ; $x = 3 ; } +$y = 3 ; +EXPECT +Name "main::y" used only once: possible typo at - line 6. diff --git a/contrib/perl5/t/pragma/warn/pp_ctl b/contrib/perl5/t/pragma/warn/pp_ctl index 0deccd35e277..ac01f277b1fa 100644 --- a/contrib/perl5/t/pragma/warn/pp_ctl +++ b/contrib/perl5/t/pragma/warn/pp_ctl @@ -214,4 +214,17 @@ DESTROY { die "@{$_[0]} foo bar" } { bless ['A'], 'Foo' for 1..10 } { bless ['B'], 'Foo' for 1..10 } EXPECT - +######## +# pp_ctl.c +use warnings; +eval 'print $foo'; +EXPECT +Use of uninitialized value in print at (eval 1) line 1. +######## +# pp_ctl.c +use warnings; +{ + no warnings; + eval 'print $foo'; +} +EXPECT diff --git a/contrib/perl5/t/pragma/warn/pp_hot b/contrib/perl5/t/pragma/warn/pp_hot index 275905749eda..698255c064b0 100644 --- a/contrib/perl5/t/pragma/warn/pp_hot +++ b/contrib/perl5/t/pragma/warn/pp_hot @@ -1,6 +1,6 @@ pp_hot.c - Filehandle %s never opened [pp_print] + print() on unopened filehandle abc [pp_print] $f = $a = "abc" ; print $f $a Filehandle %s opened only for input [pp_print] @@ -33,6 +33,9 @@ readline() on closed filehandle %s [Perl_do_readline] close STDIN ; $a = <STDIN>; + readline() on closed filehandle %s [Perl_do_readline] + readline(NONESUCH); + glob failed (child exited with status %d%s) [Perl_do_readline] <<TODO Deep recursion on subroutine \"%s\" [Perl_sub_crush_depth] @@ -52,7 +55,7 @@ print $f $a; no warnings 'unopened' ; print $f $a; EXPECT -Filehandle main::abc never opened at - line 4. +print() on unopened filehandle abc at - line 4. ######## # pp_hot.c [pp_print] use warnings 'io' ; @@ -71,12 +74,12 @@ print getc(FOO); no warnings 'io' ; print STDIN "anc"; EXPECT -Filehandle main::STDIN opened only for input at - line 3. -Filehandle main::STDOUT opened only for output at - line 4. -Filehandle main::STDERR opened only for output at - line 5. -Filehandle main::FOO opened only for output at - line 6. -Filehandle main::STDERR opened only for output at - line 7. -Filehandle main::FOO opened only for output at - line 8. +Filehandle STDIN opened only for input at - line 3. +Filehandle STDOUT opened only for output at - line 4. +Filehandle STDERR opened only for output at - line 5. +Filehandle FOO opened only for output at - line 6. +Filehandle STDERR opened only for output at - line 7. +Filehandle FOO opened only for output at - line 8. ######## # pp_hot.c [pp_print] use warnings 'closed' ; @@ -90,9 +93,9 @@ print STDIN "anc"; opendir STDIN, "."; print STDIN "anc"; EXPECT -print() on closed filehandle main::STDIN at - line 4. -print() on closed filehandle main::STDIN at - line 6. - (Are you trying to call print() on dirhandle main::STDIN?) +print() on closed filehandle STDIN at - line 4. +print() on closed filehandle STDIN at - line 6. + (Are you trying to call print() on dirhandle STDIN?) ######## # pp_hot.c [pp_rv2av] use warnings 'uninitialized' ; @@ -137,9 +140,9 @@ no warnings 'closed' ; opendir STDIN, "." ; $a = <STDIN> ; $a = <STDIN> ; EXPECT -readline() on closed filehandle main::STDIN at - line 3. -readline() on closed filehandle main::STDIN at - line 4. - (Are you trying to call readline() on dirhandle main::STDIN?) +readline() on closed filehandle STDIN at - line 3. +readline() on closed filehandle STDIN at - line 4. + (Are you trying to call readline() on dirhandle STDIN?) ######## # pp_hot.c [Perl_do_readline] use warnings 'io' ; @@ -148,9 +151,10 @@ open (FH, ">./xcv") ; my $a = <FH> ; no warnings 'io' ; $a = <FH> ; +close (FH) ; unlink $file ; EXPECT -Filehandle main::FH opened only for output at - line 5. +Filehandle FH opened only for output at - line 5. ######## # pp_hot.c [Perl_sub_crush_depth] use warnings 'recursion' ; diff --git a/contrib/perl5/t/pragma/warn/pp_sys b/contrib/perl5/t/pragma/warn/pp_sys index 7c38727e28eb..68518e29f5cd 100644 --- a/contrib/perl5/t/pragma/warn/pp_sys +++ b/contrib/perl5/t/pragma/warn/pp_sys @@ -16,7 +16,7 @@ page overflow [pp_leavewrite] - Filehandle %s never opened [pp_prtf] + printf() on unopened filehandle abc [pp_prtf] $a = "abc"; printf $a "fred" Filehandle %s opened only for input [pp_prtf] @@ -69,13 +69,16 @@ getpeername STDIN; flock() on closed socket %s [pp_flock] + flock() on closed socket [pp_flock] close STDIN; flock STDIN, 8; + flock $a, 8; warn(warn_nl, "stat"); [pp_stat] - Test on unopened file <%s> - close STDIN ; -T STDIN ; + -T on closed filehandle %s + stat() on closed filehandle %s + close STDIN ; -T STDIN ; stat(STDIN) ; warn(warn_nl, "open"); [pp_fttext] -T "abc\ndef" ; @@ -107,7 +110,7 @@ write STDIN; no warnings 'io' ; write STDIN; EXPECT -Filehandle main::STDIN opened only for input at - line 5. +Filehandle STDIN opened only for input at - line 5. ######## # pp_sys.c [pp_leavewrite] use warnings 'closed' ; @@ -123,9 +126,9 @@ write STDIN; opendir STDIN, "."; write STDIN; EXPECT -write() on closed filehandle main::STDIN at - line 6. -write() on closed filehandle main::STDIN at - line 8. - (Are you trying to call write() on dirhandle main::STDIN?) +write() on closed filehandle STDIN at - line 6. +write() on closed filehandle STDIN at - line 8. + (Are you trying to call write() on dirhandle STDIN?) ######## # pp_sys.c [pp_leavewrite] use warnings 'io' ; @@ -152,7 +155,7 @@ printf $a "fred"; no warnings 'unopened' ; printf $a "fred"; EXPECT -Filehandle main::abc never opened at - line 4. +printf() on unopened filehandle abc at - line 4. ######## # pp_sys.c [pp_prtf] use warnings 'closed' ; @@ -166,9 +169,9 @@ printf STDIN "fred"; opendir STDIN, "."; printf STDIN "fred"; EXPECT -printf() on closed filehandle main::STDIN at - line 4. -printf() on closed filehandle main::STDIN at - line 6. - (Are you trying to call printf() on dirhandle main::STDIN?) +printf() on closed filehandle STDIN at - line 4. +printf() on closed filehandle STDIN at - line 6. + (Are you trying to call printf() on dirhandle STDIN?) ######## # pp_sys.c [pp_prtf] use warnings 'io' ; @@ -176,7 +179,7 @@ printf STDIN "fred"; no warnings 'io' ; printf STDIN "fred"; EXPECT -Filehandle main::STDIN opened only for input at - line 3. +Filehandle STDIN opened only for input at - line 3. ######## # pp_sys.c [pp_send] use warnings 'closed' ; @@ -190,14 +193,16 @@ syswrite STDIN, "fred", 1; opendir STDIN, "."; syswrite STDIN, "fred", 1; EXPECT -syswrite() on closed filehandle main::STDIN at - line 4. -syswrite() on closed filehandle main::STDIN at - line 6. - (Are you trying to call syswrite() on dirhandle main::STDIN?) +syswrite() on closed filehandle STDIN at - line 4. +syswrite() on closed filehandle STDIN at - line 6. + (Are you trying to call syswrite() on dirhandle STDIN?) ######## # pp_sys.c [pp_flock] use Config; BEGIN { - if ( $^O eq 'VMS' and ! $Config{d_flock}) { + if ( !$Config{d_flock} && + !$Config{d_fcntl_can_lock} && + !$Config{d_lockf} ) { print <<EOM ; SKIPPED # flock not present @@ -205,19 +210,25 @@ EOM exit ; } } -use warnings 'closed' ; +use warnings qw(unopened closed); close STDIN; flock STDIN, 8; opendir STDIN, "."; flock STDIN, 8; -no warnings 'closed' ; +flock FOO, 8; +flock $a, 8; +no warnings qw(unopened closed); flock STDIN, 8; opendir STDIN, "."; flock STDIN, 8; +flock FOO, 8; +flock $a, 8; EXPECT -flock() on closed filehandle main::STDIN at - line 14. -flock() on closed filehandle main::STDIN at - line 16. - (Are you trying to call flock() on dirhandle main::STDIN?) +flock() on closed filehandle STDIN at - line 16. +flock() on closed filehandle STDIN at - line 18. + (Are you trying to call flock() on dirhandle STDIN?) +flock() on unopened filehandle FOO at - line 19. +flock() on unopened filehandle at - line 20. ######## # pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername] use warnings 'io' ; @@ -285,36 +296,36 @@ getsockopt STDIN, 1,2; getsockname STDIN; getpeername STDIN; EXPECT -send() on closed socket main::STDIN at - line 22. -bind() on closed socket main::STDIN at - line 23. -connect() on closed socket main::STDIN at - line 24. -listen() on closed socket main::STDIN at - line 25. -accept() on closed socket main::STDIN at - line 26. -shutdown() on closed socket main::STDIN at - line 27. -setsockopt() on closed socket main::STDIN at - line 28. -getsockopt() on closed socket main::STDIN at - line 29. -getsockname() on closed socket main::STDIN at - line 30. -getpeername() on closed socket main::STDIN at - line 31. -send() on closed socket main::STDIN at - line 33. - (Are you trying to call send() on dirhandle main::STDIN?) -bind() on closed socket main::STDIN at - line 34. - (Are you trying to call bind() on dirhandle main::STDIN?) -connect() on closed socket main::STDIN at - line 35. - (Are you trying to call connect() on dirhandle main::STDIN?) -listen() on closed socket main::STDIN at - line 36. - (Are you trying to call listen() on dirhandle main::STDIN?) -accept() on closed socket main::STDIN at - line 37. - (Are you trying to call accept() on dirhandle main::STDIN?) -shutdown() on closed socket main::STDIN at - line 38. - (Are you trying to call shutdown() on dirhandle main::STDIN?) -setsockopt() on closed socket main::STDIN at - line 39. - (Are you trying to call setsockopt() on dirhandle main::STDIN?) -getsockopt() on closed socket main::STDIN at - line 40. - (Are you trying to call getsockopt() on dirhandle main::STDIN?) -getsockname() on closed socket main::STDIN at - line 41. - (Are you trying to call getsockname() on dirhandle main::STDIN?) -getpeername() on closed socket main::STDIN at - line 42. - (Are you trying to call getpeername() on dirhandle main::STDIN?) +send() on closed socket STDIN at - line 22. +bind() on closed socket STDIN at - line 23. +connect() on closed socket STDIN at - line 24. +listen() on closed socket STDIN at - line 25. +accept() on closed socket STDIN at - line 26. +shutdown() on closed socket STDIN at - line 27. +setsockopt() on closed socket STDIN at - line 28. +getsockopt() on closed socket STDIN at - line 29. +getsockname() on closed socket STDIN at - line 30. +getpeername() on closed socket STDIN at - line 31. +send() on closed socket STDIN at - line 33. + (Are you trying to call send() on dirhandle STDIN?) +bind() on closed socket STDIN at - line 34. + (Are you trying to call bind() on dirhandle STDIN?) +connect() on closed socket STDIN at - line 35. + (Are you trying to call connect() on dirhandle STDIN?) +listen() on closed socket STDIN at - line 36. + (Are you trying to call listen() on dirhandle STDIN?) +accept() on closed socket STDIN at - line 37. + (Are you trying to call accept() on dirhandle STDIN?) +shutdown() on closed socket STDIN at - line 38. + (Are you trying to call shutdown() on dirhandle STDIN?) +setsockopt() on closed socket STDIN at - line 39. + (Are you trying to call setsockopt() on dirhandle STDIN?) +getsockopt() on closed socket STDIN at - line 40. + (Are you trying to call getsockopt() on dirhandle STDIN?) +getsockname() on closed socket STDIN at - line 41. + (Are you trying to call getsockname() on dirhandle STDIN?) +getpeername() on closed socket STDIN at - line 42. + (Are you trying to call getpeername() on dirhandle STDIN?) ######## # pp_sys.c [pp_stat] use warnings 'newline' ; @@ -325,13 +336,22 @@ EXPECT Unsuccessful stat on filename containing newline at - line 3. ######## # pp_sys.c [pp_fttext] -use warnings 'unopened' ; +use warnings qw(unopened closed) ; close STDIN ; -T STDIN ; -no warnings 'unopened' ; +stat(STDIN) ; +-T HOCUS; +stat(POCUS); +no warnings qw(unopened closed) ; -T STDIN ; +stat(STDIN); +-T HOCUS; +stat(POCUS); EXPECT -Test on unopened file <STDIN> at - line 4. +-T on closed filehandle STDIN at - line 4. +stat() on closed filehandle STDIN at - line 5. +-T on unopened filehandle HOCUS at - line 6. +stat() on unopened filehandle POCUS at - line 7. ######## # pp_sys.c [pp_fttext] use warnings 'newline' ; @@ -343,6 +363,13 @@ Unsuccessful open on filename containing newline at - line 3. ######## # pp_sys.c [pp_sysread] use warnings 'io' ; +if ($^O eq 'dos') { + print <<EOM ; +SKIPPED +# skipped on dos +EOM + exit ; +} my $file = "./xcv" ; open(F, ">$file") ; my $a = sysread(F, $a,10) ; @@ -351,4 +378,4 @@ my $a = sysread(F, $a,10) ; close F ; unlink $file ; EXPECT -Filehandle main::F opened only for output at - line 5. +Filehandle F opened only for output at - line 12. diff --git a/contrib/perl5/t/pragma/warn/regcomp b/contrib/perl5/t/pragma/warn/regcomp index 5d0c291ea042..8b86b5082fba 100644 --- a/contrib/perl5/t/pragma/warn/regcomp +++ b/contrib/perl5/t/pragma/warn/regcomp @@ -11,10 +11,6 @@ Character class [:%.*s:] unknown [S_regpposixcc] - Character class syntax [. .] is reserved for future extensions [S_regpposixcc] - - Character class syntax [= =] is reserved for future extensions [S_checkposixcc] - Character class syntax [%c %c] belongs inside character classes [S_checkposixcc] /%.127s/: false [] range \"%*.*s\" in regexp [S_regclass] @@ -33,7 +29,7 @@ $a =~ /(?=a)*/ ; no warnings 'regexp' ; $a =~ /(?=a)*/ ; EXPECT -(?=a)* matches null string many times at - line 4. +(?=a)* matches null string many times before HERE mark in regex m/(?=a)* << HERE / at - line 4. ######## # regcomp.c [S_study_chunk] use warnings 'regexp' ; @@ -42,7 +38,7 @@ $_ = "" ; no warnings 'regexp' ; /(?=a)?/; EXPECT -Strange *+?{} on zero-length expression at - line 4. +Quantifier unexpected on zero-length expression before HERE mark in regex m/(?=a)? << HERE / at - line 4. ######## # regcomp.c [S_regatom] $x = '\m' ; @@ -51,39 +47,44 @@ $a =~ /a$x/ ; no warnings 'regexp' ; $a =~ /a$x/ ; EXPECT -/a\m/: Unrecognized escape \m passed through at - line 4. +Unrecognized escape \m passed through before HERE mark in regex m/a\m << HERE / at - line 4. ######## # regcomp.c [S_regpposixcc S_checkposixcc] -BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3 } +# use warnings 'regexp' ; $_ = "" ; /[:alpha:]/; -/[.bar.]/; -/[=zog=]/; -/[[:alpha:]]/; -/[[.foo.]]/; -/[[=bar=]]/; /[:zog:]/; /[[:zog:]]/; no warnings 'regexp' ; /[:alpha:]/; -/[.foo.]/; -/[=bar=]/; -/[[:alpha:]]/; -/[[.foo.]]/; -/[[=bar=]]/; -/[[:zog:]]/; /[:zog:]/; +/[[:zog:]]/; EXPECT -Character class syntax [: :] belongs inside character classes at - line 5. -Character class syntax [. .] belongs inside character classes at - line 6. -Character class syntax [. .] is reserved for future extensions at - line 6. -Character class syntax [= =] belongs inside character classes at - line 7. -Character class syntax [= =] is reserved for future extensions at - line 7. -Character class syntax [. .] is reserved for future extensions at - line 9. -Character class syntax [= =] is reserved for future extensions at - line 10. -Character class syntax [: :] belongs inside character classes at - line 11. -Character class [:zog:] unknown at - line 12. +POSIX syntax [: :] belongs inside character classes before HERE mark in regex m/[:alpha:] << HERE / at - line 5. +POSIX syntax [: :] belongs inside character classes before HERE mark in regex m/[:zog:] << HERE / at - line 6. +POSIX class [:zog:] unknown before HERE mark in regex m/[[:zog:] << HERE ]/ +######## +# regcomp.c [S_checkposixcc] +# +use warnings 'regexp' ; +$_ = "" ; +/[.zog.]/; +no warnings 'regexp' ; +/[.zog.]/; +EXPECT +POSIX syntax [. .] belongs inside character classes before HERE mark in regex m/[.zog.] << HERE / at - line 5. +POSIX syntax [. .] is reserved for future extensions before HERE mark in regex m/[.zog.] << HERE / +######## +# regcomp.c [S_checkposixcc] +# +use warnings 'regexp' ; +$_ = "" ; +/[[.zog.]]/; +no warnings 'regexp' ; +/[[.zog.]]/; +EXPECT +POSIX syntax [. .] is reserved for future extensions before HERE mark in regex m/[[.zog.] << HERE ]/ ######## # regcomp.c [S_regclass] $_ = ""; @@ -108,14 +109,14 @@ no warnings 'regexp' ; /[[:alpha:]-[:digit:]]/; /[[:digit:]-[:alpha:]]/; EXPECT -/[a-\d]/: false [] range "a-\d" in regexp at - line 5. -/[\d-b]/: false [] range "\d-" in regexp at - line 6. -/[\s-\d]/: false [] range "\s-" in regexp at - line 7. -/[\d-\s]/: false [] range "\d-" in regexp at - line 8. -/[a-[:digit:]]/: false [] range "a-[:digit:]" in regexp at - line 9. -/[[:digit:]-b]/: false [] range "[:digit:]-" in regexp at - line 10. -/[[:alpha:]-[:digit:]]/: false [] range "[:alpha:]-" in regexp at - line 11. -/[[:digit:]-[:alpha:]]/: false [] range "[:digit:]-" in regexp at - line 12. +False [] range "a-\d" before HERE mark in regex m/[a-\d << HERE ]/ at - line 5. +False [] range "\d-" before HERE mark in regex m/[\d- << HERE b]/ at - line 6. +False [] range "\s-" before HERE mark in regex m/[\s- << HERE \d]/ at - line 7. +False [] range "\d-" before HERE mark in regex m/[\d- << HERE \s]/ at - line 8. +False [] range "a-[:digit:]" before HERE mark in regex m/[a-[:digit:] << HERE ]/ at - line 9. +False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE b]/ at - line 10. +False [] range "[:alpha:]-" before HERE mark in regex m/[[:alpha:]- << HERE [:digit:]]/ at - line 11. +False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE [:alpha:]]/ at - line 12. ######## # regcomp.c [S_regclassutf8] BEGIN { @@ -147,14 +148,14 @@ no warnings 'regexp' ; /[[:alpha:]-[:digit:]]/; /[[:digit:]-[:alpha:]]/; EXPECT -/[a-\d]/: false [] range "a-\d" in regexp at - line 12. -/[\d-b]/: false [] range "\d-" in regexp at - line 13. -/[\s-\d]/: false [] range "\s-" in regexp at - line 14. -/[\d-\s]/: false [] range "\d-" in regexp at - line 15. -/[a-[:digit:]]/: false [] range "a-[:digit:]" in regexp at - line 16. -/[[:digit:]-b]/: false [] range "[:digit:]-" in regexp at - line 17. -/[[:alpha:]-[:digit:]]/: false [] range "[:alpha:]-" in regexp at - line 18. -/[[:digit:]-[:alpha:]]/: false [] range "[:digit:]-" in regexp at - line 19. +False [] range "a-\d" before HERE mark in regex m/[a-\d << HERE ]/ at - line 12. +False [] range "\d-" before HERE mark in regex m/[\d- << HERE b]/ at - line 13. +False [] range "\s-" before HERE mark in regex m/[\s- << HERE \d]/ at - line 14. +False [] range "\d-" before HERE mark in regex m/[\d- << HERE \s]/ at - line 15. +False [] range "a-[:digit:]" before HERE mark in regex m/[a-[:digit:] << HERE ]/ at - line 16. +False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE b]/ at - line 17. +False [] range "[:alpha:]-" before HERE mark in regex m/[[:alpha:]- << HERE [:digit:]]/ at - line 18. +False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE [:alpha:]]/ at - line 19. ######## # regcomp.c [S_regclass S_regclassutf8] use warnings 'regexp' ; @@ -162,4 +163,5 @@ $a =~ /[a\zb]/ ; no warnings 'regexp' ; $a =~ /[a\zb]/ ; EXPECT -/[a\zb]/: Unrecognized escape \z in character class passed through at - line 3. +Unrecognized escape \z in character class passed through before HERE mark in regex m/[a\z << HERE b]/ at - line 3. + diff --git a/contrib/perl5/t/pragma/warn/sv b/contrib/perl5/t/pragma/warn/sv index 758137f2e8d7..2409589a8f29 100644 --- a/contrib/perl5/t/pragma/warn/sv +++ b/contrib/perl5/t/pragma/warn/sv @@ -178,7 +178,7 @@ no warnings 'uninitialized' ; $C = "" ; $C .= $A ; EXPECT -Use of uninitialized value in concatenation (.) at - line 10. +Use of uninitialized value in concatenation (.) or string at - line 10. ######## # sv.c use warnings 'numeric' ; diff --git a/contrib/perl5/t/pragma/warn/toke b/contrib/perl5/t/pragma/warn/toke index cfdea78d3c38..fa7132960cf3 100644 --- a/contrib/perl5/t/pragma/warn/toke +++ b/contrib/perl5/t/pragma/warn/toke @@ -198,10 +198,6 @@ EXPECT Semicolon seems to be missing at - line 3. ######## # toke.c -BEGIN { - # Scalars leaked: due to syntax errors - $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; -} use warnings 'syntax' ; my $a =+ 2 ; $a =- 2 ; @@ -214,25 +210,21 @@ $a =| 2 ; $a =< 2 ; $a =/ 2 ; EXPECT -Reversed += operator at - line 7. -Reversed -= operator at - line 8. -Reversed *= operator at - line 9. -Reversed %= operator at - line 10. -Reversed &= operator at - line 11. -Reversed .= operator at - line 12. -syntax error at - line 12, near "=." -Reversed ^= operator at - line 13. -syntax error at - line 13, near "=^" -Reversed |= operator at - line 14. -syntax error at - line 14, near "=|" -Reversed <= operator at - line 15. -Unterminated <> operator at - line 15. -######## -# toke.c -BEGIN { - # Scalars leaked: due to syntax errors - $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; -} +Reversed += operator at - line 3. +Reversed -= operator at - line 4. +Reversed *= operator at - line 5. +Reversed %= operator at - line 6. +Reversed &= operator at - line 7. +Reversed .= operator at - line 8. +Reversed ^= operator at - line 9. +Reversed |= operator at - line 10. +Reversed <= operator at - line 11. +syntax error at - line 8, near "=." +syntax error at - line 9, near "=^" +syntax error at - line 10, near "=|" +Unterminated <> operator at - line 11. +######## +# toke.c no warnings 'syntax' ; my $a =+ 2 ; $a =- 2 ; @@ -245,10 +237,10 @@ $a =| 2 ; $a =< 2 ; $a =/ 2 ; EXPECT -syntax error at - line 12, near "=." -syntax error at - line 13, near "=^" -syntax error at - line 14, near "=|" -Unterminated <> operator at - line 15. +syntax error at - line 8, near "=." +syntax error at - line 9, near "=^" +syntax error at - line 10, near "=|" +Unterminated <> operator at - line 11. ######## # toke.c use warnings 'syntax' ; @@ -290,6 +282,9 @@ Can't use \1 to mean $1 in expression at - line 4. # toke.c use warnings 'reserved' ; $a = abc; +$a = { def + +=> 1 }; no warnings 'reserved' ; $a = abc; EXPECT @@ -434,13 +429,14 @@ Ambiguous call resolved as CORE::time(), qualify as such or use & at - line 4. # toke.c use warnings ; eval <<'EOE'; +# line 30 "foo" +warn "yelp"; { -#line 30 "foo" $_ = " \x{123} " ; } EOE EXPECT - +yelp at foo line 30. ######## # toke.c my $a = rand + 4 ; @@ -581,3 +577,11 @@ EXPECT Integer overflow in binary number at - line 5. Integer overflow in hexadecimal number at - line 8. Integer overflow in octal number at - line 11. +######## +# toke.c +use warnings 'ambiguous'; +"@mjd_previously_unused_array"; +no warnings 'ambiguous'; +"@mjd_previously_unused_array"; +EXPECT +Possible unintended interpolation of @mjd_previously_unused_array in string at - line 3. diff --git a/contrib/perl5/t/pragma/warn/utf8 b/contrib/perl5/t/pragma/warn/utf8 index 6a2fe5446c30..9a7dbafdee84 100644 --- a/contrib/perl5/t/pragma/warn/utf8 +++ b/contrib/perl5/t/pragma/warn/utf8 @@ -15,6 +15,12 @@ __END__ # utf8.c [utf8_to_uv] -W +BEGIN { + if (ord('A') == 193) { + print "SKIPPED\n# ebcdic platforms do not generate Malformed UTF-8 warnings."; + exit 0; + } +} use utf8 ; my $a = "snøstorm" ; { @@ -24,6 +30,6 @@ my $a = "snøstorm" ; my $a = "snøstorm"; } EXPECT -Malformed UTF-8 character at - line 3. -Malformed UTF-8 character at - line 8. +Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 9. +Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 14. ######## diff --git a/contrib/perl5/t/pragma/warnings.t b/contrib/perl5/t/pragma/warnings.t index 71fb0df972e1..66b4ff91607e 100755 --- a/contrib/perl5/t/pragma/warnings.t +++ b/contrib/perl5/t/pragma/warnings.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; $ENV{PERL5LIB} = '../lib'; require Config; import Config; } @@ -26,9 +26,7 @@ else foreach (@w_files) { - next if /\.orig$/ ; - - next if /(~|\.orig)$/; + next if /(~|\.orig|,v)$/; open F, "<$_" or die "Cannot open $_: $!\n" ; while (<F>) { diff --git a/contrib/perl5/taint.c b/contrib/perl5/taint.c index 0f0ce98e7ace..7a8baac7b0ff 100644 --- a/contrib/perl5/taint.c +++ b/contrib/perl5/taint.c @@ -11,7 +11,6 @@ void Perl_taint_proper(pTHX_ const char *f, const char *s) { - dTHR; /* just for taint */ char *ug; #ifdef HAS_SETEUID @@ -64,12 +63,10 @@ Perl_taint_env(pTHX) if (!svp || *svp == &PL_sv_undef) break; if (SvTAINTED(*svp)) { - dTHR; TAINT; taint_proper("Insecure %s%s", "$ENV{DCL$PATH}"); } if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) { - dTHR; TAINT; taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}"); } @@ -81,12 +78,10 @@ Perl_taint_env(pTHX) svp = hv_fetch(GvHVn(PL_envgv),"PATH",4,FALSE); if (svp && *svp) { if (SvTAINTED(*svp)) { - dTHR; TAINT; taint_proper("Insecure %s%s", "$ENV{PATH}"); } if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) { - dTHR; TAINT; taint_proper("Insecure directory in %s%s", "$ENV{PATH}"); } @@ -96,7 +91,6 @@ Perl_taint_env(pTHX) /* tainted $TERM is okay if it contains no metachars */ svp = hv_fetch(GvHVn(PL_envgv),"TERM",4,FALSE); if (svp && *svp && SvTAINTED(*svp)) { - dTHR; /* just for taint */ STRLEN n_a; bool was_tainted = PL_tainted; char *t = SvPV(*svp, n_a); @@ -116,7 +110,6 @@ Perl_taint_env(pTHX) for (e = misc_env; *e; e++) { svp = hv_fetch(GvHVn(PL_envgv), *e, strlen(*e), FALSE); if (svp && *svp != &PL_sv_undef && SvTAINTED(*svp)) { - dTHR; /* just for taint */ TAINT; taint_proper("Insecure $ENV{%s}%s", *e); } diff --git a/contrib/perl5/thrdvar.h b/contrib/perl5/thrdvar.h index e4cfacc06caf..042912dd355a 100644 --- a/contrib/perl5/thrdvar.h +++ b/contrib/perl5/thrdvar.h @@ -82,6 +82,23 @@ PERLVAR(Ttimesbuf, struct tms) PERLVAR(Ttainted, bool) /* using variables controlled by $< */ PERLVAR(Tcurpm, PMOP *) /* what to do \ interps in REs from */ PERLVAR(Tnrs, SV *) + +/* +=for apidoc mn|SV*|PL_rs + +The input record separator - C<$/> in Perl space. + +=for apidoc mn|GV*|PL_last_in_gv + +The GV which was last used for a filehandle input operation. (C<< <FH> >>) + +=for apidoc mn|SV*|PL_ofs_sv + +The output field separator - C<$,> in Perl space. + +=cut +*/ + PERLVAR(Trs, SV *) /* input record separator $/ */ PERLVAR(Tlast_in_gv, GV *) /* GV used in last <FH> */ PERLVAR(Tofs, char *) /* output field separator $, */ diff --git a/contrib/perl5/thread.h b/contrib/perl5/thread.h index 0ea9e74544bf..1b12978dd8c9 100644 --- a/contrib/perl5/thread.h +++ b/contrib/perl5/thread.h @@ -32,13 +32,24 @@ # define pthread_mutexattr_init(a) pthread_mutexattr_create(a) # define pthread_mutexattr_settype(a,t) pthread_mutexattr_setkind_np(a,t) # endif +# if defined(__hpux) && defined(__ux_version) && __ux_version <= 1020 +# define pthread_attr_init(a) pthread_attr_create(a) + /* XXX pthread_setdetach_np() missing in DCE threads on HP-UX 10.20 */ +# define PTHREAD_ATTR_SETDETACHSTATE(a,s) (0) +# define PTHREAD_CREATE(t,a,s,d) pthread_create(t,a,s,d) +# define pthread_key_create(k,d) pthread_keycreate(k,(pthread_destructor_t)(d)) +# define pthread_mutexattr_init(a) pthread_mutexattr_create(a) +# define pthread_mutexattr_settype(a,t) pthread_mutexattr_setkind_np(a,t) +# endif # if defined(DJGPP) || defined(__OPEN_VM) # define PTHREAD_ATTR_SETDETACHSTATE(a,s) pthread_attr_setdetachstate(a,&(s)) # define YIELD pthread_yield(NULL) # endif # endif +# if !defined(__hpux) || !defined(__ux_version) || __ux_version > 1020 # define pthread_mutexattr_default NULL # define pthread_condattr_default NULL +# endif #endif #ifndef PTHREAD_CREATE @@ -117,6 +128,7 @@ #define INIT_THREADS cthread_init() #define YIELD cthread_yield() #define ALLOC_THREAD_KEY NOOP +#define FREE_THREAD_KEY NOOP #define SET_THREAD_SELF(thr) (thr->self = cthread_self()) #endif /* I_MACH_CTHREADS */ @@ -251,12 +263,19 @@ # define ALLOC_THREAD_KEY \ STMT_START { \ if (pthread_key_create(&PL_thr_key, 0)) { \ - fprintf(stderr, "panic: pthread_key_create"); \ + PerlIO_printf(PerlIO_stderr(), "panic: pthread_key_create"); \ exit(1); \ } \ } STMT_END #endif +#ifndef FREE_THREAD_KEY +# define FREE_THREAD_KEY \ + STMT_START { \ + pthread_key_delete(PL_thr_key); \ + } STMT_END +#endif + #ifndef THREAD_RET_TYPE # define THREAD_RET_TYPE void * # define THREAD_RET_CAST(p) ((void *)(p)) @@ -280,7 +299,10 @@ # define UNLOCK_STRTAB_MUTEX MUTEX_UNLOCK(&PL_strtab_mutex) # define LOCK_CRED_MUTEX MUTEX_LOCK(&PL_cred_mutex) # define UNLOCK_CRED_MUTEX MUTEX_UNLOCK(&PL_cred_mutex) - +# define LOCK_FDPID_MUTEX MUTEX_LOCK(&PL_fdpid_mutex) +# define UNLOCK_FDPID_MUTEX MUTEX_UNLOCK(&PL_fdpid_mutex) +# define LOCK_SV_LOCK_MUTEX MUTEX_LOCK(&PL_sv_lock_mutex) +# define UNLOCK_SV_LOCK_MUTEX MUTEX_UNLOCK(&PL_sv_lock_mutex) /* Values and macros for thr->flags */ #define THRf_STATE_MASK 7 @@ -376,6 +398,22 @@ typedef struct condpair { # define UNLOCK_CRED_MUTEX #endif +#ifndef LOCK_FDPID_MUTEX +# define LOCK_FDPID_MUTEX +#endif + +#ifndef UNLOCK_FDPID_MUTEX +# define UNLOCK_FDPID_MUTEX +#endif + +#ifndef LOCK_SV_LOCK_MUTEX +# define LOCK_SV_LOCK_MUTEX +#endif + +#ifndef UNLOCK_SV_LOCK_MUTEX +# define UNLOCK_SV_LOCK_MUTEX +#endif + /* THR, SET_THR, and dTHR are there for compatibility with old versions */ #ifndef THR # define THR PERL_GET_THX diff --git a/contrib/perl5/toke.c b/contrib/perl5/toke.c index 48dad64e93d8..d33b95df3cf5 100644 --- a/contrib/perl5/toke.c +++ b/contrib/perl5/toke.c @@ -1,6 +1,6 @@ /* toke.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. @@ -13,7 +13,7 @@ /* * This file is the lexer for Perl. It's closely linked to the - * parser, perly.y. + * parser, perly.y. * * The main routine is yylex(), which returns the next token. */ @@ -28,6 +28,10 @@ static char ident_too_long[] = "Identifier too long"; static void restore_rsfp(pTHXo_ void *f); +#ifndef PERL_NO_UTF16_FILTER +static I32 utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen); +static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen); +#endif #define XFAKEBRACK 128 #define XENUMMASK 127 @@ -35,10 +39,17 @@ static void restore_rsfp(pTHXo_ void *f); /*#define UTF (SvUTF8(PL_linestr) && !(PL_hints & HINT_BYTE))*/ #define UTF (PL_hints & HINT_UTF8) -/* In variables name $^X, these are the legal values for X. +/* In variables name $^X, these are the legal values for X. * 1999-02-27 mjd-perl-patch@plover.com */ #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x))) +/* On MacOS, respect nonbreaking spaces */ +#ifdef MACOS_TRADITIONAL +#define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t') +#else +#define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t') +#endif + /* LEX_* are values for PL_lex_state, the state of the lexer. * They are arranged oddly so that the guard on the switch statement * can get by with a single comparison (if the compiler is smart enough). @@ -58,26 +69,24 @@ static void restore_rsfp(pTHXo_ void *f); #define LEX_FORMLINE 1 #define LEX_KNOWNEXT 0 -/* XXX If this causes problems, set i_unistd=undef in the hint file. */ -#ifdef I_UNISTD -# include <unistd.h> /* Needed for execv() */ -#endif - - #ifdef ff_next #undef ff_next #endif #ifdef USE_PURE_BISON -YYSTYPE* yylval_pointer = NULL; -int* yychar_pointer = NULL; +# ifndef YYMAXLEVEL +# define YYMAXLEVEL 100 +# endif +YYSTYPE* yylval_pointer[YYMAXLEVEL]; +int* yychar_pointer[YYMAXLEVEL]; +int yyactlevel = -1; # undef yylval # undef yychar -# define yylval (*yylval_pointer) -# define yychar (*yychar_pointer) -# define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer +# define yylval (*yylval_pointer[yyactlevel]) +# define yychar (*yychar_pointer[yyactlevel]) +# define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel] # undef yylex -# define yylex() Perl_yylex(aTHX_ yylval_pointer, yychar_pointer) +# define yylex() Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]) #endif #include "keywords.h" @@ -112,7 +121,7 @@ int* yychar_pointer = NULL; * Aop : addition-level operator * Mop : multiplication-level operator * Eop : equality-testing operator - * Rop : relational operator <= != gt + * Rop : relational operator <= != gt * * Also see LOP and lop() below. */ @@ -198,10 +207,8 @@ S_no_op(pTHX_ char *what, char *s) if (!s) s = oldbp; - else { - assert(s >= oldbp); + else PL_bufptr = s; - } yywarn(Perl_form(aTHX_ "%s found where operator expected", what)); if (is_first) Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n"); @@ -212,8 +219,10 @@ S_no_op(pTHX_ char *what, char *s) Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n", t - PL_oldoldbufptr, PL_oldoldbufptr); } - else + else { + assert(s >= oldbp); Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp); + } PL_bufptr = oldbp; } @@ -265,7 +274,6 @@ S_missingterm(pTHX_ char *s) void Perl_deprecate(pTHX_ char *s) { - dTHR; if (ckWARN(WARN_DEPRECATED)) Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s); } @@ -319,36 +327,6 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) } #endif -#if 0 -STATIC I32 -S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) -{ - I32 count = FILTER_READ(idx+1, sv, maxlen); - if (count) { - U8* tmps; - U8* tend; - New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8); - tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv)); - sv_usepvn(sv, (char*)tmps, tend - tmps); - } - return count; -} - -STATIC I32 -S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen) -{ - I32 count = FILTER_READ(idx+1, sv, maxlen); - if (count) { - U8* tmps; - U8* tend; - New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8); - tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv)); - sv_usepvn(sv, (char*)tmps, tend - tmps); - } - return count; -} -#endif - /* * Perl_lex_start * Initialize variables. Uses the Perl save_stack to save its state (for @@ -358,7 +336,6 @@ S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen) void Perl_lex_start(pTHX_ SV *line) { - dTHR; char *s; STRLEN len; @@ -376,13 +353,14 @@ Perl_lex_start(pTHX_ SV *line) SAVEVPTR(PL_nextval[toke]); } SAVEI32(PL_nexttoke); - PL_nexttoke = 0; } SAVECOPLINE(PL_curcop); SAVEPPTR(PL_bufptr); SAVEPPTR(PL_bufend); SAVEPPTR(PL_oldbufptr); SAVEPPTR(PL_oldoldbufptr); + SAVEPPTR(PL_last_lop); + SAVEPPTR(PL_last_uni); SAVEPPTR(PL_linestart); SAVESPTR(PL_linestr); SAVEPPTR(PL_lex_brackstack); @@ -410,6 +388,7 @@ Perl_lex_start(pTHX_ SV *line) PL_lex_stuff = Nullsv; PL_lex_repl = Nullsv; PL_lex_inpat = 0; + PL_nexttoke = 0; PL_lex_inwhat = 0; PL_sublex_info.sub_inwhat = 0; PL_linestr = line; @@ -424,6 +403,7 @@ Perl_lex_start(pTHX_ SV *line) SvTEMP_off(PL_linestr); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); PL_bufend = PL_bufptr + SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; SvREFCNT_dec(PL_rs); PL_rs = newSVpvn("\n", 1); PL_rsfp = 0; @@ -454,7 +434,6 @@ Perl_lex_end(pTHX) STATIC void S_incline(pTHX_ char *s) { - dTHR; char *t; char *n; char *e; @@ -463,22 +442,22 @@ S_incline(pTHX_ char *s) CopLINE_inc(PL_curcop); if (*s++ != '#') return; - while (*s == ' ' || *s == '\t') s++; + while (SPACE_OR_TAB(*s)) s++; if (strnEQ(s, "line", 4)) s += 4; else return; - if (*s == ' ' || *s == '\t') + if (SPACE_OR_TAB(*s)) s++; - else + else return; - while (*s == ' ' || *s == '\t') s++; + while (SPACE_OR_TAB(*s)) s++; if (!isDIGIT(*s)) return; n = s; while (isDIGIT(*s)) s++; - while (*s == ' ' || *s == '\t') + while (SPACE_OR_TAB(*s)) s++; if (*s == '"' && (t = strchr(s+1, '"'))) { s++; @@ -488,15 +467,21 @@ S_incline(pTHX_ char *s) for (t = s; !isSPACE(*t); t++) ; e = t; } - while (*e == ' ' || *e == '\t' || *e == '\r' || *e == '\f') + while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f') e++; if (*e != '\n' && *e != '\0') return; /* false alarm */ ch = *t; *t = '\0'; - if (t - s > 0) + if (t - s > 0) { +#ifdef USE_ITHREADS + Safefree(CopFILE(PL_curcop)); +#else + SvREFCNT_dec(CopFILEGV(PL_curcop)); +#endif CopFILE_set(PL_curcop, s); + } *t = ch; CopLINE_set(PL_curcop, atoi(n)-1); } @@ -510,9 +495,8 @@ S_incline(pTHX_ char *s) STATIC char * S_skipspace(pTHX_ register char *s) { - dTHR; if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { - while (s < PL_bufend && (*s == ' ' || *s == '\t')) + while (s < PL_bufend && SPACE_OR_TAB(*s)) s++; return s; } @@ -565,6 +549,7 @@ S_skipspace(pTHX_ register char *s) PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; /* Close the filehandle. Could be from -P preprocessor, * STDIN, or a regular file. If we were reading code from @@ -629,7 +614,6 @@ S_check_uni(pTHX) { char *s; char *t; - dTHR; if (PL_oldoldbufptr != PL_last_uni) return; @@ -641,8 +625,8 @@ S_check_uni(pTHX) if (ckWARN_d(WARN_AMBIGUOUS)){ char ch = *s; *s = '\0'; - Perl_warner(aTHX_ WARN_AMBIGUOUS, - "Warning: Use of \"%s\" without parens is ambiguous", + Perl_warner(aTHX_ WARN_AMBIGUOUS, + "Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni); *s = ch; } @@ -695,7 +679,6 @@ S_uni(pTHX_ I32 f, char *s) STATIC I32 S_lop(pTHX_ I32 f, int x, char *s) { - dTHR; yylval.ival = f; CLINE; PL_expect = x; @@ -722,7 +705,7 @@ S_lop(pTHX_ I32 f, int x, char *s) * handles the token correctly. */ -STATIC void +STATIC void S_force_next(pTHX_ I32 type) { PL_nexttype[PL_nexttoke] = type; @@ -755,7 +738,7 @@ S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow { register char *s; STRLEN len; - + start = skipspace(start); s = start; if (isIDFIRST_lazy_if(s,UTF) || @@ -797,7 +780,6 @@ S_force_ident(pTHX_ register char *s, int kind) PL_nextval[PL_nexttoke].opval = o; force_next(WORD); if (kind) { - dTHR; /* just for in_eval */ o->op_private = OPpCONST_ENTERED; /* XXX see note in pp_entereval() for why we forgo typo warnings if the symbol must be introduced in an eval. @@ -819,13 +801,13 @@ Perl_str_to_version(pTHX_ SV *sv) NV nshift = 1.0; STRLEN len; char *start = SvPVx(sv,len); - bool utf = SvUTF8(sv); + bool utf = SvUTF8(sv) ? TRUE : FALSE; char *end = start + len; while (start < end) { - I32 skip; + STRLEN skip; UV n; if (utf) - n = utf8_to_uv((U8*)start, &skip); + n = utf8_to_uv((U8*)start, len, &skip, 0); else { n = *(U8*)start; skip = 1; @@ -837,7 +819,7 @@ Perl_str_to_version(pTHX_ SV *sv) return retval; } -/* +/* * S_force_version * Forces the next token to be a version number. */ @@ -857,7 +839,7 @@ S_force_version(pTHX_ char *s) for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++); if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) { SV *ver; - s = scan_num(s); + s = scan_num(s, &yylval); version = yylval.opval; ver = cSVOPx(version)->op_sv; if (SvPOK(ver) && !SvNIOK(ver)) { @@ -870,7 +852,7 @@ S_force_version(pTHX_ char *s) /* NOTE: The parser sees the package name and the VERSION swapped */ PL_nextval[PL_nexttoke].opval = version; - force_next(WORD); + force_next(WORD); return (s); } @@ -896,7 +878,7 @@ S_tokeq(pTHX_ SV *sv) goto finish; s = SvPV_force(sv, len); - if (SvIVX(sv) == -1) + if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) goto finish; send = s + len; while (s < send && *s != '\\') @@ -974,9 +956,11 @@ S_sublex_start(pTHX) p = SvPV(sv, len); nsv = newSVpvn(p, len); + if (SvUTF8(sv)) + SvUTF8_on(nsv); SvREFCNT_dec(sv); sv = nsv; - } + } yylval.opval = (OP*)newSVOP(op_type, 0, sv); PL_lex_stuff = Nullsv; return THING; @@ -1008,7 +992,6 @@ S_sublex_start(pTHX) STATIC I32 S_sublex_push(pTHX) { - dTHR; ENTER; PL_lex_state = PL_sublex_info.super_state; @@ -1023,6 +1006,8 @@ S_sublex_push(pTHX) SAVEPPTR(PL_bufptr); SAVEPPTR(PL_oldbufptr); SAVEPPTR(PL_oldoldbufptr); + SAVEPPTR(PL_last_lop); + SAVEPPTR(PL_last_uni); SAVEPPTR(PL_linestart); SAVESPTR(PL_linestr); SAVEPPTR(PL_lex_brackstack); @@ -1034,6 +1019,7 @@ S_sublex_push(pTHX) PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); PL_bufend += SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; SAVEFREESV(PL_linestr); PL_lex_dojoin = FALSE; @@ -1066,8 +1052,11 @@ STATIC I32 S_sublex_done(pTHX) { if (!PL_lex_starts++) { + SV *sv = newSVpvn("",0); + if (SvUTF8(PL_linestr)) + SvUTF8_on(sv); PL_expect = XOPERATOR; - yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0)); + yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); return THING; } @@ -1082,6 +1071,7 @@ S_sublex_done(pTHX) PL_lex_inpat = 0; PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); PL_bufend += SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; SAVEFREESV(PL_linestr); PL_lex_dojoin = FALSE; PL_lex_brackets = 0; @@ -1182,7 +1172,7 @@ S_sublex_done(pTHX) } (end switch) } (end if backslash) } (end while character to read) - + */ STATIC char * @@ -1193,14 +1183,13 @@ S_scan_const(pTHX_ char *start) register char *s = start; /* start of the constant */ register char *d = SvPVX(sv); /* destination for copies */ bool dorange = FALSE; /* are we in a translit range? */ - bool has_utf = FALSE; /* embedded \x{} */ - I32 len; /* ? */ + bool has_utf8 = FALSE; /* embedded \x{} */ UV uv; I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) : UTF; - I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) + I32 this_utf8 = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF)) : UTF; @@ -1280,9 +1269,9 @@ S_scan_const(pTHX_ char *start) while (count && (c = *regparse)) { if (c == '\\' && regparse[1]) regparse++; - else if (c == '{') + else if (c == '{') count++; - else if (c == '}') + else if (c == '}') count--; regparse++; } @@ -1317,27 +1306,10 @@ S_scan_const(pTHX_ char *start) break; /* in regexp, $ might be tail anchor */ } - /* (now in tr/// code again) */ - - if (*s & 0x80 && thisutf) { - (void)utf8_to_uv((U8*)s, &len); - if (len == 1) { - /* illegal UTF8, make it valid */ - char *old_pvx = SvPVX(sv); - /* need space for one extra char (NOTE: SvCUR() not set here) */ - d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx); - d = (char*)uv_to_utf8((U8*)d, (U8)*s++); - } - else { - while (len--) - *d++ = *s++; - } - has_utf = TRUE; - continue; - } - /* backslashes */ if (*s == '\\' && s+1 < send) { + bool to_be_utf8 = FALSE; + s++; /* some backslashes we leave behind */ @@ -1351,7 +1323,6 @@ S_scan_const(pTHX_ char *start) if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat && isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) { - dTHR; /* only for ckWARN */ if (ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s); *--s = '$'; @@ -1376,21 +1347,22 @@ S_scan_const(pTHX_ char *start) /* FALL THROUGH */ default: { - dTHR; if (ckWARN(WARN_MISC) && isALPHA(*s)) Perl_warner(aTHX_ WARN_MISC, "Unrecognized escape \\%c passed through", *s); /* default action is to copy the quoted character */ - *d++ = *s++; - continue; + goto default_action; } /* \132 indicates an octal constant */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': - uv = (UV)scan_oct(s, 3, &len); - s += len; + { + STRLEN len = 0; /* disallow underscores */ + uv = (UV)scan_oct(s, 3, &len); + s += len; + } goto NUM_ESCAPE_INSERT; /* \x24 indicates a hex constant */ @@ -1402,44 +1374,64 @@ S_scan_const(pTHX_ char *start) yyerror("Missing right brace on \\x{}"); e = s; } - uv = (UV)scan_hex(s + 1, e - s - 1, &len); - s = e + 1; + else { + STRLEN len = 1; /* allow underscores */ + uv = (UV)scan_hex(s + 1, e - s - 1, &len); + to_be_utf8 = TRUE; + } + s = e + 1; } else { - uv = (UV)scan_hex(s, 2, &len); - s += len; + { + STRLEN len = 0; /* disallow underscores */ + uv = (UV)scan_hex(s, 2, &len); + s += len; + } } NUM_ESCAPE_INSERT: /* Insert oct or hex escaped character. - * There will always enough room in sv since such escapes will - * be longer than any utf8 sequence they can end up as - */ + * There will always enough room in sv since such + * escapes will be longer than any UT-F8 sequence + * they can end up as. */ + + /* This spot is wrong for EBCDIC. Characters like + * the lowercase letters and digits are >127 in EBCDIC, + * so here they would need to be mapped to the Unicode + * repertoire. --jhi */ + if (uv > 127) { - if (!thisutf && !has_utf && uv > 255) { - /* might need to recode whatever we have accumulated so far - * if it contains any hibit chars + if (!has_utf8 && (to_be_utf8 || uv > 255)) { + /* Might need to recode whatever we have + * accumulated so far if it contains any + * hibit chars. + * + * (Can't we keep track of that and avoid + * this rescan? --jhi) */ int hicount = 0; char *c; + for (c = SvPVX(sv); c < d; c++) { - if (*c & 0x80) + if (UTF8_IS_CONTINUED(*c)) hicount++; } if (hicount) { char *old_pvx = SvPVX(sv); char *src, *dst; - d = SvGROW(sv, SvCUR(sv) + hicount + 1) + (d - old_pvx); + + d = SvGROW(sv, + SvCUR(sv) + hicount + 1) + + (d - old_pvx); src = d - 1; d += hicount; dst = d - 1; while (src < dst) { - if (*src & 0x80) { - dst--; - uv_to_utf8((U8*)dst, (U8)*src--); - dst--; + if (UTF8_IS_CONTINUED(*src)) { + *dst-- = UTF8_EIGHT_BIT_LO(*src); + *dst-- = UTF8_EIGHT_BIT_HI(*src--); } else { *dst-- = *src--; @@ -1448,9 +1440,16 @@ S_scan_const(pTHX_ char *start) } } - if (thisutf || uv > 255) { + if (to_be_utf8 || has_utf8 || uv > 255) { d = (char*)uv_to_utf8((U8*)d, uv); - has_utf = TRUE; + has_utf8 = TRUE; + if (PL_lex_inwhat == OP_TRANS && + PL_sublex_info.sub_op) { + PL_sublex_info.sub_op->op_private |= + (PL_lex_repl ? OPpTRANS_FROM_UTF + : OPpTRANS_TO_UTF); + utf = TRUE; + } } else { *d++ = (char)uv; @@ -1469,23 +1468,28 @@ S_scan_const(pTHX_ char *start) SV *res; STRLEN len; char *str; - + if (!e) { yyerror("Missing right brace on \\N{}"); e = s - 1; goto cont_scan; } res = newSVpvn(s + 1, e - s - 1); - res = new_constant( Nullch, 0, "charnames", + res = new_constant( Nullch, 0, "charnames", res, Nullsv, "\\N{...}" ); + if (has_utf8) + sv_utf8_upgrade(res); str = SvPV(res,len); - if (!has_utf && SvUTF8(res)) { + if (!has_utf8 && SvUTF8(res)) { char *ostart = SvPVX(sv); SvCUR_set(sv, d - ostart); SvPOK_on(sv); + *d = '\0'; sv_utf8_upgrade(sv); + /* this just broke our allocation above... */ + SvGROW(sv, send - start); d = SvPVX(sv) + SvCUR(sv); - has_utf = TRUE; + has_utf8 = TRUE; } if (len > e - s + 4) { char *odest = SvPVX(sv); @@ -1510,10 +1514,13 @@ S_scan_const(pTHX_ char *start) *d = *s++; if (isLOWER(*d)) *d = toUPPER(*d); - *d++ = toCTRL(*d); + *d = toCTRL(*d); + d++; #else - len = *s++; - *d++ = toCTRL(len); + { + U8 c = *s++; + *d++ = toCTRL(c); + } #endif continue; @@ -1554,14 +1561,41 @@ S_scan_const(pTHX_ char *start) continue; } /* end if (backslash) */ - *d++ = *s++; + default_action: + if (UTF8_IS_CONTINUED(*s) && (this_utf8 || has_utf8)) { + STRLEN len = (STRLEN) -1; + UV uv; + if (this_utf8) { + uv = utf8_to_uv((U8*)s, send - s, &len, 0); + } + if (len == (STRLEN)-1) { + /* Illegal UTF8 (a high-bit byte), make it valid. */ + char *old_pvx = SvPVX(sv); + /* need space for one extra char (NOTE: SvCUR() not set here) */ + d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx); + d = (char*)uv_to_utf8((U8*)d, (U8)*s++); + } + else { + while (len--) + *d++ = *s++; + } + has_utf8 = TRUE; + if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) { + PL_sublex_info.sub_op->op_private |= + (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF); + utf = TRUE; + } + continue; + } + + *d++ = *s++; } /* while loop to process each character */ /* terminate the string and set up the sv */ *d = '\0'; SvCUR_set(sv, d - SvPVX(sv)); SvPOK_on(sv); - if (has_utf) + if (has_utf8) SvUTF8_on(sv); /* shrink the sv if we allocated more than we used */ @@ -1573,9 +1607,9 @@ S_scan_const(pTHX_ char *start) /* return the substring (via yylval) only if we parsed anything */ if (s > PL_bufptr) { if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) - sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"), + sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"), sv, Nullsv, - ( PL_lex_inwhat == OP_TRANS + ( PL_lex_inwhat == OP_TRANS ? "tr" : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) ? "s" @@ -1846,7 +1880,7 @@ S_incl_perldb(pTHX) /* Encoded script support. filter_add() effectively inserts a - * 'pre-processing' function into the current source input stream. + * 'pre-processing' function into the current source input stream. * Note that the filter function only applies to the current source file * (e.g., it will not affect files 'require'd or 'use'd by this one). * @@ -1856,7 +1890,7 @@ S_incl_perldb(pTHX) * store private buffers and state information. * * The supplied datasv parameter is upgraded to a PVIO type - * and the IoDIRP field is used to store the function pointer, + * and the IoDIRP/IoANY field is used to store the function pointer, * and IOf_FAKE_DIRP is enabled on datasv to mark this as such. * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for * private use must be set using malloc'd pointers. @@ -1874,7 +1908,7 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) datasv = NEWSV(255,0); if (!SvUPGRADE(datasv, SVt_PVIO)) Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO"); - IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */ + IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */ IoFLAGS(datasv) |= IOf_FAKE_DIRP; DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n", funcp, SvPV_nolen(datasv))); @@ -1882,7 +1916,7 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) av_store(PL_rsfp_filters, 0, datasv) ; return(datasv); } - + /* Delete most recently added instance of this filter function. */ void @@ -1894,9 +1928,9 @@ Perl_filter_del(pTHX_ filter_t funcp) return; /* if filter is on top of stack (usual case) just pop it off */ datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters)); - if (IoDIRP(datasv) == (DIR*)funcp) { + if (IoANY(datasv) == (void *)funcp) { IoFLAGS(datasv) &= ~IOf_FAKE_DIRP; - IoDIRP(datasv) = (DIR*)NULL; + IoANY(datasv) = (void *)NULL; sv_free(av_pop(PL_rsfp_filters)); return; @@ -1909,8 +1943,8 @@ Perl_filter_del(pTHX_ filter_t funcp) /* Invoke the n'th filter function for the current rsfp. */ I32 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) - - + + /* 0 = read one text line */ { filter_t funcp; @@ -1923,7 +1957,7 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) /* Note that we append to the line. This is handy. */ DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: from rsfp\n", idx)); - if (maxlen) { + if (maxlen) { /* Want a block */ int len ; int old_len = SvCUR(buf_sv) ; @@ -1956,7 +1990,7 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */ } /* Get function pointer hidden within datasv */ - funcp = (filter_t)IoDIRP(datasv); + funcp = (filter_t)IoANY(datasv); DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: via function %p (%s)\n", idx, funcp, SvPV_nolen(datasv))); @@ -1987,6 +2021,31 @@ S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) return (sv_gets(sv, fp, append)); } +STATIC HV * +S_find_in_my_stash(pTHX_ char *pkgname, I32 len) +{ + GV *gv; + + if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__")) + return PL_curstash; + + if (len > 2 && + (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') && + (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV))) + { + return GvHV(gv); /* Foo:: */ + } + + /* use constant CLASS => 'MyClass' */ + if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) { + SV *sv; + if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) { + pkgname = SvPV_nolen(sv); + } + } + + return gv_stashpv(pkgname, FALSE); +} #ifdef DEBUGGING static char* exp_name[] = @@ -2020,25 +2079,39 @@ S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) if we already built the token before, use it. */ -int #ifdef USE_PURE_BISON -Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp) -#else -Perl_yylex(pTHX) +int +Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp) +{ + int r; + + yyactlevel++; + yylval_pointer[yyactlevel] = lvalp; + yychar_pointer[yyactlevel] = lcharp; + if (yyactlevel >= YYMAXLEVEL) + Perl_croak(aTHX_ "panic: YYMAXLEVEL"); + + r = Perl_yylex(aTHX); + + yyactlevel--; + + return r; +} +#endif + +#ifdef __SC__ +#pragma segment Perl_yylex #endif +int +Perl_yylex(pTHX) { - dTHR; register char *s; register char *d; register I32 tmp; STRLEN len; GV *gv = Nullgv; GV **gvp = 0; - -#ifdef USE_PURE_BISON - yylval_pointer = lvalp; - yychar_pointer = lcharp; -#endif + bool bof = FALSE; /* check if there's an identifier for us to look at */ if (PL_pending_ident) { @@ -2046,6 +2119,9 @@ Perl_yylex(pTHX) char pit = PL_pending_ident; PL_pending_ident = 0; + DEBUG_T({ PerlIO_printf(Perl_debug_log, + "### Tokener saw identifier '%s'\n", PL_tokenbuf); }) + /* if we're in a my(), we can't allow dynamics here. $foo'bar has already been turned into $foo::bar, so just check for colons. @@ -2070,7 +2146,7 @@ Perl_yylex(pTHX) } } - /* + /* build the ops for accesses to a my() variable. Deny my($a) or my($b) in a sort block, *if* $a or $b is @@ -2145,9 +2221,14 @@ Perl_yylex(pTHX) */ if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) { GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV); - if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) - yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s", - PL_tokenbuf, PL_tokenbuf)); + if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) + && ckWARN(WARN_AMBIGUOUS)) + { + /* Downgraded from fatal to warning 20000522 mjd */ + Perl_warner(aTHX_ WARN_AMBIGUOUS, + "Possible unintended interpolation of %s in string", + PL_tokenbuf); + } } /* build ops for a bareword */ @@ -2178,6 +2259,10 @@ Perl_yylex(pTHX) PL_expect = PL_lex_expect; PL_lex_defer = LEX_NORMAL; } + DEBUG_T({ PerlIO_printf(Perl_debug_log, + "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr, + (IV)PL_nexttype[PL_nexttoke]); }) + return(PL_nexttype[PL_nexttoke]); /* interpolated case modifiers like \L \U, including \Q and \E. @@ -2209,6 +2294,8 @@ Perl_yylex(pTHX) return yylex(); } else { + DEBUG_T({ PerlIO_printf(Perl_debug_log, + "### Saw case modifier at '%s'\n", PL_bufptr); }) s = PL_bufptr + 1; if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3)) tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */ @@ -2259,6 +2346,8 @@ Perl_yylex(pTHX) case LEX_INTERPSTART: if (PL_bufptr == PL_bufend) return sublex_done(); + DEBUG_T({ PerlIO_printf(Perl_debug_log, + "### Interpolated variable at '%s'\n", PL_bufptr); }) PL_expect = XTERM; PL_lex_dojoin = (*PL_bufptr == '@'); PL_lex_state = LEX_INTERPNORMAL; @@ -2355,7 +2444,7 @@ Perl_yylex(pTHX) s = PL_bufptr; PL_oldoldbufptr = PL_oldbufptr; PL_oldbufptr = s; - DEBUG_p( { + DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n", exp_name[PL_expect], s); } ) @@ -2375,6 +2464,9 @@ Perl_yylex(pTHX) PL_last_lop = 0; if (PL_lex_brackets) yyerror("Missing right curly or square bracket"); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Tokener got EOF\n"); + } ) TOKEN(0); } if (s++ < PL_bufend) @@ -2430,6 +2522,7 @@ Perl_yylex(pTHX) sv_catpv(PL_linestr, "\n"); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; if (PERLDB_LINE && PL_curstash != PL_debstash) { SV *sv = NEWSV(85,0); @@ -2440,6 +2533,7 @@ Perl_yylex(pTHX) goto retry; } do { + bof = PL_rsfp ? TRUE : FALSE; if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) { fake_eof: if (PL_rsfp) { @@ -2457,13 +2551,45 @@ Perl_yylex(pTHX) sv_catpv(PL_linestr,";}"); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; PL_minus_n = PL_minus_p = 0; goto retry; } PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; sv_setpv(PL_linestr,""); TOKEN(';'); /* not infinite loop because rsfp is NULL now */ } + /* if it looks like the start of a BOM, check if it in fact is */ + else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) { +#ifdef PERLIO_IS_STDIO +# ifdef __GNU_LIBRARY__ +# if __GNU_LIBRARY__ == 1 /* Linux glibc5 */ +# define FTELL_FOR_PIPE_IS_BROKEN +# endif +# else +# ifdef __GLIBC__ +# if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */ +# define FTELL_FOR_PIPE_IS_BROKEN +# endif +# endif +# endif +#endif +#ifdef FTELL_FOR_PIPE_IS_BROKEN + /* This loses the possibility to detect the bof + * situation on perl -P when the libc5 is being used. + * Workaround? Maybe attach some extra state to PL_rsfp? + */ + if (!PL_preprocess) + bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr); +#else + bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr); +#endif + if (bof) { + PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + s = swallow_bom((U8*)s); + } + } if (PL_doextract) { if (*s == '#' && s[1] == '!' && instr(s,"perl")) PL_doextract = FALSE; @@ -2473,6 +2599,7 @@ Perl_yylex(pTHX) sv_setpv(PL_linestr, ""); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; PL_doextract = FALSE; } } @@ -2487,6 +2614,7 @@ Perl_yylex(pTHX) av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); } PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; if (CopLINE(PL_curcop) == 1) { while (s < PL_bufend && isSPACE(*s)) s++; @@ -2575,6 +2703,7 @@ Perl_yylex(pTHX) *s = '#'; /* Don't try to parse shebang line */ } #endif /* ALTERNATE_SHEBANG */ +#ifndef MACOS_TRADITIONAL if (!d && *s == '#' && ipathend > ipath && @@ -2599,16 +2728,17 @@ Perl_yylex(pTHX) else newargv = PL_origargv; newargv[0] = ipath; - PerlProc_execv(ipath, newargv); + PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv)); Perl_croak(aTHX_ "Can't exec %s", ipath); } +#endif if (d) { U32 oldpdb = PL_perldb; bool oldn = PL_minus_n; bool oldp = PL_minus_p; while (*d && !isSPACE(*d)) d++; - while (*d == ' ' || *d == '\t') d++; + while (SPACE_OR_TAB(*d)) d++; if (*d++ == '-') { do { @@ -2628,6 +2758,7 @@ Perl_yylex(pTHX) sv_setpv(PL_linestr, ""); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; PL_preambled = FALSE; if (PERLDB_LINE) (void)gv_fetchfile(PL_origfilename); @@ -2646,15 +2777,23 @@ Perl_yylex(pTHX) case '\r': #ifdef PERL_STRICT_CR Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r'); - Perl_croak(aTHX_ + Perl_croak(aTHX_ "\t(Maybe you didn't strip carriage returns after a network transfer?)\n"); #endif case ' ': case '\t': case '\f': case 013: +#ifdef MACOS_TRADITIONAL + case '\312': +#endif s++; goto retry; case '#': case '\n': if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) { + if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) { + /* handle eval qq[#line 1 "foo"\n ...] */ + CopLINE_dec(PL_curcop); + incline(s); + } d = PL_bufend; while (s < d && *s != '\n') s++; @@ -2674,51 +2813,66 @@ Perl_yylex(pTHX) goto retry; case '-': if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) { + I32 ftst = 0; + s++; PL_bufptr = s; tmp = *s++; - while (s < PL_bufend && (*s == ' ' || *s == '\t')) + while (s < PL_bufend && SPACE_OR_TAB(*s)) s++; if (strnEQ(s,"=>",2)) { s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw unary minus before =>, forcing word '%s'\n", s); + } ) OPERATOR('-'); /* unary minus */ } PL_last_uni = PL_oldbufptr; - PL_last_lop_op = OP_FTEREAD; /* good enough */ switch (tmp) { - case 'r': FTST(OP_FTEREAD); - case 'w': FTST(OP_FTEWRITE); - case 'x': FTST(OP_FTEEXEC); - case 'o': FTST(OP_FTEOWNED); - case 'R': FTST(OP_FTRREAD); - case 'W': FTST(OP_FTRWRITE); - case 'X': FTST(OP_FTREXEC); - case 'O': FTST(OP_FTROWNED); - case 'e': FTST(OP_FTIS); - case 'z': FTST(OP_FTZERO); - case 's': FTST(OP_FTSIZE); - case 'f': FTST(OP_FTFILE); - case 'd': FTST(OP_FTDIR); - case 'l': FTST(OP_FTLINK); - case 'p': FTST(OP_FTPIPE); - case 'S': FTST(OP_FTSOCK); - case 'u': FTST(OP_FTSUID); - case 'g': FTST(OP_FTSGID); - case 'k': FTST(OP_FTSVTX); - case 'b': FTST(OP_FTBLK); - case 'c': FTST(OP_FTCHR); - case 't': FTST(OP_FTTTY); - case 'T': FTST(OP_FTTEXT); - case 'B': FTST(OP_FTBINARY); - case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME); - case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME); - case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME); + case 'r': ftst = OP_FTEREAD; break; + case 'w': ftst = OP_FTEWRITE; break; + case 'x': ftst = OP_FTEEXEC; break; + case 'o': ftst = OP_FTEOWNED; break; + case 'R': ftst = OP_FTRREAD; break; + case 'W': ftst = OP_FTRWRITE; break; + case 'X': ftst = OP_FTREXEC; break; + case 'O': ftst = OP_FTROWNED; break; + case 'e': ftst = OP_FTIS; break; + case 'z': ftst = OP_FTZERO; break; + case 's': ftst = OP_FTSIZE; break; + case 'f': ftst = OP_FTFILE; break; + case 'd': ftst = OP_FTDIR; break; + case 'l': ftst = OP_FTLINK; break; + case 'p': ftst = OP_FTPIPE; break; + case 'S': ftst = OP_FTSOCK; break; + case 'u': ftst = OP_FTSUID; break; + case 'g': ftst = OP_FTSGID; break; + case 'k': ftst = OP_FTSVTX; break; + case 'b': ftst = OP_FTBLK; break; + case 'c': ftst = OP_FTCHR; break; + case 't': ftst = OP_FTTTY; break; + case 'T': ftst = OP_FTTEXT; break; + case 'B': ftst = OP_FTBINARY; break; + case 'M': case 'A': case 'C': + gv_fetchpv("\024",TRUE, SVt_PV); + switch (tmp) { + case 'M': ftst = OP_FTMTIME; break; + case 'A': ftst = OP_FTATIME; break; + case 'C': ftst = OP_FTCTIME; break; + default: break; + } + break; default: Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp); break; } + PL_last_lop_op = ftst; + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw file test %c\n", (int)ftst); + } ) + FTST(ftst); } tmp = *s++; if (*s == tmp) { @@ -2847,10 +3001,6 @@ Perl_yylex(pTHX) if (*d == '(') { d = scan_str(d,TRUE,TRUE); if (!d) { - if (PL_lex_stuff) { - SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; - } /* MUST advance bufptr here to avoid bogus "at end of line" context messages from yyerror(). */ @@ -2870,9 +3020,21 @@ Perl_yylex(pTHX) PL_lex_stuff = Nullsv; } else { - attrs = append_elem(OP_LIST, attrs, - newSVOP(OP_CONST, 0, - newSVpvn(s, len))); + if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len)) + CvLVALUE_on(PL_compcv); + else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len)) + CvLOCKED_on(PL_compcv); + else if (!PL_in_my && len == 6 && strnEQ(s, "method", len)) + CvMETHOD_on(PL_compcv); + /* After we've set the flags, it could be argued that + we don't need to do the attributes.pm-based setting + process, and shouldn't bother appending recognized + flags. To experiment with that, uncomment the + following "else": */ + /* else */ + attrs = append_elem(OP_LIST, attrs, + newSVOP(OP_CONST, 0, + newSVpvn(s, len))); } s = skipspace(d); if (*s == ':' && s[1] != ':') @@ -2917,8 +3079,7 @@ Perl_yylex(pTHX) PL_expect = XTERM; TOKEN('('); case ';': - if (CopLINE(PL_curcop) < PL_copline) - PL_copline = CopLINE(PL_curcop); + CLINE; tmp = *s++; OPERATOR(tmp); case ')': @@ -2962,24 +3123,27 @@ Perl_yylex(pTHX) PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; OPERATOR(HASHBRACK); case XOPERATOR: - while (s < PL_bufend && (*s == ' ' || *s == '\t')) + while (s < PL_bufend && SPACE_OR_TAB(*s)) s++; d = s; PL_tokenbuf[0] = '\0'; if (d < PL_bufend && *d == '-') { PL_tokenbuf[0] = '-'; d++; - while (d < PL_bufend && (*d == ' ' || *d == '\t')) + while (d < PL_bufend && SPACE_OR_TAB(*d)) d++; } if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) { d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE, &len); - while (d < PL_bufend && (*d == ' ' || *d == '\t')) + while (d < PL_bufend && SPACE_OR_TAB(*d)) d++; if (*d == '}') { char minus = (PL_tokenbuf[0] == '-'); s = force_word(s + minus, WORD, FALSE, TRUE, FALSE); + if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, 0) && + PL_nextval[PL_nexttoke-1].opval) + SvUTF8_on(((SVOP*)PL_nextval[PL_nexttoke-1].opval)->op_sv); if (minus) force_next('-'); } @@ -3095,7 +3259,7 @@ Perl_yylex(pTHX) yyerror("Unmatched right curly bracket"); else PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets]; - if (PL_lex_brackets < PL_lex_formbrack) + if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL) PL_lex_formbrack = 0; if (PL_lex_state == LEX_INTERPNORMAL) { if (PL_lex_brackets == 0) { @@ -3192,9 +3356,9 @@ Perl_yylex(pTHX) if (PL_lex_brackets < PL_lex_formbrack) { char *t; #ifdef PERL_STRICT_CR - for (t = s; *t == ' ' || *t == '\t'; t++) ; + for (t = s; SPACE_OR_TAB(*t); t++) ; #else - for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ; + for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ; #endif if (*t == '\n' || *t == '#') { s--; @@ -3417,8 +3581,8 @@ Perl_yylex(pTHX) case '?': /* may either be conditional or pattern */ if (PL_expect != XOPERATOR) { /* Disable warning on "study /blah/" */ - if (PL_oldoldbufptr == PL_last_uni - && (*PL_last_uni != 's' || s - PL_last_uni < 5 + if (PL_oldoldbufptr == PL_last_uni + && (*PL_last_uni != 's' || s - PL_last_uni < 5 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy_if(PL_last_uni+5,UTF))) check_uni(); @@ -3462,13 +3626,19 @@ Perl_yylex(pTHX) /* FALL THROUGH */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': - s = scan_num(s); + s = scan_num(s, &yylval); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw number in '%s'\n", s); + } ) if (PL_expect == XOPERATOR) no_op("Number",s); TERM(THING); case '\'': s = scan_str(s,FALSE,FALSE); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw string before '%s'\n", s); + } ) if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; @@ -3485,6 +3655,9 @@ Perl_yylex(pTHX) case '"': s = scan_str(s,FALSE,FALSE); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw string before '%s'\n", s); + } ) if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; @@ -3498,7 +3671,7 @@ Perl_yylex(pTHX) missingterm((char*)0); yylval.ival = OP_CONST; for (d = SvPV(PL_lex_stuff, len); len; len--, d++) { - if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) { + if (*d == '$' || *d == '@' || *d == '\\' || UTF8_IS_CONTINUED(*d)) { yylval.ival = OP_STRINGIFY; break; } @@ -3507,6 +3680,9 @@ Perl_yylex(pTHX) case '`': s = scan_str(s,FALSE,FALSE); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw backtick string before '%s'\n", s); + } ) if (PL_expect == XOPERATOR) no_op("Backticks",s); if (!s) @@ -3532,7 +3708,7 @@ Perl_yylex(pTHX) while (isDIGIT(*start) || *start == '_') start++; if (*start == '.' && isDIGIT(start[1])) { - s = scan_num(s); + s = scan_num(s, &yylval); TERM(THING); } /* avoid v123abc() or $h{v1}, allow C<print v10;> */ @@ -3543,7 +3719,7 @@ Perl_yylex(pTHX) gv = gv_fetchpv(s, FALSE, SVt_PVCV); *start = c; if (!gv) { - s = scan_num(s); + s = scan_num(s, &yylval); TERM(THING); } } @@ -3618,10 +3794,12 @@ Perl_yylex(pTHX) tmp = keyword(PL_tokenbuf, len); /* Is this a word before a => operator? */ - if (strnEQ(d,"=>",2)) { + if (*d == '=' && d[1] == '>') { CLINE; yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0)); yylval.opval->op_private = OPpCONST_BARE; + if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len)) + SvUTF8_on(((SVOP*)yylval.opval)->op_sv); TERM(WORD); } @@ -3706,7 +3884,7 @@ Perl_yylex(pTHX) PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':') { if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV)) - Perl_warner(aTHX_ WARN_BAREWORD, + Perl_warner(aTHX_ WARN_BAREWORD, "Bareword \"%s\" refers to nonexistent package", PL_tokenbuf); len -= 2; @@ -3773,14 +3951,24 @@ Perl_yylex(pTHX) } } - /* If followed by a paren, it's certainly a subroutine. */ PL_expect = XOPERATOR; s = skipspace(s); + + /* Is this a word before a => operator? */ + if (*s == '=' && s[1] == '>') { + CLINE; + sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf); + if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len)) + SvUTF8_on(((SVOP*)yylval.opval)->op_sv); + TERM(WORD); + } + + /* If followed by a paren, it's certainly a subroutine. */ if (*s == '(') { CLINE; if (gv && GvCVu(gv)) { - for (d = s + 1; *d == ' ' || *d == '\t'; d++) ; + for (d = s + 1; SPACE_OR_TAB(*d); d++) ; if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) { s = d + 1; goto its_constant; @@ -3917,11 +4105,11 @@ Perl_yylex(pTHX) /* Mark this internal pseudo-handle as clean */ IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT; if (PL_preprocess) - IoTYPE(GvIOp(gv)) = '|'; + IoTYPE(GvIOp(gv)) = IoTYPE_PIPE; else if ((PerlIO*)PL_rsfp == PerlIO_stdin()) - IoTYPE(GvIOp(gv)) = '-'; + IoTYPE(GvIOp(gv)) = IoTYPE_STD; else - IoTYPE(GvIOp(gv)) = '<'; + IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY; #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS) /* if the script was opened in binmode, we need to revert * it to text mode for compatibility; but only iff it has CRs @@ -3930,14 +4118,14 @@ Perl_yylex(pTHX) && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r') { Off_t loc = 0; - if (IoTYPE(GvIOp(gv)) == '<') { + if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) { loc = PerlIO_tell(PL_rsfp); (void)PerlIO_seek(PL_rsfp, 0L, 0); } if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) { #if defined(__BORLANDC__) /* XXX see note in do_binmode() */ - ((FILE*)PL_rsfp)->flags |= _F_BIN; + ((FILE*)PL_rsfp)->flags &= ~_F_BIN; #endif if (loc > 0) PerlIO_seek(PL_rsfp, loc, 0); @@ -4094,7 +4282,7 @@ Perl_yylex(pTHX) case KEY_exists: UNI(OP_EXISTS); - + case KEY_exit: UNI(OP_EXIT); @@ -4298,7 +4486,7 @@ Perl_yylex(pTHX) case KEY_last: s = force_word(s,WORD,TRUE,FALSE,FALSE); LOOPX(OP_LAST); - + case KEY_lc: UNI(OP_LC); @@ -4366,7 +4554,7 @@ Perl_yylex(pTHX) s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len); if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3)) goto really_sub; - PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE); + PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len); if (!PL_in_my_stash) { char tmpbuf[1024]; PL_bufptr = s; @@ -4443,7 +4631,7 @@ Perl_yylex(pTHX) case KEY_pos: UNI(OP_POS); - + case KEY_pack: LOP(OP_PACK,XTERM); @@ -4474,6 +4662,7 @@ Perl_yylex(pTHX) int warned = 0; d = SvPV_force(PL_lex_stuff, len); while (len) { + SV *sv; for (; isSPACE(*d) && len; --len, ++d) ; if (len) { char *b = d; @@ -4494,8 +4683,11 @@ Perl_yylex(pTHX) else { for (; !isSPACE(*d) && len; --len, ++d) ; } + sv = newSVpvn(b, d-b); + if (DO_UTF8(PL_lex_stuff)) + SvUTF8_on(sv); words = append_elem(OP_LIST, words, - newSVOP(OP_CONST, 0, newSVpvn(b, d-b))); + newSVOP(OP_CONST, 0, tokeq(sv))); } } if (words) { @@ -4503,9 +4695,10 @@ Perl_yylex(pTHX) force_next(THING); } } - if (PL_lex_stuff) + if (PL_lex_stuff) { SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; + PL_lex_stuff = Nullsv; + } PL_expect = XTERM; TOKEN('('); @@ -4605,7 +4798,7 @@ Perl_yylex(pTHX) case KEY_chomp: UNI(OP_CHOMP); - + case KEY_scalar: UNI(OP_SCALAR); @@ -4773,12 +4966,8 @@ Perl_yylex(pTHX) char *p; s = scan_str(s,FALSE,FALSE); - if (!s) { - if (PL_lex_stuff) - SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; + if (!s) Perl_croak(aTHX_ "Prototype not terminated"); - } /* strip spaces */ d = SvPVX(PL_lex_stuff); tmp = 0; @@ -4894,7 +5083,7 @@ Perl_yylex(pTHX) case KEY_umask: if (ckWARN(WARN_UMASK)) { for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ; - if (*d != '0' && isDIGIT(*d)) + if (*d != '0' && isDIGIT(*d)) Perl_warner(aTHX_ WARN_UMASK, "umask: argument is missing initial 0"); } @@ -4949,7 +5138,7 @@ Perl_yylex(pTHX) { static char ctl_l[2]; - if (ctl_l[0] == '\0') + if (ctl_l[0] == '\0') ctl_l[0] = toCTRL('L'); gv_fetchpv(ctl_l,TRUE, SVt_PV); } @@ -4974,6 +5163,9 @@ Perl_yylex(pTHX) } }} } +#ifdef __SC__ +#pragma segment Main +#endif I32 Perl_keyword(pTHX_ register char *d, I32 len) @@ -5026,12 +5218,12 @@ Perl_keyword(pTHX_ register char *d, I32 len) if (strEQ(d,"cos")) return -KEY_cos; break; case 4: - if (strEQ(d,"chop")) return KEY_chop; + if (strEQ(d,"chop")) return -KEY_chop; break; case 5: if (strEQ(d,"close")) return -KEY_close; if (strEQ(d,"chdir")) return -KEY_chdir; - if (strEQ(d,"chomp")) return KEY_chomp; + if (strEQ(d,"chomp")) return -KEY_chomp; if (strEQ(d,"chmod")) return -KEY_chmod; if (strEQ(d,"chown")) return -KEY_chown; if (strEQ(d,"crypt")) return -KEY_crypt; @@ -5093,7 +5285,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) if (strEQ(d,"exit")) return -KEY_exit; if (strEQ(d,"eval")) return KEY_eval; if (strEQ(d,"exec")) return -KEY_exec; - if (strEQ(d,"each")) return KEY_each; + if (strEQ(d,"each")) return -KEY_each; break; case 5: if (strEQ(d,"elsif")) return KEY_elsif; @@ -5243,7 +5435,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) break; case 'k': if (len == 4) { - if (strEQ(d,"keys")) return KEY_keys; + if (strEQ(d,"keys")) return -KEY_keys; if (strEQ(d,"kill")) return -KEY_kill; } break; @@ -5334,11 +5526,11 @@ Perl_keyword(pTHX_ register char *d, I32 len) case 'p': switch (len) { case 3: - if (strEQ(d,"pop")) return KEY_pop; + if (strEQ(d,"pop")) return -KEY_pop; if (strEQ(d,"pos")) return KEY_pos; break; case 4: - if (strEQ(d,"push")) return KEY_push; + if (strEQ(d,"push")) return -KEY_push; if (strEQ(d,"pack")) return -KEY_pack; if (strEQ(d,"pipe")) return -KEY_pipe; break; @@ -5445,7 +5637,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) case 'h': switch (len) { case 5: - if (strEQ(d,"shift")) return KEY_shift; + if (strEQ(d,"shift")) return -KEY_shift; break; case 6: if (strEQ(d,"shmctl")) return -KEY_shmctl; @@ -5474,7 +5666,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) case 'p': if (strEQ(d,"split")) return KEY_split; if (strEQ(d,"sprintf")) return -KEY_sprintf; - if (strEQ(d,"splice")) return KEY_splice; + if (strEQ(d,"splice")) return -KEY_splice; break; case 'q': if (strEQ(d,"sqrt")) return -KEY_sqrt; @@ -5554,7 +5746,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) if (strEQ(d,"unlink")) return -KEY_unlink; break; case 7: - if (strEQ(d,"unshift")) return KEY_unshift; + if (strEQ(d,"unshift")) return -KEY_unshift; if (strEQ(d,"ucfirst")) return -KEY_ucfirst; break; } @@ -5600,7 +5792,6 @@ S_checkcomma(pTHX_ register char *s, char *name, char *what) char *w; if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */ - dTHR; /* only for ckWARN */ if (ckWARN(WARN_SYNTAX)) { int level = 1; for (w = s+2; *w && level; w++) { @@ -5655,18 +5846,27 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, SV **cvp; SV *cv, *typesv; const char *why1, *why2, *why3; - + if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { SV *msg; - why1 = "%^H is not consistent"; why2 = strEQ(key,"charnames") - ? " (missing \"use charnames ...\"?)" + ? "(possibly a missing \"use charnames ...\")" : ""; - why3 = ""; + msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s", + (type ? type: "undef"), why2); + + /* This is convoluted and evil ("goto considered harmful") + * but I do not understand the intricacies of all the different + * failure modes of %^H in here. The goal here is to make + * the most probable error message user-friendly. --jhi */ + + goto msgdone; + report: - msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s", + msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s", (type ? type: "undef"), why1, why2, why3); + msgdone: yyerror(SvPVX(msg)); SvREFCNT_dec(msg); return sv; @@ -5686,24 +5886,23 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, typesv = sv_2mortal(newSVpv(type, 0)); else typesv = &PL_sv_undef; - + PUSHSTACKi(PERLSI_OVERLOAD); ENTER ; SAVETMPS; - + PUSHMARK(SP) ; - EXTEND(sp, 4); + EXTEND(sp, 3); if (pv) PUSHs(pv); PUSHs(sv); if (pv) PUSHs(typesv); - PUSHs(cv); PUTBACK; call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL)); - + SPAGAIN ; - + /* Check the eval first */ if (!PL_in_eval && SvTRUE(ERRSV)) { STRLEN n_a; @@ -5716,12 +5915,12 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, res = POPs; (void)SvREFCNT_inc(res); } - + PUTBACK ; FREETMPS ; LEAVE ; POPSTACK; - + if (!SvOK(res)) { why1 = "Call to &{$^H{"; why2 = key; @@ -5732,7 +5931,7 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, return res; } - + STATIC char * S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp) { @@ -5752,9 +5951,9 @@ S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_packag *d++ = *s++; *d++ = *s++; } - else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) { + else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) { char *t = s + UTF8SKIP(s); - while (*t & 0x80 && is_utf8_mark((U8*)t)) + while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t)) t += UTF8SKIP(t); if (d + (t - s) > e) Perl_croak(aTHX_ ident_too_long); @@ -5804,9 +6003,9 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des *d++ = *s++; *d++ = *s++; } - else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) { + else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) { char *t = s + UTF8SKIP(s); - while (*t & 0x80 && is_utf8_mark((U8*)t)) + while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t)) t += UTF8SKIP(t); if (d + (t - s) > e) Perl_croak(aTHX_ ident_too_long); @@ -5847,7 +6046,7 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des if (isSPACE(s[-1])) { while (s < send) { char ch = *s++; - if (ch != ' ' && ch != '\t') { + if (!SPACE_OR_TAB(ch)) { *d = ch; break; } @@ -5859,7 +6058,7 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des e = s; while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') { e += UTF8SKIP(e); - while (e < send && *e & 0x80 && is_utf8_mark((U8*)e)) + while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e)) e += UTF8SKIP(e); } Copy(s, d, e - s, char); @@ -5873,9 +6072,8 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des Perl_croak(aTHX_ ident_too_long); } *d = '\0'; - while (s < send && (*s == ' ' || *s == '\t')) s++; + while (s < send && SPACE_OR_TAB(*s)) s++; if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { - dTHR; /* only for ckWARN */ if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) { const char *brack = *s == '[' ? "[...]" : "{...}"; Perl_warner(aTHX_ WARN_AMBIGUOUS, @@ -5886,8 +6084,8 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK); return s; } - } - /* Handle extended ${^Foo} variables + } + /* Handle extended ${^Foo} variables * 1999-02-27 mjd-perl-patch@plover.com */ else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */ && isALNUM(*s)) @@ -5907,7 +6105,6 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des if (funny == '#') funny = '@'; if (PL_lex_state == LEX_NORMAL) { - dTHR; /* only for ckWARN */ if (ckWARN(WARN_AMBIGUOUS) && (keyword(dest, d - dest) || get_cv(dest, FALSE))) { @@ -5953,12 +6150,8 @@ S_scan_pat(pTHX_ char *start, I32 type) char *s; s = scan_str(start,FALSE,FALSE); - if (!s) { - if (PL_lex_stuff) - SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; + if (!s) Perl_croak(aTHX_ "Search pattern not terminated"); - } pm = (PMOP*)newPMOP(type, 0); if (PL_multi_open == '?') @@ -5990,12 +6183,8 @@ S_scan_subst(pTHX_ char *start) s = scan_str(start,FALSE,FALSE); - if (!s) { - if (PL_lex_stuff) - SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; + if (!s) Perl_croak(aTHX_ "Substitution pattern not terminated"); - } if (s[-1] == PL_multi_open) s--; @@ -6003,12 +6192,10 @@ S_scan_subst(pTHX_ char *start) first_start = PL_multi_start; s = scan_str(s,FALSE,FALSE); if (!s) { - if (PL_lex_stuff) + if (PL_lex_stuff) { SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; - if (PL_lex_repl) - SvREFCNT_dec(PL_lex_repl); - PL_lex_repl = Nullsv; + PL_lex_stuff = Nullsv; + } Perl_croak(aTHX_ "Substitution replacement not terminated"); } PL_multi_start = first_start; /* so whole substitution is taken together */ @@ -6063,65 +6250,36 @@ S_scan_trans(pTHX_ char *start) yylval.ival = OP_NULL; s = scan_str(start,FALSE,FALSE); - if (!s) { - if (PL_lex_stuff) - SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; + if (!s) Perl_croak(aTHX_ "Transliteration pattern not terminated"); - } if (s[-1] == PL_multi_open) s--; s = scan_str(s,FALSE,FALSE); if (!s) { - if (PL_lex_stuff) + if (PL_lex_stuff) { SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; - if (PL_lex_repl) - SvREFCNT_dec(PL_lex_repl); - PL_lex_repl = Nullsv; + PL_lex_stuff = Nullsv; + } Perl_croak(aTHX_ "Transliteration replacement not terminated"); } - if (UTF) { - o = newSVOP(OP_TRANS, 0, 0); - utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF; - } - else { - New(803,tbl,256,short); - o = newPVOP(OP_TRANS, 0, (char*)tbl); - utf8 = 0; - } + New(803,tbl,256,short); + o = newPVOP(OP_TRANS, 0, (char*)tbl); complement = del = squash = 0; - while (strchr("cdsCU", *s)) { + while (strchr("cds", *s)) { if (*s == 'c') complement = OPpTRANS_COMPLEMENT; else if (*s == 'd') del = OPpTRANS_DELETE; else if (*s == 's') squash = OPpTRANS_SQUASH; - else { - switch (count++) { - case 0: - if (*s == 'C') - utf8 &= ~OPpTRANS_FROM_UTF; - else - utf8 |= OPpTRANS_FROM_UTF; - break; - case 1: - if (*s == 'C') - utf8 &= ~OPpTRANS_TO_UTF; - else - utf8 |= OPpTRANS_TO_UTF; - break; - default: - Perl_croak(aTHX_ "Too many /C and /U options"); - } - } s++; } - o->op_private = del|squash|complement|utf8; + o->op_private = del|squash|complement| + (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)| + (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0); PL_lex_op = o; yylval.ival = OP_TRANS; @@ -6131,7 +6289,6 @@ S_scan_trans(pTHX_ char *start) STATIC char * S_scan_heredoc(pTHX_ register char *s) { - dTHR; SV *herewas; I32 op_type = OP_SCALAR; I32 len; @@ -6147,7 +6304,7 @@ S_scan_heredoc(pTHX_ register char *s) e = PL_tokenbuf + sizeof PL_tokenbuf - 1; if (!outer) *d++ = '\n'; - for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ; + for (peek = s; SPACE_OR_TAB(*peek); peek++) ; if (*peek && strchr("`'\"",*peek)) { s = peek; term = *s++; @@ -6264,6 +6421,7 @@ S_scan_heredoc(pTHX_ register char *s) sv_setsv(PL_linestr,herewas); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; } else sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */ @@ -6275,6 +6433,7 @@ S_scan_heredoc(pTHX_ register char *s) } CopLINE_inc(PL_curcop); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; #ifndef PERL_STRICT_CR if (PL_bufend - PL_linestart >= 2) { if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') || @@ -6316,6 +6475,8 @@ retval: Renew(SvPVX(tmpstr), SvLEN(tmpstr), char); } SvREFCNT_dec(herewas); + if (UTF && !IN_BYTE && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr))) + SvUTF8_on(tmpstr); PL_lex_stuff = tmpstr; yylval.ival = op_type; return s; @@ -6466,31 +6627,30 @@ S_scan_inputsymbol(pTHX_ char *start) calls scan_str(). s/// makes yylex() call scan_subst() which calls scan_str(). tr/// and y/// make yylex() call scan_trans() which calls scan_str(). - + It skips whitespace before the string starts, and treats the first character as the delimiter. If the delimiter is one of ([{< then the corresponding "close" character )]}> is used as the closing delimiter. It allows quoting of delimiters, and if the string has balanced delimiters ([{<>}]) it allows nesting. - The lexer always reads these strings into lex_stuff, except in the - case of the operators which take *two* arguments (s/// and tr///) - when it checks to see if lex_stuff is full (presumably with the 1st - arg to s or tr) and if so puts the string into lex_repl. - + On success, the SV with the resulting string is put into lex_stuff or, + if that is already non-NULL, into lex_repl. The second case occurs only + when parsing the RHS of the special constructs s/// and tr/// (y///). + For convenience, the terminating delimiter character is stuffed into + SvIVX of the SV. */ STATIC char * S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) { - dTHR; SV *sv; /* scalar value: string */ char *tmps; /* temp string, used for delimiter matching */ register char *s = start; /* current position in the buffer */ register char term; /* terminating character */ register char *to; /* current position in the sv's data */ I32 brackets = 1; /* bracket nesting level */ - bool has_utf = FALSE; /* is there any utf8 content? */ + bool has_utf8 = FALSE; /* is there any utf8 content? */ /* skip space before the delimiter */ if (isSPACE(*s)) @@ -6501,8 +6661,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) /* after skipping whitespace, the next character is the terminator */ term = *s; - if ((term & 0x80) && UTF) - has_utf = TRUE; + if (UTF8_IS_CONTINUED(term) && UTF) + has_utf8 = TRUE; /* mark where we are */ PL_multi_start = CopLINE(PL_curcop); @@ -6548,8 +6708,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) have found the terminator */ else if (*s == term) break; - else if (!has_utf && (*s & 0x80) && UTF) - has_utf = TRUE; + else if (!has_utf8 && UTF8_IS_CONTINUED(*s) && UTF) + has_utf8 = TRUE; *to = *s; } } @@ -6577,8 +6737,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) break; else if (*s == PL_multi_open) brackets++; - else if (!has_utf && (*s & 0x80) && UTF) - has_utf = TRUE; + else if (!has_utf8 && UTF8_IS_CONTINUED(*s) && UTF) + has_utf8 = TRUE; *to = *s; } } @@ -6632,13 +6792,14 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) /* having changed the buffer, we must update PL_bufend */ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; } - + /* at this point, we have successfully read the delimited string */ if (keep_delims) sv_catpvn(sv, s, 1); - if (has_utf) + if (has_utf8) SvUTF8_on(sv); PL_multi_end = CopLINE(PL_curcop); s++; @@ -6652,7 +6813,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) /* decide whether this is the first or second quoted string we've read for this op */ - + if (PL_lex_stuff) PL_lex_repl = sv; else @@ -6681,14 +6842,14 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) try converting the number to an integer and see if it can do so without loss of precision. */ - + char * -Perl_scan_num(pTHX_ char *start) +Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) { register char *s = start; /* current position in buffer */ register char *d; /* destination in temp buffer */ register char *e; /* end of temp buffer */ - NV value; /* number read, as a double */ + NV nv; /* number read, as a double */ SV *sv = Nullsv; /* place to put the converted number */ bool floatit; /* boolean: int or float? */ char *lastub = 0; /* position of last underbar */ @@ -6699,7 +6860,7 @@ Perl_scan_num(pTHX_ char *start) switch (*s) { default: Perl_croak(aTHX_ "panic: scan_num"); - + /* if it starts with a 0, it could be an octal number, a decimal in 0.13 disguise, or a hexadecimal number, or a binary number. */ case '0': @@ -6714,7 +6875,6 @@ Perl_scan_num(pTHX_ char *start) we in octal/hex/binary?" indicator to disallow hex characters when in octal mode. */ - dTHR; NV n = 0.0; UV u = 0; I32 shift; @@ -6802,7 +6962,6 @@ Perl_scan_num(pTHX_ char *start) if ((x >> shift) != u && !(PL_hints & HINT_NEW_BINARY)) { - dTHR; overflowed = TRUE; n = (NV) u; if (ckWARN_d(WARN_OVERFLOW)) @@ -6834,7 +6993,6 @@ Perl_scan_num(pTHX_ char *start) out: sv = NEWSV(92,0); if (overflowed) { - dTHR; if (ckWARN(WARN_PORTABLE) && n > 4294967295.0) Perl_warner(aTHX_ WARN_PORTABLE, "%s number > %s non-portable", @@ -6843,7 +7001,6 @@ Perl_scan_num(pTHX_ char *start) } else { #if UVSIZE > 4 - dTHR; if (ckWARN(WARN_PORTABLE) && u > 0xffffffff) Perl_warner(aTHX_ WARN_PORTABLE, "%s number > %s non-portable", @@ -6869,11 +7026,10 @@ Perl_scan_num(pTHX_ char *start) /* read next group of digits and _ and copy into d */ while (isDIGIT(*s) || *s == '_') { - /* skip underscores, checking for misplaced ones + /* skip underscores, checking for misplaced ones if -w is on */ if (*s == '_') { - dTHR; /* only for ckWARN */ if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3) Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number"); lastub = ++s; @@ -6889,7 +7045,6 @@ Perl_scan_num(pTHX_ char *start) /* final misplaced underbar check */ if (lastub && s - lastub != 3) { - dTHR; if (ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number"); } @@ -6945,40 +7100,9 @@ Perl_scan_num(pTHX_ char *start) /* make an sv from the string */ sv = NEWSV(92,0); - /* unfortunately this monster needs to be on one line or - makedepend will be confused. */ -#if (defined(USE_64_BIT_INT) && (!defined(HAS_STRTOLL)|| !defined(HAS_STRTOULL))) || (!defined(USE_64_BIT_INT) && (!defined(HAS_STRTOL) || !defined(HAS_STRTOUL))) +#if defined(Strtol) && defined(Strtoul) /* - No working strto[u]l[l]. Since atoi() doesn't do range checks, - we need to do this the hard way. - */ - - value = Atof(PL_tokenbuf); - - /* - See if we can make do with an integer value without loss of - precision. We use I_V to cast to an int, because some - compilers have issues. Then we try casting it back and see - if it was the same. We only do this if we know we - specifically read an integer. - - Note: if floatit is true, then we don't need to do the - conversion at all. - */ - { - UV tryuv = U_V(value); - if (!floatit && (NV)tryuv == value) { - if (tryuv <= IV_MAX) - sv_setiv(sv, (IV)tryuv); - else - sv_setuv(sv, tryuv); - } - else - sv_setnv(sv, value); - } -#else - /* strtol/strtoll sets errno to ERANGE if the number is too big for an integer. We try to do an integer conversion first if no characters indicating "float" have been found. @@ -6993,20 +7117,71 @@ Perl_scan_num(pTHX_ char *start) else uv = Strtoul(PL_tokenbuf, (char**)NULL, 10); if (errno) - floatit = TRUE; /* probably just too large */ + floatit = TRUE; /* Probably just too large. */ else if (*PL_tokenbuf == '-') sv_setiv(sv, iv); + else if (uv <= IV_MAX) + sv_setiv(sv, uv); /* Prefer IVs over UVs. */ else sv_setuv(sv, uv); } if (floatit) { - value = Atof(PL_tokenbuf); - sv_setnv(sv, value); + nv = Atof(PL_tokenbuf); + sv_setnv(sv, nv); + } +#else + /* + No working strtou?ll?. + + Unfortunately atol() doesn't do range checks (returning + LONG_MIN/LONG_MAX, and setting errno to ERANGE on overflows) + everywhere [1], so we cannot use use atol() (or atoll()). + If we could, they would be used, as Atol(), very much like + Strtol() and Strtoul() are used above. + + [1] XXX Configure test needed to check for atol() + (and atoll()) overflow behaviour XXX + + --jhi + + We need to do this the hard way. */ + + nv = Atof(PL_tokenbuf); + + /* See if we can make do with an integer value without loss of + precision. We use U_V to cast to a UV, because some + compilers have issues. Then we try casting it back and see + if it was the same [1]. We only do this if we know we + specifically read an integer. If floatit is true, then we + don't need to do the conversion at all. + + [1] Note that this is lossy if our NVs cannot preserve our + UVs. There are metaconfig defines NV_PRESERVES_UV (a boolean) + and NV_PRESERVES_UV_BITS (a number), but in general we really + do hope all such potentially lossy platforms have strtou?ll? + to do a lossless IV/UV conversion. + + Maybe could do some tricks with DBL_DIG, LDBL_DIG and + DBL_MANT_DIG and LDBL_MANT_DIG (these are already available + as NV_DIG and NV_MANT_DIG)? + + --jhi + */ + { + UV uv = U_V(nv); + if (!floatit && (NV)uv == nv) { + if (uv <= IV_MAX) + sv_setiv(sv, uv); /* Prefer IVs over UVs. */ + else + sv_setuv(sv, uv); + } + else + sv_setnv(sv, nv); } #endif if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) - sv = new_constant(PL_tokenbuf, d - PL_tokenbuf, + sv = new_constant(PL_tokenbuf, d - PL_tokenbuf, (floatit ? "float" : "integer"), sv, Nullsv, NULL); break; @@ -7021,7 +7196,7 @@ vstring: pos++; if (!isALPHA(*pos)) { UV rev; - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; U8 *tmpend; bool utf8 = FALSE; s++; /* get past 'v' */ @@ -7066,7 +7241,8 @@ vstring: SvREADONLY_on(sv); if (utf8) { SvUTF8_on(sv); - sv_utf8_downgrade(sv, TRUE); + if (!UTF||IN_BYTE) + sv_utf8_downgrade(sv, TRUE); } } } @@ -7076,9 +7252,9 @@ vstring: /* make the op for the constant and return */ if (sv) - yylval.opval = newSVOP(OP_CONST, 0, sv); + lvalp->opval = newSVOP(OP_CONST, 0, sv); else - yylval.opval = Nullop; + lvalp->opval = Nullop; return s; } @@ -7086,19 +7262,18 @@ vstring: STATIC char * S_scan_formline(pTHX_ register char *s) { - dTHR; register char *eol; register char *t; SV *stuff = newSVpvn("",0); bool needargs = FALSE; while (!needargs) { - if (*s == '.' || *s == '}') { + if (*s == '.' || *s == /*{*/'}') { /*SUPPRESS 530*/ #ifdef PERL_STRICT_CR - for (t = s+1;*t == ' ' || *t == '\t'; t++) ; + for (t = s+1;SPACE_OR_TAB(*t); t++) ; #else - for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ; + for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ; #endif if (*t == '\n' || t == PL_bufend) break; @@ -7134,6 +7309,7 @@ S_scan_formline(pTHX_ register char *s) s = filter_gets(PL_linestr, PL_rsfp, 0); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); PL_bufend = PL_bufptr + SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; if (!s) { s = PL_bufptr; yyerror("Format not terminated"); @@ -7177,7 +7353,6 @@ S_set_csh(pTHX) I32 Perl_start_subparse(pTHX_ I32 is_format, U32 flags) { - dTHR; I32 oldsavestack_ix = PL_savestack_ix; CV* outsidecv = PL_compcv; AV* comppadlist; @@ -7230,10 +7405,12 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) return oldsavestack_ix; } +#ifdef __SC__ +#pragma segment Perl_yylex +#endif int Perl_yywarn(pTHX_ char *s) { - dTHR; PL_in_eval |= EVAL_WARNONLY; yyerror(s); PL_in_eval &= ~EVAL_WARNONLY; @@ -7243,7 +7420,6 @@ Perl_yywarn(pTHX_ char *s) int Perl_yyerror(pTHX_ char *s) { - dTHR; char *where = NULL; char *context = NULL; int contlen = -1; @@ -7310,7 +7486,7 @@ Perl_yyerror(pTHX_ char *s) qerror(msg); if (PL_error_count >= 10) { if (PL_in_eval && SvCUR(ERRSV)) - Perl_croak(aTHX_ "%_%s has too many errors.\n", + Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n", ERRSV, CopFILE(PL_curcop)); else Perl_croak(aTHX_ "%s has too many errors.\n", @@ -7320,7 +7496,86 @@ Perl_yyerror(pTHX_ char *s) PL_in_my_stash = Nullhv; return 0; } +#ifdef __SC__ +#pragma segment Main +#endif + +STATIC char* +S_swallow_bom(pTHX_ U8 *s) +{ + STRLEN slen; + slen = SvCUR(PL_linestr); + switch (*s) { + case 0xFF: + if (s[1] == 0xFE) { + /* UTF-16 little-endian */ + if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */ + Perl_croak(aTHX_ "Unsupported script encoding"); +#ifndef PERL_NO_UTF16_FILTER + DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n")); + s += 2; + if (PL_bufend > (char*)s) { + U8 *news; + I32 newlen; + + filter_add(utf16rev_textfilter, NULL); + New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); + PL_bufend = (char*)utf16_to_utf8_reversed(s, news, + PL_bufend - (char*)s - 1, + &newlen); + Copy(news, s, newlen, U8); + SvCUR_set(PL_linestr, newlen); + PL_bufend = SvPVX(PL_linestr) + newlen; + news[newlen++] = '\0'; + Safefree(news); + } +#else + Perl_croak(aTHX_ "Unsupported script encoding"); +#endif + } + break; + + case 0xFE: + if (s[1] == 0xFF) { /* UTF-16 big-endian */ +#ifndef PERL_NO_UTF16_FILTER + DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n")); + s += 2; + if (PL_bufend > (char *)s) { + U8 *news; + I32 newlen; + + filter_add(utf16_textfilter, NULL); + New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); + PL_bufend = (char*)utf16_to_utf8(s, news, + PL_bufend - (char*)s, + &newlen); + Copy(news, s, newlen, U8); + SvCUR_set(PL_linestr, newlen); + PL_bufend = SvPVX(PL_linestr) + newlen; + news[newlen++] = '\0'; + Safefree(news); + } +#else + Perl_croak(aTHX_ "Unsupported script encoding"); +#endif + } + break; + case 0xEF: + if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) { + DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n")); + s += 3; /* UTF-8 */ + } + break; + case 0: + if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */ + s[2] == 0xFE && s[3] == 0xFF) + { + Perl_croak(aTHX_ "Unsupported script encoding"); + } + } + return (char*)s; +} #ifdef PERL_OBJECT #include "XSUB.h" @@ -7342,3 +7597,43 @@ restore_rsfp(pTHXo_ void *f) PerlIO_close(PL_rsfp); PL_rsfp = fp; } + +#ifndef PERL_NO_UTF16_FILTER +static I32 +utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen) +{ + I32 count = FILTER_READ(idx+1, sv, maxlen); + if (count) { + U8* tmps; + U8* tend; + I32 newlen; + New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8); + if (!*SvPV_nolen(sv)) + /* Game over, but don't feed an odd-length string to utf16_to_utf8 */ + return count; + + tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen); + sv_usepvn(sv, (char*)tmps, tend - tmps); + } + return count; +} + +static I32 +utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen) +{ + I32 count = FILTER_READ(idx+1, sv, maxlen); + if (count) { + U8* tmps; + U8* tend; + I32 newlen; + if (!*SvPV_nolen(sv)) + /* Game over, but don't feed an odd-length string to utf16_to_utf8 */ + return count; + + New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8); + tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen); + sv_usepvn(sv, (char*)tmps, tend - tmps); + } + return count; +} +#endif diff --git a/contrib/perl5/universal.c b/contrib/perl5/universal.c index fc0ec41fb79f..12d31e58b151 100644 --- a/contrib/perl5/universal.c +++ b/contrib/perl5/universal.c @@ -14,29 +14,44 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level) GV* gv; GV** gvp; HV* hv = Nullhv; + SV* subgen = Nullsv; if (!stash) return &PL_sv_undef; - if(strEQ(HvNAME(stash), name)) + if (strEQ(HvNAME(stash), name)) return &PL_sv_yes; if (level > 100) - Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", HvNAME(stash)); + Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", + HvNAME(stash)); gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE); - if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv))) { - SV* sv; - SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); - if (svp && (sv = *svp) != (SV*)&PL_sv_undef) - return sv; + if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv)) + && (hv = GvHV(gv))) + { + if (SvIV(subgen) == PL_sub_generation) { + SV* sv; + SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); + if (svp && (sv = *svp) != (SV*)&PL_sv_undef) { + DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n", + name, HvNAME(stash)) ); + return sv; + } + } + else { + DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n", + HvNAME(stash)) ); + hv_clear(hv); + sv_setiv(subgen, PL_sub_generation); + } } gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); - + if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { - if(!hv) { + if (!hv || !subgen) { gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE); gv = *gvp; @@ -44,9 +59,14 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level) if (SvTYPE(gv) != SVt_PVGV) gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE); - hv = GvHVn(gv); + if (!hv) + hv = GvHVn(gv); + if (!subgen) { + subgen = newSViv(PL_sub_generation); + GvSV(gv) = subgen; + } } - if(hv) { + if (hv) { SV** svp = AvARRAY(av); /* NOTE: No support for tied ISA */ I32 items = AvFILLp(av) + 1; @@ -54,14 +74,13 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level) SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { - dTHR; if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ WARN_SYNTAX, "Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); continue; } - if(&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) { + if (&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) { (void)hv_store(hv,name,len,&PL_sv_yes,0); return &PL_sv_yes; } @@ -88,23 +107,23 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name) { char *type; HV *stash; - + stash = Nullhv; type = Nullch; - + if (SvGMAGICAL(sv)) mg_get(sv) ; if (SvROK(sv)) { sv = SvRV(sv); type = sv_reftype(sv,0); - if(SvOBJECT(sv)) + if (SvOBJECT(sv)) stash = SvSTASH(sv); } else { stash = gv_stashsv(sv, FALSE); } - + return (type && strEQ(type,name)) || (stash && isa_lookup(stash, name, strlen(name), 0) == &PL_sv_yes) ? TRUE @@ -174,9 +193,9 @@ XS(XS_UNIVERSAL_can) name = (char *)SvPV(ST(1),n_a); rv = &PL_sv_undef; - if(SvROK(sv)) { + if (SvROK(sv)) { sv = (SV*)SvRV(sv); - if(SvOBJECT(sv)) + if (SvOBJECT(sv)) pkg = SvSTASH(sv); } else { @@ -242,12 +261,12 @@ XS(XS_UNIVERSAL_VERSION) break; } if (len) { - if (SvNIOKp(req) && SvPOK(req)) { + if (SvNOK(req) && SvPOK(req)) { /* they said C<use Foo v1.2.3> and $Foo::VERSION * doesn't look like a float: do string compare */ if (sv_cmp(req,sv) == 1) { - Perl_croak(aTHX_ "%s v%vd required--" - "this is only v%vd", + Perl_croak(aTHX_ "%s v%"VDf" required--" + "this is only v%"VDf, HvNAME(pkg), req, sv); } goto finish; @@ -263,7 +282,7 @@ XS(XS_UNIVERSAL_VERSION) /* if we get here, we're looking for a numeric comparison, * so force the required version into a float, even if they * said C<use Foo v1.2.3> */ - if (SvNIOKp(req) && SvPOK(req)) { + if (SvNOK(req) && SvPOK(req)) { NV n = SvNV(req); req = sv_newmortal(); sv_setnv(req, n); diff --git a/contrib/perl5/unixish.h b/contrib/perl5/unixish.h index 1168d297b6f4..ca0ab933c201 100644 --- a/contrib/perl5/unixish.h +++ b/contrib/perl5/unixish.h @@ -125,11 +125,7 @@ # ifdef POSIX_BC # define PERL_SYS_INIT(c,v) sigignore(SIGFPE); MALLOC_INIT # else -# ifdef __CYGWIN__ -# define PERL_SYS_INIT(c,v) Perl_my_setenv_init(&environ); MALLOC_INIT -# else -# define PERL_SYS_INIT(c,v) MALLOC_INIT -# endif +# define PERL_SYS_INIT(c,v) MALLOC_INIT # endif #endif #endif @@ -141,3 +137,6 @@ #define BIT_BUCKET "/dev/null" #define dXSUB_SYS + +#define USE_ENVIRON_ARRAY + diff --git a/contrib/perl5/utf8.c b/contrib/perl5/utf8.c index 223f5ac6340e..077d36df172a 100644 --- a/contrib/perl5/utf8.c +++ b/contrib/perl5/utf8.c @@ -1,6 +1,6 @@ /* utf8.c * - * Copyright (c) 1998-2000, Larry Wall + * Copyright (c) 1998-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. @@ -26,6 +26,23 @@ /* Unicode support */ +/* +=for apidoc A|U8*|uv_to_utf8|U8 *d|UV uv + +Adds the UTF8 representation of the Unicode codepoint C<uv> to the end +of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free +bytes available. The return value is the pointer to the byte after the +end of the new character. In other words, + + d = uv_to_utf8(d, uv); + +is the recommended Unicode-aware way of saying + + *(d++) = uv; + +=cut +*/ + U8 * Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) { @@ -69,7 +86,7 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) return d; } #ifdef HAS_QUAD - if (uv < 0x1000000000LL) + if (uv < UTF8_QUAD_MAX) #endif { *d++ = 0xfe; /* Can't match U+FEFF! */ @@ -101,111 +118,415 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) #endif } -/* Tests if some arbitrary number of bytes begins in a valid UTF-8 character. - * The actual number of bytes in the UTF-8 character will be returned if it - * is valid, otherwise 0. */ -int +/* +=for apidoc A|STRLEN|is_utf8_char|U8 *s + +Tests if some arbitrary number of bytes begins in a valid UTF-8 character. +The actual number of bytes in the UTF-8 character will be returned if it +is valid, otherwise 0. + +=cut +*/ +STRLEN Perl_is_utf8_char(pTHX_ U8 *s) { U8 u = *s; - int slen, len; + STRLEN slen, len; + UV uv, ouv; - if (!(u & 0x80)) + if (UTF8_IS_ASCII(u)) return 1; - if (!(u & 0x40)) + if (!UTF8_IS_START(u)) return 0; - if (!(u & 0x20)) { len = 2; } - else if (!(u & 0x10)) { len = 3; } - else if (!(u & 0x08)) { len = 4; } - else if (!(u & 0x04)) { len = 5; } - else if (!(u & 0x02)) { len = 6; } - else if (!(u & 0x01)) { len = 7; } - else { len = 13; } /* whoa! */ + len = UTF8SKIP(s); + + if (len < 2 || !UTF8_IS_CONTINUATION(s[1])) + return 0; slen = len - 1; s++; + uv = u; + ouv = uv; while (slen--) { - if ((*s & 0xc0) != 0x80) + if (!UTF8_IS_CONTINUATION(*s)) return 0; + uv = UTF8_ACCUMULATE(uv, *s); + if (uv < ouv) + return 0; + ouv = uv; s++; } + + if (UNISKIP(uv) < len) + return 0; + return len; } +/* +=for apidoc A|bool|is_utf8_string|U8 *s|STRLEN len + +Returns true if first C<len> bytes of the given string form valid a UTF8 +string, false otherwise. + +=cut +*/ + +bool +Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len) +{ + U8* x = s; + U8* send; + STRLEN c; + + if (!len) + len = strlen((char *)s); + send = s + len; + + while (x < send) { + c = is_utf8_char(x); + if (!c) + return FALSE; + x += c; + } + if (x != send) + return FALSE; + + return TRUE; +} + +/* +=for apidoc A|U8* s|utf8_to_uv|STRLEN curlen|STRLEN *retlen|U32 flags + +Returns the character value of the first character in the string C<s> +which is assumed to be in UTF8 encoding and no longer than C<curlen>; +C<retlen> will be set to the length, in bytes, of that character. + +If C<s> does not point to a well-formed UTF8 character, the behaviour +is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY, +it is assumed that the caller will raise a warning, and this function +will silently just set C<retlen> to C<-1> and return zero. If the +C<flags> does not contain UTF8_CHECK_ONLY, warnings about +malformations will be given, C<retlen> will be set to the expected +length of the UTF-8 character in bytes, and zero will be returned. + +The C<flags> can also contain various flags to allow deviations from +the strict UTF-8 encoding (see F<utf8.h>). + +=cut */ + UV -Perl_utf8_to_uv(pTHX_ U8* s, I32* retlen) +Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags) { - UV uv = *s; - int len; - if (!(uv & 0x80)) { - if (retlen) - *retlen = 1; - return *s; + UV uv = *s, ouv; + STRLEN len = 1; +#ifdef EBCDIC + bool dowarn = 0; +#else + bool dowarn = ckWARN_d(WARN_UTF8); +#endif + STRLEN expectlen = 0; + U32 warning = 0; + +/* This list is a superset of the UTF8_ALLOW_XXX. */ + +#define UTF8_WARN_EMPTY 1 +#define UTF8_WARN_CONTINUATION 2 +#define UTF8_WARN_NON_CONTINUATION 3 +#define UTF8_WARN_FE_FF 4 +#define UTF8_WARN_SHORT 5 +#define UTF8_WARN_OVERFLOW 6 +#define UTF8_WARN_SURROGATE 7 +#define UTF8_WARN_BOM 8 +#define UTF8_WARN_LONG 9 +#define UTF8_WARN_FFFF 10 + + if (curlen == 0 && + !(flags & UTF8_ALLOW_EMPTY)) { + warning = UTF8_WARN_EMPTY; + goto malformed; } - if (!(uv & 0x40)) { - dTHR; - if (ckWARN_d(WARN_UTF8)) - Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); + + if (UTF8_IS_ASCII(uv)) { if (retlen) *retlen = 1; return *s; } - if (!(uv & 0x20)) { len = 2; uv &= 0x1f; } - else if (!(uv & 0x10)) { len = 3; uv &= 0x0f; } - else if (!(uv & 0x08)) { len = 4; uv &= 0x07; } - else if (!(uv & 0x04)) { len = 5; uv &= 0x03; } - else if (!(uv & 0x02)) { len = 6; uv &= 0x01; } - else if (!(uv & 0x01)) { len = 7; uv = 0; } - else { len = 13; uv = 0; } /* whoa! */ + if (UTF8_IS_CONTINUATION(uv) && + !(flags & UTF8_ALLOW_CONTINUATION)) { + warning = UTF8_WARN_CONTINUATION; + goto malformed; + } + if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) && + !(flags & UTF8_ALLOW_NON_CONTINUATION)) { + warning = UTF8_WARN_NON_CONTINUATION; + goto malformed; + } + + if ((uv == 0xfe || uv == 0xff) && + !(flags & UTF8_ALLOW_FE_FF)) { + warning = UTF8_WARN_FE_FF; + goto malformed; + } + + if (!(uv & 0x20)) { len = 2; uv &= 0x1f; } + else if (!(uv & 0x10)) { len = 3; uv &= 0x0f; } + else if (!(uv & 0x08)) { len = 4; uv &= 0x07; } + else if (!(uv & 0x04)) { len = 5; uv &= 0x03; } + else if (!(uv & 0x02)) { len = 6; uv &= 0x01; } + else if (!(uv & 0x01)) { len = 7; uv = 0; } + else { len = 13; uv = 0; } /* whoa! */ + if (retlen) *retlen = len; - --len; + + expectlen = len; + + if ((curlen < expectlen) && + !(flags & UTF8_ALLOW_SHORT)) { + warning = UTF8_WARN_SHORT; + goto malformed; + } + + len--; s++; + ouv = uv; + while (len--) { - if ((*s & 0xc0) != 0x80) { - dTHR; - if (ckWARN_d(WARN_UTF8)) - Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); - if (retlen) - *retlen -= len + 1; - return 0xfffd; + if (!UTF8_IS_CONTINUATION(*s) && + !(flags & UTF8_ALLOW_NON_CONTINUATION)) { + s--; + warning = UTF8_WARN_NON_CONTINUATION; + goto malformed; } else - uv = (uv << 6) | (*s++ & 0x3f); + uv = UTF8_ACCUMULATE(uv, *s); + if (!(uv > ouv)) { + /* These cannot be allowed. */ + if (uv == ouv) { + if (!(flags & UTF8_ALLOW_LONG)) { + warning = UTF8_WARN_LONG; + goto malformed; + } + } + else { /* uv < ouv */ + /* This cannot be allowed. */ + warning = UTF8_WARN_OVERFLOW; + goto malformed; + } + } + s++; + ouv = uv; } + + if (UNICODE_IS_SURROGATE(uv) && + !(flags & UTF8_ALLOW_SURROGATE)) { + warning = UTF8_WARN_SURROGATE; + goto malformed; + } else if (UNICODE_IS_BYTE_ORDER_MARK(uv) && + !(flags & UTF8_ALLOW_BOM)) { + warning = UTF8_WARN_BOM; + goto malformed; + } else if ((expectlen > UNISKIP(uv)) && + !(flags & UTF8_ALLOW_LONG)) { + warning = UTF8_WARN_LONG; + goto malformed; + } else if (UNICODE_IS_ILLEGAL(uv) && + !(flags & UTF8_ALLOW_FFFF)) { + warning = UTF8_WARN_FFFF; + goto malformed; + } + return uv; + +malformed: + + if (flags & UTF8_CHECK_ONLY) { + if (retlen) + *retlen = -1; + return 0; + } + + if (dowarn) { + SV* sv = sv_2mortal(newSVpv("Malformed UTF-8 character ", 0)); + + switch (warning) { + case 0: /* Intentionally empty. */ break; + case UTF8_WARN_EMPTY: + Perl_sv_catpvf(aTHX_ sv, "(empty string)"); + break; + case UTF8_WARN_CONTINUATION: + Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf")", uv); + break; + case UTF8_WARN_NON_CONTINUATION: + Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf" after start byte 0x%02"UVxf")", + (UV)s[1], uv); + break; + case UTF8_WARN_FE_FF: + Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv); + break; + case UTF8_WARN_SHORT: + Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d)", + curlen, curlen == 1 ? "" : "s", expectlen); + break; + case UTF8_WARN_OVERFLOW: + Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x)", + ouv, *s); + break; + case UTF8_WARN_SURROGATE: + Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv); + break; + case UTF8_WARN_BOM: + Perl_sv_catpvf(aTHX_ sv, "(byte order mark 0x%04"UVxf")", uv); + break; + case UTF8_WARN_LONG: + Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d)", + expectlen, expectlen == 1 ? "": "s", UNISKIP(uv)); + break; + case UTF8_WARN_FFFF: + Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv); + break; + default: + Perl_sv_catpvf(aTHX_ sv, "(unknown reason)"); + break; + } + + if (warning) { + char *s = SvPVX(sv); + + if (PL_op) + Perl_warner(aTHX_ WARN_UTF8, + "%s in %s", s, PL_op_desc[PL_op->op_type]); + else + Perl_warner(aTHX_ WARN_UTF8, "%s", s); + } + } + + if (retlen) + *retlen = expectlen ? expectlen : len; + + return 0; } -/* utf8_distance(a,b) is intended to be a - b in pointer arithmetic */ +/* +=for apidoc A|U8* s|utf8_to_uv_simple|STRLEN *retlen + +Returns the character value of the first character in the string C<s> +which is assumed to be in UTF8 encoding; C<retlen> will be set to the +length, in bytes, of that character. + +If C<s> does not point to a well-formed UTF8 character, zero is +returned and retlen is set, if possible, to -1. + +=cut +*/ + +UV +Perl_utf8_to_uv_simple(pTHX_ U8* s, STRLEN* retlen) +{ + return Perl_utf8_to_uv(aTHX_ s, UTF8_MAXLEN, retlen, 0); +} -I32 +/* +=for apidoc A|STRLEN|utf8_length|U8* s|U8 *e + +Return the length of the UTF-8 char encoded string C<s> in characters. +Stops at C<e> (inclusive). If C<e E<lt> s> or if the scan would end +up past C<e>, croaks. + +=cut +*/ + +STRLEN +Perl_utf8_length(pTHX_ U8* s, U8* e) +{ + STRLEN len = 0; + + /* Note: cannot use UTF8_IS_...() too eagerly here since e.g. + * the bitops (especially ~) can create illegal UTF-8. + * In other words: in Perl UTF-8 is not just for Unicode. */ + + if (e < s) + Perl_croak(aTHX_ "panic: utf8_length: unexpected end"); + while (s < e) { + U8 t = UTF8SKIP(s); + + if (e - s < t) + Perl_croak(aTHX_ "panic: utf8_length: unaligned end"); + s += t; + len++; + } + + return len; +} + +/* +=for apidoc A|IV|utf8_distance|U8 *a|U8 *b + +Returns the number of UTF8 characters between the UTF-8 pointers C<a> +and C<b>. + +WARNING: use only if you *know* that the pointers point inside the +same UTF-8 buffer. + +=cut */ + +IV Perl_utf8_distance(pTHX_ U8 *a, U8 *b) { - I32 off = 0; + IV off = 0; + + /* Note: cannot use UTF8_IS_...() too eagerly here since e.g. + * the bitops (especially ~) can create illegal UTF-8. + * In other words: in Perl UTF-8 is not just for Unicode. */ + if (a < b) { while (a < b) { - a += UTF8SKIP(a); + U8 c = UTF8SKIP(a); + + if (b - a < c) + Perl_croak(aTHX_ "panic: utf8_distance: unaligned end"); + a += c; off--; } } else { while (b < a) { - b += UTF8SKIP(b); + U8 c = UTF8SKIP(b); + + if (a - b < c) + Perl_croak(aTHX_ "panic: utf8_distance: unaligned end"); + b += c; off++; } } + return off; } -/* WARNING: do not use the following unless you *know* off is within bounds */ +/* +=for apidoc A|U8*|utf8_hop|U8 *s|I32 off + +Return the UTF-8 pointer C<s> displaced by C<off> characters, either +forward or backward. + +WARNING: do not use the following unless you *know* C<off> is within +the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned +on the first byte of character or just after the last byte of a character. + +=cut */ U8 * Perl_utf8_hop(pTHX_ U8 *s, I32 off) { + /* Note: cannot use UTF8_IS_...() too eagerly here since e.g + * the bitops (especially ~) can create illegal UTF-8. + * In other words: in Perl UTF-8 is not just for Unicode. */ + if (off >= 0) { while (off--) s += UTF8SKIP(s); @@ -213,28 +534,169 @@ Perl_utf8_hop(pTHX_ U8 *s, I32 off) else { while (off++) { s--; - if (*s & 0x80) { - while ((*s & 0xc0) == 0x80) - s--; - } + while (UTF8_IS_CONTINUATION(*s)) + s--; } } return s; } -/* XXX NOTHING CALLS THE FOLLOWING TWO ROUTINES YET!!! */ /* - * Convert native or reversed UTF-16 to UTF-8. +=for apidoc A|U8 *|utf8_to_bytes|U8 *s|STRLEN *len + +Converts a string C<s> of length C<len> from UTF8 into byte encoding. +Unlike C<bytes_to_utf8>, this over-writes the original string, and +updates len to contain the new length. +Returns zero on failure, setting C<len> to -1. + +=cut +*/ + +U8 * +Perl_utf8_to_bytes(pTHX_ U8* s, STRLEN *len) +{ + U8 *send; + U8 *d; + U8 *save = s; + + /* ensure valid UTF8 and chars < 256 before updating string */ + for (send = s + *len; s < send; ) { + U8 c = *s++; + + if (c >= 0x80 && + ((s >= send) || + ((*s++ & 0xc0) != 0x80) || ((c & 0xfe) != 0xc2))) { + *len = -1; + return 0; + } + } + + d = s = save; + while (s < send) { + if (UTF8_IS_ASCII(*s)) { + *d++ = *s++; + } + else { + STRLEN ulen; + *d++ = (U8)utf8_to_uv_simple(s, &ulen); + s += ulen; + } + } + *d = '\0'; + *len = d - save; + return save; +} + +/* +=for apidoc A|U8 *|bytes_from_utf8|U8 *s|STRLEN *len|bool *is_utf8 + +Converts a string C<s> of length C<len> from UTF8 into byte encoding. +Unlike <utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to +the newly-created string, and updates C<len> to contain the new +length. Returns the original string if no conversion occurs, C<len> +is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to +0 if C<s> is converted or contains all 7bit characters. + +=cut */ + +U8 * +Perl_bytes_from_utf8(pTHX_ U8* s, STRLEN *len, bool *is_utf8) +{ + U8 *send; + U8 *d; + U8 *start = s; + I32 count = 0; + + if (!*is_utf8) + return start; + + /* ensure valid UTF8 and chars < 256 before converting string */ + for (send = s + *len; s < send;) { + U8 c = *s++; + if (!UTF8_IS_ASCII(c)) { + if (UTF8_IS_CONTINUATION(c) || s >= send || + !UTF8_IS_CONTINUATION(*s) || UTF8_IS_DOWNGRADEABLE_START(c)) + return start; + s++, count++; + } + } + + *is_utf8 = 0; + + if (!count) + return start; + + Newz(801, d, (*len) - count + 1, U8); + s = start; start = d; + while (s < send) { + U8 c = *s++; + + if (UTF8_IS_ASCII(c)) + *d++ = c; + else + *d++ = UTF8_ACCUMULATE(c, *s++); + } + *d = '\0'; + *len = d - start; + return start; +} + +/* +=for apidoc A|U8 *|bytes_to_utf8|U8 *s|STRLEN *len + +Converts a string C<s> of length C<len> from ASCII into UTF8 encoding. +Returns a pointer to the newly-created string, and sets C<len> to +reflect the new length. + +=cut +*/ + +U8* +Perl_bytes_to_utf8(pTHX_ U8* s, STRLEN *len) +{ + U8 *send; + U8 *d; + U8 *dst; + send = s + (*len); + + Newz(801, d, (*len) * 2 + 1, U8); + dst = d; + + while (s < send) { + if (UTF8_IS_ASCII(*s)) + *d++ = *s++; + else { + UV uv = *s++; + + *d++ = UTF8_EIGHT_BIT_HI(uv); + *d++ = UTF8_EIGHT_BIT_LO(uv); + } + } + *d = '\0'; + *len = d-dst; + return dst; +} + +/* + * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8. * * Destination must be pre-extended to 3/2 source. Do not use in-place. * We optimize for native, for obvious reasons. */ U8* -Perl_utf16_to_utf8(pTHX_ U16* p, U8* d, I32 bytelen) +Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen) { - U16* pend = p + bytelen / 2; + U8* pend; + U8* dstart = d; + + if (bytelen & 1) + Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen"); + + pend = p + bytelen; + while (p < pend) { - UV uv = *p++; + UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */ + p += 2; if (uv < 0x80) { *d++ = uv; continue; @@ -245,14 +707,9 @@ Perl_utf16_to_utf8(pTHX_ U16* p, U8* d, I32 bytelen) continue; } if (uv >= 0xd800 && uv < 0xdbff) { /* surrogates */ - dTHR; - int low = *p++; - if (low < 0xdc00 || low >= 0xdfff) { - if (ckWARN_d(WARN_UTF8)) - Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-16 surrogate"); - p--; - uv = 0xfffd; - } + UV low = *p++; + if (low < 0xdc00 || low >= 0xdfff) + Perl_croak(aTHX_ "Malformed UTF-16 surrogate"); uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000; } if (uv < 0x10000) { @@ -269,13 +726,14 @@ Perl_utf16_to_utf8(pTHX_ U16* p, U8* d, I32 bytelen) continue; } } + *newlen = d - dstart; return d; } /* Note: this one is slightly destructive of the source. */ U8* -Perl_utf16_to_utf8_reversed(pTHX_ U16* p, U8* d, I32 bytelen) +Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen) { U8* s = (U8*)p; U8* send = s + bytelen; @@ -285,7 +743,7 @@ Perl_utf16_to_utf8_reversed(pTHX_ U16* p, U8* d, I32 bytelen) s[1] = tmp; s += 2; } - return utf16_to_utf8(p, d, bytelen); + return utf16_to_utf8(p, d, bytelen, newlen); } /* for now these are all defined (inefficiently) in terms of the utf8 versions */ @@ -293,7 +751,7 @@ Perl_utf16_to_utf8_reversed(pTHX_ U16* p, U8* d, I32 bytelen) bool Perl_is_uni_alnum(pTHX_ U32 c) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; uv_to_utf8(tmpbuf, (UV)c); return is_utf8_alnum(tmpbuf); } @@ -301,7 +759,7 @@ Perl_is_uni_alnum(pTHX_ U32 c) bool Perl_is_uni_alnumc(pTHX_ U32 c) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; uv_to_utf8(tmpbuf, (UV)c); return is_utf8_alnumc(tmpbuf); } @@ -309,7 +767,7 @@ Perl_is_uni_alnumc(pTHX_ U32 c) bool Perl_is_uni_idfirst(pTHX_ U32 c) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; uv_to_utf8(tmpbuf, (UV)c); return is_utf8_idfirst(tmpbuf); } @@ -317,7 +775,7 @@ Perl_is_uni_idfirst(pTHX_ U32 c) bool Perl_is_uni_alpha(pTHX_ U32 c) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; uv_to_utf8(tmpbuf, (UV)c); return is_utf8_alpha(tmpbuf); } @@ -325,7 +783,7 @@ Perl_is_uni_alpha(pTHX_ U32 c) bool Perl_is_uni_ascii(pTHX_ U32 c) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; uv_to_utf8(tmpbuf, (UV)c); return is_utf8_ascii(tmpbuf); } @@ -333,7 +791,7 @@ Perl_is_uni_ascii(pTHX_ U32 c) bool Perl_is_uni_space(pTHX_ U32 c) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; uv_to_utf8(tmpbuf, (UV)c); return is_utf8_space(tmpbuf); } @@ -341,7 +799,7 @@ Perl_is_uni_space(pTHX_ U32 c) bool Perl_is_uni_digit(pTHX_ U32 c) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; uv_to_utf8(tmpbuf, (UV)c); return is_utf8_digit(tmpbuf); } @@ -349,7 +807,7 @@ Perl_is_uni_digit(pTHX_ U32 c) bool Perl_is_uni_upper(pTHX_ U32 c) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; uv_to_utf8(tmpbuf, (UV)c); return is_utf8_upper(tmpbuf); } @@ -357,7 +815,7 @@ Perl_is_uni_upper(pTHX_ U32 c) bool Perl_is_uni_lower(pTHX_ U32 c) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; uv_to_utf8(tmpbuf, (UV)c); return is_utf8_lower(tmpbuf); } @@ -365,7 +823,7 @@ Perl_is_uni_lower(pTHX_ U32 c) bool Perl_is_uni_cntrl(pTHX_ U32 c) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; uv_to_utf8(tmpbuf, (UV)c); return is_utf8_cntrl(tmpbuf); } @@ -373,7 +831,7 @@ Perl_is_uni_cntrl(pTHX_ U32 c) bool Perl_is_uni_graph(pTHX_ U32 c) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; uv_to_utf8(tmpbuf, (UV)c); return is_utf8_graph(tmpbuf); } @@ -381,7 +839,7 @@ Perl_is_uni_graph(pTHX_ U32 c) bool Perl_is_uni_print(pTHX_ U32 c) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; uv_to_utf8(tmpbuf, (UV)c); return is_utf8_print(tmpbuf); } @@ -389,7 +847,7 @@ Perl_is_uni_print(pTHX_ U32 c) bool Perl_is_uni_punct(pTHX_ U32 c) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; uv_to_utf8(tmpbuf, (UV)c); return is_utf8_punct(tmpbuf); } @@ -397,7 +855,7 @@ Perl_is_uni_punct(pTHX_ U32 c) bool Perl_is_uni_xdigit(pTHX_ U32 c) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; uv_to_utf8(tmpbuf, (UV)c); return is_utf8_xdigit(tmpbuf); } @@ -405,7 +863,7 @@ Perl_is_uni_xdigit(pTHX_ U32 c) U32 Perl_to_uni_upper(pTHX_ U32 c) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; uv_to_utf8(tmpbuf, (UV)c); return to_utf8_upper(tmpbuf); } @@ -413,7 +871,7 @@ Perl_to_uni_upper(pTHX_ U32 c) U32 Perl_to_uni_title(pTHX_ U32 c) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; uv_to_utf8(tmpbuf, (UV)c); return to_utf8_title(tmpbuf); } @@ -421,7 +879,7 @@ Perl_to_uni_title(pTHX_ U32 c) U32 Perl_to_uni_lower(pTHX_ U32 c) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; uv_to_utf8(tmpbuf, (UV)c); return to_utf8_lower(tmpbuf); } @@ -536,7 +994,10 @@ Perl_is_utf8_alnum(pTHX_ U8 *p) if (!is_utf8_char(p)) return FALSE; if (!PL_utf8_alnum) - PL_utf8_alnum = swash_init("utf8", "IsAlnum", &PL_sv_undef, 0, 0); + /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true + * descendant of isalnum(3), in other words, it doesn't + * contain the '_'. --jhi */ + PL_utf8_alnum = swash_init("utf8", "IsWord", &PL_sv_undef, 0, 0); return swash_fetch(PL_utf8_alnum, p); /* return *p == '_' || is_utf8_alpha(p) || is_utf8_digit(p); */ #ifdef SURPRISINGLY_SLOWER /* probably because alpha is usually true */ @@ -596,7 +1057,7 @@ Perl_is_utf8_space(pTHX_ U8 *p) if (!is_utf8_char(p)) return FALSE; if (!PL_utf8_space) - PL_utf8_space = swash_init("utf8", "IsSpace", &PL_sv_undef, 0, 0); + PL_utf8_space = swash_init("utf8", "IsSpacePerl", &PL_sv_undef, 0, 0); return swash_fetch(PL_utf8_space, p); } @@ -698,7 +1159,7 @@ Perl_to_utf8_upper(pTHX_ U8 *p) if (!PL_utf8_toupper) PL_utf8_toupper = swash_init("utf8", "ToUpper", &PL_sv_undef, 4, 0); uv = swash_fetch(PL_utf8_toupper, p); - return uv ? uv : utf8_to_uv(p,0); + return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0); } UV @@ -709,7 +1170,7 @@ Perl_to_utf8_title(pTHX_ U8 *p) if (!PL_utf8_totitle) PL_utf8_totitle = swash_init("utf8", "ToTitle", &PL_sv_undef, 4, 0); uv = swash_fetch(PL_utf8_totitle, p); - return uv ? uv : utf8_to_uv(p,0); + return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0); } UV @@ -720,7 +1181,7 @@ Perl_to_utf8_lower(pTHX_ U8 *p) if (!PL_utf8_tolower) PL_utf8_tolower = swash_init("utf8", "ToLower", &PL_sv_undef, 4, 0); uv = swash_fetch(PL_utf8_tolower, p); - return uv ? uv : utf8_to_uv(p,0); + return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0); } /* a "swash" is a swatch hash */ @@ -729,8 +1190,8 @@ SV* Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none) { SV* retval; - char tmpbuf[256]; - dSP; + SV* tokenbufsv = sv_2mortal(NEWSV(0,0)); + dSP; if (!gv_stashpv(pkg, 0)) { /* demand load utf8 */ ENTER; @@ -751,16 +1212,20 @@ Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none) SAVEI32(PL_hints); PL_hints = 0; save_re_context(); - if (PL_curcop == &PL_compiling) /* XXX ought to be handled by lex_start */ - strncpy(tmpbuf, PL_tokenbuf, sizeof tmpbuf); + if (PL_curcop == &PL_compiling) + /* XXX ought to be handled by lex_start */ + sv_setpv(tokenbufsv, PL_tokenbuf); if (call_method("SWASHNEW", G_SCALAR)) - retval = newSVsv(*PL_stack_sp--); + retval = newSVsv(*PL_stack_sp--); else retval = &PL_sv_undef; LEAVE; POPSTACK; if (PL_curcop == &PL_compiling) { - strncpy(PL_tokenbuf, tmpbuf, sizeof tmpbuf); + STRLEN len; + char* pv = SvPV(tokenbufsv, len); + + Copy(pv, PL_tokenbuf, len+1, char); PL_curcop->op_private = PL_hints; } if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) @@ -810,11 +1275,11 @@ Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr) PUSHMARK(SP); EXTEND(SP,3); PUSHs((SV*)sv); - PUSHs(sv_2mortal(newSViv(utf8_to_uv(ptr, 0) & ~(needents - 1)))); + PUSHs(sv_2mortal(newSViv(utf8_to_uv(ptr, UTF8_MAXLEN, 0, 0) & ~(needents - 1)))); PUSHs(sv_2mortal(newSViv(needents))); PUTBACK; if (call_method("SWASHGET", G_SCALAR)) - retval = newSVsv(*PL_stack_sp--); + retval = newSVsv(*PL_stack_sp--); else retval = &PL_sv_undef; POPSTACK; @@ -837,7 +1302,7 @@ Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr) Copy(ptr, PL_last_swash_key, klen, U8); } - switch ((slen << 3) / needents) { + switch ((int)((slen << 3) / needents)) { case 1: bit = 1 << (off & 7); off >>= 3; diff --git a/contrib/perl5/utf8.h b/contrib/perl5/utf8.h index c37a9959efa4..d022e867bed5 100644 --- a/contrib/perl5/utf8.h +++ b/contrib/perl5/utf8.h @@ -1,6 +1,6 @@ /* utf8.h * - * Copyright (c) 1998-2000, Larry Wall + * Copyright (c) 1998-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,23 +29,105 @@ END_EXTERN_C #define UTF8_MAXLEN 13 /* how wide can a single UTF8 encoded character become */ -/*#define IN_UTF8 (PL_curcop->op_private & HINT_UTF8)*/ +/* #define IN_UTF8 (PL_curcop->op_private & HINT_UTF8) */ #define IN_BYTE (PL_curcop->op_private & HINT_BYTE) #define DO_UTF8(sv) (SvUTF8(sv) && !IN_BYTE) +#define UTF8_ALLOW_EMPTY 0x0001 +#define UTF8_ALLOW_CONTINUATION 0x0002 +#define UTF8_ALLOW_NON_CONTINUATION 0x0004 +#define UTF8_ALLOW_FE_FF 0x0008 +#define UTF8_ALLOW_SHORT 0x0010 +#define UTF8_ALLOW_SURROGATE 0x0020 +#define UTF8_ALLOW_BOM 0x0040 +#define UTF8_ALLOW_FFFF 0x0080 +#define UTF8_ALLOW_LONG 0x0100 +#define UTF8_ALLOW_ANYUV (UTF8_ALLOW_EMPTY|UTF8_ALLOW_FE_FF|\ + UTF8_ALLOW_SURROGATE|UTF8_ALLOW_BOM|\ + UTF8_ALLOW_FFFF|UTF8_ALLOW_LONG) +#define UTF8_ALLOW_ANY 0x00ff +#define UTF8_CHECK_ONLY 0x0100 + +#define UNICODE_SURROGATE_FIRST 0xd800 +#define UNICODE_SURROGATE_LAST 0xdfff +#define UNICODE_REPLACEMENT 0xfffd +#define UNICODE_BYTER_ORDER_MARK 0xfffe +#define UNICODE_ILLEGAL 0xffff + +#define UNICODE_IS_SURROGATE(c) ((c) >= UNICODE_SURROGATE_FIRST && \ + (c) <= UNICODE_SURROGATE_LAST) +#define UNICODE_IS_REPLACEMENT(c) ((c) == UNICODE_REPLACMENT) +#define UNICODE_IS_BYTE_ORDER_MARK(c) ((c) == UNICODE_BYTER_ORDER_MARK) +#define UNICODE_IS_ILLEGAL(c) ((c) == UNICODE_ILLEGAL) + #define UTF8SKIP(s) PL_utf8skip[*(U8*)s] +#define UTF8_QUAD_MAX UINT64_C(0x1000000000) + +/* + + The following table is from Unicode 3.1. + + Code Points 1st Byte 2nd Byte 3rd Byte 4th Byte + + U+0000..U+007F 00..7F + U+0080..U+07FF C2..DF 80..BF + U+0800..U+0FFF E0 A0..BF 80..BF + U+1000..U+FFFF E1..EF 80..BF 80..BF + U+10000..U+3FFFF F0 90..BF 80..BF 80..BF + U+40000..U+FFFFF F1..F3 80..BF 80..BF 80..BF + U+100000..U+10FFFF F4 80..8F 80..BF 80..BF + + */ + +#define UTF8_IS_ASCII(c) (((U8)c) < 0x80) +#define UTF8_IS_START(c) (((U8)c) >= 0xc0 && (((U8)c) <= 0xfd)) +#define UTF8_IS_CONTINUATION(c) (((U8)c) >= 0x80 && (((U8)c) <= 0xbf)) +#define UTF8_IS_CONTINUED(c) (((U8)c) & 0x80) +#define UTF8_IS_DOWNGRADEABLE_START(c) (((U8)c & 0xfc) != 0xc0) + +#define UTF8_CONTINUATION_MASK ((U8)0x3f) +#define UTF8_ACCUMULATION_SHIFT 6 +#define UTF8_ACCUMULATE(old, new) (((old) << UTF8_ACCUMULATION_SHIFT) | (((U8)new) & UTF8_CONTINUATION_MASK)) + +#define UTF8_EIGHT_BIT_HI(c) ( (((U8)(c))>>6) |0xc0) +#define UTF8_EIGHT_BIT_LO(c) (((((U8)(c)) )&0x3f)|0x80) + +#ifdef HAS_QUAD +#define UNISKIP(uv) ( (uv) < 0x80 ? 1 : \ + (uv) < 0x800 ? 2 : \ + (uv) < 0x10000 ? 3 : \ + (uv) < 0x200000 ? 4 : \ + (uv) < 0x4000000 ? 5 : \ + (uv) < 0x80000000 ? 6 : \ + (uv) < UTF8_QUAD_MAX ? 7 : 13 ) +#else +/* No, I'm not even going to *TRY* putting #ifdef inside a #define */ +#define UNISKIP(uv) ( (uv) < 0x80 ? 1 : \ + (uv) < 0x800 ? 2 : \ + (uv) < 0x10000 ? 3 : \ + (uv) < 0x200000 ? 4 : \ + (uv) < 0x4000000 ? 5 : \ + (uv) < 0x80000000 ? 6 : 7 ) +#endif + + /* * Note: we try to be careful never to call the isXXX_utf8() functions * unless we're pretty sure we've seen the beginning of a UTF-8 character * (that is, the two high bits are set). Otherwise we risk loading in the * heavy-duty SWASHINIT and SWASHGET routines unnecessarily. */ -#define isIDFIRST_lazy_if(p,c) ((!c || (*((U8*)p) < 0xc0)) \ +#ifdef EBCDIC +#define isIDFIRST_lazy_if(p,c) isIDFIRST(*(p)) +#define isALNUM_lazy_if(p,c) isALNUM(*(p)) +#else +#define isIDFIRST_lazy_if(p,c) ((IN_BYTE || (!c || (*((U8*)p) < 0xc0))) \ ? isIDFIRST(*(p)) \ : isIDFIRST_utf8((U8*)p)) -#define isALNUM_lazy_if(p,c) ((!c || (*((U8*)p) < 0xc0)) \ +#define isALNUM_lazy_if(p,c) ((IN_BYTE || (!c || (*((U8*)p) < 0xc0))) \ ? isALNUM(*(p)) \ : isALNUM_utf8((U8*)p)) +#endif #define isIDFIRST_lazy(p) isIDFIRST_lazy_if(p,1) #define isALNUM_lazy(p) isALNUM_lazy_if(p,1) diff --git a/contrib/perl5/util.c b/contrib/perl5/util.c index 059d9a45fc20..31aff21c5af6 100644 --- a/contrib/perl5/util.c +++ b/contrib/perl5/util.c @@ -1,6 +1,6 @@ /* util.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. @@ -24,11 +24,6 @@ # define SIG_ERR ((Sighandler_t) -1) #endif -/* XXX If this causes problems, set i_unistd=undef in the hint file. */ -#ifdef I_UNISTD -# include <unistd.h> -#endif - #ifdef I_VFORK # include <vfork.h> #endif @@ -464,7 +459,7 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit * Set up for a new ctype locale. */ void -Perl_new_ctype(pTHX_ const char *newctype) +Perl_new_ctype(pTHX_ char *newctype) { #ifdef USE_LOCALE_CTYPE @@ -483,10 +478,54 @@ Perl_new_ctype(pTHX_ const char *newctype) } /* + * Standardize the locale name from a string returned by 'setlocale'. + * + * The standard return value of setlocale() is either + * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL + * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL + * (the space-separated values represent the various sublocales, + * in some unspecificed order) + * + * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n", + * which is harmful for further use of the string in setlocale(). + * + */ +STATIC char * +S_stdize_locale(pTHX_ char *locs) +{ + char *s; + bool okay = TRUE; + + if ((s = strchr(locs, '='))) { + char *t; + + okay = FALSE; + if ((t = strchr(s, '.'))) { + char *u; + + if ((u = strchr(t, '\n'))) { + + if (u[1] == 0) { + STRLEN len = u - s; + Move(s + 1, locs, len, char); + locs[len] = 0; + okay = TRUE; + } + } + } + } + + if (!okay) + Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs); + + return locs; +} + +/* * Set up for a new collation locale. */ void -Perl_new_collate(pTHX_ const char *newcoll) +Perl_new_collate(pTHX_ char *newcoll) { #ifdef USE_LOCALE_COLLATE @@ -495,17 +534,17 @@ Perl_new_collate(pTHX_ const char *newcoll) ++PL_collation_ix; Safefree(PL_collation_name); PL_collation_name = NULL; - PL_collation_standard = TRUE; - PL_collxfrm_base = 0; - PL_collxfrm_mult = 2; } + PL_collation_standard = TRUE; + PL_collxfrm_base = 0; + PL_collxfrm_mult = 2; return; } if (! PL_collation_name || strNE(PL_collation_name, newcoll)) { ++PL_collation_ix; Safefree(PL_collation_name); - PL_collation_name = savepv(newcoll); + PL_collation_name = stdize_locale(savepv(newcoll)); PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX")); { @@ -534,13 +573,20 @@ Perl_set_numeric_radix(pTHX) struct lconv* lc; lc = localeconv(); - if (lc && lc->decimal_point) - /* We assume that decimal separator aka the radix - * character is always a single character. If it - * ever is a string, this needs to be rethunk. */ - PL_numeric_radix = *lc->decimal_point; + if (lc && lc->decimal_point) { + if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) { + SvREFCNT_dec(PL_numeric_radix_sv); + PL_numeric_radix_sv = 0; + } + else { + if (PL_numeric_radix_sv) + sv_setpv(PL_numeric_radix_sv, lc->decimal_point); + else + PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0); + } + } else - PL_numeric_radix = 0; + PL_numeric_radix_sv = 0; # endif /* HAS_LOCALECONV */ #endif /* USE_LOCALE_NUMERIC */ } @@ -549,7 +595,7 @@ Perl_set_numeric_radix(pTHX) * Set up for a new numeric locale. */ void -Perl_new_numeric(pTHX_ const char *newnum) +Perl_new_numeric(pTHX_ char *newnum) { #ifdef USE_LOCALE_NUMERIC @@ -557,15 +603,15 @@ Perl_new_numeric(pTHX_ const char *newnum) if (PL_numeric_name) { Safefree(PL_numeric_name); PL_numeric_name = NULL; - PL_numeric_standard = TRUE; - PL_numeric_local = TRUE; } + PL_numeric_standard = TRUE; + PL_numeric_local = TRUE; return; } if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) { Safefree(PL_numeric_name); - PL_numeric_name = savepv(newnum); + PL_numeric_name = stdize_locale(savepv(newnum)); PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX")); PL_numeric_local = TRUE; set_numeric_radix(); @@ -583,6 +629,7 @@ Perl_set_numeric_standard(pTHX) setlocale(LC_NUMERIC, "C"); PL_numeric_standard = TRUE; PL_numeric_local = FALSE; + set_numeric_radix(); } #endif /* USE_LOCALE_NUMERIC */ @@ -616,7 +663,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn) * -1 = fallback to C locale failed */ -#ifdef USE_LOCALE +#if defined(USE_LOCALE) #ifdef USE_LOCALE_CTYPE char *curctype = NULL; @@ -657,6 +704,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn) (!done && (lang || PerlEnv_getenv("LC_CTYPE"))) ? "" : Nullch))) setlocale_failure = TRUE; + else + curctype = savepv(curctype); #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE if (! (curcoll = @@ -664,6 +713,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn) (!done && (lang || PerlEnv_getenv("LC_COLLATE"))) ? "" : Nullch))) setlocale_failure = TRUE; + else + curcoll = savepv(curcoll); #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC if (! (curnum = @@ -671,6 +722,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn) (!done && (lang || PerlEnv_getenv("LC_NUMERIC"))) ? "" : Nullch))) setlocale_failure = TRUE; + else + curnum = savepv(curnum); #endif /* USE_LOCALE_NUMERIC */ } @@ -687,14 +740,20 @@ Perl_init_i18nl10n(pTHX_ int printwarn) #ifdef USE_LOCALE_CTYPE if (! (curctype = setlocale(LC_CTYPE, ""))) setlocale_failure = TRUE; + else + curctype = savepv(curctype); #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE if (! (curcoll = setlocale(LC_COLLATE, ""))) setlocale_failure = TRUE; + else + curcoll = savepv(curcoll); #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC if (! (curnum = setlocale(LC_NUMERIC, ""))) setlocale_failure = TRUE; + else + curnum = savepv(curnum); #endif /* USE_LOCALE_NUMERIC */ } @@ -747,6 +806,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn) lc_all ? lc_all : "unset", lc_all ? '"' : ')'); +#if defined(USE_ENVIRON_ARRAY) { char **e; for (e = environ; *e; e++) { @@ -757,6 +817,10 @@ Perl_init_i18nl10n(pTHX_ int printwarn) (int)(p - *e), *e, p + 1); } } +#else + PerlIO_printf(Perl_error_log, + "\t(possibly more locale environment variables)\n"); +#endif PerlIO_printf(Perl_error_log, "\tLANG = %c%s%c\n", @@ -806,15 +870,16 @@ Perl_init_i18nl10n(pTHX_ int printwarn) #endif /* ! LC_ALL */ #ifdef USE_LOCALE_CTYPE - curctype = setlocale(LC_CTYPE, Nullch); + curctype = savepv(setlocale(LC_CTYPE, Nullch)); #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE - curcoll = setlocale(LC_COLLATE, Nullch); + curcoll = savepv(setlocale(LC_COLLATE, Nullch)); #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC - curnum = setlocale(LC_NUMERIC, Nullch); + curnum = savepv(setlocale(LC_NUMERIC, Nullch)); #endif /* USE_LOCALE_NUMERIC */ } + else { #ifdef USE_LOCALE_CTYPE new_ctype(curctype); @@ -827,9 +892,22 @@ Perl_init_i18nl10n(pTHX_ int printwarn) #ifdef USE_LOCALE_NUMERIC new_numeric(curnum); #endif /* USE_LOCALE_NUMERIC */ + } #endif /* USE_LOCALE */ +#ifdef USE_LOCALE_CTYPE + if (curctype != NULL) + Safefree(curctype); +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + if (curcoll != NULL) + Safefree(curcoll); +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + if (curnum != NULL) + Safefree(curnum); +#endif /* USE_LOCALE_NUMERIC */ return ok; } @@ -1192,7 +1270,6 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit char * Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) { - dTHR; register unsigned char *s, *x; register unsigned char *big; register I32 pos; @@ -1361,7 +1438,6 @@ Perl_savepvn(pTHX_ const char *sv, register I32 len) STATIC SV * S_mess_alloc(pTHX) { - dTHR; SV *sv; XPVMG *any; @@ -1447,7 +1523,6 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { - dTHR; if (CopLINE(PL_curcop)) Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); @@ -1471,7 +1546,6 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) OP * Perl_vdie(pTHX_ const char* pat, va_list *args) { - dTHR; char *message; int was_in_eval = PL_in_eval; HV *stash; @@ -1572,7 +1646,6 @@ Perl_die(pTHX_ const char* pat, ...) void Perl_vcroak(pTHX_ const char* pat, va_list *args) { - dTHR; char *message; HV *stash; GV *gv; @@ -1580,14 +1653,20 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) SV *msv; STRLEN msglen; - msv = vmess(pat, args); - if (PL_errors && SvCUR(PL_errors)) { - sv_catsv(PL_errors, msv); - message = SvPV(PL_errors, msglen); - SvCUR_set(PL_errors, 0); + if (pat) { + msv = vmess(pat, args); + if (PL_errors && SvCUR(PL_errors)) { + sv_catsv(PL_errors, msv); + message = SvPV(PL_errors, msglen); + SvCUR_set(PL_errors, 0); + } + else + message = SvPV(msv,msglen); + } + else { + message = Nullch; + msglen = 0; } - else - message = SvPV(msv,msglen); DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message)); @@ -1606,9 +1685,14 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) ENTER; save_re_context(); - msg = newSVpvn(message, msglen); - SvREADONLY_on(msg); - SAVEFREESV(msg); + if (message) { + msg = newSVpvn(message, msglen); + SvREADONLY_on(msg); + SAVEFREESV(msg); + } + else { + msg = ERRSV; + } PUSHSTACKi(PERLSI_DIEHOOK); PUSHMARK(SP); @@ -1655,9 +1739,16 @@ Perl_croak_nocontext(const char *pat, ...) /* =for apidoc croak -This is the XSUB-writer's interface to Perl's C<die> function. Use this -function the same way you use the C C<printf> function. See -C<warn>. +This is the XSUB-writer's interface to Perl's C<die> function. +Normally use this function the same way you use the C C<printf> +function. See C<warn>. + +If you want to throw an exception object, assign the object to +C<$@> and then pass C<Nullch> to croak(): + + errsv = get_sv("@", TRUE); + sv_setsv(errsv, exception_object); + croak(Nullch); =cut */ @@ -1687,7 +1778,6 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) if (PL_warnhook) { /* sv_2cv might call Perl_warn() */ - dTHR; SV *oldwarnhook = PL_warnhook; ENTER; SAVESPTR(PL_warnhook); @@ -1785,7 +1875,6 @@ Perl_warner(pTHX_ U32 err, const char* pat,...) void Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) { - dTHR; char *message; HV *stash; GV *gv; @@ -1842,7 +1931,6 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) else { if (PL_warnhook) { /* sv_2cv might call Perl_warn() */ - dTHR; SV *oldwarnhook = PL_warnhook; ENTER; SAVESPTR(PL_warnhook); @@ -1873,15 +1961,21 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) PerlIO *serr = Perl_error_log; PerlIO_write(serr, message, msglen); #ifdef LEAKTEST - DEBUG_L(xstat()); + DEBUG_L(*message == '!' + ? (xstat(message[1]=='!' + ? (message[2]=='!' ? 2 : 1) + : 0) + , 0) + : 0); #endif (void)PerlIO_flush(serr); } } } -#ifndef VMS /* VMS' my_setenv() is in VMS.c */ -#if !defined(WIN32) && !defined(__CYGWIN__) +#ifdef USE_ENVIRON_ARRAY + /* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */ +#if !defined(WIN32) void Perl_my_setenv(pTHX_ char *nam, char *val) { @@ -1923,95 +2017,23 @@ Perl_my_setenv(pTHX_ char *nam, char *val) (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */ #else /* PERL_USE_SAFE_PUTENV */ +# if defined(__CYGWIN__) + setenv(nam, val, 1); +# else char *new_env; new_env = (char*)safesysmalloc((strlen(nam) + strlen(val) + 2) * sizeof(char)); (void)sprintf(new_env,"%s=%s",nam,val);/* all that work just for this */ (void)putenv(new_env); +# endif /* __CYGWIN__ */ #endif /* PERL_USE_SAFE_PUTENV */ } -#else /* WIN32 || __CYGWIN__ */ -#if defined(__CYGWIN__) -/* - * Save environ of perl.exe, currently Cygwin links in separate environ's - * for each exe/dll. Probably should be a member of impure_ptr. - */ -static char ***Perl_main_environ; - -EXTERN_C void -Perl_my_setenv_init(char ***penviron) -{ - Perl_main_environ = penviron; -} - -void -Perl_my_setenv(pTHX_ char *nam, char *val) -{ - /* You can not directly manipulate the environ[] array because - * the routines do some additional work that syncs the Cygwin - * environment with the Windows environment. - */ - char *oldstr = environ[setenv_getix(nam)]; - - if (!val) { - if (!oldstr) - return; - unsetenv(nam); - safesysfree(oldstr); - return; - } - setenv(nam, val, 1); - environ = *Perl_main_environ; /* environ realloc can occur in setenv */ - if(oldstr && environ[setenv_getix(nam)] != oldstr) - safesysfree(oldstr); -} -#else /* if WIN32 */ +#else /* WIN32 */ void Perl_my_setenv(pTHX_ char *nam,char *val) { - -#ifdef USE_WIN32_RTL_ENV - - register char *envstr; - STRLEN namlen = strlen(nam); - STRLEN vallen; - char *oldstr = environ[setenv_getix(nam)]; - - /* putenv() has totally broken semantics in both the Borland - * and Microsoft CRTLs. They either store the passed pointer in - * the environment without making a copy, or make a copy and don't - * free it. And on top of that, they dont free() old entries that - * are being replaced/deleted. This means the caller must - * free any old entries somehow, or we end up with a memory - * leak every time my_setenv() is called. One might think - * one could directly manipulate environ[], like the UNIX code - * above, but direct changes to environ are not allowed when - * calling putenv(), since the RTLs maintain an internal - * *copy* of environ[]. Bad, bad, *bad* stink. - * GSAR 97-06-07 - */ - - if (!val) { - if (!oldstr) - return; - val = ""; - vallen = 0; - } - else - vallen = strlen(val); - envstr = (char*)safesysmalloc((namlen + vallen + 3) * sizeof(char)); - (void)sprintf(envstr,"%s=%s",nam,val); - (void)PerlEnv_putenv(envstr); - if (oldstr) - safesysfree(oldstr); -#ifdef _MSC_VER - safesysfree(envstr); /* MSVCRT leaks without this */ -#endif - -#else /* !USE_WIN32_RTL_ENV */ - register char *envstr; STRLEN len = strlen(nam) + 3; if (!val) { @@ -2022,12 +2044,9 @@ Perl_my_setenv(pTHX_ char *nam,char *val) (void)sprintf(envstr,"%s=%s",nam,val); (void)PerlEnv_putenv(envstr); Safefree(envstr); - -#endif } #endif /* WIN32 */ -#endif I32 Perl_setenv_getix(pTHX_ char *nam) @@ -2047,7 +2066,7 @@ Perl_setenv_getix(pTHX_ char *nam) return i; } -#endif /* !VMS */ +#endif /* !VMS && !EPOC*/ #ifdef UNLINK_ALL_VERSIONS I32 @@ -2301,7 +2320,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) PERL_FLUSHALL_FOR_CHILD; #ifdef OS2 if (doexec) { - return my_syspopen(cmd,mode); + return my_syspopen(aTHX_ cmd,mode); } #endif This = (*mode == 'w'); @@ -2379,7 +2398,9 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) PerlLIO_close(p[This]); p[This] = p[that]; } + LOCK_FDPID_MUTEX; sv = *av_fetch(PL_fdpid,p[This],TRUE); + UNLOCK_FDPID_MUTEX; (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = pid; PL_forkprocess = pid; @@ -2596,7 +2617,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) int saved_win32_errno; #endif + LOCK_FDPID_MUTEX; svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); + UNLOCK_FDPID_MUTEX; pid = SvIVX(*svp); SvREFCNT_dec(*svp); *svp = &PL_sv_undef; @@ -2644,6 +2667,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) if (!pid) return -1; +#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) if (pid > 0) { sprintf(spid, "%"IVdf, (IV)pid); svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE); @@ -2666,6 +2690,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) return pid; } } +#endif #ifdef HAS_WAITPID # ifdef HAS_WAITPID_RUNTIME if (!HAS_WAITPID_RUNTIME) @@ -2867,7 +2892,7 @@ Perl_same_dirent(pTHX_ char *a, char *b) #endif /* !HAS_RENAME */ NV -Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) +Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen) { register char *s = start; register NV rnv = 0.0; @@ -2877,15 +2902,18 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) for (; len-- && *s; s++) { if (!(*s == '0' || *s == '1')) { - if (*s == '_') - continue; /* Note: does not check for __ and the like. */ - if (seenb == FALSE && *s == 'b' && ruv == 0) { + if (*s == '_' && len && *retlen + && (s[1] == '0' || s[1] == '1')) + { + --len; + ++s; + } + else if (seenb == FALSE && *s == 'b' && ruv == 0) { /* Disallow 0bbb0b0bbb... */ seenb = TRUE; continue; } else { - dTHR; if (ckWARN(WARN_DIGIT)) Perl_warner(aTHX_ WARN_DIGIT, "Illegal binary digit '%c' ignored", *s); @@ -2896,13 +2924,13 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) register UV xuv = ruv << 1; if ((xuv >> 1) != ruv) { - dTHR; overflowed = TRUE; rnv = (NV) ruv; if (ckWARN_d(WARN_OVERFLOW)) Perl_warner(aTHX_ WARN_OVERFLOW, "Integer overflow in binary number"); - } else + } + else ruv = xuv | (*s - '0'); } if (overflowed) { @@ -2923,7 +2951,6 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) || (!overflowed && ruv > 0xffffffff ) #endif ) { - dTHR; if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ WARN_PORTABLE, "Binary number > 0b11111111111111111111111111111111 non-portable"); @@ -2933,7 +2960,7 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) } NV -Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) +Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen) { register char *s = start; register NV rnv = 0.0; @@ -2942,14 +2969,17 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) for (; len-- && *s; s++) { if (!(*s >= '0' && *s <= '7')) { - if (*s == '_') - continue; /* Note: does not check for __ and the like. */ + if (*s == '_' && len && *retlen + && (s[1] >= '0' && s[1] <= '7')) + { + --len; + ++s; + } else { /* Allow \octal to work the DWIM way (that is, stop scanning * as soon as non-octal characters are seen, complain only iff * someone seems to want to use the digits eight and nine). */ if (*s == '8' || *s == '9') { - dTHR; if (ckWARN(WARN_DIGIT)) Perl_warner(aTHX_ WARN_DIGIT, "Illegal octal digit '%c' ignored", *s); @@ -2961,13 +2991,13 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) register UV xuv = ruv << 3; if ((xuv >> 3) != ruv) { - dTHR; overflowed = TRUE; rnv = (NV) ruv; if (ckWARN_d(WARN_OVERFLOW)) Perl_warner(aTHX_ WARN_OVERFLOW, "Integer overflow in octal number"); - } else + } + else ruv = xuv | (*s - '0'); } if (overflowed) { @@ -2988,7 +3018,6 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) || (!overflowed && ruv > 0xffffffff ) #endif ) { - dTHR; if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ WARN_PORTABLE, "Octal number > 037777777777 non-portable"); @@ -2998,7 +3027,7 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) } NV -Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) +Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen) { register char *s = start; register NV rnv = 0.0; @@ -3010,15 +3039,18 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) for (; len-- && *s; s++) { hexdigit = strchr((char *) PL_hexdigit, *s); if (!hexdigit) { - if (*s == '_') - continue; /* Note: does not check for __ and the like. */ - if (seenx == FALSE && *s == 'x' && ruv == 0) { + if (*s == '_' && len && *retlen && s[1] + && (hexdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + } + else if (seenx == FALSE && *s == 'x' && ruv == 0) { /* Disallow 0xxx0x0xxx... */ seenx = TRUE; continue; } else { - dTHR; if (ckWARN(WARN_DIGIT)) Perl_warner(aTHX_ WARN_DIGIT, "Illegal hexadecimal digit '%c' ignored", *s); @@ -3029,13 +3061,13 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) register UV xuv = ruv << 4; if ((xuv >> 4) != ruv) { - dTHR; overflowed = TRUE; rnv = (NV) ruv; if (ckWARN_d(WARN_OVERFLOW)) Perl_warner(aTHX_ WARN_OVERFLOW, "Integer overflow in hexadecimal number"); - } else + } + else ruv = xuv | ((hexdigit - PL_hexdigit) & 15); } if (overflowed) { @@ -3056,7 +3088,6 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) || (!overflowed && ruv > 0xffffffff ) #endif ) { - dTHR; if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ WARN_PORTABLE, "Hexadecimal number > 0xffffffff non-portable"); @@ -3068,7 +3099,6 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) char* Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags) { - dTHR; char *xfound = Nullch; char *xfailed = Nullch; char tmpbuf[MAXPATHLEN]; @@ -3449,6 +3479,35 @@ Perl_condpair_magic(pTHX_ SV *sv) return mg; } +SV * +Perl_sv_lock(pTHX_ SV *osv) +{ + MAGIC *mg; + SV *sv = osv; + + LOCK_SV_LOCK_MUTEX; + if (SvROK(sv)) { + sv = SvRV(sv); + } + + mg = condpair_magic(sv); + MUTEX_LOCK(MgMUTEXP(mg)); + if (MgOWNER(mg) == thr) + MUTEX_UNLOCK(MgMUTEXP(mg)); + else { + while (MgOWNER(mg)) + COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); + MgOWNER(mg) = thr; + DEBUG_S(PerlIO_printf(Perl_debug_log, + "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n", + PTR2UV(thr), PTR2UV(sv));) + MUTEX_UNLOCK(MgMUTEXP(mg)); + SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); + } + UNLOCK_SV_LOCK_MUTEX; + return sv; +} + /* * Make a new perl thread structure using t as a prototype. Some of the * fields for the new thread are copied from the prototype thread, t, @@ -3479,6 +3538,8 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) PL_dirty = 0; PL_localizing = 0; Zero(&PL_hv_fetch_ent_mh, 1, HE); + PL_efloatbuf = (char*)NULL; + PL_efloatsize = 0; #else Zero(thr, 1, struct perl_thread); #endif @@ -3497,7 +3558,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) JMPENV_BOOTSTRAP; - PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR) */ + PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */ PL_restartop = 0; PL_statname = NEWSV(66,0); @@ -3531,7 +3592,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) PL_tainted = t->Ttainted; PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */ PL_nrs = newSVsv(t->Tnrs); - PL_rs = SvREFCNT_inc(PL_nrs); + PL_rs = t->Tnrs ? SvREFCNT_inc(PL_nrs) : Nullsv; PL_last_in_gv = Nullgv; PL_ofslen = t->Tofslen; PL_ofs = savepvn(t->Tofs, PL_ofslen); @@ -3577,7 +3638,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) } #endif /* USE_THREADS */ -#ifdef HUGE_VAL +#if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)) /* * This hack is to force load of "huge" support from libm.a * So it is in perl for (say) POSIX to use. @@ -3586,7 +3647,10 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) NV Perl_huge(void) { - return HUGE_VAL; +# if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) + return HUGE_VALL; +# endif + return HUGE_VAL; } #endif @@ -3630,7 +3694,7 @@ Perl_get_ppaddr(pTHX) #ifndef HAS_GETENV_LEN char * -Perl_getenv_len(pTHX_ char *env_elem, unsigned long *len) +Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) { char *env_trans = PerlEnv_getenv(env_elem); if (env_trans) @@ -3744,33 +3808,49 @@ Perl_get_vtbl(pTHX_ int vtbl_id) return result; } +#if !defined(FFLUSH_NULL) && defined(HAS__FWALK) +static int S_fflush(FILE *fp); + +static int +S_fflush(FILE *fp) +{ + return fflush(fp); +} +#endif + I32 Perl_my_fflush_all(pTHX) { -#ifdef FFLUSH_NULL +#if defined(FFLUSH_NULL) return PerlIO_flush(NULL); #else +# if defined(HAS__FWALK) + /* undocumented, unprototyped, but very useful BSDism */ + extern void _fwalk(int (*)(FILE *)); + _fwalk(&S_fflush); + return 0; +# else long open_max = -1; -# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY) -# ifdef PERL_FFLUSH_ALL_FOPEN_MAX +# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY) +# ifdef PERL_FFLUSH_ALL_FOPEN_MAX open_max = PERL_FFLUSH_ALL_FOPEN_MAX; -# else -# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) +# else +# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) open_max = sysconf(_SC_OPEN_MAX); -# else -# ifdef FOPEN_MAX - open_max = FOPEN_MAX; # else -# ifdef OPEN_MAX - open_max = OPEN_MAX; +# ifdef FOPEN_MAX + open_max = FOPEN_MAX; # else -# ifdef _NFILE +# ifdef OPEN_MAX + open_max = OPEN_MAX; +# else +# ifdef _NFILE open_max = _NFILE; +# endif # endif # endif # endif -# endif -# endif +# endif if (open_max > 0) { long i; for (i = 0; i < open_max; i++) @@ -3780,50 +3860,119 @@ Perl_my_fflush_all(pTHX) PerlIO_flush(&STDIO_STREAM_ARRAY[i]); return 0; } -# endif +# endif SETERRNO(EBADF,RMS$_IFI); return EOF; +# endif #endif } NV Perl_my_atof(pTHX_ const char* s) { + NV x = 0.0; #ifdef USE_LOCALE_NUMERIC if ((PL_hints & HINT_LOCALE) && PL_numeric_local) { - NV x, y; + NV y; - x = Perl_atof(s); + Perl_atof2(s, x); SET_NUMERIC_STANDARD(); - y = Perl_atof(s); + Perl_atof2(s, y); SET_NUMERIC_LOCAL(); if ((y < 0.0 && y < x) || (y > 0.0 && y > x)) return y; - return x; } else - return Perl_atof(s); + Perl_atof2(s, x); #else - return Perl_atof(s); + Perl_atof2(s, x); #endif + return x; } void -Perl_report_closed_fh(pTHX_ GV *gv, IO *io, const char *func, const char *obj) -{ - SV *sv; - char *name; +Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) +{ + char *vile; + I32 warn_type; + char *func = + op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */ + op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ + PL_op_desc[op]; + char *pars = OP_IS_FILETEST(op) ? "" : "()"; + char *type = OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) ? + "socket" : "filehandle"; + char *name = NULL; + + if (io && IoTYPE(io) == IoTYPE_CLOSED) { + vile = "closed"; + warn_type = WARN_CLOSED; + } + else { + vile = "unopened"; + warn_type = WARN_UNOPENED; + } - assert(gv); + if (gv && isGV(gv)) { + SV *sv = sv_newmortal(); + gv_efullname4(sv, gv, Nullch, FALSE); + name = SvPVX(sv); + } - sv = sv_newmortal(); - gv_efullname3(sv, gv, Nullch); - name = SvPVX(sv); + if (name && *name) { + Perl_warner(aTHX_ warn_type, + "%s%s on %s %s %s", func, pars, vile, type, name); + if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) + Perl_warner(aTHX_ warn_type, + "\t(Are you trying to call %s%s on dirhandle %s?)\n", + func, pars, name); + } + else { + Perl_warner(aTHX_ warn_type, + "%s%s on %s %s", func, pars, vile, type); + if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) + Perl_warner(aTHX_ warn_type, + "\t(Are you trying to call %s%s on dirhandle?)\n", + func, pars); + } +} - Perl_warner(aTHX_ WARN_CLOSED, "%s() on closed %s %s", func, obj, name); +#ifdef EBCDIC +/* in ASCII order, not that it matters */ +static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"; - if (io && IoDIRP(io)) - Perl_warner(aTHX_ WARN_CLOSED, - "\t(Are you trying to call %s() on dirhandle %s?)\n", - func, name); +int +Perl_ebcdic_control(pTHX_ int ch) +{ + if (ch > 'a') { + char *ctlp; + + if (islower(ch)) + ch = toupper(ch); + + if ((ctlp = strchr(controllablechars, ch)) == 0) { + Perl_die(aTHX_ "unrecognised control character '%c'\n", ch); + } + + if (ctlp == controllablechars) + return('\177'); /* DEL */ + else + return((unsigned char)(ctlp - controllablechars - 1)); + } else { /* Want uncontrol */ + if (ch == '\177' || ch == -1) + return('?'); + else if (ch == '\157') + return('\177'); + else if (ch == '\174') + return('\000'); + else if (ch == '^') /* '\137' in 1047, '\260' in 819 */ + return('\036'); + else if (ch == '\155') + return('\037'); + else if (0 < ch && ch < (sizeof(controllablechars) - 1)) + return(controllablechars[ch+1]); + else + Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF); + } } +#endif diff --git a/contrib/perl5/util.h b/contrib/perl5/util.h index beb5215e8113..d188e34e2e82 100644 --- a/contrib/perl5/util.h +++ b/contrib/perl5/util.h @@ -1,6 +1,6 @@ /* util.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,12 +21,16 @@ || ((f)[0] && (f)[1] == ':') /* drive name */ \ || ((f)[0] == '\\' && (f)[1] == '\\')) /* UNC path */ # else /* !WIN32 */ -# ifdef DOSISH +# if defined( DOSISH) || defined(EPOC) # define PERL_FILE_IS_ABSOLUTE(f) \ (*(f) == '/' \ || ((f)[0] && (f)[1] == ':')) /* drive name */ -# else /* !DOSISH */ -# define PERL_FILE_IS_ABSOLUTE(f) (*(f) == '/') +# else /* NEITHER DOSISH NOR EPOCISH */ +# ifdef MACOS_TRADITIONAL +# define PERL_FILE_IS_ABSOLUTE(f) (strchr(f, ':') && *(f) != ':') +# else /* !MACOS_TRADITIONAL */ +# define PERL_FILE_IS_ABSOLUTE(f) (*(f) == '/') +# endif /* MACOS_TRADITIONAL */ # endif /* DOSISH */ # endif /* WIN32 */ #endif /* VMS */ diff --git a/contrib/perl5/utils/Makefile b/contrib/perl5/utils/Makefile index 944cbe8711bc..ec26cd8fdcdb 100644 --- a/contrib/perl5/utils/Makefile +++ b/contrib/perl5/utils/Makefile @@ -7,12 +7,20 @@ REALPERL = ../perl pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL splain.PL perlcc.PL dprofpp.PL plextract = c2ph h2ph h2xs perlbug perldoc pl2pm splain perlcc dprofpp -plextractexe = c2ph.exe h2ph.exe h2xs.exe perlbug.exe perldoc.exe pl2pm.exe splain.exe perlcc.exe dprofpp.exe +plextractexe = ./c2ph ./h2ph ./h2xs ./perlbug ./perldoc ./pl2pm ./splain ./perlcc ./dprofpp all: $(plextract) -compile: all - $(REALPERL) -I../lib perlcc -opt -regex 's/$$/.exe/' $(plextract) -prog -verbose dcf -log ../compilelog; +compile: all $(plextract) + $(REALPERL) -I../lib perlcc c2ph -o c2ph.exe -v 10 -log ../compilelog; + $(REALPERL) -I../lib perlcc h2ph -o h2ph.exe -v 10 -log ../compilelog; + $(REALPERL) -I../lib perlcc h2xs -o h2xs.exe -v 10 -log ../compilelog; + $(REALPERL) -I../lib perlcc perlbug -o perlbug.exe -v 10 -log ../compilelog; + $(REALPERL) -I../lib perlcc perldoc -o perldoc.exe -v 10 -log ../compilelog; + $(REALPERL) -I../lib perlcc pl2pm -o pl2pm.exe -v 10 -log ../compilelog; + $(REALPERL) -I../lib perlcc splain -o splain.exe -v 10 -log ../compilelog; + $(REALPERL) -I../lib perlcc perlcc -o perlcc.exe -v 10 -log ../compilelog; + $(REALPERL) -I../lib perlcc dprofpp -o dprofpp.exe -v 10 -log ../compilelog; $(plextract): $(PERL) -I../lib $@.PL @@ -44,3 +52,6 @@ realclean: clobber: realclean distclean: clobber + +veryclean: distclean + -rm -f *~ *.org diff --git a/contrib/perl5/utils/h2ph.PL b/contrib/perl5/utils/h2ph.PL index 0b0208b0ca40..855a899499a3 100644 --- a/contrib/perl5/utils/h2ph.PL +++ b/contrib/perl5/utils/h2ph.PL @@ -36,13 +36,16 @@ $Config{startperl} print OUT <<'!NO!SUBS!'; +use strict; + use Config; use File::Path qw(mkpath); use Getopt::Std; getopts('Dd:rlhaQ'); +use vars qw($opt_D $opt_d $opt_r $opt_l $opt_h $opt_a $opt_Q); die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a); -@inc_dirs = inc_dirs() if $opt_a; +my @inc_dirs = inc_dirs() if $opt_a; my $Exit = 0; @@ -50,7 +53,7 @@ my $Dest_dir = $opt_d || $Config{installsitearch}; die "Destination directory $Dest_dir doesn't exist or isn't a directory\n" unless -d $Dest_dir; -@isatype = split(' ',<<END); +my @isatype = split(' ',<<END); char uchar u_char short ushort u_short int uint u_int @@ -58,14 +61,18 @@ die "Destination directory $Dest_dir doesn't exist or isn't a directory\n" FILE key_t caddr_t END +my %isatype; @isatype{@isatype} = (1) x @isatype; -$inif = 0; +my $inif = 0; +my %Is_converted; @ARGV = ('-') unless @ARGV; build_preamble_if_necessary(); -while (defined ($file = next_file())) { +my ($t, $tab, %curargs, $new, $eval_index, $dir, $name, $args, $outfile); +my ($incl, $next); +while (defined (my $file = next_file())) { if (-l $file and -d $file) { link_if_possible($file) if ($opt_l); next; @@ -129,7 +136,7 @@ while (defined ($file = next_file())) { my $proto = '() '; if ($args ne '') { $proto = ''; - foreach $arg (split(/,\s*/,$args)) { + foreach my $arg (split(/,\s*/,$args)) { $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/; $curargs{$arg} = 1; } @@ -257,11 +264,11 @@ while (defined ($file = next_file())) { s@/\*.*?\*/@@g; s/\s+/ /g; /^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/; - ($enum_subs = $3) =~ s/\s//g; - @enum_subs = split(/,/, $enum_subs); - $enum_val = -1; - for $enum (@enum_subs) { - ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/; + (my $enum_subs = $3) =~ s/\s//g; + my @enum_subs = split(/,/, $enum_subs); + my $enum_val = -1; + foreach my $enum (@enum_subs) { + my ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/; $enum_value =~ s/^=//; $enum_val = (length($enum_value) ? $enum_value : $enum_val + 1); if ($opt_h) { @@ -280,12 +287,13 @@ while (defined ($file = next_file())) { } print OUT "1;\n"; - $is_converted{$file} = 1; + $Is_converted{$file} = 1; queue_includes_from($file) if ($opt_a); } exit $Exit; + sub reindent($) { my($text) = shift; $text =~ s/\n/\n /g; @@ -293,9 +301,11 @@ sub reindent($) { $text; } + sub expr { + my $joined_args; if(keys(%curargs)) { - my($joined_args) = join('|', keys(%curargs)); + $joined_args = join('|', keys(%curargs)); } while ($_ ne '') { s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator @@ -347,7 +357,7 @@ sub expr { }; # struct/union member, including arrays: s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do { - $id = $1; + my $id = $1; $id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g; $id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args); while($id =~ /\[\s*([^\$\&\d\]]+)\]/) { @@ -363,7 +373,7 @@ sub expr { $new .= " (\$$id)"; }; s/^([_a-zA-Z]\w*)// && do { - $id = $1; + my $id = $1; if ($id eq 'struct') { s/^\s+(\w+)//; $id .= ' ' . $1; @@ -505,7 +515,7 @@ sub queue_includes_from } if ($line =~ /^#\s*include\s+<(.*?)>/) { - push(@ARGV, $1) unless $is_converted{$1}; + push(@ARGV, $1) unless $Is_converted{$1}; } } close HEADER; @@ -575,7 +585,8 @@ sub build_preamble_if_necessary sub _extract_cc_defines { my %define; - my $allsymbols = join " ", @Config{ccsymbols, cppsymbols, cppccsymbols}; + my $allsymbols = join " ", + @Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'}; # Split compiler pre-definitions into `key=value' pairs: foreach (split /\s+/, $allsymbols) { @@ -708,8 +719,6 @@ that it can translate. It's only intended as a rough tool. You may need to dicker with the files produced. -Doesn't run with C<use strict> - You have to run this program by hand; it's not run as part of the Perl installation. diff --git a/contrib/perl5/utils/h2xs.PL b/contrib/perl5/utils/h2xs.PL index ca0e7cbc3247..edc2bb575010 100644 --- a/contrib/perl5/utils/h2xs.PL +++ b/contrib/perl5/utils/h2xs.PL @@ -13,9 +13,9 @@ use Cwd; # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. -$origdir = cwd; +my $origdir = cwd; chdir dirname($0); -$file = basename($0, '.PL'); +my $file = basename($0, '.PL'); $file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; @@ -41,7 +41,7 @@ h2xs - convert .h C header files to Perl extensions =head1 SYNOPSIS -B<h2xs> [B<-ACOPXcdf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [headerfile ... [extra_libraries]] +B<h2xs> [B<-ACOPXacdfkmx>] [B<-F> addflags] [B<-M> fmask] [B<-n> module_name] [B<-o> tmask] [B<-p> prefix] [B<-s> subs] [B<-v> version] [headerfile ... [extra_libraries]] B<h2xs> B<-h> @@ -78,7 +78,7 @@ S<C<use AutoLoader>> statement from the .pm file. Omits creation of the F<Changes> file, and adds a HISTORY section to the POD template. -=item B<-F> +=item B<-F> I<addflags> Additional flags to specify to C preprocessor when scanning header for function declarations. Should not be used without B<-x>. @@ -191,6 +191,18 @@ hand-editing. Such may be objects which cannot be converted from/to a pointer (like C<long long>), pointers to functions, or arrays. See also the section on L<LIMITATIONS of B<-x>>. +=item B<-b> I<version> + +Generates a .pm file which is backwards compatible with the specified +perl version. + +For versions < 5.6.0, the changes are. + - no use of 'our' (uses 'use vars' instead) + - no 'use warnings' + +Specifying a compatibility version higher than the version of perl you +are using to run h2xs will have no effect. + =back =head1 EXAMPLES @@ -248,6 +260,68 @@ also the section on L<LIMITATIONS of B<-x>>. # Same but treat SV* etc as "opaque" types h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h +=head2 Extension based on F<.h> and F<.c> files + +Suppose that you have some C files implementing some functionality, +and the corresponding header files. How to create an extension which +makes this functionality accessable in Perl? The example below +assumes that the header files are F<interface_simple.h> and +I<interface_hairy.h>, and you want the perl module be named as +C<Ext::Ension>. If you need some preprocessor directives and/or +linking with external libraries, see the flags C<-F>, C<-L> and C<-l> +in L<"OPTIONS">. + +=over + +=item Find the directory name + +Start with a dummy run of h2xs: + + h2xs -Afn Ext::Ension + +The only purpose of this step is to create the needed directories, and +let you know the names of these directories. From the output you can +see that the directory for the extension is F<Ext/Ension>. + +=item Copy C files + +Copy your header files and C files to this directory F<Ext/Ension>. + +=item Create the extension + +Run h2xs, overwriting older autogenerated files: + + h2xs -Oxan Ext::Ension interface_simple.h interface_hairy.h + +h2xs looks for header files I<after> changing to the extension +directory, so it will find your header files OK. + +=item Archive and test + +As usual, run + + cd Ext/Ension + perl Makefile.PL + make dist + make + make test + +=item Hints + +It is important to do C<make dist> as early as possible. This way you +can easily merge(1) your changes to autogenerated files if you decide +to edit your C<.h> files and rerun h2xs. + +Do not forget to edit the documentation in the generated F<.pm> file. + +Consider the autogenerated files as skeletons only, you may invent +better interfaces than what h2xs could guess. + +Consider this section as a guideline only, some other options of h2xs +may better suit your needs. + +=back + =head1 ENVIRONMENT No environment variables are used. @@ -329,15 +403,16 @@ See L<perlxs> and L<perlxstut> for additional details. use strict; -my( $H2XS_VERSION ) = ' $Revision: 1.20 $ ' =~ /\$Revision:\s+([^\s]+)/; +my( $H2XS_VERSION ) = ' $Revision: 1.21 $ ' =~ /\$Revision:\s+([^\s]+)/; my $TEMPLATE_VERSION = '0.01'; my @ARGS = @ARGV; +my $compat_version = $]; use Getopt::Std; sub usage{ warn "@_\n" if @_; - die "h2xs [-ACOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [headerfile [extra_libraries]] + die "h2xs [-ACOPXacdfhkmx] [-F addflags] [-M fmask] [-n module_name] [-o tmask] [-p prefix] [-s subs] [-v version] [headerfile [extra_libraries]] version: $H2XS_VERSION -A Omit all autoloading facilities (implies -c). -C Omit creating the Changes file, add HISTORY heading to stub POD. @@ -359,6 +434,7 @@ version: $H2XS_VERSION -s Create subroutines for specified macros. -v Specify a version number for this extension. -x Autogenerate XSUBs using C::Scan. + -b Specify a perl version to be backwards compatibile with extra_libraries are any libraries that might be needed for loading the extension, e.g. -lm would try to link in the math library. @@ -366,12 +442,22 @@ extra_libraries } -getopts("ACF:M:OPXacdfhkmn:o:p:s:v:x") || usage; +getopts("ACF:M:OPXacdfhkmn:o:p:s:v:xb:") || usage; use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_a $opt_c $opt_d - $opt_f $opt_h $opt_k $opt_m $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x); + $opt_f $opt_h $opt_k $opt_m $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x + $opt_b); usage if $opt_h; +if( $opt_b ){ + usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m); + $opt_b =~ /^\d+\.\d+\.\d+/ || + usage "You must provide the backwards compatibility version in X.Y.Z form. " . + "(i.e. 5.5.0)\n"; + my ($maj,$min,$sub) = split(/\./,$opt_b,3); + $compat_version = sprintf("%d.%03d%02d",$maj,$min,$sub); +} + if( $opt_v ){ $TEMPLATE_VERSION = $opt_v; } @@ -438,6 +524,8 @@ EOD my @path_h_ini = @path_h; my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names); +my $module = $opt_n; + if( @path_h ){ use Config; use File::Spec; @@ -456,6 +544,15 @@ if( @path_h ){ } foreach my $path_h (@path_h) { $name ||= $path_h; + $module ||= do { + $name =~ s/\.h$//; + if ( $name !~ /::/ ) { + $name =~ s#^.*/##; + $name = "\u$name"; + } + $name; + }; + if( $path_h =~ s#::#/#g && $opt_n ){ warn "Nesting of headerfile ignored with -n\n"; } @@ -464,19 +561,36 @@ if( @path_h ){ $path_h =~ s/,.*$// if $opt_x; $fullpath{$path_h} = $fullpath; + # Minor trickery: we can't chdir() before we processed the headers + # (so know the name of the extension), but the header may be in the + # extension directory... + my $tmp_path_h = $path_h; + my $rel_path_h = $path_h; + my @dirs = @paths; if (not -f $path_h) { - my $tmp_path_h = $path_h; + my $found; for my $dir (@paths) { - last if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h)); + $found++, last + if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h)); + } + if ($found) { + $rel_path_h = $path_h; + } else { + (my $epath = $module) =~ s,::,/,g; + $epath = File::Spec->catdir('ext', $epath) if -d 'ext'; + $rel_path_h = File::Spec->catfile($epath, $tmp_path_h); + $path_h = $tmp_path_h; # Used during -x + push @dirs, $epath; } } if (!$opt_c) { - die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h ); + die "Can't find $tmp_path_h in @dirs\n" + if ( ! $opt_f && ! -f "$rel_path_h" ); # Scan the header file (we should deal with nested header files) # Record the names of simple #define constants into const_names # Function prototypes are processed below. - open(CH, "<$path_h") || die "Can't open $path_h: $!\n"; + open(CH, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n"; defines: while (<CH>) { if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^" \t])(.*)/) { @@ -517,14 +631,6 @@ if( @path_h ){ } -my $module = $opt_n || do { - $name =~ s/\.h$//; - if( $name !~ /::/ ){ - $name =~ s#^.*/##; - $name = "\u$name"; - } - $name; -}; my ($ext, $nested, @modparts, $modfname, $modpname); (chdir 'ext', $ext = 'ext/') if -d 'ext'; @@ -685,13 +791,23 @@ open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n" $" = "\n\t"; warn "Writing $ext$modpname/$modfname.pm\n"; +if ( $compat_version < 5.006 ) { print PM <<"END"; package $module; -require 5.005_62; +use $compat_version; +use strict; +END +} +else { +print PM <<"END"; +package $module; + +use 5.006; use strict; use warnings; END +} unless( $opt_X || $opt_c || $opt_A ){ # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and @@ -721,15 +837,25 @@ unless ($opt_A) { # no autoloader whatsoever. } } +if ( $compat_version < 5.006 ) { + if ( $opt_X || $opt_c || $opt_A ) { + print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);'; + } else { + print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD);'; + } +} + # Determine @ISA. my $myISA = 'our @ISA = qw(Exporter'; # We seem to always want this. $myISA .= ' DynaLoader' unless $opt_X; # no XS $myISA .= ');'; +$myISA =~ s/^our // if $compat_version < 5.006; + print PM "\n$myISA\n\n"; my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls); -print PM<<"END"; +my $tmp=<<"END"; # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. @@ -750,10 +876,15 @@ our \$VERSION = '$TEMPLATE_VERSION'; END +$tmp =~ s/^our //mg if $compat_version < 5.006; +print PM $tmp; + if (@vdecls) { printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n"; } + +$tmp = ( $compat_version < 5.006 ? "" : "our \$AUTOLOAD;" ); print PM <<"END" unless $opt_c or $opt_X; sub AUTOLOAD { # This AUTOLOAD is used to 'autoload' constants from the constant() @@ -761,7 +892,7 @@ sub AUTOLOAD { # to the AUTOLOAD in AutoLoader. my \$constname; - our \$AUTOLOAD; + $tmp (\$constname = \$AUTOLOAD) =~ s/.*:://; croak "&$module::constant not defined" if \$constname eq 'constant'; my \$val = constant(\$constname, \@_ ? \$_[0] : 0); @@ -834,51 +965,62 @@ my $email = 'a.u.thor@a.galaxy.far.far.away'; my $revhist = ''; $revhist = <<EOT if $opt_C; - -=head1 HISTORY - -=over 8 - -=item $TEMPLATE_VERSION - -Original version; created by h2xs $H2XS_VERSION with options - - @ARGS - -=back - +# +#=head1 HISTORY +# +#=over 8 +# +#=item $TEMPLATE_VERSION +# +#Original version; created by h2xs $H2XS_VERSION with options +# +# @ARGS +# +#=back +# EOT my $exp_doc = <<EOD; - -=head2 EXPORT - -None by default. - +# +#=head2 EXPORT +# +#None by default. +# EOD + if (@const_names and not $opt_P) { $exp_doc .= <<EOD; -=head2 Exportable constants - - @{[join "\n ", @const_names]} - +#=head2 Exportable constants +# +# @{[join "\n ", @const_names]} +# EOD } + if (defined $fdecls and @$fdecls and not $opt_P) { $exp_doc .= <<EOD; -=head2 Exportable functions - +#=head2 Exportable functions +# EOD - $exp_doc .= <<EOD if $opt_p; -When accessing these functions from Perl, prefix C<$opt_p> should be removed. -EOD +# $exp_doc .= <<EOD if $opt_p; +#When accessing these functions from Perl, prefix C<$opt_p> should be removed. +# +#EOD $exp_doc .= <<EOD; - @{[join "\n ", @known_fnames{@fnames}]} - +# @{[join "\n ", @known_fnames{@fnames}]} +# EOD } +my $meth_doc = ''; + +if ($opt_x && $opt_a) { + my($name, $struct); + $meth_doc .= accessor_docs($name, $struct) + while ($name, $struct) = each %structs; +} + my $pod = <<"END" unless $opt_P; ## Below is stub documentation for your module. You better edit it! # @@ -898,14 +1040,14 @@ my $pod = <<"END" unless $opt_P; #unedited. # #Blah blah blah. -#$exp_doc$revhist +$exp_doc$meth_doc$revhist #=head1 AUTHOR # -#$author, $email +#$author, E<lt>${email}E<gt> # #=head1 SEE ALSO # -#perl(1). +#L<perl>. # #=cut END @@ -1357,6 +1499,72 @@ EOF } } +sub accessor_docs { + my($name, $struct) = @_; + return unless defined $struct && $name !~ /\s|_ANON/; + $name = normalize_type($name); + my $ptrname = $name . 'Ptr'; + my @items = @$struct; + my @list; + while (@items) { + my $item = shift @items; + if ($item->[0] =~ /_ANON/) { + if (defined $item->[2]) { + push @items, map [ + @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]", + ], @{ $structs{$item->[0]} }; + } else { + push @items, @{ $structs{$item->[0]} }; + } + } else { + push @list, $item->[2]; + } + } + my $methods = (join '(...)>, C<', @list) . '(...)'; + + my $pod = <<"EOF"; +# +#=head2 Object and class methods for C<$name>/C<$ptrname> +# +#The principal Perl representation of a C object of type C<$name> is an +#object of class C<$ptrname> which is a reference to an integer +#representation of a C pointer. To create such an object, one may use +#a combination +# +# my \$buffer = $name->new(); +# my \$obj = \$buffer->_to_ptr(); +# +#This exersizes the following two methods, and an additional class +#C<$name>, the internal representation of which is a reference to a +#packed string with the C structure. Keep in mind that \$buffer should +#better survive longer than \$obj. +# +#=over +# +#=item C<\$object_of_type_$name-E<gt>_to_ptr()> +# +#Converts an object of type C<$name> to an object of type C<$ptrname>. +# +#=item C<$name-E<gt>new()> +# +#Creates an empty object of type C<$name>. The corresponding packed +#string is zeroed out. +# +#=item C<$methods> +# +#return the current value of the corresponding element if called +#without additional arguments. Set the element to the supplied value +#(and return the new value) if called with an additional argument. +# +#Applicable to objects of type C<$ptrname>. +# +#=back +# +EOF + $pod =~ s/^\#//gm; + return $pod; +} + # Should be called before any actual call to normalize_type(). sub get_typemap { # We do not want to read ./typemap by obvios reasons. @@ -1509,44 +1717,106 @@ WriteMakefile( 'NAME' => '$module', 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1 + (\$] >= 5.005 ? ## Add these new keywords supported since 5.005 + (ABSTRACT_FROM => '$modfname.pm', # retrieve abstract from module + AUTHOR => '$author <$email>') : ()), END if (!$opt_X) { # print C stuff, unless XS is disabled $opt_F = '' unless defined $opt_F; + my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : ''); + my $Ihelp = ($I ? '-I. ' : ''); + my $Icomment = ($I ? '' : <<EOC); + # Insert -I. if you add *.h files later: +EOC + print PL <<END; 'LIBS' => ['$extralibs'], # e.g., '-lm' 'DEFINE' => '$opt_F', # e.g., '-DHAVE_SOMETHING' - 'INC' => '', # e.g., '-I/usr/include/other' +$Icomment 'INC' => '$I', # e.g., '$Ihelp-I/usr/include/other' +END + + my $C = grep $_ ne "$modfname.c", (glob '*.c'), (glob '*.cc'), (glob '*.C'); + my $Cpre = ($C ? '' : '# '); + my $Ccomment = ($C ? '' : <<EOC); + # Un-comment this if you add C files to link with later: +EOC + + print PL <<END; +$Ccomment $Cpre\'OBJECT' => '\$(O_FILES)', # link all the C files too END } print PL ");\n"; close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n"; +# Create a simple README since this is a CPAN requirement +# and it doesnt hurt to have one +warn "Writing $ext$modpname/README\n"; +open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n"; +my $thisyear = (gmtime)[5] + 1900; +my $rmhead = "$modpname version $TEMPLATE_VERSION"; +my $rmheadeq = "=" x length($rmhead); +print RM <<_RMEND_; +$rmhead +$rmheadeq + +The README is used to introduce the module and provide instructions on +how to install the module, any machine dependencies it may have (for +example C compilers and installed libraries) and any other information +that should be provided before the module is installed. + +A README file is required for CPAN modules since CPAN extracts the +README file from a module distribution so that people browsing the +archive can use it get an idea of the modules uses. It is usually a +good idea to provide version information here so that people can +decide whether fixes for the module are worth downloading. + +INSTALLATION + +To install this module type the following: + + perl Makefile.PL + make + make test + make install + +DEPENDENCIES + +This module requires these other modules and libraries: + + blah blah blah + +COPYRIGHT AND LICENCE + +Put the correct copyright and licence information here. + +Copyright (C) $thisyear $author blah blah blah + +_RMEND_ +close(RM) || die "Can't close $ext$modpname/README: $!\n"; + warn "Writing $ext$modpname/test.pl\n"; open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n"; print EX <<'_END_'; # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' -######################### We start with some black magic to print on failure. +######################### -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) +# change 'tests => 1' to 'tests => last_test_to_print'; -BEGIN { $| = 1; print "1..1\n"; } -END {print "not ok 1\n" unless $loaded;} +use Test; +BEGIN { plan tests => 1 }; _END_ print EX <<_END_; use $module; _END_ print EX <<'_END_'; -$loaded = 1; -print "ok 1\n"; +ok(1); # If we made it this far, we're ok. -######################### End of black magic. +######################### -# Insert your test code below (better if it prints "ok 13" -# (correspondingly "not ok 13") depending on the success of chunk 13 -# of the test code): +# Insert your test code below, the Test module is use()ed here so read +# its man page ( perldoc Test ) for help writing this test script. _END_ close(EX) || die "Can't close $ext$modpname/test.pl: $!\n"; diff --git a/contrib/perl5/utils/perlbug.PL b/contrib/perl5/utils/perlbug.PL index 208da3667c4a..d323913eeb5d 100644 --- a/contrib/perl5/utils/perlbug.PL +++ b/contrib/perl5/utils/perlbug.PL @@ -45,7 +45,7 @@ while (<PATCH_LEVEL>) { my $patch_desc = "'" . join("',\n '", @patches) . "'"; my $patch_tags = join "", map /(\S+)/ ? "+$1 " : (), @patches; -close PATCH_LEVEL; +close(PATCH_LEVEL) or die "Error closing patchlevel.h: $!"; # TO DO (prehaps): store/embed $Config::config_sh into perlbug. When perlbug is # used, compare $Config::config_sh with the stored version. If they differ then @@ -91,7 +91,7 @@ BEGIN { $::HaveUtil = ($@ eq ""); }; -my $Version = "1.28"; +my $Version = "1.33"; # Changed in 1.06 to skip Mail::Send and Mail::Util if not available. # Changed in 1.07 to see more sendmail execs, and added pipe output. @@ -124,6 +124,11 @@ my $Version = "1.28"; # Changed in 1.26 Don't require -t STDIN for -ok. HVDS 98-07-15 # Changed in 1.27 Added Mac OS and File::Spec support CNANDOR 99-07-27 # Changed in 1.28 Additional questions for Perlbugtron RFOLEY 20.03.2000 +# Changed in 1.29 Perlbug(tron): auto(-ok), short prompts RFOLEY 05-05-2000 +# Changed in 1.30 Added warnings on failure to open files MSTEVENS 13-07-2000 +# Changed in 1.31 Add checks on close().Fix my $var unless. TJENNESS 26-07-2000 +# Changed in 1.32 Use File::Spec->tmpdir TJENNESS 20-08-2000 +# Changed in 1.33 Don't require -t STDOUT for -ok. # TODO: - Allow the user to re-name the file on mail failure, and # make sure failure (transmission-wise) of Mail::Send is @@ -131,7 +136,7 @@ my $Version = "1.28"; # - Test -b option my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename, - $subject, $from, $verbose, $ed, $outfile, $Is_MacOS, $category, $severity, + $subject, $from, $verbose, $ed, $outfile, $Is_MacOS, $category, $severity, $fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP, $ok); my $perl_version = $^V ? sprintf("v%vd", $^V) : $]; @@ -149,7 +154,6 @@ include a file, you can use the -f switch. EOF die "\n"; } -if (!-t STDOUT && !$outfile) { Dump(*STDOUT); exit; } Query(); Edit() unless $usefile || ($ok and not $::opt_n); @@ -158,30 +162,45 @@ Send(); exit; -sub ask_for_alternatives { +sub ask_for_alternatives { # (category|severity) my $name = shift; - my $default = shift; - my @alts = @_; + my %alts = ( + 'category' => { + 'default' => 'core', + 'ok' => 'install', + 'opts' => [qw(core docs install library utilities)], # patch, notabug + }, + 'severity' => { + 'default' => 'low', + 'ok' => 'none', + 'opts' => [qw(critical high medium low wishlist none)], # zero + }, + ); + die "Invalid alternative($name) requested\n" unless grep(/^$name$/, keys %alts); my $alt = ""; - paraprint <<EOF; + if ($ok) { + $alt = $alts{$name}{'ok'}; + } else { + my @alts = @{$alts{$name}{'opts'}}; + paraprint <<EOF; Please pick a \u$name from the following: @alts EOF - my $err = 0; - my $joined_alts = join('|', @alts); - do { - if ($err++ > 5) { - die "Invalid $name: aborting.\n"; - } - print "Please enter a \u$name [$default]: "; - $alt = <>; - chomp $alt; - if ($alt =~ /^\s*$/) { - $alt = $default; - } - } while ($alt !~ /^($joined_alts)$/i); + my $err = 0; + do { + if ($err++ > 5) { + die "Invalid $name: aborting.\n"; + } + print "Please enter a \u$name [$alts{$name}{'default'}]: "; + $alt = <>; + chomp $alt; + if ($alt =~ /^\s*$/) { + $alt = $alts{$name}{'default'}; + } + } while !((($alt) = grep(/^$alt/i, @alts))); + } lc $alt; } @@ -196,7 +215,7 @@ sub Init { MacPerl::Ask('Provide command-line args here (-h for help):') if $Is_MacOS && $MacPerl::Version =~ /App/; - if (!getopts("dhva:s:b:f:F:r:e:SCc:to:n:")) { Help(); exit; }; + if (!getopts("Adhva:s:b:f:F:r:e:SCc:to:n:")) { Help(); exit; }; # This comment is needed to notify metaconfig that we are # using the $perladmin, $cf_by, and $cf_time definitions. @@ -204,7 +223,7 @@ sub Init { # -------- Configuration --------- # perlbug address - $perlbug = 'perlbug@perl.com'; + $perlbug = 'perlbug@perl.org'; # Test address $testaddress = 'perlbug-test@perl.com'; @@ -276,8 +295,6 @@ EOF $subject = ($::opt_n ? 'Not ' : '') . "OK: perl $perl_version ${patch_tags}on" ." $::Config{'archname'} $::Config{'osvers'} $subject"; - $category = "install"; - $severity = "none"; $ok = 1; } else { Help(); @@ -468,14 +485,10 @@ EOF } # Prompt for category of bug - $category ||= ask_for_alternatives("category", "core", - qw(core docs install - library utilities)); + $category ||= ask_for_alternatives('category'); # Prompt for severity of bug - $severity ||= ask_for_alternatives("severity", "low", - qw(critical high medium - low wishlist none)); + $severity ||= ask_for_alternatives('severity'); # Generate scratch file to edit report in $filename = filename(); @@ -509,7 +522,7 @@ EOF } # Generate report - open(REP,">$filename"); + open(REP,">$filename") or die "Unable to create report file `$filename': $!\n"; my $reptype = !$ok ? "bug" : $::opt_n ? "build failure" : "success"; print REP <<EOF; @@ -526,7 +539,7 @@ EOF while (<F>) { print REP $_ } - close(F); + close(F) or die "Error closing `$file': $!"; } else { print REP <<EOF; @@ -540,17 +553,17 @@ EOF EOF } Dump(*REP); - close(REP); + close(REP) or die "Error closing report file: $!"; # read in the report template once so that # we can track whether the user does any editing. # yes, *all* whitespace is ignored. - open(REP, "<$filename"); + open(REP, "<$filename") or die "Unable to open report file `$filename': $!\n"; while (<REP>) { s/\s+//g; $REP{$_}++; } - close(REP); + close(REP) or die "Error closing report file `$filename': $!"; } # sub Query sub Dump { @@ -561,6 +574,13 @@ sub Dump { Flags: category=$category severity=$severity +EFF + if ($::opt_A) { + print OUT <<EFF; + ack=no +EFF + } + print OUT <<EFF; --- EFF print OUT "This perlbug was built using Perl $config_tag1\n", @@ -630,7 +650,8 @@ EOF } tryagain: - my $sts = system("$ed $filename") unless $Is_MacOS; + my $sts; + $sts = system("$ed $filename") unless $Is_MacOS; if ($Is_MacOS) { require ExtUtils::MakeMaker; ExtUtils::MM_MacOS::launch_file($filename); @@ -664,7 +685,7 @@ EOF # Check that we have a report that has some, eh, report in it. my $unseen = 0; - open(REP, "<$filename"); + open(REP, "<$filename") or die "Couldn't open `$filename': $!\n"; # a strange way to check whether any significant editing # have been done: check whether any new non-empty lines # have been added. Yes, the below code ignores *any* space @@ -719,22 +740,22 @@ EOF print "\nError opening $file: $!\n\n"; goto retry; } - open(REP, "<$filename"); + open(REP, "<$filename") or die "Couldn't open file `$filename': $!\n"; print FILE "To: $address\nSubject: $subject\n"; print FILE "Cc: $cc\n" if $cc; print FILE "Reply-To: $from\n" if $from; print FILE "\n"; while (<REP>) { print FILE } - close(REP); - close(FILE); + close(REP) or die "Error closing report file `$filename': $!"; + close(FILE) or die "Error closing $file: $!"; print "\nMessage saved in `$file'.\n"; exit; } elsif ($action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow # Display the message - open(REP, "<$filename"); + open(REP, "<$filename") or die "Couldn't open file `$filename': $!\n"; while (<REP>) { print $_ } - close(REP); + close(REP) or die "Error closing report file `$filename': $!"; } elsif ($action =~ /^se/i) { # <S>end # Send the message print "Are you certain you want to send this message?\n" @@ -755,7 +776,7 @@ EOF Edit(); } elsif ($action =~ /^[qc]/i) { # <C>ancel, <Q>uit Cancel(); - } elsif ($action =~ /^s/) { + } elsif ($action =~ /^s/i) { paraprint <<EOF; I'm sorry, but I didn't understand that. Please type "send" or "save". EOF @@ -776,9 +797,9 @@ sub Send { $msg->add("Reply-To",$from) if $from; $fh = $msg->open; - open(REP, "<$filename"); + open(REP, "<$filename") or die "Couldn't open `$filename': $!\n"; while (<REP>) { print $fh $_ } - close(REP); + close(REP) or die "Error closing $filename: $!"; $fh->close; print "\nMessage sent.\n"; @@ -823,16 +844,16 @@ report. We apologize for the inconvenience. So you may attempt to find some way of sending your message, it has been left in the file `$filename'. EOF - open(SENDMAIL, "|$sendmail -t") || die "'|$sendmail -t' failed: $!"; + open(SENDMAIL, "|$sendmail -t -oi") || die "'|$sendmail -t -oi' failed: $!"; sendout: print SENDMAIL "To: $address\n"; print SENDMAIL "Subject: $subject\n"; print SENDMAIL "Cc: $cc\n" if $cc; print SENDMAIL "Reply-To: $from\n" if $from; print SENDMAIL "\n\n"; - open(REP, "<$filename"); + open(REP, "<$filename") or die "Couldn't open `$filename': $!\n"; while (<REP>) { print SENDMAIL $_ } - close(REP); + close(REP) or die "Error closing $filename: $!"; if (close(SENDMAIL)) { printf "\nMessage %s.\n", $outfile ? "saved" : "sent"; @@ -853,7 +874,7 @@ be needed. Usage: $0 [-v] [-a address] [-s subject] [-b body | -f inpufile ] [ -F outputfile ] [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t] [-h] -$0 [-v] [-r returnaddress] [-ok | -okay | -nok | -nokay] +$0 [-v] [-r returnaddress] [-A] [-ok | -okay | -nok | -nokay] Simplest usage: run "$0", and follow the prompts. @@ -875,9 +896,9 @@ Options: this if you don't give it here. -e Editor to use. -t Test mode. The target address defaults to `$testaddress'. - -d Data mode (the default if you redirect or pipe output.) - This prints out your configuration data, without mailing + -d Data mode. This prints out your configuration data, without mailing anything. You can use this with -v to get more complete data. + -A Don't send a bug received acknowledgement to the return address. -ok Report successful build on this system to perl porters (use alone or with -v). Only use -ok if *everything* was ok: if there were *any* problems at all, use -nok. @@ -892,12 +913,8 @@ EOF } sub filename { - my $dir = $Is_VMS ? 'sys$scratch:' - : ($Is_MSWin32 && $ENV{'TEMP'}) ? $ENV{'TEMP'} - : $Is_MacOS ? $ENV{'TMPDIR'} - : '/tmp'; + my $dir = File::Spec->tmpdir(); $filename = "bugrep0$$"; -# $dir .= "\\" if $Is_MSWin32 and $dir !~ m|[\\/]$|; $filename++ while -e File::Spec->catfile($dir, $filename); $filename = File::Spec->catfile($dir, $filename); } @@ -929,10 +946,10 @@ B<perlbug> S<[ B<-v> ]> S<[ B<-a> I<address> ]> S<[ B<-s> I<subject> ]> S<[ B<-b> I<body> | B<-f> I<inputfile> ]> S<[ B<-F> I<outputfile> ]> S<[ B<-r> I<returnaddress> ]> S<[ B<-e> I<editor> ]> S<[ B<-c> I<adminaddress> | B<-C> ]> -S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-h> ]> +S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-A> ]> S<[ B<-h> ]> B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]> -S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]> + S<[ B<-A> ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]> =head1 DESCRIPTION @@ -950,7 +967,7 @@ will be needed. Simply run it, and follow the prompts. If you are unable to run B<perlbug> (most likely because you don't have a working setup to send mail that perlbug recognizes), you may have to -compose your own report, and email it to B<perlbug@perl.com>. You might +compose your own report, and email it to B<perlbug@perl.org>. You might find the B<-d> option useful to get summary information in that case. In any case, when reporting a bug, please make sure you have run through @@ -1028,7 +1045,7 @@ definitely be fixed. Use the C<diff> program to generate your patches (C<diff> is being maintained by the GNU folks as part of the B<diffutils> package, so you should be able to get it from any of the GNU software repositories). If you do submit a patch, the cool-dude counter at -perlbug@perl.com will register you as a savior of the world. Your +perlbug@perl.org will register you as a savior of the world. Your patch may be returned with requests for changes, or requests for more detailed explanations about your fix. @@ -1048,7 +1065,7 @@ B<perlbug> will, amongst other things, ensure your report includes crucial information about your version of perl. If C<perlbug> is unable to mail your report after you have typed it in, you may have to compose the message yourself, add the output produced by C<perlbug -d> and email -it to B<perlbug@perl.com>. If, for some reason, you cannot run +it to B<perlbug@perl.org>. If, for some reason, you cannot run C<perlbug> at all on your system, be sure to include the entire output produced by running C<perl -V> (note the uppercase V). @@ -1075,7 +1092,14 @@ version of perl comes out and your bug is still present. =item B<-a> -Address to send the report to. Defaults to `perlbug@perl.com'. +Address to send the report to. Defaults to `perlbug@perl.org'. + +=item B<-A> + +Don't send a bug received acknowledgement to the reply address. +Generally it is only a sensible to use this option if you are a +perl maintainer actively watching perl porters for your message to +arrive. =item B<-b> diff --git a/contrib/perl5/utils/perlcc.PL b/contrib/perl5/utils/perlcc.PL index f0636f62bd1b..63045559d80b 100644 --- a/contrib/perl5/utils/perlcc.PL +++ b/contrib/perl5/utils/perlcc.PL @@ -31,1084 +31,632 @@ print OUT <<"!GROK!THIS!"; $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' if \$running_under_some_shell; +--\$running_under_some_shell; !GROK!THIS! # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; -use Config; +# Version 2.0, Simon Cozens, Thu Mar 30 17:52:45 JST 2000 +# Version 2.01, Tom Christiansen, Thu Mar 30 08:25:14 MST 2000 +# Version 2.02, Simon Cozens, Sun Apr 16 01:53:36 JST 2000 +# Version 2.03, Edward Peschko, Mon Feb 26 12:04:17 PST 2001 + use strict; +use warnings; +use v5.6.0; + use FileHandle; -use File::Basename qw(&basename &dirname); +use Config; +use Fcntl qw(:DEFAULT :flock); +use File::Temp qw(tempfile); use Cwd; +our $VERSION = 2.03; +$| = 1; -use Getopt::Long; +$SIG{INT} = sub { exit(); }; # exit gracefully and clean up after ourselves. -$Getopt::Long::bundling_override = 1; -$Getopt::Long::passthrough = 0; -$Getopt::Long::ignore_case = 0; +use subs qw{ + cc_harness check_read check_write checkopts_byte choose_backend + compile_byte compile_cstyle compile_module generate_code + grab_stash parse_argv sanity_check vprint yclept spawnit +}; +sub opt(*); # imal quoting -my $pathsep = ($Config{'osname'} eq 'MSWin32')? "\\" : "/"; # MAJOR HACK. SHOULD - # BE IN Config.pm +our ($Options, $BinPerl, $Backend); +our ($Input => $Output); +our ($logfh); +our ($cfile); -my $options = {}; -my $_fh; -unshift @ARGV, split ' ', $ENV{PERLCC_OPTS} if $ENV{PERLCC_OPTS}; +# eval { main(); 1 } or die; main(); -sub main -{ - - GetOptions - ( - $options, "L:s", - "I:s", - "C:s", - "o:s", - "e:s", - "regex:s", - "verbose:s", - "log:s", - "argv:s", - "b", - "opt", - "gen", - "sav", - "run", - "prog", - "mod" - ); - - - my $key; - - local($") = "|"; - - _usage() if (!_checkopts()); - push(@ARGV, _maketempfile()) if ($options->{'e'}); - - _usage() if (!@ARGV); - - my $file; - foreach $file (@ARGV) - { - _print(" --------------------------------------------------------------------------------- -Compiling $file: --------------------------------------------------------------------------------- -", 36 ); - _doit($file); - } +sub main { + parse_argv(); + check_write($Output); + choose_backend(); + generate_code(); + run_code(); + _die("XXX: Not reached?"); } - -sub _doit -{ - my ($file) = @_; - - my ($program_ext, $module_ext) = _getRegexps(); - my ($obj, $objfile, $so, $type, $backend, $gentype); - - $backend = $options->{'b'} ? 'Bytecode' : $options->{'opt'} ? 'CC' : 'C'; - - $gentype = $options->{'b'} ? 'Bytecode' : 'C'; - - if ( - (($file =~ m"@$program_ext") && ($file !~ m"@$module_ext")) - || (defined($options->{'prog'}) || defined($options->{'run'})) - ) - { - $type = 'program'; - - if ($options->{'b'}) - { - $obj = $objfile = $options->{'o'} ? $options->{'o'} : "${file}c"; - } - else - { - $objfile = $options->{'C'} ? $options->{'C'} : "$file.c"; - $obj = $options->{'o'} ? $options->{'o'} - : _getExecutable( $file,$program_ext); - } - return() if (!$obj); +####################################################################### +sub choose_backend { + # Choose the backend. + $Backend = 'C'; + if (opt(B)) { + checkopts_byte(); + $Backend = 'Bytecode'; } - elsif (($file =~ m"@$module_ext") || ($options->{'mod'})) - { - $type = 'module'; - - if ($options->{'b'}) - { - $obj = $objfile = $options->{'o'} ? $options->{'o'} : "${file}c"; - } - else - { - die "Shared objects are not supported on Win32 yet!!!!\n" - if ($Config{'osname'} eq 'MSWin32'); - - $objfile = $options->{'C'} ? $options->{'C'} : "$file.c"; - $obj = $options->{'o'} ? $options->{'o'} - : _getExecutable($file, $module_ext); - $so = "$obj.$Config{so}"; - } - - return() if (!$obj); - } - else - { - _error("noextension", $file, $program_ext, $module_ext); - return(); + if (opt(S) && opt(c)) { + # die "$0: Do you want me to compile this or not?\n"; + delete $Options->{S}; } + $Backend = 'CC' if opt(O); +} - if ($type eq 'program') - { - _print("Making $gentype($objfile) for $file!\n", 36 ); - - my $errcode = _createCode($backend, $objfile, $file); - (_print( "ERROR: In generating code for $file!\n", -1), return()) - if ($errcode); - - _print("Compiling C($obj) for $file!\n", 36 ) if (!$options->{'gen'} && - !$options->{'b'}); - $errcode = _compileCode($file, $objfile, $obj) - if (!$options->{'gen'} && - !$options->{'b'}); - - if ($errcode) - { - _print( "ERROR: In compiling code for $objfile !\n", -1); - my $ofile = File::Basename::basename($objfile); - $ofile =~ s"\.c$"\.o"s; - - _removeCode("$ofile"); - return() - } - - _runCode($objfile) if ($options->{'run'} && $options->{'b'}); - _runCode($obj) if ($options->{'run'} && !$options->{'b'}); - - _removeCode($objfile) if (($options->{'b'} && - ($options->{'e'} && !$options->{'o'})) || - (!$options->{'b'} && - (!$options->{'sav'} || - ($options->{'e'} && !$options->{'C'})))); - _removeCode($file) if ($options->{'e'}); +sub generate_code { - _removeCode($obj) if (!$options->{'b'} && - (($options->{'e'} && - !$options->{'sav'} && !$options->{'o'}) || - ($options->{'run'} && !$options->{'sav'}))); - } - else - { - _print( "Making $gentype($objfile) for $file!\n", 36 ); - my $errcode = _createCode($backend, $objfile, $file, $obj); - (_print( "ERROR: In generating code for $file!\n", -1), return()) - if ($errcode); - - _print( "Compiling C($so) for $file!\n", 36 ) if (!$options->{'gen'} && - !$options->{'b'}); + vprint 0, "Compiling $Input"; - $errcode = - _compileCode($file, $objfile, $obj, $so ) if (!$options->{'gen'} && - !$options->{'b'}); + $BinPerl = yclept(); # Calling convention for perl. - (_print( "ERROR: In compiling code for $objfile!\n", -1), return()) - if ($errcode); + if (opt(shared)) { + compile_module(); + } else { + if ($Backend eq 'Bytecode') { + compile_byte(); + } else { + compile_cstyle(); + } } + exit(0) if (!opt('r')); } -sub _getExecutable -{ - my ($sourceprog, $ext) = @_; - my ($obj); - - if (defined($options->{'regex'})) - { - eval("(\$obj = \$sourceprog) =~ $options->{'regex'}"); - return(0) if (_error('badeval', $@)); - return(0) if (_error('equal', $obj, $sourceprog)); - } - elsif (defined ($options->{'ext'})) - { - ($obj = $sourceprog) =~ s"@$ext"$options->{ext}"g; - return(0) if (_error('equal', $obj, $sourceprog)); - } - elsif (defined ($options->{'run'})) - { - $obj = "perlc$$"; - } - else - { - ($obj = $sourceprog) =~ s"@$ext""g; - return(0) if (_error('equal', $obj, $sourceprog)); - } - return($obj); +sub run_code { + vprint 0, "Running code"; + run("$Output @ARGV"); + exit(0); } -sub _createCode -{ - my ( $backend, $generated_file, $file, $final_output ) = @_; - my $return; - my $output_switch = "o"; - my $max_line_len = ''; - - local($") = " -I"; - - if ($^O eq 'MSWin32' && $backend =~ /^CC?$/ && $Config{cc} =~ /^cl/i) { - $max_line_len = '-l2000,'; - } - - if ($backend eq "Bytecode") - { - require ByteLoader; - - open(GENFILE, "> $generated_file") || die "Can't open $generated_file: $!"; - binmode GENFILE; - print GENFILE "#!$^X\n" if @_ == 3; - print GENFILE "use ByteLoader $ByteLoader::VERSION;\n"; - close(GENFILE); - - $output_switch ="a"; - } - - if (@_ == 3) # compiling a program - { - chmod $generated_file, 0777 & ~umask if $backend eq "Bytecode"; - my $null=File::Spec->devnull; - _print( "$^X -I@INC -MB::Stash -c $file\n", 36); - my @stash=`$^X -I@INC -MB::Stash -c $file 2>$null`; - my $stash=$stash[-1]; - chomp $stash; - - _print( "$^X -I@INC -MO=$backend,$max_line_len$stash $file\n", 36); - $return = _run("$^X -I@INC -MO=$backend,$max_line_len$stash,-$output_switch$generated_file $file", 9); - $return; - } - else # compiling a shared object - { - _print( - "$^X -I@INC -MO=$backend,$max_line_len-m$final_output $file\n", 36); - $return = - _run("$^X -I@INC -MO=$backend,$max_line_len-m$final_output,-$output_switch$generated_file $file ", 9); - $return; +# usage: vprint [level] msg args +sub vprint { + my $level; + if (@_ == 1) { + $level = 1; + } elsif ($_[0] =~ /^\d$/) { + $level = shift; + } else { + # well, they forgot to use a number; means >0 + $level = 0; + } + my $msg = "@_"; + $msg .= "\n" unless substr($msg, -1) eq "\n"; + if (opt(v) > $level) + { + print "$0: $msg" if !opt('log'); + print $logfh "$0: $msg" if opt('log'); } } -sub _compileCode -{ - my ($sourceprog, $generated_cfile, $output_executable, $shared_object) = @_; - my @return; - - if (@_ == 3) # just compiling a program - { - $return[0] = - _ccharness('static', $sourceprog, "-o", $output_executable, - $generated_cfile); - $return[0]; - } - else - { - my $object_file = $generated_cfile; - $object_file =~ s"\.c$"$Config{_o}"; - - $return[0] = _ccharness('compile', $sourceprog, "-c", $generated_cfile); - $return[1] = _ccharness - ( - 'dynamic', - $sourceprog, "-o", - $shared_object, $object_file - ); - return(1) if (grep ($_, @return)); - return(0); +sub parse_argv { + + use Getopt::Long; +# Getopt::Long::Configure("bundling"); turned off. this is silly because +# it doesn't allow for long switches. + Getopt::Long::Configure("no_ignore_case"); + + # no difference in exists and defined for %ENV; also, a "0" + # argument or a "" would not help cc, so skip + unshift @ARGV, split ' ', $ENV{PERLCC_OPTS} if $ENV{PERLCC_OPTS}; + + $Options = {}; + Getopt::Long::GetOptions( $Options, + 'L:s', # lib directory + 'I:s', # include directories (FOR C, NOT FOR PERL) + 'o:s', # Output executable + 'v:i', # Verbosity level + 'e:s', # One-liner + 'r', # run resulting executable + 'B', # Byte compiler backend + 'O', # Optimised C backend + 'c', # Compile only + 'h', # Help me + 'S', # Dump C files + 'r', # run the resulting executable + 'static', # Dirty hack to enable -shared/-static + 'shared', # Create a shared library (--shared for compat.) + 'log:s' # where to log compilation process information + ); + + # This is an attempt to make perlcc's arg. handling look like cc. + # if ( opt('s') ) { # must quote: looks like s)foo)bar)! + # if (opt('s') eq 'hared') { + # $Options->{shared}++; + # } elsif (opt('s') eq 'tatic') { + # $Options->{static}++; + # } else { + # warn "$0: Unknown option -s", opt('s'); + # } + # } + + $Options->{v} += 0; + + helpme() if opt(h); # And exit + + $Output = opt(o) || 'a.out'; + $Output = relativize($Output); + $logfh = new FileHandle(">> " . opt('log')) if (opt('log')); + + if (opt(e)) { + warn "$0: using -e 'code' as input file, ignoring @ARGV\n" if @ARGV; + # We don't use a temporary file here; why bother? + # XXX: this is not bullet proof -- spaces or quotes in name! + $Input = "-e '".opt(e)."'"; # Quotes eaten by shell + } else { + $Input = shift @ARGV; # XXX: more files? + _usage_and_die("$0: No input file specified\n") unless $Input; + # DWIM modules. This is bad but necessary. + $Options->{shared}++ if $Input =~ /\.pm\z/; + warn "$0: using $Input as input file, ignoring @ARGV\n" if @ARGV; + check_read($Input); + check_perl($Input); + sanity_check(); } -} -sub _runCode -{ - my ($executable) = @_; - _print("$executable $options->{'argv'}\n", 36); - _run("$executable $options->{'argv'}", -1 ); } -sub _removeCode -{ - my ($file) = @_; - unlink($file) if (-e $file); -} - -sub _ccharness -{ - my $type = shift; - my (@args) = @_; - local($") = " "; - - my $sourceprog = shift(@args); - my ($libdir, $incdir); - - my $L = '-L'; - $L = '-libpath:' if $^O eq 'MSWin32' && $Config{cc} =~ /^cl/i; - - if (-d "$Config{installarchlib}/CORE") - { - $libdir = "$L$Config{installarchlib}/CORE"; - $incdir = "-I$Config{installarchlib}/CORE"; - } - else - { - $libdir = "$L.. $L."; - $incdir = "-I.. -I."; - } - - $libdir .= " $L$options->{L}" if (defined($options->{L})); - $incdir .= " -I$options->{L}" if (defined($options->{L})); - - my $linkargs = ''; - my $dynaloader = ''; - my $optimize = ''; - my $flags = ''; +sub opt(*) { + my $opt = shift; + return exists($Options->{$opt}) && ($Options->{$opt} || 0); +} - if (!grep(/^-[cS]$/, @args)) - { - my $lperl = $^O eq 'os2' ? '-llibperl' - : $^O eq 'MSWin32' ? "$Config{archlibexp}\\CORE\\$Config{libperl}" - : '-lperl'; - ($lperl = $Config{libperl}) =~ s/lib(.*)\Q$Config{_a}\E/-l$1/ - if($^O eq 'cygwin'); - - $optimize = $Config{'optimize'} =~ /-O\d/ ? '' : $Config{'optimize'}; - - $flags = $type eq 'dynamic' ? $Config{lddlflags} : $Config{ldflags}; - $linkargs = "$flags $libdir $lperl @Config{libs}"; - $linkargs = "/link $linkargs" if $^O eq 'MSWin32' && $Config{cc} =~ /^cl/i; - } - - my $libs = _getSharedObjects($sourceprog); - @$libs = grep { !(/DynaLoader\.a$/ && ($dynaloader = $_)) } @$libs - if($^O eq 'cygwin'); - - my $args = "@args"; - if ($^O eq 'MSWin32' && $Config{cc} =~ /^bcc/i) { - # BC++ cmd line syntax does not allow space between -[oexz...] and arg - $args =~ s/(^|\s+)-([oe])\s+/$1-$2/g; - } - - my $ccflags = $Config{ccflags}; - $ccflags .= ' -DUSEIMPORTLIB' if $^O eq 'cygwin'; - my $cccmd = "$Config{cc} $ccflags $optimize $incdir " - ."$args $dynaloader $linkargs @$libs"; - - _print ("$cccmd\n", 36); - _run("$cccmd", 18 ); +sub compile_module { + die "$0: Compiling to shared libraries is currently disabled\n"; } -sub _getSharedObjects -{ - my ($sourceprog) = @_; - my ($tmpfile, $incfile); - my (@sharedobjects, @libraries); - local($") = " -I"; +sub compile_byte { + require ByteLoader; + my $stash = grab_stash(); + my $command = "$BinPerl -MO=Bytecode,$stash $Input"; + # The -a option means we'd have to close the file and lose the + # lock, which would create the tiniest of races. Instead, append + # the output ourselves. + vprint 1, "Writing on $Output"; - my ($tmpprog); - ($tmpprog = $sourceprog) =~ s"(.*)[\\/](.*)"$2"; + my $openflags = O_WRONLY | O_CREAT; + $openflags |= O_BINARY if eval { O_BINARY; 1 }; + $openflags |= O_EXLOCK if eval { O_EXLOCK; 1 }; - my $tempdir= File::Spec->tmpdir; + # these dies are not "$0: .... \n" because they "can't happen" - $tmpfile = "$tempdir/$tmpprog.tst"; - $incfile = "$tempdir/$tmpprog.val"; + sysopen(OUT, $Output, $openflags) + or die "can't write to $Output: $!"; - my $fd = new FileHandle("> $tmpfile") || die "Couldn't open $tmpfile!\n"; - my $fd2 = - new FileHandle("$sourceprog") || die "Couldn't open $sourceprog!\n"; + # this is blocking; hold on; why are we doing this?? + # flock OUT, LOCK_EX or die "can't lock $Output: $!" + # unless eval { O_EXLOCK; 1 }; - print $fd <<"EOF"; - use FileHandle; - my \$fh3 = new FileHandle("> $incfile") - || die "Couldn't open $incfile\\n"; + truncate(OUT, 0) + or die "couldn't trunc $Output: $!"; - my \$key; - foreach \$key (keys(\%INC)) { print \$fh3 "\$key:\$INC{\$key}\\n"; } - close(\$fh3); - exit(); + print OUT <<EOF; +#!$^X +use ByteLoader $ByteLoader::VERSION; EOF - print $fd ( <$fd2> ); - close($fd); - - _print("$^X -I@INC $tmpfile\n", 36); - _run("$^X -I@INC $tmpfile", 9 ); + # Now the compile: + vprint 1, "Compiling..."; + vprint 3, "Calling $command"; - $fd = new FileHandle ("$incfile"); - my @lines = <$fd>; + my ($output_r, $error_r) = spawnit($command); - unlink($tmpfile); - unlink($incfile); - - my $line; - my $autolib; - - my @return; - - foreach $line (@lines) - { - chomp($line); - - my ($modname, $modpath) = split(':', $line); - my ($dir, $file) = ($modpath=~ m"(.*)[\\/]($modname)"); - - if ($autolib = _lookforAuto($dir, $file)) { push(@return, $autolib); } + if (@$error_r && $? != 0) { + _die("$0: $Input did not compile, which can't happen:\n@$error_r\n"); + } else { + my @error = grep { !/^$Input syntax OK$/o } @$error_r; + warn "$0: Unexpected compiler output:\n@error" if @error; } - return(\@return); -} + + # Write it and leave. + print OUT @$output_r or _die("can't write $Output: $!"); + close OUT or _die("can't close $Output: $!"); -sub _maketempfile -{ - my $return; - -# if ($Config{'osname'} eq 'MSWin32') -# { $return = "C:\\TEMP\\comp$$.p"; } -# else -# { $return = "/tmp/comp$$.p"; } - - $return = "comp$$.p"; - - my $fd = new FileHandle( "> $return") || die "Couldn't open $return!\n"; - print $fd $options->{'e'}; - close($fd); - - return($return); + # wait, how could it be anything but what you see next? + chmod 0777 & ~umask, $Output or _die("can't chmod $Output: $!"); + exit 0; } - - -sub _lookforAuto -{ - my ($dir, $file) = @_; - my ($relabs, $relshared); - my ($prefix); - my $return; - my $sharedextension = $^O =~ /MSWin32|cygwin|os2/i - ? $Config{_a} : ".$Config{so}"; - ($prefix = $file) =~ s"(.*)\.pm"$1"; - - my ($tmp, $modname) = ($prefix =~ m"(?:(.*)[\\/]){0,1}(.*)"s); - - $relshared = "$pathsep$prefix$pathsep$modname$sharedextension"; - $relabs = "$pathsep$prefix$pathsep$modname$Config{_a}"; - # HACK . WHY DOES _a HAVE A '.' - # AND so HAVE NONE?? - - my @searchpaths = map("$_${pathsep}auto", @INC); +sub compile_cstyle { + my $stash = grab_stash(); - my $path; - foreach $path (@searchpaths) - { - if (-e ($return = "$path$relshared")) { return($return); } - if (-e ($return = "$path$relabs")) { return($return); } + # What are we going to call our output C file? + my $lose = 0; + my ($cfh); + + if (opt(S) || opt(c)) { + # We need to keep it. + if (opt(e)) { + $cfile = "a.out.c"; + } else { + $cfile = $Input; + # File off extension if present + # hold on: plx is executable; also, careful of ordering! + $cfile =~ s/\.(?:p(?:lx|l|h)|m)\z//i; + $cfile .= ".c"; + $cfile = $Output if opt(c) && $Output =~ /\.c\z/i; + } + check_write($cfile); + } else { + # Don't need to keep it, be safe with a tempfile. + $lose = 1; + ($cfh, $cfile) = tempfile("pccXXXXX", SUFFIX => ".c"); + close $cfh; # See comment just below } - return(undef); -} - -sub _getRegexps # make the appropriate regexps for making executables, -{ # shared libs - - my ($program_ext, $module_ext) = ([],[]); + vprint 1, "Writing C on $cfile"; + my $max_line_len = ''; + if ($^O eq 'MSWin32' && $Config{cc} =~ /^cl/i) { + $max_line_len = '-l2000,'; + } - @$program_ext = ($ENV{PERL_SCRIPT_EXT})? split(':', $ENV{PERL_SCRIPT_EXT}) : - ('.p$', '.pl$', '.bat$'); + # This has to do the write itself, so we can't keep a lock. Life + # sucks. + my $command = "$BinPerl -MO=$Backend,$max_line_len$stash,-o$cfile $Input"; + vprint 1, "Compiling..."; + vprint 1, "Calling $command"; + my ($output_r, $error_r) = spawnit($command); + my @output = @$output_r; + my @error = @$error_r; - @$module_ext = ($ENV{PERL_MODULE_EXT})? split(':', $ENV{PERL_MODULE_EXT}) : - ('.pm$'); + if (@error && $? != 0) { + _die("$0: $Input did not compile, which can't happen:\n@error\n"); + } - _mungeRegexp( $program_ext ); - _mungeRegexp( $module_ext ); + cc_harness($cfile,$stash) unless opt(c); - return($program_ext, $module_ext); + if ($lose) { + vprint 2, "unlinking $cfile"; + unlink $cfile or _die("can't unlink $cfile: $!"); + } } -sub _mungeRegexp -{ - my ($regexp) = @_; - - grep(s:(^|[^\\])\.:$1\x00\\.:g, @$regexp); - grep(s:(^|[^\x00])\\\.:$1\.:g, @$regexp); - grep(s:\x00::g, @$regexp); +sub cc_harness { + my ($cfile,$stash)=@_; + use ExtUtils::Embed (); + my $command = ExtUtils::Embed::ccopts." -o $Output $cfile "; + $command .= " -I".$_ for split /\s+/, opt(I); + $command .= " -L".$_ for split /\s+/, opt(L); + my @mods = split /-?u /, $stash; + $command .= " ".ExtUtils::Embed::ldopts("-std", \@mods); + vprint 3, "running $Config{cc} $command"; + system("$Config{cc} $command"); } -sub _error -{ - my ($type, @args) = @_; - - if ($type eq 'equal') - { - - if ($args[0] eq $args[1]) - { - _print ("ERROR: The object file '$args[0]' does not generate a legitimate executable file! Skipping!\n", -1); - return(1); +# Where Perl is, and which include path to give it. +sub yclept { + my $command = "$^X "; + + # DWIM the -I to be Perl, not C, include directories. + if (opt(I) && $Backend eq "Bytecode") { + for (split /\s+/, opt(I)) { + if (-d $_) { + push @INC, $_; + } else { + warn "$0: Include directory $_ not found, skipping\n"; + } } } - elsif ($type eq 'badeval') - { - if ($args[0]) - { - _print ("ERROR: $args[0]\n", -1); - return(1); - } - } - elsif ($type eq 'noextension') - { - my $progext = join(',', @{$args[1]}); - my $modext = join(',', @{$args[2]}); + + $command .= "-I$_ " for @INC; + return $command; +} - $progext =~ s"\\""g; - $modext =~ s"\\""g; +# Use B::Stash to find additional modules and stuff. +{ + my $_stash; + sub grab_stash { - $progext =~ s"\$""g; - $modext =~ s"\$""g; + warn "already called get_stash once" if $_stash; - _print - ( -" -ERROR: '$args[0]' does not have a proper extension! Proper extensions are: + my $command = "$BinPerl -MB::Stash -c $Input"; + # Filename here is perfectly sanitised. + vprint 3, "Calling $command\n"; - PROGRAM: $progext - SHARED OBJECT: $modext + my ($stash_r, $error_r) = spawnit($command); + my @stash = @$stash_r; + my @error = @$error_r; -Use the '-prog' flag to force your files to be interpreted as programs. -Use the '-mod' flag to force your files to be interpreted as modules. -", -1 - ); - return(1); + if (@error && $? != 0) { + _die("$0: $Input did not compile:\n@error\n"); + } + + $stash[0] =~ s/,-u\<none\>//; + vprint 2, "Stash: ", join " ", split /,?-u/, $stash[0]; + chomp $stash[0]; + return $_stash = $stash[0]; } - return(0); } -sub _checkopts -{ - my @errors; - local($") = "\n"; - - if ($options->{'log'}) - { - $_fh = new FileHandle(">> $options->{'log'}") || push(@errors, "ERROR: Couldn't open $options->{'log'}\n"); - } +# Check the consistency of options if -B is selected. +# To wit, (-B|-O) ==> no -shared, no -S, no -c +sub checkopts_byte { - if ($options->{'b'} && $options->{'c'}) - { - push(@errors, -"ERROR: The '-b' and '-c' options are incompatible. The '-c' option specifies - a name for the intermediate C code but '-b' generates byte code - directly.\n"); - } - if ($options->{'b'} && ($options->{'sav'} || $options->{'gen'})) - { - push(@errors, -"ERROR: The '-sav' and '-gen' options are incompatible with the '-b' option. - They ask for intermediate C code to be saved by '-b' generates byte - code directly.\n"); - } + _die("$0: Please choose one of either -B and -O.\n") if opt(O); - if (($options->{'c'}) && (@ARGV > 1) && ($options->{'sav'} )) - { - push(@errors, -"ERROR: The '-sav' and '-C' options are incompatible when you have more than - one input file! ('-C' explicitly names resulting C code, '-sav' saves it, - and hence, with more than one file, the c code will be overwritten for - each file that you compile)\n"); - } - if (($options->{'o'}) && (@ARGV > 1)) - { - push(@errors, -"ERROR: The '-o' option is incompatible when you have more than one input - file! (-o explicitly names the resulting file, hence, with more than - one file the names clash)\n"); + if (opt(shared)) { + warn "$0: Will not create a shared library for bytecode\n"; + delete $Options->{shared}; } - if ($options->{'e'} && ($options->{'sav'} || $options->{'gen'}) && - !$options->{'C'}) - { - push(@errors, -"ERROR: You need to specify where you are going to save the resulting - C code when using '-sav' and '-e'. Use '-C'.\n"); + for my $o ( qw[c S] ) { + if (opt($o)) { + warn "$0: Compiling to bytecode is a one-pass process--", + "-$o ignored\n"; + delete $Options->{$o}; + } } - if (($options->{'regex'} || $options->{'run'} || $options->{'o'}) - && $options->{'gen'}) - { - push(@errors, -"ERROR: The options '-regex', '-run', and '-o' are incompatible with '-gen'. - '-gen' says to stop at C generation, and the other three modify the - compilation and/or running process!\n"); - } +} - if ($options->{'run'} && $options->{'mod'}) - { - push(@errors, -"ERROR: Can't run modules that you are compiling! '-run' and '-mod' are - incompatible!\n"); +# Check the input and output files make sense, are read/writeable. +sub sanity_check { + if ($Input eq $Output) { + if ($Input eq 'a.out') { + _die("$0: Compiling a.out is probably not what you want to do.\n"); + # You fully deserve what you get now. No you *don't*. typos happen. + } else { + warn "$0: Will not write output on top of input file, ", + "compiling to a.out instead\n"; + $Output = "a.out"; + } } +} - if ($options->{'e'} && @ARGV) - { - push (@errors, -"ERROR: The option '-e' needs to be all by itself without any other - file arguments!\n"); - } - if ($options->{'e'} && !($options->{'o'} || $options->{'run'})) - { - $options->{'run'} = 1; +sub check_read { + my $file = shift; + unless (-r $file) { + _die("$0: Input file $file is a directory, not a file\n") if -d _; + unless (-e _) { + _die("$0: Input file $file was not found\n"); + } else { + _die("$0: Cannot read input file $file: $!\n"); + } } + unless (-f _) { + # XXX: die? don't try this on /dev/tty + warn "$0: WARNING: input $file is not a plain file\n"; + } +} - if (!defined($options->{'verbose'})) - { - $options->{'verbose'} = ($options->{'log'})? 64 : 7; +sub check_write { + my $file = shift; + if (-d $file) { + _die("$0: Cannot write on $file, is a directory\n"); } - - my $verbose_error; - - if ($options->{'verbose'} =~ m"[^tagfcd]" && - !( $options->{'verbose'} eq '0' || - ($options->{'verbose'} < 64 && $options->{'verbose'} > 0))) - { - $verbose_error = 1; - push(@errors, -"ERROR: Illegal verbosity level. Needs to have either the letters - 't','a','g','f','c', or 'd' in it or be between 0 and 63, inclusive.\n"); + if (-e _) { + _die("$0: Cannot write on $file: $!\n") unless -w _; + } + unless (-w cwd()) { + _die("$0: Cannot write in this directory: $!\n"); } +} - $options->{'verbose'} = ($options->{'verbose'} =~ m"[tagfcd]")? - ($options->{'verbose'} =~ m"d") * 32 + - ($options->{'verbose'} =~ m"c") * 16 + - ($options->{'verbose'} =~ m"f") * 8 + - ($options->{'verbose'} =~ m"t") * 4 + - ($options->{'verbose'} =~ m"a") * 2 + - ($options->{'verbose'} =~ m"g") * 1 - : $options->{'verbose'}; - - if (!$verbose_error && ( $options->{'log'} && - !( - ($options->{'verbose'} & 8) || - ($options->{'verbose'} & 16) || - ($options->{'verbose'} & 32 ) - ) - ) - ) - { - push(@errors, -"ERROR: The verbosity level '$options->{'verbose'}' does not output anything - to a logfile, and you specified '-log'!\n"); - } # } - - if (!$verbose_error && ( !$options->{'log'} && - ( - ($options->{'verbose'} & 8) || - ($options->{'verbose'} & 16) || - ($options->{'verbose'} & 32) || - ($options->{'verbose'} & 64) - ) - ) - ) - { - push(@errors, -"ERROR: The verbosity level '$options->{'verbose'}' requires that you also - specify a logfile via '-log'\n"); - } # } - - - (_print( "\n". join("\n", @errors), -1), return(0)) if (@errors); - return(1); +sub check_perl { + my $file = shift; + unless (-T $file) { + warn "$0: Binary `$file' sure doesn't smell like perl source!\n"; + print "Checking file type... "; + system("file", $file); + _die("Please try a perlier file!\n"); + } + + open(my $handle, "<", $file) or _die("XXX: can't open $file: $!"); + local $_ = <$handle>; + if (/^#!/ && !/perl/) { + _die("$0: $file is a ", /^#!\s*(\S+)/, " script, not perl\n"); + } + +} + +# File spawning and error collecting +sub spawnit { + my ($command) = shift; + my (@error,@output); + my $errname; + (undef, $errname) = tempfile("pccXXXXX"); + { + open (S_OUT, "$command 2>$errname |") + or _die("$0: Couldn't spawn the compiler.\n"); + @output = <S_OUT>; + } + open (S_ERROR, $errname) or _die("$0: Couldn't read the error file.\n"); + @error = <S_ERROR>; + close S_ERROR; + close S_OUT; + unlink $errname or _die("$0: Can't unlink error file $errname"); + return (\@output, \@error); } -sub _print -{ - my ($text, $flag ) = @_; - - my $logflag = int($flag/8) * 8; - my $regflag = $flag % 8; +sub helpme { + print "perlcc compiler frontend, version $VERSION\n\n"; + { no warnings; + exec "pod2usage $0"; + exec "perldoc $0"; + exec "pod2text $0"; + } +} - if ($flag == -1 || ($flag & $options->{'verbose'})) - { - my $dolog = ((($logflag & $options->{'verbose'}) || $flag == -1) - && $options->{'log'}); +sub relativize { + my ($args) = @_; - my $doreg = (($regflag & $options->{'verbose'}) || $flag == -1); - - if ($doreg) { print( STDERR $text ); } - if ($dolog) { print $_fh $text; } - } + return() if ($args =~ m"^[/\\]"); + return("./$args"); } -sub _run -{ - my ($command, $flag) = @_; +sub _die { + $logfh->print(@_) if opt('log'); + print STDERR @_; + exit(); # should die eventually. However, needed so that a 'make compile' + # can compile all the way through to the end for standard dist. +} - my $logflag = ($flag != -1)? int($flag/8) * 8 : 0; - my $regflag = $flag % 8; +sub _usage_and_die { + _die(<<EOU); +$0: Usage: +$0 [-o executable] [-r] [-O|-B|-c|-S] [-log log] [source[.pl] | -e oneliner] +EOU +} - if ($flag == -1 || ($flag & $options->{'verbose'})) - { - my $dolog = ($logflag & $options->{'verbose'} && $options->{'log'}); - my $doreg = (($regflag & $options->{'verbose'}) || $flag == -1); +sub run { + my (@commands) = @_; - if ($doreg && !$dolog) - { - print _interruptrun("$command"); - } - elsif ($doreg && $dolog) - { - my $text = _interruptrun($command); - print $_fh $text; - print STDERR $text; - } - else - { - my $text = _interruptrun($command); - print $_fh $text; - } - } - else - { - _interruptrun($command); - } - return($?); + print interruptrun(@commands) if (!opt('log')); + $logfh->print(interruptrun(@commands)) if (opt('log')); } -sub _interruptrun +sub interruptrun { - my ($command) = @_; - my $pid = open (FD, "$command |"); - - local($SIG{HUP}) = sub { -# kill 9, $pid + 1; -# HACK... 2>&1 doesn't propogate -# kill, comment out for quick and dirty -# process killing of child. + my (@commands) = @_; - kill 9, $pid; - exit(); - }; - local($SIG{INT}) = sub { -# kill 9, $pid + 1; -# HACK... 2>&1 doesn't propogate -# kill, comment out for quick and dirty -# process killing of child. - kill 9, $pid; - exit(); - }; + my $command = join('', @commands); + local(*FD); + my $pid = open(FD, "$command |"); + my $text; + + local($SIG{HUP}) = sub { kill 9, $pid; exit }; + local($SIG{INT}) = sub { kill 9, $pid; exit }; my $needalarm = - ($ENV{'PERLCC_TIMEOUT'} && - $Config{'osname'} ne 'MSWin32' && $command =~ m"^perlc"); - my $text; + ($ENV{PERLCC_TIMEOUT} && + $Config{'osname'} ne 'MSWin32' && + $command =~ m"(^|\s)perlcc\s"); - eval + eval { - local($SIG{ALRM}) = sub { die "INFINITE LOOP"; }; - alarm($ENV{'PERLCC_TIMEOUT'}) if ($needalarm); - $text = join('', <FD>); - alarm(0) if ($needalarm); + local($SIG{ALRM}) = sub { die "INFINITE LOOP"; }; + alarm($ENV{PERLCC_TIMEOUT}) if ($needalarm); + $text = join('', <FD>); + alarm(0) if ($needalarm); }; - if ($@) - { - eval { kill 'HUP', $pid; }; - _print("SYSTEM TIMEOUT (infinite loop?)\n", 36); + if ($@) + { + eval { kill 'HUP', $pid }; + vprint 0, "SYSTEM TIMEOUT (infinite loop?)\n"; } - + close(FD); return($text); } -sub _usage -{ - _print - ( - <<"EOF" - -Usage: $0 <file_list> - -WARNING: The whole compiler suite ('perlcc' included) is considered VERY -experimental. Use for production purposes is strongly discouraged. - - Flags with arguments - -L < extra library dirs for installation (form of 'dir1:dir2') > - -I < extra include dirs for installation (form of 'dir1:dir2') > - -C < explicit name of resulting C code > - -o < explicit name of resulting executable > - -e < to compile 'one liners'. Need executable name (-o) or '-run'> - -regex < rename regex, -regex 's/\.p/\.exe/' compiles a.p to a.exe > - -verbose < verbose level < 1-63, or following letters 'gatfcd' > - -argv < arguments for the executables to be run via '-run' or '-e' > - - Boolean flags - -b ( to generate byte code ) - -opt ( to generated optimised C code. May not work in some cases. ) - -gen ( to just generate the C code. Implies '-sav' ) - -sav ( to save intermediate C code, (and executables with '-run')) - -run ( to run the compiled program on the fly, as were interpreted.) - -prog ( to indicate that the files on command line are programs ) - -mod ( to indicate that the files on command line are modules ) - -EOF -, -1 - - ); - exit(255); +END { + unlink $cfile if ($cfile && !opt(S) && !opt(c)); } - __END__ =head1 NAME -perlcc - frontend for perl compiler +perlcc - generate executables from Perl programs =head1 SYNOPSIS - %prompt perlcc a.p # compiles into executable 'a' - - %prompt perlcc A.pm # compile into 'A.so' - - %prompt perlcc a.p -o execute # compiles 'a.p' into 'execute'. + $ perlcc hello # Compiles into executable 'a.out' + $ perlcc -o hello hello.pl # Compiles into executable 'hello' - %prompt perlcc a.p -o execute -run # compiles 'a.p' into execute, runs on - # the fly + $ perlcc -O file # Compiles using the optimised C backend + $ perlcc -B file # Compiles using the bytecode backend - %prompt perlcc a.p -o execute -run -argv 'arg1 arg2 arg3' - # compiles into execute, runs with - # arg1 arg2 arg3 as @ARGV + $ perlcc -c file # Creates a C file, 'file.c' + $ perlcc -S -o hello file # Creates a C file, 'file.c', + # then compiles it to executable 'hello' + $ perlcc -c out.c file # Creates a C file, 'out.c' from 'file' - %prompt perlcc a.p b.p c.p -regex 's/\.p/\.exe' - # compiles into 'a.exe','b.exe','c.exe'. + $ perlcc -e 'print q//' # Compiles a one-liner into 'a.out' + $ perlcc -c -e 'print q//' # Creates a C file 'a.out.c' - %prompt perlcc a.p -log compilelog # compiles into 'a', saves compilation - # info into compilelog, as well - # as mirroring to screen + $ perlcc -r hello # compiles 'hello' into 'a.out', runs 'a.out'. - %prompt perlcc a.p -log compilelog -verbose cdf - # compiles into 'a', saves compilation - # info into compilelog, being silent - # on screen. + $ perlcc -r hello a b c # compiles 'hello' into 'a.out', runs 'a.out'. + # with arguments 'a b c' - %prompt perlcc a.p -C a.c -gen # generates C code (into a.c) and - # stops without compile. - - %prompt perlcc a.p -L ../lib a.c - # Compiles with the perl libraries - # inside ../lib included. + $ perlcc hello -log c # compiles 'hello' into 'a.out' logs compile + # log into 'c'. =head1 DESCRIPTION -'perlcc' is the frontend into the perl compiler. Typing 'perlcc a.p' -compiles the code inside a.p into a standalone executable, and -perlcc A.pm will compile into a shared object, A.so, suitable for inclusion -into a perl program via "use A". +F<perlcc> creates standalone executables from Perl programs, using the +code generators provided by the L<B> module. At present, you may +either create executable Perl bytecode, using the C<-B> option, or +generate and compile C files using the standard and 'optimised' C +backends. -There are quite a few flags to perlcc which help with such issues as compiling -programs in bulk, testing compiled programs for compatibility with the -interpreter, and controlling. +The code generated in this way is not guaranteed to work. The whole +codegen suite (C<perlcc> included) should be considered B<very> +experimental. Use for production purposes is strongly discouraged. -=head1 OPTIONS +=head1 OPTIONS =over 4 -=item -L < library_directories > - -Adds directories in B<library_directories> to the compilation command. - -=item -I < include_directories > - -Adds directories inside B<include_directories> to the compilation command. - -=item -C < c_code_name > - -Explicitly gives the name B<c_code_name> to the generated file containing -the C code which is to be compiled. Can only be used if compiling one file -on the command line. - -=item -o < executable_name > - -Explicitly gives the name B<executable_name> to the executable which is to be -compiled. Can only be used if compiling one file on the command line. - -=item -e < perl_line_to_execute> - -Compiles 'one liners', in the same way that B<perl -e> runs text strings at -the command line. Default is to have the 'one liner' be compiled, and run all -in one go (see B<-run>); giving the B<-o> flag saves the resultant executable, -rather than throwing it away. Use '-argv' to pass arguments to the executable -created. - -=item -b +=item -LI<library directories> -Generates bytecode instead of C code. +Adds the given directories to the library search path when C code is +passed to your C compiler. -=item -opt +=item -II<include directories> -Uses the optimized C backend (C<B::CC>)rather than the simple C backend -(C<B::C>). Beware that the optimized C backend creates very large -switch structures and structure initializations. Many C compilers -find it a challenge to compile the resulting output in finite amounts -of time. Many Perl features such as C<goto LABEL> are also not -supported by the optimized C backend. The simple C backend should -work in more instances, but can only offer modest speed increases. +Adds the given directories to the include file search path when C code is +passed to your C compiler; when using the Perl bytecode option, adds the +given directories to Perl's include path. -=item -regex <rename_regex> +=item -o I<output file name> -Gives a rule B<rename_regex> - which is a legal perl regular expression - to -create executable file names. +Specifies the file name for the final compiled executable. -=item -verbose <verbose_level> +=item -c I<C file name> -Show exactly what steps perlcc is taking to compile your code. You can -change the verbosity level B<verbose_level> much in the same way that -the C<-D> switch changes perl's debugging level, by giving either a -number which is the sum of bits you want or a list of letters -representing what you wish to see. Here are the verbosity levels so -far : +Create C code only; do not compile to a standalone binary. - Bit 1(g): Code Generation Errors to STDERR - Bit 2(a): Compilation Errors to STDERR - Bit 4(t): Descriptive text to STDERR - Bit 8(f): Code Generation Errors to file (B<-log> flag needed) - Bit 16(c): Compilation Errors to file (B<-log> flag needed) - Bit 32(d): Descriptive text to file (B<-log> flag needed) +=item -e I<perl code> -If the B<-log> tag is given, the default verbose level is 63 (ie: mirroring -all of perlcc's output to both the screen and to a log file). If no B<-log> -tag is given, then the default verbose level is 7 (ie: outputting all of -perlcc's output to STDERR). +Compile a one-liner, much the same as C<perl -e '...'> -NOTE: Because of buffering concerns, you CANNOT shadow the output of '-run' to -both a file, and to the screen! Suggestions are welcome on how to overcome this -difficulty, but for now it simply does not work properly, and hence will only go -to the screen. +=item -S -=item -log <logname> +Do not delete generated C code after compilation. -Opens, for append, a logfile to save some or all of the text for a given -compile command. No rewrite version is available, so this needs to be done -manually. +=item -B -=item -argv <arguments> +Use the Perl bytecode code generator. -In combination with C<-run> or C<-e>, tells perlcc to run the resulting -executable with the string B<arguments> as @ARGV. +=item -O -=item -sav +Use the 'optimised' C code generator. This is more experimental than +everything else put together, and the code created is not guaranteed to +compile in finite time and memory, or indeed, at all. -Tells perl to save the intermediate C code. Usually, this C code is the name -of the perl code, plus '.c'; 'perlcode.p' gets generated in 'perlcode.p.c', -for example. If used with the C<-e> operator, you need to tell perlcc where to -save resulting executables. +=item -v -=item -gen +Increase verbosity of output; can be repeated for more verbose output. -Tells perlcc to only create the intermediate C code, and not compile the -results. Does an implicit B<-sav>, saving the C code rather than deleting it. +=item -r -=item -run +Run the resulting compiled script after compiling it. -Immediately run the perl code that has been generated. NOTE: IF YOU GIVE THE -B<-run> FLAG TO B<perlcc>, THEN THE REST OF @ARGV WILL BE INTERPRETED AS -ARGUMENTS TO THE PROGRAM THAT YOU ARE COMPILING. +=item -log -=item -prog - -Indicate that the programs at the command line are programs, and should be -compiled as such. B<perlcc> will automatically determine files to be -programs if they have B<.p>, B<.pl>, B<.bat> extensions. - -=item -mod - -Indicate that the programs at the command line are modules, and should be -compiled as such. B<perlcc> will automatically determine files to be -modules if they have the extension B<.pm>. +Log the output of compiling to a file rather than to stdout. =back -=head1 ENVIRONMENT - -Most of the work of B<perlcc> is done at the command line. However, you can -change the heuristic which determines what is a module and what is a program. -As indicated above, B<perlcc> assumes that the extensions: - -.p$, .pl$, and .bat$ - -indicate a perl program, and: - -.pm$ - -indicate a library, for the purposes of creating executables. And furthermore, -by default, these extensions will be replaced (and dropped) in the process of -creating an executable. - -To change the extensions which are programs, and which are modules, set the -environmental variables: - -PERL_SCRIPT_EXT -PERL_MODULE_EXT - -These two environmental variables take colon-separated, legal perl regular -expressions, and are used by perlcc to decide which objects are which. -For example: - -setenv PERL_SCRIPT_EXT '.prl$:.perl$' -prompt% perlcc sample.perl - -will compile the script 'sample.perl' into the executable 'sample', and - -setenv PERL_MODULE_EXT '.perlmod$:.perlmodule$' - -prompt% perlcc sample.perlmod - -will compile the module 'sample.perlmod' into the shared object -'sample.so' - -NOTE: the '.' in the regular expressions for PERL_SCRIPT_EXT and PERL_MODULE_EXT -is a literal '.', and not a wild-card. To get a true wild-card, you need to -backslash the '.'; as in: - -setenv PERL_SCRIPT_EXT '\.\.\.\.\.' - -which would have the effect of compiling ANYTHING (except what is in -PERL_MODULE_EXT) into an executable with 5 less characters in its name. - -The PERLCC_OPTS environment variable can be set to the default flags -that must be used by the compiler. - -The PERLCC_TIMEOUT environment variable can be set to the number of -seconds to wait for the backends before giving up. This is sometimes -necessary to avoid some compilers taking forever to compile the -generated output. May not work on Windows and similar platforms. - -=head1 FILES - -'perlcc' uses a temporary file when you use the B<-e> option to evaluate -text and compile it. This temporary file is 'perlc$$.p'. The temporary C code is -perlc$$.p.c, and the temporary executable is perlc$$. - -When you use '-run' and don't save your executable, the temporary executable is -perlc$$ - -=head1 BUGS - -The whole compiler suite (C<perlcc> included) should be considered very -experimental. Use for production purposes is strongly discouraged. - -perlcc currently cannot compile shared objects on Win32. This should be fixed -in future. - -Bugs in the various compiler backends still exist, and are perhaps too -numerous to list here. - =cut !NO!SUBS! diff --git a/contrib/perl5/utils/perldoc.PL b/contrib/perl5/utils/perldoc.PL index 32421d77c205..cfb773e6ffe9 100644 --- a/contrib/perl5/utils/perldoc.PL +++ b/contrib/perl5/utils/perldoc.PL @@ -36,8 +36,15 @@ use strict; # make sure creat()s are neither too much nor too little INIT { eval { umask(0077) } } # doubtless someone has no mask +(my \$pager = <<'/../') =~ s/\\s*\\z//; +$Config{pager} +/../ my \@pagers = (); -push \@pagers, "$Config{'pager'}" if -x "$Config{'pager'}"; +push \@pagers, \$pager if -x \$pager; + +(my \$bindir = <<'/../') =~ s/\\s*\\z//; +$Config{scriptdir} +/../ !GROK!THIS! @@ -48,6 +55,7 @@ print OUT <<'!NO!SUBS!'; use Fcntl; # for sysopen use Getopt::Std; use Config '%Config'; +use File::Spec::Functions qw(catfile splitdir); # # Perldoc revision #1 -- look up a piece of documentation in .pod format that @@ -79,6 +87,7 @@ my $global_target = ""; my $Is_VMS = $^O eq 'VMS'; my $Is_MSWin32 = $^O eq 'MSWin32'; my $Is_Dos = $^O eq 'dos'; +my $Is_OS2 = $^O eq 'os2'; sub usage{ warn "@_\n" if @_; @@ -147,7 +156,7 @@ usage if $opt_h; # refuse to run if we should be tainting and aren't # (but regular users deserve protection too, though!) -if (!($Is_VMS || $Is_MSWin32 || $Is_Dos) && ($> == 0 || $< == 0) +if (!($Is_VMS || $Is_MSWin32 || $Is_Dos || $Is_OS2) && ($> == 0 || $< == 0) && !am_taint_checking()) {{ if ($opt_U) { @@ -201,8 +210,9 @@ if (-f "Makefile.PL") { eval q{ use lib qw(. lib); 1; } or die; # don't add if superuser - if ($< && $>) { # don't be looking too hard now! - eval q{ use blib; 1 } or die; + if ($< && $> && -f "blib") { # don't be looking too hard now! + eval q{ use blib; 1 }; + warn $@ if $@ && $opt_v; } } @@ -223,7 +233,7 @@ sub containspod { sub minus_f_nocase { my($dir,$file) = @_; - my $path = join('/',$dir,$file); # XXX: dirseps + my $path = catfile($dir,$file); return $path if -f $path and -r _; if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') { # on a case-forgiving file system or if case is important @@ -237,13 +247,13 @@ sub minus_f_nocase { local($")="/"; my @p = ($dir); my($p,$cip); - foreach $p (split(m!/!, $file)){ # XXX: dirseps - my $try = "@p/$p"; + foreach $p (splitdir $file){ + my $try = catfile @p, $p; stat $try; if (-d _) { push @p, $p; if ( $p eq $global_target) { - my $tmp_path = join ('/', @p); # XXX: dirseps + my $tmp_path = catfile @p; my $path_f = 0; for (@global_found) { $path_f = 1 if $_ eq $tmp_path; @@ -302,7 +312,7 @@ sub searchfor { my $ret; my $i; my $dir; - $global_target = (split(m!/!, $s))[-1]; # XXX: dirseps + $global_target = (splitdir $s)[-1]; # XXX: why not use File::Basename? for ($i=0; $i<@dirs; $i++) { $dir = $dirs[$i]; ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if $Is_VMS; @@ -325,10 +335,10 @@ sub searchfor { if ($recurse) { opendir(D,$dir) or die "Can't opendir $dir: $!"; - my @newdirs = map "$dir/$_", grep { # XXX: dirseps + my @newdirs = map catfile($dir, $_), grep { not /^\.\.?\z/s and not /^auto\z/s and # save time! don't search auto dirs - -d "$dir/$_" # XXX: dirseps + -d catfile($dir, $_) } readdir D; closedir(D) or die "Can't closedir $dir: $!"; next unless @newdirs; @@ -362,7 +372,7 @@ sub printout { close OUT or die "can't close $tmp: $!"; } elsif (not $opt_u) { - my $cmd = "pod2man --lax $file | $opt_n -man"; + my $cmd = catfile($bindir, 'pod2man') . " --lax $file | $opt_n -man"; $cmd .= " | col -x" if $^O =~ /hpux/; my $rslt = `$cmd`; $rslt = filter_nroff($rslt) if $filter; @@ -406,7 +416,11 @@ sub page { } else { foreach my $pager (@pagers) { - last if system("$pager $tmp") == 0; + if ($Is_VMS) { + last if system("$pager $tmp") == 0; # quoting prevents logical expansion + } else { + last if system("$pager \"$tmp\"") == 0; + } } } } @@ -425,8 +439,7 @@ sub cleanup { my @found; foreach (@pages) { if ($podidx && open(PODIDX, $podidx)) { - my $searchfor = $_; - $searchfor =~ s,::,/,g; # XXX: dirseps + my $searchfor = catfile split '::'; print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v; local $_; while (<PODIDX>) { @@ -437,9 +450,9 @@ foreach (@pages) { next; } print STDERR "Searching for $_\n" if $opt_v; - # We must look both in @INC for library modules and in PATH + # We must look both in @INC for library modules and in $bindir # for executables, like h2xs or perldoc itself. - my @searchdirs = @INC; + my @searchdirs = ($bindir, @INC); if ($opt_F) { next unless -r; push @found, $_ if $opt_m or containspod($_); @@ -553,7 +566,10 @@ eval q{ sub END { cleanup($tmp, $buffer) } 1; } || die; -eval q{ use sigtrap qw(die INT TERM HUP QUIT) }; + +# exit/die in a windows sighandler is dangerous, so let it do the +# default thing, which is to exit +eval q{ use sigtrap qw(die INT TERM HUP QUIT) } unless $^O eq 'MSWin32'; if ($opt_m) { foreach my $pager (@pagers) { @@ -790,7 +806,7 @@ One useful value for C<PERLDOC_PAGER> is C<less -+C -E>. =head1 VERSION -This is perldoc v2.01. +This is perldoc v2.03. =head1 AUTHOR @@ -802,6 +818,9 @@ and others. =cut # +# Version 2.03: Sun Apr 23 16:56:34 BST 2000 +# Hugo van der Sanden <hv@crypt0.demon.co.uk> +# don't die when 'use blib' fails # Version 2.02: Mon Mar 13 18:03:04 MST 2000 # Tom Christiansen <tchrist@perl.com> # Added -U insecurity option diff --git a/contrib/perl5/warnings.h b/contrib/perl5/warnings.h index a2bcaeb43edc..f6814e78c403 100644 --- a/contrib/perl5/warnings.h +++ b/contrib/perl5/warnings.h @@ -22,45 +22,6 @@ #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \ (x) == pWARN_NONE) - -#define ckDEAD(x) \ - ( ! specialWARN(PL_curcop->cop_warnings) && \ - IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1)) - -#define ckWARN(x) \ - ( (PL_curcop->cop_warnings != pWARN_STD && \ - PL_curcop->cop_warnings != pWARN_NONE && \ - (PL_curcop->cop_warnings == pWARN_ALL || \ - IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \ - || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) ) - -#define ckWARN2(x,y) \ - ( (PL_curcop->cop_warnings != pWARN_STD && \ - PL_curcop->cop_warnings != pWARN_NONE && \ - (PL_curcop->cop_warnings == pWARN_ALL || \ - IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ - IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \ - || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) ) - -#define ckWARN_d(x) \ - (PL_curcop->cop_warnings == pWARN_STD || \ - PL_curcop->cop_warnings == pWARN_ALL || \ - (PL_curcop->cop_warnings != pWARN_NONE && \ - IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) - -#define ckWARN2_d(x,y) \ - (PL_curcop->cop_warnings == pWARN_STD || \ - PL_curcop->cop_warnings == pWARN_ALL || \ - (PL_curcop->cop_warnings != pWARN_NONE && \ - (IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ - IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) ) - - -#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD) -#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD) -#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE)) -#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x))) - #define WARN_ALL 0 #define WARN_CHMOD 1 #define WARN_CLOSURE 2 @@ -113,5 +74,40 @@ #define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125" #define WARN_NONEstring "\0\0\0\0\0\0\0\0\0\0\0\0" +#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD) +#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD) +#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE)) +#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x))) +#define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1)) + +#define ckDEAD(x) \ + ( ! specialWARN(PL_curcop->cop_warnings) && \ + ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \ + isWARNf_on(PL_curcop->cop_warnings, x))) + +#define ckWARN(x) \ + ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \ + (PL_curcop->cop_warnings == pWARN_ALL || \ + isWARN_on(PL_curcop->cop_warnings, x) ) ) \ + || (isLEXWARN_off && PL_dowarn & G_WARN_ON) ) + +#define ckWARN2(x,y) \ + ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \ + (PL_curcop->cop_warnings == pWARN_ALL || \ + isWARN_on(PL_curcop->cop_warnings, x) || \ + isWARN_on(PL_curcop->cop_warnings, y) ) ) \ + || (isLEXWARN_off && PL_dowarn & G_WARN_ON) ) + +#define ckWARN_d(x) \ + (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \ + (PL_curcop->cop_warnings != pWARN_NONE && \ + isWARN_on(PL_curcop->cop_warnings, x) ) ) + +#define ckWARN2_d(x,y) \ + (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \ + (PL_curcop->cop_warnings != pWARN_NONE && \ + (isWARN_on(PL_curcop->cop_warnings, x) || \ + isWARN_on(PL_curcop->cop_warnings, y) ) ) ) + /* end of file warnings.h */ diff --git a/contrib/perl5/warnings.pl b/contrib/perl5/warnings.pl index 61602d5608ab..2205d1f384cb 100644 --- a/contrib/perl5/warnings.pl +++ b/contrib/perl5/warnings.pl @@ -169,8 +169,8 @@ if (@ARGV && $ARGV[0] eq "tree") exit ; } -#unlink "warnings.h"; -#unlink "lib/warnings.pm"; +unlink "warnings.h"; +unlink "lib/warnings.pm"; open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n"; open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n"; @@ -199,45 +199,6 @@ print WARN <<'EOM' ; #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \ (x) == pWARN_NONE) - -#define ckDEAD(x) \ - ( ! specialWARN(PL_curcop->cop_warnings) && \ - IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1)) - -#define ckWARN(x) \ - ( (PL_curcop->cop_warnings != pWARN_STD && \ - PL_curcop->cop_warnings != pWARN_NONE && \ - (PL_curcop->cop_warnings == pWARN_ALL || \ - IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \ - || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) ) - -#define ckWARN2(x,y) \ - ( (PL_curcop->cop_warnings != pWARN_STD && \ - PL_curcop->cop_warnings != pWARN_NONE && \ - (PL_curcop->cop_warnings == pWARN_ALL || \ - IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ - IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \ - || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) ) - -#define ckWARN_d(x) \ - (PL_curcop->cop_warnings == pWARN_STD || \ - PL_curcop->cop_warnings == pWARN_ALL || \ - (PL_curcop->cop_warnings != pWARN_NONE && \ - IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) - -#define ckWARN2_d(x,y) \ - (PL_curcop->cop_warnings == pWARN_STD || \ - PL_curcop->cop_warnings == pWARN_ALL || \ - (PL_curcop->cop_warnings != pWARN_NONE && \ - (IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ - IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) ) - - -#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD) -#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD) -#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE)) -#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x))) - EOM my $offset = 0 ; @@ -263,6 +224,41 @@ print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" print WARN <<'EOM'; +#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD) +#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD) +#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE)) +#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x))) +#define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1)) + +#define ckDEAD(x) \ + ( ! specialWARN(PL_curcop->cop_warnings) && \ + ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \ + isWARNf_on(PL_curcop->cop_warnings, x))) + +#define ckWARN(x) \ + ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \ + (PL_curcop->cop_warnings == pWARN_ALL || \ + isWARN_on(PL_curcop->cop_warnings, x) ) ) \ + || (isLEXWARN_off && PL_dowarn & G_WARN_ON) ) + +#define ckWARN2(x,y) \ + ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \ + (PL_curcop->cop_warnings == pWARN_ALL || \ + isWARN_on(PL_curcop->cop_warnings, x) || \ + isWARN_on(PL_curcop->cop_warnings, y) ) ) \ + || (isLEXWARN_off && PL_dowarn & G_WARN_ON) ) + +#define ckWARN_d(x) \ + (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \ + (PL_curcop->cop_warnings != pWARN_NONE && \ + isWARN_on(PL_curcop->cop_warnings, x) ) ) + +#define ckWARN2_d(x,y) \ + (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \ + (PL_curcop->cop_warnings != pWARN_NONE && \ + (isWARN_on(PL_curcop->cop_warnings, x) || \ + isWARN_on(PL_curcop->cop_warnings, y) ) ) ) + /* end of file warnings.h */ EOM @@ -352,6 +348,14 @@ warnings - Perl pragma to control optional warnings warnings::warn("void", "some warning"); } + if (warnings::enabled($object)) { + warnings::warn($object, "some warning"); + } + + warnif("some warning"); + warnif("void", "some warning"); + warnif($object, "some warning"); + =head1 DESCRIPTION If no import list is supplied, all possible warnings are either enabled @@ -363,30 +367,82 @@ A number of functions are provided to assist module authors. =item use warnings::register -Creates a new warnings category which has the same name as the module -where the call to the pragma is used. +Creates a new warnings category with the same name as the package where +the call to the pragma is used. + +=item warnings::enabled() + +Use the warnings category with the same name as the current package. + +Return TRUE if that warnings category is enabled in the calling module. +Otherwise returns FALSE. + +=item warnings::enabled($category) + +Return TRUE if the warnings category, C<$category>, is enabled in the +calling module. +Otherwise returns FALSE. + +=item warnings::enabled($object) + +Use the name of the class for the object reference, C<$object>, as the +warnings category. + +Return TRUE if that warnings category is enabled in the first scope +where the object is used. +Otherwise returns FALSE. + +=item warnings::warn($message) + +Print C<$message> to STDERR. + +Use the warnings category with the same name as the current package. + +If that warnings category has been set to "FATAL" in the calling module +then die. Otherwise return. + +=item warnings::warn($category, $message) -=item warnings::enabled([$category]) +Print C<$message> to STDERR. -Returns TRUE if the warnings category C<$category> is enabled in the -calling module. Otherwise returns FALSE. +If the warnings category, C<$category>, has been set to "FATAL" in the +calling module then die. Otherwise return. -If the parameter, C<$category>, isn't supplied, the current package name -will be used. +=item warnings::warn($object, $message) -=item warnings::warn([$category,] $message) +Print C<$message> to STDERR. -If the calling module has I<not> set C<$category> to "FATAL", print -C<$message> to STDERR. -If the calling module has set C<$category> to "FATAL", print C<$message> -STDERR then die. +Use the name of the class for the object reference, C<$object>, as the +warnings category. -If the parameter, C<$category>, isn't supplied, the current package name -will be used. +If that warnings category has been set to "FATAL" in the scope where C<$object> +is first used then die. Otherwise return. + + +=item warnings::warnif($message) + +Equivalent to: + + if (warnings::enabled()) + { warnings::warn($message) } + +=item warnings::warnif($category, $message) + +Equivalent to: + + if (warnings::enabled($category)) + { warnings::warn($category, $message) } + +=item warnings::warnif($object, $message) + +Equivalent to: + + if (warnings::enabled($object)) + { warnings::warn($object, $message) } =back -See L<perlmod/Pragmatic Modules> and L<perllexwarn>. +See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>. =cut @@ -417,44 +473,80 @@ sub bits { sub import { shift; - ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ; + my $mask = ${^WARNING_BITS} ; + if (vec($mask, $Offsets{'all'}, 1)) { + $mask |= $Bits{'all'} ; + $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); + } + ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ; } sub unimport { shift; my $mask = ${^WARNING_BITS} ; if (vec($mask, $Offsets{'all'}, 1)) { - $mask = $Bits{'all'} ; + $mask |= $Bits{'all'} ; $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); } ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ; } -sub enabled +sub __chk { - croak("Usage: warnings::enabled([category])") - unless @_ == 1 || @_ == 0 ; - local $Carp::CarpLevel = 1 ; my $category ; my $offset ; - my $callers_bitmask = (caller(1))[9] ; - return 0 unless defined $callers_bitmask ; - + my $isobj = 0 ; if (@_) { # check the category supplied. $category = shift ; + if (ref $category) { + croak ("not an object") + if $category !~ /^([^=]+)=/ ;+ + $category = $1 ; + $isobj = 1 ; + } $offset = $Offsets{$category}; croak("unknown warnings category '$category'") unless defined $offset; } else { - $category = (caller(0))[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 $i = 2 ; + my $pkg ; + + if ($isobj) { + while (do { { package DB; $pkg = (caller($i++))[0] } } ) { + last unless @DB::args && $DB::args[0] =~ /^$category=/ ; + } + $i -= 2 ; + } + else { + for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) { + last if $pkg ne $this_pkg ; + } + $i = 2 + if !$pkg || $pkg eq $this_pkg ; + } + + my $callers_bitmask = (caller($i))[9] ; + return ($callers_bitmask, $offset, $i) ; +} + +sub enabled +{ + croak("Usage: warnings::enabled([category])") + unless @_ == 1 || @_ == 0 ; + + my ($callers_bitmask, $offset, $i) = __chk(@_) ; + + return 0 unless defined $callers_bitmask ; return vec($callers_bitmask, $offset, 1) || vec($callers_bitmask, $Offsets{'all'}, 1) ; } @@ -464,29 +556,34 @@ sub warn { croak("Usage: warnings::warn([category,] 'message')") unless @_ == 2 || @_ == 1 ; - local $Carp::CarpLevel = 1 ; - my $category ; - my $offset ; - my $callers_bitmask = (caller(1))[9] ; - - if (@_ == 2) { - $category = shift ; - $offset = $Offsets{$category}; - croak("unknown warnings category '$category'") - unless defined $offset ; - } - else { - $category = (caller(0))[0] ; - $offset = $Offsets{$category}; - croak("package '$category' not registered for warnings") - unless defined $offset ; - } - my $message = shift ; + my $message = pop ; + my ($callers_bitmask, $offset, $i) = __chk(@_) ; + local $Carp::CarpLevel = $i ; croak($message) if vec($callers_bitmask, $offset+1, 1) || vec($callers_bitmask, $Offsets{'all'}+1, 1) ; carp($message) ; } +sub warnif +{ + croak("Usage: warnings::warnif([category,] 'message')") + unless @_ == 2 || @_ == 1 ; + + my $message = pop ; + my ($callers_bitmask, $offset, $i) = __chk(@_) ; + local $Carp::CarpLevel = $i ; + + return + unless defined $callers_bitmask && + (vec($callers_bitmask, $offset, 1) || + vec($callers_bitmask, $Offsets{'all'}, 1)) ; + + croak($message) + if vec($callers_bitmask, $offset+1, 1) || + vec($callers_bitmask, $Offsets{'all'}+1, 1) ; + + carp($message) ; +} 1; diff --git a/contrib/perl5/x2p/EXTERN.h b/contrib/perl5/x2p/EXTERN.h index cd1a4112ae28..80fffb46e44a 100644 --- a/contrib/perl5/x2p/EXTERN.h +++ b/contrib/perl5/x2p/EXTERN.h @@ -1,6 +1,6 @@ /* $RCSfile: EXTERN.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:05 $ * - * Copyright (c) 1991-1997, 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/contrib/perl5/x2p/INTERN.h b/contrib/perl5/x2p/INTERN.h index ac1d57ab05c1..2303ea3ac118 100644 --- a/contrib/perl5/x2p/INTERN.h +++ b/contrib/perl5/x2p/INTERN.h @@ -1,6 +1,6 @@ /* $RCSfile: INTERN.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:06 $ * - * Copyright (c) 1991-1997, 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/contrib/perl5/x2p/Makefile.SH b/contrib/perl5/x2p/Makefile.SH index 8ed7d315a181..a0ba96a360c7 100755 --- a/contrib/perl5/x2p/Makefile.SH +++ b/contrib/perl5/x2p/Makefile.SH @@ -34,10 +34,7 @@ cat >Makefile <<!GROK!THIS! CC = $cc BYACC = $byacc LDFLAGS = $ldflags -SMALL = $small -LARGE = $large $split -# XXX Perl malloc temporarily unusable (declaration collisions with -# stdlib.h) +# XXX Perl malloc temporarily unusable (declaration collisions with stdlib.h) #mallocsrc = $mallocsrc #mallocobj = $mallocobj shellflags = $shellflags @@ -129,15 +126,18 @@ a2p.c: a2p.y a2p$(OBJ_EXT): a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h \ ../handy.h ../config.h str.h hash.h - $(CCCMD) $(LARGE) a2p.c + $(CCCMD) a2p.c clean: rm -f a2p *$(OBJ_EXT) $(plexe) $(plc) $(plm) realclean: clean - rm -f *.orig core $(addedbyconf) all malloc.c + rm -f core $(addedbyconf) all malloc.c rm -f $(FIRSTMAKEFILE) $(FIRSTMAKEFILE).old +veryclean: realclean + rm -f *~ *.orig + # The following lint has practically everything turned on. Unfortunately, # you have to wade through a lot of mumbo jumbo that can't be suppressed. # If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message diff --git a/contrib/perl5/x2p/a2p.c b/contrib/perl5/x2p/a2p.c index b512cf94ad62..cd667a3f29bf 100644 --- a/contrib/perl5/x2p/a2p.c +++ b/contrib/perl5/x2p/a2p.c @@ -5,7 +5,7 @@ static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91"; #line 2 "a2p.y" /* $RCSfile: a2p.y,v $$Revision: 4.1 $$Date: 92/08/07 18:29:12 $ * - * Copyright (c) 1991-1997, 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/contrib/perl5/x2p/a2p.h b/contrib/perl5/x2p/a2p.h index 3b0338ca02b1..cbcb80c0a6dc 100644 --- a/contrib/perl5/x2p/a2p.h +++ b/contrib/perl5/x2p/a2p.h @@ -1,6 +1,6 @@ /* $RCSfile: a2p.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:09 $ * - * Copyright (c) 1991-1997, 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. @@ -121,6 +121,7 @@ #ifdef DOSISH # if defined(OS2) +# define PTHX_UNUSED # include "../os2ish.h" # else # include "../dosish.h" diff --git a/contrib/perl5/x2p/a2p.y b/contrib/perl5/x2p/a2p.y index da9b6288eff4..beec3a6eaa29 100644 --- a/contrib/perl5/x2p/a2p.y +++ b/contrib/perl5/x2p/a2p.y @@ -1,7 +1,7 @@ %{ /* $RCSfile: a2p.y,v $$Revision: 4.1 $$Date: 92/08/07 18:29:12 $ * - * Copyright (c) 1991-1997, 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/contrib/perl5/x2p/a2py.c b/contrib/perl5/x2p/a2py.c index 3976c860c5ad..6884f95a6c4a 100644 --- a/contrib/perl5/x2p/a2py.c +++ b/contrib/perl5/x2p/a2py.c @@ -1,6 +1,6 @@ /* $RCSfile: a2py.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:14 $ * - * Copyright (c) 1991-1997, 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/contrib/perl5/x2p/cflags.SH b/contrib/perl5/x2p/cflags.SH index b5ef9170b9a6..dcd97a1e79ff 100755 --- a/contrib/perl5/x2p/cflags.SH +++ b/contrib/perl5/x2p/cflags.SH @@ -84,8 +84,8 @@ for file do ccflags="`echo $ccflags | sed -e 's/-DMULTIPLICITY//'`" - echo "$cc -c $ccflags $optimize $large $split" - eval "$also "'"$cc -c $ccflags $optimize $large $split"' + echo "$cc -c $ccflags $optimize" + eval "$also "'"$cc -c $ccflags $optimize"' . $TOP/config.sh diff --git a/contrib/perl5/x2p/find2perl.PL b/contrib/perl5/x2p/find2perl.PL index 25d0135528d3..adcf42ace476 100644 --- a/contrib/perl5/x2p/find2perl.PL +++ b/contrib/perl5/x2p/find2perl.PL @@ -29,7 +29,9 @@ print OUT <<"!GROK!THIS!"; $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' if \$running_under_some_shell; -my \$perlpath = "$Config{perlpath}"; +(my \$perlpath = <<'/../') =~ s/\\s*\\z//; +$Config{perlpath} +/../ !GROK!THIS! # In the following, perl variables are not expanded during extraction. @@ -37,6 +39,7 @@ my \$perlpath = "$Config{perlpath}"; print OUT <<'!NO!SUBS!'; use strict; use vars qw/$statdone/; +use File::Spec::Functions 'curdir'; my $startperl = "#! $perlpath -w"; # @@ -57,7 +60,7 @@ my @roots = (); while ($ARGV[0] =~ /^[^-!(]/) { push(@roots, shift); } -@roots = ('.') unless @roots; +@roots = (curdir()) unless @roots; for (@roots) { $_ = "e($_) } my $roots = join(', ', @roots); @@ -333,10 +336,8 @@ END if (exists $init{doexec}) { print <<'END'; -BEGIN { - require Cwd; - my $cwd = Cwd::cwd(); -} +use Cwd (); +my $cwd = Cwd::cwd(); sub doexec { my $ok = shift; @@ -674,6 +675,7 @@ sub n { sub quote { my $string = shift; + $string =~ s/\\/\\\\/g; $string =~ s/'/\\'/g; "'$string'"; } diff --git a/contrib/perl5/x2p/hash.c b/contrib/perl5/x2p/hash.c index 77b9ad8fd179..a266403efe91 100644 --- a/contrib/perl5/x2p/hash.c +++ b/contrib/perl5/x2p/hash.c @@ -1,6 +1,6 @@ /* $RCSfile: hash.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:20 $ * - * Copyright (c) 1991-1997, 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/contrib/perl5/x2p/hash.h b/contrib/perl5/x2p/hash.h index 377bfd2db096..7b2b6684921a 100644 --- a/contrib/perl5/x2p/hash.h +++ b/contrib/perl5/x2p/hash.h @@ -1,6 +1,6 @@ /* $RCSfile: hash.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:21 $ * - * Copyright (c) 1991-1997, 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/contrib/perl5/x2p/proto.h b/contrib/perl5/x2p/proto.h index 85d749616aef..e57b4fc30e32 100644 --- a/contrib/perl5/x2p/proto.h +++ b/contrib/perl5/x2p/proto.h @@ -1,6 +1,6 @@ /* proto.h * - * Copyright (c) 1991-1997, 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/contrib/perl5/x2p/s2p.PL b/contrib/perl5/x2p/s2p.PL index 4f7bf8c724fb..2d44dd2d4eb4 100644 --- a/contrib/perl5/x2p/s2p.PL +++ b/contrib/perl5/x2p/s2p.PL @@ -29,8 +29,12 @@ print OUT <<"!GROK!THIS!"; $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' if \$running_under_some_shell; -\$startperl = "$Config{startperl}"; -\$perlpath = "$Config{perlpath}"; +(\$startperl = <<'/../') =~ s/\\s*\\z//; +$Config{startperl} +/../ +(\$perlpath = <<'/../') =~ s/\\s*\\z//; +$Config{perlpath} +/../ !GROK!THIS! # In the following, perl variables are not expanded during extraction. diff --git a/contrib/perl5/x2p/str.c b/contrib/perl5/x2p/str.c index b820a8d67da1..310bcd6e3bf1 100644 --- a/contrib/perl5/x2p/str.c +++ b/contrib/perl5/x2p/str.c @@ -1,6 +1,6 @@ /* $RCSfile: str.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:26 $ * - * Copyright (c) 1991-1997, 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/contrib/perl5/x2p/str.h b/contrib/perl5/x2p/str.h index a7eec88ff10e..311c5e67dbeb 100644 --- a/contrib/perl5/x2p/str.h +++ b/contrib/perl5/x2p/str.h @@ -1,6 +1,6 @@ /* $RCSfile: str.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:27 $ * - * Copyright (c) 1991-1997, 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/contrib/perl5/x2p/util.c b/contrib/perl5/x2p/util.c index d43a1eb723ad..ab24808d73b1 100644 --- a/contrib/perl5/x2p/util.c +++ b/contrib/perl5/x2p/util.c @@ -1,6 +1,6 @@ /* $RCSfile: util.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:29 $ * - * Copyright (c) 1991-1997, 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/contrib/perl5/x2p/util.h b/contrib/perl5/x2p/util.h index 34138c7da1fb..c5ebcec7dfd7 100644 --- a/contrib/perl5/x2p/util.h +++ b/contrib/perl5/x2p/util.h @@ -1,6 +1,6 @@ /* $RCSfile: util.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:30 $ * - * Copyright (c) 1991-1997, 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/contrib/perl5/x2p/walk.c b/contrib/perl5/x2p/walk.c index 3344688117d1..59ac8a9f3d4c 100644 --- a/contrib/perl5/x2p/walk.c +++ b/contrib/perl5/x2p/walk.c @@ -1,6 +1,6 @@ /* $RCSfile: walk.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:31 $ * - * Copyright (c) 1991-1997, 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/contrib/perl5/xsutils.c b/contrib/perl5/xsutils.c index 0f5989b3dd51..b4161b0d0962 100644 --- a/contrib/perl5/xsutils.c +++ b/contrib/perl5/xsutils.c @@ -253,6 +253,8 @@ usage: rv = ST(0); ST(0) = TARG; + if (SvGMAGICAL(rv)) + mg_get(rv); if (!(SvOK(rv) && SvROK(rv))) goto usage; sv = SvRV(rv); |