diff options
| author | Charles Bailey <bailey@newman.upenn.edu> | 2001-01-08 08:53:52 +0000 |
|---|---|---|
| committer | bailey <bailey@newman.upenn.edu> | 2001-01-08 08:53:52 +0000 |
| commit | 0e06870bf080a38cda51c06c6612359afc2334e1 (patch) | |
| tree | 763f11122a3b18bc443e808010b970428ab57432 | |
| parent | e3830a4ec012ee625f1b3bc63b5b18c656f377da (diff) | |
| download | perl-0e06870bf080a38cda51c06c6612359afc2334e1.tar.gz | |
Once again syncing after too long an absence
p4raw-id: //depot/vmsperl@8367
546 files changed, 37088 insertions, 15702 deletions
@@ -1,138 +1,557 @@ -# Two sections: the real one and the virtual one. -# The real section has three \t+ fields: alias, name, email. -# The sections are separated by one or more empty lines. -# The virtual section (each record two \t+ separated fields) builds -# meta-aliases based on the real section. - -alan.burlison Alan Burlison Alan.Burlison@UK.Sun.com -allen Norton T. Allen allen@huarp.harvard.edu -bradapp Brad Appleton bradapp@enteract.com -cbail Charles Bailey bailey@newman.upenn.edu -dgris Daniel Grisinger dgris@dimensional.com -dmulholl Daniel Yacob dmulholl@cs.indiana.edu -dogcow Tom Spindler dogcow@merit.edu -domo Dominic Dunlop domo@computer.org -doug Doug MacEachern dougm@covalent.net -doughera Andy Dougherty doughera@lafcol.lafayette.edu -efifer Eric Fifer EFifer@sanwaint.com -francois Francois Desarmenien desar@club-internet.fr -gbarr Graham Barr gbarr@ti.com -gerben Gerben Wierda Gerben_Wierda@RnA.nl -gerti Gerd Knops gerti@BITart.com -gibreel Stephen Zander gibreel@pobox.com -gnat Nathan Torkington gnat@frii.com -gsar Gurusamy Sarathy gsar@activestate.com -hansmu Hans Mulder hansmu@xs4all.nl -hops Mike Hopkirk hops@sco.com -hugo Hugo van der Sanden hv@crypt.demon.co.uk -ilya Ilya Zakharevich ilya@math.ohio-state.edu -jbuehler Joe Buehler jbuehler@hekimian.com -jfs John Stoffel jfs@fluent.com -jhi Jarkko Hietaniemi jhi@iki.fi -jon Jon Orwant orwant@oreilly.com -jvromans Johan Vromans jvromans@squirrel.nl -k Andreas König a.koenig@mind.de -kjahds Kenneth Albanowski kjahds@kjahds.com -krishna Krishna Sethuraman krishna@sgi.com -kstar Kurt D. Starsinic kstar@chapin.edu -lane Charles Lane lane@DUPHY4.Physics.Drexel.Edu -lstein Lincoln D. Stein lstein@genome.wi.mit.edu -lutherh Luther Huffman lutherh@stratcom.com -lutz Mark P. Lutz mark.p.lutz@boeing.com -lwall Larry Wall larry@wall.org -makemaker MakeMaker list makemaker@franz.ww.tu-berlin.de -mbiggar Mark A Biggar mab@wdl.loral.com -mbligh Martin J. Bligh mbligh@sequent.com -mikestok Mike Stok mike@stok.co.uk -millert Todd Miller millert@openbsd.org -mkvale Mark Kvale kvale@phy.ucsf.edu -mjd Mark-Jason Dominus mjd@plover.com -mjtg Mike Guy mjtg@cam.ac.uk -laszlo.molnar Laszlo Molnar Laszlo.Molnar@eth.ericsson.se -mpeix Mark Bixby markb@cccd.edu -muir David Muir Sharnoff muir@idiom.com -neale Neale Ferguson neale@VMA.TABNSW.COM.AU -nik Nick Ing-Simmons nik@tiuk.ti.com -okamoto Jeff Okamoto okamoto@corp.hp.com -paul_green Paul Green Paul_Green@stratus.com -pmarquess Paul Marquess Paul.Marquess@btinternet.com -pomeranz Hal Pomeranz pomeranz@netcom.com -pudge Chris Nandor pudge@pobox.com -pueschel Norbert Pueschel pueschel@imsdd.meb.uni-bonn.de -pvhp Peter Prymmer pvhp@forte.com -raphael Raphael Manfredi Raphael.Manfredi@pobox.com -rdieter Rex Dieter rdieter@math.unl.edu -richard Richard Foley Richard.Foley@m.dasa.de -rra Russ Allbery rra@stanford.edu -rsanders Robert Sanders Robert.Sanders@linux.org -roberto Ollivier Robert roberto@keltia.freenix.fr -roderick Roderick Schertler roderick@argon.org -roehrich Dean Roehrich roehrich@cray.com -tsanders Tony Sanders sanders@bsdi.com -schinder Paul Schinder schinder@pobox.com -scotth Scott Henry scotth@sgi.com -seibert Greg Seibert seibert@Lynx.COM -simon Simon Cozens simon@brecon.co.uk -spider Spider Boardman spider@Orb.Nashua.NH.US -smccam Stephen McCamant smccam@uclink4.berkeley.edu -sthoenna Yitzchak Scott-Thoennes sthoenna@efn.org -sugalskd Dan Sugalski dan@sidhe.org -sundstrom David Sundstrom sunds@asictest.sc.ti.com -tchrist Tom Christiansen tchrist@perl.com -thomas.dorner Dorner Thomas Thomas.Dorner@start.de -tjenness Tim Jenness t.jenness@jach.hawaii.edu -timb Tim Bunce Tim.Bunce@ig.co.uk -tom.horsley Tom Horsley Tom.Horsley@mail.ccur.com -tye Tye McQueen tye@metronet.com -wayne.thompson Wayne Thompson Wayne.Thompson@Ebay.sun.com -wilfredo Wilfredo Sánchez wsanchez@apple.com - -PUMPKING jhi -aix jhi -amiga pueschel -beos dogcow -bsdos tsanders -cfg jhi -cgi lstein -complex jhi,raphael -cpan k -cxux tom.horsley -cygwin win32 -dec_osf jhi,spider -dgux roderick -doc tchrist -dos laszlo.molnar -dynix/ptx mbligh -ebcdic os390,vmesa,posix-bc -filespec kjahds -freebsd roberto -hpux okamoto,jhi -irix scotth,krishna,jfs,kstar -jpl gibreel -lexwarn pmarquess -linux kjahds,kstar -locale jhi,domo -machten domo -mm makemaker -netbsd jhi -next gerben,hansmu -openbsd millert -os2 ilya -os390 pvhp -plan9 lutherl -posix-bc thomas.dorner -powerux tom.horsley -qnx allen -regex ilya,jfriedl,hugo,mjd -sco francois,hops -solaris doughera,alan.burlison -step gerti,hansmu,rdieter -sunos4 doughera -svr4 tye -unicos jhi,lutz -uwin jbuehler -vmesa neale -vms sugalskd,cbail -vos paul_green -warn pmarquess -win32 gsar +# To give due honor to those who have made Perl 5 what is is today, +# here are easily-from-changelogs-extractable people and their +# (hopefully) current and preferred email addresses (as of late 2000 +# if known) from the Changes files. These people have either submitted +# patches or suggestions, or their bug reports or comments have inspired +# the appropriate patches. Corrections, additions, deletions welcome. +# +-- +Aaron B. Dossett <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 <jeffp@crusoe.net> +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@gmx.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 <pjcj@transeda.com> +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@nml.guardian.co.uk> +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/Changes5.6 b/Changes5.6 index 3dc17bc113..47adbffdb5 100644 --- a/Changes5.6 +++ b/Changes5.6 @@ -13319,7 +13319,7 @@ ____________________________________________________________________________ [ 3914] By: jhi on 1999/08/03 21:11:11 Log: The op/filetest.t failed subtest 7 if testing as root. - From: =?iso-8859-1?Q?Fran=E7ois=20D=E9sarm=E9nien?= <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 @@ -20,10 +20,10 @@ # $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $ # -# Generated on Thu Oct 19 22:28:50 EET DST 2000 [metaconfig 3.0 PL70] +# Generated on Fri Jan 5 20:11:52 EET 2001 [metaconfig 3.0 PL70] # (with additional metaconfig patches by perlbug@perl.org) -cat >/tmp/c1$$ <<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 @@ -308,6 +308,7 @@ cppminus='' cpprun='' cppstdin='' crosscompile='' +d__fwalk='' d_access='' d_accessx='' d_alarm='' @@ -348,6 +349,7 @@ d_endsent='' d_fchmod='' d_fchown='' d_fcntl='' +d_fcntl_can_lock='' d_fd_macros='' d_fd_set='' d_fds_bits='' @@ -361,6 +363,7 @@ d_fs_data_s='' d_fseeko='' d_fsetpos='' d_fstatfs='' +d_fsync='' d_ftello='' d_ftime='' d_gettimeod='' @@ -385,6 +388,7 @@ d_getnbyaddr='' d_getnbyname='' d_getnent='' d_getnetprotos='' +d_getpagsz='' d_getpent='' d_getpgid='' d_getpgrp2='' @@ -474,6 +478,7 @@ d_rmdir='' d_safebcpy='' d_safemcpy='' d_sanemcmp='' +d_sbrkproto='' d_select='' d_sem='' d_semctl='' @@ -536,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='' @@ -555,6 +562,7 @@ d_strtod='' d_strtol='' d_strtold='' d_strtoll='' +d_strtoq='' d_strtoul='' d_strtoull='' d_strtouq='' @@ -714,6 +722,7 @@ installusrbinperl='' intsize='' longsize='' shortsize='' +issymlink='' libc='' ldlibpthname='' libperl='' @@ -773,6 +782,7 @@ d_eofnblk='' eagain='' o_nonblock='' rd_nodata='' +need_va_copy='' netdb_hlen_type='' netdb_host_type='' netdb_name_type='' @@ -1424,6 +1434,7 @@ case "$src" in */*) src=`echo $0 | sed -e 's%/[^/][^/]*$%%'` case "$src" in /*) ;; + .) ;; *) src=`cd ../$src && pwd` ;; esac ;; @@ -2051,6 +2062,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 @@ -2159,6 +2171,93 @@ else fi $rm -f blurfl sym +: determine whether symbolic links are supported +echo " " +case "$lns" in +*"ln -s") + echo "Checking how to test for symbolic links..." >&4 + $lns blurfl sym + if $test "X$issymlink" = X; then + sh -c "PATH= test -h sym" >/dev/null 2>&1 + if test $? = 0; then + issymlink="test -h" + fi + fi + if $test "X$issymlink" = X; then + if $test -h >/dev/null 2>&1; then + issymlink="$test -h" + echo "Your builtin 'test -h' may be broken, I'm using external '$test -h'." >&4 + fi + fi + if $test "X$issymlink" = X; then + if $test -L sym 2>/dev/null; then + issymlink="$test -L" + fi + fi + if $test "X$issymlink" != X; then + echo "You can test for symbolic links with '$issymlink'." >&4 + else + echo "I do not know how you can test for symbolic links." >&4 + fi + $rm -f blurfl sym + ;; +*) echo "No symbolic links, so not testing for their testing..." >&4 + ;; +esac +echo " " + + +case "$mksymlinks" in +$define|true|[yY]*) + case "$src" in + ''|'.') echo "Cannot create symlinks in the original directory." >&4 + exit 1 + ;; + *) case "$lns:$issymlink" in + *"ln -s:"*"test -"?) + echo "Creating the symbolic links..." >&4 + echo "(First creating the subdirectories...)" >&4 + cd .. + awk '{print $1}' $src/MANIFEST | grep / | sed 's:/[^/]*$::' | sort -u | while true; do + read directory + test -z "$directory" && break + mkdir -p $directory + done + # Sanity check 1. + if test ! -d t/base; then + echo "Failed to create the subdirectories. Aborting." >&4 + exit 1 + fi + echo "(Then creating the symlinks...)" >&4 + awk '{print $1}' $src/MANIFEST | while true; do + read filename + test -z "$filename" && break + if test -f $filename; then + if $issymlink $filename; then + rm -f $filename + fi + fi + if test -f $filename; then + echo "$filename already exists, not symlinking." + else + ln -s $src/$filename $filename + fi + done + # Sanity check 2. + if test ! -f t/base/commonsense.t; then + echo "Failed to create the symlinks. Aborting." >&4 + exit 1 + fi + cd UU + ;; + *) echo "(I cannot figure out how to do symbolic links, ignoring mksymlinks)." >&4 + ;; + esac + ;; + esac + ;; +esac + : see whether [:lower:] and [:upper:] are supported character classes echo " " case "`echo AbyZ | $tr '[:lower:]' '[:upper:]' 2>/dev/null`" in @@ -2261,7 +2360,10 @@ if test -f config.sh; then rp="I see a config.sh file. Shall I use it to set the defaults?" . UU/myread case "$ans" in - n*|N*) echo "OK, I'll ignore it."; mv config.sh config.sh.old;; + n*|N*) echo "OK, I'll ignore it." + mv config.sh config.sh.old + myuname="$newmyuname" + ;; *) echo "Fetching default answers from your old config.sh file..." >&4 tmp_n="$n" tmp_c="$c" @@ -2426,7 +2528,7 @@ EOM esac ;; next*) osname=next ;; - NonStop-UX) osname=nonstopux ;; + nonstop-ux) osname=nonstopux ;; POSIX-BC | posix-bc ) osname=posix-bc osvers="$3" ;; @@ -2672,7 +2774,6 @@ cd UU ;; esac test "$override" && . ./optdef.sh -myuname="$newmyuname" : Restore computed paths for file in $loclist $trylist; do @@ -2906,7 +3007,7 @@ if test -f /osf_boot || $contains 'OSF/1' /usr/include/ctype.h >/dev/null 2>&1 then echo "Looks kind of like an OSF/1 system, but we'll see..." echo exit 0 >osf1 -elif test `echo abc | tr a-z A-Z` = Abc ; then +elif test `echo abc | $tr a-z A-Z` = Abc ; then xxx=`./loc addbib blurfl $pth` if $test -f $xxx; then echo "Looks kind of like a USG system with BSD features, but we'll see..." @@ -3286,7 +3387,7 @@ esac case "$fn" in *\(*) - expr $fn : '.*(\(.*\)).*' | tr ',' $trnl >getfile.ok + expr $fn : '.*(\(.*\)).*' | $tr ',' $trnl >getfile.ok fn=`echo $fn | sed 's/(.*)//'` ;; esac @@ -3663,7 +3764,8 @@ esac cat <<EOM Perl can be built to use the SOCKS proxy protocol library. To do so, -Configure must be run with -Dusesocks. +Configure must be run with -Dusesocks. If you use SOCKS you also need +to use the PerlIO abstraction layer, this will be implicitly selected. If this doesn't make any sense to you, just accept the default '$dflt'. EOM @@ -3676,6 +3778,10 @@ esac set usesocks eval $setvar +case "$usesocks" in +$define|true|[yY]*) useperlio="$define";; +esac + : Looking for optional libraries echo " " echo "Checking for optional libraries..." >&4 @@ -4041,8 +4147,8 @@ and I got the following output: EOM dflt=y -if sh -c "$cc -o try $optimize $ccflags $ldflags try.c $libs" >>try.msg 2>&1; then - if sh -c './try' >>try.msg 2>&1; then +if $sh -c "$cc -o try $optimize $ccflags $ldflags try.c $libs" >>try.msg 2>&1; then + if $sh -c './try' >>try.msg 2>&1; then xxx=`./try` case "$xxx" in "Ok") dflt=n ;; @@ -4739,7 +4845,7 @@ unknown) s/0*\([0-9][0-9][0-9][0-9][0-9]\)/\1/g G s/\n/ /' | \ - sort | $sed -e 's/^.* //'` + $sort | $sed -e 's/^.* //'` eval set \$$# done $test -r $1 || set /usr/ccs/lib/libc.$so @@ -4799,7 +4905,7 @@ compiler, or your machine supports multiple models), you can override it here. EOM else dflt='' - echo $libpth | tr ' ' $trnl | sort | uniq > libpath + echo $libpth | $tr ' ' $trnl | $sort | $uniq > libpath cat >&4 <<EOM I can't seem to find your C library. I've looked in the following places: @@ -4817,7 +4923,7 @@ rp='Where is your C library?' libc="$ans" echo " " -echo $libc $libnames | tr ' ' $trnl | sort | uniq > libnames +echo $libc $libnames | $tr ' ' $trnl | $sort | $uniq > libnames set X `cat libnames` shift xxx=files @@ -7266,6 +7372,25 @@ rp='Perl administrator e-mail address' . ./myread perladmin="$ans" +: determine whether to only install version-specific parts. +echo " " +$cat <<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 '') @@ -7280,7 +7405,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 @@ -7396,13 +7524,12 @@ $define|true|[yY]*) dflt='y';; esac cat <<EOM -Previous version of $package used the standard IO mechanisms as defined -in <stdio.h>. Versions 5.003_02 and later of perl allow alternate IO -mechanisms via a "PerlIO" abstraction, but the stdio mechanism is still -the default. This abstraction layer can use AT&T's sfio (if you already -have sfio installed) or regular stdio. Using PerlIO with sfio may cause -problems with some extension modules. Using PerlIO with stdio is safe, -but it is slower than plain stdio and therefore is not the default. +Previous version of $package used the standard IO mechanisms as +defined in <stdio.h>. Versions 5.003_02 and later of perl allow +alternate IO mechanisms via the PerlIO abstraction layer, but the +stdio mechanism is still the default. This abstraction layer can +use AT&T's sfio (if you already have sfio installed) or regular stdio. +Using PerlIO with sfio may cause problems with some extension modules. If this doesn't make any sense to you, just accept the default '$dflt'. EOM @@ -7413,13 +7540,29 @@ y|Y) val="$define" ;; *) - echo "Ok, doing things the stdio way" + echo "Ok, doing things the stdio way." val="$undef" ;; esac set useperlio eval $setvar +case "$usesocks" in +$define|true|[yY]*) + case "$useperlio" in + $define|true|[yY]*) ;; + *) cat >&4 <<EOM + +You are using the SOCKS proxy protocol library which means that you +should also use the PerlIO layer. You may be headed for trouble. + +EOM + ;; + esac + ;; +esac + + case "$vendorprefix" in '') d_vendorbin="$undef" vendorbin='' @@ -7445,25 +7588,6 @@ else installvendorbin="$vendorbinexp" fi -: 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 - : see if qgcvt exists set qgcvt d_qgcvt eval $inlibc @@ -7744,6 +7868,10 @@ qgcvt) d_Gconvert='qgcvt((x),(n),(b))' ;; ;; esac +: see if _fwalk exists +set fwalk d__fwalk +eval $inlibc + : Initialize h_fcntl h_fcntl=false @@ -8843,6 +8971,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 @@ -9219,6 +9395,10 @@ set fstatvfs d_fstatvfs eval $inlibc +: see if fsync exists +set fsync d_fsync +eval $inlibc + : see if ftello exists set ftello d_ftello eval $inlibc @@ -9378,6 +9558,10 @@ echo " " set d_getnetprotos getnetent $i_netdb netdb.h eval $hasproto +: see if getpagesize exists +set getpagesize d_getpagsz +eval $inlibc + : see if getprotobyname exists set getprotobyname d_getpbyname @@ -10040,6 +10224,37 @@ rp="What is the size of a character (in bytes)?" charsize="$ans" $rm -f try.c try +: check for volatile keyword +echo " " +echo 'Checking to see if your C compiler knows about "volatile"...' >&4 +$cat >try.c <<'EOCP' +int main() +{ + typedef struct _goo_struct goo_struct; + goo_struct * volatile goo = ((goo_struct *)0); + struct _goo_struct { + long long_int; + int reg_int; + char char_var; + }; + typedef unsigned short foo_t; + char *volatile foo; + volatile int bar; + volatile foo_t blech; + foo = foo; +} +EOCP +if $cc -c $ccflags try.c >/dev/null 2>&1 ; then + val="$define" + echo "Yup, it does." +else + val="$undef" + echo "Nope, it doesn't." +fi +set d_volatile +eval $setvar +$rm -f try.* + echo " " $echo "Choosing the C types to be used for Perl's internal types..." >&4 @@ -10218,67 +10433,68 @@ case "$i64type" in ;; esac -$echo "Checking whether your NVs can preserve your UVs..." >&4 +$echo "Checking how many bits of your UVs your NVs can preserve..." >&4 +: volatile so that the compiler has to store it out to memory. +if test X"$d_volatile" = X"$define"; then + volatile=volatile +fi $cat <<EOP >try.c #include <stdio.h> -int main() { - $uvtype k = ($uvtype)~0, l; - $nvtype d; - l = k; - d = ($nvtype)l; - l = ($uvtype)d; - if (l == k) - printf("preserve\n"); - exit(0); -} -EOP -set try -if eval $compile; then - case "`./try$exe_ext`" in - preserve) d_nv_preserves_uv="$define" ;; - esac -fi -case "$d_nv_preserves_uv" in -$define) $echo "Yes, they can." 2>&1 ;; -*) $echo "No, they can't." 2>&1 - d_nv_preserves_uv="$undef" - ;; -esac - -$rm -f try.* try - -case "$d_nv_preserves_uv" in -"$define") d_nv_preserves_uv_bits=`expr $uvsize \* 8` ;; -*) $echo "Checking how many bits of your UVs your NVs can preserve..." >&4 - $cat <<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 u = 0; + $nvtype d; int n = 8 * $uvsize; int i; +#ifdef SIGFPE + signal(SIGFPE, blech); +#endif + for (i = 0; i < n; i++) { u = u << 1 | ($uvtype)1; - if (($uvtype)($nvtype)u != u) + d = ($nvtype)u; + if (($uvtype)d != u) + break; + if (d <= 0) + break; + d = ($nvtype)(u - 1); + if (($uvtype)d != (u - 1)) break; +#ifdef SIGFPE + if (bletched) { + break; +#endif + } } - printf("%d\n", i); + printf("%d\n", ((i == n) ? -n : i)); exit(0); } EOP - set try - if eval $compile; then - d_nv_preserves_uv_bits="`./try$exe_ext`" - fi - case "$d_nv_preserves_uv_bits" in - [1-9]*) $echo "Your NVs can preserve $d_nv_preserves_uv_bits bits of your UVs." 2>&1 ;; - *) $echo "Can't figure out how many bits your NVs preserve." 2>&1 - d_nv_preserves_uv_bits="$undef" - ;; - esac - $rm -f try.* try +set try + +d_nv_preserves_uv="$undef" +if eval $compile; then + d_nv_preserves_uv_bits="`./try$exe_ext`" +fi +case "$d_nv_preserves_uv_bits" in +\-[1-9]*) + d_nv_preserves_uv_bits=`expr 0 - $d_nv_preserves_uv_bits` + $echo "Your NVs can preserve all $d_nv_preserves_uv_bits bits of your UVs." 2>&1 + d_nv_preserves_uv="$define" ;; +[1-9]*) $echo "Your NVs can preserve only $d_nv_preserves_uv_bits bits of your UVs." 2>&1 + d_nv_preserves_uv="$undef" ;; +*) $echo "Can't figure out how many bits your NVs preserve." 2>&1 + d_nv_preserves_uv_bits="$undef" ;; esac +$rm -f try.* try + : check for off64_t echo " " @@ -10792,6 +11008,11 @@ $rm -f try.* try core set d_sanemcmp eval $setvar +: see if prototype for sbrk is available +echo " " +set d_sbrkproto sbrk $i_unistd unistd.h +eval $hasproto + : see if select exists set select d_select eval $inlibc @@ -11390,7 +11611,28 @@ esac : see if _ptr and _cnt from stdio act std echo " " -if $contains '_IO_fpos_t' `./findhdr stdio.h` `./findhdr libio.h` >/dev/null 2>&1 ; then + +if $contains '_lbfsize' `./findhdr stdio.h` >/dev/null 2>&1 ; then + echo "(Looks like you have stdio.h from BSD.)" + case "$stdio_ptr" in + '') stdio_ptr='((fp)->_p)' + ptr_lval=$define + ;; + *) ptr_lval=$d_stdio_ptr_lval;; + esac + case "$stdio_cnt" in + '') stdio_cnt='((fp)->_r)' + cnt_lval=$define + ;; + *) cnt_lval=$d_stdio_cnt_lval;; + esac + case "$stdio_base" in + '') stdio_base='((fp)->_ub._base ? (fp)->_ub._base : (fp)->_bf._base)';; + esac + case "$stdio_bufsiz" in + '') stdio_bufsiz='((fp)->_ub._base ? (fp)->_ub._size : (fp)->_bf._size)';; + esac +elif $contains '_IO_fpos_t' `./findhdr stdio.h` `./findhdr libio.h` >/dev/null 2>&1 ; then echo "(Looks like you have stdio.h from Linux.)" case "$stdio_ptr" in '') stdio_ptr='((fp)->_IO_read_ptr)' @@ -11430,6 +11672,7 @@ else '') stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)';; esac fi + : test whether _ptr and _cnt really work echo "Checking how std your stdio is..." >&4 $cat >try.c <<EOP @@ -11479,6 +11722,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 @@ -11688,10 +12018,87 @@ EOM ;; esac +: see if strtoq exists +set strtoq d_strtoq +eval $inlibc + : see if strtoul exists set strtoul d_strtoul eval $inlibc +case "$d_strtoul" in +"$define") + $cat <<EOM +Checking whether your strtoul() works okay... +EOM + $cat >try.c <<'EOCP' +#include <errno.h> +#include <stdio.h> +extern unsigned long int strtoul(char *s, char **, int); +static int bad = 0; +void check(char *s, unsigned long eul, int een) { + unsigned long gul; + errno = 0; + gul = strtoul(s, 0, 10); + if (!((gul == eul) && (errno == een))) + bad++; +} +int main() { + check(" 1", 1L, 0); + check(" 0", 0L, 0); +EOCP + case "$longsize" in + 8) + $cat >>try.c <<'EOCP' + check("18446744073709551615", 18446744073709551615UL, 0); + check("18446744073709551616", 18446744073709551615UL, ERANGE); +#if 0 /* strtoul() for /^-/ strings is undefined. */ + check("-1", 18446744073709551615UL, 0); + check("-18446744073709551614", 2, 0); + check("-18446744073709551615", 1, 0); + check("-18446744073709551616", 18446744073709551615UL, ERANGE); + check("-18446744073709551617", 18446744073709551615UL, ERANGE); +#endif +EOCP + ;; + 4) + $cat >>try.c <<'EOCP' + check("4294967295", 4294967295UL, 0); + check("4294967296", 4294967295UL, ERANGE); +#if 0 /* strtoul() for /^-/ strings is undefined. */ + check("-1", 4294967295UL, 0); + check("-4294967294", 2, 0); + check("-4294967295", 1, 0); + check("-4294967296", 4294967295UL, ERANGE); + check("-4294967297", 4294967295UL, ERANGE); +#endif +EOCP + ;; + *) +: Should we write these tests to be more portable by sprintf-ing +: ~0 and then manipulating that char string as input for strtol? + ;; + esac + $cat >>try.c <<'EOCP' + if (!bad) + printf("ok\n"); + return 0; +} +EOCP + set try + if eval $compile; then + case "`./try`" in + ok) echo "Your strtoul() seems to be working okay." ;; + *) cat <<EOM >&4 +Your strtoul() doesn't seem to be working okay. +EOM + d_strtoul="$undef" + ;; + esac + fi + ;; +esac + : see if strtoull exists set strtoull d_strtoull eval $inlibc @@ -11717,10 +12124,17 @@ int check(char *s, long long eull, int een) { bad++; } int main() { - check(" 1", 1LL, 0); - check(" 0", 0LL, 0); - check("18446744073709551615", 18446744073709551615ULL, 0); - check("18446744073709551616", 18446744073709551615ULL, ERANGE); + check(" 1", 1LL, 0); + check(" 0", 0LL, 0); + check("18446744073709551615", 18446744073709551615ULL, 0); + check("18446744073709551616", 18446744073709551615ULL, ERANGE); +#if 0 /* strtoull() for /^-/ strings is undefined. */ + check("-1", 18446744073709551615ULL, 0); + check("-18446744073709551614", 2LL, 0); + check("-18446744073709551615", 1LL, 0); + check("-18446744073709551616", 18446744073709551615ULL, ERANGE); + check("-18446744073709551617", 18446744073709551615ULL, ERANGE); +#endif if (!bad) printf("ok\n"); } @@ -11743,6 +12157,54 @@ esac set strtouq d_strtouq eval $inlibc +case "$d_strtouq" in +"$define") + $cat <<EOM +Checking whether your strtouq() works okay... +EOM + $cat >try.c <<'EOCP' +#include <errno.h> +#include <stdio.h> +extern unsigned long long int strtouq(char *s, char **, int); +static int bad = 0; +void check(char *s, unsigned long long eull, int een) { + unsigned long long gull; + errno = 0; + gull = strtouq(s, 0, 10); + if (!((gull == eull) && (errno == een))) + bad++; +} +int main() { + check(" 1", 1LL, 0); + check(" 0", 0LL, 0); + check("18446744073709551615", 18446744073709551615ULL, 0); + check("18446744073709551616", 18446744073709551615ULL, ERANGE); +#if 0 /* strtouq() for /^-/ strings is undefined. */ + check("-1", 18446744073709551615ULL, 0); + check("-18446744073709551614", 2LL, 0); + check("-18446744073709551615", 1LL, 0); + check("-18446744073709551616", 18446744073709551615ULL, ERANGE); + check("-18446744073709551617", 18446744073709551615ULL, ERANGE); +#endif + if (!bad) + printf("ok\n"); + return 0; +} +EOCP + set try + if eval $compile; then + case "`./try`" in + ok) echo "Your strtouq() seems to be working okay." ;; + *) cat <<EOM >&4 +Your strtouq() doesn't seem to be working okay. +EOM + d_strtouq="$undef" + ;; + esac + fi + ;; +esac + : see if strxfrm exists set strxfrm d_strxfrm eval $inlibc @@ -11934,37 +12396,6 @@ esac set d_void_closedir eval $setvar $rm -f closedir* -: check for volatile keyword -echo " " -echo 'Checking to see if your C compiler knows about "volatile"...' >&4 -$cat >try.c <<'EOCP' -int main() -{ - typedef struct _goo_struct goo_struct; - goo_struct * volatile goo = ((goo_struct *)0); - struct _goo_struct { - long long_int; - int reg_int; - char char_var; - }; - typedef unsigned short foo_t; - char *volatile foo; - volatile int bar; - volatile foo_t blech; - foo = foo; -} -EOCP -if $cc -c $ccflags try.c >/dev/null 2>&1 ; then - val="$define" - echo "Yup, it does." -else - val="$undef" - echo "Nope, it doesn't." -fi -set d_volatile -eval $setvar -$rm -f try.* - : see if there is a wait4 set wait4 d_wait4 eval $inlibc @@ -13274,6 +13705,168 @@ rp="What is the type used for file modes for system calls (e.g. fchmod())?" set mode_t modetype int stdio.h sys/types.h eval $typedef_ask +: see if stdarg is available +echo " " +if $test `./findhdr stdarg.h`; then + echo "<stdarg.h> found." >&4 + valstd="$define" +else + echo "<stdarg.h> NOT found." >&4 + valstd="$undef" +fi + +: see if varags is available +echo " " +if $test `./findhdr varargs.h`; then + echo "<varargs.h> found." >&4 +else + echo "<varargs.h> NOT found, but that's ok (I hope)." >&4 +fi + +: set up the varargs testing programs +$cat > varargs.c <<EOP +#ifdef I_STDARG +#include <stdarg.h> +#endif +#ifdef I_VARARGS +#include <varargs.h> +#endif + +#ifdef I_STDARG +int f(char *p, ...) +#else +int f(va_alist) +va_dcl +#endif +{ + va_list ap; +#ifndef I_STDARG + char *p; +#endif +#ifdef I_STDARG + va_start(ap,p); +#else + va_start(ap); + p = va_arg(ap, char *); +#endif + va_end(ap); +} +EOP +$cat > varargs <<EOP +$startsh +if $cc -c $ccflags -D\$1 varargs.c >/dev/null 2>&1; then + echo "true" +else + echo "false" +fi +$rm -f varargs$_o +EOP +chmod +x varargs + +: now check which varargs header should be included +echo " " +i_varhdr='' +case "$valstd" in +"$define") + if `./varargs I_STDARG`; then + val='stdarg.h' + elif `./varargs I_VARARGS`; then + val='varargs.h' + fi + ;; +*) + if `./varargs I_VARARGS`; then + val='varargs.h' + fi + ;; +esac +case "$val" in +'') +echo "I could not find the definition for va_dcl... You have problems..." >&4 + val="$undef"; set i_stdarg; eval $setvar + val="$undef"; set i_varargs; eval $setvar + ;; +*) + set i_varhdr + eval $setvar + case "$i_varhdr" in + stdarg.h) + val="$define"; set i_stdarg; eval $setvar + val="$undef"; set i_varargs; eval $setvar + ;; + varargs.h) + val="$undef"; set i_stdarg; eval $setvar + val="$define"; set i_varargs; eval $setvar + ;; + esac + echo "We'll include <$i_varhdr> to get va_dcl definition." >&4;; +esac +$rm -f varargs* + +: see if we need va_copy +echo " " +case "$i_stdarg" in +"$define") + $cat >try.c <<EOCP +#include <stdarg.h> +#include <stdio.h> +#$i_stdlib I_STDLIB +#ifdef I_STDLIB +#include <stdlib.h> +#endif +#include <signal.h> + +int +ivfprintf(FILE *f, const char *fmt, va_list *valp) +{ + return vfprintf(f, fmt, *valp); +} + +int +myvfprintf(FILE *f, const char *fmt, va_list val) +{ + return ivfprintf(f, fmt, &val); +} + +int +myprintf(char *fmt, ...) +{ + va_list val; + va_start(val, fmt); + return myvfprintf(stdout, fmt, val); +} + +int +main(int ac, char **av) +{ + signal(SIGSEGV, exit); + + myprintf("%s%cs all right, then\n", "that", '\''); + exit(0); +} +EOCP + set try + if eval $compile && ./try 2>&1 >/dev/null; then + case "`./try`" in + "that's all right, then") + okay=yes + ;; + esac + fi + case "$okay" in + yes) echo "It seems that you don't need va_copy()." >&4 + need_va_copy="$undef" + ;; + *) echo "It seems that va_copy() or similar will be needed." >&4 + need_va_copy="$define" + ;; + esac + $rm -f try.* core core.* *.core *.core.* + ;; +*) echo "You don't have <stdarg.h>, not checking for va_copy()." >&4 + ;; +esac + : define a fucntion to check prototypes $cat > protochk <<EOSH $startsh @@ -14031,6 +14624,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") @@ -14038,7 +14635,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" @@ -14047,10 +14643,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 @@ -14111,13 +14716,17 @@ $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 echo "Your stdio uses signed chars." >&4 stdchar="char" fi +$rm -f stdioh + + : see if time exists echo " " @@ -14514,7 +15123,7 @@ EOSH ./tr '[a-z]' '[A-Z]' < Cppsym.know > Cppsym.a ./tr '[A-Z]' '[a-z]' < Cppsym.know > Cppsym.b $cat Cppsym.know > Cppsym.c -$cat Cppsym.a Cppsym.b Cppsym.c | $tr ' ' $trnl | sort | uniq > Cppsym.know +$cat Cppsym.a Cppsym.b Cppsym.c | $tr ' ' $trnl | $sort | $uniq > Cppsym.know $rm -f Cppsym.a Cppsym.b Cppsym.c cat <<EOSH > Cppsym $startsh @@ -14697,108 +15306,6 @@ val=$val3; set i_termios; eval $setvar set shadow.h i_shadow eval $inhdr -: see if this is a socks.h system -set socks.h i_socks -eval $inhdr - -: see if stdarg is available -echo " " -if $test `./findhdr stdarg.h`; then - echo "<stdarg.h> found." >&4 - valstd="$define" -else - echo "<stdarg.h> NOT found." >&4 - valstd="$undef" -fi - -: see if varags is available -echo " " -if $test `./findhdr varargs.h`; then - echo "<varargs.h> found." >&4 -else - echo "<varargs.h> NOT found, but that's ok (I hope)." >&4 -fi - -: set up the varargs testing programs -$cat > varargs.c <<EOP -#ifdef I_STDARG -#include <stdarg.h> -#endif -#ifdef I_VARARGS -#include <varargs.h> -#endif - -#ifdef I_STDARG -int f(char *p, ...) -#else -int f(va_alist) -va_dcl -#endif -{ - va_list ap; -#ifndef I_STDARG - char *p; -#endif -#ifdef I_STDARG - va_start(ap,p); -#else - va_start(ap); - p = va_arg(ap, char *); -#endif - va_end(ap); -} -EOP -$cat > varargs <<EOP -$startsh -if $cc -c $ccflags -D\$1 varargs.c >/dev/null 2>&1; then - echo "true" -else - echo "false" -fi -$rm -f varargs$_o -EOP -chmod +x varargs - -: now check which varargs header should be included -echo " " -i_varhdr='' -case "$valstd" in -"$define") - if `./varargs I_STDARG`; then - val='stdarg.h' - elif `./varargs I_VARARGS`; then - val='varargs.h' - fi - ;; -*) - if `./varargs I_VARARGS`; then - val='varargs.h' - fi - ;; -esac -case "$val" in -'') -echo "I could not find the definition for va_dcl... You have problems..." >&4 - val="$undef"; set i_stdarg; eval $setvar - val="$undef"; set i_varargs; eval $setvar - ;; -*) - set i_varhdr - eval $setvar - case "$i_varhdr" in - stdarg.h) - val="$define"; set i_stdarg; eval $setvar - val="$undef"; set i_varargs; eval $setvar - ;; - varargs.h) - val="$undef"; set i_stdarg; eval $setvar - val="$define"; set i_varargs; eval $setvar - ;; - esac - echo "We'll include <$i_varhdr> to get va_dcl definition." >&4;; -esac -$rm -f varargs* - : see if stddef is available set stddef.h i_stddef eval $inhdr @@ -15343,6 +15850,7 @@ d_PRIo64='$d_PRIo64' d_PRIu64='$d_PRIu64' d_PRIx64='$d_PRIx64' d_SCNfldbl='$d_SCNfldbl' +d__fwalk='$d__fwalk' d_access='$d_access' d_accessx='$d_accessx' d_alarm='$d_alarm' @@ -15389,6 +15897,7 @@ d_eunice='$d_eunice' d_fchmod='$d_fchmod' d_fchown='$d_fchown' d_fcntl='$d_fcntl' +d_fcntl_can_lock='$d_fcntl_can_lock' d_fd_macros='$d_fd_macros' d_fd_set='$d_fd_set' d_fds_bits='$d_fds_bits' @@ -15404,6 +15913,7 @@ d_fseeko='$d_fseeko' d_fsetpos='$d_fsetpos' d_fstatfs='$d_fstatfs' d_fstatvfs='$d_fstatvfs' +d_fsync='$d_fsync' d_ftello='$d_ftello' d_ftime='$d_ftime' d_getcwd='$d_getcwd' @@ -15423,6 +15933,7 @@ d_getnbyaddr='$d_getnbyaddr' d_getnbyname='$d_getnbyname' d_getnent='$d_getnent' d_getnetprotos='$d_getnetprotos' +d_getpagsz='$d_getpagsz' d_getpbyname='$d_getpbyname' d_getpbynumber='$d_getpbynumber' d_getpent='$d_getpent' @@ -15526,6 +16037,7 @@ d_rmdir='$d_rmdir' d_safebcpy='$d_safebcpy' d_safemcpy='$d_safemcpy' d_sanemcmp='$d_sanemcmp' +d_sbrkproto='$d_sbrkproto' d_sched_yield='$d_sched_yield' d_scm_rights='$d_scm_rights' d_seekdir='$d_seekdir' @@ -15580,6 +16092,8 @@ d_statfs_s='$d_statfs_s' d_statvfs='$d_statvfs' d_stdio_cnt_lval='$d_stdio_cnt_lval' d_stdio_ptr_lval='$d_stdio_ptr_lval' +d_stdio_ptr_lval_nochange_cnt='$d_stdio_ptr_lval_nochange_cnt' +d_stdio_ptr_lval_sets_cnt='$d_stdio_ptr_lval_sets_cnt' d_stdio_stream_array='$d_stdio_stream_array' d_stdiobase='$d_stdiobase' d_stdstdio='$d_stdstdio' @@ -15592,6 +16106,7 @@ d_strtod='$d_strtod' d_strtol='$d_strtol' d_strtold='$d_strtold' d_strtoll='$d_strtoll' +d_strtoq='$d_strtoq' d_strtoul='$d_strtoul' d_strtoull='$d_strtoull' d_strtouq='$d_strtouq' @@ -15783,6 +16298,7 @@ installvendorarch='$installvendorarch' installvendorbin='$installvendorbin' installvendorlib='$installvendorlib' intsize='$intsize' +issymlink='$issymlink' ivdformat='$ivdformat' ivsize='$ivsize' ivtype='$ivtype' @@ -15845,6 +16361,7 @@ mydomain='$mydomain' myhostname='$myhostname' myuname='$myuname' n='$n' +need_va_copy='$need_va_copy' netdb_hlen_type='$netdb_hlen_type' netdb_host_type='$netdb_host_type' netdb_name_type='$netdb_name_type' @@ -16057,9 +16574,9 @@ echo "CONFIGDOTSH=true" >>config.sh : propagate old symbols if $test -f UU/config.sh; then - <UU/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 @@ -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. @@ -517,6 +517,23 @@ directories to add to @INC. By default, it will be empty. Perl will search these directories (including architecture and version-specific subdirectories) for add-on modules and extensions. +=item APPLLIB_EXP + +There is one other way of adding paths to @INC at perl build time, and +that is by setting the APPLLIB_EXP C pre-processor token to a colon- +separated list of directories, like this + + sh Configure -Accflags='-DAPPLLIB_EXP=\"/usr/libperl\"' + +The directories defined by APPLLIB_EXP get added to @INC I<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 In versions 5.005_57 and earlier, the default was to store module man @@ -1131,6 +1148,39 @@ you have some libraries under /usr/local/ and others under =back +=head2 Building DB, NDBM, and ODBM interfaces with Berkeley DB 3 + +Perl interface for DB3 is part of Berkeley DB, but if you want to +compile standard Perl DB/ODBM/NDBM interfaces, you must follow +following instructions. + +Berkeley DB3 from Sleepycat Software is by default installed without +DB1 compatibility code (needed for DB_File interface) and without +links to compatibility files. So if you want to use packages written +for DB/ODBM/NDBM interfaces, you need to configure DB3 with +--enable-compat185 (and optionally with --enable-dump185) and create +additional references (suppose you are installing DB3 with +--prefix=/usr): + + ln -s libdb-3.so /usr/lib/libdbm.so + ln -s libdb-3.so /usr/lib/libndbm.so + echo '#define DB_DBM_HSEARCH 1' >dbm.h + echo '#include <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. @@ -1397,36 +1447,6 @@ numbers and function name may vary in different versions of perl): it might well be a symptom of the gcc "varargs problem". See the previous L<"varargs"> item. -=item Solaris and SunOS dynamic loading - -If you have problems with dynamic loading using gcc on SunOS or -Solaris, and you are using GNU as and GNU ld, you may need to add --B/bin/ (for SunOS) or -B/usr/ccs/bin/ (for Solaris) to your -$ccflags, $ldflags, and $lddlflags so that the system's versions of as -and ld are used. Note that the trailing '/' is required. -Alternatively, you can use the GCC_EXEC_PREFIX -environment variable to ensure that Sun's as and ld are used. Consult -your gcc documentation for further information on the -B option and -the GCC_EXEC_PREFIX variable. - -One convenient way to ensure you are not using GNU as and ld is to -invoke Configure with - - sh Configure -Dcc='gcc -B/usr/ccs/bin/' - -for Solaris systems. For a SunOS system, you must use -B/bin/ -instead. - -Alternatively, recent versions of GNU ld reportedly work if you -include C<-Wl,-export-dynamic> in the ccdlflags variable in -config.sh. - -=item ld.so.1: ./perl: fatal: relocation error: - -If you get this message on SunOS or Solaris, and you're using gcc, -it's probably the GNU as or GNU ld problem in the previous item -L<"Solaris and SunOS dynamic loading">. - =item LD_LIBRARY_PATH If you run into dynamic loading problems, check your setting of @@ -1435,18 +1455,6 @@ Perl library (libperl.a rather than libperl.so) it should build fine with LD_LIBRARY_PATH unset, though that may depend on details of your local set-up. -=item dlopen: stub interception failed - -The primary cause of the 'dlopen: stub interception failed' message is -that the LD_LIBRARY_PATH environment variable includes a directory -which is a symlink to /usr/lib (such as /lib). - -The reason this causes a problem is quite subtle. The file libdl.so.1.0 -actually *only* contains functions which generate 'stub interception -failed' errors! The runtime linker intercepts links to -"/usr/lib/libdl.so.1.0" and links in internal implementation of those -functions instead. [Thanks to Tim Bunce for this explanation.] - =item nm extraction If Configure seems to be having trouble finding library functions, @@ -1632,24 +1640,11 @@ official site named at the start of this document. If you do find that any site is carrying a corrupted or incomplete source code archive, please report it to the site's maintainer. -This message can also be a symptom of using (say) a GNU tar compiled -for SunOS4 on Solaris. When you run SunOS4 binaries on Solaris the -run-time system magically alters pathnames matching m#lib/locale# - so -when tar tries to create lib/locale.pm a differently-named file gets -created instead. - -You may find the file under its assumed name and be able to rename it -back. Or use Sun's tar to do the extract. - =item invalid token: ## You are using a non-ANSI-compliant C compiler. See L<WARNING: This version requires a compiler that supports ANSI C>. -=item lib/locale.pm: No such file or directory - -See L<THIS PACKAGE SEEMS TO BE INCOMPLETE>. - =item Miscellaneous Some additional things that have been reported for either perl4 or perl5: @@ -1,6 +1,6 @@ /* INTERN.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. diff --git a/MAINTAIN b/MAINTAIN deleted file mode 100644 index cd1e4ed3c3..0000000000 --- a/MAINTAIN +++ /dev/null @@ -1,904 +0,0 @@ -# In addition to actual maintainers this file also lists "interested parties". -# -# The maintainer aliases come from AUTHORS. They may be defined in -# a layered way: 'doc' expands to tchrist which expands to Tom Christiansen. -# -# A file that is in MANIFEST need not be here at all. -# In any case, if nobody else is listed as maintainer, -# PUMPKING (from AUTHORS) should be it. -# -# Filenames can contain * which means qr(.*) on the filenames found -# using File::Find (it's _not_ filename glob). -# -# Maintainership definitions are of course cumulative: if A maintains -# X/* and B maintains X/Y/Z, if X/Y/Z is changed, both A and B should -# be notified. -# -# The filename(glob) and the maintainer(s) are separated by one or more tabs. - -Artistic -Changes -Changes5.000 -Changes5.001 -Changes5.002 -Changes5.003 -Changes5.004 -Changes5.005 -Configure cfg -Copying -EXTERN.h -INSTALL -INTERN.h -MANIFEST -Makefile.SH -Makefile.micro simon -objXSUB.h -Policy_sh.SH -Porting/* cfg -Porting/Contract -Porting/Glossary -Porting/config.sh -Porting/config_H -Porting/findvars -Porting/fixCORE -Porting/fixvars -Porting/genlog -Porting/makerel -Porting/p4d2p -Porting/p4desc -Porting/patching.pod dgris -Porting/patchls -Porting/pumpkin.pod -README -README.amiga amiga -README.beos beos -README.cygwin cygwin -README.dos dos -README.hpux hpux -README.lexwarn lexwarn -README.machten machten -README.micro simon -README.mpeix mpeix -README.os2 os2 -README.os390 os390 -README.plan9 plan9 -README.posix-bc posix-bc -README.qnx qnx -README.threads -README.vmesa vmesa -README.vms vms -README.vos vos -README.win32 win32 -Todo -Todo-5.005 -Todo.micro simon -XSlock.h -XSUB.h -av.c -av.h -beos/* beos -bytecode.h -bytecode.pl -byterun.c -byterun.h -cc_runtime.h -cflags.SH -config_h.SH cfg -configpm -configure.com vms -configure.gnu -cop.h -cv.h -cygwin/* cygwin -deb.c -djgpp/* dos -doio.c -doop.c -dosish.h -dump.c -ebcdic.c -eg/ADB -eg/README -eg/cgi/* cgi -eg/changes -eg/client -eg/down -eg/dus -eg/findcp -eg/findtar -eg/g/gcp -eg/g/gcp.man -eg/g/ged -eg/g/ghosts -eg/g/gsh -eg/g/gsh.man -eg/muck -eg/muck.man -eg/myrup -eg/nih -eg/relink -eg/rename -eg/rmfrom -eg/scan/scan_df -eg/scan/scan_last -eg/scan/scan_messages -eg/scan/scan_passwd -eg/scan/scan_ps -eg/scan/scan_sudo -eg/scan/scan_suid -eg/scan/scanner -eg/server -eg/shmkill -eg/sysvipc/README -eg/sysvipc/ipcmsg -eg/sysvipc/ipcsem -eg/sysvipc/ipcshm -eg/travesty -eg/unuc -eg/uudecode -eg/van/empty -eg/van/unvanish -eg/van/vanexp -eg/van/vanish -eg/who -eg/wrapsuid -emacs/* ilya -embed.h -embed.pl -embedvar.h -ext/*/hints* cfg -ext/B/* nik -ext/B/B/Deparse.pm smccam -ext/DB_File* pmarquess -ext/DB_File/hints/dynixptx.pl dynix/ptx -ext/Data/Dumper/* gsar -ext/Devel/DProf/* -ext/Devel/Peek/* ilya -ext/DynaLoader/DynaLoader_pm.PL -ext/DynaLoader/Makefile.PL -ext/DynaLoader/README -ext/DynaLoader/dl_aix.xs aix -ext/DynaLoader/dl_dld.xs rsanders -ext/DynaLoader/dl_dlopen.xs timb -ext/DynaLoader/dl_hpux.xs hpux -ext/DynaLoader/dl_mpeix.xs mpeix -ext/DynaLoader/dl_next.xs next -ext/DynaLoader/dl_none.xs -ext/DynaLoader/dl_vms.xs vms -ext/DynaLoader/dl_vmesa.xs vmesa -ext/DynaLoader/dlutils.c -ext/DynaLoader/hints/linux.pl linux -ext/Errno/* gbarr -ext/Fcntl/* jhi -ext/GDBM_File/GDBM_File.pm -ext/GDBM_File/GDBM_File.xs -ext/GDBM_File/Makefile.PL -ext/GDBM_File/typemap -ext/IO/* -ext/IPC/SysV/* gbarr -ext/NDBM_File/Makefile.PL -ext/NDBM_File/NDBM_File.pm -ext/NDBM_File/NDBM_File.xs -ext/NDBM_File/hints/dec_osf.pl dec_osf -ext/NDBM_File/hints/dynixptx.pl dynix/ptx -ext/NDBM_File/hints/solaris.pl solaris -ext/NDBM_File/hints/svr4.pl svr4 -ext/NDBM_File/typemap -ext/ODBM_File/Makefile.PL -ext/ODBM_File/ODBM_File.pm -ext/ODBM_File/ODBM_File.xs -ext/ODBM_File/hints/dec_osf.pl dec_osf -ext/ODBM_File/hints/hpux.pl hpux -ext/ODBM_File/hints/sco.pl sco -ext/ODBM_File/hints/solaris.pl solaris -ext/ODBM_File/hints/svr4.pl svr4 -ext/ODBM_File/hints/ultrix.pl -ext/ODBM_File/typemap -ext/Opcode/Makefile.PL -ext/Opcode/Opcode.pm -ext/Opcode/Opcode.xs -ext/Opcode/Safe.pm -ext/Opcode/ops.pm -ext/POSIX/Makefile.PL -ext/POSIX/POSIX.pm -ext/POSIX/POSIX.pod -ext/POSIX/POSIX.xs -ext/POSIX/hints/bsdos.pl bsdos -ext/POSIX/hints/dynixptx.pl dynix/ptx -ext/POSIX/hints/freebsd.pl freebsd -ext/POSIX/hints/linux.pl linux -ext/POSIX/hints/netbsd.pl netbsd -ext/POSIX/hints/next_3.pl next -ext/POSIX/hints/openbsd.pl openbsd -ext/POSIX/hints/sunos_4.pl sunos4 -ext/POSIX/typemap -ext/SDBM_File/Makefile.PL -ext/SDBM_File/SDBM_File.pm -ext/SDBM_File/SDBM_File.xs -ext/SDBM_File/sdbm/CHANGES -ext/SDBM_File/sdbm/COMPARE -ext/SDBM_File/sdbm/Makefile.PL -ext/SDBM_File/sdbm/README -ext/SDBM_File/sdbm/README.too -ext/SDBM_File/sdbm/biblio -ext/SDBM_File/sdbm/dba.c -ext/SDBM_File/sdbm/dbd.c -ext/SDBM_File/sdbm/dbe.1 -ext/SDBM_File/sdbm/dbe.c -ext/SDBM_File/sdbm/dbm.c -ext/SDBM_File/sdbm/dbm.h -ext/SDBM_File/sdbm/dbu.c -ext/SDBM_File/sdbm/grind -ext/SDBM_File/sdbm/hash.c -ext/SDBM_File/sdbm/linux.patches -ext/SDBM_File/sdbm/makefile.sdbm -ext/SDBM_File/sdbm/pair.c -ext/SDBM_File/sdbm/pair.h -ext/SDBM_File/sdbm/readme.ms -ext/SDBM_File/sdbm/sdbm.3 -ext/SDBM_File/sdbm/sdbm.c -ext/SDBM_File/sdbm/sdbm.h -ext/SDBM_File/sdbm/tune.h -ext/SDBM_File/sdbm/util.c -ext/SDBM_File/typemap -ext/Socket/Makefile.PL -ext/Socket/Socket.pm -ext/Socket/Socket.xs -ext/Thread/Makefile.PL -ext/Thread/Notes -ext/Thread/README -ext/Thread/Thread.pm -ext/Thread/Thread.xs -ext/Thread/Thread/Queue.pm -ext/Thread/Thread/Semaphore.pm -ext/Thread/Thread/Signal.pm -ext/Thread/Thread/Specific.pm -ext/Thread/create.t -ext/Thread/die.t -ext/Thread/die2.t -ext/Thread/io.t -ext/Thread/join.t -ext/Thread/join2.t -ext/Thread/list.t -ext/Thread/lock.t -ext/Thread/queue.t -ext/Thread/specific.t -ext/Thread/sync.t -ext/Thread/sync2.t -ext/Thread/typemap -ext/Thread/unsync.t -ext/Thread/unsync2.t -ext/Thread/unsync3.t -ext/Thread/unsync4.t -ext/attrs/Makefile.PL -ext/attrs/attrs.pm -ext/attrs/attrs.xs -ext/re/Makefile.PL -ext/re/hints/mpeix.pl mpeix -ext/re/re.pm regex -ext/re/re.xs regex -ext/util/make_ext -ext/util/mkbootstrap -fakethr.h -form.h -global.sym -globals.c -globvar.sym -gv.c -gv.h -h2pl/README -h2pl/cbreak.pl -h2pl/cbreak2.pl -h2pl/eg/sizeof.ph -h2pl/eg/sys/errno.pl -h2pl/eg/sys/ioctl.pl -h2pl/eg/sysexits.pl -h2pl/getioctlsizes -h2pl/mksizes -h2pl/mkvars -h2pl/tcbreak -h2pl/tcbreak2 -handy.h -hints/* cfg -hints/3b1.sh -hints/3b1cc -hints/README.hints -hints/aix.sh aix -hints/altos486.sh -hints/amigaos.sh amiga -hints/apollo.sh -hints/aux_3.sh -hints/beos.sh beos -hints/broken-db.msg -hints/bsdos.sh bsdos -hints/convexos.sh -hints/cxux.sh cxux -hints/cygwin.sh cygwin -hints/dcosx.sh -hints/dec_osf.sh dec_osf -hints/dgux.sh dgux -hints/dos_djgpp.sh dos -hints/dynix.sh dynix/ptx -hints/dynixptx.sh dynix/ptx -hints/epix.sh -hints/esix4.sh -hints/fps.sh -hints/freebsd.sh freebsd -hints/genix.sh -hints/greenhills.sh -hints/hpux.sh hpux -hints/i386.sh -hints/irix* irix -hints/isc.sh -hints/isc_2.sh -hints/linux.sh linux -hints/lynxos.sh -hints/machten.sh machten -hints/machten_2.sh -hints/mips.sh -hints/mpc.sh -hints/mpeix.sh mpeix -hints/ncr_tower.sh -hints/netbsd.sh netbsd -hints/newsos4.sh -hints/next* step -hints/openbsd.sh openbsd -hints/opus.sh -hints/os2.sh os2 -hints/os390.sh os390 -hints/posix-bc.sh posix-bc -hints/powerux.sh powerux -hints/qnx.sh qnx -hints/sco.sh -hints/sco_2_3_0.sh -hints/sco_2_3_1.sh -hints/sco_2_3_2.sh -hints/sco_2_3_3.sh -hints/sco_2_3_4.sh -hints/solaris_2.sh solaris -hints/stellar.sh -hints/sunos_4* sunos4 -hints/svr4.sh svr4 -hints/ti1500.sh -hints/titanos.sh -hints/ultrix_4.sh ultrix -hints/umips.sh -hints/unicos* unicos -hints/unisysdynix.sh -hints/utekv.sh -hints/uts.sh -hints/uwin.sh uwin -hints/vmesa.sh vmesa -hv.c -hv.h -installhtml -installman -installperl -intrpvar.h -iperlsys.h -jpl/* jpl -keywords.h -keywords.pl -lib/AnyDBM_File.pm -lib/AutoLoader.pm -lib/AutoSplit.pm -lib/Benchmark.pm jhi,timb -lib/CGI* cgi -lib/CPAN* cpan -lib/Carp.pm -lib/Class/Struct.pm tchrist -lib/Cwd.pm -lib/Devel/SelfStubber.pm -lib/DirHandle.pm -lib/English.pm -lib/Env.pm -lib/Exporter.pm -lib/ExtUtils/* mm -lib/ExtUtils/Command.pm nik -lib/ExtUtils/Embed.pm doug -lib/ExtUtils/Installed.pm alan.burlison -lib/ExtUtils/Mksymlists.pm cbail -lib/ExtUtils/MM_OS2.pm os2 -lib/ExtUtils/MM_VMS.pm vms -lib/ExtUtils/MM_Win32.pm win32 -lib/ExtUtils/Packlist.pm alan.burlison -lib/Fatal.pm -lib/File/Basename.pm -lib/File/CheckTree.pm -lib/File/Compare.pm nik -lib/File/Copy.pm cbail -lib/File/DosGlob.pm gsar -lib/File/Find.pm -lib/File/Path.pm timb,cbail -lib/File/Spec* kjahds -lib/File/Spec/Mac.pm schinder -lib/File/Spec/OS2.pm ilya -lib/File/Spec/VMS.pm vms -lib/File/Spec/Win32.pm win32 -lib/File/Temp.pm tjenness -lib/File/stat.pm tchrist -lib/FileCache.pm -lib/FileHandle.pm -lib/FindBin.pm -lib/Getopt/Long.pm jvromans -lib/I18N/Collate.pm jhi -lib/IPC/Open2.pm -lib/IPC/Open3.pm -lib/Math/BigFloat.pm mbiggar -lib/Math/BigInt.pm mbiggar -lib/Math/Complex.pm complex -lib/Math/Trig.pm complex -lib/Net/Ping.pm -lib/Net/hostent.pm tchrist -lib/Net/netent.pm tchrist -lib/Net/protoent.pm tchrist -lib/Net/servent.pm tchrist -lib/Pod/Checker.pm bradapp -lib/Pod/Functions.pm -lib/Pod/Html.pm tchrist -lib/Pod/InputObjects.pm bradapp -lib/Pod/LaTeX.pm tjenness -lib/Pod/Man.pm rra -lib/Pod/Parser.pm bradapp -lib/Pod/PlainText.pm bradapp -lib/Pod/Select.pm bradapp -lib/Pod/Text.pm rra -lib/Pod/Text/* rra -lib/Pod/Usage.pm bradapp -lib/Search/Dict.pm -lib/SelectSaver.pm -lib/SelfLoader.pm -lib/Shell.pm -lib/Symbol.pm -lib/Sys/Hostname.pm sundstrom -lib/Sys/Syslog.pm tchrist -lib/Term/ANSIcolor.pm rra -lib/Term/Cap.pm -lib/Term/Complete.pm wayne.thompson -lib/Term/ReadLine.pm -lib/Test.pm -lib/Test/Harness.pm k -lib/Text/Abbrev.pm -lib/Text/ParseWords.pm pomeranz -lib/Text/Soundex.pm mikestok -lib/Text/Tabs.pm muir -lib/Text/Wrap.pm muir -lib/Tie/Array.pm nik -lib/Tie/Handle.pm -lib/Tie/Hash.pm -lib/Tie/RefHash.pm gsar -lib/Tie/Scalar.pm -lib/Tie/SubstrHash.pm -lib/Time/Local.pm pomeranz -lib/Time/gmtime.pm tchrist -lib/Time/localtime.pm tchrist -lib/Time/tm.pm tchrist -lib/UNIVERSAL.pm -lib/User/grent.pm tchrist -lib/User/pwent.pm tchrist -lib/abbrev.pl -lib/assert.pl -lib/autouse.pm -lib/base.pm -lib/bigfloat.pl -lib/bigint.pl -lib/bigrat.pl -lib/blib.pm -lib/cacheout.pl -lib/charnames.pm ilya -lib/chat2.pl -lib/complete.pl -lib/constant.pm -lib/ctime.pl -lib/diagnostics.pm doc -lib/dotsh.pl -lib/dumpvar.pl -lib/exceptions.pl -lib/fastcwd.pl -lib/fields.pm -lib/filetest.pm -lib/find.pl -lib/finddepth.pl -lib/flush.pl -lib/ftp.pl -lib/getcwd.pl -lib/getopt.pl -lib/getopts.pl -lib/hostname.pl -lib/importenv.pl -lib/integer.pm -lib/less.pm -lib/lib.pm -lib/locale.pm locale -lib/look.pl -lib/newgetopt.pl -lib/open2.pl -lib/open3.pl -lib/overload.pm ilya -lib/perl5db.pl ilya -lib/pwd.pl -lib/shellwords.pl -lib/sigtrap.pm -lib/stat.pl -lib/strict.pm -lib/subs.pm -lib/syslog.pl -lib/tainted.pl -lib/termcap.pl -lib/timelocal.pl -lib/unicode/*Ethiopic* dmulholl -lib/unicode* lwall -lib/utf8* lwall -lib/validate.pl -lib/vars.pm -lib/warning.pm lexwarn -makeaperl.SH -makedepend.SH -makedir.SH -malloc.c ilya -mg.c -mg.h -minimod.pl -miniperlmain.c -mpeix/* mpeix -mv-if-diff -myconfig -nostdio.h -op.c -op.h -opcode.h -opcode.pl -os2/* ilya -patchlevel.h -perl.c -perl.h -perl_exp.SH -perlio.c -perlio.h -perlio.sym -perlsdio.h -perlsfio.h -perlsh -perlvars.h -perly.c -perly_c.diff -perly.fixer -perly.h -perly.y -plan9/* plan9 -pod/pod2usage.PL bradapp -pod/podchecker.PL bradapp -pod/podselect.PL bradapp -pod/* doc -pod/buildtoc -pod/checkpods.PL -pod/perl.pod -pod/perlapio.pod -pod/perlbook.pod -pod/perlbot.pod -pod/perlcall.pod pmarquess -pod/perldata.pod -pod/perldebug.pod -pod/perldelta.pod -pod/perl5005delta.pod -pod/perl5004delta.pod -pod/perldebtut.pod richard -pod/perldiag.pod -pod/perldsc.pod tchrist -pod/perlembed.pod doug,jon -pod/perlebcdic.pod pvhp -pod/perlfaq* gnat -pod/perlform.pod -pod/perlfunc.pod -pod/perlguts.pod -pod/perlhack.pod simon -pod/perlhist.pod jhi -pod/perlipc.pod tchrist -pod/perllocale.pod locale -pod/perllol.pod tchrist -pod/perlmod.pod -pod/perlmodinstall.pod jon -pod/perlmodlib.pod simon -pod/perlmodlib.PL simon -pod/perlnewmod.pod simon -pod/perlobj.pod -pod/perlop.pod -pod/perlpod.pod lwall -pod/perlport.pod pudge -pod/perlposix-bc.pod posix-bc -pod/perlre.pod regex -pod/perlref.pod -pod/perlreftut.pod mjd -pod/perlrequick.pod mkvale -pod/perlretut.pod mkvale -pod/perlrun.pod -pod/perlsec.pod -pod/perlstyle.pod -pod/perlsub.pod -pod/perlsyn.pod -pod/perltie.pod tchrist -pod/perltoc.pod -pod/perltoot.pod tchrist -pod/perltrap.pod -pod/perlunicode.pod simon -pod/perlutil.pod simon -pod/perlvar.pod -pod/perlxs.pod roehrich -pod/perlxstut.pod okamoto -pod/pod2html.PL -pod/pod2latex.PL -pod/pod2man.PL -pod/pod2text.PL -pod/roffitall -pod/rofftoc -pod/splitman -pod/splitpod -pp.c -pp.h -pp.sym -pp_ctl.c -pp_hot.c -pp_proto.h -pp_sys.c -proto.h -qnx/* qnx -regcomp.c regex -regcomp.h regex -regcomp.pl regex -regcomp.sym regex -regexec.c regex -regexp.h regex -regnodes.h regex -run.c -scope.c -scope.h -sv.c -sv.h -t/README -t/TEST -t/UTEST -t/base/cond.t -t/base/if.t -t/base/lex.t -t/base/pat.t -t/base/rs.t -t/base/term.t -t/cmd/elsif.t -t/cmd/for.t -t/cmd/mod.t -t/cmd/subval.t -t/cmd/switch.t -t/cmd/while.t -t/comp/cmdopt.t -t/comp/colon.t -t/comp/cpp.aux -t/comp/cpp.t -t/comp/decl.t -t/comp/multiline.t -t/comp/package.t -t/comp/proto.t -t/comp/redef.t -t/comp/require.t -t/comp/script.t -t/comp/term.t -t/comp/use.t -t/harness -t/io/argv.t -t/io/dup.t -t/io/fs.t -t/io/inplace.t -t/io/iprefix.t -t/io/pipe.t -t/io/print.t -t/io/read.t -t/io/tell.t -t/lib/abbrev.t -t/lib/anydbm.t -t/lib/ansicolor.t rra -t/lib/autoloader.t -t/lib/basename.t -t/lib/bigint.t -t/lib/bigintpm.t -t/lib/cgi-form.t -t/lib/cgi-function.t -t/lib/cgi-html.t -t/lib/cgi-request.t -t/lib/charnames.t ilya -t/lib/checktree.t -t/lib/complex.t complex -t/lib/db-btree.t pmarquess -t/lib/db-hash.t pmarquess -t/lib/db-recno.t pmarquess -t/lib/dirhand.t -t/lib/dosglob.t -t/lib/dumper-ovl.t gsar -t/lib/dumper.t gsar -t/lib/english.t -t/lib/env.t -t/lib/errno.t gbarr -t/lib/fields.t -t/lib/filecache.t -t/lib/filecopy.t -t/lib/filefind.t -t/lib/filehand.t -t/lib/filepath.t -t/lib/filespec.t kjahds -t/lib/findbin.t -t/lib/ftmp-*.t tjenness -t/lib/gol-basic.t jvromans -t/lib/gol-compat.t jvromans -t/lib/gol-linkage.t jvromans -t/lib/gdbm.t -t/lib/getopt.t jvromans -t/lib/h2ph* kstar -t/lib/hostname.t -t/lib/io_* gbarr -t/lib/ipc_sysv.t gbarr -t/lib/ndbm.t -t/lib/odbm.t -t/lib/opcode.t -t/lib/open2.t -t/lib/open3.t -t/lib/ops.t -t/lib/parsewords.t -t/lib/ph.t kstar -t/lib/posix.t -t/lib/safe1.t -t/lib/safe2.t -t/lib/sdbm.t -t/lib/searchdict.t -t/lib/selectsaver.t -t/lib/socket.t -t/lib/soundex.t -t/lib/symbol.t -t/lib/texttabs.t muir -t/lib/textfill.t muir -t/lib/textwrap.t -t/lib/thr5005.t -t/lib/tie-push.t -t/lib/tie-stdarray.t -t/lib/tie-stdpush.t -t/lib/timelocal.t -t/lib/trig.t -t/op/append.t -t/op/arith.t -t/op/array.t -t/op/assignwarn.t -t/op/auto.t -t/op/avhv.t -t/op/bop.t -t/op/chop.t -t/op/closure.t -t/op/cmp.t -t/op/cond.t -t/op/context.t -t/op/defins.t -t/op/delete.t -t/op/die.t -t/op/die_exit.t -t/op/do.t -t/op/each.t -t/op/eval.t -t/op/exec.t -t/op/exp.t -t/op/filetest.t -t/op/flip.t -t/op/fork.t -t/op/glob.t -t/op/goto.t -t/op/goto_xs.t -t/op/grent.t -t/op/groups.t -t/op/gv.t -t/op/hashwarn.t -t/op/inc.t -t/op/index.t -t/op/int.t -t/op/join.t -t/op/lex_assign.t -t/op/list.t -t/op/local.t -t/op/magic.t -t/op/method.t -t/op/misc.t -t/op/mkdir.t -t/op/my.t -t/op/nothr5005.t -t/op/oct.t -t/op/ord.t -t/op/pack.t -t/op/pat.t -t/op/pos.t -t/op/push.t -t/op/pwent.t -t/op/quotemeta.t -t/op/rand.t -t/op/range.t -t/op/re_tests regex -t/op/read.t -t/op/readdir.t -t/op/recurse.t -t/op/ref.t -t/op/regexp.t regex -t/op/regexp_noamp.t regex -t/op/repeat.t -t/op/runlevel.t -t/op/sleep.t -t/op/sort.t -t/op/splice.t -t/op/split.t -t/op/sprintf.t -t/op/stat.t -t/op/study.t -t/op/subst.t -t/op/substr.t -t/op/sysio.t -t/op/taint.t -t/op/tie.t -t/op/tiearray.t -t/op/tiehandle.t -t/op/time.t -t/op/tr.t -t/op/undef.t -t/op/universal.t -t/op/unshift.t -t/op/vec.t -t/op/wantarray.t -t/op/write.t -t/pod/* bradapp -t/pragma/constant.t -t/pragma/locale.t locale -t/pragma/overload.t ilya -t/pragma/strict-refs -t/pragma/strict-subs -t/pragma/strict-vars -t/pragma/strict.t -t/pragma/subs.t -t/pragma/warn/* lexwarn -t/pragma/warn/regcomp regex -t/pragma/warn/regexec regex -t/pragma/warning.t lexwarn -taint.c -thrdvar.h -thread.h -toke.c -uconfig.h simon -uconfig.sh simon -universal.c -unixish.h -utf* lwall -utils/Makefile -utils/c2ph.PL tchrist -utils/h2ph.PL kstar -utils/h2xs.PL -utils/perlbug.PL -utils/perlcc.PL -utils/perldoc.PL -utils/pl2pm.PL -utils/splain.PL doc -vmesa/* vmesa -vms/* vms -vos/* vos -warning.h lexwarn -warning.pl lexwarn -win32/* -writemain.SH -x2p/EXTERN.h -x2p/INTERN.h -x2p/Makefile.SH -x2p/a2p.c -x2p/a2p.h -x2p/a2p.pod -x2p/a2p.y -x2p/a2py.c -x2p/cflags.SH -x2p/find2perl.PL -x2p/hash.c -x2p/hash.h -x2p/proto.h -x2p/s2p.PL -x2p/str.c -x2p/str.h -x2p/util.c -x2p/util.h -x2p/walk.c @@ -13,7 +13,6 @@ Copying The GNU General Public License EXTERN.h Included before foreign .h files INSTALL Detailed installation instructions INTERN.h Included before domestic .h files -MAINTAIN Who maintains which files MANIFEST This list of files Makefile.SH A script that generates Makefile Makefile.micro microperl Makefile @@ -32,6 +31,7 @@ Porting/p4desc Smarter 'p4 describe', outputs diffs for new files Porting/patching.pod How to report changes made to Perl Porting/patchls Flexible patch file listing utility Porting/pumpkin.pod Guidelines and hints for Perl maintainers +Porting/repository.pod How to use the Perl repository README The Instructions README.Y2K Notes about Year 2000 concerns README.aix Notes about AIX port @@ -52,6 +52,7 @@ README.os390 Notes about OS/390 (nee MVS) port README.plan9 Notes about Plan9 port README.posix-bc Notes about BS2000 POSIX port README.qnx Notes about QNX port +README.solaris Notes about Solaris port README.threads Notes about multithreading README.vmesa Notes about VM/ESA port README.vms Notes about installing the VMS port @@ -191,10 +192,11 @@ ext/DynaLoader/hints/netbsd.pl Hint for DynaLoader for named architecture ext/DynaLoader/hints/openbsd.pl Hint for DynaLoader for named architecture ext/Encode/Encode.pm Encode extension ext/Encode/Encode.xs Encode extension -ext/Encode/Makefile.PL Encode extension -ext/Encode/Todo Encode extension +ext/Encode/Encode/EncodeFormat.pod Encoding table format ext/Encode/Encode/ascii.enc Encoding tables ext/Encode/Encode/big5.enc Encoding tables +ext/Encode/Encode/cp1006.enc Encoding tables +ext/Encode/Encode/cp1047.enc Encoding tables ext/Encode/Encode/cp1250.enc Encoding tables ext/Encode/Encode/cp1251.enc Encoding tables ext/Encode/Encode/cp1252.enc Encoding tables @@ -204,12 +206,15 @@ ext/Encode/Encode/cp1255.enc Encoding tables ext/Encode/Encode/cp1256.enc Encoding tables ext/Encode/Encode/cp1257.enc Encoding tables ext/Encode/Encode/cp1258.enc Encoding tables +ext/Encode/Encode/cp37.enc Encoding tables +ext/Encode/Encode/cp424.enc Encoding tables ext/Encode/Encode/cp437.enc Encoding tables ext/Encode/Encode/cp737.enc Encoding tables ext/Encode/Encode/cp775.enc Encoding tables ext/Encode/Encode/cp850.enc Encoding tables ext/Encode/Encode/cp852.enc Encoding tables ext/Encode/Encode/cp855.enc Encoding tables +ext/Encode/Encode/cp856.enc Encoding tables ext/Encode/Encode/cp857.enc Encoding tables ext/Encode/Encode/cp860.enc Encoding tables ext/Encode/Encode/cp861.enc Encoding tables @@ -231,10 +236,16 @@ ext/Encode/Encode/euc-kr.enc Encoding tables ext/Encode/Encode/gb12345.enc Encoding tables ext/Encode/Encode/gb1988.enc Encoding tables ext/Encode/Encode/gb2312.enc Encoding tables +ext/Encode/Encode/gsm0338.enc Encoding tables ext/Encode/Encode/iso2022-jp.enc Encoding tables ext/Encode/Encode/iso2022-kr.enc Encoding tables ext/Encode/Encode/iso2022.enc Encoding tables ext/Encode/Encode/iso8859-1.enc Encoding tables +ext/Encode/Encode/iso8859-10.enc Encoding tables +ext/Encode/Encode/iso8859-13.enc Encoding tables +ext/Encode/Encode/iso8859-14.enc Encoding tables +ext/Encode/Encode/iso8859-15.enc Encoding tables +ext/Encode/Encode/iso8859-16.enc Encoding tables ext/Encode/Encode/iso8859-2.enc Encoding tables ext/Encode/Encode/iso8859-3.enc Encoding tables ext/Encode/Encode/iso8859-4.enc Encoding tables @@ -260,8 +271,14 @@ ext/Encode/Encode/macRomania.enc Encoding tables ext/Encode/Encode/macThai.enc Encoding tables ext/Encode/Encode/macTurkish.enc Encoding tables ext/Encode/Encode/macUkraine.enc Encoding tables +ext/Encode/Encode/posix-bc.enc Encoding tables ext/Encode/Encode/shiftjis.enc Encoding tables ext/Encode/Encode/symbol.enc Encoding tables +ext/Encode/Makefile.PL Encode extension +ext/Encode/Todo Encode extension +ext/Encode/compile Encode extension +ext/Encode/encengine.c Encode extension +ext/Encode/encode.h Encode extension ext/Errno/ChangeLog Errno perl module change log ext/Errno/Errno_pm.PL Errno perl module create script ext/Errno/Makefile.PL Errno extension makefile writer @@ -275,6 +292,9 @@ ext/File/Glob/Makefile.PL File::Glob extension makefile writer ext/File/Glob/TODO File::Glob extension todo list ext/File/Glob/bsd_glob.c File::Glob extension run time code ext/File/Glob/bsd_glob.h File::Glob extension header file +ext/Filter/Util/Call/Call.pm Filter::Util::Call extension module +ext/Filter/Util/Call/Call.xs Filter::Util::Call extension external subroutines +ext/Filter/Util/Call/Makefile.PL Filter::Util::Call extension makefile writer ext/GDBM_File/GDBM_File.pm GDBM extension Perl module ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines ext/GDBM_File/Makefile.PL GDBM extension makefile writer @@ -348,6 +368,7 @@ ext/POSIX/hints/netbsd.pl Hint for POSIX for named architecture ext/POSIX/hints/next_3.pl Hint for POSIX for named architecture ext/POSIX/hints/openbsd.pl Hint for POSIX for named architecture ext/POSIX/hints/sunos_4.pl Hint for POSIX for named architecture +ext/POSIX/hints/svr4.pl Hint for POSIX for named architecture ext/POSIX/typemap POSIX extension interface types ext/SDBM_File/Makefile.PL SDBM extension makefile writer ext/SDBM_File/SDBM_File.pm SDBM extension Perl module @@ -382,8 +403,8 @@ ext/Socket/Makefile.PL Socket extension makefile writer ext/Socket/Socket.pm Socket extension Perl module ext/Socket/Socket.xs Socket extension external subroutines ext/Storable/ChangeLog Storable extension -ext/Storable/Makefile.PL Storable extension ext/Storable/MANIFEST Storable extension +ext/Storable/Makefile.PL Storable extension ext/Storable/README Storable extension ext/Storable/Storable.pm Storable extension ext/Storable/Storable.xs Storable extension @@ -423,13 +444,14 @@ ext/attrs/Makefile.PL attrs extension makefile writer ext/attrs/attrs.pm attrs extension Perl module ext/attrs/attrs.xs attrs extension external subroutines ext/re/Makefile.PL re extension makefile writer +ext/re/hints/aix.pl Hints for re for named architecture ext/re/hints/mpeix.pl Hints for re for named architecture ext/re/re.pm re extension Perl module ext/re/re.xs re extension external subroutines ext/util/make_ext Used by Makefile to execute extension Makefiles ext/util/mkbootstrap Turns ext/*/*_BS into bootstrap info +fakesdio.h stdio in terms of PerlIO fakethr.h Fake threads header -fix_pl Fix up patchlevel.h for repository perls form.h Public declarations for the above global.sym Symbols that need hiding when embedded globals.c File to declare global symbols (for shared library) @@ -633,6 +655,7 @@ lib/ExtUtils/Embed.pm Utilities for embedding Perl in C programs lib/ExtUtils/Install.pm Handles 'make install' on extensions lib/ExtUtils/Installed.pm Information on installed extensions lib/ExtUtils/Liblist.pm Locates libraries +lib/ExtUtils/MANIFEST.SKIP The default MANIFEST.SKIP lib/ExtUtils/MM_Cygwin.pm MakeMaker methods for Cygwin lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2 lib/ExtUtils/MM_Unix.pm MakeMaker base class for Unix @@ -656,6 +679,7 @@ lib/File/DosGlob.pm Win32 DOS-globbing module lib/File/Find.pm Routines to do a find lib/File/Path.pm Do things like `mkdir -p' and `rm -r' lib/File/Spec.pm portable operations on file names +lib/File/Spec/Epoc.pm portable operations on EPOC file names lib/File/Spec/Functions.pm Function interface to File::Spec object methods lib/File/Spec/Mac.pm portable operations on Mac file names lib/File/Spec/OS2.pm portable operations on OS2 file names @@ -666,6 +690,7 @@ lib/File/Temp.pm create safe temporary files and file handles lib/File/stat.pm By-name interface to Perl's builtin stat lib/FileCache.pm Keep more files open than the system permits lib/FileHandle.pm Backward-compatible front end to IO extension +lib/Filter/Simple.pm Simple frontend to Filter::Util::Call lib/FindBin.pm Find name of currently executing program lib/Getopt/Long.pm Fetch command options (GetOptions) lib/Getopt/Std.pm Fetch command options (getopt, getopts) @@ -694,6 +719,7 @@ lib/Pod/Plainer.pm Pod migration utility module lib/Pod/Select.pm Pod-Parser - select portions of POD docs lib/Pod/Text.pm Pod-Parser - convert POD data to formatted ASCII text lib/Pod/Text/Color.pm Convert POD data to color ASCII text +lib/Pod/Text/Overstrike.pm Convert POD data to formatted overstrike text lib/Pod/Text/Termcap.pm Convert POD data to ASCII text with format escapes lib/Pod/Usage.pm Pod-Parser - print usage messages lib/Search/Dict.pm Perform binary search on dictionaries @@ -769,6 +795,7 @@ lib/open2.pl Open a two-ended pipe (uses IPC::Open2) lib/open3.pl Open a three-ended pipe (uses IPC::Open3) lib/overload.pm Module for overloading perl operators lib/perl5db.pl Perl debugging routines +lib/perlio.pm Perl IO interface pragma lib/pwd.pl Routines to keep track of PWD environment variable lib/shellwords.pl Perl library to split into words with shell quoting lib/sigtrap.pm For trapping an abort and giving traceback @@ -902,6 +929,7 @@ lib/unicode/Is/BidiRLE.pl Unicode character database lib/unicode/Is/BidiRLO.pl Unicode character database lib/unicode/Is/BidiS.pl Unicode character database lib/unicode/Is/BidiWS.pl Unicode character database +lib/unicode/Is/Blank.pl Unicode character database lib/unicode/Is/C.pl Unicode character database lib/unicode/Is/Cc.pl Unicode character database lib/unicode/Is/Cf.pl Unicode character database @@ -914,9 +942,9 @@ lib/unicode/Is/DCcompat.pl Unicode character database lib/unicode/Is/DCfinal.pl Unicode character database lib/unicode/Is/DCfont.pl Unicode character database lib/unicode/Is/DCfraction.pl Unicode character database -lib/unicode/Is/DCinital.pl Unicode character database lib/unicode/Is/DCinitial.pl Unicode character database lib/unicode/Is/DCisolated.pl Unicode character database +lib/unicode/Is/DCmedial.pl Unicode character database lib/unicode/Is/DCnarrow.pl Unicode character database lib/unicode/Is/DCnoBreak.pl Unicode character database lib/unicode/Is/DCsmall.pl Unicode character database @@ -990,6 +1018,7 @@ lib/unicode/Is/Sk.pl Unicode character database lib/unicode/Is/Sm.pl Unicode character database lib/unicode/Is/So.pl Unicode character database lib/unicode/Is/Space.pl Unicode character database +lib/unicode/Is/SpacePerl.pl Unicode character database lib/unicode/Is/SylA.pl Unicode character database lib/unicode/Is/SylAA.pl Unicode character database lib/unicode/Is/SylAAI.pl Unicode character database @@ -1043,6 +1072,7 @@ lib/unicode/To/Upper.pl Unicode character database lib/unicode/UCD301.html Unicode character database lib/unicode/UCDFF301.html Unicode character database lib/unicode/Unicode.301 Unicode character database +lib/unicode/distinct.pm Perl pragma to strictly distinguish UTF8 data and non-UTF data lib/unicode/mktables.PL Unicode character database generator lib/unicode/syllables.txt Unicode character database lib/utf8.pm Pragma to control Unicode support @@ -1134,8 +1164,9 @@ perl.h Global declarations perlapi.c Perl API functions perlapi.h Perl API function declarations perlio.c C code for PerlIO abstraction -perlio.h compatibility stub +perlio.h PerlIO abstraction perlio.sym Symbols for PerlIO abstraction +perliol.h PerlIO Layer definition perlsdio.h Fake stdio using perlio perlsfio.h Prototype sfio mapping for PerlIO perlsh A poor man's perl shell @@ -1275,6 +1306,7 @@ sv.h Scalar value header t/README Instructions for regression tests t/TEST The regression tester t/UTEST Run regression tests with -Mutf8 +t/base/commonsense.t See if configuration meets basic needs t/base/cond.t See if conditionals work t/base/if.t See if if works t/base/lex.t See if lexical items work @@ -1314,6 +1346,7 @@ t/io/pipe.t See if secure pipes work t/io/print.t See if print commands work t/io/read.t See if read works t/io/tell.t See if file seeking works +t/io/utf8.t See if file seeking works t/lib/abbrev.t See if Text::Abbrev works t/lib/ansicolor.t See if Term::ANSIColor works t/lib/anydbm.t See if AnyDBM_File works @@ -1332,6 +1365,7 @@ t/lib/cgi-pretty.t See if CGI.pm works t/lib/cgi-request.t See if CGI.pm works t/lib/charnames.t See if character names work t/lib/checktree.t See if File::CheckTree works +t/lib/class-struct.t See if Class::Struct works t/lib/complex.t See if Math::Complex works t/lib/db-btree.t See if DB_File works t/lib/db-hash.t See if DB_File works @@ -1354,9 +1388,9 @@ t/lib/dprof/test6_t Perl code profiler tests t/lib/dprof/test6_v Perl code profiler tests t/lib/dumper-ovl.t See if Data::Dumper works for overloaded data t/lib/dumper.t See if Data::Dumper works +t/lib/encode.t See if Encode works t/lib/english.t See if English works t/lib/env-array.t See if Env works for arrays -t/lib/encode.t See if Encode works t/lib/env.t See if Env works t/lib/errno.t See if Errno works t/lib/fatal.t See if Fatal works @@ -1368,6 +1402,8 @@ t/lib/filefunc.t See if File::Spec::Functions works t/lib/filehand.t See if FileHandle works t/lib/filepath.t See if File::Path works t/lib/filespec.t See if File::Spec works +t/lib/filter-util.pl See if Filter::Util::Call works +t/lib/filter-util.t See if Filter::Util::Call works t/lib/findbin.t See if FindBin works t/lib/ftmp-mktemp.t See if File::Temp works t/lib/ftmp-posix.t See if File::Temp works @@ -1403,6 +1439,7 @@ t/lib/io_unix.t See if UNIX socket-related methods from IO work t/lib/io_xs.t See if XSUB methods from IO work t/lib/ipc_sysv.t See if IPC::SysV works t/lib/ndbm.t See if NDBM_File works +t/lib/net-hostent.t See if Net::hostent works t/lib/odbm.t See if ODBM_File works t/lib/opcode.t See if Opcode works t/lib/open2.t See if IPC::Open2 works @@ -1444,9 +1481,12 @@ t/lib/texttabs.t See if Text::Tabs works t/lib/textwrap.t See if Text::Wrap::wrap works t/lib/thr5005.t Test 5.005-style threading (skipped if no use5005threads) t/lib/tie-push.t Test for Tie::Array +t/lib/tie-refhash.t Test for Tie::RefHash and Tie::RefHash::Nestable +t/lib/tie-splice.t Test for Tie::Array::SPLICE t/lib/tie-stdarray.t Test for Tie::StdArray t/lib/tie-stdhandle.t Test for Tie::StdHandle t/lib/tie-stdpush.t Test for Tie::StdArray +t/lib/tie-substrhash.t Test for Tie::SubstrHash t/lib/timelocal.t See if Time::Local works t/lib/trig.t See if Math::Trig works t/op/64bitint.t See if 64 bit integers work @@ -1464,6 +1504,7 @@ t/op/chars.t See if character escapes work t/op/chop.t See if chop works t/op/closure.t See if closures work t/op/cmp.t See if the various string and numeric compare work +t/op/concat.t See if string concatenation works t/op/cond.t See if conditional expressions work t/op/context.t See if context propagation works t/op/defins.t See if auto-insert of defined() works @@ -1492,6 +1533,7 @@ t/op/inc.t See if inc/dec of integers near 32 bit limit work t/op/index.t See if index works t/op/int.t See if int works t/op/join.t See if join works +t/op/length.t See if length works t/op/lex_assign.t See if ops involving lexicals or pad temps work t/op/lfs.t See if large files work for perlio t/op/list.t See if array lists work @@ -1524,6 +1566,7 @@ t/op/regexp.t See if regular expressions work t/op/regexp_noamp.t See if regular expressions work with optimizations t/op/regmesg.t See if one can get regular expression errors t/op/repeat.t See if x operator works +t/op/reverse.t See if reverse operator works t/op/runlevel.t See if die() works from perl_call_*() t/op/sleep.t See if sleep works t/op/sort.t See if sort works @@ -1546,6 +1589,7 @@ t/op/tr.t See if tr works t/op/undef.t See if undef works t/op/universal.t See if UNIVERSAL class works t/op/unshift.t See if unshift works +t/op/utf8decode.t See if UTF-8 decoding works t/op/vec.t See if vectors work t/op/ver.t See if v-strings and the %v format flag work t/op/wantarray.t See if wantarray works @@ -1691,10 +1735,13 @@ vms/writemain.pl Generate perlmain.c from miniperlmain.c+extensions vos/Changes Changes made to port Perl to the VOS operating system vos/build.cm VOS command macro to build Perl vos/compile_perl.cm VOS command macro to build multiple version of Perl -vos/config.def input for config.pl -vos/config.h config.h for VOS +vos/config.alpha.def definitions used by config.pl +vos/config.alpha.h config.h for use with alpha VOS POSIX.1 support +vos/config.ga.def definitions used by config.pl +vos/config.ga.h config.h for use with generally-available VOS POSIX.1 support vos/config.pl script to convert a config_h.SH to a config.h -vos/config_h.SH_orig config_h.SH at the time config.h was created +vos/configure_perl.cm VOS command macro to configure perl before building +vos/install_perl.cm VOS command macro to install perl after building vos/perl.bind VOS bind control file vos/test_vos_dummies.c Test program for "vos_dummies.c" vos/vos_dummies.c Wrappers to soak up undefined functions @@ -1703,6 +1750,7 @@ warnings.h The warning numbers warnings.pl Program to write warnings.h and lib/warnings.pm win32/Makefile Win32 makefile for NMAKE (Visual C++ build) win32/bin/exetype.pl Set executable type to CONSOLE or WINDOWS +win32/bin/mdelete.bat multifile delete win32/bin/perlglob.pl Win32 globbing win32/bin/pl2bat.pl wrap perl scripts into batch files win32/bin/runperl.pl run perl script via batch file namesake @@ -1716,6 +1764,7 @@ win32/config_H.vc Win32 config header (Visual C++ build) win32/config_h.PL Perl code to convert Win32 config.sh to config.h win32/config_sh.PL Perl code to update Win32 config.sh from Makefile win32/des_fcrypt.patch Win32 port +win32/distclean.bat Remove _ALL_ files not listed here in MANIFEST win32/dl_win32.xs Win32 port win32/genmk95.pl Perl code to generate command.com-usable makefile.95 win32/include/arpa/inet.h Win32 port diff --git a/Makefile.SH b/Makefile.SH index 5418fc45f2..d0b5465b8a 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -137,6 +137,7 @@ CLDFLAGS = $ldflags mallocsrc = $mallocsrc mallocobj = $mallocobj LNS = $lns +CPS = $cp -f RMS = rm -f ranlib = $ranlib @@ -300,9 +301,13 @@ utilities: miniperl lib/Config.pm $(plextract) lib/lib.pm FORCE FORCE: @sh -c true -opmini$(OBJ_EXT): op.c +# We do a copy of the op.c instead of a symlink because gcc gets huffy +# if we have a symlink forest to another disk (it complains about too many +# levels of symbolic links, even if we have only two) + +opmini$(OBJ_EXT): op.c config.h $(RMS) opmini.c - $(LNS) op.c opmini.c + $(CPS) op.c opmini.c $(CCCMD) $(PLDLFLAGS) -DPERL_EXTERNAL_GLOB opmini.c $(RMS) opmini.c @@ -324,14 +329,6 @@ ext.libs: $(static_ext) !NO!SUBS! -# if test -f .patch ; then $spitshell >>Makefile <<'!NO!SUBS!' -# patchlevel.h: .patch -# perl fix_pl || (make -f Makefile.micro && ./microperl fix_pl) -# $(SHELL) Makefile.SH -# fi -# -# !NO!SUBS! - # How to build libperl. This is still rather convoluted. # Load up custom Makefile.SH fragment for shared loading and executables: case "$osname" in @@ -600,7 +597,7 @@ install.html: all installhtml run_byacc: FORCE $(BYACC) -d perly.y - -chmod 664 perly.c + -chmod 664 perly.c perly.h sh $(shellflags) ./perly.fixer y.tab.c perly.c sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \ -e 's/y\.tab/perly/g' perly.c >perly.tmp && mv perly.tmp perly.c @@ -618,6 +615,11 @@ perly.c: perly.y perly.h: perly.y -@sh -c true +PERLYVMS = vms/perly_c.vms vms/perly_h.vms + +$(PERLYVMS): perly.c perly.h vms/vms_yfix.pl + perl vms/vms_yfix.pl perly.c perly.h vms/perly_c.vms vms/perly_h.vms + # No compat3.sym here since and including the 5.004_50. # No interp.sym since 5.005_03. SYM = global.sym globvar.sym perlio.sym pp.sym @@ -642,6 +644,31 @@ CHMOD_W = chmod +w # To force them to be regenerated, type # make regen_headers +keywords.h: keywords.pl + -perl keywords.pl + +OPCODE_PL_OUTPUT = opcode.h opnames.h pp_proto.h pp.sym + +$(OPCODE_PL_OUTPUT): opcode.pl + -perl opcode.pl + +# Really the prerequisites for the next rule should only be "embed.pl pp.sym" +# Writing it this way gives make a big hint to always run opcode.pl before +# embed.pl. The alternative - running embed.pl then opcode.pl causes embed.pl +# to be re-run next make invocation, and then all object files get recompiled. + +proto.h embed.h embedvar.h global.sym objXSUB.h perlapi.h perlapi.c pod/perlintern.pod pod/perlapi.pod: embed.pl $(OPCODE_PL_OUTPUT) + -perl embed.pl + +ext/ByteLoader/byterun.h ext/ByteLoader/byterun.c ext/B/B/Asmdata.pm: bytecode.pl + -perl bytecode.pl + +regnodes.h: regcomp.pl + -perl regcomp.pl + +warnings.h lib/warnings.pm: warnings.pl + -perl warnings.pl + AUTOGEN_FILES = keywords.h opcode.h opnames.h pp_proto.h pp.sym proto.h \ embed.h embedvar.h global.sym \ pod/perlintern.pod pod/perlapi.pod \ @@ -661,6 +688,8 @@ regen_headers: FORCE regen_pods: FORCE -cd pod; $(LDLIBPTH) make regen_pods +regen_all: $(PERLYVMS) regen_headers regen_pods + # Extensions: # Names added to $(dynamic_ext) or $(static_ext) or $(nonxs_ext) will # automatically get built. There should ordinarily be no need to change @@ -734,11 +763,11 @@ _cleaner2: rm -f $(FIRSTMAKEFILE) $(FIRSTMAKEFILE).old rm -f $(private) rm -rf lib/auto - rm -f lib/.exists lib/*/.exists + rm -f lib/.exists lib/*/.exists lib/*/*/.exists rm -f h2ph.man pstruct rm -rf .config rm -f testcompile compilelog - -rmdir lib/B lib/Data lib/Encode lib/IO/Socket lib/IO lib/Sys lib/Thread + -rmdir lib/B lib/Data lib/Encode lib/IO/Socket lib/IO lib/Filter/Util lib/Sys lib/Thread _realcleaner: @$(LDLIBPTH) $(MAKE) _cleaner1 CLEAN=realclean @@ -823,12 +852,24 @@ ok: utilities okfile: utilities $(LDLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' -F perl.ok +oknack: utilities + $(LDLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' -A + +okfilenack: utilities + $(LDLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' -F perl.ok -A + nok: utilities $(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)' nokfile: utilities $(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)' -F perl.nok +noknack: utilities + $(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)' -A + +nokfilenack: utilities + $(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)' -F perl.nok -A + clist: $(c) echo $(c) | tr ' ' $(TRNL) >.clist diff --git a/Porting/Contract b/Porting/Contract index cc91af26bc..2b619fd0ff 100644 --- a/Porting/Contract +++ b/Porting/Contract @@ -19,7 +19,7 @@ community, mutual respect, trust, and good-faith cooperation. We recognize that the Perl core, defined as the software distributed with the heart of Perl itself, is a joint project on the part of all of us. ->From time to time, a script, module, or set of modules (hereafter referred +From time to time, a script, module, or set of modules (hereafter referred to simply as a "module") will prove so widely useful and/or so integral to the correct functioning of Perl itself that it should be distributed with Perl core. This should never be done without the author's explicit diff --git a/Porting/Glossary b/Porting/Glossary index 1b93821e9b..0095ef18c0 100644 --- a/Porting/Glossary +++ b/Porting/Glossary @@ -340,6 +340,10 @@ csh (Loc.U): full pathname (if any) of the csh program. After Configure runs, the value is reset to a plain "csh" and is not useful. +d__fwalk (d__fwalk.U): + This variable conditionally defines HAS__FWALK if _fwalk() is + available to apply a function to all the file handles. + d_access (d_access.U): This variable conditionally defines HAS_ACCESS if the access() system call is available to check for access permissions using real IDs. @@ -545,6 +549,10 @@ d_fcntl (d_fcntl.U): This variable conditionally defines the HAS_FCNTL symbol, and indicates whether the fcntl() function exists +d_fcntl_can_lock (d_fcntl_can_lock.U): + This variable conditionally defines the FCNTL_CAN_LOCK symbol + and indicates whether file locking with fcntl() works. + d_fd_macros (d_fd_set.U): This variable contains the eventual value of the HAS_FD_MACROS symbol, which indicates if your C compiler knows about the macros which @@ -610,6 +618,10 @@ d_fstatvfs (d_statvfs.U): This variable conditionally defines the HAS_FSTATVFS symbol, which indicates to the C program that the fstatvfs() routine is available. +d_fsync (d_fsync.U): + This variable conditionally defines the HAS_FSYNC symbol, which + indicates to the C program that the fsync() routine is available. + d_ftello (d_ftello.U): This variable conditionally defines the HAS_FTELLO symbol, which indicates to the C program that the ftello() routine is available. @@ -711,6 +723,10 @@ d_getnetprotos (d_getnetprotos.U): prototypes for the various getnet*() functions. See also netdbtype.U for probing for various netdb types. +d_getpagsz (d_getpagsz.U): + This variable conditionally defines HAS_GETPAGESIZE if getpagesize() + is available to get the system page size. + d_getpbyname (d_getprotby.U): This variable conditionally defines the HAS_GETPROTOBYNAME symbol, which indicates to the C program that the @@ -1235,6 +1251,12 @@ d_sanemcmp (d_sanemcmp.U): the memcpy() routine is available and can be used to compare relative magnitudes of chars with their high bits set. +d_sbrkproto (d_sbrkproto.U): + This variable conditionally defines the HAS_SBRK_PROTO symbol, + which indicates to the C program that the system provides + a prototype for the sbrk() function. Otherwise, it is + up to the program to supply one. + d_sched_yield (d_pthread_y.U): This variable conditionally defines the HAS_SCHED_YIELD symbol if the sched_yield routine is available to yield @@ -1478,6 +1500,15 @@ d_stdio_ptr_lval (d_stdstdio.U): This variable conditionally defines STDIO_PTR_LVALUE if the FILE_ptr macro can be used as an lvalue. +d_stdio_ptr_lval_nochange_cnt (d_stdstdio.U): + This symbol is defined if using the FILE_ptr macro as an lvalue + to increase the pointer by n leaves File_cnt(fp) unchanged. + +d_stdio_ptr_lval_sets_cnt (d_stdstdio.U): + This symbol is defined if using the FILE_ptr macro as an lvalue + to increase the pointer by n has the side effect of decreasing the + value of File_cnt(fp) by n. + d_stdio_stream_array (stdio_streams.U): This variable tells whether there is an array holding the stdio streams. @@ -1533,6 +1564,10 @@ d_strtoll (d_strtoll.U): This variable conditionally defines the HAS_STRTOLL symbol, which indicates to the C program that the strtoll() routine is available. +d_strtoq (d_strtoq.U): + This variable conditionally defines the HAS_STRTOQ symbol, which + indicates to the C program that the strtoq() routine is available. + d_strtoul (d_strtoul.U): This variable conditionally defines the HAS_STRTOUL symbol, which indicates to the C program that the strtoul() routine is available @@ -2408,6 +2443,11 @@ intsize (intsize.U): This variable contains the value of the INTSIZE symbol, which indicates to the C program how many bytes there are in an int. +issymlink (issymlink.U): + This variable holds the switch of the test command to test + for a symbolic link (if they are supported). Typical values + include '-h' and '-L'. + ivdformat (perlxvf.U): This variable contains the format string used for printing a Perl IV as a signed decimal integer. @@ -2709,6 +2749,15 @@ n (n.U): command to suppress newline. Otherwise it is null. Correct usage is $echo $n "prompt for a question: $c". +need_va_copy (need_va_copy.U): + This symbol, if defined, indicates that the system stores + the variable argument list datatype, va_list, in a format + that cannot be copied by simple assignment, so that some + other means must be used when copying is required. + As such systems vary in their provision (or non-provision) + of copying mechanisms, handy.h defines a platform- + independent macro, Perl_va_copy(src, dst), to do the job. + netdb_hlen_type (netdbtype.U): This variable holds the type used for the 2nd argument to gethostbyaddr(). Usually, this is int or size_t or unsigned. diff --git a/Porting/config.sh b/Porting/config.sh index 632c469288..90e7dc5218 100644 --- a/Porting/config.sh +++ b/Porting/config.sh @@ -8,7 +8,7 @@ # Package name : perl5 # Source directory : /m/fs/work/work/permanent/perl/pp4/perl -# Configuration time: Fri Oct 13 02:12:22 EET DST 2000 +# Configuration time: Thu Dec 21 18:13:27 EET 2000 # Configured by : jhi # Target system : osf1 alpha.hut.fi v4.0 878 alpha @@ -62,7 +62,7 @@ ccsymbols='__alpha=1 __LANGUAGE_C__=1 __osf__=1 __unix__=1 _LONGLONG=1 _SYSTYPE_ ccversion='V5.6-082' cf_by='jhi' cf_email='yourname@yourhost.yourplace.com' -cf_time='Fri Oct 13 02:12:22 EET DST 2000' +cf_time='Thu Dec 21 18:13:27 EET 2000' charsize='1' chgrp='' chmod='' @@ -99,6 +99,7 @@ d_PRIo64='define' d_PRIu64='define' d_PRIx64='define' d_SCNfldbl='define' +d__fwalk='undef' d_access='define' d_accessx='undef' d_alarm='define' @@ -145,6 +146,7 @@ d_eunice='undef' d_fchmod='define' d_fchown='define' d_fcntl='define' +d_fcntl_can_lock='define' d_fd_macros='define' d_fd_set='define' d_fds_bits='define' @@ -160,6 +162,7 @@ d_fseeko='undef' d_fsetpos='define' d_fstatfs='define' d_fstatvfs='define' +d_fsync='define' d_ftello='undef' d_ftime='undef' d_getcwd='define' @@ -179,6 +182,7 @@ d_getnbyaddr='define' d_getnbyname='define' d_getnent='define' d_getnetprotos='define' +d_getpagsz='define' d_getpbyname='define' d_getpbynumber='define' d_getpent='define' @@ -282,6 +286,7 @@ d_rmdir='define' d_safebcpy='define' d_safemcpy='undef' d_sanemcmp='define' +d_sbrkproto='define' d_sched_yield='define' d_scm_rights='define' d_seekdir='define' @@ -336,6 +341,8 @@ d_statfs_s='define' d_statvfs='define' d_stdio_cnt_lval='define' d_stdio_ptr_lval='define' +d_stdio_ptr_lval_nochange_cnt='define' +d_stdio_ptr_lval_sets_cnt='undef' d_stdio_stream_array='define' d_stdiobase='define' d_stdstdio='define' @@ -348,6 +355,7 @@ d_strtod='define' d_strtol='define' d_strtold='undef' d_strtoll='undef' +d_strtoq='undef' d_strtoul='define' d_strtoull='undef' d_strtouq='undef' @@ -394,7 +402,7 @@ dlext='so' dlsrc='dl_dlopen.xs' doublesize='8' drand01='drand48()' -dynamic_ext='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re' +dynamic_ext='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob Filter/Util/Call IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re' eagain='EAGAIN' ebcdic='undef' echo='echo' @@ -403,7 +411,7 @@ emacs='' eunicefix=':' exe_ext='' expr='expr' -extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re Errno' +extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob Filter/Util/Call IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re Errno' fflushNULL='define' fflushall='undef' find='' @@ -539,10 +547,11 @@ installvendorarch='' installvendorbin='' installvendorlib='' intsize='4' +issymlink='-h' ivdformat='"ld"' ivsize='8' ivtype='long' -known_extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob GDBM_File IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re' +known_extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob Filter/Util/Call GDBM_File IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re' ksh='' ld='ld' lddlflags='-shared -expect_unresolved "*" -msym -std -s' @@ -601,6 +610,7 @@ mydomain='.yourplace.com' myhostname='yourhost' myuname='osf1 alpha.hut.fi v4.0 878 alpha ' n='' +need_va_copy='undef' netdb_hlen_type='int' netdb_host_type='const char *' netdb_name_type='const char *' diff --git a/Porting/config_H b/Porting/config_H index 149760ceaf..039ed258dc 100644 --- a/Porting/config_H +++ b/Porting/config_H @@ -17,7 +17,7 @@ /* * Package name : perl5 * Source directory : /m/fs/work/work/permanent/perl/pp4/perl - * Configuration time: Fri Oct 13 02:12:22 EET DST 2000 + * Configuration time: Thu Dec 21 18:13:27 EET 2000 * Configured by : jhi * Target system : osf1 alpha.hut.fi v4.0 878 alpha */ @@ -585,12 +585,6 @@ */ #define HAS_STRTOL /**/ -/* HAS_STRTOUL: - * This symbol, if defined, indicates that the strtoul routine is - * available to provide conversion of strings to unsigned long. - */ -#define HAS_STRTOUL /**/ - /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. @@ -961,12 +955,6 @@ */ #define SH_PATH "/bin/sh" /**/ -/* STDCHAR: - * This symbol is defined to be the type of char used in stdio.h. - * It has the values "unsigned char" or "char". - */ -#define STDCHAR unsigned char /**/ - /* CROSSCOMPILE: * This symbol, if defined, signifies that we our * build process is a cross-compilation. @@ -1208,6 +1196,12 @@ #define CPPRUN "/usr/bin/cpp" #define CPPLAST "" +/* HAS__FWALK: + * This symbol, if defined, indicates that the _fwalk system call is + * available to apply a function to all the file handles. + */ +/*#define HAS__FWALK / **/ + /* HAS_ACCESS: * This manifest constant lets the C program know that the access() * system call is available to check for accessibility using real UID/GID. @@ -1305,6 +1299,13 @@ */ #define HAS_ENDSERVENT /**/ +/* FCNTL_CAN_LOCK: + * This symbol, if defined, indicates that fcntl() can be used + * for file locking. Normally on Unix systems this is defined. + * It may be undefined on VMS. + */ +#define FCNTL_CAN_LOCK /**/ + /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in <sys/types.h> @@ -1347,6 +1348,13 @@ */ #define HAS_FSTATFS /**/ +/* HAS_FSYNC: + * This symbol, if defined, indicates that the fsync routine is + * available to write a file's modified data and attributes to + * permanent storage. + */ +#define HAS_FSYNC /**/ + /* HAS_FTELLO: * This symbol, if defined, indicates that the ftello routine is * available to ftell beyond 32 bits (useful for ILP32 hosts). @@ -1487,12 +1495,30 @@ */ #define HAS_GETNET_PROTOS /**/ +/* HAS_GETPAGESIZE: + * This symbol, if defined, indicates that the getpagesize system call + * is available to get system page size, which is the granularity of + * many memory management calls. + */ +#define HAS_GETPAGESIZE /**/ + /* HAS_GETPROTOENT: * This symbol, if defined, indicates that the getprotoent() routine is * available to look up protocols in some data base or another. */ #define HAS_GETPROTOENT /**/ +/* HAS_GETPGRP: + * This symbol, if defined, indicates that the getpgrp routine is + * available to get the current process group. + */ +/* USE_BSD_GETPGRP: + * This symbol, if defined, indicates that getpgrp needs one + * arguments whereas USG one needs none. + */ +#define HAS_GETPGRP /**/ +/*#define USE_BSD_GETPGRP / **/ + /* HAS_GETPROTOBYNAME: * This symbol, if defined, indicates that the getprotobyname() * routine is available to look up protocols by their name. @@ -1802,6 +1828,15 @@ */ #define HAS_SANE_MEMCMP /**/ +/* HAS_SBRK_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the sbrk() function. Otherwise, it is up + * to the program to supply one. Good guesses are + * extern void* sbrk _((int)); + * extern void* sbrk _((size_t)); + */ +#define HAS_SBRK_PROTO /**/ + /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. @@ -1839,6 +1874,18 @@ */ #define HAS_SETPROTOENT /**/ +/* HAS_SETPGRP: + * This symbol, if defined, indicates that the setpgrp routine is + * available to set the current process group. + */ +/* USE_BSD_SETPGRP: + * This symbol, if defined, indicates that setpgrp needs two + * arguments whereas USG one needs none. See also HAS_SETPGID + * for a POSIX interface. + */ +#define HAS_SETPGRP /**/ +#define USE_BSD_SETPGRP /**/ + /* HAS_SETPROCTITLE: * This symbol, if defined, indicates that the setproctitle routine is * available to set process title. @@ -2028,12 +2075,23 @@ * This symbol is defined if the FILE_cnt macro can be used as an * lvalue. */ +/* STDIO_PTR_LVAL_SETS_CNT: + * This symbol is defined if using the FILE_ptr macro as an lvalue + * to increase the pointer by n has the side effect of decreasing the + * value of File_cnt(fp) by n. + */ +/* STDIO_PTR_LVAL_NOCHANGE_CNT: + * This symbol is defined if using the FILE_ptr macro as an lvalue + * to increase the pointer by n leaves File_cnt(fp) unchanged. + */ #define USE_STDIO_PTR /**/ #ifdef USE_STDIO_PTR #define FILE_ptr(fp) ((fp)->_ptr) #define STDIO_PTR_LVALUE /**/ #define FILE_cnt(fp) ((fp)->_cnt) #define STDIO_CNT_LVALUE /**/ +/*#define STDIO_PTR_LVAL_SETS_CNT / **/ +#define STDIO_PTR_LVAL_NOCHANGE_CNT /**/ #endif /* USE_STDIO_BASE: @@ -2093,6 +2151,18 @@ */ /*#define HAS_STRTOLL / **/ +/* HAS_STRTOQ: + * This symbol, if defined, indicates that the strtoq routine is + * available to convert strings to long longs (quads). + */ +/*#define HAS_STRTOQ / **/ + +/* HAS_STRTOUL: + * This symbol, if defined, indicates that the strtoul routine is + * available to provide conversion of strings to unsigned long. + */ +#define HAS_STRTOUL /**/ + /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. @@ -2583,6 +2653,17 @@ #define RD_NODATA -1 #define EOF_NONBLOCK +/* NEED_VA_COPY: + * This symbol, if defined, indicates that the system stores + * the variable argument list datatype, va_list, in a format + * that cannot be copied by simple assignment, so that some + * other means must be used when copying is required. + * As such systems vary in their provision (or non-provision) + * of copying mechanisms, handy.h defines a platform- + * independent macro, Perl_va_copy(src, dst), to do the job. + */ +/*#define NEED_VA_COPY / **/ + /* Netdb_host_t: * This symbol holds the type used for the 1st argument * to gethostbyaddr(). @@ -2932,6 +3013,12 @@ */ #define STARTPERL "#!/opt/perl/bin/perl" /**/ +/* STDCHAR: + * This symbol is defined to be the type of char used in stdio.h. + * It has the values "unsigned char" or "char". + */ +#define STDCHAR unsigned char /**/ + /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array * holding the stdio streams. @@ -3150,27 +3237,4 @@ #define PERL_XS_APIVERSION "5.7.0" #define PERL_PM_APIVERSION "5.005" -/* HAS_GETPGRP: - * This symbol, if defined, indicates that the getpgrp routine is - * available to get the current process group. - */ -/* USE_BSD_GETPGRP: - * This symbol, if defined, indicates that getpgrp needs one - * arguments whereas USG one needs none. - */ -#define HAS_GETPGRP /**/ -/*#define USE_BSD_GETPGRP / **/ - -/* HAS_SETPGRP: - * This symbol, if defined, indicates that the setpgrp routine is - * available to set the current process group. - */ -/* USE_BSD_SETPGRP: - * This symbol, if defined, indicates that setpgrp needs two - * arguments whereas USG one needs none. See also HAS_SETPGID - * for a POSIX interface. - */ -#define HAS_SETPGRP /**/ -#define USE_BSD_SETPGRP /**/ - #endif diff --git a/Porting/genlog b/Porting/genlog index 218da41d04..627ba316d4 100755 --- a/Porting/genlog +++ b/Porting/genlog @@ -73,6 +73,7 @@ else { while (@desc) { my ($change,$who,$date,$time,@log,$branch,$file,$type,%files); my $skip = 0; + my $nbranch = 0; $_ = shift @desc; if (/^Change (\d+) by (\w+)\@.+ on (\S+) (\S+)\s*$/) { ($change, $who, $date, $time) = ($1,$2,$3,$4); @@ -88,6 +89,7 @@ else { last unless /^\.\.\./; if (m{^\.\.\. //depot/(.*?perl|[^/]*)/([^#]+)#\d+ (\w+)\s*$}) { ($branch,$file,$type) = ($1,$2,$3); + $nbranch++; if (exists $branch_exclude{$branch} or @branch_include and not exists $branch_include{$branch}) { @@ -103,7 +105,7 @@ else { } } } - next if not $change or $skip; + next if not $change; print "_" x 76, "\n"; printf <<EOT, $change, $who, $date, $time; [%6s] By: %-25s on %9s %9s diff --git a/Porting/pumpkin.pod b/Porting/pumpkin.pod index d7610595f0..3bc9d09c87 100644 --- a/Porting/pumpkin.pod +++ b/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 @@ -1353,7 +1367,8 @@ have good reason to do otherwise, I see no reason not to support them. =item File locking Somehow, straighten out, document, and implement lockf(), flock(), -and/or fcntl() file locking. It's a mess. +and/or fcntl() file locking. It's a mess. See $d_fcntl_can_lock +in recent config.sh files though. =back diff --git a/Porting/repository.pod b/Porting/repository.pod new file mode 100644 index 0000000000..5f1338dd64 --- /dev/null +++ b/Porting/repository.pod @@ -0,0 +1,327 @@ +=head1 NAME + +repository - Using the Perl repository + +This document describes what a Perl Porter needs to do +to start using the Perl repository. + +=head1 Prerequisites + +You'll need to get hold of the following software. + +=over 4 + +=item Perforce + +Download a perforce client from: + + http://www.perforce.com/perforce/loadprog.html + +You'll probably also want to look at: + + http://www.perforce.com/perforce/technical.html + +where you can look at or download its documentation. + +=item ssh + +If you don't already have access to an ssh client, then look at its +home site C<http://www.cs.hut.fi/ssh> which mentions ftp sites from +which it's available. You only need to build the client parts (ssh +and ssh-keygen should suffice). + +=back + +=head1 Creating an SSH Key Pair + +If you already use ssh and want to use the same key pair for perl +repository access then you can skip the rest of this section. +Otherwise, generate an ssh key pair for use with the repository +by typing the command + + ssh-keygen + +After generating a key pair and testing it, ssh-keygen will ask you +to enter a filename in which to save the key. The default it offers +will be the file F<~/.ssh/identity> which is suitable unless you +particularly want to keep separate ssh identities for some reason. +If so, you could save the perl repository private key in the file +F<~/.ssh/perl>, for example, but I will use the standard filename +in the remainder of the examples of this document. + +After typing in the filename, it will prompt you to type in a +passphrase. The private key will itself be encrypted so that it is +usable only when that passphrase is typed. (When using ssh, you will +be prompted when it requires a pass phrase to unlock a private key.) +If you provide a blank passphrase then no passphrase will be needed +to unlock the key and, as a consequence, anyone who gains access to +the key file gains access to accounts protected with that key +(barring additional configuration to restrict access by IP address). + +When you have typed the passphrase in twice, ssh-keygen will confirm +where it has saved the private key (in the filename you gave and +with permissions set to be only readable by you), what your public +key is (don't worry: you don't need to memorise it) and where it +has saved the corresponding public key. The public key is saved in +a filename corresponding to your private key's filename but with +".pub" appended, usually F<~/.ssh/identity.pub>. That public key +can be (but need not be) world readable. It is not used by your +own system at all. + +=head1 Notifying the Repository Keeper + +Mail the contents of that public key file to the keeper of the perl +repository (see L</Contact Information> below). +When the key is added to the repository host's configuration file, +you will be able to connect to it with ssh by using the corresponding +private key file (after unlocking it with your chosen passphrase). + +=head1 Connecting to the Repository + +Connections to the repository are made by using ssh to provide a +TCP "tunnel" rather than by using ssh to login to or invoke any +ordinary commands on the repository. When you want to start a +session using the repository, use the command + + ssh -l perlrep -f -q -x -L 1666:127.0.0.1:1666 sickle.activestate.com +foo + +If you are not using the default filename of F<~/.ssh/identity> +to hold your perl repository private key then you'll need to add +the option B<-i filename> to tell ssh where it is. Unless you chose +a blank passphrase for that private key, ssh will prompt you for the +passphrase to unlock that key. Then ssh will fork and put itself +in the background, returning you (silently) to your shell prompt. +The tunnel for repository access is now ready for use. + +For the sake of completeness (and for the case where the chosen +port of 1666 is already in use on your machine), I'll briefly +describe what all those ssh arguments are for. + +=over 4 + +=item B<-l perl> + +Use a remote username of perl. The account on the repository which +provides the end-point of the ssh tunnel is named "perl". + +=item B<-f> + +Tells ssh to fork and remain running in the background. Since ssh +is only being used for its tunnelling capabilities, the command +that ssh runs never does any I/O and can sit silently in the +background. + +=item B<-q> + +Tells ssh to be quiet. Without this option, ssh will output a +message each time you use a p4 command (since each p4 command +tunnels over the ssh connection to reach the repository). + +=item B<-x> + +Tells ssh not to bother to set up a tunnel for X11 connections. +The repository doesn't allow this anyway. + +=item B<-L 1666:127.0.0.1:1666> + +This is the important option. It tells ssh to listen out for +connections made to port 1666 on your local machine. When such +a connection is made, the ssh client tells the remote side +(the corresponding ssh daemon on the repository) to make a +connection to IP address 127.0.0.1, port 1666. Data flowing +along that connection is tunnelled over the ssh connection +(encrypted). The perforce daemon running on the repository +only accepts connections from localhost and that is exactly +where ssh-tunnelled connections appear to come from. + +If port 1666 is already in use on your machine then you can +choose any non-privileged port (a number between 1024 and 65535) +which happens to be free on your machine. It's the first of the +three colon separated values that you should change. Picking +port 2345 would mean changing the option to +B<-L 2345:127.0.0.1:1666>. Whatever port number you choose should +be used for the value of the P4PORT environment variable (q.v.). + +=item sickle.activestate.com + +This is the canonical IP name of the host on which the perl +repository runs. Its IP number is 199.60.48.20. + +=item foo + +This is a dummy place holder argument. Without an argument +here, ssh will try to perform an interactive login to the +repository which is not allowed. Ordinarily, this argument +is for the one-off command which is to be executed on the +remote host. However, the repository's ssh configuration +file uses the "command=" option to force a particular +command to run so the actual value of the argument is +ignored. The command that's actually run merely pauses and +waits for the ssh connection to drop, then exits. + +=back + +=head1 Problems + +You should normally get a prompt that asks for the passphrase +for your RSA key when you connect with the ssh command shown +above. If you see a prompt that looks like: + + perlrep@sickle.activestate.com's password: + +Then you either don't have a ~/.ssh/identity file corresponding +to your public key, or your ~/.ssh/identity file is not readable. +Fix the problem and try again. + +=head1 Using the Perforce Client + +Remember to read the documentation for Perforce. You need +to make sure that three environment variable are set +correctly before using the p4 client with the perl repository. + +=over 4 + +=item P4PORT + +Set this to localhost:1666 (the port for your ssh client to listen on) +unless that port is already in use on your host. If it is, see +the section above on the B<-L 1666:127.0.0.1:1666> option to ssh. + +=item P4CLIENT + +The value of this is the name by which Perforce knows your +host's workspace. You need to pick a name (for example, your +hostname unless that clashes with someone else's client name) +when you first start using the perl repository and then +stick with it. If you connect from multiple hosts (with +different workspaces) then maybe you could have multiple +clients. There is a licence limit on the number of perforce +clients which can be created. Although we have been told that +Perforce will raise our licence limits within reason, it's +probably best not to use additional clients unless needed. + +Note that perforce only needs the client name so that it can +find the directory under which your client files are stored. +If you have multiple hosts sharing the same directory structure +via NFS then only one client name is necessary. + +The C<p4 clients> command lists all currently known clients. + +=item P4USER + +This is the username by which perforce knows you. Use your +username if you have a well known or obvious one or else pick +a new one which other perl5-porters will recognise. There is +a licence limit on the number of these usernames. Perforce +doesn't enforce security between usernames. If you set P4USER +to be somebody else's username then perforce will believe you +completely with regard to access control, logging and so on. + +The C<p4 users> command lists all currently known users. + +=back + +Once these three environment variables are set, you can use the +perforce p4 client exactly as described in its documentation. +After setting these variables and connecting to the repository +for the first time, you should use the C<p4 user> and +C<p4 client> commands to tell perforce the details of your +new username and your new client workspace specifications. + +=head1 Ending a Repository Session + +When you have finished a session using the repository, you +should kill off the ssh client process to break the tunnel. +Since ssh forked itself into the background, you'll need to use +something like ps with the appropriate options to find the ssh +process and then kill it manually. The default signal of +SIGTERM is fine. + +=head1 Overview of the Repository + +Please read at least the introductory sections of the Perforce +User Guide (and perhaps the Quick Start Guide as well) before +reading this section. + +Every repository user typically "owns" a "branch" of the mainline +code in the repository. They hold the "pumpkin" for things in this +area, and are usually the only user who will modify files there. +This is not strictly enforced in order to allow the flexibility +of other users stealing the pumpkin for short periods with the +owner's permission. + +Here is the current structure of the repository: + + /----+-----perl - Mainline development (bleadperl) + +-----cfgperl - Configure Pumpkin's Perl + +-----vmsperl - VMS Pumpkin's Perl + +-----maint-5.004------perl - Maintainance branches + +-----maint-5.005------perl + +-----maint-5.6------perl + +Perforce uses a branching model that simply tracks relationships +between files. It does not care about directories at all, so +any file can be a branch of any other file--the fully qualified +depot path name (of the form //depot/foo/bar.c) uniquely determines +a file for the purpose of establishing branching relationships. +Since a branch usually involves hundreds of files, such relationships +are typically specified en masse using a branch map (try `p4 help branch`). +`p4 branches` lists the existing branches that have been set up. +`p4 branch -o branchname` can be used to view the map for a particular +branch, if you want to determine the ancestor for a particular set of +files. + +The mainline (aka "trunk") code in the Perl repository is under +"//depot/perl/...". Most branches typically map its entire +contents under a directory that goes by the same name as the branch +name. Thus the contents of the cfgperl branch are to be found +in //depot/cfgperl. + +Run `p4 client` to specify how the repository contents should map to +your local disk. Most users will typically have a client map that +includes at least their entire branch and the contents of the mainline. + +Run `p4 changes -l -m10` to check on the activity in the repository. +//depot/perl/Porting/genlog is useful to get an annotated changelog +that shows files and branches. You can use this listing to determine +if there are any changes in the mainline that you need to merge into +your own branch. A typical merging session looks like this: + + % cd ~/p4view/cfgperl + % p4 integrate -b cfgperl # to bring parent changes into cfgperl + % p4 resolve -a ./... # auto merge the changes + % p4 resolve ./... # manual merge conflicting changes + % p4 submit ./... # check in + +If the owner of the mainline wants to bring the changes in cfgperl +back into the mainline, they do: + + % p4 integrate -r -b cfgperl + ... + +Generating a patch for change#42 is done as follows: + + % p4 describe -du 42 | p4desc | p4d2p > change-42.patch + +p4desc and p4d2p are to be found in //depot/perl/Porting/. + +=head1 Contact Information + +The mail alias <perl-repository-keepers@perl.org> can be used to reach +all current users of the repository. + +The repository keeper is currently Gurusamy Sarathy +<gsar@activestate.com>. + +=head1 AUTHORS + +Malcolm Beattie, mbeattie@sable.ox.ac.uk, 24 June 1997. + +Gurusamy Sarathy, gsar@activestate.com, 8 May 1999. + +Slightly updated by Simon Cozens, simon@brecon.co.uk, 3 July 2000 + +=cut + + @@ -1,7 +1,7 @@ Perl Kit, Version 5.0 - Copyright 1989-2000, Larry Wall + Copyright 1989-2001, Larry Wall All rights reserved. This program is free software; you can redistribute it and/or modify diff --git a/README.aix b/README.aix index 6346a180b2..bf83535e43 100644 --- a/README.aix +++ b/README.aix @@ -8,13 +8,13 @@ README.aix - Perl version 5 on IBM Unix (AIX) systems =head1 DESCRIPTION -This document describes various features of IBM's Unix operating system -(AIX) that will affect how Perl version 5 (hereafter just Perl) is -compiled and/or runs. +This document describes various features of IBM's Unix operating +system (AIX) that will affect how Perl version 5 (hereafter just Perl) +is compiled and/or runs. =head2 Compiling Perl 5 on AIX -When compiling Perl, you must use an ANSI C compiler. AIX does not shif +When compiling Perl, you must use an ANSI C compiler. AIX does not ship an ANSI compliant C-compiler with AIX by default, but binary builds of gcc for AIX are widely available. @@ -26,8 +26,8 @@ upgrade to the latest available patch level. Currently: xlC.C 3.1.4.0 vac.C 4.4.0.3 (5.0 is already available) -Perl can be compiled with either IBM's ANSI C compiler or with gcc. The -former is recommended, as not only can it compile Perl with no +Perl can be compiled with either IBM's ANSI C compiler or with gcc. +The former is recommended, as not only can it compile Perl with no difficulty, but also can take advantage of features listed later that require the use of IBM compiler-specific command-line flags. @@ -39,7 +39,7 @@ details. Before installing the patches to the IBM C-compiler you need to know the level of patching for the Operating System. IBM's command 'oslevel' will -show the base, but is not allways complete: +show the base, but is not always complete: # oslevel 4.3.0.0 @@ -52,7 +52,7 @@ show the base, but is not allways complete: AIX supports dynamically loadable libraries (shared libraries). Shared libraries end with the suffix .a, which is a bit misleading, -cause *all* libraries are shared ;-). +because *all* libraries are shared ;-). =head2 The IBM ANSI C Compiler @@ -61,12 +61,86 @@ All defaults for Configure can be used. If you've chosen to use vac 4, be sure to run 4.4.0.3. Older versions will turn up nasty later on. +Here's a brief lead of how to upgrade the compiler to the latest +level. Of course this is subject to changes. You can only upgrade +versions from ftp-available updates if the first three digit groups +are the same (in where you can skip intermediate unlike the patches +in the developer snapshots of perl), or to one version up where the +`base' is available. In other words, the AIX compiler patches are +cumulative. + + vac.C.4.4.0.1 => vac.C.4.4.0.3 is OK (vac.C.4.4.0.2 not needed) + xlC.C.3.1.3.3 => xlC.C.3.1.4.10 is NOT OK (xlC.C.3.1.4.0 is not available) + + # ftp ftp.software.ibm.com + Connected to service.boulder.ibm.com. + : welcome message ... + Name (ftp.software.ibm.com:merijn): anonymous + 331 Guest login ok, send your complete e-mail address as password. + Password: + ... accepted login stuff + ftp> cd /aix/fixes/v4/ + ftp> dir other other.ll + output to local-file: other.ll? y + 200 PORT command successful. + 150 Opening ASCII mode data connection for /bin/ls. + 226 Transfer complete. + ftp> dir xlc xlc.ll + output to local-file: xlc.ll? y + 200 PORT command successful. + 150 Opening ASCII mode data connection for /bin/ls. + 226 Transfer complete. + ftp> bye + ... goodbye messages + # ls -l *.ll + -rw-rw-rw- 1 merijn system 1169432 Nov 2 17:29 other.ll + -rw-rw-rw- 1 merijn system 29170 Nov 2 17:29 xlc.ll + +On AIX 4.2 using xlC, we continue: + + # lslpp -l | fgrep 'xlC.C ' + xlC.C 3.1.4.9 COMMITTED C for AIX Compiler + xlC.C 3.1.4.0 COMMITTED C for AIX Compiler + # grep 'xlC.C.3.1.4.*.bff' xlc.ll + -rw-r--r-- 1 45776101 1 6286336 Jul 22 1996 xlC.C.3.1.4.1.bff + -rw-rw-r-- 1 45776101 1 6173696 Aug 24 1998 xlC.C.3.1.4.10.bff + -rw-r--r-- 1 45776101 1 6319104 Aug 14 1996 xlC.C.3.1.4.2.bff + -rw-r--r-- 1 45776101 1 6316032 Oct 21 1996 xlC.C.3.1.4.3.bff + -rw-r--r-- 1 45776101 1 6315008 Dec 20 1996 xlC.C.3.1.4.4.bff + -rw-rw-r-- 1 45776101 1 6178816 Mar 28 1997 xlC.C.3.1.4.5.bff + -rw-rw-r-- 1 45776101 1 6188032 May 22 1997 xlC.C.3.1.4.6.bff + -rw-rw-r-- 1 45776101 1 6191104 Sep 5 1997 xlC.C.3.1.4.7.bff + -rw-rw-r-- 1 45776101 1 6185984 Jan 13 1998 xlC.C.3.1.4.8.bff + -rw-rw-r-- 1 45776101 1 6169600 May 27 1998 xlC.C.3.1.4.9.bff + # wget ftp://ftp.software.ibm.com/aix/fixes/v4/xlc/xlC.C.3.1.4.10.bff + # + +On AIX 4.3 using vac, we continue: + + # lslpp -l | fgrep 'vac.C ' + vac.C 4.4.0.2 COMMITTED C for AIX Compiler + vac.C 4.4.0.0 COMMITTED C for AIX Compiler + # grep 'vac.C.4.4.0.*.bff' other.ll + -rw-rw-r-- 1 45776101 1 13466624 May 26 1999 vac.C.4.4.0.1.bff + -rw-rw-r-- 1 45776101 1 13473792 Aug 31 1999 vac.C.4.4.0.2.bff + -rw-rw-r-- 1 45776101 1 13480960 May 19 20:32 vac.C.4.4.0.3.bff + # wget ftp://ftp.software.ibm.com/aix/fixes/v4/other/vac.C.4.4.0.3.bff + # + +Then execute the following command, and fill in its choices + + # smit install_update + -> Install and Update from LATEST Available Software + * INPUT device / directory for software [ vac.C.4.4.0.3.bff ] + [ OK ] + [ OK ] + +Follow the messages ... and you're done. + =head2 Using GNU's gcc for building perl ... ? -Wait, I'll have to scan perlbug ... - =head2 Using Large Files with Perl ... ? diff --git a/README.amiga b/README.amiga index 8951f355a0..3b2a1bda9d 100644 --- a/README.amiga +++ b/README.amiga @@ -4,18 +4,10 @@ specially designed to be readable as is. =head1 NAME -perlamiga - Perl under Amiga OS (possibly very outdated information) +perlamiga - Perl under Amiga OS =head1 SYNOPSIS -NOTE: No one has reported building Perl on the Amiga in a long -time. The following information is highly unlikely to be correct. -If you would like to help the Amiga port to stay current, see: - - http://us.aminet.net/aminet/dirs/dev_gg.html - -for Amiga resources and information. - One can read this document in the following formats: man perlamiga @@ -24,6 +16,11 @@ One can read this document in the following formats: to list some (not all may be available simultaneously), or it may be read I<as is>: either as F<README.amiga>, or F<pod/perlamiga.pod>. +A recent version of perl for the Amiga can be found at the Geek Gadgets +section of the Aminet: + + http://www.aminet.net/~aminet/dirs/dev_gg.html + =cut Contents @@ -61,16 +58,12 @@ Contents =item B<Unix emulation for AmigaOS: ixemul.library> You need the Unix emulation for AmigaOS, whose most important part is -B<ixemul.library>. For a minimum setup, get the following archives from -ftp://ftp.ninemoons.com/pub/ade/current or a mirror: +B<ixemul.library>. For a minimum setup, get the latest versions +of the following packages from the Aminet archives (http://www.aminet.net/~aminet/): -ixemul-46.0-bin.lha -ixemul-46.0-env-bin.lha -pdksh-4.9-bin.lha -ADE-misc-bin.lha - -Note that there might be newer versions available by the time you read -this. + ixemul-bin + ixemul-env-bin + pdksh-bin Note also that this is a minimum setup; you might want to add other packages of B<ADE> (the I<Amiga Developers Environment>). @@ -108,16 +101,24 @@ easier to use your script under *nix.) Perl under AmigaOS lacks some features of perl under UNIX because of deficiencies in the UNIX-emulation, most notably: -=over 6 +=over 4 + +=item * + +fork() -=item fork() +=item * -=item some features of the UNIX filesystem regarding link count and file dates +some features of the UNIX filesystem regarding link count and file dates -=item inplace operation (the -i switch) without backup file +=item * -=item umask() works, but the correct permissions are only set when the file is - finally close()d +inplace operation (the -i switch) without backup file + +=item * + +umask() works, but the correct permissions are only set when the file is +finally close()d =back @@ -126,11 +127,11 @@ deficiencies in the UNIX-emulation, most notably: Change to the installation directory (most probably ADE:), and extract the binary distribution: -lha -mraxe x perl-5.003-bin.lha +lha -mraxe x perl-$VERSION-bin.lha or -tar xvzpf perl-5.003-bin.tgz +tar xvzpf perl-$VERSION-bin.tgz (Of course you need lha or tar and gunzip for this.) @@ -189,16 +190,15 @@ Here we discuss how to build Perl under AmigaOS. =head2 Prerequisites -You need to have the latest B<ADE> (Amiga Developers Environment) -from ftp://ftp.ninemoons.com/pub/ade/current. -Also, you need a lot of free memory, probably at least 8MB. +You need to have the latest B<ixemul> (Unix emulation for Amiga) +from Aminet. =head2 Getting the perl source You can either get the latest perl-for-amiga source from Ninemoons and extract it with: - tar xvzpf perl-5.004-src.tgz + tar xvzpf perl-$VERSION-src.tgz or get the official source from CPAN: @@ -206,7 +206,7 @@ or get the official source from CPAN: Extract it like this - tar xvzpf perl5.004.tar.gz + tar xvzpf perl-$VERSION.tar.gz You will see a message about errors while extracting F<Configure>. This is normal and expected. (There is a conflict with a similarly-named file @@ -214,12 +214,60 @@ F<configure>, but it causes no harm.) =head2 Making - sh configure.gnu --prefix=/ade +=over 4 + +=item * + +remember to use a healthy sized stack (I used 2000000) + +=item * + +your PATH environment variable must include /bin (e.g. ".:/bin" is good) +(or, more precisely, it must include the directory where you have your +basic UNIX utilities like test, cat, sed, and so on) + +=item * + + sh Configure -Dprefix=/ade -Dloclibpth=/ade/lib -Now +=item * + +fix makedepend + + In the file 'makedepend' there are three spots like this `$cat ...`: + a for loop near line 75, an egrep near line 161, and a for loop near + line 175. In all those spots using an editor change the $cat to + /bin/cat. + +=item * + +now type make depend + + When the make depend has ended load the gnumakefile into + an editor and go to the end of the file. + + Move upwards in the file until you reach av.o: EXTERN.h + and delete all lines down to # WARNING: Put.... + +=item * + +now go to the x2p directory + + Load the gnumakefile into an editor. + + Go to the end moveup until you reach hash.o: EXTERN.h + and delete all lines dowonwards until you reach a line saying + + # WARNING: Put nothing.... + +=item * + +Now! make +=back + =head2 Testing Now run @@ -237,9 +285,10 @@ Run make install -=head1 AUTHOR +=head1 AUTHORS Norbert Pueschel, pueschel@imsdd.meb.uni-bonn.de +Jan-Erik Karlsson, trg@privat.utfors.se =head1 SEE ALSO diff --git a/README.cygwin b/README.cygwin index 9718bb5e06..6264a15788 100644 --- a/README.cygwin +++ b/README.cygwin @@ -27,11 +27,11 @@ platforms. They run thanks to the Cygwin library which provides the UNIX system calls and environment these programs expect. More information about this project can be found at: - http://sources.redhat.com/cygwin/ + http://www.cygwin.com/ A recent net or commercial release of Cygwin is required. -At the time this document was last updated, Cygwin 1.1.4 was current. +At the time this document was last updated, Cygwin 1.1.5 was current. B<NOTE:> At this point, minimal effort has been made to provide compatibility with old (beta) Cygwin releases. The focus has been to @@ -253,14 +253,6 @@ closed pipe. You will see the following messages: At least for consistency with WinNT, you should keep the recommended value. -=item * Checking how std your stdio is... - -Configure reports: - - Your stdio doesn't appear very std. - -This is correct. - =item * Compiler/Preprocessor defines The following error occurs because of the Cygwin C<#define> of @@ -500,12 +492,11 @@ be kept as clean as possible. =item Documentation - INSTALL README.cygwin + INSTALL README.cygwin README.win32 MANIFEST Changes Changes5.005 Changes5.004 Changes5.6 - AUTHORS MAINTAIN MANIFEST README.win32 - pod/buildtoc.PL pod/perl.pod pod/perl5004delta.pod pod/perl56delta.pod - pod/perlfaq3.pod pod/perlhist.pod pod/perlmodlib.pod pod/perlport.pod - pod/perltoc.pod + pod/perl.pod pod/perlport.pod pod/perlfaq3.pod + pod/perldelta.pod pod/perl5004delta.pod pod/perl56delta.pod + pod/perlhist.pod pod/perlmodlib.pod pod/buildtoc.PL pod/perltoc.pod =item Build, Configure, Make, Install @@ -543,9 +534,7 @@ be kept as clean as possible. perl.h - binmode doio.c - win9x can not rename a file when it is open pp_sys.c - do not define h_errno, pp_system with spawn - mg.c - environ WORKAROUND - unixish.h - environ WORKAROUND - util.c - environ WORKAROUND + util.c - use setenv =item Compiled Module Source @@ -585,10 +574,14 @@ On WinNT Cygwin provides setuid(), seteuid(), setgid() and setegid(). However, additional Cygwin calls for manipulating WinNT access tokens and security contexts are required. +When building DLLs, `C<dllwrap --export-all-symbols>' is used to export +global symbols. It might be better to generate an explicit F<.def> file +(see F<makedef.pl>). Also, DLLs can now be build with `C<gcc -shared>'. + =head1 AUTHORS Charles Wilson <cwilson@ece.gatech.edu>, -Eric Fifer <efifer@sanwaint.com>, +Eric Fifer <egf7@columbia.edu>, alexander smishlajev <als@turnhere.com>, Steven Morlock <newspost@morlock.net>, Sebastien Barre <Sebastien.Barre@utc.fr>, @@ -596,4 +589,4 @@ Teun Burgers <burgers@ecn.nl>. =head1 HISTORY -Last updated: 15 August 2000 +Last updated: 9 November 2000 diff --git a/README.dos b/README.dos index 51cd1d6f18..fe649ed344 100644 --- a/README.dos +++ b/README.dos @@ -9,7 +9,7 @@ perldos - Perl under DOS, W31, W95. =head1 SYNOPSIS These are instructions for building Perl under DOS (or w??), using -DJGPP v2.01 or later. Under w95 long filenames are supported. +DJGPP v2.03 or later. Under w95 long filenames are supported. =head1 DESCRIPTION @@ -22,6 +22,10 @@ This port currently supports MakeMaker (the set of modules that is used to build extensions to perl). Therefore, you should be able to build and install most extensions found in the CPAN sites. +Detailed instructions on how to build and install perl extension +modules, including XS-type modules, is included. See 'BUILDING AND +INSTALLING MODULES'. + =head2 Prerequisites =over 4 @@ -46,19 +50,19 @@ the world. Like: You need the following files to build perl (or add new modules): - v2/djdev202.zip - v2/bnu27b.zip - v2gnu/gcc2721b.zip - v2gnu/bsh1147b.zip - v2gnu/mak3761b.zip + v2/djdev203.zip + v2/bnu2951b.zip + v2gnu/gcc2952b.zip + v2gnu/bsh204b.zip + v2gnu/mak3791b.zip v2gnu/fil316b.zip - v2gnu/sed118b.zip - v2gnu/txt122b.zip - v2gnu/dif271b.zip - v2gnu/grep21b.zip + v2gnu/sed302b.zip + v2gnu/txt20b.zip + v2gnu/dif272b.zip + v2gnu/grep24b.zip v2gnu/shl112b.zip v2gnu/gawk303b.zip - v2misc/csdpmi4b.zip + v2misc/csdpmi4b.zip or possibly any newer version. @@ -104,7 +108,7 @@ to use long file names under w95 and also to get Perl to pass all its tests, don't forget to use set LFN=y - set FNCASE=y + set FNCASE=y before unpacking the archive. @@ -115,6 +119,9 @@ directory. ln -s bash.exe sh.exe +[If you have the recommended version of bash for DJGPP, this is already +done for you.] + And make the C<SHELL> environment variable point to this F<sh.exe>: set SHELL=c:/djgpp/bin/sh.exe (use full path name!) @@ -131,20 +138,34 @@ F<split.exe> to F<djsplit.exe>, and F<gsplit.exe> to F<split.exe>. Copy or link F<gecho.exe> to F<echo.exe> if you don't have F<echo.exe>. Copy or link F<gawk.exe> to F<awk.exe> if you don't have F<awk.exe>. +[If you have the recommended versions of djdev, shell utilities and +gawk, all these are already done for you, and you will not need to do +anything.] + =item * Chdir to the djgpp subdirectory of perl toplevel and type the following -command: +commands: + set FNCASE=y configure.bat This will do some preprocessing then run the Configure script for you. -The Configure script is interactive, but in most cases you -just need to press ENTER. +The Configure script is interactive, but in most cases you just need to +press ENTER. The "set" command ensures that DJGPP preserves the letter +case of file names when reading directories. If you already issued this +set command when unpacking the archive, and you are in the same DOS +session as when you unpacked the archive, you don't have to issue the +set command again. This command is necessary *before* you start to +(re)configure or (re)build perl in order to ensure both that perl builds +correctly and that building XS-type modules can succeed. See the DJGPP +info entry for "_preserve_fncase" for more information: + + info libc alphabetical _preserve_fncase If the script says that your package is incomplete, and asks whether to continue, just answer with Y (this can only happen if you don't use -long filenames). +long filenames or forget to issue "set FNCASE=y" first). When Configure asks about the extensions, I suggest IO and Fcntl, and if you want database handling then SDBM_File or GDBM_File @@ -203,9 +224,106 @@ directory structure. Perl.exe and the utilities go into C<($DJDIR)/bin>, and the library goes under C<($DJDIR)/lib/perl5>. The pod documentation goes under C<($DJDIR)/lib/perl5/pod>. +=head1 BUILDING AND INSTALLING MODULES + + +=head2 Prerequisites + +For building and installing non-XS modules, all you need is a working +perl under DJGPP. Non-XS modules do not require re-linking the perl +binary, and so are simpler to build and install. + +XS-type modules do require re-linking the perl binary, because part of +an XS module is written in "C", and has to be linked together with the +perl binary to be executed. This is required because perl under DJGPP +is built with the "static link" option, due to the lack of "dynamic +linking" in the DJGPP environment. + +Because XS modules require re-linking of the perl binary, you need both +the perl binary distribution and the perl source distribution to build +an XS extension module. In addition, you will have to have built your +perl binary from the source distribution so that all of the components +of the perl binary are available for the required link step. + +=head2 Unpacking CPAN Modules + +First, download the module package from CPAN (e.g., the "Comma Separated +Value" text package, Text-CSV-0.01.tar.gz). Then expand the contents of +the package into some location on your disk. Most CPAN modules are +built with an internal directory structure, so it is usually safe to +expand it in the root of your DJGPP installation. Some people prefer to +locate source trees under /usr/src (i.e., C<($DJDIR)/usr/src>), but you may +put it wherever seems most logical to you, *EXCEPT* under the same +directory as your perl source code. There are special rules that apply +to modules which live in the perl source tree that do not apply to most +of the modules in CPAN. + +Unlike other DJGPP packages, which are normal "zip" files, most CPAN +module packages are "gzipped tarballs". Recent versions of WinZip will +safely unpack and expand them, *UNLESS* they have zero-length files. It +is a known WinZip bug (as of v7.0) that it will not extract zero-length +files. + +From the command line, you can use the djtar utility provided with DJGPP +to unpack and expand these files. For example: + + C:\djgpp>djtarx -v Text-CSV-0.01.tar.gz + +This will create the new directory C<($DJDIR)/Text-CSV-0.01>, filling +it with the source for this module. + +=head2 Building Non-XS Modules + +To build a non-XS module, you can use the standard module-building +instructions distributed with perl modules. + + perl Makefile.PL + make + make test + make install + +This is sufficient because non-XS modules install only ".pm" files and +(sometimes) pod and/or man documentation. No re-linking of the perl +binary is needed to build, install or use non-XS modules. + +=head2 Building XS Modules + +To build an XS module, you must use the standard module-building +instructions distributed with perl modules *PLUS* three extra +instructions specific to the DJGPP "static link" build environment. + + set FNCASE=y + perl Makefile.PL + make + make perl + make test + make -f Makefile.aperl inst_perl MAP_TARGET=perl.exe + make install + +The first extra instruction sets DJGPP's FNCASE environment variable so +that the new perl binary which you must build for an XS-type module will +build correctly. The second extra instruction re-builds the perl binary +in your module directory before you run "make test", so that you are +testing with the new module code you built with "make". The third extra +instruction installs the perl binary from your module directory into the +standard DJGPP binary directory, C<($DJDIR)/bin>, replacing your +previous perl binary. + +Note that the MAP_TARGET value *must* have the ".exe" extension or you +will not create a "perl.exe" to replace the one in C<($DJDIR)/bin>. + +When you are done, the XS-module install process will have added information +to yout "perllocal" information telling that the perl binary has been replaced, +and what module was installed. you can view this information at any time +by using the command: + + perl -S perldoc perllocal + =head1 AUTHOR -Laszlo Molnar, F<laszlo.molnar@eth.ericsson.se> +Laszlo Molnar, F<laszlo.molnar@eth.ericsson.se> [Installing/building perl] + +Peter J. Farley III F<pjfarley@banet.net> [Building/installing modules] =head1 SEE ALSO diff --git a/README.epoc b/README.epoc index 06290c3090..6c6256569d 100644 --- a/README.epoc +++ b/README.epoc @@ -1,14 +1,16 @@ -===================================================================== -Perl 5 README file for the EPOC operating system. -===================================================================== +If you read this file _as_is_, just ignore the funny characters you +see. It is written in the POD format (see pod/perlpod.pod) which is +specially designed to be readable as is. -Olaf Flebbe <o.flebbe@gmx.de> -http://members.linuxstart.com/~oflebbe/perl/perl5.html -2000-09-18 +=head1 NAME + +README.epoc - Perl for EPOC -===================================================================== -Introduction -===================================================================== +=head1 SYNOPSIS + +Perl 5 README file for the EPOC operating system. + +=head1 INTRODUCTION EPOC is a OS for palmtops and mobile phones. For more informations look at: http://www.symbian.com/ @@ -18,9 +20,7 @@ This is a port of perl to EPOC. It runs on the Psion Series 5, 5mx, the Psion Netbook or the S7. For information about this hardware please refer to http://www.psion.com. -===================================================================== -Installation/Usage -===================================================================== +=head1 INSTALLING PERL ON EPOC You will need ~4MB free space in order to install and run perl. @@ -40,9 +40,9 @@ you are leaving perl, you get into the system screen. You have to switch back manually to ESHELL. When perl is running, you will see a task with the name STDOUT in the task list. -====================================================================== -IO Redirection -====================================================================== +=head1 USING PERL ON EPOC + +=head2 IO Redirection You can redirect the output with the UNIX bourne shell syntax (this is built into perl rather then eshell) For instance the following command @@ -51,12 +51,10 @@ stdout_file, the errors to stderr_file and input from stdin_file. perl test.pl >stdout_file <stdin_file 2>stderr_file -Alternativly you can use 2>&1 in order to add the standard error +Alternatively you can use 2>&1 in order to add the standard error output to stdout. -====================================================================== -PATH Names -====================================================================== +=head2 PATH Names ESHELL looks for executables in ?:/System/Programs. The SIS file installs perl in this special folder directory. The default drive and @@ -80,68 +78,96 @@ You can automatically search for file on all EPOC drives with a ? as the driver letter. For instance ?:\a.txt searches for C:\a.txt, D:\b.txt (and Z:\a.txt). -====================================================================== -Editors -====================================================================== +=head2 Editors A suitable text-editor can be downloaded from symbian http://developer.epocworld.com/downloads/progs/Editor.zip -==================================================================== -Features -==================================================================== +=head2 Features The built-in function EPOC::getcwd returns the current directory. -====================================================================== -Restrictions -====================================================================== +=head2 Restrictions Features are left out, because of restrictions of the POSIX support in EPOC: -+ backquoting, pipes etc. +=over 4 + +=item * + +backquoting, pipes etc. + +=item * + +system() does not inherit ressources like: file descriptors, +environment etc. + +=item * + +signal, kill, alarm. Do not try to use them. This may be +impossible to implement on EPOC. + +=item * + +select is missing. + +=item * -+ system() does not inherit ressources like: file descriptors, - environment etc. +binmode does not exist. (No CR LF to LF translation for text files) -+ signal, kill, alarm. Do not try to use them. This may be - impossible to implement on EPOC. +=item * -+ select is missing. +EPOC does not handle the notion of current drive and current +directory very well (i.e. not at all, but it tries hard to emulate +one) See PATH. -+ binmode does not exist. (No CR LF to LF translation for text files) +=item * -+ EPOC does not handle the notion of current drive and current - directory very well (i.e. not at all, but it tries hard to emulate - one) See PATH. +You need the shell eshell.exe in order to run perl.exe and supply +it with arguments. -+ You need the shell eshell.exe in order to run perl.exe and supply - it with arguments. +=item * -+ Heap is limited to 4MB. +Heap is limited to 4MB. -=================================================================== -Compiling Perl 5 on the EPOC cross compiling envionment. -=================================================================== +=back + +=head2 Compiling Perl 5 on the EPOC cross compiling environment Sorry, this is far too short. - You will need the C++ SDK from http://developer.epocworld.com/. +=over 4 + +=item * + +You will need the C++ SDK from http://developer.epocworld.com/. + +=item * + +You will need to set up the cross SDK from +http://www.science-computing.de/o.flebbe/sdk + +=item * + +You may have to adjust config.sh (cc, cppflags) for your epoc +install location. + +=item * + +You may have to adjust config.sh for your cross SDK location - You will need to set up the cross SDK from - http://members.linuxstart.com/~oflebbe +=item * - You may have to adjust config.sh (cc, cppflags) for your epoc - install location. +Get the Perl sources from your nearest CPAN site. - You may have to adjust config.sh for your cross SDK location +=item * - Get the Perl sources from your nearest CPAN site. +Unpack the sources. - Unpack the sources. +=item * - Build a native perl from this sources... +Build a native perl from this sources... cp epoc/* . ./Configure -S @@ -159,10 +185,20 @@ Sorry, this is far too short. wine G:/bin/makesis perl.pkg perl.sis +=back -==================================================================== -Support Status -==================================================================== +=head1 SUPPORT STATUS I'm offering this port "as is". You can ask me questions, but I can't guarantee I'll be able to answer them. + +=head1 AUTHOR + +Olaf Flebbe <o.flebbe@gmx.de> +http://members.linuxstart.com/~oflebbe/perl/perl5.html + +=head1 LAST UPDATE + +2000-09-18 + +=cut diff --git a/README.hpux b/README.hpux index e12c60d352..e850441095 100644 --- a/README.hpux +++ b/README.hpux @@ -243,22 +243,22 @@ fix is currently available. =head2 perl -P and // -In HP-UX perl is compiled with flags that will cause problems if the +In HP-UX Perl is compiled with flags that will cause problems if the -P flag of Perl (preprocess Perl code with the C preprocessor before perl sees it) is used. The problem is that C<//>, being a C++-style until-end-of-line comment, will disappear along with the remainder of the line. This means that common Perl constructs like - s/foo//; + s/foo//; will turn into illegal code - s/foo + s/foo -The workaround is to use some other quoting characters than /, -like for example ! +The workaround is to use some other quoting separator than C<"/">, +like for example C<"!">: - s!foo!!; + s!foo!!; =head1 AUTHOR diff --git a/README.mpeix b/README.mpeix index 9e0b51d796..7976db54ad 100644 --- a/README.mpeix +++ b/README.mpeix @@ -1,260 +1,675 @@ -Perl/iX for HP 3000 MPE +If you read this file _as_is_, just ignore the funny characters you +see. It is written in the POD format (see perlpod manpage) which is +specially designed to be readable as is. -http://www.cccd.edu/~markb/perlix.html -Perl language for MPE -Last updated July 15, 1998 @ 2030 UTC +=head1 NAME - ------------------------------------------------------------------------ +README.mpeix - Perl/iX for HP e3000 MPE + +=head1 SYNOPSIS -What's New + http://www.bixby.org/mark/perlix.html + Perl language for MPE + Last updated June 2, 2000 @ 0400 UTC + +=head1 NOTE - * July 15, 1998 - o Changed startperl to #!/PERL/PUB/perl so that Perl will recognize - scripts more easily and efficiently. - * July 8, 1998 - o Updated to version 5.004_70 (internal developer release) which is - now MPE-ready. The next public freeware release of Perl should - compile "straight out of the box" on MPE. Note that this version - of Perl/iX was strictly internal to me and never publicly - released. Note that BIND/iX is now required (well, the include - files and libbind.a) if you wish to compile Perl/iX. - * November 6, 1997 - o Updated to version 5.004_04. No changes in MPE-specific - functionality. +This is a podified version of the above-mentioned web page, +podified by Jarkko Hietaniemi 2001-Jan-01. - ------------------------------------------------------------------------ +=head1 What's New -Welcome +June 1, 2000 + +=over 4 -This is the official home page for the HP 3000 MPE port of the Perl -scripting language which gives you all of the power of C, awk, sed, and sh -in a single language. Check here for the latest news, implemented -functionality, known bugs, to-do list, etc. Status reports about major -milestones will also be posted to the HP3000-L mailing list and its -associated gatewayed newsgroup comp.sys.hp.mpe. +=item * -I'm doing this port because I can't live without Perl on the HPUX machines -that I administer for the Coast Community College District, and I want to -have the same power available to me on MPE. +Rebuilt to be compatible with mod_perl. If you plan on using +mod_perl, you MUST download and install this version of Perl/iX! + +=item * -Please send your comments, questions, and bug reports directly to me, Mark -Bixby, by e-mailing to markb@cccd.edu. Or just post them to HP3000-L. You -can also telephone me at +1 714 438-4647 Monday-Friday 0815-1745 PDT -(1615-0145 UTC). +bincompat5005="undef": sorry, but you will have to recompile any +binary 5.005 extensions that you may be using (if any; there is no +5.005 code in what you download from bixby.org) +uselargefiles="undef": not available in MPE for POSIX files yet. + +=item * -The platform I'm using to do this port is an HP 3000 969KS200 running -MPE/iX 5.5 and using the gcc 2.8 compiler from -http://www.interex.org/sources/freeware.html. +Now bundled with various add-on packages: -The combined porting wisdom from all of my ports can be found in my MPE/iX -Porting Guide. +=over 8 - ------------------------------------------------------------------------ +=item * -System Requirements +libnet (http://www.gbarr.demon.co.uk/libnet/FAQ.html) - * MPE/iX 5.5 or later. This version of Perl/iX does NOT run on MPE/iX - 5.0 or earlier, nor does it run on "classic" MPE/V machines. - * The Perl binary requires that you must have converted your NMRL - libraries in /lib/lib*.a and /usr/lib/lib*.a to NMXL libraries - /lib/lib*.sl and /usr/lib/lib*.sl via the LIBSHP3K script that comes - with the GNUCORE portion of the FREEWARE tape. - * If you wish to recompile Perl, you must install both GNUCORE and - GNUGCC from the FREEWARE tape. - * Perl/iX will be happier if you install the MPEKX76A additional POSIX - filename characters patch, but this is optional. - * If you will be compiling Perl/iX yourself, you will also need the - /BIND/PUB/include and /BIND/PUB/lib portions of BIND/iX. +=item * - ------------------------------------------------------------------------ +libwww-perl (LWP) which lets Perl programs behave like web browsers: + + 1. #!/PERL/PUB/perl + 2. use LWP::Simple; + 3. $doc = get('http://www.bixby.org/mark/perlix.html'); # reads the + web page into variable $doc + +(http://www.bixby.org/mark/perlix.html) -Demos +=item * -Here is a brief selection of some sample Perl/iX uses: +mod_perl (just the perl portion; the actual DSO will be released +soon with Apache/iX 1.3.12 from bixby.org). This module allows you to +write high performance persistent Perl CGI scripts and all sorts of +cool things. (http://perl.apache.org/) + +and much much more hiding under /PERL/PUB/.cpan/ + +=item * - * A web feedback CGI form that lets a web browser user enter some data - and send e-mail to the person responsible for reading the feedback - comments. The CGI is written in Perl and requires Sendmail/iX. +The CPAN module now works for automatic downloading and +installing of add-on packages: - ------------------------------------------------------------------------ + 1. export FTP_PASSIVE=1 + 2. perl -MCPAN -e shell + 3. Ignore any terminal I/O related complaints! + +(http://theoryx5.uwinnipeg.ca/CPAN/data/perl/CPAN.html) -How to Obtain Perl/iX +=back - 1. Download Perl using either FTP.ARPA.SYS or some other client - 2. Extract the installation script - 3. Edit the installation script - 4. Run the installation script +=back + +May 20, 2000 + +=over 4 + +=item * + +Updated to version 5.6.0. Builds straight out of the box on MPE/iX. + +=item * + +Perl's getpwnam() function which had regressed to being +unimplemented on MPE is now implemented once again. + +=back + +September 17, 1999 + +=over 4 + +=item * + +Migrated from cccd.edu to bixby.org. + +=back + +=head1 Welcome + +This is the official home page for the HP e3000 MPE/iX +(http://www.businessservers.hp.com/) port of the Perl scripting +language (http://www.perl.com/) which gives you all of the power of C, +awk, sed, and sh in a single language. Check here for the latest news, +implemented functionality, known bugs, to-do list, etc. Status reports +about major milestones will also be posted to the HP3000-L mailing list +(http://www.lsoft.com/scripts/wl.exe?SL1=HP3000-L&H=RAVEN.UTC.EDU) and +its associated gatewayed newsgroup comp.sys.hp.mpe. + +I'm doing this port because I can't live without Perl on the Unix +machines that I administer, and I want to have the same power +available to me on MPE. + +Please send your comments, questions, and bug reports directly to me, +Mark Bixby (http://www.bixby.org/mark/), by e-mailing to +mark@bixby.org. Or just post them to HP3000-L. + +The platform I'm using to do this port is an HP 3000 957RX running +MPE/iX 6.0 and using the GNU gcc C compiler +(http://jazz.external.hp.com/src/gnu/gnuframe.html). + +The combined porting wisdom from all of my ports can be found in my +MPE/iX Porting Guide (http://www.bixby.org/mark/porting.html). + +IMPORTANT NOTICE: Yes, I do work for the HP CSY R&D lab, but ALL of +the software you download from bixby.org is my personal freeware that +is NOT supported by HP. + +=head1 System Requirements + +=over 4 + +=item * + +MPE/iX 5.5 or later. This version of Perl/iX does NOT run on +MPE/iX 5.0 or earlier, nor does it run on "classic" MPE/V machines. + +=item * + +If you wish to recompile Perl, you must install both GNUCORE and +GNUGCC from jazz (http://jazz.external.hp.com/src/gnu/gnuframe.html). + +=item * + +Perl/iX will be happier on MPE/iX 5.5 if you install the MPEKX40B +extended POSIX filename characters patch, but this is optional. + +=item * + +Patch LBCJXT6A is required on MPE/iX 5.5 machines in order to +prevent Perl/iX from dying with an unresolved external reference +to _getenv_libc. + +=item * + +If you will be compiling Perl/iX yourself, you will also need +Syslog/iX (http://www.bixby.org/mark/syslogix.html) and the +/BIND/PUB/include and /BIND/PUB/lib portions of BIND/iX +(http://www.bixby.org/mark/bindix.html). + +=back + +=head1 How to Obtain Perl/iX + +=over 4 + +=item 1. + +Download Perl using either FTP.ARPA.SYS or some other client + +=item 2. + +Extract the installation script + +=item 3. + +Edit the installation script + +=item 4. + +Run the installation script + +=item 5. + +Convert your *.a system archive libraries to *.sl shared libraries + +=back Download Perl using FTP.ARPA.SYS from your HP 3000 (the preferred method)..... - -:HELLO MANAGER.SYS -:XEQ FTP.ARPA.SYS -open ftp.cccd.edu -anonymous -your@email.address -bytestream -cd /pub/mpe -get perl5.005.tar.Z /tmp/perl.tar.Z -exit + + :HELLO MANAGER.SYS + :XEQ FTP.ARPA.SYS + open ftp.bixby.org + anonymous + your@email.address + bytestream + cd /pub/mpe + get perl-5.6.0-mpe.tar.Z /tmp/perl.tar.Z;disc=2147483647 + exit .....Or download using some other generic web or ftp client (the alternate method) - + Download the following files (make sure that you use "binary mode" or whatever client feature that is 8-bit clean): - * Perl from http://www.cccd.edu/ftp/pub/mpe/perl5.005.tar.Z or - ftp://ftp.cccd.edu/pub/mpe/perl5.005.tar.Z +=over 4 + +=item * + +Perl from + + http://www.bixby.org/ftp/pub/mpe/perl-5.6.0-mpe.tar.Z + +or + + ftp://ftp.bixby.org/pub/mpe/perl-5.6.0-mpe.tar.Z + +=item * Upload those files to your HP 3000 in an 8-bit clean bytestream manner to: - * /tmp/perl.tar.Z + /tmp/perl.tar.Z + +=item * Then extract the installation script (after both download methods) + + :CHDIR /tmp + :XEQ TAR.HPBIN.SYS 'xvfopz /tmp/perl.tar.Z INSTALL' -:CHDIR /tmp -:XEQ TAR.HPBIN.SYS 'xvfopz /tmp/perl.tar.Z INSTALL' +=item * Edit the installation script + +Examine the accounting structure creation commands and modify if +necessary (adding additional capabilities, choosing a non-system +volume set, etc). -Examine the accounting structure creation commands and modify if necessary -(adding additional capabilities, choosing a non-system volume set, etc). + :XEQ VI.HPBIN.SYS /tmp/INSTALL -:XEQ VI.HPBIN.SYS /tmp/INSTALL - -Run the installation script +=item * +Run the installation script. + The accounting structure will be created and then all files will be extracted from the archive. -:XEQ SH.HPBIN.SYS /tmp/INSTALL - - ------------------------------------------------------------------------ - -Distribution Contents Highlights - -README - The file you're reading now. -INSTALL - Perl/iX Installation script. -PERL - Perl NMPRG executable. A version-numbered backup copy also exists. - You might wish to "ln -s /PERL/PUB/PERL /usr/local/bin/perl". -lib/ - Perl libraries, both core and add-on. -man/ - Perl man page documentation. -public_html/feedback.cgi - Sample feedback CGI form written in Perl. -src/perl5.005 - Source code. - - ------------------------------------------------------------------------ - -How to Compile Perl/iX - - 1. cd src/perl5.005 - 2. Read the INSTALL file for the official instructions - 3. ./Configure - 4. make - 5. ./mpeix/relink - 6. make test (expect 31 out of 5899 subtests to fail, mostly due to MPE - not supporting hard links and handling exit() return codes improperly) - 7. make install - 8. Optionally create symbolic links that point to the Perl executable, - i.e. ln -s /usr/local/bin/perl /PERL/PUB/PERL + :XEQ SH.HPBIN.SYS /tmp/INSTALL + +=item * + +Convert your *.a system archive libraries to *.sl shared libraries + +You only have to do this ONCE on your MPE/iX 5.5 machine in order to +convert /lib/lib*.a and /usr/lib/lib*.a libraries to their *.sl +equivalents. This step should not be necessary on MPE/iX 6.0 or later +machines because the 6.0 or later update process does it for you. + + :XEQ SH.HPBIN.SYS /PERL/PUB/LIBSHP3K + +=back + +=head1 Distribution Contents Highlights + +=over 4 + +=item README + +The file you're reading now. + +=item INSTALL + +Perl/iX Installation script. + +=item LIBSHP3K + +Script to convert *.a system archive libraries to *.sl shared libraries. + +=item PERL + +Perl NMPRG executable. A version-numbered backup copy also +exists. You might wish to "ln -s /PERL/PUB/PERL /usr/local/bin/perl". + +=item .cpan/ + +Much add-on source code downloaded with the CPAN module. + +=item lib/ + +Perl libraries, both core and add-on. + +=item man/ + +Perl man page documentation. + +=item public_html/feedback.cgi + +Sample feedback CGI form written in Perl. + +=item src/perl-5.6.0-mpe + +Source code. + +=back + +=head1 How to Compile Perl/iX + +=over 4 + +=item 1. + +cd src/perl-5.6.0-mpe + +=item 2. + +Read the INSTALL file for the official instructions + +=item 3. + +./Configure -d + +=item 4. + +make + +=item 5. + +./mpeix/relink + +=item 6. + +make test (expect approximately 15 out of 11306 subtests to fail, +mostly due to MPE not supporting hard links, UDP socket problems, +and handling exit() return codes improperly) + +=item 7. + +make install + +=item 8. + +Optionally create symbolic links that point to the Perl +executable, i.e. ln -s /PERL/PUB/PERL /usr/local/bin/perl + +=back The summary test results from "cd t; ./perl -I../lib harness": -Failed Test Status Wstat Total Fail Failed List of failed -------------------------------------------------------------------------------- -io/fs.t 26 8 30.77% 2-5, 7-9, 11 -io/pipe.t 12 2 16.67% 11-12 -lib/posix.t 18 1 5.56% 12 -op/die_exit.t 16 16 100.00% 1-16 -op/exec.t 8 2 25.00% 5-6 -op/stat.t 58 2 3.45% 3, 35 -Failed 6/183 test scripts, 96.72% okay. 31/5899 subtests failed, 99.47% okay. - - ------------------------------------------------------------------------ - -Getting Started with Perl/iX - -Create your Perl script files with "#!/PERL/PUB/perl" (or an equivalent -symbolic link) as the first line. Use the chmod command to make sure that -your script has execute permission. Run your script! - -If you want to use Perl to write web server CGI scripts, obtain and install -CGI.pm. Build CGI.pm and all other add-on modules below /PERL/PUB/src/. - -Be sure to take a look at the CPAN module list. A wide variety of free Perl -software is available. - - ------------------------------------------------------------------------ - -MPE/iX Implementation Considerations - -There some minor functionality issues to be aware of when comparing Perl -for Unix (Perl/UX) to Perl/iX: - - * MPE gcc/ld doesn't properly support linking NMPRG executables against - NMXL dynamic libraries, so you must manually run mpeix/relink after - each re-build of Perl. - * Perl/iX File::Copy will use MPE's /bin/cp command to copy files by - name in order to preserve file attributes like file code. - * MPE (and thus Perl/iX) lacks support for setgrent(), endgrent(), - setpwent(), endpwent(). - * MPE (and thus Perl/iX) lacks support for hard links. - * MPE requires GETPRIVMODE() in order to bind() to ports less than - 1024. Perl/iX will call GETPRIVMODE() automatically on your behalf if - you attempt to bind() to these low-numbered ports. Note that the - Perl/iX executable and the PERL account do not normally have CAP=PM, - so if you will be bind()-ing to these privileged ports, you will - manually need to add PM capability as appropriate. - * MPE requires that you bind() to an IP address of zero. Perl/iX - automatically replaces the IP address that you pass to bind() with a - zero. - * If you use Perl/iX fcntl() against a socket it will fail, because MPE - requires that you use sfcntl() instead. Perl/iX does not presently - support sfcntl(). - * MPE requires GETPRIVMODE() in order to setuid(). There are too many - calls to setuid() within Perl/iX, so I have not attempted an automatic - GETPRIVMODE() solution similar to bind(). - - ------------------------------------------------------------------------ - -Known Bugs Under Investigation - - * None - - ------------------------------------------------------------------------ - -To-Do List - - * Make setuid()/setgid() support work. - * Make sure that fcntl() against a socket descriptor is redirected to - sfcntl(). - * Add support for Berkeley DB once I've finished porting Berkeley DB. - * Write an MPE XS extension library containing miscellaneous important - MPE functions like GETPRIVMODE(), GETUSERMODE(), and sfcntl(). - - ------------------------------------------------------------------------ - -Change History - - * October 16, 1997 - o Added Demos section to the Perl/iX home page so you can see some - sample Perl applications running on my 3000. - * October 3, 1997 - o Added System Requirements section to the Perl/iX home page just - so the prerequisites stand out more. Various other home page - tweaks. - * October 2, 1997 - o Initial public release. - * September 1997 - o Porting begins. - - ------------------------------------------------------------------------ - -Mark Bixby, markb@cccd.edu + Failed Test Status Wstat Total Fail Failed List of failed + --------------------------------------------------------------------------- + io/fs.t 29 8 27.59% 2-5, 7-9, 11 + io/openpid.t 10 1 10.00% 7 + lib/io_sock.t 14 1 7.14% 13 + lib/io_udp.t 7 2 28.57% 3, 5 + lib/posix.t 27 1 3.70% 12 + op/lex_assign.t 187 1 0.53% 13 + op/stat.t 58 1 1.72% 3 + 15 tests and 94 subtests skipped. + Failed 7/236 test scripts, 97.03% okay. 15/11306 subtests failed, 99.87% okay. + +=head1 Getting Started with Perl/iX + +Create your Perl script files with "#!/PERL/PUB/perl" (or an +equivalent symbolic link) as the first line. Use the chmod command to +make sure that your script has execute permission. Run your script! + +Be sure to take a look at the CPAN module list +(http://www.cpan.org/CPAN.html). A wide variety of free Perl software +is available. You can automatically download these packages by using +the CPAN module (http://theoryx5.uwinnipeg.ca/CPAN/data/perl/CPAN.html). + +=head1 MPE/iX Implementation Considerations + +There some minor functionality issues to be aware of when comparing +Perl for Unix (Perl/UX) to Perl/iX: + +=over 4 + +=item * + +MPE gcc/ld doesn't properly support linking NMPRG executables against +NMXL dynamic libraries, so you must manually run mpeix/relink after +each re-build of Perl. + +=item * + +Perl/iX File::Copy will use MPE's /bin/cp command to copy files by +name in order to preserve file attributes like file code. + +=item * + +MPE (and thus Perl/iX) lacks support for setgrent(), endgrent(), +setpwent(), endpwent(). + +=item * + +MPE (and thus Perl/iX) lacks support for hard links. + +=item * + +MPE requires GETPRIVMODE() in order to bind() to ports less than 1024. +Perl/iX will call GETPRIVMODE() automatically on your behalf if you +attempt to bind() to these low-numbered ports. Note that the Perl/iX +executable and the PERL account do not normally have CAP=PM, so if you +will be bind()-ing to these privileged ports, you will manually need +to add PM capability as appropriate. + +=item * + +MPE requires that you bind() to an IP address of zero. Perl/iX +automatically replaces the IP address that you pass to bind() with +a zero. + +=item * + +If you use Perl/iX fcntl() against a socket it will fail, because MPE +requires that you use sfcntl() instead. Perl/iX does not presently +support sfcntl(). + +=item * + +MPE requires GETPRIVMODE() in order to setuid(). There are too many +calls to setuid() within Perl/iX, so I have not attempted an automatic +GETPRIVMODE() solution similar to bind(). + +=back + +=head1 Known Bugs Under Investigation + +None. + +=head1 To-Do List + +=over 4 + +=item * + +Make setuid()/setgid() support work. + +=item * + +Make sure that fcntl() against a socket descriptor is redirected to sfcntl(). + +=item * + +Add support for Berkeley DB once I've finished porting Berkeley DB. + +=item * + +Write an MPE XS extension library containing miscellaneous important +MPE functions like GETPRIVMODE(), GETUSERMODE(), and sfcntl(). + +=back + +=head1 Change History + +May 6, 1999 + +=over 4 + +=item * + +Patch LBCJXT6A is required on MPE/iX 5.5 machines in order to prevent +Perl/iX from dying with an unresolved external reference to _getenv_libc. + +=back + +April 7, 1999 + +=over 4 + +=item * + +Updated to version 5.005_03. + +=item * + +The official source distribution once again compiles "straight out +of the box" for MPE. + +=item * + +The current incarnation of the 5.5 POSIX filename extended +characters patch is now MPEKX40B. + +=item * + +The LIBSHP3K *.a -> *.sl library conversion script is now included +as /PERL/PUB/LIBSHP3K. + +=back + +November 20, 1998 + +=over 4 + +=item * + +Updated to version 5.005_02. + +=item * + +Fixed a DynaLoader bug that was unable to load symbols from relative +path name libraries. + +=item * + +Fixed a .xs compilation bug where the mpeixish.sh include file wasn't +being installed into the proper directory. + +=item * + +All bugfixes will be submitted back to the official Perl developers. + +=item * + +The current incarnation of the POSIX filename extended characters +patch is now MPEKXJ3A. + +=back + +August 14, 1998 + +=over 4 + +=item * + +The previous POSIX filename extended characters patch MPEKX44C has +been superseded by MPEKXB5A. + +=back + +August 7, 1998 + +=over 4 + +=item * + +The previous POSIX filename extended characters patch MPEKX76A has +been superseded by MPEKX44C. + +=over 4 + +=back + +July 28, 1998 + +=item * + +Updated to version 5.005_01. + +=back + +July 23, 1998 + +=over 4 + +=item * + +Updated to version 5.005 (production release). The public +freeware sources are now 100% MPE-ready "straight out of the box". + +=back + +July 17, 1998 + +=over 4 + +=item * + +Updated to version 5.005b1 (public beta release). The public +freeware sources are now 99.9% MPE-ready. By installing and +testing this beta on your own HP3000, you will be helping to +insure that the final release of 5.005 will be 100% MPE-ready and +100% bug free. + +=item * + +My MPE binary release is now extracted using my standard INSTALL script. + +=back + +July 15, 1998 + +=over 4 + +=item * + +Changed startperl to #!/PERL/PUB/perl so that Perl will recognize +scripts more easily and efficiently. + +=back + +July 8, 1998 + +=over 4 + +=item * + +Updated to version 5.004_70 (internal developer release) which is now +MPE-ready. The next public freeware release of Perl should compile +"straight out of the box" on MPE. Note that this version of Perl/iX +was strictly internal to me and never publicly released. Note that +[21]BIND/iX is now required (well, the include files and libbind.a) if +you wish to compile Perl/iX. + +=back + +November 6, 1997 + +=over 4 + +=item * + +Updated to version 5.004_04. No changes in MPE-specific functionality. + +=back + +October 16, 1997 + +=over 4 + +=item * + +Added Demos section to the Perl/iX home page so you can see some +sample Perl applications running on my 3000. + +=back + +October 3, 1997 + +=over 4 + +=item * + +Added System Requirements section to the Perl/iX home page just so the +prerequisites stand out more. Various other home page tweaks. + +=back + +October 2, 1997 + +=over 4 + +=item * + +Initial public release. + +=back + +September 1997 + +=over 4 + +=item * + +Porting begins. + +=back + +=head1 Author + +Mark Bixby, mark@bixby.org + diff --git a/README.os2 b/README.os2 index b46fa7a528..19af8c519d 100644 --- a/README.os2 +++ b/README.os2 @@ -115,7 +115,7 @@ Contents - Threads AUTHOR SEE ALSO - + =head1 DESCRIPTION =head2 Target @@ -394,12 +394,12 @@ is considered a bug and should be fixed soon. =over 4 -=item +=item * Did you run your programs with C<-w> switch? See L<Starting OS/2 (and DOS) programs under Perl>. -=item +=item * Do you try to run I<internal> shell commands, like C<`copy a b`> (internal for F<cmd.exe>), or C<`glob a*b`> (internal for ksh)? You @@ -1163,18 +1163,18 @@ eventually). =over 4 -=item +=item * Since L<flock(3)> is present in EMX, but is not functional, it is emulated by perl. To disable the emulations, set environment variable C<USE_PERL_FLOCK=0>. -=item +=item * Here is the list of things which may be "broken" on EMX (from EMX docs): -=over +=over 4 =item * @@ -1205,7 +1205,7 @@ L<waitpid(3)>: Note that C<kill -9> does not work with the current version of EMX. -=item +=item * Since F<sh.exe> is used for globing (see L<perlfunc/glob>), the bugs of F<sh.exe> plague perl as well. @@ -1517,9 +1517,9 @@ cannot test it. For the details of the current situation with calling external programs, see L<Starting OS/2 (and DOS) programs under Perl>. -=over +=over 4 -=item +=item * External scripts may be called by name. Perl will try the same extensions as when processing B<-S> command-line switch. @@ -1549,7 +1549,7 @@ preliminary. Most notable problems: -=over +=over 4 =item C<COND_WAIT> diff --git a/README.os390 b/README.os390 index 571d027687..8dd0483b2f 100644 --- a/README.os390 +++ b/README.os390 @@ -1,5 +1,6 @@ + This document is written in pod format hence there are punctuation -characters in in odd places. Do not worry, you've apparently got +characters in odd places. Do not worry, you've apparently got the ASCII->EBCDIC translation worked out correctly. You can read more about pod in pod/perlpod.pod or the short summary in the INSTALL file. @@ -15,12 +16,12 @@ on OS/390 Unix System Services. =head1 DESCRIPTION -This is a fully ported perl for OS/390 Release 3, 5 and 6. -It may work on other versions, but those are the ones we've -tested it on. +This is a fully ported Perl for OS/390 Version 2 Release 3, 5, 6, 7, +8, and 9. It may work on other versions or releases, but those are +the ones we've tested it on. You may need to carry out some system configuration tasks before -running the Configure script for perl. +running the Configure script for Perl. =head2 Unpacking @@ -41,12 +42,39 @@ parser template files. If you have not already done so then be sure to: This may also be a good time to ensure that your /etc/protocol file and either your /etc/resolv.conf or /etc/hosts files are in place. +The IBM document that described such USS system setup issues was +SC28-1890-07 "OS/390 UNIX System Services Planning", in particular +Chapter 6 on customizing the OE shell. -GNU make for OS/390, which may be required for the build of perl, -is available from: +GNU make for OS/390, which is required for the build of perl (as well as +building CPAN modules and extensions), is available from: http://www.mks.com/s390/gnu/index.htm +Some people have reported encountering "Out of memory!" errors while +trying to build Perl using GNU make binaries. If you encounter such +trouble then try to download the source code kit and build GNU make +from source to eliminate any such trouble. You might also find GNU make +(as well as Perl and Apache) in the red-piece/book "Open Source Software +for OS/390 UNIX", SG24-5944-00 from IBM. + +There is a syntax error in the /usr/include/sys/socket.h header file +that IBM supplies with USS V2R7, V2R8, and possibly V2R9. The problem with +the header file is that near the definition of the SO_REUSEPORT constant +there is a spurious extra '/' character outside of a comment like so: + + #define SO_REUSEPORT 0x0200 /* allow local address & port + reuse */ / + +You could edit that header yourself to remove that last '/', or you might +note that Language Environment (LE) APAR PQ39997 describes the problem +and PTF's UQ46272 and UQ46271 are the (R8 at least) fixes and apply them. +If left unattended that syntax error will turn up as an inability for Perl +to build its "Socket" extension. + +For successful testing you may need to turn on the sticky bit for your +world readable /tmp directory if you have not already done so (see man chmod). + =head2 Configure Once you've unpacked the distribution, run "sh Configure" (see INSTALL @@ -58,25 +86,83 @@ to watch out for include: =item * +A message of the form: + + (I see you are using the Korn shell. Some ksh's blow up on Configure, + mainly on older exotic systems. If yours does, try the Bourne shell instead.) + +is nothing to worry about at all. + +=item * + Some of the parser default template files in /samples are needed in /etc. In particular be sure that you at least copy /samples/yyparse.c to /etc -before running perl's Configure. This step ensures successful extraction -of EBCDIC versions of parser files such as perly.c. +before running Perl's Configure. This step ensures successful extraction +of EBCDIC versions of parser files such as perly.c. This has to be done +before running Configure the first time. If you failed to do so then the +easiest way to re-Configure Perl is to delete your misconfigured build root +and re extract the source from the tar ball. If for some reason you do not +want to do that then, after ensuring that /etc/yyparse.c is properly in place +run the following commands from within the Perl build directory: + + rm -f y.tab.c y.tab.h + yacc -d perly.y + mv -f y.tab.c perly.c + chmod u+w perly.c + sed -e '/^#include "perl\.h"/a\ + \ + #define yydebug PL_yydebug\ + #define yynerrs PL_yynerrs\ + #define yyerrflag PL_yyerrflag\ + #define yychar PL_yychar\ + #define yyval PL_yyval\ + #define yylval PL_yylval' \ + -e '/YYSTYPE *yyval;/D' \ + -e '/YYSTYPE *yylval;/D' \ + -e '/int yychar,/,/yynerrs;/D' \ + -e 's/int yydebug = 0;/yydebug = 0;/' \ + -e 's/[^_]realloc(/PerlMem_realloc(/g' \ + -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \ + -e 's/y\.tab/perly/g' perly.c >perly.tmp + mv -f perly.tmp perly.c + mv -f y.tab.h perly.h + cd x2p + rm -f y.tab.c y.tab.h + yacc a2p.y + mv -f y.tab.c a2p.c + chmod u+w a2p.c + sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \ + -e 's/y\.tab/a2p/g' a2p.c >a2p.tmp + mv -f a2p.tmp a2p.c + mv -f y.tab.h a2p.h + cd .. + +There, easy huh? If you find typing all that in difficult then perhaps +you should reconsider the rm -rf of the perl build directory and +re extraction of the source tar ball. =item * -This port doesn't support dynamic loading. Although -OS/390 has support for DLLs, there are some differences -that cause problems for perl. +This port doesn't support dynamic loading. Although OS/390 has support +for DLLs via dllload(), there are some differences that cause problems +for Perl. (We need a volunteer to write a ext/DynaLoader/dl_dllload.xs +file). =item * -You may see a "WHOA THERE!!!" message for $d_shmatprototype -it is OK to keep the recommended "define". +A message of the form: + + shmat() found. + and it returns (void *). + *** WHOA THERE!!! *** + The recommended value for $d_shmatprototype on this machine was "define"! + Keep the recommended value? [y] + +is nothing to worry about at all. =item * -Don't turn on the compiler optimization flag "-O". There's +Do not turn on the compiler optimization flag "-O". There is a bug in either the optimizer or perl that causes perl to not work correctly when the optimizer is on. @@ -85,7 +171,7 @@ not work correctly when the optimizer is on. Some of the configuration files in /etc used by the networking APIs are either missing or have the wrong names. In particular, make sure that there's either -an /etc/resolv.conf or and /etc/hosts, so that +an /etc/resolv.conf or an /etc/hosts, so that gethostbyname() works, and make sure that the file /etc/proto has been renamed to /etc/protocol (NOT /etc/protocols, as used by other Unix systems). @@ -100,7 +186,7 @@ Simply put: make make test -if everything looks ok then: +if everything looks ok (see the next section for test/IVP diagnosis) then: make install @@ -108,51 +194,168 @@ this last step may or may not require UID=0 privileges depending on how you answered the questions that Configure asked and whether or not you have write access to the directories you specified. +=head2 build anomalies + +"Out of memory!" messages during the build of Perl are most often fixed +by re building the GNU make utility for OS/390 from a source code kit. + +Another memory limiting item to check is your MAXASSIZE parameter in your +'SYS1.PARMLIB(BPXPRMxx)' data set (note too that as of V2R8 address space +limits can be set on a per user ID basis in the USS segment of a RACF +profile). People have reported successful builds of Perl with MAXASSIZE +parameters as small as 503316480 (and it may be possible to build Perl +with a MAXASSIZE smaller than that). + +Within USS your /etc/profile or $HOME/.profile may limit your ulimit +settings. Check that the following command returns reasonable values: + + ulimit -a + +To conserve memory you should have your compiler modules loaded into the +Link Pack Area (LPA/ELPA) rather than in a link list or step lib. + +If the c89 compiler complains of syntax errors during the build of the +Socket extension then be sure to fix the syntax error in the system +header /usr/include/sys/socket.h. + +=head2 testing anomalies + +The `make test` step runs a Perl Verification Procedure, usually before +installation. You might encounter STDERR messages even during a successful +run of `make test`. Here is a guide to some of the more commonly seen +anomalies: + +=over 4 + +=item * + +A message of the form: + + comp/cpp.............ERROR CBC3191 ./.301989890.c:1 The character $ is not a + valid C source character. + FSUM3065 The COMPILE step ended with return code 12. + FSUM3017 Could not compile .301989890.c. Correct the errors and try again. + ok + +indicates that the t/comp/cpp.t test of Perl's -P command line switch has +passed but that the particular invocation of c89 -E in the cpp script does +not suppress the C compiler check of source code validity. + +=item * + +A message of the form: + + io/openpid...........CEE5210S The signal SIGHUP was received. + CEE5210S The signal SIGHUP was received. + CEE5210S The signal SIGHUP was received. + ok + +indicates that the t/io/openpid.t test of Perl has passed but done so +with extraneous messages on stderr from CEE. + +=item * + +A message of the form: + + lib/ftmp-security....File::Temp::_gettemp: Parent directory (/tmp/) is not safe + (sticky bit not set when world writable?) at lib/ftmp-security.t line 100 + File::Temp::_gettemp: Parent directory (/tmp/) is not safe (sticky bit not + set when world writable?) at lib/ftmp-security.t line 100 + ok + +indicates a problem with the permissions on your /tmp directory within the HFS. +To correct that problem issue the command: + + chmod a+t /tmp + +from an account with write access to the directory entry for /tmp. + +=back + =head2 Usage Hints When using perl on OS/390 please keep in mind that the EBCDIC and ASCII -character sets are different. Perl builtin functions that may behave -differently under EBCDIC are mentioned in the perlport.pod document. +character sets are different. See perlebcdic.pod for more on such character +set issues. Perl builtin functions that may behave differently under +EBCDIC are also mentioned in the perlport.pod document. -OpenEdition (UNIX System Services) does not (yet) support the #! means -of script invocation. -See: +Open Edition (UNIX System Services) from V2R8 onward does support +#!/path/to/perl script invocation. There is a PTF available from +IBM for V2R7 that will allow shell/kernel support for #!. USS +releases prior to V2R7 did not support the #! means of script invocation. +If you are running V2R6 or earlier then see: head `whence perldoc` for an example of how to use the "eval exec" trick to ask the shell to -have perl run your scripts for you. +have Perl run your scripts on those older releases of Unix System Services. + +=head2 Modules and Extensions + +Pure pure (that is non xs) modules may be installed via the usual: + + perl Makefile.PL + make + make test + make install + +You can also build xs based extensions to Perl for OS/390 but will need +to follow the instructions in ExtUtils::MakeMaker for building +statically linked perl binaries. In the simplest configurations building +a static perl + xs extension boils down to: -=head2 Extensions + perl Makefile.PL + make + make perl + make test + make install + make -f Makefile.aperl inst_perl MAP_TARGET=perl -You can build xs based extensions to Perl for OS/390 but will need to -follow the instructions in ExtUtils::MakeMaker for building statically -linked perl binaries. In most cases people have reported better -results with GNU make rather than the system's /bin/make. +In most cases people have reported better results with GNU make rather +than the system's /bin/make program, whether for plain modules or for +xs based extensions. =head1 AUTHORS -David Fiander and Peter Prymmer. +David Fiander and Peter Prymmer with thanks to Dennis Longnecker +and William Raffloer for valuable reports, LPAR and PTF feedback. +Thanks to Mike MacIsaac and Egon Terwedow for SG24-5944-00. =head1 SEE ALSO -L<INSTALL>, L<perlport>, L<ExtUtils::MakeMaker>. +L<INSTALL>, L<perlport>, L<perlebcdic>, L<ExtUtils::MakeMaker>. + + http://www.mks.com/s390/gnu/index.htm + + http://www.redbooks.ibm.com/abstracts/sg245944.html + + http://www.s390.ibm.com/products/oe/bpxa1ty1.html#opensrc + + http://www.s390.ibm.com/products/oe/portbk/bpxacenv.html + + http://www.xray.mpe.mpg.de/mailing-lists/perl-mvs/ =head2 Mailing list The Perl Institute (http://www.perl.org/) maintains a perl-mvs mailing list of interest to all folks building and/or -using perl on EBCDIC platforms. To subscribe, send a message of: +using perl on all EBCDIC platforms (not just OS/390). +To subscribe, send a message of: subscribe perl-mvs -to majordomo@perl.org. +to majordomo@perl.org. There is a web archive of the mailing list at: + + http://www.xray.mpe.mpg.de/mailing-lists/perl-mvs/ =head1 HISTORY This document was originally written by David Fiander for the 5.005 release of Perl. -This document was podified for the 5.005_03 release of perl 11 March 1999. +This document was podified for the 5.005_03 release of Perl 11 March 1999. + +Updated 12 November 2000 for the 5.7.1 release of Perl. =cut + diff --git a/README.solaris b/README.solaris new file mode 100644 index 0000000000..97e84a3622 --- /dev/null +++ b/README.solaris @@ -0,0 +1,522 @@ +If you read this file _as_is_, just ignore the funny characters you +see. It is written in the POD format (see pod/perlpod.pod) which is +specifically designed to be readable as is. + +=head1 NAME + +README.solaris - Perl version 5 on Solaris systems + +=head1 DESCRIPTION + +This document describes various features of Sun's Solaris operating system +that will affect how Perl version 5 (hereafter just perl) is +compiled and/or runs. Some issues relating to the older SunOS 4.x are +also discussed, though they may be out of date. + +For the most part, everything should just work. + +Starting with Solaris 8, perl5.00503 (or higher) is supplied with the +operating system, so you might not even need to build a newer version +of perl at all. The Sun-supplied version is installed in /usr/perl5 +with /usr/bin/perl pointing to /usr/perl5/bin/perl. Do not disturb +that installation unless you really know what you are doing. If you +remove the perl supplied with the OS, there is a good chance you will +render some bits of your system inoperable. If you wish to install a +newer version of perl, install it under a different prefix from +/usr/perl5. Common prefixes to use are /usr/local and /opt/perl. + +You may wish to put your version of perl in the PATH of all users by +changing the link /usr/bin/perl. This is OK, as all Perl scripts +shipped with Solaris use /usr/perl5/bin/perl. + +=head2 Solaris Version Numbers. + +For consistency with common usage, perl's Configure script performs +some minor manipulations on the operating system name and version +number as reported by uname. Here's a partial translation table: + + Sun: perl's Configure: + uname uname -r Name osname osvers + SunOS 4.1.3 Solaris 1.1 sunos 4.1.3 + SunOS 5.6 Solaris 2.6 solaris 2.6 + SunOS 5.8 Solaris 8 solaris 2.8 + +The complete table can be found in the Sun Managers' FAQ +L<ftp://ftp.cs.toronto.edu/pub/jdd/sun-managers/faq> under +"9.1) Which Sun models run which versions of SunOS?". + +=head1 RESOURCES + +There are many, many source for Solaris information. A few of the +important ones for perl: + +=over 4 + +=item Solaris FAQ + +The Solaris FAQ is available at +L<http://www.science.uva.nl/pub/solaris/solaris2.html>. + +The Sun Managers' FAQ is available at +L<ftp://ftp.cs.toronto.edu/pub/jdd/sun-managers/faq> + +=item Precompiled Binaries + +Precompiled binaries, links to many sites, and much, much more is +available at L<http://www.sunfreeware.com>. + +=item Solaris Documentation + +All Solaris documentation is available on-line at L<http://docs.sun.com>. + +=back + +=head1 SETTING UP + +=head2 File Extraction Problems. + +Be sure to use a tar program compiled under Solaris (not SunOS 4.x) +to extract the perl-5.x.x.tar.gz file. Do not use GNU tar compiled +for SunOS4 on Solaris. (GNU tar compiled for Solaris should be fine.) +When you run SunOS4 binaries on Solaris, the run-time system magically +alters pathnames matching m#lib/locale# so that when tar tries to create +lib/locale.pm, a file named lib/oldlocale.pm gets created instead. +If you found this advice it too late and used a SunOS4-compiled tar +anyway, you must find the incorrectly renamed file and move it back +to lib/locale.pm. + +=head2 Compiler and Related Tools. + +You must use an ANSI C compiler to build perl. Perl can be compiled +with either Sun's add-on C compiler or with gcc. The C compiler that +shipped with SunOS4 will not do. + +=head3 Include /usr/ccs/bin/ in your PATH. + +Several tools needed to build perl are located in /usr/ccs/bin/: ar, +as, ld, and make. Make sure that /usr/ccs/bin/ is in your PATH. + +You need to make sure the following packages are installed +(this info is extracted from the Solaris FAQ): + +for tools (sccs, lex, yacc, make, nm, truss, ld, as): SUNWbtool, +SUNWsprot, SUNWtoo + +for libraries & headers: SUNWhea, SUNWarc, SUNWlibm, SUNWlibms, SUNWdfbh, +SUNWcg6h, SUNWxwinc, SUNWolinc + +for 64 bit development: SUNWarcx, SUNWbtoox, SUNWdplx, SUNWscpux, +SUNWsprox, SUNWtoox, SUNWlmsx, SUNWlmx, SUNWlibCx + +If you are in doubt which package contains a file you are missing, +try to find an installation that has that file. Then do a + + grep /my/missing/file /var/sadm/install/contents + +This will display a line like this: + +/usr/include/sys/errno.h f none 0644 root bin 7471 37605 956241356 SUNWhea + +The last item listed (SUNWhea in this example) is the package you need. + +=head3 Avoid /usr/ucb/cc. + +You don't need to have /usr/ucb/ in your PATH to build perl. If you +want /usr/ucb/ in your PATH anyway, make sure that /usr/ucb/ is NOT +in your PATH before the directory containing the right C compiler. + +=head3 Sun's C Compiler + +If you use Sun's C compiler, make sure the correct directory +(usually /opt/SUNWspro/bin/) is in your PATH (before /usr/ucb/). + +=head3 GCC + +If you use gcc, make sure your installation is recent and +complete. As a point of reference, perl-5.6.0 built fine with +gcc-2.8.1 on both Solaris 2.6 and Solaris 8. You'll be able to +Configure perl with + + sh Configure -Dcc=gcc + +If you have updated your Solaris version, you may also have to update +your GCC. For example, if you are running Solaris 2.6 and your gcc is +installed under /usr/local, check in /usr/local/lib/gcc-lib and make +sure you have the appropriate directory, sparc-sun-solaris2.6/ or +i386-pc-solaris2.6/. If gcc's directory is for a different version of +Solaris than you are running, then you will need to rebuild gcc for +your new version of Solaris. + +You can get a precompiled version of gcc from +L<http://www.sunfreeware.com/>. Make sure you pick up the package for +your Solaris release. + +=head3 GNU as and GNU ld + +The versions of as and ld supplied with Solaris work fine for building +perl. There is normally no need to install the GNU versions. + +If you decide to ignore this advice and use the GNU versions anyway, +then be sure that they are relatively recent. Versions newer than 2.7 +are apparently new enough. Older versions may have trouble with +dynamic loading. + +If your gcc is configured to use GNU as and ld but you want to use the +Solaris ones instead to build perl, then you'll need to add +-B/usr/ccs/bin/ to the gcc command line. One convenient way to do +that is with + + sh Configure -Dcc='gcc -B/usr/ccs/bin/' + +Note that the trailing slash is required. This will result in some +harmless warnings as Configure is run: + + gcc: file path prefix `/usr/ccs/bin/' never used + +These messages may safely be ignored. +(Note that for a SunOS4 system, you must use -B/bin/ instead.) + +Alternatively, you can use the GCC_EXEC_PREFIX environment variable to +ensure that Sun's as and ld are used. Consult your gcc documentation +for further information on the -B option and the GCC_EXEC_PREFIX variable. + +=head3 GNU make + +Sun's make works fine for building perl. +If you wish to use GNU make anyway, be sure that the set-group-id bit is not +set. If it is, then arrange your PATH so that /usr/ccs/bin/make is +before GNU make or else have the system administrator disable the +set-group-id bit on GNU make. + +=head3 Avoid libucb. + +Solaris provides some BSD-compatibility functions in /usr/ucblib/libucb.a. +Perl will not build and run correctly if linked against -lucb since it +contains routines that are incompatible with the standard Solaris libc. +Normally this is not a problem since the solaris hints file prevents +Configure from even looking in /usr/ucblib for libraries, and also +explicitly omits -lucb. + +=head2 Environment + +=head3 PATH + +Make sure your PATH includes the compiler (/opt/SUNWspro/bin/ if you're +using Sun's compiler) as well as /usr/ccs/bin/ to pick up the other +development tools (such as make, ar, as, and ld). Make sure your path +either doesn't include /usr/ucb or that it includes it after the +compiler and compiler tools and other standard Solaris directories. +You definitely don't want /usr/ucb/cc. + +=head3 LD_LIBRARY_PATH + +If you have the LD_LIBRARY_PATH environment variable set, be sure that +it does NOT include /lib or /usr/lib. If you will be building +extensions that call third-party shared libraries (e.g. Berkeley DB) +then make sure that your LD_LIBRARY_PATH environment variable includes +the directory with that library (e.g. /usr/local/lib). + +If you get an error message + + dlopen: stub interception failed + +it is probably because your LD_LIBRARY_PATH environment variable +includes a directory which is a symlink to /usr/lib (such as /lib). +The reason this causes a problem is quite subtle. The file +libdl.so.1.0 actually *only* contains functions which generate 'stub +interception failed' errors! The runtime linker intercepts links to +"/usr/lib/libdl.so.1.0" and links in internal implementations of those +functions instead. [Thanks to Tim Bunce for this explanation.] + +=head1 RUN CONFIGURE. + +See the INSTALL file for general information regarding Configure. +Only Solaris-specific issues are discussed here. Usually, the +defaults should be fine. + +=head2 64-bit Issues. + +See the INSTALL file for general information regarding 64-bit compiles. +In general, the defaults should be fine for most people. + +By default, perl-5.6.0 (or later) is compiled as a 32-bit application +with largefile and long-long support. + +=head3 General 32-bit vs. 64-bit issues. + +Solaris 7 and above will run in either 32 bit or 64 bit mode on SPARC +CPUs, via a reboot. You can build 64 bit apps whilst running 32 bit +mode and vice-versa. 32 bit apps will run under Solaris running in +either 32 or 64 bit mode. 64 bit apps require Solaris to be running +64 bit mode. + +Existing 32 bit apps are properly known as LP32, i.e. Longs and +Pointers are 32 bit. 64-bit apps are more properly known as LP64. +The discriminating feature of a LP64 bit app is its ability to utilise a +64-bit address space. It is perfectly possible to have a LP32 bit app +that supports both 64-bit integers (long long) and largefiles (> 2GB), +and this is the default for perl-5.6.0. + +For a more complete explanation of 64-bit issues, see the Solaris 64-bit +Developer's Guide at http://docs.sun.com:80/ab2/coll.45.13/SOL64TRANS/ + +You can detect the OS mode using "isainfo -v", e.g. + + fubar$ isainfo -v # Ultra 30 in 64 bit mode + 64-bit sparcv9 applications + 32-bit sparc applications + +By default, perl will be compiled as a 32-bit application. Unless you +want to allocate more than ~ 4GB of memory inside Perl, you probably +don't need Perl to be a 64-bit app. + +=head3 Large File Suppprt + +For Solaris 2.6 and onwards, there are two different ways for 32-bit +applications to manipulate large files (files whose size is > 2GByte). +(A 64-bit application automatically has largefile support built in +by default.) + +First is the "transitional compilation environment", described in +lfcompile64(5). According to the man page, + + The transitional compilation environment exports all the + explicit 64-bit functions (xxx64()) and types in addition to + all the regular functions (xxx()) and types. Both xxx() and + xxx64() functions are available to the program source. A + 32-bit application must use the xxx64() functions in order + to access large files. See the lf64(5) manual page for a + complete listing of the 64-bit transitional interfaces. + +The transitional compilation environment is obtained with the +following compiler and linker flags: + + getconf LFS64_CFLAGS -D_LARGEFILE64_SOURCE + getconf LFS64_LDFLAG # nothing special needed + getconf LFS64_LIBS # nothing special needed + +Second is the "large file compilation environment", described in +lfcompile(5). According to the man page, + + Each interface named xxx() that needs to access 64-bit entities + to access large files maps to a xxx64() call in the + resulting binary. All relevant data types are defined to be + of correct size (for example, off_t has a typedef definition + for a 64-bit entity). + + An application compiled in this environment is able to use + the xxx() source interfaces to access both large and small + files, rather than having to explicitly utilize the transitional + xxx64() interface calls to access large files. + +Two exceptions are fseek() and ftell(). 32-bit applications should +use fseeko(3C) and ftello(3C). These will get automatically mapped +to fseeko64() and ftello64(). + +The large file compilation environment is obtained with + + getconf LFS_CFLAGS -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 + getconf LFS_LDFLAGS # nothing special needed + getconf LFS_LIBS # nothing special needed + +By default, perl uses the large file compilation environment and +relies on Solaris to do the underlying mapping of interfaces. + +=head3 Building an LP64 Perl + +To compile a 64-bit application on an UltraSparc with a recent Sun Compiler, +you need to use the flag "-xarch=v9". getconf(1) will tell you this, e.g. + + fubar$ getconf -a | grep v9 + XBS5_LP64_OFF64_CFLAGS: -xarch=v9 + XBS5_LP64_OFF64_LDFLAGS: -xarch=v9 + XBS5_LP64_OFF64_LINTFLAGS: -xarch=v9 + XBS5_LPBIG_OFFBIG_CFLAGS: -xarch=v9 + XBS5_LPBIG_OFFBIG_LDFLAGS: -xarch=v9 + XBS5_LPBIG_OFFBIG_LINTFLAGS: -xarch=v9 + _XBS5_LP64_OFF64_CFLAGS: -xarch=v9 + _XBS5_LP64_OFF64_LDFLAGS: -xarch=v9 + _XBS5_LP64_OFF64_LINTFLAGS: -xarch=v9 + _XBS5_LPBIG_OFFBIG_CFLAGS: -xarch=v9 + _XBS5_LPBIG_OFFBIG_LDFLAGS: -xarch=v9 + _XBS5_LPBIG_OFFBIG_LINTFLAGS: -xarch=v9 + +This flag is supported in Sun WorkShop Compilers 5.0 and onwards +(now marketed under the name Forte) when used on Solaris 7 or later on +UltraSparc systems. + +If you are using gcc, you would need to use -mcpu=v9 -m64 instead. This +option is not yet supported as of gcc 2.95.2; from install/SPECIFIC +in that release: + +GCC version 2.95 is not able to compile code correctly for sparc64 +targets. Users of the Linux kernel, at least, can use the sparc32 +program to start up a new shell invocation with an environment that +causes configure to recognize (via uname -a) the system as sparc-*-* +instead. + +All this should be handled automatically by the hints file, if +requested. + +If you do want to be able to allocate more than 4GB memory inside +perl, then you should use the Solaris malloc, since the perl +malloc breaks when dealing with more than 2GB of memory. You can do +this with + + sh Configure -Uusemymalloc + +=head3 Long Doubles. + +As of 5.6.0, long doubles are not working. + +=head2 Threads. + +It is possible to build a threaded version of perl on Solaris. The entire +perl thread implementation is still experimental, however, so beware. +Perl uses the sched_yield(3RT) function. In versions of Solaris up +to 2.6, that function is in -lposix4. Starting with Solaris 7, it is +in -lrt. The hints file should handle adding this automatically. + +=head2 Malloc Issues. + +You should not use perl's malloc if you are building with gcc. There +are reports of core dumps, especially in the PDL module. The problem +appears to go away under -DDEBUGGING, so it has been difficult to +track down. Sun's compiler appears to be ok with or without perl's +malloc. [XXX further investigation is needed here.] + +You should also not use perl's malloc if you are building perl as +an LP64 application, since perl's malloc has trouble allocating more +than 2GB of memory. + +You can avoid perl's malloc by Configuring with + + sh Configure -Uusemymalloc + +[XXX Update hints file.] + +=head1 MAKE PROBLEMS. + +=over 4 + +=item Dynamic Loading Problems With GNU as and GNU ld + +If you have problems with dynamic loading using gcc on SunOS or +Solaris, and you are using GNU as and GNU ld, see the section +L<"GNU as and GNU ld"> above. + +=item ld.so.1: ./perl: fatal: relocation error: + +If you get this message on SunOS or Solaris, and you're using gcc, +it's probably the GNU as or GNU ld problem in the previous item +L<"GNU as and GNU ld">. + +=item dlopen: stub interception failed + +The primary cause of the 'dlopen: stub interception failed' message is +that the LD_LIBRARY_PATH environment variable includes a directory +which is a symlink to /usr/lib (such as /lib). See +L<"LD_LIBRARY_PATH"> above. + +=item #error "No DATAMODEL_NATIVE specified" + +This is a common error when trying to build perl on Solaris 2.6 with a +gcc installation from Solaris 2.5 or 2.5.1. The Solaris header files +changed, so you need to update your gcc installation. You can either +rerun the fixincludes script from gcc or take the opportunity to +update your gcc installation. + +=item sh: ar: not found + +This is a message from your shell telling you that the command 'ar' +was not found. You need to check your PATH environment variable to +make sure that it includes the directory with the 'ar' command. This +is a common problem on Solaris, where 'ar' is in the /usr/ccs/bin/ +directory. + +=back + +=head1 MAKE TEST + +=head2 op/stat.t test 4 + +op/stat.t test 4 may fail if you are on a tmpfs of some sort. +Building in /tmp sometimes shows this behavior. The +test suite detects if you are building in /tmp, but it may not be able +to catch all tmpfs situations. + +=head1 PREBUILT BINARIES. + +You can pick up prebuilt binaries for Solaris from +L<http://www.sunfreeware.com/>, ActiveState L<http://www.activestate.com/>, +and L<http://www.perl.com/> under the Binaries list at the top of the page. +There are probably other sources as well. Please note that these sites +are under the control of their respective owners, not the perl developers. + +=head1 RUNTIME ISSUES. + +=head2 Limits on Numbers of Open Files. + +The stdio(3C) manpage notes that only 255 files may be opened using +fopen(), and only file descriptors 0 through 255 can be used in a +stream. Since perl calls open() and then fdopen(3C) with the +resulting file descriptor, perl is limited to 255 simultaneous open +files. + +=head1 SOLARIS-SPECIFIC MODULES. + +See the modules under the Solaris:: namespace on CPAN, +L<http://www.cpan.org/modules/by-module/Solaris/>. + +=head1 SOLARIS-SPECIFIC PROBLEMS WITH MODULES. + +=head2 Proc::ProcessTable + +Proc::ProcessTable does not compile on Solaris with perl5.6.0 and higher +if you have LARGEFILES defined. Since largefile support is the +default in 5.6.0 and later, you have to take special steps to use this +module. + +The problem is that various structures visible via procfs use off_t, +and if you compile with largefile support these change from 32 bits to +64 bits. Thus what you get back from procfs doesn't match up with +the structures in perl, resulting in garbage. See proc(4) for further +discussion. + +A fix for Proc::ProcessTable is to edit Makefile to +explicitly remove the largefile flags from the ones MakeMaker picks up +from Config.pm. This will result in Proc::ProcessTable being built +under the correct environment. Everything should then be OK as long as +Proc::ProcessTable doesn't try to share off_t's with the rest of perl, +or if it does they should be explicitly specified as off64_t. + +=head2 BSD::Resource + +BSD::Resource versions earlier than 1.09 do not compile on Solaris +with perl 5.6.0 and higher, for the same reasons as Proc::ProcessTable. +BSD::Resource versions starting from 1.09 have a workaround for the problem. + +=head2 Net::SSLeay + +Net::SSLeay requires a /dev/urandom to be present. This device is not +part of Solaris. You can either get the package SUNWski (packaged with +several Sun software products, for example the Sun WebServer, which is +part of the Solaris Server Intranet Extension, or the Sun Directory +Services, part of Solaris for ISPs) or download the ANDIrand package +from L<http://www.cosy.sbg.ac.at/~andi/>. If you use SUNWski, make a +symbolic link /dev/urandom pointing to /dev/random. + +It may be possible to use the Entropy Gathering Daemon (written in +Perl!), available from L<http://www.lothar.com/tech/crypto/>. + +=head1 AUTHOR + +The original was written by Andy Dougherty F<doughera@lafayette.edu> +drawing heavily on advice from Alan Burlison, Nick Ing-Simmons, Tim Bunce, +and many other Solaris users over the years. + +Please report any errors, updates, or suggestions to F<perlbug@perl.org>. + +=head1 LAST MODIFIED + +$Id: README.solaris,v 1.4 2000/11/11 20:29:58 doughera Exp $ diff --git a/README.vos b/README.vos index 99abf0d6c5..b44f3cf9f0 100644 --- a/README.vos +++ b/README.vos @@ -1,128 +1,189 @@ -Perl 5 README file for the Stratus VOS operating system. -Paul Green (Paul_Green@stratus.com) -February 3, 2000 +If you read this file _as_is_, just ignore the funny characters you +see. It is written in the POD format (see pod/perlpod.pod) which is +specially designed to be readable as is. + +=head1 NAME + +README.vos - Perl for Stratus VOS + +=head1 SYNOPSIS +This is a port of Perl version 5, revision 7, to VOS. Perl is a +scripting or macro language that is popular on many systems. See your +local computer bookstore for a number of good books on Perl. -Introduction ------------- -This is a port of Perl version 5, revision 005-63, to VOS. Perl -is a scripting or macro language that is popular on many -systems. See your local computer bookstore for a number of good -books on Perl. +=head2 Stratus POSIX Support -Most of the Perl features should work on VOS. However, any +Note that there are two different implementations of POSIX.1 +support on VOS. There is an alpha version of POSIX that is +available from the Stratus anonymous ftp site +(ftp://ftp.stratus.com/pub/vos/posix/alpha/alpha.html). There +is a generally-available version of POSIX that comes with the +VOS Standard C compiler and C runtime in VOS Release 14.3.0 or +higher. This port of POSIX will compile and bind with either +version of POSIX. + +Most of the Perl features should work on VOS regardless of which +version of POSIX that you are using. However, the alpha version +of POSIX is missing a number of key functions, and therefore any attempt by perl.pm to call the following unimplemented POSIX functions will result in an error message and an immediate and fatal call to the VOS debugger. They are "dup", "fork", and "waitpid". The lack of these functions pretty much prevents you from starting VOS commands and grabbing their output in perl. The workaround is to run the commands outside of perl, then have -perl process the output file. +perl process the output file. These functions are all available +in the generally-available version of POSIX. + +=head1 INSTALLING PERL IN VOS +=head2 Compiling Perl 5 on VOS -Compiling Perl 5 on VOS ------------------------ Before you can build Perl 5 on VOS, you need to have or acquire the following additional items. -1. The VOS Standard C Compiler and Runtime, or the VOS Standard C - Cross-Compiler. This is a standard Stratus product. +=over 5 + +=item 1 + +The VOS Standard C Compiler and Runtime, or the VOS Standard C +Cross-Compiler. This is a standard Stratus product. -2. The VOS OS TCP/IP product set. While the necessary header - files are included with VOS POSIX.1, you still need the - appropriate object files in order to bind perl.pm. This is - a standard Stratus product. +=item 2 -3. The VOS POSIX.1 environment. As of this writing, this is - available on the VOS FTP site. Login anonymously to - ftp.stratus.com and get the file - /pub/vos/alpha/posix.save.evf.gz in binary file-transfer - mode. Or use the Uniform Resource Locator (URL) - ftp://ftp.stratus.com/pub/vos/alpha/posix.save.evf.gz from - your web browser. This is not a standard Stratus product. +Either the VOS OS TCP/IP or STCP product set. If you are +building with the alpha version of POSIX you need the OS +TCP/IP product set. If you are building with the +generally-available version of POSIX you need the STCP +product set. These are standard Stratus products. - Instructions for unbundling this file are at - ftp://ftp.stratus.com/pub/vos/utility/utility.html. +=item 3 -4. You must compile this version of Perl 5 on VOS Release - 14.1.0 or higher because some of the perl source files - contain more than 32,767 source lines. Due to VOS - release-compatibility rules, this port of perl may not - execute on VOS Release 12 or earlier. +Either the alpha or generally-available version of the VOS +POSIX.1 environment. + +The alpha version of POSIX.1 support is available on the +Stratus FTP site. Login anonymously to ftp.stratus.com and +get the file /pub/vos/posix/alpha/posix.save.evf.gz in +binary file-transfer mode. Or use the Uniform Resource +Locator (URL) +ftp://ftp.stratus.com/pub/vos/alpha/posix.save.evf.gz from +your web browser. Instructions for unbundling this file +are at ftp://ftp.stratus.com/pub/vos/utility/utility.html. +This is not a standard Stratus product. + +The generally-available version of POSIX.1 support is +bundled with the VOS Standard C compiler and Runtime (or +Cross-Compiler) in VOS Release 14.3.0 or higher. This is a +standard Stratus product. + +=item 4 + +You must compile this version of Perl 5 on VOS Release +14.1.0 or higher because some of the perl source files +contain more than 32,767 source lines. Due to VOS +release-compatibility rules, this port of perl may not +execute on VOS Release 12 or earlier. + +=back To build perl 5, change to the "vos" subdirectory and type the command "compile_perl -processor X", where X is the processor type (mc68020, i80860, pa7100, pa8000) that you wish to use. +Note that the generally-available version of POSIX.1 support is +not available for the mc68020 or i80860 processors. + +You must have purchased the VOS Standard C Cross Compiler in +order to compile perl for a processor type that is different +from the processor type of the module. + Note that code compiled for the pa7100 processor type can -execute on the PA7100, PA8000, and PA8500 processors, and that -code compiled for the pa8000 processor type can execute on the -PA8000 and PA8500 processors. +execute on the PA7100, PA8000, PA8500 and PA8600 processors, and +that code compiled for the pa8000 processor type can execute on +the PA8000, PA8500 and PA8600 processors. +=head2 Installing Perl 5 on VOS -Installing Perl 5 on VOS ------------------------- -1. Create the directory >system>ported>command_library. +=over 4 -2. Copy the appropriate version of the perl program module to - this directory. For example, with your current directory - set to the top-level directory of Perl 5, to install the - executable program module for the Motorola 68K - architecture, enter: +=item 1 + +Create the directory >system>ported>command_library. + +=item 2 + +Copy the appropriate version of the perl program module to +this directory. For example, with your current directory +set to the top-level directory of Perl 5, to install the +executable program module for the Motorola 68K +architecture, enter: !copy_file vos>obj>perl.pm >system>ported>command_library>* - (If you wish to use both Perl version 4 and Perl version 5, - you must give them different names; for example, perl.pm - and perl5.pm). +(If you wish to use both Perl version 4 and Perl version 5, +you must give them different names; for example, perl.pm +and perl5.pm). + +=item 3 + +Create the directory >system>ported>perl>lib. + +=item 4 + +Copy all of the files and subdirectories from the lib +subdirectory into this new directory. For example, with +the current directory set to the top-level directory of the +perl distribution, enter: + + !copy_dir lib >system>ported>perl>lib>5.7 -3. Create the directory >system>ported>perl>lib. +=item 5 -4. Copy all of the files and subdirectories from the lib - subdirectory into this new directory. For example, with - the current directory set to the top-level directory of the - perl distribution, enter: +While there are currently no architecture-specific +extensions or modules distributed with perl, the following +directories can be used to hold such files: - !copy_dir lib >system>ported>perl>lib>5.005 + >system>ported>perl>lib>5.7.68k + >system>ported>perl>lib>5.7.860 + >system>ported>perl>lib>5.7.7100 + >system>ported>perl>lib>5.7.8000 -5. While there are currently no architecture-specific - extensions or modules distributed with perl, the following - directories can be used to hold such files: +=item 6 - >system>ported>perl>lib>5.005.68k - >system>ported>perl>lib>5.005.860 - >system>ported>perl>lib>5.005.7100 - >system>ported>perl>lib>5.005.8000 +Site-specific perl extensions and modules can be installed in one of +two places. Put architecture-independent files into: -6. Site-specific perl extensions and modules can be installed - in one of two places. Put architecture-independent files - into: + >system>ported>perl>lib>site>5.7 - >system>ported>perl>lib>site>5.005 +Put architecture-dependent files into one of the following +directories: - Put architecture-dependent files into one of the following - directories: + >system>ported>perl>lib>site>5.7.68k + >system>ported>perl>lib>site>5.7.860 + >system>ported>perl>lib>site>5.7.7100 + >system>ported>perl>lib>site>5.7.8000 - >system>ported>perl>lib>site>5.005.68k - >system>ported>perl>lib>site>5.005.860 - >system>ported>perl>lib>site>5.005.7100 - >system>ported>perl>lib>site>5.005.8000 +=item 7 -7. You can examine the @INC variable from within a perl program - to see the order in which Perl searches these directories. +You can examine the @INC variable from within a perl program +to see the order in which Perl searches these directories. +=back -Unimplemented Features ----------------------- -If Perl 5 attempts to call an unimplemented VOS POSIX.1 function, -it will print a fatal error message and enter the VOS debugger. -This error is not recoverable. See vos_dummies.c for a list of -the unimplemented POSIX.1 functions. To see what functions are -unimplemented and what the error message looks like, compile and -execute "test_vos_dummies.c". +=head1 USING PERL IN VOS +=head2 Unimplemented Features + +If perl is built with the alpha version of VOS POSIX.1 support +and if it attempts to call an unimplemented VOS POSIX.1 +function, it will print a fatal error message and enter the VOS +debugger. This error is not recoverable. See vos_dummies.c for +a list of the unimplemented POSIX.1 functions. To see what +functions are unimplemented and what the error message looks +like, compile and execute "test_vos_dummies.c". + +=head2 Restrictions -Restrictions ------------- This port of Perl version 5 to VOS prefers Unix-style, slash-separated pathnames over VOS-style greater-than-separated pathnames. VOS-style pathnames should work in most contexts, but @@ -139,13 +200,19 @@ supported epoch is January 1, 1980 to January 17, 2038. See the file pod/perlport.pod for more information about the VOS port of Perl. +=head1 SUPPORT STATUS -Support Status --------------- I'm offering this port "as is". You can ask me questions, but I -can't guarantee I'll be able to answer them; I don't know much -about Perl itself; I'm still learning that. There are some +can't guarantee I'll be able to answer them. There are some excellent books available on the Perl language; consult a book seller. -(end) +=head1 AUTHOR + +Paul Green (Paul_Green@stratus.com) + +=head1 LAST UPDATE + +October 24, 2000 + +=cut diff --git a/README.win32 b/README.win32 index 8e29accdbb..ddc1f847a6 100644 --- a/README.win32 +++ b/README.win32 @@ -14,7 +14,7 @@ These are instructions for building Perl under Windows (9x, NT and =head1 DESCRIPTION Before you start, you should glance through the README file -found in the top-level directory where the Perl distribution +found in the top-level directory to which the Perl distribution was extracted. Make sure you read and understand the terms under which this software is being distributed. @@ -28,10 +28,10 @@ particular, you can safely ignore any information that talks about You may also want to look at two other options for building a perl that will work on Windows NT: the README.cygwin and -README.os2 files, which each give a different set of rules to build -a Perl that will work on Win32 platforms. Those two methods will -probably enable you to build a more Unix-compatible perl, but you -will also need to download and use various other build-time and +README.os2 files, each of which give a different set of rules to +build a Perl that will work on Win32 platforms. Those two methods +will probably enable you to build a more Unix-compatible perl, but +you will also need to download and use various other build-time and run-time support software described in those files. This set of instructions is meant to describe a so-called "native" @@ -70,9 +70,9 @@ A port of dmake for Windows is available from: http://www.cpan.org/authors/id/GSAR/dmake-4.1pl1-win32.zip -(This is a fixed version of original dmake sources obtained from +(This is a fixed version of the original dmake sources obtained from http://www.wticorp.com/dmake/. As of version 4.1PL1, the original -sources did not build as shipped, and had various other problems. +sources did not build as shipped and had various other problems. A patch is included in the above fixed version.) Fetch and install dmake somewhere on your path (follow the instructions @@ -97,20 +97,20 @@ build usually works in this circumstance, but some tests will fail. =item Borland C++ If you are using the Borland compiler, you will need dmake. -(The make that Borland supplies is seriously crippled, and will not +(The make that Borland supplies is seriously crippled and will not work for MakeMaker builds.) -See L/"Make"> above. +See L</"Make"> above. =item Microsoft Visual C++ The nmake that comes with Visual C++ will suffice for building. -You will need to run the VCVARS32.BAT file usually found somewhere +You will need to run the VCVARS32.BAT file, usually found somewhere like C:\MSDEV4.2\BIN. This will set your build environment. -You can also use dmake to build using Visual C++, provided: +You can also use dmake to build using Visual C++; provided, however, you set OSRELEASE to "microsft" (or whatever the directory name -under which the Visual C dmake configuration lives) in your environment, +under which the Visual C dmake configuration lives) in your environment and edit win32/config.vc to change "make=nmake" into "make=dmake". The latter step is only essential if you want to use dmake as your default make for building extensions using MakeMaker. @@ -125,7 +125,7 @@ The GCC-2.95.2 bundle comes with Mingw32 libraries and headers. Make sure you install the binaries that work with MSVCRT.DLL as indicated in the README for the GCC bundle. You may need to set up a few environment -variables (usually run from a batch file). +variables (usually ran from a batch file). The version of gcc-2.95.2-msvcrt.exe released 7 November 1999 left out a fix for certain command line quotes, so be sure to download and install @@ -149,12 +149,12 @@ makefile are setup to build using the GCC compiler. =item * -Edit the makefile.mk (or Makefile, if using nmake) and change the values -of INST_DRV and INST_TOP. You can also enable various build -flags. These are explained in the makefiles. +Edit the makefile.mk (or Makefile, if you're using nmake) and change +the values of INST_DRV and INST_TOP. You can also enable various +build flags. These are explained in the makefiles. -You will have to make sure CCTYPE is set correctly, and CCHOME points -to wherever you installed your compiler. +You will have to make sure that CCTYPE is set correctly and that +CCHOME points to wherever you installed your compiler. The default value for CCHOME in the makefiles for Visual C++ may not be correct for some versions. Make sure the default exists @@ -165,7 +165,7 @@ enable the appropriate option in the makefile. des_fcrypt() is not bundled with the distribution due to US Government restrictions on the export of cryptographic software. Nevertheless, this routine is part of the "libdes" library (written by Eric Young) which is widely -available worldwide, usually along with SSLeay (for example: +available worldwide, usually along with SSLeay (for example, "ftp://fractal.mta.ca/pub/crypto/SSLeay/DES/"). Set CRYPT_SRC to the name of the file that implements des_fcrypt(). Alternatively, if you have built a library that contains des_fcrypt(), you can set @@ -212,7 +212,7 @@ If you're using the Borland compiler, you may see a failure in op/taint.t arising from the inability to find the Borland Runtime DLLs on the system default path. You will need to copy the DLLs reported by the messages from where Borland chose to install it, into the Windows system directory -(usually somewhere like C:\WINNT\SYSTEM32), and rerun the test. +(usually somewhere like C:\WINNT\SYSTEM32) and rerun the test. Please report any other failures as described under L<BUGS AND CAVEATS>. @@ -224,7 +224,7 @@ Makefile. It will also install the pod documentation under C<$INST_TOP\$VERSION\lib\pod> and HTML versions of the same under C<$INST_TOP\$VERSION\lib\pod\html>. To use the Perl you just installed, you will need to add two components to your PATH environment variable, -C<$INST_TOP\$VERSION\bin>, and C<$INST_TOP\$VERSION\bin\$ARCHNAME>. +C<$INST_TOP\$VERSION\bin> and C<$INST_TOP\$VERSION\bin\$ARCHNAME>. For example: set PATH c:\perl\5.6.0\bin;c:\perl\5.6.0\bin\MSWin32-x86;%PATH% @@ -301,24 +301,28 @@ runtime do any wildcard expansions of command-line arguments (so wildcards need not be quoted). Also, the quoting behaviours of the shell and the C runtime are rudimentary at best (and may, if you are using a non-standard shell, be inconsistent). The only (useful) quote -character is the double quote ("). It can be used to protect spaces in -arguments and other special characters. The Windows NT documentation -has almost no description of how the quoting rules are implemented, but -here are some general observations based on experiments: The C runtime -breaks arguments at spaces and passes them to programs in argc/argv. -Doublequotes can be used to prevent arguments with spaces in them from -being split up. You can put a double quote in an argument by escaping -it with a backslash and enclosing the whole argument within double -quotes. The backslash and the pair of double quotes surrounding the -argument will be stripped by the C runtime. +character is the double quote ("). It can be used to protect spaces +and other special characters in arguments. + +The Windows NT documentation has almost no description of how the +quoting rules are implemented, but here are some general observations +based on experiments: The C runtime breaks arguments at spaces and +passes them to programs in argc/argv. Double quotes can be used to +prevent arguments with spaces in them from being split up. You can +put a double quote in an argument by escaping it with a backslash and +enclosing the whole argument within double quotes. The backslash and +the pair of double quotes surrounding the argument will be stripped by +the C runtime. The file redirection characters "<", ">", and "|" can be quoted by double quotes (although there are suggestions that this may not always -be true). Single quotes are not treated as quotes by the shell or the C -runtime. The caret "^" has also been observed to behave as a quoting -character, but this appears to be a shell feature, and the caret is not -stripped from the command line, so Perl still sees it (and the C runtime -phase does not treat the caret as a quote character). +be true). Single quotes are not treated as quotes by the shell or +the C runtime, they don't get stripped by the shell (just to make +this type of quoting completely useless). The caret "^" has also +been observed to behave as a quoting character, but this appears +to be a shell feature, and the caret is not stripped from the command +line, so Perl still sees it (and the C runtime phase does not treat +the caret as a quote character). Here are some examples of usage of the "cmd" shell: @@ -386,12 +390,12 @@ be built, tested and installed with the standard mantra: where $MAKE is whatever 'make' program you have configured perl to use. Use "perl -V:make" to find out what this is. Some extensions -may not provide a testsuite (so "$MAKE test" may not do anything, or +may not provide a testsuite (so "$MAKE test" may not do anything or fail), but most serious ones do. It is important that you use a supported 'make' program, and ensure Config.pm knows about it. If you don't have nmake, you can -either get dmake from the location mentioned earlier, or get an +either get dmake from the location mentioned earlier or get an old version of nmake reportedly available from: ftp://ftp.microsoft.com/Softlib/MSLFILES/nmake15.exe @@ -439,11 +443,11 @@ be a source of frustration if you use such a perl binary with an alternate shell that *does* expand wildcards. Instead, the following solution works rather well. The nice things -about it: 1) you can start using it right away 2) it is more powerful, -because it will do the right thing with a pattern like */*/*.c -3) you can decide whether you do/don't want to use it 4) you can -extend the method to add any customizations (or even entirely -different kinds of wildcard expansion). +about it are 1) you can start using it right away; 2) it is more +powerful, because it will do the right thing with a pattern like +*/*/*.c; 3) you can decide whether you do/don't want to use it; and +4) you can extend the method to add any customizations (or even +entirely different kinds of wildcard expansion). C:\> copy con c:\perl\lib\Wild.pm # Wild.pm - emulate shell @ARGV expansion on shells that don't @@ -485,7 +489,7 @@ from CPAN. You may find that many of these extensions are meant to be used under the Activeware port of Perl, which used to be the only native port for the Win32 platform. Since the Activeware port does not have adequate support for Perl's extension building tools, these -extensions typically do not support those tools either, and therefore +extensions typically do not support those tools either and, therefore, cannot be built using the generic steps shown in the previous section. To ensure smooth transitioning of existing code that uses the @@ -541,7 +545,7 @@ If you use the 4DOS/NT or similar command shell, note that refer to all the command line arguments, so you may need to make sure that construct works in batch files. As of this writing, 4DOS/NT users will need a "ParameterChar = *" statement in their -4NT.INI file, or will need to execute "setdos /p*" in the 4DOS/NT +4NT.INI file or will need to execute "setdos /p*" in the 4DOS/NT startup file to enable this to work. =item 3 @@ -591,11 +595,25 @@ find a mailer on your system). =head1 BUGS AND CAVEATS +Norton AntiVirus interferes with the build process, particularly if +set to "AutoProtect, All Files, when Opened". Unlike large applications +the perl build process opens and modifies a lot of files. Having the +the AntiVirus scan each and every one slows build the process significantly. +Worse, with PERLIO=stdio the build process fails with peculiar messages +as the virus checker interacts badly with miniperl.exe writing configure +files (it seems to either catch file part written and treat it as suspicious, +or virus checker may have it "locked" in a way which inhibits miniperl +updating it). The build does complete with + + set PERLIO=perlio + +but that may be just luck. Other AntiVirus software may have similar issues. + Some of the built-in functions do not act exactly as documented in L<perlfunc>, and a few are not implemented at all. To avoid surprises, particularly if you have had prior exposure to Perl in other operating environments or if you intend to write code -that will be portable to other environments, see L<perlport> +that will be portable to other environments. See L<perlport> for a reasonably definitive list of these differences. Not all extensions available from CPAN may build or work properly @@ -620,11 +638,11 @@ by C<perl -V>. =over 4 -Gary Ng E<lt>71564.1743@CompuServe.COME<gt> +=item Gary Ng E<lt>71564.1743@CompuServe.COME<gt> -Gurusamy Sarathy E<lt>gsar@activestate.comE<gt> +=item Gurusamy Sarathy E<lt>gsar@activestate.comE<gt> -Nick Ing-Simmons E<lt>nick@ni-s.u-net.comE<gt> +=item Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt> =back @@ -651,6 +669,6 @@ Support for fork() emulation was added in 5.6 (ActiveState Tool Corp). Win9x support was added in 5.6 (Benjamin Stuhl). -Last updated: 22 March 2000 +Last updated: 22 November 2000 =cut @@ -1,6 +1,6 @@ /* av.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -34,10 +34,8 @@ Perl_av_reify(pTHX_ AV *av) while (key) { sv = AvARRAY(av)[--key]; assert(sv); - if (sv != &PL_sv_undef) { - dTHR; + if (sv != &PL_sv_undef) (void)SvREFCNT_inc(sv); - } } key = AvARRAY(av) - AvALLOC(av); while (key) @@ -58,7 +56,6 @@ extended. void Perl_av_extend(pTHX_ AV *av, I32 key) { - dTHR; /* only necessary if we have to extend stack */ MAGIC *mg; if ((mg = SvTIED_mg((SV*)av, 'P'))) { dSP; @@ -189,7 +186,6 @@ Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval) if (SvRMAGICAL(av)) { if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) { - dTHR; sv = sv_newmortal(); mg_copy((SV*)av, sv, 0, key); PL_av_fetch_sv = sv; @@ -272,7 +268,6 @@ Perl_av_store(pTHX_ register AV *av, I32 key, SV *val) ary = AvARRAY(av); if (AvFILLp(av) < key) { if (!AvREAL(av)) { - dTHR; if (av == PL_curstack && key > PL_stack_sp - PL_stack_base) PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */ do @@ -554,6 +549,7 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num) register I32 i; register SV **ary; MAGIC* mg; + I32 slide; if (!av || num <= 0) return; @@ -591,6 +587,9 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num) } if (num) { i = AvFILLp(av); + /* Create extra elements */ + slide = i > 0 ? i : 0; + num += slide; av_extend(av, i + num); AvFILLp(av) += num; ary = AvARRAY(av); @@ -598,6 +597,10 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num) do { ary[--num] = &PL_sv_undef; } while (num); + /* Make extra elements into a buffer */ + AvMAX(av) -= slide; + AvFILLp(av) -= slide; + SvPVX(av) = (char*)(AvARRAY(av) + slide); } } @@ -796,9 +799,14 @@ Perl_av_exists(pTHX_ AV *av, I32 key) if (SvRMAGICAL(av)) { if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) { SV *sv = sv_newmortal(); + MAGIC *mg; + mg_copy((SV*)av, sv, 0, key); - magic_existspack(sv, mg_find(sv, 'p')); - return SvTRUE(sv); + mg = mg_find(sv, 'p'); + if (mg) { + magic_existspack(sv, mg); + return SvTRUE(sv); + } } } if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef @@ -1,6 +1,6 @@ /* av.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. diff --git a/bytecode.pl b/bytecode.pl index 93216048a3..8d77620be7 100644 --- a/bytecode.pl +++ b/bytecode.pl @@ -106,7 +106,6 @@ bset_obj_store(pTHXo_ struct byteloader_state *bstate, void *obj, I32 ix) void byterun(pTHXo_ register struct byteloader_state *bstate) { - dTHR; register int insn; U32 ix; SV *specialsv_list[6]; diff --git a/config_h.SH b/config_h.SH index a209e6d29f..596faf9cb9 100644 --- a/config_h.SH +++ b/config_h.SH @@ -605,12 +605,6 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_strtol HAS_STRTOL /**/ -/* HAS_STRTOUL: - * This symbol, if defined, indicates that the strtoul routine is - * available to provide conversion of strings to unsigned long. - */ -#$d_strtoul HAS_STRTOUL /**/ - /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. @@ -981,12 +975,6 @@ sed <<!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. @@ -1228,6 +1216,12 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #define CPPRUN "$cpprun" #define CPPLAST "$cpplast" +/* HAS__FWALK: + * This symbol, if defined, indicates that the _fwalk system call is + * available to apply a function to all the file handles. + */ +#$d__fwalk HAS__FWALK /**/ + /* HAS_ACCESS: * This manifest constant lets the C program know that the access() * system call is available to check for accessibility using real UID/GID. @@ -1325,6 +1319,13 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_endsent HAS_ENDSERVENT /**/ +/* FCNTL_CAN_LOCK: + * This symbol, if defined, indicates that fcntl() can be used + * for file locking. Normally on Unix systems this is defined. + * It may be undefined on VMS. + */ +#$d_fcntl_can_lock FCNTL_CAN_LOCK /**/ + /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in <sys/types.h> @@ -1367,6 +1368,13 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_fstatfs HAS_FSTATFS /**/ +/* HAS_FSYNC: + * This symbol, if defined, indicates that the fsync routine is + * available to write a file's modified data and attributes to + * permanent storage. + */ +#$d_fsync HAS_FSYNC /**/ + /* HAS_FTELLO: * This symbol, if defined, indicates that the ftello routine is * available to ftell beyond 32 bits (useful for ILP32 hosts). @@ -1507,12 +1515,30 @@ sed <<!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. */ #$d_getpent HAS_GETPROTOENT /**/ +/* HAS_GETPGRP: + * This symbol, if defined, indicates that the getpgrp routine is + * available to get the current process group. + */ +/* USE_BSD_GETPGRP: + * This symbol, if defined, indicates that getpgrp needs one + * arguments whereas USG one needs none. + */ +#$d_getpgrp HAS_GETPGRP /**/ +#$d_bsdgetpgrp USE_BSD_GETPGRP /**/ + /* HAS_GETPROTOBYNAME: * This symbol, if defined, indicates that the getprotobyname() * routine is available to look up protocols by their name. @@ -1822,6 +1848,15 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_sanemcmp HAS_SANE_MEMCMP /**/ +/* HAS_SBRK_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the sbrk() function. Otherwise, it is up + * to the program to supply one. Good guesses are + * extern void* sbrk _((int)); + * extern void* sbrk _((size_t)); + */ +#$d_sbrkproto HAS_SBRK_PROTO /**/ + /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. @@ -1859,6 +1894,18 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_setpent HAS_SETPROTOENT /**/ +/* HAS_SETPGRP: + * This symbol, if defined, indicates that the setpgrp routine is + * available to set the current process group. + */ +/* USE_BSD_SETPGRP: + * This symbol, if defined, indicates that setpgrp needs two + * arguments whereas USG one needs none. See also HAS_SETPGID + * for a POSIX interface. + */ +#$d_setpgrp HAS_SETPGRP /**/ +#$d_bsdsetpgrp USE_BSD_SETPGRP /**/ + /* HAS_SETPROCTITLE: * This symbol, if defined, indicates that the setproctitle routine is * available to set process title. @@ -2048,12 +2095,23 @@ sed <<!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: @@ -2113,6 +2171,18 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_strtoll HAS_STRTOLL /**/ +/* HAS_STRTOQ: + * This symbol, if defined, indicates that the strtoq routine is + * available to convert strings to long longs (quads). + */ +#$d_strtoq HAS_STRTOQ /**/ + +/* HAS_STRTOUL: + * This symbol, if defined, indicates that the strtoul routine is + * available to provide conversion of strings to unsigned long. + */ +#$d_strtoul HAS_STRTOUL /**/ + /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. @@ -2603,6 +2673,17 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #define RD_NODATA $rd_nodata #$d_eofnblk EOF_NONBLOCK +/* NEED_VA_COPY: + * This symbol, if defined, indicates that the system stores + * the variable argument list datatype, va_list, in a format + * that cannot be copied by simple assignment, so that some + * other means must be used when copying is required. + * As such systems vary in their provision (or non-provision) + * of copying mechanisms, handy.h defines a platform- + * independent macro, Perl_va_copy(src, dst), to do the job. + */ +#$need_va_copy NEED_VA_COPY /**/ + /* Netdb_host_t: * This symbol holds the type used for the 1st argument * to gethostbyaddr(). @@ -2952,6 +3033,12 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #define STARTPERL "$startperl" /**/ +/* STDCHAR: + * This symbol is defined to be the type of char used in stdio.h. + * It has the values "unsigned char" or "char". + */ +#define STDCHAR $stdchar /**/ + /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array * holding the stdio streams. @@ -3170,28 +3257,5 @@ sed <<!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_GETPGRP: - * This symbol, if defined, indicates that the getpgrp routine is - * available to get the current process group. - */ -/* USE_BSD_GETPGRP: - * This symbol, if defined, indicates that getpgrp needs one - * arguments whereas USG one needs none. - */ -#$d_getpgrp HAS_GETPGRP /**/ -#$d_bsdgetpgrp USE_BSD_GETPGRP /**/ - -/* HAS_SETPGRP: - * This symbol, if defined, indicates that the setpgrp routine is - * available to set the current process group. - */ -/* USE_BSD_SETPGRP: - * This symbol, if defined, indicates that setpgrp needs two - * arguments whereas USG one needs none. See also HAS_SETPGID - * for a POSIX interface. - */ -#$d_setpgrp HAS_SETPGRP /**/ -#$d_bsdsetpgrp USE_BSD_SETPGRP /**/ - #endif !GROK!THIS! diff --git a/configure.com b/configure.com index 28ce5e8fca..2efd8bd63e 100644 --- a/configure.com +++ b/configure.com @@ -53,10 +53,20 @@ $ use_two_pot_malloc = "N" $ use_pack_malloc = "N" $ use_debugmalloc = "N" $ ccflags = "" +$ static_ext = "" $ vms_default_directory_name = F$ENVIRONMENT("DEFAULT") $ max_allowed_dir_depth = 3 ! e.g. [A.B.PERLxxx] not [A.B.C.PERLxxx] $! max_allowed_dir_depth = 2 ! e.g. [A.PERLxxx] not [A.B.PERLxxx] $! +$! Sebastian Bazley's request: close the CONFIG handle with /NOLOG +$! qualifier "just in case" (configure.com is re @ed in a bad state). +$! This construct was tested to be not a problem as far back as +$! VMS V5.5-2, hopefully earlier versions are OK as well. +$! +$ CLOSE/NOLOG CONFIG +$! +$! Now keep track of open files +$! $ vms_filcnt = F$GETJPI ("","FILCNT") $! $!: compute my invocation name @@ -2061,6 +2071,10 @@ $ ans = F$EDIT(ans,"TRIM,COMPRESS,LOWERCASE") $ IF ans.eqs."decc" then Has_Dec_C_Sockets = "T" $ IF ans.eqs."socketshr" then Has_socketshr = "T" $ ENDIF +$ IF Has_Dec_C_Sockets .or. Has_socketshr +$ THEN +$ static_ext = f$edit(static_ext+" "+"Socket","trim,compress") +$ ENDIF $! $! $! Ask if they want to build with VMS_DEBUG perl @@ -2367,8 +2381,8 @@ $ echo "you might, for example, want to build GDBM_File instead of" $ echo "SDBM_File if you have the GDBM library built on your machine." $ echo "" $ echo "Which modules do you want to build into perl?" -$! dflt = "Fcntl Errno File::Glob IO Opcode Byteloader Devel::Peek Devel::DProf Data::Dumper attrs re VMS::Stdio VMS::DCLsym B SDBM_File" -$ dflt = "re Fcntl Errno File::Glob IO Opcode Devel::Peek Devel::DProf Data::Dumper attrs VMS::Stdio VMS::DCLsym B SDBM_File Storable Thread Sys::Hostname" +$! we need to add Byteloader to this list: +$ dflt = "re Fcntl Encode Errno File::Glob Filter::Util::Call IO Opcode Devel::Peek Devel::DProf Data::Dumper attrs VMS::Stdio VMS::DCLsym B SDBM_File Storable Thread Sys::Hostname" $ IF Using_Dec_C .OR. using_cxx $ THEN $ dflt = dflt + " POSIX" @@ -2594,6 +2608,39 @@ $ GOTO Clean_up $ ENDIF $ ENDIF $! +$! PerlIO abstraction +$! +$ dflt = "n" +$ IF F$TYPE(useperlio) .NES. "" +$ THEN +$ IF useperlio THEN dflt = "y" +$ IF useperlio .EQS. "define" THEN dflt = "y" +$ ENDIF +$ IF .NOT. silent +$ THEN +$ echo "Previous version of ''package' used the standard IO mechanisms as" +$ TYPE SYS$INPUT: +$ DECK +defined in <stdio.h>. Versions 5.003_02 and later of perl allow +alternate IO mechanisms via the PerlIO abstraction layer, but the +stdio mechanism is still the default. This abstraction layer can +use AT&T's sfio (if you already have sfio installed) or regular stdio. +Using PerlIO with sfio may cause problems with some extension modules. + +$ EOD +$ echo "If this does not make any sense to you, just accept the default '" + dflt + "'." +$ ENDIF +$ rp = "Use the experimental PerlIO abstraction layer? [''dflt'] " +$ GOSUB myread +$ IF ans .EQS. "" THEN ans = dflt +$ IF ans +$ THEN +$ useperlio = "define" +$ ELSE +$ echo "Ok, doing things the stdio way." +$ useperlio = "undef" +$ ENDIF +$! $ echo "" $ echo4 "Checking the C run-time library." $! @@ -2733,7 +2780,8 @@ $ ELSE d_mymalloc="undef" $ ENDIF $! $ usedl="define" -$ startperl="""$ perl 'f$env(\""procedure\"")' 'p1' 'p2' 'p3' 'p4' 'p5' 'p6' 'p7' 'p8' !\n$ exit++ + ++$status != 0 and $exit = $status = undef;""" +$ startperl="""$ perl 'f$env(\""procedure\"")' \""'"+"'p1'\"" \""'"+"'p2'\"" \""'"+"'p3'\"" \""'"+"'p4'\"" \""'"+"'p5'\"" \""'"+"'p6'\"" \""'"+"'p7'\"" \""'"+"'p8'\""!\n" +$ startperl=startperl + "$ exit++ + ++$status!=0 and $exit=$status=undef; while($#ARGV != -1 and $ARGV[$#ARGV] eq '"+"'){pop @ARGV;}""" $! $ IF ((Use_Threads) .AND. (vms_ver .LES. "6.2")) $ THEN @@ -3475,6 +3523,54 @@ $ tmp = "fcntl" $ GOSUB inlibc $ d_fcntl = tmp $! +$! Check for fcntl locking capability +$! +$ echo4 "Checking if fcntl-based file locking works... " +$ tmp = "undef" +$ IF d_fcntl .EQS. "define" +$ THEN +$ OS +$ WS "#include <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 @@ -3547,6 +3643,42 @@ $ tmp = "strtoll" $ GOSUB inlibc $ d_strtoll = tmp $! +$! Check for strtoq +$! +$ 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 = strtoq(""123123"", NULL, 10);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "strtoq" +$ GOSUB inlibc +$ d_strtoq = tmp +$! +$! Check for strtoq +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <string.h>" +$ WS "int main()" +$ WS "{" +$ WS "__int64 result;" +$ WS "result = strtoq(""123123"", NULL, 10);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "strtoq" +$ GOSUB inlibc +$ d_strtoq = tmp +$! $! Check for strtold $! $ OS @@ -3764,6 +3896,43 @@ $ tmp = "setvbuf" $ GOSUB inlibc $ d_setvbuf = tmp $! +$! see if sfio.h is available +$! see if sfio library is available +$! Ok, but do we want to use it. +$! IF F$TYPE(usesfio) .EQS. "" THEN usesfio = "undef" +$! IF val .EQS. "define" +$! THEN +$! IF usesfio .EQS. "define" +$! THEN dflt = "y" +$! ELSE dflt = "n" +$! ENDIF +$! echo "''package' can use the sfio library, but it is experimental." +$! IF useperlio .EQS. "undef" +$! THEN +$! echo "For sfio also the PerlIO abstraction layer is needed." +$! echo "Earlier you said you would not want that." +$! ENDIF +$! rp="You seem to have sfio available, do you want to try using it? [''dflt'] " +$! GOSUB myread +$! IF ans .EQS. "" THEN ans = dflt +$! IF ans +$! THEN +$! echo "Ok, turning on both sfio and PerlIO, then." +$! useperlio="define" +$! val="define" +$! ELSE +$! echo "Ok, avoiding sfio this time. I'll use stdio instead." +$! val="undef" +$! ENDIF +$! ELSE +$! IF usesfio .EQS. "define" +$! THEN +$! echo4 "Sorry, cannot find sfio on this machine." +$! echo4 "Ignoring your setting of usesfio=''usesfio'." +$! val="undef" +$! ENDIF +$! ENDIF +$! $! Check for setenv $! $ OS @@ -4401,6 +4570,8 @@ $ i_locale="undef" $ d_locconv="undef" $ d_setlocale="undef" $ ENDIF +$ d_stdio_ptr_lval_sets_cnt="undef" +$ d_stdio_ptr_lval_nochange_cnt="undef" $! $! Sockets? $ if Has_Socketshr .OR. Has_Dec_C_Sockets @@ -4691,6 +4862,7 @@ $ WC "cppminus='" + cppminus + "'" $ WC "cpprun='" + cpprun + "'" $ WC "cppstdin='" + cppstdin + "'" $ WC "crosscompile='undef'" +$ WC "d__fwalk='undef'" $ WC "d_Gconvert='my_gconvert(x,n,t,b)'" $ WC "d_PRId64='" + d_PRId64 + "'" $ WC "d_PRIEldbl='" + d_PRIEUldbl + "'" @@ -4750,6 +4922,7 @@ $ WC "d_eunice='undef'" $ WC "d_fchmod='undef'" $ WC "d_fchown='undef'" $ WC "d_fcntl='" + d_fcntl + "'" +$ WC "d_fcntl_can_lock='" + d_fcntl_can_lock + "'" $ WC "d_fd_set='" + d_fd_set + "'" $ WC "d_fgetpos='define'" $ WC "d_flexfnam='define'" @@ -4763,6 +4936,7 @@ $ WC "d_fseeko='undef'" $ WC "d_fsetpos='define'" $ WC "d_fstatfs='undef'" $ WC "d_fstatvfs='undef'" +$ WC "d_fsync='undef'" $ WC "d_ftello='undef'" $ WC "d_getcwd='undef'" $ WC "d_getespwnam='undef'" @@ -4781,6 +4955,7 @@ $ WC "d_getnbyaddr='" + d_getnbyaddr + "'" $ WC "d_getnbyname='" + d_getnbyname + "'" $ WC "d_getnent='" + d_getnent + "'" $ WC "d_getnetprotos='" + d_getnetprotos + "'" +$ WC "d_getpagsz='undef'" $ WC "d_getpbyname='" + d_getpbyname + "'" $ WC "d_getpbynumber='" + d_getpbynumber + "'" $ WC "d_getpent='" + d_getpent + "'" @@ -4885,6 +5060,7 @@ $ WC "d_rmdir='define'" $ WC "d_safebcpy='undef'" $ WC "d_safemcpy='define'" $ WC "d_sanemcmp='define'" +$ WC "d_sbrkproto='undef'" $ WC "d_sched_yield='" + d_sched_yield + "'" $ WC "d_scm_rights='undef'" $ WC "d_seekdir='define'" @@ -4934,6 +5110,8 @@ $ WC "d_statfs_s='undef'" $ WC "d_statfsflags='undef'" $ WC "d_stdio_cnt_lval='" + d_stdio_cnt_lval + "'" $ WC "d_stdio_ptr_lval='" + d_stdio_ptr_lval + "'" +$ WC "d_stdio_ptr_lval_sets_cnt='" + d_stdio_ptr_lval_sets_cnt + "'" +$ WC "d_stdio_ptr_lval_nochange_cnt='" + d_stdio_ptr_lval_nochange_cnt + "'" $ WC "d_stdio_stream_array='undef'" $ WC "d_stdiobase='" + d_stdiobase + "'" $ WC "d_stdstdio='" + d_stdstdio + "'" @@ -4946,6 +5124,7 @@ $ WC "d_strtod='define'" $ WC "d_strtol='define'" $ WC "d_strtold='" + d_strtold + "'" $ WC "d_strtoll='" + d_strtoll + "'" +$ WC "d_strtoq='define'" $ WC "d_strtoul='define'" $ WC "d_strtoull='" + d_strtoull + "'" $ WC "d_strtouq='" + d_strtouq + "'" @@ -4995,6 +5174,7 @@ $ WC "drand01='" + drand01 + "'" $ WC "dynamic_ext='" + extensions + "'" $ WC "eagain=' '" $ WC "ebcdic='undef'" +$ WC "embedmymalloc='" + mymalloc + "'" $ WC "eunicefix=':'" $ WC "exe_ext='" + exe_ext + "'" $ WC "extensions='" + extensions + "'" @@ -5131,6 +5311,7 @@ $ WC "multiarch='undef'" $ WC "mydomain='" + mydomain + "'" $ WC "myhostname='" + myhostname + "'" $ WC "myuname='" + myuname + "'" +$ WC "need_va_copy='undef'" $ WC "netdb_hlen_type='" + netdb_hlen_type + "'" $ WC "netdb_host_type='" + netdb_host_type + "'" $ WC "netdb_name_type='" + netdb_name_type + "'" @@ -5213,7 +5394,7 @@ $ WC "spitshell='write sys$output '" $ WC "src='" + src + "'" $ WC "ssizetype='int'" $ WC "startperl=" + startperl ! This one's special--no enclosing single quotes -$ WC "static_ext='" + "'" +$ WC "static_ext='" + static_ext + "'" $ WC "stdchar='" + stdchar + "'" $ WC "stdio_base='((*fp)->_base)'" $ WC "stdio_bufsiz='((*fp)->_cnt + (*fp)->_ptr - (*fp)->_base)'" @@ -5238,6 +5419,7 @@ $ WC "uquadtype='" + uquadtype + "'" $ WC "use5005threads='" + use5005threads + "'" $ WC "use64bitall='" + use64bitall + "'" $ WC "use64bitint='" + use64bitint + "'" +$ WC "usedebugging_perl='" + use_debugging_perl + "'" $ WC "usedl='" + usedl + "'" $ WC "useithreads='" + useithreads + "'" $ WC "uselargefiles='" + uselargefiles + "'" @@ -5245,7 +5427,7 @@ $ WC "uselongdouble='" + uselongdouble + "'" $ WC "usemorebits='" + usemorebits + "'" $ WC "usemultiplicity='" + usemultiplicity + "'" $ WC "usemymalloc='" + usemymalloc + "'" -$ WC "useperlio='undef'" +$ WC "useperlio='" + useperlio + "'" $ WC "useposix='false'" $ WC "usesocks='undef'" $ WC "usethreads='" + usethreads + "'" @@ -1,6 +1,6 @@ /* cop.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -21,6 +21,7 @@ struct cop { I32 cop_arybase; /* array base this line was compiled with */ line_t cop_line; /* line # of this command */ SV * cop_warnings; /* lexical warnings bitmask */ + SV * cop_io; /* lexical IO defaults */ }; #define Nullcop Null(COP*) @@ -1,6 +1,6 @@ /* cv.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -75,6 +75,7 @@ Returns the stash of the CV. #define CVf_METHOD 0x0040 /* CV is explicitly marked as a method */ #define CVf_LOCKED 0x0080 /* CV locks itself or first arg on entry */ #define CVf_LVALUE 0x0100 /* CV return value can be used as lvalue */ +#define CVf_CONST 0x0200 /* inlinable sub */ #define CvCLONE(cv) (CvFLAGS(cv) & CVf_CLONE) #define CvCLONE_on(cv) (CvFLAGS(cv) |= CVf_CLONE) @@ -122,3 +123,7 @@ Returns the stash of the CV. #define CvSPECIAL(cv) (CvUNIQUE(cv) && SvFAKE(cv)) #define CvSPECIAL_on(cv) (CvUNIQUE_on(cv),SvFAKE_on(cv)) #define CvSPECIAL_off(cv) (CvUNIQUE_off(cv),SvFAKE_off(cv)) + +#define CvCONST(cv) (CvFLAGS(cv) & CVf_CONST) +#define CvCONST_on(cv) (CvFLAGS(cv) |= CVf_CONST) +#define CvCONST_off(cv) (CvFLAGS(cv) &= ~CVf_CONST) diff --git a/cygwin/cygwin.c b/cygwin/cygwin.c index db1c426ea1..962a60a8d4 100644 --- a/cygwin/cygwin.c +++ b/cygwin/cygwin.c @@ -27,11 +27,9 @@ do_spawnvp (const char *path, const char * const *argv) childpid = spawnvp(_P_NOWAIT,path,argv); if (childpid < 0) { status = -1; - if(ckWARN(WARN_EXEC)) { - dTHR; + if(ckWARN(WARN_EXEC)) Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%s\": %s", path,Strerror (errno)); - } } else { do { result = wait4pid(childpid, &status, 0); @@ -146,7 +144,7 @@ XS(Cygwin_cwd) if(items != 0) Perl_croak(aTHX_ "Usage: Cwd::cwd()"); - if((cwd = getcwd(NULL, 0))) { + if((cwd = getcwd(NULL, -1))) { ST(0) = sv_2mortal(newSVpv(cwd, 0)); safesysfree(cwd); XSRETURN(1); @@ -1,6 +1,6 @@ /* deb.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -45,7 +45,6 @@ void Perl_vdeb(pTHX_ const char *pat, va_list *args) { #ifdef DEBUGGING - dTHR; char* file = CopFILE(PL_curcop); #ifdef USE_THREADS @@ -65,7 +64,6 @@ I32 Perl_debstackptrs(pTHX) { #ifdef DEBUGGING - dTHR; PerlIO_printf(Perl_debug_log, "%8"UVxf" %8"UVxf" %8"IVdf" %8"IVdf" %8"IVdf"\n", PTR2UV(PL_curstack), PTR2UV(PL_stack_base), @@ -84,7 +82,6 @@ I32 Perl_debstack(pTHX) { #ifdef DEBUGGING - dTHR; I32 top = PL_stack_sp - PL_stack_base; register I32 i = top - 30; I32 *markscan = PL_markstack + PL_curstackinfo->si_markoff; diff --git a/djgpp/config.over b/djgpp/config.over index b48774f6f0..1bdd8ca120 100644 --- a/djgpp/config.over +++ b/djgpp/config.over @@ -1,5 +1,5 @@ ln='cp' -pager='less' +pager='${DJDIR}/bin/less.exe' # fix extension names under DOS repair() @@ -35,7 +35,9 @@ repair() -e 's=File/=='\ -e 's=glob=='\ -e 's=Glob=='\ - -e 's/storable/Storable/' + -e 's/storable/Storable/'\ + -e 's/encode/Encode/'\ + -e 's=filter/util/call=Filter/Util/Call=' } static_ext=$(repair "$static_ext") extensions=$(repair "$extensions") diff --git a/djgpp/djgpp.c b/djgpp/djgpp.c index 80a627e518..4e390cfc59 100644 --- a/djgpp/djgpp.c +++ b/djgpp/djgpp.c @@ -130,7 +130,6 @@ convretcode (pTHX_ int rc,char *prog,int fl) int do_aspawn (pTHX_ SV *really,SV **mark,SV **sp) { - dTHR; int rc; char **a,*tmps,**argv; STRLEN n_a; @@ -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) @@ -94,9 +74,14 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int result; bool was_fdopen = FALSE; bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0; + char *type = NULL; + char *deftype = NULL; + char mode[4]; /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */ + Zero(mode,sizeof(mode),char); PL_forkprocess = 1; /* assume true if no fork */ + /* Collect default raw/crlf info from the op */ if (PL_op && PL_op->op_type == OP_OPEN) { /* set up disciplines */ U8 flags = PL_op->op_private; @@ -106,6 +91,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, out_crlf = (flags & OPpOPEN_OUT_CRLF); } + /* If currently open - close before we re-open */ if (IoIFP(io)) { fd = PerlIO_fileno(IoIFP(io)); if (IoTYPE(io) == IoTYPE_STD) @@ -136,6 +122,8 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } if (as_raw) { + /* sysopen style args, i.e. integer mode and permissions */ + #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE) rawmode |= O_LARGEFILE; #endif @@ -163,78 +151,81 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (fd == -1) fp = NULL; else { - char fpmode[4]; STRLEN ix = 0; - if (result == O_RDONLY) - fpmode[ix++] = 'r'; + if (result == O_RDONLY) { + mode[ix++] = 'r'; + } #ifdef O_APPEND else if (rawmode & O_APPEND) { - fpmode[ix++] = 'a'; + mode[ix++] = 'a'; if (result != O_WRONLY) - fpmode[ix++] = '+'; + mode[ix++] = '+'; } #endif else { if (result == O_WRONLY) - fpmode[ix++] = 'w'; + mode[ix++] = 'w'; else { - fpmode[ix++] = 'r'; - fpmode[ix++] = '+'; + mode[ix++] = 'r'; + mode[ix++] = '+'; } } if (rawmode & O_BINARY) - fpmode[ix++] = 'b'; - fpmode[ix] = '\0'; - fp = PerlIO_fdopen(fd, fpmode); + mode[ix++] = 'b'; + mode[ix] = '\0'; + fp = PerlIO_fdopen(fd, mode); if (!fp) PerlLIO_close(fd); } } else { - char *type; + /* Regular (non-sys) open */ char *oname = name; - STRLEN tlen; STRLEN olen = len; - char mode[4]; /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */ - int dodup; + char *tend; + int dodup = 0; type = savepvn(name, len); - tlen = len; + tend = type+len; SAVEFREEPV(type); + /* Loose trailing white space */ + while (tend > type && isSPACE(tend[-1])) + *tend-- = '\0'; if (num_svs) { + /* New style explict name, type is just mode and discipline/layer info */ STRLEN l; name = SvPV(svs, l) ; len = (I32)l; name = savepvn(name, len); SAVEFREEPV(name); + /*SUPPRESS 530*/ + for (; isSPACE(*type); type++) ; } else { - while (tlen && isSPACE(type[tlen-1])) - type[--tlen] = '\0'; name = type; - len = tlen; + len = tend-type; } - mode[0] = mode[1] = mode[2] = mode[3] = '\0'; IoTYPE(io) = *type; - if (*type == IoTYPE_RDWR && tlen > 1 && type[tlen-1] != IoTYPE_PIPE) { /* scary */ + if (*type == IoTYPE_RDWR && (!num_svs || tend > type+1 && tend[-1] != IoTYPE_PIPE)) { /* scary */ mode[1] = *type++; - --tlen; writing = 1; } if (*type == IoTYPE_PIPE) { - if (num_svs && (tlen != 2 || type[1] != IoTYPE_STD)) { - unknown_desr: - Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname); + if (num_svs) { + if (type[1] != IoTYPE_STD) { + unknown_desr: + Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname); + } + type++; } /*SUPPRESS 530*/ - for (type++, tlen--; isSPACE(*type); type++, tlen--) ; + for (type++; isSPACE(*type); type++) ; if (!num_svs) { name = type; - len = tlen; + len = tend-type; } if (*name == '\0') { /* command is missing 19990114 */ - dTHR; if (ckWARN(WARN_PIPE)) Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open"); errno = EPIPE; @@ -243,23 +234,18 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (strNE(name,"-") || num_svs) TAINT_ENV(); TAINT_PROPER("piped open"); - if (name[len-1] == '|') { - dTHR; + if (!num_svs && name[len-1] == '|') { name[--len] = '\0' ; if (ckWARN(WARN_PIPE)) Perl_warner(aTHX_ WARN_PIPE, "Can't open bidirectional pipe"); } - { - char *mode; - if (out_raw) - mode = "wb"; - else if (out_crlf) - mode = "wt"; - else - mode = "w"; - fp = PerlProc_popen(name,mode); - } + mode[0] = 'w'; writing = 1; + if (out_raw) + strcat(mode, "b"); + else if (out_crlf) + strcat(mode, "t"); + fp = PerlProc_popen(name,mode); } else if (*type == IoTYPE_WRONLY) { TAINT_PROPER("open"); @@ -268,7 +254,6 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */ mode[0] = IoTYPE(io) = IoTYPE_APPEND; type++; - tlen--; } else mode[0] = 'w'; @@ -279,11 +264,11 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, else if (out_crlf) strcat(mode, "t"); - if (num_svs && tlen != 1) - goto unknown_desr; if (*type == '&') { name = type; duplicity: + if (num_svs) + goto unknown_desr; dodup = 1; name++; if (*name == '=') { @@ -355,7 +340,9 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, else { /*SUPPRESS 530*/ for (; isSPACE(*type); type++) ; - if (*type == IoTYPE_STD && !type[1]) { + if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { + /*SUPPRESS 530*/ + type++; fp = PerlIO_stdout(); IoTYPE(io) = IoTYPE_STD; } @@ -365,8 +352,6 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } } else if (*type == IoTYPE_RDONLY) { - if (num_svs && tlen != 1) - goto unknown_desr; /*SUPPRESS 530*/ for (type++; isSPACE(*type); type++) ; mode[0] = 'r'; @@ -379,28 +364,30 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, name = type; goto duplicity; } - if (*type == IoTYPE_STD && !type[1]) { + if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { + /*SUPPRESS 530*/ + type++; fp = PerlIO_stdin(); IoTYPE(io) = IoTYPE_STD; } else fp = PerlIO_open((num_svs ? name : type), mode); } - else if (tlen > 1 && type[tlen-1] == IoTYPE_PIPE) { + else if ((num_svs && type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) || + (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) { if (num_svs) { - if (tlen != 2 || type[0] != IoTYPE_STD) - goto unknown_desr; + type += 2; /* skip over '-|' */ } else { - type[--tlen] = '\0'; - while (tlen && isSPACE(type[tlen-1])) - type[--tlen] = '\0'; + *--tend = '\0'; + while (tend > type && isSPACE(tend[-1])) + *--tend = '\0'; /*SUPPRESS 530*/ for (; isSPACE(*type); type++) ; name = type; + len = tend-type; } if (*name == '\0') { /* command is missing 19990114 */ - dTHR; if (ckWARN(WARN_PIPE)) Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open"); errno = EPIPE; @@ -409,16 +396,12 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (strNE(name,"-") || num_svs) TAINT_ENV(); TAINT_PROPER("piped open"); - { - char *mode; - if (in_raw) - mode = "rb"; - else if (in_crlf) - mode = "rt"; - else - mode = "r"; - fp = PerlProc_popen(name,mode); - } + mode[0] = 'r'; + if (in_raw) + strcat(mode, "b"); + else if (in_crlf) + strcat(mode, "t"); + fp = PerlProc_popen(name,mode); IoTYPE(io) = IoTYPE_PIPE; } else { @@ -428,31 +411,26 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, IoTYPE(io) = IoTYPE_RDONLY; /*SUPPRESS 530*/ for (; isSPACE(*name); name++) ; + mode[0] = 'r'; + if (in_raw) + strcat(mode, "b"); + else if (in_crlf) + strcat(mode, "t"); if (strEQ(name,"-")) { fp = PerlIO_stdin(); IoTYPE(io) = IoTYPE_STD; } else { - char *mode; - if (in_raw) - mode = "rb"; - else if (in_crlf) - mode = "rt"; - else - mode = "r"; fp = PerlIO_open(name,mode); } } } if (!fp) { - dTHR; if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == IoTYPE_RDONLY && strchr(name, '\n')) Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open"); goto say_false; } - if (IoTYPE(io) && - IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD) { - dTHR; + if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD) { if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) { (void)PerlIO_close(fp); goto say_false; @@ -480,13 +458,17 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, #endif } if (saveifp) { /* must use old fp? */ + /* If fd is less that PL_maxsysfd i.e. STDIN..STDERR + then dup the new fileno down + */ fd = PerlIO_fileno(saveifp); if (saveofp) { - PerlIO_flush(saveofp); /* emulate PerlIO_close() */ + PerlIO_flush(saveofp); /* emulate PerlIO_close() */ if (saveofp != saveifp) { /* was a socket? */ PerlIO_close(saveofp); + /* This looks very suspect - NI-S 24 Nov 2000 */ if (fd > 2) - Safefree(saveofp); + Safefree(saveofp); /* ??? */ } } if (fd != PerlIO_fileno(fp)) { @@ -494,6 +476,15 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, SV *sv; PerlLIO_dup2(PerlIO_fileno(fp), fd); +#ifdef VMS + if (fd != PerlIO_fileno(PerlIO_stdin())) { + char newname[FILENAME_MAX+1]; + if (fgetname(fp, newname)) { + if (fd == PerlIO_fileno(PerlIO_stdout())) Perl_vmssetuserlnm("SYS$OUTPUT", newname); + if (fd == PerlIO_fileno(PerlIO_stderr())) Perl_vmssetuserlnm("SYS$ERROR", newname); + } + } +#endif LOCK_FDPID_MUTEX; sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE); (void)SvUPGRADE(sv, SVt_IV); @@ -519,25 +510,51 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } #endif IoIFP(io) = fp; + if (!num_svs) { + /* Need to supply default type info from open.pm */ + SV *layers = PL_curcop->cop_io; + type = NULL; + if (layers) { + STRLEN len; + type = SvPV(layers,len); + if (type && mode[0] != 'r') { + /* Skip to write part */ + char *s = strchr(type,0); + if (s && (s-type) < len) { + type = s+1; + } + } + } + } + if (type) { + while (isSPACE(*type)) type++; + if (*type) { + if (PerlIO_apply_layers(aTHX_ IoIFP(io),mode,type) != 0) { + goto say_false; + } + } + } + IoFLAGS(io) &= ~IOf_NOLINE; if (writing) { - dTHR; if (IoTYPE(io) == IoTYPE_SOCKET || (IoTYPE(io) == IoTYPE_WRONLY && S_ISCHR(PL_statbuf.st_mode)) ) { - char *mode; - if (out_raw) - mode = "wb"; - else if (out_crlf) - mode = "wt"; - else - mode = "w"; - + mode[0] = 'w'; if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),mode))) { PerlIO_close(fp); IoIFP(io) = Nullfp; goto say_false; } + if (type && *type) { + if (PerlIO_apply_layers(aTHX_ IoOFP(io),mode,type) != 0) { + PerlIO_close(IoOFP(io)); + PerlIO_close(fp); + IoIFP(io) = Nullfp; + IoOFP(io) = Nullfp; + goto say_false; + } + } } else IoOFP(io) = fp; @@ -583,7 +600,6 @@ Perl_nextargv(pTHX_ register GV *gv) } PL_filemode = 0; while (av_len(GvAV(gv)) >= 0) { - dTHR; STRLEN oldlen; sv = av_shift(GvAV(gv)); SAVEFREESV(sv); @@ -649,7 +665,7 @@ Perl_nextargv(pTHX_ register GV *gv) #if !defined(DOSISH) && !defined(__CYGWIN__) if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) { if (ckWARN_d(WARN_INPLACE)) - Perl_warner(aTHX_ WARN_INPLACE, + Perl_warner(aTHX_ WARN_INPLACE, "Can't rename %s to %s: %s, skipping file", PL_oldname, SvPVX(sv), Strerror(errno) ); do_close(gv,FALSE); @@ -732,7 +748,6 @@ Perl_nextargv(pTHX_ register GV *gv) return IoIFP(GvIOp(gv)); } else { - dTHR; if (ckWARN_d(WARN_INPLACE)) { int eno = errno; if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0 @@ -827,7 +842,6 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit) io = GvIO(gv); if (!io) { /* never opened */ if (not_implicit) { - dTHR; if (ckWARN(WARN_UNOPENED)) /* no check for closed here */ report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,SS$_IVCHAN); @@ -883,7 +897,6 @@ Perl_io_close(pTHX_ IO *io, bool not_implicit) bool Perl_do_eof(pTHX_ GV *gv) { - dTHR; register IO *io; int ch; @@ -896,7 +909,7 @@ Perl_do_eof(pTHX_ GV *gv) || IoIFP(io) == PerlIO_stderr())) { /* integrate to report_evil_fh()? */ - char *name = NULL; + char *name = NULL; if (isGV(gv)) { SV* sv = sv_newmortal(); gv_efullname4(sv, gv, Nullch, FALSE); @@ -922,6 +935,7 @@ Perl_do_eof(pTHX_ GV *gv) (void)PerlIO_ungetc(IoIFP(io),ch); return FALSE; } + if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) { if (PerlIO_get_cnt(IoIFP(io)) < -1) PerlIO_set_cnt(IoIFP(io),-1); @@ -949,11 +963,8 @@ Perl_do_tell(pTHX_ GV *gv) #endif return PerlIO_tell(fp); } - { - dTHR; - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); - } + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS$_IFI); return (Off_t)-1; } @@ -971,11 +982,8 @@ Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence) #endif return PerlIO_seek(fp, pos, whence) >= 0; } - { - dTHR; - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); - } + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS$_IFI); return FALSE; } @@ -988,11 +996,8 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence) if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence); - { - dTHR; - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); - } + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS$_IFI); return (Off_t)-1; } @@ -1041,7 +1046,11 @@ fail_discipline: end = strchr(s+1, ':'); if (!end) end = s+len; +#ifndef PERLIO_LAYERS Perl_croak(aTHX_ "Unknown discipline '%.*s'", end-s, s); +#else + s = end; +#endif } } } @@ -1051,46 +1060,11 @@ fail_discipline: int Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode) { -#ifdef DOSISH -# if defined(atarist) || defined(__MINT__) - if (!PerlIO_flush(fp)) { - if (mode & O_BINARY) - ((FILE*)fp)->_flag |= _IOBIN; - else - ((FILE*)fp)->_flag &= ~ _IOBIN; - return 1; - } - return 0; -# else - if (PerlLIO_setmode(PerlIO_fileno(fp), mode) != -1) { -# if defined(WIN32) && defined(__BORLANDC__) - /* The translation mode of the stream is maintained independent - * of the translation mode of the fd in the Borland RTL (heavy - * digging through their runtime sources reveal). User has to - * set the mode explicitly for the stream (though they don't - * document this anywhere). GSAR 97-5-24 - */ - PerlIO_seek(fp,0L,0); - if (mode & O_BINARY) - ((FILE*)fp)->flags |= _F_BIN; - else - ((FILE*)fp)->flags &= ~ _F_BIN; -# endif - return 1; - } - else - return 0; -# endif -#else -# if defined(USEMYBINMODE) - if (my_binmode(fp, iotype, mode) != FALSE) - return 1; - else - return 0; -# else - return 1; -# endif -#endif + /* The old body of this is now in non-LAYER part of perlio.c + * This is a stub for any XS code which might have been calling it. + */ + char *name = (O_BINARY != O_TEXT && !(mode & O_BINARY)) ? ":crlf" : ":raw"; + return PerlIO_binmode(aTHX_ fp, iotype, mode, name); } #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) @@ -1168,11 +1142,8 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) } switch (SvTYPE(sv)) { case SVt_NULL: - { - dTHR; - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(); - } + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(); return TRUE; case SVt_IV: if (SvIOK(sv)) { @@ -1186,12 +1157,14 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) } /* FALL THROUGH */ default: -#if 0 - /* XXX Fix this when the I/O disciplines arrive. XXX */ - if (DO_UTF8(sv)) - sv_utf8_downgrade(sv, FALSE); -#endif - tmps = SvPV(sv, len); + if (PerlIO_isutf8(fp)) { + tmps = SvPVutf8(sv, len); + } + else { + if (DO_UTF8(sv)) + sv_utf8_downgrade(sv, FALSE); + tmps = SvPV(sv, len); + } break; } /* To detect whether the process is about to overstep its @@ -1303,7 +1276,6 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, STRLEN n_a; if (sp > mark) { - dTHR; New(401,PL_Argv, sp - mark + 1, char*); a = PL_Argv; while (++mark <= sp) { @@ -1316,11 +1288,11 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, if (*PL_Argv[0] != '/') /* will execvp use PATH? */ TAINT_ENV(); /* testing IFS here is overkill, probably */ if (really && *(tmps = SvPV(really, n_a))) - PerlProc_execvp(tmps,PL_Argv); + PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv)); else - PerlProc_execvp(PL_Argv[0],PL_Argv); + PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv)); if (ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", + Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno)); if (do_report) { int e = errno; @@ -1451,11 +1423,10 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) goto doshell; } { - dTHR; int e = errno; if (ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", + Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno)); if (do_report) { PerlLIO_write(fd, (void*)&e, sizeof(int)); @@ -1472,7 +1443,6 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) I32 Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) { - dTHR; register I32 val; register I32 val2; register I32 tot = 0; @@ -1530,7 +1500,7 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) } break; #endif -/* +/* XXX Should we make lchown() directly available from perl? For now, we'll let Configure test for HAS_LCHOWN, but do nothing in the core. @@ -1757,7 +1727,6 @@ Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective) I32 Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp) { - dTHR; key_t key; I32 n, flags; @@ -1790,7 +1759,6 @@ Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp) I32 Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) { - dTHR; SV *astr; char *a; I32 id, n, cmd, infosize, getinfo; @@ -1915,7 +1883,6 @@ I32 Perl_do_msgsnd(pTHX_ SV **mark, SV **sp) { #ifdef HAS_MSG - dTHR; SV *mstr; char *mbuf; I32 id, msize, flags; @@ -1938,7 +1905,6 @@ I32 Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) { #ifdef HAS_MSG - dTHR; SV *mstr; char *mbuf; long mtype; @@ -1955,7 +1921,7 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) flags = SvIVx(*++mark); SvPV_force(mstr, len); mbuf = SvGROW(mstr, sizeof(long)+msize+1); - + SETERRNO(0,0); ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags); if (ret >= 0) { @@ -1976,7 +1942,6 @@ I32 Perl_do_semop(pTHX_ SV **mark, SV **sp) { #ifdef HAS_SEM - dTHR; SV *opstr; char *opbuf; I32 id; @@ -2001,7 +1966,6 @@ I32 Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) { #ifdef HAS_SHM - dTHR; SV *mstr; char *mbuf, *shm; I32 id, mpos, msize; @@ -2056,3 +2020,149 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) #endif /* SYSV IPC */ +/* +=for apidoc start_glob + +Function called by C<do_readline> to spawn a glob (or do the glob inside +perl on VMS). This code used to be inline, but now perl uses C<File::Glob> +this glob starter is only used by miniperl during the build proccess. +Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up. + +=cut +*/ + +PerlIO * +Perl_start_glob (pTHX_ SV *tmpglob, IO *io) +{ + SV *tmpcmd = NEWSV(55, 0); + PerlIO *fp; + ENTER; + SAVEFREESV(tmpcmd); +#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */ + /* since spawning off a process is a real performance hit */ + { +#include <descrip.h> +#include <lib$routines.h> +#include <nam.h> +#include <rmsdef.h> + char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'}; + char vmsspec[NAM$C_MAXRSS+1]; + char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp; + char tmpfnam[L_tmpnam] = "SYS$SCRATCH:"; + $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;"); + PerlIO *tmpfp; + STRLEN i; + struct dsc$descriptor_s wilddsc + = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + struct dsc$descriptor_vs rsdsc + = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt}; + unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0; + + /* We could find out if there's an explicit dev/dir or version + by peeking into lib$find_file's internal context at + ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb + but that's unsupported, so I don't want to do it now and + have it bite someone in the future. */ + strcat(tmpfnam,PerlLIO_tmpnam(NULL)); + cp = SvPV(tmpglob,i); + for (; i; i--) { + if (cp[i] == ';') hasver = 1; + if (cp[i] == '.') { + if (sts) hasver = 1; + else sts = 1; + } + if (cp[i] == '/') { + hasdir = isunix = 1; + break; + } + if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') { + hasdir = 1; + break; + } + } + if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) { + Stat_t st; + if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode)) + ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL); + else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL); + if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer); + while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt, + &dfltdsc,NULL,NULL,NULL))&1)) { + end = rstr + (unsigned long int) *rslt; + if (!hasver) while (*end != ';') end--; + *(end++) = '\n'; *end = '\0'; + for (cp = rstr; *cp; cp++) *cp = _tolower(*cp); + if (hasdir) { + if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1); + begin = rstr; + } + else { + begin = end; + while (*(--begin) != ']' && *begin != '>') ; + ++begin; + } + ok = (PerlIO_puts(tmpfp,begin) != EOF); + } + if (cxt) (void)lib$find_file_end(&cxt); + if (ok && sts != RMS$_NMF && + sts != RMS$_DNF && sts != RMS$_FNF) ok = 0; + if (!ok) { + if (!(sts & 1)) { + SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts); + } + PerlIO_close(tmpfp); + fp = NULL; + } + else { + PerlIO_rewind(tmpfp); + IoTYPE(io) = IoTYPE_RDONLY; + IoIFP(io) = fp = tmpfp; + IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */ + } + } + } +#else /* !VMS */ +#ifdef MACOS_TRADITIONAL + sv_setpv(tmpcmd, "glob "); + sv_catsv(tmpcmd, tmpglob); + sv_catpv(tmpcmd, " |"); +#else +#ifdef DOSISH +#ifdef OS2 + sv_setpv(tmpcmd, "for a in "); + sv_catsv(tmpcmd, tmpglob); + sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |"); +#else +#ifdef DJGPP + sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */ + sv_catsv(tmpcmd, tmpglob); +#else + sv_setpv(tmpcmd, "perlglob "); + sv_catsv(tmpcmd, tmpglob); + sv_catpv(tmpcmd, " |"); +#endif /* !DJGPP */ +#endif /* !OS2 */ +#else /* !DOSISH */ +#if defined(CSH) + sv_setpvn(tmpcmd, PL_cshname, PL_cshlen); + sv_catpv(tmpcmd, " -cf 'set nonomatch; glob "); + sv_catsv(tmpcmd, tmpglob); + sv_catpv(tmpcmd, "' 2>/dev/null |"); +#else + sv_setpv(tmpcmd, "echo "); + sv_catsv(tmpcmd, tmpglob); +#if 'z' - 'a' == 25 + sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|"); +#else + sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|"); +#endif +#endif /* !CSH */ +#endif /* !DOSISH */ +#endif /* MACOS_TRADITIONAL */ + (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd), + FALSE, O_RDONLY, 0, Nullfp); + fp = IoIFP(io); +#endif /* !VMS */ + LEAVE; + return fp; +} @@ -1,6 +1,6 @@ /* doop.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -21,41 +21,27 @@ #endif #endif -#define HALF_UTF8_UPGRADE(start,end) \ - STMT_START { \ - if ((start)<(end)) { \ - U8* NeWsTr; \ - STRLEN LeN = (end) - (start); \ - NeWsTr = bytes_to_utf8(start, &LeN); \ - Safefree(start); \ - (start) = NeWsTr; \ - (end) = (start) + LeN; \ - } \ - } STMT_END - STATIC I32 S_do_trans_simple(pTHX_ SV *sv) { - dTHR; U8 *s; U8 *d; U8 *send; U8 *dstart; I32 matches = 0; - I32 sutf = SvUTF8(sv); STRLEN len; short *tbl; I32 ch; tbl = (short*)cPVOP->op_pv; if (!tbl) - Perl_croak(aTHX_ "panic: do_trans"); + Perl_croak(aTHX_ "panic: do_trans_simple"); s = (U8*)SvPV(sv, len); send = s + len; /* First, take care of non-UTF8 input strings, because they're easy */ - if (!sutf) { + if (!SvUTF8(sv)) { while (s < send) { if ((ch = tbl[*s]) >= 0) { matches++; @@ -72,18 +58,15 @@ S_do_trans_simple(pTHX_ SV *sv) Newz(0, d, len*2+1, U8); dstart = d; while (s < send) { - I32 ulen; + STRLEN ulen; short c; ulen = 1; /* Need to check this, otherwise 128..255 won't match */ - c = utf8_to_uv_chk(s, &ulen, 0); + c = utf8_to_uv(s, send - s, &ulen, 0); if (c < 0x100 && (ch = tbl[(short)c]) >= 0) { matches++; - if (ch < 0x80) - *d++ = ch; - else - d = uv_to_utf8(d,ch); + d = uv_to_utf8(d, ch); s += ulen; } else { /* No match -> copy */ @@ -92,8 +75,7 @@ S_do_trans_simple(pTHX_ SV *sv) } } *d = '\0'; - sv_setpvn(sv, (const char*)dstart, d - dstart); - Safefree(dstart); + sv_setpvn(sv, (char*)dstart, d - dstart); SvUTF8_on(sv); SvSETMAGIC(sv); return matches; @@ -102,37 +84,33 @@ S_do_trans_simple(pTHX_ SV *sv) STATIC I32 S_do_trans_count(pTHX_ SV *sv)/* SPC - OK */ { - dTHR; U8 *s; U8 *send; I32 matches = 0; - I32 hasutf = SvUTF8(sv); STRLEN len; short *tbl; tbl = (short*)cPVOP->op_pv; if (!tbl) - Perl_croak(aTHX_ "panic: do_trans"); + Perl_croak(aTHX_ "panic: do_trans_count"); s = (U8*)SvPV(sv, len); send = s + len; - while (s < send) { - if (hasutf && *s & 0x80) - s += UTF8SKIP(s); - else { - UV c; - I32 ulen; - ulen = 1; - if (hasutf) - c = utf8_to_uv_chk(s,&ulen, 0); - else - c = *s; - if (c < 0x100 && tbl[c] >= 0) + if (!SvUTF8(sv)) + while (s < send) { + if (tbl[*s++] >= 0) matches++; - s += ulen; - } - } + } + else + while (s < send) { + UV c; + STRLEN ulen; + c = utf8_to_uv(s, send - s, &ulen, 0); + if (c < 0x100 && tbl[c] >= 0) + matches++; + s += ulen; + } return matches; } @@ -140,11 +118,11 @@ S_do_trans_count(pTHX_ SV *sv)/* SPC - OK */ STATIC I32 S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */ { - dTHR; U8 *s; U8 *send; U8 *d; - I32 hasutf = SvUTF8(sv); + U8 *dstart; + I32 isutf8; I32 matches = 0; STRLEN len; short *tbl; @@ -152,66 +130,109 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */ tbl = (short*)cPVOP->op_pv; if (!tbl) - Perl_croak(aTHX_ "panic: do_trans"); + Perl_croak(aTHX_ "panic: do_trans_complex"); s = (U8*)SvPV(sv, len); + isutf8 = SvUTF8(sv); send = s + len; - d = s; - if (PL_op->op_private & OPpTRANS_SQUASH) { - U8* p = send; - - while (s < send) { - if (hasutf && *s & 0x80) - s += UTF8SKIP(s); - else { - if ((ch = tbl[*s]) >= 0) { + if (!isutf8) { + dstart = d = s; + if (PL_op->op_private & OPpTRANS_SQUASH) { + U8* p = send; + while (s < send) { + if ((ch = tbl[*s]) >= 0) { *d = ch; matches++; - if (p == d - 1 && *p == *d) - matches--; - else - p = d++; - } - else if (ch == -1) /* -1 is unmapped character */ - *d++ = *s; /* -2 is delete character */ - s++; - } + if (p != d - 1 || *p != *d) + p = d++; + } + else if (ch == -1) /* -1 is unmapped character */ + *d++ = *s; + else if (ch == -2) /* -2 is delete character */ + matches++; + s++; + } } - } - else { - while (s < send) { - if (hasutf && *s & 0x80) - s += UTF8SKIP(s); - else { + else { + while (s < send) { if ((ch = tbl[*s]) >= 0) { - *d = ch; matches++; - d++; - } - else if (ch == -1) /* -1 is unmapped character */ - *d++ = *s; /* -2 is delete character */ - s++; - } + *d++ = ch; + } + else if (ch == -1) /* -1 is unmapped character */ + *d++ = *s; + else if (ch == -2) /* -2 is delete character */ + matches++; + s++; + } } + SvCUR_set(sv, d - dstart); + } + else { /* isutf8 */ + Newz(0, d, len*2+1, U8); + dstart = d; + + if (PL_op->op_private & OPpTRANS_SQUASH) { + U8* p = send; + UV pch = 0xfeedface; + while (s < send) { + STRLEN len; + UV comp = utf8_to_uv_simple(s, &len); + + if (comp > 0xff) + d = uv_to_utf8(d, comp); /* always unmapped */ + else if ((ch = tbl[comp]) >= 0) { + matches++; + if (ch != pch) { + d = uv_to_utf8(d, ch); + pch = ch; + } + s += len; + continue; + } + else if (ch == -1) /* -1 is unmapped character */ + d = uv_to_utf8(d, comp); + else if (ch == -2) /* -2 is delete character */ + matches++; + s += len; + pch = 0xfeedface; + } + } + else { + while (s < send) { + STRLEN len; + UV comp = utf8_to_uv_simple(s, &len); + if (comp > 0xff) + d = uv_to_utf8(d, comp); /* always unmapped */ + else if ((ch = tbl[comp]) >= 0) { + d = uv_to_utf8(d, ch); + matches++; + } + else if (ch == -1) { /* -1 is unmapped character */ + d = uv_to_utf8(d, comp); + } + else if (ch == -2) /* -2 is delete character */ + matches++; + s += len; + } + } + *d = '\0'; + sv_setpvn(sv, (char*)dstart, d - dstart); + SvUTF8_on(sv); } - matches += send - d; /* account for disappeared chars */ - *d = '\0'; - SvCUR_set(sv, d - (U8*)SvPVX(sv)); SvSETMAGIC(sv); - return matches; } STATIC I32 S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */ { - dTHR; U8 *s; U8 *send; U8 *d; U8 *start; - U8 *dstart; + U8 *dstart, *dend; I32 matches = 0; STRLEN len; @@ -222,11 +243,19 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */ UV extra = none + 1; UV final; UV uv; - I32 isutf; - I32 howmany; + I32 isutf8; + U8 hibit = 0; - isutf = SvUTF8(sv); s = (U8*)SvPV(sv, len); + isutf8 = SvUTF8(sv); + if (!isutf8) { + U8 *t = s, *e = s + len; + while (t < e) + if ((hibit = UTF8_IS_CONTINUED(*t++))) + break; + if (hibit) + s = bytes_to_utf8(s, &len); + } send = s + len; start = s; @@ -235,41 +264,46 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */ final = SvUV(*svp); /* d needs to be bigger than s, in case e.g. upgrading is required */ - Newz(0, d, len*2+1, U8); + New(0, d, len*3+UTF8_MAXLEN, U8); + dend = d + len * 3; dstart = d; + while (s < send) { if ((uv = swash_fetch(rv, s)) < none) { s += UTF8SKIP(s); matches++; - if ((uv & 0x80) && !isutf++) - HALF_UTF8_UPGRADE(dstart,d); d = uv_to_utf8(d, uv); } else if (uv == none) { - int i; - i = UTF8SKIP(s); - if (i > 1 && !isutf++) - HALF_UTF8_UPGRADE(dstart,d); + int i = UTF8SKIP(s); while(i--) *d++ = *s++; } else if (uv == extra) { - int i; - i = UTF8SKIP(s); + int i = UTF8SKIP(s); s += i; matches++; - if (i > 1 && !isutf++) - HALF_UTF8_UPGRADE(dstart,d); d = uv_to_utf8(d, final); } else s += UTF8SKIP(s); + + if (d >= dend) { + STRLEN clen = d - dstart; + STRLEN nlen = dend - dstart + len + UTF8_MAXLEN; + Renew(dstart, nlen+UTF8_MAXLEN, U8); + d = dstart + clen; + dend = dstart + nlen; + } } *d = '\0'; - sv_setpvn(sv, (const char*)dstart, d - dstart); + sv_setpvn(sv, (char*)dstart, d - dstart); SvSETMAGIC(sv); - if (isutf) - SvUTF8_on(sv); + SvUTF8_on(sv); + if (hibit) + Safefree(start); + if (!isutf8 && !(PL_hints & HINT_UTF8)) + sv_utf8_downgrade(sv, TRUE); return matches; } @@ -277,9 +311,8 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */ STATIC I32 S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */ { - dTHR; U8 *s; - U8 *send; + U8 *start, *send; I32 matches = 0; STRLEN len; @@ -288,10 +321,17 @@ S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */ SV** svp = hv_fetch(hv, "NONE", 4, FALSE); UV none = svp ? SvUV(*svp) : 0x7fffffff; UV uv; + U8 hibit = 0; s = (U8*)SvPV(sv, len); - if (!SvUTF8(sv)) - s = bytes_to_utf8(s, &len); + if (!SvUTF8(sv)) { + U8 *t = s, *e = s + len; + while (t < e) + if ((hibit = !UTF8_IS_ASCII(*t++))) + break; + if (hibit) + start = s = bytes_to_utf8(s, &len); + } send = s + len; while (s < send) { @@ -299,6 +339,8 @@ S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */ matches++; s += UTF8SKIP(s); } + if (hibit) + Safefree(start); return matches; } @@ -306,9 +348,8 @@ S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */ STATIC I32 S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */ { - dTHR; U8 *s; - U8 *send; + U8 *start, *send; U8 *d; I32 matches = 0; I32 squash = PL_op->op_private & OPpTRANS_SQUASH; @@ -321,41 +362,45 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */ UV final; UV uv; STRLEN len; - U8 *dst; - I32 isutf = SvUTF8(sv); + U8 *dstart, *dend; + I32 isutf8; + U8 hibit = 0; s = (U8*)SvPV(sv, len); + isutf8 = SvUTF8(sv); + if (!isutf8) { + U8 *t = s, *e = s + len; + while (t < e) + if ((hibit = !UTF8_IS_ASCII(*t++))) + break; + if (hibit) + s = bytes_to_utf8(s, &len); + } send = s + len; + start = s; svp = hv_fetch(hv, "FINAL", 5, FALSE); if (svp) final = SvUV(*svp); - Newz(0, d, len*2+1, U8); - dst = d; + New(0, d, len*3+UTF8_MAXLEN, U8); + dend = d + len * 3; + dstart = d; if (squash) { UV puv = 0xfeedface; while (s < send) { - if (SvUTF8(sv)) - uv = swash_fetch(rv, s); - else { - U8 tmpbuf[2]; - uv = *s++; - if (uv < 0x80) - tmpbuf[0] = uv; - else { - tmpbuf[0] = (( uv >> 6) | 0xc0); - tmpbuf[1] = (( uv & 0x3f) | 0x80); - } - uv = swash_fetch(rv, tmpbuf); + uv = swash_fetch(rv, s); + + if (d >= dend) { + STRLEN clen = d - dstart, nlen = dend - dstart + len; + Renew(dstart, nlen+UTF8_MAXLEN, U8); + d = dstart + clen; + dend = dstart + nlen; } - if (uv < none) { matches++; if (uv != puv) { - if ((uv & 0x80) && !isutf++) - HALF_UTF8_UPGRADE(dst,d); d = uv_to_utf8(d, uv); puv = uv; } @@ -363,9 +408,9 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */ continue; } else if (uv == none) { /* "none" is unmapped character */ - I32 ulen; - *d++ = (U8)utf8_to_uv_chk(s, &ulen, 0); - s += ulen; + int i = UTF8SKIP(s); + while(i--) + *d++ = *s++; puv = 0xfeedface; continue; } @@ -384,18 +429,12 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */ } else { while (s < send) { - if (SvUTF8(sv)) - uv = swash_fetch(rv, s); - else { - U8 tmpbuf[2]; - uv = *s++; - if (uv < 0x80) - tmpbuf[0] = uv; - else { - tmpbuf[0] = (( uv >> 6) | 0xc0); - tmpbuf[1] = (( uv & 0x3f) | 0x80); - } - uv = swash_fetch(rv, tmpbuf); + uv = swash_fetch(rv, s); + if (d >= dend) { + STRLEN clen = d - dstart, nlen = dend - dstart + len; + Renew(dstart, nlen+UTF8_MAXLEN, U8); + d = dstart + clen; + dend = dstart + nlen; } if (uv < none) { matches++; @@ -404,9 +443,9 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */ continue; } else if (uv == none) { /* "none" is unmapped character */ - I32 ulen; - *d++ = (U8)utf8_to_uv_chk(s, &ulen, 0); - s += ulen; + int i = UTF8SKIP(s); + while(i--) + *d++ = *s++; continue; } else if (uv == extra && !del) { @@ -419,12 +458,13 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */ s += UTF8SKIP(s); } } - if (dst) - sv_usepvn(sv, (char*)dst, d - dst); - else { - *d = '\0'; - SvCUR_set(sv, d - (U8*)SvPVX(sv)); - } + *d = '\0'; + sv_setpvn(sv, (char*)dstart, d - dstart); + SvUTF8_on(sv); + if (hibit) + Safefree(start); + if (!isutf8 && !(PL_hints & HINT_UTF8)) + sv_utf8_downgrade(sv, TRUE); SvSETMAGIC(sv); return matches; @@ -433,7 +473,6 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */ I32 Perl_do_trans(pTHX_ SV *sv) { - dTHR; STRLEN len; I32 hasutf = (PL_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)); @@ -501,8 +540,6 @@ Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **s } if (items-- > 0) { - char *s; - sv_setpv(sv, ""); if (*mark) sv_catsv(sv, *mark); @@ -510,10 +547,9 @@ Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **s } else sv_setpv(sv,""); - len = delimlen; - if (len) { + if (delimlen) { for (; items > 0; items--,mark++) { - sv_catpvn(sv,delim,len); + sv_catsv(sv,del); sv_catsv(sv,*mark); } } @@ -550,9 +586,8 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ Perl_croak(aTHX_ "Illegal number of bits in vec"); - if (SvUTF8(sv)) { + if (SvUTF8(sv)) (void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE); - } offset *= size; /* turn into bit offset */ len = (offset + size + 7) / 8; /* required number of bytes */ @@ -585,7 +620,6 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) } #ifdef UV_IS_QUAD else if (size == 64) { - dTHR; if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ WARN_PORTABLE, "Bit vector size > 32 non-portable"); @@ -655,7 +689,6 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) s[offset + 3]; #ifdef UV_IS_QUAD else if (size == 64) { - dTHR; if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ WARN_PORTABLE, "Bit vector size > 32 non-portable"); @@ -743,7 +776,6 @@ Perl_do_vecset(pTHX_ SV *sv) } #ifdef UV_IS_QUAD else if (size == 64) { - dTHR; if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ WARN_PORTABLE, "Bit vector size > 32 non-portable"); @@ -766,7 +798,6 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv) { STRLEN len; char *s; - dTHR; if (SvTYPE(sv) == SVt_PVAV) { register I32 i; @@ -799,15 +830,15 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv) char *send = s + len; char *start = s; s = send - 1; - while ((*s & 0xc0) == 0x80) - --s; - if (UTF8SKIP(s) != send - s && ckWARN_d(WARN_UTF8)) - Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); - sv_setpvn(astr, s, send - s); - *s = '\0'; - SvCUR_set(sv, s - start); - SvNIOK_off(sv); - SvUTF8_on(astr); + while (s > start && UTF8_IS_CONTINUATION(*s)) + s--; + if (utf8_to_uv_simple((U8*)s, 0)) { + sv_setpvn(astr, s, send - s); + *s = '\0'; + SvCUR_set(sv, s - start); + SvNIOK_off(sv); + SvUTF8_on(astr); + } } else sv_setpvn(astr, "", 0); @@ -828,7 +859,6 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv) I32 Perl_do_chomp(pTHX_ register SV *sv) { - dTHR; register I32 count; STRLEN len; char *s; @@ -906,7 +936,6 @@ Perl_do_chomp(pTHX_ register SV *sv) void Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) { - dTHR; /* just for taint */ #ifdef LIBERAL register long *dl; register long *ll; @@ -927,7 +956,7 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) if (left_utf && !right_utf) sv_utf8_upgrade(right); - if (!left_utf && right_utf) + else if (!left_utf && right_utf) sv_utf8_upgrade(left); if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv))) @@ -964,15 +993,15 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) char *dcsave = dc; STRLEN lulen = leftlen; STRLEN rulen = rightlen; - I32 ulen; + STRLEN ulen; switch (optype) { case OP_BIT_AND: while (lulen && rulen) { - luc = utf8_to_uv_chk((U8*)lc, &ulen, 0); + luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); lc += ulen; lulen -= ulen; - ruc = utf8_to_uv_chk((U8*)rc, &ulen, 0); + ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); rc += ulen; rulen -= ulen; duc = luc & ruc; @@ -984,10 +1013,10 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) break; case OP_BIT_XOR: while (lulen && rulen) { - luc = utf8_to_uv_chk((U8*)lc, &ulen, 0); + luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); lc += ulen; lulen -= ulen; - ruc = utf8_to_uv_chk((U8*)rc, &ulen, 0); + ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); rc += ulen; rulen -= ulen; duc = luc ^ ruc; @@ -996,10 +1025,10 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) goto mop_up_utf; case OP_BIT_OR: while (lulen && rulen) { - luc = utf8_to_uv_chk((U8*)lc, &ulen, 0); + luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); lc += ulen; lulen -= ulen; - ruc = utf8_to_uv_chk((U8*)rc, &ulen, 0); + ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); rc += ulen; rulen -= ulen; duc = luc | ruc; @@ -1,6 +1,6 @@ /* dump.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -29,7 +29,6 @@ Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) void Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) { - dTHR; PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), ""); PerlIO_vprintf(file, pat, *args); } @@ -37,7 +36,6 @@ Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) void Perl_dump_all(pTHX) { - dTHR; PerlIO_setlinebuf(Perl_debug_log); if (PL_main_root) op_dump(PL_main_root); @@ -47,7 +45,6 @@ Perl_dump_all(pTHX) void Perl_dump_packsubs(pTHX_ HV *stash) { - dTHR; I32 i; HE *entry; @@ -275,6 +272,8 @@ Perl_sv_peek(pTHX_ SV *sv) if (SvOOK(sv)) Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX(sv)-SvIVX(sv), SvIVX(sv), 0, 127)); Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX(sv), SvCUR(sv), SvLEN(sv), 127)); + if (SvUTF8(sv)) + Perl_sv_catpvf(aTHX_ t, " [UTF8]"); SvREFCNT_dec(tmp); } } @@ -369,7 +368,6 @@ Perl_pmop_dump(pTHX_ PMOP *pm) void Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) { - dTHR; Perl_dump_indent(aTHX_ level, file, "{\n"); level++; if (o->op_seq) @@ -457,6 +455,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) } else if (o->op_type == OP_ENTERSUB || o->op_type == OP_RV2SV || + o->op_type == OP_GVSV || o->op_type == OP_RV2AV || o->op_type == OP_RV2HV || o->op_type == OP_RV2GV || @@ -768,7 +767,6 @@ Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv) void Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) { - dTHR; SV *d; char *s; U32 flags; @@ -822,6 +820,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,"); if (CvCLONE(sv)) sv_catpv(d, "CLONE,"); if (CvCLONED(sv)) sv_catpv(d, "CLONED,"); + if (CvCONST(sv)) sv_catpv(d, "CONST,"); if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,"); if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,"); break; diff --git a/emacs/cperl-mode.el b/emacs/cperl-mode.el index 383d164914..ff16b03942 100644 --- a/emacs/cperl-mode.el +++ b/emacs/cperl-mode.el @@ -7083,7 +7083,6 @@ Currently it is tuned to C and Perl syntax." found-bad found))) (not not-found))) - ;;; Getting help (defvar cperl-have-help-regexp ;;(concat "\\(" diff --git a/emacs/ptags b/emacs/ptags index 54770a0a14..1054ac11de 100755 --- a/emacs/ptags +++ b/emacs/ptags @@ -21,7 +21,7 @@ if test ! -z "$OS2_SHELL"; then alias find=gnufind; fi # Move autogenerated less-informative files to the end: # Hard to do embed.h and embedvar.h in one sweep: -topfiles="`echo ' ' *.y *.c *.h ' ' | sed 's/ / /g' | sed 's/ embedvar\.h\|embed\.h\|obj\(pp\|XSUB\)\.h\|\(globals\|perlapi\)\.c / /g'`" +topfiles="`echo ' ' *.y *.c *.h ' ' | sed 's/ / /g' | sed 's/ embedvar\.h\|embed\.h\|perlapi\.h\|obj\(pp\|XSUB\)\.h\|\(globals\|perlapi\)\.c / /g'`" subdirs="`find ./* -maxdepth 0 -type d`" subdirfiles="`find $subdirs -name '*.[cy]' -print | sort`" subdirfiles1="`find $subdirs -name '*.[hH]' -print | sort`" @@ -99,7 +99,7 @@ perl -w014pe 'if (s/^(S_ # 1: First group }' TAGS.tmp > TAGS.tm1 && mv TAGS.tm1 TAGS.tmp etags -o TAGS.tmp -a -D -l none -r '/#define.*\t\(Perl_.*\)/\1/' embed.h -etags -o TAGS.tmp -a globals.c embedvar.h objXSUB.h perlapi.c +etags -o TAGS.tmp -a globals.c embedvar.h objXSUB.h perlapi.c perlapi.h # The above processes created a lot of descriptions with an # an explicitly specified tag. Such descriptions have higher @@ -68,6 +68,7 @@ #endif #define amagic_call Perl_amagic_call #define Gv_AMupdate Perl_Gv_AMupdate +#define gv_handler Perl_gv_handler #define append_elem Perl_append_elem #define append_list Perl_append_list #define apply Perl_apply @@ -542,6 +543,7 @@ #define ref Perl_ref #define refkids Perl_refkids #define regdump Perl_regdump +#define regclass_swash Perl_regclass_swash #define pregexec Perl_pregexec #define pregfree Perl_pregfree #define pregcomp Perl_pregcomp @@ -597,6 +599,7 @@ #define save_pptr Perl_save_pptr #define save_vptr Perl_save_vptr #define save_re_context Perl_save_re_context +#define save_padsv Perl_save_padsv #define save_sptr Perl_save_sptr #define save_svref Perl_save_svref #define save_threadsv Perl_save_threadsv @@ -701,6 +704,7 @@ #define sv_tainted Perl_sv_tainted #define sv_unmagic Perl_sv_unmagic #define sv_unref Perl_sv_unref +#define sv_unref_flags Perl_sv_unref_flags #define sv_untaint Perl_sv_untaint #define sv_upgrade Perl_sv_upgrade #define sv_usepvn Perl_sv_usepvn @@ -725,12 +729,13 @@ #define utilize Perl_utilize #define utf16_to_utf8 Perl_utf16_to_utf8 #define utf16_to_utf8_reversed Perl_utf16_to_utf8_reversed +#define utf8_length Perl_utf8_length #define utf8_distance Perl_utf8_distance #define utf8_hop Perl_utf8_hop #define utf8_to_bytes Perl_utf8_to_bytes #define bytes_to_utf8 Perl_bytes_to_utf8 +#define utf8_to_uv_simple Perl_utf8_to_uv_simple #define utf8_to_uv Perl_utf8_to_uv -#define utf8_to_uv_chk Perl_utf8_to_uv_chk #define uv_to_utf8 Perl_uv_to_utf8 #define vivify_defelem Perl_vivify_defelem #define vivify_ref Perl_vivify_ref @@ -744,7 +749,8 @@ #define watch Perl_watch #define whichsig Perl_whichsig #define yyerror Perl_yyerror -#if defined(USE_PURE_BISON) +#ifdef USE_PURE_BISON +#define yylex_r Perl_yylex_r #define yylex Perl_yylex #else #define yylex Perl_yylex @@ -816,6 +822,7 @@ #define sv_utf8_encode Perl_sv_utf8_encode #define sv_utf8_decode Perl_sv_utf8_decode #define sv_force_normal Perl_sv_force_normal +#define sv_force_normal_flags Perl_sv_force_normal_flags #define tmps_grow Perl_tmps_grow #define sv_rvweaken Perl_sv_rvweaken #define magic_killbackrefs Perl_magic_killbackrefs @@ -989,7 +996,6 @@ #define regbranch S_regbranch #define reguni S_reguni #define regclass S_regclass -#define regclassutf8 S_regclassutf8 #define regcurly S_regcurly #define reg_node S_reg_node #define regpiece S_regpiece @@ -1019,13 +1025,14 @@ #define regrepeat_hard S_regrepeat_hard #define regtry S_regtry #define reginclass S_reginclass -#define reginclassutf8 S_reginclassutf8 #define regcppush S_regcppush #define regcppop S_regcppop #define regcp_set_to S_regcp_set_to #define cache_re S_cache_re #define reghop S_reghop +#define reghop3 S_reghop3 #define reghopmaybe S_reghopmaybe +#define reghopmaybe3 S_reghopmaybe3 #define find_byclass S_find_byclass #endif #if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT) @@ -1082,6 +1089,10 @@ # if defined(DEBUGGING) #define del_sv S_del_sv # endif +# if !defined(NV_PRESERVES_UV) +#define sv_2inuv_non_preserve S_sv_2inuv_non_preserve +#define sv_2iuv_non_preserve S_sv_2iuv_non_preserve +# endif #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #define check_uni S_check_uni @@ -1134,6 +1145,7 @@ #define isa_lookup S_isa_lookup #endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) +#define stdize_locale S_stdize_locale #define mess_alloc S_mess_alloc # if defined(LEAKTEST) #define xstat S_xstat @@ -1550,6 +1562,7 @@ #endif #define amagic_call(a,b,c,d) Perl_amagic_call(aTHX_ a,b,c,d) #define Gv_AMupdate(a) Perl_Gv_AMupdate(aTHX_ a) +#define gv_handler(a,b) Perl_gv_handler(aTHX_ a,b) #define append_elem(a,b,c) Perl_append_elem(aTHX_ a,b,c) #define append_list(a,b,c) Perl_append_list(aTHX_ a,b,c) #define apply(a,b,c) Perl_apply(aTHX_ a,b,c) @@ -2003,6 +2016,7 @@ #define ref(a,b) Perl_ref(aTHX_ a,b) #define refkids(a,b) Perl_refkids(aTHX_ a,b) #define regdump(a) Perl_regdump(aTHX_ a) +#define regclass_swash(a,b,c) Perl_regclass_swash(aTHX_ a,b,c) #define pregexec(a,b,c,d,e,f,g) Perl_pregexec(aTHX_ a,b,c,d,e,f,g) #define pregfree(a) Perl_pregfree(aTHX_ a) #define pregcomp(a,b,c) Perl_pregcomp(aTHX_ a,b,c) @@ -2058,6 +2072,7 @@ #define save_pptr(a) Perl_save_pptr(aTHX_ a) #define save_vptr(a) Perl_save_vptr(aTHX_ a) #define save_re_context() Perl_save_re_context(aTHX) +#define save_padsv(a) Perl_save_padsv(aTHX_ a) #define save_sptr(a) Perl_save_sptr(aTHX_ a) #define save_svref(a) Perl_save_svref(aTHX_ a) #define save_threadsv(a) Perl_save_threadsv(aTHX_ a) @@ -2068,7 +2083,7 @@ #define scalarvoid(a) Perl_scalarvoid(aTHX_ a) #define scan_bin(a,b,c) Perl_scan_bin(aTHX_ a,b,c) #define scan_hex(a,b,c) Perl_scan_hex(aTHX_ a,b,c) -#define scan_num(a) Perl_scan_num(aTHX_ a) +#define scan_num(a,b) Perl_scan_num(aTHX_ a,b) #define scan_oct(a,b,c) Perl_scan_oct(aTHX_ a,b,c) #define scope(a) Perl_scope(aTHX_ a) #define screaminstr(a,b,c,d,e,f) Perl_screaminstr(aTHX_ a,b,c,d,e,f) @@ -2160,6 +2175,7 @@ #define sv_tainted(a) Perl_sv_tainted(aTHX_ a) #define sv_unmagic(a,b) Perl_sv_unmagic(aTHX_ a,b) #define sv_unref(a) Perl_sv_unref(aTHX_ a) +#define sv_unref_flags(a,b) Perl_sv_unref_flags(aTHX_ a,b) #define sv_untaint(a) Perl_sv_untaint(aTHX_ a) #define sv_upgrade(a,b) Perl_sv_upgrade(aTHX_ a,b) #define sv_usepvn(a,b,c) Perl_sv_usepvn(aTHX_ a,b,c) @@ -2184,12 +2200,13 @@ #define utilize(a,b,c,d,e) Perl_utilize(aTHX_ a,b,c,d,e) #define utf16_to_utf8(a,b,c,d) Perl_utf16_to_utf8(aTHX_ a,b,c,d) #define utf16_to_utf8_reversed(a,b,c,d) Perl_utf16_to_utf8_reversed(aTHX_ a,b,c,d) +#define utf8_length(a,b) Perl_utf8_length(aTHX_ a,b) #define utf8_distance(a,b) Perl_utf8_distance(aTHX_ a,b) #define utf8_hop(a,b) Perl_utf8_hop(aTHX_ a,b) #define utf8_to_bytes(a,b) Perl_utf8_to_bytes(aTHX_ a,b) #define bytes_to_utf8(a,b) Perl_bytes_to_utf8(aTHX_ a,b) -#define utf8_to_uv(a,b) Perl_utf8_to_uv(aTHX_ a,b) -#define utf8_to_uv_chk(a,b,c) Perl_utf8_to_uv_chk(aTHX_ a,b,c) +#define utf8_to_uv_simple(a,b) Perl_utf8_to_uv_simple(aTHX_ a,b) +#define utf8_to_uv(a,b,c,d) Perl_utf8_to_uv(aTHX_ a,b,c,d) #define uv_to_utf8(a,b) Perl_uv_to_utf8(aTHX_ a,b) #define vivify_defelem(a) Perl_vivify_defelem(aTHX_ a) #define vivify_ref(a,b) Perl_vivify_ref(aTHX_ a,b) @@ -2201,7 +2218,8 @@ #define watch(a) Perl_watch(aTHX_ a) #define whichsig(a) Perl_whichsig(aTHX_ a) #define yyerror(a) Perl_yyerror(aTHX_ a) -#if defined(USE_PURE_BISON) +#ifdef USE_PURE_BISON +#define yylex_r(a,b) Perl_yylex_r(aTHX_ a,b) #define yylex(a,b) Perl_yylex(aTHX_ a,b) #else #define yylex() Perl_yylex(aTHX) @@ -2269,6 +2287,7 @@ #define sv_utf8_encode(a) Perl_sv_utf8_encode(aTHX_ a) #define sv_utf8_decode(a) Perl_sv_utf8_decode(aTHX_ a) #define sv_force_normal(a) Perl_sv_force_normal(aTHX_ a) +#define sv_force_normal_flags(a,b) Perl_sv_force_normal_flags(aTHX_ a,b) #define tmps_grow(a) Perl_tmps_grow(aTHX_ a) #define sv_rvweaken(a) Perl_sv_rvweaken(aTHX_ a) #define magic_killbackrefs(a,b) Perl_magic_killbackrefs(aTHX_ a,b) @@ -2436,48 +2455,48 @@ # endif #endif #if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT) -#define reg(a,b) S_reg(aTHX_ a,b) -#define reganode(a,b) S_reganode(aTHX_ a,b) -#define regatom(a) S_regatom(aTHX_ a) -#define regbranch(a,b) S_regbranch(aTHX_ a,b) -#define reguni(a,b,c) S_reguni(aTHX_ a,b,c) -#define regclass() S_regclass(aTHX) -#define regclassutf8() S_regclassutf8(aTHX) +#define reg(a,b,c) S_reg(aTHX_ a,b,c) +#define reganode(a,b,c) S_reganode(aTHX_ a,b,c) +#define regatom(a,b) S_regatom(aTHX_ a,b) +#define regbranch(a,b,c) S_regbranch(aTHX_ a,b,c) +#define reguni(a,b,c,d) S_reguni(aTHX_ a,b,c,d) +#define regclass(a) S_regclass(aTHX_ a) #define regcurly(a) S_regcurly(aTHX_ a) -#define reg_node(a) S_reg_node(aTHX_ a) -#define regpiece(a) S_regpiece(aTHX_ a) -#define reginsert(a,b) S_reginsert(aTHX_ a,b) -#define regoptail(a,b) S_regoptail(aTHX_ a,b) -#define regtail(a,b) S_regtail(aTHX_ a,b) +#define reg_node(a,b) S_reg_node(aTHX_ a,b) +#define regpiece(a,b) S_regpiece(aTHX_ a,b) +#define reginsert(a,b,c) S_reginsert(aTHX_ a,b,c) +#define regoptail(a,b,c) S_regoptail(aTHX_ a,b,c) +#define regtail(a,b,c) S_regtail(aTHX_ a,b,c) #define regwhite(a,b) S_regwhite(aTHX_ a,b) -#define nextchar() S_nextchar(aTHX) +#define nextchar(a) S_nextchar(aTHX_ a) #define dumpuntil(a,b,c,d,e) S_dumpuntil(aTHX_ a,b,c,d,e) #define put_byte(a,b) S_put_byte(aTHX_ a,b) -#define scan_commit(a) S_scan_commit(aTHX_ a) -#define cl_anything(a) S_cl_anything(aTHX_ a) +#define scan_commit(a,b) S_scan_commit(aTHX_ a,b) +#define cl_anything(a,b) S_cl_anything(aTHX_ a,b) #define cl_is_anything(a) S_cl_is_anything(aTHX_ a) -#define cl_init(a) S_cl_init(aTHX_ a) -#define cl_init_zero(a) S_cl_init_zero(aTHX_ a) +#define cl_init(a,b) S_cl_init(aTHX_ a,b) +#define cl_init_zero(a,b) S_cl_init_zero(aTHX_ a,b) #define cl_and(a,b) S_cl_and(aTHX_ a,b) -#define cl_or(a,b) S_cl_or(aTHX_ a,b) -#define study_chunk(a,b,c,d,e) S_study_chunk(aTHX_ a,b,c,d,e) -#define add_data(a,b) S_add_data(aTHX_ a,b) -#define regpposixcc(a) S_regpposixcc(aTHX_ a) -#define checkposixcc() S_checkposixcc(aTHX) +#define cl_or(a,b,c) S_cl_or(aTHX_ a,b,c) +#define study_chunk(a,b,c,d,e,f) S_study_chunk(aTHX_ a,b,c,d,e,f) +#define add_data(a,b,c) S_add_data(aTHX_ a,b,c) +#define regpposixcc(a,b) S_regpposixcc(aTHX_ a,b) +#define checkposixcc(a) S_checkposixcc(aTHX_ a) #endif #if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT) #define regmatch(a) S_regmatch(aTHX_ a) #define regrepeat(a,b) S_regrepeat(aTHX_ a,b) #define regrepeat_hard(a,b,c) S_regrepeat_hard(aTHX_ a,b,c) #define regtry(a,b) S_regtry(aTHX_ a,b) -#define reginclass(a,b) S_reginclass(aTHX_ a,b) -#define reginclassutf8(a,b) S_reginclassutf8(aTHX_ a,b) +#define reginclass(a,b,c) S_reginclass(aTHX_ a,b,c) #define regcppush(a) S_regcppush(aTHX_ a) #define regcppop() S_regcppop(aTHX) #define regcp_set_to(a) S_regcp_set_to(aTHX_ a) #define cache_re(a) S_cache_re(aTHX_ a) #define reghop(a,b) S_reghop(aTHX_ a,b) +#define reghop3(a,b,c) S_reghop3(aTHX_ a,b,c) #define reghopmaybe(a,b) S_reghopmaybe(aTHX_ a,b) +#define reghopmaybe3(a,b,c) S_reghopmaybe3(aTHX_ a,b,c) #define find_byclass(a,b,c,d,e,f) S_find_byclass(aTHX_ a,b,c,d,e,f) #endif #if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT) @@ -2534,6 +2553,10 @@ # if defined(DEBUGGING) #define del_sv(a) S_del_sv(aTHX_ a) # endif +# if !defined(NV_PRESERVES_UV) +#define sv_2inuv_non_preserve(a,b) S_sv_2inuv_non_preserve(aTHX_ a,b) +#define sv_2iuv_non_preserve(a,b) S_sv_2iuv_non_preserve(aTHX_ a,b) +# endif #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #define check_uni() S_check_uni(aTHX) @@ -2586,6 +2609,7 @@ #define isa_lookup(a,b,c,d) S_isa_lookup(aTHX_ a,b,c,d) #endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) +#define stdize_locale(a) S_stdize_locale(aTHX_ a) #define mess_alloc() S_mess_alloc(aTHX) # if defined(LEAKTEST) #define xstat(a) S_xstat(aTHX_ a) @@ -3009,6 +3033,8 @@ #define amagic_call Perl_amagic_call #define Perl_Gv_AMupdate CPerlObj::Perl_Gv_AMupdate #define Gv_AMupdate Perl_Gv_AMupdate +#define Perl_gv_handler CPerlObj::Perl_gv_handler +#define gv_handler Perl_gv_handler #define Perl_append_elem CPerlObj::Perl_append_elem #define append_elem Perl_append_elem #define Perl_append_list CPerlObj::Perl_append_list @@ -3849,6 +3875,8 @@ #define pad_swipe Perl_pad_swipe #define Perl_peep CPerlObj::Perl_peep #define peep Perl_peep +#define Perl_start_glob CPerlObj::Perl_start_glob +#define start_glob Perl_start_glob #if defined(PERL_OBJECT) #define Perl_construct CPerlObj::Perl_construct #define Perl_destruct CPerlObj::Perl_destruct @@ -3924,6 +3952,8 @@ #define refkids Perl_refkids #define Perl_regdump CPerlObj::Perl_regdump #define regdump Perl_regdump +#define Perl_regclass_swash CPerlObj::Perl_regclass_swash +#define regclass_swash Perl_regclass_swash #define Perl_pregexec CPerlObj::Perl_pregexec #define pregexec Perl_pregexec #define Perl_pregfree CPerlObj::Perl_pregfree @@ -4032,6 +4062,8 @@ #define save_vptr Perl_save_vptr #define Perl_save_re_context CPerlObj::Perl_save_re_context #define save_re_context Perl_save_re_context +#define Perl_save_padsv CPerlObj::Perl_save_padsv +#define save_padsv Perl_save_padsv #define Perl_save_sptr CPerlObj::Perl_save_sptr #define save_sptr Perl_save_sptr #define Perl_save_svref CPerlObj::Perl_save_svref @@ -4236,6 +4268,8 @@ #define sv_unmagic Perl_sv_unmagic #define Perl_sv_unref CPerlObj::Perl_sv_unref #define sv_unref Perl_sv_unref +#define Perl_sv_unref_flags CPerlObj::Perl_sv_unref_flags +#define sv_unref_flags Perl_sv_unref_flags #define Perl_sv_untaint CPerlObj::Perl_sv_untaint #define sv_untaint Perl_sv_untaint #define Perl_sv_upgrade CPerlObj::Perl_sv_upgrade @@ -4280,6 +4314,8 @@ #define utf16_to_utf8 Perl_utf16_to_utf8 #define Perl_utf16_to_utf8_reversed CPerlObj::Perl_utf16_to_utf8_reversed #define utf16_to_utf8_reversed Perl_utf16_to_utf8_reversed +#define Perl_utf8_length CPerlObj::Perl_utf8_length +#define utf8_length Perl_utf8_length #define Perl_utf8_distance CPerlObj::Perl_utf8_distance #define utf8_distance Perl_utf8_distance #define Perl_utf8_hop CPerlObj::Perl_utf8_hop @@ -4288,10 +4324,10 @@ #define utf8_to_bytes Perl_utf8_to_bytes #define Perl_bytes_to_utf8 CPerlObj::Perl_bytes_to_utf8 #define bytes_to_utf8 Perl_bytes_to_utf8 +#define Perl_utf8_to_uv_simple CPerlObj::Perl_utf8_to_uv_simple +#define utf8_to_uv_simple Perl_utf8_to_uv_simple #define Perl_utf8_to_uv CPerlObj::Perl_utf8_to_uv #define utf8_to_uv Perl_utf8_to_uv -#define Perl_utf8_to_uv_chk CPerlObj::Perl_utf8_to_uv_chk -#define utf8_to_uv_chk Perl_utf8_to_uv_chk #define Perl_uv_to_utf8 CPerlObj::Perl_uv_to_utf8 #define uv_to_utf8 Perl_uv_to_utf8 #define Perl_vivify_defelem CPerlObj::Perl_vivify_defelem @@ -4318,7 +4354,9 @@ #define whichsig Perl_whichsig #define Perl_yyerror CPerlObj::Perl_yyerror #define yyerror Perl_yyerror -#if defined(USE_PURE_BISON) +#ifdef USE_PURE_BISON +#define Perl_yylex_r CPerlObj::Perl_yylex_r +#define yylex_r Perl_yylex_r #define Perl_yylex CPerlObj::Perl_yylex #define yylex Perl_yylex #else @@ -4449,6 +4487,8 @@ #define sv_utf8_decode Perl_sv_utf8_decode #define Perl_sv_force_normal CPerlObj::Perl_sv_force_normal #define sv_force_normal Perl_sv_force_normal +#define Perl_sv_force_normal_flags CPerlObj::Perl_sv_force_normal_flags +#define sv_force_normal_flags Perl_sv_force_normal_flags #define Perl_tmps_grow CPerlObj::Perl_tmps_grow #define tmps_grow Perl_tmps_grow #define Perl_sv_rvweaken CPerlObj::Perl_sv_rvweaken @@ -4751,8 +4791,6 @@ #define reguni S_reguni #define S_regclass CPerlObj::S_regclass #define regclass S_regclass -#define S_regclassutf8 CPerlObj::S_regclassutf8 -#define regclassutf8 S_regclassutf8 #define S_regcurly CPerlObj::S_regcurly #define regcurly S_regcurly #define S_reg_node CPerlObj::S_reg_node @@ -4809,8 +4847,6 @@ #define regtry S_regtry #define S_reginclass CPerlObj::S_reginclass #define reginclass S_reginclass -#define S_reginclassutf8 CPerlObj::S_reginclassutf8 -#define reginclassutf8 S_reginclassutf8 #define S_regcppush CPerlObj::S_regcppush #define regcppush S_regcppush #define S_regcppop CPerlObj::S_regcppop @@ -4821,8 +4857,12 @@ #define cache_re S_cache_re #define S_reghop CPerlObj::S_reghop #define reghop S_reghop +#define S_reghop3 CPerlObj::S_reghop3 +#define reghop3 S_reghop3 #define S_reghopmaybe CPerlObj::S_reghopmaybe #define reghopmaybe S_reghopmaybe +#define S_reghopmaybe3 CPerlObj::S_reghopmaybe3 +#define reghopmaybe3 S_reghopmaybe3 #define S_find_byclass CPerlObj::S_find_byclass #define find_byclass S_find_byclass #endif @@ -4927,6 +4967,12 @@ #define S_del_sv CPerlObj::S_del_sv #define del_sv S_del_sv # endif +# if !defined(NV_PRESERVES_UV) +#define S_sv_2inuv_non_preserve CPerlObj::S_sv_2inuv_non_preserve +#define sv_2inuv_non_preserve S_sv_2inuv_non_preserve +#define S_sv_2iuv_non_preserve CPerlObj::S_sv_2iuv_non_preserve +#define sv_2iuv_non_preserve S_sv_2iuv_non_preserve +# endif #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #define S_check_uni CPerlObj::S_check_uni @@ -5019,6 +5065,8 @@ #define isa_lookup S_isa_lookup #endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) +#define S_stdize_locale CPerlObj::S_stdize_locale +#define stdize_locale S_stdize_locale #define S_mess_alloc CPerlObj::S_mess_alloc #define mess_alloc S_mess_alloc # if defined(LEAKTEST) @@ -1376,6 +1376,7 @@ START_EXTERN_C # include "pp_proto.h" Ap |SV* |amagic_call |SV* left|SV* right|int method|int dir Ap |bool |Gv_AMupdate |HV* stash +Ap |CV* |gv_handler |HV* stash|I32 id p |OP* |append_elem |I32 optype|OP* head|OP* tail p |OP* |append_list |I32 optype|LISTOP* first|LISTOP* last p |I32 |apply |I32 type|SV** mark|SV** sp @@ -1441,7 +1442,7 @@ Afnp |int |fprintf_nocontext|PerlIO* stream|const char* fmt|... #endif p |void |cv_ckproto |CV* cv|GV* gv|char* p p |CV* |cv_clone |CV* proto -Ap |SV* |cv_const_sv |CV* cv +Apd |SV* |cv_const_sv |CV* cv p |SV* |op_const_sv |OP* o|CV* cv Ap |void |cv_undef |CV* cv Ap |void |cx_dump |PERL_CONTEXT* cs @@ -1563,11 +1564,11 @@ Ap |HV* |gv_stashpvn |const char* name|U32 namelen|I32 create Apd |HV* |gv_stashsv |SV* sv|I32 create Apd |void |hv_clear |HV* tb Ap |void |hv_delayfree_ent|HV* hv|HE* entry -Apd |SV* |hv_delete |HV* tb|const char* key|U32 klen|I32 flags +Apd |SV* |hv_delete |HV* tb|const char* key|I32 klen|I32 flags Apd |SV* |hv_delete_ent |HV* tb|SV* key|I32 flags|U32 hash -Apd |bool |hv_exists |HV* tb|const char* key|U32 klen +Apd |bool |hv_exists |HV* tb|const char* key|I32 klen Apd |bool |hv_exists_ent |HV* tb|SV* key|U32 hash -Apd |SV** |hv_fetch |HV* tb|const char* key|U32 klen|I32 lval +Apd |SV** |hv_fetch |HV* tb|const char* key|I32 klen|I32 lval Apd |HE* |hv_fetch_ent |HV* tb|SV* key|I32 lval|U32 hash Ap |void |hv_free_ent |HV* hv|HE* entry Apd |I32 |hv_iterinit |HV* tb @@ -1578,7 +1579,7 @@ Apd |SV* |hv_iternextsv |HV* hv|char** key|I32* retlen Apd |SV* |hv_iterval |HV* tb|HE* entry Ap |void |hv_ksplit |HV* hv|IV newmax Apd |void |hv_magic |HV* hv|GV* gv|int how -Apd |SV** |hv_store |HV* tb|const char* key|U32 klen|SV* val \ +Apd |SV** |hv_store |HV* tb|const char* key|I32 klen|SV* val \ |U32 hash Apd |HE* |hv_store_ent |HV* tb|SV* key|SV* val|U32 hash Apd |void |hv_undef |HV* tb @@ -1626,7 +1627,7 @@ Ap |bool |is_uni_xdigit_lc|U32 c Ap |U32 |to_uni_upper_lc|U32 c Ap |U32 |to_uni_title_lc|U32 c Ap |U32 |to_uni_lower_lc|U32 c -Ap |int |is_utf8_char |U8 *p +Ap |STRLEN |is_utf8_char |U8 *p Ap |bool |is_utf8_string |U8 *s|STRLEN len Ap |bool |is_utf8_alnum |U8 *p Ap |bool |is_utf8_alnumc |U8 *p @@ -1761,7 +1762,7 @@ Ap |OP* |newANONHASH |OP* o Ap |OP* |newANONSUB |I32 floor|OP* proto|OP* block Ap |OP* |newASSIGNOP |I32 flags|OP* left|I32 optype|OP* right Ap |OP* |newCONDOP |I32 flags|OP* expr|OP* trueop|OP* falseop -Apd |void |newCONSTSUB |HV* stash|char* name|SV* sv +Apd |CV* |newCONSTSUB |HV* stash|char* name|SV* sv Ap |void |newFORM |I32 floor|OP* o|OP* block Ap |OP* |newFOROP |I32 flags|char* label|line_t forline \ |OP* sclr|OP* expr|OP*block|OP*cont @@ -1801,7 +1802,7 @@ Apd |SV* |newSVuv |UV u Apd |SV* |newSVnv |NV n Apd |SV* |newSVpv |const char* s|STRLEN len Apd |SV* |newSVpvn |const char* s|STRLEN len -Apd |SV* |newSVpvn_share |const char* s|STRLEN len|U32 hash +Apd |SV* |newSVpvn_share |const char* s|I32 len|U32 hash Afpd |SV* |newSVpvf |const char* pat|... Ap |SV* |vnewSVpvf |const char* pat|va_list* args Apd |SV* |newSVrv |SV* rv|const char* classname @@ -1828,6 +1829,7 @@ p |void |pad_free |PADOFFSET po p |void |pad_reset p |void |pad_swipe |PADOFFSET po p |void |peep |OP* o +dopM |PerlIO*|start_glob |SV* pattern|IO *io #if defined(PERL_OBJECT) Aox |void |Perl_construct Aox |void |Perl_destruct @@ -1852,9 +1854,9 @@ Apd |HV* |get_hv |const char* name|I32 create Apd |CV* |get_cv |const char* name|I32 create Ap |int |init_i18nl10n |int printwarn Ap |int |init_i18nl14n |int printwarn -Ap |void |new_collate |const char* newcoll -Ap |void |new_ctype |const char* newctype -Ap |void |new_numeric |const char* newcoll +Ap |void |new_collate |char* newcoll +Ap |void |new_ctype |char* newctype +Ap |void |new_numeric |char* newcoll Ap |void |set_numeric_local Ap |void |set_numeric_radix Ap |void |set_numeric_standard @@ -1871,6 +1873,7 @@ Ap |void |push_scope p |OP* |ref |OP* o|I32 type p |OP* |refkids |OP* o|I32 type Ap |void |regdump |regexp* r +Ap |SV* |regclass_swash |struct regnode *n|bool doinit|SV **initsvp Ap |I32 |pregexec |regexp* prog|char* stringarg \ |char* strend|char* strbeg|I32 minend \ |SV* screamer|U32 nosave @@ -1933,6 +1936,7 @@ Ap |SV* |save_scalar |GV* gv Ap |void |save_pptr |char** pptr Ap |void |save_vptr |void* pptr Ap |void |save_re_context +Ap |void |save_padsv |PADOFFSET off Ap |void |save_sptr |SV** sptr Ap |SV* |save_svref |SV** sptr Ap |SV** |save_threadsv |PADOFFSET i @@ -1941,10 +1945,10 @@ p |OP* |scalar |OP* o p |OP* |scalarkids |OP* o p |OP* |scalarseq |OP* o p |OP* |scalarvoid |OP* o -Ap |NV |scan_bin |char* start|I32 len|I32* retlen -Ap |NV |scan_hex |char* start|I32 len|I32* retlen -Ap |char* |scan_num |char* s -Ap |NV |scan_oct |char* start|I32 len|I32* retlen +Ap |NV |scan_bin |char* start|STRLEN len|STRLEN* retlen +Ap |NV |scan_hex |char* start|STRLEN len|STRLEN* retlen +Ap |char* |scan_num |char* s|YYSTYPE *lvalp +Ap |NV |scan_oct |char* start|STRLEN len|STRLEN* retlen p |OP* |scope |OP* o Ap |char* |screaminstr |SV* bigsv|SV* littlesv|I32 start_shift \ |I32 end_shift|I32 *state|I32 last @@ -2041,6 +2045,7 @@ Ap |void |sv_taint |SV* sv Ap |bool |sv_tainted |SV* sv Apd |int |sv_unmagic |SV* sv|int type Apd |void |sv_unref |SV* sv +Apd |void |sv_unref_flags |SV* sv|U32 flags Ap |void |sv_untaint |SV* sv Apd |bool |sv_upgrade |SV* sv|U32 mt Apd |void |sv_usepvn |SV* sv|char* ptr|STRLEN len @@ -2070,12 +2075,13 @@ p |void |unshare_hek |HEK* hek p |void |utilize |int aver|I32 floor|OP* version|OP* id|OP* arg Ap |U8* |utf16_to_utf8 |U8* p|U8 *d|I32 bytelen|I32 *newlen Ap |U8* |utf16_to_utf8_reversed|U8* p|U8 *d|I32 bytelen|I32 *newlen -Ap |I32 |utf8_distance |U8 *a|U8 *b +Ap |STRLEN |utf8_length |U8* s|U8 *e +Ap |IV |utf8_distance |U8 *a|U8 *b Ap |U8* |utf8_hop |U8 *s|I32 off ApM |U8* |utf8_to_bytes |U8 *s|STRLEN *len ApM |U8* |bytes_to_utf8 |U8 *s|STRLEN *len -Ap |UV |utf8_to_uv |U8 *s|I32* retlen -Ap |UV |utf8_to_uv_chk |U8 *s|I32* retlen|bool checking +Ap |UV |utf8_to_uv_simple|U8 *s|STRLEN* retlen +Ap |UV |utf8_to_uv |U8 *s|STRLEN curlen|STRLEN* retlen|U32 flags Ap |U8* |uv_to_utf8 |U8 *d|UV uv p |void |vivify_defelem |SV* sv p |void |vivify_ref |SV* sv|U32 to_what @@ -2089,7 +2095,8 @@ Ap |void |vwarner |U32 err|const char* pat|va_list* args p |void |watch |char** addr Ap |I32 |whichsig |char* sig p |int |yyerror |char* s -#if defined(USE_PURE_BISON) +#ifdef USE_PURE_BISON +p |int |yylex_r |YYSTYPE *lvalp|int *lcharp p |int |yylex |YYSTYPE *lvalp|int *lcharp #else p |int |yylex @@ -2167,6 +2174,7 @@ ApdM |bool |sv_utf8_downgrade|SV *sv|bool fail_ok ApdM |void |sv_utf8_encode |SV *sv Ap |bool |sv_utf8_decode |SV *sv Ap |void |sv_force_normal|SV *sv +Ap |void |sv_force_normal_flags|SV *sv|U32 flags Ap |void |tmps_grow |I32 n Apd |SV* |sv_rvweaken |SV *sv p |int |magic_killbackrefs|SV *sv|MAGIC *mg @@ -2353,40 +2361,39 @@ s |int |dooneliner |char *cmd|char *filename #endif #if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT) -s |regnode*|reg |I32|I32 * -s |regnode*|reganode |U8|U32 -s |regnode*|regatom |I32 * -s |regnode*|regbranch |I32 *|I32 -s |void |reguni |UV|char *|I32* -s |regnode*|regclass -s |regnode*|regclassutf8 +s |regnode*|reg |struct RExC_state_t*|I32|I32 * +s |regnode*|reganode |struct RExC_state_t*|U8|U32 +s |regnode*|regatom |struct RExC_state_t*|I32 * +s |regnode*|regbranch |struct RExC_state_t*|I32 *|I32 +s |void |reguni |struct RExC_state_t*|UV|char *|STRLEN* +s |regnode*|regclass |struct RExC_state_t* s |I32 |regcurly |char * -s |regnode*|reg_node |U8 -s |regnode*|regpiece |I32 * -s |void |reginsert |U8|regnode * -s |void |regoptail |regnode *|regnode * -s |void |regtail |regnode *|regnode * +s |regnode*|reg_node |struct RExC_state_t*|U8 +s |regnode*|regpiece |struct RExC_state_t*|I32 * +s |void |reginsert |struct RExC_state_t*|U8|regnode * +s |void |regoptail |struct RExC_state_t*|regnode *|regnode * +s |void |regtail |struct RExC_state_t*|regnode *|regnode * s |char*|regwhite |char *|char * -s |char*|nextchar +s |char*|nextchar |struct RExC_state_t* s |regnode*|dumpuntil |regnode *start|regnode *node \ |regnode *last|SV* sv|I32 l s |void |put_byte |SV* sv|int c -s |void |scan_commit |struct scan_data_t *data -s |void |cl_anything |struct regnode_charclass_class *cl +s |void |scan_commit |struct RExC_state_t*|struct scan_data_t *data +s |void |cl_anything |struct RExC_state_t*|struct regnode_charclass_class *cl s |int |cl_is_anything |struct regnode_charclass_class *cl -s |void |cl_init |struct regnode_charclass_class *cl -s |void |cl_init_zero |struct regnode_charclass_class *cl +s |void |cl_init |struct RExC_state_t*|struct regnode_charclass_class *cl +s |void |cl_init_zero |struct RExC_state_t*|struct regnode_charclass_class *cl s |void |cl_and |struct regnode_charclass_class *cl \ |struct regnode_charclass_class *and_with -s |void |cl_or |struct regnode_charclass_class *cl \ +s |void |cl_or |struct RExC_state_t*|struct regnode_charclass_class *cl \ |struct regnode_charclass_class *or_with -s |I32 |study_chunk |regnode **scanp|I32 *deltap \ +s |I32 |study_chunk |struct RExC_state_t*|regnode **scanp|I32 *deltap \ |regnode *last|struct scan_data_t *data \ |U32 flags -s |I32 |add_data |I32 n|char *s +s |I32 |add_data |struct RExC_state_t*|I32 n|char *s rs |void|re_croak2 |const char* pat1|const char* pat2|... -s |I32 |regpposixcc |I32 value -s |void |checkposixcc +s |I32 |regpposixcc |struct RExC_state_t*|I32 value +s |void |checkposixcc |struct RExC_state_t* #endif #if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT) @@ -2394,14 +2401,15 @@ s |I32 |regmatch |regnode *prog s |I32 |regrepeat |regnode *p|I32 max s |I32 |regrepeat_hard |regnode *p|I32 max|I32 *lp s |I32 |regtry |regexp *prog|char *startpos -s |bool |reginclass |regnode *p|I32 c -s |bool |reginclassutf8 |regnode *f|U8* p +s |bool |reginclass |regnode *n|U8 *p|bool do_utf8sv_is_utf8 s |CHECKPOINT|regcppush |I32 parenfloor s |char*|regcppop s |char*|regcp_set_to |I32 ss s |void |cache_re |regexp *prog s |U8* |reghop |U8 *pos|I32 off +s |U8* |reghop3 |U8 *pos|I32 off|U8 *lim s |U8* |reghopmaybe |U8 *pos|I32 off +s |U8* |reghopmaybe3 |U8 *pos|I32 off|U8 *lim s |char* |find_byclass |regexp * prog|regnode *c|char *s|char *strend|char *startpos|I32 norun #endif @@ -2461,6 +2469,10 @@ s |void |sv_del_backref |SV *sv # if defined(DEBUGGING) s |void |del_sv |SV *p # endif +# if !defined(NV_PRESERVES_UV) +s |int |sv_2inuv_non_preserve |SV *sv|I32 numtype +s |int |sv_2iuv_non_preserve |SV *sv|I32 numtype +# endif #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) @@ -2520,6 +2532,7 @@ s |SV*|isa_lookup |HV *stash|const char *name|int len|int level #endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) +s |char* |stdize_locale |char* locs s |SV* |mess_alloc # if defined(LEAKTEST) s |void |xstat |int diff --git a/embedvar.h b/embedvar.h index 729389c17a..fddcd12733 100644 --- a/embedvar.h +++ b/embedvar.h @@ -70,8 +70,7 @@ #define PL_modcount (vTHX->Tmodcount) #define PL_na (vTHX->Tna) #define PL_nrs (vTHX->Tnrs) -#define PL_ofs (vTHX->Tofs) -#define PL_ofslen (vTHX->Tofslen) +#define PL_ofs_sv (vTHX->Tofs_sv) #define PL_op (vTHX->Top) #define PL_opsave (vTHX->Topsave) #define PL_protect (vTHX->Tprotect) @@ -341,8 +340,7 @@ #define PL_origargv (PERL_GET_INTERP->Iorigargv) #define PL_origenviron (PERL_GET_INTERP->Iorigenviron) #define PL_origfilename (PERL_GET_INTERP->Iorigfilename) -#define PL_ors (PERL_GET_INTERP->Iors) -#define PL_orslen (PERL_GET_INTERP->Iorslen) +#define PL_ors_sv (PERL_GET_INTERP->Iors_sv) #define PL_osname (PERL_GET_INTERP->Iosname) #define PL_pad_reset_pending (PERL_GET_INTERP->Ipad_reset_pending) #define PL_padix (PERL_GET_INTERP->Ipadix) @@ -621,8 +619,7 @@ #define PL_origargv (vTHX->Iorigargv) #define PL_origenviron (vTHX->Iorigenviron) #define PL_origfilename (vTHX->Iorigfilename) -#define PL_ors (vTHX->Iors) -#define PL_orslen (vTHX->Iorslen) +#define PL_ors_sv (vTHX->Iors_sv) #define PL_osname (vTHX->Iosname) #define PL_pad_reset_pending (vTHX->Ipad_reset_pending) #define PL_padix (vTHX->Ipadix) @@ -775,8 +772,7 @@ #define PL_modcount (aTHXo->interp.Tmodcount) #define PL_na (aTHXo->interp.Tna) #define PL_nrs (aTHXo->interp.Tnrs) -#define PL_ofs (aTHXo->interp.Tofs) -#define PL_ofslen (aTHXo->interp.Tofslen) +#define PL_ofs_sv (aTHXo->interp.Tofs_sv) #define PL_op (aTHXo->interp.Top) #define PL_opsave (aTHXo->interp.Topsave) #define PL_protect (aTHXo->interp.Tprotect) @@ -1038,8 +1034,7 @@ #define PL_origargv (aTHXo->interp.Iorigargv) #define PL_origenviron (aTHXo->interp.Iorigenviron) #define PL_origfilename (aTHXo->interp.Iorigfilename) -#define PL_ors (aTHXo->interp.Iors) -#define PL_orslen (aTHXo->interp.Iorslen) +#define PL_ors_sv (aTHXo->interp.Iors_sv) #define PL_osname (aTHXo->interp.Iosname) #define PL_pad_reset_pending (aTHXo->interp.Ipad_reset_pending) #define PL_padix (aTHXo->interp.Ipadix) @@ -1319,8 +1314,7 @@ #define PL_Iorigargv PL_origargv #define PL_Iorigenviron PL_origenviron #define PL_Iorigfilename PL_origfilename -#define PL_Iors PL_ors -#define PL_Iorslen PL_orslen +#define PL_Iors_sv PL_ors_sv #define PL_Iosname PL_osname #define PL_Ipad_reset_pending PL_pad_reset_pending #define PL_Ipadix PL_padix @@ -1469,8 +1463,7 @@ #define PL_modcount (aTHX->Tmodcount) #define PL_na (aTHX->Tna) #define PL_nrs (aTHX->Tnrs) -#define PL_ofs (aTHX->Tofs) -#define PL_ofslen (aTHX->Tofslen) +#define PL_ofs_sv (aTHX->Tofs_sv) #define PL_op (aTHX->Top) #define PL_opsave (aTHX->Topsave) #define PL_protect (aTHX->Tprotect) @@ -1606,8 +1599,7 @@ #define PL_Tmodcount PL_modcount #define PL_Tna PL_na #define PL_Tnrs PL_nrs -#define PL_Tofs PL_ofs -#define PL_Tofslen PL_ofslen +#define PL_Tofs_sv PL_ofs_sv #define PL_Top PL_op #define PL_Topsave PL_opsave #define PL_Tprotect PL_protect diff --git a/epoc/config.sh b/epoc/config.sh index ee65ee35ce..c155ce4e6e 100644 --- a/epoc/config.sh +++ b/epoc/config.sh @@ -78,6 +78,7 @@ cppsymbols='' crosscompile='define' cryptlib='' csh='csh' +d__fwalk='undef' d_Gconvert='epoc_gcvt((x),(n),(b))' d_PRIEUldbl='undef' d_PRIFUldbl='undef' @@ -138,6 +139,7 @@ d_eunice='undef' d_fchmod='undef' d_fchown='undef' d_fcntl='undef' +d_fcntl_can_lock='undef' d_fd_macros='undef' d_fd_set='define' d_fds_bits='undef' @@ -152,6 +154,7 @@ d_fseeko='undef' d_fsetpos='define' d_fstatfs='define' d_fstatvfs='undef' +d_fsync='undef' d_ftello='undef' d_ftime='undef' d_getespwnam='undef' @@ -169,6 +172,7 @@ d_getnbyaddr='undef' d_getnbyname='undef' d_getnent='undef' d_getnetprotos='define' +d_getpagsz='undef' d_getpbyname='define' d_getpbynumber='define' d_getpent='undef' @@ -271,6 +275,7 @@ d_rmdir='define' d_safebcpy='undef' d_safemcpy='undef' d_sanemcmp='define' +d_sbrkproto='undef' d_sched_yield='undef' d_scm_rights='undef' d_seekdir='define' @@ -324,6 +329,8 @@ d_statfsflags='define' d_statvfs='undef' d_stdio_cnt_lval='define' d_stdio_ptr_lval='define' +d_stdio_ptr_lval_sets_cnt='undef' +d_stdio_ptr_lval_nochange_cnt='undef' d_stdio_stream_array='undef' d_stdiobase='undef' d_stdstdio='undef' @@ -334,7 +341,9 @@ d_strerrm='strerror(e)' d_strerror='define' d_strtod='define' d_strtol='define' +d_strtoq='undef' d_strtoul='define' +d_strtouq='undef' d_strtoull='undef' d_strxfrm='define' d_suidsafe='undef' @@ -566,6 +575,7 @@ mydomain='.gmx.de' myhostname='dragon' myuname='' n='-n' +need_va_copy='undef' netdb_hlen_type='int' netdb_host_type='const char *' netdb_name_type='const char *' @@ -973,3 +983,6 @@ i_prot='undef' d_SCNfldbl='undef' d_perl_otherlibdirs='undef' nvsize='16' +issymlink='' + + diff --git a/epoc/epoc.c b/epoc/epoc.c index a2691f3d38..b9bc652c22 100644 --- a/epoc/epoc.c +++ b/epoc/epoc.c @@ -101,7 +101,6 @@ do_aspawn( pTHX_ SV *really,SV **mark,SV **sp) { int do_spawn (pTHX_ SV *really,SV **mark,SV **sp) { - dTHR; int rc; char **a,*cmd,**ptr, *cmdline, **argv, *p2; STRLEN n_a; diff --git a/epoc/epocish.c b/epoc/epocish.c index 4963a2e5b5..a0557cc129 100644 --- a/epoc/epocish.c +++ b/epoc/epocish.c @@ -33,8 +33,12 @@ epoc_spawn( char *cmd, char *cmdline) { /* Workaround for defect atof(), see java defect list for epoc */ - double epoc_atof( const char* str) { + double epoc_atof( char* str) { TReal64 aRes; + + while (TChar( *str).IsSpace()) { + str++; + } TLex lex( _L( str)); TInt err = lex.Val( aRes, TChar( '.')); diff --git a/ext/B/B.pm b/ext/B/B.pm index 50364fa1d2..591b5811cd 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -9,12 +9,17 @@ package B; use XSLoader (); require Exporter; @ISA = qw(Exporter); + +# walkoptree_slow comes from B.pm (you are there), +# walkoptree comes from B.xs @EXPORT_OK = qw(minus_c ppname save_BEGINs class peekop cast_I32 cstring cchar hash threadsv_names - main_root main_start main_cv svref_2object opnumber amagic_generation - walkoptree walkoptree_slow walkoptree_exec walksymtable + main_root main_start main_cv svref_2object opnumber + amagic_generation + walkoptree_slow walkoptree walkoptree_exec walksymtable parents comppadlist sv_undef compile_stats timing_info begin_av init_av end_av); + sub OPf_KIDS (); use strict; @B::SV::ISA = 'B::OBJECT'; @@ -185,7 +190,7 @@ sub walksymtable { *glob = "*main::".$prefix.$sym; if ($sym =~ /::$/) { $sym = $prefix . $sym; - if ($sym ne "main::" && &$recurse($sym)) { + if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) { walksymtable(\%glob, $method, $recurse, $sym); } } else { @@ -531,6 +536,8 @@ This method returns TRUE if the GP field of the GV is NULL. =item CvFLAGS +=item const_sv + =back =head2 B::HV METHODS diff --git a/ext/B/B.xs b/ext/B/B.xs index f1f0e65781..ec9e578020 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -1229,6 +1229,12 @@ U16 CvFLAGS(cv) B::CV cv +MODULE = B PACKAGE = B::CV PREFIX = cv_ + +B::SV +cv_const_sv(cv) + B::CV cv + MODULE = B PACKAGE = B::HV PREFIX = Hv diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm index d0c8159d9f..dac9417806 100644 --- a/ext/B/B/C.pm +++ b/ext/B/B/C.pm @@ -1020,7 +1020,6 @@ sub output_all { print <<"EOT"; static int $init_name() { - dTHR; dTARG; djSP; EOT @@ -1338,7 +1337,7 @@ sub should_save # Now see if current package looks like an OO class this is probably too strong. foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE)) { - if ($package->can($m)) + if (UNIVERSAL::can($package, $m)) { warn "$package has method $m: saving package\n";#debug return mark_package($package); @@ -1368,7 +1367,7 @@ sub walkpackages if ($sym =~ /::$/) { $sym = $prefix . $sym; - if ($sym ne "main::" && &$recurse($sym)) + if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) { walkpackages(\%glob, $recurse, $sym); } diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm index 5c5c5eb9cb..b0a5eaeb38 100644 --- a/ext/B/B/Deparse.pm +++ b/ext/B/B/Deparse.pm @@ -17,7 +17,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber CVf_METHOD CVf_LOCKED CVf_LVALUE PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); -$VERSION = 0.591; +$VERSION = 0.60; use strict; # Changes between 0.50 and 0.51: @@ -83,6 +83,12 @@ use strict; # - added support for Chip's OP_METHOD_NAMED # - added support for Ilya's OPpTARGET_MY optimization # - elided arrows before `()' subscripts when possible +# Changes between 0.59 and 0.60 +# - support for method attribues was added +# - some warnings fixed +# - separate recognition of constant subs +# - rewrote continue block handling, now recoginizing for loops +# - added more control of expanding control structures # Todo: # - finish tr/// changes @@ -93,8 +99,8 @@ use strict; # - left/right context # - recognize `use utf8', `use integer', etc # - treat top-level block specially for incremental output -# - interpret in high bit chars in string as utf8 \x{...} (when?) -# - copy comments (look at real text with $^P?) +# - interpret high bit chars in string as utf8 \x{...} (when?) +# - copy comments (look at real text with $^P?) # - avoid semis in one-statement blocks # - associativity of &&=, ||=, ?: # - ',' => '=>' (auto-unquote?) @@ -108,7 +114,6 @@ use strict; # - version using op_next instead of op_first/sibling? # - avoid string copies (pass arrays, one big join?) # - auto-apply `-u'? -# - while{} with one-statement continue => for(; XXX; XXX) {}? # - -uPackage:: descend recursively? # - here-docs? # - <DATA>? @@ -357,6 +362,8 @@ sub new { $self->{'unquote'} = 1; } elsif (substr($arg, 0, 2) eq "-s") { $self->style_opts(substr $arg, 2); + } elsif ($arg =~ /^-x(\d)$/) { + $self->{'expand'} = $1; } } return $self; @@ -393,6 +400,7 @@ sub deparse { my $self = shift; my($op, $cx) = @_; # cluck if class($op) eq "NULL"; +# cluck unless $op; # return $self->$ {\("pp_" . $op->name)}($op, $cx); my $meth = "pp_" . $op->name; return $self->$meth($op, $cx); @@ -446,6 +454,11 @@ sub deparse_sub { # skip leavesub return $proto . "{\n\t" . $self->deparse($cv->ROOT->first, 0) . "\n\b}\n"; + } + my $sv = $cv->const_sv; + if ($$sv) { + # uh-oh. inlinable sub... format it differently + return $proto . "{ " . const($sv) . " }\n"; } else { # XSUB? return $proto . "{}\n"; } @@ -679,70 +692,69 @@ sub pp_entertry { # see also leavetry return "XXX"; } -# leave and scope/lineseq should probably share code -sub pp_leave { +sub lineseq { my $self = shift; - my($op, $cx) = @_; - my ($kid, $expr); - my @exprs; - local($self->{'curstash'}) = $self->{'curstash'}; - $kid = $op->first->sibling; # skip enter - if (is_miniwhile($kid)) { - my $top = $kid->first; - my $name = $top->name; - if ($name eq "and") { - $name = "while"; - } elsif ($name eq "or") { - $name = "until"; - } else { # no conditional -> while 1 or until 0 - return $self->deparse($top->first, 1) . " while 1"; - } - my $cond = $top->first; - my $body = $cond->sibling->first; # skip lineseq - $cond = $self->deparse($cond, 1); - $body = $self->deparse($body, 1); - return "$body $name $cond"; - } - for (; !null($kid); $kid = $kid->sibling) { + my(@ops) = @_; + my($expr, @exprs); + for (my $i = 0; $i < @ops; $i++) { $expr = ""; - if (is_state $kid) { - $expr = $self->deparse($kid, 0); - $kid = $kid->sibling; - last if null $kid; + if (is_state $ops[$i]) { + $expr = $self->deparse($ops[$i], 0); + $i++; + last if $i > $#ops; } - $expr .= $self->deparse($kid, 0); + if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and + $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3) + { + push @exprs, $expr . $self->for_loop($ops[$i], 0); + $i++; + next; + } + $expr .= $self->deparse($ops[$i], 0); push @exprs, $expr if length $expr; } - if ($cx > 0) { # inside an expression - return "do { " . join(";\n", @exprs) . " }"; - } else { - return join(";\n", @exprs) . ";"; - } + return join(";\n", @exprs); } -sub pp_scope { - my $self = shift; - my($op, $cx) = @_; - my ($kid, $expr); - my @exprs; - for ($kid = $op->first; !null($kid); $kid = $kid->sibling) { - $expr = ""; - if (is_state $kid) { - $expr = $self->deparse($kid, 0); - $kid = $kid->sibling; - last if null $kid; +sub scopeop { + my($real_block, $self, $op, $cx) = @_; + my $kid; + my @kids; + local($self->{'curstash'}) = $self->{'curstash'} if $real_block; + if ($real_block) { + $kid = $op->first->sibling; # skip enter + if (is_miniwhile($kid)) { + my $top = $kid->first; + my $name = $top->name; + if ($name eq "and") { + $name = "while"; + } elsif ($name eq "or") { + $name = "until"; + } else { # no conditional -> while 1 or until 0 + return $self->deparse($top->first, 1) . " while 1"; + } + my $cond = $top->first; + my $body = $cond->sibling->first; # skip lineseq + $cond = $self->deparse($cond, 1); + $body = $self->deparse($body, 1); + return "$body $name $cond"; } - $expr .= $self->deparse($kid, 0); - push @exprs, $expr if length $expr; + } else { + $kid = $op->first; + } + for (; !null($kid); $kid = $kid->sibling) { + push @kids, $kid; } if ($cx > 0) { # inside an expression, (a do {} while for lineseq) - return "do { " . join(";\n", @exprs) . " }"; + return "do { " . $self->lineseq(@kids) . " }"; } else { - return join(";\n", @exprs) . ";"; + return $self->lineseq(@kids) . ";"; } } -sub pp_lineseq { pp_scope(@_) } +sub pp_scope { scopeop(0, @_); } +sub pp_lineseq { scopeop(0, @_); } +sub pp_leave { scopeop(1, @_); } # The BEGIN {} is used here because otherwise this code isn't executed # when you run B::Deparse on itself. @@ -1380,11 +1392,14 @@ sub logop { my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_; my $left = $op->first; my $right = $op->first->sibling; - if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b} + if ($cx == 0 and is_scope($right) and $blockname + and $self->{'expand'} < 7) + { # if ($a) {$b} $left = $self->deparse($left, 1); $right = $self->deparse($right, 0); return "$blockname ($left) {\n\t$right\n\b}\cK"; - } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a + } elsif ($cx == 0 and $blockname and not $self->{'parens'} + and $self->{'expand'} < 7) { # $b if $a $right = $self->deparse($right, 1); $left = $self->deparse($left, 1); return "$right $blockname $left"; @@ -1675,7 +1690,8 @@ sub pp_cond_expr { my $false = $true->sibling; my $cuddle = $self->{'cuddle'}; unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and - (is_scope($false) || is_ifelse_cont($false))) { + (is_scope($false) || is_ifelse_cont($false)) + and $self->{'expand'} < 7) { $cond = $self->deparse($cond, 8); $true = $self->deparse($true, 8); $false = $self->deparse($false, 8); @@ -1704,20 +1720,24 @@ sub pp_cond_expr { return $head . join($cuddle, "", @elsifs) . $false; } -sub pp_leaveloop { +sub loop_common { my $self = shift; - my($op, $cx) = @_; + my($op, $cx, $init) = @_; my $enter = $op->first; my $kid = $enter->sibling; local($self->{'curstash'}) = $self->{'curstash'}; my $head = ""; my $bare = 0; + my $body; + my $cond = undef; if ($kid->name eq "lineseq") { # bare or infinite loop if (is_state $kid->last) { # infinite $head = "for (;;) "; # shorter than while (1) + $cond = ""; } else { $bare = 1; } + $body = $kid; } elsif ($enter->name eq "enteriter") { # foreach my $ary = $enter->first->sibling; # first was pushmark my $var = $ary->sibling; @@ -1749,62 +1769,60 @@ sub pp_leaveloop { $var = "\$" . $self->deparse($var, 1); } $head = "foreach $var ($ary) "; - $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER + $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER } elsif ($kid->name eq "null") { # while/until $kid = $kid->first; - my $name = {"and" => "while", "or" => "until"} - ->{$kid->name}; - $head = "$name (" . $self->deparse($kid->first, 1) . ") "; - $kid = $kid->first->sibling; + my $name = {"and" => "while", "or" => "until"}->{$kid->name}; + $cond = $self->deparse($kid->first, 1); + $head = "$name ($cond) "; + $body = $kid->first->sibling; } elsif ($kid->name eq "stub") { # bare and empty return "{;}"; # {} could be a hashref } - # The third-to-last kid is the continue block if the pointer used - # by `next BLOCK' points to its first OP, which happens to be the - # the op_next of the head of the _previous_ statement. - # Unless it's a bare loop, in which case it's last, since there's - # no unstack or extra nextstate. - # Except if the previous head isn't null but the first kid is - # (because it's a nulled out nextstate in a scope), in which - # case the head's next is advanced past the null but the nextop's - # isn't, so we need to try nextop->next. - my $precont; - my $cont = $kid->first; - if ($bare) { - while (!null($cont->sibling)) { - $precont = $cont; - $cont = $cont->sibling; - } - } else { - while (!null($cont->sibling->sibling->sibling)) { - $precont = $cont; - $cont = $cont->sibling; + # If there isn't a continue block, then the next pointer for the loop + # will point to the unstack, which is kid's penultimate child, except + # in a bare loop, when it will point to the leaveloop. When neither of + # these conditions hold, then the third-to-last child in the continue + # block (or the last in a bare loop). + my $cont_start = $enter->nextop; + my $cont; + if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) { + if ($bare) { + $cont = $body->last; + } else { + $cont = $body->first; + while (!null($cont->sibling->sibling->sibling)) { + $cont = $cont->sibling; + } + } + my $state = $body->first; + my $cuddle = $self->{'cuddle'}; + my @states; + for (; $$state != $$cont; $state = $state->sibling) { + push @states, $state; + } + $body = $self->lineseq(@states); + if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) { + $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") "; + $cont = "\cK"; + } else { + $cont = $cuddle . "continue {\n\t" . + $self->deparse($cont, 0) . "\n\b}\cK"; } - } - if ($precont and $ {$precont->next} == $ {$enter->nextop} - || $ {$precont->next} == $ {$enter->nextop->next} ) - { - my $state = $kid->first; - my $cuddle = $self->{'cuddle'}; - my($expr, @exprs); - for (; $$state != $$cont; $state = $state->sibling) { - $expr = ""; - if (is_state $state) { - $expr = $self->deparse($state, 0); - $state = $state->sibling; - last if null $state; - } - $expr .= $self->deparse($state, 0); - push @exprs, $expr if $expr; - } - $kid = join(";\n", @exprs); - $cont = $cuddle . "continue {\n\t" . - $self->deparse($cont, 0) . "\n\b}\cK"; } else { $cont = "\cK"; - $kid = $self->deparse($kid, 0); + $body = $self->deparse($body, 0); } - return $head . "{\n\t" . $kid . "\n\b}" . $cont; + return $head . "{\n\t" . $body . "\n\b}" . $cont; +} + +sub pp_leaveloop { loop_common(@_, "") } + +sub for_loop { + my $self = shift; + my($op, $cx) = @_; + my $init = $self->deparse($op, 1); + return $self->loop_common($op->sibling, $cx, $init); } sub pp_leavetry { @@ -2851,8 +2869,8 @@ B::Deparse - Perl compiler backend to produce perl code =head1 SYNOPSIS -B<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 @@ -2997,6 +3015,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 @@ -3043,7 +3110,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/ext/B/B/Lint.pm b/ext/B/B/Lint.pm index ed0d07dfcb..094b3cf8fd 100644 --- a/ext/B/B/Lint.pm +++ b/ext/B/B/Lint.pm @@ -116,7 +116,7 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk. =cut use strict; -use B qw(walkoptree_slow main_root walksymtable svref_2object parents +use B qw(walkoptree main_root walksymtable svref_2object parents OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY ); @@ -277,12 +277,12 @@ sub B::GV::lintcv { return if !$$cv || $done_cv{$$cv}++; my $root = $cv->ROOT; #warn " root = $root (0x$$root)\n";#debug - walkoptree_slow($root, "lint") if $$root; + walkoptree($root, "lint") if $$root; } sub do_lint { my %search_pack; - walkoptree_slow(main_root, "lint") if ${main_root()}; + walkoptree(main_root, "lint") if ${main_root()}; # Now do subs in main no strict qw(vars refs); diff --git a/ext/B/B/Terse.pm b/ext/B/B/Terse.pm index 66b5cfc2f2..a7a071e937 100644 --- a/ext/B/B/Terse.pm +++ b/ext/B/B/Terse.pm @@ -1,6 +1,6 @@ package B::Terse; use strict; -use B qw(peekop class walkoptree_slow walkoptree_exec +use B qw(peekop class walkoptree walkoptree_exec walkoptree_slow main_start main_root cstring svref_2object); use B::Asmdata qw(@specialsv_name); diff --git a/ext/ByteLoader/ByteLoader.xs b/ext/ByteLoader/ByteLoader.xs index d3b435199e..05b795ca25 100644 --- a/ext/ByteLoader/ByteLoader.xs +++ b/ext/ByteLoader/ByteLoader.xs @@ -77,7 +77,6 @@ bl_read(struct byteloader_fdata *data, char *buf, size_t size, size_t n) static I32 byteloader_filter(pTHXo_ int idx, SV *buf_sv, int maxlen) { - dTHR; OP *saveroot = PL_main_root; OP *savestart = PL_main_start; struct byteloader_state bstate; diff --git a/ext/ByteLoader/byterun.c b/ext/ByteLoader/byterun.c index 19f1f6b44c..3e12790fb0 100644 --- a/ext/ByteLoader/byterun.c +++ b/ext/ByteLoader/byterun.c @@ -54,7 +54,6 @@ bset_obj_store(pTHXo_ struct byteloader_state *bstate, void *obj, I32 ix) void byterun(pTHXo_ register struct byteloader_state *bstate) { - dTHR; register int insn; U32 ix; SV *specialsv_list[6]; diff --git a/ext/DB_File/Changes b/ext/DB_File/Changes index ad54382d63..eda270d82b 100644 --- a/ext/DB_File/Changes +++ b/ext/DB_File/Changes @@ -292,7 +292,45 @@ the updates to the documentation and writing DB_File::Lock (available on CPAN). -1.73 27th April 2000 +1.73 31st May 2000 * Added support in version.c for building with threaded Perl. + * Berkeley DB 3.1 has reenabled support for null keys. The test + harness has been updated to reflect this. + +1.74 10th December 2000 + + * A "close" call in DB_File.xs needed parenthesised to stop win32 from + thinking it was one of its macros. + + * Updated dbinfo to support Berkeley DB 3.1 file format changes. + + * DB_File.pm & the test hasness now use the warnings pragma (when + available). + + * Included Perl core patch 7703 -- size argument for hash_cb is different + for Berkeley DB 3.x + + * Included Perl core patch 7801 -- Give __getBerkeleyDBInfo the ANSI C + treatment. + + * @a = () produced the warning 'Argument "" isn't numeric in entersub' + This has been fixed. Thanks to Edward Avis for spotting this bug. + + * Added note about building under Linux. Included patches. + + * Included Perl core patch 8068 -- fix for bug 20001013.009 + When run with warnings enabled "$hash{XX} = undef " produced an + "Uninitialized value" warning. This has been fixed. + +1.75 17th December 2000 + + * Fixed perl core patch 7703 + + * Added suppport to allow DB_File to be built with Berkeley DB 3.2 -- + btree_compare, btree_prefix and hash_cb needed to be changed. + + * Updated dbinfo to support Berkeley DB 3.2 file format changes. + + diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index a1ec0e6362..c8302168f8 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -1,8 +1,8 @@ # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (Paul.Marquess@btinternet.com) -# last modified 26th April 2000 -# version 1.73 +# last modified 17th December 2000 +# version 1.75 # # Copyright (c) 1995-2000 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or @@ -13,6 +13,7 @@ package DB_File::HASHINFO ; require 5.003 ; +use warnings; use strict; use Carp; require Tie::Hash; @@ -104,6 +105,7 @@ sub CLEAR { my $self = shift ; $self->NotHere("CLEAR") } package DB_File::RECNOINFO ; +use warnings; use strict ; @DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ; @@ -121,6 +123,7 @@ sub TIEHASH package DB_File::BTREEINFO ; +use warnings; use strict ; @DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ; @@ -140,6 +143,7 @@ sub TIEHASH package DB_File ; +use warnings; use strict; use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO $db_version $use_XSLoader @@ -147,7 +151,7 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO use Carp; -$VERSION = "1.73" ; +$VERSION = "1.75" ; #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; $DB_BTREE = new DB_File::BTREEINFO ; @@ -271,7 +275,7 @@ sub TIEARRAY sub CLEAR { my $self = shift; - my $key = "" ; + my $key = 0 ; my $value = "" ; my $status = $self->seq($key, $value, R_FIRST()); my @keys; @@ -665,6 +669,7 @@ This example shows how to create a database, add key/value pairs to the database, delete keys/value pairs and finally how to enumerate the contents of the database. + use warnings ; use strict ; use DB_File ; use vars qw( %h $k $v ) ; @@ -715,6 +720,7 @@ This script shows how to override the default sorting algorithm that BTREE uses. Instead of using the normal lexical ordering, a case insensitive compare function will be used. + use warnings ; use strict ; use DB_File ; @@ -783,6 +789,7 @@ There are some difficulties in using the tied hash interface if you want to manipulate a BTREE database with duplicate keys. Consider this code: + use warnings ; use strict ; use DB_File ; @@ -837,6 +844,7 @@ and the API in general. Here is the script above rewritten using the C<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/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index cb8fd80385..fa3bb336c2 100644 --- a/ext/DB_File/DB_File.xs +++ b/ext/DB_File/DB_File.xs @@ -3,8 +3,8 @@ DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess <Paul.Marquess@btinternet.com> - last modified 27th April 2000 - version 1.73 + last modified 17 December 2000 + version 1.75 All comments/suggestions/problems are welcome @@ -83,6 +83,13 @@ Rewrote push 1.72 - No change to DB_File.xs 1.73 - No change to DB_File.xs + 1.74 - A call to open needed parenthesised to stop it clashing + with a win32 macro. + Added Perl core patches 7703 & 7801. + 1.75 - Fixed Perl core patch 7703. + Added suppport to allow DB_File to be built with + Berkeley DB 3.2 -- btree_compare, btree_prefix and hash_cb + needed to be changed. */ @@ -128,6 +135,10 @@ # include <db.h> #endif +#ifdef CAN_PROTOTYPE +extern void __getBerkeleyDBInfo(void); +#endif + #ifndef pTHX # define pTHX # define pTHX_ @@ -159,6 +170,10 @@ # define BERKELEY_DB_1_OR_2 #endif +#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2) +# define AT_LEAST_DB_3_2 +#endif + /* map version 2 features & constants onto their version 1 equivalent */ #ifdef DB_Prefix_t @@ -244,6 +259,7 @@ typedef db_recno_t recno_t; #else /* db version 1.x */ +#define BERKELEY_DB_1 #define BERKELEY_DB_1_OR_2 typedef union INFO { @@ -473,6 +489,19 @@ u_int flags ; static int +#ifdef AT_LEAST_DB_3_2 + +#ifdef CAN_PROTOTYPE +btree_compare(DB * db, const DBT *key1, const DBT *key2) +#else +btree_compare(db, key1, key2) +DB * db ; +const DBT * key1 ; +const DBT * key2 ; +#endif /* CAN_PROTOTYPE */ + +#else /* Berkeley DB < 3.2 */ + #ifdef CAN_PROTOTYPE btree_compare(const DBT *key1, const DBT *key2) #else @@ -480,6 +509,9 @@ btree_compare(key1, key2) const DBT * key1 ; const DBT * key2 ; #endif + +#endif + { #ifdef dTHX dTHX; @@ -529,6 +561,19 @@ const DBT * key2 ; } static DB_Prefix_t +#ifdef AT_LEAST_DB_3_2 + +#ifdef CAN_PROTOTYPE +btree_prefix(DB * db, const DBT *key1, const DBT *key2) +#else +btree_prefix(db, key1, key2) +Db * db ; +const DBT * key1 ; +const DBT * key2 ; +#endif + +#else /* Berkeley DB < 3.2 */ + #ifdef CAN_PROTOTYPE btree_prefix(const DBT *key1, const DBT *key2) #else @@ -536,6 +581,8 @@ btree_prefix(key1, key2) const DBT * key1 ; const DBT * key2 ; #endif + +#endif { #ifdef dTHX dTHX; @@ -584,13 +631,35 @@ const DBT * key2 ; return (retval) ; } + +#ifdef BERKELEY_DB_1 +# define HASH_CB_SIZE_TYPE size_t +#else +# define HASH_CB_SIZE_TYPE u_int32_t +#endif + static DB_Hash_t +#ifdef AT_LEAST_DB_3_2 + #ifdef CAN_PROTOTYPE -hash_cb(const void *data, size_t size) +hash_cb(DB * db, const void *data, u_int32_t size) +#else +hash_cb(db, data, size) +DB * db ; +const void * data ; +HASH_CB_SIZE_TYPE size ; +#endif + +#else /* Berkeley DB < 3.2 */ + +#ifdef CAN_PROTOTYPE +hash_cb(const void *data, HASH_CB_SIZE_TYPE size) #else hash_cb(data, size) const void * data ; -size_t size ; +HASH_CB_SIZE_TYPE size ; +#endif + #endif { #ifdef dTHX @@ -1266,7 +1335,7 @@ SV * sv ; Flags |= DB_TRUNCATE ; #endif - status = RETVAL->dbp->open(RETVAL->dbp, name, NULL, RETVAL->type, + status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type, Flags, mode) ; /* printf("open returned %d %s\n", status, db_strerror(status)) ; */ diff --git a/ext/DB_File/dbinfo b/ext/DB_File/dbinfo index 701ac612b6..5a4df15907 100644 --- a/ext/DB_File/dbinfo +++ b/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/ext/DB_File/typemap b/ext/DB_File/typemap index 41a24f4a86..55439ee76d 100644 --- a/ext/DB_File/typemap +++ b/ext/DB_File/typemap @@ -1,8 +1,8 @@ # typemap for Perl 5 interface to Berkeley # # written by Paul Marquess <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/ext/DB_File/version.c b/ext/DB_File/version.c index f3e2c947c8..6e55b2e3d1 100644 --- a/ext/DB_File/version.c +++ b/ext/DB_File/version.c @@ -17,6 +17,8 @@ Support for Berkeley DB 2/3's backward compatability mode. 1.72 - No change. 1.73 - Added support for threading + 1.74 - Added Perl core patch 7801. + */ @@ -27,7 +29,11 @@ #include <db.h> void +#ifdef CAN_PROTOTYPE +__getBerkeleyDBInfo(void) +#else __getBerkeleyDBInfo() +#endif { #ifdef dTHX dTHX; diff --git a/ext/Devel/DProf/DProf.xs b/ext/Devel/DProf/DProf.xs index 7167a0028f..8f28c6eb33 100644 --- a/ext/Devel/DProf/DProf.xs +++ b/ext/Devel/DProf/DProf.xs @@ -3,11 +3,6 @@ #include "perl.h" #include "XSUB.h" -/* For older Perls */ -#ifndef dTHR -# define dTHR int dummy_thr -#endif /* dTHR */ - /*#define DBG_SUB 1 */ /*#define DBG_TIMER 1 */ @@ -388,7 +383,6 @@ prof_mark(pTHX_ opcode ptype) static void test_time(pTHX_ clock_t *r, clock_t *u, clock_t *s) { - dTHR; CV *cv = perl_get_cv("Devel::DProf::NONESUCH_noxs", FALSE); int i, j, k = 0; HV *oldstash = PL_curstash; diff --git a/ext/Devel/Peek/Peek.xs b/ext/Devel/Peek/Peek.xs index e5fc8ae2c9..312f5f84ba 100644 --- a/ext/Devel/Peek/Peek.xs +++ b/ext/Devel/Peek/Peek.xs @@ -140,6 +140,7 @@ struct mstats_buffer void _fill_mstats(struct mstats_buffer *b, int level) { + dTHX; b->buffer.nfree = b->buf; b->buffer.ntotal = b->buf + _NBUCKETS; b->buffer.bucket_mem_size = b->buf + 2*_NBUCKETS; @@ -151,6 +152,7 @@ _fill_mstats(struct mstats_buffer *b, int level) void fill_mstats(SV *sv, int level) { + dTHX; int nbuckets; struct mstats_buffer buf; @@ -166,6 +168,7 @@ fill_mstats(SV *sv, int level) void _mstats_to_hv(HV *hv, struct mstats_buffer *b, int level) { + dTHX; SV **svp; int type; diff --git a/ext/DynaLoader/DynaLoader_pm.PL b/ext/DynaLoader/DynaLoader_pm.PL index b7b45d8372..266c9d030f 100644 --- a/ext/DynaLoader/DynaLoader_pm.PL +++ b/ext/DynaLoader/DynaLoader_pm.PL @@ -1,4 +1,3 @@ - use Config; sub to_string { @@ -12,7 +11,7 @@ unlink "DynaLoader.pm" if -f "DynaLoader.pm"; open OUT, ">DynaLoader.pm" or die $!; print OUT <<'EOT'; -# Generated from DynaLoader.pm.PL (resolved %Config::Config values) +# Generated from DynaLoader.pm.PL package DynaLoader; @@ -28,11 +27,15 @@ package DynaLoader; # # Tim.Bunce@ig.co.uk, August 1994 -$VERSION = "1.04"; # avoid typo warning +use vars qw($VERSION *AUTOLOAD); + +$VERSION = 1.04; # avoid typo warning require AutoLoader; *AUTOLOAD = \&AutoLoader::AUTOLOAD; +use Config; + # The following require can't be removed during maintenance # releases, sadly, because of the risk of buggy code that does # require Carp; Carp::croak "..."; without brackets dying @@ -40,7 +43,6 @@ require AutoLoader; # We'll let those bugs get found on the development track. require Carp if $] < 5.00450; - # enable debug/trace messages from DynaLoader perl code $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; @@ -71,48 +73,112 @@ print OUT <<'EOT'; # (VMS support by Charles Bailey <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) && @@ -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/ext/DynaLoader/dl_aix.xs b/ext/DynaLoader/dl_aix.xs index d6acc689af..89b84396ef 100644 --- a/ext/DynaLoader/dl_aix.xs +++ b/ext/DynaLoader/dl_aix.xs @@ -11,6 +11,8 @@ * on statup... It can probably be trimmed more. */ +#define PERLIO_NOT_STDIO 0 + /* * @(#)dlfcn.c 1.5 revision of 93/02/14 20:14:17 * This is an unpublished work copyright (c) 1992 Helios Software GmbH @@ -87,14 +89,6 @@ # define FREAD(p,s,n,ldptr) fread(p,s,n,IOPTR(ldptr)) #endif -/* If using PerlIO, redefine these macros from <ldfcn.h> */ -#ifdef USE_PERLIO -#undef FSEEK -#undef FREAD -#define FSEEK(ldptr,o,p) PerlIO_seek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr)+o):o,p) -#define FREAD(p,s,n,ldptr) PerlIO_read(IOPTR(ldptr),p,s*n) -#endif - /* * We simulate dlopen() et al. through a call to load. Because AIX has * no call to find an exported symbol we read the loader section of the @@ -532,11 +526,7 @@ static int readExports(ModulePtr mp) } /* This first case is a hack, since it assumes that the 3rd parameter to FREAD is 1. See the redefinition of FREAD above to see how this works. */ -#ifdef USE_PERLIO - if (FREAD(ldbuf, sh.s_size, 1, ldp) != sh.s_size) { -#else if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) { -#endif errvalid++; strcpy(errbuf, "readExports: cannot read loader section"); safefree(ldbuf); diff --git a/ext/Encode/Encode.pm b/ext/Encode/Encode.pm index 8ba7232d5e..1f4ffb1485 100644 --- a/ext/Encode/Encode.pm +++ b/ext/Encode/Encode.pm @@ -22,6 +22,10 @@ require Exporter; off_utf8 utf_to_utf encodings + utf8_decode + utf8_encode + utf8_upgrade + utf8_downgrade ); bootstrap Encode (); @@ -340,9 +344,9 @@ sub from_to return length($_[0] = $string); } -my %encoding = ( Unicode => bless({},'Encode::Unicode'), - 'iso10646-1' => bless({},'Encode::iso10646_1'), - ); +# The global hash is declared in XS code +$encoding{Unicode} = bless({},'Encode::Unicode'); +$encoding{'iso10646-1'} = bless({},'Encode::iso10646_1'); sub encodings { @@ -378,6 +382,7 @@ sub loadEncoding last unless $type eq '#'; } $class .= ('::'.(($type eq 'E') ? 'Escape' : 'Table')); + #warn "Loading $file"; return $class->read($fh,$name,$type); } else @@ -407,13 +412,20 @@ sub getEncoding package Encode::Unicode; -# Dummy package that provides the encode interface +# Dummy package that provides the encode interface but leaves data +# as UTF-8 encoded. It is here so that from_to() works. sub name { 'Unicode' } -sub toUnicode { $_[1] } +sub toUnicode +{ + my ($obj,$str,$chk) = @_; + Encode::utf8_upgrade($str); + $_[1] = '' if $chk; + return $str; +} -sub fromUnicode { $_[1] } +*fromUnicode = \&toUnicode; package Encode::Table; @@ -532,7 +544,9 @@ sub fromUnicode return $str; } -package Encode::iso10646_1;# +package Encode::iso10646_1; +# Encoding is 16-bit network order Unicode +# Used for X font encodings sub name { 'iso10646-1' } @@ -546,6 +560,7 @@ sub toUnicode $uni .= chr($code); } $_[1] = $str if $chk; + Encode::utf8_upgrade($uni); return $uni; } @@ -568,6 +583,7 @@ sub fromUnicode return $str; } + package Encode::Escape; use Carp; diff --git a/ext/Encode/Encode.xs b/ext/Encode/Encode.xs index c231bbab6b..a7acd88e67 100644 --- a/ext/Encode/Encode.xs +++ b/ext/Encode/Encode.xs @@ -1,6 +1,11 @@ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +#define U8 U8 +#include "encode.h" +#include "iso8859.h" +#include "EBCDIC.h" +#include "Symbols.h" #define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) { \ Perl_croak(aTHX_ "panic_unimplemented"); \ @@ -9,8 +14,469 @@ UNIMPLEMENTED(_encoded_utf8_to_bytes, I32) UNIMPLEMENTED(_encoded_bytes_to_utf8, I32) +#ifdef USE_PERLIO +/* Define an encoding "layer" in the perliol.h sense. + The layer defined here "inherits" in an object-oriented sense from the + "perlio" layer with its PerlIOBuf_* "methods". + The implementation is particularly efficient as until Encode settles down + there is no point in tryint to tune it. + + The layer works by overloading the "fill" and "flush" methods. + + "fill" calls "SUPER::fill" in perl terms, then calls the encode OO perl API + to convert the encoded data to UTF-8 form, then copies it back to the + buffer. The "base class's" read methods then see the UTF-8 data. + + "flush" transforms the UTF-8 data deposited by the "base class's write + method in the buffer back into the encoded form using the encode OO perl API, + then copies data back into the buffer and calls "SUPER::flush. + + Note that "flush" is _also_ called for read mode - we still do the (back)-translate + so that the the base class's "flush" sees the correct number of encoded chars + for positioning the seek pointer. (This double translation is the worst performance + issue - particularly with all-perl encode engine.) + +*/ + + +#include "perliol.h" + +typedef struct +{ + PerlIOBuf base; /* PerlIOBuf stuff */ + SV * bufsv; + SV * enc; +} PerlIOEncode; + + +IV +PerlIOEncode_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len) +{ + PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode); + dTHX; + dSP; + IV code; + code = PerlIOBuf_pushed(f,mode,Nullch,0); + ENTER; + SAVETMPS; + PUSHMARK(sp); + XPUSHs(sv_2mortal(newSVpv("Encode",0))); + XPUSHs(sv_2mortal(newSVpvn(arg,len))); + PUTBACK; + if (perl_call_method("getEncoding",G_SCALAR) != 1) + return -1; + SPAGAIN; + e->enc = POPs; + PUTBACK; + if (!SvROK(e->enc)) + return -1; + SvREFCNT_inc(e->enc); + FREETMPS; + LEAVE; + PerlIOBase(f)->flags |= PERLIO_F_UTF8; + return code; +} + +IV +PerlIOEncode_popped(PerlIO *f) +{ + PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode); + dTHX; + if (e->enc) + { + SvREFCNT_dec(e->enc); + e->enc = Nullsv; + } + if (e->bufsv) + { + SvREFCNT_dec(e->bufsv); + e->bufsv = Nullsv; + } + return 0; +} + +STDCHAR * +PerlIOEncode_get_base(PerlIO *f) +{ + PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode); + dTHX; + if (!e->base.bufsiz) + e->base.bufsiz = 1024; + if (!e->bufsv) + { + e->bufsv = newSV(e->base.bufsiz); + sv_setpvn(e->bufsv,"",0); + } + e->base.buf = (STDCHAR *)SvPVX(e->bufsv); + if (!e->base.ptr) + e->base.ptr = e->base.buf; + if (!e->base.end) + e->base.end = e->base.buf; + if (e->base.ptr < e->base.buf || e->base.ptr > e->base.buf+SvLEN(e->bufsv)) + { + Perl_warn(aTHX_ " ptr %p(%p)%p", + e->base.buf,e->base.ptr,e->base.buf+SvLEN(e->bufsv)); + abort(); + } + if (SvLEN(e->bufsv) < e->base.bufsiz) + { + SSize_t poff = e->base.ptr - e->base.buf; + SSize_t eoff = e->base.end - e->base.buf; + e->base.buf = (STDCHAR *)SvGROW(e->bufsv,e->base.bufsiz); + e->base.ptr = e->base.buf + poff; + e->base.end = e->base.buf + eoff; + } + if (e->base.ptr < e->base.buf || e->base.ptr > e->base.buf+SvLEN(e->bufsv)) + { + Perl_warn(aTHX_ " ptr %p(%p)%p", + e->base.buf,e->base.ptr,e->base.buf+SvLEN(e->bufsv)); + abort(); + } + return e->base.buf; +} + +IV +PerlIOEncode_fill(PerlIO *f) +{ + PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode); + dTHX; + dSP; + IV code; + code = PerlIOBuf_fill(f); + if (code == 0) + { + SV *uni; + STRLEN len; + char *s; + /* Set SV that is the buffer to be buf..ptr */ + SvCUR_set(e->bufsv, e->base.end - e->base.buf); + SvUTF8_off(e->bufsv); + ENTER; + SAVETMPS; + PUSHMARK(sp); + XPUSHs(e->enc); + XPUSHs(e->bufsv); + XPUSHs(&PL_sv_yes); + PUTBACK; + if (perl_call_method("toUnicode",G_SCALAR) != 1) + code = -1; + SPAGAIN; + uni = POPs; + PUTBACK; + /* Now get translated string (forced to UTF-8) and copy back to buffer + don't use sv_setsv as that may "steal" PV from returned temp + and so free() our known-large-enough buffer. + sv_setpvn() should do but let us do it long hand. + */ + s = SvPVutf8(uni,len); + if (s != SvPVX(e->bufsv)) + { + e->base.buf = (STDCHAR *)SvGROW(e->bufsv,len); + Move(s,e->base.buf,len,char); + SvCUR_set(e->bufsv,len); + } + SvUTF8_on(e->bufsv); + e->base.end = e->base.buf+len; + e->base.ptr = e->base.buf; + FREETMPS; + LEAVE; + } + return code; +} + +IV +PerlIOEncode_flush(PerlIO *f) +{ + PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode); + IV code = 0; + dTHX; + if (e->bufsv && (PerlIOBase(f)->flags & (PERLIO_F_RDBUF|PERLIO_F_WRBUF))) + { + dSP; + SV *str; + char *s; + STRLEN len; + SSize_t left = 0; + if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) + { + /* This is really just a flag to see if we took all the data, if + we did PerlIOBase_flush avoids a seek to lower layer. + Need to revisit if we start getting clever with unreads or seeks-in-buffer + */ + left = e->base.end - e->base.ptr; + } + ENTER; + SAVETMPS; + PUSHMARK(sp); + XPUSHs(e->enc); + SvCUR_set(e->bufsv, e->base.ptr - e->base.buf); + SvUTF8_on(e->bufsv); + XPUSHs(e->bufsv); + XPUSHs(&PL_sv_yes); + PUTBACK; + if (perl_call_method("fromUnicode",G_SCALAR) != 1) + code = -1; + SPAGAIN; + str = POPs; + PUTBACK; + s = SvPV(str,len); + if (s != SvPVX(e->bufsv)) + { + e->base.buf = (STDCHAR *)SvGROW(e->bufsv,len); + Move(s,e->base.buf,len,char); + SvCUR_set(e->bufsv,len); + } + SvUTF8_off(e->bufsv); + e->base.ptr = e->base.buf+len; + /* restore end != ptr as inequality is used by PerlIOBuf_flush in read case */ + e->base.end = e->base.ptr + left; + FREETMPS; + LEAVE; + if (PerlIOBuf_flush(f) != 0) + code = -1; + } + return code; +} + +IV +PerlIOEncode_close(PerlIO *f) +{ + PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode); + IV code = PerlIOBase_close(f); + dTHX; + if (e->bufsv) + { + SvREFCNT_dec(e->bufsv); + e->bufsv = Nullsv; + } + e->base.buf = NULL; + e->base.ptr = NULL; + e->base.end = NULL; + PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF); + return code; +} + +Off_t +PerlIOEncode_tell(PerlIO *f) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + /* Unfortunately the only way to get a postion is to back-translate, + the UTF8-bytes we have buf..ptr and adjust accordingly. + But we will try and save any unread data in case stream + is un-seekable. + */ + if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF) && b->ptr < b->end) + { + Size_t count = b->end - b->ptr; + PerlIO_push(f,&PerlIO_pending,"r",Nullch,0); + /* Save what we have left to read */ + PerlIOSelf(f,PerlIOBuf)->bufsiz = count; + PerlIO_unread(f,b->ptr,count); + /* There isn't any unread data - we just saved it - so avoid the lower seek */ + b->end = b->ptr; + /* Flush ourselves - now one layer down, + this does the back translate and adjusts position + */ + PerlIO_flush(PerlIONext(f)); + /* Set position of the saved data */ + PerlIOSelf(f,PerlIOBuf)->posn = b->posn; + } + else + { + PerlIO_flush(f); + } + return b->posn; +} + +PerlIO_funcs PerlIO_encode = { + "encoding", + sizeof(PerlIOEncode), + PERLIO_K_BUFFERED, + PerlIOBase_fileno, + PerlIOBuf_fdopen, + PerlIOBuf_open, + PerlIOBuf_reopen, + PerlIOEncode_pushed, + PerlIOEncode_popped, + PerlIOBuf_read, + PerlIOBuf_unread, + PerlIOBuf_write, + PerlIOBuf_seek, + PerlIOEncode_tell, + PerlIOEncode_close, + PerlIOEncode_flush, + PerlIOEncode_fill, + PerlIOBase_eof, + PerlIOBase_error, + PerlIOBase_clearerr, + PerlIOBuf_setlinebuf, + PerlIOEncode_get_base, + PerlIOBuf_bufsiz, + PerlIOBuf_get_ptr, + PerlIOBuf_get_cnt, + PerlIOBuf_set_ptrcnt, +}; +#endif + +void +Encode_Define(pTHX_ encode_t *enc) +{ + HV *hash = get_hv("Encode::encoding",GV_ADD|GV_ADDMULTI); + HV *stash = gv_stashpv("Encode::XS", TRUE); + SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash); + hv_store(hash,enc->name,strlen(enc->name),sv,0); +} + void call_failure (SV *routine, U8* done, U8* dest, U8* orig) {} +static SV * +encode_method(pTHX_ encode_t *enc, encpage_t *dir, SV *src, int check) +{ + STRLEN slen; + U8 *s = (U8 *) SvPV(src,slen); + SV *dst = sv_2mortal(newSV(2*slen+1)); + if (slen) + { + U8 *d = (U8 *) SvGROW(dst, 2*slen+1); + STRLEN dlen = SvLEN(dst); + int code; + while ((code = do_encode(dir,s,&slen,d,dlen,&dlen,!check))) + { + SvCUR_set(dst,dlen); + SvPOK_on(dst); + + if (code == ENCODE_FALLBACK) + break; + + switch(code) + { + case ENCODE_NOSPACE: + { + STRLEN need = (slen) ? (SvLEN(dst)*SvCUR(src)/slen) : (dlen + UTF8_MAXLEN); + if (need <= SvLEN(dst)) + need += UTF8_MAXLEN; + d = (U8 *) SvGROW(dst, need); + dlen = SvLEN(dst); + slen = SvCUR(src); + break; + } + + case ENCODE_NOREP: + if (dir == enc->f_utf8) + { + if (!check && ckWARN_d(WARN_UTF8)) + { + STRLEN clen; + UV ch = utf8_to_uv(s+slen,(SvCUR(src)-slen),&clen,0); + Perl_warner(aTHX_ WARN_UTF8, "\"\\x{%x}\" does not map to %s", ch, enc->name); + /* FIXME: Skip over the character, copy in replacement and continue + * but that is messy so for now just fail. + */ + return &PL_sv_undef; + } + else + { + return &PL_sv_undef; + } + } + else + { + /* UTF-8 is supposed to be "Universal" so should not happen */ + Perl_croak(aTHX_ "%s '%.*s' does not map to UTF-8", + enc->name, (SvCUR(src)-slen),s+slen); + } + break; + + case ENCODE_PARTIAL: + if (!check && ckWARN_d(WARN_UTF8)) + { + Perl_warner(aTHX_ WARN_UTF8, "Partial %s character", + (dir == enc->f_utf8) ? "UTF-8" : enc->name); + } + return &PL_sv_undef; + + default: + Perl_croak(aTHX_ "Unexpected code %d converting %s %s", + code, (dir == enc->f_utf8) ? "to" : "from",enc->name); + return &PL_sv_undef; + } + } + SvCUR_set(dst,dlen); + SvPOK_on(dst); + if (check) + { + if (slen < SvCUR(src)) + { + Move(s+slen,s,SvCUR(src)-slen,U8); + } + SvCUR_set(src,SvCUR(src)-slen); + } + } + return dst; +} + +MODULE = Encode PACKAGE = Encode PREFIX = sv_ + +void +valid_utf8(sv) +SV * sv +CODE: + { + STRLEN len; + char *s = SvPV(sv,len); + if (!SvUTF8(sv) || is_utf8_string((U8*)s,len)) + XSRETURN_YES; + else + XSRETURN_NO; + } + +void +sv_utf8_encode(sv) +SV * sv + +bool +sv_utf8_decode(sv) +SV * sv + +void +sv_utf8_upgrade(sv) +SV * sv + +bool +sv_utf8_downgrade(sv,failok=0) +SV * sv +bool failok + +MODULE = Encode PACKAGE = Encode::XS PREFIX = Encode_ + +PROTOTYPES: ENABLE + +void +Encode_toUnicode(obj,src,check = 0) +SV * obj +SV * src +int check +CODE: + { + encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj))); + ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check); + SvUTF8_on(ST(0)); + XSRETURN(1); + } + +void +Encode_fromUnicode(obj,src,check = 0) +SV * obj +SV * src +int check +CODE: + { + encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj))); + sv_utf8_upgrade(src); + ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check); + XSRETURN(1); + } + MODULE = Encode PACKAGE = Encode PROTOTYPES: ENABLE @@ -182,7 +648,7 @@ _is_utf8(sv, ...) { SV * check = items == 2 ? ST(1) : Nullsv; if (SvPOK(sv)) { - RETVAL = SvUTF8(sv); + RETVAL = SvUTF8(sv) ? 1 : 0; if (RETVAL && SvTRUE(check) && !is_utf8_string((U8*)SvPVX(sv), SvCUR(sv))) @@ -239,3 +705,12 @@ _utf_to_utf(sv, from, to, ...) OUTPUT: RETVAL +BOOT: +{ +#ifdef USE_PERLIO + PerlIO_define_layer(&PerlIO_encode); +#endif +#include "iso8859.def" +#include "EBCDIC.def" +#include "Symbols.def" +} diff --git a/ext/Encode/Encode/EncodeFormat.pod b/ext/Encode/Encode/EncodeFormat.pod new file mode 100644 index 0000000000..d83b12838d --- /dev/null +++ b/ext/Encode/Encode/EncodeFormat.pod @@ -0,0 +1,164 @@ +=head1 NAME + +EncodeFormat - the format of encoding tables of the Encode extension + +=head1 DESCRIPTION + +I<The format used in the encoding tables of the Encode extension has +been borrowed from Tcl, as has the following documentation been borrowed +from the same. The documentation has been reformatted as Perl pod.> + +Space would prohibit precompiling into Tcl every possible encoding +algorithm, so many encodings are stored on disk as dynamically-loadable +encoding files. This behavior also allows the user to create additional +encoding files that can be loaded using the same mechanism. These +encoding files contain information about the tables and/or escape +sequences used to map between an external encoding and Unicode. The +external encoding may consist of single-byte, multi-byte, or double-byte +characters. + +Each dynamically-loadable encoding is represented as a text file. The +initial line of the file, beginning with a ``#'' symbol, is a comment +that provides a human-readable description of the file. The next line +identifies the type of encoding file. It can be one of the following +letters: + +=over 4 + +=item [1] B<S> + +A single-byte encoding, where one character is always one byte long in +the encoding. An example is B<iso8859-1>, used by many European languages. + +=item [2] B<D> + +A double-byte encoding, where one character is always two bytes long in the +encoding. An example is B<big5>, used for Chinese text. + +=item [3] B<M> + +A multi-byte encoding, where one character may be either one or two +bytes long. Certain bytes are a lead bytes, indicating that another +byte must follow and that together the two bytes represent one +character. Other bytes are not lead bytes and represent themselves. +An example is B<shiftjis>, used by many Japanese computers. + +=item [4] B<E> + +An escape-sequence encoding, specifying that certain sequences of +bytes do not represent characters, but commands that describe how +following bytes should be interpreted. + +=back + +The rest of the lines in the file depend on the type. + +Cases [1], [2], and [3] are collectively referred to as table-based +encoding files. The lines in a table-based encoding file are in the +same format as this example taken from the B<shiftjis> encoding (this +is not the complete file): + + # Encoding file: shiftjis, multi-byte + M + 003F 0 40 + 00 + 0000000100020003000400050006000700080009000A000B000C000D000E000F + 0010001100120013001400150016001700180019001A001B001C001D001E001F + 0020002100220023002400250026002700280029002A002B002C002D002E002F + 0030003100320033003400350036003700380039003A003B003C003D003E003F + 0040004100420043004400450046004700480049004A004B004C004D004E004F + 0050005100520053005400550056005700580059005A005B005C005D005E005F + 0060006100620063006400650066006700680069006A006B006C006D006E006F + 0070007100720073007400750076007700780079007A007B007C007D203E007F + 0080000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000FF61FF62FF63FF64FF65FF66FF67FF68FF69FF6AFF6BFF6CFF6DFF6EFF6F + FF70FF71FF72FF73FF74FF75FF76FF77FF78FF79FF7AFF7BFF7CFF7DFF7EFF7F + FF80FF81FF82FF83FF84FF85FF86FF87FF88FF89FF8AFF8BFF8CFF8DFF8EFF8F + FF90FF91FF92FF93FF94FF95FF96FF97FF98FF99FF9AFF9BFF9CFF9DFF9EFF9F + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 81 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 300030013002FF0CFF0E30FBFF1AFF1BFF1FFF01309B309C00B4FF4000A8FF3E + FFE3FF3F30FD30FE309D309E30034EDD30053006300730FC20152010FF0F005C + 301C2016FF5C2026202520182019201C201DFF08FF0930143015FF3BFF3DFF5B + FF5D30083009300A300B300C300D300E300F30103011FF0B221200B100D70000 + 00F7FF1D2260FF1CFF1E22662267221E22342642264000B0203220332103FFE5 + FF0400A200A3FF05FF03FF06FF0AFF2000A72606260525CB25CF25CE25C725C6 + 25A125A025B325B225BD25BC203B301221922190219121933013000000000000 + 000000000000000000000000000000002208220B2286228722822283222A2229 + 000000000000000000000000000000002227222800AC21D221D4220022030000 + 0000000000000000000000000000000000000000222022A52312220222072261 + 2252226A226B221A223D221D2235222B222C0000000000000000000000000000 + 212B2030266F266D266A2020202100B6000000000000000025EF000000000000 + +The third line of the file is three numbers. The first number is the +fallback character (in base 16) to use when converting from UTF-8 to +this encoding. The second number is a B<1> if this file represents +the encoding for a symbol font, or B<0> otherwise. The last number +(in base 10) is how many pages of data follow. + +Subsequent lines in the example above are pages that describe how to +map from the encoding into 2-byte Unicode. The first line in a page +identifies the page number. Following it are 256 double-byte numbers, +arranged as 16 rows of 16 numbers. Given a character in the encoding, +the high byte of that character is used to select which page, and the +low byte of that character is used as an index to select one of the +double-byte numbers in that page - the value obtained being the +corresponding Unicode character. By examination of the example above, +one can see that the characters 0x7E and 0x8163 in B<shiftjis> map to +203E and 2026 in Unicode, respectively. + +Following the first page will be all the other pages, each in the same +format as the first: one number identifying the page followed by 256 +double-byte Unicode characters. If a character in the encoding maps +to the Unicode character 0000, it means that the character doesn't +actually exist. If all characters on a page would map to 0000, that +page can be omitted. + +Case [4] is the escape-sequence encoding file. The lines in an this +type of file are in the same format as this example taken from the +B<iso2022-jp> encoding: + + # Encoding file: iso2022-jp, escape-driven + E + init {} + final {} + iso8859-1 \\x1b(B + jis0201 \\x1b(J + jis0208 \\x1b$@ + jis0208 \\x1b$B + jis0212 \\x1b$(D + gb2312 \\x1b$A + ksc5601 \\x1b$(C + +In the file, the first column represents an option and the second +column is the associated value. B<init> is a string to emit or expect +before the first character is converted, while B<final> is a string to +emit or expect after the last character. All other options are names +of table-based encodings; the associated value is the escape-sequence +that marks that encoding. Tcl syntax is used for the values; in the +above example, for instance, ``B<{}>'' represents the empty string and +``B<\\x1b>'' represents character 27. + +B<Completely Tcl-specific paragraph, ignore in the context of Perl> +When B<Tcl_GetEncoding> encounters an encoding I<name> that has not +been loaded, it attempts to load an encoding file called +I<name>B<.enc> from the B<encoding> subdirectory of each directory +specified in the library path B<$tcl_libPath>. If the encoding file +exists, but is malformed, an error message will be left in I<interp>. + +=head1 KEYWORDS + +utf, encoding, convert + +=head1 COPYRIGHT + + # Copyright (c) 1997-1998 Sun Microsystems, Inc. + # See the file "license.terms" for information on usage and redistribution + # of this file, and for a DISCLAIMER OF ALL WARRANTIES. + # RCS: @(#) $Id: Encoding.3,v 1.7 1999/10/13 00:32:05 hobbs Exp $ diff --git a/ext/Encode/Encode/ascii.enc b/ext/Encode/Encode/ascii.enc index e0320b8c58..284a9f51d2 100644 --- a/ext/Encode/Encode/ascii.enc +++ b/ext/Encode/Encode/ascii.enc @@ -9,7 +9,7 @@ S 0040004100420043004400450046004700480049004A004B004C004D004E004F 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F -0070007100720073007400750076007700780079007A007B007C007D007E0000 +0070007100720073007400750076007700780079007A007B007C007D007E007F 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 diff --git a/ext/Encode/Encode/cp1006.enc b/ext/Encode/Encode/cp1006.enc new file mode 100644 index 0000000000..3ba00dd7e4 --- /dev/null +++ b/ext/Encode/Encode/cp1006.enc @@ -0,0 +1,20 @@ +# Encoding file: cp1006, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +0080008100820083008400850086008700880089008A008B008C008D008E008F +0090009100920093009400950096009700980099009A009B009C009D009E009F +00A006F006F106F206F306F406F506F606F706F806F9060C061B00AD061FFE81 +FE8DFE8EFE8EFE8FFE91FB56FB58FE93FE95FE97FB66FB68FE99FE9BFE9DFE9F +FB7AFB7CFEA1FEA3FEA5FEA7FEA9FB84FEABFEADFB8CFEAFFB8AFEB1FEB3FEB5 +FEB7FEB9FEBBFEBDFEBFFEC1FEC5FEC9FECAFECBFECCFECDFECEFECFFED0FED1 +FED3FED5FED7FED9FEDBFB92FB94FEDDFEDFFEE0FEE1FEE3FB9EFEE5FEE7FE85 +FEEDFBA6FBA8FBA9FBAAFE80FE89FE8AFE8BFEF1FEF2FEF3FBB0FBAEFE7CFE7D diff --git a/ext/Encode/Encode/cp1047.enc b/ext/Encode/Encode/cp1047.enc new file mode 100644 index 0000000000..8956fa4558 --- /dev/null +++ b/ext/Encode/Encode/cp1047.enc @@ -0,0 +1,20 @@ +# Encoding file: cp1047 (EBCDIC), single-byte +S +006F 0 1 +00 +0000000100020003009C00090086007F0097008D008E000B000C000D000E000F +0010001100120013009D000A00080087001800190092008F001C001D001E001F +0080008100820083008400850017001B00880089008A008B008C000500060007 +0090009100160093009400950096000400980099009A009B00140015009E001A +002000A000E200E400E000E100E300E500E700F100A2002E003C0028002B007C +002600E900EA00EB00E800ED00EE00EF00EC00DF00210024002A0029003B005E +002D002F00C200C400C000C100C300C500C700D100A6002C0025005F003E003F +00F800C900CA00CB00C800CD00CE00CF00CC0060003A002300400027003D0022 +00D800610062006300640065006600670068006900AB00BB00F000FD00FE00B1 +00B0006A006B006C006D006E006F00700071007200AA00BA00E600B800C600A4 +00B5007E0073007400750076007700780079007A00A100BF00D0005B00DE00AE +00AC00A300A500B700A900A700B600BC00BD00BE00DD00A800AF005D00B400D7 +007B00410042004300440045004600470048004900AD00F400F600F200F300F5 +007D004A004B004C004D004E004F00500051005200B900FB00FC00F900FA00FF +005C00F70053005400550056005700580059005A00B200D400D600D200D300D5 +003000310032003300340035003600370038003900B300DB00DC00D900DA009F diff --git a/ext/Encode/Encode/cp37.enc b/ext/Encode/Encode/cp37.enc new file mode 100644 index 0000000000..94d8c335bf --- /dev/null +++ b/ext/Encode/Encode/cp37.enc @@ -0,0 +1,20 @@ +# Encoding file: cp37 (EBCDIC), single-byte +S +006F 0 1 +00 +0000000100020003009C00090086007F0097008D008E000B000C000D000E000F +0010001100120013009D008500080087001800190092008F001C001D001E001F +00800081008200830084000A0017001B00880089008A008B008C000500060007 +0090009100160093009400950096000400980099009A009B00140015009E001A +002000A000E200E400E000E100E300E500E700F100A2002E003C0028002B007C +002600E900EA00EB00E800ED00EE00EF00EC00DF00210024002A0029003B00AC +002D002F00C200C400C000C100C300C500C700D100A6002C0025005F003E003F +00F800C900CA00CB00C800CD00CE00CF00CC0060003A002300400027003D0022 +00D800610062006300640065006600670068006900AB00BB00F000FD00FE00B1 +00B0006A006B006C006D006E006F00700071007200AA00BA00E600B800C600A4 +00B5007E0073007400750076007700780079007A00A100BF00D000DD00DE00AE +005E00A300A500B700A900A700B600BC00BD00BE005B005D00AF00A800B400D7 +007B00410042004300440045004600470048004900AD00F400F600F200F300F5 +007D004A004B004C004D004E004F00500051005200B900FB00FC00F900FA00FF +005C00F70053005400550056005700580059005A00B200D400D600D200D300D5 +003000310032003300340035003600370038003900B300DB00DC00D900DA009F diff --git a/ext/Encode/Encode/cp424.enc b/ext/Encode/Encode/cp424.enc new file mode 100644 index 0000000000..3b0c23ec7a --- /dev/null +++ b/ext/Encode/Encode/cp424.enc @@ -0,0 +1,20 @@ +# Encoding file: cp424, single-byte +S +003F 0 1 +00 +0000000100020003009C00090086007F0097008D008E000B000C000D000E000F +0010001100120013009D008500080087001800190092008F001C001D001E001F +00800081008200830084000A0017001B00880089008A008B008C000500060007 +0090009100160093009400950096000400980099009A009B00140015009E001A +002005D005D105D205D305D405D505D605D705D800A2002E003C0028002B007C +002605D905DA05DB05DC05DD05DE05DF05E005E100210024002A0029003B00AC +002D002F05E205E305E405E505E605E705E805E900A6002C0025005F003E003F +000005EA0000000000A000000000000020170060003A002300400027003D0022 +000000610062006300640065006600670068006900AB00BB00000000000000B1 +00B0006A006B006C006D006E006F00700071007200000000000000B8000000A4 +00B5007E0073007400750076007700780079007A0000000000000000000000AE +005E00A300A500B700A900A700B600BC00BD00BE005B005D00AF00A800B400D7 +007B00410042004300440045004600470048004900AD00000000000000000000 +007D004A004B004C004D004E004F00500051005200B900000000000000000000 +005C00F70053005400550056005700580059005A00B200000000000000000000 +003000310032003300340035003600370038003900B30000000000000000009F diff --git a/ext/Encode/Encode/cp856.enc b/ext/Encode/Encode/cp856.enc new file mode 100644 index 0000000000..cab493c60a --- /dev/null +++ b/ext/Encode/Encode/cp856.enc @@ -0,0 +1,20 @@ +# Encoding file: cp856, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +05D005D105D205D305D405D505D605D705D805D905DA05DB05DC05DD05DE05DF +05E005E105E205E305E405E505E605E705E805E905EA000000A3000000D70000 +00000000000000000000000000000000000000AE00AC00BD00BC000000AB00BB +2591259225932502252400000000000000A9256325512557255D00A200A52510 +25142534252C251C2500253C00000000255A25542569256625602550256C00A4 +0000000000000000000000000000000000002518250C2588258400A600002580 +00000000000000000000000000B5000000000000000000000000000000AF00B4 +00AD00B1201700BE00B600A700F700B800B000A800B700B900B300B225A000A0 diff --git a/ext/Encode/Encode/gsm0338.enc b/ext/Encode/Encode/gsm0338.enc new file mode 100644 index 0000000000..bf09e70e8b --- /dev/null +++ b/ext/Encode/Encode/gsm0338.enc @@ -0,0 +1,20 @@ +# Encoding file: GSM 03.38, single-byte +S +003F 0 1 +00 +004000A3002400A500E800E900F900EC00F200E7000A00D800F8000D00C500E5 +0394005F03A60393039B03A903A003A803A30398039E00A000C600E600DF00C9 +002000210022002300A400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +00A1004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A00C400D600D100DC00A7 +00BF006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A00E400F600F100FC00E0 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 diff --git a/ext/Encode/Encode/iso8859-10.enc b/ext/Encode/Encode/iso8859-10.enc new file mode 100644 index 0000000000..934b3b920b --- /dev/null +++ b/ext/Encode/Encode/iso8859-10.enc @@ -0,0 +1,20 @@ +# Encoding file: iso8859-10, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +0080008100820083008400850086008700880089008A008B008C008D008E008F +0090009100920093009400950096009700980099009A009B009C009D009E009F +00A0010401120122012A0128013600A7013B011001600166017D00AD016A014A +00B0010501130123012B0129013700B7013C011101610167017E2015016B014B +010000C100C200C300C400C500C6012E010C00C9011800CB011600CD00CE00CF +00D00145014C00D300D400D500D6016800D8017200DA00DB00DC00DD00DE00DF +010100E100E200E300E400E500E6012F010D00E9011900EB011700ED00EE00EF +00F00146014D00F300F400F500F6016900F8017300FA00FB00FC00FD00FE0138 diff --git a/ext/Encode/Encode/iso8859-13.enc b/ext/Encode/Encode/iso8859-13.enc new file mode 100644 index 0000000000..b7edcaf38f --- /dev/null +++ b/ext/Encode/Encode/iso8859-13.enc @@ -0,0 +1,20 @@ +# Encoding file: iso8859-13, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +0080008100820083008400850086008700880089008A008B008C008D008E008F +0090009100920093009400950096009700980099009A009B009C009D009E009F +00A0201D00A200A300A4201E00A600A700D800A9015600AB00AC00AD00AE00C6 +00B000B100B200B3201C00B500B600B700F800B9015700BB00BC00BD00BE00E6 +0104012E0100010600C400C501180112010C00C90179011601220136012A013B +01600143014500D3014C00D500D600D701720141015A016A00DC017B017D00DF +0105012F0101010700E400E501190113010D00E9017A011701230137012B013C +01610144014600F3014D00F500F600F701730142015B016B00FC017C017E2019 diff --git a/ext/Encode/Encode/iso8859-14.enc b/ext/Encode/Encode/iso8859-14.enc new file mode 100644 index 0000000000..a65ba05b9a --- /dev/null +++ b/ext/Encode/Encode/iso8859-14.enc @@ -0,0 +1,20 @@ +# Encoding file: iso8859-14, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +0080008100820083008400850086008700880089008A008B008C008D008E008F +0090009100920093009400950096009700980099009A009B009C009D009E009F +00A01E021E0300A3010A010B1E0A00A71E8000A91E821E0B1EF200AD00AE0178 +1E1E1E1F012001211E401E4100B61E561E811E571E831E601EF31E841E851E61 +00C000C100C200C300C400C500C600C700C800C900CA00CB00CC00CD00CE00CF +017400D100D200D300D400D500D61E6A00D800D900DA00DB00DC00DD017600DF +00E000E100E200E300E400E500E600E700E800E900EA00EB00EC00ED00EE00EF +017500F100F200F300F400F500F61E6B00F800F900FA00FB00FC00FD017700FF diff --git a/ext/Encode/Encode/iso8859-15.enc b/ext/Encode/Encode/iso8859-15.enc new file mode 100644 index 0000000000..823af466e5 --- /dev/null +++ b/ext/Encode/Encode/iso8859-15.enc @@ -0,0 +1,20 @@ +# Encoding file: iso8859-15, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +0080008100820083008400850086008700880089008A008B008C008D008E008F +0090009100920093009400950096009700980099009A009B009C009D009E009F +00A000A100A200A320AC00A5016000A7016100A900AA00AB00AC00AD00AE00AF +00B000B100B200B3017D00B500B600B7017E00B900BA00BB01520153017800BF +00C000C100C200C300C400C500C600C700C800C900CA00CB00CC00CD00CE00CF +00D000D100D200D300D400D500D600D700D800D900DA00DB00DC00DD00DE00DF +00E000E100E200E300E400E500E600E700E800E900EA00EB00EC00ED00EE00EF +00F000F100F200F300F400F500F600F700F800F900FA00FB00FC00FD00FE00FF diff --git a/ext/Encode/Encode/iso8859-16.enc b/ext/Encode/Encode/iso8859-16.enc new file mode 100644 index 0000000000..1936b97b6f --- /dev/null +++ b/ext/Encode/Encode/iso8859-16.enc @@ -0,0 +1,20 @@ +# Encoding file: iso8859-16, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +0080008100820083008400850086008700880089008A008B008C008D008E008F +0090009100920093009400950096009700980099009A009B009C009D009E009F +00A001040105014120AC00AB016000A7016100A90218201E017900AD017A017B +00B000B1010C0142017D201D00B600B7017E010D021900BB015201530178017C +00C000C100C2010200C4010600C600C700C800C900CA00CB00CC00CD00CE00CF +0110014300D200D300D4015000D6015A017000D900DA00DB00DC0118021A00DF +00E000E100E2010300E4010700E600E700E800E900EA00EB00EC00ED00EE00EF +0111014400F200F300F4015100F6015B017100F900FA00FB00FC0119021B00FF diff --git a/ext/Encode/Encode/posix-bc.enc b/ext/Encode/Encode/posix-bc.enc new file mode 100644 index 0000000000..8b533a4933 --- /dev/null +++ b/ext/Encode/Encode/posix-bc.enc @@ -0,0 +1,20 @@ +# Encoding file: posix-bc (EBCDIC), single-byte +S +006F 0 1 +00 +0000000100020003009C00090086007F0097008D008E000B000C000D000E000F +0010001100120013009D000A00080087001800190092008F001C001D001E001F +0080008100820083008400850017001B00880089008A008B008C000500060007 +0090009100160093009400950096000400980099009A009B00140015009E001A +002000A000E200E400E000E100E300E500E700F10060002E003C0028002B007C +002600E900EA00EB00E800ED00EE00EF00EC00DF00210024002A0029003B009F +002D002F00C200C400C000C100C300C500C700D1005E002C0025005F003E003F +00F800C900CA00CB00C800CD00CE00CF00CC00A8003A002300400027003D0022 +00D800610062006300640065006600670068006900AB00BB00F000FD00FE00B1 +00B0006A006B006C006D006E006F00700071007200AA00BA00E600B800C600A4 +00B500AF0073007400750076007700780079007A00A100BF00D000DD00DE00AE +00A200A300A500B700A900A700B600BC00BD00BE00AC005B005C005D00B400D7 +00F900410042004300440045004600470048004900AD00F400F600F200F300F5 +00A6004A004B004C004D004E004F00500051005200B900FB00FC00DB00FA00FF +00D900F70053005400550056005700580059005A00B200D400D600D200D300D5 +003000310032003300340035003600370038003900B3007B00DC007D00DA007E diff --git a/ext/Encode/Makefile.PL b/ext/Encode/Makefile.PL index 329937e0e2..4b1ec95ad2 100644 --- a/ext/Encode/Makefile.PL +++ b/ext/Encode/Makefile.PL @@ -1,7 +1,25 @@ use ExtUtils::MakeMaker; + +my %tables = (iso8859 => ['ascii.enc', 'cp1250.enc'], + EBCDIC => ['cp1047.enc','cp37.enc','posix-bc.enc'], + Symbols => ['symbol.enc','dingbats.enc'], + ); + +opendir(ENC,'Encode'); +while (defined(my $file = readdir(ENC))) + { + if ($file =~ /iso8859.*\.enc/) + { + push(@{$tables{iso8859}},$file); + } + } +closedir(ENC); + + WriteMakefile( NAME => "Encode", VERSION_FROM => 'Encode.pm', + OBJECT => '$(O_FILES)', 'dist' => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', @@ -9,3 +27,84 @@ WriteMakefile( }, MAN3PODS => {}, ); + +package MY; + + +sub post_initialize +{ + my ($self) = @_; + my %o; + # Find existing O_FILES + foreach my $f (@{$self->{'O_FILES'}}) + { + $o{$f} = 1; + } + my $x = $self->{'OBJ_EXT'}; + # Add the table O_FILES + foreach my $e (keys %tables) + { + $o{$e.$x} = 1; + } + # Reset the variable + $self->{'O_FILES'} = [sort keys %o]; + my @files; + foreach my $table (keys %tables) + { + foreach my $ext (qw($(OBJ_EXT) .c .h .def)) + { + push (@files,$table.$ext); + } + } + $self->{'clean'}{'FILES'} .= join(' ',@files); + return ''; +} + +sub postamble +{ + my $self = shift; + my $dir = $self->catdir($self->curdir,'Encode'); + my $str = "# Encode$(OBJ_EXT) depends on .h and .def files not .c files - but all written by compile\n"; + $str .= 'Encode$(OBJ_EXT) :'; + my @rules; + foreach my $table (keys %tables) + { + $str .= " $table.c"; + } + $str .= "\n\n"; + foreach my $table (keys %tables) + { + my $numlines = 1; + my $lengthsofar = length($str); + my $continuator = ''; + $str .= "$table.c : compile Makefile.PL"; + foreach my $file (@{$tables{$table}}) + { + $str .= $continuator.' '.$self->catfile($dir,$file); + if ( length($str)-$lengthsofar > 128*$numlines ) + { + $continuator .= " \\\n\t"; + $numlines++; + } else { + $continuator = ''; + } + } + $numlines = 1; + $lengthsofar = length($str); + $continuator = ''; + $str .= "\n\t\$(PERL) compile \$\@"; + foreach my $file (@{$tables{$table}}) + { + $str .= $continuator.' '.$self->catfile($dir,$file); + if ( length($str)-$lengthsofar > 128*$numlines ) + { + $continuator .= "\n\t\$(PERL) compile \$\@"; + $numlines++; + } else { + $continuator = ''; + } + } + $str .= "\n\n"; + } + return $str; +} diff --git a/ext/Encode/compile b/ext/Encode/compile new file mode 100755 index 0000000000..b890a04d81 --- /dev/null +++ b/ext/Encode/compile @@ -0,0 +1,530 @@ +#!../../perl -w +BEGIN { @INC = '../../lib' }; +use strict; + +sub encode_U +{ + # UTF-8 encode long hand - only covers part of perl's range + my $uv = shift; + if ($uv < 0x80) + { + return chr($uv) + } + if ($uv < 0x800) + { + return chr(($uv >> 6) | 0xC0). + chr(($uv & 0x3F) | 0x80); + } + return chr(($uv >> 12) | 0xE0). + chr((($uv >> 6) & 0x3F) | 0x80). + chr(($uv & 0x3F) | 0x80); +} + +sub encode_S +{ + # encode single byte + my ($ch,$page) = @_; + return chr($ch); +} + +sub encode_D +{ + # encode double byte MS byte first + my ($ch,$page) = @_; + return chr($page).chr($ch); +} + +sub encode_M +{ + # encode Multi-byte - single for 0..255 otherwise double + my ($ch,$page) = @_; + return &encode_D if $page; + return &encode_S; +} + +# Win32 does not expand globs on command line +eval "\@ARGV = map(glob(\$_),\@ARGV)" if ($^O eq 'MSWin32'); + +my $cname = shift(@ARGV); +chmod(0666,$cname) if -f $cname && !-w $cname; +open(C,">$cname") || die "Cannot open $cname:$!"; +my $dname = $cname; +$dname =~ s/(\.[^\.]*)?$/.def/; + +my ($doC,$doEnc,$doUcm); + +if ($cname =~ /\.(c|xs)$/) + { + $doC = 1; + chmod(0666,$dname) if -f $cname && !-w $dname; + open(D,">$dname") || die "Cannot open $dname:$!"; + my $hname = $cname; + $hname =~ s/(\.[^\.]*)?$/.h/; + chmod(0666,$hname) if -f $cname && !-w $hname; + open(H,">$hname") || die "Cannot open $hname:$!"; + + foreach my $fh (\*C,\*D,\*H) + { + print $fh <<"END"; +/* + !!!!!!! DO NOT EDIT THIS FILE !!!!!!! + This file was autogenerated by: + $^X $0 $cname @ARGV +*/ +END + } + + if ($cname =~ /(\w+)\.xs$/) + { + print C "#include <EXTERN.h>\n"; + print C "#include <perl.h>\n"; + print C "#include <XSUB.h>\n"; + print C "#define U8 U8\n"; + } + print C "#include \"encode.h\"\n"; + } +elsif ($cname =~ /\.enc$/) + { + $doEnc = 1; + } +elsif ($cname =~ /\.ucm$/) + { + $doUcm = 1; + } + +my %encoding; +my %strings; + +sub cmp_name +{ + if ($a =~ /^.*-(\d+)/) + { + my $an = $1; + if ($b =~ /^.*-(\d+)/) + { + my $r = $an <=> $1; + return $r if $r; + } + } + return $a cmp $b; +} + +foreach my $enc (sort cmp_name @ARGV) + { + my ($name,$sfx) = $enc =~ /^.*?([\w-]+)\.(enc|ucm)$/; + if (open(E,$enc)) + { + if ($sfx eq 'enc') + { + compile_enc(\*E,lc($name),\*C); + } + else + { + compile_ucm(\*E,lc($name),\*C); + } + } + else + { + warn "Cannot open $enc for $name:$!"; + } + } + +if ($doC) + { + foreach my $enc (sort cmp_name keys %encoding) + { + my $sym = "${enc}_encoding"; + $sym =~ s/\W+/_/g; + print C "encode_t $sym = \n"; + print C " {",join(',',"\"$enc\"",@{$encoding{$enc}}),"};\n\n"; + } + + foreach my $enc (sort cmp_name keys %encoding) + { + my $sym = "${enc}_encoding"; + $sym =~ s/\W+/_/g; + print H "extern encode_t $sym;\n"; + print D " Encode_Define(aTHX_ &$sym);\n"; + } + + if ($cname =~ /(\w+)\.xs$/) + { + my $mod = $1; + print C "\nMODULE = Encode::$mod\tPACKAGE = Encode::$mod\n\n"; + print C "BOOT:\n{\n"; + print C "#include \"$dname\"\n"; + print C "}\n"; + } + close(D); + close(H); + } +close(C); + + +sub compile_ucm +{ + my ($fh,$name,$ch) = @_; + my $e2u = {}; + my $u2e = {}; + my $cs; + my %attr; + while (<$fh>) + { + s/#.*$//; + last if /^\s*CHARMAP\s*$/i; + if (/^\s*<(\w+)>\s+"?([^"]*)"?\s*$/i) + { + $attr{$1} = $2; + } + } + if (!defined($cs = $attr{'code_set_name'})) + { + warn "No <code_set_name> in $name\n"; + } + else + { + # $name = lc($cs); + } + my $erep; + my $urep; + if (exists $attr{'subchar'}) + { + my @byte = $attr{'subchar'} =~ /^\s*(?:\\x([0-9a-f]+))+\s*$/; + $erep = join('',map(hex($_),@byte)); + } + warn "Scanning $name ($cs)\n"; + my $nfb = 0; + my $hfb = 0; + while (<$fh>) + { + s/#.*$//; + last if /^\s*END\s+CHARMAP\s*$/i; + next if /^\s*$/; + my ($u,@byte) = /^<U([0-9a-f]+)>\s+(?:\\x([0-9a-f]+))+\s*(\|[0-3]|)\s*$/i; + my $fb = pop(@byte); + if (defined($u)) + { + my $uch = encode_U(hex($u)); + my $ech = join('',map(chr(hex($_)),@byte)); + if (length($fb)) + { + $fb = substr($fb,1); + $hfb++; + } + else + { + $nfb++; + $fb = '0'; + } + # $fb is fallback flag + # 0 - round trip safe + # 1 - fallback for unicode -> enc + # 2 - skip sub-char mapping + # 3 - fallback enc -> unicode + enter($u2e,$uch,$ech,$u2e,$fb+0) if ($fb =~ /[01]/); + enter($e2u,$ech,$uch,$e2u,$fb+0) if ($fb =~ /[03]/); + } + else + { + warn $_; + } + + } + if ($nfb && $hfb) + { + die "$nfb entries without fallback, $hfb entries with\n"; + } + if ($doC) + { + output($ch,$name.'_utf8',$e2u); + output($ch,'utf8_'.$name,$u2e); + $encoding{$name} = [$e2u->{Cname},$u2e->{Cname}, + outstring($ch,$e2u->{Cname}.'_def',$erep),length($erep)]; + } + elsif ($doEnc) + { + output_enc($ch,$name,$e2u); + } + elsif ($doUcm) + { + output_ucm($ch,$name,$u2e); + } +} + +sub compile_enc +{ + my ($fh,$name,$ch) = @_; + my $e2u = {}; + my $u2e = {}; + + my $type; + while ($type = <$fh>) + { + last if $type !~ /^\s*#/; + } + chomp($type); + return if $type eq 'E'; + my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>)); + warn "$type encoded $name\n"; + my $rep = ''; + { + my $v = hex($def); + no strict 'refs'; + $rep = &{"encode_$type"}($v & 0xFF, ($v >> 8) & 0xffe); + } + while ($pages--) + { + my $line = <$fh>; + chomp($line); + my $page = hex($line); + my $ch = 0; + for (my $i = 0; $i < 16; $i++) + { + my $line = <$fh>; + for (my $j = 0; $j < 16; $j++) + { + no strict 'refs'; + my $ech = &{"encode_$type"}($ch,$page); + my $val = hex(substr($line,0,4,'')); + if ($val || (!$ch && !$page)) + { + my $uch = encode_U($val); + enter($e2u,$ech,$uch,$e2u,0); + enter($u2e,$uch,$ech,$u2e,0); + } + else + { + # No character at this position + # enter($e2u,$ech,undef,$e2u); + } + $ch++; + } + } + } + if ($doC) + { + output($ch,$name.'_utf8',$e2u); + output($ch,'utf8_'.$name,$u2e); + $encoding{$name} = [$e2u->{Cname},$u2e->{Cname}, + outstring($ch,$e2u->{Cname}.'_def',$rep),length($rep)]; + } + elsif ($doEnc) + { + output_enc($ch,$name,$e2u); + } + elsif ($doUcm) + { + output_ucm($ch,$name,$u2e); + } +} + +sub enter +{ + my ($a,$s,$d,$t,$fb) = @_; + $t = $a if @_ < 4; + my $b = substr($s,0,1); + my $e = $a->{$b}; + unless ($e) + { # 0 1 2 3 4 5 + $e = [$b,$b,'',{},length($s),0,$fb]; + $a->{$b} = $e; + } + if (length($s) > 1) + { + enter($e->[3],substr($s,1),$d,$t,$fb); + } + else + { + $e->[2] = $d; + $e->[3] = $t; + $e->[5] = length($d); + } +} + +sub outstring +{ + my ($fh,$name,$s) = @_; + my $sym = $strings{$s}; + unless ($sym) + { + foreach my $o (keys %strings) + { + my $i = index($o,$s); + if ($i >= 0) + { + $sym = $strings{$o}; + $sym .= sprintf("+0x%02x",$i) if ($i); + return $sym; + } + } + $strings{$s} = $sym = $name; + printf $fh "\nstatic const U8 %s[%d] =\n",$name,length($s); + # Do in chunks of 16 chars to constrain line length + # Assumes ANSI C adjacent string litteral concatenation + while (length($s)) + { + my $c = substr($s,0,16,''); + print $fh '"',join('',map(sprintf('\x%02x',ord($_)),split(//,$c))),'"'; + print $fh "\n" if length($s); + } + printf $fh ";\n"; + } + return $sym; +} + +sub process +{ + my ($name,$a) = @_; + $name =~ s/\W+/_/g; + $a->{Cname} = $name; + my @keys = grep(ref($a->{$_}),sort keys %$a); + my $l; + my @ent; + foreach my $b (@keys) + { + my ($s,$f,$out,$t,$end) = @{$a->{$b}}; + if (defined($l) && + ord($b) == ord($a->{$l}[1])+1 && + $a->{$l}[3] == $a->{$b}[3] && + $a->{$l}[4] == $a->{$b}[4] && + $a->{$l}[5] == $a->{$b}[5] && + $a->{$l}[6] == $a->{$b}[6] + # && length($a->{$l}[2]) < 16 + ) + { + my $i = ord($b)-ord($a->{$l}[0]); + $a->{$l}[1] = $b; + $a->{$l}[2] .= $a->{$b}[2]; + } + else + { + $l = $b; + push(@ent,$b); + } + if (exists $t->{Cname}) + { + $t->{'Forward'} = 1 if $t != $a; + } + else + { + process(sprintf("%s_%02x",$name,ord($s)),$t); + } + } + if (ord($keys[-1]) < 255) + { + my $t = chr(ord($keys[-1])+1); + $a->{$t} = [$t,chr(255),undef,$a,0,0]; + push(@ent,$t); + } + $a->{'Entries'} = \@ent; +} + +sub outtable +{ + my ($fh,$a) = @_; + my $name = $a->{'Cname'}; + # String tables + foreach my $b (@{$a->{'Entries'}}) + { + next unless $a->{$b}[5]; + my $s = ord($a->{$b}[0]); + my $e = ord($a->{$b}[1]); + outstring($fh,sprintf("%s__%02x_%02x",$name,$s,$e),$a->{$b}[2]); + } + if ($a->{'Forward'}) + { + print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n"; + } + $a->{'Done'} = 1; + foreach my $b (@{$a->{'Entries'}}) + { + my ($s,$e,$out,$t,$end,$l) = @{$a->{$b}}; + outtable($fh,$t) unless $t->{'Done'}; + } + print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"] = {\n"; + foreach my $b (@{$a->{'Entries'}}) + { + my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}}; + my $sc = ord($s); + my $ec = ord($e); + $end |= 0x80 if $fb; + print $fh "{"; + if ($l) + { + printf $fh outstring($fh,'',$out); + } + else + { + print $fh "0"; + } + print $fh ",",$t->{Cname}; + printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec; + } + print $fh "};\n"; +} + +sub output +{ + my ($fh,$name,$a) = @_; + process($name,$a); + # Sub-tables + outtable($fh,$a); +} + +sub output_enc +{ + my ($fh,$name,$a) = @_; + foreach my $b (sort keys %$a) + { + my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}}; + } +} + +sub decode_U +{ + my $s = shift; + +} + + +sub output_ucm_page +{ + my ($fh,$a,$t,$pre) = @_; + # warn sprintf("Page %x\n",$pre); + foreach my $b (sort keys %$t) + { + my ($s,$e,$out,$n,$end,$l,$fb) = @{$t->{$b}}; + die "oops $s $e" unless $s eq $e; + my $u = ord($s); + if ($n != $a && $n != $t) + { + output_ucm_page($fh,$a,$n,(($pre|($u &0x3F)) << 6)&0xFFFF); + } + elsif (length($out)) + { + if ($pre) + { + $u = $pre|($u &0x3f); + } + printf $fh "<U%04X> ",$u; + foreach my $c (split(//,$out)) + { + printf $fh "\\x%02X",ord($c); + } + printf $fh " |%d\n",($fb ? 1 : 0); + } + else + { + warn join(',',@{$t->{$b}},$a,$t); + } + } +} + +sub output_ucm +{ + my ($fh,$name,$a) = @_; + print $fh "CHARMAP\n"; + output_ucm_page($fh,$a,$a,0); + print $fh "END CHARMAP\n"; +} + diff --git a/ext/Encode/encengine.c b/ext/Encode/encengine.c new file mode 100644 index 0000000000..513ef9ac5b --- /dev/null +++ b/ext/Encode/encengine.c @@ -0,0 +1,164 @@ +/* +Data structures for encoding transformations. + +Perl works internally in either a native 'byte' encoding or +in UTF-8 encoded Unicode. We have no immediate need for a "wchar_t" +representation. When we do we can use utf8_to_uv(). + +Most character encodings are either simple byte mappings or +variable length multi-byte encodings. UTF-8 can be viewed as a +rather extreme case of the latter. + +So to solve an important part of perl's encode needs we need to solve the +"multi-byte -> multi-byte" case. The simple byte forms are then just degenerate +case. (Where one of multi-bytes will usually be UTF-8.) + +The other type of encoding is a shift encoding where a prefix sequence +determines what subsequent bytes mean. Such encodings have state. + +We also need to handle case where a character in one encoding has to be +represented as multiple characters in the other. e.g. letter+diacritic. + +The process can be considered as pseudo perl: + +my $dst = ''; +while (length($src)) + { + my $size = $count($src); + my $in_seq = substr($src,0,$size,''); + my $out_seq = $s2d_hash{$in_seq}; + if (defined $out_seq) + { + $dst .= $out_seq; + } + else + { + # an error condition + } + } +return $dst; + +That has the following components: + &src_count - a "rule" for how many bytes make up the next character in the + source. + %s2d_hash - a mapping from input sequences to output sequences + +The problem with that scheme is that it does not allow the output +character repertoire to affect the characters considered from the +input. + +So we use a "trie" representation which can also be considered +a state machine: + +my $dst = ''; +my $seq = \@s2d_seq; +my $next = \@s2d_next; +while (length($src)) + { + my $byte = $substr($src,0,1,''); + my $out_seq = $seq->[$byte]; + if (defined $out_seq) + { + $dst .= $out_seq; + } + else + { + # an error condition + } + ($next,$seq) = @$next->[$byte] if $next; + } +return $dst; + +There is now a pair of data structures to represent everything. +It is valid for output sequence at a particular point to +be defined but zero length, that just means "don't know yet". +For the single byte case there is no 'next' so new tables will be the same as +the original tables. For a multi-byte case a prefix byte will flip to the tables +for the next page (adding nothing to the output), then the tables for the page +will provide the actual output and set tables back to original base page. + +This scheme can also handle shift encodings. + +A slight enhancement to the scheme also allows for look-ahead - if +we add a flag to re-add the removed byte to the source we could handle + a" -> ä + ab -> a (and take b back please) + +*/ + +#include <EXTERN.h> +#include <perl.h> +#define U8 U8 +#include "encode.h" + +int +do_encode(encpage_t *enc, const U8 *src, STRLEN *slen, U8 *dst, STRLEN dlen, STRLEN *dout, int approx) +{ + const U8 *s = src; + const U8 *send = s+*slen; + const U8 *last = s; + U8 *d = dst; + U8 *dend = d+dlen; + int code = 0; + while (s < send) + { + encpage_t *e = enc; + U8 byte = *s; + while (byte > e->max) + e++; + if (byte >= e->min && e->slen && (approx || !(e->slen & 0x80))) + { + const U8 *cend = s + (e->slen & 0x7f); + if (cend <= send) + { + STRLEN n; + if ((n = e->dlen)) + { + const U8 *out = e->seq+n*(byte - e->min); + U8 *oend = d+n; + if (dst) + { + if (oend <= dend) + { + while (d < oend) + *d++ = *out++; + } + else + { + /* Out of space */ + code = ENCODE_NOSPACE; + break; + } + } + else + d = oend; + } + enc = e->next; + s++; + if (s == cend) + { + if (approx && (e->slen & 0x80)) + code = ENCODE_FALLBACK; + last = s; + } + } + else + { + /* partial source character */ + code = ENCODE_PARTIAL; + break; + } + } + else + { + /* Cannot represent */ + code = ENCODE_NOREP; + break; + } + } + *slen = last - src; + *dout = d - dst; + return code; +} + + diff --git a/ext/Encode/encode.h b/ext/Encode/encode.h new file mode 100644 index 0000000000..853ad041b4 --- /dev/null +++ b/ext/Encode/encode.h @@ -0,0 +1,40 @@ +#ifndef ENCODE_H +#define ENCODE_H +#ifndef U8 +typedef unsigned char U8; +#endif + +typedef struct encpage_s encpage_t; + +struct encpage_s +{ + const U8 *seq; + encpage_t *next; + U8 min; + U8 max; + U8 dlen; + U8 slen; +}; + +typedef struct encode_s encode_t; +struct encode_s +{ + const char *name; + encpage_t *t_utf8; + encpage_t *f_utf8; + const U8 *rep; + int replen; +}; + +#ifdef U8 +extern int do_encode(encpage_t *enc, const U8 *src, STRLEN *slen, + U8 *dst, STRLEN dlen, STRLEN *dout, int approx); + +extern void Encode_DefineEncoding(encode_t *enc); +#endif + +#define ENCODE_NOSPACE 1 +#define ENCODE_PARTIAL 2 +#define ENCODE_NOREP 3 +#define ENCODE_FALLBACK 4 +#endif diff --git a/ext/Errno/Errno_pm.PL b/ext/Errno/Errno_pm.PL index 0666b2af60..3e34b90bee 100644 --- a/ext/Errno/Errno_pm.PL +++ b/ext/Errno/Errno_pm.PL @@ -2,9 +2,7 @@ use ExtUtils::MakeMaker; use Config; use strict; -use vars qw($VERSION); - -$VERSION = "1.111"; +our $VERSION = "1.111"; my %err = (); @@ -29,6 +27,12 @@ sub process_file { warn "Cannot open '$file'"; return; } + } elsif ($Config{gccversion} ne '') { + # With the -dM option, gcc outputs every #define it finds + unless(open(FH,"$Config{cc} -E -dM $file |")) { + warn "Cannot open '$file'"; + return; + } } else { unless(open(FH,"< $file")) { # This file could be a temporary file created by cppstdin @@ -79,6 +83,10 @@ sub get_files { } elsif ($^O eq 'vmesa') { # OS/390 C compiler doesn't generate #file or #line directives $file{'../../vmesa/errno.h'} = 1; + } elsif ($^O eq 'linux') { + # Some Linuxes have weird errno.hs which generate + # no #file or #line directives + $file{'/usr/include/errno.h'} = 1; } else { open(CPPI,"> errno.c") or die "Cannot open errno.c"; @@ -175,7 +183,7 @@ sub write_errno_pm { # package Errno; -use vars qw(\@EXPORT_OK \%EXPORT_TAGS \@ISA \$VERSION \%errno \$AUTOLOAD); +our (\@EXPORT_OK,\%EXPORT_TAGS,\@ISA,\$VERSION,\%errno,\$AUTOLOAD); use Exporter (); use Config; use strict; diff --git a/ext/Fcntl/Fcntl.pm b/ext/Fcntl/Fcntl.pm index 92103a1eaf..c68dda1c2f 100644 --- a/ext/Fcntl/Fcntl.pm +++ b/ext/Fcntl/Fcntl.pm @@ -201,7 +201,7 @@ sub S_ISENFMT { ( $_[0] & _S_IFMT() ) == S_IFENFMT() } sub AUTOLOAD { (my $constname = $AUTOLOAD) =~ s/.*:://; - my $val = constant($constname, 0); + my $val = constant($constname); if ($! != 0) { if ($! =~ /Invalid/ || $!{EINVAL}) { $AutoLoader::AUTOLOAD = $AUTOLOAD; diff --git a/ext/Fcntl/Fcntl.xs b/ext/Fcntl/Fcntl.xs index b597e03c1a..21029b212c 100644 --- a/ext/Fcntl/Fcntl.xs +++ b/ext/Fcntl/Fcntl.xs @@ -40,13 +40,13 @@ not_here(char *s) return -1; } -static double -constant(char *name, int arg) +static IV +constant(char *name) { errno = 0; - switch (*name) { + switch (*(name++)) { case '_': - if (strEQ(name, "_S_IFMT")) /* Yes, on name _S_IFMT return S_IFMT. */ + if (strEQ(name, "S_IFMT")) /* Yes, on name _S_IFMT return S_IFMT. */ #ifdef S_IFMT return S_IFMT; #else @@ -54,218 +54,219 @@ constant(char *name, int arg) #endif break; case 'F': - if (strnEQ(name, "F_", 2)) { - if (strEQ(name, "F_ALLOCSP")) + if (*name == '_') { + name++; + if (strEQ(name, "ALLOCSP")) #ifdef F_ALLOCSP return F_ALLOCSP; #else goto not_there; #endif - if (strEQ(name, "F_ALLOCSP64")) + if (strEQ(name, "ALLOCSP64")) #ifdef F_ALLOCSP64 return F_ALLOCSP64; #else goto not_there; #endif - if (strEQ(name, "F_COMPAT")) + if (strEQ(name, "COMPAT")) #ifdef F_COMPAT return F_COMPAT; #else goto not_there; #endif - if (strEQ(name, "F_DUP2FD")) + if (strEQ(name, "DUP2FD")) #ifdef F_DUP2FD return F_DUP2FD; #else goto not_there; #endif - if (strEQ(name, "F_DUPFD")) + if (strEQ(name, "DUPFD")) #ifdef F_DUPFD return F_DUPFD; #else goto not_there; #endif - if (strEQ(name, "F_EXLCK")) + if (strEQ(name, "EXLCK")) #ifdef F_EXLCK return F_EXLCK; #else goto not_there; #endif - if (strEQ(name, "F_FREESP")) + if (strEQ(name, "FREESP")) #ifdef F_FREESP return F_FREESP; #else goto not_there; #endif - if (strEQ(name, "F_FREESP64")) + if (strEQ(name, "FREESP64")) #ifdef F_FREESP64 return F_FREESP64; #else goto not_there; #endif - if (strEQ(name, "F_FSYNC")) + if (strEQ(name, "FSYNC")) #ifdef F_FSYNC return F_FSYNC; #else goto not_there; #endif - if (strEQ(name, "F_FSYNC64")) + if (strEQ(name, "FSYNC64")) #ifdef F_FSYNC64 return F_FSYNC64; #else goto not_there; #endif - if (strEQ(name, "F_GETFD")) + if (strEQ(name, "GETFD")) #ifdef F_GETFD return F_GETFD; #else goto not_there; #endif - if (strEQ(name, "F_GETFL")) + if (strEQ(name, "GETFL")) #ifdef F_GETFL return F_GETFL; #else goto not_there; #endif - if (strEQ(name, "F_GETLK")) + if (strEQ(name, "GETLK")) #ifdef F_GETLK return F_GETLK; #else goto not_there; #endif - if (strEQ(name, "F_GETLK64")) + if (strEQ(name, "GETLK64")) #ifdef F_GETLK64 return F_GETLK64; #else goto not_there; #endif - if (strEQ(name, "F_GETOWN")) + if (strEQ(name, "GETOWN")) #ifdef F_GETOWN return F_GETOWN; #else goto not_there; #endif - if (strEQ(name, "F_NODNY")) + if (strEQ(name, "NODNY")) #ifdef F_NODNY return F_NODNY; #else goto not_there; #endif - if (strEQ(name, "F_POSIX")) + if (strEQ(name, "POSIX")) #ifdef F_POSIX return F_POSIX; #else goto not_there; #endif - if (strEQ(name, "F_RDACC")) + if (strEQ(name, "RDACC")) #ifdef F_RDACC return F_RDACC; #else goto not_there; #endif - if (strEQ(name, "F_RDDNY")) + if (strEQ(name, "RDDNY")) #ifdef F_RDDNY return F_RDDNY; #else goto not_there; #endif - if (strEQ(name, "F_RDLCK")) + if (strEQ(name, "RDLCK")) #ifdef F_RDLCK return F_RDLCK; #else goto not_there; #endif - if (strEQ(name, "F_RWACC")) + if (strEQ(name, "RWACC")) #ifdef F_RWACC return F_RWACC; #else goto not_there; #endif - if (strEQ(name, "F_RWDNY")) + if (strEQ(name, "RWDNY")) #ifdef F_RWDNY return F_RWDNY; #else goto not_there; #endif - if (strEQ(name, "F_SETFD")) + if (strEQ(name, "SETFD")) #ifdef F_SETFD return F_SETFD; #else goto not_there; #endif - if (strEQ(name, "F_SETFL")) + if (strEQ(name, "SETFL")) #ifdef F_SETFL return F_SETFL; #else goto not_there; #endif - if (strEQ(name, "F_SETLK")) + if (strEQ(name, "SETLK")) #ifdef F_SETLK return F_SETLK; #else goto not_there; #endif - if (strEQ(name, "F_SETLK64")) + if (strEQ(name, "SETLK64")) #ifdef F_SETLK64 return F_SETLK64; #else goto not_there; #endif - if (strEQ(name, "F_SETLKW")) + if (strEQ(name, "SETLKW")) #ifdef F_SETLKW return F_SETLKW; #else goto not_there; #endif - if (strEQ(name, "F_SETLKW64")) + if (strEQ(name, "SETLKW64")) #ifdef F_SETLKW64 return F_SETLKW64; #else goto not_there; #endif - if (strEQ(name, "F_SETOWN")) + if (strEQ(name, "SETOWN")) #ifdef F_SETOWN return F_SETOWN; #else goto not_there; #endif - if (strEQ(name, "F_SHARE")) + if (strEQ(name, "SHARE")) #ifdef F_SHARE return F_SHARE; #else goto not_there; #endif - if (strEQ(name, "F_SHLCK")) + if (strEQ(name, "SHLCK")) #ifdef F_SHLCK return F_SHLCK; #else goto not_there; #endif - if (strEQ(name, "F_UNLCK")) + if (strEQ(name, "UNLCK")) #ifdef F_UNLCK return F_UNLCK; #else goto not_there; #endif - if (strEQ(name, "F_UNSHARE")) + if (strEQ(name, "UNSHARE")) #ifdef F_UNSHARE return F_UNSHARE; #else goto not_there; #endif - if (strEQ(name, "F_WRACC")) + if (strEQ(name, "WRACC")) #ifdef F_WRACC return F_WRACC; #else goto not_there; #endif - if (strEQ(name, "F_WRDNY")) + if (strEQ(name, "WRDNY")) #ifdef F_WRDNY return F_WRDNY; #else goto not_there; #endif - if (strEQ(name, "F_WRLCK")) + if (strEQ(name, "WRLCK")) #ifdef F_WRLCK return F_WRLCK; #else @@ -274,79 +275,79 @@ constant(char *name, int arg) errno = EINVAL; return 0; } - if (strEQ(name, "FAPPEND")) + if (strEQ(name, "APPEND")) #ifdef FAPPEND return FAPPEND; #else goto not_there; #endif - if (strEQ(name, "FASYNC")) + if (strEQ(name, "ASYNC")) #ifdef FASYNC return FASYNC; #else goto not_there; #endif - if (strEQ(name, "FCREAT")) + if (strEQ(name, "CREAT")) #ifdef FCREAT return FCREAT; #else goto not_there; #endif - if (strEQ(name, "FD_CLOEXEC")) + if (strEQ(name, "D_CLOEXEC")) #ifdef FD_CLOEXEC return FD_CLOEXEC; #else goto not_there; #endif - if (strEQ(name, "FDEFER")) + if (strEQ(name, "DEFER")) #ifdef FDEFER return FDEFER; #else goto not_there; #endif - if (strEQ(name, "FDSYNC")) + if (strEQ(name, "DSYNC")) #ifdef FDSYNC return FDSYNC; #else goto not_there; #endif - if (strEQ(name, "FEXCL")) + if (strEQ(name, "EXCL")) #ifdef FEXCL return FEXCL; #else goto not_there; #endif - if (strEQ(name, "FLARGEFILE")) + if (strEQ(name, "LARGEFILE")) #ifdef FLARGEFILE return FLARGEFILE; #else goto not_there; #endif - if (strEQ(name, "FNDELAY")) + if (strEQ(name, "NDELAY")) #ifdef FNDELAY return FNDELAY; #else goto not_there; #endif - if (strEQ(name, "FNONBLOCK")) + if (strEQ(name, "NONBLOCK")) #ifdef FNONBLOCK return FNONBLOCK; #else goto not_there; #endif - if (strEQ(name, "FRSYNC")) + if (strEQ(name, "RSYNC")) #ifdef FRSYNC return FRSYNC; #else goto not_there; #endif - if (strEQ(name, "FSYNC")) + if (strEQ(name, "SYNC")) #ifdef FSYNC return FSYNC; #else goto not_there; #endif - if (strEQ(name, "FTRUNC")) + if (strEQ(name, "TRUNC")) #ifdef FTRUNC return FTRUNC; #else @@ -354,28 +355,29 @@ constant(char *name, int arg) #endif break; case 'L': - if (strnEQ(name, "LOCK_", 5)) { + if (strnEQ(name, "OCK_", 4)) { /* We support flock() on systems which don't have it, so always supply the constants. */ - if (strEQ(name, "LOCK_SH")) + name += 4; + if (strEQ(name, "SH")) #ifdef LOCK_SH return LOCK_SH; #else return 1; #endif - if (strEQ(name, "LOCK_EX")) + if (strEQ(name, "EX")) #ifdef LOCK_EX return LOCK_EX; #else return 2; #endif - if (strEQ(name, "LOCK_NB")) + if (strEQ(name, "NB")) #ifdef LOCK_NB return LOCK_NB; #else return 4; #endif - if (strEQ(name, "LOCK_UN")) + if (strEQ(name, "UN")) #ifdef LOCK_UN return LOCK_UN; #else @@ -385,188 +387,189 @@ constant(char *name, int arg) goto not_there; break; case 'O': - if (strnEQ(name, "O_", 2)) { - if (strEQ(name, "O_ACCMODE")) + if (name[0] == '_') { + name++; + if (strEQ(name, "ACCMODE")) #ifdef O_ACCMODE return O_ACCMODE; #else goto not_there; #endif - if (strEQ(name, "O_APPEND")) + if (strEQ(name, "APPEND")) #ifdef O_APPEND return O_APPEND; #else goto not_there; #endif - if (strEQ(name, "O_ASYNC")) + if (strEQ(name, "ASYNC")) #ifdef O_ASYNC return O_ASYNC; #else goto not_there; #endif - if (strEQ(name, "O_BINARY")) + if (strEQ(name, "BINARY")) #ifdef O_BINARY return O_BINARY; #else goto not_there; #endif - if (strEQ(name, "O_CREAT")) + if (strEQ(name, "CREAT")) #ifdef O_CREAT return O_CREAT; #else goto not_there; #endif - if (strEQ(name, "O_DEFER")) + if (strEQ(name, "DEFER")) #ifdef O_DEFER return O_DEFER; #else goto not_there; #endif - if (strEQ(name, "O_DIRECT")) + if (strEQ(name, "DIRECT")) #ifdef O_DIRECT return O_DIRECT; #else goto not_there; #endif - if (strEQ(name, "O_DIRECTORY")) + if (strEQ(name, "DIRECTORY")) #ifdef O_DIRECTORY return O_DIRECTORY; #else goto not_there; #endif - if (strEQ(name, "O_DSYNC")) + if (strEQ(name, "DSYNC")) #ifdef O_DSYNC return O_DSYNC; #else goto not_there; #endif - if (strEQ(name, "O_EXCL")) + if (strEQ(name, "EXCL")) #ifdef O_EXCL return O_EXCL; #else goto not_there; #endif - if (strEQ(name, "O_EXLOCK")) + if (strEQ(name, "EXLOCK")) #ifdef O_EXLOCK return O_EXLOCK; #else goto not_there; #endif - if (strEQ(name, "O_LARGEFILE")) + if (strEQ(name, "LARGEFILE")) #ifdef O_LARGEFILE return O_LARGEFILE; #else goto not_there; #endif - if (strEQ(name, "O_NDELAY")) + if (strEQ(name, "NDELAY")) #ifdef O_NDELAY return O_NDELAY; #else goto not_there; #endif - if (strEQ(name, "O_NOCTTY")) + if (strEQ(name, "NOCTTY")) #ifdef O_NOCTTY return O_NOCTTY; #else goto not_there; #endif - if (strEQ(name, "O_NOFOLLOW")) + if (strEQ(name, "NOFOLLOW")) #ifdef O_NOFOLLOW return O_NOFOLLOW; #else goto not_there; #endif - if (strEQ(name, "O_NOINHERIT")) + if (strEQ(name, "NOINHERIT")) #ifdef O_NOINHERIT return O_NOINHERIT; #else goto not_there; #endif - if (strEQ(name, "O_NONBLOCK")) + if (strEQ(name, "NONBLOCK")) #ifdef O_NONBLOCK return O_NONBLOCK; #else goto not_there; #endif - if (strEQ(name, "O_RANDOM")) + if (strEQ(name, "RANDOM")) #ifdef O_RANDOM return O_RANDOM; #else goto not_there; #endif - if (strEQ(name, "O_RAW")) + if (strEQ(name, "RAW")) #ifdef O_RAW return O_RAW; #else goto not_there; #endif - if (strEQ(name, "O_RDONLY")) + if (strEQ(name, "RDONLY")) #ifdef O_RDONLY return O_RDONLY; #else goto not_there; #endif - if (strEQ(name, "O_RDWR")) + if (strEQ(name, "RDWR")) #ifdef O_RDWR return O_RDWR; #else goto not_there; #endif - if (strEQ(name, "O_RSYNC")) + if (strEQ(name, "RSYNC")) #ifdef O_RSYNC return O_RSYNC; #else goto not_there; #endif - if (strEQ(name, "O_SEQUENTIAL")) + if (strEQ(name, "SEQUENTIAL")) #ifdef O_SEQUENTIAL return O_SEQUENTIAL; #else goto not_there; #endif - if (strEQ(name, "O_SHLOCK")) + if (strEQ(name, "SHLOCK")) #ifdef O_SHLOCK return O_SHLOCK; #else goto not_there; #endif - if (strEQ(name, "O_SYNC")) + if (strEQ(name, "SYNC")) #ifdef O_SYNC return O_SYNC; #else goto not_there; #endif - if (strEQ(name, "O_TEMPORARY")) + if (strEQ(name, "TEMPORARY")) #ifdef O_TEMPORARY return O_TEMPORARY; #else goto not_there; #endif - if (strEQ(name, "O_TEXT")) + if (strEQ(name, "TEXT")) #ifdef O_TEXT return O_TEXT; #else goto not_there; #endif - if (strEQ(name, "O_TRUNC")) + if (strEQ(name, "TRUNC")) #ifdef O_TRUNC return O_TRUNC; #else goto not_there; #endif - if (strEQ(name, "O_WRONLY")) + if (strEQ(name, "WRONLY")) #ifdef O_WRONLY return O_WRONLY; #else goto not_there; #endif - if (strEQ(name, "O_ALIAS")) + if (strEQ(name, "ALIAS")) #ifdef O_ALIAS return O_ALIAS; #else goto not_there; #endif - if (strEQ(name, "O_RSRC")) + if (strEQ(name, "RSRC")) #ifdef O_RSRC return O_RSRC; #else @@ -576,171 +579,171 @@ constant(char *name, int arg) goto not_there; break; case 'S': - switch (name[1]) { + switch (*(name++)) { case '_': - if (strEQ(name, "S_ISUID")) + if (strEQ(name, "ISUID")) #ifdef S_ISUID return S_ISUID; #else goto not_there; #endif - if (strEQ(name, "S_ISGID")) + if (strEQ(name, "ISGID")) #ifdef S_ISGID return S_ISGID; #else goto not_there; #endif - if (strEQ(name, "S_ISVTX")) + if (strEQ(name, "ISVTX")) #ifdef S_ISVTX return S_ISVTX; #else goto not_there; #endif - if (strEQ(name, "S_ISTXT")) + if (strEQ(name, "ISTXT")) #ifdef S_ISTXT return S_ISTXT; #else goto not_there; #endif - if (strEQ(name, "S_IFREG")) + if (strEQ(name, "IFREG")) #ifdef S_IFREG return S_IFREG; #else goto not_there; #endif - if (strEQ(name, "S_IFDIR")) + if (strEQ(name, "IFDIR")) #ifdef S_IFDIR return S_IFDIR; #else goto not_there; #endif - if (strEQ(name, "S_IFLNK")) + if (strEQ(name, "IFLNK")) #ifdef S_IFLNK return S_IFLNK; #else goto not_there; #endif - if (strEQ(name, "S_IFSOCK")) + if (strEQ(name, "IFSOCK")) #ifdef S_IFSOCK return S_IFSOCK; #else goto not_there; #endif - if (strEQ(name, "S_IFBLK")) + if (strEQ(name, "IFBLK")) #ifdef S_IFBLK return S_IFBLK; #else goto not_there; #endif - if (strEQ(name, "S_IFCHR")) + if (strEQ(name, "IFCHR")) #ifdef S_IFCHR return S_IFCHR; #else goto not_there; #endif - if (strEQ(name, "S_IFIFO")) + if (strEQ(name, "IFIFO")) #ifdef S_IFIFO return S_IFIFO; #else goto not_there; #endif - if (strEQ(name, "S_IFWHT")) + if (strEQ(name, "IFWHT")) #ifdef S_IFWHT return S_IFWHT; #else goto not_there; #endif - if (strEQ(name, "S_ENFMT")) + if (strEQ(name, "ENFMT")) #ifdef S_ENFMT return S_ENFMT; #else goto not_there; #endif - if (strEQ(name, "S_IRUSR")) + if (strEQ(name, "IRUSR")) #ifdef S_IRUSR return S_IRUSR; #else goto not_there; #endif - if (strEQ(name, "S_IWUSR")) + if (strEQ(name, "IWUSR")) #ifdef S_IWUSR return S_IWUSR; #else goto not_there; #endif - if (strEQ(name, "S_IXUSR")) + if (strEQ(name, "IXUSR")) #ifdef S_IXUSR return S_IXUSR; #else goto not_there; #endif - if (strEQ(name, "S_IRWXU")) + if (strEQ(name, "IRWXU")) #ifdef S_IRWXU return S_IRWXU; #else goto not_there; #endif - if (strEQ(name, "S_IRGRP")) + if (strEQ(name, "IRGRP")) #ifdef S_IRGRP return S_IRGRP; #else goto not_there; #endif - if (strEQ(name, "S_IWGRP")) + if (strEQ(name, "IWGRP")) #ifdef S_IWGRP return S_IWGRP; #else goto not_there; #endif - if (strEQ(name, "S_IXGRP")) + if (strEQ(name, "IXGRP")) #ifdef S_IXGRP return S_IXGRP; #else goto not_there; #endif - if (strEQ(name, "S_IRWXG")) + if (strEQ(name, "IRWXG")) #ifdef S_IRWXG return S_IRWXG; #else goto not_there; #endif - if (strEQ(name, "S_IROTH")) + if (strEQ(name, "IROTH")) #ifdef S_IROTH return S_IROTH; #else goto not_there; #endif - if (strEQ(name, "S_IWOTH")) + if (strEQ(name, "IWOTH")) #ifdef S_IWOTH return S_IWOTH; #else goto not_there; #endif - if (strEQ(name, "S_IXOTH")) + if (strEQ(name, "IXOTH")) #ifdef S_IXOTH return S_IXOTH; #else goto not_there; #endif - if (strEQ(name, "S_IRWXO")) + if (strEQ(name, "IRWXO")) #ifdef S_IRWXO return S_IRWXO; #else goto not_there; #endif - if (strEQ(name, "S_IREAD")) + if (strEQ(name, "IREAD")) #ifdef S_IREAD return S_IREAD; #else goto not_there; #endif - if (strEQ(name, "S_IWRITE")) + if (strEQ(name, "IWRITE")) #ifdef S_IWRITE return S_IWRITE; #else goto not_there; #endif - if (strEQ(name, "S_IEXEC")) + if (strEQ(name, "IEXEC")) #ifdef S_IEXEC return S_IEXEC; #else @@ -748,19 +751,19 @@ constant(char *name, int arg) #endif break; case 'E': - if (strEQ(name, "SEEK_CUR")) + if (strEQ(name, "EK_CUR")) #ifdef SEEK_CUR return SEEK_CUR; #else return 1; #endif - if (strEQ(name, "SEEK_END")) + if (strEQ(name, "EK_END")) #ifdef SEEK_END return SEEK_END; #else return 2; #endif - if (strEQ(name, "SEEK_SET")) + if (strEQ(name, "EK_SET")) #ifdef SEEK_SET return SEEK_SET; #else @@ -780,8 +783,7 @@ not_there: MODULE = Fcntl PACKAGE = Fcntl -double -constant(name,arg) +IV +constant(name) char * name - int arg diff --git a/ext/Filter/Util/Call/Call.pm b/ext/Filter/Util/Call/Call.pm new file mode 100644 index 0000000000..694b1b3b20 --- /dev/null +++ b/ext/Filter/Util/Call/Call.pm @@ -0,0 +1,474 @@ +package Filter::Util::Call ; + +require 5.002 ; +require DynaLoader; +require Exporter; +use Carp ; +use strict; +use vars qw($VERSION @ISA @EXPORT) ; + +@ISA = qw(Exporter DynaLoader); +@EXPORT = qw( filter_add filter_del filter_read filter_read_exact) ; +$VERSION = "1.04" ; + +sub filter_read_exact($) +{ + my ($size) = @_ ; + my ($left) = $size ; + my ($status) ; + + croak ("filter_read_exact: size parameter must be > 0") + unless $size > 0 ; + + # try to read a block which is exactly $size bytes long + while ($left and ($status = filter_read($left)) > 0) { + $left = $size - length $_ ; + } + + # EOF with pending data is a special case + return 1 if $status == 0 and length $_ ; + + return $status ; +} + +sub filter_add($) +{ + my($obj) = @_ ; + + # Did we get a code reference? + my $coderef = (ref $obj eq 'CODE') ; + + # If the parameter isn't already a reference, make it one. + $obj = \$obj unless ref $obj ; + + $obj = bless ($obj, (caller)[0]) unless $coderef ; + + # finish off the installation of the filter in C. + Filter::Util::Call::real_import($obj, (caller)[0], $coderef) ; +} + +bootstrap Filter::Util::Call ; + +1; +__END__ + +=head1 NAME + +Filter::Util::Call - Perl Source Filter Utility Module + +=head1 SYNOPSIS + + use Filter::Util::Call ; + +=head1 DESCRIPTION + +This module provides you with the framework to write I<Source Filters> +in Perl. + +A I<Perl Source Filter> is implemented as a Perl module. The structure +of the module can take one of two broadly similar formats. To +distinguish between them, the first will be referred to as I<method +filter> and the second as I<closure filter>. + +Here is a skeleton for the I<method filter>: + + package MyFilter ; + + use Filter::Util::Call ; + + sub import + { + my($type, @arguments) = @_ ; + filter_add([]) ; + } + + sub filter + { + my($self) = @_ ; + my($status) ; + + $status = filter_read() ; + $status ; + } + + 1 ; + +and this is the equivalent skeleton for the I<closure filter>: + + package MyFilter ; + + use Filter::Util::Call ; + + sub import + { + my($type, @arguments) = @_ ; + + filter_add( + sub + { + my($status) ; + $status = filter_read() ; + $status ; + } ) + } + + 1 ; + +To make use of either of the two filter modules above, place the line +below in a Perl source file. + + use MyFilter; + +In fact, the skeleton modules shown above are fully functional I<Source +Filters>, albeit fairly useless ones. All they does is filter the +source stream without modifying it at all. + +As you can see both modules have a broadly similar structure. They both +make use of the C<Filter::Util::Call> module and both have an C<import> +method. The difference between them is that the I<method filter> +requires a I<filter> method, whereas the I<closure filter> gets the +equivalent of a I<filter> method with the anonymous sub passed to +I<filter_add>. + +To make proper use of the I<closure filter> shown above you need to +have a good understanding of the concept of a I<closure>. See +L<perlref> for more details on the mechanics of I<closures>. + +=head2 B<use Filter::Util::Call> + +The following functions are exported by C<Filter::Util::Call>: + + filter_add() + filter_read() + filter_read_exact() + filter_del() + +=head2 B<import()> + +The C<import> method is used to create an instance of the filter. It is +called indirectly by Perl when it encounters the C<use MyFilter> line +in a source file (See L<perlfunc/import> for more details on +C<import>). + +It will always have at least one parameter automatically passed by Perl +- this corresponds to the name of the package. In the example above it +will be C<"MyFilter">. + +Apart from the first parameter, import can accept an optional list of +parameters. These can be used to pass parameters to the filter. For +example: + + use MyFilter qw(a b c) ; + +will result in the C<@_> array having the following values: + + @_ [0] => "MyFilter" + @_ [1] => "a" + @_ [2] => "b" + @_ [3] => "c" + +Before terminating, the C<import> function must explicitly install the +filter by calling C<filter_add>. + +B<filter_add()> + +The function, C<filter_add>, actually installs the filter. It takes one +parameter which should be a reference. The kind of reference used will +dictate which of the two filter types will be used. + +If a CODE reference is used then a I<closure filter> will be assumed. + +If a CODE reference is not used, a I<method filter> will be assumed. +In a I<method filter>, the reference can be used to store context +information. The reference will be I<blessed> into the package by +C<filter_add>. + +See the filters at the end of this documents for examples of using +context information using both I<method filters> and I<closure +filters>. + +=head2 B<filter() and anonymous sub> + +Both the C<filter> method used with a I<method filter> and the +anonymous sub used with a I<closure filter> is where the main +processing for the filter is done. + +The big difference between the two types of filter is that the I<method +filter> uses the object passed to the method to store any context data, +whereas the I<closure filter> uses the lexical variables that are +maintained by the closure. + +Note that the single parameter passed to the I<method filter>, +C<$self>, is the same reference that was passed to C<filter_add> +blessed into the filter's package. See the example filters later on for +details of using C<$self>. + +Here is a list of the common features of the anonymous sub and the +C<filter()> method. + +=over 5 + +=item B<$_> + +Although C<$_> doesn't actually appear explicitly in the sample filters +above, it is implicitly used in a number of places. + +Firstly, when either C<filter> or the anonymous sub are called, a local +copy of C<$_> will automatically be created. It will always contain the +empty string at this point. + +Next, both C<filter_read> and C<filter_read_exact> will append any +source data that is read to the end of C<$_>. + +Finally, when C<filter> or the anonymous sub are finished processing, +they are expected to return the filtered source using C<$_>. + +This implicit use of C<$_> greatly simplifies the filter. + +=item B<$status> + +The status value that is returned by the user's C<filter> method or +anonymous sub and the C<filter_read> and C<read_exact> functions take +the same set of values, namely: + + < 0 Error + = 0 EOF + > 0 OK + +=item B<filter_read> and B<filter_read_exact> + +These functions are used by the filter to obtain either a line or block +from the next filter in the chain or the actual source file if there +aren't any other filters. + +The function C<filter_read> takes two forms: + + $status = filter_read() ; + $status = filter_read($size) ; + +The first form is used to request a I<line>, the second requests a +I<block>. + +In line mode, C<filter_read> will append the next source line to the +end of the C<$_> scalar. + +In block mode, C<filter_read> will append a block of data which is <= +C<$size> to the end of the C<$_> scalar. It is important to emphasise +the that C<filter_read> will not necessarily read a block which is +I<precisely> C<$size> bytes. + +If you need to be able to read a block which has an exact size, you can +use the function C<filter_read_exact>. It works identically to +C<filter_read> in block mode, except it will try to read a block which +is exactly C<$size> bytes in length. The only circumstances when it +will not return a block which is C<$size> bytes long is on EOF or +error. + +It is I<very> important to check the value of C<$status> after I<every> +call to C<filter_read> or C<filter_read_exact>. + +=item B<filter_del> + +The function, C<filter_del>, is used to disable the current filter. It +does not affect the running of the filter. All it does is tell Perl not +to call filter any more. + +See L<Example 4: Using filter_del> for details. + +=back + +=head1 EXAMPLES + +Here are a few examples which illustrate the key concepts - as such +most of them are of little practical use. + +The C<examples> sub-directory has copies of all these filters +implemented both as I<method filters> and as I<closure filters>. + +=head2 Example 1: A simple filter. + +Below is a I<method filter> which is hard-wired to replace all +occurrences of the string C<"Joe"> to C<"Jim">. Not particularly +Useful, but it is the first example and I wanted to keep it simple. + + package Joe2Jim ; + + use Filter::Util::Call ; + + sub import + { + my($type) = @_ ; + + filter_add(bless []) ; + } + + sub filter + { + my($self) = @_ ; + my($status) ; + + s/Joe/Jim/g + if ($status = filter_read()) > 0 ; + $status ; + } + + 1 ; + +Here is an example of using the filter: + + use Joe2Jim ; + print "Where is Joe?\n" ; + +And this is what the script above will print: + + Where is Jim? + +=head2 Example 2: Using the context + +The previous example was not particularly useful. To make it more +general purpose we will make use of the context data and allow any +arbitrary I<from> and I<to> strings to be used. This time we will use a +I<closure filter>. To reflect its enhanced role, the filter is called +C<Subst>. + + package Subst ; + + use Filter::Util::Call ; + use Carp ; + + sub import + { + croak("usage: use Subst qw(from to)") + unless @_ == 3 ; + my ($self, $from, $to) = @_ ; + filter_add( + sub + { + my ($status) ; + s/$from/$to/ + if ($status = filter_read()) > 0 ; + $status ; + }) + } + 1 ; + +and is used like this: + + use Subst qw(Joe Jim) ; + print "Where is Joe?\n" ; + + +=head2 Example 3: Using the context within the filter + +Here is a filter which a variation of the C<Joe2Jim> filter. As well as +substituting all occurrences of C<"Joe"> to C<"Jim"> it keeps a count +of the number of substitutions made in the context object. + +Once EOF is detected (C<$status> is zero) the filter will insert an +extra line into the source stream. When this extra line is executed it +will print a count of the number of substitutions actually made. +Note that C<$status> is set to C<1> in this case. + + package Count ; + + use Filter::Util::Call ; + + sub filter + { + my ($self) = @_ ; + my ($status) ; + + if (($status = filter_read()) > 0 ) { + s/Joe/Jim/g ; + ++ $$self ; + } + elsif ($$self >= 0) { # EOF + $_ = "print q[Made ${$self} substitutions\n]" ; + $status = 1 ; + $$self = -1 ; + } + + $status ; + } + + sub import + { + my ($self) = @_ ; + my ($count) = 0 ; + filter_add(\$count) ; + } + + 1 ; + +Here is a script which uses it: + + use Count ; + print "Hello Joe\n" ; + print "Where is Joe\n" ; + +Outputs: + + Hello Jim + Where is Jim + Made 2 substitutions + +=head2 Example 4: Using filter_del + +Another variation on a theme. This time we will modify the C<Subst> +filter to allow a starting and stopping pattern to be specified as well +as the I<from> and I<to> patterns. If you know the I<vi> editor, it is +the equivalent of this command: + + :/start/,/stop/s/from/to/ + +When used as a filter we want to invoke it like this: + + use NewSubst qw(start stop from to) ; + +Here is the module. + + package NewSubst ; + + use Filter::Util::Call ; + use Carp ; + + sub import + { + my ($self, $start, $stop, $from, $to) = @_ ; + my ($found) = 0 ; + croak("usage: use Subst qw(start stop from to)") + unless @_ == 5 ; + + filter_add( + sub + { + my ($status) ; + + if (($status = filter_read()) > 0) { + + $found = 1 + if $found == 0 and /$start/ ; + + if ($found) { + s/$from/$to/ ; + filter_del() if /$stop/ ; + } + + } + $status ; + } ) + + } + + 1 ; + +=head1 AUTHOR + +Paul Marquess + +=head1 DATE + +26th January 1996 + +=cut + diff --git a/ext/Filter/Util/Call/Call.xs b/ext/Filter/Util/Call/Call.xs new file mode 100644 index 0000000000..c8105d0d43 --- /dev/null +++ b/ext/Filter/Util/Call/Call.xs @@ -0,0 +1,252 @@ +/* + * Filename : Call.xs + * + * Author : Paul Marquess + * Date : 26th March 2000 + * Version : 1.05 + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifndef PERL_VERSION +# include "patchlevel.h" +# define PERL_REVISION 5 +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION +#endif + +/* defgv must be accessed differently under threaded perl */ +/* DEFSV et al are in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(defgv) +#endif + +#ifndef pTHX +# define pTHX +# define pTHX_ +# define aTHX +# define aTHX_ +#endif + + +/* Internal defines */ +#define PERL_MODULE(s) IoBOTTOM_NAME(s) +#define PERL_OBJECT(s) IoTOP_GV(s) +#define FILTER_ACTIVE(s) IoLINES(s) +#define BUF_OFFSET(sv) IoPAGE_LEN(sv) +#define CODE_REF(sv) IoPAGE(sv) + +#define SET_LEN(sv,len) \ + do { SvPVX(sv)[len] = '\0'; SvCUR_set(sv, len); } while (0) + + + +static int fdebug = 0; +static int current_idx ; + +static I32 +filter_call(pTHX_ int idx, SV *buf_sv, int maxlen) +{ + SV *my_sv = FILTER_DATA(idx); + char *nl = "\n"; + char *p; + char *out_ptr; + int n; + + if (fdebug) + warn("**** In filter_call - maxlen = %d, out len buf = %d idx = %d my_sv = %d [%s]\n", + maxlen, SvCUR(buf_sv), idx, SvCUR(my_sv), SvPVX(my_sv) ) ; + + while (1) { + + /* anything left from last time */ + if (n = SvCUR(my_sv)) { + + out_ptr = SvPVX(my_sv) + BUF_OFFSET(my_sv) ; + + if (maxlen) { + /* want a block */ + if (fdebug) + warn("BLOCK(%d): size = %d, maxlen = %d\n", + idx, n, maxlen) ; + + sv_catpvn(buf_sv, out_ptr, maxlen > n ? n : maxlen ); + if(n <= maxlen) { + BUF_OFFSET(my_sv) = 0 ; + SET_LEN(my_sv, 0) ; + } + else { + BUF_OFFSET(my_sv) += maxlen ; + SvCUR_set(my_sv, n - maxlen) ; + } + return SvCUR(buf_sv); + } + else { + /* want lines */ + if (p = ninstr(out_ptr, out_ptr + n - 1, nl, nl)) { + + sv_catpvn(buf_sv, out_ptr, p - out_ptr + 1); + + n = n - (p - out_ptr + 1); + BUF_OFFSET(my_sv) += (p - out_ptr + 1); + SvCUR_set(my_sv, n) ; + if (fdebug) + warn("recycle %d - leaving %d, returning %d [%s]", + idx, n, SvCUR(buf_sv), SvPVX(buf_sv)) ; + + return SvCUR(buf_sv); + } + else /* no EOL, so append the complete buffer */ + sv_catpvn(buf_sv, out_ptr, n) ; + } + + } + + + SET_LEN(my_sv, 0) ; + BUF_OFFSET(my_sv) = 0 ; + + if (FILTER_ACTIVE(my_sv)) + { + dSP ; + int count ; + + if (fdebug) + warn("gonna call %s::filter\n", PERL_MODULE(my_sv)) ; + + ENTER ; + SAVETMPS; + + SAVEINT(current_idx) ; /* save current idx */ + current_idx = idx ; + + SAVESPTR(DEFSV) ; /* save $_ */ + /* make $_ use our buffer */ + DEFSV = sv_2mortal(newSVpv("", 0)) ; + + PUSHMARK(sp) ; + + if (CODE_REF(my_sv)) { + /* if (SvROK(PERL_OBJECT(my_sv)) && SvTYPE(SvRV(PERL_OBJECT(my_sv))) == SVt_PVCV) { */ + count = perl_call_sv((SV*)PERL_OBJECT(my_sv), G_SCALAR); + } + else { + XPUSHs((SV*)PERL_OBJECT(my_sv)) ; + + PUTBACK ; + + count = perl_call_method("filter", G_SCALAR); + } + + SPAGAIN ; + + if (count != 1) + croak("Filter::Util::Call - %s::filter returned %d values, 1 was expected \n", + PERL_MODULE(my_sv), count ) ; + + n = POPi ; + + if (fdebug) + warn("status = %d, length op buf = %d [%s]\n", + n, SvCUR(DEFSV), SvPVX(DEFSV) ) ; + if (SvCUR(DEFSV)) + sv_setpvn(my_sv, SvPVX(DEFSV), SvCUR(DEFSV)) ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + } + else + n = FILTER_READ(idx + 1, my_sv, maxlen) ; + + if (n <= 0) + { + /* Either EOF or an error */ + + if (fdebug) + warn ("filter_read %d returned %d , returning %d\n", idx, n, + (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n); + + /* PERL_MODULE(my_sv) ; */ + /* PERL_OBJECT(my_sv) ; */ + filter_del(filter_call); + + /* If error, return the code */ + if (n < 0) + return n ; + + /* return what we have so far else signal eof */ + return (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n; + } + + } +} + + + +MODULE = Filter::Util::Call PACKAGE = Filter::Util::Call + +REQUIRE: 1.924 +PROTOTYPES: ENABLE + +#define IDX current_idx + +int +filter_read(size=0) + int size + CODE: + { + SV * buffer = DEFSV ; + + RETVAL = FILTER_READ(IDX + 1, buffer, size) ; + } + OUTPUT: + RETVAL + + + + +void +real_import(object, perlmodule, coderef) + SV * object + char * perlmodule + int coderef + PPCODE: + { + SV * sv = newSV(1) ; + + (void)SvPOK_only(sv) ; + filter_add(filter_call, sv) ; + + PERL_MODULE(sv) = savepv(perlmodule) ; + PERL_OBJECT(sv) = (GV*) newSVsv(object) ; + FILTER_ACTIVE(sv) = TRUE ; + BUF_OFFSET(sv) = 0 ; + CODE_REF(sv) = coderef ; + + SvCUR_set(sv, 0) ; + + } + +void +filter_del() + CODE: + FILTER_ACTIVE(FILTER_DATA(IDX)) = FALSE ; + + + +void +unimport(...) + PPCODE: + filter_del(filter_call); + + +BOOT: + /* temporary hack to control debugging in toke.c */ + if (fdebug) + filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0"); + + diff --git a/ext/Filter/Util/Call/Makefile.PL b/ext/Filter/Util/Call/Makefile.PL new file mode 100644 index 0000000000..030dbc2d31 --- /dev/null +++ b/ext/Filter/Util/Call/Makefile.PL @@ -0,0 +1,7 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Filter::Util::Call', + VERSION_FROM => 'Call.pm', + MAN3PODS => {}, # Pods will be built by installman. +); diff --git a/ext/GDBM_File/GDBM_File.pm b/ext/GDBM_File/GDBM_File.pm index ab866eecab..fe87dd0856 100644 --- a/ext/GDBM_File/GDBM_File.pm +++ b/ext/GDBM_File/GDBM_File.pm @@ -59,7 +59,7 @@ use XSLoader (); GDBM_WRITER ); -$VERSION = "1.03"; +$VERSION = "1.04"; sub AUTOLOAD { my($constname); diff --git a/ext/GDBM_File/GDBM_File.xs b/ext/GDBM_File/GDBM_File.xs index 13123ef540..b4d3b3d29c 100644 --- a/ext/GDBM_File/GDBM_File.xs +++ b/ext/GDBM_File/GDBM_File.xs @@ -56,7 +56,7 @@ not_here(char *s) static void output_datum(pTHX_ SV *arg, char *str, int size) { -#if !defined(MYMALLOC) || (defined(MYMALLOC) && defined(PERL_POLLUTE_MALLOC) && !defined(LEAKTEST)) +#if (!defined(MYMALLOC) || (defined(MYMALLOC) && defined(PERL_POLLUTE_MALLOC))) && !defined(LEAKTEST) sv_usepvn(arg, str, size); #else sv_setpvn(arg, str, size); diff --git a/ext/GDBM_File/typemap b/ext/GDBM_File/typemap index 4f79ae3e32..1dd063003a 100644 --- a/ext/GDBM_File/typemap +++ b/ext/GDBM_File/typemap @@ -19,8 +19,14 @@ T_DATUM_K $var.dsize = (int)PL_na; T_DATUM_V ckFilter($arg, filter_store_value, \"filter_store_value\"); - $var.dptr = SvPV($arg, PL_na); - $var.dsize = (int)PL_na; + if (SvOK($arg)) { + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; + } + else { + $var.dptr = \"\"; + $var.dsize = 0; + } OUTPUT T_DATUM_K output_datum(aTHX_ $arg, $var.dptr, $var.dsize); diff --git a/ext/IO/IO.xs b/ext/IO/IO.xs index 1b79cfd4c0..13b198cc71 100644 --- a/ext/IO/IO.xs +++ b/ext/IO/IO.xs @@ -59,9 +59,9 @@ io_blocking(InputStream f, int block) if (RETVAL >= 0) { int mode = RETVAL; #ifdef O_NONBLOCK - /* POSIX style */ + /* POSIX style */ #if defined(O_NDELAY) && O_NDELAY != O_NONBLOCK - /* Ooops has O_NDELAY too - make sure we don't + /* Ooops has O_NDELAY too - make sure we don't * get SysV behaviour by mistake. */ /* E.g. In UNICOS and UNICOS/mk a F_GETFL returns an O_NDELAY @@ -86,7 +86,7 @@ io_blocking(InputStream f, int block) } } #else - /* Standard POSIX */ + /* Standard POSIX */ RETVAL = RETVAL & O_NONBLOCK ? 0 : 1; if ((block == 0) && !(mode & O_NONBLOCK)) { @@ -103,11 +103,11 @@ io_blocking(InputStream f, int block) if(ret < 0) RETVAL = ret; } -#endif +#endif #else /* Not POSIX - better have O_NDELAY or we can't cope. * for BSD-ish machines this is an acceptable alternative - * for SysV we can't tell "would block" from EOF but that is + * for SysV we can't tell "would block" from EOF but that is * the way SysV is... */ RETVAL = RETVAL & O_NDELAY ? 0 : 1; @@ -141,13 +141,18 @@ fgetpos(handle) InputStream handle CODE: if (handle) { - Fpos_t pos; #ifdef PerlIO - PerlIO_getpos(handle, &pos); + ST(0) = sv_2mortal(newSV(0)); + if (PerlIO_getpos(handle, ST(0)) != 0) { + ST(0) = &PL_sv_undef; + } #else - fgetpos(handle, &pos); + if (fgetpos(handle, &pos)) { + ST(0) = &PL_sv_undef; + } else { + ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); + } #endif - ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); } else { ST(0) = &PL_sv_undef; @@ -159,14 +164,21 @@ fsetpos(handle, pos) InputStream handle SV * pos CODE: - char *p; - STRLEN len; - if (handle && (p = SvPV(pos,len)) && len == sizeof(Fpos_t)) + if (handle) { #ifdef PerlIO - RETVAL = PerlIO_setpos(handle, (Fpos_t*)p); + RETVAL = PerlIO_setpos(handle, pos); #else - RETVAL = fsetpos(handle, (Fpos_t*)p); + char *p; + STRLEN len; + if ((p = SvPV(pos,len)) && len == sizeof(Fpos_t)) { + RETVAL = fsetpos(handle, (Fpos_t*)p); + } + else { + RETVAL = -1; + errno = EINVAL; + } #endif + } else { RETVAL = -1; errno = EINVAL; @@ -202,7 +214,7 @@ new_tmpfile(packname = "IO::File") MODULE = IO PACKAGE = IO::Poll -void +void _poll(timeout,...) int timeout; PPCODE: diff --git a/ext/IO/lib/IO/Handle.pm b/ext/IO/lib/IO/Handle.pm index b6cb410b57..fb754a60bf 100644 --- a/ext/IO/lib/IO/Handle.pm +++ b/ext/IO/lib/IO/Handle.pm @@ -110,7 +110,8 @@ or a file descriptor number. =item $io->opened -Returns true if the object is currently a valid file descriptor. +Returns true if the object is currently a valid file descriptor, false +otherwise. =item $io->getline @@ -139,31 +140,37 @@ called C<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 diff --git a/ext/IO/lib/IO/Seekable.pm b/ext/IO/lib/IO/Seekable.pm index e09d48b9bf..243a971acc 100644 --- a/ext/IO/lib/IO/Seekable.pm +++ b/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/ext/IO/lib/IO/Select.pm b/ext/IO/lib/IO/Select.pm index e84b54f015..1a3a26fe6a 100644 --- a/ext/IO/lib/IO/Select.pm +++ b/ext/IO/lib/IO/Select.pm @@ -56,6 +56,7 @@ sub exists sub _fileno { my($self, $f) = @_; + return unless defined $f; $f = $f->[0] if ref($f) eq 'ARRAY'; ($f =~ /^\d+$/) ? $f : fileno($f); } diff --git a/ext/IPC/SysV/SysV.xs b/ext/IPC/SysV/SysV.xs index 38062e028b..4a10eb90e3 100644 --- a/ext/IPC/SysV/SysV.xs +++ b/ext/IPC/SysV/SysV.xs @@ -203,7 +203,7 @@ ftok(path, id) key_t k = ftok(path, id); ST(0) = k == (key_t) -1 ? &PL_sv_undef : sv_2mortal(newSViv(k)); #else - DIE(PL_no_func, "ftok"); + DIE(aTHX_ PL_no_func, "ftok"); #endif int diff --git a/ext/NDBM_File/NDBM_File.pm b/ext/NDBM_File/NDBM_File.pm index c9ef6993a8..99aae17d5c 100644 --- a/ext/NDBM_File/NDBM_File.pm +++ b/ext/NDBM_File/NDBM_File.pm @@ -10,7 +10,7 @@ require Tie::Hash; use XSLoader (); our @ISA = qw(Tie::Hash); -our $VERSION = "1.03"; +our $VERSION = "1.04"; XSLoader::load 'NDBM_File', $VERSION; diff --git a/ext/NDBM_File/NDBM_File.xs b/ext/NDBM_File/NDBM_File.xs index 49a1db5e56..c417eb693e 100644 --- a/ext/NDBM_File/NDBM_File.xs +++ b/ext/NDBM_File/NDBM_File.xs @@ -1,6 +1,11 @@ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +/* If using the DB3 emulation, ENTER is defined both + * by DB3 and Perl. We drop the Perl definition now. + * See also INSTALL section on DB3. + * -- Stanislav Brabec <utx@penguin.cz> */ +#undef ENTER #include <ndbm.h> typedef struct { diff --git a/ext/NDBM_File/typemap b/ext/NDBM_File/typemap index eeb5d59027..40b95f22c0 100644 --- a/ext/NDBM_File/typemap +++ b/ext/NDBM_File/typemap @@ -20,8 +20,14 @@ T_DATUM_K $var.dsize = (int)PL_na; T_DATUM_V ckFilter($arg, filter_store_value, \"filter_store_value\"); - $var.dptr = SvPV($arg, PL_na); - $var.dsize = (int)PL_na; + if (SvOK($arg)) { + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; + } + else { + $var.dptr = \"\"; + $var.dsize = 0; + } T_GDATUM UNIMPLEMENTED OUTPUT diff --git a/ext/ODBM_File/ODBM_File.pm b/ext/ODBM_File/ODBM_File.pm index 732ed60930..4244eb966f 100644 --- a/ext/ODBM_File/ODBM_File.pm +++ b/ext/ODBM_File/ODBM_File.pm @@ -6,7 +6,7 @@ require Tie::Hash; use XSLoader (); our @ISA = qw(Tie::Hash); -our $VERSION = "1.02"; +our $VERSION = "1.03"; XSLoader::load 'ODBM_File', $VERSION; diff --git a/ext/ODBM_File/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs index 150f2ef894..27174ef062 100644 --- a/ext/ODBM_File/ODBM_File.xs +++ b/ext/ODBM_File/ODBM_File.xs @@ -3,6 +3,11 @@ #include "XSUB.h" #ifdef I_DBM +/* If using the DB3 emulation, ENTER is defined both + * by DB3 and Perl. We drop the Perl definition now. + * See also INSTALL section on DB3. + * -- Stanislav Brabec <utx@penguin.cz> */ +# undef ENTER # include <dbm.h> #else # ifdef I_RPCSVC_DBM diff --git a/ext/ODBM_File/typemap b/ext/ODBM_File/typemap index 7c23815ec7..096427ea7f 100644 --- a/ext/ODBM_File/typemap +++ b/ext/ODBM_File/typemap @@ -20,8 +20,14 @@ T_DATUM_K $var.dsize = (int)PL_na; T_DATUM_V ckFilter($arg, filter_store_value, \"filter_store_value\"); - $var.dptr = SvPV($arg, PL_na); - $var.dsize = (int)PL_na; + if (SvOK($arg)) { + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; + } + else { + $var.dptr = \"\"; + $var.dsize = 0; + } T_GDATUM UNIMPLEMENTED OUTPUT diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index 841120c4c6..6a5e30dd17 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -2,18 +2,19 @@ package Opcode; require 5.005_64; +use strict; + our($VERSION, $XS_VERSION, @ISA, @EXPORT_OK); $VERSION = "1.04"; $XS_VERSION = "1.03"; -use strict; use Carp; use Exporter (); use XSLoader (); -@ISA = qw(Exporter); BEGIN { + @ISA = qw(Exporter); @EXPORT_OK = qw( opset ops_to_opset opset_to_ops opset_to_hex invert_opset diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs index e191ec7c9c..04f7c3fa33 100644 --- a/ext/Opcode/Opcode.xs +++ b/ext/Opcode/Opcode.xs @@ -253,6 +253,12 @@ PPCODE: save_hptr(&PL_defstash); /* save current default stash */ /* the assignment to global defstash changes our sense of 'main' */ PL_defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already */ + if (strNE(HvNAME(PL_defstash),"main")) { + Safefree(HvNAME(PL_defstash)); + HvNAME(PL_defstash) = savepv("main"); /* make it think it's in main:: */ + hv_store(PL_defstash,"_",1,(SV *)PL_defgv,0); /* connect _ to global */ + SvREFCNT_inc((SV *)PL_defgv); /* want to keep _ around! */ + } save_hptr(&PL_curstash); PL_curstash = PL_defstash; diff --git a/ext/POSIX/Makefile.PL b/ext/POSIX/Makefile.PL index 55c5c1fbf3..73bb02dddb 100644 --- a/ext/POSIX/Makefile.PL +++ b/ext/POSIX/Makefile.PL @@ -2,12 +2,7 @@ use ExtUtils::MakeMaker; use Config; my @libs; if ($^O ne 'MSWin32') { - if ($Config{archname} =~ /RM\d\d\d-svr4/) { - @libs = ('LIBS' => ["-lm -lc -lposix -lcposix"]); - } - else { - @libs = ('LIBS' => ["-lm -lposix -lcposix"]); - } + @libs = ('LIBS' => ["-lm -lposix -lcposix"]); } WriteMakefile( NAME => 'POSIX', diff --git a/ext/POSIX/POSIX.pm b/ext/POSIX/POSIX.pm index 252e5bbad1..e1e6b28e40 100644 --- a/ext/POSIX/POSIX.pm +++ b/ext/POSIX/POSIX.pm @@ -734,16 +734,6 @@ sub setbuf { redef "IO::Handle::setbuf()"; } -sub setgid { - usage "setgid(gid)" if @_ != 1; - $( = $_[0]; -} - -sub setuid { - usage "setuid(uid)" if @_ != 1; - $< = $_[0]; -} - sub setvbuf { redef "IO::Handle::setvbuf()"; } diff --git a/ext/POSIX/POSIX.pod b/ext/POSIX/POSIX.pod index 314147cb2b..10199e9a2b 100644 --- a/ext/POSIX/POSIX.pod +++ b/ext/POSIX/POSIX.pod @@ -1008,9 +1008,12 @@ see L<perlre>. =item setgid -Sets the real group identifier for this process. -Identical to assigning a value to the Perl's builtin C<$)> variable, -see L<perlvar/$UID>. +Sets the real group identifier and the effective group identifier for +this process. Similar to assigning a value to the Perl's builtin +C<$)> variable, see L<perlvar/$GID>, except that the latter +will change only the real user identifier, and that the setgid() +uses only a single numeric argument, as opposed to a space-separated +list of numbers. =item setjmp @@ -1063,9 +1066,10 @@ setting the session identifier of the current process. =item setuid -Sets the real user identifier for this process. -Identical to assigning a value to the Perl's builtin C<$E<lt>> variable, -see L<perlvar/$UID>. +Sets the real user identifier and the effective user identifier for +this process. Similar to assigning a value to the Perl's builtin +C<$E<lt>> variable, see L<perlvar/$UID>, except that the latter +will change only the real user identifier. =item sigaction @@ -1434,7 +1438,9 @@ Returns a name for a temporary file. $tmpfile = POSIX::tmpnam(); -See also L<File::Temp>. +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 diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index a536671afc..887fcbcbea 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -3940,6 +3940,14 @@ pathconf(filename, name) SysRet pause() +SysRet +setgid(gid) + Gid_t gid + +SysRet +setuid(uid) + Uid_t uid + SysRetLong sysconf(name) int name @@ -3947,3 +3955,4 @@ sysconf(name) char * ttyname(fd) int fd + diff --git a/ext/POSIX/hints/svr4.pl b/ext/POSIX/hints/svr4.pl new file mode 100644 index 0000000000..07f2cb0412 --- /dev/null +++ b/ext/POSIX/hints/svr4.pl @@ -0,0 +1,12 @@ +# NCR MP-RAS. Thanks to Doug Hendricks for this info. +# Configure sets osname=svr4.0, osvers=3.0, archname='3441-svr4.0' +# This system needs to explicitly link against -lmw to pull in some +# symbols such as _mwoflocheckl and possibly others. +# A. Dougherty Thu Dec 7 11:55:28 EST 2000 +if ($Config{'archname'} =~ /3441-svr4/) { + $self->{LIBS} = ['-lm -posix -lcposix -lmw']; +} +# Not sure what OS this one is. +elsif ($Config{archname} =~ /RM\d\d\d-svr4/) { + $self->{LIBS} = ['-lm -lc -lposix -lcposix']; +} diff --git a/ext/POSIX/typemap b/ext/POSIX/typemap index baf9bfc051..d54d5d11a0 100644 --- a/ext/POSIX/typemap +++ b/ext/POSIX/typemap @@ -3,6 +3,7 @@ pid_t T_NV Uid_t T_NV Time_t T_NV Gid_t T_NV +Uid_t T_NV Off_t T_NV Dev_t T_NV NV T_NV diff --git a/ext/SDBM_File/Makefile.PL b/ext/SDBM_File/Makefile.PL index a1debb92a3..132bdadf26 100644 --- a/ext/SDBM_File/Makefile.PL +++ b/ext/SDBM_File/Makefile.PL @@ -1,4 +1,5 @@ use ExtUtils::MakeMaker; +use Config; # The existence of the ./sdbm/Makefile.PL file causes MakeMaker # to automatically include Makefile code for the targets @@ -21,18 +22,26 @@ WriteMakefile( sub MY::postamble { if ($^O =~ /MSWin32/ && Win32::IsWin95()) { - # XXX: dmake-specific, like rest of Win95 port - return - ' + if ($Config{'make'} =~ /dmake/i) { + # dmake-specific + return <<EOT; $(MYEXTLIB): sdbm/Makefile @[ cd sdbm $(MAKE) all cd .. ] -'; - } - elsif ($^O ne 'VMS') { +EOT + } elsif ($Config{'make'} =~ /nmake/i) { + # + return <<EOT; +$(MYEXTLIB): sdbm/Makefile + cd sdbm + $(MAKE) all + cd .. +EOT + } +} elsif ($^O ne 'VMS') { ' $(MYEXTLIB): sdbm/Makefile cd sdbm && $(MAKE) all diff --git a/ext/SDBM_File/SDBM_File.pm b/ext/SDBM_File/SDBM_File.pm index b3502b9837..4d1411bf34 100644 --- a/ext/SDBM_File/SDBM_File.pm +++ b/ext/SDBM_File/SDBM_File.pm @@ -6,7 +6,7 @@ require Tie::Hash; use XSLoader (); our @ISA = qw(Tie::Hash); -our $VERSION = "1.02" ; +our $VERSION = "1.03" ; XSLoader::load 'SDBM_File', $VERSION; diff --git a/ext/SDBM_File/sdbm/sdbm.c b/ext/SDBM_File/sdbm/sdbm.c index 64c75cbb20..d41c770dfb 100644 --- a/ext/SDBM_File/sdbm/sdbm.c +++ b/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/ext/SDBM_File/typemap b/ext/SDBM_File/typemap index eeb5d59027..40b95f22c0 100644 --- a/ext/SDBM_File/typemap +++ b/ext/SDBM_File/typemap @@ -20,8 +20,14 @@ T_DATUM_K $var.dsize = (int)PL_na; T_DATUM_V ckFilter($arg, filter_store_value, \"filter_store_value\"); - $var.dptr = SvPV($arg, PL_na); - $var.dsize = (int)PL_na; + if (SvOK($arg)) { + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; + } + else { + $var.dptr = \"\"; + $var.dsize = 0; + } T_GDATUM UNIMPLEMENTED OUTPUT diff --git a/ext/Storable/ChangeLog b/ext/Storable/ChangeLog index 049ce29583..92789b59a4 100644 --- a/ext/Storable/ChangeLog +++ b/ext/Storable/ChangeLog @@ -1,3 +1,50 @@ +Wed Jan 3 10:43:18 MET 2001 Raphael Manfredi <Raphael_Manfredi@pobox.com> + +. Description: + + Removed spurious 'clean' entry in Makefile.PL. + + Added CAN_FLOCK to determine whether we can flock() or not, + by inspecting Perl's configuration parameters, as determined + by Configure. + + Trace offending package when overloading cannot be restored + on a scalar. + + Made context cleanup safer to avoid dup freeing, mostly in the + presence of repeated exceptions during store/retrieve (which can + cause memory leaks anyway, so it's just additional safety, not a + definite fix). + +Sun Nov 5 18:23:48 MET 2000 Raphael Manfredi <Raphael_Manfredi@pobox.com> + +. Description: + + Version 1.0.6. + + Fixed severe "object lost" bug for STORABLE_freeze returns, + when refs to lexicals, taken within the hook, were to be + serialized by Storable. Enhanced the t/recurse.t test to + stress hook a little more with refs to lexicals. + +Thu Oct 26 19:14:38 MEST 2000 Raphael Manfredi <Raphael_Manfredi@pobox.com> + +. Description: + + Version 1.0.5. + + Documented that store() and retrieve() can return undef. + That is, the error reporting is not always made via exceptions, + as the paragraph on error reporting was implying. + + Auto requires module of blessed ref when STORABLE_thaw misses. + When the Storable engine looks for the STORABLE_thaw hook and + does not find it, it now tries to require the package into which + the blessed reference is. + + Just check $^O, in t/lock.t: there's no need to pull the whole + Config module for that. + Fri Sep 29 21:52:29 MEST 2000 Raphael Manfredi <Raphael_Manfredi@pobox.com> . Description: diff --git a/ext/Storable/Makefile.PL b/ext/Storable/Makefile.PL index 7ed71e69a3..c8151f3083 100644 --- a/ext/Storable/Makefile.PL +++ b/ext/Storable/Makefile.PL @@ -1,4 +1,4 @@ -# $Id: Makefile.PL,v 1.0 2000/09/01 19:40:41 ram Exp $ +# $Id: Makefile.PL,v 1.0.1.1 2001/01/03 09:38:39 ram Exp $ # # Copyright (c) 1995-2000, Raphael Manfredi # @@ -6,6 +6,9 @@ # in the README file that comes with the distribution. # # $Log: Makefile.PL,v $ +# Revision 1.0.1.1 2001/01/03 09:38:39 ram +# patch7: removed spurious 'clean' entry +# # Revision 1.0 2000/09/01 19:40:41 ram # Baseline for first official release. # @@ -19,6 +22,5 @@ WriteMakefile( 'MAN3PODS' => {}, 'VERSION_FROM' => 'Storable.pm', 'dist' => { SUFFIX => 'gz', COMPRESS => 'gzip -f' }, - 'clean' => {'FILES' => '*%'}, ); diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm index 76c320923b..06c05d4fe9 100644 --- a/ext/Storable/Storable.pm +++ b/ext/Storable/Storable.pm @@ -1,4 +1,4 @@ -;# $Id: Storable.pm,v 1.0 2000/09/01 19:40:41 ram Exp $ +;# $Id: Storable.pm,v 1.0.1.7 2001/01/03 09:39:02 ram Exp $ ;# ;# Copyright (c) 1995-2000, Raphael Manfredi ;# @@ -6,6 +6,21 @@ ;# in the README file that comes with the distribution. ;# ;# $Log: Storable.pm,v $ +;# Revision 1.0.1.7 2001/01/03 09:39:02 ram +;# patch7: added CAN_FLOCK to determine whether we can flock() or not +;# +;# Revision 1.0.1.6 2000/11/05 17:20:25 ram +;# patch6: increased version number +;# +;# Revision 1.0.1.5 2000/10/26 17:10:18 ram +;# patch5: documented that store() and retrieve() can return undef +;# patch5: added paragraph explaining the auto require for thaw hooks +;# +;# Revision 1.0.1.4 2000/10/23 18:02:57 ram +;# patch4: protected calls to flock() for dos platform +;# patch4: added logcarp emulation if they don't have Log::Agent +;# +;# $Log: Storable.pm,v $ ;# Revision 1.0 2000/09/01 19:40:41 ram ;# Baseline for first official release. ;# @@ -26,7 +41,7 @@ package Storable; @ISA = qw(Exporter DynaLoader); use AutoLoader; use vars qw($forgive_me $VERSION); -$VERSION = '1.003'; +$VERSION = '1.007'; *AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr... # @@ -41,6 +56,10 @@ unless (defined @Log::Agent::EXPORT) { require Carp; Carp::croak(@_); } + sub logcarp { + require Carp; + Carp::carp(@_); + } }; } @@ -61,9 +80,25 @@ BEGIN { } sub logcroak; +sub logcarp; sub retrieve_fd { &fd_retrieve } # Backward compatibility +# +# Determine whether locking is possible, but only when needed. +# + +my $CAN_FLOCK; + +sub CAN_FLOCK { + return $CAN_FLOCK if defined $CAN_FLOCK; + require Config; import Config; + return $CAN_FLOCK = + $Config{'d_flock'} || + $Config{'d_fcntl_can_lock'} || + $Config{'d_lockf'}; +} + bootstrap Storable; 1; __END__ @@ -118,6 +153,10 @@ sub _store { open(FILE, ">$file") || logcroak "can't create $file: $!"; binmode FILE; # Archaic systems... if ($use_locking) { + unless (&CAN_FLOCK) { + logcarp "Storable::lock_store: fcntl/flock emulation broken on $^O"; + return undef; + } flock(FILE, LOCK_EX) || logcroak "can't get exclusive lock on $file: $!"; truncate FILE, 0; @@ -234,7 +273,12 @@ sub _retrieve { my $self; my $da = $@; # Could be from exception handler if ($use_locking) { - flock(FILE, LOCK_SH) || logcroak "can't get shared lock on $file: $!"; + unless (&CAN_FLOCK) { + logcarp "Storable::lock_retrieve: fcntl/flock emulation broken on $^O"; + return undef; + } + flock(FILE, LOCK_SH) || + logcroak "can't get shared lock on $file: $!"; # Unlocking will happen when FILE is closed } eval { $self = pretrieve(*FILE) }; # Call C routine @@ -435,6 +479,9 @@ those exceptions. When Storable croaks, it tries to report the error via the C<logcroak()> routine from the C<Log::Agent> package, if it is available. +Normal errors are reported by having store() or retrieve() return C<undef>. +Such errors are usually I/O errors (or truncated stream errors at retrieval). + =head1 WIZARDS ONLY =head2 Hooks @@ -514,6 +561,13 @@ and there may be an optional list of references, in the same order you gave them at serialization time, pointing to the deserialized objects (which have been processed courtesy of the Storable engine). +When the Storable engine does not find any C<STORABLE_thaw> hook routine, +it tries to load the class by requiring the package dynamically (using +the blessed package name), and then re-attempts the lookup. If at that +time the hook cannot be located, the engine croaks. Note that this mechanism +will fail if you define several classes in the same file, but perlmod(1) +warned you. + It is up to you to use these information to populate I<obj> the way you want. Returned value: none. diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index 1c412b5d20..9378001cc4 100644 --- a/ext/Storable/Storable.xs +++ b/ext/Storable/Storable.xs @@ -3,7 +3,7 @@ */ /* - * $Id: Storable.xs,v 1.0 2000/09/01 19:40:41 ram Exp $ + * $Id: Storable.xs,v 1.0.1.6 2001/01/03 09:40:40 ram Exp $ * * Copyright (c) 1995-2000, Raphael Manfredi * @@ -11,6 +11,21 @@ * in the README file that comes with the distribution. * * $Log: Storable.xs,v $ + * Revision 1.0.1.6 2001/01/03 09:40:40 ram + * patch7: prototype and casting cleanup + * patch7: trace offending package when overloading cannot be restored + * patch7: made context cleanup safer to avoid dup freeing + * + * Revision 1.0.1.5 2000/11/05 17:21:24 ram + * patch6: fixed severe "object lost" bug for STORABLE_freeze returns + * + * Revision 1.0.1.4 2000/10/26 17:11:04 ram + * patch5: auto requires module of blessed ref when STORABLE_thaw misses + * + * Revision 1.0.1.3 2000/09/29 19:49:57 ram + * patch3: avoid using "tainted" and "dirty" since Perl remaps them via cpp + * + * $Log: Storable.xs,v $ * Revision 1.0 2000/09/01 19:40:41 ram * Baseline for first official release. * @@ -87,14 +102,21 @@ typedef double NV; /* Older perls lack the NV type */ #endif #ifdef DEBUGME -#ifndef DASSERT -#define DASSERT -#endif -#define TRACEME(x) do { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } while (0) +/* + * TRACEME() will only output things when the $Storable::DEBUGME is true. + */ + +#define TRACEME(x) do { \ + if (SvTRUE(perl_get_sv("Storable::DEBUGME", TRUE))) \ + { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \ +} while (0) #else #define TRACEME(x) #endif +#ifndef DASSERT +#define DASSERT +#endif #ifdef DASSERT #define ASSERT(x,y) do { \ if (!(x)) { \ @@ -235,6 +257,7 @@ typedef struct stcxt { int entry; /* flags recursion */ int optype; /* type of traversal operation */ HV *hseen; /* which objects have been seen, store time */ + AV *hook_seen; /* which SVs were returned by STORABLE_freeze() */ AV *aseen; /* which objects have been seen, retrieve time */ HV *hclass; /* which classnames have been seen, store time */ AV *aclass; /* which classnames have been seen, retrieve time */ @@ -652,7 +675,7 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ #define GETMARK(x) do { \ if (!cxt->fio) \ MBUF_GETC(x); \ - else if ((x = PerlIO_getc(cxt->fio)) == EOF) \ + else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF) \ return (SV *) 0; \ } while (0) @@ -740,14 +763,14 @@ static int store_tied_item(stcxt_t *cxt, SV *sv); static int store_other(stcxt_t *cxt, SV *sv); static int store_blessed(stcxt_t *cxt, SV *sv, int type, HV *pkg); -static int (*sv_store[])() = { - store_ref, /* svis_REF */ - store_scalar, /* svis_SCALAR */ - store_array, /* svis_ARRAY */ - store_hash, /* svis_HASH */ - store_tied, /* svis_TIED */ - store_tied_item, /* svis_TIED_ITEM */ - store_other, /* svis_OTHER */ +static int (*sv_store[])(stcxt_t *cxt, SV *sv) = { + store_ref, /* svis_REF */ + store_scalar, /* svis_SCALAR */ + (int (*)(stcxt_t *cxt, SV *sv)) store_array, /* svis_ARRAY */ + (int (*)(stcxt_t *cxt, SV *sv)) store_hash, /* svis_HASH */ + store_tied, /* svis_TIED */ + store_tied_item, /* svis_TIED_ITEM */ + store_other, /* svis_OTHER */ }; #define SV_STORE(x) (*sv_store[x]) @@ -773,7 +796,7 @@ static SV *retrieve_tied_hash(stcxt_t *cxt); static SV *retrieve_tied_scalar(stcxt_t *cxt); static SV *retrieve_other(stcxt_t *cxt); -static SV *(*sv_old_retrieve[])() = { +static SV *(*sv_old_retrieve[])(stcxt_t *cxt) = { 0, /* SX_OBJECT -- entry unused dynamically */ retrieve_lscalar, /* SX_LSCALAR */ old_retrieve_array, /* SX_ARRAY -- for pre-0.6 binaries */ @@ -814,7 +837,7 @@ static SV *retrieve_overloaded(stcxt_t *cxt); static SV *retrieve_tied_key(stcxt_t *cxt); static SV *retrieve_tied_idx(stcxt_t *cxt); -static SV *(*sv_retrieve[])() = { +static SV *(*sv_retrieve[])(stcxt_t *cxt) = { 0, /* SX_OBJECT -- entry unused dynamically */ retrieve_lscalar, /* SX_LSCALAR */ retrieve_array, /* SX_ARRAY */ @@ -946,6 +969,15 @@ static void init_store_context( */ cxt->hook = newHV(); /* Table where hooks are cached */ + + /* + * The `hook_seen' array keeps track of all the SVs returned by + * STORABLE_freeze hooks for us to serialize, so that they are not + * reclaimed until the end of the serialization process. Each SV is + * only stored once, the first time it is seen. + */ + + cxt->hook_seen = newAV(); /* Lists SVs returned by STORABLE_freeze */ } /* @@ -975,16 +1007,41 @@ static void clean_store_context(stcxt_t *cxt) /* * And now dispose of them... + * + * The surrounding if() protection has been added because there might be + * some cases where this routine is called more than once, during + * exceptionnal events. This was reported by Marc Lehmann when Storable + * is executed from mod_perl, and the fix was suggested by him. + * -- RAM, 20/12/2000 */ - hv_undef(cxt->hseen); - sv_free((SV *) cxt->hseen); + if (cxt->hseen) { + HV *hseen = cxt->hseen; + cxt->hseen = 0; + hv_undef(hseen); + sv_free((SV *) hseen); + } + + if (cxt->hclass) { + HV *hclass = cxt->hclass; + cxt->hclass = 0; + hv_undef(hclass); + sv_free((SV *) hclass); + } - hv_undef(cxt->hclass); - sv_free((SV *) cxt->hclass); + if (cxt->hook) { + HV *hook = cxt->hook; + cxt->hook = 0; + hv_undef(hook); + sv_free((SV *) hook); + } - hv_undef(cxt->hook); - sv_free((SV *) cxt->hook); + if (cxt->hook_seen) { + AV *hook_seen = cxt->hook_seen; + cxt->hook_seen = 0; + av_undef(hook_seen); + sv_free((SV *) hook_seen); + } cxt->entry = 0; cxt->s_dirty = 0; @@ -1039,17 +1096,33 @@ static void clean_retrieve_context(stcxt_t *cxt) ASSERT(cxt->optype & ST_RETRIEVE, ("was performing a retrieve()")); - av_undef(cxt->aseen); - sv_free((SV *) cxt->aseen); + if (cxt->aseen) { + AV *aseen = cxt->aseen; + cxt->aseen = 0; + av_undef(aseen); + sv_free((SV *) aseen); + } - av_undef(cxt->aclass); - sv_free((SV *) cxt->aclass); + if (cxt->aclass) { + AV *aclass = cxt->aclass; + cxt->aclass = 0; + av_undef(aclass); + sv_free((SV *) aclass); + } - hv_undef(cxt->hook); - sv_free((SV *) cxt->hook); + if (cxt->hook) { + HV *hook = cxt->hook; + cxt->hook = 0; + hv_undef(hook); + sv_free((SV *) hook); + } - if (cxt->hseen) - sv_free((SV *) cxt->hseen); /* optional HV, for backward compat. */ + if (cxt->hseen) { + HV *hseen = cxt->hseen; + cxt->hseen = 0; + hv_undef(hseen); + sv_free((SV *) hseen); /* optional HV, for backward compat. */ + } cxt->entry = 0; cxt->s_dirty = 0; @@ -1071,6 +1144,8 @@ stcxt_t *cxt; clean_retrieve_context(cxt); else clean_store_context(cxt); + + ASSERT(!cxt->s_dirty, ("context is clean")); } /* @@ -1223,6 +1298,19 @@ static void pkg_hide( } /* + * pkg_uncache + * + * Discard cached value: a whole fetch loop will be retried at next lookup. + */ +static void pkg_uncache( + HV *cache, + HV *pkg, + char *method) +{ + (void) hv_delete(cache, HvNAME(pkg), strlen(HvNAME(pkg)), G_DISCARD); +} + +/* * pkg_can * * Our own "UNIVERSAL::can", which caches results. @@ -2096,11 +2184,14 @@ static int store_hook( for (i = 1; i < count; i++) { SV **svh; - SV *xsv = ary[i]; + SV *rsv = ary[i]; + SV *xsv; + AV *av_hook = cxt->hook_seen; - if (!SvROK(xsv)) - CROAK(("Item #%d from hook in %s is not a reference", i, class)); - xsv = SvRV(xsv); /* Follow ref to know what to look for */ + if (!SvROK(rsv)) + CROAK(("Item #%d returned by STORABLE_freeze " + "for %s is not a reference", i, class)); + xsv = SvRV(rsv); /* Follow ref to know what to look for */ /* * Look in hseen and see if we have a tag already. @@ -2136,11 +2227,34 @@ static int store_hook( CROAK(("Could not serialize item #%d from hook in %s", i, class)); /* - * Replace entry with its tag (not a real SV, so no refcnt increment) + * It was the first time we serialized `xsv'. + * + * Keep this SV alive until the end of the serialization: if we + * disposed of it right now by decrementing its refcount, and it was + * a temporary value, some next temporary value allocated during + * another STORABLE_freeze might take its place, and we'd wrongly + * assume that new SV was already serialized, based on its presence + * in cxt->hseen. + * + * Therefore, push it away in cxt->hook_seen. */ + av_store(av_hook, AvFILLp(av_hook)+1, SvREFCNT_inc(xsv)); + sv_seen: - SvREFCNT_dec(xsv); + /* + * Dispose of the REF they returned. If we saved the `xsv' away + * in the array of returned SVs, that will not cause the underlying + * referenced SV to be reclaimed. + */ + + ASSERT(SvREFCNT(xsv) > 1, ("SV will survive disposal of its REF")); + SvREFCNT_dec(rsv); /* Dispose of reference */ + + /* + * Replace entry with its tag (not a real SV, so no refcnt increment) + */ + ary[i] = *svh; TRACEME(("listed object %d at 0x%"UVxf" is tag #%"UVuf, i-1, PTR2UV(xsv), PTR2UV(*svh))); @@ -3131,8 +3245,37 @@ static SV *retrieve_hook(stcxt_t *cxt) BLESS(sv, class); hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw"); - if (!hook) - CROAK(("No STORABLE_thaw defined for objects of class %s", class)); + if (!hook) { + /* + * Hook not found. Maybe they did not require the module where this + * hook is defined yet? + * + * If the require below succeeds, we'll be able to find the hook. + * Still, it only works reliably when each class is defined in a + * file of its own. + */ + + SV *psv = newSVpvn("require ", 8); + sv_catpv(psv, class); + + TRACEME(("No STORABLE_thaw defined for objects of class %s", class)); + TRACEME(("Going to require module '%s' with '%s'", class, SvPVX(psv))); + + perl_eval_sv(psv, G_DISCARD); + sv_free(psv); + + /* + * We cache results of pkg_can, so we need to uncache before attempting + * the lookup again. + */ + + pkg_uncache(cxt->hook, SvSTASH(sv), "STORABLE_thaw"); + hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw"); + + if (!hook) + CROAK(("No STORABLE_thaw defined for objects of class %s " + "(even after a \"require %s;\")", class, class)); + } /* * If we don't have an `av' yet, prepare one. @@ -3273,9 +3416,10 @@ static SV *retrieve_overloaded(stcxt_t *cxt) stash = (HV *) SvSTASH (sv); if (!stash || !Gv_AMG(stash)) - CROAK(("Cannot restore overloading on %s(0x%"UVxf")", + CROAK(("Cannot restore overloading on %s(0x%"UVxf") (package %s)", sv_reftype(sv, FALSE), - PTR2UV(sv))); + PTR2UV(sv), + stash ? HvNAME(stash) : "<unknown>")); SvAMAGIC_on(rv); diff --git a/ext/Sys/Syslog/Syslog.pm b/ext/Sys/Syslog/Syslog.pm index c7ce3ded96..71f5b828d0 100644 --- a/ext/Sys/Syslog/Syslog.pm +++ b/ext/Sys/Syslog/Syslog.pm @@ -264,7 +264,9 @@ sub xlate { $name = uc $name; $name = "LOG_$name" unless $name =~ /^LOG_/; $name = "Sys::Syslog::$name"; - eval { &$name } || -1; + # Can't have just eval { &$name } || -1 because some LOG_XXX may be zero. + my $value = eval { &$name }; + defined $value ? $value : -1; } sub connect { @@ -274,8 +276,8 @@ sub connect { ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _) } unless ( $sock_type ) { - my $udp = getprotobyname('udp'); - my $syslog = getservbyname('syslog','udp'); + my $udp = getprotobyname('udp') || croak "getprotobyname failed for udp"; + my $syslog = getservbyname('syslog','udp') || croak "getservbyname failed"; my $this = sockaddr_in($syslog, INADDR_ANY); my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host"); socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!"; diff --git a/ext/Thread/Thread.pm b/ext/Thread/Thread.pm index c752e3d6dd..f8a8a26bbc 100644 --- a/ext/Thread/Thread.pm +++ b/ext/Thread/Thread.pm @@ -21,6 +21,11 @@ Thread - manipulate threads in Perl (EXPERIMENTAL, subject to change) $result = $t->join; $result = $t->eval; $t->detach; + $flags = $t->flags; + + if ($t->done) { + $t->join; + } if($t->equal($another_thread)) { # ... @@ -181,6 +186,17 @@ increasing integer assigned when a thread is created. The main thread of a program will have a tid of zero, while subsequent threads will have tids assigned starting with one. +=item flags + +The C<flags> method returns the flags for the thread. This is the +integer value corresponding to the internal flags for the thread, and +the value may not be all that meaningful to you. + +=item done + +The C<done> method returns true if the thread you're checking has +finished, and false otherwise. + =back =head1 LIMITATIONS diff --git a/ext/Thread/Thread.xs b/ext/Thread/Thread.xs index 17e5aefd04..c117c60a42 100644 --- a/ext/Thread/Thread.xs +++ b/ext/Thread/Thread.xs @@ -98,7 +98,6 @@ threadstart(void *arg) DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p waiting to start\n", thr)); - /* Don't call *anything* requiring dTHR until after PERL_SET_THX() */ /* * Wait until our creator releases us. If we didn't do this, then * it would be potentially possible for out thread to carry on and @@ -116,7 +115,6 @@ threadstart(void *arg) */ PERL_SET_THX(thr); - /* Only now can we use SvPEEK (which calls sv_newmortal which does dTHR) */ DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p starting at %s\n", thr, SvPEEK(TOPs))); @@ -177,7 +175,7 @@ threadstart(void *arg) Safefree(PL_savestack); Safefree(PL_retstack); Safefree(PL_tmps_stack); - Safefree(PL_ofs); + SvREFCNT_dec(PL_ofs_sv); SvREFCNT_dec(PL_rs); SvREFCNT_dec(PL_nrs); @@ -191,6 +189,7 @@ threadstart(void *arg) Safefree(PL_reg_poscache); MUTEX_LOCK(&thr->mutex); + thr->thr_done = 1; DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: threadstart finishing: state is %u\n", thr, ThrSTATE(thr))); @@ -448,6 +447,14 @@ flags(t) #endif void +done(t) + Thread t + PPCODE: +#ifdef USE_THREADS + PUSHs(t->thr_done ? &PL_sv_yes : &PL_sv_no); +#endif + +void self(classname) char * classname PREINIT: diff --git a/ext/re/Makefile.PL b/ext/re/Makefile.PL index bc31b2c2cc..b8d25bd0d6 100644 --- a/ext/re/Makefile.PL +++ b/ext/re/Makefile.PL @@ -1,12 +1,15 @@ use ExtUtils::MakeMaker; use File::Spec; +use Config; + +my $object = 're_exec$(OBJ_EXT) re_comp$(OBJ_EXT) re$(OBJ_EXT)'; WriteMakefile( NAME => 're', VERSION_FROM => 're.pm', MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', - OBJECT => 're_exec$(OBJ_EXT) re_comp$(OBJ_EXT) re$(OBJ_EXT)', + OBJECT => $object, DEFINE => '-DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG', clean => { FILES => '*$(OBJ_EXT) *.c ../../lib/re.pm' }, ); diff --git a/ext/re/hints/aix.pl b/ext/re/hints/aix.pl new file mode 100644 index 0000000000..4fbfefd735 --- /dev/null +++ b/ext/re/hints/aix.pl @@ -0,0 +1,22 @@ +# Add explicit link to deb.o to pick up .Perl_deb symbol which is not +# mentioned in perl.exp for earlier cc (xlc) versions in at least +# non DEBUGGING builds +# Peter Prymmer <pvhp@best.com> + +use Config; + +if ($^O eq 'aix' && defined($Config{'ccversion'}) && + ( $Config{'ccversion'} =~ /^3\.\d/ + # needed for at least these versions: + # $Config{'ccversion'} eq '3.6.6.0' + # $Config{'ccversion'} eq '3.6.4.0' + # $Config{'ccversion'} eq '3.1.4.0' AIX 4.2 + # $Config{'ccversion'} eq '3.1.4.10' AIX 4.2 + # $Config{'ccversion'} eq '3.1.3.3' + || + $Config{'ccversion'} =~ /^4\.4\.0\.[0-3]/ + ) + ) { + $self->{OBJECT} .= ' ../../deb$(OBJ_EXT)'; +} + diff --git a/ext/re/re.xs b/ext/re/re.xs index 04a5fdc742..25c2a90d60 100644 --- a/ext/re/re.xs +++ b/ext/re/re.xs @@ -25,7 +25,6 @@ static int oldfl; static void deinstall(pTHX) { - dTHR; PL_regexecp = Perl_regexec_flags; PL_regcompp = Perl_pregcomp; PL_regint_start = Perl_re_intuit_start; @@ -39,7 +38,6 @@ deinstall(pTHX) static void install(pTHX) { - dTHR; PL_colorset = 0; /* Allow reinspection of ENV. */ PL_regexecp = &my_regexec; PL_regcompp = &my_regcomp; diff --git a/fakesdio.h b/fakesdio.h new file mode 100644 index 0000000000..479123242f --- /dev/null +++ b/fakesdio.h @@ -0,0 +1,104 @@ +/* + * This is "source level" stdio compatibility mode. + * We try and #define stdio functions in terms of PerlIO. + */ +#define _CANNOT "CANNOT" +#undef FILE +#define FILE PerlIO +#undef clearerr +#undef fclose +#undef fdopen +#undef feof +#undef ferror +#undef fflush +#undef fgetc +#undef fgetpos +#undef fgets +#undef fileno +#undef flockfile +#undef fopen +#undef fprintf +#undef fputc +#undef fputs +#undef fread +#undef freopen +#undef fscanf +#undef fseek +#undef fsetpos +#undef ftell +#undef ftrylockfile +#undef funlockfile +#undef fwrite +#undef getc +#undef getc_unlocked +#undef getw +#undef pclose +#undef popen +#undef putc +#undef putc_unlocked +#undef putw +#undef rewind +#undef setbuf +#undef setvbuf +#undef stderr +#undef stdin +#undef stdout +#undef tmpfile +#undef ungetc +#undef vfprintf +#define fprintf PerlIO_printf +#define stdin PerlIO_stdin() +#define stdout PerlIO_stdout() +#define stderr PerlIO_stderr() +#define tmpfile() PerlIO_tmpfile() +#define fclose(f) PerlIO_close(f) +#define fflush(f) PerlIO_flush(f) +#define fopen(p,m) PerlIO_open(p,m) +#define vfprintf(f,fmt,a) PerlIO_vprintf(f,fmt,a) +#define fgetc(f) PerlIO_getc(f) +#define fputc(c,f) PerlIO_putc(f,c) +#define fputs(s,f) PerlIO_puts(f,s) +#define getc(f) PerlIO_getc(f) +#define getc_unlocked(f) PerlIO_getc(f) +#define putc(c,f) PerlIO_putc(f,c) +#define putc_unlocked(c,f) PerlIO_putc(c,f) +#define ungetc(c,f) PerlIO_ungetc(f,c) +#if 0 +/* return values of read/write need work */ +#define fread(b,s,c,f) PerlIO_read(f,b,(s*c)) +#define fwrite(b,s,c,f) PerlIO_write(f,b,(s*c)) +#else +#define fread(b,s,c,f) _CANNOT fread +#define fwrite(b,s,c,f) _CANNOT fwrite +#endif +#define fseek(f,o,w) PerlIO_seek(f,o,w) +#define ftell(f) PerlIO_tell(f) +#define rewind(f) PerlIO_rewind(f) +#define clearerr(f) PerlIO_clearerr(f) +#define feof(f) PerlIO_eof(f) +#define ferror(f) PerlIO_error(f) +#define fdopen(fd,p) PerlIO_fdopen(fd,p) +#define fileno(f) PerlIO_fileno(f) +#define popen(c,m) my_popen(c,m) +#define pclose(f) my_pclose(f) + +#define fsetpos(f,p) _CANNOT _fsetpos_ +#define fgetpos(f,p) _CANNOT _fgetpos_ + +#define __filbuf(f) _CANNOT __filbuf_ +#define _filbuf(f) _CANNOT _filbuf_ +#define __flsbuf(c,f) _CANNOT __flsbuf_ +#define _flsbuf(c,f) _CANNOT _flsbuf_ +#define getw(f) _CANNOT _getw_ +#define putw(v,f) _CANNOT _putw_ +#if SFIO_VERSION < 20000101L +#define flockfile(f) _CANNOT _flockfile_ +#define ftrylockfile(f) _CANNOT _ftrylockfile_ +#define funlockfile(f) _CANNOT _funlockfile_ +#endif +#define freopen(p,m,f) _CANNOT _freopen_ +#define setbuf(f,b) _CANNOT _setbuf_ +#define setvbuf(f,b,x,s) _CANNOT _setvbuf_ +#define fscanf _CANNOT _fscanf_ +#define fgets(s,n,f) _CANNOT _fgets_ + diff --git a/fix_pl b/fix_pl deleted file mode 100644 index 44c3f52170..0000000000 --- a/fix_pl +++ /dev/null @@ -1,21 +0,0 @@ -#!perl -# Not fixing perl, but fixing the patchlevel if this perl comes -# from the repository rather than an official release -exit unless -e ".patch"; -open PATCH, ".patch" or die "Couldn't open .patch: $!"; -open PLIN, "patchlevel.h" or die "Couldn't open patchlevel.h : $!"; -open PLOUT, ">patchlevel.new" or die "Couldn't write on patchlevel.new : $!"; -my $pl = <PATCH>; -chomp ($pl); -$pl =~ s/\D//g; -my $seen=0; -while (<PLIN>) { - if (/\t,NULL/ and $seen) { - print PLOUT "\t,\"devel-$pl\"\n"; - } - $seen++ if /local_patches\[\]/; - print PLOUT; -} -close PLOUT; close PLIN; -rename "patchlevel.new", "patchlevel.h" or die "Couldn't rename: $!"; -unlink ".patch"; @@ -1,6 +1,6 @@ /* form.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -23,4 +23,5 @@ #define FF_NEWLINE 13 #define FF_BLANK 14 #define FF_MORE 15 +#define FF_0DECIMAL 16 diff --git a/global.sym b/global.sym index 0dea03efbe..2f6f65b9c8 100644 --- a/global.sym +++ b/global.sym @@ -21,6 +21,7 @@ Perl_get_context Perl_set_context Perl_amagic_call Perl_Gv_AMupdate +Perl_gv_handler Perl_apply_attrs_string Perl_avhv_delete_ent Perl_avhv_exists_ent @@ -315,6 +316,7 @@ Perl_pmflag Perl_pop_scope Perl_push_scope Perl_regdump +Perl_regclass_swash Perl_pregexec Perl_pregfree Perl_pregcomp @@ -358,6 +360,7 @@ Perl_save_scalar Perl_save_pptr Perl_save_vptr Perl_save_re_context +Perl_save_padsv Perl_save_sptr Perl_save_svref Perl_save_threadsv @@ -443,6 +446,7 @@ Perl_sv_taint Perl_sv_tainted Perl_sv_unmagic Perl_sv_unref +Perl_sv_unref_flags Perl_sv_untaint Perl_sv_upgrade Perl_sv_usepvn @@ -461,12 +465,13 @@ Perl_unlock_condpair Perl_unsharepvn Perl_utf16_to_utf8 Perl_utf16_to_utf8_reversed +Perl_utf8_length Perl_utf8_distance Perl_utf8_hop Perl_utf8_to_bytes Perl_bytes_to_utf8 +Perl_utf8_to_uv_simple Perl_utf8_to_uv -Perl_utf8_to_uv_chk Perl_uv_to_utf8 Perl_warn Perl_vwarn @@ -527,6 +532,7 @@ Perl_sv_utf8_downgrade Perl_sv_utf8_encode Perl_sv_utf8_decode Perl_sv_force_normal +Perl_sv_force_normal_flags Perl_tmps_grow Perl_sv_rvweaken Perl_newANONATTRSUB @@ -1,6 +1,6 @@ /* gv.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -53,7 +53,6 @@ Perl_gv_IOadd(pTHX_ register GV *gv) GV * Perl_gv_fetchfile(pTHX_ const char *name) { - dTHR; char smallbuf[256]; char *tmpbuf; STRLEN tmplen; @@ -85,7 +84,6 @@ Perl_gv_fetchfile(pTHX_ const char *name) void Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) { - dTHR; register GP *gp; bool doproto = SvTYPE(gv) > SVt_NULL; char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; @@ -227,7 +225,6 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) basestash = gv_stashpvn(packname, packlen, TRUE); gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE); if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { - dTHR; /* just for SvREFCNT_dec */ gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE); if (!gvp || !(gv = *gvp)) Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash)); @@ -247,7 +244,6 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { - dTHR; /* just for ckWARN */ if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); @@ -342,7 +338,6 @@ C<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; @@ -403,7 +398,6 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) GV* Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) { - dTHR; static char autoload[] = "AUTOLOAD"; static STRLEN autolen = 8; GV* gv; @@ -418,7 +412,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) return Nullgv; cv = GvCV(gv); - if (!CvROOT(cv)) + if (!(CvROOT(cv) || CvXSUB(cv))) return Nullgv; /* @@ -430,6 +424,20 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", HvNAME(stash), (int)len, name); +#ifndef USE_THREADS + if (CvXSUB(cv)) { + /* rather than lookup/init $AUTOLOAD here + * only to have the XSUB do another lookup for $AUTOLOAD + * and split that value on the last '::', + * pass along the same data via some unused fields in the CV + */ + CvSTASH(cv) = stash; + SvPVX(cv) = (char *)name; /* cast to loose constness warning */ + SvCUR(cv) = len; + return gv; + } +#endif + /* * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. * The subroutine's original name may not be "AUTOLOAD", so we don't @@ -525,7 +533,6 @@ Perl_gv_stashsv(pTHX_ SV *sv, I32 create) GV * Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) { - dTHR; register const char *name = nambeg; register GV *gv = 0; GV**gvp; @@ -840,7 +847,6 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) case ',': case '\\': case '/': - case '|': case '\001': /* $^A */ case '\003': /* $^C */ case '\004': /* $^D */ @@ -848,12 +854,20 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) case '\006': /* $^F */ case '\010': /* $^H */ case '\011': /* $^I, NOT \t in EBCDIC */ - case '\017': /* $^O */ case '\020': /* $^P */ case '\024': /* $^T */ if (len > 1) break; goto magicalize; + case '|': + if (len > 1) + break; + sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0); + goto magicalize; + case '\017': /* $^O & $^OPEN */ + if (len > 1 && strNE(name, "\017PEN")) + break; + goto magicalize; case '\023': /* $^S */ if (len > 1) break; @@ -992,7 +1006,6 @@ Perl_gv_efullname(pTHX_ SV *sv, GV *gv) IO * Perl_newIO(pTHX) { - dTHR; IO *io; GV *iogv; @@ -1011,7 +1024,6 @@ Perl_newIO(pTHX) void Perl_gv_check(pTHX_ HV *stash) { - dTHR; register HE *entry; register I32 i; register GV *gv; @@ -1088,7 +1100,6 @@ Perl_gp_ref(pTHX_ GP *gp) void Perl_gp_free(pTHX_ GV *gv) { - dTHR; GP* gp; if (!gv || !(gp = GvGP(gv))) @@ -1149,21 +1160,16 @@ register GV *gv; bool Perl_Gv_AMupdate(pTHX_ HV *stash) { - dTHR; GV* gv; CV* cv; MAGIC* mg=mg_find((SV*)stash,'c'); AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL; AMT amt; STRLEN n_a; -#ifdef OVERLOAD_VIA_HASH - GV** gvp; - HV* hv; -#endif if (mg && amtp->was_ok_am == PL_amagic_generation && amtp->was_ok_sub == PL_sub_generation) - return AMT_AMAGIC(amtp); + return AMT_OVERLOADED(amtp); if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */ int i; for (i=1; i<NofAMmeth; i++) { @@ -1181,90 +1187,40 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) amt.fallback = AMGfallNO; amt.flags = 0; -#ifdef OVERLOAD_VIA_HASH - gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */ - if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) { - int filled=0; - int i; - char *cp; - SV* sv; - SV** svp; - - /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ - - if (( cp = (char *)PL_AMG_names[0] ) && - (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) { - if (SvTRUE(sv)) amt.fallback=AMGfallYES; - else if (SvOK(sv)) amt.fallback=AMGfallNEVER; - } - for (i = 1; 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)) { - default: - if (!SvROK(sv)) { - if (!SvOK(sv)) break; - gv = gv_fetchmethod(stash, SvPV(sv, n_a)); - if (gv) cv = GvCV(gv); - break; - } - cv = (CV*)SvRV(sv); - if (SvTYPE(cv) == SVt_PVCV) - break; - /* FALL THROUGH */ - case SVt_PVHV: - case SVt_PVAV: - Perl_croak(aTHX_ "Not a subroutine reference in overload table"); - return FALSE; - case SVt_PVCV: - cv = (CV*)sv; - break; - case SVt_PVGV: - if (!(cv = GvCVu((GV*)sv))) - cv = sv_2cv(sv, &stash, &gv, FALSE); - break; - } - if (cv) filled=1; - else { - Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n", - cp,HvNAME(stash)); - return FALSE; - } - } -#else { - int filled = 0; - int i; + int filled = 0, have_ovl = 0; + int i, lim = 1; const char *cp; SV* sv = NULL; /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ - if ((cp = PL_AMG_names[0])) { - /* Try to find via inheritance. */ - gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */ - if (gv) - sv = GvSV(gv); - - if (!gv) - goto no_table; - else if (SvTRUE(sv)) - amt.fallback=AMGfallYES; - else if (SvOK(sv)) - amt.fallback=AMGfallNEVER; - } + /* Try to find via inheritance. */ + gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1); + if (gv) + sv = GvSV(gv); + + if (!gv) + lim = DESTROY_amg; /* Skip overloading entries. */ + else if (SvTRUE(sv)) + amt.fallback=AMGfallYES; + else if (SvOK(sv)) + amt.fallback=AMGfallNEVER; + + for (i = 1; i < lim; i++) + amt.table[i] = Nullcv; + for (; i < NofAMmeth; i++) { + char *cooky = (char*)PL_AMG_names[i]; + /* Human-readable form, for debugging: */ + char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i)); + STRLEN l = strlen(cooky); - for (i = 1; i < NofAMmeth; i++) { - SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i])); DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n", cp, HvNAME(stash)) ); /* don't fill the cache while looking up! */ - gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1); + gv = gv_fetchmeth(stash, cooky, l, -1); cv = 0; - if(gv && (cv = GvCV(gv))) { + if (gv && (cv = GvCV(gv))) { if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) { /* GvSV contains the name of the method. */ @@ -1292,14 +1248,17 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))) ); filled = 1; + if (i < DESTROY_amg) + have_ovl = 1; } -#endif amt.table[i]=(CV*)SvREFCNT_inc(cv); } if (filled) { AMT_AMAGIC_on(&amt); + if (have_ovl) + AMT_OVERLOADED_on(&amt); sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT)); - return TRUE; + return have_ovl; } } /* Here we have no table: */ @@ -1309,10 +1268,35 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) return FALSE; } + +CV* +Perl_gv_handler(pTHX_ HV *stash, I32 id) +{ + dTHR; + MAGIC *mg; + AMT *amtp; + + if (!stash) + return Nullcv; + mg = mg_find((SV*)stash,'c'); + if (!mg) { + do_update: + Gv_AMupdate(stash); + mg = mg_find((SV*)stash,'c'); + } + amtp = (AMT*)mg->mg_ptr; + if ( amtp->was_ok_am != PL_amagic_generation + || amtp->was_ok_sub != PL_sub_generation ) + goto do_update; + if (AMT_AMAGIC(amtp)) + return amtp->table[id]; + return Nullcv; +} + + SV* Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { - dTHR; MAGIC *mg; CV *cv; CV **cvp=NULL, **ocvp=NULL; @@ -1493,7 +1477,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (off==-1) off=method; msg = sv_2mortal(Perl_newSVpvf(aTHX_ "Operation `%s': no method found,%sargument %s%s%s%s", - PL_AMG_names[method + assignshift], + AMG_id2name(method + assignshift), (flags & AMGf_unary ? " " : "\n\tleft "), SvAMAGIC(left)? "in overloaded package ": @@ -1522,11 +1506,11 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (!notfound) { DEBUG_o( Perl_deb(aTHX_ "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n", - PL_AMG_names[off], + AMG_id2name(off), method+assignshift==off? "" : " (initially `", method+assignshift==off? "" : - PL_AMG_names[method+assignshift], + AMG_id2name(method+assignshift), method+assignshift==off? "" : "')", flags & AMGf_unary? "" : lr==1 ? " for right argument": " for left argument", @@ -1586,7 +1570,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PUSHs(lr>0? left: right); PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); if (notfound) { - PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0))); + PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0))); } PUSHs((SV*)cv); PUTBACK; @@ -1672,6 +1656,13 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) if (len == 3 && strEQ(name, "SIG")) goto yes; break; + case '\017': /* $^O & $^OPEN */ + if (len == 1 + || (len == 4 && strEQ(name, "\027PEN"))) + { + goto yes; + } + break; case '\027': /* $^W & $^WARNING_BITS */ if (len == 1 || (len == 12 && strEQ(name, "\027ARNING_BITS")) @@ -1715,7 +1706,6 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) case '\010': /* $^H */ case '\011': /* $^I, NOT \t in EBCDIC */ case '\014': /* $^L */ - case '\017': /* $^O */ case '\020': /* $^P */ case '\023': /* $^S */ case '\024': /* $^T */ @@ -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. @@ -1,6 +1,6 @@ /* handy.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -114,6 +114,10 @@ Null SV pointer. */ +#ifdef I_INTTYPES /* e.g. Linux has int64_t without <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. */ @@ -448,21 +463,21 @@ Converts the specified character to lowercase. #define isPSXSPC_utf8(c) (isSPACE_utf8(c) ||(c) == '\f') #define isBLANK_utf8(c) isBLANK(c) /* could be wrong */ -#define isALNUM_LC_utf8(p) isALNUM_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isIDFIRST_LC_utf8(p) isIDFIRST_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isALPHA_LC_utf8(p) isALPHA_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isSPACE_LC_utf8(p) isSPACE_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isDIGIT_LC_utf8(p) isDIGIT_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isUPPER_LC_utf8(p) isUPPER_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isLOWER_LC_utf8(p) isLOWER_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isALNUMC_LC_utf8(p) isALNUMC_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isCNTRL_LC_utf8(p) isCNTRL_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isGRAPH_LC_utf8(p) isGRAPH_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isPRINT_LC_utf8(p) isPRINT_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define isPUNCT_LC_utf8(p) isPUNCT_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define toUPPER_LC_utf8(p) toUPPER_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define toTITLE_LC_utf8(p) toTITLE_LC_uni(utf8_to_uv_chk(p, 0, 0)) -#define toLOWER_LC_utf8(p) toLOWER_LC_uni(utf8_to_uv_chk(p, 0, 0)) +#define isALNUM_LC_utf8(p) isALNUM_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isIDFIRST_LC_utf8(p) isIDFIRST_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isALPHA_LC_utf8(p) isALPHA_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isSPACE_LC_utf8(p) isSPACE_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isDIGIT_LC_utf8(p) isDIGIT_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isUPPER_LC_utf8(p) isUPPER_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isLOWER_LC_utf8(p) isLOWER_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isALNUMC_LC_utf8(p) isALNUMC_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isCNTRL_LC_utf8(p) isCNTRL_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isGRAPH_LC_utf8(p) isGRAPH_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isPRINT_LC_utf8(p) isPRINT_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define isPUNCT_LC_utf8(p) isPUNCT_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define toUPPER_LC_utf8(p) toUPPER_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define toTITLE_LC_utf8(p) toTITLE_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) +#define toLOWER_LC_utf8(p) toLOWER_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0)) #define isPSXSPC_LC_utf8(c) (isSPACE_LC_utf8(c) ||(c) == '\f') #define isBLANK_LC_utf8(c) isBLANK(c) /* could be wrong */ @@ -606,3 +621,14 @@ extern long lastxycount[MAXXCOUNT][MAXYCOUNT]; #else #define StructCopy(s,d,t) Copy(s,d,1,t) #endif + +#ifdef NEED_VA_COPY +# ifdef va_copy +# define Perl_va_copy(s, d) va_copy(d, s) +# elif defined(__va_copy) +# define Perl_va_copy(s, d) __va_copy(d, s) +# else +# define Perl_va_copy(s, d) Copy(s, d, 1, va_list) +# endif +#endif + diff --git a/hints/aix.sh b/hints/aix.sh index cf7e43cce7..b14aad0e99 100644 --- a/hints/aix.sh +++ b/hints/aix.sh @@ -130,6 +130,13 @@ case "$cc" in *gcc*) ccdlflags='-Xlinker' ;; *) ccversion=`lslpp -L | grep 'C for AIX Compiler$' | awk '{print $2}'` case "$ccversion" in + '') ccversion=`lslpp -L | grep 'IBM C and C++ Compilers LUM$' | awk '{print $2}'` + ;; + esac + case "$ccversion" in + 3.6.6.0) + optimize='none' + ;; 4.4.0.0|4.4.0.1|4.4.0.2) echo >&4 "*** This C compiler ($ccversion) is outdated." echo >&4 "*** Please upgrade to at least 4.4.0.3." @@ -156,6 +163,20 @@ case "$osvers" in lddlflags="$lddlflags -bhalt:4 -bM:SRE -bI:\$(PERL_INC)/perl.exp -bE:\$(BASEEXT).exp -b noentry -lc" ;; esac +# AIX 4.2 (using latest patchlevels on 20001130) has a broken bind +# library (getprotobyname and getprotobynumber are outversioned by +# the same calls in libc, at least for xlc version 3... +case "`oslevel`" in + 4.2.1.*) # Test for xlc version too, should we? + case "$ccversion" in # Don't know if needed for gcc + 3.1.4.*) # libswanted "bind ... c ..." => "... c bind ..." + set `echo X "$libswanted "| sed -e 's/ bind\( .*\) \([cC]\) / \1 \2 bind /'` + shift + libswanted="$*" + ;; + esac + ;; + esac # This script UU/usethreads.cbu will get 'called-back' by Configure # after it has prompted the user for whether to use threads. diff --git a/hints/cygwin.sh b/hints/cygwin.sh index 7be173557c..c57d3f6fdf 100644 --- a/hints/cygwin.sh +++ b/hints/cygwin.sh @@ -25,6 +25,7 @@ libswanted=`echo " $libswanted " | sed -e 's/ c / /g'` libswanted=`echo " $libswanted " | sed -e 's/ m / /g'` libswanted="$libswanted cygipc" test -z "$optimize" && optimize='-O2' +ccflags="$ccflags -DPERL_USE_SAFE_PUTENV" # - otherwise i686-cygwin archname='cygwin' diff --git a/hints/dec_osf.sh b/hints/dec_osf.sh index 07b80ea920..ce3a40c77d 100644 --- a/hints/dec_osf.sh +++ b/hints/dec_osf.sh @@ -70,12 +70,13 @@ case "`$cc -v 2>&1 | grep cc`" in if test "$1" -lt 2 -o \( "$1" -eq 2 -a \( "$2" -lt 95 -o \( "$2" -eq 95 -a "$3" -lt 2 \) \) \); then cat >&4 <<EOF -*** Your cc seems to be gcc and its 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). +*** 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 +*** 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. @@ -88,10 +89,10 @@ 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 -*** dumps core (meaning that the SDBM_File is unusable). As this core -*** dump 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. +*** 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. diff --git a/hints/dos_djgpp.sh b/hints/dos_djgpp.sh index d50bca4b25..ebbd786b45 100644 --- a/hints/dos_djgpp.sh +++ b/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/hints/freebsd.sh b/hints/freebsd.sh index 0ba6b6190e..cc48351879 100644 --- a/hints/freebsd.sh +++ b/hints/freebsd.sh @@ -86,13 +86,6 @@ case "$osvers" in d_setegid='undef' d_seteuid='undef' ;; -3.*) - usevfork='true' - usemymalloc='n' - libswanted=`echo $libswanted | sed 's/ malloc / /'` - ;; -# -# Guesses at what will be needed after 3.* *) usevfork='true' usemymalloc='n' libswanted=`echo $libswanted | sed 's/ malloc / /'` diff --git a/hints/hpux.sh b/hints/hpux.sh index 43d72bc0b1..ca5c50b3b0 100644 --- a/hints/hpux.sh +++ b/hints/hpux.sh @@ -179,6 +179,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 ;; diff --git a/hints/linux.sh b/hints/linux.sh index 913cfd0fd1..a6b2bd985a 100644 --- a/hints/linux.sh +++ b/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 diff --git a/hints/machten.sh b/hints/machten.sh index 69f16355c2..3a311a1746 100644 --- a/hints/machten.sh +++ b/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 @@ -197,6 +200,11 @@ if test "$d_shm" = ""; then esac fi +# MachTen has stubs for mmap and munmap(), but they just result in the +# caller being killed on the grounds of "Bad system call" +d_mmap=${d_mmap:-undef} +d_munmap=${d_munmap:-undef} + # Get rid of some extra libs which it takes Configure a tediously # long time never to find on MachTen, or which break perl set `echo X "$libswanted "|sed -e 's/ net / /' -e 's/ socket / /' \ @@ -228,6 +236,8 @@ During Configure, you may see the message as well as similar messages concerning \$d_sem and \$d_shm. Select the default answers: MachTen 4.1 appears to provide System V IPC support, but it is incomplete and buggy: perl should be built without it. +Similar considerations apply to memory mapping of files, controlled +by \$d_mmap and \$d_munmap. Similarly, when you see diff --git a/hints/nonstopux.sh b/hints/nonstopux.sh index f93c312203..aec05ee680 100644 --- a/hints/nonstopux.sh +++ b/hints/nonstopux.sh @@ -9,7 +9,7 @@ case "$cc" in lddlflags='-shared' ldflags='' ;; - '') + *) cc="cc -Xa -Olimit 4096" malloctype="void *" ;; diff --git a/hints/openbsd.sh b/hints/openbsd.sh index 5b79709055..2e7a433326 100644 --- a/hints/openbsd.sh +++ b/hints/openbsd.sh @@ -43,7 +43,7 @@ OpenBSD.alpha|OpenBSD.mips|OpenBSD.powerpc|OpenBSD.vax) ;; *) # from 2.8 onwards ld=${cc:-cc} - lddlflags="-shared $lddlflags" + lddlflags="-shared -fPIC $lddlflags" ;; esac ;; @@ -95,6 +95,9 @@ case "$openbsd_distribution" in sysman='/usr/share/man/man1' libpth='/usr/lib' glibpth='/usr/lib' + # Local things, however, do go in /usr/local + siteprefix='/usr/local' + siteprefixexp='/usr/local' # Ports installs non-std libs in /usr/local/lib so look there too locincpth='/usr/local/include' loclibpth='/usr/local/lib' diff --git a/hints/solaris_2.sh b/hints/solaris_2.sh index e8175f241a..0bf5bab3af 100644 --- a/hints/solaris_2.sh +++ b/hints/solaris_2.sh @@ -1,35 +1,48 @@ # hints/solaris_2.sh -# Last modified: Tue Apr 13 13:12:49 EDT 1999 +# Last modified: Tue Jan 2 10:16:35 2001 +# Lupe Christoph <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,47 +58,35 @@ case "$archname" in ;; esac -cc=${cc:-cc} - -ccversion="`$cc -V 2>&1|head -1|sed 's/^cc: //'`" -case "$ccversion" in -*WorkShop*) ccname=workshop ;; -*) ccversion='' ;; -esac - -cat >UU/workshoplibpth.cbu<<'EOCBU' +cat > UU/workshoplibpth.cbu << 'EOCBU' +# This script UU/workshoplibpth.cbu will get 'called-back' +# by other CBUs this script creates. case "$workshoplibpth_done" in -'') case "$use64bitall" in - "$define"|true|[yY]*) - loclibpth="$loclibpth /usr/lib/sparcv9" - if test -n "$workshoplibs"; then - loclibpth=`echo $loclibpth | sed -e "s% $workshoplibs%%" ` - for lib in $workshoplibs; do - # Logically, it should be sparcv9. - # But the reality fights back, it's v9. - loclibpth="$loclibpth $lib/sparcv9 $lib/v9" - done - fi + '') if test `uname -p` = "sparc"; then + case "$use64bitall" in + "$define"|true|[yY]*) + # add SPARC-specific 64 bit libraries + loclibpth="$loclibpth /usr/lib/sparcv9" + if test -n "$workshoplibs"; then + loclibpth=`echo $loclibpth | sed -e "s% $workshoplibs%%" ` + for lib in $workshoplibs; do + # Logically, it should be sparcv9. + # But the reality fights back, it's v9. + loclibpth="$loclibpth $lib/sparcv9 $lib/v9" + done + fi ;; - *) loclibpth="$loclibpth $workshoplibs" + *) loclibpth="$loclibpth $workshoplibs" ;; esac + else + loclibpth="$loclibpth $workshoplibs" + fi workshoplibpth_done="$define" ;; esac EOCBU -case "$ccname" in -workshop) - cat >try.c <<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. # @@ -95,12 +96,12 @@ esac # To: perl5-porters@africa.nicoh.com # Subject: Re: On perl5/solaris/gcc # -# Here's another draft of the perl5/solaris/gcc sanity-checker. +# Here's another draft of the perl5/solaris/gcc sanity-checker. case `type ${cc:-cc}` in */usr/ucb/cc*) cat <<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. @@ -158,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 @@ -170,31 +171,33 @@ END fi rm -f make.vers -# XXX EXPERIMENTAL A.D. 2/27/1998 -# XXX This script UU/cc.cbu will get 'called-back' by Configure after it -# XXX has prompted the user for the C compiler to use. -cat > UU/cc.cbu <<'EOSH' +cat > UU/cc.cbu <<'EOCBU' +# This script UU/cc.cbu will get 'called-back' by Configure after it +# has prompted the user for the C compiler to use. + # If the C compiler is gcc: # - check the fixed-includes # - check as(1) and ld(1), they should not be GNU # (GNU as and ld 2.8.1 and later are reportedly ok, however.) # If the C compiler is not gcc: +# - Check if it is the Workshop/Forte compiler. +# If it is, prepare for 64 bit and long doubles. # - check as(1) and ld(1), they should not be GNU # (GNU as and ld 2.8.1 and later are reportedly ok, however.) # # Watch out in case they have not set $cc. -# Perl compiled with some combinations of GNU as and ld may not +# Perl compiled with some combinations of GNU as and ld may not # be able to perform dynamic loading of extensions. If you have a # problem with dynamic loading, be sure that you are using the Solaris # /usr/ccs/bin/as and /usr/ccs/bin/ld. You can do that with # sh Configure -Dcc='gcc -B/usr/ccs/bin/' -# (note the trailing slash is required). +# (note the trailing slash is required). # Combinations that are known to work with the following hints: # # gcc-2.7.2, GNU as 2.7, GNU ld 2.7 # egcs-1.0.3, GNU as 2.9.1 and GNU ld 2.9.1 -# --Andy Dougherty <doughera@lafayette.edu> +# --Andy Dougherty <doughera@lafayette.edu> # Tue Apr 13 17:19:43 EDT 1999 # Get gcc to share its secrets. @@ -207,12 +210,6 @@ if echo "$verbose" | grep '^Reading specs from' >/dev/null 2>&1; then # Using gcc. # - tmp=`echo "$verbose" | grep '^Reading' | - awk '{print $NF}' | sed 's/specs$/include/'` - - # Determine if the fixed-includes look like they'll work. - # Doesn't work anymore for gcc-2.7.2. - # See if as(1) is GNU as(1). GNU as(1) might not work for this job. if echo "$verbose" | grep ' /usr/ccs/bin/as ' >/dev/null 2>&1; then : @@ -277,6 +274,23 @@ else # Not using gcc. # + ccversion="`${cc:-cc} -V 2>&1|sed -n -e '1s/^cc: //p'`" + case "$ccversion" in + *WorkShop*) ccname=workshop ;; + *) ccversion='' ;; + esac + + case "$ccname" in + workshop) + cat >try.c <<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*) @@ -293,22 +307,12 @@ END # See if ld(1) is GNU ld(1). GNU ld(1) might not work for this job. # ld --version doesn't properly report itself as a GNU tool, # as of ld version 2.6, so we need to be more strict. TWP 9/5/96 - gnu_ld=false - case `ld --version < /dev/null 2>&1` in - *GNU*|ld\ version\ 2*) - gnu_ld=true ;; - *) ;; - esac - if $gnu_ld ; then : + # Sun's ld always emits the "Software Generation Utilities" string. + if ld -V 2>&1 | grep "ld: Software Generation Utilities" >/dev/null 2>&1; then + # Ok, ld is /usr/ccs/bin/ld. + : else - # Try to guess from path - case `type ld | awk '{print $NF}'` in - *gnu*|*GNU*|*FSF*) - gnu_ld=true ;; - esac - fi - if $gnu_ld ; then - cat <<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 @@ -324,16 +328,16 @@ rm -f try try.c rm -f core # XXX -EOSH +EOCBU cat > UU/usethreads.cbu <<'EOCBU' -# This script UU/usethreads.cbu will get 'called-back' by Configure +# This script UU/usethreads.cbu will get 'called-back' by Configure # after it has prompted the user for whether to use threads. case "$usethreads" in $define|true|[yY]*) ccflags="-D_REENTRANT $ccflags" - # sched_yield is in -lposix4 up to Solaris 2.6, in -lrt starting with Solaris 7 + # sched_yield is in -lposix4 up to Solaris 2.6, in -lrt starting with Solaris 2.7 case `uname -r` in 5.[0-6] | 5.5.1) sched_yield_lib="posix4" ;; *) sched_yield_lib="rt"; @@ -352,12 +356,12 @@ $define|true|[yY]*) cat >try.c <<'EOM' /* Test for sig(set|long)jmp bug. */ #include <setjmp.h> - + main() { sigjmp_buf env; int ret; - + ret = sigsetjmp(env, 1); if (ret) { return ret == 2; } siglongjmp(env, 2); @@ -379,7 +383,7 @@ esac EOCBU cat > UU/uselargefiles.cbu <<'EOCBU' -# This script UU/uselargefiles.cbu will get 'called-back' by Configure +# This script UU/uselargefiles.cbu will get 'called-back' by Configure # after it has prompted the user for whether to use large files. case "$uselargefiles" in ''|$define|true|[yY]*) @@ -399,21 +403,40 @@ EOCBU # This is truly a mess. case "$usemorebits" in "$define"|true|[yY]*) - use64bitint="$define" - uselongdouble="$define" + use64bitint="$define" + uselongdouble="$define" ;; esac -cat > UU/use64bitall.cbu <<'EOCBU' -# This script UU/use64bitall.cbu will get 'called-back' by Configure +if test `uname -p` = "sparc"; then + cat > UU/use64bitint.cbu <<'EOCBU' +# This script UU/use64bitint.cbu will get 'called-back' by Configure +# after it has prompted the user for whether to use 64 bit integers. +case "$use64bitint" in +"$define"|true|[yY]*) + case "`uname -r`" in + 5.[0-4]) + cat >&4 <<EOM +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 + ;; + esac + ;; +esac +EOCBU + + 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.[1-6]) + 5.[0-6]) cat >&4 <<EOM -Solaris `uname -r|sed -e 's/^5\.\([789]\)$/\1/'` does not support 64-bit pointers. -You should upgrade to at least Solaris 7. +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 ;; @@ -423,13 +446,12 @@ EOM cat >&4 <<EOM I do not see the 64-bit libc, $libc. -(You are either in an old sparc or in an x86.) 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 @@ -437,13 +459,16 @@ EOM *"m64 is not supported"*) cat >&4 <<EOM -Full 64-bit build not supported by this gcc 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 ;; - esac + 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`" @@ -460,234 +485,47 @@ EOM ldflags="$ldflags `getconf XBS5_LP64_OFF64_LDFLAGS 2>/dev/null`" lddlflags="$lddlflags -G `getconf XBS5_LP64_OFF64_LDFLAGS 2>/dev/null`" ;; - esac + esac libscheck='case "`/usr/bin/file $xxx`" in *64-bit*|*SPARCV9*) ;; *) xxx=/no/64-bit$xxx ;; esac' + use64bitall_done=yes ;; esac EOCBU - -# Actually, we want to run this already now, if so requested, -# because we need to fix up things right now. -case "$use64bitall" in -"$define"|true|[yY]*) - . ./UU/use64bitall.cbu + + # Actually, we want to run this already now, if so requested, + # because we need to fix up things right now. + case "$use64bitall" in + "$define"|true|[yY]*) + # CBUs expect to be run in UU + cd UU; . ./use64bitall.cbu; cd .. ;; -esac + esac +fi cat > UU/uselongdouble.cbu <<'EOCBU' -# This script UU/uselongdouble.cbu will get 'called-back' by Configure +# This script UU/uselongdouble.cbu will get 'called-back' by Configure # after it has prompted the user for whether to use long doubles. -case "$uselongdouble-$uselongdouble_done" in -"$define-"|true-|[yY]*-) - case "$ccname" in - workshop) - libswanted="$libswanted sunmath" - loclibpth="$loclibpth /opt/SUNWspro/lib" - ;; - *) cat >&4 <<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 -The Sun Workshop compiler is not being used; 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" - ;; - 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 - -# 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/hints/svr4.sh b/hints/svr4.sh index 8109b39752..69af6fda2f 100644 --- a/hints/svr4.sh +++ b/hints/svr4.sh @@ -135,6 +135,22 @@ case "`uname -sm`" in ;; esac +# NCR MP-RAS. Thanks to Doug Hendricks for this info. +# The output of uname -a looks like this +# foo foo 4.0 3.0 3441 Pentium III(TM)-ISA/PCI +# Configure sets osname=svr4.0, osvers=3.0, archname='3441-svr4.0' +case "$myuname" in +*3441*) + # With the NCR High Performance C Compiler R3.0c, miniperl fails + # t/op/regexp.t test 461 unless we compile with optimizie=-g. + # The whole O/S is being phased out, so more detailed probing + # is probably not warranted. + case "$optimize" in + '') optimize='-g' ;; + esac + ;; +esac + # Configure may fail to find lstat() since it's a static/inline function # in <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/hints/uts.sh b/hints/uts.sh index 74698db2be..2bae4b0acf 100644 --- a/hints/uts.sh +++ b/hints/uts.sh @@ -1,4 +1,18 @@ -ccflags="$ccflags -DCRIPPLED_CC" -d_lstat='define' -usedl='undef' - +archname='s390' +cc='cc -Xa' +cccdlflags='-pic' +d_bincompat3='undef' +d_csh='undef' +d_lstat='define' +d_suidsafe='define' +dlsrc='dl_dlopen.xs' +ld='ld' +lddlflags='-G -z text' +libperl='libperl.so' +libpth='/lib /usr/lib /usr/ccs/lib' +libs='-lsocket -lnsl -ldl -lm' +optimize='undef' +prefix='psf_prefix' +static_ext='none' +dynamic_ext='Fcntl IO Opcode Socket' +useshrplib='define' diff --git a/hints/uwin.sh b/hints/uwin.sh index 0b2cf9d3a0..9141efcd13 100644 --- a/hints/uwin.sh +++ b/hints/uwin.sh @@ -24,7 +24,7 @@ i_utime=undef # compile/link flags ldflags=-g optimize=-g -static_ext="B Data/Dumper Fcntl IO IPC/SysV Opcode POSIX SDBM_File Socket Storable attrs" +static_ext="B Data/Dumper Fcntl Filter::Util::Call IO IPC/SysV Opcode POSIX SDBM_File Socket Storable attrs" #static_ext=none # dynamic loading needs work usedl=undef diff --git a/hints/vmesa.sh b/hints/vmesa.sh index 2b3dd285d9..81ab6a4f44 100644 --- a/hints/vmesa.sh +++ b/hints/vmesa.sh @@ -218,7 +218,7 @@ dynamic_ext='' eagain='EAGAIN' ebcdic='define' exe_ext='' -extensions='Fcntl GDBM_File IO NDBM_File Opcode POSIX Socket Storable IPC/SysV Errno Thread attrs re Data/Dumper' +extensions=' Data/Dumper Errno Fcntl Filter::Util:Call GDBM_File IO NDBM_File Opcode POSIX Socket Storable IPC/SysV Thread attrs re' fpostype='fpos_t' freetype='void' groupstype='gid_t' @@ -1,6 +1,6 @@ /* hv.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -75,20 +75,27 @@ S_save_hek(pTHX_ const char *str, I32 len, U32 hash) { char *k; register HEK *hek; + bool is_utf8 = FALSE; + + if (len < 0) { + len = -len; + is_utf8 = TRUE; + } New(54, k, HEK_BASESIZE + len + 1, char); hek = (HEK*)k; Copy(str, HEK_KEY(hek), len, char); - *(HEK_KEY(hek) + len) = '\0'; HEK_LEN(hek) = len; HEK_HASH(hek) = hash; + HEK_UTF8(hek) = (char)is_utf8; return hek; } void Perl_unshare_hek(pTHX_ HEK *hek) { - unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek)); + unsharepvn(HEK_KEY(hek),HEK_UTF8(hek)?-HEK_LEN(hek):HEK_LEN(hek), + HEK_HASH(hek)); } #if defined(USE_ITHREADS) @@ -112,9 +119,9 @@ Perl_he_dup(pTHX_ HE *e, bool shared) if (HeKLEN(e) == HEf_SVKEY) HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e))); else if (shared) - HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN(e), HeHASH(e)); + HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e)); else - HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN(e), HeHASH(e)); + HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e)); HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e))); return ret; } @@ -138,19 +145,24 @@ information on how to use this function on tied hashes. */ SV** -Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval) +Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval) { register XPVHV* xhv; register U32 hash; register HE *entry; SV *sv; + bool is_utf8 = FALSE; if (!hv) return 0; + if (klen < 0) { + klen = -klen; + is_utf8 = TRUE; + } + if (SvRMAGICAL(hv)) { if (mg_find((SV*)hv,'P')) { - dTHR; sv = sv_newmortal(); mg_copy((SV*)hv, sv, key, klen); PL_hv_fetch_sv = sv; @@ -194,6 +206,8 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval) continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; return &HeVAL(entry); } #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */ @@ -209,7 +223,7 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval) #endif if (lval) { /* gonna assign to this, so it better be there */ sv = NEWSV(61,0); - return hv_store(hv,key,klen,sv,hash); + return hv_store(hv,key,is_utf8?-klen:klen,sv,hash); } return 0; } @@ -241,13 +255,13 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) STRLEN klen; register HE *entry; SV *sv; + bool is_utf8; if (!hv) return 0; if (SvRMAGICAL(hv)) { if (mg_find((SV*)hv,'P')) { - dTHR; sv = sv_newmortal(); keysv = sv_2mortal(newSVsv(keysv)); mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY); @@ -291,6 +305,7 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) } key = SvPV(keysv, klen); + is_utf8 = (SvUTF8(keysv)!=0); if (!hash) PERL_HASH(hash, key, klen); @@ -303,6 +318,8 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; return entry; } #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */ @@ -361,16 +378,22 @@ information on how to use this function on tied hashes. */ SV** -Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 hash) +Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 hash) { register XPVHV* xhv; register I32 i; register HE *entry; register HE **oentry; + bool is_utf8 = FALSE; if (!hv) return 0; + if (klen < 0) { + klen = -klen; + is_utf8 = TRUE; + } + xhv = (XPVHV*)SvANY(hv); if (SvMAGICAL(hv)) { bool needs_copy; @@ -406,6 +429,8 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 has continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; SvREFCNT_dec(HeVAL(entry)); HeVAL(entry) = val; return &HeVAL(entry); @@ -413,9 +438,9 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 has entry = new_HE(); if (HvSHAREKEYS(hv)) - HeKEY_hek(entry) = share_hek(key, klen, hash); + HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash); else /* gotta do the real thing */ - HeKEY_hek(entry) = save_hek(key, klen, hash); + HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash); HeVAL(entry) = val; HeNEXT(entry) = *oentry; *oentry = entry; @@ -458,13 +483,13 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash) register I32 i; register HE *entry; register HE **oentry; + bool is_utf8; if (!hv) return 0; xhv = (XPVHV*)SvANY(hv); if (SvMAGICAL(hv)) { - dTHR; bool needs_copy; bool needs_store; hv_magic_check (hv, &needs_copy, &needs_store); @@ -489,6 +514,7 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash) } key = SvPV(keysv, klen); + is_utf8 = (SvUTF8(keysv) != 0); if (!hash) PERL_HASH(hash, key, klen); @@ -507,6 +533,8 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash) continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; SvREFCNT_dec(HeVAL(entry)); HeVAL(entry) = val; return entry; @@ -514,9 +542,9 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash) entry = new_HE(); if (HvSHAREKEYS(hv)) - HeKEY_hek(entry) = share_hek(key, klen, hash); + HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash); else /* gotta do the real thing */ - HeKEY_hek(entry) = save_hek(key, klen, hash); + HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash); HeVAL(entry) = val; HeNEXT(entry) = *oentry; *oentry = entry; @@ -543,7 +571,7 @@ will be returned. */ SV * -Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags) +Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags) { register XPVHV* xhv; register I32 i; @@ -552,9 +580,14 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags) register HE **oentry; SV **svp; SV *sv; + bool is_utf8 = FALSE; if (!hv) return Nullsv; + if (klen < 0) { + klen = -klen; + is_utf8 = TRUE; + } if (SvRMAGICAL(hv)) { bool needs_copy; bool needs_store; @@ -594,6 +627,8 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags) continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; *oentry = HeNEXT(entry); if (i && !*oentry) xhv->xhv_fill--; @@ -634,6 +669,7 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) register HE *entry; register HE **oentry; SV *sv; + bool is_utf8; if (!hv) return Nullsv; @@ -667,6 +703,7 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) return Nullsv; key = SvPV(keysv, klen); + is_utf8 = (SvUTF8(keysv) != 0); if (!hash) PERL_HASH(hash, key, klen); @@ -681,6 +718,8 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; *oentry = HeNEXT(entry); if (i && !*oentry) xhv->xhv_fill--; @@ -710,19 +749,24 @@ C<klen> is the length of the key. */ bool -Perl_hv_exists(pTHX_ HV *hv, const char *key, U32 klen) +Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen) { register XPVHV* xhv; register U32 hash; register HE *entry; SV *sv; + bool is_utf8 = FALSE; if (!hv) return 0; + if (klen < 0) { + klen = -klen; + is_utf8 = TRUE; + } + if (SvRMAGICAL(hv)) { if (mg_find((SV*)hv,'P')) { - dTHR; sv = sv_newmortal(); mg_copy((SV*)hv, sv, key, klen); magic_existspack(sv, mg_find(sv, 'p')); @@ -756,6 +800,8 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, U32 klen) continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; return TRUE; } #ifdef DYNAMIC_ENV_FETCH /* is it out there? */ @@ -792,13 +838,13 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) STRLEN klen; register HE *entry; SV *sv; + bool is_utf8; if (!hv) return 0; if (SvRMAGICAL(hv)) { if (mg_find((SV*)hv,'P')) { - dTHR; /* just for SvTRUE */ sv = sv_newmortal(); keysv = sv_2mortal(newSVsv(keysv)); mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY); @@ -822,6 +868,7 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) #endif key = SvPV(keysv, klen); + is_utf8 = (SvUTF8(keysv) != 0); if (!hash) PERL_HASH(hash, key, klen); @@ -837,6 +884,8 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; return TRUE; } #ifdef DYNAMIC_ENV_FETCH /* is it out there? */ @@ -1051,8 +1100,8 @@ Perl_newHVhv(pTHX_ HV *ohv) /* Slow way */ hv_iterinit(ohv); while ((entry = hv_iternext(ohv))) { - hv_store(hv, HeKEY(entry), HeKLEN(entry), - SvREFCNT_inc(HeVAL(entry)), HeHASH(entry)); + hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry), + newSVsv(HeVAL(entry)), HeHASH(entry)); } HvRITER(ohv) = hv_riter; HvEITER(ohv) = hv_eiter; @@ -1342,10 +1391,9 @@ Perl_hv_iterkeysv(pTHX_ register HE *entry) { if (HeKLEN(entry) == HEf_SVKEY) return sv_mortalcopy(HeKEY_sv(entry)); - else { + else return sv_2mortal(newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""), - HeKLEN(entry), HeHASH(entry))); - } + HeKLEN_UTF8(entry), HeHASH(entry))); } /* @@ -1422,6 +1470,12 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash) register HE **oentry; register I32 i = 1; I32 found = 0; + bool is_utf8 = FALSE; + + if (len < 0) { + len = -len; + is_utf8 = TRUE; + } /* what follows is the moral equivalent of: if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) { @@ -1439,6 +1493,8 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash) continue; if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; found = 1; if (--HeVAL(entry) == Nullsv) { *oentry = HeNEXT(entry); @@ -1452,11 +1508,8 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash) } UNLOCK_STRTAB_MUTEX; - { - dTHR; - if (!found && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str); - } + if (!found && ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str); } /* get a (constant) string ptr from the global string table @@ -1471,6 +1524,12 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash) register HE **oentry; register I32 i = 1; I32 found = 0; + bool is_utf8 = FALSE; + + if (len < 0) { + len = -len; + is_utf8 = TRUE; + } /* what follows is the moral equivalent of: @@ -1488,12 +1547,14 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash) continue; if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ continue; + if (HeKUTF8(entry) != (char)is_utf8) + continue; found = 1; break; } if (!found) { entry = new_HE(); - HeKEY_hek(entry) = save_hek(str, len, hash); + HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash); HeVAL(entry) = Nullsv; HeNEXT(entry) = *oentry; *oentry = entry; @@ -1,6 +1,6 @@ /* hv.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -151,6 +151,8 @@ C<SV*>. #define HeKEY(he) HEK_KEY(HeKEY_hek(he)) #define HeKEY_sv(he) (*(SV**)HeKEY(he)) #define HeKLEN(he) HEK_LEN(HeKEY_hek(he)) +#define HeKUTF8(he) HEK_UTF8(HeKEY_hek(he)) +#define HeKLEN_UTF8(he) (HeKUTF8(he) ? -HeKLEN(he) : HeKLEN(he)) #define HeVAL(he) (he)->hent_val #define HeHASH(he) HEK_HASH(HeKEY_hek(he)) #define HePV(he,lp) ((HeKLEN(he) == HEf_SVKEY) ? \ @@ -175,6 +177,7 @@ C<SV*>. #define HEK_HASH(hek) (hek)->hek_hash #define HEK_LEN(hek) (hek)->hek_len #define HEK_KEY(hek) (hek)->hek_key +#define HEK_UTF8(hek) (*(HEK_KEY(hek)+HEK_LEN(hek))) /* calculate HV array allocation */ #if defined(STRANGE_MALLOC) || defined(MYMALLOC) diff --git a/installhtml b/installhtml index bef35e9099..b5406c5691 100755 --- a/installhtml +++ b/installhtml @@ -1,9 +1,8 @@ -#!./perl -w +#!./perl -Ilib -w # This file should really be extracted from a .PL file -use lib 'lib'; # use source library if present - +use strict; use Config; # for config options in the makefile use Getopt::Long; # for command-line parsing use Cwd; @@ -110,6 +109,8 @@ Chris Hall E<lt>hallc@cs.colorado.eduE<gt> =cut +my $usage; + $usage =<<END_OF_USAGE; Usage: $0 --help --podpath=<name>:...:<name> --podroot=<name> --htmldir=<name> --htmlroot=<name> --norecurse --recurse @@ -142,6 +143,9 @@ Usage: $0 --help --podpath=<name>:...:<name> --podroot=<name> END_OF_USAGE +my (@libpods, @podpath, $podroot, $htmldir, $htmlroot, $recurse, @splithead, + @splititem, $splitpod, $verbose, $pod2html); + @libpods = (); @podpath = ( "." ); # colon-separated list of directories containing .pod # and .pm files to be converted. @@ -163,8 +167,12 @@ usage("") unless @ARGV; # See vms/descrip_mms.template -> descrip.mms for invokation. if ( $^O eq 'VMS' ) { @ARGV = split(/\s+/,$ARGV[0]); } +use vars qw($opt_htmldir $opt_htmlroot $opt_podroot $opt_splitpod + $opt_verbose $opt_help $opt_podpath $opt_splithead $opt_splititem + $opt_libpods $opt_recurse); + # parse the command-line -$result = GetOptions( qw( +my $result = GetOptions( qw( help podpath=s podroot=s @@ -196,8 +204,8 @@ $splitpod = "$podroot/pod" unless $splitpod; # ignored in the conversion process. these are files that have been # process by splititem or splithead and should not be converted as a # result. -@ignore = (); - +my @ignore = (); +my @splitdirs; # split pods. its important to do this before convert ANY pods because # it may effect some of the links @@ -209,25 +217,25 @@ split_on_item($podroot, \@splitdirs, \@ignore, @splititem); # convert the pod pages found in @poddirs #warn "converting files\n" if $verbose; #warn "\@ignore\t= @ignore\n" if $verbose; -foreach $dir (@podpath) { +foreach my $dir (@podpath) { installdir($dir, $recurse, $podroot, \@splitdirs, \@ignore); } # now go through and create master indices for each pod we split -foreach $dir (@splititem) { +foreach my $dir (@splititem) { print "creating index $htmldir/$dir.html\n" if $verbose; create_index("$htmldir/$dir.html", "$htmldir/$dir"); } -foreach $dir (@splithead) { +foreach my $dir (@splithead) { $dir .= ".pod" unless $dir =~ /(\.pod|\.pm)$/; # let pod2html create the file runpod2html($dir, 1); # now go through and truncate after the index $dir =~ /^(.*?)(\.pod|\.pm)?$/sm; - $file = "$htmldir/$1"; + my $file = "$htmldir/$1"; print "creating index $file.html\n" if $verbose; # read in everything until what would have been the first =head @@ -235,7 +243,7 @@ foreach $dir (@splithead) { open(H, "<$file.html") || die "$0: error opening $file.html for input: $!\n"; $/ = ""; - @data = (); + my @data = (); while (<H>) { last if /NAME=/; $_ =~ s{HREF="#(.*)">}{ @@ -251,7 +259,7 @@ foreach $dir (@splithead) { # now rewrite the file open(H, ">$file.html") || die "$0: error opening $file.html for output: $!\n"; - print H "@data\n"; + print H "@data", "\n"; close(H); } @@ -322,6 +330,7 @@ sub create_index { close(IN); # pull out the NAME section + my $name; ($name) = grep(/NAME=/, @filedata); ($lcp1,$lcp2) = ($name =~ m,/H1>\s(\S+)\s[\s-]*(.*?)\s*$,sm); if (defined $lcp1 and $lcp1 eq '<P>') { # Uninteresting. Try again. @@ -383,7 +392,7 @@ sub split_on_item { print "splitting files by item.\n" if $verbose && $#splititem >= 0; $pwd = getcwd(); my $splitter = absolute_path($pwd, "$splitpod/splitpod"); - foreach $pod (@splititem) { + foreach my $pod (@splititem) { # figure out the directory to split into $pod =~ s,^([^/]*)$,/$1,; $pod =~ m,(.*?)/(.*?)(\.pod)?$,; @@ -443,7 +452,7 @@ sub splitpod { # create list of =head[1-6] sections so that we can rewrite # L<> links as necessary. - %heads = (); + my %heads = (); foreach $i (0..$#poddata) { $heads{htmlize($1)} = 1 if $poddata[$i] =~ /=head[1-6]\s+(.*)/; } @@ -451,7 +460,7 @@ sub splitpod { # create a directory of a similar name and store all the # files in there $pod =~ s,.*/(.*),$1,; # get the last part of the name - $dir = $pod; + my $dir = $pod; $dir =~ s/\.pod//g; push(@$splitdirs, "$poddir/$dir"); mkdir("$poddir/$dir", 0755) || @@ -538,7 +547,7 @@ sub installdir { } # install all the pods we found - foreach $pod (@podlist) { + foreach my $pod (@podlist) { # check if we should ignore it. next if grep($_ eq "$podroot/$pod.pod", @$ignore); @@ -552,7 +561,7 @@ sub installdir { } # install all the .pm files we found - foreach $pm (@pmlist) { + foreach my $pm (@pmlist) { # check if we should ignore it. next if grep($_ eq "$pm.pm", @ignore); diff --git a/installman b/installman index 72c76fd8a2..06f68f5ddd 100755 --- a/installman +++ b/installman @@ -23,19 +23,21 @@ die "Patchlevel of perl ($patchlevel)", my $usage = "Usage: installman --man1dir=/usr/wherever --man1ext=1 --man3dir=/usr/wherever --man3ext=3 + --batchlimit=40 --notify --verbose --silent --help Defaults are: man1dir = $Config{'installman1dir'}; man1ext = $Config{'man1ext'}; man3dir = $Config{'installman3dir'}; man3ext = $Config{'man3ext'}; + batchlimit is maximum number of pod files per invocation of pod2man --notify (or -n) just lists commands that would be executed. --verbose (or -V) report all progress. --silent (or -S) be silent. Only report errors.\n"; my %opts; GetOptions( \%opts, - qw( man1dir=s man1ext=s man3dir=s man3ext=s + qw( man1dir=s man1ext=s man3dir=s man3ext=s batchlimit=i notify n help silent S verbose V)) || die $usage; die $usage if $opts{help}; @@ -48,6 +50,7 @@ $opts{man3dir} = $Config{'installman3dir'} unless defined($opts{man3dir}); $opts{man3ext} = $Config{'man3ext'} unless defined($opts{man3ext}); +$opts{batchlimit} ||= 40; $opts{silent} ||= $opts{S}; $opts{notify} ||= $opts{n}; $opts{verbose} ||= $opts{V} || $opts{notify}; @@ -71,24 +74,12 @@ runpod2man('pod', $opts{man1dir}, $opts{man1ext}); runpod2man('lib', $opts{man3dir}, $opts{man3ext}); # Install the pods embedded in the installed scripts -runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'c2ph'); -runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'h2ph'); -runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'h2xs'); -runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'perlcc'); -runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'perldoc'); -runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'perlbug'); -runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'pl2pm'); -runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'splain'); -runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'dprofpp'); -runpod2man('x2p', $opts{man1dir}, $opts{man1ext}, 's2p'); -runpod2man('x2p', $opts{man1dir}, $opts{man1ext}, 'a2p.pod'); -runpod2man('x2p', $opts{man1dir}, $opts{man1ext}, 'find2perl'); -runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2man'); -runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2html'); -runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2text'); -runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2usage'); -runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'podchecker'); -runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'podselect'); +runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'c2ph', 'h2ph', 'h2xs', + 'perlcc', 'perldoc', 'perlbug', 'pl2pm', 'splain', 'dprofpp'); +runpod2man('x2p', $opts{man1dir}, $opts{man1ext}, 's2p', 'a2p.pod', + 'find2perl'); +runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2man', 'pod2html', + 'pod2text', 'pod2usage', 'podchecker', 'podselect'); # It would probably be better to have this page linked # to the c2ph man page. Or, this one could say ".so man1/c2ph.1", @@ -98,9 +89,9 @@ runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'pstruct'); runpod2man('lib/ExtUtils', $opts{man1dir}, $opts{man1ext}, 'xsubpp'); sub runpod2man { - # $script is script name if we are installing a manpage embedded - # in a script, undef otherwise - my($poddir, $mandir, $manext, $script) = @_; + # @script is scripts names if we are installing manpages embedded + # in scripts, () otherwise + my($poddir, $mandir, $manext, @script) = @_; my($downdir); # can't just use .. when installing xsubpp manpage @@ -109,8 +100,12 @@ sub runpod2man { my($builddir) = Cwd::getcwd(); if ($mandir eq ' ' or $mandir eq '') { - warn "Skipping installation of ", - ($script ? "$poddir/$script man page" : "$poddir man pages"), ".\n"; + if (@script) { + warn "Skipping installation of $poddir/$_ man page.\n" + foreach @script; + } else { + warn "Skipping installation of $poddir man pages.\n"; + } return; } @@ -134,13 +129,14 @@ sub runpod2man { # Make a list of all the .pm and .pod files in the directory. We will # always run pod2man from the lib directory and feed it the full pathname # of the pod. This might be useful for pod2man someday. - if ($script) { - @modpods = ($script); + if (@script) { + @modpods = @script; } else { @modpods = (); File::Find::find(\&lsmodpods, '.'); } + my @to_process; foreach my $mod (@modpods) { my $manpage = $mod; my $tmp; @@ -159,15 +155,25 @@ sub runpod2man { } $tmp = "${mandir}/${manpage}.tmp"; $manpage = "${mandir}/${manpage}.${manext}"; - if (&cmd("$pod2man $mod > $tmp") == 0 && !$opts{notify} && -s $tmp) { - if (rename($tmp, $manpage)) { - $packlist->{$manpage} = { type => 'file' }; - next; + push @to_process, [$mod, $tmp, $manpage]; + } + # Don't do all pods in same command to avoid busting command line limits + while (my @this_batch = splice @to_process, 0, $opts{batchlimit}) { + my $cmd = join " ", $pod2man, map "$$_[0] $$_[1]", @this_batch; + if (&cmd($cmd) == 0 && !$opts{notify}) { + foreach (@this_batch) { + my (undef, $tmp, $manpage) = @$_; + if (-s $tmp) { + if (rename($tmp, $manpage)) { + $packlist->{$manpage} = { type => 'file' }; + next; + } + } + unless ($opts{notify}) { + unlink($tmp); + } } } - unless ($opts{notify}) { - unlink($tmp); - } } chdir "$builddir" || die "Unable to cd back to $builddir directory!\n$!\n"; print " chdir $builddir\n" if $opts{verbose}; diff --git a/installperl b/installperl index 99d376fd2c..f3788cf943 100755 --- a/installperl +++ b/installperl @@ -162,8 +162,8 @@ if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; } -x 'suidperl' . $exe_ext|| die "suidperl isn't executable!\n" if $d_dosuid; -f 't/rantests' || $Is_W32 - || warn "WARNING: You've never run 'make test'!!!", - " (Installing anyway.)\n"; + || warn "WARNING: You've never run 'make test' or", + " some tests failed! (Installing anyway.)\n"; if ($Is_W32 or $Is_Cygwin) { my $perldll; diff --git a/intrpvar.h b/intrpvar.h index 07ec33ede6..e9c3797be7 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -97,7 +97,7 @@ C<PL_DBsingle>. =for apidoc Amn|SV *|PL_DBsingle When Perl is run in debugging mode, with the B<-d> switch, this SV is a -boolean which indicates whether subs are being single-stepped. +boolean which indicates whether subs are being single-stepped. Single-stepping is automatically turned on after every step. This is the C variable which corresponds to Perl's $DB::single variable. See C<PL_DBsub>. @@ -169,8 +169,7 @@ PERLVARI(Ilaststype, I32, OP_STAT) PERLVAR(Imess_sv, SV *) /* XXX shouldn't these be per-thread? --GSAR */ -PERLVAR(Iors, char *) /* output record separator $\ */ -PERLVAR(Iorslen, STRLEN) +PERLVAR(Iors_sv, SV *) /* output record separator $\ */ PERLVAR(Iofmt, char *) /* output format for numbers $# */ /* interpreter atexit processing */ @@ -181,10 +180,10 @@ PERLVARI(Iexitlistlen, I32, 0) /* length of same */ /* =for apidoc Amn|HV*|PL_modglobal -C<PL_modglobal> is a general purpose, interpreter global HV for use by +C<PL_modglobal> is a general purpose, interpreter global HV for use by extensions that need to keep information on a per-interpreter basis. -In a pinch, it can also be used as a symbol table for extensions -to share data among each other. It is a good idea to use keys +In a pinch, it can also be used as a symbol table for extensions +to share data among each other. It is a good idea to use keys prefixed by the package name of the extension that owns the data. =cut diff --git a/iperlsys.h b/iperlsys.h index 59da4748cb..fe03f5c53b 100644 --- a/iperlsys.h +++ b/iperlsys.h @@ -49,30 +49,11 @@ * */ - /* - Interface for perl stdio functions -*/ - - -/* Clean up (or at least document) the various possible #defines. - This section attempts to match the 5.003_03 Configure variables - onto the 5.003_02 header file values. - I can't figure out where USE_STDIO was supposed to be set. - --AD + Interface for perl stdio functions, or whatever we are Configure-d + to use. */ -#ifndef USE_PERLIO -# define PERLIO_IS_STDIO -#endif - -/* Below is the 5.003_02 stuff. */ -#ifdef USE_STDIO -# ifndef PERLIO_IS_STDIO -# define PERLIO_IS_STDIO -# endif -#else -extern void PerlIO_init (void); -#endif +#include "perlio.h" #ifndef Sighandler_t typedef Signal_t (*Sighandler_t) (int); @@ -80,60 +61,54 @@ typedef Signal_t (*Sighandler_t) (int); #if defined(PERL_IMPLICIT_SYS) -#ifndef PerlIO -typedef struct _PerlIO PerlIO; -#endif - /* IPerlStdIO */ struct IPerlStdIO; struct IPerlStdIOInfo; -typedef PerlIO* (*LPStdin)(struct IPerlStdIO*); -typedef PerlIO* (*LPStdout)(struct IPerlStdIO*); -typedef PerlIO* (*LPStderr)(struct IPerlStdIO*); -typedef PerlIO* (*LPOpen)(struct IPerlStdIO*, const char*, +typedef FILE* (*LPStdin)(struct IPerlStdIO*); +typedef FILE* (*LPStdout)(struct IPerlStdIO*); +typedef FILE* (*LPStderr)(struct IPerlStdIO*); +typedef FILE* (*LPOpen)(struct IPerlStdIO*, const char*, const char*); -typedef int (*LPClose)(struct IPerlStdIO*, PerlIO*); -typedef int (*LPEof)(struct IPerlStdIO*, PerlIO*); -typedef int (*LPError)(struct IPerlStdIO*, PerlIO*); -typedef void (*LPClearerr)(struct IPerlStdIO*, PerlIO*); -typedef int (*LPGetc)(struct IPerlStdIO*, PerlIO*); -typedef char* (*LPGetBase)(struct IPerlStdIO*, PerlIO*); -typedef int (*LPGetBufsiz)(struct IPerlStdIO*, PerlIO*); -typedef int (*LPGetCnt)(struct IPerlStdIO*, PerlIO*); -typedef char* (*LPGetPtr)(struct IPerlStdIO*, PerlIO*); -typedef char* (*LPGets)(struct IPerlStdIO*, PerlIO*, char*, int); -typedef int (*LPPutc)(struct IPerlStdIO*, PerlIO*, int); -typedef int (*LPPuts)(struct IPerlStdIO*, PerlIO*, const char*); -typedef int (*LPFlush)(struct IPerlStdIO*, PerlIO*); -typedef int (*LPUngetc)(struct IPerlStdIO*, PerlIO*,int); -typedef int (*LPFileno)(struct IPerlStdIO*, PerlIO*); -typedef PerlIO* (*LPFdopen)(struct IPerlStdIO*, int, const char*); -typedef PerlIO* (*LPReopen)(struct IPerlStdIO*, const char*, - const char*, PerlIO*); -typedef SSize_t (*LPRead)(struct IPerlStdIO*, PerlIO*, void*, Size_t); -typedef SSize_t (*LPWrite)(struct IPerlStdIO*, PerlIO*, const void*, +typedef int (*LPClose)(struct IPerlStdIO*, FILE*); +typedef int (*LPEof)(struct IPerlStdIO*, FILE*); +typedef int (*LPError)(struct IPerlStdIO*, FILE*); +typedef void (*LPClearerr)(struct IPerlStdIO*, FILE*); +typedef int (*LPGetc)(struct IPerlStdIO*, FILE*); +typedef char* (*LPGetBase)(struct IPerlStdIO*, FILE*); +typedef int (*LPGetBufsiz)(struct IPerlStdIO*, FILE*); +typedef int (*LPGetCnt)(struct IPerlStdIO*, FILE*); +typedef char* (*LPGetPtr)(struct IPerlStdIO*, FILE*); +typedef char* (*LPGets)(struct IPerlStdIO*, FILE*, char*, int); +typedef int (*LPPutc)(struct IPerlStdIO*, FILE*, int); +typedef int (*LPPuts)(struct IPerlStdIO*, FILE*, const char*); +typedef int (*LPFlush)(struct IPerlStdIO*, FILE*); +typedef int (*LPUngetc)(struct IPerlStdIO*, int,FILE*); +typedef int (*LPFileno)(struct IPerlStdIO*, FILE*); +typedef FILE* (*LPFdopen)(struct IPerlStdIO*, int, const char*); +typedef FILE* (*LPReopen)(struct IPerlStdIO*, const char*, + const char*, FILE*); +typedef SSize_t (*LPRead)(struct IPerlStdIO*, void*, Size_t, Size_t, FILE *); +typedef SSize_t (*LPWrite)(struct IPerlStdIO*, const void*, Size_t, Size_t, FILE *); +typedef void (*LPSetBuf)(struct IPerlStdIO*, FILE*, char*); +typedef int (*LPSetVBuf)(struct IPerlStdIO*, FILE*, char*, int, Size_t); -typedef void (*LPSetBuf)(struct IPerlStdIO*, PerlIO*, char*); -typedef int (*LPSetVBuf)(struct IPerlStdIO*, PerlIO*, char*, int, - Size_t); -typedef void (*LPSetCnt)(struct IPerlStdIO*, PerlIO*, int); -typedef void (*LPSetPtrCnt)(struct IPerlStdIO*, PerlIO*, char*, - int); -typedef void (*LPSetlinebuf)(struct IPerlStdIO*, PerlIO*); -typedef int (*LPPrintf)(struct IPerlStdIO*, PerlIO*, const char*, +typedef void (*LPSetCnt)(struct IPerlStdIO*, FILE*, int); +typedef void (*LPSetPtr)(struct IPerlStdIO*, FILE*, char*); +typedef void (*LPSetlinebuf)(struct IPerlStdIO*, FILE*); +typedef int (*LPPrintf)(struct IPerlStdIO*, FILE*, const char*, ...); -typedef int (*LPVprintf)(struct IPerlStdIO*, PerlIO*, const char*, +typedef int (*LPVprintf)(struct IPerlStdIO*, FILE*, const char*, va_list); -typedef long (*LPTell)(struct IPerlStdIO*, PerlIO*); -typedef int (*LPSeek)(struct IPerlStdIO*, PerlIO*, Off_t, int); -typedef void (*LPRewind)(struct IPerlStdIO*, PerlIO*); -typedef PerlIO* (*LPTmpfile)(struct IPerlStdIO*); -typedef int (*LPGetpos)(struct IPerlStdIO*, PerlIO*, Fpos_t*); -typedef int (*LPSetpos)(struct IPerlStdIO*, PerlIO*, +typedef long (*LPTell)(struct IPerlStdIO*, FILE*); +typedef int (*LPSeek)(struct IPerlStdIO*, FILE*, Off_t, int); +typedef void (*LPRewind)(struct IPerlStdIO*, FILE*); +typedef FILE* (*LPTmpfile)(struct IPerlStdIO*); +typedef int (*LPGetpos)(struct IPerlStdIO*, FILE*, Fpos_t*); +typedef int (*LPSetpos)(struct IPerlStdIO*, FILE*, const Fpos_t*); typedef void (*LPInit)(struct IPerlStdIO*); typedef void (*LPInitOSExtras)(struct IPerlStdIO*); -typedef PerlIO* (*LPFdupopen)(struct IPerlStdIO*, PerlIO*); +typedef FILE* (*LPFdupopen)(struct IPerlStdIO*, FILE*); struct IPerlStdIO { @@ -163,7 +138,7 @@ struct IPerlStdIO LPSetBuf pSetBuf; LPSetVBuf pSetVBuf; LPSetCnt pSetCnt; - LPSetPtrCnt pSetPtrCnt; + LPSetPtr pSetPtr; LPSetlinebuf pSetlinebuf; LPPrintf pPrintf; LPVprintf pVprintf; @@ -184,297 +159,181 @@ struct IPerlStdIOInfo struct IPerlStdIO perlStdIOList; }; +/* These do not belong here ... NI-S, 14 Nov 2000 */ + #ifdef USE_STDIO_PTR -# define PerlIO_has_cntptr(f) 1 -# ifdef STDIO_CNT_LVALUE -# define PerlIO_canset_cnt(f) 1 -# ifdef STDIO_PTR_LVALUE -# define PerlIO_fast_gets(f) 1 +# define PerlSIO_has_cntptr(f) 1 +# ifdef STDIO_PTR_LVALUE +# ifdef STDIO_CNT_LVALUE +# define PerlSIO_canset_cnt(f) 1 +# ifdef STDIO_PTR_LVAL_NOCHANGE_CNT +# define PerlSIO_fast_gets(f) 1 +# endif +# else /* STDIO_CNT_LVALUE */ +# define PerlSIO_canset_cnt(f) 0 +# endif +# else /* STDIO_PTR_LVALUE */ +# ifdef STDIO_PTR_LVAL_SETS_CNT +# define PerlSIO_fast_gets(f) 1 # endif -# else -# define PerlIO_canset_cnt(f) 0 # endif #else /* USE_STDIO_PTR */ -# define PerlIO_has_cntptr(f) 0 -# define PerlIO_canset_cnt(f) 0 +# define PerlSIO_has_cntptr(f) 0 +# define PerlSIO_canset_cnt(f) 0 #endif /* USE_STDIO_PTR */ -#ifndef PerlIO_fast_gets -#define PerlIO_fast_gets(f) 0 +#ifndef PerlSIO_fast_gets +#define PerlSIO_fast_gets(f) 0 #endif #ifdef FILE_base -#define PerlIO_has_base(f) 1 +#define PerlSIO_has_base(f) 1 #else -#define PerlIO_has_base(f) 0 +#define PerlSIO_has_base(f) 0 #endif -#define PerlIO_stdin() \ +/* Now take FILE * via function table */ + +#define PerlSIO_stdin \ (*PL_StdIO->pStdin)(PL_StdIO) -#define PerlIO_stdout() \ +#define PerlSIO_stdout \ (*PL_StdIO->pStdout)(PL_StdIO) -#define PerlIO_stderr() \ +#define PerlSIO_stderr \ (*PL_StdIO->pStderr)(PL_StdIO) -#define PerlIO_open(x,y) \ +#define PerlSIO_fopen(x,y) \ (*PL_StdIO->pOpen)(PL_StdIO, (x),(y)) -#define PerlIO_close(f) \ +#define PerlSIO_fclose(f) \ (*PL_StdIO->pClose)(PL_StdIO, (f)) -#define PerlIO_eof(f) \ +#define PerlSIO_feof(f) \ (*PL_StdIO->pEof)(PL_StdIO, (f)) -#define PerlIO_error(f) \ +#define PerlSIO_ferror(f) \ (*PL_StdIO->pError)(PL_StdIO, (f)) -#define PerlIO_clearerr(f) \ +#define PerlSIO_clearerr(f) \ (*PL_StdIO->pClearerr)(PL_StdIO, (f)) -#define PerlIO_getc(f) \ +#define PerlSIO_fgetc(f) \ (*PL_StdIO->pGetc)(PL_StdIO, (f)) -#define PerlIO_get_base(f) \ +#define PerlSIO_get_base(f) \ (*PL_StdIO->pGetBase)(PL_StdIO, (f)) -#define PerlIO_get_bufsiz(f) \ +#define PerlSIO_get_bufsiz(f) \ (*PL_StdIO->pGetBufsiz)(PL_StdIO, (f)) -#define PerlIO_get_cnt(f) \ +#define PerlSIO_get_cnt(f) \ (*PL_StdIO->pGetCnt)(PL_StdIO, (f)) -#define PerlIO_get_ptr(f) \ +#define PerlSIO_get_ptr(f) \ (*PL_StdIO->pGetPtr)(PL_StdIO, (f)) -#define PerlIO_putc(f,c) \ +#define PerlSIO_fputc(f,c) \ (*PL_StdIO->pPutc)(PL_StdIO, (f),(c)) -#define PerlIO_puts(f,s) \ +#define PerlSIO_fputs(f,s) \ (*PL_StdIO->pPuts)(PL_StdIO, (f),(s)) -#define PerlIO_flush(f) \ +#define PerlSIO_fflush(f) \ (*PL_StdIO->pFlush)(PL_StdIO, (f)) -#define PerlIO_gets(s, n, fp) \ +#define PerlSIO_fgets(s, n, fp) \ (*PL_StdIO->pGets)(PL_StdIO, (fp), s, n) -#define PerlIO_ungetc(f,c) \ - (*PL_StdIO->pUngetc)(PL_StdIO, (f),(c)) -#define PerlIO_fileno(f) \ +#define PerlSIO_ungetc(c,f) \ + (*PL_StdIO->pUngetc)(PL_StdIO, (c),(f)) +#define PerlSIO_fileno(f) \ (*PL_StdIO->pFileno)(PL_StdIO, (f)) -#define PerlIO_fdopen(f, s) \ +#define PerlSIO_fdopen(f, s) \ (*PL_StdIO->pFdopen)(PL_StdIO, (f),(s)) -#define PerlIO_reopen(p, m, f) \ +#define PerlSIO_freopen(p, m, f) \ (*PL_StdIO->pReopen)(PL_StdIO, (p), (m), (f)) -#define PerlIO_read(f,buf,count) \ - (SSize_t)(*PL_StdIO->pRead)(PL_StdIO, (f), (buf), (count)) -#define PerlIO_write(f,buf,count) \ - (*PL_StdIO->pWrite)(PL_StdIO, (f), (buf), (count)) -#define PerlIO_setbuf(f,b) \ +#define PerlSIO_fread(buf,sz,count,f) \ + (*PL_StdIO->pRead)(PL_StdIO, (buf), (sz), (count), (f)) +#define PerlSIO_fwrite(buf,sz,count,f) \ + (*PL_StdIO->pWrite)(PL_StdIO, (buf), (sz), (count), (f)) +#define PerlSIO_setbuf(f,b) \ (*PL_StdIO->pSetBuf)(PL_StdIO, (f), (b)) -#define PerlIO_setvbuf(f,b,t,s) \ +#define PerlSIO_setvbuf(f,b,t,s) \ (*PL_StdIO->pSetVBuf)(PL_StdIO, (f),(b),(t),(s)) -#define PerlIO_set_cnt(f,c) \ +#define PerlSIO_set_cnt(f,c) \ (*PL_StdIO->pSetCnt)(PL_StdIO, (f), (c)) -#define PerlIO_set_ptrcnt(f,p,c) \ - (*PL_StdIO->pSetPtrCnt)(PL_StdIO, (f), (p), (c)) -#define PerlIO_setlinebuf(f) \ +#define PerlSIO_set_ptr(f,p) \ + (*PL_StdIO->pSetPtr)(PL_StdIO, (f), (p)) +#define PerlSIO_setlinebuf(f) \ (*PL_StdIO->pSetlinebuf)(PL_StdIO, (f)) -#define PerlIO_printf Perl_fprintf_nocontext -#define PerlIO_stdoutf *PL_StdIO->pPrintf -#define PerlIO_vprintf(f,fmt,a) \ - (*PL_StdIO->pVprintf)(PL_StdIO, (f),(fmt),a) -#define PerlIO_tell(f) \ +#define PerlSIO_printf Perl_fprintf_nocontext +#define PerlSIO_stdoutf *PL_StdIO->pPrintf +#define PerlSIO_vprintf(f,fmt,a) \ + (*PL_StdIO->pVprintf)(PL_StdIO, (f),(fmt),a) +#define PerlSIO_ftell(f) \ (*PL_StdIO->pTell)(PL_StdIO, (f)) -#define PerlIO_seek(f,o,w) \ +#define PerlSIO_fseek(f,o,w) \ (*PL_StdIO->pSeek)(PL_StdIO, (f),(o),(w)) -#define PerlIO_getpos(f,p) \ +#define PerlSIO_fgetpos(f,p) \ (*PL_StdIO->pGetpos)(PL_StdIO, (f),(p)) -#define PerlIO_setpos(f,p) \ +#define PerlSIO_fsetpos(f,p) \ (*PL_StdIO->pSetpos)(PL_StdIO, (f),(p)) -#define PerlIO_rewind(f) \ +#define PerlSIO_rewind(f) \ (*PL_StdIO->pRewind)(PL_StdIO, (f)) -#define PerlIO_tmpfile() \ +#define PerlSIO_tmpfile() \ (*PL_StdIO->pTmpfile)(PL_StdIO) -#define PerlIO_init() \ +#define PerlSIO_init() \ (*PL_StdIO->pInit)(PL_StdIO) #undef init_os_extras #define init_os_extras() \ (*PL_StdIO->pInitOSExtras)(PL_StdIO) -#define PerlIO_fdupopen(f) \ +#define PerlSIO_fdupopen(f) \ (*PL_StdIO->pFdupopen)(PL_StdIO, (f)) #else /* PERL_IMPLICIT_SYS */ -#include "perlsdio.h" -#include "perl.h" -#define PerlIO_fdupopen(f) (f) - -#endif /* PERL_IMPLICIT_SYS */ - -#ifndef PERLIO_IS_STDIO -#ifdef USE_SFIO -#include "perlsfio.h" -#endif /* USE_SFIO */ -#endif /* PERLIO_IS_STDIO */ - -#ifndef EOF -#define EOF (-1) -#endif - -/* This is to catch case with no stdio */ -#ifndef BUFSIZ -#define BUFSIZ 1024 -#endif - -#ifndef SEEK_SET -#define SEEK_SET 0 -#endif - -#ifndef SEEK_CUR -#define SEEK_CUR 1 -#endif - -#ifndef SEEK_END -#define SEEK_END 2 -#endif - -#ifndef PerlIO -struct _PerlIO; -#define PerlIO struct _PerlIO -#endif /* No PerlIO */ - -#ifndef Fpos_t -#define Fpos_t long -#endif - -#ifndef NEXT30_NO_ATTRIBUTE -#ifndef HASATTRIBUTE /* disable GNU-cc attribute checking? */ -#ifdef __attribute__ /* Avoid possible redefinition errors */ -#undef __attribute__ -#endif -#define __attribute__(attr) -#endif -#endif - -#ifndef PerlIO_stdoutf -extern int PerlIO_stdoutf (const char *,...) - __attribute__((__format__ (__printf__, 1, 2))); -#endif -#ifndef PerlIO_puts -extern int PerlIO_puts (PerlIO *,const char *); -#endif -#ifndef PerlIO_open -extern PerlIO * PerlIO_open (const char *,const char *); -#endif -#ifndef PerlIO_close -extern int PerlIO_close (PerlIO *); -#endif -#ifndef PerlIO_eof -extern int PerlIO_eof (PerlIO *); -#endif -#ifndef PerlIO_error -extern int PerlIO_error (PerlIO *); -#endif -#ifndef PerlIO_clearerr -extern void PerlIO_clearerr (PerlIO *); -#endif -#ifndef PerlIO_getc -extern int PerlIO_getc (PerlIO *); -#endif -#ifndef PerlIO_putc -extern int PerlIO_putc (PerlIO *,int); -#endif -#ifndef PerlIO_flush -extern int PerlIO_flush (PerlIO *); -#endif -#ifndef PerlIO_ungetc -extern int PerlIO_ungetc (PerlIO *,int); -#endif -#ifndef PerlIO_fileno -extern int PerlIO_fileno (PerlIO *); -#endif -#ifndef PerlIO_fdopen -extern PerlIO * PerlIO_fdopen (int, const char *); -#endif -#ifndef PerlIO_importFILE -extern PerlIO * PerlIO_importFILE (FILE *,int); -#endif -#ifndef PerlIO_exportFILE -extern FILE * PerlIO_exportFILE (PerlIO *,int); -#endif -#ifndef PerlIO_findFILE -extern FILE * PerlIO_findFILE (PerlIO *); -#endif -#ifndef PerlIO_releaseFILE -extern void PerlIO_releaseFILE (PerlIO *,FILE *); -#endif -#ifndef PerlIO_read -extern SSize_t PerlIO_read (PerlIO *,void *,Size_t); -#endif -#ifndef PerlIO_write -extern SSize_t PerlIO_write (PerlIO *,const void *,Size_t); -#endif -#ifndef PerlIO_setlinebuf -extern void PerlIO_setlinebuf (PerlIO *); -#endif -#ifndef PerlIO_printf -extern int PerlIO_printf (PerlIO *, const char *,...) - __attribute__((__format__ (__printf__, 2, 3))); -#endif -#ifndef PerlIO_sprintf -extern int PerlIO_sprintf (char *, int, const char *,...) - __attribute__((__format__ (__printf__, 3, 4))); -#endif -#ifndef PerlIO_vprintf -extern int PerlIO_vprintf (PerlIO *, const char *, va_list); -#endif -#ifndef PerlIO_tell -extern Off_t PerlIO_tell (PerlIO *); -#endif -#ifndef PerlIO_seek -extern int PerlIO_seek (PerlIO *, Off_t, int); -#endif -#ifndef PerlIO_rewind -extern void PerlIO_rewind (PerlIO *); -#endif -#ifndef PerlIO_has_base -extern int PerlIO_has_base (PerlIO *); -#endif -#ifndef PerlIO_has_cntptr -extern int PerlIO_has_cntptr (PerlIO *); -#endif -#ifndef PerlIO_fast_gets -extern int PerlIO_fast_gets (PerlIO *); -#endif -#ifndef PerlIO_canset_cnt -extern int PerlIO_canset_cnt (PerlIO *); -#endif -#ifndef PerlIO_get_ptr -extern STDCHAR * PerlIO_get_ptr (PerlIO *); -#endif -#ifndef PerlIO_get_cnt -extern int PerlIO_get_cnt (PerlIO *); -#endif -#ifndef PerlIO_set_cnt -extern void PerlIO_set_cnt (PerlIO *,int); -#endif -#ifndef PerlIO_set_ptrcnt -extern void PerlIO_set_ptrcnt (PerlIO *,STDCHAR *,int); -#endif -#ifndef PerlIO_get_base -extern STDCHAR * PerlIO_get_base (PerlIO *); -#endif -#ifndef PerlIO_get_bufsiz -extern int PerlIO_get_bufsiz (PerlIO *); -#endif -#ifndef PerlIO_tmpfile -extern PerlIO * PerlIO_tmpfile (void); -#endif -#ifndef PerlIO_stdin -extern PerlIO * PerlIO_stdin (void); -#endif -#ifndef PerlIO_stdout -extern PerlIO * PerlIO_stdout (void); -#endif -#ifndef PerlIO_stderr -extern PerlIO * PerlIO_stderr (void); -#endif -#ifndef PerlIO_getpos -extern int PerlIO_getpos (PerlIO *,Fpos_t *); -#endif -#ifndef PerlIO_setpos -extern int PerlIO_setpos (PerlIO *,const Fpos_t *); +#define PerlSIO_stdin stdin +#define PerlSIO_stdout stdout +#define PerlSIO_stderr stderr +#define PerlSIO_fopen(x,y) fopen(x,y) +#define PerlSIO_fclose(f) fclose(f) +#define PerlSIO_feof(f) feof(f) +#define PerlSIO_ferror(f) ferror(f) +#define PerlSIO_clearerr(f) clearerr(f) +#define PerlSIO_fgetc(f) fgetc(f) +#if PerlSIO_has_base +#define PerlSIO_get_base(f) FILE_base(f) +#define PerlSIO_get_bufsiz(f) FILE_bufsiz(f) +#else +#define PerlSIO_get_base(f) NULL +#define PerlSIO_get_bufsiz(f) 0 #endif -#ifndef PerlIO_fdupopen -extern PerlIO * PerlIO_fdupopen (PerlIO *); +#ifdef USE_STDIO_PTR +#define PerlSIO_get_cnt(f) FILE_cnt(f) +#define PerlSIO_get_ptr(f) FILE_ptr(f) +#else +#define PerlSIO_get_cnt(f) 0 +#define PerlSIO_get_ptr(f) NULL +#endif +#define PerlSIO_fputc(f,c) fputc(c,f) +#define PerlSIO_fputs(f,s) fputs(s,f) +#define PerlSIO_fflush(f) Fflush(f) +#define PerlSIO_fgets(s, n, fp) fgets(s,n,fp) +#define PerlSIO_ungetc(c,f) ungetc(c,f) +#define PerlSIO_fileno(f) fileno(f) +#define PerlSIO_fdopen(f, s) fdopen(f,s) +#define PerlSIO_freopen(p, m, f) freopen(p,m,f) +#define PerlSIO_fread(buf,sz,count,f) fread(buf,sz,count,f) +#define PerlSIO_fwrite(buf,sz,count,f) fwrite(buf,sz,count,f) +#define PerlSIO_setbuf(f,b) setbuf(f,b) +#define PerlSIO_setvbuf(f,b,t,s) setvbuf(f,b,t,s) +#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) +#define PerlSIO_set_cnt(f,c) FILE_cnt(f) = (c) +#else +#define PerlSIO_set_cnt(f,c) PerlIOProc_abort() #endif +#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) +#define PerlSIO_set_ptr(f,p) FILE_ptr(f) = (p) +#else +#define PerlSIO_set_ptr(f,p) PerlIOProc_abort() +#endif +#define PerlSIO_setlinebuf(f) setlinebuf(f) +#define PerlSIO_printf Perl_fprintf_nocontext +#define PerlSIO_stdoutf *PL_StdIO->pPrintf +#define PerlSIO_vprintf(f,fmt,a) +#define PerlSIO_ftell(f) ftell(f) +#define PerlSIO_fseek(f,o,w) fseek(f,o,w) +#define PerlSIO_fgetpos(f,p) fgetpos(f,p) +#define PerlSIO_fsetpos(f,p) fsetpos(f,p) +#define PerlSIO_rewind(f) rewind(f) +#define PerlSIO_tmpfile() tmpfile() +#define PerlSIO_fdupopen(f) (f) +#endif /* PERL_IMPLICIT_SYS */ /* * Interface for directory functions @@ -552,7 +411,7 @@ struct IPerlDirInfo #define PerlDir_mkdir(name, mode) Mkdir((name), (mode)) #ifdef VMS # define PerlDir_chdir(n) Chdir(((n) && *(n)) ? (n) : "SYS$LOGIN") -#else +#else # define PerlDir_chdir(name) chdir((name)) #endif #define PerlDir_rmdir(name) rmdir((name)) @@ -922,36 +781,36 @@ struct IPerlMemInfo /* Shared memory macros */ #define PerlMemShared_malloc(size) \ - (*PL_MemShared->pMalloc)(PL_Mem, (size)) + (*PL_MemShared->pMalloc)(PL_MemShared, (size)) #define PerlMemShared_realloc(buf, size) \ - (*PL_MemShared->pRealloc)(PL_Mem, (buf), (size)) + (*PL_MemShared->pRealloc)(PL_MemShared, (buf), (size)) #define PerlMemShared_free(buf) \ - (*PL_MemShared->pFree)(PL_Mem, (buf)) + (*PL_MemShared->pFree)(PL_MemShared, (buf)) #define PerlMemShared_calloc(num, size) \ - (*PL_MemShared->pCalloc)(PL_Mem, (num), (size)) + (*PL_MemShared->pCalloc)(PL_MemShared, (num), (size)) #define PerlMemShared_get_lock() \ - (*PL_MemShared->pGetLock)(PL_Mem) + (*PL_MemShared->pGetLock)(PL_MemShared) #define PerlMemShared_free_lock() \ - (*PL_MemShared->pFreeLock)(PL_Mem) + (*PL_MemShared->pFreeLock)(PL_MemShared) #define PerlMemShared_is_locked() \ - (*PL_MemShared->pIsLocked)(PL_Mem) + (*PL_MemShared->pIsLocked)(PL_MemShared) /* Parse tree memory macros */ #define PerlMemParse_malloc(size) \ - (*PL_MemParse->pMalloc)(PL_Mem, (size)) + (*PL_MemParse->pMalloc)(PL_MemParse, (size)) #define PerlMemParse_realloc(buf, size) \ - (*PL_MemParse->pRealloc)(PL_Mem, (buf), (size)) + (*PL_MemParse->pRealloc)(PL_MemParse, (buf), (size)) #define PerlMemParse_free(buf) \ - (*PL_MemParse->pFree)(PL_Mem, (buf)) + (*PL_MemParse->pFree)(PL_MemParse, (buf)) #define PerlMemParse_calloc(num, size) \ - (*PL_MemParse->pCalloc)(PL_Mem, (num), (size)) + (*PL_MemParse->pCalloc)(PL_MemParse, (num), (size)) #define PerlMemParse_get_lock() \ - (*PL_MemParse->pGetLock)(PL_Mem) + (*PL_MemParse->pGetLock)(PL_MemParse) #define PerlMemParse_free_lock() \ - (*PL_MemParse->pFreeLock)(PL_Mem) + (*PL_MemParse->pFreeLock)(PL_MemParse) #define PerlMemParse_is_locked() \ - (*PL_MemParse->pIsLocked)(PL_Mem) + (*PL_MemParse->pIsLocked)(PL_MemParse) #else /* PERL_IMPLICIT_SYS */ @@ -1043,6 +902,7 @@ typedef int (*LPProcSpawnvp)(struct IPerlProc*, int, const char*, const char*const*); typedef int (*LPProcASpawn)(struct IPerlProc*, void*, void**, void**); #endif +typedef int (*LPProcLastHost)(struct IPerlProc*); struct IPerlProc { @@ -1081,6 +941,7 @@ struct IPerlProc LPProcSpawnvp pSpawnvp; LPProcASpawn pASpawn; #endif + LPProcLastHost pLastHost; }; struct IPerlProcInfo @@ -1160,6 +1021,8 @@ struct IPerlProcInfo #define PerlProc_aspawn(m,c,a) \ (*PL_Proc->pASpawn)(PL_Proc, (m), (c), (a)) #endif +#define PerlProc_lasthost() \ + (*PL_Proc->pLastHost)(PL_Proc) #else /* PERL_IMPLICIT_SYS */ @@ -1256,7 +1119,7 @@ typedef int (*LPRecvfrom)(struct IPerlSock*, SOCKET, char*, int, typedef int (*LPSelect)(struct IPerlSock*, int, char*, char*, char*, const struct timeval*); typedef int (*LPSend)(struct IPerlSock*, SOCKET, const char*, int, - int); + int); typedef int (*LPSendto)(struct IPerlSock*, SOCKET, const char*, int, int, const struct sockaddr*, int); typedef void (*LPSethostent)(struct IPerlSock*, int); diff --git a/lib/AnyDBM_File.pm b/lib/AnyDBM_File.pm index 58ffda768e..ce850491e5 100644 --- a/lib/AnyDBM_File.pm +++ b/lib/AnyDBM_File.pm @@ -1,6 +1,7 @@ package AnyDBM_File; use 5.005_64; +our $VERSION = '1.00'; our @ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA; my $mod; diff --git a/lib/CGI.pm b/lib/CGI.pm index fd06f64e41..6b870545b3 100644 --- a/lib/CGI.pm +++ b/lib/CGI.pm @@ -107,18 +107,18 @@ unless ($OS) { $OS = $Config::Config{'osname'}; } } -if ($OS=~/Win/i) { +if ($OS =~ /^MSWin/i) { $OS = 'WINDOWS'; -} elsif ($OS=~/vms/i) { +} elsif ($OS =~ /^VMS/i) { $OS = 'VMS'; -} elsif ($OS=~/bsdos/i) { - $OS = 'UNIX'; -} elsif ($OS=~/dos/i) { +} elsif ($OS =~ /^dos/i) { $OS = 'DOS'; -} elsif ($OS=~/^MacOS$/i) { +} elsif ($OS =~ /^MacOS/i) { $OS = 'MACINTOSH'; -} elsif ($OS=~/os2/i) { +} elsif ($OS =~ /^os2/i) { $OS = 'OS2'; +} elsif ($OS =~ /^epoc/i) { + $OS = 'EPOC'; } else { $OS = 'UNIX'; } @@ -135,7 +135,7 @@ $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass; # The path separator is a slash, backslash or semicolon, depending # on the paltform. $SL = { - UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/' + UNIX=>'/', EPOC=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/' }->{$OS}; # This no longer seems to be necessary @@ -3274,7 +3274,7 @@ unless ($TMPDIRECTORY) { @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp", "C:${SL}temp","${SL}tmp","${SL}temp", "${vol}${SL}Temporary Items", - "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH"); + "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH", "C:${SL}system${SL}temp"); unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'}; # this feature was supposed to provide per-user tmpfiles, but @@ -3530,12 +3530,18 @@ have several choices: =over 4 -=item 1. Use another name for the argument, if one is available. For -example, -value is an alias for -values. +=item 1. + +Use another name for the argument, if one is available. +For example, -value is an alias for -values. -=item 2. Change the capitalization, e.g. -Values +=item 2. -=item 3. Put quotes around the argument name, e.g. '-values' +Change the capitalization, e.g. -Values + +=item 3. + +Put quotes around the argument name, e.g. '-values' =back @@ -5669,6 +5675,7 @@ field. The second argument (-src) is also required and specifies the URL =item 3. + The third option (-align, optional) is an alignment type, and may be TOP, BOTTOM or MIDDLE @@ -6102,6 +6109,7 @@ Returns either the remote host name or IP address. if the former is unavailable. =item B<script_name()> + Return the script name as a partial URL, for self-refering scripts. @@ -6220,7 +6228,9 @@ Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your CGI->nph(1) -=item By using B<-nph> parameters in the B<header()> and B<redirect()> statements: +=item By using B<-nph> parameters + +in the B<header()> and B<redirect()> statements: print $q->header(-nph=>1); diff --git a/lib/CGI/Apache.pm b/lib/CGI/Apache.pm index dced8664b4..550c6e433b 100644 --- a/lib/CGI/Apache.pm +++ b/lib/CGI/Apache.pm @@ -1,4 +1,7 @@ use CGI; + +our $VERSION = '1.00'; + 1; __END__ diff --git a/lib/CGI/Switch.pm b/lib/CGI/Switch.pm index b16b9c0658..e754fdedce 100644 --- a/lib/CGI/Switch.pm +++ b/lib/CGI/Switch.pm @@ -1,4 +1,7 @@ use CGI; + +our $VERSION = '1.00'; + 1; __END__ diff --git a/lib/CPAN.pm b/lib/CPAN.pm index aeb6a57958..fce7dc455b 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -1,12 +1,11 @@ # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- package CPAN; -$VERSION = '1.57_68RC'; - -# $Id: CPAN.pm,v 1.354 2000/10/08 14:20:57 k Exp $ +$VERSION = '1.59_51'; +# $Id: CPAN.pm,v 1.381 2000/12/01 08:13:05 k Exp $ # only used during development: $Revision = ""; -# $Revision = "[".substr(q$Revision: 1.354 $, 10)."]"; +# $Revision = "[".substr(q$Revision: 1.381 $, 10)."]"; use Carp (); use Config (); @@ -56,7 +55,7 @@ package CPAN; use strict qw(vars); use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term - $Revision $Signal $Cwd $End $Suppress_readline $Frontend + $Revision $Signal $End $Suppress_readline $Frontend $Defaultsite $Have_warned); @CPAN::ISA = qw(CPAN::Debug Exporter); @@ -88,24 +87,24 @@ sub shell { $Suppress_readline = ! -t STDIN unless defined $Suppress_readline; CPAN::Config->load unless $CPAN::Config_loaded++; - CPAN::Index->read_metadata_cache; + my $oprompt = shift || "cpan> "; + my $prompt = $oprompt; + my $commandline = shift || ""; - my $prompt = "cpan> "; local($^W) = 1; unless ($Suppress_readline) { require Term::ReadLine; -# import Term::ReadLine; - $term = Term::ReadLine->new('CPAN Monitor'); + if (! $term + or + $term->ReadLine eq "Term::ReadLine::Stub" + ) { + $term = Term::ReadLine->new('CPAN Monitor'); + } if ($term->ReadLine eq "Term::ReadLine::Gnu") { my $attribs = $term->Attribs; -# $attribs->{completion_entry_function} = -# $attribs->{'list_completion_function'}; $attribs->{attempted_completion_function} = sub { &CPAN::Complete::gnu_cpl; } -# $attribs->{completion_word} = -# [qw(help me somebody to find out how -# to use completion with GNU)]; } else { $readline::rl_completion_function = $readline::rl_completion_function = 'CPAN::Complete::cpl'; @@ -120,9 +119,7 @@ sub shell { # no strict; # I do not recall why no strict was here (2000-09-03) $META->checklock(); - my $getcwd; - $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my $cwd = CPAN->$getcwd(); + my $cwd = CPAN::anycwd(); my $try_detect_readline; $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term; my $rl_avail = $Suppress_readline ? "suppressed" : @@ -141,20 +138,21 @@ ReadLine support %s ) unless $CPAN::Config->{'inhibit_startup_message'} ; my($continuation) = ""; - while () { + SHELLCOMMAND: while () { if ($Suppress_readline) { print $prompt; - last unless defined ($_ = <> ); + last SHELLCOMMAND unless defined ($_ = <> ); chomp; } else { - last unless defined ($_ = $term->readline($prompt)); + last SHELLCOMMAND unless + defined ($_ = $term->readline($prompt, $commandline)); } $_ = "$continuation$_" if $continuation; s/^\s+//; - next if /^$/; + next SHELLCOMMAND if /^$/; $_ = 'h' if /^\s*\?/; if (/^(?:q(?:uit)?|bye|exit)$/i) { - last; + last SHELLCOMMAND; } elsif (s/\\$//s) { chomp; $continuation = $_; @@ -169,14 +167,16 @@ ReadLine support %s eval($eval); warn $@ if $@; $continuation = ""; - $prompt = "cpan> "; + $prompt = $oprompt; } elsif (/./) { my(@line); if ($] < 5.00322) { # parsewords had a bug until recently @line = split; } else { eval { @line = Text::ParseWords::shellwords($_) }; - warn($@), next if $@; + warn($@), next SHELLCOMMAND if $@; + warn("Text::Parsewords could not parse the line [$_]"), + next SHELLCOMMAND unless @line; } $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG; my $command = shift @line; @@ -185,9 +185,12 @@ ReadLine support %s chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!}); $CPAN::Frontend->myprint("\n"); $continuation = ""; - $prompt = "cpan> "; + $prompt = $oprompt; } } continue { + $commandline = ""; # I do want to be able to pass a default to + # shell, but on the second command I see no + # use in that $Signal=0; CPAN::Queue->nullify_queue; if ($try_detect_readline) { @@ -201,10 +204,12 @@ ReadLine support %s require Term::ReadLine; $CPAN::Frontend->myprint("\n$redef subroutines in ". "Term::ReadLine redefined\n"); + @_ = ($oprompt,""); goto &shell; } } } + chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!}); } package CPAN::CacheMgr; @@ -226,6 +231,11 @@ use vars qw($Ua $Thesite $Themethod); package CPAN::Complete; @CPAN::Complete::ISA = qw(CPAN::Debug); +@CPAN::Complete::COMMANDS = sort qw( + ! a b d h i m o q r u autobundle clean dump + make test install force readme reload look + cvs_import ls +) unless @CPAN::Complete::COMMANDS; package CPAN::Index; use vars qw($last_time $date_of_03); @@ -251,8 +261,10 @@ package CPAN::Module; @CPAN::Module::ISA = qw(CPAN::InfoObj); package CPAN::Shell; -use vars qw($AUTOLOAD @ISA); +use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING); @CPAN::Shell::ISA = qw(CPAN::Debug); +$COLOR_REGISTERED ||= 0; +$PRINT_ORNAMENTING ||= 0; #-> sub CPAN::Shell::AUTOLOAD ; sub AUTOLOAD { @@ -279,8 +291,9 @@ For this you just need to type } package CPAN::Tarzip; -use vars qw($AUTOLOAD @ISA); +use vars qw($AUTOLOAD @ISA $BUGHUNTING); @CPAN::Tarzip::ISA = qw(CPAN::Debug); +$BUGHUNTING = 0; # released code must have turned off package CPAN::Queue; @@ -583,6 +596,13 @@ sub DESTROY { &cleanup; # need an eval? } +#-> sub CPAN::anycwd ; +sub anycwd () { + my $getcwd; + $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; + CPAN->$getcwd(); +} + #-> sub CPAN::cwd ; sub cwd {Cwd::cwd();} @@ -592,6 +612,7 @@ sub getcwd {Cwd::getcwd();} #-> sub CPAN::exists ; sub exists { my($mgr,$class,$id) = @_; + CPAN::Config->load unless $CPAN::Config_loaded++; CPAN::Index->reload; ### Carp::croak "exists called without class argument" unless $class; $id ||= ""; @@ -788,9 +809,7 @@ sub entries { return unless defined $dir; $self->debug("reading dir[$dir]") if $CPAN::DEBUG; $dir ||= $self->{ID}; - my $getcwd; - $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my($cwd) = CPAN->$getcwd(); + my($cwd) = CPAN::anycwd(); chdir $dir or Carp::croak("Can't chdir to $dir: $!"); my $dh = DirHandle->new(File::Spec->curdir) or Carp::croak("Couldn't opendir $dir: $!"); @@ -1030,7 +1049,7 @@ EOF my($fh) = FileHandle->new; rename $configpm, "$configpm~" if -f $configpm; open $fh, ">$configpm" or - $CPAN::Frontend->mywarn("Couldn't open >$configpm: $!"); + $CPAN::Frontend->mydie("Couldn't open >$configpm: $!"); $fh->print(qq[$msg\$CPAN::Config = \{\n]); foreach (sort keys %$CPAN::Config) { $fh->print( @@ -1267,21 +1286,40 @@ sub a { $CPAN::Frontend->myprint($self->format_result('Author',@arg)); } -#-> sub CPAN::Shell::local_bundles ; +#-> sub CPAN::Shell::ls ; +sub ls { + my($self,@arg) = @_; + for (@arg) { + $_ = uc $_; + } + for my $a (@arg){ + my $author = $self->expand('Author',$a) or die "No author found for $a"; + $author->ls; + } +} +#-> sub CPAN::Shell::local_bundles ; sub local_bundles { my($self,@which) = @_; my($incdir,$bdir,$dh); foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { - $bdir = MM->catdir($incdir,"Bundle"); - if ($dh = DirHandle->new($bdir)) { # may fail - my($entry); - for $entry ($dh->read) { - next if -d MM->catdir($bdir,$entry); - next unless $entry =~ s/\.pm(?!\n)\Z//; - $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry"); - } - } + my @bbase = "Bundle"; + while (my $bbase = shift @bbase) { + $bdir = MM->catdir($incdir,split /::/, $bbase); + CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG; + if ($dh = DirHandle->new($bdir)) { # may fail + my($entry); + for $entry ($dh->read) { + next if $entry =~ /^\./; # + if (-d MM->catdir($bdir,$entry)){ + push @bbase, "$bbase\::$entry"; + } else { + next unless $entry =~ s/\.pm(?!\n)\Z//; + $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry"); + } + } + } + } } } @@ -1312,10 +1350,14 @@ sub i { for $type (@type) { push @result, $self->expand($type,@args); } - my $result = @result == 1 ? + my $result = @result == 1 ? $result[0]->as_string : - join "", map {$_->as_glimpse} @result; - $result ||= "No objects found of any type for argument @args\n"; + @result == 0 ? + "No objects found of any type for argument @args\n" : + join("", + (map {$_->as_glimpse} @result), + scalar @result, " items found\n", + ); $CPAN::Frontend->myprint($result); } @@ -1358,6 +1400,10 @@ sub o { if (@o_what) { while (@o_what) { my($what) = shift @o_what; + if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) { + $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what}; + next; + } if ( exists $CPAN::DEBUG{$what} ) { $CPAN::DEBUG |= $CPAN::DEBUG{$what}; } elsif ($what =~ /^\d/) { @@ -1499,7 +1545,7 @@ sub _u_r_common { my(@result,$module,%seen,%need,$headerdone, $version_undefs,$version_zeroes); $version_undefs = $version_zeroes = 0; - my $sprintf = "%-25s %9s %9s %s\n"; + my $sprintf = "%s%-25s%s %9s %9s %s\n"; my @expand = $self->expand('Module',@args); my $expand = scalar @expand; if (0) { # Looks like noise to me, was very useful for debugging @@ -1555,15 +1601,31 @@ sub _u_r_common { unless ($headerdone++){ $CPAN::Frontend->myprint("\n"); $CPAN::Frontend->myprint(sprintf( - $sprintf, - "Package namespace", - "installed", - "latest", - "in CPAN file" - )); + $sprintf, + "", + "Package namespace", + "", + "installed", + "latest", + "in CPAN file" + )); } + my $color_on = ""; + my $color_off = ""; + if ( + $COLOR_REGISTERED + && + $CPAN::META->has_inst("Term::ANSIColor") + && + $module->{RO}{description} + ) { + $color_on = Term::ANSIColor::color("green"); + $color_off = Term::ANSIColor::color("reset"); + } $CPAN::Frontend->myprint(sprintf $sprintf, + $color_on, $module->id, + $color_off, $have, $latest, $file); @@ -1653,6 +1715,7 @@ sub expandany { my($self,$s) = @_; CPAN->debug("s[$s]") if $CPAN::DEBUG; if ($s =~ m|/|) { # looks like a file + $s = CPAN::Distribution->normalize($s); return $CPAN::META->instance('CPAN::Distribution',$s); # Distributions spring into existence, not expand } elsif ($s =~ m|^Bundle::|) { @@ -1673,15 +1736,21 @@ sub expand { shift; my($type,@args) = @_; my($arg,@m); + CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG; for $arg (@args) { my($regex,$command); if ($arg =~ m|^/(.*)/$|) { $regex = $1; - } elsif ($arg =~ m/^=/) { - $command = substr($arg,1); + } elsif ($arg =~ m/=/) { + $command = 1; } my $class = "CPAN::$type"; my $obj; + CPAN->debug(sprintf "class[%s]regex[%s]command[%s]", + $class, + defined $regex ? $regex : "UNDEFINED", + $command || "UNDEFINED", + ) if $CPAN::DEBUG; if (defined $regex) { for $obj ( sort @@ -1690,10 +1759,11 @@ sub expand { ) { unless ($obj->id){ # BUG, we got an empty object somewhere + require Data::Dumper; CPAN->debug(sprintf( - "Empty id on obj[%s]%%[%s]", + "Bug in CPAN: Empty id on obj[%s][%s]", $obj, - join(":", %$obj) + Data::Dumper::Dumper($obj) )) if $CPAN::DEBUG; next; } @@ -1712,21 +1782,33 @@ sub expand { ); } } elsif ($command) { - die "leading equal sign in command disabled, ". - "please edit CPAN.pm to enable eval() or ". - "do not use = on argument list"; + die "equal sign in command disabled (immature interface), ". + "you can set + ! \$CPAN::Shell::ADVANCED_QUERY=1 +to enable it. But please note, this is HIGHLY EXPERIMENTAL code +that may go away anytime.\n" + unless $ADVANCED_QUERY; + my($method,$criterion) = $arg =~ /(.+?)=(.+)/; + my($matchcrit) = $criterion =~ m/^~(.+)/; for my $self ( sort {$a->id cmp $b->id} $CPAN::META->all_objects($class) ) { - push @m, $self if eval $command; + my $lhs = $self->$method() or next; # () for 5.00503 + if ($matchcrit) { + push @m, $self if $lhs =~ m/$matchcrit/; + } else { + push @m, $self if $lhs eq $criterion; + } } } else { my($xarg) = $arg; if ( $type eq 'Bundle' ) { $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/; - } + } elsif ($type eq "Distribution") { + $xarg = CPAN::Distribution->normalize($arg); + } if ($CPAN::META->exists($class,$xarg)) { $obj = $CPAN::META->instance($class,$xarg); } elsif ($CPAN::META->exists($class,$arg)) { @@ -1746,22 +1828,33 @@ sub format_result { my($type,@args) = @_; @args = '/./' unless @args; my(@result) = $self->expand($type,@args); - my $result = @result == 1 ? + my $result = @result == 1 ? $result[0]->as_string : - join "", map {$_->as_glimpse} @result; - $result ||= "No objects of type $type found for argument @args\n"; + @result == 0 ? + "No objects of type $type found for argument @args\n" : + join("", + (map {$_->as_glimpse} @result), + scalar @result, " items found\n", + ); $result; } # The only reason for this method is currently to have a reliable # debugging utility that reveals which output is going through which # channel. No, I don't like the colors ;-) + +#-> sub CPAN::Shell::print_ornameted ; sub print_ornamented { my($self,$what,$ornament) = @_; my $longest = 0; - my $ornamenting = 0; # turn the colors on + return unless defined $what; - if ($ornamenting) { + if ($CPAN::Config->{term_is_latin}){ + # courtesy jhi: + $what + =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #}; + } + if ($PRINT_ORNAMENTING) { unless (defined &color) { if ($CPAN::META->has_inst("Term::ANSIColor")) { import Term::ANSIColor "color"; @@ -1789,6 +1882,7 @@ sub print_ornamented { sub myprint { my($self,$what) = @_; + $self->print_ornamented($what, 'bold blue on_yellow'); } @@ -1873,13 +1967,17 @@ sub rematein { push @qcopy, $obj; } elsif ($CPAN::META->exists('CPAN::Author',$s)) { $obj = $CPAN::META->instance('CPAN::Author',$s); - $CPAN::Frontend->myprint( - join "", - "Don't be silly, you can't $meth ", - $obj->fullname, - " ;-)\n" - ); - sleep 2; + if ($meth eq "dump") { + $obj->dump; + } else { + $CPAN::Frontend->myprint( + join "", + "Don't be silly, you can't $meth ", + $obj->fullname, + " ;-)\n" + ); + sleep 2; + } } else { $CPAN::Frontend ->myprint(qq{Warning: Cannot $meth $s, }. @@ -2065,14 +2163,19 @@ sub localize { # Inheritance is not easier to manage than a few if/else branches if ($CPAN::META->has_usable('LWP::UserAgent')) { unless ($Ua) { - $Ua = LWP::UserAgent->new; - my($var); - $Ua->proxy('ftp', $var) - if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy}; - $Ua->proxy('http', $var) - if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy}; - $Ua->no_proxy($var) - if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy}; + eval {$Ua = LWP::UserAgent->new;}; # Why is has_usable still not fit enough? + if ($@) { + $CPAN::Frontent->mywarn("LWP::UserAgent->new dies with $@") + if $CPAN::DEBUG; + } else { + my($var); + $Ua->proxy('ftp', $var) + if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy}; + $Ua->proxy('http', $var) + if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy}; + $Ua->no_proxy($var) + if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy}; + } } } $ENV{ftp_proxy} = $CPAN::Config->{ftp_proxy} if $CPAN::Config->{ftp_proxy}; @@ -2137,7 +2240,7 @@ sub localize { qq{E.g. with 'o conf urllist push ftp://myurl/'}; $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n"); sleep 2; - $CPAN::Frontend->myprint("Cannot fetch $file\n\n"); + $CPAN::Frontend->myprint("Could not fetch $file\n"); } if ($restore) { rename "$aslocal.bak", $aslocal; @@ -2291,7 +2394,7 @@ sub hosthard { $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG; my($f,$funkyftp); - for $f ('lynx','ncftpget','ncftp') { + for $f ('lynx','ncftpget','ncftp','wget') { next unless exists $CPAN::Config->{$f}; $funkyftp = $CPAN::Config->{$f}; next unless defined $funkyftp; @@ -2304,6 +2407,8 @@ sub hosthard { $src_switch = " -source"; } elsif ($f eq "ncftp"){ $src_switch = " -c"; + } elsif ($f eq "wget"){ + $src_switch = " -O -"; } my($chdir) = ""; my($stdout_redir) = " > $asl_ungz"; @@ -2609,6 +2714,7 @@ sub new { }, $class; } +# CPAN::FTP::hasdefault; sub hasdefault { shift->{'hasdefault'} } sub netrc { shift->{'netrc'} } sub protected { shift->{'protected'} } @@ -2656,24 +2762,22 @@ sub cpl { } my @return; if ($pos == 0) { - @return = grep( - /^$word/, - sort qw( - ! a b d h i m o q r u autobundle clean dump - make test install force readme reload look cvs_import - ) - ); + @return = grep /^$word/, @CPAN::Complete::COMMANDS; } elsif ( $line !~ /^[\!abcdhimorutl]/ ) { @return = (); - } elsif ($line =~ /^a\s/) { - @return = cplx('CPAN::Author',$word); + } elsif ($line =~ /^(a|ls)\s/) { + @return = cplx('CPAN::Author',uc($word)); } elsif ($line =~ /^b\s/) { + CPAN::Shell->local_bundles; @return = cplx('CPAN::Bundle',$word); } elsif ($line =~ /^d\s/) { @return = cplx('CPAN::Distribution',$word); } elsif ($line =~ m/^( [mru]|make|clean|dump|test|install|readme|look|cvs_import )\s/x ) { + if ($word =~ /^Bundle::/) { + CPAN::Shell->local_bundles; + } @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word)); } elsif ($line =~ /^i\s/) { @return = cpl_any($word); @@ -2681,6 +2785,9 @@ sub cpl { @return = cpl_reload($word,$line,$pos); } elsif ($line =~ /^o\s/) { @return = cpl_option($word,$line,$pos); + } elsif ($line =~ m/^\S+\s/ ) { + # fallback for future commands and what we have forgotten above + @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word)); } else { @return = (); } @@ -2757,7 +2864,15 @@ sub reload { for ($CPAN::Config->{index_expire}) { $_ = 0.001 unless $_ && $_ > 0.001; } - $CPAN::META->{PROTOCOL} ||= "1.0"; + unless (1 || $CPAN::Have_warned->{readmetadatacache}++) { + # debug here when CPAN doesn't seem to read the Metadata + require Carp; + Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]"); + } + unless ($CPAN::META->{PROTOCOL}) { + $cl->read_metadata_cache; + $CPAN::META->{PROTOCOL} ||= "1.0"; + } if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) { # warn "Setting last_time to 0"; $last_time = 0; # No warning necessary @@ -2846,9 +2961,6 @@ sub rd_authindex { my @lines; return unless defined $index_target; $CPAN::Frontend->myprint("Going to read $index_target\n"); -# my $fh = CPAN::Tarzip->TIEHANDLE($index_target); -# while ($_ = $fh->READLINE) { - # no strict 'refs'; local(*FH); tie *FH, CPAN::Tarzip, $index_target; local($/) = "\n"; @@ -3047,7 +3159,7 @@ sub rd_modlist { Carp::confess($@) if $@; return if $CPAN::Signal; for (keys %$ret) { - my $obj = $CPAN::META->instance(CPAN::Module,$_); + my $obj = $CPAN::META->instance("CPAN::Module",$_); delete $ret->{$_}{modid}; # not needed here, maybe elsewhere $obj->set(%{$ret->{$_}}); return if $CPAN::Signal; @@ -3158,6 +3270,10 @@ sub set { # because of a typo, we do not like it that they are written into # the readonly area and made permanent (at least for a while) and # that is why we do not "allow" other places to call ->set. + unless ($self->id) { + CPAN->debug("Bug? Empty ID, rejecting"); + return; + } my $ro = $self->{RO} = $CPAN::META->{readonly}{$class}{$self->id} ||= {}; @@ -3187,17 +3303,20 @@ sub as_string { # next if m/^(ID|RO)$/; my $extra = ""; if ($_ eq "CPAN_USERID") { - $extra .= " (".$self->author; - my $email; # old perls! - if ($email = $CPAN::META->instance(CPAN::Author, - $self->cpan_userid - )->email) { - $extra .= " <$email>"; - } else { - $extra .= " <no email>"; - } - $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; } @@ -3221,7 +3340,7 @@ sub as_string { #-> sub CPAN::InfoObj::author ; sub author { my($self) = @_; - $CPAN::META->instance(CPAN::Author,$self->cpan_userid)->fullname; + $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname; } #-> sub CPAN::InfoObj::dump ; @@ -3244,11 +3363,89 @@ sub as_glimpse { } #-> sub CPAN::Author::fullname ; -sub fullname { shift->{RO}{FULLNAME} } +sub fullname { + shift->{RO}{FULLNAME}; +} *name = \&fullname; #-> sub CPAN::Author::email ; -sub email { shift->{RO}{EMAIL} } +sub email { shift->{RO}{EMAIL}; } + +#-> sub CPAN::Author::ls ; +sub ls { + my $self = shift; + my $id = $self->id; + + # adapted from CPAN::Distribution::verifyMD5 ; + my(@chksumfile); + @chksumfile = $self->id =~ /(.)(.)(.*)/; + $chksumfile[1] = join "", @chksumfile[0,1]; + $chksumfile[2] = join "", @chksumfile[1,2]; + push @chksumfile, "CHECKSUMS"; + print join "", map { + sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2]) + } sort { $a->[2] cmp $b->[2] } $self->dir_listing(\@chksumfile); +} + +#-> sub CPAN::Author::dir_listing ; +sub dir_listing { + my $self = shift; + my $chksumfile = shift; + my $lc_want = + MM->catfile($CPAN::Config->{keep_source_where}, + "authors", "id", @$chksumfile); + local($") = "/"; + my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile", + $lc_want,1); + unless ($lc_file) { + $CPAN::Frontend->myprint("Trying $lc_want.gz\n"); + $chksumfile->[-1] .= ".gz"; + $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile", + "$lc_want.gz",1); + if ($lc_file) { + $lc_file =~ s{\.gz(?!\n)\Z}{}; #}; + CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file); + } else { + return; + } + } + + # adapted from CPAN::Distribution::MD5_check_file ; + my $fh = FileHandle->new; + my($cksum); + if (open $fh, $lc_file){ + local($/); + my $eval = <$fh>; + $eval =~ s/\015?\012/\n/g; + close $fh; + my($comp) = Safe->new(); + $cksum = $comp->reval($eval); + if ($@) { + rename $lc_file, "$lc_file.bad"; + Carp::confess($@) if $@; + } + } else { + Carp::carp "Could not open $lc_file for reading"; + } + my(@result,$f); + for $f (sort keys %$cksum) { + if (exists $cksum->{$f}{isdir}) { + my(@dir) = @$chksumfile; + pop @dir; + push @dir, $f, "CHECKSUMS"; + push @result, map { + [$_->[0], $_->[1], "$f/$_->[2]"] + } $self->dir_listing(\@dir); + } else { + push @result, [ + ($cksum->{$f}{"size"}||0), + $cksum->{$f}{"mtime"}||"---", + $f + ]; + } + } + @result; +} package CPAN::Distribution; @@ -3260,6 +3457,19 @@ sub undelay { delete $self->{later}; } +# CPAN::Distribution::normalize +sub normalize { + my($self,$s) = @_; + $s = $self->id unless defined $s; + if ($s =~ tr|/|| == 1) { + return $s if $s =~ m|^N/A|; + $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or + $CPAN::Frontend->mywarn("Strange distribution name [$s]"); + CPAN->debug("s[$s]") if $CPAN::DEBUG; + } + $s; +} + #-> sub CPAN::Distribution::color_cmd_tmps ; sub color_cmd_tmps { my($self) = shift; @@ -3300,15 +3510,27 @@ sub as_string { #-> sub CPAN::Distribution::containsmods ; sub containsmods { my $self = shift; - return if exists $self->{CONTAINSMODS}; + return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS}; + my $dist_id = $self->{ID}; for my $mod ($CPAN::META->all_objects("CPAN::Module")) { my $mod_file = $mod->cpan_file or next; - my $dist_id = $self->{ID} or next; my $mod_id = $mod->{ID} or next; # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]"; # sleep 1; $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id; } + keys %{$self->{CONTAINSMODS}}; +} + +#-> sub CPAN::Distribution::uptodate ; +sub uptodate { + my($self) = @_; + my $c; + foreach $c ($self->containsmods) { + my $obj = CPAN::Shell->expandany($c); + return 0 unless $obj->uptodate; + } + return 1; } #-> sub CPAN::Distribution::called_for ; @@ -3318,6 +3540,22 @@ sub called_for { return $self->{CALLED_FOR}; } +#-> sub CPAN::Distribution::my_chdir ; +sub safe_chdir { + my($self,$todir) = @_; + # we die if we cannot chdir and we are debuggable + Carp::confess("safe_chdir called without todir argument") + unless defined $todir and length $todir; + if (chdir $todir) { + $self->debug(sprintf "changed directory to %s", CPAN::anycwd()) + if $CPAN::DEBUG; + } else { + my $cwd = CPAN::anycwd(); + $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }. + qq{to todir[$todir]: $!}); + } +} + #-> sub CPAN::Distribution::get ; sub get { my($self) = @_; @@ -3327,6 +3565,12 @@ sub get { "Is already unwrapped into directory $self->{'build_dir'}"; $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } + my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible + + # + # Get the file on local disk + # + my($local_file); my($local_wanted) = MM->catfile( @@ -3339,31 +3583,41 @@ sub get { $self->debug("Doing localize") if $CPAN::DEBUG; $local_file = CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted) - or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n"); - return if $CPAN::Signal; + or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n"); + $self->debug("local_file[$local_file]") if $CPAN::DEBUG; $self->{localfile} = $local_file; - $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok - my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok - $self->debug("doing chdir $builddir") if $CPAN::DEBUG; - chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!"); - my $packagedir; + return if $CPAN::Signal; - $self->debug("local_file[$local_file]") if $CPAN::DEBUG; + # + # Check integrity + # if ($CPAN::META->has_inst("MD5")) { $self->debug("MD5 is installed, verifying"); $self->verifyMD5; } else { $self->debug("MD5 is NOT installed"); } + return if $CPAN::Signal; + + # + # Create a clean room and go there + # + $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok + my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok + $self->safe_chdir($builddir); $self->debug("Removing tmp") if $CPAN::DEBUG; File::Path::rmtree("tmp"); mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!"; - chdir "tmp" or $CPAN::Frontend->mydie(qq{Could not chdir to "tmp": $!});; - $self->debug("Changed directory to tmp") if $CPAN::DEBUG; - return if $CPAN::Signal; - if (! $local_file) { - Carp::croak "bad download, can't do anything :-(\n"; - } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){ + if ($CPAN::Signal){ + $self->safe_chdir($sub_wd); + return; + } + $self->safe_chdir("tmp"); + + # + # Unpack the goods + # + if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){ $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file); $self->untar_me($local_file); } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) { @@ -3373,81 +3627,106 @@ sub get { $self->pm2dir_me($local_file); } else { $self->{archived} = "NO"; + $self->safe_chdir($sub_wd); + return; } - my $cwd = File::Spec->updir; - chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "": $!}); - if ($self->{archived} ne 'NO') { - $cwd = File::Spec->catdir(File::Spec->curdir, "tmp"); - chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!}); - # Let's check if the package has its own directory. - my $dh = DirHandle->new(File::Spec->curdir) - or Carp::croak("Couldn't opendir .: $!"); - my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC?? - $dh->close; - my ($distdir,$packagedir); - if (@readdir == 1 && -d $readdir[0]) { + + # we are still in the tmp directory! + # Let's check if the package has its own directory. + my $dh = DirHandle->new(File::Spec->curdir) + or Carp::croak("Couldn't opendir .: $!"); + my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC?? + $dh->close; + my ($distdir,$packagedir); + if (@readdir == 1 && -d $readdir[0]) { $distdir = $readdir[0]; $packagedir = MM->catdir($builddir,$distdir); + $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]") + if $CPAN::DEBUG; -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ". "$packagedir\n"); File::Path::rmtree($packagedir); rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!"); - } else { - my $userid = $self->cpan_userid; - unless ($userid) { - CPAN->debug("no userid? self[$self]"); - $userid = "anon"; - } - my $pragmatic_dir = $userid . '000'; - $pragmatic_dir =~ s/\W_//g; - $pragmatic_dir++ while -d "../$pragmatic_dir"; - $packagedir = MM->catdir($builddir,$pragmatic_dir); - File::Path::mkpath($packagedir); - my($f); - for $f (@readdir) { # is already without "." and ".." - my $to = MM->catdir($packagedir,$f); - rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!"); - } - } - $self->{'build_dir'} = $packagedir; - $cwd = File::Spec->updir; - chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!}); - - $self->debug("Changed directory to .. (self[$self]=[". - $self->as_string."])") if $CPAN::DEBUG; - File::Path::rmtree("tmp"); - if ($CPAN::Config->{keep_source_where} =~ /^no/i ){ - $CPAN::Frontend->myprint("Going to unlink $local_file\n"); - unlink $local_file or Carp::carp "Couldn't unlink $local_file"; - } - my($makefilepl) = MM->catfile($packagedir,"Makefile.PL"); - unless (-f $makefilepl) { + $self->debug(sprintf("renamed distdir[%s] to packagedir[%s] -e[%s]-d[%s]", + $distdir, + $packagedir, + -e $packagedir, + -d $packagedir, + )) if $CPAN::DEBUG; + } else { + my $userid = $self->cpan_userid; + unless ($userid) { + CPAN->debug("no userid? self[$self]"); + $userid = "anon"; + } + my $pragmatic_dir = $userid . '000'; + $pragmatic_dir =~ s/\W_//g; + $pragmatic_dir++ while -d "../$pragmatic_dir"; + $packagedir = MM->catdir($builddir,$pragmatic_dir); + $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG; + File::Path::mkpath($packagedir); + my($f); + for $f (@readdir) { # is already without "." and ".." + my $to = MM->catdir($packagedir,$f); + rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!"); + } + } + if ($CPAN::Signal){ + $self->safe_chdir($sub_wd); + return; + } + + $self->{'build_dir'} = $packagedir; + $self->safe_chdir(File::Spec->updir); + File::Path::rmtree("tmp"); + + my($mpl) = MM->catfile($packagedir,"Makefile.PL"); + my($mpl_exists) = -f $mpl; + unless ($mpl_exists) { + # Steffen's stupid NFS has problems to see an existing + # Makefile.PL such a short time after the directory was + # renamed. Maybe this trick helps + $dh = DirHandle->new($packagedir) + or Carp::croak("Couldn't opendir $packagedir: $!"); + $mpl_exists = grep /^Makefile\.PL$/, $dh->read; + } + unless ($mpl_exists) { + $self->debug(sprintf("makefilepl[%s]anycwd[%s]", + $mpl, + CPAN::anycwd(), + )) if $CPAN::DEBUG; my($configure) = MM->catfile($packagedir,"Configure"); if (-f $configure) { - # do we have anything to do? - $self->{'configure'} = $configure; + # do we have anything to do? + $self->{'configure'} = $configure; } elsif (-f MM->catfile($packagedir,"Makefile")) { - $CPAN::Frontend->myprint(qq{ + $CPAN::Frontend->myprint(qq{ Package comes with a Makefile and without a Makefile.PL. We\'ll try to build it with that Makefile then. }); - $self->{writemakefile} = "YES"; - sleep 2; + $self->{writemakefile} = "YES"; + sleep 2; } else { - my $cf = $self->called_for || "unknown"; - if ($cf =~ m|/|) { - $cf =~ s|.*/||; - $cf =~ s|\W.*||; - } - $cf =~ s|[/\\:]||g; # risk of filesystem damage - $cf = "unknown" unless length($cf); - $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL. - Writing one on our own (calling it $cf)\n}); - $self->{had_no_makefile_pl}++; - my $fh = FileHandle->new(">$makefilepl") - or Carp::croak("Could not open >$makefilepl"); - $fh->print( + my $cf = $self->called_for || "unknown"; + if ($cf =~ m|/|) { + $cf =~ s|.*/||; + $cf =~ s|\W.*||; + } + $cf =~ s|[/\\:]||g; # risk of filesystem damage + $cf = "unknown" unless length($cf); + $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL. + (The test -f "$mpl" returned false.) + Writing one on our own (setting NAME to $cf)\a\n}); + $self->{had_no_makefile_pl}++; + sleep 3; + + # Writing our own Makefile.PL + + my $fh = FileHandle->new; + $fh->open(">$mpl") + or Carp::croak("Could not open >$mpl: $!"); + $fh->print( qq{# This Makefile.PL has been autogenerated by the module CPAN.pm # because there was no Makefile.PL supplied. # Autogenerated on: }.scalar localtime().qq{ @@ -3456,10 +3735,10 @@ use ExtUtils::MakeMaker; WriteMakefile(NAME => q[$cf]); }); - $fh->close; + $fh->close; } - } } + return $self; } @@ -3531,9 +3810,7 @@ Please define it with "o conf shell <your shell>" my $dist = $self->id; my $dir = $self->dir or $self->get; $dir = $self->dir; - my $getcwd; - $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my $pwd = CPAN->$getcwd(); + my $pwd = CPAN::anycwd(); chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!}); $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); system($CPAN::Config->{'shell'}) == 0 @@ -3567,9 +3844,7 @@ sub cvs_import { my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log, "$cvs_dir", $userid, "v$version"); - my $getcwd; - $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my $pwd = CPAN->$getcwd(); + my $pwd = CPAN::anycwd(); chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!}); $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); @@ -3630,7 +3905,7 @@ sub verifyMD5 { $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } my($lc_want,$lc_file,@local,$basename); - @local = split("/",$self->{ID}); + @local = split("/",$self->id); pop @local; push @local, "CHECKSUMS"; $lc_want = @@ -3647,6 +3922,7 @@ sub verifyMD5 { $lc_file = CPAN::FTP->localize("authors/id/@local", $lc_want,1); unless ($lc_file) { + $CPAN::Frontend->myprint("Trying $lc_want.gz\n"); $local[-1] .= ".gz"; $lc_file = CPAN::FTP->localize("authors/id/@local", "$lc_want.gz",1); @@ -3824,8 +4100,7 @@ sub isa_perl { sub perl { my($self) = @_; my($perl) = MM->file_name_is_absolute($^X) ? $^X : ""; - my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my $pwd = CPAN->$getcwd(); + my $pwd = CPAN::anycwd(); my $candidate = MM->catfile($pwd,$^X); $perl ||= $candidate if MM->maybe_command($candidate); unless ($perl) { @@ -4339,7 +4614,7 @@ sub as_string { #-> sub CPAN::Bundle::contains ; sub contains { my($self) = @_; - my($parsefile) = $self->inst_file; + my($parsefile) = $self->inst_file || ""; my($id) = $self->id; $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG; unless ($parsefile) { @@ -4403,8 +4678,7 @@ sub find_bundle_file { my $manifest = MM->catfile($where,"MANIFEST"); unless (-f $manifest) { require ExtUtils::Manifest; - my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my $cwd = CPAN->$getcwd(); + my $cwd = CPAN::anycwd(); chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!}); ExtUtils::Manifest::mkmanifest(); chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!}); @@ -4439,21 +4713,37 @@ sub find_bundle_file { Carp::croak("Couldn't find a Bundle file in $where"); } -# needs to work slightly different from Module::inst_file because of -# cpan_home/Bundle/ directory. +# needs to work quite differently from Module::inst_file because of +# cpan_home/Bundle/ directory and the possibility that we have +# shadowing effect. As it makes no sense to take the first in @INC for +# Bundles, we parse them all for $VERSION and take the newest. #-> sub CPAN::Bundle::inst_file ; sub inst_file { my($self) = @_; - return $self->{INST_FILE} if - exists $self->{INST_FILE} && $self->{INST_FILE}; my($inst_file); my(@me); @me = split /::/, $self->id; $me[-1] .= ".pm"; - $inst_file = MM->catfile($CPAN::Config->{'cpan_home'}, @me); - return $self->{INST_FILE} = $inst_file if -f $inst_file; - $self->SUPER::inst_file; + my($incdir,$bestv); + foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { + my $bfile = MM->catfile($incdir, @me); + CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG; + next unless -f $bfile; + my $foundv = MM->parse_version($bfile); + if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) { + $self->{INST_FILE} = $bfile; + $self->{INST_VERSION} = $bestv = $foundv; + } + } + $self->{INST_FILE}; +} + +#-> sub CPAN::Bundle::inst_version ; +sub inst_version { + my($self) = @_; + $self->inst_file; # finds INST_VERSION as side effect + $self->{INST_VERSION}; } #-> sub CPAN::Bundle::rematein ; @@ -4564,6 +4854,18 @@ sub install { #-> sub CPAN::Bundle::clean ; sub clean { shift->rematein('clean',@_); } +#-> sub CPAN::Bundle::uptodate ; +sub uptodate { + my($self) = @_; + return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def + my $c; + foreach $c ($self->contains) { + my $obj = CPAN::Shell->expandany($c); + return 0 unless $obj->uptodate; + } + return 1; +} + #-> sub CPAN::Bundle::readme ; sub readme { my($self) = @_; @@ -4579,8 +4881,8 @@ package CPAN::Module; # sub cpan_userid { shift->{RO}{CPAN_USERID} } sub userid { my $self = shift; - return unless exists $self->{RO}{userid}; - $self->{RO}{userid}; + return unless exists $self->{RO}; # should never happen + return $self->{RO}{CPAN_USERID} || $self->{RO}{userid}; } sub description { shift->{RO}{description} } @@ -4624,7 +4926,23 @@ sub as_glimpse { my(@m); my $class = ref($self); $class =~ s/^CPAN:://; - push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID}, + my $color_on = ""; + my $color_off = ""; + if ( + $CPAN::Shell::COLOR_REGISTERED + && + $CPAN::META->has_inst("Term::ANSIColor") + && + $self->{RO}{description} + ) { + $color_on = Term::ANSIColor::color("green"); + $color_off = Term::ANSIColor::color("reset"); + } + push @m, sprintf("%-15s %s%-15s%s (%s)\n", + $class, + $color_on, + $self->id, + $color_off, $self->cpan_file); join "", @m; } @@ -4689,8 +5007,45 @@ sub as_string { $stati{$self->{RO}{stati}} ) if $self->{RO}{statd}; my $local_file = $self->inst_file; - if ($local_file) { - $self->{MANPAGE} ||= $self->manpage_headline($local_file); + unless ($self->{MANPAGE}) { + if ($local_file) { + $self->{MANPAGE} = $self->manpage_headline($local_file); + } else { + # If we have already untarred it, we should look there + my $dist = $CPAN::META->instance('CPAN::Distribution', + $self->cpan_file); + # warn "dist[$dist]"; + # mff=manifest file; mfh=manifest handle + my($mff,$mfh); + if ($dist->{build_dir} and + -f ($mff = MM->catfile($dist->{build_dir}, "MANIFEST")) and + $mfh = FileHandle->new($mff) + ) { + CPAN->debug("mff[$mff]") if $CPAN::DEBUG; + my $lfre = $self->id; # local file RE + $lfre =~ s/::/./g; + $lfre .= "\\.pm\$"; + my($lfl); # local file file + local $/ = "\n"; + my(@mflines) = <$mfh>; + for (@mflines) { + s/^\s+//; + s/\s.*//s; + } + while (length($lfre)>5 and !$lfl) { + ($lfl) = grep /$lfre/, @mflines; + CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG; + $lfre =~ s/.+?\.//; + } + $lfl =~ s/\s.*//; # remove comments + $lfl =~ s/\s+//g; # chomp would maybe be too system-specific + my $lfl_abs = MM->catfile($dist->{build_dir},$lfl); + # warn "lfl_abs[$lfl_abs]"; + if (-f $lfl_abs) { + $self->{MANPAGE} = $self->manpage_headline($lfl_abs); + } + } + } } my($item); for $item (qw/MANPAGE/) { @@ -4744,26 +5099,29 @@ sub cpan_file { } if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){ return $self->{RO}{CPAN_FILE}; - } elsif ( defined $self->userid ) { - my $fullname = $CPAN::META->instance("CPAN::Author", - $self->userid)->fullname; - my $email = $CPAN::META->instance("CPAN::Author", - $self->userid)->email; - unless (defined $fullname && defined $email) { - my $userid = $self->userid; - return sprintf("Contact Author %s (Try 'a %s')", - $userid, - $userid, - ); - } - return "Contact Author $fullname <$email>"; } else { - return "N/A"; + my $userid = $self->userid; + if ( $userid ) { + if ($CPAN::META->exists("CPAN::Author",$userid)) { + my $author = $CPAN::META->instance("CPAN::Author", + $userid); + my $fullname = $author->fullname; + my $email = $author->email; + unless (defined $fullname && defined $email) { + return sprintf("Contact Author %s", + $userid, + ); + } + return "Contact Author $fullname <$email>"; + } else { + return "UserID $userid"; + } + } else { + return "N/A"; + } } } -*name = \&cpan_file; - #-> sub CPAN::Module::cpan_version ; sub cpan_version { my $self = shift; @@ -5087,10 +5445,29 @@ sub DESTROY { # CPAN::Tarzip::untar sub untar { my($class,$file) = @_; + my($prefer) = 0; + if (0) { # makes changing order easier + } elsif ($BUGHUNTING){ + $prefer=2; } elsif (MM->maybe_command($CPAN::Config->{gzip}) - && - MM->maybe_command($CPAN::Config->{'tar'})) { + && + MM->maybe_command($CPAN::Config->{'tar'})) { + # should be default until Archive::Tar is fixed + $prefer = 1; + } elsif ( + $CPAN::META->has_inst("Archive::Tar") + && + $CPAN::META->has_inst("Compress::Zlib") ) { + $prefer = 2; + } else { + $CPAN::Frontend->mydie(qq{ +CPAN.pm needs either both external programs tar and gzip installed or +both the modules Archive::Tar and Compress::Zlib. Neither prerequisite +is available. Can\'t continue. +}); + } + if ($prefer==1) { # 1 => external gzip+tar my($system); my $is_compressed = $class->gtest($file); if ($is_compressed) { @@ -5122,33 +5499,43 @@ sub untar { } else { return 1; } - } elsif ($CPAN::META->has_inst("Archive::Tar") - && - $CPAN::META->has_inst("Compress::Zlib") ) { + } elsif ($prefer==2) { # 2 => modules my $tar = Archive::Tar->new($file,1); my $af; # archive file my @af; - for $af ($tar->list_files) { - if ($af =~ m!^(/|\.\./)!) { - $CPAN::Frontend->mydie("ALERT: Archive contains ". - "illegal member [$af]"); + if ($BUGHUNTING) { + # RCS 1.337 had this code, it turned out unacceptable slow but + # it revealed a bug in Archive::Tar. Code is only here to hunt + # the bug again. It should never be enabled in published code. + # GDGraph3d-0.53 was an interesting case according to Larry + # Virden. + warn(">>>Bughunting code enabled<<< " x 20); + for $af ($tar->list_files) { + if ($af =~ m!^(/|\.\./)!) { + $CPAN::Frontend->mydie("ALERT: Archive contains ". + "illegal member [$af]"); + } + $CPAN::Frontend->myprint("$af\n"); + $tar->extract($af); # slow but effective for finding the bug + return if $CPAN::Signal; } - $CPAN::Frontend->myprint("$af\n"); - push @af, $af; - return if $CPAN::Signal; + } else { + for $af ($tar->list_files) { + if ($af =~ m!^(/|\.\./)!) { + $CPAN::Frontend->mydie("ALERT: Archive contains ". + "illegal member [$af]"); + } + $CPAN::Frontend->myprint("$af\n"); + push @af, $af; + return if $CPAN::Signal; + } + $tar->extract(@af); } - $tar->extract(@af); ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1) if ($^O eq 'MacOS'); return 1; - } else { - $CPAN::Frontend->mydie(qq{ -CPAN.pm needs either both external programs tar and gzip installed or -both the modules Archive::Tar and Compress::Zlib. Neither prerequisite -is available. Can\'t continue. -}); } } @@ -5226,9 +5613,8 @@ sub float2vv { my($self,$n) = @_; my($rev) = int($n); $rev ||= 0; - my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits so that - # architecture cannot - # influnce + my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit + # architecture influence $mantissa ||= 0; $mantissa .= "0" while length($mantissa)%3; my $ret = "v" . $rev; @@ -5310,11 +5696,11 @@ the make processes and deletes excess space according to a simple FIFO mechanism. For extended searching capabilities there's a plugin for CPAN available, -L<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 @@ -5333,6 +5719,10 @@ command completion. Once you are on the command line, type 'h' and the rest should be self-explanatory. +The function call C<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 @@ -5519,6 +5909,12 @@ list of CPAN::Module objects according to the C<@things> arguments given. In scalar context it only returns the first element of the list. +=item expandany(@things) + +Like expand, but returns objects of the appropriate type, i.e. +CPAN::Bundle objects for bundles, CPAN::Module objects for modules and +CPAN::Distribution objects fro distributions. + =item Programming Examples This enables the programmer to do operations that combine @@ -5549,13 +5945,13 @@ all modules that need updating. First a quick and dirty way: perl -e 'use CPAN; CPAN::Shell->r;' -If you don't want to get any output if all modules are up to date, you -can parse the output of above command for the regular expression -//modules are up to date// and decide to mail the output only if it -doesn't match. Ick? +If you don't want to get any output in the case that all modules are +up to date, you can parse the output of above command for the regular +expression //modules are up to date// and decide to mail the output +only if it doesn't match. Ick? If you prefer to do it more in a programmer style in one single -process, maybe something like this suites you better: +process, maybe something like this suits you better: # list all modules on my disk that have newer versions on CPAN for $mod (CPAN::Shell->expand("Module","/./")){ @@ -5581,7 +5977,299 @@ tricks: =back -=head2 Methods in the four Classes +=head2 Methods in the other Classes + +The programming interface for the classes CPAN::Module, +CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered +beta and partially even alpha. In the following paragraphs only those +methods are documented that have proven useful over a longer time and +thus are unlikely to change. + +=over + +=item CPAN::Author::as_glimpse() + +Returns a one-line description of the author + +=item CPAN::Author::as_string() + +Returns a multi-line description of the author + +=item CPAN::Author::email() + +Returns the author's email address + +=item CPAN::Author::fullname() + +Returns the author's name + +=item CPAN::Author::name() + +An alias for fullname + +=item CPAN::Bundle::as_glimpse() + +Returns a one-line description of the bundle + +=item CPAN::Bundle::as_string() + +Returns a multi-line description of the bundle + +=item CPAN::Bundle::clean() + +Recursively runs the C<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 @@ -5734,6 +6422,8 @@ defined: ('follow' automatically, 'ask' me, or 'ignore') scan_cache controls scanning of cache ('atstart' or 'never') tar location of external program tar + term_is_latin if true internal UTF-8 is translated to ISO-8859-1 + (and nonsense for characters outside latin range) unzip location of external program unzip urllist arrayref to nearby CPAN sites (or equivalent locations) wait_list arrayref to a wait server to try (See CPAN::WAIT) @@ -5821,8 +6511,8 @@ oneliners. =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES -To populate a freshly installed perl with my favorite modules is pretty -easiest by maintaining a private bundle definition file. To get a useful +Populating a freshly installed perl with my favorite modules is pretty +easy if you maintain a private bundle definition file. To get a useful blueprint of a bundle definition file, the command autobundle can be used on the CPAN shell command line. This command writes a bundle definition file for all modules that are installed for the currently running perl @@ -5834,7 +6524,7 @@ Bundle/my_bundle.pm. With a clever bundle file you can then simply say then answer a few questions and then go out for a coffee. -Maintaining a bundle definition file means to keep track of two +Maintaining a bundle definition file means keeping track of two things: dependencies and interactivity. CPAN.pm sometimes fails on calculating dependencies because not all modules define all MakeMaker attributes correctly, so a bundle definition file should specify @@ -5843,7 +6533,7 @@ annoying that many distributions need some interactive configuring. So what I try to accomplish in my private bundle file is to have the packages that need to be configured early in the file and the gentle ones later, so I can go out after a few minutes and leave CPAN.pm -unattained. +untended. =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS @@ -5905,7 +6595,7 @@ the firewall as if it is not there. This is the firewall implemented in the Linux kernel, it allows you to hide a complete network behind one IP address. With this firewall no -special compiling is need as you can access hosts directly. +special compiling is needed as you can access hosts directly. =back @@ -5933,8 +6623,10 @@ Your milage may vary... =over -=item 1) I installed a new version of module X but CPAN keeps saying, - I have the old version installed +=item 1) + +I installed a new version of module X but CPAN keeps saying, +I have the old version installed Most probably you B<do> have the old version installed. This can happen if a module installs itself into a different directory in the @@ -5946,14 +6638,35 @@ many people add this argument permanently by configuring o conf make_install_arg UNINST=1 -=item 2) So why is UNINST=1 not the default? +=item 2) + +So why is UNINST=1 not the default? Because there are people who have their precise expectations about who may install where in the @INC path and who uses which @INC array. In fine tuned environments C<UNINST=1> can cause damage. -=item 3) When I install bundles or multiple modules with one command - there is too much output to keep track of +=item 3) + +I want to clean up my mess, and install a new perl along with +all modules I have. How do I go about it? + +Run the autobundle command for your old perl and optionally rename the +resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl +with the Configure option prefix, e.g. + + ./Configure -Dprefix=/usr/local/perl-5.6.78.9 + +Install the bundle file you produced in the first step with something like + + cpan> install Bundle::mybundle + +and you're done. + +=item 4) + +When I install bundles or multiple modules with one command +there is too much output to keep track of. You may want to configure something like @@ -5963,8 +6676,9 @@ You may want to configure something like so that STDOUT is captured in a file for later inspection. -=item 4) I am not root, how can I install a module in a personal - directory? +=item 5) + +I am not root, how can I install a module in a personal directory? You will most probably like something like this: @@ -5987,14 +6701,17 @@ or setting the PERL5LIB environment variable. Another thing you should bear in mind is that the UNINST parameter should never be set if you are not root. -=item 5) How to get a package, unwrap it, and make a change before - building it? +=item 6) + +How to get a package, unwrap it, and make a change before building it? look Sybase::Sybperl -=item 6) I installed a Bundle and had a couple of fails. When I - retried, everything resolved nicely. Can this be fixed to work - on first try? +=item 7) + +I installed a Bundle and had a couple of fails. When I +retried, everything resolved nicely. Can this be fixed to work +on first try? The reason for this is that CPAN does not know the dependencies of all modules when it starts out. To decide about the additional items to @@ -6011,12 +6728,38 @@ definition file manually. It is planned to improve the metadata situation for dependencies on CPAN in general, but this will still take some time. -=item 7) In our intranet we have many modules for internal use. How - can I integrate these modules with CPAN.pm but without uploading - the modules to CPAN? +=item 8) + +In our intranet we have many modules for internal use. How +can I integrate these modules with CPAN.pm but without uploading +the modules to CPAN? Have a look at the CPAN::Site module. +=item 9) + +When I run CPAN's shell, I get error msg about line 1 to 4, +setting meta input/output via the /etc/inputrc file. + +Some versions of readline are picky about capitalization in the +/etc/inputrc file and specifically RedHat 6.2 comes with a +/etc/inputrc that contains the word C<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 diff --git a/lib/CPAN/FirstTime.pm b/lib/CPAN/FirstTime.pm index 9f8366e073..7cf01cd20c 100644 --- a/lib/CPAN/FirstTime.pm +++ b/lib/CPAN/FirstTime.pm @@ -1,3 +1,4 @@ +# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- package CPAN::Mirrored::By; sub new { @@ -16,7 +17,7 @@ use FileHandle (); use File::Basename (); use File::Path (); use vars qw($VERSION); -$VERSION = substr q$Revision: 1.46 $, 10; +$VERSION = substr q$Revision: 1.51 $, 10; =head1 NAME @@ -174,6 +175,9 @@ disable the cache scanning with 'never'. } while ($ans ne 'atstart' && $ans ne 'never'); $CPAN::Config->{scan_cache} = $ans; + # + # cache_metadata + # print qq{ To considerably speed up the initial CPAN shell startup, it is @@ -189,6 +193,30 @@ is not available, the normal index mechanism will be used. $CPAN::Config->{cache_metadata} = ($ans =~ /^\s*y/i ? 1 : 0); # + # term_is_latin + # + print qq{ + +The next option deals with the charset your terminal supports. In +general CPAN is English speaking territory, thus the charset does not +matter much, but some of the aliens out there who upload their +software to CPAN bear names that are outside the ASCII range. If your +terminal supports UTF-8, you say no to the next question, if it +supports ISO-8859-1 (also known as LATIN1) then you say yes, and if it +supports neither nor, your answer does not matter, you will not be +able to read the names of some authors anyway. If you answer no, nmes +will be output in UTF-8. + +}; + + defined($default = $CPAN::Config->{term_is_latin}) or $default = 1; + do { + $ans = prompt("Your terminal expects ISO-8859-1 (yes/no)?", + ($default ? 'yes' : 'no')); + } while ($ans !~ /^\s*[yn]/i); + $CPAN::Config->{term_is_latin} = ($ans =~ /^\s*y/i ? 1 : 0); + + # # prerequisites_policy # Do we follow PREREQ_PM? # @@ -216,10 +244,11 @@ policy to one of the three values. print qq{ -The CPAN module will need a few external programs to work -properly. Please correct me, if I guess the wrong path for a program. -Don\'t panic if you do not have some of them, just press ENTER for -those. +The CPAN module will need a few external programs to work properly. +Please correct me, if I guess the wrong path for a program. Don\'t +panic if you do not have some of them, just press ENTER for those. To +disable the use of a download program, you can type a space followed +by ENTER. }; @@ -228,7 +257,7 @@ those. my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'}; local $^W = $old_warn; my $progname; - for $progname (qw/gzip tar unzip make lynx ncftpget ncftp ftp/){ + for $progname (qw/gzip tar unzip make lynx wget ncftpget ncftp ftp/){ if ($^O eq 'MacOS') { $CPAN::Config->{$progname} = 'not_here'; next; @@ -286,9 +315,9 @@ those. print qq{ Every Makefile.PL is run by perl in a separate process. Likewise we -run \'make\' and \'make install\' in processes. If you have any parameters -\(e.g. PREFIX, INSTALLPRIVLIB, UNINST or the like\) you want to pass to -the calls, please specify them here. +run \'make\' and \'make install\' in processes. If you have any +parameters \(e.g. PREFIX, LIB, UNINST or the like\) you want to pass +to the calls, please specify them here. If you don\'t understand this question, just press ENTER. @@ -296,13 +325,29 @@ If you don\'t understand this question, just press ENTER. $default = $CPAN::Config->{makepl_arg} || ""; $CPAN::Config->{makepl_arg} = - prompt("Parameters for the 'perl Makefile.PL' command?",$default); + prompt("Parameters for the 'perl Makefile.PL' command? +Typical frequently used settings: + + POLLUTE=1 increasing backwards compatibility + LIB=~/perl non-root users (please see manual for more hints) + +Your choice: ",$default); $default = $CPAN::Config->{make_arg} || ""; - $CPAN::Config->{make_arg} = prompt("Parameters for the 'make' command?",$default); + $CPAN::Config->{make_arg} = prompt("Parameters for the 'make' command? +Typical frequently used setting: + + -j3 dual processor system + +Your choice: ",$default); $default = $CPAN::Config->{make_install_arg} || $CPAN::Config->{make_arg} || ""; $CPAN::Config->{make_install_arg} = - prompt("Parameters for the 'make install' command?",$default); + prompt("Parameters for the 'make install' command? +Typical frequently used setting: + + UNINST=1 to always uninstall potentially conflicting files + +Your choice: ",$default); # # Alarm period @@ -376,8 +421,26 @@ sub conf_sites { } my $loopcount = 0; local $^T = time; + my $overwrite_local = 0; + if ($mby && -f $mby && -M _ <= 60 && -s _ > 0) { + my $mtime = localtime((stat _)[9]); + my $prompt = qq{Found $mby as of $mtime + + I\'d use that as a database of CPAN sites. If that is OK for you, + please answer 'y', but if you want me to get a new database now, + please answer 'n' to the following question. + + Shall I use the local database in $mby?}; + my $ans = prompt($prompt,"y"); + $overwrite_local = 1 unless $ans =~ /^y/i; + } while ($mby) { - if ( ! -f $mby ){ + if ($overwrite_local) { + print qq{Trying to overwrite $mby +}; + $mby = CPAN::FTP->localize($m,$mby,3); + $overwrite_local = 0; + } elsif ( ! -f $mby ){ print qq{You have no $mby I\'m trying to fetch one }; @@ -519,7 +582,8 @@ http: -- that host a CPAN mirror. } } push (@urls, map ("$_ (previous pick)", @previous_urls)); - my $prompt = "Select as many URLs as you like"; + my $prompt = "Select as many URLs as you like, +put them on one line, separated by blanks"; if (@previous_urls) { $default = join (' ', ((scalar @urls) - (scalar @previous_urls) + 1) .. (scalar @urls)); @@ -547,11 +611,15 @@ Please enter your CPAN site:}; $ans =~ s|/?\z|/|; # has to end with one slash $ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file: if ($ans =~ /^\w+:\/./) { - push @urls, $ans unless $seen{$ans}++; + push @urls, $ans unless $seen{$ans}++; } else { - print qq{"$ans" doesn\'t look like an URL at first sight. -I\'ll ignore it for now. You can add it to $INC{'CPAN/MyConfig.pm'} -later if you\'re sure it\'s right.\n}; + printf(qq{"%s" doesn\'t look like an URL at first sight. +I\'ll ignore it for now. +You can add it to your %s +later if you\'re sure it\'s right.\n}, + $ans, + $INC{'CPAN/MyConfig.pm'} || $INC{'CPAN/Config.pm'} || "configuration file", + ); } } } while $ans || !%seen; diff --git a/lib/Carp.pm b/lib/Carp.pm index 43524ddbe5..69d477b486 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -1,5 +1,7 @@ package Carp; +our $VERSION = '1.00'; + =head1 NAME carp - warn of errors (from perspective of caller) @@ -68,6 +70,8 @@ $MaxArgLen = 64; # How much of each argument to print. 0 = all. $MaxArgNums = 8; # How many arguments to print. 0 = all. $Verbose = 0; # If true then make shortmess call longmess instead +$CarpInternal{Carp}++; + require Exporter; @ISA = ('Exporter'); @EXPORT = qw(confess croak carp); diff --git a/lib/Carp/Heavy.pm b/lib/Carp/Heavy.pm index 8cfdcb48f0..b551560e61 100644 --- a/lib/Carp/Heavy.pm +++ b/lib/Carp/Heavy.pm @@ -1,247 +1,244 @@ +# Carp::Heavy uses some variables in common with Carp. package Carp; =head1 NAME -Carp::Heavy - Carp guts +Carp heavy machinery - no user serviceable parts inside -=head1 SYNOPIS +=cut -(internal use only) +# use strict; # not yet + +# On one line so MakeMaker will see it. +use Carp; our $VERSION = $Carp::VERSION; + +our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxLenArg, $Verbose); + +sub caller_info { + my $i = shift(@_) + 1; + package DB; + my %call_info; + @call_info{ + qw(pack file line sub has_args wantarray evaltext is_require) + } = caller($i); + + unless (defined $call_info{pack}) { + return (); + } + + my $sub_name = Carp::get_subname(\%call_info); + if ($call_info{has_args}) { + # Reuse the @args array to avoid warnings. :-) + local @args = map {Carp::format_arg($_)} @args; + if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show? + $#args = $MaxArgNums; + push @args, '...'; + } + # Push the args onto the subroutine + $sub_name .= '(' . join (',', @args) . ')'; + } + $call_info{sub_name} = $sub_name; + return wantarray() ? %call_info : \%call_info; +} -=head1 DESCRIPTION +# Transform an argument to a function into a string. +sub format_arg { + my $arg = shift; + if (not defined($arg)) { + $arg = 'undef'; + } + elsif (ref($arg)) { + $arg .= ''; # Make it a string; + } + $arg =~ s/'/\\'/g; + $arg = str_len_trim($arg, $MaxLenArg); + + # Quote it? + $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/; + + # The following handling of "control chars" is direct from + # the original code - I think it is broken on Unicode though. + # Suggestions? + $arg =~ s/([[:cntrl:]]|[[^:ascii:]])/sprintf("\\x{%x}",ord($1))/eg; + return $arg; +} -No user-serviceable parts inside. +# Takes an inheritance cache and a package and returns +# an anon hash of known inheritances and anon array of +# inheritances which consequences have not been figured +# for. +sub get_status { + my $cache = shift; + my $pkg = shift; + $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]]; + return @{$cache->{$pkg}}; +} -=cut +# Takes the info from caller() and figures out the name of +# the sub/require/eval +sub get_subname { + my $info = shift; + if (defined($info->{eval})) { + my $eval = $info->{eval}; + if ($info->{is_require}) { + return "require $eval"; + } + else { + $eval =~ s/([\\\'])/\\$1/g; + return str_len_trim($eval, $MaxEvalLen); + } + } -# This package is heavily used. Be small. Be fast. Be good. + return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub}; +} -# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an -# _almost_ complete understanding of the package. Corrections and -# comments are welcome. +# Figures out what call (from the point of view of the caller) +# the long error backtrace should start at. +sub long_error_loc { + my $i; + my $lvl = $CarpLevel; + { + my $pkg = caller(++$i); + unless(defined($pkg)) { + # This *shouldn't* happen. + if (%Internal) { + local %Internal; + $i = long_error_loc(); + last; + } + else { + # OK, now I am irritated. + return 2; + } + } + redo if $CarpInternal{$pkg}; + redo unless 0 > --$lvl; + redo if $Internal{$pkg}; + } + return $i - 1; +} -# longmess() crawls all the way up the stack reporting on all the function -# calls made. The error string, $error, is originally constructed from the -# arguments passed into longmess() via confess(), cluck() or shortmess(). -# This gets appended with the stack trace messages which are generated for -# each function call on the stack. sub longmess_heavy { - return @_ if ref $_[0]; - my $error = join '', @_; - my $mess = ""; - my $i = 1 + $CarpLevel; - my ($pack,$file,$line,$sub,$hargs,$eval,$require); - my (@a); - # - # crawl up the stack.... - # - while (do { { package DB; @a = caller($i++) } } ) { - # get copies of the variables returned from caller() - ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; - # - # if the $error error string is newline terminated then it - # is copied into $mess. Otherwise, $mess gets set (at the end of - # the 'else' section below) to one of two things. The first time - # through, it is set to the "$error at $file line $line" message. - # $error is then set to 'called' which triggers subsequent loop - # iterations to append $sub to $mess before appending the "$error - # at $file line $line" which now actually reads "called at $file line - # $line". Thus, the stack trace message is constructed: - # - # first time: $mess = $error at $file line $line - # subsequent times: $mess .= $sub $error at $file line $line - # ^^^^^^ - # "called" - if ($error =~ m/\n$/) { - $mess .= $error; - } else { - # Build a string, $sub, which names the sub-routine called. - # This may also be "require ...", "eval '...' or "eval {...}" - if (defined $eval) { - if ($require) { - $sub = "require $eval"; - } else { - $eval =~ s/([\\\'])/\\$1/g; - if ($MaxEvalLen && length($eval) > $MaxEvalLen) { - substr($eval,$MaxEvalLen) = '...'; - } - $sub = "eval '$eval'"; - } - } elsif ($sub eq '(eval)') { - $sub = 'eval {...}'; - } - # if there are any arguments in the sub-routine call, format - # them according to the format variables defined earlier in - # this file and join them onto the $sub sub-routine string - if ($hargs) { - # we may trash some of the args so we take a copy - @a = @DB::args; # must get local copy of args - # don't print any more than $MaxArgNums - if ($MaxArgNums and @a > $MaxArgNums) { - # cap the length of $#a and set the last element to '...' - $#a = $MaxArgNums; - $a[$#a] = "..."; - } - for (@a) { - # set args to the string "undef" if undefined - $_ = "undef", next unless defined $_; - if (ref $_) { - # force reference to string representation - $_ .= ''; - s/'/\\'/g; - } - else { - s/'/\\'/g; - # terminate the string early with '...' if too long - substr($_,$MaxArgLen) = '...' - if $MaxArgLen and $MaxArgLen < length; - } - # 'quote' arg unless it looks like a number - $_ = "'$_'" unless /^-?[\d.]+$/; - # print high-end chars as 'M-<char>' - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - # print remaining control chars as ^<char> - s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; - } - # append ('all', 'the', 'arguments') to the $sub string - $sub .= '(' . join(', ', @a) . ')'; - } - # here's where the error message, $mess, gets constructed - $mess .= "\t$sub " if $error eq "called"; - $mess .= "$error at $file line $line"; - if (defined &Thread::tid) { - my $tid = Thread->self->tid; - $mess .= " thread $tid" if $tid; - } - $mess .= "\n"; - } - # we don't need to print the actual error message again so we can - # change this to "called" so that the string "$error at $file line - # $line" makes sense as "called at $file line $line". - $error = "called"; - } - $mess || $error; + return @_ if ref($_[0]); # WHAT IS THIS FOR??? + my $i = long_error_loc(); + return ret_backtrace($i, @_); } +# Returns a full stack backtrace starting from where it is +# told. +sub ret_backtrace { + my ($i, @error) = @_; + my $mess; + my $err = join '', @error; + $i++; + + my $tid_msg = ''; + if (defined &Thread::tid) { + my $tid = Thread->self->tid; + $tid_msg = " thread $tid" if $tid; + } + + if ($err =~ /\n$/) { + $mess = $err; + } + else { + my %i = caller_info($i); + $mess = "$err at $i{file} line $i{line}$tid_msg\n"; + } + + while (my %i = caller_info(++$i)) { + $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; + } + + return $mess || $err; +} -# ancestors() returns the complete set of ancestors of a module - -sub ancestors($$); - -sub ancestors($$){ - my( $pack, $href ) = @_; - if( @{"${pack}::ISA"} ){ - my $risa = \@{"${pack}::ISA"}; - my %tree = (); - @tree{@$risa} = (); - foreach my $mod ( @$risa ){ - # visit ancestors - if not already in the gallery - if( ! defined( $$href{$mod} ) ){ - my @ancs = ancestors( $mod, $href ); - @tree{@ancs} = (); - } - } - return ( keys( %tree ) ); - } else { - return (); - } +sub ret_summary { + my ($i, @error) = @_; + my $mess; + my $err = join '', @error; + $i++; + + my $tid_msg = ''; + if (defined &Thread::tid) { + my $tid = Thread->self->tid; + $tid_msg = " thread $tid" if $tid; + } + + my %i = caller_info($i); + return "$err at $i{file} line $i{line}$tid_msg\n"; +} + + +sub short_error_loc { + my $cache; + my $i = 1; + my $lvl = $CarpLevel; + { + my $called = caller($i++); + my $caller = caller($i); + return 0 unless defined($caller); # What happened? + redo if $Internal{$caller}; + redo if $CarpInternal{$called}; + redo if trusts($called, $caller, $cache); + redo if trusts($caller, $called, $cache); + redo unless 0 > --$lvl; + } + return $i - 1; +} + +sub shortmess_heavy { + return longmess_heavy(@_) if $Verbose; + return @_ if ref($_[0]); # WHAT IS THIS FOR??? + my $i = short_error_loc(); + if ($i) { + ret_summary($i, @_); + } + else { + longmess_heavy(@_); + } } +# If a string is too long, trims it with ... +sub str_len_trim { + my $str = shift; + my $max = shift || 0; + if (2 < $max and $max < length($str)) { + substr($str, $max - 3) = '...'; + } + return $str; +} -# shortmess() is called by carp() and croak() to skip all the way up to -# the top-level caller's package and report the error from there. confess() -# and cluck() generate a full stack trace so they call longmess() to -# generate that. In verbose mode shortmess() calls longmess() so -# you always get a stack trace - -sub shortmess_heavy { # Short-circuit &longmess if called via multiple packages - goto &longmess_heavy if $Verbose; - return @_ if ref $_[0]; - my $error = join '', @_; - my ($prevpack) = caller(1); - my $extra = $CarpLevel; - - my @Clans = ( $prevpack ); - my $i = 2; - my ($pack,$file,$line); - # when reporting an error, we want to report it from the context of the - # calling package. So what is the calling package? Within a module, - # there may be many calls between methods and perhaps between sub-classes - # and super-classes, but the user isn't interested in what happens - # inside the package. We start by building a hash array which keeps - # track of all the packages to which the calling package belongs. We - # do this by examining its @ISA variable. Any call from a base class - # method (one of our caller's @ISA packages) can be ignored - my %isa; - - # merge all the caller's @ISA packages and ancestors into %isa. - my @pars = ancestors( $prevpack, \%isa ); - @isa{@pars} = () if @pars; - $isa{$prevpack} = 1; - - # now we crawl up the calling stack and look at all the packages in - # there. For each package, we look to see if it has an @ISA and then - # we see if our caller features in that list. That would imply that - # our caller is a derived class of that package and its calls can also - # be ignored -CALLER: - while (($pack,$file,$line) = caller($i++)) { - - # Chances are, the caller's caller (or its caller...) is already - # in the gallery - if so, ignore this caller. - next if exists( $isa{$pack} ); - - # no: collect this module's ancestors. - my @i = ancestors( $pack, \%isa ); - my %i; - if( @i ){ - @i{@i} = (); - # check whether our representative of one of the clans is - # in this family tree. - foreach my $cl (@Clans){ - if( exists( $i{$cl} ) ){ - # yes: merge all of the family tree into %isa - @isa{@i,$pack} = (); - # and here's where we do some more ignoring... - # if the package in question is one of our caller's - # base or derived packages then we can ignore it (skip it) - # and go onto the next. - next CALLER if exists( $isa{$pack} ); - last; - } - } - } - - # Hey! We've found a package that isn't one of our caller's - # clan....but wait, $extra refers to the number of 'extra' levels - # we should skip up. If $extra > 0 then this is a false alarm. - # We must merge the package into the %isa hash (so we can ignore it - # if it pops up again), decrement $extra, and continue. - if ($extra-- > 0) { - push( @Clans, $pack ); - @isa{@i,$pack} = (); - } - else { - # OK! We've got a candidate package. Time to construct the - # relevant error message and return it. - my $msg; - $msg = "$error at $file line $line"; - if (defined &Thread::tid) { - my $tid = Thread->self->tid; - $mess .= " thread $tid" if $tid; - } - $msg .= "\n"; - return $msg; - } +# Takes two packages and an optional cache. Says whether the +# first inherits from the second. +# +# Recursive versions of this have to work to avoid certain +# possible endless loops, and when following long chains of +# inheritance are less efficient. +sub trusts { + my $child = shift; + my $parent = shift; + my $cache = shift || {}; + my ($known, $partial) = get_status($cache, $child); + # Figure out consequences until we have an answer + while (@$partial and not exists $known->{$parent}) { + my $anc = shift @$partial; + next if exists $known->{$anc}; + $known->{$anc}++; + my ($anc_knows, $anc_partial) = get_status($cache, $anc); + my @found = keys %$anc_knows; + @$known{@found} = (); + push @$partial, @$anc_partial; } + return exists $known->{$parent}; +} - # uh-oh! It looks like we crawled all the way up the stack and - # never found a candidate package. Oh well, let's call longmess - # to generate a full stack trace. We use the magical form of 'goto' - # so that this shortmess() function doesn't appear on the stack - # to further confuse longmess() about it's calling package. - goto &longmess_heavy; +# Takes a package and gives a list of those trusted directly +sub trusts_directly { + my $class = shift; + return @{"$class\::ISA"}; } 1; + diff --git a/lib/Class/Struct.pm b/lib/Class/Struct.pm index ac1fb4736d..185a8ff142 100644 --- a/lib/Class/Struct.pm +++ b/lib/Class/Struct.pm @@ -14,7 +14,7 @@ require Exporter; @ISA = qw(Exporter); @EXPORT = qw(struct); -$VERSION = '0.58'; +$VERSION = '0.59'; ## Tested on 5.002 and 5.003 without class membership tests: my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95); @@ -51,6 +51,20 @@ sub printem { sub DESTROY { } } +sub import { + my $self = shift; + + if ( @_ == 0 ) { + $self->export_to_level( 1, $self, @EXPORT ); + } elsif ( @_ == 1 ) { + # This is admittedly a little bit silly: + # do we ever export anything else than 'struct'...? + $self->export_to_level( 1, $self, @_ ); + } else { + &struct; + } +} + sub struct { # Determine parameter list structure, one of: @@ -76,6 +90,7 @@ sub struct { $class = (caller())[0]; @decls = @_; } + _usage_error() if @decls % 2 == 1; # Ensure we are not, and will not be, a subclass. @@ -242,6 +257,9 @@ Class::Struct - declare struct-like datatypes as Perl classes # declare struct, based on array, implicit class name: struct( ELEMENT_NAME => ELEMENT_TYPE, ... ); + # Declare struct at compile time + use Class::Struct CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]; + use Class::Struct CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... }; package Myobj; use Class::Struct; @@ -262,14 +280,13 @@ Class::Struct - declare struct-like datatypes as Perl classes # hash type accessor: $hash_ref = $obj->h; # reference to whole hash $hash_element_value = $obj->h('x'); # hash element value - $obj->h('x', 'new value'); # assign to hash element + $obj->h('x', 'new value'); # assign to hash element # class type accessor: $element_value = $obj->c; # object reference $obj->c->method(...); # call method of object $obj->c(new My_Other_Class); # assign a new object - =head1 DESCRIPTION C<Class::Struct> exports a single function, C<struct>. @@ -287,7 +304,6 @@ same name in the package. (See Example 2.) Each element's type can be scalar, array, hash, or class. - =head2 The C<struct()> function The C<struct> function has three forms of parameter-list. @@ -326,6 +342,15 @@ element name will be defined as an accessor method unless a method by that name is explicitly defined; in the latter case, a warning is issued if the warning flag (B<-w>) is set. +=head2 Class Creation at Compile Time + +C<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 @@ -410,7 +435,6 @@ contents of that hash are passed to the element's own constructor. See Example 3 below for an example of initialization. - =head1 EXAMPLES =over @@ -444,7 +468,6 @@ type C<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 @@ -492,7 +515,6 @@ Note that the initializer for a nested struct is specified as an anonymous hash of initializers, which is passed on to the nested struct's constructor. - use Class::Struct; struct Breed => @@ -524,6 +546,9 @@ struct's constructor. =head1 Author and Modification History +Modified by Casey Tweten, 2000-11-08, v0.59. + + Added the ability for compile time class creation. Modified by Damian Conway, 1999-03-05, v0.58. @@ -541,7 +566,6 @@ Modified by Damian Conway, 1999-03-05, v0.58. Previously these were returned as a reference to a reference to the element. - Renamed to C<Class::Struct> and modified by Jim Miner, 1997-04-02. members() function removed. @@ -553,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/lib/Cwd.pm b/lib/Cwd.pm index 727959132c..4a263cd5fa 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -70,7 +70,7 @@ use strict; use Carp; -our $VERSION = '2.03'; +our $VERSION = '2.04'; use base qw/ Exporter /; our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); @@ -99,6 +99,9 @@ unless(defined &cwd) { } } +# set a reasonable (and very safe) default for fastgetcwd, in case it +# isn't redefined later (20001212 rspier) +*fastgetcwd = \&cwd; # By Brandon S. Allbery # @@ -188,7 +191,7 @@ sub chdir_init { } sub chdir { - my $newdir = @? ? shift : ''; # allow for no arg (chdir to HOME dir) + my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir) $newdir =~ s|///*|/|g unless $^O eq 'MSWin32'; chdir_init() unless $chdir_init; return 0 unless CORE::chdir $newdir; @@ -408,7 +411,8 @@ sub _epoc_cwd { *abs_path = \&fast_abs_path; } elsif ($^O eq 'epoc') { - *getcwd = \&_epoc_cwd; + *cwd = \&_epoc_cwd; + *getcwd = \&_epoc_cwd; *fastgetcwd = \&_epoc_cwd; *fastcwd = \&_epoc_cwd; *abs_path = \&fast_abs_path; diff --git a/lib/DirHandle.pm b/lib/DirHandle.pm index 047755dc17..12ee6c6343 100644 --- a/lib/DirHandle.pm +++ b/lib/DirHandle.pm @@ -1,5 +1,7 @@ package DirHandle; +our $VERSION = '1.00'; + =head1 NAME DirHandle - supply object methods for directory handles diff --git a/lib/Dumpvalue.pm b/lib/Dumpvalue.pm index 475f4ff725..c8282cfbd5 100644 --- a/lib/Dumpvalue.pm +++ b/lib/Dumpvalue.pm @@ -1,6 +1,7 @@ use 5.005_64; # for (defined ref) and $#$v and our package Dumpvalue; use strict; +our $VERSION = '1.00'; our(%address, $stab, @stab, %stab, %subs); # translate control chars to ^X - Randal Schwartz diff --git a/lib/English.pm b/lib/English.pm index 1ebc3de11d..77f27c5b71 100644 --- a/lib/English.pm +++ b/lib/English.pm @@ -1,5 +1,7 @@ package English; +our $VERSION = '1.00'; + require Exporter; @ISA = (Exporter); diff --git a/lib/Env.pm b/lib/Env.pm index d1ee071cf8..eb9187fc90 100644 --- a/lib/Env.pm +++ b/lib/Env.pm @@ -1,5 +1,7 @@ package Env; +our $VERSION = '1.00'; + =head1 NAME Env - perl module that imports environment variables as scalars or arrays diff --git a/lib/Exporter.pm b/lib/Exporter.pm index 585109e7d0..ad6cdef87e 100644 --- a/lib/Exporter.pm +++ b/lib/Exporter.pm @@ -2,88 +2,85 @@ package Exporter; require 5.001; -$ExportLevel = 0; -$Verbose ||= 0; -$VERSION = '5.562'; +use strict; +no strict 'refs'; + +our $Debug = 0; +our $ExportLevel = 0; +our $Verbose ||= 0; +our $VERSION = '5.562'; sub export_to_level { require Exporter::Heavy; - goto &heavy_export_to_level; + goto &Exporter::Heavy::heavy_export_to_level; } sub export { require Exporter::Heavy; - goto &heavy_export; + goto &Exporter::Heavy::heavy_export; } sub export_tags { require Exporter::Heavy; - _push_tags((caller)[0], "EXPORT", \@_); + Exporter::Heavy::_push_tags((caller)[0], "EXPORT", \@_); } sub export_ok_tags { require Exporter::Heavy; - _push_tags((caller)[0], "EXPORT_OK", \@_); + Exporter::Heavy::_push_tags((caller)[0], "EXPORT_OK", \@_); } sub import { my $pkg = shift; my $callpkg = caller($ExportLevel); - *exports = *{"$pkg\::EXPORT"}; + + my($exports, $export_cache) = (\@{"$pkg\::EXPORT"}, + \%{"$pkg\::EXPORT"}); # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-( - *fail = *{"$pkg\::EXPORT_FAIL"}; + my($fail) = \@{"$pkg\::EXPORT_FAIL"}; return export $pkg, $callpkg, @_ - if $Verbose or $Debug or @fail > 1; - my $args = @_ or @_ = @exports; + if $Verbose or $Debug or @$fail > 1; + my $args = @_ or @_ = @$exports; - if ($args and not %exports) { - foreach my $sym (@exports, @{"$pkg\::EXPORT_OK"}) { + if ($args and not %$export_cache) { + foreach my $sym (@$exports, @{"$pkg\::EXPORT_OK"}) { $sym =~ s/^&//; - $exports{$sym} = 1; + $export_cache->{$sym} = 1; } } if ($Verbose or $Debug - or grep {/\W/ or $args and not exists $exports{$_} - or @fail and $_ eq $fail[0] + or grep {/\W/ or $args and not exists $export_cache->{$_} + or @$fail and $_ eq $fail->[0] or (@{"$pkg\::EXPORT_OK"} and $_ eq ${"$pkg\::EXPORT_OK"}[0])} @_) { return export $pkg, $callpkg, ($args ? @_ : ()); } - #local $SIG{__WARN__} = sub {require Carp; goto &Carp::carp}; local $SIG{__WARN__} = sub {require Carp; local $Carp::CarpLevel = 1; &Carp::carp}; - foreach $sym (@_) { + foreach my $sym (@_) { # shortcut for the common case of no type character *{"$callpkg\::$sym"} = \&{"$pkg\::$sym"}; } } -1; -# A simple self test harness. Change 'require Carp' to 'use Carp ()' for testing. -# package main; eval(join('',<DATA>)) or die $@ unless caller; -__END__ -package Test; -$INC{'Exporter.pm'} = 1; -@ISA = qw(Exporter); -@EXPORT = qw(A1 A2 A3 A4 A5); -@EXPORT_OK = qw(B1 B2 B3 B4 B5); -%EXPORT_TAGS = (T1=>[qw(A1 A2 B1 B2)], T2=>[qw(A1 A2 B3 B4)], T3=>[qw(X3)]); -@EXPORT_FAIL = qw(B4); -Exporter::export_ok_tags('T3', 'unknown_tag'); +# Default methods + sub export_fail { - map { "Test::$_" } @_ # edit symbols just as an example + my $self = shift; + @_; } -package main; -$Exporter::Verbose = 1; -#import Test; -#import Test qw(X3); # export ok via export_ok_tags() -#import Test qw(:T1 !A2 /5/ !/3/ B5); -import Test qw(:T2 !B4); -import Test qw(:T2); # should fail + +sub require_version { + require Exporter::Heavy; + goto &Exporter::Heavy::require_version; +} + + 1; + =head1 NAME Exporter - Implements default import method for modules diff --git a/lib/Exporter/Heavy.pm b/lib/Exporter/Heavy.pm index 6647f7075c..39bce2d85e 100644 --- a/lib/Exporter/Heavy.pm +++ b/lib/Exporter/Heavy.pm @@ -1,4 +1,12 @@ -package Exporter; +package Exporter::Heavy; + +use strict; +no strict 'refs'; + +# On one line so MakeMaker will see it. +require Exporter; our $VERSION = $Exporter::VERSION; + +our $Verbose; =head1 NAME @@ -41,16 +49,17 @@ sub heavy_export { my($pkg, $callpkg, @imports) = @_; my($type, $sym, $oops); - *exports = *{"${pkg}::EXPORT"}; + my($exports, $export_cache) = (\@{"${pkg}::EXPORT"}, + \%{"${pkg}::EXPORT"}); if (@imports) { - if (!%exports) { - grep(s/^&//, @exports); - @exports{@exports} = (1) x @exports; + if (!%$export_cache) { + s/^&// foreach @$exports; + @{$export_cache}{@$exports} = (1) x @$exports; my $ok = \@{"${pkg}::EXPORT_OK"}; if (@$ok) { - grep(s/^&//, @$ok); - @exports{@$ok} = (1) x @$ok; + s/^&// foreach @$ok; + @{$export_cache}{@$ok} = (1) x @$ok; } } @@ -66,7 +75,7 @@ sub heavy_export { if ($spec =~ s/^://){ if ($spec eq 'DEFAULT'){ - @names = @exports; + @names = @$exports; } elsif ($tagdata = $tagsref->{$spec}) { @names = @$tagdata; @@ -79,7 +88,7 @@ sub heavy_export { } elsif ($spec =~ m:^/(.*)/$:){ my $patn = $1; - @allexports = keys %exports unless @allexports; # only do keys once + @allexports = keys %$export_cache unless @allexports; # only do keys once @names = grep(/$patn/, @allexports); # not anchored by default } else { @@ -100,13 +109,13 @@ sub heavy_export { } foreach $sym (@imports) { - if (!$exports{$sym}) { + if (!$export_cache->{$sym}) { if ($sym =~ m/^\d/) { $pkg->require_version($sym); # If the version number was the only thing specified # then we should act as if nothing was specified: if (@imports == 1) { - @imports = @exports; + @imports = @$exports; last; } # We need a way to emulate 'use Foo ()' but still @@ -115,7 +124,7 @@ sub heavy_export { @imports = (); last; } - } elsif ($sym !~ s/^&// || !$exports{$sym}) { + } elsif ($sym !~ s/^&// || !$export_cache->{$sym}) { require Carp; Carp::carp(qq["$sym" is not exported by the $pkg module]); $oops++; @@ -128,21 +137,23 @@ sub heavy_export { } } else { - @imports = @exports; + @imports = @$exports; } - *fail = *{"${pkg}::EXPORT_FAIL"}; - if (@fail) { - if (!%fail) { + my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"}, + \%{"${pkg}::EXPORT_FAIL"}); + + if (@$fail) { + if (!%$fail_cache) { # Build cache of symbols. Optimise the lookup by adding # barewords twice... both with and without a leading &. - # (Technique could be applied to %exports cache at cost of memory) - my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @fail; + # (Technique could be applied to $export_cache at cost of memory) + my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail; warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Verbose; - @fail{@expanded} = (1) x @expanded; + @{$fail_cache}{@expanded} = (1) x @expanded; } my @failed; - foreach $sym (@imports) { push(@failed, $sym) if $fail{$sym} } + foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} } if (@failed) { @failed = $pkg->export_fail(@failed); foreach $sym (@failed) { @@ -188,24 +199,19 @@ sub heavy_export_to_level sub _push_tags { my($pkg, $var, $syms) = @_; - my $nontag; - *export_tags = \%{"${pkg}::EXPORT_TAGS"}; + my @nontag = (); + my $export_tags = \%{"${pkg}::EXPORT_TAGS"}; push(@{"${pkg}::$var"}, - map { $export_tags{$_} ? @{$export_tags{$_}} : scalar(++$nontag,$_) } - (@$syms) ? @$syms : keys %export_tags); - if ($nontag and $^W) { + map { $export_tags->{$_} ? @{$export_tags->{$_}} + : scalar(push(@nontag,$_),$_) } + (@$syms) ? @$syms : keys %$export_tags); + if (@nontag and $^W) { # This may change to a die one day require Carp; - Carp::carp("Some names are not tags"); + Carp::carp(join(", ", @nontag)." are not tags of $pkg"); } } -# Default methods - -sub export_fail { - my $self = shift; - @_; -} sub require_version { my($self, $wanted) = @_; diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm index 92db8c908a..c496aa0ae5 100644 --- a/lib/ExtUtils/Install.pm +++ b/lib/ExtUtils/Install.pm @@ -262,8 +262,22 @@ sub inc_uninstall { } } +sub run_filter { + my ($cmd, $src, $dest) = @_; + local *SRC, *CMD; + open(CMD, "|$cmd >$dest") || die "Cannot fork: $!"; + open(SRC, $src) || die "Cannot open $src: $!"; + my $buf; + my $sz = 1024; + while (my $len = sysread(SRC, $buf, $sz)) { + syswrite(CMD, $buf, $len); + } + close SRC; + close CMD or die "Filter command '$cmd' failed for $src"; +} + sub pm_to_blib { - my($fromto,$autodir) = @_; + my($fromto,$autodir,$pm_filter) = @_; use File::Basename qw(dirname); use File::Copy qw(copy); @@ -286,23 +300,37 @@ sub pm_to_blib { mkpath($autodir,0,0755); foreach (keys %$fromto) { - next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_; - unless (compare($_,$fromto->{$_})){ - print "Skip $fromto->{$_} (unchanged)\n"; + my $dest = $fromto->{$_}; + next if -f $dest && -M $dest < -M $_; + + # When a pm_filter is defined, we need to pre-process the source first + # to determine whether it has changed or not. Therefore, only perform + # the comparison check when there's no filter to be ran. + # -- RAM, 03/01/2001 + + my $need_filtering = defined $pm_filter && length $pm_filter && /\.pm$/; + + if (!$need_filtering && 0 == compare($_,$dest)) { + print "Skip $dest (unchanged)\n"; next; } - if (-f $fromto->{$_}){ - forceunlink($fromto->{$_}); + if (-f $dest){ + forceunlink($dest); + } else { + mkpath(dirname($dest),0,0755); + } + if ($need_filtering) { + run_filter($pm_filter, $_, $dest); + print "$pm_filter <$_ >$dest\n"; } else { - mkpath(dirname($fromto->{$_}),0,0755); + copy($_,$dest); + print "cp $_ $dest\n"; } - copy($_,$fromto->{$_}); my($mode,$atime,$mtime) = (stat)[2,8,9]; - utime($atime,$mtime+$Is_VMS,$fromto->{$_}); - chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$fromto->{$_}); - print "cp $_ $fromto->{$_}\n"; - next unless /\.pm\z/; - autosplit($fromto->{$_},$autodir); + utime($atime,$mtime+$Is_VMS,$dest); + chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$dest); + next unless /\.pm$/; + autosplit($dest,$autodir); } } @@ -392,6 +420,11 @@ no-don't-really-do-it-now switch. pm_to_blib() takes a hashref as the first argument and copies all keys of the hash to the corresponding values efficiently. Filenames with the extension pm are autosplit. Second argument is the autosplit -directory. +directory. If third argument is not empty, it is taken as a filter command +to be ran on each .pm file, the output of the command being what is finally +copied, and the source for auto-splitting. + +You can have an environment variable PERL_INSTALL_ROOT set which will +be prepended as a directory to each installed file (and directory). =cut diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index b22363bb5b..5e2f91db5c 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -1,9 +1,30 @@ package ExtUtils::Liblist; +@ISA = qw(ExtUtils::Liblist::Kid File::Spec); + +sub lsdir { + shift; + my $rex = qr/$_[1]/; + opendir my $dir, $_[0]; + grep /$rex/, readdir $dir; +} + +sub file_name_is_absolute { + require File::Spec; + shift; + 'File::Spec'->file_name_is_absolute(@_); +} + + +package ExtUtils::Liblist::Kid; + +# This kid package is to be used by MakeMaker. It will not work if +# $self is not a Makemaker. + use 5.005_64; # Broken out of MakeMaker from version 4.11 -our $VERSION = substr q$Revision: 1.25 $, 10; +our $VERSION = substr q$Revision: 1.26 $, 10; use Config; use Cwd 'cwd'; @@ -16,7 +37,7 @@ sub ext { } sub _unix_os2_ext { - my($self,$potential_libs, $verbose) = @_; + my($self,$potential_libs, $verbose, $give_libs) = @_; if ($^O =~ 'os2' and $Config{perllibs}) { # Dynamic libraries are not transitive, so we may need including # the libraries linked against perl.dll again. @@ -24,7 +45,7 @@ sub _unix_os2_ext { $potential_libs .= " " if $potential_libs; $potential_libs .= $Config{perllibs}; } - return ("", "", "", "") unless $potential_libs; + return ("", "", "", "", ($give_libs ? [] : ())) unless $potential_libs; warn "Potential libraries are '$potential_libs':\n" if $verbose; my($so) = $Config{'so'}; @@ -39,6 +60,7 @@ sub _unix_os2_ext { my(@searchpath); # from "-L/path" entries in $potential_libs my(@libpath) = split " ", $Config{'libpth'}; my(@ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen); + my(@libs, %libs_seen); my($fullname, $thislib, $thispth, @fullname); my($pwd) = cwd(); # from Cwd.pm my($found) = 0; @@ -132,6 +154,7 @@ sub _unix_os2_ext { warn "'-l$thislib' found at $fullname\n" if $verbose; my($fullnamedir) = dirname($fullname); push @ld_run_path, $fullnamedir unless $ld_run_path_seen{$fullnamedir}++; + push @libs, $fullname unless $libs_seen{$fullname}++; $found++; $found_lib++; @@ -179,19 +202,19 @@ sub _unix_os2_ext { ."No library found for -l$thislib\n" unless $found_lib>0; } - return ('','','','') unless $found; - ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path)); + return ('','','','', ($give_libs ? \@libs : ())) unless $found; + ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path), ($give_libs ? \@libs : ())); } sub _win32_ext { require Text::ParseWords; - my($self, $potential_libs, $verbose) = @_; + my($self, $potential_libs, $verbose, $give_libs) = @_; # If user did not supply a list, we punt. # (caller should probably use the list in $Config{libs}) - return ("", "", "", "") unless $potential_libs; + return ("", "", "", "", ($give_libs ? [] : ())) unless $potential_libs; my $cc = $Config{cc}; my $VC = 1 if $cc =~ /^cl/i; @@ -201,6 +224,7 @@ sub _win32_ext { my $libs = $Config{'perllibs'}; my $libpth = $Config{'libpth'}; my $libext = $Config{'lib_ext'} || ".lib"; + my(@libs, %libs_seen); if ($libs and $potential_libs !~ /:nodefault/i) { # If Config.pm defines a set of default libs, we always @@ -298,6 +322,7 @@ sub _win32_ext { $found++; $found_lib++; push(@extralibs, $fullname); + push @libs, $fullname unless $libs_seen{$fullname}++; last; } @@ -319,10 +344,11 @@ sub _win32_ext { } - return ('','','','') unless $found; + return ('','','','', ($give_libs ? \@libs : ())) unless $found; # make sure paths with spaces are properly quoted @extralibs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @extralibs; + @libs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @libs; $lib = join(' ',@extralibs); # normalize back to backward slashes (to help braindead tools) @@ -331,12 +357,12 @@ sub _win32_ext { $lib =~ s,/,\\,g; warn "Result: $lib\n" if $verbose; - wantarray ? ($lib, '', $lib, '') : $lib; + wantarray ? ($lib, '', $lib, '', ($give_libs ? \@libs : ())) : $lib; } sub _vms_ext { - my($self, $potential_libs,$verbose) = @_; + my($self, $potential_libs,$verbose,$give_libs) = @_; my(@crtls,$crtlstr); my($dbgqual) = $self->{OPTIMIZE} || $Config{'optimize'} || $self->{CCFLAS} || $Config{'ccflags'}; @@ -365,7 +391,7 @@ sub _vms_ext { unless ($potential_libs) { warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose; - return ('', '', $crtlstr, ''); + return ('', '', $crtlstr, '', ($give_libs ? [] : ())); } my(@dirs,@libs,$dir,$lib,%found,@fndlibs,$ldlib); @@ -374,6 +400,7 @@ sub _vms_ext { # List of common Unix library names and there VMS equivalents # (VMS equivalent of '' indicates that the library is automatially # searched by the linker, and should be skipped here.) + my(@flibs, %libs_seen); my %libmap = ( 'm' => '', 'f77' => '', 'F77' => '', 'V77' => '', 'c' => '', 'malloc' => '', 'crypt' => '', 'resolv' => '', 'c_s' => '', 'socket' => '', 'X11' => 'DECW$XLIBSHR', @@ -478,6 +505,7 @@ sub _vms_ext { if ($cand eq 'VAXCCURSE') { unshift @{$found{$ctype}}, $cand; } else { push @{$found{$ctype}}, $cand; } warn "\tFound as $cand (really $test), type $ctype\n" if $verbose > 1; + push @flibs, $name unless $libs_seen{$fullname}++; next LIB; } } @@ -492,7 +520,7 @@ sub _vms_ext { $ldlib = $crtlstr ? "$lib $crtlstr" : $lib; warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose; - wantarray ? ($lib, '', $ldlib, '') : $lib; + wantarray ? ($lib, '', $ldlib, '', ($give_libs ? \@flibs : ())) : $lib; } 1; @@ -507,20 +535,22 @@ ExtUtils::Liblist - determine libraries to use and how to use them C<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: diff --git a/lib/ExtUtils/MANIFEST.SKIP b/lib/ExtUtils/MANIFEST.SKIP new file mode 100644 index 0000000000..a203d8f615 --- /dev/null +++ b/lib/ExtUtils/MANIFEST.SKIP @@ -0,0 +1,16 @@ +# Avoid version control files. +\bRCS\b +\bCVS\b +,v$ + +# Avoid Makemaker generated and utility files. +^MANIFEST\. +^Makefile$ +^blib/ +^MakeMaker-\d +^pm_to_blib$ + +# Avoid temp and backup files. +~$ +\.old$ +\#$ diff --git a/lib/ExtUtils/MM_Cygwin.pm b/lib/ExtUtils/MM_Cygwin.pm index a5ba410fdc..abb491f1a2 100644 --- a/lib/ExtUtils/MM_Cygwin.pm +++ b/lib/ExtUtils/MM_Cygwin.pm @@ -1,12 +1,16 @@ package ExtUtils::MM_Cygwin; +use strict; + +our $VERSION = '1.00'; + use Config; #use Cwd; #use File::Basename; require Exporter; -Exporter::import('ExtUtils::MakeMaker', - qw( $Verbose &neatvalue)); +require ExtUtils::MakeMaker; +ExtUtils::MakeMaker->import(qw( $Verbose &neatvalue)); unshift @MM::ISA, 'ExtUtils::MM_Cygwin'; @@ -71,6 +75,8 @@ q[-e 'next if -e $$m{$$_} && -M $$m{$$_} < -M $$_ && -M $$m{$$_} < -M "], push(@m,"\n"); if (%{$self->{MAN1PODS}} || %{$self->{MAN3PODS}}) { + grep { $self->{MAN1PODS}{$_} =~ s/::/./g } keys %{$self->{MAN1PODS}}; + grep { $self->{MAN3PODS}{$_} =~ s/::/./g } keys %{$self->{MAN3PODS}}; push @m, "\t$self->{NOECHO}\$(POD2MAN) \\\n\t"; push @m, join " \\\n\t", %{$self->{MAN1PODS}}, %{$self->{MAN3PODS}}; } diff --git a/lib/ExtUtils/MM_OS2.pm b/lib/ExtUtils/MM_OS2.pm index 430235a0aa..c0c52402f6 100644 --- a/lib/ExtUtils/MM_OS2.pm +++ b/lib/ExtUtils/MM_OS2.pm @@ -1,12 +1,16 @@ package ExtUtils::MM_OS2; +use strict; + +our $VERSION = '1.00'; + #use Config; #use Cwd; #use File::Basename; require Exporter; -Exporter::import('ExtUtils::MakeMaker', - qw( $Verbose &neatvalue)); +require ExtUtils::MakeMaker; +ExtUtils::MakeMaker->import(qw( $Verbose &neatvalue)); unshift @MM::ISA, 'ExtUtils::MM_OS2'; @@ -34,7 +38,7 @@ $self->{BASEEXT}.def: Makefile.PL ', "DL_VARS" => ', neatvalue($vars), ');\' '); } - if (%{$self->{IMPORTS}}) { + if ($self->{IMPORTS} && %{$self->{IMPORTS}}) { # Make import files (needed for static build) -d 'tmp_imp' or mkdir 'tmp_imp', 0777 or die "Can't mkdir tmp_imp"; open IMP, '>tmpimp.imp' or die "Can't open tmpimp.imp"; @@ -57,7 +61,7 @@ $self->{BASEEXT}.def: Makefile.PL sub static_lib { my($self) = @_; my $old = $self->ExtUtils::MM_Unix::static_lib(); - return $old unless %{$self->{IMPORTS}}; + return $old unless $self->{IMPORTS} && %{$self->{IMPORTS}}; my @chunks = split /\n{2,}/, $old; shift @chunks unless length $chunks[0]; # Empty lines at the start diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 52862c598e..d7dd720a06 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -1,17 +1,19 @@ package ExtUtils::MM_Unix; +use strict; + use Exporter (); use Config; use File::Basename qw(basename dirname fileparse); use DirHandle; use strict; -use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 $Is_Dos $Is_PERL_OBJECT - $Verbose %pm %static $Xsubpp_Version); +our ($Is_Mac,$Is_OS2,$Is_VMS,$Is_Win32,$Is_Dos,$Is_PERL_OBJECT, + $Verbose,%pm,%static,$Xsubpp_Version); -$VERSION = substr q$Revision: 1.12603 $, 10; -# $Id: MM_Unix.pm,v 1.126 1998/06/28 21:32:49 k Exp k $ +our $VERSION = '1.12603'; -Exporter::import('ExtUtils::MakeMaker', qw($Verbose &neatvalue)); +require ExtUtils::MakeMaker; +ExtUtils::MakeMaker->import(qw($Verbose &neatvalue)); $Is_OS2 = $^O eq 'os2'; $Is_Mac = $^O eq 'MacOS'; @@ -264,6 +266,14 @@ sub c_o { my($self) = shift; return '' unless $self->needs_linking(); my(@m); + if (my $cpp = $Config{cpprun}) { + my $cpp_cmd = $self->const_cccmd; + $cpp_cmd =~ s/^CCCMD\s*=\s*\$\(CC\)/$cpp/; + push @m, ' +.c.i: + '. $cpp_cmd . ' $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c > $*.i +'; + } push @m, ' .c$(OBJ_EXT): $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c @@ -580,7 +590,7 @@ MM_VERSION = $ExtUtils::MakeMaker::VERSION for $tmp (qw/ FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT - LDFROM LINKTYPE + LDFROM LINKTYPE PM_FILTER / ) { next unless defined $self->{$tmp}; push @m, "$tmp = $self->{$tmp}\n"; @@ -628,7 +638,7 @@ MAN3PODS = ".join(" \\\n\t", sort keys %{$self->{MAN3PODS}})." # work around a famous dec-osf make(1) feature(?): makemakerdflt: all -.SUFFIXES: .xs .c .C .cpp .cxx .cc \$(OBJ_EXT) +.SUFFIXES: .xs .c .C .cpp .i .cxx .cc \$(OBJ_EXT) # Nick wanted to get rid of .PRECIOUS. I don't remember why. I seem to recall, that # some make implementations will delete the Makefile when we rebuild it. Because @@ -1074,6 +1084,14 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $ldrun = qq{-rpath "$self->{LD_RUN_PATH}"} if ($^O eq 'irix' && $self->{LD_RUN_PATH}); + # For example in AIX the shared objects/libraries from previous builds + # linger quite a while in the shared dynalinker cache even when nobody + # is using them. This is painful if one for instance tries to restart + # a failed build because the link command will fail unnecessarily 'cos + # the shared object/library is 'busy'. + push(@m,' $(RM_F) $@ +'); + push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom. ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)'); push @m, ' @@ -1650,7 +1668,7 @@ sub init_main { unless ($self->{PERL_SRC}){ my($dir); - foreach $dir ($self->updir(),$self->catdir($self->updir(),$self->updir()),$self->catdir($self->updir(),$self->updir(),$self->updir())){ + foreach $dir ($self->updir(),$self->catdir($self->updir(),$self->updir()),$self->catdir($self->updir(),$self->updir(),$self->updir()),$self->catdir($self->updir(),$self->updir(),$self->updir(),$self->updir())){ if ( -f $self->catfile($dir,"config.sh") && @@ -1702,6 +1720,7 @@ from the perl source tree. $self->{PERL_INC} = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now my $perl_h; + no warnings 'uninitialized' ; if (not -f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h")) and not $old){ # Maybe somebody tries to build an extension with an @@ -2455,6 +2474,7 @@ MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} } unless ($libperl && -f $lperl) { # Ilya's code... my $dir = $self->{PERL_SRC} || "$self->{PERL_ARCHLIB}/CORE"; + $dir = "$self->{PERL_ARCHLIB}/.." if $self->{UNINSTALLED_PERL}; $libperl ||= "libperl$self->{LIB_EXT}"; $libperl = "$dir/$libperl"; $lperl ||= "libperl$self->{LIB_EXT}"; @@ -3030,7 +3050,7 @@ sub pm_to_blib { pm_to_blib: $(TO_INST_PM) }.$self->{NOECHO}.q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \ "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \ - -e "pm_to_blib({qw{$(PM_TO_BLIB)}},'}.$autodir.q{')" + -e "pm_to_blib({qw{$(PM_TO_BLIB)}},'}.$autodir.q{','$(PM_FILTER)')" }.$self->{NOECHO}.q{$(TOUCH) $@ }; } @@ -3141,8 +3161,22 @@ realclean purge :: clean push(@m, " $self->{RM_F} \$(INST_DYNAMIC) \$(INST_BOOT)\n"); push(@m, " $self->{RM_F} \$(INST_STATIC)\n"); } - push(@m, " $self->{RM_F} " . join(" ", values %{$self->{PM}}) . "\n") - if keys %{$self->{PM}}; + # Issue a several little RM_F commands rather than risk creating a + # very long command line (useful for extensions such as Encode + # that have many files). + if (keys %{$self->{PM}}) { + my $line = ""; + foreach (values %{$self->{PM}}) { + if (length($line) + length($_) > 80) { + push @m, "\t$self->{RM_F} $line\n"; + $line = $_; + } + else { + $line .= " $_"; + } + } + push @m, "\t$self->{RM_F} $line\n" if $line; + } my(@otherfiles) = ($self->{MAKEFILE}, "$self->{MAKEFILE}.old"); # Makefiles last push(@otherfiles, $attribs{FILES}) if $attribs{FILES}; @@ -3287,8 +3321,9 @@ sub subdir_x { my($self, $subdir) = @_; my(@m); if ($Is_Win32 && Win32::IsWin95()) { - # XXX: dmake-specific, like rest of Win95 port - return <<EOT; + if ($Config{'make'} =~ /dmake/i) { + # dmake-specific + return <<EOT; subdirs :: @[ cd $subdir @@ -3296,8 +3331,16 @@ subdirs :: cd .. ] EOT - } - else { + } elsif ($Config{'make'} =~ /nmake/i) { + # nmake-specific + return <<EOT; +subdirs :: + cd $subdir + \$(MAKE) all \$(PASTHRU) + cd .. +EOT + } + } else { return <<EOT; subdirs :: diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index 377d5d124d..b753e2a819 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -7,19 +7,23 @@ package ExtUtils::MM_VMS; +use strict; + use Carp qw( &carp ); use Config; require Exporter; use VMS::Filespec; use File::Basename; use File::Spec; -our($Revision, @ISA); -$Revision = '5.56 (27-Apr-1999)'; +our($Revision, @ISA, $VERSION, $Verbose); +# All on one line so MakeMaker can see it. +($VERSION) = ($Revision = '5.56 (27-Apr-1999)') =~ /^([\d.]+)/; @ISA = qw( File::Spec ); unshift @MM::ISA, 'ExtUtils::MM_VMS'; -Exporter::import('ExtUtils::MakeMaker', '$Verbose', '&neatvalue'); +require ExtUtils::MakeMaker; +ExtUtils::MakeMaker->import('$Verbose', '&neatvalue'); =head1 NAME @@ -122,7 +126,7 @@ sub ExtUtils::MM_VMS::makeaperl; sub ExtUtils::MM_VMS::ext; sub ExtUtils::MM_VMS::nicetext; -#use SelfLoader; +our $AUTOLOAD; sub AUTOLOAD { my $code; if (defined fileno(DATA)) { @@ -151,11 +155,12 @@ sub AUTOLOAD { # This isn't really an override. It's just here because ExtUtils::MM_VMS -# appears in @MM::ISA before ExtUtils::Liblist, so if there isn't an ext() +# appears in @MM::ISA before ExtUtils::Liblist::Kid, so if there isn't an ext() # in MM_VMS, then AUTOLOAD is called, and bad things happen. So, we just -# mimic inheritance here and hand off to ExtUtils::Liblist. +# mimic inheritance here and hand off to ExtUtils::Liblist::Kid. sub ext { - ExtUtils::Liblist::ext(@_); + require ExtUtils::Liblist; + ExtUtils::Liblist::Kid::ext(@_); } =back @@ -557,22 +562,23 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision # DLBASE = Basename part of dynamic library. May be just equal BASEEXT. ]; - for $tmp (qw/ + for my $tmp (qw/ FULLEXT VERSION_FROM OBJECT LDFROM / ) { next unless defined $self->{$tmp}; push @m, "$tmp = ",$self->fixpath($self->{$tmp},0),"\n"; } - for $tmp (qw/ + for my $tmp (qw/ BASEEXT PARENT_NAME DLBASE INC DEFINE LINKTYPE / ) { next unless defined $self->{$tmp}; push @m, "$tmp = $self->{$tmp}\n"; } - for $tmp (qw/ XS MAN1PODS MAN3PODS PM /) { - next unless defined $self->{$tmp}; + for my $tmp (qw/ XS MAN1PODS MAN3PODS PM /) { + # Where is the space coming from? --jhi + next unless $self ne " " && defined $self->{$tmp}; my(%tmp,$key); for $key (keys %{$self->{$tmp}}) { $tmp{$self->fixpath($key,0)} = $self->fixpath($self->{$tmp}{$key},0); @@ -580,7 +586,7 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision $self->{$tmp} = \%tmp; } - for $tmp (qw/ C O_FILES H /) { + for my $tmp (qw/ C O_FILES H /) { next unless defined $self->{$tmp}; my(@tmp,$val); for $val (@{$self->{$tmp}}) { @@ -601,7 +607,7 @@ MAN3PODS = ',$self->wraplist(sort keys %{$self->{MAN3PODS}}),' '; - for $tmp (qw/ + for my $tmp (qw/ INST_MAN1DIR INSTALLMAN1DIR MAN1EXT INST_MAN3DIR INSTALLMAN3DIR MAN3EXT /) { next unless defined $self->{$tmp}; @@ -700,7 +706,7 @@ sub cflags { # conflate the ones from $Config{'ccflags'} and $self->{DEFINE} # ($self->{DEFINE} has already been VMSified in constants() above) if ($self->{DEFINE}) { $quals .= $self->{DEFINE}; } - for $type (qw(Def Undef)) { + for my $type (qw(Def Undef)) { my(@terms); while ($quals =~ m:/${type}i?n?e?=([^/]+):ig) { my $term = $1; @@ -826,7 +832,7 @@ pm_to_blib.ts : $(TO_INST_PM) } push(@m,"\t\$(NOECHO) \$(PERL) -e \"print '$line'\" >>.MM_tmp\n") if $line; - push(@m,q[ $(PERL) "-I$(PERL_LIB)" "-MExtUtils::Install" -e "pm_to_blib({split(' ',<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 @@ -1414,7 +1420,7 @@ sub processPL { my $list = ref($self->{PL_FILES}->{$plfile}) ? $self->{PL_FILES}->{$plfile} : [$self->{PL_FILES}->{$plfile}]; - foreach $target (@$list) { + foreach my $target (@$list) { my $vmsplfile = vmsify($plfile); my $vmsfile = vmsify($target); push @m, " @@ -2046,6 +2052,8 @@ Consequently, it hasn't really been tested, and may well be incomplete. =cut +our %olbs; + sub makeaperl { my($self, %attribs) = @_; my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) = @@ -2088,7 +2096,7 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) $linkcmd =~ s/\s+/ /g; # Which *.olb files could we make use of... - local(%olbs); + local(%olbs); # XXX can this be lexical? $olbs{$self->{INST_ARCHAUTODIR}} = "$self->{BASEEXT}\$(LIB_EXT)"; require File::Find; File::Find::find(sub { @@ -2185,6 +2193,7 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) push @optlibs, @$extra; $target = "Perl$Config{'exe_ext'}" unless $target; + my $shrtarget; ($shrtarget,$targdir) = fileparse($target); $shrtarget =~ s/^([^.]*)/$1Shr/; $shrtarget = $targdir . $shrtarget; diff --git a/lib/ExtUtils/MM_Win32.pm b/lib/ExtUtils/MM_Win32.pm index 7f40ff7ece..80e247d27c 100644 --- a/lib/ExtUtils/MM_Win32.pm +++ b/lib/ExtUtils/MM_Win32.pm @@ -1,5 +1,7 @@ package ExtUtils::MM_Win32; +our $VERSION = '1.00'; + =head1 NAME ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker @@ -23,8 +25,8 @@ use Config; use File::Basename; require Exporter; -Exporter::import('ExtUtils::MakeMaker', - qw( $Verbose &neatvalue)); +require ExtUtils::MakeMaker; +ExtUtils::MakeMaker->import(qw( $Verbose &neatvalue)); $ENV{EMXSHELL} = 'sh'; # to run `commands` unshift @MM::ISA, 'ExtUtils::MM_Win32'; @@ -596,7 +598,7 @@ pm_to_blib: $(TO_INST_PM) ($NMAKE ? 'qw[ <<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) << diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index bef12b54da..9680348c27 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/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; # @@ -200,7 +200,8 @@ 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 @@ -239,7 +240,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 +982,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 +1161,6 @@ or as NAME=VALUE pairs on the command line: =over 2 -=item AUTHOR - -String containing name (and email address) of package author(s). Is used -in PPD (Perl Package Description) files for PPM (Perl Package Manager). - =item ABSTRACT One line description of the module. Will be included in PPD file. @@ -1160,6 +1171,11 @@ Name of the file that contains the package description. MakeMaker looks for a line in the POD matching /^($package\s-\s)(.*)/. This is typically the first line in the "=head1 NAME" section. $2 becomes the abstract. +=item AUTHOR + +String containing name (and email address) of package author(s). Is used +in PPD (Perl Package Description) files for PPM (Perl Package Manager). + =item BINARY_LOCATION Used when creating PPD files for binary packages. It can be set to a @@ -1409,11 +1425,6 @@ to INSTALLBIN during 'make install' Old name for INST_SCRIPT. Deprecated. Please use INST_SCRIPT if you need to use it. -=item INST_LIB - -Directory where we put library files of this extension while building -it. - =item INST_HTMLLIBDIR Directory to hold the man pages in HTML format at 'make' time @@ -1422,6 +1433,11 @@ Directory to hold the man pages in HTML format at 'make' time Directory to hold the man pages in HTML format at 'make' time +=item INST_LIB + +Directory where we put library files of this extension while building +it. + =item INST_MAN1DIR Directory to hold the man pages at 'make' time @@ -1437,34 +1453,6 @@ Directory, where executable files should be installed during testing. make install will copy the files in INST_SCRIPT to INSTALLSCRIPT. -=item PERL_MALLOC_OK - -defaults to 0. Should be set to TRUE if the extension can work with -the memory allocation routines substituted by the Perl malloc() subsystem. -This should be applicable to most extensions with exceptions of those - -=over - -=item * - -with bugs in memory allocations which are caught by Perl's malloc(); - -=item * - -which interact with the memory allocator in other ways than via -malloc(), realloc(), free(), calloc(), sbrk() and brk(); - -=item * - -which rely on special alignment which is not provided by Perl's malloc(). - -=back - -B<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 +1461,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 @@ -1527,10 +1519,11 @@ at Configure time. =item MAN3PODS -Hashref of .pm and .pod files. MakeMaker will default this to all - .pod and any .pm files that include POD directives. The files listed -here will be converted to man pages and installed as was requested -at Configure time. +Hashref that assigns to *.pm and *.pod files the files into which the +manpages are to be written. MakeMaker parses all *.pod and *.pm files +for POD directives. Files that contain POD will be the default keys of +the MAN3PODS hashref. These will then be converted to man pages during +C<make> and will be installed during C<make install>. =item MAP_TARGET @@ -1578,6 +1571,8 @@ List of object files, defaults to '$(BASEEXT)$(OBJ_EXT)', but can be a long string containing all object files, e.g. "tkpBind.o tkpButton.o tkpCanvas.o" +(Where BASEEXT is the last component of NAME, and OBJ_EXT is $Config{obj_ext}.) + =item OPTIMIZE Defaults to C<-O>. Set it to C<-g> to turn debugging on. The flag is @@ -1594,12 +1589,40 @@ to $(CC). =item PERL_ARCHLIB -Same as above for architecture dependent files. +Same as below, but for architecture dependent files. =item PERL_LIB Directory containing the Perl library to use. +=item PERL_MALLOC_OK + +defaults to 0. Should be set to TRUE if the extension can work with +the memory allocation routines substituted by the Perl malloc() subsystem. +This should be applicable to most extensions with exceptions of those + +=over 4 + +=item * + +with bugs in memory allocations which are caught by Perl's malloc(); + +=item * + +which interact with the memory allocator in other ways than via +malloc(), realloc(), free(), calloc(), sbrk() and brk(); + +=item * + +which rely on special alignment which is not provided by Perl's malloc(). + +=back + +B<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 +1671,31 @@ they contain will be installed in the corresponding location in the library. A libscan() method can be used to alter the behaviour. Defining PM in the Makefile.PL will override PMLIBDIRS. +(Where BASEEXT is the last component of NAME.) + +=item PM_FILTER + +A filter program, in the traditional Unix sense (input from stdin, output +to stdout) that is passed on each .pm file during the build (in the +pm_to_blib() phase). It is empty by default, meaning no filtering is done. + +Great care is necessary when defining the command if quoting needs to be +done. For instance, you would need to say: + + {'PM_FILTER' => 'grep -v \\"^\\#\\"'} + +to remove all the leading coments on the fly during the build. The +extra \\ are necessary, unfortunately, because this variable is interpolated +within the context of a Perl program built on the command line, and double +quotes are what is used with the -e switch to build that command line. The +# is escaped for the Makefile, since what is going to be generated will then +be: + + PM_FILTER = grep -v \"^\#\" + +Without the \\ before the #, we'd have the start of a Makefile comment, +and the macro would be incorrectly defined. + =item POLLUTE Release 5.005 grandfathered old global symbol names by providing preprocessor @@ -1725,6 +1773,7 @@ MakeMaker object. The following lines will be parsed o.k.: ( $VERSION ) = '$Revision: 1.222 $ ' =~ /\$Revision:\s+([^\s]+)/; $FOO::VERSION = '1.10'; *FOO::VERSION = \'1.11'; + our $VERSION = 1.2.3; # new for perl5.6.0 but these will fail: @@ -1732,6 +1781,8 @@ but these will fail: local $VERSION = '1.02'; local $FOO::VERSION = '1.30'; +(Putting C<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 +1837,8 @@ part of the Makefile. {ANY_TARGET => ANY_DEPENDECY, ...} +(ANY_TARGET must not be given a double-colon rule by MakeMaker.) + =item dist {TARFLAGS => 'cvfF', COMPRESS => 'gzip', SUFFIX => '.gz', @@ -2030,10 +2083,10 @@ ExtUtils::Install, ExtUtils::Embed =head1 AUTHORS Andy Dougherty <F<doughera@lafcol.lafayette.edu>>, Andreas KE<ouml>nig -<F<A.Koenig@franz.ww.TU-Berlin.DE>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>. -VMS support by Charles Bailey <F<bailey@newman.upenn.edu>>. OS/2 -support by Ilya Zakharevich <F<ilya@math.ohio-state.edu>>. Contact the -makemaker mailing list C<mailto:makemaker@franz.ww.tu-berlin.de>, if -you have any questions. +<F<andreas.koenig@mind.de>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>. VMS +support by Charles Bailey <F<bailey@newman.upenn.edu>>. OS/2 support +by Ilya Zakharevich <F<ilya@math.ohio-state.edu>>. + +Send patches and bug reports to <F<perlbug@perl.org>>. =cut diff --git a/lib/ExtUtils/Manifest.pm b/lib/ExtUtils/Manifest.pm index 28b70539fc..030eedffeb 100644 --- a/lib/ExtUtils/Manifest.pm +++ b/lib/ExtUtils/Manifest.pm @@ -4,11 +4,12 @@ require Exporter; use Config; use File::Find; use File::Copy 'copy'; +use File::Spec::Functions qw(splitpath); use Carp; use strict; -use vars qw($VERSION @ISA @EXPORT_OK - $Is_VMS $Debug $Verbose $Quiet $MANIFEST $found); +our ($VERSION,@ISA,@EXPORT_OK, + $Is_VMS,$Debug,$Verbose,$Quiet,$MANIFEST,$found,$DEFAULT_MSKIP); $VERSION = substr(q$Revision: 1.33 $, 10); @ISA=('Exporter'); @@ -18,10 +19,11 @@ $VERSION = substr(q$Revision: 1.33 $, 10); $Is_VMS = $^O eq 'VMS'; if ($Is_VMS) { require File::Basename } -$Debug = 0; +$Debug = $ENV{PERL_MM_MANIFEST_DEBUG} || 0; $Verbose = 1; $Quiet = 0; $MANIFEST = 'MANIFEST'; +$DEFAULT_MSKIP = (splitpath($INC{"ExtUtils/Manifest.pm"}))[1]."$MANIFEST.SKIP"; # Really cool fix from Ilya :) unless (defined $Config{d_link}) { @@ -160,8 +162,7 @@ sub _maniskip { my @skip ; $mfile ||= "$MANIFEST.SKIP"; local *M; - return $matches unless -f $mfile; - open M, $mfile or return $matches; + open M, $mfile or open M, $DEFAULT_MSKIP or return $matches; while (<M>){ chomp; next if /^#/; @@ -187,13 +188,13 @@ sub manicopy { require File::Basename; my(%dirs,$file); $target = VMS::Filespec::unixify($target) if $Is_VMS; - File::Path::mkpath([ $target ],1,$Is_VMS ? undef : 0755); + File::Path::mkpath([ $target ],! $Quiet,$Is_VMS ? undef : 0755); foreach $file (keys %$read){ $file = VMS::Filespec::unixify($file) if $Is_VMS; if ($file =~ m!/!) { # Ilya, that hurts, I fear, or maybe not? my $dir = File::Basename::dirname($file); $dir = VMS::Filespec::unixify($dir) if $Is_VMS; - File::Path::mkpath(["$target/$dir"],1,$Is_VMS ? undef : 0755); + File::Path::mkpath(["$target/$dir"],! $Quiet,$Is_VMS ? undef : 0755); } cp_if_diff($file, "$target/$file", $how); } @@ -344,15 +345,27 @@ expressions should appear one on each line. Blank lines and lines which start with C<#> are skipped. Use C<\#> if you need a regular expression to start with a sharp character. A typical example: + # Version control files and dirs. \bRCS\b + \bCVS\b + ,v$ + + # Makemaker generated files and dirs. ^MANIFEST\. ^Makefile$ - ~$ - \.html$ - \.old$ ^blib/ ^MakeMaker-\d + # Temp, old and emacs backup files. + ~$ + \.old$ + ^#.*#$ + +If no MANIFEST.SKIP file is found, a default set of skips will be +used, similar to the example above. If you want nothing skipped, +simply make an empty MANIFEST.SKIP file. + + =head1 EXPORT_OK C<&mkmanifest>, C<&manicheck>, C<&filecheck>, C<&fullcheck>, @@ -369,6 +382,10 @@ and a developer version including RCS). C<$ExtUtils::Manifest::Quiet> defaults to 0. If set to a true value, all functions act silently. +C<$ExtUtils::Manifest::Debug> defaults to 0. If set to a true value, +or if PERL_MM_MANIFEST_DEBUG is true, debugging output will be +produced. + =head1 DIAGNOSTICS All diagnostic output is sent to C<STDERR>. @@ -397,12 +414,22 @@ to MANIFEST. $Verbose is set to 1 by default. =back +=head1 ENVIRONMENT + +=over 4 + +=item B<PERL_MM_MANIFEST_DEBUG> + +Turns on debugging + +=back + =head1 SEE ALSO L<ExtUtils::MakeMaker> which has handy targets for most of the functionality. =head1 AUTHOR -Andreas Koenig <F<koenig@franz.ww.TU-Berlin.DE>> +Andreas Koenig <F<andreas.koenig@anima.de>> =cut diff --git a/lib/ExtUtils/Mksymlists.pm b/lib/ExtUtils/Mksymlists.pm index c8f41c74bc..c06b393be3 100644 --- a/lib/ExtUtils/Mksymlists.pm +++ b/lib/ExtUtils/Mksymlists.pm @@ -49,6 +49,7 @@ sub Mksymlists { } if ($osname eq 'aix') { _write_aix(\%spec); } + elsif ($osname eq 'MacOS'){ _write_aix(\%spec) } elsif ($osname eq 'VMS') { _write_vms(\%spec) } elsif ($osname eq 'os2') { _write_os2(\%spec) } elsif ($osname eq 'MSWin32') { _write_win32(\%spec) } diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap index 9961f2d61d..c59c3dc88a 100644 --- a/lib/ExtUtils/typemap +++ b/lib/ExtUtils/typemap @@ -40,7 +40,8 @@ Boolean T_IV double T_DOUBLE SysRet T_SYSRET SysRetLong T_SYSRET -FILE * T_IN +FILE * T_STDIO +PerlIO * T_INOUT FileHandle T_PTROBJ InputStream T_IN InOutStream T_INOUT @@ -55,22 +56,22 @@ T_SVREF if (sv_isa($arg, \"${ntype}\")) $var = (SV*)SvRV($arg); else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") T_AVREF if (sv_isa($arg, \"${ntype}\")) $var = (AV*)SvRV($arg); else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") T_HVREF if (sv_isa($arg, \"${ntype}\")) $var = (HV*)SvRV($arg); else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") T_CVREF if (sv_isa($arg, \"${ntype}\")) $var = (CV*)SvRV($arg); else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") T_SYSRET $var NOT IMPLEMENTED T_UV @@ -113,50 +114,50 @@ T_PTRREF $var = INT2PTR($type,tmp); } else - croak(\"$var is not a reference\") + Perl_croak(aTHX_ \"$var is not a reference\") T_REF_IV_REF if (sv_isa($arg, \"${type}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *($type *) tmp; } else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") T_REF_IV_PTR if (sv_isa($arg, \"${type}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = ($type) tmp; } else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") T_PTROBJ if (sv_derived_from($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type,tmp); } else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") T_PTRDESC if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); - ${type}_desc = (\U${type}_DESC\E*) tmp; + ${type}_desc = (\U${type}_DESC\E*) tmp; $var = ${type}_desc->ptr; } else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") T_REFREF if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *INT2PTR($type,tmp); } else - croak(\"$var is not a reference\") + Perl_croak(aTHX_ \"$var is not a reference\") T_REFOBJ if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *INT2PTR($type,tmp); } else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") T_OPAQUE $var NOT IMPLEMENTED T_OPAQUEPTR @@ -173,6 +174,8 @@ T_ARRAY while (items--) { DO_ARRAY_ELEM; } +T_STDIO + $var = PerlIO_findFILE(IoIFP(sv_2io($arg))) T_IN $var = IoIFP(sv_2io($arg)) T_INOUT @@ -267,6 +270,15 @@ T_ARRAY DO_ARRAY_ELEM } SP += $var.size - 1; +T_STDIO + { + GV *gv = newGVgen("$Package"); + PerlIO *fp = PerlIO_importFILE($var,0); + if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } T_IN { GV *gv = newGVgen("$Package"); diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 1e9ff45cc9..2093633930 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -109,7 +109,7 @@ sub Q ; # Global Constants -$XSUBPP_version = "1.9507"; +$XSUBPP_version = "1.9508"; my ($Is_VMS, $SymSet); if ($^O eq 'VMS') { @@ -418,7 +418,7 @@ sub INPUT_handler { $var_init =~ s/"/\\"/g; s/\s+/ /g; - my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s + my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s or blurt("Error: invalid argument declaration '$line'"), next; # Check for duplicate definitions @@ -444,12 +444,9 @@ sub INPUT_handler { $proto_arg[$var_num] = ProtoString($var_type) if $var_num ; - if ($var_addr) { - $var_addr{$var_name} = 1; - $func_args =~ s/\b($var_name)\b/&$1/; - } + $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr; if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/ - or $in_out{$var_name} and $in_out{$var_name} eq 'OUTLIST' + or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/ and $var_init !~ /\S/) { if ($name_printed) { print ";\n"; @@ -494,6 +491,8 @@ sub OUTPUT_handler { } else { &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic); } + delete $in_out{$outarg} # No need to auto-OUTPUT + if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/; } } @@ -859,10 +858,21 @@ print("#line 1 \"$filename\"\n") firstmodule: while (<$FH>) { if (/^=/) { + my $podstartline = $.; do { - next firstmodule if /^=cut\s*$/; + if (/^=cut\s*$/) { + print("/* Skipped embedded POD. */\n"); + printf("#line %d \"$filename\"\n", $. + 1) + if $WantLineNumbers; + next firstmodule + } + } while (<$FH>); - &Exit; + # At this point $. is at end of file so die won't state the start + # of the problem, and as we haven't yet read any lines &death won't + # show the correct line in the message either. + die ("Error: Unterminated pod in $filename, line $podstartline\n") + unless $lastline; } last if ($Module, $Package, $Prefix) = /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; @@ -992,7 +1002,6 @@ while (fetch_para()) { # initialize info arrays undef(%args_match); undef(%var_types); - undef(%var_addr); undef(%defaults); undef($class); undef($static); @@ -1004,7 +1013,7 @@ while (fetch_para()) { undef(@arg_with_types) ; undef($processing_arg_with_types) ; undef(%arg_types) ; - undef(@in_out) ; + undef(@outlist) ; undef(%in_out) ; undef($proto_in_this_xsub) ; undef($scope_in_this_xsub) ; @@ -1070,7 +1079,7 @@ while (fetch_para()) { $orig_args =~ s/\\\s*/ /g; # process line continuations - my %out_vars; + my %only_outlist; if ($process_argtypes and $orig_args =~ /\S/) { my $args = "$orig_args ,"; if ($args =~ /^( (??{ $C_arg }) , )* $ /x) { @@ -1085,10 +1094,10 @@ while (fetch_para()) { next unless length $pre; my $out_type; my $inout_var; - if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST)\s+//) { + if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) { my $type = $1; $out_type = $type if $type ne 'IN'; - $arg =~ s/^(IN|IN_OUTLIST|OUTLIST)\s+//; + $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//; } if (/\W/) { # Has a type push @arg_with_types, $arg; @@ -1096,8 +1105,8 @@ while (fetch_para()) { $arg_types{$name} = $arg; $_ = "$name$default"; } - $out_vars{$_} = 1 if $out_type eq 'OUTLIST'; - push @in_out, $name if $out_type; + $only_outlist{$_} = 1 if $out_type eq "OUTLIST"; + push @outlist, $name if $out_type =~ /OUTLIST$/; $in_out{$name} = $out_type if $out_type; } } else { @@ -1107,11 +1116,11 @@ while (fetch_para()) { } else { @args = split(/\s*,\s*/, $orig_args); for (@args) { - if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST)\s+//) { + if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) { my $out_type = $1; next if $out_type eq 'IN'; - $out_vars{$_} = 1 if $out_type eq 'OUTLIST'; - push @in_out, $name; + $only_outlist{$_} = 1 if $out_type eq "OUTLIST"; + push @outlist, $name if $out_type =~ /OUTLIST$/; $in_out{$_} = $out_type; } } @@ -1135,7 +1144,7 @@ while (fetch_para()) { last; } } - if ($out_vars{$args[$i]}) { + if ($only_outlist{$args[$i]}) { push @args_num, undef; } else { push @args_num, ++$num_args; @@ -1174,6 +1183,7 @@ while (fetch_para()) { # print function header print Q<<"EOF"; +#XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */ #XS(XS_${Full_func_name}) #[[ # dXSARGS; @@ -1324,6 +1334,9 @@ EOF undef %outargs ; process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE"); + &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic) + for grep $in_out{$_} =~ /OUT$/, keys %in_out; + # all OUTPUT done, so now push the return value on the stack if ($gotRETVAL && $RETVAL_code) { print "\t$RETVAL_code\n"; @@ -1360,11 +1373,11 @@ EOF $xsreturn = 1 if $ret_type ne "void"; my $num = $xsreturn; - my $c = @in_out; + my $c = @outlist; print "\tXSprePUSH;" if $c and not $prepush_done; print "\tEXTEND(SP,$c);\n" if $c; $xsreturn += $c; - generate_output($var_types{$_}, $num++, $_, 0, 1) for @in_out; + generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist; # do cleanup process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE") ; @@ -1490,6 +1503,7 @@ print Q<<"EOF"; EOF print Q<<"EOF"; +#XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */ #XS(boot_$Module_cname) EOF diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm index 243234403a..75996f2d08 100644 --- a/lib/File/Basename.pm +++ b/lib/File/Basename.pm @@ -176,7 +176,7 @@ sub fileparse { $dirpath ||= ''; # should always be defined } } - if ($fstype =~ /^MS(DOS|Win32)/i) { + if ($fstype =~ /^MS(DOS|Win32)|epoc/i) { ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s); $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/; } diff --git a/lib/File/CheckTree.pm b/lib/File/CheckTree.pm index ae1877741b..8b6ae0805a 100644 --- a/lib/File/CheckTree.pm +++ b/lib/File/CheckTree.pm @@ -1,4 +1,7 @@ package File::CheckTree; + +our $VERSION = '4.1'; + require 5.000; require Exporter; @@ -41,39 +44,8 @@ The routine returns the number of warnings issued. =cut -@ISA = qw(Exporter); -@EXPORT = qw(validate); - -# $RCSfile: validate.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:19 $ - -# The validate routine takes a single multiline string consisting of -# lines containing a filename plus a file test to try on it. (The -# file test may also be a 'cd', causing subsequent relative filenames -# to be interpreted relative to that directory.) After the file test -# you may put '|| die' to make it a fatal error if the file test fails. -# The default is '|| warn'. The file test may optionally have a ! prepended -# to test for the opposite condition. If you do a cd and then list some -# relative filenames, you may want to indent them slightly for readability. -# If you supply your own "die" or "warn" message, you can use $file to -# interpolate the filename. - -# Filetests may be bunched: -rwx tests for all of -r, -w and -x. -# Only the first failed test of the bunch will produce a warning. - -# The routine returns the number of warnings issued. - -# Usage: -# use File::CheckTree; -# $warnings += validate(' -# /vmunix -e || die -# /boot -e || die -# /bin cd -# csh -ex -# csh !-ug -# sh -ex -# sh !-ug -# /usr -d || warn "What happened to $file?\n" -# '); +our @ISA = qw(Exporter); +our @EXPORT = qw(validate); sub validate { local($file,$test,$warnings,$oldwarnings); @@ -94,7 +66,8 @@ sub validate { $this =~ s/(-\w\b)/$1 \$file/g; $this =~ s/-Z/-$one/; $this .= ' || warn' unless $this =~ /\|\|/; - $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || valmess('$2','$1')/; + $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || + valmess('$2','$1')/; $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g; eval $this; last if $warnings > $oldwarnings; @@ -103,47 +76,54 @@ sub validate { $warnings; } +our %Val_Switch = ( + 'r' => sub { "$_[0] is not readable by uid $>." }, + 'w' => sub { "$_[0] is not writable by uid $>." }, + 'x' => sub { "$_[0] is not executable by uid $>." }, + 'o' => sub { "$_[0] is not owned by uid $>." }, + 'R' => sub { "$_[0] is not readable by you." }, + 'W' => sub { "$_[0] is not writable by you." }, + 'X' => sub { "$_[0] is not executable by you." }, + 'O' => sub { "$_[0] is not owned by you." }, + 'e' => sub { "$_[0] does not exist." }, + 'z' => sub { "$_[0] does not have zero size." }, + 's' => sub { "$_[0] does not have non-zero size." }, + 'f' => sub { "$_[0] is not a plain file." }, + 'd' => sub { "$_[0] is not a directory." }, + 'l' => sub { "$_[0] is not a symbolic link." }, + 'p' => sub { "$_[0] is not a named pipe (FIFO)." }, + 'S' => sub { "$_[0] is not a socket." }, + 'b' => sub { "$_[0] is not a block special file." }, + 'c' => sub { "$_[0] is not a character special file." }, + 'u' => sub { "$_[0] does not have the setuid bit set." }, + 'g' => sub { "$_[0] does not have the setgid bit set." }, + 'k' => sub { "$_[0] does not have the sticky bit set." }, + 'T' => sub { "$_[0] is not a text file." }, + 'B' => sub { "$_[0] is not a binary file." }, +); + sub valmess { - local($disposition,$this) = @_; - $file = $cwd . '/' . $file unless $file =~ m|^/|s; + my($disposition,$this) = @_; + my $file = $cwd . '/' . $file unless $file =~ m|^/|s; + + my $ferror; if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) { - $neg = $1; - $tmp = $2; - $tmp eq 'r' && ($mess = "$file is not readable by uid $>."); - $tmp eq 'w' && ($mess = "$file is not writable by uid $>."); - $tmp eq 'x' && ($mess = "$file is not executable by uid $>."); - $tmp eq 'o' && ($mess = "$file is not owned by uid $>."); - $tmp eq 'R' && ($mess = "$file is not readable by you."); - $tmp eq 'W' && ($mess = "$file is not writable by you."); - $tmp eq 'X' && ($mess = "$file is not executable by you."); - $tmp eq 'O' && ($mess = "$file is not owned by you."); - $tmp eq 'e' && ($mess = "$file does not exist."); - $tmp eq 'z' && ($mess = "$file does not have zero size."); - $tmp eq 's' && ($mess = "$file does not have non-zero size."); - $tmp eq 'f' && ($mess = "$file is not a plain file."); - $tmp eq 'd' && ($mess = "$file is not a directory."); - $tmp eq 'l' && ($mess = "$file is not a symbolic link."); - $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO)."); - $tmp eq 'S' && ($mess = "$file is not a socket."); - $tmp eq 'b' && ($mess = "$file is not a block special file."); - $tmp eq 'c' && ($mess = "$file is not a character special file."); - $tmp eq 'u' && ($mess = "$file does not have the setuid bit set."); - $tmp eq 'g' && ($mess = "$file does not have the setgid bit set."); - $tmp eq 'k' && ($mess = "$file does not have the sticky bit set."); - $tmp eq 'T' && ($mess = "$file is not a text file."); - $tmp eq 'B' && ($mess = "$file is not a binary file."); + my($neg,$ftype) = ($1,$2); + + $ferror = $Val_Switch{$tmp}->($file); + if ($neg eq '!') { - $mess =~ s/ is not / should not be / || - $mess =~ s/ does not / should not / || - $mess =~ s/ not / /; + $ferror =~ s/ is not / should not be / || + $ferror =~ s/ does not / should not / || + $ferror =~ s/ not / /; } } else { $this =~ s/\$file/'$file'/g; - $mess = "Can't do $this.\n"; + $ferror = "Can't do $this.\n"; } - die "$mess\n" if $disposition eq 'die'; - warn "$mess\n"; + die "$ferror\n" if $disposition eq 'die'; + warn "$ferror\n"; ++$warnings; } diff --git a/lib/File/DosGlob.pm b/lib/File/DosGlob.pm index d7dea7b46c..2b4d39acd0 100644 --- a/lib/File/DosGlob.pm +++ b/lib/File/DosGlob.pm @@ -1,54 +1,59 @@ #!perl -w +# use strict fails +#Can't use string ("main::glob") as a symbol ref while "strict refs" in use at /usr/lib/perl5/5.005/File/DosGlob.pm line 191. + # # Documentation at the __END__ # package File::DosGlob; +our $VERSION = '1.00'; +use strict; + sub doglob { my $cond = shift; my @retval = (); #print "doglob: ", join('|', @_), "\n"; OUTER: - for my $arg (@_) { - local $_ = $arg; + for my $pat (@_) { my @matched = (); my @globdirs = (); my $head = '.'; my $sepchr = '/'; - next OUTER unless defined $_ and $_ ne ''; + my $tail; + next OUTER unless defined $pat and $pat ne ''; # if arg is within quotes strip em and do no globbing - if (/^"(.*)"\z/s) { - $_ = $1; - if ($cond eq 'd') { push(@retval, $_) if -d $_ } - else { push(@retval, $_) if -e $_ } + if ($pat =~ /^"(.*)"\z/s) { + $pat = $1; + if ($cond eq 'd') { push(@retval, $pat) if -d $pat } + else { push(@retval, $pat) if -e $pat } next OUTER; } # wildcards with a drive prefix such as h:*.pm must be changed # to h:./*.pm to expand correctly - if (m|^([A-Za-z]:)[^/\\]|s) { + if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) { substr($_,0,2) = $1 . "./"; } - if (m|^(.*)([\\/])([^\\/]*)\z|s) { - my $tail; + if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) { ($head, $sepchr, $tail) = ($1,$2,$3); #print "div: |$head|$sepchr|$tail|\n"; - push (@retval, $_), next OUTER if $tail eq ''; + push (@retval, $pat), next OUTER if $tail eq ''; if ($head =~ /[*?]/) { @globdirs = doglob('d', $head); push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)), next OUTER if @globdirs; } $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s; - $_ = $tail; + $pat = $tail; } # # If file component has no wildcards, we can avoid opendir - unless (/[*?]/) { + unless ($pat =~ /[*?]/) { $head = '' if $head eq '.'; $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; - $head .= $_; + $head .= $pat; if ($cond eq 'd') { push(@retval,$head) if -d $head } else { push(@retval,$head) if -e $head } next OUTER; @@ -60,14 +65,13 @@ sub doglob { $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; # escape regex metachars but not glob chars - s:([].+^\-\${}[|]):\\$1:g; + $pat =~ s:([].+^\-\${}[|]):\\$1:g; # and convert DOS-style wildcards to regex - s/\*/.*/g; - s/\?/.?/g; + $pat =~ s/\*/.*/g; + $pat =~ s/\?/.?/g; - #print "regex: '$_', head: '$head'\n"; - my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }'; - warn($@), next OUTER if $@; + #print "regex: '$pat', head: '$head'\n"; + my $matchsub = sub { $_[0] =~ m|^$pat\z|is }; INNER: for my $e (@leaves) { next INNER if $e eq '.' or $e eq '..'; @@ -80,7 +84,7 @@ sub doglob { # has a dot *and* name is shorter than 9 chars. # if (index($e,'.') == -1 and length($e) < 9 - and index($_,'\\.') != -1) { + and index($pat,'\\.') != -1) { push(@matched, "$head$e"), next INNER if &$matchsub("$e."); } } @@ -100,8 +104,7 @@ my %iter; my %entries; sub glob { - my $pat = shift; - my $cxix = shift; + my($pat,$cxix) = @_; my @pat; # glob without args defaults to $_ @@ -116,6 +119,52 @@ sub glob { push @pat, $pat; } + # Mike Mestnik: made to do abc{1,2,3} == abc1 abc2 abc3. + # abc3 will be the original {3} (and drop the {}). + # abc1 abc2 will be put in @appendpat. + # This was just the esiest way, not nearly the best. + REHASH: { + my @appendpat = (); + for (@pat) { + # There must be a "," I.E. abc{efg} is not what we want. + while ( /^(.*)(?<!\\)\{(.*?)(?<!\\)\,.*?(?<!\\)\}(.*)$/ ) { + my ($start, $match, $end) = ($1, $2, $3); + #print "Got: \n\t$start\n\t$match\n\t$end\n"; + my $tmp = "$start$match$end"; + while ( $tmp =~ s/^(.*?)(?<!\\)\{(?:.*(?<!\\)\,)?(.*\Q$match\E.*?)(?:(?<!\\)\,.*)?(?<!\\)\}(.*)$/$1$2$3/ ) { + #print "Striped: $tmp\n"; + # these expanshions will be preformed by the original, + # when we call REHASH. + } + push @appendpat, ("$tmp"); + s/^\Q$start\E(?<!\\)\{\Q$match\E(?<!\\)\,/$start\{/; + if ( /^\Q$start\E(?<!\\)\{(?!.*?(?<!\\)\,.*?\Q$end\E$)(.*)(?<!\\)\}\Q$end\E$/ ) { + $match = $1; + #print "GOT: \n\t$start\n\t$match\n\t$end\n\n"; + $_ = "$start$match$end"; + } + } + #print "Sould have "GOT" vs "Got"!\n"; + #FIXME: There should be checking for this. + # How or what should be done about failure is beond me. + } + if ( $#appendpat != -1 + ) { + #print "LOOP\n"; + #FIXME: Max loop, no way! :") + for ( @appendpat ) { + push @pat, $_; + } + goto REHASH; + } + } + for ( @pat ) { + s/\\{/{/g; + s/\\}/}/g; + s/\\,/,/g; + } + #print join ("\n", @pat). "\n"; + # assume global context if not provided one $cxix = '_G_' unless defined $cxix; $iter{$cxix} = 0 unless exists $iter{$cxix}; @@ -143,14 +192,17 @@ sub glob { } } -sub import { +{ + no strict 'refs'; + + sub import { my $pkg = shift; return unless @_; my $sym = shift; my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0)); *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob'; + } } - 1; __END__ diff --git a/lib/File/Find.pm b/lib/File/Find.pm index 6e6e462767..1e33f1edec 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -1,5 +1,7 @@ package File::Find; +use strict; use 5.005_64; +our $VERSION = '1.00'; require Exporter; require Cwd; @@ -187,8 +189,8 @@ in an unknown directory. =cut -@ISA = qw(Exporter); -@EXPORT = qw(find finddepth); +our @ISA = qw(Exporter); +our @EXPORT = qw(find finddepth); use strict; @@ -759,7 +761,7 @@ if ($^O eq 'VMS') { $File::Find::dont_use_nlink = 1 if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32' || - $^O eq 'cygwin'; + $^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/lib/File/Path.pm b/lib/File/Path.pm index ffc856bb59..3859f248eb 100644 --- a/lib/File/Path.pm +++ b/lib/File/Path.pm @@ -105,8 +105,8 @@ my $Is_VMS = $^O eq 'VMS'; # 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) = @_; diff --git a/lib/File/Spec.pm b/lib/File/Spec.pm index 40503c467f..35707cc780 100644 --- a/lib/File/Spec.pm +++ b/lib/File/Spec.pm @@ -1,14 +1,15 @@ package File::Spec; use strict; -use vars qw(@ISA $VERSION); +our(@ISA, $VERSION); $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/lib/File/Spec/Epoc.pm b/lib/File/Spec/Epoc.pm new file mode 100644 index 0000000000..65d5e1fcb5 --- /dev/null +++ b/lib/File/Spec/Epoc.pm @@ -0,0 +1,378 @@ +package File::Spec::Epoc; + +use strict; +use Cwd; +use vars qw(@ISA); +require File::Spec::Unix; +@ISA = qw(File::Spec::Unix); + +=head1 NAME + +File::Spec::Epoc - methods for Epoc file specs + +=head1 SYNOPSIS + + require File::Spec::Epoc; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See File::Spec::Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +This package is still work in progress ;-) +o.flebbe@gmx.de + + +=over + +=item devnull + +Returns a string representation of the null device. + +=cut + +sub devnull { + return "nul:"; +} + +=item tmpdir + +Returns a string representation of a temporay directory: + +=cut + +my $tmpdir; +sub tmpdir { + return "C:/System/temp"; +} + +sub case_tolerant { + return 1; +} + +sub file_name_is_absolute { + my ($self,$file) = @_; + return scalar($file =~ m{^([a-z?]:)?[\\/]}is); +} + +=item path + +Takes no argument, returns the environment variable PATH as an array. Since +there is no search path supported, it returns undef, sorry. + +=cut +sub path { + return undef; +} + +=item canonpath + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminated successive slashes and successive "/.". + +=cut + +sub canonpath { + my ($self,$path) = @_; + $path =~ s/^([a-z]:)/\u$1/s; + + $path =~ s|/+|/|g unless($^O eq 'cygwin'); # xx////xx -> xx/xx + $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx + $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx + $path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx + $path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx + return $path; +} + +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Splits a path in to volume, directory, and filename portions. Assumes that +the last file is a path unless the path ends in '\\', '\\.', '\\..' +or $no_file is true. On Win32 this means that $no_file true makes this return +( $volume, $path, undef ). + +Separators accepted are \ and /. + +The results can be passed to L</catpath> to get back a path equivalent to +(usually identical to) the original path. + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + my ($volume,$directory,$file) = ('','',''); + if ( $nofile ) { + $path =~ + m{^( (?:[a-zA-Z?]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + } + else { + $path =~ + m{^ ( (?: [a-zA-Z?]: | + (?:\\\\|//)[^\\/]+[\\/][^\\/]+ + )? + ) + ( (?:.*[\\\\/](?:\.\.?\z)?)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + $file = $3; + } + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of L</catdir()>. + + @dirs = File::Spec->splitdir( $directories ); + +$directories must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, leading empty and +trailing directory entries can be returned, because these are significant +on some OSs. So, + + File::Spec->splitdir( "/a/b/c" ); + +Yields: + + ( '', 'a', 'b', '', 'c', '' ) + +=cut + +sub splitdir { + my ($self,$directories) = @_ ; + # + # split() likes to forget about trailing null fields, so here we + # check to be sure that there will not be any before handling the + # simple case. + # + if ( $directories !~ m|[\\/]\z| ) { + return split( m|[\\/]|, $directories ); + } + else { + # + # since there was a trailing separator, add a file name to the end, + # then do the split, then replace it with ''. + # + my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ; + $directories[ $#directories ]= '' ; + return @directories ; + } +} + + +=item catpath + +Takes volume, directory and file portions and returns an entire path. Under +Unix, $volume is ignored, and this is just like catfile(). On other OSs, +the $volume become significant. + +=cut + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + # If it's UNC, make sure the glue separator is there, reusing + # whatever separator is first in the $volume + $volume .= $1 + if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\z@s && + $directory =~ m@^[^\\/]@s + ) ; + + $volume .= $directory ; + + # If the volume is not just A:, make sure the glue separator is + # there, reusing whatever separator is first in the $volume if possible. + if ( $volume !~ m@^[a-zA-Z]:\z@s && + $volume =~ m@[^\\/]\z@ && + $file =~ m@[^\\/]@ + ) { + $volume =~ m@([\\/])@ ; + my $sep = $1 ? $1 : '\\' ; + $volume .= $sep ; + } + + $volume .= $file ; + + return $volume ; +} + + +=item abs2rel + +Takes a destination path and an optional base path returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $destination ) ; + $rel_path = File::Spec->abs2rel( $destination, $base ) ; + +If $base is not present or '', then L</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) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + $path = $self->rel2abs( $path ) ; + } + else { + $path = $self->canonpath( $path ) ; + } + + # Figure out the effective $base and clean it up. + if ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + elsif ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( $path_volume, $path_directories, $path_file ) = + $self->splitpath( $path, 1 ) ; + + my ( undef, $base_directories, undef ) = + $self->splitpath( $base, 1 ) ; + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my @basechunks = $self->splitdir( $base_directories ); + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) + ) { + shift @pathchunks ; + shift @basechunks ; + } + + # No need to catdir, we know these are well formed. + $path_directories = CORE::join( '\\', @pathchunks ); + $base_directories = CORE::join( '\\', @basechunks ); + + # $base_directories now contains the directories the resulting relative + # path must ascend out of before it can descend to $path_directory. So, + # replace all names with $parentDir + + #FA Need to replace between backslashes... + $base_directories =~ s|[^\\]+|..|g ; + + # Glue the two together, using a separator if necessary, and preventing an + # empty result. + + #FA Must check that new directories are not empty. + if ( $path_directories ne '' && $base_directories ne '' ) { + $path_directories = "$base_directories\\$path_directories" ; + } else { + $path_directories = "$base_directories$path_directories" ; + } + + # It makes no sense to add a relative path to a UNC volume + $path_volume = '' unless $path_volume =~ m{^[A-Z]:}is ; + + return $self->canonpath( + $self->catpath($path_volume, $path_directories, $path_file ) + ) ; +} + +=item rel2abs + +Converts a relative path to an absolute path. + + $abs_path = File::Spec->rel2abs( $destination ) ; + $abs_path = File::Spec->rel2abs( $destination, $base ) ; + +If $base is not present or '', then L<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($;$;) { + my ($self,$path,$base ) = @_; + + if ( ! $self->file_name_is_absolute( $path ) ) { + + if ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + my ( undef, $path_directories, $path_file ) = + $self->splitpath( $path, 1 ) ; + + my ( $base_volume, $base_directories, undef ) = + $self->splitpath( $base, 1 ) ; + + $path = $self->catpath( + $base_volume, + $self->catdir( $base_directories, $path_directories ), + $path_file + ) ; + } + + return $self->canonpath( $path ) ; +} + +=back + +=head1 SEE ALSO + +L<File::Spec> + +=cut + +1; diff --git a/lib/File/Spec/Functions.pm b/lib/File/Spec/Functions.pm index 0036ac1ded..be653338fa 100644 --- a/lib/File/Spec/Functions.pm +++ b/lib/File/Spec/Functions.pm @@ -3,7 +3,7 @@ package File::Spec::Functions; use File::Spec; use strict; -use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); +our (@ISA,@EXPORT,@EXPORT_OK,%EXPORT_TAGS,$VERSION); $VERSION = '1.1'; diff --git a/lib/File/Spec/Unix.pm b/lib/File/Spec/Unix.pm index a81c533235..4e4cc753aa 100644 --- a/lib/File/Spec/Unix.pm +++ b/lib/File/Spec/Unix.pm @@ -1,7 +1,7 @@ package File::Spec::Unix; use strict; -use vars qw($VERSION); +our($VERSION); $VERSION = '1.2'; diff --git a/lib/File/Temp.pm b/lib/File/Temp.pm index a35104400d..2d1a4b2f6b 100644 --- a/lib/File/Temp.pm +++ b/lib/File/Temp.pm @@ -124,7 +124,7 @@ use Carp; use File::Spec 0.8; use File::Path qw/ rmtree /; use Fcntl 1.03; -use Errno qw( EEXIST ENOENT ENOTDIR EINVAL ); +use Errno; require VMS::Stdio if $^O eq 'VMS'; # Need the Symbol package if we are running older perl @@ -166,7 +166,7 @@ Exporter::export_tags('POSIX','mktemp'); # Version number -$VERSION = '0.10'; +$VERSION = '0.11'; # This is a list of characters that can be used in random filenames @@ -443,7 +443,7 @@ sub _gettemp { # Error opening file - abort with error # if the reason was anything but EEXIST - unless ($! == EEXIST) { + unless ($!{EEXIST}) { carp "File::Temp: Could not create temp file $path: $!"; return (); } @@ -473,7 +473,7 @@ sub _gettemp { # Abort with error if the reason for failure was anything # except EEXIST - unless ($! == EEXIST) { + unless ($!{EEXIST}) { carp "File::Temp: Could not create directory $path: $!"; return (); } @@ -881,7 +881,8 @@ is specified. Return the filename and filehandle as before except that the file is automatically removed when the program exits. Default is for the file to be removed if a file handle is requested and to be kept if the -filename is requested. +filename is requested. In a scalar context (where no filename is +returned) the file is always deleted either on exit or when it is closed. If the template is not specified, a template is always automatically generated. This temporary file is placed in tmpdir() @@ -896,8 +897,11 @@ the description of tmpfile() elsewhere in this document). This is the preferred mode of operation, as if you only have a filehandle, you can never create a race condition by fumbling with the filename. On systems that can not unlink -an open file (for example, Windows NT) the file is marked for -deletion when the program ends (equivalent to setting UNLINK to 1). +an open file or can not mark a file as temporary when it is opened +(for example, Windows NT uses the C<O_TEMPORARY> flag)) +the file is marked for deletion when the program ends (equivalent +to setting UNLINK to 1). The C<UNLINK> flag is ignored if present. + (undef, $filename) = tempfile($template, OPEN => 0); @@ -978,19 +982,33 @@ sub tempfile { # Now add a suffix $template .= $options{"SUFFIX"}; + # Determine whether we should tell _gettemp to unlink the file + # On unix this is irrelevant and can be worked out after the file is + # opened (simply by unlinking the open filehandle). On Windows or VMS + # we have to indicate temporary-ness when we open the file. In general + # we only want a true temporary file if we are returning just the + # filehandle - if the user wants the filename they probably do not + # want the file to disappear as soon as they close it. + # For this reason, tie unlink_on_close to the return context regardless + # of OS. + my $unlink_on_close = ( wantarray ? 0 : 1); + # Create the file my ($fh, $path); croak "Error in tempfile() using $template" unless (($fh, $path) = _gettemp($template, "open" => $options{'OPEN'}, "mkdir"=> 0 , - "unlink_on_close" => $options{'UNLINK'}, + "unlink_on_close" => $unlink_on_close, "suffixlen" => length($options{'SUFFIX'}), ) ); # Set up an exit handler that can do whatever is right for the - # system. Do not check return status since this is all done with - # END blocks + # system. This removes files at exit when requested explicitly or when + # system is asked to unlink_on_close but is unable to do so because + # of OS limitations. + # The latter should be achieved by using a tied filehandle. + # Do not check return status since this is all done with END blocks. _deferred_unlink($fh, $path, 0) if $options{"UNLINK"}; # Return @@ -1731,6 +1749,15 @@ descriptor before passing it to another process. fcntl($tmpfh, F_SETFD, 0) or die "Can't clear close-on-exec flag on temp fh: $!\n"; +=head2 Temporary files and NFS + +Some problems are associated with using temporary files that reside +on NFS file systems and it is recommended that a local filesystem +is used whenever possible. Some of the security tests will most probably +fail when the temp file is not local. Additionally, be aware that +the performance of I/O operations over NFS will not be as good as for +a local disk. + =head1 HISTORY Originally began life in May 1999 as an XS interface to the system @@ -1743,8 +1770,8 @@ operating system and to help with portability. L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path> -See L<File::MkTemp> for a different implementation of temporary -file handling. +See L<IO::File> and L<File::MkTemp> for different implementations of +temporary file handling. =head1 AUTHOR diff --git a/lib/File/stat.pm b/lib/File/stat.pm index 0cf7a0b7aa..200af4ef17 100644 --- a/lib/File/stat.pm +++ b/lib/File/stat.pm @@ -4,6 +4,8 @@ use strict; use 5.005_64; our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); +our $VERSION = '1.00'; + BEGIN { use Exporter (); @EXPORT = qw(stat lstat); diff --git a/lib/FileCache.pm b/lib/FileCache.pm index e1c5ec4c8a..78a3e67c31 100644 --- a/lib/FileCache.pm +++ b/lib/FileCache.pm @@ -1,5 +1,7 @@ package FileCache; +our $VERSION = '1.00'; + =head1 NAME FileCache - keep more files open than the system permits diff --git a/lib/Filter/Simple.pm b/lib/Filter/Simple.pm new file mode 100644 index 0000000000..fa883e65bd --- /dev/null +++ b/lib/Filter/Simple.pm @@ -0,0 +1,248 @@ +package Filter::Simple; + +use vars qw{ $VERSION }; + +$VERSION = '0.01'; + +use Filter::Util::Call; +use Carp; + +sub import { + my $caller = caller; + my ($class, $filter) = @_; + croak "Usage: use Filter::Simple sub {...}" unless ref $filter eq CODE; + *{"${caller}::import"} = gen_filter_import($caller, $filter); + *{"${caller}::unimport"} = \*filter_unimport; +} + +sub gen_filter_import { + my ($class, $filter) = @_; + return sub { + my ($imported_class, @args) = @_; + filter_add( + sub { + my ($status, $off); + my $data = ""; + while ($status = filter_read()) { + if (m/^\s*no\s+$class\s*;\s*$/) { + $off=1; + last; + } + $data .= $_; + $_ = ""; + } + $_ = $data; + $filter->(@args) unless $status < 0; + $_ .= "no $class;\n" if $off; + return length; + } + ); + } +} + +sub filter_unimport { + filter_del(); +} + +1; + +__END__ + +=head1 NAME + +Filter::Simple - Simplified source filtering + + +=head1 SYNOPSIS + + # in MyFilter.pm: + + package MyFilter; + + use Filter::Simple sub { ... }; + + + # in user's code: + + use MyFilter; + + # this code is filtered + + no MyFilter; + + # this code is not + + +=head1 DESCRIPTION + +=head2 The Problem + +Source filtering is an immensely powerful feature of recent versions of Perl. +It allows one to extend the language itself (e.g. the Switch module), to +simplify the language (e.g. Language::Pythonesque), or to completely recast the +language (e.g. Lingua::Romana::Perligata). Effectively, it allows one to use +the full power of Perl as its own, recursively applied, macro language. + +The excellent Filter::Util::Call module (by Paul Marquess) provides a +usable Perl interface to source filtering, but it is often too powerful +and not nearly as simple as it could be. + +To use the module it is necessary to do the following: + +=over 4 + +=item 1. + +Download, build, and install the Filter::Util::Call module. + +=item 2. + +Set up a module that does a C<use Filter::Util::Call>. + +=item 3. + +Within that module, create an C<import> subroutine. + +=item 4. + +Within the C<import> subroutine do a call to C<filter_add>, passing +it either a subroutine reference. + +=item 5. + +Within the subroutine reference, call C<filter_read> or C<filter_read_exact> +to "prime" $_ with source code data from the source file that will +C<use> your module. Check the status value returned to see if any +source code was actually read in. + +=item 6. + +Process the contents of $_ to change the source code in the desired manner. + +=item 7. + +Return the status value. + +=item 8. + +If the act of unimporting your module (via a C<no>) should cause source +code filtering to cease, create an C<unimport> subroutine, and have it call +C<filter_del>. Make sure that the call to C<filter_read> or +C<filter_read_exact> in step 5 will not accidentally read past the +C<no>. Effectively this limits source code filters to line-by-line +operation, unless the C<import> subroutine does some fancy +pre-pre-parsing of the source code it's filtering. + +=back + +For example, here is a minimal source code filter in a module named +BANG.pm. It simply converts every occurrence of the sequence C<BANG\s+BANG> +to the sequence C<die 'BANG' if $BANG> in any piece of code following a +C<use BANG;> statement (until the next C<no BANG;> statement, if any): + + package BANG; + + use Filter::Util::Call ; + + sub import { + filter_add( sub { + my $caller = caller; + my ($status, $no_seen, $data); + while ($status = filter_read()) { + if (/^\s*no\s+$caller\s*;\s*$/) { + $no_seen=1; + last; + } + $data .= $_; + $_ = ""; + } + $_ = $data; + s/BANG\s+BANG/die 'BANG' if \$BANG/g + unless $status < 0; + $_ .= "no $class;\n" if $no_seen; + return 1; + }) + } + + sub unimport { + filter_del(); + } + + 1 ; + +Given this level of complexity, it's perhaps not surprising that source +code filtering is still a mystery to most users. + + +=head2 A Solution + +The Filter::Simple module provides a vastly simplified interface to +Filter::Util::Call; one that is sufficient for most common cases. + +Instead of the above process, with Filter::Simple the task of setting up +a source code filter is reduced to: + +=over 4 + +=item 1. + +Set up a module that does a C<use Filter::Simple sub { ... }>. + +=item 2. + +Within the anonymous subroutine passed to C<use Filter::Simple>, process the +contents of $_ to change the source code in the desired manner. + +=back + +In other words, the previous example, would become: + + package BANG; + + use Filter::Simple sub { + s/BANG\s+BANG/die 'BANG' if \$BANG/g; + }; + + 1 ; + + +=head2 How it works + +The Filter::Simple module exports into the package that C<use>s it (e.g. +package "BANG" in the above example) two automagically constructed +subroutines -- C<import> and C<unimport> -- which take care of all the +nasty details. + +In addition, the generated C<import> subroutine passes its own argument +list to the filtering subroutine, so the BANG.pm filter could easily +be made parametric: + + package BANG; + + use Filter::Simple sub { + my ($die_msg, $var_name) = @_; + s/BANG\s+BANG/die '$die_msg' if \${$var_name}/g; + }; + + # and in some user code: + + use BANG "BOOM", "BAM; # "BANG BANG" becomes: die 'BOOM' if $BAM + + +The specified filtering subroutine is called every time a C<use BANG> +is encountered, and passed all the source code following that call, +up to either the next C<no BANG;> call or the end of the source file +(whichever occurs first). Currently, any C<no BANG;> call must appear +by itself on a separate line, or it is ignored. + + +=head1 AUTHOR + +Damian Conway (damian@conway.org) + +=head1 COPYRIGHT + + Copyright (c) 2000, Damian Conway. All Rights Reserved. + This module is free software. It may be used, redistributed +and/or modified under the terms of the Perl Artistic License + (see http://www.perl.com/perl/misc/Artistic.html) diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index 2bb0548a2c..e933c483fd 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -2,17 +2,17 @@ package Getopt::Long; -# RCS Status : $Id: GetoptLong.pl,v 2.25 2000-08-28 21:45:17+02 jv Exp $ +# RCS Status : $Id: GetoptLong.pl,v 2.25 2000-08-28 21:45:17+02 jv Exp jv $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Mon Jul 31 21:21:13 2000 -# Update Count : 739 +# Last Modified On: Sat Jan 6 17:12:27 2001 +# Update Count : 748 # Status : Released ################ Copyright ################ -# This program is Copyright 1990,2000 by Johan Vromans. +# This program is Copyright 1990,2001 by Johan Vromans. # This program is free software; you can redistribute it and/or # modify it under the terms of the Perl Artistic License or the # GNU General Public License as published by the Free Software @@ -30,19 +30,24 @@ package Getopt::Long; ################ Module Preamble ################ +use 5.004; + use strict; -BEGIN { - require 5.004; - use Exporter (); - use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - $VERSION = 2.24; +use vars qw($VERSION $VERSION_STRING); +$VERSION = 2.24_02; +$VERSION_STRING = "2.24_02"; + +use Exporter; +use AutoLoader qw(AUTOLOAD); - @ISA = qw(Exporter); +use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); +@ISA = qw(Exporter); +%EXPORT_TAGS = qw(); +BEGIN { + # Init immediately so their contents can be used in the 'use vars' below. @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); - %EXPORT_TAGS = qw(); @EXPORT_OK = qw(); - use AutoLoader qw(AUTOLOAD); } # User visible variables. @@ -143,7 +148,7 @@ sub new { my %atts = @_; # Register the callers package. - my $self = { caller => (caller)[0] }; + my $self = { caller_pkg => (caller)[0] }; bless ($self, $class); @@ -189,7 +194,7 @@ sub getoptions { # Call main routine. my $ret = 0; - $Getopt::Long::caller = $self->{caller}; + $Getopt::Long::caller = $self->{caller_pkg}; eval { $ret = Getopt::Long::GetOptions (@_); }; # Restore saved settings. @@ -210,12 +215,12 @@ __END__ ################ AutoLoading subroutines ################ -# RCS Status : $Id: GetoptLongAl.pl,v 2.29 2000-08-28 21:56:18+02 jv Exp $ +# RCS Status : $Id: GetoptLongAl.pl,v 2.29 2000-08-28 21:56:18+02 jv Exp jv $ # Author : Johan Vromans # Created On : Fri Mar 27 11:50:30 1998 # Last Modified By: Johan Vromans -# Last Modified On: Fri Jul 28 19:12:29 2000 -# Update Count : 97 +# Last Modified On: Tue Dec 26 18:01:16 2000 +# Update Count : 98 # Status : Released sub GetOptions { @@ -321,7 +326,9 @@ sub GetOptions { if ( ! defined $o ) { # empty -> '-' option - $opctl{$linko = $o = ''} = $c; + $linko = $o = ''; + $opctl{''} = $c; + $bopctl{''} = $c if $bundling; } else { # Handle alias names @@ -658,7 +665,8 @@ sub FindOption ($$$$$$$) { print STDERR ("=> find \"$opt\", prefix=\"$prefix\"\n") if $debug; - return (0) unless $opt =~ /^$prefix(.*)$/s; + return 0 unless $opt =~ /^$prefix(.*)$/s; + return 0 if $opt eq "-" && !defined $opctl->{""}; $opt = $+; my ($starter) = $1; @@ -687,7 +695,7 @@ sub FindOption ($$$$$$$) { if ( $bundling && $starter eq '-' ) { # Unbundle single letter option. - $rest = substr ($tryopt, 1); + $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : ""; $tryopt = substr ($tryopt, 0, 1); $tryopt = lc ($tryopt) if $ignorecase > 1; print STDERR ("=> $starter$tryopt unbundled from ", @@ -1553,13 +1561,18 @@ It goes without saying that bundling can be quite confusing. =head2 The lonesome dash -Some applications require the option C<-> (that's a lone dash). This -can be achieved by adding an option specification with an empty name: +Normally, a lone dash C<-> on the command line will not be considered +an option. Option processing will terminate (unless "permute" is +configured) and the dash will be left in C<@ARGV>. + +It is possible to get special treatment for a lone dash. This can be +achieved by adding an option specification with an empty name, for +example: GetOptions ('' => \$stdio); -A lone dash on the command line will now be legal, and set options -variable C<$stdio>. +A lone dash on the command line will now be a legal option, and using +it will set variable C<$stdio>. =head2 Argument call-back diff --git a/lib/I18N/Collate.pm b/lib/I18N/Collate.pm index 64a03a284b..d18a5a5710 100644 --- a/lib/I18N/Collate.pm +++ b/lib/I18N/Collate.pm @@ -1,5 +1,8 @@ package I18N::Collate; +use strict; +our $VERSION = '1.00'; + =head1 NAME I18N::Collate - compare 8-bit scalar data according to the current locale @@ -112,15 +115,18 @@ use warnings::register; require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(collate_xfrm setlocale LC_COLLATE); -@EXPORT_OK = qw(); +our @ISA = qw(Exporter); +our @EXPORT = qw(collate_xfrm setlocale LC_COLLATE); +our @EXPORT_OK = qw(); use overload qw( fallback 1 cmp collate_cmp ); +our($LOCALE, $C); + +our $please_use_I18N_Collate_even_if_deprecated = 0; sub new { my $new = $_[1]; diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm index e7a071ab7f..066e36638b 100644 --- a/lib/Math/Complex.pm +++ b/lib/Math/Complex.pm @@ -1414,6 +1414,8 @@ sub stringify_polar { 1; __END__ +=pod + =head1 NAME Math::Complex - complex numbers and associated mathematical functions diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm index 40da9f3817..a2846fe902 100644 --- a/lib/Net/Ping.pm +++ b/lib/Net/Ping.pm @@ -269,13 +269,13 @@ sub checksum ); $len_msg = length($msg); - $num_short = $len_msg / 2; + $num_short = int($len_msg / 2); $chk = 0; foreach $short (unpack("S$num_short", $msg)) { $chk += $short; } # Add the odd byte in - $chk += unpack("C", substr($msg, $len_msg - 1, 1)) if $len_msg % 2; + $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2; $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement } @@ -369,16 +369,17 @@ sub ping_udp elsif ($nfound) # A packet is waiting { $from_msg = ""; - $from_saddr = recv($self->{"fh"}, $from_msg, 1500, $flags); - ($from_port, $from_ip) = sockaddr_in($from_saddr); - if (($from_ip eq $ip) && # Does the packet check out? - ($from_port == $self->{"port_num"}) && - ($from_msg eq $msg)) - { - $ret = 1; # It's a winner - $done = 1; - } - } + $from_saddr = recv($self->{"fh"}, $from_msg, 1500, $flags) + or last; # For example an unreachable host will make recv() fail. + ($from_port, $from_ip) = sockaddr_in($from_saddr); + if (($from_ip eq $ip) && # Does the packet check out? + ($from_port == $self->{"port_num"}) && + ($from_msg eq $msg)) + { + $ret = 1; # It's a winner + $done = 1; + } + } else # Oops, timed out { $done = 1; @@ -459,6 +460,11 @@ received from the remote host and the received packet contains the same data as the packet that was sent, the remote host is considered reachable. This protocol does not require any special privileges. +It should be borne in mind that, for both tcp and udp ping, a host +will be reported as unreachable if it is not running the +appropriate echo service. For Unix-like systems see L<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/lib/Net/hostent.pm b/lib/Net/hostent.pm index 6cfde7253c..0a22389302 100644 --- a/lib/Net/hostent.pm +++ b/lib/Net/hostent.pm @@ -2,6 +2,7 @@ package Net::hostent; use strict; use 5.005_64; +our $VERSION = '1.00'; our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); diff --git a/lib/Net/netent.pm b/lib/Net/netent.pm index b21cd04664..d5ce22ebb3 100644 --- a/lib/Net/netent.pm +++ b/lib/Net/netent.pm @@ -2,6 +2,7 @@ package Net::netent; use strict; use 5.005_64; +our $VERSION = '1.00'; our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); diff --git a/lib/Net/protoent.pm b/lib/Net/protoent.pm index 6aad940903..2c3db88e9b 100644 --- a/lib/Net/protoent.pm +++ b/lib/Net/protoent.pm @@ -2,6 +2,7 @@ package Net::protoent; use strict; use 5.005_64; +our $VERSION = '1.00'; our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); diff --git a/lib/Net/servent.pm b/lib/Net/servent.pm index c892af0bbe..18c7fb5c92 100644 --- a/lib/Net/servent.pm +++ b/lib/Net/servent.pm @@ -2,6 +2,7 @@ package Net::servent; use strict; use 5.005_64; +our $VERSION = '1.00'; our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); diff --git a/lib/Pod/Checker.pm b/lib/Pod/Checker.pm index 37ed68f873..35d0186a99 100644 --- a/lib/Pod/Checker.pm +++ b/lib/Pod/Checker.pm @@ -150,8 +150,8 @@ C<"">. =item * Unknown command "I<CMD>" An invalid POD command has been found. Valid are C<=head1>, C<=head2>, -C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>, C<=for>, C<=pod>, -C<=cut> +C<=head3>, C<=head4>, C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>, +C<=for>, C<=pod>, C<=cut> =item * Unknown interior-sequence "I<SEQ>" @@ -355,6 +355,8 @@ my %VALID_COMMANDS = ( 'cut' => 1, 'head1' => 1, 'head2' => 1, + 'head3' => 1, + 'head4' => 1, 'over' => 1, 'back' => 1, 'item' => 1, diff --git a/lib/Pod/Functions.pm b/lib/Pod/Functions.pm index 44619d53d8..960b847394 100644 --- a/lib/Pod/Functions.pm +++ b/lib/Pod/Functions.pm @@ -2,12 +2,16 @@ package Pod::Functions; #:vi:set ts=20 +our $VERSION = '1.00'; + require Exporter; @ISA = qw(Exporter); @EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order); -%Type_Description = ( +our(%Kinds, %Type, %Flavor); + +our %Type_Description = ( 'ARRAY' => 'Functions for real @ARRAYs', 'Binary' => 'Functions for fixed length data or records', 'File' => 'Functions for filehandles, files, or directories', @@ -30,7 +34,7 @@ require Exporter; 'Namespace' => 'Keywords altering or affecting scoping of identifiers', ); -@Type_Order = qw{ +our @Type_Order = qw{ String Regexp Math @@ -57,20 +61,20 @@ while (<DATA>) { chomp; s/#.*//; next unless $_; - ($name, $type, $text) = split " ", $_, 3; + my($name, $type, $text) = split " ", $_, 3; $Type{$name} = $type; $Flavor{$name} = $text; - for $type ( split /[,\s]+/, $type ) { - push @{$Kinds{$type}}, $name; + for my $t ( split /[,\s]+/, $type ) { + push @{$Kinds{$t}}, $name; } } close DATA; unless (caller) { - foreach $type ( @Type_Order ) { - $list = join(", ", sort @{$Kinds{$type}}); - $typedesc = $Type_Description{$type} . ":"; + foreach my $type ( @Type_Order ) { + my $list = join(", ", sort @{$Kinds{$type}}); + my $typedesc = $Type_Description{$type} . ":"; write; } } diff --git a/lib/Pod/Html.pm b/lib/Pod/Html.pm index f70a42bccc..43168231f3 100644 --- a/lib/Pod/Html.pm +++ b/lib/Pod/Html.pm @@ -12,7 +12,6 @@ use Config; use Cwd; use File::Spec::Unix; use Getopt::Long; -use Pod::Functions; use locale; # make \w work right in non-ASCII lands diff --git a/lib/Pod/Man.pm b/lib/Pod/Man.pm index 0fdb6d0360..84c8f6671b 100644 --- a/lib/Pod/Man.pm +++ b/lib/Pod/Man.pm @@ -1,5 +1,5 @@ # Pod::Man -- Convert POD data to formatted *roff input. -# $Id: Man.pm,v 1.8 2000/10/10 02:14:31 eagle Exp $ +# $Id: Man.pm,v 1.12 2000/12/25 12:56:12 eagle Exp $ # # Copyright 1999, 2000 by Russ Allbery <rra@stanford.edu> # @@ -38,7 +38,7 @@ use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION); # Perl core and too many things could munge CVS magic revision strings. # This number should ideally be the same as the CVS revision in podlators, # however. -$VERSION = 1.08; +$VERSION = 1.12; ############################################################################ @@ -279,33 +279,6 @@ sub protect { $_; } -# Given a command and a single argument that may or may not contain double -# quotes, handle double-quote formatting for it. If there are no double -# quotes, just return the command followed by the argument in double quotes. -# If there are double quotes, use an if statement to test for nroff, and for -# nroff output the command followed by the argument in double quotes with -# embedded double quotes doubled. For other formatters, remap paired double -# quotes to `` and ''. -sub switchquotes { - my $command = shift; - local $_ = shift; - my $extra = shift; - s/\\\*\([LR]\"/\"/g; - if (/\"/) { - s/\"/\"\"/g; - my $troff = $_; - $troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g; - s/\"/\"\"/g if $extra; - $troff =~ s/\"/\"\"/g if $extra; - $_ = qq("$_") . ($extra ? " $extra" : ''); - $troff = qq("$troff") . ($extra ? " $extra" : ''); - return ".if n $command $_\n.el $command $troff\n"; - } else { - $_ = qq("$_") . ($extra ? " $extra" : ''); - return "$command $_\n"; - } -} - # Translate a font string into an escape. sub toescape { (length ($_[0]) > 1 ? '\f(' : '\f') . $_[0] } @@ -568,7 +541,7 @@ sub textblock { $text = $self->parse ($text, @_); $text =~ s/\n\s*$/\n/; $self->makespace; - $self->output (protect $self->mapfonts ($text)); + $self->output (protect $self->textmapfonts ($text)); $self->outindex; $$self{NEEDSPACE} = 1; } @@ -661,7 +634,7 @@ sub cmd_head1 { $$self{ITEMS} = 0; $self->output (".PD\n"); } - $self->output (switchquotes ('.SH', $self->mapfonts ($_))); + $self->output ($self->switchquotes ('.SH', $self->mapfonts ($_))); $self->outindex (($_ eq 'NAME') ? () : ('Header', $_)); $$self{NEEDSPACE} = 0; } @@ -675,11 +648,41 @@ sub cmd_head2 { $$self{ITEMS} = 0; $self->output (".PD\n"); } - $self->output (switchquotes ('.Sh', $self->mapfonts ($_))); + $self->output ($self->switchquotes ('.Sh', $self->mapfonts ($_))); $self->outindex ('Subsection', $_); $$self{NEEDSPACE} = 0; } +# Third level heading. +sub cmd_head3 { + my $self = shift; + local $_ = $self->parse (@_); + s/\s+$//; + if ($$self{ITEMS} > 1) { + $$self{ITEMS} = 0; + $self->output (".PD\n"); + } + $self->makespace; + $self->output ($self->switchquotes ('.I', $self->mapfonts ($_))); + $self->outindex ('Subsection', $_); + $$self{NEEDSPACE} = 1; +} + +# Fourth level heading. +sub cmd_head4 { + my $self = shift; + local $_ = $self->parse (@_); + s/\s+$//; + if ($$self{ITEMS} > 1) { + $$self{ITEMS} = 0; + $self->output (".PD\n"); + } + $self->makespace; + $self->output ($self->textmapfonts ($_) . "\n"); + $self->outindex ('Subsection', $_); + $$self{NEEDSPACE} = 1; +} + # Start a list. For indents after the first, wrap the outside indent in .RS # so that hanging paragraph tags will be correct. sub cmd_over { @@ -736,9 +739,9 @@ sub cmd_item { $self->output (".RE\n"); $$self{WEIRDINDENT} = 0; } - $_ = $self->mapfonts ($_); + $_ = $self->textmapfonts ($_); $self->output (".PD 0\n") if ($$self{ITEMS} == 1); - $self->output (switchquotes ('.Ip', $_, $$self{INDENT})); + $self->output ($self->switchquotes ('.Ip', $_, $$self{INDENT})); $self->outindex ($index ? ('Item', $index) : ()); $$self{NEEDSPACE} = 0; $$self{ITEMS}++; @@ -844,18 +847,52 @@ sub buildlink { # At this point, we'll have embedded font codes of the form \f(<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)}; @@ -1020,6 +1057,44 @@ sub outindex { # Output text to the output device. sub output { print { $_[0]->output_handle } $_[1] } +# Given a command and a single argument that may or may not contain double +# quotes, handle double-quote formatting for it. If there are no double +# quotes, just return the command followed by the argument in double quotes. +# If there are double quotes, use an if statement to test for nroff, and for +# nroff output the command followed by the argument in double quotes with +# embedded double quotes doubled. For other formatters, remap paired double +# quotes to LQUOTE and RQUOTE. +sub switchquotes { + my $self = shift; + my $command = shift; + local $_ = shift; + my $extra = shift; + s/\\\*\([LR]\"/\"/g; + + # We also have to deal with \*C` and \*C', which are used to add the + # quotes around C<> text, since they may expand to " and if they do this + # confuses the .SH macros and the like no end. Expand them ourselves. + # If $extra is set, we're dealing with =item, which in most nroff macro + # sets requires an extra level of quoting of double quotes. + my $c_is_quote = ($$self{LQUOTE} =~ /\"/) || ($$self{RQUOTE} =~ /\"/); + if (/\"/ || ($c_is_quote && /\\\*\(C[\'\`]/)) { + s/\"/\"\"/g; + my $troff = $_; + $troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g; + s/\\\*\(C\`/$$self{LQUOTE}/g; + s/\\\*\(C\'/$$self{RQUOTE}/g; + $troff =~ s/\\\*\(C[\'\`]//g; + s/\"/\"\"/g if $extra; + $troff =~ s/\"/\"\"/g if $extra; + $_ = qq("$_") . ($extra ? " $extra" : ''); + $troff = qq("$troff") . ($extra ? " $extra" : ''); + return ".if n $command $_\n.el $command $troff\n"; + } else { + $_ = qq("$_") . ($extra ? " $extra" : ''); + return "$command $_\n"; + } +} + __END__ .\" These are some extra bits of roff that I don't want to lose track of diff --git a/lib/Pod/Select.pm b/lib/Pod/Select.pm index d86d823350..e7c820f350 100644 --- a/lib/Pod/Select.pm +++ b/lib/Pod/Select.pm @@ -109,33 +109,39 @@ Some example section specifications follow. =over 4 -=item +=item * + Match the C<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</!.+> diff --git a/lib/Pod/Text.pm b/lib/Pod/Text.pm index 5a7bab8f2a..5f2dae049a 100644 --- a/lib/Pod/Text.pm +++ b/lib/Pod/Text.pm @@ -1,5 +1,5 @@ # Pod::Text -- Convert POD data to formatted ASCII text. -# $Id: Text.pm,v 2.6 2000/10/10 02:13:17 eagle Exp $ +# $Id: Text.pm,v 2.7 2000/11/19 04:47:50 eagle Exp $ # # Copyright 1999, 2000 by Russ Allbery <rra@stanford.edu> # @@ -37,7 +37,7 @@ use vars qw(@ISA @EXPORT %ESCAPES $VERSION); # Perl core and too many things could munge CVS magic revision strings. # This number should ideally be the same as the CVS revision in podlators, # however. -$VERSION = 2.06; +$VERSION = 2.07; ############################################################################ @@ -173,7 +173,7 @@ sub initialize { $$self{width} = 76 unless defined $$self{width}; # Figure out what quotes we'll be using for C<> text. - $$self{quotes} ||= "'"; + $$self{quotes} ||= '"'; if ($$self{quotes} eq 'none') { $$self{LQUOTE} = $$self{RQUOTE} = ''; } elsif (length ($$self{quotes}) == 1) { @@ -376,6 +376,32 @@ sub cmd_head2 { } } +# Third level heading. +sub cmd_head3 { + my $self = shift; + local $_ = shift; + s/\s+$//; + $_ = $self->interpolate ($_, shift); + if ($$self{alt}) { + $self->output ("\n= $_ =\n\n"); + } else { + $self->output (' ' x ($$self{indent} * 2 / 3 + 0.5) . $_ . "\n\n"); + } +} + +# Third level heading. +sub cmd_head4 { + my $self = shift; + local $_ = shift; + s/\s+$//; + $_ = $self->interpolate ($_, shift); + if ($$self{alt}) { + $self->output ("\n- $_ -\n\n"); + } else { + $self->output (' ' x ($$self{indent} * 3 / 4 + 0.5) . $_ . "\n\n"); + } +} + # Start a list. sub cmd_over { my $self = shift; diff --git a/lib/Pod/Text/Color.pm b/lib/Pod/Text/Color.pm index 10e1d9fa30..e943216d88 100644 --- a/lib/Pod/Text/Color.pm +++ b/lib/Pod/Text/Color.pm @@ -1,5 +1,5 @@ # Pod::Text::Color -- Convert POD data to formatted color ASCII text -# $Id: Color.pm,v 0.5 1999/09/20 10:15:16 eagle Exp $ +# $Id: Color.pm,v 0.6 2000/12/25 12:52:39 eagle Exp $ # # Copyright 1999 by Russ Allbery <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/lib/Pod/Text/Overstrike.pm b/lib/Pod/Text/Overstrike.pm new file mode 100644 index 0000000000..c9f0789d06 --- /dev/null +++ b/lib/Pod/Text/Overstrike.pm @@ -0,0 +1,160 @@ +# Pod::Text::Overstrike -- Convert POD data to formatted overstrike text +# $Id: Overstrike.pm,v 1.1 2000/12/25 12:51:23 eagle Exp $ +# +# Created by Joe Smith <Joe.Smith@inwap.com> 30-Nov-2000 +# (based on Pod::Text::Color 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. +# +# This was written because the output from: +# +# pod2text Text.pm > plain.txt; less plain.txt +# +# is not as rich as the output from +# +# pod2man Text.pm | nroff -man > fancy.txt; less fancy.txt +# +# and because both Pod::Text::Color and Pod::Text::Termcap are not device +# independent. + +############################################################################ +# Modules and declarations +############################################################################ + +package Pod::Text::Overstrike; + +require 5.004; + +use Pod::Text (); + +use strict; +use vars qw(@ISA $VERSION); + +@ISA = qw(Pod::Text); + +# Don't use the CVS revision as the version, since this module is also in +# Perl core and too many things could munge CVS magic revision strings. +# This number should ideally be the same as the CVS revision in podlators, +# however. +$VERSION = 1.01; + + +############################################################################ +# Overrides +############################################################################ + +# Make level one headings bold, overridding any existing formatting. +sub cmd_head1 { + my $self = shift; + local $_ = shift; + s/\s+$//; + s/(.)\cH\1//g; + s/_\cH//g; + s/(.)/$1\b$1/g; + $self->SUPER::cmd_head1 ($_); +} + +# Make level two headings bold, overriding any existing formatting. +sub cmd_head2 { + my $self = shift; + local $_ = shift; + s/\s+$//; + s/(.)\cH\1//g; + s/_\cH//g; + s/(.)/$1\b$1/g; + $self->SUPER::cmd_head2 ($_); +} + +# Make level three headings underscored, overriding any existing formatting. +sub cmd_head3 { + my $self = shift; + local $_ = shift; + s/\s+$//; + s/(.)\cH\1//g; + s/_\cH//g; + s/(.)/_\b$1/g; + $self->SUPER::cmd_head3 ($_); +} + +# Fix the various interior sequences. +sub seq_b { local $_ = $_[1]; s/(.)\cH\1//g; s/_\cH//g; s/(.)/$1\b$1/g; $_ } +sub seq_f { local $_ = $_[1]; s/(.)\cH\1//g; s/_\cH//g; s/(.)/_\b$1/g; $_ } +sub seq_i { local $_ = $_[1]; s/(.)\cH\1//g; s/_\cH//g; s/(.)/_\b$1/g; $_ } + +# We unfortunately have to override the wrapping code here, since the normal +# wrapping code gets really confused by all the escape sequences. +sub wrap { + my $self = shift; + local $_ = shift; + my $output = ''; + my $spaces = ' ' x $$self{MARGIN}; + my $width = $$self{width} - $$self{MARGIN}; + while (length > $width) { + if (s/^((?:(?:[^\n]\cH)?[^\n]){0,$width})\s+// + || s/^((?:(?:[^\n]\cH)?[^\n]){$width})//) { + $output .= $spaces . $1 . "\n"; + } else { + last; + } + } + $output .= $spaces . $_; + $output =~ s/\s+$/\n\n/; + $output; +} + +############################################################################ +# Module return value and documentation +############################################################################ + +1; +__END__ + +=head1 NAME + +Pod::Text::Overstrike - Convert POD data to formatted overstrike text + +=head1 SYNOPSIS + + use Pod::Text::Overstrike; + my $parser = Pod::Text::Overstrike->new (sentence => 0, width => 78); + + # Read POD from STDIN and write to STDOUT. + $parser->parse_from_filehandle; + + # Read POD from file.pod and write to file.txt. + $parser->parse_from_file ('file.pod', 'file.txt'); + +=head1 DESCRIPTION + +Pod::Text::Overstrike is a simple subclass of Pod::Text that highlights +output text using overstrike sequences, in a manner similar to nroff. +Characters in bold text are overstruck (character, backspace, character) and +characters in underlined text are converted to overstruck underscores +(underscore, backspace, character). This format was originally designed for +hardcopy terminals and/or lineprinters, yet is readable on softcopy (CRT) +terminals. + +Overstruck text is best viewed by page-at-a-time programs that take +advantage of the terminal's B<stand-out> and I<underline> capabilities, such +as the less program on Unix. + +Apart from the overstrike, it in all ways functions like Pod::Text. See +L<Pod::Text> for details and available options. + +=head1 BUGS + +Currently, the outermost formatting instruction wins, so for example +underlined text inside a region of bold text is displayed as simply bold. +There may be some better approach possible. + +=head1 SEE ALSO + +L<Pod::Text|Pod::Text>, L<Pod::Parser|Pod::Parser> + +=head1 AUTHOR + +Joe Smith E<lt>Joe.Smith@inwap.comE<gt>, using the framework created by Russ +Allbery E<lt>rra@stanford.eduE<gt>. + +=cut diff --git a/lib/Pod/Text/Termcap.pm b/lib/Pod/Text/Termcap.pm index 7e89ec61be..333852a425 100644 --- a/lib/Pod/Text/Termcap.pm +++ b/lib/Pod/Text/Termcap.pm @@ -1,5 +1,5 @@ # Pod::Text::Termcap -- Convert POD data to ASCII text with format escapes. -# $Id: Termcap.pm,v 0.4 1999/09/20 10:17:45 eagle Exp $ +# $Id: Termcap.pm,v 1.0 2000/12/25 12:52:48 eagle Exp $ # # Copyright 1999 by Russ Allbery <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/lib/Search/Dict.pm b/lib/Search/Dict.pm index 9a229a7bc0..58c7543ced 100644 --- a/lib/Search/Dict.pm +++ b/lib/Search/Dict.pm @@ -2,8 +2,11 @@ package Search::Dict; require 5.000; require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(look); +use strict; + +our $VERSION = '1.00'; +our @ISA = qw(Exporter); +our @EXPORT = qw(look); =head1 NAME @@ -30,9 +33,9 @@ If I<$fold> is true, ignore case. =cut sub look { - local(*FH,$key,$dict,$fold) = @_; + my($fh,$key,$dict,$fold) = @_; local($_); - my(@stat) = stat(FH) + my(@stat) = stat($fh) or return -1; my($size, $blksize) = @stat[7,11]; $blksize ||= 8192; @@ -41,10 +44,10 @@ sub look { my($min, $max, $mid) = (0, int($size / $blksize)); while ($max - $min > 1) { $mid = int(($max + $min) / 2); - seek(FH, $mid * $blksize, 0) + seek($fh, $mid * $blksize, 0) or return -1; - <FH> if $mid; # probably a partial line - $_ = <FH>; + <$fh> if $mid; # probably a partial line + $_ = <$fh>; chop; s/[^\w\s]//g if $dict; $_ = lc $_ if $fold; @@ -56,19 +59,19 @@ sub look { } } $min *= $blksize; - seek(FH,$min,0) + seek($fh,$min,0) or return -1; - <FH> if $min; + <$fh> if $min; for (;;) { - $min = tell(FH); - defined($_ = <FH>) + $min = tell($fh); + defined($_ = <$fh>) or last; chop; s/[^\w\s]//g if $dict; $_ = lc $_ if $fold; last if $_ ge $key; } - seek(FH,$min,0); + seek($fh,$min,0); $min; } diff --git a/lib/SelectSaver.pm b/lib/SelectSaver.pm index 5f569222fc..08104f47d4 100644 --- a/lib/SelectSaver.pm +++ b/lib/SelectSaver.pm @@ -1,5 +1,7 @@ package SelectSaver; +our $VERSION = '1.00'; + =head1 NAME SelectSaver - save and restore selected file handle diff --git a/lib/Term/Cap.pm b/lib/Term/Cap.pm index 0954000e8d..6d31ab77c5 100644 --- a/lib/Term/Cap.pm +++ b/lib/Term/Cap.pm @@ -1,7 +1,9 @@ package Term::Cap; use Carp; -# Last updated: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com +our $VERSION = '1.00'; + +# Last updated: Thu Nov 30 23:34:29 EST 2000 by schwern@pobox.com # TODO: # support Berkeley DB termcaps diff --git a/lib/Term/Complete.pm b/lib/Term/Complete.pm index 445dfca02a..6cf6a0cfc5 100644 --- a/lib/Term/Complete.pm +++ b/lib/Term/Complete.pm @@ -2,8 +2,10 @@ package Term::Complete; require 5.000; require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(Complete); +use strict; +our @ISA = qw(Exporter); +our @EXPORT = qw(Complete); +our $VERSION = '1.2'; # @(#)complete.pl,v1.2 (me@anywhere.EBay.Sun.COM) 09/23/91 @@ -64,6 +66,7 @@ Wayne Thompson =cut +our($complete, $kill, $erase1, $erase2); CONFIG: { $complete = "\004"; $kill = "\025"; @@ -72,7 +75,7 @@ CONFIG: { } sub Complete { - my($prompt, @cmp_list, $cmp, $test, $l, @match); + my($prompt, @cmp_lst, $cmp, $test, $l, @match); my ($return, $r) = ("", 0); $return = ""; diff --git a/lib/Term/ReadLine.pm b/lib/Term/ReadLine.pm index 8bb820578a..491ce79cbe 100644 --- a/lib/Term/ReadLine.pm +++ b/lib/Term/ReadLine.pm @@ -159,22 +159,27 @@ particular used C<Term::ReadLine::*> package). =cut +use strict; + package Term::ReadLine::Stub; -@ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap'; +our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap'; $DB::emacs = $DB::emacs; # To peacify -w +our @rl_term_set; *rl_term_set = \@Term::ReadLine::TermCap::rl_term_set; sub ReadLine {'Term::ReadLine::Stub'} sub readline { my $self = shift; my ($in,$out,$str) = @$self; - print $out $rl_term_set[0], shift, $rl_term_set[1], $rl_term_set[2]; + my $prompt = shift; + print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2]; $self->register_Tk if not $Term::ReadLine::registered and $Term::ReadLine::toloop and defined &Tk::DoOneEvent; #$str = scalar <$in>; $str = $self->get_line; + $str =~ s/^\s*\Q$prompt\E// if ($^O eq 'MacOS'); print $out $rl_term_set[3]; # bug in 5.000: chomping empty string creats length -1: chomp $str if defined $str; @@ -185,7 +190,9 @@ sub addhistory {} sub findConsole { my $console; - if (-e "/dev/tty") { + if ($^O eq 'MacOS') { + $console = "Dev:Console"; + } elsif (-e "/dev/tty") { $console = "/dev/tty"; } elsif (-e "con" or $^O eq 'MSWin32') { $console = "con"; @@ -204,7 +211,7 @@ sub findConsole { } } - $consoleOUT = $console; + my $consoleOUT = $console; $console = "&STDIN" unless defined $console; if (!defined $consoleOUT) { $consoleOUT = defined fileno(STDERR) ? "&STDERR" : "&STDOUT"; @@ -218,19 +225,19 @@ sub new { #local (*FIN, *FOUT); my ($FIN, $FOUT, $ret); if (@_==2) { - ($console, $consoleOUT) = findConsole; + my($console, $consoleOUT) = findConsole; open(FIN, "<$console"); open(FOUT,">$consoleOUT"); #OUT->autoflush(1); # Conflicts with debugger? - $sel = select(FOUT); + my $sel = select(FOUT); $| = 1; # for DB::OUT select($sel); $ret = bless [\*FIN, \*FOUT]; } else { # Filehandles supplied $FIN = $_[2]; $FOUT = $_[3]; #OUT->autoflush(1); # Conflicts with debugger? - $sel = select($FOUT); + my $sel = select($FOUT); $| = 1; # for DB::OUT select($sel); $ret = bless [$FIN, $FOUT]; @@ -262,6 +269,8 @@ sub Features { \%features } package Term::ReadLine; # So late to allow the above code be defined? +our $VERSION = '1.00'; + my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef; if ($which) { if ($which =~ /\bgnu\b/i){ @@ -281,7 +290,7 @@ if ($which) { # To make possible switch off RL in debugger: (Not needed, work done # in debugger). - +our @ISA; if (defined &Term::ReadLine::Gnu::readline) { @ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub); } elsif (defined &Term::ReadLine::Perl::readline) { @@ -294,10 +303,11 @@ package Term::ReadLine::TermCap; # Prompt-start, prompt-end, command-line-start, command-line-end # -- zero-width beautifies to emit around prompt and the command line. -@rl_term_set = ("","","",""); +our @rl_term_set = ("","","",""); # string encoded: -$rl_term_set = ',,,'; +our $rl_term_set = ',,,'; +our $terminal; sub LoadTermCap { return if defined $terminal; @@ -325,8 +335,10 @@ sub ornaments { package Term::ReadLine::Tk; +our($count_handle, $count_DoOne, $count_loop); $count_handle = $count_DoOne = $count_loop = 0; +our($giveup); sub handle {$giveup = 1; $count_handle++} sub Tk_loop { diff --git a/lib/Test.pm b/lib/Test.pm index c18d3812e5..60e9f7eee1 100644 --- a/lib/Test.pm +++ b/lib/Test.pm @@ -177,9 +177,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/lib/Test/Harness.pm b/lib/Test/Harness.pm index a17bdbfd72..f438af6233 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -1,17 +1,17 @@ +# -*- Mode: cperl; cperl-indent-level: 4 -*- package Test::Harness; use 5.005_64; use Exporter; use Benchmark; use Config; -use FileHandle; use strict; our($VERSION, $verbose, $switches, $have_devel_corestack, $curtest, $columns, @ISA, @EXPORT, @EXPORT_OK); $have_devel_corestack = 0; -$VERSION = "1.1604"; +$VERSION = "1.1607"; $ENV{HARNESS_ACTIVE} = 1; @@ -72,21 +72,20 @@ sub runtests { $ml = "\r$blank\r$leader" if -t STDOUT and not $ENV{HARNESS_NOTTY} and not $verbose; print $leader; - my $fh = new FileHandle; - $fh->open($test) or print "can't open $test. $!\n"; + open(my $fh, $test) or print "can't open $test. $!\n"; my $first = <$fh>; my $s = $switches; $s .= " $ENV{'HARNESS_PERL_SWITCHES'}" if exists $ENV{'HARNESS_PERL_SWITCHES'}; $s .= join " ", q[ "-T"], map {qq["-I$_"]} @INC if $first =~ /^#!.*\bperl.*-\w*T/; - $fh->close or print "can't close $test. $!\n"; + close($fh) or print "can't close $test. $!\n"; my $cmd = ($ENV{'HARNESS_COMPILE_TEST'}) ? "./perl -I../lib ../utils/perlcc $test " . "-run 2>> ./compilelog |" : "$^X $s $test|"; $cmd = "MCR $cmd" if $^O eq 'VMS'; - $fh->open($cmd) or print "can't run $test. $!\n"; + open($fh, $cmd) or print "can't run $test. $!\n"; $ok = $next = $max = 0; @failed = (); my %todo = (); @@ -120,7 +119,7 @@ sub runtests { $ok++; $totok++; } - } elsif (/^ok\s*(\d*)(\s*\#\s*[Ss]kip\S*(?:(?>\s+)(.+))?)?/) { + } elsif (/^ok\s*(\d*) *(\s*\#\s*[Ss]kip\S*(?:(?>\s+)(.+))?)?$/) { $this = $1 if $1 > 0; print "${ml}ok $this/$max" if $ml; $ok++; @@ -137,6 +136,15 @@ sub runtests { $skip_reason = $reason; } $bonus++, $totbonus++ if $todo{$this}; + } elsif (/^ok\s*(\d*)\s*\#([^\r]*)$/) { + $this = $1 if $1 > 0; + print "${ml}ok $this/$max" if $ml; + $ok++; + $totok++; + } else { + # an ok or not ok not matching the 3 cases above... + # just ignore it for compatibility with TEST + next; } if ($this > $next) { # print "Test output counter mismatch [test $this]\n"; @@ -148,9 +156,11 @@ sub runtests { $next = $this; } $next = $this + 1; - } + } elsif (/^Bail out!\s*(.*)/i) { # magic words + die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n"); + } } - $fh->close; # must close to reap child resource values + close($fh); # must close to reap child resource values my $wstatus = $ignore_exitcode ? 0 : $?; # Can trust $? ? my $estatus; $estatus = ($^O eq 'VMS' @@ -249,7 +259,7 @@ sub runtests { } } my $t_total = timediff(new Benchmark, $t_start); - + if ($^O eq 'VMS') { if (defined $old5lib) { $ENV{PERL5LIB} = $old5lib; @@ -452,7 +462,7 @@ script supplies test numbers again. So the following test script ok END -will generate +will generate FAILED tests 1, 3, 6 Failed 3/6 tests, 50.00% okay @@ -467,15 +477,26 @@ script(s). The default value is C<-w>. If the standard output line contains substring C< # Skip> (with variations in spacing and case) after C<ok> or C<ok NUMBER>, it is -counted as a skipped test. If the whole testscript succeeds, the -count of skipped tests is included in the generated output. +counted as a skipped test. In no other circumstance is anything +allowed to follow C<ok> or C<ok NUMBER>. If the whole testscript +succeeds, the count of skipped tests is included in the generated +output. -C<Test::Harness> reports the text after C< # Skip(whatever)> as a -reason for skipping. Similarly, one can include a similar explanation -in a C<1..0> line emitted if the test is skipped completely: +C<Test::Harness> reports the text after C< # Skip\S*\s+> as a reason +for skipping. Similarly, one can include a similar explanation in a +C<1..0> line emitted if the test is skipped completely: 1..0 # Skipped: no leverage found +As an emergency measure, a test script can decide that further tests +are useless (e.g. missing dependencies) and testing should stop +immediately. In that case the test script prints the magic words + + Bail out! + +to standard output. Any message after these words will be displayed by +C<Test::Harness> as the reason why testing is stopped. + =head1 EXPORT C<&runtests> is exported by Test::Harness per default. @@ -506,6 +527,11 @@ printed in a message similar to the above. If not all tests were successful, the script dies with one of the above messages. +=item C<FAILED--Further testing stopped%s> + +If a single subtest decides that further testing will not make sense, +the script dies with this message. + =back =head1 ENVIRONMENT diff --git a/lib/Text/Abbrev.pm b/lib/Text/Abbrev.pm index d4f12d0b99..08143fea8f 100644 --- a/lib/Text/Abbrev.pm +++ b/lib/Text/Abbrev.pm @@ -2,6 +2,8 @@ package Text::Abbrev; require 5.005; # Probably works on earlier versions too. require Exporter; +our $VERSION = '1.00'; + =head1 NAME abbrev - create an abbreviation table from a list diff --git a/lib/Text/ParseWords.pm b/lib/Text/ParseWords.pm index 2a6afc3be9..23eace9782 100644 --- a/lib/Text/ParseWords.pm +++ b/lib/Text/ParseWords.pm @@ -214,21 +214,27 @@ demonstrating: =over 4 =item 0 + a simple word =item 1 + multiple spaces are skipped because of our $delim =item 2 + use of quotes to include a space in a word =item 3 + use of a backslash to include a space in a word =item 4 + use of a backslash to remove the special meaning of a double-quote =item 5 + another simple word (note the lack of effect of the backslashed double-quote) diff --git a/lib/Tie/Array.pm b/lib/Tie/Array.pm index e3b85d412e..f4c6193596 100644 --- a/lib/Tie/Array.pm +++ b/lib/Tie/Array.pm @@ -34,47 +34,43 @@ sub POP $val; } -sub SPLICE -{ - my $obj = shift; - my $sz = $obj->FETCHSIZE; - my $off = (@_) ? shift : 0; - $off += $sz if ($off < 0); - my $len = (@_) ? shift : $sz - $off; - my @result; - for (my $i = 0; $i < $len; $i++) - { - push(@result,$obj->FETCH($off+$i)); - } - if (@_ > $len) - { - # Move items up to make room - my $d = @_ - $len; - my $e = $off+$len; - $obj->EXTEND($sz+$d); - for (my $i=$sz-1; $i >= $e; $i--) - { - my $val = $obj->FETCH($i); - $obj->STORE($i+$d,$val); +sub SPLICE { + my $obj = shift; + my $sz = $obj->FETCHSIZE; + my $off = (@_) ? shift : 0; + $off += $sz if ($off < 0); + my $len = (@_) ? shift : $sz - $off; + $len += $sz - $off if $len < 0; + my @result; + for (my $i = 0; $i < $len; $i++) { + push(@result,$obj->FETCH($off+$i)); } - } - elsif (@_ < $len) - { - # Move items down to close the gap - my $d = $len - @_; - my $e = $off+$len; - for (my $i=$off+$len; $i < $sz; $i++) - { - my $val = $obj->FETCH($i); - $obj->STORE($i-$d,$val); + $off = $sz if $off > $sz; + $len -= $off + $len - $sz if $off + $len > $sz; + if (@_ > $len) { + # Move items up to make room + my $d = @_ - $len; + my $e = $off+$len; + $obj->EXTEND($sz+$d); + for (my $i=$sz-1; $i >= $e; $i--) { + my $val = $obj->FETCH($i); + $obj->STORE($i+$d,$val); + } } - $obj->STORESIZE($sz-$d); - } - for (my $i=0; $i < @_; $i++) - { - $obj->STORE($off+$i,$_[$i]); - } - return @result; + elsif (@_ < $len) { + # Move items down to close the gap + my $d = $len - @_; + my $e = $off+$len; + for (my $i=$off+$len; $i < $sz; $i++) { + my $val = $obj->FETCH($i); + $obj->STORE($i-$d,$val); + } + $obj->STORESIZE($sz-$d); + } + for (my $i=0; $i < @_; $i++) { + $obj->STORE($off+$i,$_[$i]); + } + return @result; } sub EXISTS { diff --git a/lib/Tie/Hash.pm b/lib/Tie/Hash.pm index 2244711669..7399d8b853 100644 --- a/lib/Tie/Hash.pm +++ b/lib/Tie/Hash.pm @@ -1,5 +1,7 @@ package Tie::Hash; +our $VERSION = '1.00'; + =head1 NAME Tie::Hash, Tie::StdHash - base class definitions for tied hashes diff --git a/lib/Tie/RefHash.pm b/lib/Tie/RefHash.pm index ffa9eb20a0..8555635691 100644 --- a/lib/Tie/RefHash.pm +++ b/lib/Tie/RefHash.pm @@ -1,5 +1,7 @@ package Tie::RefHash; +our $VERSION = '1.21'; + =head1 NAME Tie::RefHash - use references as hash keys @@ -9,17 +11,26 @@ Tie::RefHash - use references as hash keys require 5.004; use Tie::RefHash; tie HASHVARIABLE, 'Tie::RefHash', LIST; + tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST; untie HASHVARIABLE; =head1 DESCRIPTION -This module provides the ability to use references as hash keys if -you first C<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::Hash. 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 +47,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 @@ -68,7 +84,17 @@ sub TIEHASH { sub FETCH { my($s, $k) = @_; - (ref $k) ? $s->[0]{"$k"}[1] : $s->[1]{$k}; + if (ref $k) { + if (defined $s->[0]{"$k"}) { + $s->[0]{"$k"}[1]; + } + else { + undef; + } + } + else { + $s->[1]{$k}; + } } sub STORE { @@ -121,4 +147,16 @@ sub CLEAR { %{$s->[1]} = (); } +package Tie::RefHash::Nestable; +use vars '@ISA'; @ISA = qw(Tie::RefHash); + +sub STORE { + my($s, $k, $v) = @_; + if (ref($v) eq 'HASH' and not tied %$v) { + my @elems = %$v; + tie %$v, ref($s), @elems; + } + $s->SUPER::STORE($k, $v); +} + 1; diff --git a/lib/Tie/Scalar.pm b/lib/Tie/Scalar.pm index 89ad03eddc..39480c8a28 100644 --- a/lib/Tie/Scalar.pm +++ b/lib/Tie/Scalar.pm @@ -1,5 +1,7 @@ package Tie::Scalar; +our $VERSION = '1.00'; + =head1 NAME Tie::Scalar, Tie::StdScalar - base class definitions for tied scalars diff --git a/lib/Tie/SubstrHash.pm b/lib/Tie/SubstrHash.pm index 4b18a58e12..afe5d8dc25 100644 --- a/lib/Tie/SubstrHash.pm +++ b/lib/Tie/SubstrHash.pm @@ -1,5 +1,7 @@ package Tie::SubstrHash; +our $VERSION = '1.00'; + =head1 NAME Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing @@ -33,6 +35,8 @@ Because the current implementation uses the table and key sizes for the hashing algorithm, there is no means by which to dynamically change the value of any of the initialization parameters. +The hash does not support exists(). + =cut use Carp; @@ -41,12 +45,20 @@ sub TIEHASH { my $pack = shift; my ($klen, $vlen, $tsize) = @_; my $rlen = 1 + $klen + $vlen; - $tsize = findprime($tsize * 1.1); # Allow 10% empty. + $tsize = [$tsize, + findgteprime($tsize * 1.1)]; # Allow 10% empty. $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1]; - $$self[0] x= $rlen * $tsize; + $$self[0] x= $rlen * $tsize->[1]; $self; } +sub CLEAR { + local($self) = @_; + $$self[0] = "\0" x ($$self[4] * $$self[3]->[1]); + $$self[5] = 0; + $$self[6] = -1; +} + sub FETCH { local($self,$key) = @_; local($klen, $vlen, $tsize, $rlen) = @$self[1..4]; @@ -69,8 +81,8 @@ sub FETCH { sub STORE { local($self,$key,$val) = @_; local($klen, $vlen, $tsize, $rlen) = @$self[1..4]; - croak("Table is full") if $$self[5] == $tsize; - croak(qq/Value "$val" is not $vlen characters long./) + croak("Table is full ($tsize->[0] elements)") if $$self[5] > $tsize->[0]; + croak(qq/Value "$val" is not $vlen characters long/) if length($val) != $vlen; my $writeoffset; @@ -129,7 +141,7 @@ sub FIRSTKEY { sub NEXTKEY { local($self) = @_; local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6]; - for (++$iterix; $iterix < $tsize; ++$iterix) { + for (++$iterix; $iterix < $tsize->[1]; ++$iterix) { next unless substr($$self[0], $iterix * $rlen, 1) eq "\2"; $$self[6] = $iterix; return substr($$self[0], $iterix * $rlen + 1, $klen); @@ -138,42 +150,57 @@ sub NEXTKEY { undef; } +sub EXISTS { + croak "Tie::SubstrHash does not support exists()"; +} + sub hashkey { - croak(qq/Key "$key" is not $klen characters long.\n/) + croak(qq/Key "$key" is not $klen characters long/) if length($key) != $klen; $hash = 2; for (unpack('C*', $key)) { $hash = $hash * 33 + $_; &_hashwrap if $hash >= 1e13; } - &_hashwrap if $hash >= $tsize; + &_hashwrap if $hash >= $tsize->[1]; $hash = 1 unless $hash; $hashbase = $hash; } sub _hashwrap { - $hash -= int($hash / $tsize) * $tsize; + $hash -= int($hash / $tsize->[1]) * $tsize->[1]; } sub rehash { $hash += $hashbase; - $hash -= $tsize if $hash >= $tsize; + $hash -= $tsize->[1] if $hash >= $tsize->[1]; } -sub findprime { +# using POSIX::ceil() would be too heavy, and not all platforms have it. +sub ceil { + my $num = shift; + $num = int($num + 1) unless $num == int $num; + return $num; +} + +sub findgteprime { # find the smallest prime integer greater than or equal to use integer; - my $num = shift; - $num++ unless $num % 2; +# It may be sufficient (and more efficient, IF IT IS CORRECT) to use +# $max = 1 + int sqrt $num and calculate it once only, but is it correct? + + my $num = ceil(shift); + return 2 if $num <= 2; - $max = int sqrt $num; + $num++ unless $num % 2; NUM: for (;; $num += 2) { - for ($i = 3; $i <= $max; $i += 2) { - next NUM unless $num % $i; - } - return $num; + my $max = int sqrt $num; + for ($i = 3; $i <= $max; $i += 2) { + next NUM unless $num % $i; + } + return $num; } } diff --git a/lib/Time/Local.pm b/lib/Time/Local.pm index a4808849b0..9c81209ad3 100644 --- a/lib/Time/Local.pm +++ b/lib/Time/Local.pm @@ -2,23 +2,25 @@ package Time::Local; require 5.000; require Exporter; use Carp; +use strict; -@ISA = qw( Exporter ); -@EXPORT = qw( timegm timelocal ); -@EXPORT_OK = qw( timegm_nocheck timelocal_nocheck ); +our $VERSION = '1.00'; +our @ISA = qw( Exporter ); +our @EXPORT = qw( timegm timelocal ); +our @EXPORT_OK = qw( timegm_nocheck timelocal_nocheck ); # Set up constants - $SEC = 1; - $MIN = 60 * $SEC; - $HR = 60 * $MIN; - $DAY = 24 * $HR; +our $SEC = 1; +our $MIN = 60 * $SEC; +our $HR = 60 * $MIN; +our $DAY = 24 * $HR; # Determine breakpoint for rolling century - my $thisYear = (localtime())[5]; - $nextCentury = int($thisYear / 100) * 100; - $breakpoint = ($thisYear + 50) % 100; - $nextCentury += 100 if $breakpoint < 50; + my $ThisYear = (localtime())[5]; + my $NextCentury = int($ThisYear / 100) * 100; + my $Breakpoint = ($ThisYear + 50) % 100; + $NextCentury += 100 if $Breakpoint < 50; -my %options; +our(%Options, %Cheat); sub timegm { my (@date) = @_; @@ -26,11 +28,11 @@ sub timegm { $date[5] -= 1900; } elsif ($date[5] >= 0 && $date[5] < 100) { - $date[5] -= 100 if $date[5] > $breakpoint; - $date[5] += $nextCentury; + $date[5] -= 100 if $date[5] > $Breakpoint; + $date[5] += $NextCentury; } - $ym = pack(C2, @date[5,4]); - $cheat = $cheat{$ym} || &cheat(@date); + my $ym = pack('C2', @date[5,4]); + my $cheat = $Cheat{$ym} || &cheat($ym, @date); $cheat + $date[0] * $SEC + $date[1] * $MIN @@ -39,7 +41,7 @@ sub timegm { } sub timegm_nocheck { - local $options{no_range_check} = 1; + local $Options{no_range_check} = 1; &timegm; } @@ -71,59 +73,61 @@ sub timelocal { $tzsec += $HR if($lt[8]); - $time = $t + $tzsec; - @test = localtime($time + ($tt - $t)); + my $time = $t + $tzsec; + my @test = localtime($time + ($tt - $t)); $time -= $HR if $test[2] != $_[2]; $time; } sub timelocal_nocheck { - local $options{no_range_check} = 1; + local $Options{no_range_check} = 1; &timelocal; } sub cheat { - $year = $_[5]; - $month = $_[4]; - unless ($options{no_range_check}) { + my($ym, @date) = @_; + my($sec, $min, $hour, $day, $month, $year) = @date; + unless ($Options{no_range_check}) { croak "Month '$month' out of range 0..11" if $month > 11 || $month < 0; - croak "Day '$_[3]' out of range 1..31" if $_[3] > 31 || $_[3] < 1; - croak "Hour '$_[2]' out of range 0..23" if $_[2] > 23 || $_[2] < 0; - croak "Minute '$_[1]' out of range 0..59" if $_[1] > 59 || $_[1] < 0; - croak "Second '$_[0]' out of range 0..59" if $_[0] > 59 || $_[0] < 0; + croak "Day '$day' out of range 1..31" if $day > 31 || $day < 1; + croak "Hour '$hour' out of range 0..23" if $hour > 23 || $hour < 0; + croak "Minute '$min' out of range 0..59" if $min > 59 || $min < 0; + croak "Second '$sec' out of range 0..59" if $sec > 59 || $sec < 0; } - $guess = $^T; - @g = gmtime($guess); - $lastguess = ""; - $counter = 0; - while ($diff = $year - $g[5]) { - croak "Can't handle date (".join(", ",@_).")" if ++$counter > 255; + my $guess = $^T; + my @g = gmtime($guess); + my $lastguess = ""; + my $counter = 0; + while (my $diff = $year - $g[5]) { + my $thisguess; + croak "Can't handle date (".join(", ",@date).")" if ++$counter > 255; $guess += $diff * (363 * $DAY); @g = gmtime($guess); if (($thisguess = "@g") eq $lastguess){ - croak "Can't handle date (".join(", ",@_).")"; + croak "Can't handle date (".join(", ",@date).")"; #date beyond this machine's integer limit } $lastguess = $thisguess; } - while ($diff = $month - $g[4]) { - croak "Can't handle date (".join(", ",@_).")" if ++$counter > 255; + while (my $diff = $month - $g[4]) { + my $thisguess; + croak "Can't handle date (".join(", ",@date).")" if ++$counter > 255; $guess += $diff * (27 * $DAY); @g = gmtime($guess); if (($thisguess = "@g") eq $lastguess){ - croak "Can't handle date (".join(", ",@_).")"; + croak "Can't handle date (".join(", ",@date).")"; #date beyond this machine's integer limit } $lastguess = $thisguess; } - @gfake = gmtime($guess-1); #still being sceptic + my @gfake = gmtime($guess-1); #still being sceptic if ("@gfake" eq $lastguess){ - croak "Can't handle date (".join(", ",@_).")"; + croak "Can't handle date (".join(", ",@date).")"; #date beyond this machine's integer limit } $g[3]--; $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAY; - $cheat{$ym} = $guess; + $Cheat{$ym} = $guess; } 1; diff --git a/lib/Time/tm.pm b/lib/Time/tm.pm index fd47ad19a9..2c308ebb41 100644 --- a/lib/Time/tm.pm +++ b/lib/Time/tm.pm @@ -1,6 +1,8 @@ package Time::tm; use strict; +our $VERSION = '1.00'; + use Class::Struct qw(struct); struct('Time::tm' => [ map { $_ => '$' } qw{ sec min hour mday mon year wday yday isdst } diff --git a/lib/UNIVERSAL.pm b/lib/UNIVERSAL.pm index f2f1fe9e7a..a66f8d5328 100644 --- a/lib/UNIVERSAL.pm +++ b/lib/UNIVERSAL.pm @@ -1,5 +1,7 @@ package UNIVERSAL; +our $VERSION = '1.00'; + # UNIVERSAL should not contain any extra subs/methods beyond those # that it exists to define. The use of Exporter below is a historical # accident that should be fixed sometime. diff --git a/lib/User/grent.pm b/lib/User/grent.pm index 95e4189c9e..fd6fe568cc 100644 --- a/lib/User/grent.pm +++ b/lib/User/grent.pm @@ -2,6 +2,7 @@ package User::grent; use strict; use 5.005_64; +our $VERSION = '1.00'; our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); diff --git a/lib/User/pwent.pm b/lib/User/pwent.pm index 8c059265c3..edd5f51dc7 100644 --- a/lib/User/pwent.pm +++ b/lib/User/pwent.pm @@ -1,6 +1,7 @@ package User::pwent; use 5.006; +our $VERSION = '1.00'; use strict; use warnings; diff --git a/lib/Win32.pod b/lib/Win32.pod index 64361f8286..842e484fc6 100644 --- a/lib/Win32.pod +++ b/lib/Win32.pod @@ -175,7 +175,9 @@ function. system boot. Resolution is limited to system timer ticks (about 10ms on WinNT and 55ms on Win9X). -=item Win32::InitiateSystemShutdown(MACHINE, MESSAGE, TIMEOUT, FORCECLOSE, REBOOT) +=item Win32::InitiateSystemShutdown + +(MACHINE, MESSAGE, TIMEOUT, FORCECLOSE, REBOOT) [EXT] Shutsdown the specified MACHINE, notifying users with the supplied MESSAGE, within the specified TIMEOUT interval. Forces diff --git a/lib/bytes.pm b/lib/bytes.pm index f2f7e0157c..3b0268e644 100644 --- a/lib/bytes.pm +++ b/lib/bytes.pm @@ -1,5 +1,7 @@ package bytes; +our $VERSION = '1.00'; + $bytes::hint_bits = 0x00000008; sub import { diff --git a/lib/charnames.pm b/lib/charnames.pm index 0ec7ec2d21..934fafddd5 100644 --- a/lib/charnames.pm +++ b/lib/charnames.pm @@ -1,4 +1,7 @@ package charnames; + +our $VERSION = '1.00'; + use bytes (); # for $bytes::hint_bits use warnings(); $charnames::hint_bits = 0x20000; diff --git a/lib/constant.pm b/lib/constant.pm index 72ad793653..1e07a686cc 100644 --- a/lib/constant.pm +++ b/lib/constant.pm @@ -28,75 +28,93 @@ my %forbidden = (%keywords, %forced_into_main); sub import { my $class = shift; return unless @_; # Ignore 'use constant;' - my $name = shift; - unless (defined $name) { - require Carp; - Carp::croak("Can't use undef as constant name"); + my %constants = (); + my $multiple = ref $_[0]; + + if ( $multiple ) { + if (ref $_[0] ne 'HASH') { + require Carp; + Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'"); + } + %constants = %{+shift}; + } else { + $constants{+shift} = undef; } - my $pkg = caller; - - # Normal constant name - if ($name =~ /^_?[^\W_0-9]\w*\z/ and !$forbidden{$name}) { - # Everything is okay - - # Name forced into main, but we're not in main. Fatal. - } elsif ($forced_into_main{$name} and $pkg ne 'main') { - require Carp; - Carp::croak("Constant name '$name' is forced into main::"); - - # Starts with double underscore. Fatal. - } elsif ($name =~ /^__/) { - require Carp; - Carp::croak("Constant name '$name' begins with '__'"); - - # Maybe the name is tolerable - } elsif ($name =~ /^[A-Za-z_]\w*\z/) { - # Then we'll warn only if you've asked for warnings - if (warnings::enabled()) { - if ($keywords{$name}) { - warnings::warn("Constant name '$name' is a Perl keyword"); - } elsif ($forced_into_main{$name}) { - warnings::warn("Constant name '$name' is " . - "forced into package main::"); + + foreach my $name ( keys %constants ) { + unless (defined $name) { + require Carp; + Carp::croak("Can't use undef as constant name"); + } + my $pkg = caller; + + # Normal constant name + if ($name =~ /^_?[^\W_0-9]\w*\z/ and !$forbidden{$name}) { + # Everything is okay + + # Name forced into main, but we're not in main. Fatal. + } elsif ($forced_into_main{$name} and $pkg ne 'main') { + require Carp; + Carp::croak("Constant name '$name' is forced into main::"); + + # Starts with double underscore. Fatal. + } elsif ($name =~ /^__/) { + require Carp; + Carp::croak("Constant name '$name' begins with '__'"); + + # Maybe the name is tolerable + } elsif ($name =~ /^[A-Za-z_]\w*\z/) { + # Then we'll warn only if you've asked for warnings + if (warnings::enabled()) { + if ($keywords{$name}) { + warnings::warn("Constant name '$name' is a Perl keyword"); + } elsif ($forced_into_main{$name}) { + warnings::warn("Constant name '$name' is " . + "forced into package main::"); + } else { + # Catch-all - what did I miss? If you get this error, + # please let me know what your constant's name was. + # Write to <rootbeer@redcat.com>. Thanks! + warnings::warn("Constant name '$name' has unknown problems"); + } + } + + # Looks like a boolean + # use constant FRED == fred; + } elsif ($name =~ /^[01]?\z/) { + require Carp; + if (@_) { + Carp::croak("Constant name '$name' is invalid"); } else { - # Catch-all - what did I miss? If you get this error, - # please let me know what your constant's name was. - # Write to <rootbeer@redcat.com>. Thanks! - warnings::warn("Constant name '$name' has unknown problems"); + Carp::croak("Constant name looks like boolean value"); } - } - # Looks like a boolean - # use constant FRED == fred; - } elsif ($name =~ /^[01]?\z/) { - require Carp; - if (@_) { - Carp::croak("Constant name '$name' is invalid"); } else { - Carp::croak("Constant name looks like boolean value"); + # Must have bad characters + require Carp; + Carp::croak("Constant name '$name' has invalid characters"); } - } else { - # Must have bad characters - require Carp; - Carp::croak("Constant name '$name' has invalid characters"); - } - - { - no strict 'refs'; - my $full_name = "${pkg}::$name"; - $declared{$full_name}++; - if (@_ == 1) { - my $scalar = $_[0]; - *$full_name = sub () { $scalar }; - } elsif (@_) { - my @list = @_; - *$full_name = sub () { @list }; - } else { - *$full_name = sub () { }; + { + no strict 'refs'; + my $full_name = "${pkg}::$name"; + $declared{$full_name}++; + if ($multiple) { + my $scalar = $constants{$name}; + *$full_name = sub () { $scalar }; + } else { + if (@_ == 1) { + my $scalar = $_[0]; + *$full_name = sub () { $scalar }; + } elsif (@_) { + my @list = @_; + *$full_name = sub () { @list }; + } else { + *$full_name = sub () { }; + } + } } } - } 1; @@ -133,6 +151,17 @@ constant - Perl pragma to declare constants print CCODE->("me"); print CHASH->[10]; # compile-time error + # declaring multiple constants at once + use constant { + BUFFER_SIZE => 4096, + ONE_YEAR => 365.2425 * 24 * 60 * 60, + PI => 4 * atan2( 1, 1 ), + DEBUGGING => 0, + ORACLE => 'oracle@cs.indiana.edu', + USERNAME => scalar getpwuid($<), + USERINFO => getpwuid($<), + }; + =head1 DESCRIPTION This will declare a symbol to be a constant with the given scalar @@ -176,14 +205,26 @@ Other as C<Other::CONST>. As with all C<use> directives, defining a constant happens at compile time. Thus, it's probably not correct to put a constant declaration inside of a conditional statement (like C<if ($foo) -{ use constant ... }>). +{ use constant ... }>). When defining multiple constants, you +cannot use the values of other constants within the same declaration +scope. This is because the calling package doesn't know about any +constant within that group until I<after> the C<use> statement is +finished. + + use constant { + AGE => 20, + PERSON => { age => AGE }, # Error! + }; + [...] + use constant PERSON => { age => AGE }; # Right Omitting the value for a symbol gives it the value of C<undef> in a scalar context or the empty list, C<()>, in a list context. This isn't so nice as it may sound, though, because in this case you must either quote the symbol name, or use a big arrow, (C<=E<gt>>), -with nothing to point to. It is probably best to declare these -explicitly. +with nothing to point to. It is also illegal to do when defining +multiple constants at once, you must declare them explicitly. It +is probably best to declare these explicitly. use constant UNICORNS => (); use constant LOGFILE => undef; @@ -206,6 +247,11 @@ Dereferencing constant references incorrectly (such as using an array subscript on a constant hash reference, or vice versa) will be trapped at compile time. +When declaring multiple constants, all constant values will be a scalar. +This is because C<constant> can't guess the intent of the programmer +correctly all the time since values must be expressed in scalar context +within a hash ref. + In the rare case in which you need to discover at run time whether a particular constant has been declared via this module, you may use this function to examine the hash C<%constant::declared>. If the given @@ -268,6 +314,9 @@ C<CONSTANT =E<gt> 'value'>. Tom Phoenix, E<lt>F<rootbeer@redcat.com>E<gt>, with help from many other folks. +Multiple constant declarations at once added by Casey Tweten, +E<lt>F<crt@kiski.net>E<gt>. + =head1 COPYRIGHT Copyright (C) 1997, 1999 Tom Phoenix diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index 884ea3ca65..f3e60f5897 100755 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -171,7 +171,7 @@ use strict; use 5.005_64; use Carp; -our $VERSION = v1.0; +our $VERSION = 1.0; our $DEBUG; our $VERBOSE; our $PRETTY; diff --git a/lib/filetest.pm b/lib/filetest.pm index b52a9b484d..21252f35a6 100644 --- a/lib/filetest.pm +++ b/lib/filetest.pm @@ -1,5 +1,7 @@ package filetest; +our $VERSION = '1.00'; + =head1 NAME filetest - Perl pragma to control the filetest permission operators diff --git a/lib/ftp.pl b/lib/ftp.pl index aa6a489665..3f0af1a8d7 100644 --- a/lib/ftp.pl +++ b/lib/ftp.pl @@ -74,7 +74,7 @@ # No longer call die expect on fatal errors. Just return fail codes. # Changed returns so higher up routines can tell whats happening. # Get expect/accept in correct order for dir listing. -# When ftp_show is set then print hashes every 1k transfered (like ftp). +# When ftp_show is set then print hashes every 1k transferred (like ftp). # Allow for stripping returns out of incoming data. # Save last error in a global string. # diff --git a/lib/integer.pm b/lib/integer.pm index 86afcaf130..f019fb3534 100644 --- a/lib/integer.pm +++ b/lib/integer.pm @@ -1,5 +1,7 @@ package integer; +our $VERSION = '1.00'; + =head1 NAME integer - Perl pragma to compute arithmetic in integer instead of double diff --git a/lib/less.pm b/lib/less.pm index b3afef0fcd..de0ac8f423 100644 --- a/lib/less.pm +++ b/lib/less.pm @@ -1,5 +1,7 @@ package less; +our $VERSION = '0.01'; + =head1 NAME less - perl pragma to request less of something from the compiler diff --git a/lib/lib_pm.PL b/lib/lib_pm.PL index bb02106058..66b4944de5 100644 --- a/lib/lib_pm.PL +++ b/lib/lib_pm.PL @@ -8,10 +8,30 @@ chdir dirname($0); my $file = basename($0, '.PL'); $file =~ s!_(pm)$!.$1!i; -my $Config_archname = defined($Config{'archname'}) ? $Config{'archname'} : ''; -my $Config_ver = defined($Config{'version'}) ? $Config{'version'} : ''; -my @Config_inc_version_list = defined($Config{'inc_version_list'}) ? - reverse split / /, $Config{'inc_version_list'} : (); +my $useConfig; +my $Config_archname; +my $Config_version; +my $Config_inc_version_list; + +# Expand the variables only if explicitly requested because +# otherwise relocating Perl becomes much harder. + +if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS}) { + $useConfig = ''; + $Config_archname = qq('$Config{archname}'); + $Config_version = qq('$Config{version}'); + my @Config_inc_version_list = + reverse split / /, $Config{inc_version_list}; + $Config_inc_version_list = + @Config_inc_version_list ? + qq(@Config_inc_version_list) : q(()); +} else { + $useConfig = 'use Config;'; + $Config_archname = q($Config{archname}); + $Config_version = q($Config{version}); + $Config_inc_version_list = + q(reverse split / /, qw($Config{inc_version_list})); +} open OUT,">$file" or die "Can't create $file: $!"; @@ -26,9 +46,11 @@ package lib; # THIS FILE IS AUTOMATICALLY GENERATED FROM lib_pm.PL. # ANY CHANGES TO THIS FILE WILL BE OVERWRITTEN BY THE NEXT PERL BUILD. -my \$archname = "$Config_archname"; -my \$ver = "$Config_ver"; -my \@inc_version_list = qw(@Config_inc_version_list); +$useConfig + +my \$archname = $Config_archname; +my \$version = $Config_version; +my \@inc_version_list = $Config_inc_version_list; !GROK!THIS! print OUT <<'!NO!SUBS!'; @@ -57,9 +79,9 @@ sub import { } # Put a corresponding archlib directory infront of $_ if it # looks like $_ has an archlib directory below it. - unshift(@INC, "$_/$archname") if -d "$_/$archname/auto"; - unshift(@INC, "$_/$ver") if -d "$_/$ver"; - unshift(@INC, "$_/$ver/$archname") if -d "$_/$ver/$archname"; + unshift(@INC, "$_/$archname") if -d "$_/$archname/auto"; + unshift(@INC, "$_/$version") if -d "$_/$version"; + unshift(@INC, "$_/$version/$archname") if -d "$_/$version/$archname"; } # remove trailing duplicates @@ -74,9 +96,9 @@ sub unimport { my %names; foreach (@_) { ++$names{$_}; - ++$names{"$_/$archname"} if -d "$_/$archname/auto"; - ++$names{"$_/$ver"} if -d "$_/$ver"; - ++$names{"$_/$ver/$archname"} if -d "$_/$ver/$archname"; + ++$names{"$_/$archname"} if -d "$_/$archname/auto"; + ++$names{"$_/$version"} if -d "$_/$version"; + ++$names{"$_/$version/$archname"} if -d "$_/$version/$archname"; } # Remove ALL instances of each named directory. diff --git a/lib/locale.pm b/lib/locale.pm index 6314aca59e..3e5054c99b 100644 --- a/lib/locale.pm +++ b/lib/locale.pm @@ -1,5 +1,7 @@ package locale; +our $VERSION = '1.00'; + =head1 NAME locale - Perl pragma to use and avoid POSIX locales for built-in operations diff --git a/lib/open.pm b/lib/open.pm index cdd20ac2c3..1e073c2e62 100644 --- a/lib/open.pm +++ b/lib/open.pm @@ -1,23 +1,45 @@ package open; +use Carp; $open::hint_bits = 0x20000; +use vars qw(%layers @layers); + +# Populate hash in non-PerlIO case +%layers = (crlf => 1, raw => 0) unless (@layers); + +our $VERSION = '1.00'; + sub import { shift; die "`use open' needs explicit list of disciplines" unless @_; $^H |= $open::hint_bits; + my ($in,$out) = split(/\0/,(${^OPEN} || '\0')); + my @in = split(/\s+/,$in); + my @out = split(/\s+/,$out); while (@_) { my $type = shift; - if ($type =~ /^(IN|OUT)\z/s) { - my $discp = shift; - unless ($discp =~ /^\s*:(raw|crlf)\s*\z/s) { - die "Unknown discipline '$discp'"; + my $discp = shift; + my @val; + foreach my $layer (split(/\s+:?/,$discp)) { + unless(exists $layers{$layer}) { + croak "Unknown discipline layer '$layer'"; } - $^H{"open_$type"} = $discp; + push(@val,":$layer"); + if ($layer =~ /^(crlf|raw)$/) { + $^H{"open_$type"} = $layer; + } + } + if ($type eq 'IN') { + $in = join(' ',@val); + } + elsif ($type eq 'OUT') { + $out = join(' ',@val); } else { - die "Unknown discipline class '$type'"; + croak "Unknown discipline class '$type'"; } } + ${^OPEN} = join('\0',$in,$out); } 1; diff --git a/lib/overload.pm b/lib/overload.pm index 2b0b99d3cd..69092a00cf 100644 --- a/lib/overload.pm +++ b/lib/overload.pm @@ -1,5 +1,7 @@ package overload; +our $VERSION = '1.00'; + $overload::hint_bits = 0x20000; sub nil {} diff --git a/lib/perl5db.pl b/lib/perl5db.pl index fb6d683f7d..63b4381339 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -25,7 +25,7 @@ $header = "perl5db.pl version $VERSION"; # if caller() is called from the package DB, it provides some # additional data. # -# The array @{$main::{'_<'.$filename} is the line-by-line contents of +# The array @{$main::{'_<'.$filename}} is the line-by-line contents of # $filename. # # The hash %{'_<'.$filename} contains breakpoints and action (it is @@ -401,6 +401,12 @@ if ($notty) { $console = "/dev/tty"; } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') { $console = "con"; + } elsif ($^O eq 'MacOS') { + if ($MacPerl::Version !~ /MPW/) { + $console = "Dev:Console:Perl Debug"; # Separate window for application + } else { + $console = "Dev:Console"; + } } else { $console = "sys\$command"; } diff --git a/lib/perlio.pm b/lib/perlio.pm new file mode 100644 index 0000000000..48acfbbf0b --- /dev/null +++ b/lib/perlio.pm @@ -0,0 +1,87 @@ +package perlio; +1; +__END__ + +=head1 NAME + +perlio - perl pragma to configure C level IO + +=head1 SYNOPSIS + + Shell: + PERLIO=perlio perl .... + + print "Have ",join(',',keys %perlio::layers),"\n"; + print "Using ",join(',',@perlio::layers),"\n"; + + +=head1 DESCRIPTION + +Mainly a Place holder for now. + +The C<%perlio::layers> hash is a record of the available "layers" that may be pushed +onto a C<PerlIO> stream. + +The C<@perlio::layers> array is the current set of layers that are used when +a new C<PerlIO> stream is opened. The C code looks are the array each time +a stream is opened so the "stack" can be manipulated by messing with the array : + + pop(@perlio::layers); + push(@perlio::layers,$perlio::layers{'stdio'}); + +The values if both the hash and the array are perl objects, of class C<perlio::Layer> +which are created by the C code in C<perlio.c>. As yet there is nothing useful you +can do with the objects at the perl level. + +There are three layers currently defined: + +=over 4 + +=item unix + +Low level layer which calls C<read>, C<write> and C<lseek> etc. + +=item stdio + +Layer which calls C<fread>, C<fwrite> and C<fseek>/C<ftell> etc. +Note that as this is "real" stdio it will ignore any layers beneath it and +got straight to the operating system via the C library as usual. + +=item perlio + +This is a re-implementation of "stdio-like" buffering written as a PerlIO "layer". +As such it will call whatever layer is below it for its operations. + +=back + +=head2 Defaults and how to override them + +If C<Configure> found out how to do "fast" IO using system's stdio, then +the default layers are : + + unix stdio + +Otherwise the default layers are + + unix perlio + +(STDERR will have just unix in this case as that is optimal way to make it +"unbuffered" - do not add a buffering layer!) + +The default may change once perlio has been better tested and tuned. + +The default can be overridden by setting the environment variable PERLIO +to a space separated list of layers (unix is always pushed first). +This can be used to see the effect of/bugs in the various layers e.g. + + cd .../perl/t + PERLIO=stdio ./perl harness + PERLIO=perlio ./perl harness + +=head1 AUTHOR + +Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt> + +=cut + + diff --git a/lib/strict.pm b/lib/strict.pm index 042227f967..8afb9a3792 100644 --- a/lib/strict.pm +++ b/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/lib/subs.pm b/lib/subs.pm index aa332a6785..e5a9aa8827 100644 --- a/lib/subs.pm +++ b/lib/subs.pm @@ -1,5 +1,7 @@ package subs; +our $VERSION = '1.00'; + =head1 NAME subs - Perl pragma to predeclare sub names diff --git a/lib/unicode/Is/Alnum.pl b/lib/unicode/Is/Alnum.pl index 94f9a5c621..a0aac62938 100644 --- a/lib/unicode/Is/Alnum.pl +++ b/lib/unicode/Is/Alnum.pl @@ -6,13 +6,23 @@ return <<'END'; 0041 005a 0061 007a 00aa +00b2 00b3 00b5 -00ba +00b9 00ba +00bc 00be 00c0 00d6 00d8 00f6 00f8 021f 0222 0233 0250 02ad +02b0 02b8 +02bb 02c1 +02d0 02d1 +02e0 02e4 +02ee +0300 034e +0360 0362 +037a 0386 0388 038a 038c @@ -21,38 +31,57 @@ return <<'END'; 03d0 03d7 03da 03f3 0400 0481 +0483 0486 +0488 0489 048c 04c4 04c7 04c8 04cb 04cc 04d0 04f5 04f8 04f9 0531 0556 +0559 0561 0587 +0591 05a1 +05a3 05b9 +05bb 05bd +05bf +05c1 05c2 +05c4 05d0 05ea 05f0 05f2 0621 063a -0641 064a +0640 0655 0660 0669 -0671 06d3 -06d5 +0670 06d3 +06d5 06e8 +06ea 06ed 06f0 06fc -0710 -0712 072c -0780 07a5 +0710 072c +0730 074a +0780 07b0 +0901 0903 0905 0939 -093d -0950 -0958 0961 +093c 094d +0950 0954 +0958 0963 0966 096f +0981 0983 0985 098c 098f 0990 0993 09a8 09aa 09b0 09b2 09b6 09b9 +09bc +09be 09c4 +09c7 09c8 +09cb 09cd +09d7 09dc 09dd -09df 09e1 +09df 09e3 09e6 09f1 +09f4 09f9 +0a02 0a05 0a0a 0a0f 0a10 0a13 0a28 @@ -60,10 +89,14 @@ return <<'END'; 0a32 0a33 0a35 0a36 0a38 0a39 +0a3c +0a3e 0a42 +0a47 0a48 +0a4b 0a4d 0a59 0a5c 0a5e -0a66 0a6f -0a72 0a74 +0a66 0a74 +0a81 0a83 0a85 0a8b 0a8d 0a8f 0a91 @@ -71,20 +104,27 @@ return <<'END'; 0aaa 0ab0 0ab2 0ab3 0ab5 0ab9 -0abd +0abc 0ac5 +0ac7 0ac9 +0acb 0acd 0ad0 0ae0 0ae6 0aef +0b01 0b03 0b05 0b0c 0b0f 0b10 0b13 0b28 0b2a 0b30 0b32 0b33 0b36 0b39 -0b3d +0b3c 0b43 +0b47 0b48 +0b4b 0b4d +0b56 0b57 0b5c 0b5d 0b5f 0b61 0b66 0b6f +0b82 0b83 0b85 0b8a 0b8e 0b90 0b92 0b95 @@ -95,36 +135,60 @@ return <<'END'; 0ba8 0baa 0bae 0bb5 0bb7 0bb9 -0be7 0bef +0bbe 0bc2 +0bc6 0bc8 +0bca 0bcd +0bd7 +0be7 0bf2 +0c01 0c03 0c05 0c0c 0c0e 0c10 0c12 0c28 0c2a 0c33 0c35 0c39 +0c3e 0c44 +0c46 0c48 +0c4a 0c4d +0c55 0c56 0c60 0c61 0c66 0c6f +0c82 0c83 0c85 0c8c 0c8e 0c90 0c92 0ca8 0caa 0cb3 0cb5 0cb9 +0cbe 0cc4 +0cc6 0cc8 +0cca 0ccd +0cd5 0cd6 0cde 0ce0 0ce1 0ce6 0cef +0d02 0d03 0d05 0d0c 0d0e 0d10 0d12 0d28 0d2a 0d39 +0d3e 0d43 +0d46 0d48 +0d4a 0d4d +0d57 0d60 0d61 0d66 0d6f +0d82 0d83 0d85 0d96 0d9a 0db1 0db3 0dbb 0dbd 0dc0 0dc6 -0e01 0e30 -0e32 0e33 -0e40 0e45 +0dca +0dcf 0dd4 +0dd6 +0dd8 0ddf +0df2 0df3 +0e01 0e3a +0e40 0e4e 0e50 0e59 0e81 0e82 0e84 @@ -137,22 +201,33 @@ return <<'END'; 0ea5 0ea7 0eaa 0eab -0ead 0eb0 -0eb2 0eb3 -0ebd +0ead 0eb9 +0ebb 0ebd 0ec0 0ec4 +0ec6 +0ec8 0ecd 0ed0 0ed9 0edc 0edd 0f00 -0f20 0f29 -0f40 0f47 +0f18 0f19 +0f20 0f33 +0f35 +0f37 +0f39 +0f3e 0f47 0f49 0f6a -0f88 0f8b +0f71 0f84 +0f86 0f8b +0f90 0f97 +0f99 0fbc +0fc6 1000 1021 1023 1027 1029 102a +102c 1032 +1036 1039 1040 1049 -1050 1055 +1050 1059 10a0 10c5 10d0 10f6 1100 1159 @@ -183,18 +258,18 @@ return <<'END'; 1318 131e 1320 1346 1348 135a -1369 1371 +1369 137c 13a0 13f4 1401 166c 166f 1676 1681 169a 16a0 16ea -1780 17b3 +16ee 16f0 +1780 17d3 17e0 17e9 1810 1819 -1820 1842 -1844 1877 -1880 18a8 +1820 1877 +1880 18a9 1e00 1e9b 1ea0 1ef9 1f00 1f15 @@ -216,7 +291,10 @@ return <<'END'; 1fe0 1fec 1ff2 1ff4 1ff6 1ffc -207f +2070 +2074 2079 +207f 2089 +20d0 20e3 2102 2107 210a 2113 @@ -228,12 +306,25 @@ return <<'END'; 212a 212d 212f 2131 2133 2139 -3006 +2153 2183 +2460 249b +24ea +2776 2793 +3005 3007 +3021 302f +3031 3035 +3038 303a 3041 3094 +3099 309a +309d 309e 30a1 30fa +30fc 30fe 3105 312c 3131 318e +3192 3195 31a0 31b7 +3220 3229 +3280 3289 3400 4db5 4e00 9fa5 a000 a48c @@ -241,8 +332,7 @@ ac00 d7a3 f900 fa2d fb00 fb06 fb13 fb17 -fb1d -fb1f fb28 +fb1d fb28 fb2a fb36 fb38 fb3c fb3e @@ -253,15 +343,14 @@ fbd3 fd3d fd50 fd8f fd92 fdc7 fdf0 fdfb +fe20 fe23 fe70 fe72 fe74 fe76 fefc ff10 ff19 ff21 ff3a ff41 ff5a -ff66 ff6f -ff71 ff9d -ffa0 ffbe +ff66 ffbe ffc2 ffc7 ffca ffcf ffd2 ffd7 diff --git a/lib/unicode/Is/Alpha.pl b/lib/unicode/Is/Alpha.pl index de5046f9d4..13dc003c96 100644 --- a/lib/unicode/Is/Alpha.pl +++ b/lib/unicode/Is/Alpha.pl @@ -12,6 +12,14 @@ return <<'END'; 00f8 021f 0222 0233 0250 02ad +02b0 02b8 +02bb 02c1 +02d0 02d1 +02e0 02e4 +02ee +0300 034e +0360 0362 +037a 0386 0388 038a 038c @@ -20,36 +28,54 @@ return <<'END'; 03d0 03d7 03da 03f3 0400 0481 +0483 0486 +0488 0489 048c 04c4 04c7 04c8 04cb 04cc 04d0 04f5 04f8 04f9 0531 0556 +0559 0561 0587 +0591 05a1 +05a3 05b9 +05bb 05bd +05bf +05c1 05c2 +05c4 05d0 05ea 05f0 05f2 0621 063a -0641 064a -0671 06d3 -06d5 +0640 0655 +0670 06d3 +06d5 06e8 +06ea 06ed 06fa 06fc -0710 -0712 072c -0780 07a5 +0710 072c +0730 074a +0780 07b0 +0901 0903 0905 0939 -093d -0950 -0958 0961 +093c 094d +0950 0954 +0958 0963 +0981 0983 0985 098c 098f 0990 0993 09a8 09aa 09b0 09b2 09b6 09b9 +09bc +09be 09c4 +09c7 09c8 +09cb 09cd +09d7 09dc 09dd -09df 09e1 +09df 09e3 09f0 09f1 +0a02 0a05 0a0a 0a0f 0a10 0a13 0a28 @@ -57,9 +83,14 @@ return <<'END'; 0a32 0a33 0a35 0a36 0a38 0a39 +0a3c +0a3e 0a42 +0a47 0a48 +0a4b 0a4d 0a59 0a5c 0a5e -0a72 0a74 +0a70 0a74 +0a81 0a83 0a85 0a8b 0a8d 0a8f 0a91 @@ -67,18 +98,25 @@ return <<'END'; 0aaa 0ab0 0ab2 0ab3 0ab5 0ab9 -0abd +0abc 0ac5 +0ac7 0ac9 +0acb 0acd 0ad0 0ae0 +0b01 0b03 0b05 0b0c 0b0f 0b10 0b13 0b28 0b2a 0b30 0b32 0b33 0b36 0b39 -0b3d +0b3c 0b43 +0b47 0b48 +0b4b 0b4d +0b56 0b57 0b5c 0b5d 0b5f 0b61 +0b82 0b83 0b85 0b8a 0b8e 0b90 0b92 0b95 @@ -89,32 +127,56 @@ return <<'END'; 0ba8 0baa 0bae 0bb5 0bb7 0bb9 +0bbe 0bc2 +0bc6 0bc8 +0bca 0bcd +0bd7 +0c01 0c03 0c05 0c0c 0c0e 0c10 0c12 0c28 0c2a 0c33 0c35 0c39 +0c3e 0c44 +0c46 0c48 +0c4a 0c4d +0c55 0c56 0c60 0c61 +0c82 0c83 0c85 0c8c 0c8e 0c90 0c92 0ca8 0caa 0cb3 0cb5 0cb9 +0cbe 0cc4 +0cc6 0cc8 +0cca 0ccd +0cd5 0cd6 0cde 0ce0 0ce1 +0d02 0d03 0d05 0d0c 0d0e 0d10 0d12 0d28 0d2a 0d39 +0d3e 0d43 +0d46 0d48 +0d4a 0d4d +0d57 0d60 0d61 +0d82 0d83 0d85 0d96 0d9a 0db1 0db3 0dbb 0dbd 0dc0 0dc6 -0e01 0e30 -0e32 0e33 -0e40 0e45 +0dca +0dcf 0dd4 +0dd6 +0dd8 0ddf +0df2 0df3 +0e01 0e3a +0e40 0e4e 0e81 0e82 0e84 0e87 0e88 @@ -126,19 +188,30 @@ return <<'END'; 0ea5 0ea7 0eaa 0eab -0ead 0eb0 -0eb2 0eb3 -0ebd +0ead 0eb9 +0ebb 0ebd 0ec0 0ec4 +0ec6 +0ec8 0ecd 0edc 0edd 0f00 -0f40 0f47 +0f18 0f19 +0f35 +0f37 +0f39 +0f3e 0f47 0f49 0f6a -0f88 0f8b +0f71 0f84 +0f86 0f8b +0f90 0f97 +0f99 0fbc +0fc6 1000 1021 1023 1027 1029 102a -1050 1055 +102c 1032 +1036 1039 +1050 1059 10a0 10c5 10d0 10f6 1100 1159 @@ -174,10 +247,9 @@ return <<'END'; 166f 1676 1681 169a 16a0 16ea -1780 17b3 -1820 1842 -1844 1877 -1880 18a8 +1780 17d3 +1820 1877 +1880 18a9 1e00 1e9b 1ea0 1ef9 1f00 1f15 @@ -200,6 +272,7 @@ return <<'END'; 1ff2 1ff4 1ff6 1ffc 207f +20d0 20e3 2102 2107 210a 2113 @@ -211,9 +284,14 @@ return <<'END'; 212a 212d 212f 2131 2133 2139 -3006 +3005 3006 +302a 302f +3031 3035 3041 3094 +3099 309a +309d 309e 30a1 30fa +30fc 30fe 3105 312c 3131 318e 31a0 31b7 @@ -224,8 +302,7 @@ ac00 d7a3 f900 fa2d fb00 fb06 fb13 fb17 -fb1d -fb1f fb28 +fb1d fb28 fb2a fb36 fb38 fb3c fb3e @@ -236,14 +313,13 @@ fbd3 fd3d fd50 fd8f fd92 fdc7 fdf0 fdfb +fe20 fe23 fe70 fe72 fe74 fe76 fefc ff21 ff3a ff41 ff5a -ff66 ff6f -ff71 ff9d -ffa0 ffbe +ff66 ffbe ffc2 ffc7 ffca ffcf ffd2 ffd7 diff --git a/lib/unicode/Is/Blank.pl b/lib/unicode/Is/Blank.pl new file mode 100644 index 0000000000..86429218e3 --- /dev/null +++ b/lib/unicode/Is/Blank.pl @@ -0,0 +1,12 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.301. +# Any changes made here will be lost! +return <<'END'; +0009 +0020 +00a0 +1680 +2000 200b +202f +3000 +END diff --git a/lib/unicode/Is/DCmedial.pl b/lib/unicode/Is/DCmedial.pl new file mode 100644 index 0000000000..8778a75ed5 --- /dev/null +++ b/lib/unicode/Is/DCmedial.pl @@ -0,0 +1,59 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.301. +# Any changes made here will be lost! +return <<'END'; +fb55 +fb59 +fb5d +fb61 +fb65 +fb69 +fb6d +fb71 +fb75 +fb79 +fb7d +fb81 +fb91 +fb95 +fb99 +fb9d +fba3 +fba9 +fbad +fbd6 +fbe7 +fbe9 +fbff +fcdf fcf4 +fd34 fd3b +fe71 +fe77 +fe79 +fe7b +fe7d +fe7f +fe8c +fe92 +fe98 +fe9c +fea0 +fea4 +fea8 +feb4 +feb8 +febc +fec0 +fec4 +fec8 +fecc +fed0 +fed4 +fed8 +fedc +fee0 +fee4 +fee8 +feec +fef4 +END diff --git a/lib/unicode/Is/Graph.pl b/lib/unicode/Is/Graph.pl index 40d35067f6..238cc56229 100644 --- a/lib/unicode/Is/Graph.pl +++ b/lib/unicode/Is/Graph.pl @@ -3,7 +3,7 @@ # Any changes made here will be lost! return <<'END'; 0021 007e -00a0 021f +00a1 021f 0222 0233 0250 02ad 02b0 02ee @@ -239,7 +239,7 @@ return <<'END'; 1361 137c 13a0 13f4 1401 1676 -1680 169c +1681 169c 16a0 16f0 1780 17dc 17e0 17e9 @@ -265,10 +265,8 @@ return <<'END'; 1fdd 1fef 1ff2 1ff4 1ff6 1ffe -2000 2008 -200b -2010 2029 -202f 2046 +2010 2027 +2030 2046 2048 204d 2070 2074 208e @@ -304,7 +302,7 @@ return <<'END'; 2e9b 2ef3 2f00 2fd5 2ff0 2ffb -3000 303a +3001 303a 303e 303f 3041 3094 3099 309e @@ -330,6 +328,7 @@ a4b5 a4c0 a4c2 a4c4 a4c6 ac00 d7a3 +e000 f8ff f900 fa2d fb00 fb06 fb13 fb17 @@ -360,4 +359,6 @@ ffda ffdc ffe0 ffe6 ffe8 ffee fffc fffd +f0000 ffffd +100000 10fffd END diff --git a/lib/unicode/Is/Print.pl b/lib/unicode/Is/Print.pl index c3adba6c5c..1229a282b2 100644 --- a/lib/unicode/Is/Print.pl +++ b/lib/unicode/Is/Print.pl @@ -266,7 +266,7 @@ return <<'END'; 1ff2 1ff4 1ff6 1ffe 2000 200b -2010 2029 +2010 2027 202f 2046 2048 204d 2070 @@ -329,6 +329,7 @@ a4b5 a4c0 a4c2 a4c4 a4c6 ac00 d7a3 +e000 f8ff f900 fa2d fb00 fb06 fb13 fb17 @@ -359,4 +360,6 @@ ffda ffdc ffe0 ffe6 ffe8 ffee fffc fffd +f0000 ffffd +100000 10fffd END diff --git a/lib/unicode/Is/Punct.pl b/lib/unicode/Is/Punct.pl index 9e088bab85..97330ecd48 100644 --- a/lib/unicode/Is/Punct.pl +++ b/lib/unicode/Is/Punct.pl @@ -8,45 +8,45 @@ return <<'END'; 003a 003b 003f 0040 005b 005d -005f -007b -007d -00a1 -00ab -00ad -00b7 -00bb -00bf -037e -0387 +005f +007b +007d +00a1 +00ab +00ad +00b7 +00bb +00bf +037e +0387 055a 055f 0589 058a -05be -05c0 -05c3 +05be +05c0 +05c3 05f3 05f4 -060c -061b -061f +060c +061b +061f 066a 066d -06d4 +06d4 0700 070d 0964 0965 -0970 -0df4 -0e4f +0970 +0df4 +0e4f 0e5a 0e5b 0f04 0f12 0f3a 0f3d -0f85 +0f85 104a 104f -10fb +10fb 1361 1368 166d 166e 169b 169c 16eb 16ed 17d4 17da -17dc +17dc 1800 180a 2010 2027 2030 2043 @@ -58,14 +58,14 @@ return <<'END'; 3001 3003 3008 3011 3014 301f -3030 -30fb +3030 +30fb fd3e fd3f fe30 fe44 fe49 fe52 fe54 fe61 -fe63 -fe68 +fe63 +fe68 fe6a fe6b ff01 ff03 ff05 ff0a @@ -73,8 +73,8 @@ ff0c ff0f ff1a ff1b ff1f ff20 ff3b ff3d -ff3f -ff5b -ff5d +ff3f +ff5b +ff5d ff61 ff65 END diff --git a/lib/unicode/Is/Space.pl b/lib/unicode/Is/Space.pl index 1625dce03b..9971082fbe 100644 --- a/lib/unicode/Is/Space.pl +++ b/lib/unicode/Is/Space.pl @@ -3,12 +3,11 @@ # Any changes made here will be lost! return <<'END'; 0009 000d -0020 -0085 -00a0 -1680 +0020 +00a0 +1680 2000 200b 2028 2029 -202f -3000 +202f +3000 END diff --git a/lib/unicode/Is/SpacePerl.pl b/lib/unicode/Is/SpacePerl.pl new file mode 100644 index 0000000000..2bb74dea8a --- /dev/null +++ b/lib/unicode/Is/SpacePerl.pl @@ -0,0 +1,14 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables.PL from e.g. Unicode.301. +# Any changes made here will be lost! +return <<'END'; +0009 000a +000c 000d +0020 +00a0 +1680 +2000 200b +2028 2029 +202f +3000 +END diff --git a/lib/unicode/Is/Word.pl b/lib/unicode/Is/Word.pl index 1c76c60b78..6ea32e6099 100644 --- a/lib/unicode/Is/Word.pl +++ b/lib/unicode/Is/Word.pl @@ -7,13 +7,23 @@ return <<'END'; 005f 0061 007a 00aa +00b2 00b3 00b5 -00ba +00b9 00ba +00bc 00be 00c0 00d6 00d8 00f6 00f8 021f 0222 0233 0250 02ad +02b0 02b8 +02bb 02c1 +02d0 02d1 +02e0 02e4 +02ee +0300 034e +0360 0362 +037a 0386 0388 038a 038c @@ -22,38 +32,57 @@ return <<'END'; 03d0 03d7 03da 03f3 0400 0481 +0483 0486 +0488 0489 048c 04c4 04c7 04c8 04cb 04cc 04d0 04f5 04f8 04f9 0531 0556 +0559 0561 0587 +0591 05a1 +05a3 05b9 +05bb 05bd +05bf +05c1 05c2 +05c4 05d0 05ea 05f0 05f2 0621 063a -0641 064a +0640 0655 0660 0669 -0671 06d3 -06d5 +0670 06d3 +06d5 06e8 +06ea 06ed 06f0 06fc -0710 -0712 072c -0780 07a5 +0710 072c +0730 074a +0780 07b0 +0901 0903 0905 0939 -093d -0950 -0958 0961 +093c 094d +0950 0954 +0958 0963 0966 096f +0981 0983 0985 098c 098f 0990 0993 09a8 09aa 09b0 09b2 09b6 09b9 +09bc +09be 09c4 +09c7 09c8 +09cb 09cd +09d7 09dc 09dd -09df 09e1 +09df 09e3 09e6 09f1 +09f4 09f9 +0a02 0a05 0a0a 0a0f 0a10 0a13 0a28 @@ -61,10 +90,14 @@ return <<'END'; 0a32 0a33 0a35 0a36 0a38 0a39 +0a3c +0a3e 0a42 +0a47 0a48 +0a4b 0a4d 0a59 0a5c 0a5e -0a66 0a6f -0a72 0a74 +0a66 0a74 +0a81 0a83 0a85 0a8b 0a8d 0a8f 0a91 @@ -72,20 +105,27 @@ return <<'END'; 0aaa 0ab0 0ab2 0ab3 0ab5 0ab9 -0abd +0abc 0ac5 +0ac7 0ac9 +0acb 0acd 0ad0 0ae0 0ae6 0aef +0b01 0b03 0b05 0b0c 0b0f 0b10 0b13 0b28 0b2a 0b30 0b32 0b33 0b36 0b39 -0b3d +0b3c 0b43 +0b47 0b48 +0b4b 0b4d +0b56 0b57 0b5c 0b5d 0b5f 0b61 0b66 0b6f +0b82 0b83 0b85 0b8a 0b8e 0b90 0b92 0b95 @@ -96,36 +136,60 @@ return <<'END'; 0ba8 0baa 0bae 0bb5 0bb7 0bb9 -0be7 0bef +0bbe 0bc2 +0bc6 0bc8 +0bca 0bcd +0bd7 +0be7 0bf2 +0c01 0c03 0c05 0c0c 0c0e 0c10 0c12 0c28 0c2a 0c33 0c35 0c39 +0c3e 0c44 +0c46 0c48 +0c4a 0c4d +0c55 0c56 0c60 0c61 0c66 0c6f +0c82 0c83 0c85 0c8c 0c8e 0c90 0c92 0ca8 0caa 0cb3 0cb5 0cb9 +0cbe 0cc4 +0cc6 0cc8 +0cca 0ccd +0cd5 0cd6 0cde 0ce0 0ce1 0ce6 0cef +0d02 0d03 0d05 0d0c 0d0e 0d10 0d12 0d28 0d2a 0d39 +0d3e 0d43 +0d46 0d48 +0d4a 0d4d +0d57 0d60 0d61 0d66 0d6f +0d82 0d83 0d85 0d96 0d9a 0db1 0db3 0dbb 0dbd 0dc0 0dc6 -0e01 0e30 -0e32 0e33 -0e40 0e45 +0dca +0dcf 0dd4 +0dd6 +0dd8 0ddf +0df2 0df3 +0e01 0e3a +0e40 0e4e 0e50 0e59 0e81 0e82 0e84 @@ -138,22 +202,33 @@ return <<'END'; 0ea5 0ea7 0eaa 0eab -0ead 0eb0 -0eb2 0eb3 -0ebd +0ead 0eb9 +0ebb 0ebd 0ec0 0ec4 +0ec6 +0ec8 0ecd 0ed0 0ed9 0edc 0edd 0f00 -0f20 0f29 -0f40 0f47 +0f18 0f19 +0f20 0f33 +0f35 +0f37 +0f39 +0f3e 0f47 0f49 0f6a -0f88 0f8b +0f71 0f84 +0f86 0f8b +0f90 0f97 +0f99 0fbc +0fc6 1000 1021 1023 1027 1029 102a +102c 1032 +1036 1039 1040 1049 -1050 1055 +1050 1059 10a0 10c5 10d0 10f6 1100 1159 @@ -184,18 +259,18 @@ return <<'END'; 1318 131e 1320 1346 1348 135a -1369 1371 +1369 137c 13a0 13f4 1401 166c 166f 1676 1681 169a 16a0 16ea -1780 17b3 +16ee 16f0 +1780 17d3 17e0 17e9 1810 1819 -1820 1842 -1844 1877 -1880 18a8 +1820 1877 +1880 18a9 1e00 1e9b 1ea0 1ef9 1f00 1f15 @@ -217,7 +292,10 @@ return <<'END'; 1fe0 1fec 1ff2 1ff4 1ff6 1ffc -207f +2070 +2074 2079 +207f 2089 +20d0 20e3 2102 2107 210a 2113 @@ -229,12 +307,25 @@ return <<'END'; 212a 212d 212f 2131 2133 2139 -3006 +2153 2183 +2460 249b +24ea +2776 2793 +3005 3007 +3021 302f +3031 3035 +3038 303a 3041 3094 +3099 309a +309d 309e 30a1 30fa +30fc 30fe 3105 312c 3131 318e +3192 3195 31a0 31b7 +3220 3229 +3280 3289 3400 4db5 4e00 9fa5 a000 a48c @@ -242,8 +333,7 @@ ac00 d7a3 f900 fa2d fb00 fb06 fb13 fb17 -fb1d -fb1f fb28 +fb1d fb28 fb2a fb36 fb38 fb3c fb3e @@ -254,15 +344,14 @@ fbd3 fd3d fd50 fd8f fd92 fdc7 fdf0 fdfb +fe20 fe23 fe70 fe72 fe74 fe76 fefc ff10 ff19 ff21 ff3a ff41 ff5a -ff66 ff6f -ff71 ff9d -ffa0 ffbe +ff66 ffbe ffc2 ffc7 ffca ffcf ffd2 ffd7 diff --git a/lib/unicode/distinct.pm b/lib/unicode/distinct.pm new file mode 100644 index 0000000000..6471ac8d84 --- /dev/null +++ b/lib/unicode/distinct.pm @@ -0,0 +1,35 @@ +package unicode:distinct; + +our $VERSION = '0.01'; + +$unicode::distinct::hint_bits = 0x01000000; + +sub import { + $^H |= $unicode::distinct::hint_bits; +} + +sub unimport { + $^H &= ~$unicode::distinct::hint_bits; +} + +1; +__END__ + +=head1 NAME + +unicode::distinct - Perl pragma to strictly distinguish UTF8 data and non-UTF data. + +=head1 SYNOPSIS + + use unicode::distinct; + no unicode::distinct; + +=head1 DESCRIPTION + + *NOT YET* + +=head1 SEE ALSO + +L<perlunicode>, L<utf8> + +=cut diff --git a/lib/unicode/mktables.PL b/lib/unicode/mktables.PL index 37b6e84874..82b35ef97d 100755 --- a/lib/unicode/mktables.PL +++ b/lib/unicode/mktables.PL @@ -16,18 +16,31 @@ mkdir "To", 0755; @todo = ( # typical - ['IsWord', '$cat =~ /^L[ulot]|^Nd/ or $code eq "005F"', ''], - ['IsAlnum', '$cat =~ /^L[ulot]|^Nd/', ''], - ['IsAlpha', '$cat =~ /^L[ulot]/', ''], - ['IsSpace', 'White space', $PropData], + # 005F: SPACING UNDERSCROE + ['IsWord', '$cat =~ /^[LMN]/ or $code eq "005F"', ''], + ['IsAlnum', '$cat =~ /^[LMN]/', ''], + ['IsAlpha', '$cat =~ /^[LM]/', ''], + # 0009: HORIZONTAL TABULATION + # 000A: LINE FEED + # 000B: VERTICAL TABULATION + # 000C: FORM FEED + # 000D: CARRIAGE RETURN + # 0020: SPACE + ['IsSpace', '$cat =~ /^Z/ || + $code =~ /^(0009|000A|000B|000C|000D)$/', ''], + ['IsSpacePerl', + '$cat =~ /^Z/ || + $code =~ /^(0009|000A|000C|000D)$/', ''], + ['IsBlank', '$cat =~ /^Z[^lp]$/ || $code eq "0009"', ''], ['IsDigit', '$cat =~ /^Nd$/', ''], ['IsUpper', '$cat =~ /^L[ut]$/', ''], ['IsLower', '$cat =~ /^Ll$/', ''], - ['IsASCII', 'hex $code <= 127', ''], + ['IsASCII', '$code le "007f"', ''], ['IsCntrl', '$cat =~ /^C/', ''], - ['IsGraph', '$cat =~ /^[^C]/ and ($cat !~ /^Z/ and $code ne "0020" or chr(hex $code) !~ /^\s/)', ''], - ['IsPrint', '$cat =~ /^[^C]/', ''], - ['IsPunct', 'Punctuation', $PropData], + ['IsGraph', '$cat =~ /^([LMNPS]|Co)/', ''], + ['IsPrint', '$cat =~ /^([LMNPS]|Co|Zs)/', ''], + ['IsPunct', '$cat =~ /^P/', ''], + # 003[0-9]: DIGIT ZERO..NINE, 00[46][1-6]: A..F, a..f ['IsXDigit', '$code =~ /^00(3[0-9]|[46][1-6])$/', ''], ['ToUpper', '$up', '$up'], ['ToLower', '$down', '$down'], @@ -145,7 +158,7 @@ mkdir "To", 0755; ['IsDCfont', '$decomp =~ /^<font>/', ''], ['IsDCnoBreak', '$decomp =~ /^<noBreak>/', ''], ['IsDCinitial', '$decomp =~ /^<initial>/', ''], - ['IsDCinital', '$decomp =~ /^<medial>/', ''], + ['IsDCmedial', '$decomp =~ /^<medial>/', ''], ['IsDCfinal', '$decomp =~ /^<final>/', ''], ['IsDCisolated', '$decomp =~ /^<isolated>/', ''], ['IsDCcircle', '$decomp =~ /^<circle>/', ''], diff --git a/lib/unicode/syllables.txt b/lib/unicode/syllables.txt index 40e946e6d8..bc8bc23681 100644 --- a/lib/unicode/syllables.txt +++ b/lib/unicode/syllables.txt @@ -1,1329 +1,1329 @@ -################################################################################
-#
-# V: as "u" in "but" (often represented with schwa or small uppercase lambda)
-# U: as "oo" in "fool"
-# I: as "ea" in "meat"
-# A: as "a" in "father"
-# E: as "a" in "hate"
-# C: the consonant form having no vowel element
-# O: as "o" in "note"
-#
-# Vowel identifiers are assumed short, doubled identifiers are considered long
-# (following Cushitic rules). Dipthong syllables are identified with "W" as
-# per Ethiopic and Canadian syllabary character names.
-#
-#
-# WV WVV WU WUU WI WII WA WAA WAI WAAI WE WEE WC WO WOO
-#
-# V VV U UU I II A AA AI AAI E EE C O OO
-#
-################################################################################
-
-#
-# Ethiopic
-#
-1200; HA; V
-1201; HU; U
-1202; HI; I
-1203; HAA; A
-1204; HEE; E
-1205; HE; C
-1206; HO; O
-1208; LA; V
-1209; LU; U
-120A; LI; I
-120B; LAA; A
-120C; LEE; E
-120D; LE; C
-120E; LO; O
-120F; LWA; WA
-1210; HHA; V
-1211; HHU; U
-1212; HHI; I
-1213; HHAA; A
-1214; HHEE; E
-1215; HHE; C
-1216; HHO; O
-1217; HHWA; WA
-1218; MA; V
-1219; MU; U
-121A; MI; I
-121B; MAA; A
-121C; MEE; E
-121D; ME; C
-121E; MO; O
-121F; MWA; WA
-1220; SZA; V
-1221; SZU; U
-1222; SZI; I
-1223; SZAA; A
-1224; SZEE; E
-1225; SZE; C
-1226; SZO; O
-1227; SZWA; WA
-1228; RA; V
-1229; RU; U
-122A; RI; I
-122B; RAA; A
-122C; REE; E
-122D; RE; C
-122E; RO; O
-122F; RWA; WA
-1230; SA; V
-1231; SU; U
-1232; SI; I
-1233; SAA; A
-1234; SEE; E
-1235; SE; C
-1236; SO; O
-1237; SWA; WA
-1238; SHA; V
-1239; SHU; U
-123A; SHI; I
-123B; SHAA; A
-123C; SHEE; E
-123D; SHE; C
-123E; SHO; O
-123F; SHWA; WA
-1240; QA; V
-1241; QU; U
-1242; QI; I
-1243; QAA; A
-1244; QEE; E
-1245; QE; C
-1246; QO; O
-1248; QWA; WV
-124A; QWI; WI
-124B; QWAA; WA
-124C; QWEE; WE
-124D; QWE; WC
-1250; QHA; V
-1251; QHU; U
-1252; QHI; I
-1253; QHAA; A
-1254; QHEE; E
-1255; QHE; C
-1256; QHO; O
-1258; QHWA; WV
-125A; QHWI; WI
-125B; QHWAA; WA
-125C; QHWEE; WE
-125D; QHWE; WC
-1260; BA; V
-1261; BU; U
-1262; BI; I
-1263; BAA; A
-1264; BEE; E
-1265; BE; C
-1266; BO; O
-1267; BWA; WA
-1268; VA; V
-1269; VU; U
-126A; VI; I
-126B; VAA; A
-126C; VEE; E
-126D; VE; C
-126E; VO; O
-126F; VWA; WA
-1270; TA; V
-1271; TU; U
-1272; TI; I
-1273; TAA; A
-1274; TEE; E
-1275; TE; C
-1276; TO; O
-1277; TWA; WA
-1278; CA; V
-1279; CU; U
-127A; CI; I
-127B; CAA; A
-127C; CEE; E
-127D; CE; C
-127E; CO; O
-127F; CWA; WA
-1280; XA; V
-1281; XU; U
-1282; XI; I
-1283; XAA; A
-1284; XEE; E
-1285; XE; C
-1286; XO; O
-1288; XWA; WV
-128A; XWI; WI
-128B; XWAA; WA
-128C; XWEE; WE
-128D; XWE; WC
-1290; NA; V
-1291; NU; U
-1292; NI; I
-1293; NAA; A
-1294; NEE; E
-1295; NE; C
-1296; NO; O
-1297; NWA; WA
-1298; NYA; V
-1299; NYU; U
-129A; NYI; I
-129B; NYAA; A
-129C; NYEE; E
-129D; NYE; C
-129E; NYO; O
-129F; NYWA; WA
-12A0; GLOTTAL A; V
-12A1; GLOTTAL U; U
-12A2; GLOTTAL I; I
-12A3; GLOTTAL AA; A
-12A4; GLOTTAL EE; E
-12A5; GLOTTAL E; C
-12A6; GLOTTAL O; O
-12A7; GLOTTAL WA; WA
-12A8; KA; V
-12A9; KU; U
-12AA; KI; I
-12AB; KAA; A
-12AC; KEE; E
-12AD; KE; C
-12AE; KO; O
-12B0; KWA; WV
-12B2; KWI; WI
-12B3; KWAA; WA
-12B4; KWEE; WE
-12B5; KWE; WC
-12B8; KXA; V
-12B9; KXU; U
-12BA; KXI; I
-12BB; KXAA; A
-12BC; KXEE; E
-12BD; KXE; C
-12BE; KXO; O
-12C0; KXWA; WV
-12C2; KXWI; WI
-12C3; KXWAA; WA
-12C4; KXWEE; WE
-12C5; KXWE; WC
-12C8; WA; V
-12C9; WU; U
-12CA; WI; I
-12CB; WAA; A
-12CC; WEE; E
-12CD; WE; C
-12CE; WO; O
-12D0; PHARYNGEAL A; V
-12D1; PHARYNGEAL U; U
-12D2; PHARYNGEAL I; I
-12D3; PHARYNGEAL AA; A
-12D4; PHARYNGEAL EE; E
-12D5; PHARYNGEAL E; C
-12D6; PHARYNGEAL O; O
-12D8; ZA; V
-12D9; ZU; U
-12DA; ZI; I
-12DB; ZAA; A
-12DC; ZEE; E
-12DD; ZE; C
-12DE; ZO; O
-12DF; ZWA; WA
-12E0; ZHA; V
-12E1; ZHU; U
-12E2; ZHI; I
-12E3; ZHAA; A
-12E4; ZHEE; E
-12E5; ZHE; C
-12E6; ZHO; O
-12E7; ZHWA; WA
-12E8; YA; V
-12E9; YU; U
-12EA; YI; I
-12EB; YAA; A
-12EC; YEE; E
-12ED; YE; C
-12EE; YO; O
-12F0; DA; V
-12F1; DU; U
-12F2; DI; I
-12F3; DAA; A
-12F4; DEE; E
-12F5; DE; C
-12F6; DO; O
-12F7; DWA; WA
-12F8; DDA; V
-12F9; DDU; U
-12FA; DDI; I
-12FB; DDAA; A
-12FC; DDEE; E
-12FD; DDE; C
-12FE; DDO; O
-12FF; DDWA; WA
-1300; JA; V
-1301; JU; U
-1302; JI; I
-1303; JAA; A
-1304; JEE; E
-1305; JE; C
-1306; JO; O
-1307; JWA; WA
-1308; GA; V
-1309; GU; U
-130A; GI; I
-130B; GAA; A
-130C; GEE; E
-130D; GE; C
-130E; GO; O
-1310; GWA; WV
-1312; GWI; WI
-1313; GWAA; WA
-1314; GWEE; WE
-1315; GWE; WC
-1318; GGA; V
-1319; GGU; U
-131A; GGI; I
-131B; GGAA; A
-131C; GGEE; E
-131D; GGE; C
-131E; GGO; O
-1320; THA; V
-1321; THU; U
-1322; THI; I
-1323; THAA; A
-1324; THEE; E
-1325; THE; C
-1326; THO; O
-1327; THWA; WA
-1328; CHA; V
-1329; CHU; U
-132A; CHI; I
-132B; CHAA; A
-132C; CHEE; E
-132D; CHE; C
-132E; CHO; O
-132F; CHWA; WA
-1330; PHA; V
-1331; PHU; U
-1332; PHI; I
-1333; PHAA; A
-1334; PHEE; E
-1335; PHE; C
-1336; PHO; O
-1337; PHWA; WA
-1338; TSA; V
-1339; TSU; U
-133A; TSI; I
-133B; TSAA; A
-133C; TSEE; E
-133D; TSE; C
-133E; TSO; O
-133F; TSWA; WA
-1340; TZA; V
-1341; TZU; U
-1342; TZI; I
-1343; TZAA; A
-1344; TZEE; E
-1345; TZE; C
-1346; TZO; O
-1348; FA; V
-1349; FU; U
-134A; FI; I
-134B; FAA; A
-134C; FEE; E
-134D; FE; C
-134E; FO; O
-134F; FWA; WA
-1350; PA; V
-1351; PU; U
-1352; PI; I
-1353; PAA; A
-1354; PEE; E
-1355; PE; C
-1356; PO; O
-1357; PWA; WA
-#
-# Cherokee
-#
-13A0; A; A
-13A1; E; E
-13A2; I; I
-13A3; O; O
-13A4; U; U
-13A5; V; V
-13A6; GA; A
-13A7; KA; A
-13A8; GE; E
-13A9; GI; I
-13AA; GO; O
-13AB; GU; U
-13AC; GV; V
-13AD; HA; A
-13AE; HE; E
-13AF; HI; I
-13B0; HO; O
-13B1; HU; U
-13B2; HV; V
-13B3; LA; A
-13B4; LE; E
-13B5; LI; I
-13B6; LO; O
-13B7; LU; U
-13B8; LV; V
-13B9; MA; A
-13BA; ME; E
-13BB; MI; I
-13BC; MO; O
-13BD; MU; U
-13BE; NA; A
-13BF; HNA; A
-13C0; NAH; C
-13C1; NE; E
-13C2; NI; I
-13C3; NO; O
-13C4; NU; U
-13C5; NV; V
-13C6; QUA; A
-13C7; QUE; E
-13C8; QUI; I
-13C9; QUO; O
-13CA; QUU; U
-13CB; QUV; V
-13CC; SA; A
-13CD; S; C
-13CE; SE; E
-13CF; SI; I
-13D0; SO; O
-13D1; SU; U
-13D2; SV; V
-13D3; DA; A
-13D4; TA; A
-13D5; DE; E
-13D6; TE; E
-13D7; DI; I
-13D8; TI; I
-13D9; DO; O
-13DA; DU; U
-13DB; DV; V
-13DC; DLA; A
-13DD; TLA; A
-13DE; TLE; E
-13DF; TLI; I
-13E0; TLO; O
-13E1; TLU; U
-13E2; TLV; V
-13E3; TSA; A
-13E4; TSE; E
-13E5; TSI; I
-13E6; TSO; O
-13E7; TSU; U
-13E8; TSV; V
-13E9; WA; A
-13EA; WE; E
-13EB; WI; I
-13EC; WO; O
-13ED; WU; U
-13EE; WV; V
-13EF; YA; A
-13F0; YE; E
-13F1; YI; I
-13F2; YO; O
-13F3; YU; U
-13F4; YV; V
-#
-# 1400 Unified Canadian Aboriginal Syllabics 167F
-#
-1401; E; E
-1402; AAI; AAI
-1403; I; I
-1404; II; II
-1405; O; O
-1406; OO; OO
-1407; Y-CREE OO; OO
-1408; CARRIER EE; EE
-1409; CARRIER I; I
-140A; A; A
-140B; AA; AA
-140C; WE; WE
-140D; WEST-CREE WE; WE
-140E; WI; WI
-140F; WEST-CREE WI; WI
-1410; WII; WII
-1411; WEST-CREE WII; WII
-1412; WO; WO
-1413; WEST-CREE WO; WO
-1414; WOO; WOO
-1415; WEST-CREE WOO; WOO
-1416; NASKAPI WOO; WOO
-1417; WA; WA
-1418; WEST-CREE WA; WA
-1419; WAA; WAA
-141A; WEST-CREE WAA; WAA
-141B; NASKAPI WAA; WAA
-141C; AI; AI
-141D; Y-CREE W; C
-142B; EN; C
-142C; IN; C
-142D; ON; C
-142E; AN; C
-142F; PE; E
-1430; PAAI; AAI
-1431; PI; I
-1432; PII; II
-1433; PO; O
-1434; POO; OO
-1435; Y-CREE POO; OO
-1436; CARRIER HEE; EE
-1437; CARRIER HI; I
-1438; PA; A
-1439; PAA; AA
-143A; PWE; WE
-143B; WEST-CREE PWE; WE
-143C; PWI; WI
-143D; WEST-CREE PWI; WI
-143E; PWII; WII
-143F; WEST-CREE PWII; WII
-1440; PWO; WO
-1441; WEST-CREE PWO; WO
-1442; PWOO; WOO
-1443; WEST-CREE PWOO; WOO
-1444; PWA; WA
-1445; WEST-CREE PWA; WA
-1446; PWAA; WAA
-1447; WEST-CREE PWAA; WAA
-1448; Y-CREE PWAA; WAA
-1449; P; C
-144A; WEST-CREE P; C
-144B; CARRIER H; C
-144C; TE; E
-144D; TAAI; AAI
-144E; TI; I
-144F; TII; II
-1450; TO; O
-1451; TOO; OO
-1452; Y-CREE TOO; OO
-1453; CARRIER DEE; EE
-1454; CARRIER DI; I
-1455; TA; A
-1456; TAA; AA
-1457; TWE; WE
-1458; WEST-CREE TWE; WE
-1459; TWI; WI
-145A; WEST-CREE TWI; WI
-145B; TWII; WII
-145C; WEST-CREE TWII; WII
-145D; TWO; WO
-145E; WEST-CREE TWO; WO
-145F; TWOO; WOO
-1460; WEST-CREE TWOO; WOO
-1461; TWA; WA
-1462; WEST-CREE TWA; WA
-1463; TWAA; WAA
-1464; WEST-CREE TWAA; WAA
-1465; NASKAPI TWAA; WAA
-1466; T; C
-1467; TTE; E
-1468; TTI; I
-1469; TTO; O
-146A; TTA; A
-146B; KE; E
-146C; KAAI; AAI
-146D; KI; I
-146E; KII; II
-146F; KO; O
-1470; KOO; OO
-1471; Y-CREE KOO; OO
-1472; KA; A
-1473; KAA; AA
-1474; KWE; WE
-1475; WEST-CREE KWE; WE
-1476; KWI; WI
-1477; WEST-CREE KWI; WI
-1478; KWII; WII
-1479; WEST-CREE KWII; WII
-147A; KWO; WO
-147B; WEST-CREE KWO; WO
-147C; KWOO; WOO
-147D; WEST-CREE KWOO; WOO
-147E; KWA; WA
-147F; WEST-CREE KWA; WA
-1480; KWAA; WAA
-1481; WEST-CREE KWAA; WAA
-1482; NASKAPI KWAA; WAA
-1483; K; C
-1484; KW; WC
-1485; SOUTH-SLAVEY KEH; C
-1486; SOUTH-SLAVEY KIH; C
-1487; SOUTH-SLAVEY KOH; C
-1488; SOUTH-SLAVEY KAH; C
-1489; CE; E
-148A; CAAI; AAI
-148B; CI; I
-148C; CII; II
-148D; CO; O
-148E; COO; OO
-148F; Y-CREE COO; OO
-1490; CA; A
-1491; CAA; AA
-1492; CWE; WE
-1493; WEST-CREE CWE; WE
-1494; CWI; WI
-1495; WEST-CREE CWI; WI
-1496; CWII; WII
-1497; WEST-CREE CWII; WII
-1498; CWO; WO
-1499; WEST-CREE CWO; WO
-149A; CWOO; WOO
-149B; WEST-CREE CWOO; WOO
-149C; CWA; WA
-149D; WEST-CREE CWA; WA
-149E; CWAA; WAA
-149F; WEST-CREE CWAA; WAA
-14A0; NASKAPI CWAA; WAA
-14A1; C; C
-14A2; SAYISI TH;
-14A3; ME; E
-14A4; MAAI; AAI
-14A5; MI; I
-14A6; MII; II
-14A7; MO; O
-14A8; MOO; OO
-14A9; Y-CREE MOO; OO
-14AA; MA; A
-14AB; MAA; AA
-14AC; MWE; WE
-14AD; WEST-CREE MWE; WE
-14AE; MWI; WI
-14AF; WEST-CREE MWI; WI
-14B0; MWII; WII
-14B1; WEST-CREE MWII; WII
-14B2; MWO; WO
-14B3; WEST-CREE MWO; WO
-14B4; MWOO; WOO
-14B5; WEST-CREE MWOO; WOO
-14B6; MWA; WA
-14B7; WEST-CREE MWA; WA
-14B8; MWAA; WAA
-14B9; WEST-CREE MWAA; WAA
-14BA; NASKAPI MWAA; WAA
-14BB; M; C
-14BC; WEST-CREE M; C
-14BD; MH; C
-14BE; ATHAPASCAN M; C
-14BF; SAYISI M; C
-14C0; NE; E
-14C1; NAAI; AAI
-14C2; NI; I
-14C3; NII; II
-14C4; NO; O
-14C5; NOO; OO
-14C6; Y-CREE NOO; OO
-14C7; NA; A
-14C8; NAA; AA
-14C9; NWE; WE
-14CA; WEST-CREE NWE; WE
-14CB; NWA; WA
-14CC; WEST-CREE NWA; WA
-14CD; NWAA; WAA
-14CE; WEST-CREE NWAA; WAA
-14CF; NASKAPI NWAA; WAA
-14D0; N; C
-14D1; CARRIER NG; C
-14D2; NH; C
-14D3; LE; E
-14D4; LAAI; AAI
-14D5; LI; I
-14D6; LII; II
-14D7; LO; O
-14D8; LOO; OO
-14D9; Y-CREE LOO; OO
-14DA; LA; A
-14DB; LAA; AA
-14DC; LWE; WE
-14DD; WEST-CREE LWE; WE
-14DE; LWI; WI
-14DF; WEST-CREE LWI; WI
-14E0; LWII; WII
-14E1; WEST-CREE LWII; WII
-14E2; LWO; WO
-14E3; WEST-CREE LWO; WO
-14E4; LWOO; WOO
-14E5; WEST-CREE LWOO; WOO
-14E6; LWA; WA
-14E7; WEST-CREE LWA; WA
-14E8; LWAA; WAA
-14E9; WEST-CREE LWAA; WAA
-14EA; L; C
-14EB; WEST-CREE L; C
-14EC; MEDIAL L; C
-14ED; SE; E
-14EE; SAAI; AAI
-14EF; SI; I
-14F0; SII; II
-14F1; SO; O
-14F2; SOO; OO
-14F3; Y-CREE SOO; OO
-14F4; SA; A
-14F5; SAA; AA
-14F6; SWE; WE
-14F7; WEST-CREE SWE; WE
-14F8; SWI; WI
-14F9; WEST-CREE SWI; WI
-14FA; SWII; WII
-14FB; WEST-CREE SWII; WII
-14FC; SWO; WO
-14FD; WEST-CREE SWO; WO
-14FE; SWOO; WOO
-14FF; WEST-CREE SWOO; WOO
-1500; SWA; WA
-1501; WEST-CREE SWA; WA
-1502; SWAA; WAA
-1503; WEST-CREE SWAA; WAA
-1504; NASKAPI SWAA; WAA
-1505; S; C
-1506; ATHAPASCAN S; C
-1507; SW; WC
-1508; BLACKFOOT S; C
-1509; MOOSE-CREE SK;C
-150A; NASKAPI SKW; C
-150B; NASKAPI S-W; C
-150C; NASKAPI SPWA; WA
-150D; NASKAPI STWA; WA
-150E; NASKAPI SKWA; WA
-150F; NASKAPI SCWA; WA
-1510; SHE; E
-1511; SHI; I
-1512; SHII; II
-1513; SHO; O
-1514; SHOO; OO
-1515; SHA; A
-1516; SHAA; AA
-1517; SHWE; WE
-1518; WEST-CREE SHWE; WE
-1519; SHWI; WI
-151A; WEST-CREE SHWI; WI
-151B; SHWII; WII
-151C; WEST-CREE SHWII; WII
-151D; SHWO; WO
-151E; WEST-CREE SHWO; WO
-151F; SHWOO; WOO
-1520; WEST-CREE SHWOO; WOO
-1521; SHWA; WA
-1522; WEST-CREE SHWA; WA
-1523; SHWAA; WAA
-1524; WEST-CREE SHWAA; WAA
-1525; SH; C
-1526; YE; E
-1527; YAAI; AAI
-1528; YI; I
-1529; YII; II
-152A; YO; O
-152B; YOO; OO
-152C; Y-CREE YOO; OO
-152D; YA; A
-152E; YAA; AA
-152F; YWE; WE
-1530; WEST-CREE YWE; WE
-1531; YWI; WI
-1532; WEST-CREE YWI; WI
-1533; YWII; WII
-1534; WEST-CREE YWII; WII
-1535; YWO; WO
-1536; WEST-CREE YWO; WO
-1537; YWOO; WOO
-1538; WEST-CREE YWOO; WOO
-1539; YWA; WA
-153A; WEST-CREE YWA; WA
-153B; YWAA; WAA
-153C; WEST-CREE YWAA; WAA
-153D; NASKAPI YWAA; WAA
-153E; Y; C
-153F; BIBLE-CREE Y; C
-1540; WEST-CREE Y; C
-1541; SAYISI YI; I
-1542; RE; E
-1543; R-CREE RE; E
-1544; WEST-CREE LE; E
-1545; RAAI; AAI
-1546; RI; I
-1547; RII; II
-1548; RO; O
-1549; ROO; OO
-154A; WEST-CREE LO; O
-154B; RA; A
-154C; RAA; AA
-154D; WEST-CREE LA; A
-154E; RWAA; WAA
-154F; WEST-CREE RWAA; WAA
-1550; R; C
-1551; WEST-CREE R; C
-1552; MEDIAL R; C
-1553; FE; E
-1554; FAAI; AAI
-1555; FI; I
-1556; FII; II
-1557; FO; O
-1558; FOO; OO
-1559; FA; A
-155A; FAA; AA
-155B; FWAA; WAA
-155C; WEST-CREE FWAA; WAA
-155D; F; C
-155E; THE; E
-155F; N-CREE THE; E
-1560; THI; I
-1561; N-CREE THI; I
-1562; THII; II
-1563; N-CREE THII; II
-1564; THO; O
-1565; THOO; OO
-1566; THA; A
-1567; THAA; AA
-1568; THWAA; WAA
-1569; WEST-CREE THWAA; WAA
-156A; TH; C
-156B; TTHE; E
-156C; TTHI; I
-156D; TTHO; O
-156E; TTHA; A
-156F; TTH; C
-1570; TYE; E
-1571; TYI; I
-1572; TYO; O
-1573; TYA; A
-1574; NUNAVIK HE; E
-1575; NUNAVIK HI; I
-1576; NUNAVIK HII; II
-1577; NUNAVIK HO; O
-1578; NUNAVIK HOO; OO
-1579; NUNAVIK HA; A
-157A; NUNAVIK HAA; AA
-157B; NUNAVIK H; C
-157C; NUNAVUT H; C
-157D; HK; C
-157E; QAAI; AAI
-157F; QI; I
-1580; QII; II
-1581; QO; O
-1582; QOO; OO
-1583; QA; A
-1584; QAA; AA
-1585; Q; C
-1586; TLHE; E
-1587; TLHI; I
-1588; TLHO; O
-1589; TLHA; A
-158A; WEST-CREE RE; E
-158B; WEST-CREE RI; I
-158C; WEST-CREE RO; O
-158D; WEST-CREE RA; A
-158E; NGAAI; AAI
-158F; NGI; I
-1590; NGII; II
-1591; NGO; O
-1592; NGOO; OO
-1593; NGA; A
-1594; NGAA; AA
-1595; NG; C
-1596; NNG; C
-1597; SAYISI SHE; E
-1598; SAYISI SHI; I
-1599; SAYISI SHO; O
-159A; SAYISI SHA; A
-159B; WOODS-CREE THE; E
-159C; WOODS-CREE THI; I
-159D; WOODS-CREE THO; O
-159E; WOODS-CREE THA; A
-159F; WOODS-CREE TH; C
-15A0; LHI; I
-15A1; LHII; II
-15A2; LHO; O
-15A3; LHOO; OO
-15A4; LHA; A
-15A5; LHAA; AA
-15A6; LH; C
-15A7; TH-CREE THE; E
-15A8; TH-CREE THI; I
-15A9; TH-CREE THII; II
-15AA; TH-CREE THO; O
-15AB; TH-CREE THOO; OO
-15AC; TH-CREE THA; A
-15AD; TH-CREE THAA; AA
-15AE; TH-CREE TH; C
-15AF; AIVILIK B; C
-15B0; BLACKFOOT E; E
-15B1; BLACKFOOT I; I
-15B2; BLACKFOOT O; O
-15B3; BLACKFOOT A; A
-15B4; BLACKFOOT WE; E
-15B5; BLACKFOOT WI; I
-15B6; BLACKFOOT WO; O
-15B7; BLACKFOOT WA; A
-15B8; BLACKFOOT NE; E
-15B9; BLACKFOOT NI; I
-15BA; BLACKFOOT NO; O
-15BB; BLACKFOOT NA; A
-15BC; BLACKFOOT KE; E
-15BD; BLACKFOOT KI; I
-15BE; BLACKFOOT KO; O
-15BF; BLACKFOOT KA; A
-15C0; SAYISI HE; E
-15C1; SAYISI HI; I
-15C2; SAYISI HO; O
-15C3; SAYISI HA; A
-15C4; CARRIER GHU; U
-15C5; CARRIER GHO; O
-15C6; CARRIER GHE; E
-15C7; CARRIER GHEE; EE
-15C8; CARRIER GHI; I
-15C9; CARRIER GHA; A
-15CA; CARRIER RU; U
-15CB; CARRIER RO; O
-15CC; CARRIER RE; E
-15CD; CARRIER REE; EE
-15CE; CARRIER RI; I
-15CF; CARRIER RA; A
-15D0; CARRIER WU; U
-15D1; CARRIER WO; O
-15D2; CARRIER WE; E
-15D3; CARRIER WEE; EE
-15D4; CARRIER WI; I
-15D5; CARRIER WA; A
-15D6; CARRIER HWU; WU
-15D7; CARRIER HWO; WO
-15D8; CARRIER HWE; WE
-15D9; CARRIER HWEE; WEE
-15DA; CARRIER HWI; WI
-15DB; CARRIER HWA; WA
-15DC; CARRIER THU; U
-15DD; CARRIER THO; O
-15DE; CARRIER THE; E
-15DF; CARRIER THEE; EE
-15E0; CARRIER THI; I
-15E1; CARRIER THA; A
-15E2; CARRIER TTU; U
-15E3; CARRIER TTO; O
-15E4; CARRIER TTE; E
-15E5; CARRIER TTEE; EE
-15E6; CARRIER TTI; I
-15E7; CARRIER TTA; A
-15E8; CARRIER PU; U
-15E9; CARRIER PO; O
-15EA; CARRIER PE; E
-15EB; CARRIER PEE; EE
-15EC; CARRIER PI; I
-15ED; CARRIER PA; A
-15EE; CARRIER P;
-15EF; CARRIER GU; U
-15F0; CARRIER GO; O
-15F1; CARRIER GE; E
-15F2; CARRIER GEE; EE
-15F3; CARRIER GI; I
-15F4; CARRIER GA; A
-15F5; CARRIER KHU; U
-15F6; CARRIER KHO; O
-15F7; CARRIER KHE; E
-15F8; CARRIER KHEE; EE
-15F9; CARRIER KHI; I
-15FA; CARRIER KHA; A
-15FB; CARRIER KKU; U
-15FC; CARRIER KKO; O
-15FD; CARRIER KKE; E
-15FE; CARRIER KKEE; EE
-15FF; CARRIER KKI; I
-1600; CARRIER KKA; A
-1601; CARRIER KK;
-1602; CARRIER NU; U
-1603; CARRIER NO; O
-1604; CARRIER NE; E
-1605; CARRIER NEE; EE
-1606; CARRIER NI; I
-1607; CARRIER NA; A
-1608; CARRIER MU; U
-1609; CARRIER MO; O
-160A; CARRIER ME; E
-160B; CARRIER MEE; EE
-160C; CARRIER MI; I
-160D; CARRIER MA; A
-160E; CARRIER YU; U
-160F; CARRIER YO; O
-1610; CARRIER YE; E
-1611; CARRIER YEE; EE
-1612; CARRIER YI; I
-1613; CARRIER YA; A
-1614; CARRIER JU; U
-1615; SAYISI JU; U
-1616; CARRIER JO; O
-1617; CARRIER JE; E
-1618; CARRIER JEE; EE
-1619; CARRIER JI; I
-161A; SAYISI JI; I
-161B; CARRIER JA; A
-161C; CARRIER JJU; U
-161D; CARRIER JJO; O
-161E; CARRIER JJE; E
-161F; CARRIER JJEE; EE
-1620; CARRIER JJI; I
-1621; CARRIER JJA; A
-1622; CARRIER LU; U
-1623; CARRIER LO; O
-1624; CARRIER LE; E
-1625; CARRIER LEE; EE
-1626; CARRIER LI; I
-1627; CARRIER LA; A
-1628; CARRIER DLU; U
-1629; CARRIER DLO; O
-162A; CARRIER DLE; E
-162B; CARRIER DLEE; EE
-162C; CARRIER DLI; I
-162D; CARRIER DLA; A
-162E; CARRIER LHU; U
-162F; CARRIER LHO; O
-1630; CARRIER LHE; E
-1631; CARRIER LHEE; EE
-1632; CARRIER LHI; I
-1633; CARRIER LHA; A
-1634; CARRIER TLHU; U
-1635; CARRIER TLHO; O
-1636; CARRIER TLHE; E
-1637; CARRIER TLHEE; EE
-1638; CARRIER TLHI; I
-1639; CARRIER TLHA; A
-163A; CARRIER TLU; U
-163B; CARRIER TLO; O
-163C; CARRIER TLE; E
-163D; CARRIER TLEE; EE
-163E; CARRIER TLI; I
-163F; CARRIER TLA; A
-1640; CARRIER ZU; U
-1641; CARRIER ZO; O
-1642; CARRIER ZE; E
-1643; CARRIER ZEE; EE
-1644; CARRIER ZI; I
-1645; CARRIER ZA; A
-1646; CARRIER Z;
-1647; CARRIER INITIAL Z;
-1648; CARRIER DZU; U
-1649; CARRIER DZO; O
-164A; CARRIER DZE; E
-164B; CARRIER DZEE; EE
-164C; CARRIER DZI; I
-164D; CARRIER DZA; A
-164E; CARRIER SU; U
-164F; CARRIER SO; O
-1650; CARRIER SE; E
-1651; CARRIER SEE; EE
-1652; CARRIER SI; I
-1653; CARRIER SA; A
-1654; CARRIER SHU; U
-1655; CARRIER SHO; O
-1656; CARRIER SHE; E
-1657; CARRIER SHEE; EE
-1658; CARRIER SHI; I
-1659; CARRIER SHA; A
-165A; CARRIER SH;
-165B; CARRIER TSU; U
-165C; CARRIER TSO; O
-165D; CARRIER TSE; E
-165E; CARRIER TSEE; EE
-165F; CARRIER TSI; I
-1660; CARRIER TSA; A
-1661; CARRIER CHU; U
-1662; CARRIER CHO; O
-1663; CARRIER CHE; E
-1664; CARRIER CHEE; EE
-1665; CARRIER CHI; I
-1666; CARRIER CHA; A
-1667; CARRIER TTSU; U
-1668; CARRIER TTSO; O
-1669; CARRIER TTSE; E
-166A; CARRIER TTSEE; EE
-166B; CARRIER TTSI; I
-166C; CARRIER TTSA; A
-166F; QAI; AI
-1670; NGAI; AI
-1671; NNGI; I
-1672; NNGII; II
-1673; NNGO; O
-1674; NNGOO; OO
-1675; NNGA; A
-1676; NNGAA; AA
-#
-# Katakana
-#
-30A1; SMALL A; A
-30A2; A; A
-30A3; SMALL I; I
-30A4; I; I
-30A5; SMALL U; U
-30A6; U; U
-30A7; SMALL E; E
-30A8; E; E
-30A9; SMALL O; O
-30AA; O; O
-30AB; KA; A
-30AC; GA; A
-30AD; KI; I
-30AE; GI; I
-30AF; KU; U
-30B0; GU; U
-30B1; KE; E
-30B2; GE; E
-30B3; KO; O
-30B4; GO; O
-30B5; SA; A
-30B6; ZA; A
-30B7; SI; I
-30B8; ZI; I
-30B9; SU; U
-30BA; ZU; U
-30BB; SE; E
-30BC; ZE; E
-30BD; SO; O
-30BE; ZO; O
-30BF; TA; A
-30C0; DA; A
-30C1; TI; I
-30C2; DI; I
-30C3; SMALL TU; U
-30C4; TU; U
-30C5; DU; U
-30C6; TE; E
-30C7; DE; E
-30C8; TO; O
-30C9; DO; O
-30CA; NA; A
-30CB; NI; I
-30CC; NU; U
-30CD; NE; E
-30CE; NO; O
-30CF; HA; A
-30D0; BA; A
-30D1; PA; A
-30D2; HI; I
-30D3; BI; I
-30D4; PI; I
-30D5; HU; U
-30D6; BU; U
-30D7; PU; U
-30D8; HE; E
-30D9; BE; E
-30DA; PE; E
-30DB; HO; O
-30DC; BO; O
-30DD; PO; O
-30DE; MA; A
-30DF; MI; I
-30E0; MU; U
-30E1; ME; E
-30E2; MO; O
-30E3; SMALL YA; A
-30E4; YA; A
-30E5; SMALL YU; U
-30E6; YU; U
-30E7; SMALL YO; O
-30E8; YO; O
-30E9; RA; A
-30EA; RI; I
-30EB; RU; U
-30EC; RE; E
-30ED; RO; O
-30EE; SMALL WA; A
-30EF; WA; A
-30F0; WI; I
-30F1; WE; E
-30F2; WO; O
-30F3; N; C
-30F4; VU; U
-30F5; SMALL KA; A
-30F6; SMALL KE; E
-30F7; VA; A
-30F8; VI; I
-30F9; VE; E
-30FA; VO; O
-32D0; CIRCLED KATAKANA A; A
-32D1; CIRCLED KATAKANA I; I
-32D2; CIRCLED KATAKANA U; U
-32D3; CIRCLED KATAKANA E; E
-32D4; CIRCLED KATAKANA O; O
-32D5; CIRCLED KATAKANA KA; A
-32D6; CIRCLED KATAKANA KI; I
-32D7; CIRCLED KATAKANA KU; U
-32D8; CIRCLED KATAKANA KE; E
-32D9; CIRCLED KATAKANA KO; O
-32DA; CIRCLED KATAKANA SA; A
-32DB; CIRCLED KATAKANA SI; I
-32DC; CIRCLED KATAKANA SU; U
-32DD; CIRCLED KATAKANA SE; E
-32DE; CIRCLED KATAKANA SO; O
-32DF; CIRCLED KATAKANA TA; A
-32E0; CIRCLED KATAKANA TI; I
-32E1; CIRCLED KATAKANA TU; U
-32E2; CIRCLED KATAKANA TE; E
-32E3; CIRCLED KATAKANA TO; O
-32E4; CIRCLED KATAKANA NA; A
-32E5; CIRCLED KATAKANA NI; I
-32E6; CIRCLED KATAKANA NU; U
-32E7; CIRCLED KATAKANA NE; E
-32E8; CIRCLED KATAKANA NO; O
-32E9; CIRCLED KATAKANA HA; A
-32EA; CIRCLED KATAKANA HI; I
-32EB; CIRCLED KATAKANA HU; U
-32EC; CIRCLED KATAKANA HE; E
-32ED; CIRCLED KATAKANA HO; O
-32EE; CIRCLED KATAKANA MA; A
-32EF; CIRCLED KATAKANA MI; I
-32F0; CIRCLED KATAKANA MU; U
-32F1; CIRCLED KATAKANA ME; E
-32F2; CIRCLED KATAKANA MO; O
-32F3; CIRCLED KATAKANA YA; A
-32F4; CIRCLED KATAKANA YU; U
-32F5; CIRCLED KATAKANA YO; O
-32F6; CIRCLED KATAKANA RA; A
-32F7; CIRCLED KATAKANA RI; I
-32F8; CIRCLED KATAKANA RU; U
-32F9; CIRCLED KATAKANA RE; E
-32FA; CIRCLED KATAKANA RO; O
-32FB; CIRCLED KATAKANA WA; A
-32FC; CIRCLED KATAKANA WI; I
-32FD; CIRCLED KATAKANA WE; E
-32FE; CIRCLED KATAKANA WO; O
-#
-# Katakana
-#
-FF66; HALFWIDTH WO; O
-FF67; HALFWIDTH SMALL A; A
-FF68; HALFWIDTH SMALL I; I
-FF69; HALFWIDTH SMALL U; U
-FF6A; HALFWIDTH SMALL E; E
-FF6B; HALFWIDTH SMALL O; O
-FF6C; HALFWIDTH SMALL YA; A
-FF6D; HALFWIDTH SMALL YU; U
-FF6E; HALFWIDTH SMALL YO; O
-FF6F; HALFWIDTH SMALL TU; U
-FF71; HALFWIDTH A; A
-FF72; HALFWIDTH I; I
-FF73; HALFWIDTH U; U
-FF74; HALFWIDTH E; E
-FF75; HALFWIDTH O; O
-FF76; HALFWIDTH KA; A
-FF77; HALFWIDTH KI; I
-FF78; HALFWIDTH KU; U
-FF79; HALFWIDTH KE; E
-FF7A; HALFWIDTH KO; O
-FF7B; HALFWIDTH SA; A
-FF7C; HALFWIDTH SI; I
-FF7D; HALFWIDTH SU; U
-FF7E; HALFWIDTH SE; E
-FF7F; HALFWIDTH SO; O
-FF80; HALFWIDTH TA; A
-FF81; HALFWIDTH TI; I
-FF82; HALFWIDTH TU; U
-FF83; HALFWIDTH TE; E
-FF84; HALFWIDTH TO; O
-FF85; HALFWIDTH NA; A
-FF86; HALFWIDTH NI; I
-FF87; HALFWIDTH NU; U
-FF88; HALFWIDTH NE; E
-FF89; HALFWIDTH NO; O
-FF8A; HALFWIDTH HA; A
-FF8B; HALFWIDTH HI; I
-FF8C; HALFWIDTH HU; U
-FF8D; HALFWIDTH HE; E
-FF8E; HALFWIDTH HO; O
-FF8F; HALFWIDTH MA; A
-FF90; HALFWIDTH MI; I
-FF91; HALFWIDTH MU; U
-FF92; HALFWIDTH ME; E
-FF93; HALFWIDTH MO; O
-FF94; HALFWIDTH YA; A
-FF95; HALFWIDTH YU; U
-FF96; HALFWIDTH YO; O
-FF97; HALFWIDTH RA; A
-FF98; HALFWIDTH RI; I
-FF99; HALFWIDTH RU; U
-FF9A; HALFWIDTH RE; E
-FF9B; HALFWIDTH RO; O
-FF9C; HALFWIDTH WA; A
-FF9D; HALFWIDTH N; C
-#
-# Hiragana
-#
-3041; SMALL A; A
-3042; A; A
-3043; SMALL I; I
-3044; I; I
-3045; SMALL U; U
-3046; U; U
-3047; SMALL E; E
-3048; E; E
-3049; SMALL O; O
-304A; O; O
-304B; KA; A
-304C; GA; A
-304D; KI; I
-304E; GI; I
-304F; KU; U
-3050; GU; U
-3051; KE; E
-3052; GE; E
-3053; KO; O
-3054; GO; O
-3055; SA; A
-3056; ZA; A
-3057; SI; I
-3058; ZI; I
-3059; SU; U
-305A; ZU; U
-305B; SE; E
-305C; ZE; E
-305D; SO; O
-305E; ZO; O
-305F; TA; A
-3060; DA; A
-3061; TI; I
-3062; DI; I
-3063; SMALL TU; U
-3064; TU; U
-3065; DU; U
-3066; TE; E
-3067; DE; E
-3068; TO; O
-3069; DO; O
-306A; NA; A
-306B; NI; I
-306C; NU; U
-306D; NE; E
-306E; NO; O
-306F; HA; A
-3070; BA; A
-3071; PA; A
-3072; HI; I
-3073; BI; I
-3074; PI; I
-3075; HU; U
-3076; BU; U
-3077; PU; U
-3078; HE; E
-3079; BE; E
-307A; PE; E
-307B; HO; O
-307C; BO; O
-307D; PO; O
-307E; MA; A
-307F; MI; I
-3080; MU; U
-3081; ME; E
-3082; MO; O
-3083; SMALL YA; A
-3084; YA; A
-3085; SMALL YU; U
-3086; YU; U
-3087; SMALL YO; O
-3088; YO; O
-3089; RA; A
-308A; RI; I
-308B; RU; U
-308C; RE; E
-308D; RO; O
-308E; SMALL WA; A
-308F; WA; A
-3090; WI; I
-3091; WE; E
-3092; WO; O
-3093; N; N
-3094; VU; U
+################################################################################ +# +# V: as "u" in "but" (often represented with schwa or small uppercase lambda) +# U: as "oo" in "fool" +# I: as "ea" in "meat" +# A: as "a" in "father" +# E: as "a" in "hate" +# C: the consonant form having no vowel element +# O: as "o" in "note" +# +# Vowel identifiers are assumed short, doubled identifiers are considered long +# (following Cushitic rules). Dipthong syllables are identified with "W" as +# per Ethiopic and Canadian syllabary character names. +# +# +# WV WVV WU WUU WI WII WA WAA WAI WAAI WE WEE WC WO WOO +# +# V VV U UU I II A AA AI AAI E EE C O OO +# +################################################################################ + +# +# Ethiopic +# +1200; HA; V +1201; HU; U +1202; HI; I +1203; HAA; A +1204; HEE; E +1205; HE; C +1206; HO; O +1208; LA; V +1209; LU; U +120A; LI; I +120B; LAA; A +120C; LEE; E +120D; LE; C +120E; LO; O +120F; LWA; WA +1210; HHA; V +1211; HHU; U +1212; HHI; I +1213; HHAA; A +1214; HHEE; E +1215; HHE; C +1216; HHO; O +1217; HHWA; WA +1218; MA; V +1219; MU; U +121A; MI; I +121B; MAA; A +121C; MEE; E +121D; ME; C +121E; MO; O +121F; MWA; WA +1220; SZA; V +1221; SZU; U +1222; SZI; I +1223; SZAA; A +1224; SZEE; E +1225; SZE; C +1226; SZO; O +1227; SZWA; WA +1228; RA; V +1229; RU; U +122A; RI; I +122B; RAA; A +122C; REE; E +122D; RE; C +122E; RO; O +122F; RWA; WA +1230; SA; V +1231; SU; U +1232; SI; I +1233; SAA; A +1234; SEE; E +1235; SE; C +1236; SO; O +1237; SWA; WA +1238; SHA; V +1239; SHU; U +123A; SHI; I +123B; SHAA; A +123C; SHEE; E +123D; SHE; C +123E; SHO; O +123F; SHWA; WA +1240; QA; V +1241; QU; U +1242; QI; I +1243; QAA; A +1244; QEE; E +1245; QE; C +1246; QO; O +1248; QWA; WV +124A; QWI; WI +124B; QWAA; WA +124C; QWEE; WE +124D; QWE; WC +1250; QHA; V +1251; QHU; U +1252; QHI; I +1253; QHAA; A +1254; QHEE; E +1255; QHE; C +1256; QHO; O +1258; QHWA; WV +125A; QHWI; WI +125B; QHWAA; WA +125C; QHWEE; WE +125D; QHWE; WC +1260; BA; V +1261; BU; U +1262; BI; I +1263; BAA; A +1264; BEE; E +1265; BE; C +1266; BO; O +1267; BWA; WA +1268; VA; V +1269; VU; U +126A; VI; I +126B; VAA; A +126C; VEE; E +126D; VE; C +126E; VO; O +126F; VWA; WA +1270; TA; V +1271; TU; U +1272; TI; I +1273; TAA; A +1274; TEE; E +1275; TE; C +1276; TO; O +1277; TWA; WA +1278; CA; V +1279; CU; U +127A; CI; I +127B; CAA; A +127C; CEE; E +127D; CE; C +127E; CO; O +127F; CWA; WA +1280; XA; V +1281; XU; U +1282; XI; I +1283; XAA; A +1284; XEE; E +1285; XE; C +1286; XO; O +1288; XWA; WV +128A; XWI; WI +128B; XWAA; WA +128C; XWEE; WE +128D; XWE; WC +1290; NA; V +1291; NU; U +1292; NI; I +1293; NAA; A +1294; NEE; E +1295; NE; C +1296; NO; O +1297; NWA; WA +1298; NYA; V +1299; NYU; U +129A; NYI; I +129B; NYAA; A +129C; NYEE; E +129D; NYE; C +129E; NYO; O +129F; NYWA; WA +12A0; GLOTTAL A; V +12A1; GLOTTAL U; U +12A2; GLOTTAL I; I +12A3; GLOTTAL AA; A +12A4; GLOTTAL EE; E +12A5; GLOTTAL E; C +12A6; GLOTTAL O; O +12A7; GLOTTAL WA; WA +12A8; KA; V +12A9; KU; U +12AA; KI; I +12AB; KAA; A +12AC; KEE; E +12AD; KE; C +12AE; KO; O +12B0; KWA; WV +12B2; KWI; WI +12B3; KWAA; WA +12B4; KWEE; WE +12B5; KWE; WC +12B8; KXA; V +12B9; KXU; U +12BA; KXI; I +12BB; KXAA; A +12BC; KXEE; E +12BD; KXE; C +12BE; KXO; O +12C0; KXWA; WV +12C2; KXWI; WI +12C3; KXWAA; WA +12C4; KXWEE; WE +12C5; KXWE; WC +12C8; WA; V +12C9; WU; U +12CA; WI; I +12CB; WAA; A +12CC; WEE; E +12CD; WE; C +12CE; WO; O +12D0; PHARYNGEAL A; V +12D1; PHARYNGEAL U; U +12D2; PHARYNGEAL I; I +12D3; PHARYNGEAL AA; A +12D4; PHARYNGEAL EE; E +12D5; PHARYNGEAL E; C +12D6; PHARYNGEAL O; O +12D8; ZA; V +12D9; ZU; U +12DA; ZI; I +12DB; ZAA; A +12DC; ZEE; E +12DD; ZE; C +12DE; ZO; O +12DF; ZWA; WA +12E0; ZHA; V +12E1; ZHU; U +12E2; ZHI; I +12E3; ZHAA; A +12E4; ZHEE; E +12E5; ZHE; C +12E6; ZHO; O +12E7; ZHWA; WA +12E8; YA; V +12E9; YU; U +12EA; YI; I +12EB; YAA; A +12EC; YEE; E +12ED; YE; C +12EE; YO; O +12F0; DA; V +12F1; DU; U +12F2; DI; I +12F3; DAA; A +12F4; DEE; E +12F5; DE; C +12F6; DO; O +12F7; DWA; WA +12F8; DDA; V +12F9; DDU; U +12FA; DDI; I +12FB; DDAA; A +12FC; DDEE; E +12FD; DDE; C +12FE; DDO; O +12FF; DDWA; WA +1300; JA; V +1301; JU; U +1302; JI; I +1303; JAA; A +1304; JEE; E +1305; JE; C +1306; JO; O +1307; JWA; WA +1308; GA; V +1309; GU; U +130A; GI; I +130B; GAA; A +130C; GEE; E +130D; GE; C +130E; GO; O +1310; GWA; WV +1312; GWI; WI +1313; GWAA; WA +1314; GWEE; WE +1315; GWE; WC +1318; GGA; V +1319; GGU; U +131A; GGI; I +131B; GGAA; A +131C; GGEE; E +131D; GGE; C +131E; GGO; O +1320; THA; V +1321; THU; U +1322; THI; I +1323; THAA; A +1324; THEE; E +1325; THE; C +1326; THO; O +1327; THWA; WA +1328; CHA; V +1329; CHU; U +132A; CHI; I +132B; CHAA; A +132C; CHEE; E +132D; CHE; C +132E; CHO; O +132F; CHWA; WA +1330; PHA; V +1331; PHU; U +1332; PHI; I +1333; PHAA; A +1334; PHEE; E +1335; PHE; C +1336; PHO; O +1337; PHWA; WA +1338; TSA; V +1339; TSU; U +133A; TSI; I +133B; TSAA; A +133C; TSEE; E +133D; TSE; C +133E; TSO; O +133F; TSWA; WA +1340; TZA; V +1341; TZU; U +1342; TZI; I +1343; TZAA; A +1344; TZEE; E +1345; TZE; C +1346; TZO; O +1348; FA; V +1349; FU; U +134A; FI; I +134B; FAA; A +134C; FEE; E +134D; FE; C +134E; FO; O +134F; FWA; WA +1350; PA; V +1351; PU; U +1352; PI; I +1353; PAA; A +1354; PEE; E +1355; PE; C +1356; PO; O +1357; PWA; WA +# +# Cherokee +# +13A0; A; A +13A1; E; E +13A2; I; I +13A3; O; O +13A4; U; U +13A5; V; V +13A6; GA; A +13A7; KA; A +13A8; GE; E +13A9; GI; I +13AA; GO; O +13AB; GU; U +13AC; GV; V +13AD; HA; A +13AE; HE; E +13AF; HI; I +13B0; HO; O +13B1; HU; U +13B2; HV; V +13B3; LA; A +13B4; LE; E +13B5; LI; I +13B6; LO; O +13B7; LU; U +13B8; LV; V +13B9; MA; A +13BA; ME; E +13BB; MI; I +13BC; MO; O +13BD; MU; U +13BE; NA; A +13BF; HNA; A +13C0; NAH; C +13C1; NE; E +13C2; NI; I +13C3; NO; O +13C4; NU; U +13C5; NV; V +13C6; QUA; A +13C7; QUE; E +13C8; QUI; I +13C9; QUO; O +13CA; QUU; U +13CB; QUV; V +13CC; SA; A +13CD; S; C +13CE; SE; E +13CF; SI; I +13D0; SO; O +13D1; SU; U +13D2; SV; V +13D3; DA; A +13D4; TA; A +13D5; DE; E +13D6; TE; E +13D7; DI; I +13D8; TI; I +13D9; DO; O +13DA; DU; U +13DB; DV; V +13DC; DLA; A +13DD; TLA; A +13DE; TLE; E +13DF; TLI; I +13E0; TLO; O +13E1; TLU; U +13E2; TLV; V +13E3; TSA; A +13E4; TSE; E +13E5; TSI; I +13E6; TSO; O +13E7; TSU; U +13E8; TSV; V +13E9; WA; A +13EA; WE; E +13EB; WI; I +13EC; WO; O +13ED; WU; U +13EE; WV; V +13EF; YA; A +13F0; YE; E +13F1; YI; I +13F2; YO; O +13F3; YU; U +13F4; YV; V +# +# 1400 Unified Canadian Aboriginal Syllabics 167F +# +1401; E; E +1402; AAI; AAI +1403; I; I +1404; II; II +1405; O; O +1406; OO; OO +1407; Y-CREE OO; OO +1408; CARRIER EE; EE +1409; CARRIER I; I +140A; A; A +140B; AA; AA +140C; WE; WE +140D; WEST-CREE WE; WE +140E; WI; WI +140F; WEST-CREE WI; WI +1410; WII; WII +1411; WEST-CREE WII; WII +1412; WO; WO +1413; WEST-CREE WO; WO +1414; WOO; WOO +1415; WEST-CREE WOO; WOO +1416; NASKAPI WOO; WOO +1417; WA; WA +1418; WEST-CREE WA; WA +1419; WAA; WAA +141A; WEST-CREE WAA; WAA +141B; NASKAPI WAA; WAA +141C; AI; AI +141D; Y-CREE W; C +142B; EN; C +142C; IN; C +142D; ON; C +142E; AN; C +142F; PE; E +1430; PAAI; AAI +1431; PI; I +1432; PII; II +1433; PO; O +1434; POO; OO +1435; Y-CREE POO; OO +1436; CARRIER HEE; EE +1437; CARRIER HI; I +1438; PA; A +1439; PAA; AA +143A; PWE; WE +143B; WEST-CREE PWE; WE +143C; PWI; WI +143D; WEST-CREE PWI; WI +143E; PWII; WII +143F; WEST-CREE PWII; WII +1440; PWO; WO +1441; WEST-CREE PWO; WO +1442; PWOO; WOO +1443; WEST-CREE PWOO; WOO +1444; PWA; WA +1445; WEST-CREE PWA; WA +1446; PWAA; WAA +1447; WEST-CREE PWAA; WAA +1448; Y-CREE PWAA; WAA +1449; P; C +144A; WEST-CREE P; C +144B; CARRIER H; C +144C; TE; E +144D; TAAI; AAI +144E; TI; I +144F; TII; II +1450; TO; O +1451; TOO; OO +1452; Y-CREE TOO; OO +1453; CARRIER DEE; EE +1454; CARRIER DI; I +1455; TA; A +1456; TAA; AA +1457; TWE; WE +1458; WEST-CREE TWE; WE +1459; TWI; WI +145A; WEST-CREE TWI; WI +145B; TWII; WII +145C; WEST-CREE TWII; WII +145D; TWO; WO +145E; WEST-CREE TWO; WO +145F; TWOO; WOO +1460; WEST-CREE TWOO; WOO +1461; TWA; WA +1462; WEST-CREE TWA; WA +1463; TWAA; WAA +1464; WEST-CREE TWAA; WAA +1465; NASKAPI TWAA; WAA +1466; T; C +1467; TTE; E +1468; TTI; I +1469; TTO; O +146A; TTA; A +146B; KE; E +146C; KAAI; AAI +146D; KI; I +146E; KII; II +146F; KO; O +1470; KOO; OO +1471; Y-CREE KOO; OO +1472; KA; A +1473; KAA; AA +1474; KWE; WE +1475; WEST-CREE KWE; WE +1476; KWI; WI +1477; WEST-CREE KWI; WI +1478; KWII; WII +1479; WEST-CREE KWII; WII +147A; KWO; WO +147B; WEST-CREE KWO; WO +147C; KWOO; WOO +147D; WEST-CREE KWOO; WOO +147E; KWA; WA +147F; WEST-CREE KWA; WA +1480; KWAA; WAA +1481; WEST-CREE KWAA; WAA +1482; NASKAPI KWAA; WAA +1483; K; C +1484; KW; WC +1485; SOUTH-SLAVEY KEH; C +1486; SOUTH-SLAVEY KIH; C +1487; SOUTH-SLAVEY KOH; C +1488; SOUTH-SLAVEY KAH; C +1489; CE; E +148A; CAAI; AAI +148B; CI; I +148C; CII; II +148D; CO; O +148E; COO; OO +148F; Y-CREE COO; OO +1490; CA; A +1491; CAA; AA +1492; CWE; WE +1493; WEST-CREE CWE; WE +1494; CWI; WI +1495; WEST-CREE CWI; WI +1496; CWII; WII +1497; WEST-CREE CWII; WII +1498; CWO; WO +1499; WEST-CREE CWO; WO +149A; CWOO; WOO +149B; WEST-CREE CWOO; WOO +149C; CWA; WA +149D; WEST-CREE CWA; WA +149E; CWAA; WAA +149F; WEST-CREE CWAA; WAA +14A0; NASKAPI CWAA; WAA +14A1; C; C +14A2; SAYISI TH; +14A3; ME; E +14A4; MAAI; AAI +14A5; MI; I +14A6; MII; II +14A7; MO; O +14A8; MOO; OO +14A9; Y-CREE MOO; OO +14AA; MA; A +14AB; MAA; AA +14AC; MWE; WE +14AD; WEST-CREE MWE; WE +14AE; MWI; WI +14AF; WEST-CREE MWI; WI +14B0; MWII; WII +14B1; WEST-CREE MWII; WII +14B2; MWO; WO +14B3; WEST-CREE MWO; WO +14B4; MWOO; WOO +14B5; WEST-CREE MWOO; WOO +14B6; MWA; WA +14B7; WEST-CREE MWA; WA +14B8; MWAA; WAA +14B9; WEST-CREE MWAA; WAA +14BA; NASKAPI MWAA; WAA +14BB; M; C +14BC; WEST-CREE M; C +14BD; MH; C +14BE; ATHAPASCAN M; C +14BF; SAYISI M; C +14C0; NE; E +14C1; NAAI; AAI +14C2; NI; I +14C3; NII; II +14C4; NO; O +14C5; NOO; OO +14C6; Y-CREE NOO; OO +14C7; NA; A +14C8; NAA; AA +14C9; NWE; WE +14CA; WEST-CREE NWE; WE +14CB; NWA; WA +14CC; WEST-CREE NWA; WA +14CD; NWAA; WAA +14CE; WEST-CREE NWAA; WAA +14CF; NASKAPI NWAA; WAA +14D0; N; C +14D1; CARRIER NG; C +14D2; NH; C +14D3; LE; E +14D4; LAAI; AAI +14D5; LI; I +14D6; LII; II +14D7; LO; O +14D8; LOO; OO +14D9; Y-CREE LOO; OO +14DA; LA; A +14DB; LAA; AA +14DC; LWE; WE +14DD; WEST-CREE LWE; WE +14DE; LWI; WI +14DF; WEST-CREE LWI; WI +14E0; LWII; WII +14E1; WEST-CREE LWII; WII +14E2; LWO; WO +14E3; WEST-CREE LWO; WO +14E4; LWOO; WOO +14E5; WEST-CREE LWOO; WOO +14E6; LWA; WA +14E7; WEST-CREE LWA; WA +14E8; LWAA; WAA +14E9; WEST-CREE LWAA; WAA +14EA; L; C +14EB; WEST-CREE L; C +14EC; MEDIAL L; C +14ED; SE; E +14EE; SAAI; AAI +14EF; SI; I +14F0; SII; II +14F1; SO; O +14F2; SOO; OO +14F3; Y-CREE SOO; OO +14F4; SA; A +14F5; SAA; AA +14F6; SWE; WE +14F7; WEST-CREE SWE; WE +14F8; SWI; WI +14F9; WEST-CREE SWI; WI +14FA; SWII; WII +14FB; WEST-CREE SWII; WII +14FC; SWO; WO +14FD; WEST-CREE SWO; WO +14FE; SWOO; WOO +14FF; WEST-CREE SWOO; WOO +1500; SWA; WA +1501; WEST-CREE SWA; WA +1502; SWAA; WAA +1503; WEST-CREE SWAA; WAA +1504; NASKAPI SWAA; WAA +1505; S; C +1506; ATHAPASCAN S; C +1507; SW; WC +1508; BLACKFOOT S; C +1509; MOOSE-CREE SK;C +150A; NASKAPI SKW; C +150B; NASKAPI S-W; C +150C; NASKAPI SPWA; WA +150D; NASKAPI STWA; WA +150E; NASKAPI SKWA; WA +150F; NASKAPI SCWA; WA +1510; SHE; E +1511; SHI; I +1512; SHII; II +1513; SHO; O +1514; SHOO; OO +1515; SHA; A +1516; SHAA; AA +1517; SHWE; WE +1518; WEST-CREE SHWE; WE +1519; SHWI; WI +151A; WEST-CREE SHWI; WI +151B; SHWII; WII +151C; WEST-CREE SHWII; WII +151D; SHWO; WO +151E; WEST-CREE SHWO; WO +151F; SHWOO; WOO +1520; WEST-CREE SHWOO; WOO +1521; SHWA; WA +1522; WEST-CREE SHWA; WA +1523; SHWAA; WAA +1524; WEST-CREE SHWAA; WAA +1525; SH; C +1526; YE; E +1527; YAAI; AAI +1528; YI; I +1529; YII; II +152A; YO; O +152B; YOO; OO +152C; Y-CREE YOO; OO +152D; YA; A +152E; YAA; AA +152F; YWE; WE +1530; WEST-CREE YWE; WE +1531; YWI; WI +1532; WEST-CREE YWI; WI +1533; YWII; WII +1534; WEST-CREE YWII; WII +1535; YWO; WO +1536; WEST-CREE YWO; WO +1537; YWOO; WOO +1538; WEST-CREE YWOO; WOO +1539; YWA; WA +153A; WEST-CREE YWA; WA +153B; YWAA; WAA +153C; WEST-CREE YWAA; WAA +153D; NASKAPI YWAA; WAA +153E; Y; C +153F; BIBLE-CREE Y; C +1540; WEST-CREE Y; C +1541; SAYISI YI; I +1542; RE; E +1543; R-CREE RE; E +1544; WEST-CREE LE; E +1545; RAAI; AAI +1546; RI; I +1547; RII; II +1548; RO; O +1549; ROO; OO +154A; WEST-CREE LO; O +154B; RA; A +154C; RAA; AA +154D; WEST-CREE LA; A +154E; RWAA; WAA +154F; WEST-CREE RWAA; WAA +1550; R; C +1551; WEST-CREE R; C +1552; MEDIAL R; C +1553; FE; E +1554; FAAI; AAI +1555; FI; I +1556; FII; II +1557; FO; O +1558; FOO; OO +1559; FA; A +155A; FAA; AA +155B; FWAA; WAA +155C; WEST-CREE FWAA; WAA +155D; F; C +155E; THE; E +155F; N-CREE THE; E +1560; THI; I +1561; N-CREE THI; I +1562; THII; II +1563; N-CREE THII; II +1564; THO; O +1565; THOO; OO +1566; THA; A +1567; THAA; AA +1568; THWAA; WAA +1569; WEST-CREE THWAA; WAA +156A; TH; C +156B; TTHE; E +156C; TTHI; I +156D; TTHO; O +156E; TTHA; A +156F; TTH; C +1570; TYE; E +1571; TYI; I +1572; TYO; O +1573; TYA; A +1574; NUNAVIK HE; E +1575; NUNAVIK HI; I +1576; NUNAVIK HII; II +1577; NUNAVIK HO; O +1578; NUNAVIK HOO; OO +1579; NUNAVIK HA; A +157A; NUNAVIK HAA; AA +157B; NUNAVIK H; C +157C; NUNAVUT H; C +157D; HK; C +157E; QAAI; AAI +157F; QI; I +1580; QII; II +1581; QO; O +1582; QOO; OO +1583; QA; A +1584; QAA; AA +1585; Q; C +1586; TLHE; E +1587; TLHI; I +1588; TLHO; O +1589; TLHA; A +158A; WEST-CREE RE; E +158B; WEST-CREE RI; I +158C; WEST-CREE RO; O +158D; WEST-CREE RA; A +158E; NGAAI; AAI +158F; NGI; I +1590; NGII; II +1591; NGO; O +1592; NGOO; OO +1593; NGA; A +1594; NGAA; AA +1595; NG; C +1596; NNG; C +1597; SAYISI SHE; E +1598; SAYISI SHI; I +1599; SAYISI SHO; O +159A; SAYISI SHA; A +159B; WOODS-CREE THE; E +159C; WOODS-CREE THI; I +159D; WOODS-CREE THO; O +159E; WOODS-CREE THA; A +159F; WOODS-CREE TH; C +15A0; LHI; I +15A1; LHII; II +15A2; LHO; O +15A3; LHOO; OO +15A4; LHA; A +15A5; LHAA; AA +15A6; LH; C +15A7; TH-CREE THE; E +15A8; TH-CREE THI; I +15A9; TH-CREE THII; II +15AA; TH-CREE THO; O +15AB; TH-CREE THOO; OO +15AC; TH-CREE THA; A +15AD; TH-CREE THAA; AA +15AE; TH-CREE TH; C +15AF; AIVILIK B; C +15B0; BLACKFOOT E; E +15B1; BLACKFOOT I; I +15B2; BLACKFOOT O; O +15B3; BLACKFOOT A; A +15B4; BLACKFOOT WE; E +15B5; BLACKFOOT WI; I +15B6; BLACKFOOT WO; O +15B7; BLACKFOOT WA; A +15B8; BLACKFOOT NE; E +15B9; BLACKFOOT NI; I +15BA; BLACKFOOT NO; O +15BB; BLACKFOOT NA; A +15BC; BLACKFOOT KE; E +15BD; BLACKFOOT KI; I +15BE; BLACKFOOT KO; O +15BF; BLACKFOOT KA; A +15C0; SAYISI HE; E +15C1; SAYISI HI; I +15C2; SAYISI HO; O +15C3; SAYISI HA; A +15C4; CARRIER GHU; U +15C5; CARRIER GHO; O +15C6; CARRIER GHE; E +15C7; CARRIER GHEE; EE +15C8; CARRIER GHI; I +15C9; CARRIER GHA; A +15CA; CARRIER RU; U +15CB; CARRIER RO; O +15CC; CARRIER RE; E +15CD; CARRIER REE; EE +15CE; CARRIER RI; I +15CF; CARRIER RA; A +15D0; CARRIER WU; U +15D1; CARRIER WO; O +15D2; CARRIER WE; E +15D3; CARRIER WEE; EE +15D4; CARRIER WI; I +15D5; CARRIER WA; A +15D6; CARRIER HWU; WU +15D7; CARRIER HWO; WO +15D8; CARRIER HWE; WE +15D9; CARRIER HWEE; WEE +15DA; CARRIER HWI; WI +15DB; CARRIER HWA; WA +15DC; CARRIER THU; U +15DD; CARRIER THO; O +15DE; CARRIER THE; E +15DF; CARRIER THEE; EE +15E0; CARRIER THI; I +15E1; CARRIER THA; A +15E2; CARRIER TTU; U +15E3; CARRIER TTO; O +15E4; CARRIER TTE; E +15E5; CARRIER TTEE; EE +15E6; CARRIER TTI; I +15E7; CARRIER TTA; A +15E8; CARRIER PU; U +15E9; CARRIER PO; O +15EA; CARRIER PE; E +15EB; CARRIER PEE; EE +15EC; CARRIER PI; I +15ED; CARRIER PA; A +15EE; CARRIER P; +15EF; CARRIER GU; U +15F0; CARRIER GO; O +15F1; CARRIER GE; E +15F2; CARRIER GEE; EE +15F3; CARRIER GI; I +15F4; CARRIER GA; A +15F5; CARRIER KHU; U +15F6; CARRIER KHO; O +15F7; CARRIER KHE; E +15F8; CARRIER KHEE; EE +15F9; CARRIER KHI; I +15FA; CARRIER KHA; A +15FB; CARRIER KKU; U +15FC; CARRIER KKO; O +15FD; CARRIER KKE; E +15FE; CARRIER KKEE; EE +15FF; CARRIER KKI; I +1600; CARRIER KKA; A +1601; CARRIER KK; +1602; CARRIER NU; U +1603; CARRIER NO; O +1604; CARRIER NE; E +1605; CARRIER NEE; EE +1606; CARRIER NI; I +1607; CARRIER NA; A +1608; CARRIER MU; U +1609; CARRIER MO; O +160A; CARRIER ME; E +160B; CARRIER MEE; EE +160C; CARRIER MI; I +160D; CARRIER MA; A +160E; CARRIER YU; U +160F; CARRIER YO; O +1610; CARRIER YE; E +1611; CARRIER YEE; EE +1612; CARRIER YI; I +1613; CARRIER YA; A +1614; CARRIER JU; U +1615; SAYISI JU; U +1616; CARRIER JO; O +1617; CARRIER JE; E +1618; CARRIER JEE; EE +1619; CARRIER JI; I +161A; SAYISI JI; I +161B; CARRIER JA; A +161C; CARRIER JJU; U +161D; CARRIER JJO; O +161E; CARRIER JJE; E +161F; CARRIER JJEE; EE +1620; CARRIER JJI; I +1621; CARRIER JJA; A +1622; CARRIER LU; U +1623; CARRIER LO; O +1624; CARRIER LE; E +1625; CARRIER LEE; EE +1626; CARRIER LI; I +1627; CARRIER LA; A +1628; CARRIER DLU; U +1629; CARRIER DLO; O +162A; CARRIER DLE; E +162B; CARRIER DLEE; EE +162C; CARRIER DLI; I +162D; CARRIER DLA; A +162E; CARRIER LHU; U +162F; CARRIER LHO; O +1630; CARRIER LHE; E +1631; CARRIER LHEE; EE +1632; CARRIER LHI; I +1633; CARRIER LHA; A +1634; CARRIER TLHU; U +1635; CARRIER TLHO; O +1636; CARRIER TLHE; E +1637; CARRIER TLHEE; EE +1638; CARRIER TLHI; I +1639; CARRIER TLHA; A +163A; CARRIER TLU; U +163B; CARRIER TLO; O +163C; CARRIER TLE; E +163D; CARRIER TLEE; EE +163E; CARRIER TLI; I +163F; CARRIER TLA; A +1640; CARRIER ZU; U +1641; CARRIER ZO; O +1642; CARRIER ZE; E +1643; CARRIER ZEE; EE +1644; CARRIER ZI; I +1645; CARRIER ZA; A +1646; CARRIER Z; +1647; CARRIER INITIAL Z; +1648; CARRIER DZU; U +1649; CARRIER DZO; O +164A; CARRIER DZE; E +164B; CARRIER DZEE; EE +164C; CARRIER DZI; I +164D; CARRIER DZA; A +164E; CARRIER SU; U +164F; CARRIER SO; O +1650; CARRIER SE; E +1651; CARRIER SEE; EE +1652; CARRIER SI; I +1653; CARRIER SA; A +1654; CARRIER SHU; U +1655; CARRIER SHO; O +1656; CARRIER SHE; E +1657; CARRIER SHEE; EE +1658; CARRIER SHI; I +1659; CARRIER SHA; A +165A; CARRIER SH; +165B; CARRIER TSU; U +165C; CARRIER TSO; O +165D; CARRIER TSE; E +165E; CARRIER TSEE; EE +165F; CARRIER TSI; I +1660; CARRIER TSA; A +1661; CARRIER CHU; U +1662; CARRIER CHO; O +1663; CARRIER CHE; E +1664; CARRIER CHEE; EE +1665; CARRIER CHI; I +1666; CARRIER CHA; A +1667; CARRIER TTSU; U +1668; CARRIER TTSO; O +1669; CARRIER TTSE; E +166A; CARRIER TTSEE; EE +166B; CARRIER TTSI; I +166C; CARRIER TTSA; A +166F; QAI; AI +1670; NGAI; AI +1671; NNGI; I +1672; NNGII; II +1673; NNGO; O +1674; NNGOO; OO +1675; NNGA; A +1676; NNGAA; AA +# +# Katakana +# +30A1; SMALL A; A +30A2; A; A +30A3; SMALL I; I +30A4; I; I +30A5; SMALL U; U +30A6; U; U +30A7; SMALL E; E +30A8; E; E +30A9; SMALL O; O +30AA; O; O +30AB; KA; A +30AC; GA; A +30AD; KI; I +30AE; GI; I +30AF; KU; U +30B0; GU; U +30B1; KE; E +30B2; GE; E +30B3; KO; O +30B4; GO; O +30B5; SA; A +30B6; ZA; A +30B7; SI; I +30B8; ZI; I +30B9; SU; U +30BA; ZU; U +30BB; SE; E +30BC; ZE; E +30BD; SO; O +30BE; ZO; O +30BF; TA; A +30C0; DA; A +30C1; TI; I +30C2; DI; I +30C3; SMALL TU; U +30C4; TU; U +30C5; DU; U +30C6; TE; E +30C7; DE; E +30C8; TO; O +30C9; DO; O +30CA; NA; A +30CB; NI; I +30CC; NU; U +30CD; NE; E +30CE; NO; O +30CF; HA; A +30D0; BA; A +30D1; PA; A +30D2; HI; I +30D3; BI; I +30D4; PI; I +30D5; HU; U +30D6; BU; U +30D7; PU; U +30D8; HE; E +30D9; BE; E +30DA; PE; E +30DB; HO; O +30DC; BO; O +30DD; PO; O +30DE; MA; A +30DF; MI; I +30E0; MU; U +30E1; ME; E +30E2; MO; O +30E3; SMALL YA; A +30E4; YA; A +30E5; SMALL YU; U +30E6; YU; U +30E7; SMALL YO; O +30E8; YO; O +30E9; RA; A +30EA; RI; I +30EB; RU; U +30EC; RE; E +30ED; RO; O +30EE; SMALL WA; A +30EF; WA; A +30F0; WI; I +30F1; WE; E +30F2; WO; O +30F3; N; C +30F4; VU; U +30F5; SMALL KA; A +30F6; SMALL KE; E +30F7; VA; A +30F8; VI; I +30F9; VE; E +30FA; VO; O +32D0; CIRCLED KATAKANA A; A +32D1; CIRCLED KATAKANA I; I +32D2; CIRCLED KATAKANA U; U +32D3; CIRCLED KATAKANA E; E +32D4; CIRCLED KATAKANA O; O +32D5; CIRCLED KATAKANA KA; A +32D6; CIRCLED KATAKANA KI; I +32D7; CIRCLED KATAKANA KU; U +32D8; CIRCLED KATAKANA KE; E +32D9; CIRCLED KATAKANA KO; O +32DA; CIRCLED KATAKANA SA; A +32DB; CIRCLED KATAKANA SI; I +32DC; CIRCLED KATAKANA SU; U +32DD; CIRCLED KATAKANA SE; E +32DE; CIRCLED KATAKANA SO; O +32DF; CIRCLED KATAKANA TA; A +32E0; CIRCLED KATAKANA TI; I +32E1; CIRCLED KATAKANA TU; U +32E2; CIRCLED KATAKANA TE; E +32E3; CIRCLED KATAKANA TO; O +32E4; CIRCLED KATAKANA NA; A +32E5; CIRCLED KATAKANA NI; I +32E6; CIRCLED KATAKANA NU; U +32E7; CIRCLED KATAKANA NE; E +32E8; CIRCLED KATAKANA NO; O +32E9; CIRCLED KATAKANA HA; A +32EA; CIRCLED KATAKANA HI; I +32EB; CIRCLED KATAKANA HU; U +32EC; CIRCLED KATAKANA HE; E +32ED; CIRCLED KATAKANA HO; O +32EE; CIRCLED KATAKANA MA; A +32EF; CIRCLED KATAKANA MI; I +32F0; CIRCLED KATAKANA MU; U +32F1; CIRCLED KATAKANA ME; E +32F2; CIRCLED KATAKANA MO; O +32F3; CIRCLED KATAKANA YA; A +32F4; CIRCLED KATAKANA YU; U +32F5; CIRCLED KATAKANA YO; O +32F6; CIRCLED KATAKANA RA; A +32F7; CIRCLED KATAKANA RI; I +32F8; CIRCLED KATAKANA RU; U +32F9; CIRCLED KATAKANA RE; E +32FA; CIRCLED KATAKANA RO; O +32FB; CIRCLED KATAKANA WA; A +32FC; CIRCLED KATAKANA WI; I +32FD; CIRCLED KATAKANA WE; E +32FE; CIRCLED KATAKANA WO; O +# +# Katakana +# +FF66; HALFWIDTH WO; O +FF67; HALFWIDTH SMALL A; A +FF68; HALFWIDTH SMALL I; I +FF69; HALFWIDTH SMALL U; U +FF6A; HALFWIDTH SMALL E; E +FF6B; HALFWIDTH SMALL O; O +FF6C; HALFWIDTH SMALL YA; A +FF6D; HALFWIDTH SMALL YU; U +FF6E; HALFWIDTH SMALL YO; O +FF6F; HALFWIDTH SMALL TU; U +FF71; HALFWIDTH A; A +FF72; HALFWIDTH I; I +FF73; HALFWIDTH U; U +FF74; HALFWIDTH E; E +FF75; HALFWIDTH O; O +FF76; HALFWIDTH KA; A +FF77; HALFWIDTH KI; I +FF78; HALFWIDTH KU; U +FF79; HALFWIDTH KE; E +FF7A; HALFWIDTH KO; O +FF7B; HALFWIDTH SA; A +FF7C; HALFWIDTH SI; I +FF7D; HALFWIDTH SU; U +FF7E; HALFWIDTH SE; E +FF7F; HALFWIDTH SO; O +FF80; HALFWIDTH TA; A +FF81; HALFWIDTH TI; I +FF82; HALFWIDTH TU; U +FF83; HALFWIDTH TE; E +FF84; HALFWIDTH TO; O +FF85; HALFWIDTH NA; A +FF86; HALFWIDTH NI; I +FF87; HALFWIDTH NU; U +FF88; HALFWIDTH NE; E +FF89; HALFWIDTH NO; O +FF8A; HALFWIDTH HA; A +FF8B; HALFWIDTH HI; I +FF8C; HALFWIDTH HU; U +FF8D; HALFWIDTH HE; E +FF8E; HALFWIDTH HO; O +FF8F; HALFWIDTH MA; A +FF90; HALFWIDTH MI; I +FF91; HALFWIDTH MU; U +FF92; HALFWIDTH ME; E +FF93; HALFWIDTH MO; O +FF94; HALFWIDTH YA; A +FF95; HALFWIDTH YU; U +FF96; HALFWIDTH YO; O +FF97; HALFWIDTH RA; A +FF98; HALFWIDTH RI; I +FF99; HALFWIDTH RU; U +FF9A; HALFWIDTH RE; E +FF9B; HALFWIDTH RO; O +FF9C; HALFWIDTH WA; A +FF9D; HALFWIDTH N; C +# +# Hiragana +# +3041; SMALL A; A +3042; A; A +3043; SMALL I; I +3044; I; I +3045; SMALL U; U +3046; U; U +3047; SMALL E; E +3048; E; E +3049; SMALL O; O +304A; O; O +304B; KA; A +304C; GA; A +304D; KI; I +304E; GI; I +304F; KU; U +3050; GU; U +3051; KE; E +3052; GE; E +3053; KO; O +3054; GO; O +3055; SA; A +3056; ZA; A +3057; SI; I +3058; ZI; I +3059; SU; U +305A; ZU; U +305B; SE; E +305C; ZE; E +305D; SO; O +305E; ZO; O +305F; TA; A +3060; DA; A +3061; TI; I +3062; DI; I +3063; SMALL TU; U +3064; TU; U +3065; DU; U +3066; TE; E +3067; DE; E +3068; TO; O +3069; DO; O +306A; NA; A +306B; NI; I +306C; NU; U +306D; NE; E +306E; NO; O +306F; HA; A +3070; BA; A +3071; PA; A +3072; HI; I +3073; BI; I +3074; PI; I +3075; HU; U +3076; BU; U +3077; PU; U +3078; HE; E +3079; BE; E +307A; PE; E +307B; HO; O +307C; BO; O +307D; PO; O +307E; MA; A +307F; MI; I +3080; MU; U +3081; ME; E +3082; MO; O +3083; SMALL YA; A +3084; YA; A +3085; SMALL YU; U +3086; YU; U +3087; SMALL YO; O +3088; YO; O +3089; RA; A +308A; RI; I +308B; RU; U +308C; RE; E +308D; RO; O +308E; SMALL WA; A +308F; WA; A +3090; WI; I +3091; WE; E +3092; WO; O +3093; N; N +3094; VU; U diff --git a/lib/utf8.pm b/lib/utf8.pm index 6d6c0eb503..f06b893a59 100644 --- a/lib/utf8.pm +++ b/lib/utf8.pm @@ -4,6 +4,8 @@ if (ord('A') != 193) { # make things more pragmatic for EBCDIC folk $utf8::hint_bits = 0x00800000; +our $VERSION = '1.00'; + sub import { $^H |= $utf8::hint_bits; $enc{caller()} = $_[1] if $_[1]; diff --git a/lib/vars.pm b/lib/vars.pm index 0ace55169c..d39f19766e 100644 --- a/lib/vars.pm +++ b/lib/vars.pm @@ -2,6 +2,8 @@ package vars; require 5.002; +our $VERSION = '1.00'; + # The following require can't be removed during maintenance # releases, sadly, because of the risk of buggy code that does # require Carp; Carp::croak "..."; without brackets dying @@ -10,6 +12,7 @@ require 5.002; require Carp if $] < 5.00450; use warnings::register; +require strict; sub import { my $callpack = caller; @@ -26,6 +29,8 @@ sub import { Carp::croak("Can't declare individual elements of hash or array"); } elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) { warnings::warn("No need to declare built-in vars"); + } elsif ( $^H &= strict::bits('vars') ) { + Carp::croak("'$ch$sym' is not a valid variable name under strict vars"); } } *{"${callpack}::$sym"} = diff --git a/lib/warnings.pm b/lib/warnings.pm index 2517239365..e3416419fd 100644 --- a/lib/warnings.pm +++ b/lib/warnings.pm @@ -5,6 +5,8 @@ package warnings; +our $VERSION = '1.00'; + =head1 NAME warnings - Perl pragma to control optional warnings @@ -39,7 +41,7 @@ warnings - Perl pragma to control optional warnings If no import list is supplied, all possible warnings are either enabled or disabled. -A number of functions are provided to assist module authors. +A number of functions are provided to assist module authors. =over 4 @@ -295,7 +297,7 @@ sub bits { $mask |= $DeadBits{$word} if $fatal ; } else - { croak("unknown warnings category '$word'")} + { croak("unknown warnings category '$word'")} } return $mask ; @@ -341,13 +343,13 @@ sub __chk unless defined $offset; } else { - $category = (caller(1))[0] ; + $category = (caller(1))[0] ; $offset = $Offsets{$category}; croak("package '$category' not registered for warnings") unless defined $offset ; } - my $this_pkg = (caller(1))[0] ; + my $this_pkg = (caller(1))[0] ; my $i = 2 ; my $pkg ; @@ -361,11 +363,11 @@ sub __chk for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) { last if $pkg ne $this_pkg ; } - $i = 2 + $i = 2 if !$pkg || $pkg eq $this_pkg ; } - my $callers_bitmask = (caller($i))[9] ; + my $callers_bitmask = (caller($i))[9] ; return ($callers_bitmask, $offset, $i) ; } @@ -390,7 +392,7 @@ sub warn my $message = pop ; my ($callers_bitmask, $offset, $i) = __chk(@_) ; local $Carp::CarpLevel = $i ; - croak($message) + croak($message) if vec($callers_bitmask, $offset+1, 1) || vec($callers_bitmask, $Offsets{'all'}+1, 1) ; carp($message) ; @@ -405,12 +407,12 @@ sub warnif my ($callers_bitmask, $offset, $i) = __chk(@_) ; local $Carp::CarpLevel = $i ; - return + return unless defined $callers_bitmask && (vec($callers_bitmask, $offset, 1) || vec($callers_bitmask, $Offsets{'all'}, 1)) ; - croak($message) + croak($message) if vec($callers_bitmask, $offset+1, 1) || vec($callers_bitmask, $Offsets{'all'}+1, 1) ; diff --git a/lib/warnings/register.pm b/lib/warnings/register.pm index f98075a5ee..d40da36053 100644 --- a/lib/warnings/register.pm +++ b/lib/warnings/register.pm @@ -1,5 +1,7 @@ package warnings::register ; +our $VERSION = '1.00'; + =pod =head1 NAME diff --git a/makedef.pl b/makedef.pl index a02a298213..6a30fc6ee9 100644 --- a/makedef.pl +++ b/makedef.pl @@ -73,7 +73,8 @@ if ($PLATFORM eq 'aix') { } elsif ($PLATFORM eq 'win32') { $CCTYPE = "MSVC" unless defined $CCTYPE; - foreach ($thrdvar_h, $intrpvar_h, $perlvars_h, $global_sym, $pp_sym, $globvar_sym) { + foreach ($thrdvar_h, $intrpvar_h, $perlvars_h, $global_sym, + $pp_sym, $globvar_sym, $perlio_sym) { s!^!..\\!; } } @@ -87,7 +88,7 @@ unless ($PLATFORM eq 'win32') { } if ($PLATFORM eq 'os2') { $CONFIG_ARGS = $1 if /^(?:config_args)='(.+)'$/; - $ARCHNAME = $1 if /^(?:archname)='(.+)'$/; + $ARCHNAME = $1 if /^(?:archname)='(.+)'$/; } } close(CFG); @@ -96,12 +97,9 @@ unless ($PLATFORM eq 'win32') { open(CFG,$config_h) || die "Cannot open $config_h: $!\n"; while (<CFG>) { $define{$1} = 1 if /^\s*#\s*define\s+(MYMALLOC)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(USE_5005THREADS)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(USE_ITHREADS)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(USE_PERLIO)\b/; $define{$1} = 1 if /^\s*#\s*define\s+(MULTIPLICITY)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(PERL_IMPLICIT_SYS)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(PERL_BINCOMPAT_5005)\b/; + $define{$1} = 1 if /^\s*#\s*define\s+(PERL_\w+)\b/; + $define{$1} = 1 if /^\s*#\s*define\s+(USE_\w+)\b/; } close(CFG); @@ -134,7 +132,7 @@ if ($define{PERL_OBJECT}) { if ($PLATFORM eq 'win32') { warn join(' ',keys %define)."\n"; - print "LIBRARY Perl56\n"; + print "LIBRARY Perl57\n"; print "DESCRIPTION 'Perl interpreter'\n"; print "EXPORTS\n"; if ($define{PERL_IMPLICIT_SYS}) { @@ -145,16 +143,7 @@ if ($PLATFORM eq 'win32') { elsif ($PLATFORM eq 'os2') { ($v = $]) =~ s/(\d\.\d\d\d)(\d\d)$/$1_$2/; $v .= '-thread' if $ARCHNAME =~ /-thread/; - #$sum = 0; - #for (split //, $v) { - # $sum = ($sum * 33) + ord; - # $sum &= 0xffffff; - #} - #$sum += $sum >> 5; - #$sum &= 0xffff; - #$sum = printf '%X', $sum; ($dll = $define{PERL_DLL}) =~ s/\.dll$//i; - # print STDERR "'$dll' <= '$define{PERL_DLL}'\n"; print <<"---EOP---"; LIBRARY '$dll' INITINSTANCE TERMINSTANCE DESCRIPTION '\@#perl5-porters\@perl.org:$v#\@ Perl interpreter' @@ -314,7 +303,6 @@ elsif ($PLATFORM eq 'os2') { unless ($define{'DEBUGGING'}) { skip_symbols [qw( - Perl_deb Perl_deb_growlevel Perl_debop Perl_debprofdump @@ -572,6 +560,8 @@ while (<DATA>) { if ($PLATFORM eq 'win32') { foreach my $symbol (qw( + setuid + setgid boot_DynaLoader Perl_init_os_extras Perl_thread_create @@ -579,35 +569,6 @@ if ($PLATFORM eq 'win32') { RunPerl win32_errno win32_environ - win32_stdin - win32_stdout - win32_stderr - win32_ferror - win32_feof - win32_strerror - win32_fprintf - win32_printf - win32_vfprintf - win32_vprintf - win32_fread - win32_fwrite - win32_fopen - win32_fdopen - win32_freopen - win32_fclose - win32_fputs - win32_fputc - win32_ungetc - win32_getc - win32_fileno - win32_clearerr - win32_fflush - win32_ftell - win32_fseek - win32_fgetpos - win32_fsetpos - win32_rewind - win32_tmpfile win32_abort win32_fstat win32_stat @@ -678,17 +639,6 @@ if ($PLATFORM eq 'win32') { win32_getenv win32_putenv win32_perror - win32_setbuf - win32_setvbuf - win32_flushall - win32_fcloseall - win32_fgets - win32_gets - win32_fgetc - win32_putc - win32_puts - win32_getchar - win32_putchar win32_malloc win32_calloc win32_realloc @@ -720,6 +670,47 @@ if ($PLATFORM eq 'win32') { win32_getpid win32_crypt win32_dynaload + + win32_stdin + win32_stdout + win32_stderr + win32_ferror + win32_feof + win32_strerror + win32_fprintf + win32_printf + win32_vfprintf + win32_vprintf + win32_fread + win32_fwrite + win32_fopen + win32_fdopen + win32_freopen + win32_fclose + win32_fputs + win32_fputc + win32_ungetc + win32_getc + win32_fileno + win32_clearerr + win32_fflush + win32_ftell + win32_fseek + win32_fgetpos + win32_fsetpos + win32_rewind + win32_tmpfile + win32_setbuf + win32_setvbuf + win32_flushall + win32_fcloseall + win32_fgets + win32_gets + win32_fgetc + win32_putc + win32_puts + win32_getchar + win32_putchar )) { try_symbol($symbol); @@ -797,3 +788,38 @@ perl_destruct perl_free perl_parse perl_run +PerlIO_define_layer +PerlIOBuf_set_ptrcnt +PerlIOBuf_get_cnt +PerlIOBuf_get_ptr +PerlIOBuf_bufsiz +PerlIOBuf_setlinebuf +PerlIOBase_clearerr +PerlIOBase_error +PerlIOBase_eof +PerlIOBuf_tell +PerlIOBuf_seek +PerlIOBuf_write +PerlIOBuf_unread +PerlIOBuf_read +PerlIOBuf_reopen +PerlIOBuf_open +PerlIOBuf_fdopen +PerlIOBase_fileno +PerlIOBuf_pushed +PerlIOBuf_fill +PerlIOBuf_flush +PerlIOBase_close +PerlIO_define_layer +PerlIO_pending +PerlIO_unread +PerlIO_push +PerlIO_apply_layers +perlsio_binmode +PerlIO_binmode +PerlIO_init +PerlIO_tmpfile +PerlIO_setpos +PerlIO_getpos +PerlIO_vsprintf +PerlIO_sprintf @@ -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 /* <unistd.h> usually takes care of this */ +extern Malloc_t sbrk(int); +# endif +#endif + +#ifdef DEBUGGING_MSTATS +/* + * nmalloc[i] is the difference between the number of mallocs and frees + * for a given block size. + */ +static u_int nmalloc[NBUCKETS]; +static u_int sbrk_slack; +static u_int start_slack; +#else /* !( defined DEBUGGING_MSTATS ) */ +# define sbrk_slack 0 +#endif + +static u_int goodsbrk; + +# ifdef PERL_EMERGENCY_SBRK + +# ifndef BIG_SIZE +# define BIG_SIZE (1<<16) /* 64K */ +# endif + static char *emergency_buffer; static MEM_SIZE emergency_buffer_size; +static int no_mem; /* 0 if the last request for more memory succeeded. + Otherwise the size of the failing request. */ static Malloc_t emergency_sbrk(MEM_SIZE size) { MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<<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); } } @@ -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; @@ -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; @@ -200,7 +192,7 @@ Perl_mg_size(pTHX_ SV *sv) { MAGIC* mg; I32 len; - + for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; if (vtbl && vtbl->svt_len) { @@ -269,6 +261,8 @@ MAGIC* Perl_mg_find(pTHX_ SV *sv, int type) { MAGIC* mg; + if (!sv) + return 0; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { if (mg->mg_type == type) return mg; @@ -339,7 +333,6 @@ Perl_mg_free(pTHX_ SV *sv) U32 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register REGEXP *rx; if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { @@ -348,14 +341,13 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) else /* @- */ return rx->lastparen; } - + return (U32)-1; } int Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register I32 paren; register I32 s; register I32 i; @@ -374,6 +366,11 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) i = t; else /* @- */ i = s; + + if (i > 0 && DO_UTF8(PL_reg_sv)) { + char *b = rx->subbeg; + i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i)); + } sv_setiv(sv,i); } } @@ -383,7 +380,6 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg) { - dTHR; Perl_croak(aTHX_ PL_no_modify); /* NOT REACHED */ return 0; @@ -392,7 +388,6 @@ Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg) U32 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register I32 paren; register I32 i; register REGEXP *rx; @@ -403,7 +398,7 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) case '5': case '6': case '7': case '8': case '9': case '&': if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { - paren = atoi(mg->mg_ptr); + paren = atoi(mg->mg_ptr); /* $& is in [0] */ getparen: if (paren <= rx->nparens && (s1 = rx->startp[paren]) != -1 && @@ -411,17 +406,15 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) { i = t1 - s1; getlen: - if (i > 0 && (PL_curpm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) { - char *s = rx->subbeg + s1; + if (i > 0 && DO_UTF8(PL_reg_sv)) { + char *s = rx->subbeg + s1; char *send = rx->subbeg + t1; - i = 0; - while (s < send) { - s += UTF8SKIP(s); - i++; - } + + i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send); } - if (i >= 0) - return i; + if (i < 0) + Perl_croak(aTHX_ "panic: magic_len: %d", i); + return i; } } return 0; @@ -456,10 +449,6 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) } } return 0; - case ',': - return (STRLEN)PL_ofslen; - case '\\': - return (STRLEN)PL_orslen; } magic_get(sv,mg); if (!SvPOK(sv) && SvNIOK(sv)) { @@ -474,7 +463,6 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register I32 paren; register char *s; register I32 i; @@ -498,7 +486,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) #ifdef MACOS_TRADITIONAL { char msg[256]; - + sv_setnv(sv,(double)gMacPerl_OSErr); sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : ""); } @@ -563,15 +551,22 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) else sv_setsv(sv, &PL_sv_undef); break; - case '\017': /* ^O */ - sv_setpv(sv, PL_osname); + case '\017': /* ^O & ^OPEN */ + if (*(mg->mg_ptr+1) == '\0') + sv_setpv(sv, PL_osname); + else if (strEQ(mg->mg_ptr, "\017PEN")) { + if (!PL_compiling.cop_io) + sv_setsv(sv, &PL_sv_undef); + else { + sv_setsv(sv, PL_compiling.cop_io); + } + } break; case '\020': /* ^P */ sv_setiv(sv, (IV)PL_perldb); break; case '\023': /* ^S */ { - dTHR; if (PL_lex_state != LEX_NOTPARSING) (void)SvOK_off(sv); else if (PL_in_eval) @@ -596,10 +591,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } else if (PL_compiling.cop_warnings == pWARN_ALL) { sv_setpvn(sv, WARN_ALLstring, WARNsize) ; - } + } else { sv_setsv(sv, PL_compiling.cop_warnings); - } + } SvPOK_only(sv); } else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS")) @@ -614,7 +609,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj)); * XXX Does the new way break anything? */ - paren = atoi(mg->mg_ptr); + paren = atoi(mg->mg_ptr); /* $& is in [0] */ getparen: if (paren <= rx->nparens && (s1 = rx->startp[paren]) != -1 && @@ -633,7 +628,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) PL_tainted = FALSE; } sv_setpvn(sv, s, i); - if ((PL_curpm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) + if (DO_UTF8(PL_reg_sv)) SvUTF8_on(sv); else SvUTF8_off(sv); @@ -725,10 +720,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); break; case ',': - sv_setpvn(sv,PL_ofs,PL_ofslen); break; case '\\': - sv_setpvn(sv,PL_ors,PL_orslen); break; case '#': sv_setpv(sv,PL_ofmt); @@ -895,7 +888,6 @@ Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) #if defined(VMS) Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); #else - dTHR; if (PL_localizing) { HE* entry; STRLEN n_a; @@ -936,12 +928,8 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) cur += len+1; } FreeEnvironmentStrings(envv); -# else -# ifdef __CYGWIN__ - I32 i; - for (i = 0; environ[i]; i++) - safesysfree(environ[i]); # else +#ifdef USE_ENVIRON_ARRAY # ifndef PERL_USE_SAFE_PUTENV I32 i; @@ -951,10 +939,10 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) for (i = 0; environ[i]; i++) safesysfree(environ[i]); # endif /* PERL_USE_SAFE_PUTENV */ -# endif /* __CYGWIN__ */ environ[0] = Nullch; +#endif /* USE_ENVIRON_ARRAY */ # endif /* WIN32 */ # endif /* PERL_IMPLICIT_SYS */ #endif /* VMS */ @@ -1009,7 +997,6 @@ Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register char *s; I32 i; SV** svp; @@ -1126,7 +1113,7 @@ Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) hv_ksplit((HV*)LvTARG(sv), SvIV(sv)); } return 0; -} +} /* caller is responsible for stack switching/cleanup */ STATIC int @@ -1137,7 +1124,7 @@ S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val) PUSHMARK(SP); EXTEND(SP, n); PUSHs(SvTIED_obj(sv, mg)); - if (n > 1) { + if (n > 1) { if (mg->mg_ptr) { if (mg->mg_len >= 0) PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len))); @@ -1205,7 +1192,7 @@ Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) U32 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) -{ +{ dSP; U32 retval = 0; @@ -1267,12 +1254,11 @@ int Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg) { return magic_methpack(sv,mg,"EXISTS"); -} +} int Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) { - dTHR; OP *o; I32 i; GV* gv; @@ -1291,7 +1277,6 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg) { - dTHR; sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase); return 0; } @@ -1299,7 +1284,6 @@ Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) { - dTHR; av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase); return 0; } @@ -1308,11 +1292,10 @@ int Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) { SV* lsv = LvTARG(sv); - + if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) { mg = mg_find(lsv, 'g'); if (mg && mg->mg_len >= 0) { - dTHR; I32 i = mg->mg_len; if (DO_UTF8(lsv)) sv_pos_b2u(lsv, &i); @@ -1331,10 +1314,9 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) SSize_t pos; STRLEN len; STRLEN ulen = 0; - dTHR; mg = 0; - + if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) mg = mg_find(lsv, 'g'); if (!mg) { @@ -1435,14 +1417,20 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) { STRLEN len; char *tmps = SvPV(sv,len); - sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len); + if (DO_UTF8(sv)) { + sv_utf8_upgrade(LvTARG(sv)); + sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len); + SvUTF8_on(LvTARG(sv)); + } + else + sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len); + return 0; } int Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) { - dTHR; TAINT_IF((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */ return 0; @@ -1451,7 +1439,6 @@ Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg) { - dTHR; if (PL_localizing) { if (PL_localizing == 1) mg->mg_len <<= 1; @@ -1510,7 +1497,6 @@ Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) targ = AvARRAY(av)[LvTARGOFF(sv)]; } if (targ && targ != &PL_sv_undef) { - dTHR; /* just for SvREFCNT_dec */ /* somebody else defined it for us */ SvREFCNT_dec(LvTARG(sv)); LvTARG(sv) = SvREFCNT_inc(targ); @@ -1541,7 +1527,6 @@ Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg) void Perl_vivify_defelem(pTHX_ SV *sv) { - dTHR; /* just for SvREFCNT_inc and SvREFCNT_dec*/ MAGIC *mg; SV *value = Nullsv; @@ -1665,7 +1650,6 @@ Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register char *s; I32 i; STRLEN len; @@ -1714,12 +1698,20 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_inplace = Nullch; break; case '\017': /* ^O */ - if (PL_osname) - Safefree(PL_osname); - if (SvOK(sv)) - PL_osname = savepv(SvPV(sv,len)); - else - PL_osname = Nullch; + if (*(mg->mg_ptr+1) == '\0') { + if (PL_osname) + Safefree(PL_osname); + if (SvOK(sv)) + PL_osname = savepv(SvPV(sv,len)); + else + PL_osname = Nullch; + } + else if (strEQ(mg->mg_ptr, "\017PEN")) { + if (!PL_compiling.cop_io) + PL_compiling.cop_io = newSVsv(sv); + else + sv_setsv(PL_compiling.cop_io,sv); + } break; case '\020': /* ^P */ PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); @@ -1737,7 +1729,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (*(mg->mg_ptr+1) == '\0') { if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); - PL_dowarn = (PL_dowarn & ~G_WARN_ON) + PL_dowarn = (PL_dowarn & ~G_WARN_ON) | (i ? G_WARN_ON : G_WARN_OFF) ; } } @@ -1833,21 +1825,24 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_rs = SvREFCNT_inc(PL_nrs); break; case '\\': - if (PL_ors) - Safefree(PL_ors); + if (PL_ors_sv) + SvREFCNT_dec(PL_ors_sv); if (SvOK(sv) || SvGMAGICAL(sv)) { - s = SvPV(sv,PL_orslen); - PL_ors = savepvn(s,PL_orslen); + PL_ors_sv = newSVsv(sv); } else { - PL_ors = Nullch; - PL_orslen = 0; + PL_ors_sv = Nullsv; } break; case ',': - if (PL_ofs) - Safefree(PL_ofs); - PL_ofs = savepv(SvPV(sv, PL_ofslen)); + if (PL_ofs_sv) + SvREFCNT_dec(PL_ofs_sv); + if (SvOK(sv) || SvGMAGICAL(sv)) { + PL_ofs_sv = newSVsv(sv); + } + else { + PL_ofs_sv = Nullsv; + } break; case '#': if (PL_ofmt) @@ -2043,7 +2038,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (PL_origargv[i] == s + 1 #ifdef OS2 || PL_origargv[i] == s + 2 -#endif +#endif ) { ++s; @@ -2056,7 +2051,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (PL_origenviron && (PL_origenviron[0] == s + 1 #ifdef OS2 || (PL_origenviron[0] == s + 9 && (s += 8)) -#endif +#endif )) { my_setenv("NoNe SuCh", Nullch); /* force copy of environment */ @@ -2105,7 +2100,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_mutexfree(pTHX_ SV *sv, MAGIC *mg) { - dTHR; DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": magic_mutexfree 0x%"UVxf"\n", PTR2UV(thr), PTR2UV(sv));) @@ -2159,7 +2153,7 @@ Perl_sighandler(int sig) #if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT) PERL_SET_THX(aTHXo); /* fake TLS, see above */ #endif - + if (PL_savestack_ix + 15 <= PL_savestack_max) flags |= 1; if (PL_markstack_ptr < PL_markstack_max - 2) @@ -2180,7 +2174,7 @@ Perl_sighandler(int sig) o_save_i = PL_savestack_ix; SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags); } - if (flags & 4) + if (flags & 4) PL_markstack_ptr++; /* Protect mark. */ if (flags & 8) { PL_retstack_ix++; @@ -2189,7 +2183,7 @@ Perl_sighandler(int sig) if (flags & 16) PL_scopestack_ix += 1; /* sv_2cv is too complicated, try a simpler variant first: */ - if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig])) + if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig])) || SvTYPE(cv) != SVt_PVCV) cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE); @@ -2223,16 +2217,16 @@ Perl_sighandler(int sig) cleanup: if (flags & 1) PL_savestack_ix -= 8; /* Unprotect save in progress. */ - if (flags & 4) + if (flags & 4) PL_markstack_ptr--; - if (flags & 8) + if (flags & 8) PL_retstack_ix--; if (flags & 16) PL_scopestack_ix -= 1; if (flags & 64) SvREFCNT_dec(sv); PL_op = myop; /* Apparently not needed... */ - + PL_Sv = tSv; /* Restore global temporaries. */ PL_Xpv = tXpv; return; @@ -2246,7 +2240,6 @@ cleanup: static void restore_magic(pTHXo_ void *p) { - dTHR; MGS* mgs = SSPTR(PTR2IV(p), MGS*); SV* sv = mgs->mgs_sv; @@ -2288,7 +2281,6 @@ restore_magic(pTHXo_ void *p) static void unwind_handler_stack(pTHXo_ void *p) { - dTHR; U32 flags = *(U32*)p; if (flags & 1) @@ -1,6 +1,6 @@ /* mg.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. diff --git a/minimod.pl b/minimod.pl index 8efbd31ffc..18b9c0748c 100644 --- a/minimod.pl +++ b/minimod.pl @@ -59,7 +59,7 @@ sub writemain{ my($mname, $cname); ($mname = $pname) =~ s!/!::!g; ($cname = $pname) =~ s!/!__!g; - print "EXTERN_C void boot_${cname} (CV* cv);\n"; + print "EXTERN_C void boot_${cname} (pTHX_ CV* cv);\n"; } my ($tail1,$tail2) = ( $tail =~ /\A(.*\n)(\s*\}.*)\Z/s ); @@ -1,8 +1,13 @@ -/* This is an 1st attempt to stop other include files pulling +/* + * Strong denial of stdio - make all stdio calls (we can think of) errors + */ +/* This is an 1st attempt to stop other include files pulling in real <stdio.h>. A more ambitious set of possible symbols can be found in sfio.h (inside an _cplusplus gard). + It is completely pointless as we have already included it ourselves. */ + #if !defined(_STDIO_H) && !defined(FILE) && !defined(_STDIO_INCLUDED) && !defined(__STDIO_LOADED) #define _STDIO_H #define _STDIO_INCLUDED @@ -13,14 +18,98 @@ struct _FILE; #define _CANNOT "CANNOT" -#undef stdin -#undef stdout -#undef stderr -#undef getc -#undef putc #undef clearerr -#undef fflush +#undef fclose +#undef fdopen #undef feof #undef ferror +#undef fflush +#undef fgetc +#undef fgetpos +#undef fgets #undef fileno +#undef flockfile +#undef fopen +#undef fprintf +#undef fputc +#undef fputs +#undef fread +#undef freopen +#undef fscanf +#undef fseek +#undef fsetpos +#undef ftell +#undef ftrylockfile +#undef funlockfile +#undef fwrite +#undef getc +#undef getc_unlocked +#undef getw +#undef pclose +#undef popen +#undef putc +#undef putc_unlocked +#undef putw +#undef rewind +#undef setbuf +#undef setvbuf +#undef stderr +#undef stdin +#undef stdout +#undef tmpfile +#undef ungetc +#undef vfprintf +#define fprintf _CANNOT _fprintf_ +#define stdin _CANNOT _stdin_ +#define stdout _CANNOT _stdout_ +#define stderr _CANNOT _stderr_ +#ifndef OS2 +#define tmpfile() _CANNOT _tmpfile_ +#endif +#define fclose(f) _CANNOT _fclose_ +#define fflush(f) _CANNOT _fflush_ +#define fopen(p,m) _CANNOT _fopen_ +#define freopen(p,m,f) _CANNOT _freopen_ +#define setbuf(f,b) _CANNOT _setbuf_ +#define setvbuf(f,b,x,s) _CANNOT _setvbuf_ +#define fscanf _CANNOT _fscanf_ +#define vfprintf(f,fmt,a) _CANNOT _vfprintf_ +#define fgetc(f) _CANNOT _fgetc_ +#define fgets(s,n,f) _CANNOT _fgets_ +#define fputc(c,f) _CANNOT _fputc_ +#define fputs(s,f) _CANNOT _fputs_ +#define getc(f) _CANNOT _getc_ +#define putc(c,f) _CANNOT _putc_ +#ifndef OS2 +#define ungetc(c,f) _CANNOT _ungetc_ +#endif +#define fread(b,s,c,f) _CANNOT _fread_ +#define fwrite(b,s,c,f) _CANNOT _fwrite_ +#define fgetpos(f,p) _CANNOT _fgetpos_ +#define fseek(f,o,w) _CANNOT _fseek_ +#define fsetpos(f,p) _CANNOT _fsetpos_ +#define ftell(f) _CANNOT _ftell_ +#define rewind(f) _CANNOT _rewind_ +#define clearerr(f) _CANNOT _clearerr_ +#define feof(f) _CANNOT _feof_ +#define ferror(f) _CANNOT _ferror_ +#define __filbuf(f) _CANNOT __filbuf_ +#define __flsbuf(c,f) _CANNOT __flsbuf_ +#define _filbuf(f) _CANNOT _filbuf_ +#define _flsbuf(c,f) _CANNOT _flsbuf_ +#define fdopen(fd,p) _CANNOT _fdopen_ +#define fileno(f) _CANNOT _fileno_ +#if SFIO_VERSION < 20000101L +#define flockfile(f) _CANNOT _flockfile_ +#define ftrylockfile(f) _CANNOT _ftrylockfile_ +#define funlockfile(f) _CANNOT _funlockfile_ +#endif +#define getc_unlocked(f) _CANNOT _getc_unlocked_ +#define putc_unlocked(c,f) _CANNOT _putc_unlocked_ +#define popen(c,m) _CANNOT _popen_ +#define getw(f) _CANNOT _getw_ +#define putw(v,f) _CANNOT _putw_ +#ifndef OS2 +#define pclose(f) _CANNOT _pclose_ +#endif @@ -35,6 +35,10 @@ #define Perl_Gv_AMupdate pPerl->Perl_Gv_AMupdate #undef Gv_AMupdate #define Gv_AMupdate Perl_Gv_AMupdate +#undef Perl_gv_handler +#define Perl_gv_handler pPerl->Perl_gv_handler +#undef gv_handler +#define gv_handler Perl_gv_handler #undef Perl_apply_attrs_string #define Perl_apply_attrs_string pPerl->Perl_apply_attrs_string #undef apply_attrs_string @@ -1259,6 +1263,10 @@ #define Perl_regdump pPerl->Perl_regdump #undef regdump #define regdump Perl_regdump +#undef Perl_regclass_swash +#define Perl_regclass_swash pPerl->Perl_regclass_swash +#undef regclass_swash +#define regclass_swash Perl_regclass_swash #undef Perl_pregexec #define Perl_pregexec pPerl->Perl_pregexec #undef pregexec @@ -1433,6 +1441,10 @@ #define Perl_save_re_context pPerl->Perl_save_re_context #undef save_re_context #define save_re_context Perl_save_re_context +#undef Perl_save_padsv +#define Perl_save_padsv pPerl->Perl_save_padsv +#undef save_padsv +#define save_padsv Perl_save_padsv #undef Perl_save_sptr #define Perl_save_sptr pPerl->Perl_save_sptr #undef save_sptr @@ -1777,6 +1789,10 @@ #define Perl_sv_unref pPerl->Perl_sv_unref #undef sv_unref #define sv_unref Perl_sv_unref +#undef Perl_sv_unref_flags +#define Perl_sv_unref_flags pPerl->Perl_sv_unref_flags +#undef sv_unref_flags +#define sv_unref_flags Perl_sv_unref_flags #undef Perl_sv_untaint #define Perl_sv_untaint pPerl->Perl_sv_untaint #undef sv_untaint @@ -1853,6 +1869,10 @@ #define Perl_utf16_to_utf8_reversed pPerl->Perl_utf16_to_utf8_reversed #undef utf16_to_utf8_reversed #define utf16_to_utf8_reversed Perl_utf16_to_utf8_reversed +#undef Perl_utf8_length +#define Perl_utf8_length pPerl->Perl_utf8_length +#undef utf8_length +#define utf8_length Perl_utf8_length #undef Perl_utf8_distance #define Perl_utf8_distance pPerl->Perl_utf8_distance #undef utf8_distance @@ -1869,14 +1889,14 @@ #define Perl_bytes_to_utf8 pPerl->Perl_bytes_to_utf8 #undef bytes_to_utf8 #define bytes_to_utf8 Perl_bytes_to_utf8 +#undef Perl_utf8_to_uv_simple +#define Perl_utf8_to_uv_simple pPerl->Perl_utf8_to_uv_simple +#undef utf8_to_uv_simple +#define utf8_to_uv_simple Perl_utf8_to_uv_simple #undef Perl_utf8_to_uv #define Perl_utf8_to_uv pPerl->Perl_utf8_to_uv #undef utf8_to_uv #define utf8_to_uv Perl_utf8_to_uv -#undef Perl_utf8_to_uv_chk -#define Perl_utf8_to_uv_chk pPerl->Perl_utf8_to_uv_chk -#undef utf8_to_uv_chk -#define utf8_to_uv_chk Perl_utf8_to_uv_chk #undef Perl_uv_to_utf8 #define Perl_uv_to_utf8 pPerl->Perl_uv_to_utf8 #undef uv_to_utf8 @@ -1901,7 +1921,7 @@ #define Perl_whichsig pPerl->Perl_whichsig #undef whichsig #define whichsig Perl_whichsig -#if defined(USE_PURE_BISON) +#ifdef USE_PURE_BISON #else #endif #if defined(MYMALLOC) @@ -2130,6 +2150,10 @@ #define Perl_sv_force_normal pPerl->Perl_sv_force_normal #undef sv_force_normal #define sv_force_normal Perl_sv_force_normal +#undef Perl_sv_force_normal_flags +#define Perl_sv_force_normal_flags pPerl->Perl_sv_force_normal_flags +#undef sv_force_normal_flags +#define sv_force_normal_flags Perl_sv_force_normal_flags #undef Perl_tmps_grow #define Perl_tmps_grow pPerl->Perl_tmps_grow #undef tmps_grow @@ -2276,6 +2300,8 @@ #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) # if defined(DEBUGGING) # endif +# if !defined(NV_PRESERVES_UV) +# endif #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #if 0 @@ -1,6 +1,6 @@ /* op.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -107,13 +107,12 @@ S_no_bareword_allowed(pTHX_ OP *o) PADOFFSET Perl_pad_allocmy(pTHX_ char *name) { - dTHR; PADOFFSET off; SV *sv; if (!(PL_in_my == KEY_our || isALPHA(name[1]) || - (PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) || + (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) || (name[1] == '_' && (int)strlen(name) > 2))) { if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { @@ -238,7 +237,6 @@ STATIC PADOFFSET S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval, U32 flags) { - dTHR; CV *cv; I32 off; SV *sv; @@ -385,7 +383,6 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, PADOFFSET Perl_pad_findmy(pTHX_ char *name) { - dTHR; I32 off; I32 pendoff = 0; SV *sv; @@ -448,7 +445,6 @@ Perl_pad_findmy(pTHX_ char *name) void Perl_pad_leavemy(pTHX_ I32 fill) { - dTHR; I32 off; SV **svp = AvARRAY(PL_comppad_name); SV *sv; @@ -468,7 +464,6 @@ Perl_pad_leavemy(pTHX_ I32 fill) PADOFFSET Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) { - dTHR; SV *sv; I32 retval; @@ -520,7 +515,6 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) SV * Perl_pad_sv(pTHX_ PADOFFSET po) { - dTHR; #ifdef USE_THREADS DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n", @@ -537,7 +531,6 @@ Perl_pad_sv(pTHX_ PADOFFSET po) void Perl_pad_free(pTHX_ PADOFFSET po) { - dTHR; if (!PL_curpad) return; if (AvARRAY(PL_comppad) != PL_curpad) @@ -565,7 +558,6 @@ Perl_pad_free(pTHX_ PADOFFSET po) void Perl_pad_swipe(pTHX_ PADOFFSET po) { - dTHR; if (AvARRAY(PL_comppad) != PL_curpad) Perl_croak(aTHX_ "panic: pad_swipe curpad"); if (!po) @@ -595,7 +587,6 @@ void Perl_pad_reset(pTHX) { #ifdef USE_BROKEN_PAD_RESET - dTHR; register I32 po; if (AvARRAY(PL_comppad) != PL_curpad) @@ -624,7 +615,6 @@ Perl_pad_reset(pTHX) PADOFFSET Perl_find_threadsv(pTHX_ const char *name) { - dTHR; char *p; PADOFFSET key; SV **svp; @@ -853,6 +843,8 @@ S_cop_free(pTHX_ COP* cop) #endif if (! specialWARN(cop->cop_warnings)) SvREFCNT_dec(cop->cop_warnings); + if (! specialCopIO(cop->cop_io)) + SvREFCNT_dec(cop->cop_io); } STATIC void @@ -909,7 +901,6 @@ STATIC OP * S_scalarboolean(pTHX_ OP *o) { if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { - dTHR; if (ckWARN(WARN_SYNTAX)) { line_t oldline = CopLINE(PL_curcop); @@ -1005,10 +996,7 @@ Perl_scalarvoid(pTHX_ OP *o) || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_SETSTATE || o->op_targ == OP_DBSTATE))) - { - dTHR; PL_curcop = (COP*)o; /* for warning below */ - } /* assumes no premature commitment */ want = o->op_flags & OPf_WANT; @@ -1125,12 +1113,17 @@ Perl_scalarvoid(pTHX_ OP *o) if (cSVOPo->op_private & OPpCONST_STRICT) no_bareword_allowed(o); else { - dTHR; if (ckWARN(WARN_VOID)) { useless = "a constant"; if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) useless = 0; else if (SvPOK(sv)) { + /* perl4's way of mixing documentation and code + (before the invention of POD) was based on a + trick to mix nroff and perl code. The trick was + built upon these three nroff macros being used in + void context. The pink camel has the details in + the script wrapman near page 319. */ if (strnEQ(SvPVX(sv), "di", 2) || strnEQ(SvPVX(sv), "ds", 2) || strnEQ(SvPVX(sv), "ig", 2)) @@ -1194,11 +1187,8 @@ Perl_scalarvoid(pTHX_ OP *o) } break; } - if (useless) { - dTHR; - if (ckWARN(WARN_VOID)) - Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless); - } + if (useless && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless); return o; } @@ -1299,7 +1289,6 @@ Perl_scalarseq(pTHX_ OP *o) o->op_type == OP_LEAVE || o->op_type == OP_LEAVETRY) { - dTHR; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) { scalarvoid(kid); @@ -1330,7 +1319,6 @@ S_modkids(pTHX_ OP *o, I32 type) OP * Perl_mod(pTHX_ OP *o, I32 type) { - dTHR; OP *kid; STRLEN n_a; @@ -1348,6 +1336,31 @@ Perl_mod(pTHX_ OP *o, I32 type) PL_modcount++; return o; case OP_CONST: + if (o->op_private & (OPpCONST_BARE) && + !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) { + SV *sv = ((SVOP*)o)->op_sv; + GV *gv; + + /* Could be a filehandle */ + if (gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO)) { + OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv)); + op_free(o); + o = gvio; + } else { + /* OK, it's a sub */ + OP* enter; + gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV); + + enter = newUNOP(OP_ENTERSUB,0, + newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, gv) + )); + enter->op_private |= OPpLVAL_INTRO; + op_free(o); + o = enter; + } + break; + } if (!(o->op_private & (OPpCONST_ARYBASE))) goto nomod; if (PL_eval_start && PL_eval_start->op_type == OP_CONST) { @@ -1965,7 +1978,6 @@ Perl_sawparens(pTHX_ OP *o) OP * Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) { - dTHR; OP *o; if (ckWARN(WARN_MISC) && @@ -2052,7 +2064,6 @@ Perl_save_hints(pTHX) int Perl_block_start(pTHX_ int full) { - dTHR; int retval = PL_savestack_ix; SAVEI32(PL_comppad_name_floor); @@ -2075,13 +2086,17 @@ Perl_block_start(pTHX_ int full) PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; SAVEFREESV(PL_compiling.cop_warnings) ; } + SAVESPTR(PL_compiling.cop_io); + if (! specialCopIO(PL_compiling.cop_io)) { + PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ; + SAVEFREESV(PL_compiling.cop_io) ; + } return retval; } OP* Perl_block_end(pTHX_ I32 floor, OP *seq) { - dTHR; int needblockscope = PL_hints & HINT_BLOCK_SCOPE; OP* retval = scalarseq(seq); LEAVE_SCOPE(floor); @@ -2109,7 +2124,6 @@ S_newDEFSVOP(pTHX) void Perl_newPROG(pTHX_ OP *o) { - dTHR; if (PL_in_eval) { if (PL_eval_root) return; @@ -2154,10 +2168,9 @@ Perl_localize(pTHX_ OP *o, I32 lex) if (o->op_flags & OPf_PARENS) list(o); else { - dTHR; if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') { char *s; - for (s = PL_bufptr; *s && (isALNUM(*s) || (*s & 0x80) || strchr("@$%, ",*s)); s++) ; + for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ; if (*s == ';' || *s == '=') Perl_warner(aTHX_ WARN_PARENTHESIS, "Parentheses missing around \"%s\" list", @@ -2192,7 +2205,6 @@ Perl_jmaybe(pTHX_ OP *o) OP * Perl_fold_constants(pTHX_ register OP *o) { - dTHR; register OP *curop; I32 type = o->op_type; SV *sv; @@ -2268,13 +2280,11 @@ Perl_fold_constants(pTHX_ register OP *o) if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK && type != OP_NEGATE) { - IV iv = SvIV(sv); - if ((NV)iv == SvNV(sv)) { - SvREFCNT_dec(sv); - sv = newSViv(iv); - } - else - SvIOK_off(sv); /* undo SvIV() damage */ +#ifdef PERL_PRESERVE_IVUV + /* Only bother to attempt to fold to IV if + most operators will benefit */ + SvIV_please(sv); +#endif } return newSVOP(OP_CONST, 0, sv); } @@ -2310,7 +2320,6 @@ Perl_fold_constants(pTHX_ register OP *o) OP * Perl_gen_constant_list(pTHX_ register OP *o) { - dTHR; register OP *curop; I32 oldtmps_floor = PL_tmps_floor; @@ -2437,6 +2446,8 @@ Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) if (type == OP_LIST) { /* already a PUSHMARK there */ first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; ((LISTOP*)last)->op_first->op_sibling = first; + if (!(first->op_flags & OPf_PARENS)) + last->op_flags &= ~OPf_PARENS; } else { if (!(last->op_flags & OPf_KIDS)) { @@ -2621,7 +2632,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) SV* transv = 0; U8* tend = t + tlen; U8* rend = r + rlen; - I32 ulen; + STRLEN ulen; U32 tfirst = 1; U32 tlast = 0; I32 tdiff; @@ -2639,8 +2650,9 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) I32 to_utf = o->op_private & OPpTRANS_TO_UTF; if (complement) { - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; U8** cp; + I32* cl; UV nextmin = 0; New(1109, cp, tlen, U8*); i = 0; @@ -2656,7 +2668,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) qsort(cp, i, sizeof(U8*), utf8compare); for (j = 0; j < i; j++) { U8 *s = cp[j]; - UV val = utf8_to_uv_chk(s, &ulen, 0); + I32 cur = j < i ? cp[j+1] - s : tend - s; + UV val = utf8_to_uv(s, cur, &ulen, 0); s += ulen; diff = val - nextmin; if (diff > 0) { @@ -2669,7 +2682,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } } if (*s == 0xff) - val = utf8_to_uv_chk(s+1, &ulen, 0); + val = utf8_to_uv(s+1, cur - 1, &ulen, 0); if (val >= nextmin) nextmin = val + 1; } @@ -2696,10 +2709,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) while (t < tend || tfirst <= tlast) { /* see if we need more "t" chars */ if (tfirst > tlast) { - tfirst = (I32)utf8_to_uv_chk(t, &ulen, 0); + tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0); t += ulen; if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */ - tlast = (I32)utf8_to_uv_chk(++t, &ulen, 0); + t++; + tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0); t += ulen; } else @@ -2709,10 +2723,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) /* now see if we need more "r" chars */ if (rfirst > rlast) { if (r < rend) { - rfirst = (I32)utf8_to_uv_chk(r, &ulen, 0); + rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0); r += ulen; if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */ - rlast = (I32)utf8_to_uv_chk(++r, &ulen, 0); + r++; + rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0); r += ulen; } else @@ -2850,7 +2865,6 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) OP * Perl_newPMOP(pTHX_ I32 type, I32 flags) { - dTHR; PMOP *pmop; NewOp(1101, pmop, 1, PMOP); @@ -2877,7 +2891,6 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) OP * Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) { - dTHR; PMOP *pm; LOGOP *rcop; I32 repl_has_vars = 0; @@ -2897,7 +2910,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) p = SvPV(pat, plen); pm->op_pmflags |= PMf_SKIPWHITE; } - if ((PL_hints & HINT_UTF8) || (SvUTF8(pat) && !(PL_hints & HINT_BYTE))) + if ((PL_hints & HINT_UTF8) || DO_UTF8(pat)) pm->op_pmdynflags |= PMdf_UTF8; pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm); if (strEQ("\\s+", pm->op_pmregexp->precomp)) @@ -3068,7 +3081,6 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) { - dTHR; #ifdef USE_ITHREADS GvIN_PAD_on(gv); return newPADOP(type, flags, SvREFCNT_inc(gv)); @@ -3097,7 +3109,6 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) void Perl_package(pTHX_ OP *o) { - dTHR; SV *sv; save_hptr(&PL_curstash); @@ -3359,7 +3370,6 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } if (list_assignment(left)) { - dTHR; OP *curop; PL_modcount = 0; @@ -3500,7 +3510,6 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) OP * Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) { - dTHR; U32 seq = intro_my(); register COP *cop; @@ -3531,6 +3540,10 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->cop_warnings = PL_curcop->cop_warnings ; else cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ; + if (specialCopIO(PL_curcop->cop_io)) + cop->cop_io = PL_curcop->cop_io; + else + cop->cop_io = newSVsv(PL_curcop->cop_io) ; if (PL_copline == NOLINE) @@ -3589,7 +3602,6 @@ Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) STATIC OP * S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) { - dTHR; LOGOP *logop; OP *o; OP *first = *firstp; @@ -3701,7 +3713,6 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) OP * Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) { - dTHR; LOGOP *logop; OP *start; OP *o; @@ -3755,7 +3766,6 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) OP * Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) { - dTHR; LOGOP *range; OP *flip; OP *flop; @@ -3802,7 +3812,6 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) OP * Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) { - dTHR; OP* listop; OP* o; int once = block && block->op_flags & OPf_SPECIAL && @@ -3858,7 +3867,6 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) OP * Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont) { - dTHR; OP *redo; OP *next = 0; OP *listop; @@ -3899,7 +3907,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * if (cont) { next = LINKLIST(cont); - loopflags |= OPpLOOP_CONTINUE; } if (expr) { OP *unstack = newOP(OP_UNSTACK, 0); @@ -4052,7 +4059,6 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo OP* Perl_newLOOPEX(pTHX_ I32 type, OP *label) { - dTHR; OP *o; STRLEN n_a; @@ -4079,7 +4085,6 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) void Perl_cv_undef(pTHX_ CV *cv) { - dTHR; #ifdef USE_THREADS if (CvMUTEXP(cv)) { MUTEX_DESTROY(CvMUTEXP(cv)); @@ -4112,6 +4117,10 @@ Perl_cv_undef(pTHX_ CV *cv) CvGV(cv) = Nullgv; SvREFCNT_dec(CvOUTSIDE(cv)); CvOUTSIDE(cv) = Nullcv; + if (CvCONST(cv)) { + SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); + CvCONST_off(cv); + } if (CvPADLIST(cv)) { /* may be during global destruction */ if (SvREFCNT(CvPADLIST(cv))) { @@ -4185,7 +4194,6 @@ S_cv_dump(pTHX_ CV *cv) STATIC CV * S_cv_clone2(pTHX_ CV *proto, CV *outside) { - dTHR; AV* av; I32 ix; AV* protopadlist = CvPADLIST(proto); @@ -4312,6 +4320,15 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) #endif LEAVE; + + if (CvCONST(cv)) { + SV* const_sv = op_const_sv(CvSTART(cv), cv); + assert(const_sv); + /* constant sub () { $x } closing over $x - see lib/constant.pm */ + SvREFCNT_dec(cv); + cv = newCONSTSUB(CvSTASH(proto), 0, const_sv); + } + return cv; } @@ -4328,8 +4345,6 @@ Perl_cv_clone(pTHX_ CV *proto) void Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) { - dTHR; - if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { SV* msg = sv_newmortal(); SV* name = Nullsv; @@ -4350,12 +4365,25 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) } } +static void const_sv_xsub(pTHXo_ CV* cv); + +/* +=for apidoc cv_const_sv + +If C<cv> is a constant sub eligible for inlining. returns the constant +value returned by the sub. Otherwise, returns NULL. + +Constant subs can be created with C<newCONSTSUB> or as described in +L<perlsub/"Constant Functions">. + +=cut +*/ SV * Perl_cv_const_sv(pTHX_ CV *cv) { - if (!cv || !SvPOK(cv) || SvCUR(cv)) + if (!cv || !CvCONST(cv)) return Nullsv; - return op_const_sv(CvSTART(cv), cv); + return (SV*)CvXSUBANY(cv).any_ptr; } SV * @@ -4374,8 +4402,12 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv) if (sv && o->op_next == o) return sv; - if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK) - continue; + if (o->op_next != o) { + if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK) + continue; + if (type == OP_DBSTATE) + continue; + } if (type == OP_LEAVESUB || type == OP_RETURN) break; if (sv) @@ -4385,7 +4417,17 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv) else if ((type == OP_PADSV || type == OP_CONST) && cv) { AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]); sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv; - if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1)) + if (!sv) + return Nullsv; + if (CvCONST(cv)) { + /* We get here only from cv_clone2() while creating a closure. + Copy the const value here instead of in cv_clone2 so that + SvREADONLY_on doesn't lead to problems when leaving + scope. + */ + sv = newSVsv(sv); + } + if (!SvREADONLY(sv) && SvREFCNT(sv) > 1) return Nullsv; } else @@ -4419,7 +4461,6 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) CV * Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { - dTHR; STRLEN n_a; char *name; char *aname; @@ -4427,6 +4468,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch; register CV *cv=0; I32 ix; + SV *const_sv; name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch; if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) { @@ -4465,12 +4507,17 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) SvREFCNT_dec(PL_compcv); cv = PL_compcv = NULL; PL_sub_generation++; - goto noblock; + goto done; } - if (!name || GvCVGEN(gv)) - cv = Nullcv; - else if ((cv = GvCV(gv))) { + cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv); + + if (!block || !ps || *ps || attrs) + const_sv = Nullsv; + else + const_sv = op_const_sv(block, Nullcv); + + if (cv) { bool exists = CvROOT(cv) || CvXSUB(cv); /* if the subroutine doesn't exist and wasn't pre-declared * with a prototype, assume it will be AUTOLOADed, @@ -4480,8 +4527,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) cv_ckproto(cv, gv, ps); /* already defined (or promised)? */ if (exists || GvASSUMECV(gv)) { - SV* const_sv; - bool const_changed = TRUE; if (!block && !attrs) { /* just a "sub foo;" when &foo is already defined */ SAVEFREESV(PL_compcv); @@ -4490,24 +4535,42 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) /* ahem, death to those who redefine active sort subs */ if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv)) Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name); - if (!block) - goto withattrs; - if ((const_sv = cv_const_sv(cv))) - const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv)); - if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE)) - { - line_t oldline = CopLINE(PL_curcop); - CopLINE_set(PL_curcop, PL_copline); - Perl_warner(aTHX_ WARN_REDEFINE, - const_sv ? "Constant subroutine %s redefined" - : "Subroutine %s redefined", name); - CopLINE_set(PL_curcop, oldline); + if (block) { + if (ckWARN(WARN_REDEFINE) + || (CvCONST(cv) + && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv)))) + { + line_t oldline = CopLINE(PL_curcop); + CopLINE_set(PL_curcop, PL_copline); + Perl_warner(aTHX_ WARN_REDEFINE, + CvCONST(cv) ? "Constant subroutine %s redefined" + : "Subroutine %s redefined", name); + CopLINE_set(PL_curcop, oldline); + } + SvREFCNT_dec(cv); + cv = Nullcv; } - SvREFCNT_dec(cv); - cv = Nullcv; } } - withattrs: + if (const_sv) { + SvREFCNT_inc(const_sv); + if (cv) { + assert(!CvROOT(cv) && !CvCONST(cv)); + sv_setpv((SV*)cv, ""); /* prototype is "" */ + CvXSUBANY(cv).any_ptr = const_sv; + CvXSUB(cv) = const_sv_xsub; + CvCONST_on(cv); + } + else { + GvCV(gv) = Nullcv; + cv = newCONSTSUB(NULL, name, const_sv); + } + op_free(block); + SvREFCNT_dec(PL_compcv); + PL_compcv = NULL; + PL_sub_generation++; + goto done; + } if (attrs) { HV *stash; SV *rcv; @@ -4591,12 +4654,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } } - if (!block) { - noblock: - PL_copline = NOLINE; - LEAVE_SCOPE(floor); - return cv; - } + if (!block) + goto done; if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad)) av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv); @@ -4635,6 +4694,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PL_curpad[ix] = Nullsv; } } + assert(!CvCONST(cv)); + if (ps && !*ps && op_const_sv(block, cv)) + CvCONST_on(cv); } else { AV *av = newAV(); /* Will be @_ */ @@ -4750,10 +4812,10 @@ eligible for inlining at compile-time. =cut */ -void +CV * Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) { - dTHR; + CV* cv; ENTER; @@ -4774,15 +4836,14 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) #endif } - newATTRSUB( - start_subparse(FALSE, 0), - newSVOP(OP_CONST, 0, newSVpv(name,0)), - newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ - Nullop, - newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) - ); + cv = newXS(name, const_sv_xsub, __FILE__); + CvXSUBANY(cv).any_ptr = sv; + CvCONST_on(cv); + sv_setpv((SV*)cv, ""); /* prototype is "" */ LEAVE; + + return cv; } /* @@ -4796,7 +4857,6 @@ Used by C<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; @@ -4814,7 +4874,10 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) line_t oldline = CopLINE(PL_curcop); if (PL_copline != NOLINE) CopLINE_set(PL_curcop, PL_copline); - Perl_warner(aTHX_ WARN_REDEFINE, "Subroutine %s redefined",name); + Perl_warner(aTHX_ WARN_REDEFINE, + CvCONST(cv) ? "Constant subroutine %s redefined" + : "Subroutine %s redefined" + ,name); CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); @@ -4895,7 +4958,6 @@ done: void Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) { - dTHR; register CV *cv; char *name; GV *gv; @@ -4993,8 +5055,6 @@ Perl_oopsAV(pTHX_ OP *o) OP * Perl_oopsHV(pTHX_ OP *o) { - dTHR; - switch (o->op_type) { case OP_PADSV: case OP_PADAV: @@ -5291,7 +5351,6 @@ Perl_ck_gvconst(pTHX_ register OP *o) OP * Perl_ck_rvconst(pTHX_ register OP *o) { - dTHR; SVOP *kid = (SVOP*)cUNOPo->op_first; o->op_private |= (PL_hints & HINT_STRICT_REFS); @@ -5392,6 +5451,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) #else kid->op_sv = SvREFCNT_inc(gv); #endif + kid->op_private = 0; kid->op_ppaddr = PL_ppaddr[OP_GV]; } } @@ -5401,7 +5461,6 @@ Perl_ck_rvconst(pTHX_ register OP *o) OP * Perl_ck_ftst(pTHX_ OP *o) { - dTHR; I32 type = o->op_type; if (o->op_flags & OPf_REF) { @@ -5439,7 +5498,6 @@ Perl_ck_ftst(pTHX_ OP *o) OP * Perl_ck_fun(pTHX_ OP *o) { - dTHR; register OP *kid; OP **tokid; OP *sibl; @@ -5764,7 +5822,6 @@ Perl_ck_lfun(pTHX_ OP *o) OP * Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ { - dTHR; if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) { switch (cUNOPo->op_first->op_type) { case OP_RV2AV: @@ -6135,7 +6192,6 @@ Perl_ck_sort(pTHX_ OP *o) STATIC void S_simplify_sort(pTHX_ OP *o) { - dTHR; register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ OP *k; int reversed; @@ -6269,7 +6325,6 @@ Perl_ck_join(pTHX_ OP *o) OP * Perl_ck_subr(pTHX_ OP *o) { - dTHR; OP *prev = ((cUNOPo->op_first->op_sibling) ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first; OP *o2 = prev->op_sibling; @@ -6484,7 +6539,6 @@ Perl_ck_substr(pTHX_ OP *o) void Perl_peep(pTHX_ register OP *o) { - dTHR; register OP* oldop = 0; STRLEN n_a; OP *last_composite = Nullop; @@ -6520,7 +6574,7 @@ Perl_peep(pTHX_ register OP *o) PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP); if (SvPADTMP(cSVOPo->op_sv)) { /* If op_sv is already a PADTMP then it is being used by - * another pad, so make a copy. */ + * some pad, so make a copy. */ sv_setsv(PL_curpad[ix],cSVOPo->op_sv); SvREADONLY_on(PL_curpad[ix]); SvREFCNT_dec(cSVOPo->op_sv); @@ -6529,6 +6583,8 @@ Perl_peep(pTHX_ register OP *o) SvREFCNT_dec(PL_curpad[ix]); SvPADTMP_on(cSVOPo->op_sv); PL_curpad[ix] = cSVOPo->op_sv; + /* XXX I don't know how this isn't readonly already. */ + SvREADONLY_on(PL_curpad[ix]); } cSVOPo->op_sv = Nullsv; o->op_targ = ix; @@ -6646,8 +6702,14 @@ Perl_peep(pTHX_ register OP *o) case OP_ENTERLOOP: o->op_seq = PL_op_seqmax++; + while (cLOOP->op_redoop->op_type == OP_NULL) + cLOOP->op_redoop = cLOOP->op_redoop->op_next; peep(cLOOP->op_redoop); + while (cLOOP->op_nextop->op_type == OP_NULL) + cLOOP->op_nextop = cLOOP->op_nextop->op_next; peep(cLOOP->op_nextop); + while (cLOOP->op_lastop->op_type == OP_NULL) + cLOOP->op_lastop = cLOOP->op_lastop->op_next; peep(cLOOP->op_lastop); break; @@ -6655,6 +6717,9 @@ Perl_peep(pTHX_ register OP *o) case OP_MATCH: case OP_SUBST: o->op_seq = PL_op_seqmax++; + while (cPMOP->op_pmreplstart && + cPMOP->op_pmreplstart->op_type == OP_NULL) + cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next; peep(cPMOP->op_pmreplstart); break; @@ -6696,6 +6761,8 @@ Perl_peep(pTHX_ register OP *o) svp = cSVOPx_svp(((BINOP*)o)->op_last); if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) { key = SvPV(sv, keylen); + if (SvUTF8(sv)) + keylen = -keylen; lexname = newSVpvn_share(key, keylen, 0); SvREFCNT_dec(sv); *svp = lexname; @@ -6714,6 +6781,8 @@ Perl_peep(pTHX_ register OP *o) if (!fields || !GvHV(*fields)) break; key = SvPV(*svp, keylen); + if (SvUTF8(*svp)) + keylen = -keylen; indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); if (!indsvp) { Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s", @@ -6779,6 +6848,8 @@ Perl_peep(pTHX_ register OP *o) key_op = (SVOP*)key_op->op_sibling) { svp = cSVOPx_svp(key_op); key = SvPV(*svp, keylen); + if (SvUTF8(*svp)) + keylen = -keylen; indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); if (!indsvp) { Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" " @@ -6843,3 +6914,15 @@ Perl_peep(pTHX_ register OP *o) } LEAVE; } + +#include "XSUB.h" + +/* Efficient sub that returns a constant scalar value. */ +static void +const_sv_xsub(pTHXo_ CV* cv) +{ + dXSARGS; + EXTEND(sp, 1); + ST(0) = (SV*)XSANY.any_ptr; + XSRETURN(1); +} @@ -1,6 +1,6 @@ /* op.h * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -139,9 +139,6 @@ Deprecated. Use C<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. */ @@ -250,6 +247,9 @@ struct pmop { #define PMdf_USED 0x01 /* pm has been used once already */ #define PMdf_TAINTED 0x02 /* pm compiled from tainted pattern */ #define PMdf_UTF8 0x04 /* pm compiled from utf8 data */ +#define PMdf_DYN_UTF8 0x08 + +#define PMdf_CMP_UTF8 (PMdf_UTF8|PMdf_DYN_UTF8) #define PMf_RETAINT 0x0001 /* taint $1 etc. if target tainted */ #define PMf_ONCE 0x0002 /* use pattern only once per reset */ @@ -1,5 +1,6 @@ #!/usr/bin/perl +chmod 0666, "opcode.h", "opnames.h"; unlink "opcode.h", "opnames.h"; open(OC, ">opcode.h") || die "Can't create opcode.h: $!\n"; open(ON, ">opnames.h") || die "Can't create opnames.h: $!\n"; @@ -56,7 +57,9 @@ for (@ops) { } print ON "\t", &tab(3,"OP_max"), "\n"; print ON "} opcode;\n"; -print ON "\n#define MAXO ", scalar @ops, "\n\n"; +print ON "\n#define MAXO ", scalar @ops, "\n"; +print ON "#define OP_phoney_INPUT_ONLY -1\n"; +print ON "#define OP_phoney_OUTPUT_ONLY -2\n\n"; # Emit op names and descriptions. @@ -359,6 +359,8 @@ typedef enum opcode { } opcode; #define MAXO 351 +#define OP_phoney_INPUT_ONLY -1 +#define OP_phoney_OUTPUT_ONLY -2 #define OP_IS_SOCKET(op) \ diff --git a/os2/OS2/ExtAttr/Makefile.PL b/os2/OS2/ExtAttr/Makefile.PL index 35680288b8..0b8837f153 100644 --- a/os2/OS2/ExtAttr/Makefile.PL +++ b/os2/OS2/ExtAttr/Makefile.PL @@ -4,7 +4,7 @@ use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'OS2::ExtAttr', 'VERSION_FROM' => 'ExtAttr.pm', # finds $VERSION - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' diff --git a/os2/OS2/PrfDB/Makefile.PL b/os2/OS2/PrfDB/Makefile.PL index 39521685df..2d4a6a7ae5 100644 --- a/os2/OS2/PrfDB/Makefile.PL +++ b/os2/OS2/PrfDB/Makefile.PL @@ -4,7 +4,7 @@ use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'OS2::PrfDB', 'VERSION_FROM' => 'PrfDB.pm', # finds $VERSION - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' diff --git a/os2/OS2/Process/Makefile.PL b/os2/OS2/Process/Makefile.PL index d324063164..9c97ad0c10 100644 --- a/os2/OS2/Process/Makefile.PL +++ b/os2/OS2/Process/Makefile.PL @@ -4,7 +4,7 @@ use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'OS2::Process', VERSION_FROM=> 'Process.pm', - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' diff --git a/os2/OS2/REXX/DLL/Makefile.PL b/os2/OS2/REXX/DLL/Makefile.PL index fe2403d0c2..fb91688ce7 100644 --- a/os2/OS2/REXX/DLL/Makefile.PL +++ b/os2/OS2/REXX/DLL/Makefile.PL @@ -3,7 +3,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'OS2::DLL', VERSION => '0.01', - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', PERL_MALLOC_OK => 1, ); diff --git a/os2/OS2/REXX/Makefile.PL b/os2/OS2/REXX/Makefile.PL index 6648b2c575..178ef7bac1 100644 --- a/os2/OS2/REXX/Makefile.PL +++ b/os2/OS2/REXX/Makefile.PL @@ -3,7 +3,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'OS2::REXX', VERSION => '0.22', - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', PERL_MALLOC_OK => 1, ); diff --git a/os2/OS2/REXX/REXX.xs b/os2/OS2/REXX/REXX.xs index 1dc20d3c04..b196ea19b8 100644 --- a/os2/OS2/REXX/REXX.xs +++ b/os2/OS2/REXX/REXX.xs @@ -46,7 +46,6 @@ static long incompartment; static SV* exec_in_REXX(pTHX_ char *cmd, char * handlerName, RexxFunctionHandler *handler) { - dTHR; HMODULE hRexx, hRexxAPI; BYTE buf[200]; LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING, @@ -21,6 +21,8 @@ #include <process.h> #include <fcntl.h> +#define PERLIO_NOT_STDIO 0 + #include "EXTERN.h" #include "perl.h" @@ -375,7 +377,6 @@ spawn_sighandler(int sig) static int result(pTHX_ int flag, int pid) { - dTHR; int r, status; Signal_t (*ihand)(); /* place to save signal during system() */ Signal_t (*qhand)(); /* place to save signal during system() */ @@ -467,7 +468,6 @@ static ULONG os2_mytype; int do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) { - dTHR; int trueflag = flag; int rc, pass = 1; char *tmps; @@ -605,8 +605,9 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) char *scr = find_script(PL_Argv[0], TRUE, NULL, 0); if (scr) { - FILE *file; - char *s = 0, *s1; + PerlIO *file; + SSize_t rd; + char *s = 0, *s1, *s2; int l; l = strlen(scr); @@ -622,14 +623,18 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) Safefree(scr); scr = scrbuf; - file = fopen(scr, "r"); + file = PerlIO_open(scr, "r"); PL_Argv[0] = scr; if (!file) goto panic_file; - if (!fgets(buf, sizeof buf, file)) { /* Empty... */ + rd = PerlIO_read(file, buf, sizeof buf-1); + buf[rd]='\0'; + if ((s2 = strchr(buf, '\n')) != NULL) *++s2 = '\0'; + + if (!rd) { /* Empty... */ buf[0] = 0; - fclose(file); + PerlIO_close(file); /* Special case: maybe from -Zexe build, so there is an executable around (contrary to documentation, DosQueryAppType sometimes (?) @@ -648,7 +653,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) } else goto longbuf; } - if (fclose(file) != 0) { /* Failure */ + if (PerlIO_close(file) != 0) { /* Failure */ panic_file: Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s", scr, Strerror(errno)); @@ -818,7 +823,6 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) int do_spawn3(pTHX_ char *cmd, int execf, int flag) { - dTHR; register char **a; register char *s; char flags[10]; @@ -946,7 +950,6 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag) int os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp) { - dTHR; register char **a; int rc; int flag = P_WAIT, flag_set = 0; @@ -984,21 +987,18 @@ os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp) int os2_do_spawn(pTHX_ char *cmd) { - dTHR; return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0); } int do_spawn_nowait(pTHX_ char *cmd) { - dTHR; return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0); } bool Perl_do_exec(pTHX_ char *cmd) { - dTHR; do_spawn3(aTHX_ cmd, EXECF_EXEC, 0); return FALSE; } @@ -1006,7 +1006,6 @@ Perl_do_exec(pTHX_ char *cmd) bool os2exec(pTHX_ char *cmd) { - dTHR; return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0); } @@ -1163,10 +1162,13 @@ tcp1(char *name, int arg) ((void (*)(int)) fcn) (arg); } +#ifndef HAS_GETHOSTENT /* Older versions of EMX did not have it... */ void * gethostent() { return tcp0("GETHOSTENT"); } void * getnetent() { return tcp0("GETNETENT"); } void * getprotoent() { return tcp0("GETPROTOENT"); } void * getservent() { return tcp0("GETSERVENT"); } +#endif + void sethostent(x) { tcp1("SETHOSTENT", x); } void setnetent(x) { tcp1("SETNETENT", x); } void setprotoent(x) { tcp1("SETPROTOENT", x); } @@ -1367,7 +1369,6 @@ os2error(int rc) char * os2_execname(pTHX) { - dTHR; char buf[300], *p; if (_execname(buf, sizeof buf) != 0) diff --git a/os2/os2ish.h b/os2/os2ish.h index c9719e65bd..dccd9320b6 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -155,7 +155,6 @@ extern int rc; Perl_croak_nocontext("panic: COND_DESTROY, rc=%i", rc); \ } STMT_END /*#define THR ((struct thread *) TlsGetValue(PL_thr_key)) -#define dTHR struct thread *thr = THR */ #ifdef USE_SLOW_THREAD_SPECIFIC diff --git a/patchlevel.h b/patchlevel.h index b9d0dc4250..5030553cec 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -70,7 +70,7 @@ #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT) static char *local_patches[] = { NULL - ,"DEVEL7368" + ,"DEVEL8341" ,NULL }; @@ -1,6 +1,6 @@ /* perl.c * - * Copyright (c) 1987-2000 Larry Wall + * Copyright (c) 1987-2001 Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -157,7 +157,7 @@ perl_construct(pTHXx) #ifdef MULTIPLICITY init_interp(); - PL_perl_destruct_level = 1; + PL_perl_destruct_level = 1; #else if (PL_perl_destruct_level > 0) init_interp(); @@ -298,7 +298,6 @@ Shuts down a Perl interpreter. See L<perlembed>. void perl_destruct(pTHXx) { - dTHR; int destruct_level; /* 0=none, 1=full, 2=full with checks */ I32 last_sv_count; HV *hv; @@ -344,7 +343,7 @@ perl_destruct(pTHXx) DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: detaching thread %p\n", t)); ThrSETSTATE(t, THRf_R_DETACHED); - /* + /* * We unlock threads_mutex and t->mutex in the opposite order * from which we locked them just so that DETACH won't * deadlock if it panics. It's only a breach of good style @@ -434,7 +433,7 @@ perl_destruct(pTHXx) if (destruct_level == 0){ DEBUG_P(debprofdump()); - + /* The exit() function will do everything that needs doing. */ return; } @@ -474,11 +473,11 @@ perl_destruct(pTHXx) /* magical thingies */ - Safefree(PL_ofs); /* $, */ - PL_ofs = Nullch; + SvREFCNT_dec(PL_ofs_sv); /* $, */ + PL_ofs_sv = Nullsv; - Safefree(PL_ors); /* $\ */ - PL_ors = Nullch; + SvREFCNT_dec(PL_ors_sv); /* $\ */ + PL_ors_sv = Nullsv; SvREFCNT_dec(PL_rs); /* $/ */ PL_rs = Nullsv; @@ -603,6 +602,9 @@ perl_destruct(pTHXx) if (!specialWARN(PL_compiling.cop_warnings)) SvREFCNT_dec(PL_compiling.cop_warnings); PL_compiling.cop_warnings = Nullsv; + if (!specialCopIO(PL_compiling.cop_io)) + SvREFCNT_dec(PL_compiling.cop_io); + PL_compiling.cop_io = Nullsv; #ifdef USE_ITHREADS Safefree(CopFILE(&PL_compiling)); CopFILE(&PL_compiling) = Nullch; @@ -724,7 +726,7 @@ perl_destruct(pTHXx) Safefree(PL_psig_name); nuke_stacks(); PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */ - + DEBUG_P(debprofdump()); #ifdef USE_THREADS MUTEX_DESTROY(&PL_strtab_mutex); @@ -783,10 +785,18 @@ perl_free(pTHXx) #if defined(PERL_OBJECT) PerlMem_free(this); #else -# if defined(PERL_IMPLICIT_SYS) && defined(WIN32) +# if defined(WIN32) +# if defined(PERL_IMPLICIT_SYS) void *host = w32_internal_host; + if (PerlProc_lasthost()) { + PerlIO_cleanup(); + } PerlMem_free(aTHXx); win32_delete_internal_host(host); +#else + PerlIO_cleanup(); + PerlMem_free(aTHXx); +#endif # else PerlMem_free(aTHXx); # endif @@ -813,7 +823,6 @@ Tells a Perl interpreter to parse a Perl script. See L<perlembed>. int perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) { - dTHR; I32 oldscope; int ret; dJMPENV; @@ -836,7 +845,7 @@ setuid perl scripts securely.\n"); PL_origargv = argv; PL_origargc = argc; -#if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */ +#ifdef USE_ENVIRON_ARRAY PL_origenviron = environ; #endif @@ -915,7 +924,6 @@ S_vparse_body(pTHX_ va_list args) STATIC void * S_parse_body(pTHX_ char **env, XSINIT_t xsinit) { - dTHR; int argc = PL_origargc; char **argv = PL_origargv; char *scriptname = NULL; @@ -986,7 +994,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #ifdef MACOS_TRADITIONAL /* ignore -e for Dev:Pseudo argument */ if (argv[1] && !strcmp(argv[1], "Dev:Pseudo")) - break; + break; #endif if (PL_euid != PL_uid || PL_egid != PL_gid) Perl_croak(aTHX_ "No -e allowed in setuid scripts"); @@ -1267,7 +1275,7 @@ print \" \\@INC:\\n @INC\\n\";"); # else SOCKSinit(argv[0]); # endif -#endif +#endif init_predump_symbols(); /* init_postdump_symbols not currently designed to be called */ @@ -1346,7 +1354,6 @@ Tells a Perl interpreter to run. See L<perlembed>. int perl_run(pTHXx) { - dTHR; I32 oldscope; int ret = 0; dJMPENV; @@ -1414,8 +1421,6 @@ S_vrun_body(pTHX_ va_list args) STATIC void * S_run_body(pTHX_ I32 oldscope) { - dTHR; - DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n", PL_sawampersand ? "Enabling" : "Omitting")); @@ -1434,7 +1439,7 @@ S_run_body(pTHX_ I32 oldscope) my_exit(0); } if (PERLDB_SINGLE && PL_DBsingle) - sv_setiv(PL_DBsingle, 1); + sv_setiv(PL_DBsingle, 1); if (PL_initav) call_list(oldscope, PL_initav); } @@ -1474,10 +1479,8 @@ Perl_get_sv(pTHX_ const char *name, I32 create) #ifdef USE_THREADS if (name[1] == '\0' && !isALPHA(name[0])) { PADOFFSET tmp = find_threadsv(name); - if (tmp != NOT_IN_PAD) { - dTHR; + if (tmp != NOT_IN_PAD) return THREADSV(tmp); - } } #endif /* USE_THREADS */ gv = gv_fetchpv(name, create, SVt_PV); @@ -1569,7 +1572,7 @@ Performs a callback to the specified Perl sub. See L<perlcall>. I32 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv) - + /* See G_* flags in cop.h */ /* null terminated arg list */ { @@ -1694,15 +1697,15 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) { register PERL_CONTEXT *cx; I32 gimme = GIMME_V; - + ENTER; SAVETMPS; - + push_return(Nullop); PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); PUSHEVAL(cx, 0, 0); PL_eval_root = PL_op; /* Only needed so that goto works right. */ - + PL_in_eval = EVAL_INEVAL; if (flags & G_KEEPERR) PL_in_eval |= EVAL_KEEPERR; @@ -1797,8 +1800,6 @@ S_vcall_body(pTHX_ va_list args) STATIC void S_call_body(pTHX_ OP *myop, int is_eval) { - dTHR; - if (PL_op == myop) { if (is_eval) PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */ @@ -1821,7 +1822,7 @@ Tells Perl to C<eval> the string in the SV. I32 Perl_eval_sv(pTHX_ SV *sv, I32 flags) - + /* See G_* flags in cop.h */ { dSP; @@ -2025,13 +2026,12 @@ NULL char * Perl_moreswitches(pTHX_ char *s) { - I32 numlen; + STRLEN numlen; U32 rschar; switch (*s) { case '0': { - dTHR; numlen = 0; /* disallow underscores */ rschar = (U32)scan_oct(s, 4, &numlen); SvREFCNT_dec(PL_nrs); @@ -2095,7 +2095,7 @@ Perl_moreswitches(pTHX_ char *s) #ifdef DEBUGGING forbid_setid("-D"); if (isALPHA(s[1])) { - static char debopts[] = "psltocPmfrxuLHXDS"; + static char debopts[] = "psltocPmfrxuLHXDST"; char *d; for (s++; *s && (d = strchr(debopts,*s)); s++) @@ -2107,7 +2107,6 @@ Perl_moreswitches(pTHX_ char *s) } PL_debug |= 0x80000000; #else - dTHR; if (ckWARN_d(WARN_DEBUGGING)) Perl_warner(aTHX_ WARN_DEBUGGING, "Recompile perl with -DDEBUGGING to use -D switch\n"); @@ -2117,7 +2116,7 @@ Perl_moreswitches(pTHX_ char *s) return s; } case 'h': - usage(PL_origargv[0]); + usage(PL_origargv[0]); PerlProc_exit(0); case 'i': if (PL_inplace) @@ -2159,24 +2158,23 @@ Perl_moreswitches(pTHX_ char *s) case 'l': PL_minus_l = TRUE; s++; - if (PL_ors) - Safefree(PL_ors); + if (PL_ors_sv) { + SvREFCNT_dec(PL_ors_sv); + PL_ors_sv = Nullsv; + } if (isDIGIT(*s)) { - PL_ors = savepv("\n"); - PL_orslen = 1; + PL_ors_sv = newSVpvn("\n",1); numlen = 0; /* disallow underscores */ - *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen); + *SvPVX(PL_ors_sv) = (char)scan_oct(s, 3 + (*s == '0'), &numlen); s += numlen; } else { - dTHR; if (RsPARA(PL_nrs)) { - PL_ors = "\n\n"; - PL_orslen = 2; + PL_ors_sv = newSVpvn("\n\n",2); + } + else { + PL_ors_sv = newSVsv(PL_nrs); } - else - PL_ors = SvPV(PL_nrs, PL_orslen); - PL_ors = savepvn(PL_ors, PL_orslen); } return s; case 'M': @@ -2261,7 +2259,7 @@ Perl_moreswitches(pTHX_ char *s) #endif PerlIO_printf(PerlIO_stdout(), - "\n\nCopyright 1987-2000, Larry Wall\n"); + "\n\nCopyright 1987-2001, Larry Wall\n"); #ifdef MACOS_TRADITIONAL PerlIO_printf(PerlIO_stdout(), "\nMacOS port Copyright (c) 1991-2000, Matthias Neeracher\n"); @@ -2329,16 +2327,16 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); PerlProc_exit(0); case 'w': if (! (PL_dowarn & G_WARN_ALL_MASK)) - PL_dowarn |= G_WARN_ON; + PL_dowarn |= G_WARN_ON; s++; return s; case 'W': - PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; + PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; PL_compiling.cop_warnings = pWARN_ALL ; s++; return s; case 'X': - PL_dowarn = G_WARN_ALL_OFF; + PL_dowarn = G_WARN_ALL_OFF; PL_compiling.cop_warnings = pWARN_NONE ; s++; return s; @@ -2484,7 +2482,6 @@ S_init_interp(pTHX) STATIC void S_init_main_stash(pTHX) { - dTHR; GV *gv; /* Note that strtab is a rather special HV. Assumptions are made @@ -2496,7 +2493,7 @@ S_init_main_stash(pTHX) #endif HvSHAREKEYS_off(PL_strtab); /* mandatory */ hv_ksplit(PL_strtab, 512); - + PL_curstash = PL_defstash = newHV(); PL_curstname = newSVpvn("main",4); gv = gv_fetchpv("main::",TRUE, SVt_PVHV); @@ -2528,8 +2525,6 @@ S_init_main_stash(pTHX) STATIC void S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) { - dTHR; - *fdscript = -1; if (PL_e_script) { @@ -2719,7 +2714,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd) check_okay = fstatvfs(fd, &stfs) == 0; on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID); # endif /* fstatvfs */ - + # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ defined(PERL_MOUNT_NOSUID) && \ defined(HAS_FSTATFS) && \ @@ -2789,7 +2784,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd) fclose(mtab); # endif /* getmntent+hasmntopt */ - if (!check_okay) + if (!check_okay) Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename); return on_nosuid; } @@ -2823,7 +2818,6 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) */ #ifdef DOSUID - dTHR; char *s, *s2; if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */ @@ -3021,7 +3015,6 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #else /* !DOSUID */ if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */ #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW - dTHR; PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */ if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID) || @@ -3046,7 +3039,7 @@ S_find_beginning(pTHX) forbid_setid("-x"); #ifdef MACOS_TRADITIONAL /* Since the Mac OS does not honor !# arguments for us, we do it ourselves */ - + while (PL_doextract || gMacPerl_AlwaysExtract) { if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) { if (!gMacPerl_AlwaysExtract) @@ -3060,7 +3053,7 @@ S_find_beginning(pTHX) /* Pater peccavi, file does not have #! */ PerlIO_rewind(PL_rsfp); - + break; } #else @@ -3112,7 +3105,6 @@ S_forbid_setid(pTHX_ char *s) void Perl_init_debugger(pTHX) { - dTHR; HV *ostash = PL_curstash; PL_curstash = PL_debstash; @@ -3123,11 +3115,11 @@ Perl_init_debugger(pTHX) PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV)); sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */ PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV))); - sv_setiv(PL_DBsingle, 0); + sv_setiv(PL_DBsingle, 0); PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV))); - sv_setiv(PL_DBtrace, 0); + sv_setiv(PL_DBtrace, 0); PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV))); - sv_setiv(PL_DBsignal, 0); + sv_setiv(PL_DBsignal, 0); PL_curstash = ostash; } @@ -3180,7 +3172,6 @@ Perl_init_stacks(pTHX) STATIC void S_nuke_stacks(pTHX) { - dTHR; while (PL_curstackinfo->si_next) PL_curstackinfo = PL_curstackinfo->si_next; while (PL_curstackinfo) { @@ -3217,7 +3208,6 @@ S_init_lexer(pTHX) STATIC void S_init_predump_symbols(pTHX) { - dTHR; GV *tmpgv; IO *io; @@ -3257,7 +3247,6 @@ S_init_predump_symbols(pTHX) STATIC void S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env) { - dTHR; char *s; SV *sv; GV* tmpgv; @@ -3319,7 +3308,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register GvMULTI_on(PL_envgv); hv = GvHVn(PL_envgv); hv_magic(hv, PL_envgv, 'E'); -#if !defined( VMS) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) /* VMS doesn't have environ array */ +#ifdef USE_ENVIRON_ARRAY /* Note that if the supplied env parameter is actually a copy of the global environ then it may now point to free'd memory if the environment has been modified since. To avoid this @@ -3404,7 +3393,7 @@ S_init_perllib(pTHX) Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl); if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) incpush(SvPVX(privdir), TRUE, FALSE); - + SvREFCNT_dec(privdir); } if (!PL_tainting) @@ -3413,7 +3402,7 @@ S_init_perllib(pTHX) #ifndef PRIVLIB_EXP # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" #endif -#if defined(WIN32) +#if defined(WIN32) incpush(PRIVLIB_EXP, TRUE, FALSE); #else incpush(PRIVLIB_EXP, FALSE, FALSE); @@ -3483,7 +3472,7 @@ S_init_perllib(pTHX) #endif #ifndef PERLLIB_MANGLE # define PERLLIB_MANGLE(s,n) (s) -#endif +#endif STATIC void S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) @@ -3559,7 +3548,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) #define PERL_ARCH_FMT "/%s" #endif /* .../version/archname if -d .../version/archname */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT PERL_ARCH_FMT, + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT PERL_ARCH_FMT, libdir, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION, ARCHNAME); @@ -3637,6 +3626,7 @@ S_init_main_thread(pTHX) thr->tid = 0; thr->next = thr; thr->prev = thr; + thr->thr_done = 0; MUTEX_UNLOCK(&PL_threads_mutex); #ifdef HAVE_THREAD_INTERN @@ -3651,8 +3641,9 @@ S_init_main_thread(pTHX) PERL_SET_THX(thr); /* - * These must come after the SET_THR because sv_setpvn does - * SvTAINT and the taint fields require dTHR. + * These must come after the thread self setting + * because sv_setpvn does SvTAINT and the taint + * fields thread selfness being set. */ PL_toptarget = NEWSV(0,0); sv_upgrade(PL_toptarget, SVt_PVFM); @@ -3680,7 +3671,6 @@ S_init_main_thread(pTHX) void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) { - dTHR; SV *atsv; line_t oldline = CopLINE(PL_curcop); CV *cv; @@ -3785,8 +3775,6 @@ S_call_list_body(pTHX_ CV *cv) void Perl_my_exit(pTHX_ U32 status) { - dTHR; - DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n", thr, (unsigned long) status)); switch (status) { @@ -3822,7 +3810,7 @@ Perl_my_failure_exit(pTHX) if (errno & 255) STATUS_POSIX_SET(errno); else { - exitstatus = STATUS_POSIX >> 8; + exitstatus = STATUS_POSIX >> 8; if (exitstatus & 255) STATUS_POSIX_SET(exitstatus); else @@ -3835,7 +3823,6 @@ Perl_my_failure_exit(pTHX) STATIC void S_my_exit_jump(pTHX) { - dTHR; register PERL_CONTEXT *cx; I32 gimme; SV **newsp; @@ -1,6 +1,6 @@ /* perl.h * - * Copyright (c) 1987-2000, Larry Wall + * Copyright (c) 1987-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -183,7 +183,7 @@ class CPerlObj; struct perl_thread; # define pTHX register struct perl_thread *thr # define aTHX thr -# define dTHR dNOOP +# define dTHR dNOOP /* only backward compatibility */ # define dTHXa(a) pTHX = (struct perl_thread*)a # else # ifndef MULTIPLICITY @@ -303,7 +303,7 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); #endif #define WITH_THX(s) STMT_START { dTHX; s; } STMT_END -#define WITH_THR(s) STMT_START { dTHR; s; } STMT_END +#define WITH_THR(s) WITH_THX(s) /* * SOFT_CAST can be used for args to prototyped functions to retain some @@ -496,12 +496,16 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); # include <sys/param.h> #endif - /* 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 @@ -709,10 +713,47 @@ typedef struct perl_mstats perl_mstats_t; #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 +# 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 @@ -1043,6 +1084,11 @@ typedef UVTYPE UV; #define IV_DIG (BIT_DIGITS(IVSIZE * 8)) #define UV_DIG (BIT_DIGITS(UVSIZE * 8)) +/* We like our integers to stay integers. */ +#ifndef NO_PERL_PRESERVE_IVUV +#define PERL_PRESERVE_IVUV +#endif + /* * The macros INT2PTR and NUM2PTR are (despite their names) * bi-directional: they will convert int/float to or from pointers. @@ -1075,6 +1121,9 @@ typedef UVTYPE UV; #endif #ifdef USE_LONG_DOUBLE +# if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE == DOUBLESIZE +# define LONG_DOUBLE_EQUALS_DOUBLE +# endif # if !(defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE)) # undef USE_LONG_DOUBLE /* Ouch! */ # endif @@ -1440,6 +1489,7 @@ struct perl_mstats { UV *bucket_available_size; UV nbuckets; }; +struct RExC_state_t; typedef MEM_SIZE STRLEN; @@ -1626,6 +1676,9 @@ typedef struct ptr_tbl PTR_TBL_t; # else # if defined(MACOS_TRADITIONAL) # include "macos/macish.h" +# ifndef NO_ENVIRON_ARRAY +# define NO_ENVIRON_ARRAY +# endif # else # include "unixish.h" # endif @@ -2105,6 +2158,7 @@ Gid_t getegid (void); # else # define DEBUG_S(a) # endif +#define DEBUG_T(a) if (PL_debug & (1<<17)) a #else #define DEB(a) #define DEBUG(a) @@ -2125,6 +2179,7 @@ Gid_t getegid (void); #define DEBUG_X(a) #define DEBUG_D(a) #define DEBUG_S(a) +#define DEBUG_T(a) #endif #define YYMAXDEPTH 300 @@ -2195,8 +2250,12 @@ char *crypt (const char*, const char*); # ifndef getenv char *getenv (const char*); # endif /* !getenv */ -# if !defined(EPOC) && !(defined(__hpux) && defined(_FILE_OFFSET_BITS) && _FILE_OFFSET_BITS == 64) && !defined(HAS_LSEEK_PROTO) +# if !defined(HAS_LSEEK_PROTO) && !defined(EPOC) && !defined(__hpux) +# ifdef _FILE_OFFSET_BITS +# if _FILE_OFFSET_BITS == 64 Off_t lseek (int,Off_t,int); +# endif +# endif # endif # endif /* !DONT_DECLARE_STD */ char *getlogin (void); @@ -2639,6 +2698,7 @@ enum { /* pass one of these to get_vtbl */ #define HINT_FILETEST_ACCESS 0x00400000 #define HINT_UTF8 0x00800000 +#define HINT_UTF8_DISTINCT 0x01000000 /* Various states of an input record separator SV (rs, nrs) */ #define RsSNARF(sv) (! SvOK(sv)) @@ -2658,10 +2718,6 @@ typedef char* (CPERLscope(*re_intuit_start_t)) (pTHX_ regexp *prog, SV *sv, typedef SV* (CPERLscope(*re_intuit_string_t)) (pTHX_ regexp *prog); typedef void (CPERLscope(*regfree_t)) (pTHX_ struct regexp* r); -#ifdef USE_PURE_BISON -int Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp); -#endif - typedef void (*DESTRUCTORFUNC_NOCONTEXT_t) (void*); typedef void (*DESTRUCTORFUNC_t) (pTHXo_ void*); typedef void (*SVFUNC_t) (pTHXo_ SV*); @@ -3005,46 +3061,53 @@ enum { to_sv_amg, to_av_amg, to_hv_amg, to_gv_amg, to_cv_amg, iter_amg, - max_amg_code + DESTROY_amg, max_amg_code /* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */ }; #define NofAMmeth max_amg_code +#define AMG_id2name(id) ((char*)PL_AMG_names[id]+1) #ifdef DOINIT EXTCONST char * PL_AMG_names[NofAMmeth] = { - "fallback", "abs", /* "fallback" should be the first. */ - "bool", "nomethod", - "\"\"", "0+", - "+", "+=", - "-", "-=", - "*", "*=", - "/", "/=", - "%", "%=", - "**", "**=", - "<<", "<<=", - ">>", ">>=", - "&", "&=", - "|", "|=", - "^", "^=", - "<", "<=", - ">", ">=", - "==", "!=", - "<=>", "cmp", - "lt", "le", - "gt", "ge", - "eq", "ne", - "!", "~", - "++", "--", - "atan2", "cos", - "sin", "exp", - "log", "sqrt", - "x", "x=", - ".", ".=", - "=", "neg", - "${}", "@{}", - "%{}", "*{}", - "&{}", "<>", + /* Names kept in the symbol table. fallback => "()", the rest has + "(" prepended. The only other place in perl which knows about + this convention is AMG_id2name (used for debugging output and + 'nomethod' only), the only other place which has it hardwired is + overload.pm. */ + "()", "(abs", /* "fallback" should be the first. */ + "(bool", "(nomethod", + "(\"\"", "(0+", + "(+", "(+=", + "(-", "(-=", + "(*", "(*=", + "(/", "(/=", + "(%", "(%=", + "(**", "(**=", + "(<<", "(<<=", + "(>>", "(>>=", + "(&", "(&=", + "(|", "(|=", + "(^", "(^=", + "(<", "(<=", + "(>", "(>=", + "(==", "(!=", + "(<=>", "(cmp", + "(lt", "(le", + "(gt", "(ge", + "(eq", "(ne", + "(!", "(~", + "(++", "(--", + "(atan2", "(cos", + "(sin", "(exp", + "(log", "(sqrt", + "(x", "(x=", + "(.", "(.=", + "(=", "(neg", + "(${}", "(@{}", + "(%{}", "(*{}", + "(&{}", "(<>", + "DESTROY", }; #else EXTCONST char * PL_AMG_names[NofAMmeth]; @@ -3072,10 +3135,15 @@ typedef struct am_table_short AMTS; #define AMGfallYES 3 #define AMTf_AMAGIC 1 +#define AMTf_OVERLOADED 2 #define AMT_AMAGIC(amt) ((amt)->flags & AMTf_AMAGIC) #define AMT_AMAGIC_on(amt) ((amt)->flags |= AMTf_AMAGIC) #define AMT_AMAGIC_off(amt) ((amt)->flags &= ~AMTf_AMAGIC) +#define AMT_OVERLOADED(amt) ((amt)->flags & AMTf_OVERLOADED) +#define AMT_OVERLOADED_on(amt) ((amt)->flags |= AMTf_OVERLOADED) +#define AMT_OVERLOADED_off(amt) ((amt)->flags &= ~AMTf_OVERLOADED) +#define StashHANDLER(stash,meth) gv_handler((stash),CAT2(meth,_amg)) /* * some compilers like to redefine cos et alia as faster @@ -3140,16 +3208,10 @@ typedef struct am_table_short AMTS; #ifdef USE_LOCALE_NUMERIC #define SET_NUMERIC_STANDARD() \ - STMT_START { \ - if (! PL_numeric_standard) \ - set_numeric_standard(); \ - } STMT_END + set_numeric_standard(); #define SET_NUMERIC_LOCAL() \ - STMT_START { \ - if (! PL_numeric_local) \ - set_numeric_local(); \ - } STMT_END + set_numeric_local(); #define IS_NUMERIC_RADIX(c) \ ((PL_hints & HINT_LOCALE) && \ @@ -3157,11 +3219,11 @@ typedef struct am_table_short AMTS; #define STORE_NUMERIC_LOCAL_SET_STANDARD() \ bool was_local = (PL_hints & HINT_LOCALE) && PL_numeric_local; \ - if (!was_local) SET_NUMERIC_STANDARD(); + if (was_local) SET_NUMERIC_STANDARD(); #define STORE_NUMERIC_STANDARD_SET_LOCAL() \ - bool was_standard = !(PL_hints & HINT_LOCALE) || PL_numeric_standard; \ - if (!was_standard) SET_NUMERIC_LOCAL(); + bool was_standard = (PL_hints & HINT_LOCALE) && PL_numeric_standard; \ + if (was_standard) SET_NUMERIC_LOCAL(); #define RESTORE_NUMERIC_LOCAL() \ if (was_local) SET_NUMERIC_LOCAL(); @@ -3191,6 +3253,9 @@ typedef struct am_table_short AMTS; # if !defined(Strtol) && defined(HAS_STRTOLL) # define Strtol strtoll # endif +# if !defined(Strtol) && defined(HAS_STRTOQ) +# define Strtol strtoq +# endif /* is there atoq() anywhere? */ #endif #if !defined(Strtol) && defined(HAS_STRTOL) @@ -3402,6 +3467,10 @@ typedef struct am_table_short AMTS; # include <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" @@ -85,6 +85,13 @@ Perl_Gv_AMupdate(pTHXo_ HV* stash) return ((CPerlObj*)pPerl)->Perl_Gv_AMupdate(stash); } +#undef Perl_gv_handler +CV* +Perl_gv_handler(pTHXo_ HV* stash, I32 id) +{ + return ((CPerlObj*)pPerl)->Perl_gv_handler(stash, id); +} + #undef Perl_apply_attrs_string void Perl_apply_attrs_string(pTHXo_ char *stashpv, CV *cv, char *attrstr, STRLEN len) @@ -936,7 +943,7 @@ Perl_hv_delayfree_ent(pTHXo_ HV* hv, HE* entry) #undef Perl_hv_delete SV* -Perl_hv_delete(pTHXo_ HV* tb, const char* key, U32 klen, I32 flags) +Perl_hv_delete(pTHXo_ HV* tb, const char* key, I32 klen, I32 flags) { return ((CPerlObj*)pPerl)->Perl_hv_delete(tb, key, klen, flags); } @@ -950,7 +957,7 @@ Perl_hv_delete_ent(pTHXo_ HV* tb, SV* key, I32 flags, U32 hash) #undef Perl_hv_exists bool -Perl_hv_exists(pTHXo_ HV* tb, const char* key, U32 klen) +Perl_hv_exists(pTHXo_ HV* tb, const char* key, I32 klen) { return ((CPerlObj*)pPerl)->Perl_hv_exists(tb, key, klen); } @@ -964,7 +971,7 @@ Perl_hv_exists_ent(pTHXo_ HV* tb, SV* key, U32 hash) #undef Perl_hv_fetch SV** -Perl_hv_fetch(pTHXo_ HV* tb, const char* key, U32 klen, I32 lval) +Perl_hv_fetch(pTHXo_ HV* tb, const char* key, I32 klen, I32 lval) { return ((CPerlObj*)pPerl)->Perl_hv_fetch(tb, key, klen, lval); } @@ -1041,7 +1048,7 @@ Perl_hv_magic(pTHXo_ HV* hv, GV* gv, int how) #undef Perl_hv_store SV** -Perl_hv_store(pTHXo_ HV* tb, const char* key, U32 klen, SV* val, U32 hash) +Perl_hv_store(pTHXo_ HV* tb, const char* key, I32 klen, SV* val, U32 hash) { return ((CPerlObj*)pPerl)->Perl_hv_store(tb, key, klen, val, hash); } @@ -1327,7 +1334,7 @@ Perl_to_uni_lower_lc(pTHXo_ U32 c) } #undef Perl_is_utf8_char -int +STRLEN Perl_is_utf8_char(pTHXo_ U8 *p) { return ((CPerlObj*)pPerl)->Perl_is_utf8_char(p); @@ -1743,10 +1750,10 @@ Perl_newCONDOP(pTHXo_ I32 flags, OP* expr, OP* trueop, OP* falseop) } #undef Perl_newCONSTSUB -void +CV* Perl_newCONSTSUB(pTHXo_ HV* stash, char* name, SV* sv) { - ((CPerlObj*)pPerl)->Perl_newCONSTSUB(stash, name, sv); + return ((CPerlObj*)pPerl)->Perl_newCONSTSUB(stash, name, sv); } #undef Perl_newFORM @@ -2017,7 +2024,7 @@ Perl_newSVpvn(pTHXo_ const char* s, STRLEN len) #undef Perl_newSVpvn_share SV* -Perl_newSVpvn_share(pTHXo_ const char* s, STRLEN len, U32 hash) +Perl_newSVpvn_share(pTHXo_ const char* s, I32 len, U32 hash) { return ((CPerlObj*)pPerl)->Perl_newSVpvn_share(s, len, hash); } @@ -2237,21 +2244,21 @@ Perl_init_i18nl14n(pTHXo_ int printwarn) #undef Perl_new_collate void -Perl_new_collate(pTHXo_ const char* newcoll) +Perl_new_collate(pTHXo_ char* newcoll) { ((CPerlObj*)pPerl)->Perl_new_collate(newcoll); } #undef Perl_new_ctype void -Perl_new_ctype(pTHXo_ const char* newctype) +Perl_new_ctype(pTHXo_ char* newctype) { ((CPerlObj*)pPerl)->Perl_new_ctype(newctype); } #undef Perl_new_numeric void -Perl_new_numeric(pTHXo_ const char* newcoll) +Perl_new_numeric(pTHXo_ char* newcoll) { ((CPerlObj*)pPerl)->Perl_new_numeric(newcoll); } @@ -2312,6 +2319,13 @@ Perl_regdump(pTHXo_ regexp* r) ((CPerlObj*)pPerl)->Perl_regdump(r); } +#undef Perl_regclass_swash +SV* +Perl_regclass_swash(pTHXo_ struct regnode *n, bool doinit, SV **initsvp) +{ + return ((CPerlObj*)pPerl)->Perl_regclass_swash(n, doinit, initsvp); +} + #undef Perl_pregexec I32 Perl_pregexec(pTHXo_ regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, U32 nosave) @@ -2615,6 +2629,13 @@ Perl_save_re_context(pTHXo) ((CPerlObj*)pPerl)->Perl_save_re_context(); } +#undef Perl_save_padsv +void +Perl_save_padsv(pTHXo_ PADOFFSET off) +{ + ((CPerlObj*)pPerl)->Perl_save_padsv(off); +} + #undef Perl_save_sptr void Perl_save_sptr(pTHXo_ SV** sptr) @@ -2638,28 +2659,28 @@ Perl_save_threadsv(pTHXo_ PADOFFSET i) #undef Perl_scan_bin NV -Perl_scan_bin(pTHXo_ char* start, I32 len, I32* retlen) +Perl_scan_bin(pTHXo_ char* start, STRLEN len, STRLEN* retlen) { return ((CPerlObj*)pPerl)->Perl_scan_bin(start, len, retlen); } #undef Perl_scan_hex NV -Perl_scan_hex(pTHXo_ char* start, I32 len, I32* retlen) +Perl_scan_hex(pTHXo_ char* start, STRLEN len, STRLEN* retlen) { return ((CPerlObj*)pPerl)->Perl_scan_hex(start, len, retlen); } #undef Perl_scan_num char* -Perl_scan_num(pTHXo_ char* s) +Perl_scan_num(pTHXo_ char* s, YYSTYPE *lvalp) { - return ((CPerlObj*)pPerl)->Perl_scan_num(s); + return ((CPerlObj*)pPerl)->Perl_scan_num(s, lvalp); } #undef Perl_scan_oct NV -Perl_scan_oct(pTHXo_ char* start, I32 len, I32* retlen) +Perl_scan_oct(pTHXo_ char* start, STRLEN len, STRLEN* retlen) { return ((CPerlObj*)pPerl)->Perl_scan_oct(start, len, retlen); } @@ -3220,6 +3241,13 @@ Perl_sv_unref(pTHXo_ SV* sv) ((CPerlObj*)pPerl)->Perl_sv_unref(sv); } +#undef Perl_sv_unref_flags +void +Perl_sv_unref_flags(pTHXo_ SV* sv, U32 flags) +{ + ((CPerlObj*)pPerl)->Perl_sv_unref_flags(sv, flags); +} + #undef Perl_sv_untaint void Perl_sv_untaint(pTHXo_ SV* sv) @@ -3350,8 +3378,15 @@ Perl_utf16_to_utf8_reversed(pTHXo_ U8* p, U8 *d, I32 bytelen, I32 *newlen) return ((CPerlObj*)pPerl)->Perl_utf16_to_utf8_reversed(p, d, bytelen, newlen); } +#undef Perl_utf8_length +STRLEN +Perl_utf8_length(pTHXo_ U8* s, U8 *e) +{ + return ((CPerlObj*)pPerl)->Perl_utf8_length(s, e); +} + #undef Perl_utf8_distance -I32 +IV Perl_utf8_distance(pTHXo_ U8 *a, U8 *b) { return ((CPerlObj*)pPerl)->Perl_utf8_distance(a, b); @@ -3378,18 +3413,18 @@ Perl_bytes_to_utf8(pTHXo_ U8 *s, STRLEN *len) return ((CPerlObj*)pPerl)->Perl_bytes_to_utf8(s, len); } -#undef Perl_utf8_to_uv +#undef Perl_utf8_to_uv_simple UV -Perl_utf8_to_uv(pTHXo_ U8 *s, I32* retlen) +Perl_utf8_to_uv_simple(pTHXo_ U8 *s, STRLEN* retlen) { - return ((CPerlObj*)pPerl)->Perl_utf8_to_uv(s, retlen); + return ((CPerlObj*)pPerl)->Perl_utf8_to_uv_simple(s, retlen); } -#undef Perl_utf8_to_uv_chk +#undef Perl_utf8_to_uv UV -Perl_utf8_to_uv_chk(pTHXo_ U8 *s, I32* retlen, bool checking) +Perl_utf8_to_uv(pTHXo_ U8 *s, STRLEN curlen, STRLEN* retlen, U32 flags) { - return ((CPerlObj*)pPerl)->Perl_utf8_to_uv_chk(s, retlen, checking); + return ((CPerlObj*)pPerl)->Perl_utf8_to_uv(s, curlen, retlen, flags); } #undef Perl_uv_to_utf8 @@ -3439,7 +3474,7 @@ Perl_whichsig(pTHXo_ char* sig) { return ((CPerlObj*)pPerl)->Perl_whichsig(sig); } -#if defined(USE_PURE_BISON) +#ifdef USE_PURE_BISON #else #endif #if defined(MYMALLOC) @@ -3854,6 +3889,13 @@ Perl_sv_force_normal(pTHXo_ SV *sv) ((CPerlObj*)pPerl)->Perl_sv_force_normal(sv); } +#undef Perl_sv_force_normal_flags +void +Perl_sv_force_normal_flags(pTHXo_ SV *sv, U32 flags) +{ + ((CPerlObj*)pPerl)->Perl_sv_force_normal_flags(sv, flags); +} + #undef Perl_tmps_grow void Perl_tmps_grow(pTHXo_ I32 n) @@ -4068,6 +4110,8 @@ Perl_sys_intern_init(pTHXo) #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) # if defined(DEBUGGING) # endif +# if !defined(NV_PRESERVES_UV) +# endif #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #if 0 @@ -420,10 +420,8 @@ START_EXTERN_C #define PL_origenviron (*Perl_Iorigenviron_ptr(aTHXo)) #undef PL_origfilename #define PL_origfilename (*Perl_Iorigfilename_ptr(aTHXo)) -#undef PL_ors -#define PL_ors (*Perl_Iors_ptr(aTHXo)) -#undef PL_orslen -#define PL_orslen (*Perl_Iorslen_ptr(aTHXo)) +#undef PL_ors_sv +#define PL_ors_sv (*Perl_Iors_sv_ptr(aTHXo)) #undef PL_osname #define PL_osname (*Perl_Iosname_ptr(aTHXo)) #undef PL_pad_reset_pending @@ -712,10 +710,8 @@ START_EXTERN_C #define PL_na (*Perl_Tna_ptr(aTHXo)) #undef PL_nrs #define PL_nrs (*Perl_Tnrs_ptr(aTHXo)) -#undef PL_ofs -#define PL_ofs (*Perl_Tofs_ptr(aTHXo)) -#undef PL_ofslen -#define PL_ofslen (*Perl_Tofslen_ptr(aTHXo)) +#undef PL_ofs_sv +#define PL_ofs_sv (*Perl_Tofs_sv_ptr(aTHXo)) #undef PL_op #define PL_op (*Perl_Top_ptr(aTHXo)) #undef PL_opsave @@ -7,7 +7,6 @@ * */ - #define VOIDUSED 1 #ifdef PERL_MICRO # include "uconfig.h" @@ -15,31 +14,103 @@ # include "config.h" #endif -#define PERLIO_NOT_STDIO 0 +#define PERLIO_NOT_STDIO 0 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO) -#define PerlIO FILE +/* #define PerlIO FILE */ #endif /* - * This file provides those parts of PerlIO abstraction - * which are not #defined in iperlsys.h. - * Which these are depends on various Configure #ifdef's + * This file provides those parts of PerlIO abstraction + * which are not #defined in perlio.h. + * Which these are depends on various Configure #ifdef's */ #include "EXTERN.h" #define PERL_IN_PERLIO_C #include "perl.h" -#if !defined(PERL_IMPLICIT_SYS) +#undef PerlMemShared_calloc +#define PerlMemShared_calloc(x,y) calloc(x,y) +#undef PerlMemShared_free +#define PerlMemShared_free(x) free(x) + +int +perlsio_binmode(FILE *fp, int iotype, int mode) +{ +/* This used to be contents of do_binmode in doio.c */ +#ifdef DOSISH +# if defined(atarist) || defined(__MINT__) + if (!fflush(fp)) { + if (mode & O_BINARY) + ((FILE*)fp)->_flag |= _IOBIN; + else + ((FILE*)fp)->_flag &= ~ _IOBIN; + return 1; + } + return 0; +# else + dTHX; + if (PerlLIO_setmode(fileno(fp), mode) != -1) { +# if defined(WIN32) && defined(__BORLANDC__) + /* The translation mode of the stream is maintained independent + * of the translation mode of the fd in the Borland RTL (heavy + * digging through their runtime sources reveal). User has to + * set the mode explicitly for the stream (though they don't + * document this anywhere). GSAR 97-5-24 + */ + fseek(fp,0L,0); + if (mode & O_BINARY) + fp->flags |= _F_BIN; + else + fp->flags &= ~ _F_BIN; +# endif + return 1; + } + else + return 0; +# endif +#else +# if defined(USEMYBINMODE) + if (my_binmode(fp, iotype, mode) != FALSE) + return 1; + else + return 0; +# else + return 1; +# endif +#endif +} + +#ifndef PERLIO_LAYERS +int +PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) +{ + if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw")) + { + return 0; + } + Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names); + /* NOTREACHED */ + return -1; +} + +int +PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names) +{ + return perlsio_binmode(fp,iotype,mode); +} + +#endif + -#ifdef PERLIO_IS_STDIO +#ifdef PERLIO_IS_STDIO void PerlIO_init(void) { - /* Does nothing (yet) except force this file to be included + /* Does nothing (yet) except force this file to be included in perl binary. That allows this file to force inclusion - of other functions that may be required by loadable - extensions e.g. for FileHandle::tmpfile + of other functions that may be required by loadable + extensions e.g. for FileHandle::tmpfile */ } @@ -57,7 +128,7 @@ PerlIO_tmpfile(void) #undef HAS_FSETPOS #undef HAS_FGETPOS -/* This section is just to make sure these functions +/* This section is just to make sure these functions get pulled in from libsfio.a */ @@ -71,364 +142,2992 @@ PerlIO_tmpfile(void) void PerlIO_init(void) { - /* Force this file to be included in perl binary. Which allows - * this file to force inclusion of other functions that may be - * required by loadable extensions e.g. for FileHandle::tmpfile + /* Force this file to be included in perl binary. Which allows + * this file to force inclusion of other functions that may be + * required by loadable extensions e.g. for FileHandle::tmpfile */ /* Hack * sfio does its own 'autoflush' on stdout in common cases. - * Flush results in a lot of lseek()s to regular files and + * Flush results in a lot of lseek()s to regular files and * lot of small writes to pipes. */ sfset(sfstdout,SF_SHARE,0); } #else /* USE_SFIO */ +/*======================================================================================*/ +/* Implement all the PerlIO interface ourselves. + */ -/* Implement all the PerlIO interface using stdio. - - this should be only file to include <stdio.h> -*/ +#include "perliol.h" + +/* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */ +#ifdef I_UNISTD +#include <unistd.h> +#endif +#ifdef HAS_MMAP +#include <sys/mman.h> +#endif + +#include "XSUB.h" + +void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2))); + +void +PerlIO_debug(const char *fmt,...) +{ + dTHX; + static int dbg = 0; + va_list ap; + va_start(ap,fmt); + if (!dbg) + { + char *s = PerlEnv_getenv("PERLIO_DEBUG"); + if (s && *s) + dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666); + else + dbg = -1; + } + if (dbg > 0) + { + dTHX; + SV *sv = newSVpvn("",0); + char *s; + STRLEN len; + s = CopFILE(PL_curcop); + if (!s) + s = "(none)"; + Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop)); + Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap); + + s = SvPV(sv,len); + PerlLIO_write(dbg,s,len); + SvREFCNT_dec(sv); + } + va_end(ap); +} + +/*--------------------------------------------------------------------------------------*/ + +/* Inner level routines */ + +/* Table of pointers to the PerlIO structs (malloc'ed) */ +PerlIO *_perlio = NULL; +#define PERLIO_TABLE_SIZE 64 -#undef PerlIO_stderr PerlIO * -PerlIO_stderr(void) +PerlIO_allocate(pTHX) { - return (PerlIO *) stderr; + /* Find a free slot in the table, allocating new table as necessary */ + PerlIO **last; + PerlIO *f; + last = &_perlio; + while ((f = *last)) + { + int i; + last = (PerlIO **)(f); + for (i=1; i < PERLIO_TABLE_SIZE; i++) + { + if (!*++f) + { + return f; + } + } + } + f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO)); + if (!f) + { + return NULL; + } + *last = f; + return f+1; +} + +void +PerlIO_cleantable(pTHX_ PerlIO **tablep) +{ + PerlIO *table = *tablep; + if (table) + { + int i; + PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0])); + for (i=PERLIO_TABLE_SIZE-1; i > 0; i--) + { + PerlIO *f = table+i; + if (*f) + { + PerlIO_close(f); + } + } + PerlMemShared_free(table); + *tablep = NULL; + } +} + +HV *PerlIO_layer_hv; +AV *PerlIO_layer_av; + +void +PerlIO_cleanup() +{ + dTHX; + PerlIO_cleantable(aTHX_ &_perlio); +} + +void +PerlIO_pop(PerlIO *f) +{ + dTHX; + PerlIOl *l = *f; + if (l) + { + PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name); + (*l->tab->Popped)(f); + *f = l->next; + PerlMemShared_free(l); + } +} + +/*--------------------------------------------------------------------------------------*/ +/* XS Interface for perl code */ + +XS(XS_perlio_import) +{ + dXSARGS; + GV *gv = CvGV(cv); + char *s = GvNAME(gv); + STRLEN l = GvNAMELEN(gv); + PerlIO_debug("%.*s\n",(int) l,s); + XSRETURN_EMPTY; +} + +XS(XS_perlio_unimport) +{ + dXSARGS; + GV *gv = CvGV(cv); + char *s = GvNAME(gv); + STRLEN l = GvNAMELEN(gv); + PerlIO_debug("%.*s\n",(int) l,s); + XSRETURN_EMPTY; +} + +SV * +PerlIO_find_layer(const char *name, STRLEN len) +{ + dTHX; + SV **svp; + SV *sv; + if ((SSize_t) len <= 0) + len = strlen(name); + svp = hv_fetch(PerlIO_layer_hv,name,len,0); + if (svp && (sv = *svp) && SvROK(sv)) + return *svp; + return NULL; +} + + +static int +perlio_mg_set(pTHX_ SV *sv, MAGIC *mg) +{ + if (SvROK(sv)) + { + IO *io = GvIOn((GV *)SvRV(sv)); + PerlIO *ifp = IoIFP(io); + PerlIO *ofp = IoOFP(io); + AV *av = (AV *) mg->mg_obj; + Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp); + } + return 0; +} + +static int +perlio_mg_get(pTHX_ SV *sv, MAGIC *mg) +{ + if (SvROK(sv)) + { + IO *io = GvIOn((GV *)SvRV(sv)); + PerlIO *ifp = IoIFP(io); + PerlIO *ofp = IoOFP(io); + AV *av = (AV *) mg->mg_obj; + Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp); + } + return 0; +} + +static int +perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg) +{ + Perl_warn(aTHX_ "clear %"SVf,sv); + return 0; +} + +static int +perlio_mg_free(pTHX_ SV *sv, MAGIC *mg) +{ + Perl_warn(aTHX_ "free %"SVf,sv); + return 0; +} + +MGVTBL perlio_vtab = { + perlio_mg_get, + perlio_mg_set, + NULL, /* len */ + NULL, + perlio_mg_free +}; + +XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) +{ + dXSARGS; + SV *sv = SvRV(ST(1)); + AV *av = newAV(); + MAGIC *mg; + int count = 0; + int i; + sv_magic(sv, (SV *)av, '~', NULL, 0); + SvRMAGICAL_off(sv); + mg = mg_find(sv,'~'); + mg->mg_virtual = &perlio_vtab; + mg_magical(sv); + Perl_warn(aTHX_ "attrib %"SVf,sv); + for (i=2; i < items; i++) + { + STRLEN len; + const char *name = SvPV(ST(i),len); + SV *layer = PerlIO_find_layer(name,len); + if (layer) + { + av_push(av,SvREFCNT_inc(layer)); + } + else + { + ST(count) = ST(i); + count++; + } + } + SvREFCNT_dec(av); + XSRETURN(count); +} + +void +PerlIO_define_layer(PerlIO_funcs *tab) +{ + dTHX; + HV *stash = gv_stashpv("perlio::Layer", TRUE); + SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash); + hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0); +} + +PerlIO_funcs * +PerlIO_default_layer(I32 n) +{ + dTHX; + SV **svp; + SV *layer; + PerlIO_funcs *tab = &PerlIO_stdio; + int len; + if (!PerlIO_layer_hv) + { + const char *s = PerlEnv_getenv("PERLIO"); + newXS("perlio::import",XS_perlio_import,__FILE__); + newXS("perlio::unimport",XS_perlio_unimport,__FILE__); +#if 0 + newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__); +#endif + PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI); + PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI); + PerlIO_define_layer(&PerlIO_unix); + PerlIO_define_layer(&PerlIO_perlio); + PerlIO_define_layer(&PerlIO_stdio); + PerlIO_define_layer(&PerlIO_crlf); +#ifdef HAS_MMAP + PerlIO_define_layer(&PerlIO_mmap); +#endif + av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0))); + if (s) + { + while (*s) + { + while (*s && isSPACE((unsigned char)*s)) + s++; + if (*s) + { + const char *e = s; + SV *layer; + while (*e && !isSPACE((unsigned char)*e)) + e++; + if (*s == ':') + s++; + layer = PerlIO_find_layer(s,e-s); + if (layer) + { + PerlIO_debug("Pushing %.*s\n",(e-s),s); + av_push(PerlIO_layer_av,SvREFCNT_inc(layer)); + } + else + Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s); + s = e; + } + } + } + } + len = av_len(PerlIO_layer_av); + if (len < 1) + { + if (O_BINARY != O_TEXT) + { + av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_crlf.name,0))); + } + else + { + if (PerlIO_stdio.Set_ptrcnt) + { + av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0))); + } + else + { + av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0))); + } + } + len = av_len(PerlIO_layer_av); + } + if (n < 0) + n += len+1; + svp = av_fetch(PerlIO_layer_av,n,0); + if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer)))) + { + tab = INT2PTR(PerlIO_funcs *, SvIV(layer)); + } + /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */ + return tab; +} + +#define PerlIO_default_top() PerlIO_default_layer(-1) +#define PerlIO_default_btm() PerlIO_default_layer(0) + +void +PerlIO_stdstreams() +{ + if (!_perlio) + { + dTHX; + PerlIO_allocate(aTHX); + PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT); + PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT); + PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT); + } } -#undef PerlIO_stdin PerlIO * -PerlIO_stdin(void) +PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len) { - return (PerlIO *) stdin; + dTHX; + PerlIOl *l = NULL; + l = PerlMemShared_calloc(tab->size,sizeof(char)); + if (l) + { + Zero(l,tab->size,char); + l->next = *f; + l->tab = tab; + *f = l; + PerlIO_debug("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)"); + if ((*l->tab->Pushed)(f,mode,arg,len) != 0) + { + PerlIO_pop(f); + return NULL; + } + } + return f; } -#undef PerlIO_stdout +int +PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) +{ + if (names) + { + const char *s = names; + while (*s) + { + while (isSPACE(*s)) + s++; + if (*s == ':') + s++; + if (*s) + { + const char *e = s; + const char *as = Nullch; + const char *ae = Nullch; + int count = 0; + while (*e && *e != ':' && !isSPACE(*e)) + { + if (*e == '(') + { + if (!as) + as = e; + count++; + } + else if (*e == ')') + { + if (as && --count == 0) + ae = e; + } + e++; + } + if (e > s) + { + if ((e - s) == 3 && strncmp(s,"raw",3) == 0) + { + /* Pop back to bottom layer */ + if (PerlIONext(f)) + { + PerlIO_flush(f); + while (PerlIONext(f)) + { + PerlIO_pop(f); + } + } + } + else if ((e - s) == 4 && strncmp(s,"utf8",4) == 0) + { + PerlIOBase(f)->flags |= PERLIO_F_UTF8; + } + else if ((e - s) == 5 && strncmp(s,"bytes",5) == 0) + { + PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; + } + else + { + STRLEN len = ((as) ? as : e)-s; + SV *layer = PerlIO_find_layer(s,len); + if (layer) + { + PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer))); + if (tab) + { + len = (as) ? (ae-(as++)-1) : 0; + if (!PerlIO_push(f,tab,mode,as,len)) + return -1; + } + } + else + Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)len,s); + } + } + s = e; + } + } + } + return 0; +} + + + +/*--------------------------------------------------------------------------------------*/ +/* Given the abstraction above the public API functions */ + +int +PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) +{ + PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", + f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)"); + if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY))) + { + PerlIO *top = f; + PerlIOl *l; + while (l = *top) + { + if (PerlIOBase(top)->tab == &PerlIO_crlf) + { + PerlIO_flush(top); + PerlIOBase(top)->flags &= ~PERLIO_F_CRLF; + break; + } + top = PerlIONext(top); + } + } + return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE; +} + +#undef PerlIO__close +int +PerlIO__close(PerlIO *f) +{ + return (*PerlIOBase(f)->tab->Close)(f); +} + +#undef PerlIO_fdupopen PerlIO * -PerlIO_stdout(void) +PerlIO_fdupopen(pTHX_ PerlIO *f) +{ + char buf[8]; + int fd = PerlLIO_dup(PerlIO_fileno(f)); + PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf)); + if (new) + { + Off_t posn = PerlIO_tell(f); + PerlIO_seek(new,posn,SEEK_SET); + } + return new; +} + +#undef PerlIO_close +int +PerlIO_close(PerlIO *f) +{ + int code = (*PerlIOBase(f)->tab->Close)(f); + while (*f) + { + PerlIO_pop(f); + } + return code; +} + +#undef PerlIO_fileno +int +PerlIO_fileno(PerlIO *f) +{ + return (*PerlIOBase(f)->tab->Fileno)(f); +} + + + +#undef PerlIO_fdopen +PerlIO * +PerlIO_fdopen(int fd, const char *mode) +{ + PerlIO_funcs *tab = PerlIO_default_top(); + if (!_perlio) + PerlIO_stdstreams(); + return (*tab->Fdopen)(tab,fd,mode); +} + +#undef PerlIO_open +PerlIO * +PerlIO_open(const char *path, const char *mode) +{ + PerlIO_funcs *tab = PerlIO_default_top(); + if (!_perlio) + PerlIO_stdstreams(); + return (*tab->Open)(tab,path,mode); +} + +#undef PerlIO_reopen +PerlIO * +PerlIO_reopen(const char *path, const char *mode, PerlIO *f) +{ + if (f) + { + PerlIO_flush(f); + if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0) + { + if ((*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0) == 0) + return f; + } + return NULL; + } + else + return PerlIO_open(path,mode); +} + +#undef PerlIO_read +SSize_t +PerlIO_read(PerlIO *f, void *vbuf, Size_t count) +{ + return (*PerlIOBase(f)->tab->Read)(f,vbuf,count); +} + +#undef PerlIO_unread +SSize_t +PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count) +{ + return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count); +} + +#undef PerlIO_write +SSize_t +PerlIO_write(PerlIO *f, const void *vbuf, Size_t count) +{ + return (*PerlIOBase(f)->tab->Write)(f,vbuf,count); +} + +#undef PerlIO_seek +int +PerlIO_seek(PerlIO *f, Off_t offset, int whence) +{ + return (*PerlIOBase(f)->tab->Seek)(f,offset,whence); +} + +#undef PerlIO_tell +Off_t +PerlIO_tell(PerlIO *f) +{ + return (*PerlIOBase(f)->tab->Tell)(f); +} + +#undef PerlIO_flush +int +PerlIO_flush(PerlIO *f) +{ + if (f) + { + return (*PerlIOBase(f)->tab->Flush)(f); + } + else + { + PerlIO **table = &_perlio; + int code = 0; + while ((f = *table)) + { + int i; + table = (PerlIO **)(f++); + for (i=1; i < PERLIO_TABLE_SIZE; i++) + { + if (*f && PerlIO_flush(f) != 0) + code = -1; + f++; + } + } + return code; + } +} + +#undef PerlIO_fill +int +PerlIO_fill(PerlIO *f) +{ + return (*PerlIOBase(f)->tab->Fill)(f); +} + +#undef PerlIO_isutf8 +int +PerlIO_isutf8(PerlIO *f) +{ + return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0; +} + +#undef PerlIO_eof +int +PerlIO_eof(PerlIO *f) +{ + return (*PerlIOBase(f)->tab->Eof)(f); +} + +#undef PerlIO_error +int +PerlIO_error(PerlIO *f) { - return (PerlIO *) stdout; + return (*PerlIOBase(f)->tab->Error)(f); +} + +#undef PerlIO_clearerr +void +PerlIO_clearerr(PerlIO *f) +{ + if (f && *f) + (*PerlIOBase(f)->tab->Clearerr)(f); +} + +#undef PerlIO_setlinebuf +void +PerlIO_setlinebuf(PerlIO *f) +{ + (*PerlIOBase(f)->tab->Setlinebuf)(f); +} + +#undef PerlIO_has_base +int +PerlIO_has_base(PerlIO *f) +{ + if (f && *f) + { + return (PerlIOBase(f)->tab->Get_base != NULL); + } + return 0; } #undef PerlIO_fast_gets -int +int PerlIO_fast_gets(PerlIO *f) { -#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) - return 1; -#else + if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) + { + PerlIO_funcs *tab = PerlIOBase(f)->tab; + return (tab->Set_ptrcnt != NULL); + } return 0; -#endif } #undef PerlIO_has_cntptr -int +int PerlIO_has_cntptr(PerlIO *f) { -#if defined(USE_STDIO_PTR) - return 1; -#else + if (f && *f) + { + PerlIO_funcs *tab = PerlIOBase(f)->tab; + return (tab->Get_ptr != NULL && tab->Get_cnt != NULL); + } return 0; -#endif } #undef PerlIO_canset_cnt -int +int PerlIO_canset_cnt(PerlIO *f) { -#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) - return 1; -#else + if (f && *f) + { + PerlIOl *l = PerlIOBase(f); + return (l->tab->Set_ptrcnt != NULL); + } return 0; -#endif +} + +#undef PerlIO_get_base +STDCHAR * +PerlIO_get_base(PerlIO *f) +{ + return (*PerlIOBase(f)->tab->Get_base)(f); +} + +#undef PerlIO_get_bufsiz +int +PerlIO_get_bufsiz(PerlIO *f) +{ + return (*PerlIOBase(f)->tab->Get_bufsiz)(f); +} + +#undef PerlIO_get_ptr +STDCHAR * +PerlIO_get_ptr(PerlIO *f) +{ + PerlIO_funcs *tab = PerlIOBase(f)->tab; + if (tab->Get_ptr == NULL) + return NULL; + return (*tab->Get_ptr)(f); +} + +#undef PerlIO_get_cnt +int +PerlIO_get_cnt(PerlIO *f) +{ + PerlIO_funcs *tab = PerlIOBase(f)->tab; + if (tab->Get_cnt == NULL) + return 0; + return (*tab->Get_cnt)(f); } #undef PerlIO_set_cnt void -PerlIO_set_cnt(PerlIO *f, int cnt) +PerlIO_set_cnt(PerlIO *f,int cnt) { - dTHX; - if (cnt < -1 && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d\n",cnt); -#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) - FILE_cnt(f) = cnt; -#else - Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system"); -#endif + (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt); } #undef PerlIO_set_ptrcnt void PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt) { - dTHX; -#ifdef FILE_bufsiz - STDCHAR *e = FILE_base(f) + FILE_bufsiz(f); - int ec = e - ptr; - if (ptr > e + 1 && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Setting ptr %p > end+1 %p\n", ptr, e + 1); - if (cnt != ec && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d, ptr implies %d\n",cnt,ec); -#endif -#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) - FILE_ptr(f) = ptr; -#else - Perl_croak(aTHX_ "Cannot set 'ptr' of FILE * on this system"); + PerlIO_funcs *tab = PerlIOBase(f)->tab; + if (tab->Set_ptrcnt == NULL) + { + dTHX; + Perl_croak(aTHX_ "PerlIO buffer snooping abuse"); + } + (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt); +} + +/*--------------------------------------------------------------------------------------*/ +/* "Methods" of the "base class" */ + +IV +PerlIOBase_fileno(PerlIO *f) +{ + return PerlIO_fileno(PerlIONext(f)); +} + +char * +PerlIO_modestr(PerlIO *f,char *buf) +{ + char *s = buf; + IV flags = PerlIOBase(f)->flags; + if (flags & PERLIO_F_APPEND) + { + *s++ = 'a'; + if (flags & PERLIO_F_CANREAD) + { + *s++ = '+'; + } + } + else if (flags & PERLIO_F_CANREAD) + { + *s++ = 'r'; + if (flags & PERLIO_F_CANWRITE) + *s++ = '+'; + } + else if (flags & PERLIO_F_CANWRITE) + { + *s++ = 'w'; + if (flags & PERLIO_F_CANREAD) + { + *s++ = '+'; + } + } +#if O_TEXT != O_BINARY + if (!(flags & PERLIO_F_CRLF)) + *s++ = 'b'; #endif -#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) - FILE_cnt(f) = cnt; -#else - Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system"); + *s = '\0'; + return buf; +} + +IV +PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +{ + PerlIOl *l = PerlIOBase(f); + const char *omode = mode; + char temp[8]; + PerlIO_funcs *tab = PerlIOBase(f)->tab; + l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE| + PERLIO_F_TRUNCATE|PERLIO_F_APPEND); + if (tab->Set_ptrcnt != NULL) + l->flags |= PERLIO_F_FASTGETS; + if (mode) + { + switch (*mode++) + { + case 'r': + l->flags |= PERLIO_F_CANREAD; + break; + case 'a': + l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE; + break; + case 'w': + l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE; + break; + default: + errno = EINVAL; + return -1; + } + while (*mode) + { + switch (*mode++) + { + case '+': + l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE; + break; + case 'b': + l->flags &= ~PERLIO_F_CRLF; + break; + case 't': + l->flags |= PERLIO_F_CRLF; + break; + default: + errno = EINVAL; + return -1; + } + } + } + else + { + if (l->next) + { + l->flags |= l->next->flags & + (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND); + } + } +#if 0 + PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n", + f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)", + l->flags,PerlIO_modestr(f,temp)); #endif + return 0; } -#undef PerlIO_get_cnt -int -PerlIO_get_cnt(PerlIO *f) +IV +PerlIOBase_popped(PerlIO *f) +{ + return 0; +} + +SSize_t +PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count) +{ + Off_t old = PerlIO_tell(f); + SSize_t done; + PerlIO_push(f,&PerlIO_pending,"r",Nullch,0); + done = PerlIOBuf_unread(f,vbuf,count); + PerlIOSelf(f,PerlIOBuf)->posn = old - done; + return done; +} + +IV +PerlIOBase_noop_ok(PerlIO *f) +{ + return 0; +} + +IV +PerlIOBase_noop_fail(PerlIO *f) +{ + return -1; +} + +IV +PerlIOBase_close(PerlIO *f) +{ + IV code = 0; + PerlIO *n = PerlIONext(f); + if (PerlIO_flush(f) != 0) + code = -1; + if (n && (*PerlIOBase(n)->tab->Close)(n) != 0) + code = -1; + PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN); + return code; +} + +IV +PerlIOBase_eof(PerlIO *f) +{ + if (f && *f) + { + return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0; + } + return 1; +} + +IV +PerlIOBase_error(PerlIO *f) +{ + if (f && *f) + { + return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0; + } + return 1; +} + +void +PerlIOBase_clearerr(PerlIO *f) +{ + if (f && *f) + { + PerlIO *n = PerlIONext(f); + PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF); + if (n) + PerlIO_clearerr(n); + } +} + +void +PerlIOBase_setlinebuf(PerlIO *f) +{ + +} + +/*--------------------------------------------------------------------------------------*/ +/* Bottom-most level for UNIX-like case */ + +typedef struct +{ + struct _PerlIO base; /* The generic part */ + int fd; /* UNIX like file descriptor */ + int oflags; /* open/fcntl flags */ +} PerlIOUnix; + +int +PerlIOUnix_oflags(const char *mode) +{ + int oflags = -1; + switch(*mode) + { + case 'r': + oflags = O_RDONLY; + if (*++mode == '+') + { + oflags = O_RDWR; + mode++; + } + break; + + case 'w': + oflags = O_CREAT|O_TRUNC; + if (*++mode == '+') + { + oflags |= O_RDWR; + mode++; + } + else + oflags |= O_WRONLY; + break; + + case 'a': + oflags = O_CREAT|O_APPEND; + if (*++mode == '+') + { + oflags |= O_RDWR; + mode++; + } + else + oflags |= O_WRONLY; + break; + } + if (*mode == 'b') + { + oflags |= O_BINARY; + oflags &= ~O_TEXT; + mode++; + } + else if (*mode == 't') + { + oflags |= O_TEXT; + oflags &= ~O_BINARY; + mode++; + } + /* Always open in binary mode */ + oflags |= O_BINARY; + if (*mode || oflags == -1) + { + errno = EINVAL; + oflags = -1; + } + return oflags; +} + +IV +PerlIOUnix_fileno(PerlIO *f) +{ + return PerlIOSelf(f,PerlIOUnix)->fd; +} + +PerlIO * +PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode) +{ + dTHX; + PerlIO *f = NULL; + if (*mode == 'I') + mode++; + if (fd >= 0) + { + int oflags = PerlIOUnix_oflags(mode); + if (oflags != -1) + { + PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix); + s->fd = fd; + s->oflags = oflags; + PerlIOBase(f)->flags |= PERLIO_F_OPEN; + } + } + return f; +} + +PerlIO * +PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode) { -#ifdef FILE_cnt - return FILE_cnt(f); -#else dTHX; - Perl_croak(aTHX_ "Cannot get 'cnt' of FILE * on this system"); + PerlIO *f = NULL; + int oflags = PerlIOUnix_oflags(mode); + if (oflags != -1) + { + int fd = PerlLIO_open3(path,oflags,0666); + if (fd >= 0) + { + PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix); + s->fd = fd; + s->oflags = oflags; + PerlIOBase(f)->flags |= PERLIO_F_OPEN; + } + } + return f; +} + +int +PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f) +{ + PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix); + int oflags = PerlIOUnix_oflags(mode); + if (PerlIOBase(f)->flags & PERLIO_F_OPEN) + (*PerlIOBase(f)->tab->Close)(f); + if (oflags != -1) + { + dTHX; + int fd = PerlLIO_open3(path,oflags,0666); + if (fd >= 0) + { + s->fd = fd; + s->oflags = oflags; + PerlIOBase(f)->flags |= PERLIO_F_OPEN; + return 0; + } + } return -1; -#endif } -#undef PerlIO_get_bufsiz -int -PerlIO_get_bufsiz(PerlIO *f) +SSize_t +PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count) +{ + dTHX; + int fd = PerlIOSelf(f,PerlIOUnix)->fd; + if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) + return 0; + while (1) + { + SSize_t len = PerlLIO_read(fd,vbuf,count); + if (len >= 0 || errno != EINTR) + { + if (len < 0) + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + else if (len == 0 && count != 0) + PerlIOBase(f)->flags |= PERLIO_F_EOF; + return len; + } + } +} + +SSize_t +PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count) +{ + dTHX; + int fd = PerlIOSelf(f,PerlIOUnix)->fd; + while (1) + { + SSize_t len = PerlLIO_write(fd,vbuf,count); + if (len >= 0 || errno != EINTR) + { + if (len < 0) + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + return len; + } + } +} + +IV +PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence) +{ + dTHX; + Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence); + PerlIOBase(f)->flags &= ~PERLIO_F_EOF; + return (new == (Off_t) -1) ? -1 : 0; +} + +Off_t +PerlIOUnix_tell(PerlIO *f) +{ + dTHX; + Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR); + return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR); +} + +IV +PerlIOUnix_close(PerlIO *f) +{ + dTHX; + int fd = PerlIOSelf(f,PerlIOUnix)->fd; + int code = 0; + while (PerlLIO_close(fd) != 0) + { + if (errno != EINTR) + { + code = -1; + break; + } + } + if (code == 0) + { + PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; + } + return code; +} + +PerlIO_funcs PerlIO_unix = { + "unix", + sizeof(PerlIOUnix), + PERLIO_K_RAW, + PerlIOUnix_fileno, + PerlIOUnix_fdopen, + PerlIOUnix_open, + PerlIOUnix_reopen, + PerlIOBase_pushed, + PerlIOBase_noop_ok, + PerlIOUnix_read, + PerlIOBase_unread, + PerlIOUnix_write, + PerlIOUnix_seek, + PerlIOUnix_tell, + PerlIOUnix_close, + PerlIOBase_noop_ok, /* flush */ + PerlIOBase_noop_fail, /* fill */ + PerlIOBase_eof, + PerlIOBase_error, + PerlIOBase_clearerr, + PerlIOBase_setlinebuf, + NULL, /* get_base */ + NULL, /* get_bufsiz */ + NULL, /* get_ptr */ + NULL, /* get_cnt */ + NULL, /* set_ptrcnt */ +}; + +/*--------------------------------------------------------------------------------------*/ +/* stdio as a layer */ + +typedef struct +{ + struct _PerlIO base; + FILE * stdio; /* The stream */ +} PerlIOStdio; + +IV +PerlIOStdio_fileno(PerlIO *f) +{ + dTHX; + return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio); +} + +char * +PerlIOStdio_mode(const char *mode,char *tmode) +{ + char *ret = tmode; + while (*mode) + { + *tmode++ = *mode++; + } + if (O_BINARY != O_TEXT) + { + *tmode++ = 'b'; + } + *tmode = '\0'; + return ret; +} + +PerlIO * +PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode) +{ + dTHX; + PerlIO *f = NULL; + int init = 0; + char tmode[8]; + if (*mode == 'I') + { + init = 1; + mode++; + } + if (fd >= 0) + { + FILE *stdio = NULL; + if (init) + { + switch(fd) + { + case 0: + stdio = PerlSIO_stdin; + break; + case 1: + stdio = PerlSIO_stdout; + break; + case 2: + stdio = PerlSIO_stderr; + break; + } + } + else + { + stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode)); + } + if (stdio) + { + PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio); + s->stdio = stdio; + } + } + return f; +} + +#undef PerlIO_importFILE +PerlIO * +PerlIO_importFILE(FILE *stdio, int fl) +{ + dTHX; + PerlIO *f = NULL; + if (stdio) + { + PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio); + s->stdio = stdio; + } + return f; +} + +PerlIO * +PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode) +{ + dTHX; + PerlIO *f = NULL; + FILE *stdio = PerlSIO_fopen(path,mode); + if (stdio) + { + char tmode[8]; + PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self, + (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0), + PerlIOStdio); + s->stdio = stdio; + } + return f; +} + +int +PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f) +{ + dTHX; + PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio); + char tmode[8]; + FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio); + if (!s->stdio) + return -1; + s->stdio = stdio; + return 0; +} + +SSize_t +PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count) +{ + dTHX; + FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio; + SSize_t got = 0; + if (count == 1) + { + STDCHAR *buf = (STDCHAR *) vbuf; + /* Perl is expecting PerlIO_getc() to fill the buffer + * Linux's stdio does not do that for fread() + */ + int ch = PerlSIO_fgetc(s); + if (ch != EOF) + { + *buf = ch; + got = 1; + } + } + else + got = PerlSIO_fread(vbuf,1,count,s); + return got; +} + +SSize_t +PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count) +{ + dTHX; + FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio; + STDCHAR *buf = ((STDCHAR *)vbuf)+count-1; + SSize_t unread = 0; + while (count > 0) + { + int ch = *buf-- & 0xff; + if (PerlSIO_ungetc(ch,s) != ch) + break; + unread++; + count--; + } + return unread; +} + +SSize_t +PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count) +{ + dTHX; + return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio); +} + +IV +PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence) +{ + dTHX; + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + return PerlSIO_fseek(stdio,offset,whence); +} + +Off_t +PerlIOStdio_tell(PerlIO *f) +{ + dTHX; + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + return PerlSIO_ftell(stdio); +} + +IV +PerlIOStdio_close(PerlIO *f) { -#ifdef FILE_bufsiz - return FILE_bufsiz(f); + dTHX; +#ifdef HAS_SOCKET + int optval, optlen = sizeof(int); +#endif + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + return( +#ifdef HAS_SOCKET + (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ? + PerlSIO_fclose(stdio) : + close(PerlIO_fileno(f)) #else + PerlSIO_fclose(stdio) +#endif + ); + +} + +IV +PerlIOStdio_flush(PerlIO *f) +{ dTHX; - Perl_croak(aTHX_ "Cannot get 'bufsiz' of FILE * on this system"); - return -1; + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) + { + return PerlSIO_fflush(stdio); + } + else + { +#if 0 + /* FIXME: This discards ungetc() and pre-read stuff which is + not right if this is just a "sync" from a layer above + Suspect right design is to do _this_ but not have layer above + flush this layer read-to-read + */ + /* Not writeable - sync by attempting a seek */ + int err = errno; + if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0) + errno = err; #endif + } + return 0; } -#undef PerlIO_get_ptr -STDCHAR * -PerlIO_get_ptr(PerlIO *f) +IV +PerlIOStdio_fill(PerlIO *f) { -#ifdef FILE_ptr - return FILE_ptr(f); -#else dTHX; - Perl_croak(aTHX_ "Cannot get 'ptr' of FILE * on this system"); - return NULL; + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + int c; + /* fflush()ing read-only streams can cause trouble on some stdio-s */ + if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) + { + if (PerlSIO_fflush(stdio) != 0) + return EOF; + } + c = PerlSIO_fgetc(stdio); + if (c == EOF || PerlSIO_ungetc(c,stdio) != c) + return EOF; + return 0; +} + +IV +PerlIOStdio_eof(PerlIO *f) +{ + dTHX; + return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio); +} + +IV +PerlIOStdio_error(PerlIO *f) +{ + dTHX; + return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio); +} + +void +PerlIOStdio_clearerr(PerlIO *f) +{ + dTHX; + PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio); +} + +void +PerlIOStdio_setlinebuf(PerlIO *f) +{ + dTHX; +#ifdef HAS_SETLINEBUF + PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio); +#else + PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0); #endif } -#undef PerlIO_get_base +#ifdef FILE_base STDCHAR * -PerlIO_get_base(PerlIO *f) +PerlIOStdio_get_base(PerlIO *f) { -#ifdef FILE_base - return FILE_base(f); -#else dTHX; - Perl_croak(aTHX_ "Cannot get 'base' of FILE * on this system"); - return NULL; + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + return PerlSIO_get_base(stdio); +} + +Size_t +PerlIOStdio_get_bufsiz(PerlIO *f) +{ + dTHX; + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + return PerlSIO_get_bufsiz(stdio); +} #endif + +#ifdef USE_STDIO_PTR +STDCHAR * +PerlIOStdio_get_ptr(PerlIO *f) +{ + dTHX; + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + return PerlSIO_get_ptr(stdio); } -#undef PerlIO_has_base -int -PerlIO_has_base(PerlIO *f) +SSize_t +PerlIOStdio_get_cnt(PerlIO *f) { + dTHX; + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + return PerlSIO_get_cnt(stdio); +} + +void +PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt) +{ + dTHX; + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + if (ptr != NULL) + { +#ifdef STDIO_PTR_LVALUE + PerlSIO_set_ptr(stdio,ptr); +#ifdef STDIO_PTR_LVAL_SETS_CNT + if (PerlSIO_get_cnt(stdio) != (cnt)) + { + dTHX; + assert(PerlSIO_get_cnt(stdio) == (cnt)); + } +#endif +#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT)) + /* Setting ptr _does_ change cnt - we are done */ + return; +#endif +#else /* STDIO_PTR_LVALUE */ + PerlProc_abort(); +#endif /* STDIO_PTR_LVALUE */ + } +/* Now (or only) set cnt */ +#ifdef STDIO_CNT_LVALUE + PerlSIO_set_cnt(stdio,cnt); +#else /* STDIO_CNT_LVALUE */ +#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT)) + PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt)); +#else /* STDIO_PTR_LVAL_SETS_CNT */ + PerlProc_abort(); +#endif /* STDIO_PTR_LVAL_SETS_CNT */ +#endif /* STDIO_CNT_LVALUE */ +} + +#endif + +PerlIO_funcs PerlIO_stdio = { + "stdio", + sizeof(PerlIOStdio), + PERLIO_K_BUFFERED, + PerlIOStdio_fileno, + PerlIOStdio_fdopen, + PerlIOStdio_open, + PerlIOStdio_reopen, + PerlIOBase_pushed, + PerlIOBase_noop_ok, + PerlIOStdio_read, + PerlIOStdio_unread, + PerlIOStdio_write, + PerlIOStdio_seek, + PerlIOStdio_tell, + PerlIOStdio_close, + PerlIOStdio_flush, + PerlIOStdio_fill, + PerlIOStdio_eof, + PerlIOStdio_error, + PerlIOStdio_clearerr, + PerlIOStdio_setlinebuf, #ifdef FILE_base - return 1; + PerlIOStdio_get_base, + PerlIOStdio_get_bufsiz, #else - return 0; + NULL, + NULL, #endif +#ifdef USE_STDIO_PTR + PerlIOStdio_get_ptr, + PerlIOStdio_get_cnt, +#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT))) + PerlIOStdio_set_ptrcnt +#else /* STDIO_PTR_LVALUE */ + NULL +#endif /* STDIO_PTR_LVALUE */ +#else /* USE_STDIO_PTR */ + NULL, + NULL, + NULL +#endif /* USE_STDIO_PTR */ +}; + +#undef PerlIO_exportFILE +FILE * +PerlIO_exportFILE(PerlIO *f, int fl) +{ + FILE *stdio; + PerlIO_flush(f); + stdio = fdopen(PerlIO_fileno(f),"r+"); + if (stdio) + { + PerlIOStdio *s = PerlIOSelf(PerlIO_push(f,&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio); + s->stdio = stdio; + } + return stdio; +} + +#undef PerlIO_findFILE +FILE * +PerlIO_findFILE(PerlIO *f) +{ + PerlIOl *l = *f; + while (l) + { + if (l->tab == &PerlIO_stdio) + { + PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio); + return s->stdio; + } + l = *PerlIONext(&l); + } + return PerlIO_exportFILE(f,0); +} + +#undef PerlIO_releaseFILE +void +PerlIO_releaseFILE(PerlIO *p, FILE *f) +{ +} + +/*--------------------------------------------------------------------------------------*/ +/* perlio buffer layer */ + +IV +PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + b->posn = PerlIO_tell(PerlIONext(f)); + return PerlIOBase_pushed(f,mode,arg,len); +} + +PerlIO * +PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode) +{ + dTHX; + PerlIO_funcs *tab = PerlIO_default_btm(); + int init = 0; + PerlIO *f; + if (*mode == 'I') + { + init = 1; + mode++; + } +#if O_BINARY != O_TEXT + /* do something about failing setmode()? --jhi */ + PerlLIO_setmode(fd, O_BINARY); +#endif + f = (*tab->Fdopen)(tab,fd,mode); + if (f) + { + PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf); + if (init && fd == 2) + { + /* Initial stderr is unbuffered */ + PerlIOBase(f)->flags |= PERLIO_F_UNBUF; + } +#if 0 + PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n", + self->name,f,fd,mode,PerlIOBase(f)->flags); +#endif + } + return f; +} + +PerlIO * +PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode) +{ + PerlIO_funcs *tab = PerlIO_default_btm(); + PerlIO *f = (*tab->Open)(tab,path,mode); + if (f) + { + PerlIO_push(f,self,mode,Nullch,0); + } + return f; } -#undef PerlIO_puts int -PerlIO_puts(PerlIO *f, const char *s) +PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f) { - return fputs(s,f); + PerlIO *next = PerlIONext(f); + int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next); + if (code = 0) + code = (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0); + return code; } -#undef PerlIO_open -PerlIO * -PerlIO_open(const char *path, const char *mode) +/* This "flush" is akin to sfio's sync in that it handles files in either + read or write state +*/ +IV +PerlIOBuf_flush(PerlIO *f) { - return fopen(path,mode); + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + int code = 0; + if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) + { + /* write() the buffer */ + STDCHAR *buf = b->buf; + STDCHAR *p = buf; + int count; + PerlIO *n = PerlIONext(f); + while (p < b->ptr) + { + count = PerlIO_write(n,p,b->ptr - p); + if (count > 0) + { + p += count; + } + else if (count < 0 || PerlIO_error(n)) + { + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + code = -1; + break; + } + } + b->posn += (p - buf); + } + else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) + { + STDCHAR *buf = PerlIO_get_base(f); + /* Note position change */ + b->posn += (b->ptr - buf); + if (b->ptr < b->end) + { + /* We did not consume all of it */ + if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0) + { + b->posn = PerlIO_tell(PerlIONext(f)); + } + } + } + b->ptr = b->end = b->buf; + PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF); + /* FIXME: Is this right for read case ? */ + if (PerlIO_flush(PerlIONext(f)) != 0) + code = -1; + return code; } -#undef PerlIO_fdopen -PerlIO * -PerlIO_fdopen(int fd, const char *mode) +IV +PerlIOBuf_fill(PerlIO *f) { - return fdopen(fd,mode); + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + PerlIO *n = PerlIONext(f); + SSize_t avail; + /* FIXME: doing the down-stream flush is a bad idea if it causes + pre-read data in stdio buffer to be discarded + but this is too simplistic - as it skips _our_ hosekeeping + and breaks tell tests. + if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) + { + } + */ + if (PerlIO_flush(f) != 0) + return -1; + + if (!b->buf) + PerlIO_get_base(f); /* allocate via vtable */ + + b->ptr = b->end = b->buf; + if (PerlIO_fast_gets(n)) + { + /* Layer below is also buffered + * We do _NOT_ want to call its ->Read() because that will loop + * till it gets what we asked for which may hang on a pipe etc. + * Instead take anything it has to hand, or ask it to fill _once_. + */ + avail = PerlIO_get_cnt(n); + if (avail <= 0) + { + avail = PerlIO_fill(n); + if (avail == 0) + avail = PerlIO_get_cnt(n); + else + { + if (!PerlIO_error(n) && PerlIO_eof(n)) + avail = 0; + } + } + if (avail > 0) + { + STDCHAR *ptr = PerlIO_get_ptr(n); + SSize_t cnt = avail; + if (avail > b->bufsiz) + avail = b->bufsiz; + Copy(ptr,b->buf,avail,STDCHAR); + PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail); + } + } + else + { + avail = PerlIO_read(n,b->ptr,b->bufsiz); + } + if (avail <= 0) + { + if (avail == 0) + PerlIOBase(f)->flags |= PERLIO_F_EOF; + else + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + return -1; + } + b->end = b->buf+avail; + PerlIOBase(f)->flags |= PERLIO_F_RDBUF; + return 0; } -#undef PerlIO_reopen -PerlIO * -PerlIO_reopen(const char *name, const char *mode, PerlIO *f) +SSize_t +PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count) { - return freopen(name,mode,f); + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + STDCHAR *buf = (STDCHAR *) vbuf; + if (f) + { + if (!b->ptr) + PerlIO_get_base(f); + if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) + return 0; + while (count > 0) + { + SSize_t avail = PerlIO_get_cnt(f); + SSize_t take = (count < avail) ? count : avail; + if (take > 0) + { + STDCHAR *ptr = PerlIO_get_ptr(f); + Copy(ptr,buf,take,STDCHAR); + PerlIO_set_ptrcnt(f,ptr+take,(avail -= take)); + count -= take; + buf += take; + } + if (count > 0 && avail <= 0) + { + if (PerlIO_fill(f) != 0) + break; + } + } + return (buf - (STDCHAR *) vbuf); + } + return 0; } -#undef PerlIO_close -int -PerlIO_close(PerlIO *f) +SSize_t +PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count) { - return fclose(f); + const STDCHAR *buf = (const STDCHAR *) vbuf+count; + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + SSize_t unread = 0; + SSize_t avail; + if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) + PerlIO_flush(f); + if (!b->buf) + PerlIO_get_base(f); + if (b->buf) + { + if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) + { + avail = (b->ptr - b->buf); + } + else + { + avail = b->bufsiz; + b->end = b->buf + avail; + b->ptr = b->end; + PerlIOBase(f)->flags |= PERLIO_F_RDBUF; + b->posn -= b->bufsiz; + } + if (avail > (SSize_t) count) + avail = count; + if (avail > 0) + { + b->ptr -= avail; + buf -= avail; + if (buf != b->ptr) + { + Copy(buf,b->ptr,avail,STDCHAR); + } + count -= avail; + unread += avail; + PerlIOBase(f)->flags &= ~ PERLIO_F_EOF; + } + } + return unread; } -#undef PerlIO_eof -int -PerlIO_eof(PerlIO *f) +SSize_t +PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + const STDCHAR *buf = (const STDCHAR *) vbuf; + Size_t written = 0; + if (!b->buf) + PerlIO_get_base(f); + if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) + return 0; + while (count > 0) + { + SSize_t avail = b->bufsiz - (b->ptr - b->buf); + if ((SSize_t) count < avail) + avail = count; + PerlIOBase(f)->flags |= PERLIO_F_WRBUF; + if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) + { + while (avail > 0) + { + int ch = *buf++; + *(b->ptr)++ = ch; + count--; + avail--; + written++; + if (ch == '\n') + { + PerlIO_flush(f); + break; + } + } + } + else + { + if (avail) + { + Copy(buf,b->ptr,avail,STDCHAR); + count -= avail; + buf += avail; + written += avail; + b->ptr += avail; + } + } + if (b->ptr >= (b->buf + b->bufsiz)) + PerlIO_flush(f); + } + if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) + PerlIO_flush(f); + return written; +} + +IV +PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence) +{ + IV code; + if ((code = PerlIO_flush(f)) == 0) + { + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + PerlIOBase(f)->flags &= ~PERLIO_F_EOF; + code = PerlIO_seek(PerlIONext(f),offset,whence); + if (code == 0) + { + b->posn = PerlIO_tell(PerlIONext(f)); + } + } + return code; +} + +Off_t +PerlIOBuf_tell(PerlIO *f) { - return feof(f); + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + Off_t posn = b->posn; + if (b->buf) + posn += (b->ptr - b->buf); + return posn; } -#undef PerlIO_getname -char * -PerlIO_getname(PerlIO *f, char *buf) +IV +PerlIOBuf_close(PerlIO *f) { -#ifdef VMS - return fgetname(f,buf); -#else dTHX; - Perl_croak(aTHX_ "Don't know how to get file name"); - return NULL; -#endif + IV code = PerlIOBase_close(f); + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + if (b->buf && b->buf != (STDCHAR *) &b->oneword) + { + PerlMemShared_free(b->buf); + } + b->buf = NULL; + b->ptr = b->end = b->buf; + PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF); + return code; } -#undef PerlIO_getc -int -PerlIO_getc(PerlIO *f) +void +PerlIOBuf_setlinebuf(PerlIO *f) { - return fgetc(f); + if (f) + { + PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF; + } } -#undef PerlIO_error -int -PerlIO_error(PerlIO *f) +STDCHAR * +PerlIOBuf_get_ptr(PerlIO *f) { - return ferror(f); + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + if (!b->buf) + PerlIO_get_base(f); + return b->ptr; +} + +SSize_t +PerlIOBuf_get_cnt(PerlIO *f) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + if (!b->buf) + PerlIO_get_base(f); + if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) + return (b->end - b->ptr); + return 0; +} + +STDCHAR * +PerlIOBuf_get_base(PerlIO *f) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + if (!b->buf) + { + dTHX; + if (!b->bufsiz) + b->bufsiz = 4096; + b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR)); + if (!b->buf) + { + b->buf = (STDCHAR *)&b->oneword; + b->bufsiz = sizeof(b->oneword); + } + b->ptr = b->buf; + b->end = b->ptr; + } + return b->buf; +} + +Size_t +PerlIOBuf_bufsiz(PerlIO *f) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + if (!b->buf) + PerlIO_get_base(f); + return (b->end - b->buf); } -#undef PerlIO_clearerr void -PerlIO_clearerr(PerlIO *f) +PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt) { - clearerr(f); + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + if (!b->buf) + PerlIO_get_base(f); + b->ptr = ptr; + if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) + { + dTHX; + assert(PerlIO_get_cnt(f) == cnt); + assert(b->ptr >= b->buf); + } + PerlIOBase(f)->flags |= PERLIO_F_RDBUF; } -#undef PerlIO_flush -int -PerlIO_flush(PerlIO *f) +PerlIO_funcs PerlIO_perlio = { + "perlio", + sizeof(PerlIOBuf), + PERLIO_K_BUFFERED, + PerlIOBase_fileno, + PerlIOBuf_fdopen, + PerlIOBuf_open, + PerlIOBuf_reopen, + PerlIOBuf_pushed, + PerlIOBase_noop_ok, + PerlIOBuf_read, + PerlIOBuf_unread, + PerlIOBuf_write, + PerlIOBuf_seek, + PerlIOBuf_tell, + PerlIOBuf_close, + PerlIOBuf_flush, + PerlIOBuf_fill, + PerlIOBase_eof, + PerlIOBase_error, + PerlIOBase_clearerr, + PerlIOBuf_setlinebuf, + PerlIOBuf_get_base, + PerlIOBuf_bufsiz, + PerlIOBuf_get_ptr, + PerlIOBuf_get_cnt, + PerlIOBuf_set_ptrcnt, +}; + +/*--------------------------------------------------------------------------------------*/ +/* Temp layer to hold unread chars when cannot do it any other way */ + +IV +PerlIOPending_fill(PerlIO *f) { - return Fflush(f); + /* Should never happen */ + PerlIO_flush(f); + return 0; } -#undef PerlIO_fileno -int -PerlIO_fileno(PerlIO *f) +IV +PerlIOPending_close(PerlIO *f) { - return fileno(f); + /* A tad tricky - flush pops us, then we close new top */ + PerlIO_flush(f); + return PerlIO_close(f); +} + +IV +PerlIOPending_seek(PerlIO *f, Off_t offset, int whence) +{ + /* A tad tricky - flush pops us, then we seek new top */ + PerlIO_flush(f); + return PerlIO_seek(f,offset,whence); +} + + +IV +PerlIOPending_flush(PerlIO *f) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + if (b->buf && b->buf != (STDCHAR *) &b->oneword) + { + dTHX; + PerlMemShared_free(b->buf); + b->buf = NULL; + } + PerlIO_pop(f); + return 0; } -#undef PerlIO_setlinebuf void -PerlIO_setlinebuf(PerlIO *f) +PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt) { -#ifdef HAS_SETLINEBUF - setlinebuf(f); + if (cnt <= 0) + { + PerlIO_flush(f); + } + else + { + PerlIOBuf_set_ptrcnt(f,ptr,cnt); + } +} + +IV +PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len) +{ + IV code = PerlIOBase_pushed(f,mode,arg,len); + PerlIOl *l = PerlIOBase(f); + /* Our PerlIO_fast_gets must match what we are pushed on, + or sv_gets() etc. get muddled when it changes mid-string + when we auto-pop. + */ + l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) | + (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8)); + return code; +} + +SSize_t +PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count) +{ + SSize_t avail = PerlIO_get_cnt(f); + SSize_t got = 0; + if (count < avail) + avail = count; + if (avail > 0) + got = PerlIOBuf_read(f,vbuf,avail); + if (got < count) + got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got); + return got; +} + + +PerlIO_funcs PerlIO_pending = { + "pending", + sizeof(PerlIOBuf), + PERLIO_K_BUFFERED, + PerlIOBase_fileno, + NULL, + NULL, + NULL, + PerlIOPending_pushed, + PerlIOBase_noop_ok, + PerlIOPending_read, + PerlIOBuf_unread, + PerlIOBuf_write, + PerlIOPending_seek, + PerlIOBuf_tell, + PerlIOPending_close, + PerlIOPending_flush, + PerlIOPending_fill, + PerlIOBase_eof, + PerlIOBase_error, + PerlIOBase_clearerr, + PerlIOBuf_setlinebuf, + PerlIOBuf_get_base, + PerlIOBuf_bufsiz, + PerlIOBuf_get_ptr, + PerlIOBuf_get_cnt, + PerlIOPending_set_ptrcnt, +}; + + + +/*--------------------------------------------------------------------------------------*/ +/* crlf - translation + On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries + to hand back a line at a time and keeping a record of which nl we "lied" about. + On write translate "\n" to CR,LF + */ + +typedef struct +{ + PerlIOBuf base; /* PerlIOBuf stuff */ + STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */ +} PerlIOCrlf; + +IV +PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len) +{ + IV code; + PerlIOBase(f)->flags |= PERLIO_F_CRLF; + code = PerlIOBuf_pushed(f,mode,arg,len); +#if 0 + PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n", + f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)", + PerlIOBase(f)->flags); +#endif + return code; +} + + +SSize_t +PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count) +{ + PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf); + if (c->nl) + { + *(c->nl) = 0xd; + c->nl = NULL; + } + if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) + return PerlIOBuf_unread(f,vbuf,count); + else + { + const STDCHAR *buf = (const STDCHAR *) vbuf+count; + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + SSize_t unread = 0; + if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) + PerlIO_flush(f); + if (!b->buf) + PerlIO_get_base(f); + if (b->buf) + { + if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) + { + b->end = b->ptr = b->buf + b->bufsiz; + PerlIOBase(f)->flags |= PERLIO_F_RDBUF; + b->posn -= b->bufsiz; + } + while (count > 0 && b->ptr > b->buf) + { + int ch = *--buf; + if (ch == '\n') + { + if (b->ptr - 2 >= b->buf) + { + *--(b->ptr) = 0xa; + *--(b->ptr) = 0xd; + unread++; + count--; + } + else + { + buf++; + break; + } + } + else + { + *--(b->ptr) = ch; + unread++; + count--; + } + } + } + return unread; + } +} + +SSize_t +PerlIOCrlf_get_cnt(PerlIO *f) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + if (!b->buf) + PerlIO_get_base(f); + if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) + { + PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf); + if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl) + { + STDCHAR *nl = b->ptr; + scan: + while (nl < b->end && *nl != 0xd) + nl++; + if (nl < b->end && *nl == 0xd) + { + test: + if (nl+1 < b->end) + { + if (nl[1] == 0xa) + { + *nl = '\n'; + c->nl = nl; + } + else + { + /* Not CR,LF but just CR */ + nl++; + goto scan; + } + } + else + { + /* Blast - found CR as last char in buffer */ + if (b->ptr < nl) + { + /* They may not care, defer work as long as possible */ + return (nl - b->ptr); + } + else + { + int code; + dTHX; + b->ptr++; /* say we have read it as far as flush() is concerned */ + b->buf++; /* Leave space an front of buffer */ + b->bufsiz--; /* Buffer is thus smaller */ + code = PerlIO_fill(f); /* Fetch some more */ + b->bufsiz++; /* Restore size for next time */ + b->buf--; /* Point at space */ + b->ptr = nl = b->buf; /* Which is what we hand off */ + b->posn--; /* Buffer starts here */ + *nl = 0xd; /* Fill in the CR */ + if (code == 0) + goto test; /* fill() call worked */ + /* CR at EOF - just fall through */ + } + } + } + } + return (((c->nl) ? (c->nl+1) : b->end) - b->ptr); + } + return 0; +} + +void +PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf); + IV flags = PerlIOBase(f)->flags; + if (!b->buf) + PerlIO_get_base(f); + if (!ptr) + { + if (c->nl) + ptr = c->nl+1; + else + { + ptr = b->end; + if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd) + ptr--; + } + ptr -= cnt; + } + else + { + /* Test code - delete when it works ... */ + STDCHAR *chk; + if (c->nl) + chk = c->nl+1; + else + { + chk = b->end; + if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd) + chk--; + } + chk -= cnt; + + if (ptr != chk) + { + dTHX; + Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d", + ptr, chk, flags, c->nl, b->end, cnt); + } + } + if (c->nl) + { + if (ptr > c->nl) + { + /* They have taken what we lied about */ + *(c->nl) = 0xd; + c->nl = NULL; + ptr++; + } + } + b->ptr = ptr; + PerlIOBase(f)->flags |= PERLIO_F_RDBUF; +} + +SSize_t +PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count) +{ + if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) + return PerlIOBuf_write(f,vbuf,count); + else + { + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + const STDCHAR *buf = (const STDCHAR *) vbuf; + const STDCHAR *ebuf = buf+count; + if (!b->buf) + PerlIO_get_base(f); + if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) + return 0; + while (buf < ebuf) + { + STDCHAR *eptr = b->buf+b->bufsiz; + PerlIOBase(f)->flags |= PERLIO_F_WRBUF; + while (buf < ebuf && b->ptr < eptr) + { + if (*buf == '\n') + { + if ((b->ptr + 2) > eptr) + { + /* Not room for both */ + PerlIO_flush(f); + break; + } + else + { + *(b->ptr)++ = 0xd; /* CR */ + *(b->ptr)++ = 0xa; /* LF */ + buf++; + if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) + { + PerlIO_flush(f); + break; + } + } + } + else + { + int ch = *buf++; + *(b->ptr)++ = ch; + } + if (b->ptr >= eptr) + { + PerlIO_flush(f); + break; + } + } + } + if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) + PerlIO_flush(f); + return (buf - (STDCHAR *) vbuf); + } +} + +IV +PerlIOCrlf_flush(PerlIO *f) +{ + PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf); + if (c->nl) + { + *(c->nl) = 0xd; + c->nl = NULL; + } + return PerlIOBuf_flush(f); +} + +PerlIO_funcs PerlIO_crlf = { + "crlf", + sizeof(PerlIOCrlf), + PERLIO_K_BUFFERED|PERLIO_K_CANCRLF, + PerlIOBase_fileno, + PerlIOBuf_fdopen, + PerlIOBuf_open, + PerlIOBuf_reopen, + PerlIOCrlf_pushed, + PerlIOBase_noop_ok, /* popped */ + PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */ + PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */ + PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */ + PerlIOBuf_seek, + PerlIOBuf_tell, + PerlIOBuf_close, + PerlIOCrlf_flush, + PerlIOBuf_fill, + PerlIOBase_eof, + PerlIOBase_error, + PerlIOBase_clearerr, + PerlIOBuf_setlinebuf, + PerlIOBuf_get_base, + PerlIOBuf_bufsiz, + PerlIOBuf_get_ptr, + PerlIOCrlf_get_cnt, + PerlIOCrlf_set_ptrcnt, +}; + +#ifdef HAS_MMAP +/*--------------------------------------------------------------------------------------*/ +/* mmap as "buffer" layer */ + +typedef struct +{ + PerlIOBuf base; /* PerlIOBuf stuff */ + Mmap_t mptr; /* Mapped address */ + Size_t len; /* mapped length */ + STDCHAR *bbuf; /* malloced buffer if map fails */ +} PerlIOMmap; + +static size_t page_size = 0; + +IV +PerlIOMmap_map(PerlIO *f) +{ + dTHX; + PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap); + PerlIOBuf *b = &m->base; + IV flags = PerlIOBase(f)->flags; + IV code = 0; + if (m->len) + abort(); + if (flags & PERLIO_F_CANREAD) + { + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + int fd = PerlIO_fileno(f); + struct stat st; + code = fstat(fd,&st); + if (code == 0 && S_ISREG(st.st_mode)) + { + SSize_t len = st.st_size - b->posn; + if (len > 0) + { + Off_t posn; + if (!page_size) { +#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE)) + { + SETERRNO(0,SS$_NORMAL); +# ifdef _SC_PAGESIZE + page_size = sysconf(_SC_PAGESIZE); +# else + page_size = sysconf(_SC_PAGE_SIZE); +# endif + if ((long)page_size < 0) { + if (errno) { + SV *error = ERRSV; + char *msg; + STRLEN n_a; + (void)SvUPGRADE(error, SVt_PV); + msg = SvPVx(error, n_a); + Perl_croak(aTHX_ "panic: sysconf: %s", msg); + } + else + Perl_croak(aTHX_ "panic: sysconf: pagesize unknown"); + } + } #else -# ifdef __BORLANDC__ /* Borland doesn't like NULL size for _IOLBF */ - setvbuf(f, Nullch, _IOLBF, BUFSIZ); -# else - setvbuf(f, Nullch, _IOLBF, 0); -# endif +# ifdef HAS_GETPAGESIZE + page_size = getpagesize(); +# else +# if defined(I_SYS_PARAM) && defined(PAGESIZE) + page_size = PAGESIZE; /* compiletime, bad */ +# endif +# endif +#endif + if ((IV)page_size <= 0) + Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size); + } + if (b->posn < 0) + { + /* This is a hack - should never happen - open should have set it ! */ + b->posn = PerlIO_tell(PerlIONext(f)); + } + posn = (b->posn / page_size) * page_size; + len = st.st_size - posn; + m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn); + if (m->mptr && m->mptr != (Mmap_t) -1) + { +#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL) + madvise(m->mptr, len, MADV_SEQUENTIAL); #endif +#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED) + madvise(m->mptr, len, MADV_WILLNEED); +#endif + PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF; + b->end = ((STDCHAR *)m->mptr) + len; + b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn); + b->ptr = b->buf; + m->len = len; + } + else + { + b->buf = NULL; + } + } + else + { + PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF; + b->buf = NULL; + b->ptr = b->end = b->ptr; + code = -1; + } + } + } + return code; } -#undef PerlIO_putc -int -PerlIO_putc(PerlIO *f, int ch) +IV +PerlIOMmap_unmap(PerlIO *f) { - return putc(ch,f); + PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap); + PerlIOBuf *b = &m->base; + IV code = 0; + if (m->len) + { + if (b->buf) + { + code = munmap(m->mptr, m->len); + b->buf = NULL; + m->len = 0; + m->mptr = NULL; + if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0) + code = -1; + } + b->ptr = b->end = b->buf; + PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF); + } + return code; } -#undef PerlIO_ungetc -int -PerlIO_ungetc(PerlIO *f, int ch) +STDCHAR * +PerlIOMmap_get_base(PerlIO *f) { - return ungetc(ch,f); + PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap); + PerlIOBuf *b = &m->base; + if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) + { + /* Already have a readbuffer in progress */ + return b->buf; + } + if (b->buf) + { + /* We have a write buffer or flushed PerlIOBuf read buffer */ + m->bbuf = b->buf; /* save it in case we need it again */ + b->buf = NULL; /* Clear to trigger below */ + } + if (!b->buf) + { + PerlIOMmap_map(f); /* Try and map it */ + if (!b->buf) + { + /* Map did not work - recover PerlIOBuf buffer if we have one */ + b->buf = m->bbuf; + } + } + b->ptr = b->end = b->buf; + if (b->buf) + return b->buf; + return PerlIOBuf_get_base(f); } -#undef PerlIO_read SSize_t -PerlIO_read(PerlIO *f, void *buf, Size_t count) +PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count) { - return fread(buf,1,count,f); + PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap); + PerlIOBuf *b = &m->base; + if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) + PerlIO_flush(f); + if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count)) + { + b->ptr -= count; + PerlIOBase(f)->flags &= ~ PERLIO_F_EOF; + return count; + } + if (m->len) + { + /* Loose the unwritable mapped buffer */ + PerlIO_flush(f); + /* If flush took the "buffer" see if we have one from before */ + if (!b->buf && m->bbuf) + b->buf = m->bbuf; + if (!b->buf) + { + PerlIOBuf_get_base(f); + m->bbuf = b->buf; + } + } +return PerlIOBuf_unread(f,vbuf,count); } -#undef PerlIO_write SSize_t -PerlIO_write(PerlIO *f, const void *buf, Size_t count) +PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count) { - return fwrite1(buf,1,count,f); + PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap); + PerlIOBuf *b = &m->base; + if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) + { + /* No, or wrong sort of, buffer */ + if (m->len) + { + if (PerlIOMmap_unmap(f) != 0) + return 0; + } + /* If unmap took the "buffer" see if we have one from before */ + if (!b->buf && m->bbuf) + b->buf = m->bbuf; + if (!b->buf) + { + PerlIOBuf_get_base(f); + m->bbuf = b->buf; + } + } + return PerlIOBuf_write(f,vbuf,count); } -#undef PerlIO_vprintf -int -PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap) +IV +PerlIOMmap_flush(PerlIO *f) { - return vfprintf(f,fmt,ap); + PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap); + PerlIOBuf *b = &m->base; + IV code = PerlIOBuf_flush(f); + /* Now we are "synced" at PerlIOBuf level */ + if (b->buf) + { + if (m->len) + { + /* Unmap the buffer */ + if (PerlIOMmap_unmap(f) != 0) + code = -1; + } + else + { + /* We seem to have a PerlIOBuf buffer which was not mapped + * remember it in case we need one later + */ + m->bbuf = b->buf; + } + } + return code; } -#undef PerlIO_tell -Off_t -PerlIO_tell(PerlIO *f) +IV +PerlIOMmap_fill(PerlIO *f) { -#if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64) - return ftello(f); -#else - return ftell(f); + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + IV code = PerlIO_flush(f); + if (code == 0 && !b->buf) + { + code = PerlIOMmap_map(f); + } + if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) + { + code = PerlIOBuf_fill(f); + } + return code; +} + +IV +PerlIOMmap_close(PerlIO *f) +{ + PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap); + PerlIOBuf *b = &m->base; + IV code = PerlIO_flush(f); + if (m->bbuf) + { + b->buf = m->bbuf; + m->bbuf = NULL; + b->ptr = b->end = b->buf; + } + if (PerlIOBuf_close(f) != 0) + code = -1; + return code; +} + + +PerlIO_funcs PerlIO_mmap = { + "mmap", + sizeof(PerlIOMmap), + PERLIO_K_BUFFERED, + PerlIOBase_fileno, + PerlIOBuf_fdopen, + PerlIOBuf_open, + PerlIOBuf_reopen, + PerlIOBuf_pushed, + PerlIOBase_noop_ok, + PerlIOBuf_read, + PerlIOMmap_unread, + PerlIOMmap_write, + PerlIOBuf_seek, + PerlIOBuf_tell, + PerlIOBuf_close, + PerlIOMmap_flush, + PerlIOMmap_fill, + PerlIOBase_eof, + PerlIOBase_error, + PerlIOBase_clearerr, + PerlIOBuf_setlinebuf, + PerlIOMmap_get_base, + PerlIOBuf_bufsiz, + PerlIOBuf_get_ptr, + PerlIOBuf_get_cnt, + PerlIOBuf_set_ptrcnt, +}; + +#endif /* HAS_MMAP */ + +void +PerlIO_init(void) +{ + if (!_perlio) + { +#ifndef WIN32 + atexit(&PerlIO_cleanup); #endif + } } -#undef PerlIO_seek +#undef PerlIO_stdin +PerlIO * +PerlIO_stdin(void) +{ + if (!_perlio) + PerlIO_stdstreams(); + return &_perlio[1]; +} + +#undef PerlIO_stdout +PerlIO * +PerlIO_stdout(void) +{ + if (!_perlio) + PerlIO_stdstreams(); + return &_perlio[2]; +} + +#undef PerlIO_stderr +PerlIO * +PerlIO_stderr(void) +{ + if (!_perlio) + PerlIO_stdstreams(); + return &_perlio[3]; +} + +/*--------------------------------------------------------------------------------------*/ + +#undef PerlIO_getname +char * +PerlIO_getname(PerlIO *f, char *buf) +{ + dTHX; + Perl_croak(aTHX_ "Don't know how to get file name"); + return NULL; +} + + +/*--------------------------------------------------------------------------------------*/ +/* Functions which can be called on any kind of PerlIO implemented + in terms of above +*/ + +#undef PerlIO_getc int -PerlIO_seek(PerlIO *f, Off_t offset, int whence) +PerlIO_getc(PerlIO *f) { -#if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64) - return fseeko(f,offset,whence); -#else - return fseek(f,offset,whence); -#endif + STDCHAR buf[1]; + SSize_t count = PerlIO_read(f,buf,1); + if (count == 1) + { + return (unsigned char) buf[0]; + } + return EOF; +} + +#undef PerlIO_ungetc +int +PerlIO_ungetc(PerlIO *f, int ch) +{ + if (ch != EOF) + { + STDCHAR buf = ch; + if (PerlIO_unread(f,&buf,1) == 1) + return ch; + } + return EOF; +} + +#undef PerlIO_putc +int +PerlIO_putc(PerlIO *f, int ch) +{ + STDCHAR buf = ch; + return PerlIO_write(f,&buf,1); +} + +#undef PerlIO_puts +int +PerlIO_puts(PerlIO *f, const char *s) +{ + STRLEN len = strlen(s); + return PerlIO_write(f,s,len); } #undef PerlIO_rewind void PerlIO_rewind(PerlIO *f) { - rewind(f); + PerlIO_seek(f,(Off_t)0,SEEK_SET); + PerlIO_clearerr(f); +} + +#undef PerlIO_vprintf +int +PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap) +{ + dTHX; + SV *sv = newSVpvn("",0); + char *s; + STRLEN len; +#ifdef NEED_VA_COPY + va_list apc; + Perl_va_copy(ap, apc); + sv_vcatpvf(sv, fmt, &apc); +#else + sv_vcatpvf(sv, fmt, &ap); +#endif + s = SvPV(sv,len); + return PerlIO_write(f,s,len); } #undef PerlIO_printf -int +int PerlIO_printf(PerlIO *f,const char *fmt,...) { va_list ap; int result; va_start(ap,fmt); - result = vfprintf(f,fmt,ap); + result = PerlIO_vprintf(f,fmt,ap); va_end(ap); return result; } #undef PerlIO_stdoutf -int +int PerlIO_stdoutf(const char *fmt,...) { va_list ap; @@ -443,93 +3142,114 @@ PerlIO_stdoutf(const char *fmt,...) PerlIO * PerlIO_tmpfile(void) { - return tmpfile(); -} - -#undef PerlIO_importFILE -PerlIO * -PerlIO_importFILE(FILE *f, int fl) -{ - return f; -} - -#undef PerlIO_exportFILE -FILE * -PerlIO_exportFILE(PerlIO *f, int fl) -{ + /* I have no idea how portable mkstemp() is ... */ +#if defined(WIN32) || !defined(HAVE_MKSTEMP) + dTHX; + PerlIO *f = NULL; + FILE *stdio = PerlSIO_tmpfile(); + if (stdio) + { + PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio); + s->stdio = stdio; + } return f; -} - -#undef PerlIO_findFILE -FILE * -PerlIO_findFILE(PerlIO *f) -{ +#else + dTHX; + SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0); + int fd = mkstemp(SvPVX(sv)); + PerlIO *f = NULL; + if (fd >= 0) + { + f = PerlIO_fdopen(fd,"w+"); + if (f) + { + PerlIOBase(f)->flags |= PERLIO_F_TEMP; + } + PerlLIO_unlink(SvPVX(sv)); + SvREFCNT_dec(sv); + } return f; +#endif } -#undef PerlIO_releaseFILE -void -PerlIO_releaseFILE(PerlIO *p, FILE *f) -{ -} - -void -PerlIO_init(void) -{ - /* Does nothing (yet) except force this file to be included - in perl binary. That allows this file to force inclusion - of other functions that may be required by loadable - extensions e.g. for FileHandle::tmpfile - */ -} +#undef HAS_FSETPOS +#undef HAS_FGETPOS #endif /* USE_SFIO */ #endif /* PERLIO_IS_STDIO */ +/*======================================================================================*/ +/* Now some functions in terms of above which may be needed even if + we are not in true PerlIO mode + */ + #ifndef HAS_FSETPOS #undef PerlIO_setpos int -PerlIO_setpos(PerlIO *f, const Fpos_t *pos) +PerlIO_setpos(PerlIO *f, SV *pos) { - return PerlIO_seek(f,*pos,0); + dTHX; + if (SvOK(pos)) + { + STRLEN len; + Off_t *posn = (Off_t *) SvPV(pos,len); + if (f && len == sizeof(Off_t)) + return PerlIO_seek(f,*posn,SEEK_SET); + } + errno = EINVAL; + return -1; } #else -#ifndef PERLIO_IS_STDIO #undef PerlIO_setpos int -PerlIO_setpos(PerlIO *f, const Fpos_t *pos) +PerlIO_setpos(PerlIO *f, SV *pos) { + dTHX; + if (SvOK(pos)) + { + STRLEN len; + Fpos_t *fpos = (Fpos_t *) SvPV(pos,len); + if (f && len == sizeof(Fpos_t)) + { #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) - return fsetpos64(f, pos); + return fsetpos64(f, fpos); #else - return fsetpos(f, pos); + return fsetpos(f, fpos); #endif + } + } + errno = EINVAL; + return -1; } #endif -#endif #ifndef HAS_FGETPOS #undef PerlIO_getpos int -PerlIO_getpos(PerlIO *f, Fpos_t *pos) +PerlIO_getpos(PerlIO *f, SV *pos) { - *pos = PerlIO_tell(f); - return 0; + dTHX; + Off_t posn = PerlIO_tell(f); + sv_setpvn(pos,(char *)&posn,sizeof(posn)); + return (posn == (Off_t)-1) ? -1 : 0; } #else -#ifndef PERLIO_IS_STDIO #undef PerlIO_getpos int -PerlIO_getpos(PerlIO *f, Fpos_t *pos) +PerlIO_getpos(PerlIO *f, SV *pos) { + dTHX; + Fpos_t fpos; + int code; #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) - return fgetpos64(f, pos); + code = fgetpos64(f, &fpos); #else - return fgetpos(f, pos); + code = fgetpos(f, &fpos); #endif + sv_setpvn(pos,(char *)&fpos,sizeof(fpos)); + return code; } #endif -#endif #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF) @@ -550,7 +3270,7 @@ vfprintf(FILE *fd, char *pat, char *args) #endif #ifndef PerlIO_vsprintf -int +int PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap) { int val = vsprintf(s, fmt, ap); @@ -559,7 +3279,8 @@ PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap) if (strlen(s) >= (STRLEN)n) { dTHX; - PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n"); + (void)PerlIO_puts(Perl_error_log, + "panic: sprintf overflow - memory corrupted!\n"); my_exit(1); } } @@ -568,7 +3289,7 @@ PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap) #endif #ifndef PerlIO_sprintf -int +int PerlIO_sprintf(char *s, int n, const char *fmt,...) { va_list ap; @@ -580,5 +3301,4 @@ PerlIO_sprintf(char *s, int n, const char *fmt,...) } #endif -#endif /* !PERL_IMPLICIT_SYS */ @@ -1 +1,337 @@ -#include "iperlsys.h" +#ifndef _PERLIO_H +#define _PERLIO_H +/* + Interface for perl to IO functions. + There is a hierachy of Configure determined #define controls: + USE_STDIO - forces PerlIO_xxx() to be #define-d onto stdio functions. + This is used for x2p subdirectory and for conservative + builds - "just like perl5.00X used to be". + This dominates over the others. + + USE_PERLIO - The primary Configure variable that enables PerlIO. + If USE_PERLIO is _NOT_ set + then USE_STDIO above will be set to be conservative. + If USE_PERLIO is set + then there are two modes determined by USE_SFIO: + + USE_SFIO - If set causes PerlIO_xxx() to be #define-d onto sfio functions. + A backward compatability mode for some specialist applications. + + If USE_SFIO is not set then PerlIO_xxx() are real functions + defined in perlio.c which implement extra functionality + required for utf8 support. + + One further note - the table-of-functions scheme controlled + by PERL_IMPLICIT_SYS turns on USE_PERLIO so that iperlsys.h can + #define PerlIO_xxx() to go via the function table, without having + to #undef them from (say) stdio forms. + +*/ + +#if defined(PERL_IMPLICIT_SYS) +#ifndef USE_PERLIO +# define USE_PERLIO +#endif +#endif + +#ifndef USE_PERLIO +# define USE_STDIO +#endif + +#ifdef USE_STDIO +# ifndef PERLIO_IS_STDIO +# define PERLIO_IS_STDIO +# endif +#endif + +/* -------------------- End of Configure controls ---------------------------- */ + +/* + * Although we may not want stdio to be used including <stdio.h> here + * avoids issues where stdio.h has strange side effects + */ +#include <stdio.h> + +#if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64) +#define ftell ftello +#endif + +#if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64) +#define fseek fseeko +#endif + +#ifdef PERLIO_IS_STDIO +/* #define PerlIO_xxxx() as equivalent stdio function */ +#include "perlsdio.h" +#else /* PERLIO_IS_STDIO */ +#ifdef USE_SFIO +/* #define PerlIO_xxxx() as equivalent sfio function */ +#include "perlsfio.h" +#endif /* USE_SFIO */ +#endif /* PERLIO_IS_STDIO */ + +#ifndef PerlIO +/* ----------- PerlIO implementation ---------- */ +/* PerlIO not #define-d to something else - define the implementation */ + +typedef struct _PerlIO PerlIOl; +typedef struct _PerlIO_funcs PerlIO_funcs; +typedef PerlIOl *PerlIO; +#define PerlIO PerlIO +#define PERLIO_LAYERS 1 + +extern void PerlIO_define_layer (PerlIO_funcs *tab); +extern SV * PerlIO_find_layer (const char *name, STRLEN len); +extern PerlIO * PerlIO_push (PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len); +extern void PerlIO_pop (PerlIO *f); + +#endif /* PerlIO */ + +/* ----------- End of implementation choices ---------- */ + +#ifndef PERLIO_IS_STDIO +/* Not using stdio _directly_ as PerlIO */ + +/* We now need to determine what happens if source trys to use stdio. + * There are three cases based on PERLIO_NOT_STDIO which XS code + * can set how it wants. + */ + +#ifdef PERL_CORE +/* Make a choice for perl core code + - currently this is set to try and catch lingering raw stdio calls. + This is a known issue with some non UNIX ports which still use + "native" stdio features. +*/ +#ifndef PERLIO_NOT_STDIO +#define PERLIO_NOT_STDIO 1 +#endif +#else +#ifndef PERLIO_NOT_STDIO +#define PERLIO_NOT_STDIO 0 +#endif +#endif + +#ifdef PERLIO_NOT_STDIO +#if PERLIO_NOT_STDIO +/* + * PERLIO_NOT_STDIO #define'd as 1 + * Case 1: Strong denial of stdio - make all stdio calls (we can think of) errors + */ +#include "nostdio.h" +#else /* if PERLIO_NOT_STDIO */ +/* + * PERLIO_NOT_STDIO #define'd as 0 + * Case 2: Declares that both PerlIO and stdio can be used + */ +#endif /* if PERLIO_NOT_STDIO */ +#else /* ifdef PERLIO_NOT_STDIO */ +/* + * PERLIO_NOT_STDIO not defined + * Case 3: Try and fake stdio calls as PerlIO calls + */ +#include "fakesdio.h" +#endif /* ifndef PERLIO_NOT_STDIO */ +#endif /* PERLIO_IS_STDIO */ + +#define specialCopIO(sv) ((sv) != Nullsv) + +/* ----------- fill in things that have not got #define'd ---------- */ + +#ifndef Fpos_t +#define Fpos_t Off_t +#endif + +#ifndef EOF +#define EOF (-1) +#endif + +/* This is to catch case with no stdio */ +#ifndef BUFSIZ +#define BUFSIZ 1024 +#endif + +#ifndef SEEK_SET +#define SEEK_SET 0 +#endif + +#ifndef SEEK_CUR +#define SEEK_CUR 1 +#endif + +#ifndef SEEK_END +#define SEEK_END 2 +#endif + +/* --------------------- Now prototypes for functions --------------- */ + +START_EXTERN_C + +#ifndef NEXT30_NO_ATTRIBUTE +#ifndef HASATTRIBUTE /* disable GNU-cc attribute checking? */ +#ifdef __attribute__ /* Avoid possible redefinition errors */ +#undef __attribute__ +#endif +#define __attribute__(attr) +#endif +#endif + +#ifndef PerlIO_init +extern void PerlIO_init (void); +#endif +#ifndef PerlIO_stdoutf +extern int PerlIO_stdoutf (const char *,...) + __attribute__((__format__ (__printf__, 1, 2))); +#endif +#ifndef PerlIO_puts +extern int PerlIO_puts (PerlIO *,const char *); +#endif +#ifndef PerlIO_open +extern PerlIO * PerlIO_open (const char *,const char *); +#endif +#ifndef PerlIO_close +extern int PerlIO_close (PerlIO *); +#endif +#ifndef PerlIO_eof +extern int PerlIO_eof (PerlIO *); +#endif +#ifndef PerlIO_error +extern int PerlIO_error (PerlIO *); +#endif +#ifndef PerlIO_clearerr +extern void PerlIO_clearerr (PerlIO *); +#endif +#ifndef PerlIO_getc +extern int PerlIO_getc (PerlIO *); +#endif +#ifndef PerlIO_putc +extern int PerlIO_putc (PerlIO *,int); +#endif +#ifndef PerlIO_flush +extern int PerlIO_flush (PerlIO *); +#endif +#ifndef PerlIO_ungetc +extern int PerlIO_ungetc (PerlIO *,int); +#endif +#ifndef PerlIO_fileno +extern int PerlIO_fileno (PerlIO *); +#endif +#ifndef PerlIO_fdopen +extern PerlIO * PerlIO_fdopen (int, const char *); +#endif +#ifndef PerlIO_importFILE +extern PerlIO * PerlIO_importFILE (FILE *,int); +#endif +#ifndef PerlIO_exportFILE +extern FILE * PerlIO_exportFILE (PerlIO *,int); +#endif +#ifndef PerlIO_findFILE +extern FILE * PerlIO_findFILE (PerlIO *); +#endif +#ifndef PerlIO_releaseFILE +extern void PerlIO_releaseFILE (PerlIO *,FILE *); +#endif +#ifndef PerlIO_read +extern SSize_t PerlIO_read (PerlIO *,void *,Size_t); +#endif +#ifndef PerlIO_write +extern SSize_t PerlIO_write (PerlIO *,const void *,Size_t); +#endif +#ifndef PerlIO_setlinebuf +extern void PerlIO_setlinebuf (PerlIO *); +#endif +#ifndef PerlIO_printf +extern int PerlIO_printf (PerlIO *, const char *,...) + __attribute__((__format__ (__printf__, 2, 3))); +#endif +#ifndef PerlIO_sprintf +extern int PerlIO_sprintf (char *, int, const char *,...) + __attribute__((__format__ (__printf__, 3, 4))); +#endif +#ifndef PerlIO_vprintf +extern int PerlIO_vprintf (PerlIO *, const char *, va_list); +#endif +#ifndef PerlIO_tell +extern Off_t PerlIO_tell (PerlIO *); +#endif +#ifndef PerlIO_seek +extern int PerlIO_seek (PerlIO *, Off_t, int); +#endif +#ifndef PerlIO_rewind +extern void PerlIO_rewind (PerlIO *); +#endif +#ifndef PerlIO_has_base +extern int PerlIO_has_base (PerlIO *); +#endif +#ifndef PerlIO_has_cntptr +extern int PerlIO_has_cntptr (PerlIO *); +#endif +#ifndef PerlIO_fast_gets +extern int PerlIO_fast_gets (PerlIO *); +#endif +#ifndef PerlIO_canset_cnt +extern int PerlIO_canset_cnt (PerlIO *); +#endif +#ifndef PerlIO_get_ptr +extern STDCHAR * PerlIO_get_ptr (PerlIO *); +#endif +#ifndef PerlIO_get_cnt +extern int PerlIO_get_cnt (PerlIO *); +#endif +#ifndef PerlIO_set_cnt +extern void PerlIO_set_cnt (PerlIO *,int); +#endif +#ifndef PerlIO_set_ptrcnt +extern void PerlIO_set_ptrcnt (PerlIO *,STDCHAR *,int); +#endif +#ifndef PerlIO_get_base +extern STDCHAR * PerlIO_get_base (PerlIO *); +#endif +#ifndef PerlIO_get_bufsiz +extern int PerlIO_get_bufsiz (PerlIO *); +#endif +#ifndef PerlIO_tmpfile +extern PerlIO * PerlIO_tmpfile (void); +#endif +#ifndef PerlIO_stdin +extern PerlIO * PerlIO_stdin (void); +#endif +#ifndef PerlIO_stdout +extern PerlIO * PerlIO_stdout (void); +#endif +#ifndef PerlIO_stderr +extern PerlIO * PerlIO_stderr (void); +#endif +#ifndef PerlIO_getpos +extern int PerlIO_getpos (PerlIO *,SV *); +#endif +#ifndef PerlIO_setpos +extern int PerlIO_setpos (PerlIO *,SV *); +#endif +#ifndef PerlIO_fdupopen +extern PerlIO * PerlIO_fdupopen (pTHX_ PerlIO *); +#endif +#if !defined(PerlIO_modestr) && !defined(PERLIO_IS_STDIO) +extern char *PerlIO_modestr (PerlIO *,char *buf); +#endif +#ifndef PerlIO_isutf8 +extern int PerlIO_isutf8 (PerlIO *); +#endif +#ifndef PerlIO_apply_layers +extern int PerlIO_apply_layers (pTHX_ PerlIO *f, const char *mode, const char *names); +#endif +#ifndef PerlIO_binmode +extern int PerlIO_binmode (pTHX_ PerlIO *f, int iotype, int omode, const char *names); +#endif + +#ifndef PERLIO_IS_STDIO + +extern void PerlIO_cleanup(void); + +extern void PerlIO_debug(const char *fmt,...); + +#endif + +END_EXTERN_C + +#endif /* _PERLIO_H */ diff --git a/perliol.h b/perliol.h new file mode 100644 index 0000000000..04c7071fa4 --- /dev/null +++ b/perliol.h @@ -0,0 +1,150 @@ +#ifndef _PERLIOL_H +#define _PERLIOL_H + +struct _PerlIO_funcs +{ + char * name; + Size_t size; + IV kind; + IV (*Fileno)(PerlIO *f); + PerlIO * (*Fdopen)(PerlIO_funcs *tab, int fd, const char *mode); + PerlIO * (*Open)(PerlIO_funcs *tab, const char *path, const char *mode); + int (*Reopen)(const char *path, const char *mode, PerlIO *f); + IV (*Pushed)(PerlIO *f,const char *mode,const char *arg,STRLEN len); + IV (*Popped)(PerlIO *f); + /* Unix-like functions - cf sfio line disciplines */ + SSize_t (*Read)(PerlIO *f, void *vbuf, Size_t count); + SSize_t (*Unread)(PerlIO *f, const void *vbuf, Size_t count); + SSize_t (*Write)(PerlIO *f, const void *vbuf, Size_t count); + IV (*Seek)(PerlIO *f, Off_t offset, int whence); + Off_t (*Tell)(PerlIO *f); + IV (*Close)(PerlIO *f); + /* Stdio-like buffered IO functions */ + IV (*Flush)(PerlIO *f); + IV (*Fill)(PerlIO *f); + IV (*Eof)(PerlIO *f); + IV (*Error)(PerlIO *f); + void (*Clearerr)(PerlIO *f); + void (*Setlinebuf)(PerlIO *f); + /* Perl's snooping functions */ + STDCHAR * (*Get_base)(PerlIO *f); + Size_t (*Get_bufsiz)(PerlIO *f); + STDCHAR * (*Get_ptr)(PerlIO *f); + SSize_t (*Get_cnt)(PerlIO *f); + void (*Set_ptrcnt)(PerlIO *f,STDCHAR *ptr,SSize_t cnt); +}; + +/*--------------------------------------------------------------------------------------*/ +/* Kind values */ +#define PERLIO_K_RAW 0x00000001 +#define PERLIO_K_BUFFERED 0x00000002 +#define PERLIO_K_CANCRLF 0x00000004 +#define PERLIO_K_FASTGETS 0x00000008 + +/*--------------------------------------------------------------------------------------*/ +struct _PerlIO +{ + PerlIOl * next; /* Lower layer */ + PerlIO_funcs * tab; /* Functions for this layer */ + IV flags; /* Various flags for state */ +}; + +/*--------------------------------------------------------------------------------------*/ + +/* Flag values */ +#define PERLIO_F_EOF 0x00000100 +#define PERLIO_F_CANWRITE 0x00000200 +#define PERLIO_F_CANREAD 0x00000400 +#define PERLIO_F_ERROR 0x00000800 +#define PERLIO_F_TRUNCATE 0x00001000 +#define PERLIO_F_APPEND 0x00002000 +#define PERLIO_F_CRLF 0x00004000 +#define PERLIO_F_UTF8 0x00008000 +#define PERLIO_F_UNBUF 0x00010000 +#define PERLIO_F_WRBUF 0x00020000 +#define PERLIO_F_RDBUF 0x00040000 +#define PERLIO_F_LINEBUF 0x00080000 +#define PERLIO_F_TEMP 0x00100000 +#define PERLIO_F_OPEN 0x00200000 +#define PERLIO_F_FASTGETS 0x00400000 + +#define PerlIOBase(f) (*(f)) +#define PerlIOSelf(f,type) ((type *)PerlIOBase(f)) +#define PerlIONext(f) (&(PerlIOBase(f)->next)) + +/*--------------------------------------------------------------------------------------*/ + +extern PerlIO_funcs PerlIO_unix; +extern PerlIO_funcs PerlIO_perlio; +extern PerlIO_funcs PerlIO_stdio; +extern PerlIO_funcs PerlIO_crlf; +/* The EXT is need for Cygwin -- but why only for _pending? --jhi */ +EXT PerlIO_funcs PerlIO_pending; +#ifdef HAS_MMAP +extern PerlIO_funcs PerlIO_mmap; +#endif + +extern PerlIO *PerlIO_allocate(pTHX); + +#if O_BINARY != O_TEXT +#define PERLIO_STDTEXT "t" +#else +#define PERLIO_STDTEXT "" +#endif + +/*--------------------------------------------------------------------------------------*/ +/* Generic, or stub layer functions */ + +extern IV PerlIOBase_fileno (PerlIO *f); +extern IV PerlIOBase_pushed (PerlIO *f, const char *mode,const char *arg,STRLEN len); +extern IV PerlIOBase_popped (PerlIO *f); +extern SSize_t PerlIOBase_unread (PerlIO *f, const void *vbuf, Size_t count); +extern IV PerlIOBase_eof (PerlIO *f); +extern IV PerlIOBase_error (PerlIO *f); +extern void PerlIOBase_clearerr (PerlIO *f); +extern IV PerlIOBase_flush (PerlIO *f); +extern IV PerlIOBase_fill (PerlIO *f); +extern IV PerlIOBase_close (PerlIO *f); +extern void PerlIOBase_setlinebuf(PerlIO *f); + +extern IV PerlIOBase_noop_ok (PerlIO *f); +extern IV PerlIOBase_noop_fail (PerlIO *f); + +/*--------------------------------------------------------------------------------------*/ +/* perlio buffer layer + As this is reasonably generic its struct and "methods" are declared here + so they can be used to "inherit" from it. +*/ + +typedef struct +{ + struct _PerlIO base; /* Base "class" info */ + STDCHAR * buf; /* Start of buffer */ + STDCHAR * end; /* End of valid part of buffer */ + STDCHAR * ptr; /* Current position in buffer */ + Off_t posn; /* Offset of buf into the file */ + Size_t bufsiz; /* Real size of buffer */ + IV oneword; /* Emergency buffer */ +} PerlIOBuf; + +extern PerlIO * PerlIOBuf_fdopen (PerlIO_funcs *self, int fd, const char *mode); +extern PerlIO * PerlIOBuf_open (PerlIO_funcs *self, const char *path, const char *mode); +extern int PerlIOBuf_reopen (const char *path, const char *mode, PerlIO *f); +extern SSize_t PerlIOBuf_read (PerlIO *f, void *vbuf, Size_t count); +extern SSize_t PerlIOBuf_unread (PerlIO *f, const void *vbuf, Size_t count); +extern SSize_t PerlIOBuf_write (PerlIO *f, const void *vbuf, Size_t count); +extern IV PerlIOBuf_seek (PerlIO *f, Off_t offset, int whence); +extern Off_t PerlIOBuf_tell (PerlIO *f); +extern IV PerlIOBuf_close (PerlIO *f); +extern IV PerlIOBuf_flush (PerlIO *f); +extern IV PerlIOBuf_fill (PerlIO *f); +extern void PerlIOBuf_setlinebuf (PerlIO *f); +extern STDCHAR *PerlIOBuf_get_base (PerlIO *f); +extern Size_t PerlIOBuf_bufsiz (PerlIO *f); +extern STDCHAR *PerlIOBuf_get_ptr (PerlIO *f); +extern SSize_t PerlIOBuf_get_cnt (PerlIO *f); +extern void PerlIOBuf_set_ptrcnt (PerlIO *f, STDCHAR *ptr, SSize_t cnt); + +/*--------------------------------------------------------------------------------------*/ + +#endif /* _PERLIOL_H */ diff --git a/perlsdio.h b/perlsdio.h index c4a1179a41..fd990c06d8 100644 --- a/perlsdio.h +++ b/perlsdio.h @@ -1,25 +1,23 @@ -/* - * Although we may not want stdio to be used including <stdio.h> here - * avoids issues where stdio.h has strange side effects - */ -#include <stdio.h> - #ifdef PERLIO_IS_STDIO /* + * This file #define-s the PerlIO_xxx abstraction onto stdio functions. * Make this as close to original stdio as possible. */ -#define PerlIO FILE +#define PerlIO FILE #define PerlIO_stderr() stderr #define PerlIO_stdout() stdout #define PerlIO_stdin() stdin +#define PerlIO_fdupopen(f) (f) +#define PerlIO_isutf8(f) 0 + #define PerlIO_printf fprintf #define PerlIO_stdoutf printf -#define PerlIO_vprintf(f,fmt,a) vfprintf(f,fmt,a) +#define PerlIO_vprintf(f,fmt,a) vfprintf(f,fmt,a) #define PerlIO_write(f,buf,count) fwrite1(buf,1,count,f) #define PerlIO_open fopen #define PerlIO_fdopen fdopen -#define PerlIO_reopen freopen +#define PerlIO_reopen freopen #define PerlIO_close(f) fclose(f) #define PerlIO_puts(f,s) fputs(s,f) #define PerlIO_putc(f,c) fputc(c,f) @@ -43,10 +41,12 @@ (feof(f) ? EOF : getc(f)) # define PerlIO_read(f,buf,count) \ (feof(f) ? 0 : (SSize_t)fread(buf,1,count,f)) +# define PerlIO_tell(f) ftell(f) #else -# define PerlIO_ungetc(f,c) ungetc(c,f) # define PerlIO_getc(f) getc(f) +# define PerlIO_ungetc(f,c) ungetc(c,f) # define PerlIO_read(f,buf,count) (SSize_t)fread(buf,1,count,f) +# define PerlIO_tell(f) ftell(f) #endif #define PerlIO_eof(f) feof(f) #define PerlIO_getname(f,b) fgetname(f,b) @@ -54,33 +54,20 @@ #define PerlIO_fileno(f) fileno(f) #define PerlIO_clearerr(f) clearerr(f) #define PerlIO_flush(f) Fflush(f) -#define PerlIO_tell(f) ftell(f) -#if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64) -#define ftell ftello -#endif #if defined(VMS) && !defined(__DECC) - /* Old VAXC RTL doesn't reset EOF on seek; Perl folk seem to expect this */ -# define PerlIO_seek(f,o,w) (((f) && (*f) && ((*f)->_flag &= ~_IOEOF)),fseek(f,o,w)) +/* Old VAXC RTL doesn't reset EOF on seek; Perl folk seem to expect this */ +#define PerlIO_seek(f,o,w) (((f) && (*f) && ((*f)->_flag &= ~_IOEOF)),fseek(f,o,w)) #else # define PerlIO_seek(f,o,w) fseek(f,o,w) #endif -#if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64) -#define fseek fseeko -#endif -#ifdef HAS_FGETPOS -#define PerlIO_getpos(f,p) fgetpos(f,p) -#endif -#ifdef HAS_FSETPOS -#define PerlIO_setpos(f,p) fsetpos(f,p) -#endif #define PerlIO_rewind(f) rewind(f) #define PerlIO_tmpfile() tmpfile() -#define PerlIO_importFILE(f,fl) (f) -#define PerlIO_exportFILE(f,fl) (f) -#define PerlIO_findFILE(f) (f) -#define PerlIO_releaseFILE(p,f) ((void) 0) +#define PerlIO_importFILE(f,fl) (f) +#define PerlIO_exportFILE(f,fl) (f) +#define PerlIO_findFILE(f) (f) +#define PerlIO_releaseFILE(p,f) ((void) 0) #ifdef HAS_SETLINEBUF #define PerlIO_setlinebuf(f) setlinebuf(f); @@ -91,26 +78,36 @@ /* Now our interface to Configure's FILE_xxx macros */ #ifdef USE_STDIO_PTR -#define PerlIO_has_cntptr(f) 1 -#define PerlIO_get_ptr(f) FILE_ptr(f) -#define PerlIO_get_cnt(f) FILE_cnt(f) +#define PerlIO_has_cntptr(f) 1 +#define PerlIO_get_ptr(f) FILE_ptr(f) +#define PerlIO_get_cnt(f) FILE_cnt(f) #ifdef STDIO_CNT_LVALUE -#define PerlIO_canset_cnt(f) 1 +#define PerlIO_canset_cnt(f) 1 +#define PerlIO_set_cnt(f,c) (FILE_cnt(f) = (c)) #ifdef STDIO_PTR_LVALUE -#define PerlIO_fast_gets(f) 1 +#ifdef STDIO_PTR_LVAL_NOCHANGE_CNT +#define PerlIO_fast_gets(f) 1 #endif -#define PerlIO_set_cnt(f,c) (FILE_cnt(f) = (c)) -#else -#define PerlIO_canset_cnt(f) 0 +#endif /* STDIO_PTR_LVALUE */ +#else /* STDIO_CNT_LVALUE */ +#define PerlIO_canset_cnt(f) 0 #define PerlIO_set_cnt(f,c) abort() #endif #ifdef STDIO_PTR_LVALUE -#define PerlIO_set_ptrcnt(f,p,c) (FILE_ptr(f) = (p), PerlIO_set_cnt(f,c)) +#ifdef STDIO_PTR_LVAL_NOCHANGE_CNT +#define PerlIO_set_ptrcnt(f,p,c) STMT_START {FILE_ptr(f) = (p), PerlIO_set_cnt(f,c);} STMT_END +#else +#ifdef STDIO_PTR_LVAL_SETS_CNT +/* assert() may pre-process to ""; potential syntax error (FILE_ptr(), ) */ +#define PerlIO_set_ptrcnt(f,p,c) STMT_START {FILE_ptr(f) = (p); assert(FILE_cnt(f) == (c));} STMT_END +#define PerlIO_fast_gets(f) 1 #else #define PerlIO_set_ptrcnt(f,p,c) abort() #endif +#endif +#endif #else /* USE_STDIO_PTR */ @@ -124,209 +121,18 @@ #endif /* USE_STDIO_PTR */ #ifndef PerlIO_fast_gets -#define PerlIO_fast_gets(f) 0 +#define PerlIO_fast_gets(f) 0 #endif #ifdef FILE_base -#define PerlIO_has_base(f) 1 -#define PerlIO_get_base(f) FILE_base(f) -#define PerlIO_get_bufsiz(f) FILE_bufsiz(f) +#define PerlIO_has_base(f) 1 +#define PerlIO_get_base(f) FILE_base(f) +#define PerlIO_get_bufsiz(f) FILE_bufsiz(f) #else #define PerlIO_has_base(f) 0 #define PerlIO_get_base(f) (abort(),(void *)0) #define PerlIO_get_bufsiz(f) (abort(),0) #endif -#else /* PERLIO_IS_STDIO */ -#ifdef PERL_CORE -#ifndef PERLIO_NOT_STDIO -#define PERLIO_NOT_STDIO 1 -#endif -#endif -#ifdef PERLIO_NOT_STDIO -#if PERLIO_NOT_STDIO -/* - * Strong denial of stdio - make all stdio calls (we can think of) errors - */ -#include "nostdio.h" -#undef fprintf -#undef tmpfile -#undef fclose -#undef fopen -#undef vfprintf -#undef fgetc -#undef fputc -#undef fputs -#undef ungetc -#undef fread -#undef fwrite -#undef fgetpos -#undef fseek -#undef fsetpos -#undef ftell -#undef rewind -#undef fdopen -#undef popen -#undef pclose -#undef getw -#undef putw -#undef freopen -#undef setbuf -#undef setvbuf -#undef fscanf -#undef fgets -#undef getc_unlocked -#undef putc_unlocked -#define fprintf _CANNOT _fprintf_ -#define stdin _CANNOT _stdin_ -#define stdout _CANNOT _stdout_ -#define stderr _CANNOT _stderr_ -#define tmpfile() _CANNOT _tmpfile_ -#define fclose(f) _CANNOT _fclose_ -#define fflush(f) _CANNOT _fflush_ -#define fopen(p,m) _CANNOT _fopen_ -#define freopen(p,m,f) _CANNOT _freopen_ -#define setbuf(f,b) _CANNOT _setbuf_ -#define setvbuf(f,b,x,s) _CANNOT _setvbuf_ -#define fscanf _CANNOT _fscanf_ -#define vfprintf(f,fmt,a) _CANNOT _vfprintf_ -#define fgetc(f) _CANNOT _fgetc_ -#define fgets(s,n,f) _CANNOT _fgets_ -#define fputc(c,f) _CANNOT _fputc_ -#define fputs(s,f) _CANNOT _fputs_ -#define getc(f) _CANNOT _getc_ -#define putc(c,f) _CANNOT _putc_ -#define ungetc(c,f) _CANNOT _ungetc_ -#define fread(b,s,c,f) _CANNOT _fread_ -#define fwrite(b,s,c,f) _CANNOT _fwrite_ -#define fgetpos(f,p) _CANNOT _fgetpos_ -#define fseek(f,o,w) _CANNOT _fseek_ -#define fsetpos(f,p) _CANNOT _fsetpos_ -#define ftell(f) _CANNOT _ftell_ -#define rewind(f) _CANNOT _rewind_ -#define clearerr(f) _CANNOT _clearerr_ -#define feof(f) _CANNOT _feof_ -#define ferror(f) _CANNOT _ferror_ -#define __filbuf(f) _CANNOT __filbuf_ -#define __flsbuf(c,f) _CANNOT __flsbuf_ -#define _filbuf(f) _CANNOT _filbuf_ -#define _flsbuf(c,f) _CANNOT _flsbuf_ -#define fdopen(fd,p) _CANNOT _fdopen_ -#define fileno(f) _CANNOT _fileno_ -#if SFIO_VERSION < 20000101L -#define flockfile(f) _CANNOT _flockfile_ -#define ftrylockfile(f) _CANNOT _ftrylockfile_ -#define funlockfile(f) _CANNOT _funlockfile_ -#endif -#define getc_unlocked(f) _CANNOT _getc_unlocked_ -#define putc_unlocked(c,f) _CANNOT _putc_unlocked_ -#define popen(c,m) _CANNOT _popen_ -#define getw(f) _CANNOT _getw_ -#define putw(v,f) _CANNOT _putw_ -#define pclose(f) _CANNOT _pclose_ - -#else /* if PERLIO_NOT_STDIO */ -/* - * PERLIO_NOT_STDIO defined as 0 - * Declares that both PerlIO and stdio can be used - */ -#endif /* if PERLIO_NOT_STDIO */ -#else /* ifdef PERLIO_NOT_STDIO */ -/* - * PERLIO_NOT_STDIO not defined - * This is "source level" stdio compatibility mode. - */ -#include "nostdio.h" -#undef FILE -#define FILE PerlIO -#undef fprintf -#undef tmpfile -#undef fclose -#undef fopen -#undef vfprintf -#undef fgetc -#undef getc_unlocked -#undef fputc -#undef putc_unlocked -#undef fputs -#undef ungetc -#undef fread -#undef fwrite -#undef fgetpos -#undef fseek -#undef fsetpos -#undef ftell -#undef rewind -#undef fdopen -#undef popen -#undef pclose -#undef getw -#undef putw -#undef freopen -#undef setbuf -#undef setvbuf -#undef fscanf -#undef fgets -#define fprintf PerlIO_printf -#define stdin PerlIO_stdin() -#define stdout PerlIO_stdout() -#define stderr PerlIO_stderr() -#define tmpfile() PerlIO_tmpfile() -#define fclose(f) PerlIO_close(f) -#define fflush(f) PerlIO_flush(f) -#define fopen(p,m) PerlIO_open(p,m) -#define vfprintf(f,fmt,a) PerlIO_vprintf(f,fmt,a) -#define fgetc(f) PerlIO_getc(f) -#define fputc(c,f) PerlIO_putc(f,c) -#define fputs(s,f) PerlIO_puts(f,s) -#define getc(f) PerlIO_getc(f) -#ifdef getc_unlocked -#undef getc_unlocked -#endif -#define getc_unlocked(f) PerlIO_getc(f) -#define putc(c,f) PerlIO_putc(f,c) -#ifdef putc_unlocked -#undef putc_unlocked -#endif -#define putc_unlocked(c,f) PerlIO_putc(c,f) -#define ungetc(c,f) PerlIO_ungetc(f,c) -#if 0 -/* return values of read/write need work */ -#define fread(b,s,c,f) PerlIO_read(f,b,(s*c)) -#define fwrite(b,s,c,f) PerlIO_write(f,b,(s*c)) -#else -#define fread(b,s,c,f) _CANNOT fread -#define fwrite(b,s,c,f) _CANNOT fwrite -#endif -#define fgetpos(f,p) PerlIO_getpos(f,p) -#define fseek(f,o,w) PerlIO_seek(f,o,w) -#define fsetpos(f,p) PerlIO_setpos(f,p) -#define ftell(f) PerlIO_tell(f) -#define rewind(f) PerlIO_rewind(f) -#define clearerr(f) PerlIO_clearerr(f) -#define feof(f) PerlIO_eof(f) -#define ferror(f) PerlIO_error(f) -#define fdopen(fd,p) PerlIO_fdopen(fd,p) -#define fileno(f) PerlIO_fileno(f) -#define popen(c,m) my_popen(c,m) -#define pclose(f) my_pclose(f) - -#define __filbuf(f) _CANNOT __filbuf_ -#define _filbuf(f) _CANNOT _filbuf_ -#define __flsbuf(c,f) _CANNOT __flsbuf_ -#define _flsbuf(c,f) _CANNOT _flsbuf_ -#define getw(f) _CANNOT _getw_ -#define putw(v,f) _CANNOT _putw_ -#if SFIO_VERSION < 20000101L -#define flockfile(f) _CANNOT _flockfile_ -#define ftrylockfile(f) _CANNOT _ftrylockfile_ -#define funlockfile(f) _CANNOT _funlockfile_ -#endif -#define freopen(p,m,f) _CANNOT _freopen_ -#define setbuf(f,b) _CANNOT _setbuf_ -#define setvbuf(f,b,x,s) _CANNOT _setvbuf_ -#define fscanf _CANNOT _fscanf_ -#define fgets(s,n,f) _CANNOT _fgets_ -#endif /* ifdef PERLIO_NOT_STDIO */ #endif /* PERLIO_IS_STDIO */ diff --git a/perlsfio.h b/perlsfio.h index d0f6471659..de7e9acc1f 100644 --- a/perlsfio.h +++ b/perlsfio.h @@ -5,7 +5,7 @@ /* sfio 2000 changed _stdopen to _stdfdopen */ #if SFIO_VERSION >= 20000101L -#define _stdopen _stdfdopen +#define _stdopen _stdfdopen #endif extern Sfio_t* _stdopen _ARG_((int, const char*)); @@ -16,9 +16,11 @@ extern int _stdprintf _ARG_((const char*, ...)); #define PerlIO_stdout() sfstdout #define PerlIO_stdin() sfstdin +#define PerlIO_isutf8(f) 0 + #define PerlIO_printf sfprintf #define PerlIO_stdoutf _stdprintf -#define PerlIO_vprintf(f,fmt,a) sfvprintf(f,fmt,a) +#define PerlIO_vprintf(f,fmt,a) sfvprintf(f,fmt,a) #define PerlIO_read(f,buf,count) sfread(f,buf,count) #define PerlIO_write(f,buf,count) sfwrite(f,buf,count) #define PerlIO_open(path,mode) sfopen(NULL,path,mode) @@ -35,7 +37,12 @@ extern int _stdprintf _ARG_((const char*, ...)); #define PerlIO_fileno(f) sffileno(f) #define PerlIO_clearerr(f) sfclrerr(f) #define PerlIO_flush(f) sfsync(f) +#if 0 +/* This breaks tests */ +#define PerlIO_tell(f) sfseek(f,0,1|SF_SHARE) +#else #define PerlIO_tell(f) sftell(f) +#endif #define PerlIO_seek(f,o,w) sfseek(f,o,w) #define PerlIO_rewind(f) (void) sfseek((f),0L,0) #define PerlIO_tmpfile() sftmp(0) @@ -49,15 +56,15 @@ extern int _stdprintf _ARG_((const char*, ...)); /* Now our interface to equivalent of Configure's FILE_xxx macros */ -#define PerlIO_has_cntptr(f) 1 +#define PerlIO_has_cntptr(f) 1 #define PerlIO_get_ptr(f) ((f)->next) #define PerlIO_get_cnt(f) ((f)->endr - (f)->next) -#define PerlIO_canset_cnt(f) 1 -#define PerlIO_fast_gets(f) 1 -#define PerlIO_set_ptrcnt(f,p,c) ((f)->next = (unsigned char *)(p)) -#define PerlIO_set_cnt(f,c) 1 +#define PerlIO_canset_cnt(f) 1 +#define PerlIO_fast_gets(f) 1 +#define PerlIO_set_ptrcnt(f,p,c) STMT_START {(f)->next = (unsigned char *)(p); assert(PerlIO_get_cnt(f) == (c));} STMT_END +#define PerlIO_set_cnt(f,c) STMT_START {(f)->next = (f)->endr - (c);} STMT_END -#define PerlIO_has_base(f) 1 +#define PerlIO_has_base(f) 1 #define PerlIO_get_base(f) ((f)->data) #define PerlIO_get_bufsiz(f) ((f)->endr - (f)->data) @@ -1747,7 +1747,7 @@ case 35: break; case 37: #line 269 "perly.y" -{ (void)scan_num("1"); yyval.opval = yylval.opval; } +{ (void)scan_num("1", &yylval); yyval.opval = yylval.opval; } break; case 39: #line 274 "perly.y" @@ -1,6 +1,6 @@ /* perly.y * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -266,7 +266,7 @@ nexpr : /* NULL */ ; texpr : /* NULL means true */ - { (void)scan_num("1"); $$ = yylval.opval; } + { (void)scan_num("1", &yylval); $$ = yylval.opval; } | expr ; diff --git a/pod/Makefile.SH b/pod/Makefile.SH index ae6262c816..58ce9bea6f 100644 --- a/pod/Makefile.SH +++ b/pod/Makefile.SH @@ -64,6 +64,7 @@ POD2HTML = pod2html \ --libpods=perlfunc:perlguts:perlvar:perlrun:perlop PERL = ../miniperl +PERLILIB = $(PERL) -I../lib REALPERL = ../perl all: $(CONVERTERS) man @@ -73,7 +74,9 @@ converters: $(CONVERTERS) regen_pods: perlmodlib.pod toc buildtoc: buildtoc.PL perl.pod ../MANIFEST - $(PERL) -I ../lib buildtoc.PL + $(PERLILIB) buildtoc.PL + +perltoc.pod: buildtoc man: pod2man $(MAN) @@ -82,7 +85,7 @@ html: pod2html $(HTML) tex: pod2latex $(TEX) toc: buildtoc - $(PERL) -I../lib buildtoc + $(PERLILIB) buildtoc .SUFFIXES: .pm .pod diff --git a/pod/buildtoc.PL b/pod/buildtoc.PL index 3819308031..f2dba95f61 100644 --- a/pod/buildtoc.PL +++ b/pod/buildtoc.PL @@ -154,12 +154,16 @@ if (-d "pod") { perlamiga perlcygwin perldos + perlepoc perlhpux perlmachten + perlmpeix perlos2 perlos390 perlposix-bc + perlsolaris perlvms + perlvos perlwin32 ); @@ -168,12 +172,16 @@ if (-d "pod") { perlamiga perlcygwin perldos + perlepoc perlhpux perlmachten + perlmpeix perlos2 perlos390 perlposix-bc + perlsolaris perlvms + perlvos perlwin32 ); for (@ARCHPODS) { s/$/.pod/ } @@ -328,7 +336,7 @@ podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] ); Here should be listed all the extra programs' documentation, but they don't all have manual pages yet: - =over + =over 4 =item a2p @@ -381,13 +389,13 @@ sub podset { } if (s/^=head1 (.*)/=item $1/) { unhead2(); - output "=over\n\n" unless $inhead1; + output "=over 4\n\n" unless $inhead1; $inhead1 = 1; output $_; nl(); next; } if (s/^=head2 (.*)/=item $1/) { unitem(); - output "=over\n\n" unless $inhead2; + output "=over 4\n\n" unless $inhead2; $inhead2 = 1; output $_; nl(); next; } @@ -399,7 +407,7 @@ sub podset { s/\s+$//; next if /^[\d.]+$/; next if $pod eq 'perlmodlib' && /^ftp:/; - ##print "=over\n\n" unless $initem; + ##print "=over 4\n\n" unless $initem; output ", " if $initem; $initem = 1; s/\.$//; diff --git a/pod/perl.pod b/pod/perl.pod index 946d6f2927..4e08cc8ede 100644 --- a/pod/perl.pod +++ b/pod/perl.pod @@ -108,12 +108,16 @@ For ease of access, the Perl manual has been split up into several sections: perlamiga Perl notes for Amiga perlcygwin Perl notes for Cygwin perldos Perl notes for DOS + perlepoc Perl notes for EPOC perlhpux Perl notes for HP-UX perlmachten Perl notes for Power MachTen + perlmpeix Perl notes for MPE/iX perlos2 Perl notes for OS/2 perlos390 Perl notes for OS/390 perlposix-bc Perl notes for POSIX-BC + perlsolaris Perl notes for Solaris perlvms Perl notes for VMS + perlvos Perl notes for Stratus VOS perlwin32 Perl notes for Windows (If you're intending to read these straight through for the first time, @@ -187,58 +191,85 @@ But wait, there's more... Begun in 1993 (see L<perlhist>), Perl version 5 is nearly a complete rewrite that provides the following additional benefits: -=over +=over 4 -=item * modularity and reusability using innumerable modules +=item * + +modularity and reusability using innumerable modules Described in L<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>. diff --git a/pod/perl5004delta.pod b/pod/perl5004delta.pod index 8cec3aba8a..429cba93ce 100644 --- a/pod/perl5004delta.pod +++ b/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) @@ -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/pod/perl5005delta.pod b/pod/perl5005delta.pod index b133c0dd81..4b50f402c4 100644 --- a/pod/perl5005delta.pod +++ b/pod/perl5005delta.pod @@ -63,11 +63,15 @@ the new features in this release. =over 4 -=item Core sources now require ANSI C compiler +=item * + +Core sources now require ANSI C compiler An ANSI C compiler is now B<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,7 +602,7 @@ Various pragmata to control behavior of regular expressions. =head2 Changes in existing modules -=over +=over 4 =item Benchmark @@ -702,7 +708,7 @@ L<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 +865,7 @@ are outside the range which can be represented by integers internally. One possible workaround is to force Perl to use magical string increment by prepending "0" to your numbers. -=item Recursive inheritance detected while looking for method '%s' in package '%s' +=item Recursive inheritance detected while looking for method '%s' %s (F) More than 100 levels of inheritance were encountered while invoking a method. Probably indicates an unintended loop in your inheritance hierarchy. @@ -916,7 +922,7 @@ fix the problem can be found in L<perllocale/"LOCALE PROBLEMS">. =head1 Obsolete Diagnostics -=over +=over 4 =item Can't mktemp() diff --git a/pod/perl56delta.pod b/pod/perl56delta.pod index 9f30314aca..fc0d668726 100644 --- a/pod/perl56delta.pod +++ b/pod/perl56delta.pod @@ -786,7 +786,7 @@ regardless of whether or not the array has been used or declared already. The fatal error has been downgraded to an optional warning: Possible unintended interpolation of @example in string - + This warns you that C<"fred@example.com"> is going to turn into C<fred.com> if you don't backslash the C<@>. See http://www.plover.com/~mjd/perl/at-error.html for more details @@ -1837,7 +1837,8 @@ run in compile-only mode. Since this is typically not the expected behavior, END blocks are not executed anymore when the C<-c> switch is used, or if compilation fails. -See L<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 @@ -2630,9 +2631,12 @@ but still allowed it. In Perl 5.6.0 and later, C<"$$1"> always means C<"${$1}">. -=item delete(), values() and C<\(%h)> operate on aliases to values, not copies +=item delete(), each(), values() and C<\(%h)> + +operate on aliases to values, not copies -delete(), each(), values() and hashes in a list context return the actual +delete(), each(), values() and hashes (e.g. C<\(%h)>) +in a list context return the actual values in the hash, instead of copies (as they used to in earlier versions). Typical idioms for using these constructs copy the returned values, but this can make a significant difference when @@ -2782,7 +2786,7 @@ See L<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> @@ -2912,7 +2916,9 @@ include the following: =item The DB module -=item The regular expression constructs C<(?{ code })> and C<(??{ code })> +=item The regular expression code constructs: + +C<(?{ code })> and C<(??{ code })> =back diff --git a/pod/perlapi.pod b/pod/perlapi.pod index 98abdc1d07..f5596e27c9 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -287,6 +287,19 @@ Returns the stash of the CV. =for hackers Found in file cv.h +=item cv_const_sv + +If C<cv> is a constant sub eligible for inlining. returns the constant +value returned by the sub. Otherwise, returns NULL. + +Constant subs can be created with C<newCONSTSUB> or as described in +L<perlsub/"Constant Functions">. + + SV* cv_const_sv(CV* cv) + +=for hackers +Found in file op.c + =item dMARK Declare a stack marker variable, C<mark>, for the XSUB. See C<MARK> and @@ -748,7 +761,7 @@ hash and returned to the caller. The C<klen> is the length of the key. The C<flags> value will normally be zero; if set to G_DISCARD then NULL will be returned. - SV* hv_delete(HV* tb, const char* key, U32 klen, I32 flags) + SV* hv_delete(HV* tb, const char* key, I32 klen, I32 flags) =for hackers Found in file hv.c @@ -770,7 +783,7 @@ Found in file hv.c Returns a boolean indicating whether the specified hash key exists. The C<klen> is the length of the key. - bool hv_exists(HV* tb, const char* key, U32 klen) + bool hv_exists(HV* tb, const char* key, I32 klen) =for hackers Found in file hv.c @@ -796,7 +809,7 @@ dereferencing it to a C<SV*>. See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more information on how to use this function on tied hashes. - SV** hv_fetch(HV* tb, const char* key, U32 klen, I32 lval) + SV** hv_fetch(HV* tb, const char* key, I32 klen, I32 lval) =for hackers Found in file hv.c @@ -907,7 +920,7 @@ the call, and decrementing it if the function returned NULL. See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more information on how to use this function on tied hashes. - SV** hv_store(HV* tb, const char* key, U32 klen, SV* val, U32 hash) + SV** hv_store(HV* tb, const char* key, I32 klen, SV* val, U32 hash) =for hackers Found in file hv.c @@ -1032,7 +1045,8 @@ Found in file scope.h =item looks_like_number Test if an the content of an SV looks like a number (or is a -number). +number). C<Inf> and C<Infinity> are treated as numbers (so will not +issue a non-numeric warning), even if your atof() doesn't grok them. I32 looks_like_number(SV* sv) @@ -1162,7 +1176,7 @@ Found in file handy.h Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is eligible for inlining at compile-time. - void newCONSTSUB(HV* stash, char* name, SV* sv) + CV* newCONSTSUB(HV* stash, char* name, SV* sv) =for hackers Found in file op.c @@ -1270,7 +1284,7 @@ The idea here is that as string table is used for shared hash keys these strings will have SvPVX == HeKEY and hash lookup will avoid string compare. - SV* newSVpvn_share(const char* s, STRLEN len, U32 hash) + SV* newSVpvn_share(const char* s, I32 len, U32 hash) =for hackers Found in file sv.c @@ -1430,7 +1444,7 @@ Found in file perl.c =item PL_DBsingle When Perl is run in debugging mode, with the B<-d> switch, this SV is a -boolean which indicates whether subs are being single-stepped. +boolean which indicates whether subs are being single-stepped. Single-stepping is automatically turned on after every step. This is the C variable which corresponds to Perl's $DB::single variable. See C<PL_DBsub>. @@ -1474,10 +1488,10 @@ Found in file intrpvar.h =item PL_modglobal -C<PL_modglobal> is a general purpose, interpreter global HV for use by +C<PL_modglobal> is a general purpose, interpreter global HV for use by extensions that need to keep information on a per-interpreter basis. -In a pinch, it can also be used as a symbol table for extensions -to share data among each other. It is a good idea to use keys +In a pinch, it can also be used as a symbol table for extensions +to share data among each other. It is a good idea to use keys prefixed by the package name of the extension that owns the data. HV* PL_modglobal @@ -2421,6 +2435,15 @@ Type flag for blessed scalars. See C<svtype>. =for hackers Found in file sv.h +=item SvUOK + +Returns a boolean indicating whether the SV contains an unsigned integer. + + void SvUOK(SV* sv) + +=for hackers +Found in file sv.h + =item SvUPGRADE Used to upgrade an SV to a more complex form. Uses C<sv_upgrade> to @@ -2559,8 +2582,9 @@ 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) @@ -3050,13 +3074,29 @@ Found in file sv.c Unsets the RV status of the SV, and decrements the reference count of whatever was being referenced by the RV. This can almost be thought of -as a reversal of C<newSVrv>. See C<SvROK_off>. +as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag> +being zero. See C<SvROK_off>. void sv_unref(SV* sv) =for hackers Found in file sv.c +=item sv_unref_flags + +Unsets the RV status of the SV, and decrements the reference count of +whatever was being referenced by the RV. This can almost be thought of +as a reversal of C<newSVrv>. The C<cflags> argument can contain +C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented +(otherwise the decrementing is conditional on the reference count being +different from one or the reference being a readonly SV). +See C<SvROK_off>. + + void sv_unref_flags(SV* sv, U32 flags) + +=for hackers +Found in file sv.c + =item sv_upgrade Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See @@ -3190,6 +3230,44 @@ string, false otherwise. =for hackers Found in file utf8.c +=item utf8_distance + +Returns the number of UTF8 characters between the UTF-8 pointers C<a> +and C<b>. + +WARNING: use only if you *know* that the pointers point inside the +same UTF-8 buffer. + + IV utf8_distance(U8 *a, U8 *b) + +=for hackers +Found in file utf8.c + +=item utf8_hop + +Return the UTF-8 pointer C<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. + + 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. + + 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. @@ -3205,32 +3283,35 @@ Found in file utf8.c =item utf8_to_uv Returns the character value of the first character in the string C<s> -which is assumed to be in UTF8 encoding; C<retlen> will be set to the -length, in bytes, of that character, and the pointer C<s> will be -advanced to the end of the character. +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, an optional UTF8 -warning is produced. +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. - U8* s utf8_to_uv(I32 *retlen) +The C<flags> can also contain various flags to allow deviations from +the strict UTF-8 encoding (see F<utf8.h>). + + U8* s utf8_to_uv(STRLEN curlen, STRLEN *retlen, U32 flags) =for hackers Found in file utf8.c -=item utf8_to_uv_chk +=item utf8_to_uv_simple Returns the character value of the first character in the string C<s> which is assumed to be in UTF8 encoding; C<retlen> will be set to the -length, in bytes, of that character, and the pointer C<s> will be -advanced to the end of the character. +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<checking>: if this is true, it is -assumed that the caller will raise a warning, and this function will -set C<retlen> to C<-1> and return. If C<checking> is not true, an optional UTF8 -warning is produced. +If C<s> does not point to a well-formed UTF8 character, zero is +returned and retlen is set, if possible, to -1. - U8* s utf8_to_uv_chk(I32 *retlen, I32 checking) + U8* s utf8_to_uv_simple(STRLEN *retlen) =for hackers Found in file utf8.c diff --git a/pod/perldebguts.pod b/pod/perldebguts.pod index 742423bb67..20cc5460fd 100644 --- a/pod/perldebguts.pod +++ b/pod/perldebguts.pod @@ -23,7 +23,7 @@ frame was called with are copied to the @DB::args array. The general mechanisms is enabled by calling Perl with the B<-d> switch, the following additional features are enabled (cf. L<perlvar/$^P>): -=over +=over 4 =item * @@ -402,7 +402,7 @@ shorter than 7 chars. The fields of interest which may appear in the last line are -=over +=over 4 =item C<anchored> I<STRING> C<at> I<POS> @@ -693,7 +693,7 @@ Devel::Peek module. Here is some explanation of that format: -=over +=over 4 =item C<buckets SMALLEST(APPROX)..GREATEST(APPROX)> @@ -840,7 +840,7 @@ per glob - for glob name, and glob stringification magic. Here are explanations for other I<Id>s above: -=over +=over 4 =item C<717> @@ -894,7 +894,7 @@ these categories. If warn() string starts with -=over +=over 4 =item C<!!!> diff --git a/pod/perldebtut.pod b/pod/perldebtut.pod index 2916897893..ece5848269 100644 --- a/pod/perldebtut.pod +++ b/pod/perldebtut.pod @@ -495,7 +495,7 @@ And a print to show what values we're currently using: DB<1> p $deg, $num f33.3 - + We can put another break point on any line beginning with a colon, we'll use line 17 as that's just as we come out of the subroutine, and we'd like to pause there later on: @@ -538,7 +538,7 @@ it for inspection. In this case though, we simply continue down to line 29: DB<4> c 29 main::f2c(temp:29): return $c; - + And have a look at the return value: DB<5> p $c @@ -616,7 +616,7 @@ the DEBUGGING flag for this one: floating `'$ at 4..2147483647 (checking floating) stclass `EXACTF <pe>' anchored(BOL) minlen 4 Omitting $` $& $' support. - + EXECUTING... Freeing REx: `^pe(a)*rl$' @@ -656,7 +656,7 @@ script from the command-line, try something like this: > perl -d my_cgi.pl -nodebug -Of course 'L<perldoc CGI>' and L<perlfaq9> will tell you more. +Of course L<CGI> and L<perlfaq9> will tell you more. =head1 GUIs diff --git a/pod/perldebug.pod b/pod/perldebug.pod index faff39b2ab..01f35e1eb4 100644 --- a/pod/perldebug.pod +++ b/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 < ? diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 480ab8492d..22a24bece6 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -402,6 +402,11 @@ L<perlport> for more on portability concerns. (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 binmode() on closed filehandle %s + +(W unopened) You tried binmode() on a filehandle that was never opened. +Check you control flow and number of arguments. + =item Bit vector size > 32 non-portable (W portable) Using bit vector sizes larger than 32 is non-portable. @@ -651,6 +656,13 @@ 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 @@ -1086,7 +1098,7 @@ on I<Mastering Regular Expressions>.) to check the return value of your socket() call? See L<perlfunc/connect>. -=item constant(%s): %s +=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 @@ -1116,8 +1128,8 @@ workarounds. =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 @@ -1380,7 +1392,7 @@ 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 +some time before now. Check your control flow. flock() operates on filehandles. Are you attempting to call flock() on a dirhandle by the same name? @@ -1660,8 +1672,8 @@ shows in the regular expression about where the problem was discovered. (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)>. +operators arguments found inside the parentheses. See +L<perlop/Terms and List Operators (Leftward)>. =item Invalid %s attribute: %s @@ -1713,6 +1725,11 @@ silently ignored. (F) Your machine apparently doesn't implement ioctl(), which is pretty strange for a machine that supports C. +=item ioctl() on unopened %s + +(W unopened) You tried ioctl() on a filehandle that was never opened. +Check you control flow and number of arguments. + =item `%s' is not a code reference (W) The second (fourth, sixth, ...) argument of overload::constant needs @@ -1768,7 +1785,7 @@ instead on the filehandle.) values cannot be returned in subroutines used in lvalue context. See L<perlsub/"Lvalue subroutines">. -=item Lookbehind longer than %d not implemented before << HERE in reges m/%s/ +=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 @@ -1789,6 +1806,10 @@ 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 @@ -2266,9 +2287,9 @@ 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>. +that isn't open. Check your control flow. See also L<perlfunc/-X>. -=item %s() on unopened %s %s +=item %s() on unopened %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() @@ -2325,7 +2346,8 @@ 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>. +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 @@ -2383,23 +2405,19 @@ 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. - =item panic: do_subst (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 +(P) The internal do_trans routines were called with invalid operational data. =item panic: frexp @@ -2491,6 +2509,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. @@ -2563,13 +2585,23 @@ C<sh>-shell in. See "PERL_SH_DIR" in L<perlos2>. 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>. +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 perlio: unknown layer "%s" + +(S) An attempt was made to push an unknown layer onto the Perl I/O +system. (Layers take care of transforming data between external and +internal representations.) Note that some layers, such as C<mmap>, +are not supported in all environments. If your program didn't +explicitly request the failing operation, it may be the result of the +value of the environment variable PERLIO. =item Permission denied @@ -2712,12 +2744,12 @@ 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. +before now. Check your control 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. +before now. Check your control flow. =item Process terminated by SIG%s @@ -2738,7 +2770,7 @@ declared or defined with a different function prototype. {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 in regex m/%s/ +=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 @@ -2756,7 +2788,7 @@ 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. +before now. Check your control flow. =item Reallocation too large: %lx @@ -2899,9 +2931,10 @@ filehandle that was either never opened or has since been closed. (F) This machine doesn't implement the select() system call. -=item Self-ties are not supported +=item Self-ties of arrays and hashes are not supported -(F) Self-ties are not supported in the current implementation. +(F) Self-ties are of arrays and hashes are not supported in +the current implementation. =item Semicolon seems to be missing @@ -2920,7 +2953,7 @@ scalar that had previously been marked as free. =item send() on closed socket %s (W closed) The socket you're sending to got itself closed sometime -before now. Check your logic flow. +before now. Check your control flow. =item Sequence (? incomplete before << HERE mark in regex m/%s/ @@ -2928,18 +2961,18 @@ before now. Check your logic flow. shows in the regular expression about where the problem was discovered. See L<perlre>. -=item Sequence (?{...}) not terminated or not {}-balanced in regex m/%s/ +=item Sequence (?{...}) not terminated or not {}-balanced in %s (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 before << HERE mark in regex m/%s/ +=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. The << HERE shows in the regular expression about where the problem was discovered. See L<perlre>. -=item Sequence (?%s...) not recognized before << HERE mark in regex m/%s/ +=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 @@ -3130,7 +3163,7 @@ assignment or as a subroutine argument for example). (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 << HERE in regex m/%s/ +=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 @@ -3195,7 +3228,7 @@ 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. +before now. Check your control flow. =item Target of goto is too deeply nested @@ -3235,7 +3268,7 @@ will deny it. 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 +=item The stat preceding %s 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 @@ -3677,6 +3710,15 @@ old way has bad side effects. (D deprecated) This was an ill-advised attempt to emulate a poorly defined B<awk> feature. Use an explicit printf() or sprintf() instead. +=item Use of reference "%s" in array index + +(W) You tried to use a reference as an array index; this probably +isn't what you mean, because references tend to be huge numbers which +take you out of memory, and so usually indicates programmer error. + +If you really do mean it, explicitly numify your reference, like so: +C<$array[0+$ref]> + =item Use of reserved word "%s" is deprecated (D deprecated) The indicated bareword is a reserved word. Future @@ -3780,7 +3822,7 @@ 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. -=item Variable length lookbehind not implemented before << HERE in regex m/%s/ +=item Variable length lookbehind not implemented before << HERE in %s (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 @@ -3829,7 +3871,7 @@ So put in parentheses to say what you really mean. =item write() on closed filehandle %s (W closed) The filehandle you're writing to got itself closed sometime -before now. Check your logic flow. +before now. Check your control flow. =item X outside of string diff --git a/pod/perlebcdic.pod b/pod/perlebcdic.pod index 4ef5eca2d0..12ea2f3ef4 100644 --- a/pod/perlebcdic.pod +++ b/pod/perlebcdic.pod @@ -501,7 +501,8 @@ provide easy to use ASCII to EBCDIC operations that are also easily reversed. For example, to convert ASCII to code page 037 take the output of the second -column from the output of recipe 0 and use it in tr/// like so: +column from the output of recipe 0 (modified to add \\ characters) and use +it in tr/// like so: $cp_037 = '\000\001\002\003\234\011\206\177\227\215\216\013\014\015\016\017' . @@ -524,15 +525,19 @@ column from the output of recipe 0 and use it in tr/// like so: my $ebcdic_string = $ascii_string; eval '$ebcdic_string =~ tr/\000-\377/' . $cp_037 . '/'; -To convert from EBCDIC to ASCII just reverse the order of the tr/// +To convert from EBCDIC 037 to ASCII just reverse the order of the tr/// arguments like so: my $ascii_string = $ebcdic_string; - eval '$ascii_string = tr/' . $code_page_chrs . '/\000-\037/'; + eval '$ascii_string = tr/' . $cp_037 . '/\000-\377/'; + +Similarly one could take the output of the third column from recipe 0 to +obtain a C<$cp_1047> table. The fourth column of the output from recipe +0 could provide a C<$cp_posix_bc> table suitable for transcoding as well. =head2 iconv -XPG4 operability often implies the presence of an I<iconv> utility +XPG operability often implies the presence of an I<iconv> utility available from the shell or from the C library. Consult your system's documentation for information on iconv. diff --git a/pod/perlembed.pod b/pod/perlembed.pod index 1787e4b2eb..57d1bdbc0e 100644 --- a/pod/perlembed.pod +++ b/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 @@ -948,7 +967,7 @@ B<ExtUtils::Embed> can also automate writing the I<xs_init> glue code. Consult L<perlxs>, L<perlguts>, and L<perlapi> for more details. -=head1 Embedding Perl under Windows +=head1 Embedding Perl under Win32 In general, all of the source code shown here should work unmodified under Windows. diff --git a/pod/perlfaq.pod b/pod/perlfaq.pod index fa6943f0db..bc29c694f2 100644 --- a/pod/perlfaq.pod +++ b/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/pod/perlfaq1.pod b/pod/perlfaq1.pod index ec61e8b61e..1f9cb4c2e0 100644 --- a/pod/perlfaq1.pod +++ b/pod/perlfaq1.pod @@ -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 @@ -120,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 @@ -183,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 @@ -201,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"? @@ -220,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 @@ -263,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 @@ -272,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. @@ -292,7 +292,7 @@ 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 +(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. That probably means running the 5.005 release, although 5.004 diff --git a/pod/perlfaq2.pod b/pod/perlfaq2.pod index df05091e06..f438baa620 100644 --- a/pod/perlfaq2.pod +++ b/pod/perlfaq2.pod @@ -69,19 +69,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? @@ -133,7 +133,7 @@ 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 @@ -145,14 +145,16 @@ 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. -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 @@ -193,7 +195,7 @@ a request. 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 (July 2000) in its third edition: @@ -206,7 +208,7 @@ the creator of Perl, is now (July 2000) in its third edition: 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: +(first premiered at the 1998 Perl Conference), is: The Perl Cookbook (the "Ram Book"): by Tom Christiansen and Nathan Torkington, @@ -215,8 +217,8 @@ of real-world examples, mini-tutorials, and complete programs 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 @@ -225,9 +227,9 @@ out: 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 @@ -245,7 +247,7 @@ useful. Your mileage may (but, we hope, probably won't) vary. Recommended books on (or mostly on) Perl follow. -=over +=over 4 =item References @@ -350,7 +352,7 @@ Recommended books on (or mostly on) Perl follow. 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 +announcements, contests, and much more. I<TPJ> has 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 @@ -362,11 +364,11 @@ 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 +To get the best performance, pick a site from the list below and use it to grab the complete list of mirror sites. From there you can find the quickest site for you. Remember, the following list is I<not> the complete list of CPAN mirrors @@ -399,7 +401,7 @@ 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 @@ -413,7 +415,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.* @@ -427,13 +429,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 @@ -444,7 +446,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 diff --git a/pod/perlfaq3.pod b/pod/perlfaq3.pod index b05b7361c0..5bf2f5c118 100644 --- a/pod/perlfaq3.pod +++ b/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,7 +157,7 @@ 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 +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. @@ -168,7 +169,7 @@ 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 +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. @@ -176,22 +177,76 @@ 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. +your hard-earned cash for. + +If you're transferring Windows text files to Unix using FTP be sure to +transfer them in ASCII mode so the ends of lines are appropriately mangled. + +PerlBuilder (http://www.solutionsoft.com/perl.htm) is an integrated +development environment for Windows that supports Perl development. +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 in beta (late 2000) +(http://www.ActiveState.com/Products/VisualPerl/index.html)). +The visiPerl+ IDE is available from Help Consulting +(http://helpconsulting.net/visiperl/). Perl code magic is +another IDE (http://www.petes-place.com/codemagic.html). CodeMagicCD +(http://www.codemagiccd.com/) is another IDE. The Object System +(http://www.castlelink.co.uk/object_system/) is a Perl web +applications development IDE. + +Perl programs are just plain text, though, so you could download GNU +Emacs (http://www.gnu.org/software/emacs/windows/ntemacs.html) or +XEmacs (http://www.xemacs.org/Download/index.html), or a vi clone such +as Elvis (ftp://ftp.cs.pdx.edu/pub/elvis/, see also +http://www.fh-wedel.de/elvis/), nvi (http://www.bostic.com/vi/, or +available from CPAN in src/misc/), or Vile +(http://www.clark.net/pub/dickey/vile/vile.html), or vim +(http://www.vim.org/) (win32: http://www.cs.vu.nl/%7Etmgil/vi.html). +(For vi lovers in general: http://www.thomer.com/thomer/vi/vi.html) + +The following are Win32 multilanguage editor/IDESs that support Perl: +Codewright (http://www.starbase.com/), MultiEdit (http://www.MultiEdit.com/), +SlickEdit (http://www.slickedit.com/). + +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 the Bash +from the Cygwin package (http://sources.redhat.com/cygwin/), or the +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/), or +the Tcsh (ftp://ftp.astron.com/pub/tcsh/, see also +http://www.primate.wisc.edu/software/csh-tcsh-book/), or the Zsh +(ftp://ftp.blarg.net/users/amol/zsh/, see also http://www.zsh.org/). +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. + +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). BBEdit and BBEdit Lite are text editors for Mac OS +that have a Perl sensitivity mode (http://web.barebones.com/). +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/). =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 +278,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 +292,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 +308,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 +348,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 +393,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 +434,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 +450,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 +467,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 +489,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 +507,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 +518,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 +534,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 +603,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 +653,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 +670,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/pod/perlfaq4.pod b/pod/perlfaq4.pod index 79905f88ce..1198f18a4f 100644 --- a/pod/perlfaq4.pod +++ b/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. @@ -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); + @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 @@ -1196,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 = (); @@ -1297,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] } @@ -1438,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. @@ -1471,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. @@ -1487,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 { diff --git a/pod/perlfaq5.pod b/pod/perlfaq5.pod index feb66a45cd..e4ad3fa372 100644 --- a/pod/perlfaq5.pod +++ b/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: @@ -465,7 +468,7 @@ whatever: 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 +csh or tcsh or (some versions of) ksh, and thus your code may have portability problems. The Glob::KGlob module (available from CPAN) gives more portable glob functionality. @@ -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,12 +835,12 @@ 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 standard DB_File module's $DB_RECNO bindings, which allow you to tie an array to a file so that accessing an element @@ -847,7 +848,7 @@ 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/pod/perlfaq6.pod b/pod/perlfaq6.pod index 4ab4d4cc98..5100c351e8 100644 --- a/pod/perlfaq6.pod +++ b/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. @@ -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: @@ -450,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? @@ -487,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 @@ -514,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 @@ -589,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? @@ -670,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/pod/perlfaq7.pod b/pod/perlfaq7.pod index 0d4876fd68..0299c2d893 100644 --- a/pod/perlfaq7.pod +++ b/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>. @@ -258,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? @@ -274,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. @@ -349,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 ); @@ -370,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: @@ -394,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; } @@ -460,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); @@ -495,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())); @@ -516,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. @@ -557,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? @@ -634,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. @@ -709,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: @@ -767,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>. @@ -789,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): @@ -861,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 @@ -894,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 @@ -906,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 @@ -946,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 @@ -967,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/pod/perlfaq8.pod b/pod/perlfaq8.pod index 0ac462021b..d806ed67e7 100644 --- a/pod/perlfaq8.pod +++ b/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; @@ -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? @@ -494,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). @@ -510,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 @@ -522,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()? @@ -567,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 @@ -595,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: @@ -688,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 @@ -715,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 @@ -762,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: @@ -855,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. @@ -867,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? @@ -930,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? @@ -971,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. @@ -1010,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. @@ -1047,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/pod/perlfaq9.pod b/pod/perlfaq9.pod index d1bd593dfe..4c701cafde 100644 --- a/pod/perlfaq9.pod +++ b/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: @@ -224,13 +224,11 @@ available from CPAN. =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. @@ -248,12 +246,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? @@ -276,9 +274,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 @@ -289,7 +287,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>; @@ -397,7 +395,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: @@ -465,7 +463,7 @@ include queueing, MX records, and security. 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 @@ -520,7 +518,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")' @@ -532,7 +530,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/pod/perlfilter.pod b/pod/perlfilter.pod index c3c83153ad..4327809ec9 100644 --- a/pod/perlfilter.pod +++ b/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/pod/perlfunc.pod b/pod/perlfunc.pod index db90b86879..82086e3c96 100644 --- a/pod/perlfunc.pod +++ b/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 @@ -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. @@ -923,7 +923,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 @@ -1193,7 +1196,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 @@ -1208,7 +1211,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: @@ -1472,7 +1482,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; @@ -2341,8 +2354,8 @@ it succeeded, false otherwise. See the example in L<perlipc/"Sockets: Client/Se =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 @@ -2476,6 +2489,29 @@ 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 @@ -2846,7 +2882,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>; @@ -3470,12 +3506,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 @@ -4258,9 +4295,9 @@ 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 and type - + @articles = sort {$b <=> $a} @files; - + 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 @@ -4345,6 +4382,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); @@ -4478,13 +4524,31 @@ and the conversion letter: h interpret integer as C type "short" or "unsigned short" If no flags, interpret integer as C type "int" or "unsigned" +Perl supports parameter ordering, in other words, fetching the +parameters in some explicitly specified "random" ordering as opposed +to the default implicit sequential ordering. The syntax is, instead +of the C<%> and C<*>, to use C<%>I<digits>C<$> and C<*>I<digits>C<$>, +where the I<digits> is the wanted index, from one upwards. For example: + + printf "%2\$d %1\$d\n", 12, 34; # will print "34 12\n" + printf "%*2\$d\n", 12, 3; # will print " 12\n" + +Note that using the reordering syntax does not interfere with the usual +implicit sequential fetching of the parameters: + + printf "%2\$d %d\n", 12, 34; # will print "34 12\n" + printf "%2\$d %d %d\n", 12, 34; # will print "34 12 34\n" + printf "%3\$d %d %d\n", 12, 34, 56; # will print "56 12 34\n" + printf "%2\$*3\$d %d\n", 12, 34, 3; # will print " 34 12\n" + printf "%*3\$2\$d %d\n", 12, 34, 3; # will print " 34 12\n" + There are also two Perl-specific flags: - V interpret integer as Perl's standard integer type - v interpret string as a vector of integers, output as - numbers separated either by dots, or by an arbitrary - string received from the argument list when the flag - is preceded by C<*> + V interpret integer as Perl's standard integer type + v interpret string as a vector of integers, output as + numbers separated either by dots, or by an arbitrary + string received from the argument list when the flag + is preceded by C<*> Where a number would appear in the flags, an asterisk (C<*>) may be used instead, in which case Perl uses the next item in the parameter @@ -5043,9 +5107,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. diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 4d62774477..f38bba37a0 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -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. @@ -1088,7 +1092,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)> @@ -1161,7 +1165,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)> @@ -1511,6 +1515,31 @@ 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 compiler while I<yacc> code feeds it @@ -1571,6 +1600,41 @@ 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 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) + + 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 diff --git a/pod/perlhack.pod b/pod/perlhack.pod index 3abc1f7266..155773d8e5 100644 --- a/pod/perlhack.pod +++ b/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,267 @@ 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 -avz rsync://ftp.linux.activestate.com/perl-diffs perl-diffs - -Use this to get the latest source tree in full: - - rsync -avz 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. + +Note that this will not delete any files that were in '.' before +the rsync. Once you are sure that the rsync is running correctly, +run it with the --delete and the --dry-run options like this: + + # rsync -avz --delete --dry-run rsync://ftp.linux.activestate.com/perl-current/ . + +This will I<simulate> an rsync run that also deletes files not +present in the bleadperl master copy. Observe the results from +this run closely. If you are sure that the actual run would delete +no files precious to you, you could remove the '--dry-run' option. + +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 + +=head3 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 + +=head3 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 than 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 @@ -827,7 +1076,7 @@ the tied C<push> is implemented; see C<av_push> in F<av.c>: 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. @@ -950,7 +1199,7 @@ useful options are probably Some of the functionality of the debugging code can be achieved using XS modules. - + -Dr => use re 'debug' -Dx => use O 'Debug' @@ -1012,7 +1261,7 @@ Run until the next breakpoint. Run until the end of the current function, then stop again. -=item +=item 'enter' Just pressing Enter will do the most recent operation again - it's a blessing when stepping through miles of source code. @@ -1256,7 +1505,7 @@ this text in the description of C<pack>: 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: @@ -1454,6 +1703,12 @@ 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 diff --git a/pod/perlhist.pod b/pod/perlhist.pod index 2aa928cc2f..f5a96020ed 100644 --- a/pod/perlhist.pod +++ b/pod/perlhist.pod @@ -1,5 +1,3 @@ -=pod - =head1 NAME perlhist - the Perl history records diff --git a/pod/perlintern.pod b/pod/perlintern.pod index 11d9385181..b63b694131 100644 --- a/pod/perlintern.pod +++ b/pod/perlintern.pod @@ -12,6 +12,18 @@ B<they are not for use in extensions>! =over 8 +=item djSP + +Declare Just C<SP>. This is actually identical to C<dSP>, and declares +a local copy of perl's stack pointer, available via the C<SP> macro. +See C<SP>. (Available for backward source code compatibility with the +old (Perl 5.005) thread model.) + + djSP; + +=for hackers +Found in file pp.h + =item is_gv_magical Returns C<TRUE> if given the name of a magical GV. @@ -27,6 +39,18 @@ allow selecting particular classes of magical variable. =for hackers Found in file gv.c +=item start_glob + +Function called by C<do_readline> to spawn a glob (or do the glob inside +perl on VMS). This code used to be inline, but now perl uses C<File::Glob> +this glob starter is only used by miniperl during the build proccess. +Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up. + + PerlIO* start_glob(SV* pattern, IO *io) + +=for hackers +Found in file doio.c + =back =head1 AUTHORS diff --git a/pod/perlipc.pod b/pod/perlipc.pod index 94b6bdec9b..a1df3e42e0 100644 --- a/pod/perlipc.pod +++ b/pod/perlipc.pod @@ -660,14 +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) = $port =~ /^(\d+)$/ || die "invalid port"; + ($port) = $port =~ /^(\d+)$/ or die "invalid port"; socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, @@ -703,7 +703,7 @@ 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" } @@ -711,7 +711,7 @@ go back to service a new client. my $port = shift || 2345; my $proto = getprotobyname('tcp'); - ($port) = $port =~ /^(\d+)$/ || die "invalid port"; + ($port) = $port =~ /^(\d+)$/ or die "invalid port"; socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, @@ -865,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'; @@ -901,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 @@ -952,7 +976,7 @@ looks like this: Here are what those parameters to the C<new> constructor mean: -=over +=over 4 =item C<Proto> @@ -1147,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 diff --git a/pod/perllexwarn.pod b/pod/perllexwarn.pod index 3dd3ba977a..b98e3332e4 100644 --- a/pod/perllexwarn.pod +++ b/pod/perllexwarn.pod @@ -468,7 +468,7 @@ Consider this example: bless [], $class ; } - + 1 ; The code below makes use of both modules, but it only enables warnings from diff --git a/pod/perllocale.pod b/pod/perllocale.pod index 3d9a58a007..d37664c5ab 100644 --- a/pod/perllocale.pod +++ b/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>. @@ -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 @@ -445,7 +445,7 @@ 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 @@ -453,13 +453,13 @@ 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 @@ -554,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 @@ -580,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 @@ -642,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. @@ -686,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. @@ -708,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 @@ -716,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()): diff --git a/pod/perlmodlib.PL b/pod/perlmodlib.PL index e1ba87b52a..c47affc608 100644 --- a/pod/perlmodlib.PL +++ b/pod/perlmodlib.PL @@ -580,6 +580,12 @@ 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. diff --git a/pod/perlmodlib.pod b/pod/perlmodlib.pod index f37279d90a..d0bd1c9b76 100644 --- a/pod/perlmodlib.pod +++ b/pod/perlmodlib.pod @@ -98,10 +98,6 @@ Compute arithmetic in integer instead of double Request less of something from the compiler -=item lib - -Manipulate @INC at compile time - =item locale Use and avoid POSIX locales for built-in operations @@ -118,6 +114,10 @@ Restrict unsafe operations when compiling Package for overloading perl operations +=item perlio + +Configure C level IO + =item re Alter regular expression behaviour @@ -146,6 +146,10 @@ Predeclare global variable names (obsolete) Control optional warnings +=item warnings::register + +Warnings import function + =back =head2 Standard Modules @@ -220,6 +224,10 @@ Show lexical variables used in functions or files Helper module for CC backend +=item B::Stash + +Show what stashes are loaded + =item B::Terse Walk Perl syntax tree, printing terse info about ops @@ -284,10 +292,6 @@ Wrapper around CPAN.pm without using any XS module Warn of errors (from perspective of caller) -=item Carp::Heavy - -Carp guts - =item Class::Struct Declare struct-like datatypes as Perl classes @@ -316,6 +320,10 @@ Supply object methods for directory handles Provides screen dump of Perl data. +=item Encode + +Character encodings + =item English Use nice English (or awk) names for ugly punctuation variables @@ -436,6 +444,10 @@ Create or remove directory trees 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 @@ -476,6 +488,10 @@ Keep more files open than the system permits Supply object methods for filehandles +=item Filter::Simple + +Simplified source filtering + =item FindBin Locate directory of original perl script @@ -572,6 +588,10 @@ Module to convert pod files to HTML 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 @@ -636,6 +656,10 @@ Run shell commands transparently within perl Load the C socket.h defines and structure manipulators +=item Storable + +Persistency for perl data structures + =item Symbol Manipulate Perl symbols and their names @@ -778,66 +802,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 @@ -1201,6 +1246,12 @@ 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. @@ -1400,18 +1451,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/pod/perlnumber.pod b/pod/perlnumber.pod index d179d8c74a..44d921cfe6 100644 --- a/pod/perlnumber.pod +++ b/pod/perlnumber.pod @@ -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/pod/perlop.pod b/pod/perlop.pod index e97a25bc9b..0bb506ddc7 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -300,8 +300,13 @@ 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. If your platform supports NaNs (not-a-numbers) as numeric -values, using them with "<=>" (or any other numeric comparison) -returns undef. +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. @@ -798,7 +803,7 @@ 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. @@ -951,7 +956,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 @@ -1338,7 +1343,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 @@ -1392,7 +1397,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///> @@ -1842,8 +1847,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 diff --git a/pod/perlopentut.pod b/pod/perlopentut.pod index 5d2d48e7f1..b4003f4f2e 100644 --- a/pod/perlopentut.pod +++ b/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 @@ -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/pod/perlpod.pod b/pod/perlpod.pod index 6c0c5348c4..22a0256961 100644 --- a/pod/perlpod.pod +++ b/pod/perlpod.pod @@ -27,6 +27,8 @@ use however it pleases. Currently recognized commands are =head1 heading =head2 heading + =head3 heading + =head4 heading =item text =over N =back @@ -50,8 +52,13 @@ another paragraph to the doc if you're mixing up code and pod a lot. =item =head2 -Head1 and head2 produce first and second level headings, with the text in -the same paragraph as the "=headn" directive forming the heading description. +=item =head3 + +=item =head4 + +Head1, head2, head3 and head4 produce first, second, third and fourth +level headings, with the text in the same paragraph as the "=headn" +directive forming the heading description. =item =over diff --git a/pod/perlport.pod b/pod/perlport.pod index 0c3554686d..1078e58bf3 100644 --- a/pod/perlport.pod +++ b/pod/perlport.pod @@ -334,7 +334,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. @@ -683,7 +686,7 @@ The ActiveState Pages, http://www.activestate.com/ =item * The Cygwin environment for Win32; F<README.cygwin> (installed -as L<perlcygwin>), http://sources.redhat.com/cygwin/ +as L<perlcygwin>), http://www.cygwin.com/ =item * @@ -890,9 +893,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 @@ -908,12 +911,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 @@ -1211,7 +1213,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> @@ -1995,9 +1997,9 @@ http://www.perl.com/CPAN/ports/index.html for binary distributions. =head1 SEE ALSO -L<perlaix>, L<perlamiga>, L<perlcygwin>, L<perldos>, L<perlebcdic>, -L<perlhpux>, L<perlos2>, L<perlos390>, L<perlposix-bc>, 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<perlposix-bc>, +L<perlwin32>, L<perlvms>, L<perlvos>, and L<Win32>. =head1 AUTHORS / CONTRIBUTORS diff --git a/pod/perlre.pod b/pod/perlre.pod index 380bc5f1f3..c5ecb13c40 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -225,19 +225,21 @@ whole character class. For example: 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 @@ -910,10 +912,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", @@ -1129,7 +1135,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> diff --git a/pod/perlreftut.pod b/pod/perlreftut.pod index c8593fb1ce..073d358da5 100644 --- a/pod/perlreftut.pod +++ b/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/pod/perlrequick.pod b/pod/perlrequick.pod index a14229c303..5b72a35187 100644 --- a/pod/perlrequick.pod +++ b/pod/perlrequick.pod @@ -166,24 +166,31 @@ Perl has several abbreviations for common character classes: =over 4 =item * + \d is a digit and represents [0-9] =item * + \s is a whitespace character and represents [\ \t\r\n\f] =item * + \w is a word character (alphanumeric or _) and represents [0-9a-zA-Z_] =item * + \D is a negated \d; it represents any character but a digit [^0-9] =item * + \S is a negated \s; it represents any non-whitespace character [^\s] =item * + \W is a negated \w; it represents any non-word character [^\w] =item * + The period '.' matches any character but "\n" =back @@ -297,18 +304,30 @@ have the following meanings: =over 4 -=item * C<a?> = match 'a' 1 or 0 times +=item * -=item * C<a*> = match 'a' 0 or more times, i.e., any number of times +C<a?> = match 'a' 1 or 0 times + +=item * -=item * C<a+> = match 'a' 1 or more times, i.e., at least once +C<a*> = match 'a' 0 or more times, i.e., any number of times -=item * C<a{n,m}> = match at least C<n> times, but not more than C<m> +=item * + +C<a+> = match 'a' 1 or more times, i.e., at least once + +=item * + +C<a{n,m}> = match at least C<n> times, but not more than C<m> times. -=item * C<a{n,}> = match at least C<n> or more times +=item * + +C<a{n,}> = match at least C<n> or more times + +=item * -=item * C<a{n}> = match exactly C<n> times +C<a{n}> = match exactly C<n> times =back diff --git a/pod/perlretut.pod b/pod/perlretut.pod index 2c449f8b07..a77b87e125 100644 --- a/pod/perlretut.pod +++ b/pod/perlretut.pod @@ -368,24 +368,31 @@ has several abbreviations for common character classes: =over 4 =item * + \d is a digit and represents [0-9] =item * + \s is a whitespace character and represents [\ \t\r\n\f] =item * + \w is a word character (alphanumeric or _) and represents [0-9a-zA-Z_] =item * + \D is a negated \d; it represents any character but a digit [^0-9] =item * + \S is a negated \s; it represents any non-whitespace character [^\s] =item * + \W is a negated \w; it represents any non-word character [^\w] =item * + The period '.' matches any character but "\n" =back @@ -451,22 +458,26 @@ and C<$> are able to match. Here are the four possible combinations: =over 4 =item * + no modifiers (//): Default behavior. C<'.'> matches any character except C<"\n">. C<^> matches only at the beginning of the string and C<$> matches only at the end or before a newline at the end. =item * + s modifier (//s): Treat string as a single long line. C<'.'> matches any character, even C<"\n">. C<^> matches only at the beginning of the string and C<$> matches only at the end or before a newline at the end. =item * + m modifier (//m): Treat string as a set of multiple lines. C<'.'> matches any character except C<"\n">. C<^> and C<$> are able to match at the start or end of I<any> line within the string. =item * + both s and m modifiers (//sm): Treat string as a single long line, but detect multiple lines. C<'.'> matches any character, even C<"\n">. C<^> and C<$>, however, are able to match at the start or end @@ -602,32 +613,52 @@ of what perl does when it tries to match the regexp =over 4 -=item 0 Start with the first letter in the string 'a'. +=item 0 + +Start with the first letter in the string 'a'. + +=item 1 -=item 1 Try the first alternative in the first group 'abd'. +Try the first alternative in the first group 'abd'. -=item 2 Match 'a' followed by 'b'. So far so good. +=item 2 -=item 3 'd' in the regexp doesn't match 'c' in the string - a dead +Match 'a' followed by 'b'. So far so good. + +=item 3 + +'d' in the regexp doesn't match 'c' in the string - a dead end. So backtrack two characters and pick the second alternative in the first group 'abc'. -=item 4 Match 'a' followed by 'b' followed by 'c'. We are on a roll +=item 4 + +Match 'a' followed by 'b' followed by 'c'. We are on a roll and have satisfied the first group. Set $1 to 'abc'. -=item 5 Move on to the second group and pick the first alternative +=item 5 + +Move on to the second group and pick the first alternative 'df'. -=item 6 Match the 'd'. +=item 6 -=item 7 'f' in the regexp doesn't match 'e' in the string, so a dead +Match the 'd'. + +=item 7 + +'f' in the regexp doesn't match 'e' in the string, so a dead end. Backtrack one character and pick the second alternative in the second group 'd'. -=item 8 'd' matches. The second grouping is satisfied, so set $2 to +=item 8 + +'d' matches. The second grouping is satisfied, so set $2 to 'd'. -=item 9 We are at the end of the regexp, so we are done! We have +=item 9 + +We are at the end of the regexp, so we are done! We have matched 'abcd' out of the string "abcde". =back @@ -770,18 +801,30 @@ meanings: =over 4 -=item * C<a?> = match 'a' 1 or 0 times +=item * -=item * C<a*> = match 'a' 0 or more times, i.e., any number of times +C<a?> = match 'a' 1 or 0 times -=item * C<a+> = match 'a' 1 or more times, i.e., at least once +=item * + +C<a*> = match 'a' 0 or more times, i.e., any number of times + +=item * -=item * C<a{n,m}> = match at least C<n> times, but not more than C<m> +C<a+> = match 'a' 1 or more times, i.e., at least once + +=item * + +C<a{n,m}> = match at least C<n> times, but not more than C<m> times. -=item * C<a{n,}> = match at least C<n> or more times +=item * + +C<a{n,}> = match at least C<n> or more times + +=item * -=item * C<a{n}> = match exactly C<n> times +C<a{n}> = match exactly C<n> times =back @@ -845,19 +888,23 @@ the principles above to predict which way the regexp will match: =over 4 =item * + Principle 0: Taken as a whole, any regexp will be matched at the earliest possible position in the string. =item * + Principle 1: In an alternation C<a|b|c...>, the leftmost alternative that allows a match for the whole regexp will be the one used. =item * + Principle 2: The maximal matching quantifiers C<?>, C<*>, C<+> and C<{n,m}> will in general match as much of the string as possible while still allowing the whole regexp to match. =item * + Principle 3: If there are two or more elements in a regexp, the leftmost greedy quantifier, if any, will match as much of the string as possible while still allowing the whole regexp to match. The next @@ -925,21 +972,33 @@ following meanings: =over 4 -=item * C<a??> = match 'a' 0 or 1 times. Try 0 first, then 1. +=item * + +C<a??> = match 'a' 0 or 1 times. Try 0 first, then 1. -=item * C<a*?> = match 'a' 0 or more times, i.e., any number of times, +=item * + +C<a*?> = match 'a' 0 or more times, i.e., any number of times, but as few times as possible -=item * C<a+?> = match 'a' 1 or more times, i.e., at least once, but +=item * + +C<a+?> = match 'a' 1 or more times, i.e., at least once, but as few times as possible -=item * C<a{n,m}?> = match at least C<n> times, not more than C<m> +=item * + +C<a{n,m}?> = match at least C<n> times, not more than C<m> times, as few times as possible -=item * C<a{n,}?> = match at least C<n> times, but as few times as +=item * + +C<a{n,}?> = match at least C<n> times, but as few times as possible -=item * C<a{n}?> = match exactly C<n> times. Because we match exactly +=item * + +C<a{n}?> = match exactly C<n> times. Because we match exactly C<n> times, C<a{n}?> is equivalent to C<a{n}> and is just there for notational consistency. @@ -998,6 +1057,7 @@ quantifiers: =over 4 =item * + Principle 3: If there are two or more elements in a regexp, the leftmost greedy (non-greedy) quantifier, if any, will match as much (little) of the string as possible while still allowing the whole @@ -1019,23 +1079,37 @@ backtracking. Here is a step-by-step analysis of the example =over 4 -=item 0 Start with the first letter in the string 't'. +=item 0 + +Start with the first letter in the string 't'. -=item 1 The first quantifier '.*' starts out by matching the whole +=item 1 + +The first quantifier '.*' starts out by matching the whole string 'the cat in the hat'. -=item 2 'a' in the regexp element 'at' doesn't match the end of the +=item 2 + +'a' in the regexp element 'at' doesn't match the end of the string. Backtrack one character. -=item 3 'a' in the regexp element 'at' still doesn't match the last +=item 3 + +'a' in the regexp element 'at' still doesn't match the last letter of the string 't', so backtrack one more character. -=item 4 Now we can match the 'a' and the 't'. +=item 4 + +Now we can match the 'a' and the 't'. -=item 5 Move on to the third element '.*'. Since we are at the end of +=item 5 + +Move on to the third element '.*'. Since we are at the end of the string and '.*' can match 0 times, assign it the empty string. -=item 6 We are done! +=item 6 + +We are done! =back @@ -1180,15 +1254,25 @@ This is our final regexp. To recap, we built a regexp by =over 4 -=item * specifying the task in detail, +=item * + +specifying the task in detail, -=item * breaking down the problem into smaller parts, +=item * + +breaking down the problem into smaller parts, + +=item * -=item * translating the small parts into regexps, +translating the small parts into regexps, -=item * combining the regexps, +=item * + +combining the regexps, + +=item * -=item * and optimizing the final combined regexp. +and optimizing the final combined regexp. =back diff --git a/pod/perlrun.pod b/pod/perlrun.pod index d8fb12c9be..4a4c957a50 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -311,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 @@ -322,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 @@ -569,9 +570,23 @@ 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> diff --git a/pod/perlsec.pod b/pod/perlsec.pod index 6b50b92f96..3870c2ef70 100644 --- a/pod/perlsec.pod +++ b/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. diff --git a/pod/perlsub.pod b/pod/perlsub.pod index 997631674f..cef8050731 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -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 @@ -697,9 +697,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. You need to give a global variable a temporary value, especially $_. +=item 1. + +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 +718,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 +750,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: diff --git a/pod/perltie.pod b/pod/perltie.pod index 1a5896515f..1bba005be5 100644 --- a/pod/perltie.pod +++ b/pod/perltie.pod @@ -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 @@ -201,31 +201,22 @@ B<Tie::Array> simply C<croak>. 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 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: -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: - - 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 @@ -235,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 @@ -259,11 +251,9 @@ 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 @@ -281,19 +271,185 @@ 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}"; } - return $self->{ARRAY}[$idx] = $value; + # 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 splice @{$self->{ARRAY}}, $offset, $length, @list; + } + =item UNTIE this Will be called when C<untie> happens. (See below.) @@ -307,17 +463,6 @@ 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 Hashes were the first Perl data type to be tied (see dbmopen()). A class @@ -400,7 +545,7 @@ that calls it. Here are the methods for the DotFiles tied hash. -=over +=over 4 =item TIEHASH classname, LIST @@ -655,7 +800,7 @@ In our example we're going to create a shouting handle. package Shout; -=over +=over 4 =item TIEHANDLE classname, LIST @@ -936,3 +1081,4 @@ TIEHANDLE by Sven Verdoolaege <F<skimo@dns.ufsia.ac.be>> and Doug MacEachern <F< UNTIE by Nick Ing-Simmons <F<nick@ing-simmons.net>> +Tying Arrays by Casey Tweten <F<crt@kiski.net>> diff --git a/pod/perltoc.pod b/pod/perltoc.pod index b87b3ab6d9..c0750e82dc 100644 --- a/pod/perltoc.pod +++ b/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,7 +40,7 @@ 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 +=over 4 =item DESCRIPTION @@ -63,7 +53,7 @@ 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 +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 @@ -72,80 +62,81 @@ 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 +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 +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 in my C program, what am I doing wrong?, When I tried to run my -script, I got this message. What does it mean?, 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 +do I send bug reports?, What is perl.com? Perl Mongers? pm.org? perl.org?, +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 in my C program; what am I doing wrong?, When I +tried to run my script, I got this message. What does it mean?, 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 @@ -183,7 +174,7 @@ 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 +LHS while 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?, @@ -229,7 +220,7 @@ 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)? +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 @@ -245,33 +236,32 @@ 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 +daemon process?, 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 4 =item Where to get this document @@ -286,7 +276,7 @@ authors =item Author and Copyright Information -=over +=over 4 =item Bundled Distributions @@ -296,20 +286,21 @@ 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 perltoc - perl documentation table of contents -=over +=over 4 =item DESCRIPTION =item BASIC DOCUMENTATION -=over +=over 4 =item perl - Practical Extraction and Report Language @@ -319,7 +310,7 @@ DIAGNOSTICS, BUGS, NOTES =item perlfaq - frequently asked questions about Perl ($Date: 1999/05/23 20:38:02 $) -DESCRIPTION +DESCRIPTION, Where to get this document, How to contribute =back @@ -327,7 +318,7 @@ DESCRIPTION =head2 perlbook - Perl book information -=over +=over 4 =item DESCRIPTION @@ -335,11 +326,11 @@ DESCRIPTION =head2 perlsyn - Perl syntax -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Declarations @@ -367,11 +358,11 @@ DESCRIPTION =head2 perldata - Perl data types -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Variable names @@ -395,13 +386,13 @@ DESCRIPTION =head2 perlop - Perl operators and precedence -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Terms and List Operators (Leftward) @@ -490,13 +481,13 @@ regular expressions =head2 perlsub - Perl subroutines -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Private Variables via my() @@ -510,10 +501,6 @@ regular expressions =item When to Still Use local() -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 Pass by Reference =item Prototypes @@ -534,11 +521,11 @@ You want to temporarily change just one element of an array or hash =head2 perlfunc - Perl builtin functions -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Perl Functions by Category @@ -636,7 +623,7 @@ LIST, write FILEHANDLE, write EXPR, write, y/// =head2 perlreftut - Mark's very short tutorial about references -=over +=over 4 =item DESCRIPTION @@ -646,7 +633,7 @@ LIST, write FILEHANDLE, write EXPR, write, y/// =item Syntax -=over +=over 4 =item Making References @@ -666,7 +653,7 @@ LIST, write FILEHANDLE, write EXPR, write, y/// =item Credits -=over +=over 4 =item Distribution Conditions @@ -676,7 +663,7 @@ LIST, write FILEHANDLE, write EXPR, write, y/// =head2 perldsc - Perl Data Structures Cookbook -=over +=over 4 =item DESCRIPTION @@ -697,7 +684,7 @@ more elaborate constructs =item ARRAYS OF ARRAYS -=over +=over 4 =item Declaration of a ARRAY OF ARRAYS @@ -709,7 +696,7 @@ more elaborate constructs =item HASHES OF ARRAYS -=over +=over 4 =item Declaration of a HASH OF ARRAYS @@ -721,7 +708,7 @@ more elaborate constructs =item ARRAYS OF HASHES -=over +=over 4 =item Declaration of a ARRAY OF HASHES @@ -733,7 +720,7 @@ more elaborate constructs =item HASHES OF HASHES -=over +=over 4 =item Declaration of a HASH OF HASHES @@ -745,7 +732,7 @@ more elaborate constructs =item MORE ELABORATE RECORDS -=over +=over 4 =item Declaration of MORE ELABORATE RECORDS @@ -765,25 +752,18 @@ more elaborate constructs =head2 perlrequick - Perl regular expressions quick start -=over +=over 4 =item DESCRIPTION =item The Guide -=over +=over 4 =item Simple word matching =item Using character classes -\d is a digit and represents [0-9], \s is a whitespace character and -represents [\ \t\r\n\f], \w is a word character (alphanumeric or _) and -represents [0-9a-zA-Z_], \D is a negated \d; it represents any character -but a digit [^0-9], \S is a negated \s; it represents any non-whitespace -character [^\s], \W is a negated \w; it represents any non-word character -[^\w], The period '.' matches any character but "\n" - =item Matching this or that =item Grouping things and hierarchical matching @@ -812,7 +792,7 @@ times =item AUTHOR AND COPYRIGHT -=over +=over 4 =item Acknowledgments @@ -822,11 +802,11 @@ times =head2 perlpod - plain old documentation -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Verbatim Paragraph @@ -850,7 +830,7 @@ times =head2 perlstyle - Perl style guide -=over +=over 4 =item DESCRIPTION @@ -858,11 +838,11 @@ times =head2 perltrap - Perl traps for the unwary -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Awk Traps @@ -943,13 +923,13 @@ LIMIT specified =head2 perlrun - how to execute the Perl interpreter -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item #! and quoting on non-Unix systems @@ -979,7 +959,7 @@ PERL_ROOT (specific to the VMS port), SYS$LOGIN (specific to the VMS port) =head2 perldiag - various Perl diagnostics -=over +=over 4 =item DESCRIPTION @@ -987,11 +967,11 @@ PERL_ROOT (specific to the VMS port), SYS$LOGIN (specific to the VMS port) =head2 perllexwarn - Perl Lexical Warnings -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Default Warnings and Optional Warnings @@ -1021,7 +1001,7 @@ B<-w>, B<-W>, B<-X> =head2 perldebtut - Perl debugging tutorial -=over +=over 4 =item DESCRIPTION @@ -1055,13 +1035,13 @@ B<-w>, B<-W>, B<-X> =head2 perldebug - Perl debugging -=over +=over 4 =item DESCRIPTION =item The Perl Debugger -=over +=over 4 =item Debugger Commands @@ -1113,11 +1093,11 @@ listing =head2 perlvar - Perl predefined variables -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Predefined Names @@ -1163,7 +1143,7 @@ ${^WIDE_SYSTEM_CALLS}, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @INC, @_, %INC, =head2 perllol - Manipulating Arrays of Arrays in Perl -=over +=over 4 =item DESCRIPTION @@ -1183,13 +1163,13 @@ ${^WIDE_SYSTEM_CALLS}, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @INC, @_, %INC, =head2 perlopentut - tutorial on opening things in Perl -=over +=over 4 =item DESCRIPTION =item Open E<agrave> la shell -=over +=over 4 =item Simple Opens @@ -1205,7 +1185,7 @@ ${^WIDE_SYSTEM_CALLS}, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @INC, @_, %INC, =item Open E<agrave> la C -=over +=over 4 =item Permissions E<agrave> la mode @@ -1213,7 +1193,7 @@ ${^WIDE_SYSTEM_CALLS}, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @INC, @_, %INC, =item Obscure Open Tricks -=over +=over 4 =item Re-Opening Files (dups) @@ -1229,7 +1209,7 @@ ${^WIDE_SYSTEM_CALLS}, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @INC, @_, %INC, =item Other I/O Issues -=over +=over 4 =item Opening Non-File Files @@ -1249,109 +1229,35 @@ ${^WIDE_SYSTEM_CALLS}, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @INC, @_, %INC, =head2 perlretut - Perl regular expressions tutorial -=over +=over 4 =item DESCRIPTION =item Part 1: The basics -=over +=over 4 =item Simple word matching =item Using character classes -\d is a digit and represents [0-9], \s is a whitespace character and -represents [\ \t\r\n\f], \w is a word character (alphanumeric or _) and -represents [0-9a-zA-Z_], \D is a negated \d; it represents any character -but a digit [^0-9], \S is a negated \s; it represents any non-whitespace -character [^\s], \W is a negated \w; it represents any non-word character -[^\w], The period '.' matches any character but "\n", no modifiers (//): -Default behavior. C<'.'> matches any character except C<"\n">. C<^> -matches only at the beginning of the string and C<$> matches only at the -end or before a newline at the end, s modifier (//s): Treat string as a -single long line. C<'.'> matches any character, even C<"\n">. C<^> -matches only at the beginning of the string and C<$> matches only at the -end or before a newline at the end, m modifier (//m): Treat string as a set -of multiple lines. C<'.'> matches any character except C<"\n">. C<^> and -C<$> are able to match at the start or end of I<any> line within the -string, both s and m modifiers (//sm): Treat string as a single long line, -but detect multiple lines. C<'.'> matches any character, even C<"\n">. -C<^> and C<$>, however, are able to match at the start or end of I<any> -line within the string - =item Matching this or that =item Grouping things and hierarchical matching -0 Start with the first letter in the string 'a', 1 Try the first -alternative in the first group 'abd', 2 Match 'a' followed by 'b'. So far -so good, 3 'd' in the regexp doesn't match 'c' in the string - a dead end. -So backtrack two characters and pick the second alternative in the first -group 'abc', 4 Match 'a' followed by 'b' followed by 'c'. We are on a roll -and have satisfied the first group. Set $1 to 'abc', 5 Move on to the -second group and pick the first alternative 'df', 6 Match the 'd', 7 'f' in -the regexp doesn't match 'e' in the string, so a dead end. Backtrack one -character and pick the second alternative in the second group 'd', 8 'd' -matches. The second grouping is satisfied, so set $2 to 'd', 9 We are at -the end of the regexp, so we are done! We have matched 'abcd' out of the -string "abcde" - =item Extracting matches =item Matching repetitions -C<a?> = match 'a' 1 or 0 times, C<a*> = match 'a' 0 or more times, i.e., -any number of times, C<a+> = match 'a' 1 or more times, i.e., at least -once, C<a{n,m}> = match at least C<n> times, but not more than C<m> times, -C<a{n,}> = match at least C<n> or more times, C<a{n}> = match exactly C<n> -times, Principle 0: Taken as a whole, any regexp will be matched at the -earliest possible position in the string, Principle 1: In an alternation -C<a|b|c...>, the leftmost alternative that allows a match for the whole -regexp will be the one used, Principle 2: The maximal matching quantifiers -C<?>, C<*>, C<+> and C<{n,m}> will in general match as much of the string -as possible while still allowing the whole regexp to match, Principle 3: If -there are two or more elements in a regexp, the leftmost greedy quantifier, -if any, will match as much of the string as possible while still allowing -the whole regexp to match. The next leftmost greedy quantifier, if any, -will try to match as much of the string remaining available to it as -possible, while still allowing the whole regexp to match. And so on, until -all the regexp elements are satisfied, C<a??> = match 'a' 0 or 1 times. Try -0 first, then 1, C<a*?> = match 'a' 0 or more times, i.e., any number of -times, but as few times as possible, C<a+?> = match 'a' 1 or more times, -i.e., at least once, but as few times as possible, C<a{n,m}?> = match at -least C<n> times, not more than C<m> times, as few times as possible, -C<a{n,}?> = match at least C<n> times, but as few times as possible, -C<a{n}?> = match exactly C<n> times. Because we match exactly C<n> times, -C<a{n}?> is equivalent to C<a{n}> and is just there for notational -consistency, Principle 3: If there are two or more elements in a regexp, -the leftmost greedy (non-greedy) quantifier, if any, will match as much -(little) of the string as possible while still allowing the whole regexp to -match. The next leftmost greedy (non-greedy) quantifier, if any, will try -to match as much (little) of the string remaining available to it as -possible, while still allowing the whole regexp to match. And so on, until -all the regexp elements are satisfied, 0 Start with the first letter in the -string 't', 1 The first quantifier '.*' starts out by matching the whole -string 'the cat in the hat', 2 'a' in the regexp element 'at' doesn't match -the end of the string. Backtrack one character, 3 'a' in the regexp -element 'at' still doesn't match the last letter of the string 't', so -backtrack one more character, 4 Now we can match the 'a' and the 't', 5 -Move on to the third element '.*'. Since we are at the end of the string -and '.*' can match 0 times, assign it the empty string, 6 We are done! - =item Building a regexp -specifying the task in detail,, breaking down the problem into smaller -parts,, translating the small parts into regexps,, combining the regexps,, -and optimizing the final combined regexp - =item Using regular expressions in Perl =back =item Part 2: Power tools -=over +=over 4 =item More on characters, strings, and character classes @@ -1379,7 +1285,7 @@ and optimizing the final combined regexp =item AUTHOR AND COPYRIGHT -=over +=over 4 =item Acknowledgments @@ -1389,13 +1295,13 @@ and optimizing the final combined regexp =head2 perlre - Perl regular expressions -=over +=over 4 =item DESCRIPTION i, m, s, x -=over +=over 4 =item Regular Expressions @@ -1435,13 +1341,13 @@ C<(?(condition)yes-pattern|no-pattern)> =head2 perlref - Perl references and nested data structures -=over +=over 4 =item NOTE =item DESCRIPTION -=over +=over 4 =item Making References @@ -1465,11 +1371,11 @@ C<(?(condition)yes-pattern|no-pattern)> =head2 perlform - Perl formats -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Format Variables @@ -1477,7 +1383,7 @@ C<(?(condition)yes-pattern|no-pattern)> =item NOTES -=over +=over 4 =item Footers @@ -1491,11 +1397,11 @@ C<(?(condition)yes-pattern|no-pattern)> =head2 perlboot - Beginner's Object-Oriented Tutorial -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item If we could talk to the animals... @@ -1549,13 +1455,13 @@ C<(?(condition)yes-pattern|no-pattern)> =head2 perltoot - Tom's object-oriented tutorial for perl -=over +=over 4 =item DESCRIPTION =item Creating a Class -=over +=over 4 =item Object Representation @@ -1573,7 +1479,7 @@ C<(?(condition)yes-pattern|no-pattern)> =item Class Data -=over +=over 4 =item Accessing Class Data @@ -1589,7 +1495,7 @@ C<(?(condition)yes-pattern|no-pattern)> =item Inheritance -=over +=over 4 =item Overridden Methods @@ -1601,7 +1507,7 @@ C<(?(condition)yes-pattern|no-pattern)> =item Alternate Object Representations -=over +=over 4 =item Arrays as Objects @@ -1611,7 +1517,7 @@ C<(?(condition)yes-pattern|no-pattern)> =item AUTOLOAD: Proxy Methods -=over +=over 4 =item Autoloaded Data Methods @@ -1621,14 +1527,18 @@ C<(?(condition)yes-pattern|no-pattern)> =item Metaclassical Tools -=over +=over 4 =item Class::Struct =item Data Members as Variables +=back + =item NOTES +=over 4 + =item Object Terminology =back @@ -1639,7 +1549,7 @@ C<(?(condition)yes-pattern|no-pattern)> =item COPYRIGHT -=over +=over 4 =item Acknowledgments @@ -1649,13 +1559,13 @@ C<(?(condition)yes-pattern|no-pattern)> =head2 perltootc - Tom's OO Tutorial for Class Data in Perl -=over +=over 4 =item DESCRIPTION =item Class Data as Package Variables -=over +=over 4 =item Putting All Your Eggs in One Basket @@ -1673,7 +1583,7 @@ C<(?(condition)yes-pattern|no-pattern)> =item Class Data as Lexical Variables -=over +=over 4 =item Privacy and Responsibility @@ -1701,11 +1611,11 @@ C<(?(condition)yes-pattern|no-pattern)> =head2 perlobj - Perl objects -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item An Object is Simply a Reference @@ -1735,7 +1645,7 @@ isa(CLASS), can(METHOD), VERSION( [NEED] ) =head2 perlbot - Bag'o Object Tricks (the BOT) -=over +=over 4 =item DESCRIPTION @@ -1765,13 +1675,13 @@ isa(CLASS), can(METHOD), VERSION( [NEED] ) =head2 perltie - how to hide an object class in a simple variable -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Tying Scalars @@ -1781,7 +1691,10 @@ DESTROY this =item Tying Arrays TIEARRAY classname, LIST, FETCH this, index, STORE this, index, value, -UNTIE this, DESTROY this +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 @@ -1812,7 +1725,7 @@ DESTROY this =head2 perlipc - Perl interprocess communication (signals, fifos, pipes, safe subprocesses, sockets, and semaphores) -=over +=over 4 =item DESCRIPTION @@ -1820,7 +1733,7 @@ safe subprocesses, sockets, and semaphores) =item Named Pipes -=over +=over 4 =item WARNING @@ -1828,7 +1741,7 @@ safe subprocesses, sockets, and semaphores) =item Using open() for IPC -=over +=over 4 =item Filehandles @@ -1846,7 +1759,7 @@ safe subprocesses, sockets, and semaphores) =item Sockets: Client/Server Communication -=over +=over 4 =item Internet Line Terminators @@ -1858,7 +1771,7 @@ safe subprocesses, sockets, and semaphores) =item TCP Clients with IO::Socket -=over +=over 4 =item A Simple Client @@ -1890,13 +1803,13 @@ Proto, LocalPort, Listen, Reuse =head2 perlfork - Perl's fork() emulation -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Behavior of other Perl features in forked pseudo-processes @@ -1928,7 +1841,7 @@ application, Thread-safety of extensions =head2 perlnumber - semantics of numbers and numeric operations in Perl -=over +=over 4 =item SYNOPSIS @@ -1953,7 +1866,7 @@ string =head2 perlthrtut - tutorial on threads in Perl -=over +=over 4 =item DESCRIPTION @@ -1961,7 +1874,7 @@ string =item Threaded Program Models -=over +=over 4 =item Boss/Worker @@ -1979,7 +1892,7 @@ string =item Thread Basics -=over +=over 4 =item Basic Thread Support @@ -1997,7 +1910,7 @@ string =item Threads And Data -=over +=over 4 =item Shared And Unshared Data @@ -2013,7 +1926,7 @@ string =item Threads And Code -=over +=over 4 =item Semaphores: Synchronizing Data Access @@ -2031,7 +1944,7 @@ Basic semaphores, Advanced Semaphores =item General Thread Utility Routines -=over +=over 4 =item What Thread Am I In? @@ -2049,7 +1962,7 @@ Basic semaphores, Advanced Semaphores =item Bibliography -=over +=over 4 =item Introductory Texts @@ -2069,7 +1982,7 @@ Basic semaphores, Advanced Semaphores =head2 perlport - Writing portable Perl -=over +=over 4 =item DESCRIPTION @@ -2078,7 +1991,7 @@ portable =item ISSUES -=over +=over 4 =item Newlines @@ -2115,7 +2028,7 @@ http://testers.cpan.org/ =item PLATFORMS -=over +=over 4 =item Unix @@ -2139,7 +2052,7 @@ Build instructions for OS/2, L<perlos2> =item FUNCTION IMPLEMENTATIONS -=over +=over 4 =item Alphabetical Listing of Perl Functions @@ -2193,7 +2106,7 @@ v1.23, 10 July 1998 =head2 perllocale - Perl locale handling (internationalization and localization) -=over +=over 4 =item DESCRIPTION @@ -2201,7 +2114,7 @@ localization) =item USING LOCALES -=over +=over 4 =item The use locale pragma @@ -2225,7 +2138,7 @@ localization) =item LOCALE CATEGORIES -=over +=over 4 =item Category LC_COLLATE: Collation @@ -2243,15 +2156,6 @@ localization) =item SECURITY -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()): - =item ENVIRONMENT PERL_BADLANG, LC_ALL, LANGUAGE, LC_CTYPE, LC_COLLATE, LC_MONETARY, @@ -2259,7 +2163,7 @@ LC_NUMERIC, LC_TIME, LANG =item NOTES -=over +=over 4 =item Backward compatibility @@ -2279,7 +2183,7 @@ LC_NUMERIC, LC_TIME, LANG =item BUGS -=over +=over 4 =item Broken systems @@ -2293,11 +2197,11 @@ LC_NUMERIC, LC_TIME, LANG =head2 perlunicode - Unicode support in Perl -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Important Caveat @@ -2320,13 +2224,13 @@ to enable a few features =head2 perlebcdic - Considerations for running Perl on EBCDIC platforms -=over +=over 4 =item DESCRIPTION =item COMMON CHARACTER CODE SETS -=over +=over 4 =item ASCII @@ -2354,7 +2258,7 @@ recipe 0, recipe 1, recipe 2, recipe 3, recipe 4 =item CONVERSIONS -=over +=over 4 =item tr/// @@ -2376,7 +2280,7 @@ chr(), ord(), pack(), print(), printf(), sort(), sprintf(), unpack() =item SORTING -=over +=over 4 =item Ignore ASCII vs. EBCDIC sort differences. @@ -2390,7 +2294,7 @@ chr(), ord(), pack(), print(), printf(), sort(), sprintf(), unpack() =item TRANFORMATION FORMATS -=over +=over 4 =item URL decoding and encoding @@ -2410,7 +2314,7 @@ chr(), ord(), pack(), print(), printf(), sort(), sprintf(), unpack() =item OS ISSUES -=over +=over 4 =item OS/400 @@ -2438,11 +2342,11 @@ chcp, dataset access, OS/390 iconv, locales =head2 perlsec - Perl security -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Laundering and Detecting Tainted Data @@ -2462,11 +2366,11 @@ chcp, dataset access, OS/390 iconv, locales =head2 perlmod - Perl modules (packages and symbol tables) -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Packages @@ -2486,49 +2390,51 @@ chcp, dataset access, OS/390 iconv, locales =head2 perlmodlib - constructing new Perl modules and finding existing ones -=over +=over 4 =item DESCRIPTION =item THE PERL MODULE LIBRARY -=over +=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 +diagnostics, fields, filetest, integer, less, locale, open, ops, overload, +perlio, 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::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, 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::Functions, File::Spec::Mac, File::Spec::OS2, -File::Spec::Unix, File::Spec::VMS, File::Spec::Win32, File::Temp, -File::stat, FileCache, FileHandle, FindBin, Getopt::Long, Getopt::Std, +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, CPAN, CPAN::FirstTime, CPAN::Nox, +Carp, Class::Struct, Cwd, DB, DB_File, Devel::SelfStubber, DirHandle, +Dumpvalue, Encode, 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, Filter::Simple, FindBin, Getopt::Long, Getopt::Std, I18N::Collate, IO, IPC::Open2, IPC::Open3, Math::BigFloat, Math::BigInt, Math::Complex, Math::Trig, NDBM_File, Net::Ping, Net::hostent, Net::netent, Net::protoent, Net::servent, O, ODBM_File, Opcode, Pod::Checker, Pod::Find, -Pod::Html, Pod::InputObjects, Pod::Man, Pod::ParseUtils, Pod::Parser, -Pod::Plainer, Pod::Select, Pod::Text, Pod::Text::Color, 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::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 +Pod::Html, Pod::InputObjects, Pod::LaTeX, Pod::Man, Pod::ParseUtils, +Pod::Parser, Pod::Plainer, Pod::Select, Pod::Text, Pod::Text::Color, +Pod::Text::Termcap, Pod::Usage, SDBM_File, Safe, Search::Dict, SelectSaver, +SelfLoader, Shell, Socket, Storable, Symbol, Term::ANSIColor, 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 Extension Modules @@ -2536,24 +2442,12 @@ UNIVERSAL, User::grent, User::pwent =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 +Africa, Asia, Australasia, Central America, Europe, North America, South +America =item Modules: Creation, Use, and Abuse -=over +=over 4 =item Guidelines for Module Creation @@ -2578,12 +2472,6 @@ to ::, Converts die(...) to croak(...), Several other minor changes =item Guidelines for Reusing Application Code -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 - =back =item NOTE @@ -2592,11 +2480,11 @@ can then be reduced to a small =head2 perlmodinstall - Installing CPAN Modules -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item PREAMBLE @@ -2617,11 +2505,11 @@ module (sometimes unnecessary), B<INSTALL> the module =head2 perlnewmod - preparing a new module for distribution -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Warning @@ -2653,11 +2541,11 @@ tarball, Announce to the modules list, Announce to clpa, Fix bugs! =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? @@ -2689,7 +2577,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 @@ -2700,11 +2588,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? @@ -2756,11 +2644,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)? @@ -2821,7 +2709,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? @@ -2837,13 +2725,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)? @@ -2869,7 +2757,7 @@ Trig functions? =item Data: Dates -=over +=over 4 =item How do I find the week-of-the-year/day-of-the-year? @@ -2889,7 +2777,7 @@ Trig functions? =item Data: Strings -=over +=over 4 =item How do I validate input? @@ -2941,7 +2829,7 @@ the tag =item Data: Arrays -=over +=over 4 =item What is the difference between a list and an array? @@ -2949,11 +2837,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? @@ -2986,7 +2870,7 @@ intersection of two arrays? =item Data: Hashes (Associative Arrays) -=over +=over 4 =item How do I process an entire hash? @@ -3025,7 +2909,7 @@ array of hashes or arrays? =item Data: Misc -=over +=over 4 =item How do I handle binary data correctly? @@ -3050,11 +2934,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? @@ -3139,11 +3023,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? @@ -3157,7 +3041,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? @@ -3175,7 +3059,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? @@ -3206,11 +3090,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? @@ -3285,11 +3169,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? @@ -3333,7 +3217,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? @@ -3413,13 +3297,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? @@ -3478,11 +3362,11 @@ CGI script to do bad things? =head2 perlcompile - Introduction to the Perl Compiler-Translator -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Layout @@ -3492,7 +3376,7 @@ B::Bytecode, B::C, B::CC, B::Lint, B::Deparse, B::Xref =item Using The Back Ends -=over +=over 4 =item The Cross Referencing Back End @@ -3522,11 +3406,11 @@ B::Stash, B::Terse, B::Xref =head2 perlembed - how to embed perl in your C program -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item PREAMBLE @@ -3556,7 +3440,7 @@ program =back -=item Embedding Perl under Windows +=item Embedding Perl under Win32 =item MORAL @@ -3568,13 +3452,13 @@ program =head2 perldebguts - Guts of Perl debugging -=over +=over 4 =item DESCRIPTION =item Debugger Internals -=over +=over 4 =item Writing Your Own Debugger @@ -3584,7 +3468,7 @@ program =item Debugging regular expressions -=over +=over 4 =item Compile-time output @@ -3601,7 +3485,7 @@ C<anchored(TYPE)> =item Debugging Perl memory usage -=over +=over 4 =item Using C<$ENV{PERL_DEBUG_MSTATS}> @@ -3627,13 +3511,13 @@ C<!!!>, C<!!>, C<!> =head2 perlxstut, perlXStut - Tutorial for writing XSUBs -=over +=over 4 =item DESCRIPTION =item SPECIAL NOTES -=over +=over 4 =item make @@ -3645,7 +3529,7 @@ C<!!!>, C<!!>, C<!> =item TUTORIAL -=over +=over 4 =item EXAMPLE 1 @@ -3707,7 +3591,7 @@ C<!!!>, C<!!>, C<!> =item Author -=over +=over 4 =item Last Changed @@ -3717,11 +3601,11 @@ C<!!!>, C<!!>, C<!> =head2 perlxs - XS language reference manual -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Introduction @@ -3759,7 +3643,7 @@ C<!!!>, C<!!>, C<!> =item The INPUT: Keyword -=item The IN/OUTLIST/IN_OUTLIST Keywords +=item The IN/OUTLIST/IN_OUTLIST/OUT/IN_OUT Keywords =item Variable-length Parameter Lists @@ -3795,7 +3679,7 @@ C<!!!>, C<!!>, C<!> =item The & Unary Operator -=item Inserting Comments and C Preprocessor Directives +=item Inserting POD, Comments and C Preprocessor Directives =item Using XS With C++ @@ -3817,13 +3701,13 @@ C<!!!>, C<!!>, C<!> =head2 perlguts - Introduction to the Perl API -=over +=over 4 =item DESCRIPTION =item Variables -=over +=over 4 =item Datatypes @@ -3879,7 +3763,7 @@ C<void save_hptr(HV **hptr)> =item Subroutines -=over +=over 4 =item XSUBs and the Argument Stack @@ -3899,7 +3783,7 @@ C<void save_hptr(HV **hptr)> =item Compiled code -=over +=over 4 =item Code tree @@ -3915,9 +3799,11 @@ C<void save_hptr(HV **hptr)> =back +=item Examining internal data structures with the C<dump> functions + =item How multiple interpreters and concurrency are supported -=over +=over 4 =item Background and PERL_IMPLICIT_CONTEXT @@ -3931,7 +3817,7 @@ C<void save_hptr(HV **hptr)> A, p, d, s, n, r, f, m, o, j, x -=over +=over 4 =item Formatted Printing of IVs, UVs, and NVs @@ -3943,7 +3829,7 @@ A, p, d, s, n, r, f, m, o, j, x =item Unicode Support -=over +=over 4 =item What B<is> Unicode, anyway? @@ -3967,7 +3853,7 @@ A, p, d, s, n, r, f, m, o, j, x =head2 perlcall - Perl calling conventions from C -=over +=over 4 =item DESCRIPTION @@ -3979,7 +3865,7 @@ call_sv, call_pv, call_method, call_argv =item FLAG VALUES -=over +=over 4 =item G_VOID @@ -4003,7 +3889,7 @@ call_sv, call_pv, call_method, call_argv =item EXAMPLES -=over +=over 4 =item No Parameters, Nothing returned @@ -4053,11 +3939,11 @@ callback =head2 perlutil - utilities packaged with the Perl distribution -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item DOCUMENTATION @@ -4083,7 +3969,7 @@ L<h2xs|h2xs>, L<dprofpp|dprofpp>, L<perlcc|perlcc> =head2 perlfilter - Source Filters -=over +=over 4 =item DESCRIPTION @@ -4115,7 +4001,7 @@ B<Decryption Filters> =head2 perldbmfilter - Perl DBM Filters -=over +=over 4 =item SYNOPSIS @@ -4124,7 +4010,7 @@ B<Decryption Filters> B<filter_store_key>, B<filter_store_value>, B<filter_fetch_key>, B<filter_fetch_value> -=over +=over 4 =item The Filter @@ -4142,16 +4028,16 @@ B<filter_fetch_value> =head2 perlapi - autogenerated documentation for the perl public API -=over +=over 4 =item DESCRIPTION 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_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, +croak, CvSTASH, cv_const_sv, 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, @@ -4177,8 +4063,8 @@ 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, +SVt_NV, SVt_PV, SVt_PVAV, SVt_PVCV, SVt_PVHV, SVt_PVMG, SvUOK, 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, @@ -4188,13 +4074,14 @@ 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_unmagic, sv_unref, sv_unref_flags, sv_upgrade, sv_usepvn, sv_usepvn_mg, sv_utf8_downgrade, sv_utf8_encode, sv_utf8_upgrade, sv_vcatpvfn, -sv_vsetpvfn, THIS, toLOWER, toUPPER, U8 *s, utf8_to_bytes, utf8_to_uv, -utf8_to_uv_chk, 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 +sv_vsetpvfn, THIS, toLOWER, toUPPER, U8 *s, utf8_distance, utf8_hop, +utf8_length, utf8_to_bytes, utf8_to_uv, utf8_to_uv_simple, 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 =item AUTHORS @@ -4205,11 +4092,11 @@ XST_mUNDEF, XST_mYES, XS_VERSION, XS_VERSION_BOOTCHECK, Zero =head2 perlintern - autogenerated documentation of purely B<internal> Perl functions -=over +=over 4 =item DESCRIPTION -is_gv_magical +djSP, is_gv_magical, start_glob =item AUTHORS @@ -4219,7 +4106,7 @@ is_gv_magical =head2 perlapio - perl's IO abstraction interface. -=over +=over 4 =item SYNOPSIS @@ -4236,7 +4123,7 @@ 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 +=over 4 =item Co-existence with stdio @@ -4253,13 +4140,13 @@ B<PerlIO_get_base(f)>, B<PerlIO_get_bufsiz(f)> =head2 perltodo - Perl TO-DO List -=over +=over 4 =item DESCRIPTION =item Infrastructure -=over +=over 4 =item Mailing list archives @@ -4274,7 +4161,7 @@ perl5 =item Configure -=over +=over 4 =item Install HTML @@ -4282,9 +4169,7 @@ perl5 =item Perl Language -=over - -=item our ($var) +=over 4 =item 64-bit Perl @@ -4296,7 +4181,7 @@ Named prototypes, Indirect objects, Method calls, Context, Scoped subs =item Perl Internals -=over +=over 4 =item magic_setisa @@ -4325,7 +4210,7 @@ sighandler, Add tests for Thread::Signal, Automatic tests against CPAN =item Documentation -=over +=over 4 =item A clear division into tutorial and reference @@ -4357,7 +4242,7 @@ Regular expressions, I/O, pack/unpack, Debugging =item Modules -=over +=over 4 =item Update the POSIX extension to conform with the POSIX 1003.1 Edition 2 @@ -4395,8 +4280,6 @@ VecArray, SubstrArray, VirtualArray, ShiftSplice =item Update semibroken auxiliary tools; h2ph, a2p, etc. -=item POD Converters - =item pod2html =item Podchecker @@ -4405,7 +4288,7 @@ VecArray, SubstrArray, VirtualArray, ShiftSplice =item Tom's Wishes -=over +=over 4 =item Webperl @@ -4419,7 +4302,7 @@ VecArray, SubstrArray, VirtualArray, ShiftSplice =item Win32 Stuff -=over +=over 4 =item Rename new headers to be consistent with the rest @@ -4441,7 +4324,7 @@ debugger, lvalue functions =item Possible pragmas -=over +=over 4 =item 'less' @@ -4449,7 +4332,7 @@ debugger, lvalue functions =item Optimizations -=over +=over 4 =item constant function cache @@ -4479,7 +4362,7 @@ threaded code, structured types, Modifiable $1 et al =item To Do Or Not To Do -=over +=over 4 =item Making my() work on "package" variables @@ -4493,7 +4376,7 @@ threaded code, structured types, Modifiable $1 et al =item Threading -=over +=over 4 =item Modules @@ -4515,7 +4398,7 @@ threaded code, structured types, Modifiable $1 et al =item Compiler -=over +=over 4 =item Optimization @@ -4541,7 +4424,7 @@ threaded code, structured types, Modifiable $1 et al =item Recently Finished Tasks -=over +=over 4 =item Figure a way out of $^(capital letter) @@ -4563,7 +4446,7 @@ threaded code, structured types, Modifiable $1 et al =head2 perlhack - How to hack at the Perl internals -=over +=over 4 =item DESCRIPTION @@ -4573,10 +4456,21 @@ 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, L<perlguts>, L<perlxstut> and -L<perlxs>, L<perlapi>, F<Porting/pumpkin.pod>, The perl5-porters FAQ +work?, Patches speak louder than words -=over +=over 4 + +=item Keeping in sync + +rsync'ing the source tree, Using rsync over the LAN, Using pushing over the +NFS, rsync'ing the patches, It's easier, It's more recent, It's more +reliable, It's easier, It's a good reference, Finding a start point, +Finding how to fix a bug, Finding the source of misbehaviour + +=item Submitting patches + +L<perlguts>, L<perlxstut> and L<perlxs>, L<perlapi>, +F<Porting/pumpkin.pod>, The perl5-porters FAQ =item Finding Your Way Around @@ -4601,7 +4495,7 @@ Argument stack, Mark stack, Save stack =item Using a source-level debugger run [args], break function_name, break source.c:xxx, step, next, continue, -finish, print +finish, 'enter', print =item Dumping Perl Data Structures @@ -4611,7 +4505,7 @@ finish, print =item EXTERNAL TOOLS FOR DEBUGGING PERL -=over +=over 4 =item Rational Software's Purify @@ -4635,7 +4529,7 @@ I<The Road goes ever on and on, down from the door where it began.> =head2 perlhist - the Perl history records -=over +=over 4 =item DESCRIPTION @@ -4643,7 +4537,7 @@ I<The Road goes ever on and on, down from the door where it began.> =item THE KEEPERS OF THE PUMPKIN -=over +=over 4 =item PUMPKIN? @@ -4651,7 +4545,7 @@ I<The Road goes ever on and on, down from the door where it began.> =item THE RECORDS -=over +=over 4 =item SELECTED RELEASE SIZES @@ -4665,7 +4559,7 @@ I<The Road goes ever on and on, down from the door where it began.> =head2 perldelta - what's new for perl v5.7.0 -=over +=over 4 =item DESCRIPTION @@ -4677,7 +4571,7 @@ I<The Road goes ever on and on, down from the door where it began.> =item Modules and Pragmata -=over +=over 4 =item New Modules @@ -4691,18 +4585,9 @@ I<The Road goes ever on and on, down from the door where it began.> =item Performance Enhancements -sort() has been changed to use mergesort internally as opposed to the -earlier quicksort. For very small lists this may result in slightly slower -sorting times, but in general the speedup should be at least 20%. -Additional bonuses are that the worst case behaviour of sort() is now -better (in computer science terms it now runs in time O(N log N), as -opposed to quicksort's Theta(N**2) worst-case run time behaviour), and that -sort() is now stable (meaning that elements with identical keys will stay -ordered as they were before the sort) - =item Installation and Configuration Improvements -=over +=over 4 =item Generic Improvements @@ -4710,10 +4595,7 @@ ordered as they were before the sort) =item Selected Bug Fixes -sort() arguments are now compiled in the right wantarray context (they were -accidentally using the context of the sort() itself) - -=over +=over 4 =item Platform Specific Changes and Fixes @@ -4725,7 +4607,7 @@ accidentally using the context of the sort() itself) =item Known Problems -=over +=over 4 =item Unicode Support Still Far From Perfect @@ -4741,6 +4623,8 @@ accidentally using the context of the sort() itself) =item Linux With Sfio Fails op/misc Test 48 +=item sprintf tests 129 and 130 + =item Storable tests fail in some platforms =item Threads Are Still Experimental @@ -4759,13 +4643,13 @@ accidentally using the context of the sort() itself) =head2 perl56delta, perldelta - what's new for perl v5.6.0 -=over +=over 4 =item DESCRIPTION =item Core Enhancements -=over +=over 4 =item Interpreter cloning, threads, and concurrency @@ -4881,7 +4765,7 @@ accidentally using the context of the sort() itself) =item Modules and Pragmata -=over +=over 4 =item Modules @@ -4900,7 +4784,7 @@ Term::ANSIColor, Time::Local, Win32, XSLoader, DBM Filters =item Utility Changes -=over +=over 4 =item dprofpp @@ -4925,7 +4809,7 @@ perlreftut.pod, perltootc.pod, perltodo.pod, perlunicode.pod =item Performance enhancements -=over +=over 4 =item Simple sort() using { $a <=> $b } and the like are optimized @@ -4939,7 +4823,7 @@ perlreftut.pod, perltootc.pod, perltodo.pod, perlunicode.pod =item Installation and Configuration Improvements -=over +=over 4 =item -Dusethreads means something different @@ -4965,7 +4849,7 @@ perlreftut.pod, perltootc.pod, perltodo.pod, perlunicode.pod =item Platform specific changes -=over +=over 4 =item Supported platforms @@ -4981,7 +4865,7 @@ perlreftut.pod, perltootc.pod, perltodo.pod, perlunicode.pod =item Significant bug fixes -=over +=over 4 =item <HANDLE> on empty files @@ -5072,7 +4956,7 @@ CLI symbol "%s" too long, Version number must be a constant number =item Incompatible Changes -=over +=over 4 =item Perl Source Incompatibilities @@ -5081,8 +4965,7 @@ 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(), values() and -C<\(%h)> operate on aliases to values, not copies, vec(EXPR,OFFSET,BITS) +Writing C<"$$1"> to mean C<"${$}1"> is unsupported, 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 @@ -5103,7 +4986,7 @@ C<PATCHLEVEL> is now C<PERL_VERSION> =item Known Problems -=over +=over 4 =item Thread test failures @@ -5146,7 +5029,7 @@ to mean "${$}<digit>" is deprecated =head2 perl5005delta, perldelta - what's new for perl5.005 -=over +=over 4 =item DESCRIPTION @@ -5154,7 +5037,7 @@ to mean "${$}<digit>" is deprecated =item Incompatible Changes -=over +=over 4 =item WARNING: This version is not binary compatible with Perl 5.004. @@ -5164,10 +5047,6 @@ to mean "${$}<digit>" is deprecated =item C Source Compatibility -Core sources now require ANSI C compiler, All Perl global variables must -now be referenced with an explicit prefix, Enabling threads has source -compatibility issues - =item Binary Compatibility =item Security fixes may affect compatibility @@ -5180,7 +5059,7 @@ compatibility issues =item Core Changes -=over +=over 4 =item Threads @@ -5260,7 +5139,7 @@ improvements, Incompatible changes =item Supported Platforms -=over +=over 4 =item New Platforms @@ -5270,7 +5149,7 @@ improvements, Incompatible changes =item Modules and Pragmata -=over +=over 4 =item New Modules @@ -5305,9 +5184,9 @@ 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' in package '%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 +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 @@ -5326,7 +5205,7 @@ temporary file, regexp too big =head2 perl5004delta, perldelta - what's new for perl5.004 -=over +=over 4 =item DESCRIPTION @@ -5334,11 +5213,11 @@ temporary file, regexp too big =item Core Changes -=over +=over 4 =item List assignment to %ENV works -=item "Can't locate Foo.pm in @INC" error now lists @INC +=item Change to "Can't locate Foo.pm in @INC" error =item Compilation option: Binary compatibility with 5.003 @@ -5418,7 +5297,7 @@ LIST, READLINE this, GETC this, DESTROY this =item Support for More Operating Systems -=over +=over 4 =item Win32 @@ -5437,7 +5316,7 @@ constant NAME => VALUE, use locale, use ops, use vmsish =item Modules -=over +=over 4 =item Required Updates @@ -5463,7 +5342,7 @@ constant NAME => VALUE, use locale, use ops, use vmsish =item Utility Changes -=over +=over 4 =item pod2html @@ -5504,14 +5383,14 @@ 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 package `%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 +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 =item BUGS @@ -5523,11 +5402,11 @@ PERL_SH_DIR too long, Process terminated by SIG%s =head2 perlaix, README.aix - Perl version 5 on IBM Unix (AIX) systems -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Compiling Perl 5 on AIX @@ -5557,19 +5436,19 @@ PERL_SH_DIR too long, Process terminated by SIG%s =back -=head2 perlamiga - Perl under Amiga OS (possibly very outdated information) +=head2 perlamiga - Perl under Amiga OS -=over +=over 4 =item SYNOPSIS =back -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Prerequisites @@ -5590,7 +5469,7 @@ finally close()d =item Accessing documentation -=over +=over 4 =item Manpages @@ -5604,7 +5483,7 @@ finally close()d =item BUILD -=over +=over 4 =item Prerequisites @@ -5612,13 +5491,15 @@ finally close()d =item Making +sh Configure -Dprefix=/ade -Dloclibpth=/ade/lib + =item Testing =item Installing the built perl =back -=item AUTHOR +=item AUTHORS =item SEE ALSO @@ -5626,13 +5507,13 @@ finally close()d =head2 perlcygwin, README.cygwin - Perl for Cygwin -=over +=over 4 =item SYNOPSIS =item PREREQUISITES -=over +=over 4 =item Cygwin = GNU+Cygnus+Windows (Don't leave UNIX without it) @@ -5644,7 +5525,7 @@ C<PATH>, I<nroff>, Permissions =item CONFIGURE -=over +=over 4 =item Strip Binaries @@ -5660,14 +5541,13 @@ C<-Duse64bitint>, C<-Duselongdouble>, C<-Dusethreads>, C<-Duselargefiles> =item Suspicious Warnings -I<dlsym()>, Win9x and C<d_eofnblk>, Checking how std your stdio is.., -Compiler/Preprocessor defines +I<dlsym()>, Win9x and C<d_eofnblk>, Compiler/Preprocessor defines =back =item MAKE -=over +=over 4 =item Warnings @@ -5677,7 +5557,7 @@ Compiler/Preprocessor defines =item TEST -=over +=over 4 =item File Permissions @@ -5712,13 +5592,13 @@ Source, Compiled Module Source, Perl Modules/Scripts =head2 perldos - Perl under DOS, W31, W95. -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Prerequisites @@ -5734,20 +5614,70 @@ DJGPP, Pthreads =back +=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 perlepoc, README.epoc - Perl for EPOC + +=over 4 + +=item SYNOPSIS + +=item INTRODUCTION + +=item INSTALLING PERL ON EPOC + +=item USING PERL ON EPOC + +=over 4 + +=item IO Redirection + +=item PATH Names + +=item Editors + +=item Features + +=item Restrictions + +=item Compiling Perl 5 on the EPOC cross compiling environment + +=back + +=item SUPPORT STATUS + +=item AUTHOR + +=item LAST UPDATE + +=back + =head2 perlhpux, README.hpux - Perl version 5 on Hewlett-Packard Unix (HP-UX) systems -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Compiling Perl 5 on HP-UX @@ -5788,11 +5718,11 @@ DJGPP, Pthreads =head2 perlmachten, README.machten - Perl version 5 on Power MachTen systems -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Compiling Perl 5 on MachTen @@ -5810,15 +5740,43 @@ op/lexassign.t, pragma/warnings.t =back +=head2 perlmpeix, README.mpeix - Perl/iX for HP e3000 MPE + +=head1 SYNOPSIS + +=over 4 + +=item What's New + +=item System Requirements + +=item How to Obtain Perl/iX + +=item Distribution Contents Highlights + +README, public_html/feedback.cgi, 4, 6 + +=item Getting Started with Perl/iX + +=item MPE/iX Implementation Considerations + +=item Change History + +=back + =head2 perlos2 - Perl under OS/2, DOS, Win0.3*, Win0.95 and WinNT. -=over +=over 4 =item SYNOPSIS =back -=over +=over 4 + +=item DESCRIPTION + +=over 4 =item Target @@ -5834,11 +5792,9 @@ EMX, RSX, HPFS, pdksh =back -=over - =item Frequently asked questions -=over +=over 4 =item I cannot run external programs @@ -5856,7 +5812,7 @@ L<ExtUtils::Embed>? =item INSTALLATION -=over +=over 4 =item Automatic binary installation @@ -5876,7 +5832,7 @@ Perl manual in F<.INF> format, Pdksh =item Accessing documentation -=over +=over 4 =item OS/2 F<.INF> file @@ -5896,7 +5852,7 @@ Perl manual in F<.INF> format, Pdksh =item BUILD -=over +=over 4 =item Prerequisites @@ -5921,7 +5877,7 @@ F<lib/io_pipe.t>, F<lib/io_sock.t>, F<op/stat.t>, F<lib/io_udp.t> =item Build FAQ -=over +=over 4 =item Some C</> became C<\> in pdksh. @@ -5941,7 +5897,7 @@ F<lib/io_pipe.t>, F<lib/io_sock.t>, F<op/stat.t>, F<lib/io_udp.t> =item Specific (mis)features of OS/2 port -=over +=over 4 =item C<setpriority>, C<getpriority> @@ -5970,7 +5926,7 @@ C<popen>, C<tmpnam>, C<tmpfile>, C<ctermid>, C<stat>, C<flock> =item Perl flavors -=over +=over 4 =item F<perl.exe> @@ -5992,7 +5948,7 @@ explicit fork(), open FH, "|-", open FH, "-|" =item ENVIRONMENT -=over +=over 4 =item C<PERLLIB_PREFIX> @@ -6010,7 +5966,7 @@ explicit fork(), open FH, "|-", open FH, "-|" =item Evolution -=over +=over 4 =item Priorities @@ -6030,7 +5986,7 @@ C<COND_WAIT>, F<os2.c> =back -=over +=over 4 =item AUTHOR @@ -6040,13 +5996,13 @@ C<COND_WAIT>, F<os2.c> =head2 perlos390, README.os390 - building and installing Perl for OS/390. -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Unpacking @@ -6056,9 +6012,13 @@ C<COND_WAIT>, F<os2.c> =item Build, test, install +=item build anomalies + +=item testing anomalies + =item Usage Hints -=item Extensions +=item Modules and Extensions =back @@ -6066,7 +6026,7 @@ C<COND_WAIT>, F<os2.c> =item SEE ALSO -=over +=over 4 =item Mailing list @@ -6079,13 +6039,13 @@ C<COND_WAIT>, F<os2.c> =head2 perlposix-bc, README.posix-bc - building and installing Perl for BS2000 POSIX. -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item gzip @@ -6107,7 +6067,7 @@ BS2000 POSIX. =item SEE ALSO -=over +=over 4 =item Mailing list @@ -6117,9 +6077,93 @@ BS2000 POSIX. =back +=head2 perlsolaris, README.solaris - Perl version 5 on Solaris systems + +=over 4 + +=item DESCRIPTION + +=over 4 + +=item Solaris Version Numbers. + +=back + +=item RESOURCES + +Solaris FAQ, Precompiled Binaries, Solaris Documentation + +=item SETTING UP + +=over 4 + +=item File Extraction Problems. + +=item Compiler and Related Tools. + +=item Environment + +=back + +=item RUN CONFIGURE. + +=over 4 + +=item 64-bit Issues. + +=item Threads. + +=item Malloc Issues. + +=back + +=item MAKE PROBLEMS. + +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 + +=item MAKE TEST + +=over 4 + +=item op/stat.t test 4 + +=back + +=item PREBUILT BINARIES. + +=item RUNTIME ISSUES. + +=over 4 + +=item Limits on Numbers of Open Files. + +=back + +=item SOLARIS-SPECIFIC MODULES. + +=item SOLARIS-SPECIFIC PROBLEMS WITH MODULES. + +=over 4 + +=item Proc::ProcessTable + +=item BSD::Resource + +=item Net::SSLeay + +=back + +=item AUTHOR + +=item LAST MODIFIED + +=back + =head2 perlvms - VMS-specific documentation for Perl -=over +=over 4 =item DESCRIPTION @@ -6127,7 +6171,7 @@ BS2000 POSIX. =item Organization of Perl Images -=over +=over 4 =item Core Images @@ -6141,7 +6185,7 @@ BS2000 POSIX. =item File specifications -=over +=over 4 =item Syntax @@ -6155,7 +6199,7 @@ BS2000 POSIX. =item Command line -=over +=over 4 =item I/O redirection and backgrounding @@ -6178,7 +6222,7 @@ LIST, waitpid PID,FLAGS =item Standard modules with VMS-specific differences -=over +=over 4 =item SDBM_File @@ -6190,15 +6234,55 @@ LIST, waitpid PID,FLAGS =back +=head2 perlvos, README.vos - Perl for Stratus VOS + +=over 4 + +=item SYNOPSIS + +=over 4 + +=item Stratus POSIX Support + +=back + +=item INSTALLING PERL IN VOS + +=over 4 + +=item Compiling Perl 5 on VOS + +=item Installing Perl 5 on VOS + +=back + +=item USING PERL IN VOS + +=over 4 + +=item Unimplemented Features + +=item Restrictions + +=back + +=item SUPPORT STATUS + +=item AUTHOR + +=item LAST UPDATE + +=back + =head2 perlwin32 - Perl under Win32 -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Setting Up @@ -6222,6 +6306,10 @@ Extensions, Running Perl Scripts, Miscellaneous Things =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@ing-simmons.netE<gt> + =item SEE ALSO =item HISTORY @@ -6232,7 +6320,7 @@ Extensions, Running Perl Scripts, Miscellaneous Things =head2 attrs - set/get attributes of a subroutine (deprecated) -=over +=over 4 =item SYNOPSIS @@ -6244,7 +6332,7 @@ method, locked =head2 re - Perl pragma to alter regular expression behaviour -=over +=over 4 =item SYNOPSIS @@ -6254,13 +6342,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 @@ -6280,7 +6368,7 @@ FETCH_I<type>_ATTRIBUTES, MODIFY_I<type>_ATTRIBUTES =item EXPORTS -=over +=over 4 =item Default exports @@ -6298,7 +6386,7 @@ FETCH_I<type>_ATTRIBUTES, MODIFY_I<type>_ATTRIBUTES =head2 attrs - set/get attributes of a subroutine (deprecated) -=over +=over 4 =item SYNOPSIS @@ -6310,7 +6398,7 @@ method, locked =head2 autouse - postpone load of modules until a function is used -=over +=over 4 =item SYNOPSIS @@ -6326,7 +6414,7 @@ method, locked =head2 base - Establish IS-A relationship with base class at compile time -=over +=over 4 =item SYNOPSIS @@ -6340,7 +6428,7 @@ method, locked =head2 blib - Use MakeMaker's uninstalled version of a package -=over +=over 4 =item SYNOPSIS @@ -6355,7 +6443,7 @@ method, locked =head2 bytes - Perl pragma to force byte semantics rather than character semantics -=over +=over 4 =item SYNOPSIS @@ -6368,7 +6456,7 @@ semantics =head2 charnames - define character names for C<\N{named}> string literal escape. -=over +=over 4 =item SYNOPSIS @@ -6382,7 +6470,7 @@ escape. =head2 constant - Perl pragma to declare constants -=over +=over 4 =item SYNOPSIS @@ -6403,13 +6491,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 @@ -6429,7 +6517,7 @@ diagnostics =head2 fields - compile-time class fields -=over +=over 4 =item SYNOPSIS @@ -6443,13 +6531,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 @@ -6460,7 +6548,7 @@ new, phash =head2 integer - Perl pragma to compute arithmetic in integer instead of double -=over +=over 4 =item SYNOPSIS @@ -6470,7 +6558,7 @@ double =head2 less - perl pragma to request less of something from the compiler -=over +=over 4 =item SYNOPSIS @@ -6480,13 +6568,13 @@ double =head2 lib - manipulate @INC at compile time -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Adding directories to @INC @@ -6505,7 +6593,7 @@ double =head2 locale - Perl pragma to use and avoid POSIX locales for built-in operations -=over +=over 4 =item SYNOPSIS @@ -6515,7 +6603,7 @@ operations =head2 open - perl pragma to set default disciplines for input and output -=over +=over 4 =item SYNOPSIS @@ -6529,7 +6617,7 @@ operations =head2 ops - Perl pragma to restrict unsafe operations when compiling -=over +=over 4 =item SYNOPSIS @@ -6541,13 +6629,13 @@ operations =head2 overload - Package for overloading perl operations -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Declaration of overloaded functions @@ -6576,7 +6664,7 @@ is inherited by derived classes =item SPECIAL SYMBOLS FOR C<use overload> -=over +=over 4 =item Last Resort @@ -6615,7 +6703,7 @@ integer, float, binary, q, qr =item Cookbook -=over +=over 4 =item Two-face scalars @@ -6638,9 +6726,29 @@ type, `%s' is not a code reference =back +=head2 perlio - perl pragma to configure C level IO + +=over 4 + +=item SYNOPSIS + +=item DESCRIPTION + +unix, stdio, perlio + +=over 4 + +=item Defaults and how to override them + +=back + +=item AUTHOR + +=back + =head2 re - Perl pragma to alter regular expression behaviour -=over +=over 4 =item SYNOPSIS @@ -6650,7 +6758,7 @@ type, `%s' is not a code reference =head2 sigtrap - Perl pragma to enable simple signal handling -=over +=over 4 =item SYNOPSIS @@ -6658,7 +6766,7 @@ type, `%s' is not a code reference =item OPTIONS -=over +=over 4 =item SIGNAL HANDLERS @@ -6680,7 +6788,7 @@ B<untrapped>, B<any>, I<signal>, I<number> =head2 strict - Perl pragma to restrict unsafe constructs -=over +=over 4 =item SYNOPSIS @@ -6692,17 +6800,30 @@ C<strict refs>, C<strict vars>, C<strict subs> =head2 subs - Perl pragma to predeclare sub names -=over +=over 4 + +=item SYNOPSIS + +=item DESCRIPTION + +=back + +=head2 unicode::distinct - Perl pragma to strictly distinguish UTF8 data +and non-UTF data. + +=over 4 =item SYNOPSIS =item DESCRIPTION +=item SEE ALSO + =back =head2 utf8 - Perl pragma to enable/disable UTF-8 in source code -=over +=over 4 =item SYNOPSIS @@ -6714,7 +6835,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 @@ -6724,7 +6845,7 @@ C<strict refs>, C<strict vars>, C<strict subs> =head2 warnings - Perl pragma to control optional warnings -=over +=over 4 =item SYNOPSIS @@ -6744,13 +6865,13 @@ warnings::warnif($object, $message) =head2 AnyDBM_File - provide framework for multiple DBMs -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item DBM Comparisons @@ -6764,13 +6885,13 @@ warnings::warnif($object, $message) =head2 AutoLoader - load subroutines only on demand -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Subroutine Stubs @@ -6794,7 +6915,7 @@ warnings::warnif($object, $message) =head2 AutoSplit - split a package for autoloading -=over +=over 4 =item SYNOPSIS @@ -6802,7 +6923,7 @@ warnings::warnif($object, $message) $keep, $check, $modtime -=over +=over 4 =item Multiple packages @@ -6814,7 +6935,7 @@ $keep, $check, $modtime =head2 B - The Perl Compiler -=over +=over 4 =item SYNOPSIS @@ -6822,7 +6943,7 @@ $keep, $check, $modtime =item OVERVIEW OF CLASSES -=over +=over 4 =item SV-RELATED CLASSES @@ -6879,7 +7000,7 @@ FILL, MAX, OFF, ARRAY, AvFLAGS =item B::CV METHODS STASH, START, ROOT, GV, FILE, DEPTH, PADLIST, OUTSIDE, XSUB, XSUBANY, -CvFLAGS +CvFLAGS, const_sv =item B::HV METHODS @@ -6947,7 +7068,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 @@ -6959,7 +7080,7 @@ bytecode =head2 B::Assembler - Assemble Perl bytecode -=over +=over 4 =item SYNOPSIS @@ -6971,7 +7092,7 @@ bytecode =head2 B::Bblock - Walk basic blocks -=over +=over 4 =item SYNOPSIS @@ -6983,7 +7104,7 @@ bytecode =head2 B::Bytecode - Perl compiler's bytecode backend -=over +=over 4 =item SYNOPSIS @@ -7006,7 +7127,7 @@ output. =back =head2 B::C - Perl compiler's C backend -=over +=over 4 =item SYNOPSIS @@ -7027,7 +7148,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 @@ -7045,7 +7166,7 @@ B<-ffreetmps-each-bblock>, B<-ffreetmps-each-loop>, B<-fomit-taint>, B<-On> =item DIFFERENCES -=over +=over 4 =item Loops @@ -7063,7 +7184,7 @@ B<-ffreetmps-each-bblock>, B<-ffreetmps-each-loop>, B<-fomit-taint>, B<-On> =head2 B::Debug - Walk Perl syntax tree, printing debug info about ops -=over +=over 4 =item SYNOPSIS @@ -7075,7 +7196,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 @@ -7088,7 +7209,7 @@ B<T>, B<v>I<STRING>B<.> =item USING B::Deparse AS A MODULE -=over +=over 4 =item Synopsis @@ -7108,7 +7229,7 @@ B<T>, B<v>I<STRING>B<.> =head2 B::Disassembler - Disassemble Perl bytecode -=over +=over 4 =item SYNOPSIS @@ -7120,7 +7241,7 @@ B<T>, B<v>I<STRING>B<.> =head2 B::Lint - Perl lint -=over +=over 4 =item SYNOPSIS @@ -7143,7 +7264,7 @@ B<-u Package> =head2 B::O, O - Generic interface to Perl Compiler backends -=over +=over 4 =item SYNOPSIS @@ -7159,7 +7280,7 @@ B<-u Package> =head2 B::Showlex - Show lexical variables used in functions or files -=over +=over 4 =item SYNOPSIS @@ -7171,7 +7292,7 @@ B<-u Package> =head2 B::Stackobj - Helper module for CC backend -=over +=over 4 =item SYNOPSIS @@ -7185,7 +7306,7 @@ B<-u Package> =head2 B::Terse - Walk Perl syntax tree, printing terse info about ops -=over +=over 4 =item SYNOPSIS @@ -7197,7 +7318,7 @@ B<-u Package> =head2 B::Xref - Generates cross reference reports for Perl programs -=over +=over 4 =item SYNOPSIS @@ -7215,7 +7336,7 @@ C<-oFILENAME>, C<-r>, C<-D[tO]> =head2 Bblock, B::Bblock - Walk basic blocks -=over +=over 4 =item SYNOPSIS @@ -7227,13 +7348,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 @@ -7271,7 +7392,7 @@ STYLE ] ), cmpthese ( RESULTSHASHREF ), countit(TIME, CODE), disablecache ( =head2 ByteLoader - load byte compiled perl code -=over +=over 4 =item SYNOPSIS @@ -7285,7 +7406,7 @@ STYLE ] ), cmpthese ( RESULTSHASHREF ), countit(TIME, CODE), disablecache ( =head2 Bytecode, B::Bytecode - Perl compiler's bytecode backend -=over +=over 4 =item SYNOPSIS @@ -7308,7 +7429,7 @@ output. =back =head2 CGI - Simple Common Gateway Interface Class -=over +=over 4 =item SYNOPSIS @@ -7316,16 +7437,12 @@ output. =back =item DESCRIPTION -=over +=over 4 =item PROGRAMMING STYLE =item CALLING CGI.PM ROUTINES -1. Use another name for the argument, if one is available. For example, --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 @@ -7374,7 +7491,7 @@ a </UL> tag) =item GENERATING DYNAMIC DOCUMENTS -=over +=over 4 =item CREATING A STANDARD HTTP HEADER: @@ -7399,7 +7516,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 @@ -7420,7 +7537,7 @@ charset([$charset]);, $flag = autoEscape([$flag]); =item CREATING FILL-OUT FORMS: -=over +=over 4 =item CREATING AN ISINDEX TAG @@ -7472,8 +7589,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 @@ -7494,7 +7610,7 @@ the <FORM> tag =item DEBUGGING -=over +=over 4 =item DUMPING OUT ALL THE NAME/VALUE PAIRS @@ -7503,16 +7619,15 @@ 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_port ()>, +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 @@ -7552,7 +7667,7 @@ MacEachern (dougm@opengroup.org), Robin Houston (robin@oneworld.org), =head2 CGI::Apache - Backward compatibility module for CGI.pm -=over +=over 4 =item SYNOPSIS @@ -7571,7 +7686,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 @@ -7581,7 +7696,7 @@ other) error log =item MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW -=over +=over 4 =item Changing the default message @@ -7599,7 +7714,7 @@ other) error log =head2 CGI::Cookie - Interface to Netscape Cookies -=over +=over 4 =item SYNOPSIS @@ -7609,7 +7724,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 @@ -7633,7 +7748,7 @@ B<name()>, B<value()>, B<domain()>, B<path()>, B<expires()> =head2 CGI::Fast - CGI Interface for Fast CGI -=over +=over 4 =item SYNOPSIS @@ -7659,13 +7774,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 @@ -7683,7 +7798,7 @@ B<name()>, B<value()>, B<domain()>, B<path()>, B<expires()> =head2 CGI::Push - Simple Interface to Server Push -=over +=over 4 =item SYNOPSIS @@ -7693,7 +7808,7 @@ B<name()>, B<value()>, B<domain()>, B<path()>, B<expires()> -next_page, -last_page, -type, -delay, -cookie, -target, -expires -=over +=over 4 =item Heterogeneous Pages @@ -7713,7 +7828,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 @@ -7731,13 +7846,13 @@ B<name()>, B<value()>, B<domain()>, B<path()>, B<expires()> =head2 CPAN - query, download and build perl modules from CPAN sites -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Interactive Mode @@ -7755,9 +7870,36 @@ distribution, Signals =item Programmer's interface -expand($type,@things), Programming Examples - -=item Methods in the four Classes +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 @@ -7780,7 +7922,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 @@ -7796,7 +7938,7 @@ optionE<gt> [shift|pop]>, C<o conf E<lt>list optionE<gt> =item WORKING WITH CPAN.pm BEHIND FIREWALLS -=over +=over 4 =item Three basic types of firewalls @@ -7808,16 +7950,7 @@ http firewall, ftp firewall, One way visibility, SOCKS, IP Masquerade =item FAQ -1) I installed a new version of module X but CPAN keeps saying, I -have the old version installed, 2) So why is UNINST=1 not the default?, 3) -When I install bundles or multiple modules with one command there is -too much output to keep track of, 4) I am not root, how can I install a -module in a personal directory?, 5) How to get a package, unwrap it, -and make a change before building it?, 6) I installed a Bundle and -had a couple of fails. When I retried, everything resolved nicely. -Can this be fixed to work on first try?, 7) In our intranet we have -many modules for internal use. How can I integrate these modules with -CPAN.pm but without uploading the modules to CPAN? +1), 2), 3), 4), 5), 6), 7), 8), 9), 10) =item BUGS @@ -7829,7 +7962,7 @@ CPAN.pm but without uploading the modules to CPAN? =head2 CPAN::FirstTime - Utility for CPAN::Config file Initialization -=over +=over 4 =item SYNOPSIS @@ -7840,7 +7973,7 @@ CPAN.pm but without uploading the modules to CPAN? =head2 CPANox, CPAN::Nox - Wrapper around CPAN.pm without using any XS module -=over +=over 4 =item SYNOPSIS @@ -7852,13 +7985,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 @@ -7868,28 +8001,22 @@ module =back -=head2 Carp::Heavy - Carp guts - -=over - -=item SYNOPIS - -=item DESCRIPTION - -=back +=head2 Carp::Heavy, Carp heavy machinery - no user serviceable parts inside =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 @@ -7909,7 +8036,7 @@ Example 1, Example 2, Example 3 =head2 Config - access Perl configuration information -=over +=over 4 =item SYNOPSIS @@ -7923,7 +8050,7 @@ myconfig(), config_sh(), config_vars(@names) =item GLOSSARY -=over +=over 4 =item _ @@ -7955,38 +8082,39 @@ 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_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_frexpl>, 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_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_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_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_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_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>, @@ -7996,31 +8124,33 @@ 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_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_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_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_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_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>, -C<d_voidsig>, C<d_voidtty>, C<d_volatile>, C<d_vprintf>, C<d_wait4>, -C<d_waitpid>, C<d_wcstombs>, C<d_wctomb>, C<d_xenix>, C<date>, -C<db_hashtype>, C<db_prefixtype>, C<defvoidused>, C<direntrytype>, -C<dlext>, C<dlsrc>, C<doublesize>, C<drand01>, C<dynamic_ext> +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_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_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_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_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>, C<d_voidsig>, C<d_voidtty>, +C<d_volatile>, C<d_vprintf>, C<d_wait4>, C<d_waitpid>, C<d_wcstombs>, +C<d_wctomb>, C<d_xenix>, C<date>, C<db_hashtype>, C<db_prefixtype>, +C<defvoidused>, C<direntrytype>, C<dlext>, C<dlsrc>, C<doublesize>, +C<drand01>, C<dynamic_ext> =item e @@ -8065,7 +8195,8 @@ 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<installvendorlib>, C<intsize>, C<issymlink>, C<ivdformat>, C<ivsize>, +C<ivtype> =item k @@ -8093,10 +8224,10 @@ 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<nveformat>, C<nvEUformat>, C<nvfformat>, C<nvFUformat>, C<nvgformat>, -C<nvGUformat>, 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 @@ -8180,7 +8311,7 @@ C<zcat>, C<zip> =head2 Cwd, getcwd - get pathname of current working directory -=over +=over 4 =item SYNOPSIS @@ -8192,13 +8323,13 @@ C<zcat>, C<zip> subject to change) -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Global Variables @@ -8227,7 +8358,7 @@ CLIENT->output(LIST) =head2 DB_File - Perl5 access to Berkeley DB version 1.x -=over +=over 4 =item SYNOPSIS @@ -8235,7 +8366,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 @@ -8251,7 +8382,7 @@ B<DB_HASH>, B<DB_BTREE>, B<DB_RECNO> =item DB_HASH -=over +=over 4 =item A Simple Example @@ -8259,7 +8390,7 @@ B<DB_HASH>, B<DB_BTREE>, B<DB_RECNO> =item DB_BTREE -=over +=over 4 =item Changing the BTREE sort order @@ -8277,7 +8408,7 @@ B<DB_HASH>, B<DB_BTREE>, B<DB_RECNO> =item DB_RECNO -=over +=over 4 =item The 'bval' Option @@ -8304,7 +8435,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 @@ -8316,7 +8447,7 @@ B<filter_fetch_value> =item HINTS AND TIPS -=over +=over 4 =item Locking: The Trouble with fd @@ -8332,7 +8463,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? @@ -8363,13 +8494,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 @@ -8417,7 +8548,7 @@ Dumper =head2 Devel::DProf - a Perl code profiler -=over +=over 4 =item SYNOPSIS @@ -8437,13 +8568,13 @@ Dumper =head2 Devel::Peek - A data debugging tool for the XS programmer -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Memory footprint debugging @@ -8451,7 +8582,7 @@ Dumper =item EXAMPLES -=over +=over 4 =item A simple scalar string @@ -8485,7 +8616,7 @@ Dumper =head2 Devel::SelfStubber - generate stubs for a SelfLoading module -=over +=over 4 =item SYNOPSIS @@ -8495,7 +8626,7 @@ Dumper =head2 DirHandle - supply object methods for directory handles -=over +=over 4 =item SYNOPSIS @@ -8505,13 +8636,13 @@ Dumper =head2 Dumpvalue - provides screen dump of Perl data. -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Creation @@ -8531,7 +8662,7 @@ veryCompact, set, get =head2 DynaLoader - Dynamically load C libraries into Perl code -=over +=over 4 =item SYNOPSIS @@ -8550,7 +8681,7 @@ bootstrap() =head2 DynaLoader::XSLoader, XSLoader - Dynamically load C libraries into Perl code -=over +=over 4 =item SYNOPSIS @@ -8562,7 +8693,7 @@ Perl code =head2 Encode - character encodings -=over +=over 4 =item TERMINOLOGY @@ -8582,10 +8713,39 @@ Perl code =back +=head2 Encode::EncodeFormat, EncodeFormat - the format of encoding tables +of the Encode extension + +=over 4 + +=item DESCRIPTION + +[1] B<S>, [2] B<D>, [3] B<M>, [4] B<E> + +=item KEYWORDS + +=item COPYRIGHT + +=back + +=head2 EncodeFormat - the format of encoding tables of the Encode extension + +=over 4 + +=item DESCRIPTION + +[1] B<S>, [2] B<D>, [3] B<M>, [4] B<E> + +=item KEYWORDS + +=item COPYRIGHT + +=back + =head2 English - use nice English (or awk) names for ugly punctuation variables -=over +=over 4 =item SYNOPSIS @@ -8598,7 +8758,7 @@ variables =head2 Env - perl module that imports environment variables as scalars or arrays -=over +=over 4 =item SYNOPSIS @@ -8612,7 +8772,7 @@ arrays =head2 Errno - System errno constants -=over +=over 4 =item SYNOPSIS @@ -8628,13 +8788,13 @@ arrays =head2 Exporter - Implements default import method for modules -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item How to Export @@ -8656,7 +8816,7 @@ arrays =head2 Exporter::Heavy - Exporter guts -=over +=over 4 =item SYNOPIS @@ -8667,7 +8827,7 @@ arrays =head2 ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc. -=over +=over 4 =item SYNOPSIS @@ -8695,7 +8855,7 @@ mkpath directory.. test_f file -=over +=over 4 =item BUGS @@ -8707,7 +8867,7 @@ test_f file =head2 ExtUtils::Embed - Utilities for embedding Perl in C/C++ applications -=over +=over 4 =item SYNOPSIS @@ -8730,7 +8890,7 @@ ccopts(), xsi_header(), xsi_protos(@modules), xsi_body(@modules) =head2 ExtUtils::Install - install files from here to there -=over +=over 4 =item SYNOPSIS @@ -8740,7 +8900,7 @@ ccopts(), xsi_header(), xsi_protos(@modules), xsi_body(@modules) =head2 ExtUtils::Installed - Inventory management of installed modules -=over +=over 4 =item SYNOPSIS @@ -8761,7 +8921,7 @@ packlist(), version() =head2 ExtUtils::Liblist - determine libraries to use and how to use them -=over +=over 4 =item SYNOPSIS @@ -8769,7 +8929,7 @@ packlist(), version() For static extensions, For dynamic extensions, For dynamic extensions -=over +=over 4 =item EXTRALIBS @@ -8781,7 +8941,7 @@ For static extensions, For dynamic extensions, For dynamic extensions =item PORTABILITY -=over +=over 4 =item VMS implementation @@ -8796,7 +8956,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 @@ -8809,7 +8969,7 @@ canonpath, cflags, manifypods, perl_archive =head2 ExtUtils::MM_OS2 - methods to override UN*X behaviour in ExtUtils::MakeMaker -=over +=over 4 =item SYNOPSIS @@ -8819,7 +8979,7 @@ ExtUtils::MakeMaker =head2 ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker -=over +=over 4 =item SYNOPSIS @@ -8827,7 +8987,7 @@ ExtUtils::MakeMaker =item METHODS -=over +=over 4 =item Preloaded methods @@ -8847,7 +9007,7 @@ rootdir updir -=over +=over 4 =item SelfLoaded methods @@ -8899,7 +9059,7 @@ file_name_is_absolute find_perl -=over +=over 4 =item Methods to actually produce chunks of text for the Makefile @@ -9017,7 +9177,7 @@ perl_archive export_list -=over +=over 4 =item SEE ALSO @@ -9026,13 +9186,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 @@ -9044,7 +9204,7 @@ wraplist rootdir (override) -=over +=over 4 =item SelfLoaded methods @@ -9141,7 +9301,7 @@ nicetext (override) =head2 ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker -=over +=over 4 =item SYNOPSIS @@ -9187,13 +9347,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 @@ -9217,21 +9377,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, POLLUTE, PPM_INSTALL_EXEC, PPM_INSTALL_SCRIPT, +PREFIX, PREREQ_PM, SKIP, TYPEMAPS, VERSION, VERSION_FROM, XS, XSOPT, +XSPROTOARG, XS_VERSION =item Additional lowercase attributes @@ -9264,7 +9424,7 @@ PERL_MM_OPT =head2 ExtUtils::Manifest - utilities to write and check a MANIFEST file -=over +=over 4 =item SYNOPSIS @@ -9281,6 +9441,10 @@ PERL_MM_OPT C<Not in MANIFEST:> I<file>, C<No such file:> I<file>, C<MANIFEST:> I<$!>, C<Added to MANIFEST:> I<file> +=item ENVIRONMENT + +B<PERL_MM_MANIFEST_DEBUG> + =item SEE ALSO =item AUTHOR @@ -9289,7 +9453,7 @@ C<Added to MANIFEST:> I<file> =head2 ExtUtils::Miniperl, writemain - write the C code for perlmain.c -=over +=over 4 =item SYNOPSIS @@ -9301,7 +9465,7 @@ C<Added to MANIFEST:> I<file> =head2 ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader -=over +=over 4 =item SYNOPSIS @@ -9312,7 +9476,7 @@ C<Added to MANIFEST:> I<file> =head2 ExtUtils::Mksymlists - write linker options files for dynamic extension -=over +=over 4 =item SYNOPSIS @@ -9328,7 +9492,7 @@ DLBASE, DL_FUNCS, DL_VARS, FILE, FUNCLIST, IMPORTS, NAME =head2 ExtUtils::Packlist - manage .packlist files -=over +=over 4 =item SYNOPSIS @@ -9348,7 +9512,7 @@ new(), read(), write(), validate(), packlist_file() =head2 ExtUtils::testlib - add blib/* directories to @INC -=over +=over 4 =item SYNOPSIS @@ -9358,7 +9522,7 @@ new(), read(), write(), validate(), packlist_file() =head2 Fatal - replace functions with equivalents which succeed or die -=over +=over 4 =item SYNOPSIS @@ -9370,7 +9534,7 @@ new(), read(), write(), validate(), packlist_file() =head2 Fcntl - load the C Fcntl.h defines -=over +=over 4 =item SYNOPSIS @@ -9384,7 +9548,7 @@ new(), read(), write(), validate(), packlist_file() =head2 File::Basename, fileparse - split a pathname into pieces -=over +=over 4 =item SYNOPSIS @@ -9400,7 +9564,7 @@ C<basename>, C<dirname> =head2 File::CheckTree, validate - run many filetest checks on a tree -=over +=over 4 =item SYNOPSIS @@ -9410,7 +9574,7 @@ C<basename>, C<dirname> =head2 File::Compare - Compare files or filehandles -=over +=over 4 =item SYNOPSIS @@ -9424,13 +9588,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) @@ -9446,7 +9610,7 @@ rmscopy($from,$to[,$date_flag]) =head2 File::DosGlob - DOS like globbing and then some -=over +=over 4 =item SYNOPSIS @@ -9466,7 +9630,7 @@ rmscopy($from,$to[,$date_flag]) =head2 File::Find, find - traverse a file tree -=over +=over 4 =item SYNOPSIS @@ -9482,7 +9646,7 @@ C<untaint_pattern>, C<untaint_skip> =head2 File::Glob - Perl extension for BSD glob routine -=over +=over 4 =item SYNOPSIS @@ -9503,7 +9667,7 @@ C<GLOB_NOSPACE>, C<GLOB_ABEND> =head2 File::Path - create or remove directory trees -=over +=over 4 =item SYNOPSIS @@ -9515,7 +9679,7 @@ C<GLOB_NOSPACE>, C<GLOB_ABEND> =head2 File::Spec - portably perform operations on file names -=over +=over 4 =item SYNOPSIS @@ -9527,15 +9691,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 @@ -9547,7 +9745,7 @@ C<GLOB_NOSPACE>, C<GLOB_ABEND> =head2 File::Spec::Mac - File::Spec for MacOS -=over +=over 4 =item SYNOPSIS @@ -9587,7 +9785,7 @@ abs2rel rel2abs -=over +=over 4 =item SEE ALSO @@ -9595,7 +9793,7 @@ rel2abs =head2 File::Spec::OS2 - methods for OS/2 file specs -=over +=over 4 =item SYNOPSIS @@ -9605,7 +9803,7 @@ rel2abs =head2 File::Spec::Unix - methods used by File::Spec -=over +=over 4 =item SYNOPSIS @@ -9651,7 +9849,7 @@ abs2rel rel2abs -=over +=over 4 =item SEE ALSO @@ -9659,7 +9857,7 @@ rel2abs =head2 File::Spec::VMS - methods for VMS file specs -=over +=over 4 =item SYNOPSIS @@ -9671,7 +9869,7 @@ eliminate_macros fixpath -=over +=over 4 =item Methods always loaded @@ -9709,7 +9907,7 @@ abs2rel (override) rel2abs (override) -=over +=over 4 =item SEE ALSO @@ -9717,7 +9915,7 @@ rel2abs (override) =head2 File::Spec::Win32 - methods for Win32 file specs -=over +=over 4 =item SYNOPSIS @@ -9739,7 +9937,7 @@ splitdir catpath -=over +=over 4 =item SEE ALSO @@ -9747,7 +9945,7 @@ catpath =head2 File::Temp - return name and handle of a temporary file safely -=over +=over 4 =item PORTABILITY @@ -9757,7 +9955,7 @@ catpath =back -=over +=over 4 =item FUNCTIONS @@ -9767,7 +9965,7 @@ B<tempfile> B<tempdir> -=over +=over 4 =item MKTEMP FUNCTIONS @@ -9781,7 +9979,7 @@ B<mkdtemp> B<mktemp> -=over +=over 4 =item POSIX FUNCTIONS @@ -9791,7 +9989,7 @@ B<tmpnam> B<tmpfile> -=over +=over 4 =item ADDITIONAL FUNCTIONS @@ -9799,7 +9997,7 @@ B<tempnam> =back -=over +=over 4 =item UTILITY FUNCTIONS @@ -9807,7 +10005,7 @@ B<unlink0> =back -=over +=over 4 =item PACKAGE VARIABLES @@ -9817,10 +10015,16 @@ B<safe_level>, STANDARD, MEDIUM, HIGH TopSystemUID -=over +=over 4 =item WARNING +=over 4 + +=item Temporary files and NFS + +=back + =item HISTORY =item SEE ALSO @@ -9831,7 +10035,7 @@ TopSystemUID =head2 File::stat - by-name interface to Perl's built-in stat() functions -=over +=over 4 =item SYNOPSIS @@ -9845,7 +10049,7 @@ TopSystemUID =head2 FileCache - keep more files open than the system permits -=over +=over 4 =item SYNOPSIS @@ -9857,7 +10061,7 @@ TopSystemUID =head2 FileHandle - supply object methods for filehandles -=over +=over 4 =item SYNOPSIS @@ -9869,9 +10073,75 @@ $fh->print, $fh->printf, $fh->getline, $fh->getlines =back +=head2 Filter::Simple - Simplified source filtering + +=over 4 + +=item SYNOPSIS + +=item DESCRIPTION + +=over 4 + +=item The Problem + +=item A Solution + +=item How it works + +=back + +=item AUTHOR + +=item COPYRIGHT + +=back + +=head2 Filter::Util::Call - Perl Source Filter Utility Module + +=over 4 + +=item SYNOPSIS + + use Filter::Util::Call ; + +=item DESCRIPTION + +=over 4 + +=item B<use Filter::Util::Call> + +=item B<import()> + +=item B<filter() and anonymous sub> + +B<$_>, B<$status>, B<filter_read> and B<filter_read_exact>, B<filter_del> + +=back + +=item EXAMPLES + +=over 4 + +=item Example 1: A simple filter. + +=item Example 2: Using the context + +=item Example 3: Using the context within the filter + +=item Example 4: Using filter_del + +=back + +=item AUTHOR + +=item DATE + +=back + =head2 FindBin - Locate directory of original perl script -=over +=over 4 =item SYNOPSIS @@ -9889,7 +10159,7 @@ $fh->print, $fh->printf, $fh->getline, $fh->getlines =head2 GDBM_File - Perl5 access to the gdbm library. -=over +=over 4 =item SYNOPSIS @@ -9905,7 +10175,7 @@ $fh->print, $fh->printf, $fh->getline, $fh->getlines =head2 Getopt::Long - Extended processing of command line options -=over +=over 4 =item SYNOPSIS @@ -9915,7 +10185,7 @@ $fh->print, $fh->printf, $fh->getline, $fh->getlines =item Getting Started with Getopt::Long -=over +=over 4 =item Simple options @@ -9943,7 +10213,7 @@ $fh->print, $fh->printf, $fh->getline, $fh->getlines =item Advanced Possibilities -=over +=over 4 =item Object oriented interface @@ -9971,7 +10241,7 @@ prefix_pattern, debug (default: disabled) =item Legacy -=over +=over 4 =item Default destinations @@ -9983,7 +10253,7 @@ prefix_pattern, debug (default: disabled) =item Trouble Shooting -=over +=over 4 =item Warning: Ignoring '!' modifier for short option @@ -10001,7 +10271,7 @@ supplied =head2 Getopt::Std, getopt - Process single-character switches with switch clustering -=over +=over 4 =item SYNOPSIS @@ -10012,7 +10282,7 @@ clustering =head2 I18N::Collate - compare 8-bit scalar data according to the current locale -=over +=over 4 =item SYNOPSIS @@ -10022,7 +10292,7 @@ locale =head2 IO - load various IO modules -=over +=over 4 =item SYNOPSIS @@ -10032,7 +10302,7 @@ locale =head2 IO::Dir - supply object methods for directory handles -=over +=over 4 =item SYNOPSIS @@ -10051,7 +10321,7 @@ rewind (), close (), tie %hash, IO::Dir, DIRNAME [, OPTIONS ] =head2 IO::File - supply object methods for filehandles -=over +=over 4 =item SYNOPSIS @@ -10073,7 +10343,7 @@ open( FILENAME [,MODE [,PERMS]] ) =head2 IO::Handle - supply object methods for I/O handles -=over +=over 4 =item SYNOPSIS @@ -10102,7 +10372,7 @@ $io->blocking ( [ BOOL ] ), $io->untaint =head2 IO::Pipe - supply object methods for pipes -=over +=over 4 =item SYNOPSIS @@ -10126,7 +10396,7 @@ reader ([ARGS]), writer ([ARGS]), handles () =head2 IO::Poll - Object interface to system poll call -=over +=over 4 =item SYNOPSIS @@ -10147,13 +10417,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 @@ -10161,7 +10433,7 @@ IO ), handles( [ EVENT_MASK ] ) =head2 IO::Select - OO interface to the select system call -=over +=over 4 =item SYNOPSIS @@ -10187,7 +10459,7 @@ count (), bits(), select ( READ, WRITE, ERROR [, TIMEOUT ] ) =head2 IO::Socket - Object interface to socket communications -=over +=over 4 =item SYNOPSIS @@ -10212,7 +10484,7 @@ sockopt(OPT [, VAL]), sockdomain, socktype, protocol, connected =head2 IO::Socket::INET - Object interface for AF_INET domain sockets -=over +=over 4 =item SYNOPSIS @@ -10222,7 +10494,7 @@ sockopt(OPT [, VAL]), sockdomain, socktype, protocol, connected new ( [ARGS] ) -=over +=over 4 =item METHODS @@ -10241,7 +10513,7 @@ sockaddr (), sockport (), sockhost (), peeraddr (), peerport (), peerhost =head2 IO::Socket::UNIX - Object interface for AF_UNIX domain sockets -=over +=over 4 =item SYNOPSIS @@ -10266,7 +10538,7 @@ hostpath(), peerpath() =head2 IO::lib::IO::Dir, IO::Dir - supply object methods for directory handles -=over +=over 4 =item SYNOPSIS @@ -10285,7 +10557,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 @@ -10308,7 +10580,7 @@ open( FILENAME [,MODE [,PERMS]] ) =head2 IO::lib::IO::Handle, IO::Handle - supply object methods for I/O handles -=over +=over 4 =item SYNOPSIS @@ -10337,7 +10609,7 @@ $io->blocking ( [ BOOL ] ), $io->untaint =head2 IO::lib::IO::Pipe, IO::Pipe - supply object methods for pipes -=over +=over 4 =item SYNOPSIS @@ -10361,7 +10633,7 @@ reader ([ARGS]), writer ([ARGS]), handles () =head2 IO::lib::IO::Poll, IO::Poll - Object interface to system poll call -=over +=over 4 =item SYNOPSIS @@ -10383,13 +10655,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 @@ -10398,7 +10672,7 @@ I/O objects =head2 IO::lib::IO::Select, IO::Select - OO interface to the select system call -=over +=over 4 =item SYNOPSIS @@ -10425,7 +10699,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 @@ -10451,7 +10725,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 @@ -10461,7 +10735,7 @@ AF_INET domain sockets new ( [ARGS] ) -=over +=over 4 =item METHODS @@ -10481,7 +10755,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 @@ -10505,7 +10779,7 @@ hostpath(), peerpath() =head2 IPC::Msg - SysV Msg IPC object class -=over +=over 4 =item SYNOPSIS @@ -10527,7 +10801,7 @@ FLAGS ] ), stat =head2 IPC::Open2, open2 - open a process for both reading and writing -=over +=over 4 =item SYNOPSIS @@ -10542,7 +10816,7 @@ FLAGS ] ), stat =head2 IPC::Open3, open3 - open a process for reading, writing, and error handling -=over +=over 4 =item SYNOPSIS @@ -10554,7 +10828,7 @@ handling =head2 IPC::Semaphore - SysV Semaphore IPC object class -=over +=over 4 =item SYNOPSIS @@ -10577,7 +10851,7 @@ set ( NAME => VALUE [, NAME => VALUE ...] ), setall ( VALUES ), setval ( N =head2 IPC::SysV - SysV IPC constants -=over +=over 4 =item SYNOPSIS @@ -10595,7 +10869,7 @@ ftok( PATH, ID ) =head2 IPC::SysV::Msg, IPC::Msg - SysV Msg IPC object class -=over +=over 4 =item SYNOPSIS @@ -10618,7 +10892,7 @@ FLAGS ] ), stat =head2 IPC::SysV::Semaphore, IPC::Semaphore - SysV Semaphore IPC object class -=over +=over 4 =item SYNOPSIS @@ -10641,7 +10915,7 @@ set ( NAME => VALUE [, NAME => VALUE ...] ), setall ( VALUES ), setval ( N =head2 Math::BigFloat - Arbitrary length float math package -=over +=over 4 =item SYNOPSIS @@ -10658,7 +10932,7 @@ performed =head2 Math::BigInt - Arbitrary size integer math package -=over +=over 4 =item SYNOPSIS @@ -10679,7 +10953,7 @@ Canonical notation, Input, Output =head2 Math::Complex - complex numbers and associated mathematical functions -=over +=over 4 =item SYNOPSIS @@ -10691,7 +10965,7 @@ functions =item STRINGIFICATION -=over +=over 4 =item CHANGED IN PERL 5.6 @@ -10711,7 +10985,7 @@ functions =head2 Math::Trig - trigonometric functions -=over +=over 4 =item SYNOPSIS @@ -10721,7 +10995,7 @@ functions B<tan> -=over +=over 4 =item ERRORS DUE TO DIVISION BY ZERO @@ -10733,7 +11007,7 @@ B<tan> =item RADIAL COORDINATE CONVERSIONS -=over +=over 4 =item COORDINATE SYSTEMS @@ -10756,7 +11030,7 @@ cylindrical_to_spherical, spherical_to_cartesian, spherical_to_cylindrical =head2 NDBM_File - Tied access to ndbm files -=over +=over 4 =item SYNOPSIS @@ -10764,7 +11038,7 @@ C<O_RDONLY>, C<O_WRONLY>, C<O_RDWR> =item DIAGNOSTICS -=over +=over 4 =item C<ndbm store returned -1, errno 22, key "..." at ...> @@ -10776,13 +11050,13 @@ C<O_RDONLY>, C<O_WRONLY>, C<O_RDWR> =head2 Net::Ping - check a remote host for reachability -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item Functions @@ -10800,7 +11074,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 @@ -10817,7 +11091,7 @@ functions =head2 Net::netent - by-name interface to Perl's built-in getnet*() functions -=over +=over 4 =item SYNOPSIS @@ -10834,7 +11108,7 @@ functions =head2 Net::protoent - by-name interface to Perl's built-in getproto*() functions -=over +=over 4 =item SYNOPSIS @@ -10849,7 +11123,7 @@ functions =head2 Net::servent - by-name interface to Perl's built-in getserv*() functions -=over +=over 4 =item SYNOPSIS @@ -10865,7 +11139,7 @@ functions =head2 O - Generic interface to Perl Compiler backends -=over +=over 4 =item SYNOPSIS @@ -10881,7 +11155,7 @@ functions =head2 ODBM_File - Tied access to odbm files -=over +=over 4 =item SYNOPSIS @@ -10889,7 +11163,7 @@ C<O_RDONLY>, C<O_WRONLY>, C<O_RDWR> =item DIAGNOSTICS -=over +=over 4 =item C<odbm store returned -1, errno 22, key "..." at ...> @@ -10901,7 +11175,7 @@ C<O_RDONLY>, C<O_WRONLY>, C<O_RDWR> =head2 Opcode - Disable named opcodes when compiling perl code -=over +=over 4 =item SYNOPSIS @@ -10929,7 +11203,7 @@ opdump (PAT) =back -=over +=over 4 =item Predefined Opcode Tags @@ -10947,7 +11221,7 @@ opdump (PAT) =head2 Opcode::Safe, Safe - Compile and execute code in restricted compartments -=over +=over 4 =item SYNOPSIS @@ -10957,7 +11231,7 @@ a new namespace, an operator mask =item WARNING -=over +=over 4 =item RECENT CHANGES @@ -10981,7 +11255,7 @@ Memory, CPU, Snooping, Signals, State Changes =head2 Opcode::ops, ops - Perl pragma to restrict unsafe operations when compiling -=over +=over 4 =item SYNOPSIS @@ -10993,7 +11267,7 @@ compiling =head2 POSIX - Perl interface to IEEE Std 1003.1 -=over +=over 4 =item SYNOPSIS @@ -11034,7 +11308,7 @@ wctomb, write =item CLASSES -=over +=over 4 =item POSIX::SigAction @@ -11122,13 +11396,13 @@ Constants, Macros =head2 Pod::Checker, podchecker() - check pod documents for syntax errors -=over +=over 4 =item SYNOPSIS =item OPTIONS/ARGUMENTS -=over +=over 4 =item podchecker() @@ -11140,7 +11414,7 @@ B<-warnings> =E<gt> I<val> =item DIAGNOSTICS -=over +=over 4 =item Errors @@ -11195,7 +11469,7 @@ C<$checker-E<gt>idx()> C<$checker-E<gt>hyperlink()> -=over +=over 4 =item AUTHOR @@ -11203,7 +11477,7 @@ C<$checker-E<gt>hyperlink()> =head2 Pod::Find - find POD documents in directory trees -=over +=over 4 =item SYNOPSIS @@ -11211,7 +11485,7 @@ C<$checker-E<gt>hyperlink()> =back -=over +=over 4 =item C<pod_find( { %opts } , @directories )> @@ -11220,13 +11494,13 @@ C<-verbose =E<gt> 1>, C<-perl =E<gt> 1>, C<-script =E<gt> 1>, C<-inc =E<gt> =back -=over +=over 4 =item C<simplify_name( $str )> =back -=over +=over 4 =item C<pod_where( { %opts }, $pod )> @@ -11235,13 +11509,13 @@ C<-inc =E<gt> 1>, C<-dirs =E<gt> [ $dir1, $dir2, ... ]>, C<-verbose =E<gt> =back -=over +=over 4 =item C<contains_pod( $file , $verbose )> =back -=over +=over 4 =item AUTHOR @@ -11251,7 +11525,7 @@ C<-inc =E<gt> 1>, C<-dirs =E<gt> [ $dir1, $dir2, ... ]>, C<-verbose =E<gt> =head2 Pod::Html - module to convert pod files to HTML -=over +=over 4 =item SYNOPSIS @@ -11278,7 +11552,7 @@ verbose =head2 Pod::InputObjects - objects representing POD input paragraphs, commands, etc. -=over +=over 4 =item SYNOPSIS @@ -11293,211 +11567,211 @@ 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 Pod::Paragraph-E<gt>B<new()> =back -=over +=over 4 =item $pod_para-E<gt>B<cmd_name()> =back -=over +=over 4 =item $pod_para-E<gt>B<text()> =back -=over +=over 4 =item $pod_para-E<gt>B<raw_text()> =back -=over +=over 4 =item $pod_para-E<gt>B<cmd_prefix()> =back -=over +=over 4 =item $pod_para-E<gt>B<cmd_separator()> =back -=over +=over 4 =item $pod_para-E<gt>B<parse_tree()> =back -=over +=over 4 =item $pod_para-E<gt>B<file_line()> =back -=over +=over 4 =item B<Pod::InteriorSequence> =back -=over +=over 4 =item Pod::InteriorSequence-E<gt>B<new()> =back -=over +=over 4 =item $pod_seq-E<gt>B<cmd_name()> =back -=over +=over 4 =item $pod_seq-E<gt>B<prepend()> =back -=over +=over 4 =item $pod_seq-E<gt>B<append()> =back -=over +=over 4 =item $pod_seq-E<gt>B<nested()> =back -=over +=over 4 =item $pod_seq-E<gt>B<raw_text()> =back -=over +=over 4 =item $pod_seq-E<gt>B<left_delimiter()> =back -=over +=over 4 =item $pod_seq-E<gt>B<right_delimiter()> =back -=over +=over 4 =item $pod_seq-E<gt>B<parse_tree()> =back -=over +=over 4 =item $pod_seq-E<gt>B<file_line()> =back -=over +=over 4 =item Pod::InteriorSequence::B<DESTROY()> =back -=over +=over 4 =item B<Pod::ParseTree> =back -=over +=over 4 =item Pod::ParseTree-E<gt>B<new()> =back -=over +=over 4 =item $ptree-E<gt>B<top()> =back -=over +=over 4 =item $ptree-E<gt>B<children()> =back -=over +=over 4 =item $ptree-E<gt>B<prepend()> =back -=over +=over 4 =item $ptree-E<gt>B<append()> =back -=over +=over 4 =item $ptree-E<gt>B<raw_text()> =back -=over +=over 4 =item Pod::ParseTree::B<DESTROY()> =back -=over +=over 4 =item SEE ALSO @@ -11507,7 +11781,7 @@ B<Pod::InteriorSequence>, package B<Pod::ParseTree> =head2 Pod::LaTeX - Convert Pod data to formatted Latex -=over +=over 4 =item SYNOPSIS @@ -11515,7 +11789,7 @@ B<Pod::InteriorSequence>, package B<Pod::ParseTree> =back -=over +=over 4 =item OBJECT METHODS @@ -11523,7 +11797,7 @@ C<initialize> =back -=over +=over 4 =item Data Accessors @@ -11555,7 +11829,7 @@ B<UserPostamble> B<Lists> -=over +=over 4 =item Subclassed methods @@ -11573,7 +11847,7 @@ B<textblock> B<interior_sequence> -=over +=over 4 =item List Methods @@ -11585,7 +11859,7 @@ B<end_list> B<add_item> -=over +=over 4 =item Methods for headings @@ -11593,7 +11867,7 @@ B<head> =back -=over +=over 4 =item Internal methods @@ -11609,7 +11883,7 @@ B<_create_index> B<_clean_latex_commands> -=over +=over 4 =item NOTES @@ -11625,7 +11899,7 @@ B<_clean_latex_commands> =head2 Pod::Man - Convert POD data to formatted *roff input -=over +=over 4 =item SYNOPSIS @@ -11651,7 +11925,7 @@ line %d, Unmatched =back =head2 Pod::ParseUtils - helpers for POD parsing and conversion -=over +=over 4 =item SYNOPSIS @@ -11659,7 +11933,7 @@ line %d, Unmatched =back =back -=over +=over 4 =item Pod::List @@ -11683,7 +11957,7 @@ $list-E<gt>parent() $list-E<gt>tag() -=over +=over 4 =item Pod::Hyperlink @@ -11711,7 +11985,7 @@ $link-E<gt>type() $link-E<gt>link() -=over +=over 4 =item Pod::Cache @@ -11723,7 +11997,7 @@ $cache-E<gt>item() $cache-E<gt>find_page($name) -=over +=over 4 =item Pod::Cache::Item @@ -11745,7 +12019,7 @@ $cacheitem-E<gt>find_node($name) $cacheitem-E<gt>idx() -=over +=over 4 =item AUTHOR @@ -11755,7 +12029,7 @@ $cacheitem-E<gt>idx() =head2 Pod::Parser - base class for creating POD filters and translators -=over +=over 4 =item SYNOPSIS @@ -11774,13 +12048,13 @@ B<-warnings> (default: unset) =back -=over +=over 4 =item RECOMMENDED SUBROUTINE/METHOD OVERRIDES =back -=over +=over 4 =item B<command()> @@ -11788,7 +12062,7 @@ C<$cmd>, C<$text>, C<$line_num>, C<$pod_para> =back -=over +=over 4 =item B<verbatim()> @@ -11796,7 +12070,7 @@ C<$text>, C<$line_num>, C<$pod_para> =back -=over +=over 4 =item B<textblock()> @@ -11804,73 +12078,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()> @@ -11880,109 +12154,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 @@ -11994,13 +12268,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 @@ -12015,7 +12289,7 @@ I<code-ref>|I<method-name> =head2 Pod::Select, podselect() - extract selected sections of POD from input -=over +=over 4 =item SYNOPSIS @@ -12031,55 +12305,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()> @@ -12087,31 +12361,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 @@ -12121,7 +12395,7 @@ B<-output>, B<-sections>, B<-ranges> =head2 Pod::Text - Convert POD data to formatted ASCII text -=over +=over 4 =item SYNOPSIS @@ -12147,7 +12421,24 @@ specification "%s", %s:%d: Unknown command paragraph "%s", Unknown escape: =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 @@ -12164,7 +12455,7 @@ specification "%s", %s:%d: Unknown command paragraph "%s", Unknown escape: =head2 Pod::Text::Termcap, Pod::Text::Color - Convert POD data to ASCII text with format escapes -=over +=over 4 =item SYNOPSIS @@ -12179,7 +12470,7 @@ text with format escapes =head2 Pod::Usage, pod2usage() - print a usage message from embedded pod documentation -=over +=over 4 =item SYNOPSIS @@ -12192,7 +12483,7 @@ C<-pathlist> =item EXAMPLES -=over +=over 4 =item Recommended Use @@ -12208,7 +12499,7 @@ C<-pathlist> =head2 SDBM_File - Tied access to sdbm files -=over +=over 4 =item SYNOPSIS @@ -12218,7 +12509,7 @@ C<O_RDONLY>, C<O_WRONLY>, C<O_RDWR> =item DIAGNOSTICS -=over +=over 4 =item C<sdbm store returned -1, errno 22, key "..." at ...> @@ -12230,7 +12521,7 @@ C<O_RDONLY>, C<O_WRONLY>, C<O_RDWR> =head2 Safe - Compile and execute code in restricted compartments -=over +=over 4 =item SYNOPSIS @@ -12240,7 +12531,7 @@ a new namespace, an operator mask =item WARNING -=over +=over 4 =item RECENT CHANGES @@ -12263,7 +12554,7 @@ Memory, CPU, Snooping, Signals, State Changes =head2 Search::Dict, look - search for key in dictionary file -=over +=over 4 =item SYNOPSIS @@ -12273,7 +12564,7 @@ Memory, CPU, Snooping, Signals, State Changes =head2 SelectSaver - save and restore selected file handle -=over +=over 4 =item SYNOPSIS @@ -12283,13 +12574,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 @@ -12311,13 +12602,13 @@ Memory, CPU, Snooping, Signals, State Changes =head2 Shell - run shell commands transparently within perl -=over +=over 4 =item SYNOPSIS =item DESCRIPTION -=over +=over 4 =item OBJECT ORIENTED SYNTAX @@ -12330,7 +12621,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 @@ -12346,7 +12637,7 @@ pack_sockaddr_un PATH, unpack_sockaddr_un SOCKADDR_UN =head2 Storable - persistency for perl data structures -=over +=over 4 =item SYNOPSIS @@ -12364,7 +12655,7 @@ pack_sockaddr_un PATH, unpack_sockaddr_un SOCKADDR_UN =item WIZARDS ONLY -=over +=over 4 =item Hooks @@ -12400,7 +12691,7 @@ C<Storable::is_retrieving> =head2 Symbol - manipulate Perl symbols and their names -=over +=over 4 =item SYNOPSIS @@ -12410,7 +12701,7 @@ C<Storable::is_retrieving> =head2 Sys::Hostname - Try every conceivable way to get hostname -=over +=over 4 =item SYNOPSIS @@ -12423,7 +12714,7 @@ C<Storable::is_retrieving> =head2 Syslog, Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls -=over +=over 4 =item SYNOPSIS @@ -12444,7 +12735,7 @@ closelog =head2 Syslog::Syslog, Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls -=over +=over 4 =item SYNOPSIS @@ -12464,7 +12755,7 @@ closelog =head2 Term::ANSIColor - Color screen output using ANSI escape sequences -=over +=over 4 =item SYNOPSIS @@ -12486,7 +12777,7 @@ subs" in use =head2 Term::Cap - Perl termcap interface -=over +=over 4 =item SYNOPSIS @@ -12498,7 +12789,7 @@ subs" in use =head2 Term::Complete - Perl word completion module -=over +=over 4 =item SYNOPSIS @@ -12517,7 +12808,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 @@ -12540,7 +12831,7 @@ C<tkRunning>, C<ornaments>, C<newTTY> =head2 Test - provides a simple framework for writing test scripts -=over +=over 4 =item SYNOPSIS @@ -12562,13 +12853,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 @@ -12581,7 +12872,7 @@ NORMAL TESTS, SKIPPED TESTS, TODO TESTS C<All tests successful.\nFiles=%d, Tests=%d, %s>, C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>, C<Test returned status %d (wstat %d)>, C<Failed 1 test, %.2f%% okay. %s>, C<Failed %d/%d tests, %.2f%% okay. -%s> +%s>, C<FAILED--Further testing stopped%s> =item ENVIRONMENT @@ -12595,7 +12886,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 @@ -12608,7 +12899,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 @@ -12616,12 +12907,6 @@ arrays =item EXAMPLES -0 a simple word, 1 multiple spaces are skipped because of our $delim, 2 use -of quotes to include a space in a word, 3 use of a backslash to include a -space in a word, 4 use of a backslash to remove the special meaning of a -double-quote, 5 another simple word (note the lack of effect of the -backslashed double-quote) - =item AUTHORS =back @@ -12629,7 +12914,7 @@ backslashed double-quote) =head2 Text::Soundex - Implementation of the Soundex Algorithm as Described by Knuth -=over +=over 4 =item SYNOPSIS @@ -12646,7 +12931,7 @@ by Knuth =head2 Text::Tabs -- expand and unexpand tabs per the unix expand(1) and unexpand(1) -=over +=over 4 =item SYNOPSIS @@ -12660,7 +12945,7 @@ unexpand(1) =head2 Text::Wrap - line wrapping to form simple paragraphs -=over +=over 4 =item SYNOPSIS @@ -12675,7 +12960,7 @@ unexpand(1) =head2 Thread - manipulate threads in Perl (EXPERIMENTAL, subject to change) -=over +=over 4 =item SYNOPSIS @@ -12689,7 +12974,7 @@ cond_broadcast VARIABLE, yield =item METHODS -join, eval, detach, equal, tid +join, eval, detach, equal, tid, flags, done =item LIMITATIONS @@ -12699,7 +12984,7 @@ join, eval, detach, equal, tid =head2 Thread::Queue - thread-safe queues -=over +=over 4 =item SYNOPSIS @@ -12715,7 +13000,7 @@ new, enqueue LIST, dequeue, dequeue_nb, pending =head2 Thread::Semaphore - thread-safe semaphores -=over +=over 4 =item SYNOPSIS @@ -12729,7 +13014,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 @@ -12741,7 +13026,7 @@ new, new NUMBER, down, down NUMBER, up, up NUMBER =head2 Thread::Specific - thread-specific keys -=over +=over 4 =item SYNOPSIS @@ -12751,7 +13036,7 @@ new, new NUMBER, down, down NUMBER, up, up NUMBER =head2 Tie::Array - base class for tied arrays -=over +=over 4 =item SYNOPSIS @@ -12771,7 +13056,7 @@ SHIFT this, UNSHIFT this, LIST, SPLICE this, offset, length, LIST =head2 Tie::Handle, Tie::StdHandle - base class definitions for tied handles -=over +=over 4 =item SYNOPSIS @@ -12790,7 +13075,7 @@ EOF this, TELL this, SEEK this, offset, whence, DESTROY this =head2 Tie::Hash, Tie::StdHash - base class definitions for tied hashes -=over +=over 4 =item SYNOPSIS @@ -12807,7 +13092,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 @@ -12826,7 +13111,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 @@ -12840,7 +13125,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 @@ -12852,7 +13137,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 @@ -12867,7 +13152,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 @@ -12882,7 +13167,7 @@ function =head2 Time::localtime - by-name interface to Perl's built-in localtime() function -=over +=over 4 =item SYNOPSIS @@ -12896,7 +13181,7 @@ function =head2 Time::tm - internal object used by Time::gmtime and Time::localtime -=over +=over 4 =item SYNOPSIS @@ -12908,7 +13193,7 @@ function =head2 UNIVERSAL - base class for ALL classes (blessed references) -=over +=over 4 =item SYNOPSIS @@ -12922,7 +13207,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 @@ -12937,13 +13222,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 @@ -12961,11 +13246,11 @@ March 18th, 2000 =head2 Win32 - Interfaces to some Win32 API Functions -=over +=over 4 =item DESCRIPTION -=over +=over 4 =item Alphabetical Listing of Win32 Functions @@ -12977,8 +13262,7 @@ 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(MACHINE, -MESSAGE, TIMEOUT, FORCECLOSE, REBOOT), Win32::IsWinNT(), Win32::IsWin95(), +PROCNAME), Win32::GetTickCount(), Win32::IsWinNT(), Win32::IsWin95(), Win32::LoadLibrary(LIBNAME), Win32::LoginName(), Win32::LookupAccountName(SYSTEM, ACCOUNT, DOMAIN, SID, SIDTYPE), Win32::LookupAccountSID(SYSTEM, SID, ACCOUNT, DOMAIN, SIDTYPE), @@ -12993,7 +13277,7 @@ PID), Win32::UnregisterServer(LIBRARYNAME) =head2 XSLoader - Dynamically load C libraries into Perl code -=over +=over 4 =item SYNOPSIS @@ -13008,7 +13292,7 @@ PID), Win32::UnregisterServer(LIBRARYNAME) 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/pod/perltodo.pod b/pod/perltodo.pod index f12b10f4b9..f38ba88bf3 100644 --- a/pod/perltodo.pod +++ b/pod/perltodo.pod @@ -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 @@ -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 diff --git a/pod/perltoot.pod b/pod/perltoot.pod index 31a7c76353..594cb99daa 100644 --- a/pod/perltoot.pod +++ b/pod/perltoot.pod @@ -1700,7 +1700,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 +1727,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. diff --git a/pod/perltootc.pod b/pod/perltootc.pod index 0bcb638a50..ee0bd02f62 100644 --- a/pod/perltootc.pod +++ b/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 * diff --git a/pod/perlunicode.pod b/pod/perlunicode.pod index c9954d8e96..30a4482260 100644 --- a/pod/perlunicode.pod +++ b/pod/perlunicode.pod @@ -10,7 +10,7 @@ WARNING: The implementation of Unicode support in Perl is incomplete. The following areas need further work. -=over +=over 4 =item Input and Output Disciplines @@ -198,6 +198,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/pod/perlvar.pod b/pod/perlvar.pod index 83f4d9cd9e..49cdcb273e 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -619,7 +619,8 @@ across fork() calls. (Mnemonic: same as shells.) =item $< The real uid of this process. (Mnemonic: it's the uid you came I<from>, -if you're running setuid.) +if you're running setuid.) You can change both the real uid and +the effective uid at the same time by using POSIX::setuid(). =item $EFFECTIVE_USER_ID @@ -632,6 +633,9 @@ The effective uid of this process. Example: $< = $>; # set real to effective uid ($<,$>) = ($>,$<); # swap real and effective uid +You can change both the effective uid and the real uid at the same +time by using POSIX::setuid(). + (Mnemonic: it's the uid you went I<to>, if you're running setuid.) C<< $< >> and C<< $> >> can be swapped only on machines supporting setreuid(). @@ -652,6 +656,9 @@ However, a value assigned to C<$(> must be a single number used to set the real gid. So the value given by C<$(> should I<not> be assigned back to C<$(> without being forced numeric, such as by adding zero. +You can change both the real gid and the effective gid at the same +time by using POSIX::setgid(). + (Mnemonic: parentheses are used to I<group> things. The real gid is the group you I<left>, if you're running setgid.) @@ -674,6 +681,9 @@ empty list for setgroups(), just repeat the new effective gid; that is, to force an effective gid of 5 and an effectively empty setgroups() list, say C< $) = "5 5" >. +You can change both the effective gid and the real gid at the same +time by using POSIX::setgid() (use only a single numeric argument). + (Mnemonic: parentheses are used to I<group> things. The effective gid is the group that's I<right> for you, if you're running setgid.) diff --git a/pod/perlxs.pod b/pod/perlxs.pod index 781afe60bf..a4db596755 100644 --- a/pod/perlxs.pod +++ b/pod/perlxs.pod @@ -66,7 +66,9 @@ 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. @@ -207,9 +209,9 @@ separate lines and should be flush left-adjusted. double x sin(x) double x -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. +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 @@ -276,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. @@ -754,29 +754,37 @@ 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 Keywords +=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> keywords. C<IN> keyword is a default, -the other two keywords indicate how the Perl interface should differ from -the C interface. - -Parameters preceded by C<OUTLIST>/C<IN_OUTLIST> keywords are considered to -be used by the C subroutine I<via pointers>. C<OUTLIST> keyword indicates -that the C subroutine does not inspect the memory pointed by this parameter, -but will write through this pointer to provide additional return values. -Such parameters do not appear in the usage signature of the generated Perl -function. - -Parameters preceded by C<IN_OUTLIST> I<do> appear as parameters to the -Perl function. 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 +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_INIT Keyword> was used) followed by all the C<OUTLIST> -and C<IN_OUTLIST> parameters (in the order of appearence). Say, an XSUB +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) @@ -792,17 +800,30 @@ 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> keywords can be mixed with ANSI-style -declarations, as in +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_OUTLIST> parameters are somewhat similar to parameters introduced -with L<The & Unary Operator> and put into the C<OUTPUT:> section (see -L<The OUTPUT: Keyword>). Say, the same C function can be interfaced with as +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) @@ -1347,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:, 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. +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 @@ -1613,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 diff --git a/pod/perlxstut.pod b/pod/perlxstut.pod index 347b46e4f5..5b7ed6da34 100644 --- a/pod/perlxstut.pod +++ b/pod/perlxstut.pod @@ -682,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 diff --git a/pod/pod2man.PL b/pod/pod2man.PL index 4c5831b90b..f320a3c295 100644 --- a/pod/pod2man.PL +++ b/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.3 2000/09/03 09:20:52 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> # @@ -72,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 @@ -88,7 +93,7 @@ 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>] -[B<--quotes>=I<quotes>] [I<input> [I<output>]] +[B<--quotes>=I<quotes>] [I<input> [I<output>] ...] pod2man B<--help> @@ -101,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 diff --git a/pod/pod2text.PL b/pod/pod2text.PL index b4965cb00f..7b5727decc 100644 --- a/pod/pod2text.PL +++ b/pod/pod2text.PL @@ -75,8 +75,8 @@ my %options; $options{sentence} = 0; Getopt::Long::config ('bundling'); GetOptions (\%options, 'alt|a', 'color|c', 'help|h', 'indent|i=i', - 'loose|l', 'quotes|q=s', '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. @@ -89,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); @@ -104,7 +107,7 @@ pod2text - Convert POD data to formatted ASCII text =head1 SYNOPSIS -pod2text [B<-aclst>] [B<-i> I<indent>] [B<-q> I<quotes>] [B<-w> I<width>] +pod2text [B<-aclost>] [B<-i> I<indent>] [B<-q> I<quotes>] [B<-w> I<width>] [I<input> [I<output>]] pod2text B<-h> @@ -150,6 +153,13 @@ 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 @@ -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 @@ -178,7 +174,7 @@ PP(pp_padany) PP(pp_rv2gv) { - djSP; dTOPss; + djSP; dTOPss; if (SvROK(sv)) { wasref: @@ -206,9 +202,9 @@ PP(pp_rv2gv) goto wasref; } if (!SvOK(sv) && sv != &PL_sv_undef) { - /* If this is a 'my' scalar and flag is set then vivify + /* If this is a 'my' scalar and flag is set then vivify * NI-S 1999/05/07 - */ + */ if (PL_op->op_private & OPpDEREF) { char *name; GV *gv; @@ -223,7 +219,8 @@ PP(pp_rv2gv) name = CopSTASHPV(PL_curcop); gv = newGVgen(name); } - sv_upgrade(sv, SVt_RV); + if (SvTYPE(sv) < SVt_RV) + sv_upgrade(sv, SVt_RV); SvRV(sv) = (SV*)gv; SvROK_on(sv); SvSETMAGIC(sv); @@ -388,8 +385,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; @@ -410,7 +411,7 @@ PP(pp_prototype) char *s = SvPVX(TOPs); if (strnEQ(s, "CORE::", 6)) { int code; - + code = keyword(s + 6, SvCUR(TOPs) - 6); if (code < 0) { /* Overridable. */ #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2) @@ -430,13 +431,13 @@ PP(pp_prototype) found: oa = PL_opargs[i] >> OASHIFT; while (oa) { - if (oa & OA_OPTIONAL) { + if (oa & OA_OPTIONAL && !seen_question) { seen_question = 1; str[n++] = ';'; } - else if (n && str[0] == ';' && seen_question) + else if (n && str[0] == ';' && seen_question) goto set; /* XXXX system, exec */ - if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF + if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) { str[n++] = '\\'; } @@ -567,7 +568,7 @@ PP(pp_bless) Perl_croak(aTHX_ "Attempt to bless into a reference"); ptr = SvPV(ssv,len); if (ckWARN(WARN_MISC) && len == 0) - Perl_warner(aTHX_ WARN_MISC, + Perl_warner(aTHX_ WARN_MISC, "Explicit blessing to '' (assuming package main)"); stash = gv_stashpvn(ptr, len, TRUE); } @@ -584,7 +585,7 @@ PP(pp_gelem) char *elem; djSP; STRLEN n_a; - + sv = POPs; elem = SvPV(sv, n_a); gv = (GV*)POPs; @@ -928,6 +929,114 @@ PP(pp_pow) PP(pp_multiply) { djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + /* Unless the left argument is integer in range we are going to have to + use NV maths. Hence only attempt to coerce the right argument if + we know the left is integer. */ + /* Left operand is defined, so is it IV? */ + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + const UV topmask = (~ (UV)0) << (4 * sizeof (UV)); + const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV))); + UV alow; + UV ahigh; + UV blow; + UV bhigh; + + if (auvok) { + alow = SvUVX(TOPm1s); + } else { + IV aiv = SvIVX(TOPm1s); + if (aiv >= 0) { + alow = aiv; + auvok = TRUE; /* effectively it's a UV now */ + } else { + alow = -aiv; /* abs, auvok == false records sign */ + } + } + if (buvok) { + blow = SvUVX(TOPs); + } else { + IV biv = SvIVX(TOPs); + if (biv >= 0) { + blow = biv; + buvok = TRUE; /* effectively it's a UV now */ + } else { + blow = -biv; /* abs, buvok == false records sign */ + } + } + + /* If this does sign extension on unsigned it's time for plan B */ + ahigh = alow >> (4 * sizeof (UV)); + alow &= botmask; + bhigh = blow >> (4 * sizeof (UV)); + blow &= botmask; + if (ahigh && bhigh) { + /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000 + which is overflow. Drop to NVs below. */ + } else if (!ahigh && !bhigh) { + /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001 + so the unsigned multiply cannot overflow. */ + UV product = alow * blow; + if (auvok == buvok) { + /* -ve * -ve or +ve * +ve gives a +ve result. */ + SP--; + SETu( product ); + RETURN; + } else if (product <= (UV)IV_MIN) { + /* 2s complement assumption that (UV)-IV_MIN is correct. */ + /* -ve result, which could overflow an IV */ + SP--; + SETi( -product ); + RETURN; + } /* else drop to NVs below. */ + } else { + /* One operand is large, 1 small */ + UV product_middle; + if (bhigh) { + /* swap the operands */ + ahigh = bhigh; + bhigh = blow; /* bhigh now the temp var for the swap */ + blow = alow; + alow = bhigh; + } + /* now, ((ahigh * blow) << half_UV_len) + (alow * blow) + multiplies can't overflow. shift can, add can, -ve can. */ + product_middle = ahigh * blow; + if (!(product_middle & topmask)) { + /* OK, (ahigh * blow) won't lose bits when we shift it. */ + UV product_low; + product_middle <<= (4 * sizeof (UV)); + product_low = alow * blow; + + /* as for pp_add, UV + something mustn't get smaller. + IIRC ANSI mandates this wrapping *behaviour* for + unsigned whatever the actual representation*/ + product_low += product_middle; + if (product_low >= product_middle) { + /* didn't overflow */ + if (auvok == buvok) { + /* -ve * -ve or +ve * +ve gives a +ve result. */ + SP--; + SETu( product_low ); + RETURN; + } else if (product_low <= (UV)IV_MIN) { + /* 2s complement assumption again */ + /* -ve result, which could overflow an IV */ + SP--; + SETi( -product_low ); + RETURN; + } /* else drop to NVs below. */ + } + } /* product_middle too large */ + } /* ahigh && bhigh */ + } /* SvIOK(TOPm1s) */ + } /* SvIOK(TOPs) */ +#endif { dPOPTOPnnrl; SETn( left * right ); @@ -1119,11 +1228,146 @@ PP(pp_repeat) PP(pp_subtract) { - djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); + djSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN); + useleft = USE_LEFT(TOPm1s); +#ifdef PERL_PRESERVE_IVUV + /* We must see if we can perform the addition with integers if possible, + as the integer code detects overflow while the NV code doesn't. + If either argument hasn't had a numeric conversion yet attempt to get + the IV. It's important to do this now, rather than just assuming that + it's not IOK as a PV of "9223372036854775806" may not take well to NV + addition, and an SV which is NOK, NV=6.0 ought to be coerced to + integer in case the second argument is IV=9223372036854775806 + We can (now) rely on sv_2iv to do the right thing, only setting the + public IOK flag if the value in the NV (or PV) slot is truly integer. + + A side effect is that this also aggressively prefers integer maths over + fp maths for integer values. */ + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + /* Unless the left argument is integer in range we are going to have to + use NV maths. Hence only attempt to coerce the right argument if + we know the left is integer. */ + if (!useleft) { + /* left operand is undef, treat as zero. + 0 is identity. */ + if (SvUOK(TOPs)) { + dPOPuv; /* Scary macros. Lets put a sequence point (;) here */ + if (value <= (UV)IV_MIN) { + /* 2s complement assumption. */ + SETi(-(IV)value); + RETURN; + } /* else drop through into NVs below */ + } else { + dPOPiv; + SETu((UV)-value); + RETURN; + } + } else { + /* Left operand is defined, so is it IV? */ + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (!auvok && !buvok) { /* ## IV - IV ## */ + IV aiv = SvIVX(TOPm1s); + IV biv = SvIVX(TOPs); + IV result = aiv - biv; + + if (biv >= 0 ? (result < aiv) : (result >= aiv)) { + SP--; + SETi( result ); + RETURN; + } + /* +ve - +ve can't overflow. (worst case 0 - IV_MAX) */ + /* -ve - -ve can't overflow. (worst case -1 - IV_MIN) */ + /* -ve - +ve can only overflow too negative. */ + /* leaving +ve - -ve, which will go UV */ + if (aiv >= 0 && biv < 0) { /* assert don't need biv <0 */ + /* 2s complement assumption for IV_MIN */ + UV result = (UV)aiv + (UV)-biv; + /* UV + UV must get bigger. +ve IV + +ve IV +1 can't + overflow UV (2s complement assumption */ + assert (result >= (UV) aiv); + SP--; + SETu( result ); + RETURN; + } + /* Overflow, drop through to NVs */ + } else if (auvok && buvok) { /* ## UV - UV ## */ + UV auv = SvUVX(TOPm1s); + UV buv = SvUVX(TOPs); + IV result; + + if (auv >= buv) { + SP--; + SETu( auv - buv ); + RETURN; + } + /* Blatant 2s complement assumption. */ + result = (IV)(auv - buv); + if (result < 0) { + SP--; + SETi( result ); + RETURN; + } + /* Overflow on IV - IV, drop through to NVs */ + } else if (auvok) { /* ## Mixed UV - IV ## */ + UV auv = SvUVX(TOPm1s); + IV biv = SvIVX(TOPs); + + if (biv < 0) { + /* 2s complement assumptions for IV_MIN */ + UV result = auv + ((UV)-biv); + /* UV + UV can only get bigger... */ + if (result >= auv) { + SP--; + SETu( result ); + RETURN; + } + /* and if it gets too big for UV then it's NV time. */ + } else if (auv > (UV)IV_MAX) { + /* I think I'm making an implicit 2s complement + assumption that IV_MIN == -IV_MAX - 1 */ + /* biv is >= 0 */ + UV result = auv - (UV)biv; + assert (result <= auv); + SP--; + SETu( result ); + RETURN; + } else { + /* biv is >= 0 */ + IV result = (IV)auv - biv; + assert (result <= (IV)auv); + SP--; + SETi( result ); + RETURN; + } + } else { /* ## Mixed IV - UV ## */ + IV aiv = SvIVX(TOPm1s); + UV buv = SvUVX(TOPs); + IV result = aiv - (IV)buv; /* 2s complement assumption. */ + + /* result must not get larger. */ + if (result <= aiv) { + SP--; + SETi( result ); + RETURN; + } /* end of IV-IV / UV-UV / UV-IV / IV-UV */ + } + } + } + } +#endif { - dPOPTOPnnrl_ul; - SETn( left - right ); - RETURN; + dPOPnv; + if (!useleft) { + /* left operand is undef, treat as zero - value */ + SETn(-value); + RETURN; + } + SETn( TOPn - value ); + RETURN; } } @@ -1164,6 +1408,74 @@ PP(pp_right_shift) PP(pp_lt) { djSP; tryAMAGICbinSET(lt,0); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (!auvok && !buvok) { /* ## IV < IV ## */ + IV aiv = SvIVX(TOPm1s); + IV biv = SvIVX(TOPs); + + SP--; + SETs(boolSV(aiv < biv)); + RETURN; + } + if (auvok && buvok) { /* ## UV < UV ## */ + UV auv = SvUVX(TOPm1s); + UV buv = SvUVX(TOPs); + + SP--; + SETs(boolSV(auv < buv)); + RETURN; + } + if (auvok) { /* ## UV < IV ## */ + UV auv; + IV biv; + + biv = SvIVX(TOPs); + SP--; + if (biv < 0) { + /* As (a) is a UV, it's >=0, so it cannot be < */ + SETs(&PL_sv_no); + RETURN; + } + auv = SvUVX(TOPs); + if (auv >= (UV) IV_MAX) { + /* As (b) is an IV, it cannot be > IV_MAX */ + SETs(&PL_sv_no); + RETURN; + } + SETs(boolSV(auv < (UV)biv)); + RETURN; + } + { /* ## IV < UV ## */ + IV aiv; + UV buv; + + aiv = SvIVX(TOPm1s); + if (aiv < 0) { + /* As (b) is a UV, it's >=0, so it must be < */ + SP--; + SETs(&PL_sv_yes); + RETURN; + } + buv = SvUVX(TOPs); + SP--; + if (buv > (UV) IV_MAX) { + /* As (a) is an IV, it cannot be > IV_MAX */ + SETs(&PL_sv_yes); + RETURN; + } + SETs(boolSV((UV)aiv < buv)); + RETURN; + } + } + } +#endif { dPOPnv; SETs(boolSV(TOPn < value)); @@ -1174,6 +1486,74 @@ PP(pp_lt) PP(pp_gt) { djSP; tryAMAGICbinSET(gt,0); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (!auvok && !buvok) { /* ## IV > IV ## */ + IV aiv = SvIVX(TOPm1s); + IV biv = SvIVX(TOPs); + + SP--; + SETs(boolSV(aiv > biv)); + RETURN; + } + if (auvok && buvok) { /* ## UV > UV ## */ + UV auv = SvUVX(TOPm1s); + UV buv = SvUVX(TOPs); + + SP--; + SETs(boolSV(auv > buv)); + RETURN; + } + if (auvok) { /* ## UV > IV ## */ + UV auv; + IV biv; + + biv = SvIVX(TOPs); + SP--; + if (biv < 0) { + /* As (a) is a UV, it's >=0, so it must be > */ + SETs(&PL_sv_yes); + RETURN; + } + auv = SvUVX(TOPs); + if (auv > (UV) IV_MAX) { + /* As (b) is an IV, it cannot be > IV_MAX */ + SETs(&PL_sv_yes); + RETURN; + } + SETs(boolSV(auv > (UV)biv)); + RETURN; + } + { /* ## IV > UV ## */ + IV aiv; + UV buv; + + aiv = SvIVX(TOPm1s); + if (aiv < 0) { + /* As (b) is a UV, it's >=0, so it cannot be > */ + SP--; + SETs(&PL_sv_no); + RETURN; + } + buv = SvUVX(TOPs); + SP--; + if (buv >= (UV) IV_MAX) { + /* As (a) is an IV, it cannot be > IV_MAX */ + SETs(&PL_sv_no); + RETURN; + } + SETs(boolSV((UV)aiv > buv)); + RETURN; + } + } + } +#endif { dPOPnv; SETs(boolSV(TOPn > value)); @@ -1184,6 +1564,74 @@ PP(pp_gt) PP(pp_le) { djSP; tryAMAGICbinSET(le,0); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (!auvok && !buvok) { /* ## IV <= IV ## */ + IV aiv = SvIVX(TOPm1s); + IV biv = SvIVX(TOPs); + + SP--; + SETs(boolSV(aiv <= biv)); + RETURN; + } + if (auvok && buvok) { /* ## UV <= UV ## */ + UV auv = SvUVX(TOPm1s); + UV buv = SvUVX(TOPs); + + SP--; + SETs(boolSV(auv <= buv)); + RETURN; + } + if (auvok) { /* ## UV <= IV ## */ + UV auv; + IV biv; + + biv = SvIVX(TOPs); + SP--; + if (biv < 0) { + /* As (a) is a UV, it's >=0, so a cannot be <= */ + SETs(&PL_sv_no); + RETURN; + } + auv = SvUVX(TOPs); + if (auv > (UV) IV_MAX) { + /* As (b) is an IV, it cannot be > IV_MAX */ + SETs(&PL_sv_no); + RETURN; + } + SETs(boolSV(auv <= (UV)biv)); + RETURN; + } + { /* ## IV <= UV ## */ + IV aiv; + UV buv; + + aiv = SvIVX(TOPm1s); + if (aiv < 0) { + /* As (b) is a UV, it's >=0, so a must be <= */ + SP--; + SETs(&PL_sv_yes); + RETURN; + } + buv = SvUVX(TOPs); + SP--; + if (buv >= (UV) IV_MAX) { + /* As (a) is an IV, it cannot be > IV_MAX */ + SETs(&PL_sv_yes); + RETURN; + } + SETs(boolSV((UV)aiv <= buv)); + RETURN; + } + } + } +#endif { dPOPnv; SETs(boolSV(TOPn <= value)); @@ -1194,6 +1642,74 @@ PP(pp_le) PP(pp_ge) { djSP; tryAMAGICbinSET(ge,0); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (!auvok && !buvok) { /* ## IV >= IV ## */ + IV aiv = SvIVX(TOPm1s); + IV biv = SvIVX(TOPs); + + SP--; + SETs(boolSV(aiv >= biv)); + RETURN; + } + if (auvok && buvok) { /* ## UV >= UV ## */ + UV auv = SvUVX(TOPm1s); + UV buv = SvUVX(TOPs); + + SP--; + SETs(boolSV(auv >= buv)); + RETURN; + } + if (auvok) { /* ## UV >= IV ## */ + UV auv; + IV biv; + + biv = SvIVX(TOPs); + SP--; + if (biv < 0) { + /* As (a) is a UV, it's >=0, so it must be >= */ + SETs(&PL_sv_yes); + RETURN; + } + auv = SvUVX(TOPs); + if (auv >= (UV) IV_MAX) { + /* As (b) is an IV, it cannot be > IV_MAX */ + SETs(&PL_sv_yes); + RETURN; + } + SETs(boolSV(auv >= (UV)biv)); + RETURN; + } + { /* ## IV >= UV ## */ + IV aiv; + UV buv; + + aiv = SvIVX(TOPm1s); + if (aiv < 0) { + /* As (b) is a UV, it's >=0, so a cannot be >= */ + SP--; + SETs(&PL_sv_no); + RETURN; + } + buv = SvUVX(TOPs); + SP--; + if (buv > (UV) IV_MAX) { + /* As (a) is an IV, it cannot be > IV_MAX */ + SETs(&PL_sv_no); + RETURN; + } + SETs(boolSV((UV)aiv >= buv)); + RETURN; + } + } + } +#endif { dPOPnv; SETs(boolSV(TOPn >= value)); @@ -1204,6 +1720,66 @@ PP(pp_ge) PP(pp_ne) { djSP; tryAMAGICbinSET(ne,0); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (!auvok && !buvok) { /* ## IV <=> IV ## */ + IV aiv = SvIVX(TOPm1s); + IV biv = SvIVX(TOPs); + + SP--; + SETs(boolSV(aiv != biv)); + RETURN; + } + if (auvok && buvok) { /* ## UV != UV ## */ + UV auv = SvUVX(TOPm1s); + UV buv = SvUVX(TOPs); + + SP--; + SETs(boolSV(auv != buv)); + RETURN; + } + { /* ## Mixed IV,UV ## */ + IV iv; + UV uv; + + /* != is commutative so swap if needed (save code) */ + if (auvok) { + /* swap. top of stack (b) is the iv */ + iv = SvIVX(TOPs); + SP--; + if (iv < 0) { + /* As (a) is a UV, it's >0, so it cannot be == */ + SETs(&PL_sv_yes); + RETURN; + } + uv = SvUVX(TOPs); + } else { + iv = SvIVX(TOPm1s); + SP--; + if (iv < 0) { + /* As (b) is a UV, it's >0, so it cannot be == */ + SETs(&PL_sv_yes); + RETURN; + } + uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */ + } + /* we know iv is >= 0 */ + if (uv > (UV) IV_MAX) { + SETs(&PL_sv_yes); + RETURN; + } + SETs(boolSV((UV)iv != uv)); + RETURN; + } + } + } +#endif { dPOPnv; SETs(boolSV(TOPn != value)); @@ -1214,6 +1790,84 @@ PP(pp_ne) PP(pp_ncmp) { djSP; dTARGET; tryAMAGICbin(ncmp,0); +#ifdef PERL_PRESERVE_IVUV + /* Fortunately it seems NaN isn't IOK */ + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool leftuvok = SvUOK(TOPm1s); + bool rightuvok = SvUOK(TOPs); + I32 value; + if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */ + IV leftiv = SvIVX(TOPm1s); + IV rightiv = SvIVX(TOPs); + + if (leftiv > rightiv) + value = 1; + else if (leftiv < rightiv) + value = -1; + else + value = 0; + } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */ + UV leftuv = SvUVX(TOPm1s); + UV rightuv = SvUVX(TOPs); + + if (leftuv > rightuv) + value = 1; + else if (leftuv < rightuv) + value = -1; + else + value = 0; + } else if (leftuvok) { /* ## UV <=> IV ## */ + UV leftuv; + IV rightiv; + + rightiv = SvIVX(TOPs); + if (rightiv < 0) { + /* As (a) is a UV, it's >=0, so it cannot be < */ + value = 1; + } else { + leftuv = SvUVX(TOPm1s); + if (leftuv > (UV) IV_MAX) { + /* As (b) is an IV, it cannot be > IV_MAX */ + value = 1; + } else if (leftuv > (UV)rightiv) { + value = 1; + } else if (leftuv < (UV)rightiv) { + value = -1; + } else { + value = 0; + } + } + } else { /* ## IV <=> UV ## */ + IV leftiv; + UV rightuv; + + leftiv = SvIVX(TOPm1s); + if (leftiv < 0) { + /* As (b) is a UV, it's >=0, so it must be < */ + value = -1; + } else { + rightuv = SvUVX(TOPs); + if (rightuv > (UV) IV_MAX) { + /* As (a) is an IV, it cannot be > IV_MAX */ + value = -1; + } else if (leftiv > (UV)rightuv) { + value = 1; + } else if (leftiv < (UV)rightuv) { + value = -1; + } else { + value = 0; + } + } + } + SP--; + SETi(value); + RETURN; + } + } +#endif { dPOPTOPnnrl; I32 value; @@ -1400,11 +2054,15 @@ PP(pp_negate) djSP; dTARGET; tryAMAGICun(neg); { dTOPss; + int flags = SvFLAGS(sv); if (SvGMAGICAL(sv)) mg_get(sv); - if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) { + if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { + /* It's publicly an integer, or privately an integer-not-float */ + oops_its_an_int: if (SvIsUV(sv)) { if (SvIVX(sv) == IV_MIN) { + /* 2s complement assumption. */ SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */ RETURN; } @@ -1417,6 +2075,12 @@ PP(pp_negate) SETi(-SvIVX(sv)); RETURN; } +#ifdef PERL_PRESERVE_IVUV + else { + SETu((UV)IV_MIN); + RETURN; + } +#endif } if (SvNIOKp(sv)) SETn(-SvNV(sv)); @@ -1431,12 +2095,16 @@ 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); } - else - sv_setnv(TARG, -SvNV(sv)); + else { + SvIV_please(sv); + if (SvIOK(sv)) + goto oops_its_an_int; + sv_setnv(TARG, -SvNV(sv)); + } SETTARG; } else @@ -1476,31 +2144,50 @@ PP(pp_complement) tmps = (U8*)SvPV_force(TARG, len); anum = len; if (SvUTF8(TARG)) { - /* Calculate exact length, let's not estimate */ + /* Calculate exact length, let's not estimate. */ STRLEN targlen = 0; U8 *result; U8 *send; - I32 l; + STRLEN l; + UV nchar = 0; + UV nwide = 0; send = tmps + len; while (tmps < send) { - UV c = utf8_to_uv(tmps, &l); + UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV); tmps += UTF8SKIP(tmps); - targlen += UTF8LEN(~c); + targlen += UNISKIP(~c); + nchar++; + if (c > 0xff) + nwide++; } /* Now rewind strings and write them. */ tmps -= len; - Newz(0, result, targlen + 1, U8); - while (tmps < send) { - UV c = utf8_to_uv(tmps, &l); - tmps += UTF8SKIP(tmps); - result = uv_to_utf8(result,(UV)~c); + + 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); } - *result = '\0'; - result -= targlen; - sv_setpvn(TARG, (char*)result, targlen); - SvUTF8_on(TARG); Safefree(result); SETs(TARG); RETURN; @@ -1552,7 +2239,7 @@ PP(pp_i_divide) PP(pp_i_modulo) { - djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { dPOPTOPiirl; if (!right) @@ -1566,7 +2253,7 @@ PP(pp_i_add) { djSP; dATARGET; tryAMAGICbin(add,opASSIGN); { - dPOPTOPiirl; + dPOPTOPiirl_ul; SETi( left + right ); RETURN; } @@ -1576,7 +2263,7 @@ PP(pp_i_subtract) { djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { - dPOPTOPiirl; + dPOPTOPiirl_ul; SETi( left - right ); RETURN; } @@ -1776,7 +2463,6 @@ S_seed(pTHX) #define SEED_C3 269 #define SEED_C5 26107 - dTHR; #ifndef PERL_NO_DEV_RANDOM int fd; #endif @@ -1881,25 +2567,49 @@ PP(pp_int) { djSP; dTARGET; { - NV value = TOPn; - IV iv; - - if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) { - iv = SvIVX(TOPs); - SETi(iv); - } - else { - if (value >= 0.0) - (void)Perl_modf(value, &value); - else { - (void)Perl_modf(-value, &value); - value = -value; - } - iv = I_V(value); - if (iv == value) - SETi(iv); - else - SETn(value); + NV value; + IV iv = TOPi; /* attempt to convert to IV if possible. */ + /* XXX it's arguable that compiler casting to IV might be subtly + different from modf (for numbers inside (IV_MIN,UV_MAX)) in which + else preferring IV has introduced a subtle behaviour change bug. OTOH + relying on floating point to be accurate is a bug. */ + + if (SvIOK(TOPs)) { + if (SvIsUV(TOPs)) { + UV uv = TOPu; + SETu(uv); + } else + SETi(iv); + } else { + value = TOPn; + if (value >= 0.0) { + if (value < (NV)UV_MAX + 0.5) { + SETu(U_V(value)); + } else { +#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 { + if (value > (NV)IV_MIN - 0.5) { + SETi(I_V(value)); + } else { +#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 + SETn(value); + } + } } } RETURN; @@ -1909,18 +2619,30 @@ PP(pp_abs) { djSP; dTARGET; tryAMAGICun(abs); { - NV value = TOPn; - IV iv; - - if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) && - (iv = SvIVX(TOPs)) != IV_MIN) { - if (iv < 0) - iv = -iv; - SETi(iv); - } - else { + /* This will cache the NV value if string isn't actually integer */ + IV iv = TOPi; + + if (SvIOK(TOPs)) { + /* IVX is precise */ + if (SvIsUV(TOPs)) { + SETu(TOPu); /* force it to be numeric only */ + } else { + if (iv >= 0) { + SETi(iv); + } else { + if (iv != IV_MIN) { + SETi(-iv); + } else { + /* 2s complement assumption. Also, not really needed as + IV_MIN and -IV_MIN should both be %100...00 and NV-able */ + SETu(IV_MIN); + } + } + } + } else{ + NV value = TOPn; if (value < 0.0) - value = -value; + value = -value; SETn(value); } } @@ -1931,7 +2653,7 @@ PP(pp_hex) { djSP; dTARGET; char *tmps; - I32 argtype; + STRLEN argtype; STRLEN n_a; tmps = POPpx; @@ -1944,7 +2666,7 @@ PP(pp_oct) { djSP; dTARGET; NV value; - I32 argtype; + STRLEN argtype; char *tmps; STRLEN n_a; @@ -2220,17 +2942,11 @@ 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; + SV *argsv = POPs; + STRLEN len; + U8 *s = (U8*)SvPVx(argsv, len); - if ((*tmps & 0x80) && DO_UTF8(tmpsv)) - value = utf8_to_uv_chk(tmps, &retlen, 0); - else - value = (UV)(*tmps & 255); - XPUSHu(value); + XPUSHu(DO_UTF8(argsv) ? utf8_to_uv_simple(s, 0) : (*s & 0xff)); RETURN; } @@ -2242,7 +2958,8 @@ PP(pp_chr) (void)SvUPGRADE(TARG,SVt_PV); - if ((value > 255 && !IN_BYTE) || (value & 0x80 && PL_hints & HINT_UTF8) ) { + if ((value > 255 && !IN_BYTE) || + (UTF8_IS_CONTINUED(value) && (PL_hints & HINT_UTF8)) ) { SvGROW(TARG, UTF8_MAXLEN+1); tmps = SvPVX(TARG); tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value); @@ -2253,6 +2970,9 @@ PP(pp_chr) XPUSHs(TARG); RETURN; } + else { + SvUTF8_off(TARG); + } SvGROW(TARG,2); SvCUR_set(TARG, 1); @@ -2276,7 +2996,7 @@ PP(pp_crypt) sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); #endif #else - DIE(aTHX_ + DIE(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); #endif SETs(TARG); @@ -2290,11 +3010,11 @@ PP(pp_ucfirst) 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_chk(s, &ulen, 0); + UV uv = utf8_to_uv(s, slen, &ulen, 0); if (PL_op->op_private & OPpLOCALE) { TAINT; @@ -2349,11 +3069,11 @@ PP(pp_lcfirst) 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_chk(s, &ulen, 0); + UV uv = utf8_to_uv(s, slen, &ulen, 0); if (PL_op->op_private & OPpLOCALE) { TAINT; @@ -2410,7 +3130,7 @@ PP(pp_uc) if (DO_UTF8(sv)) { dTARGET; - I32 ulen; + STRLEN ulen; register U8 *d; U8 *send; @@ -2430,7 +3150,7 @@ PP(pp_uc) TAINT; SvTAINTED_on(TARG); while (s < send) { - d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv_chk(s, &ulen, 0))); + d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0))); s += ulen; } } @@ -2484,7 +3204,7 @@ PP(pp_lc) if (DO_UTF8(sv)) { dTARGET; - I32 ulen; + STRLEN ulen; register U8 *d; U8 *send; @@ -2504,7 +3224,7 @@ PP(pp_lc) TAINT; SvTAINTED_on(TARG); while (s < send) { - d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv_chk(s, &ulen, 0))); + d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0))); s += ulen; } } @@ -2565,7 +3285,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; @@ -2805,6 +3525,7 @@ PP(pp_hslice) while (++MARK <= SP) { SV *keysv = *MARK; SV **svp; + I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0); if (realhv) { HE *he = hv_fetch_ent(hv, keysv, lval, 0); svp = he ? &HeVAL(he) : 0; @@ -2817,8 +3538,15 @@ PP(pp_hslice) STRLEN n_a; DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); } - if (PL_op->op_private & OPpLVAL_INTRO) - save_helem(hv, keysv, svp); + if (PL_op->op_private & OPpLVAL_INTRO) { + if (preeminent) + save_helem(hv, keysv, svp); + else { + STRLEN keylen; + char *key = SvPV(keysv, keylen); + save_delete(hv, key, keylen); + } + } } *MARK = svp ? *svp : &PL_sv_undef; } @@ -2884,7 +3612,7 @@ PP(pp_lslice) ix = SvIVx(*lelem); if (ix < 0) ix += max; - else + else ix -= arybase; if (ix < 0 || ix >= max) *lelem = &PL_sv_undef; @@ -3251,20 +3979,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; @@ -3348,9 +4073,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 @@ -3646,7 +4371,9 @@ PP(pp_unpack) len = strend - s; if (checksum) { while (len-- > 0 && s < strend) { - auint = utf8_to_uv_chk((U8*)s, &along, 0); + STRLEN alen; + auint = utf8_to_uv((U8*)s, strend - s, &alen, 0); + along = alen; s += along; if (checksum > 32) cdouble += (NV)auint; @@ -3658,7 +4385,9 @@ PP(pp_unpack) EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0 && s < strend) { - auint = utf8_to_uv_chk((U8*)s, &along, 0); + 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); @@ -3899,7 +4628,6 @@ PP(pp_unpack) if (checksum) { #if LONGSIZE != SIZE32 if (natint) { - long along; while (len-- > 0) { COPYNN(s, &along, sizeof(long)); s += sizeof(long); @@ -3913,6 +4641,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) @@ -3931,7 +4662,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); @@ -3944,6 +4674,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) @@ -4065,7 +4798,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); @@ -4212,7 +4945,7 @@ PP(pp_unpack) */ if (PL_uudmap['M'] == 0) { int i; - + for (i = 0; i < sizeof(PL_uuemap); i += 1) PL_uudmap[(U8)PL_uuemap[i]] = i; /* @@ -4457,7 +5190,7 @@ PP(pp_pack) patcopy++; continue; } - if (datumtype == 'U' && pat == patcopy+1) + if (datumtype == 'U' && pat == patcopy+1) SvUTF8_on(cat); if (datumtype == '#') { while (pat < patend && *pat != '\n') @@ -4690,7 +5423,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)); } @@ -5007,16 +5740,17 @@ PP(pp_split) AV *ary; register IV limit = POPi; /* note, negative is forever */ SV *sv = POPs; - bool doutf8 = DO_UTF8(sv); 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; @@ -5034,7 +5768,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) && @@ -5110,7 +5844,7 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); - if (doutf8) + if (do_utf8) (void)SvUTF8_on(dstr); XPUSHs(dstr); @@ -5132,7 +5866,7 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); - if (doutf8) + if (do_utf8) (void)SvUTF8_on(dstr); XPUSHs(dstr); s = m; @@ -5145,7 +5879,7 @@ PP(pp_split) SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx); len = rx->minlen; - if (len == 1 && !tail) { + if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) { STRLEN n_a; char c = *SvPV(csv, n_a); while (--limit) { @@ -5157,12 +5891,15 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); - if (doutf8) + if (do_utf8) (void)SvUTF8_on(dstr); XPUSHs(dstr); /* The rx->minlen is in characters but we want to step * s ahead by bytes. */ - s = m + (doutf8 ? SvCUR(csv) : len); + if (do_utf8) + s = (char*)utf8_hop((U8*)m, len); + else + s = m + len; /* Fake \n at the end */ } } else { @@ -5176,19 +5913,22 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); - if (doutf8) + if (do_utf8) (void)SvUTF8_on(dstr); XPUSHs(dstr); /* The rx->minlen is in characters but we want to step * s ahead by bytes. */ - s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */ + 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 +/* && (!rx->check_substr || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend, 0, NULL)))) */ && CALLREGEXEC(aTHX_ rx, s, strend, orig, @@ -5207,7 +5947,7 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); - if (doutf8) + if (do_utf8) (void)SvUTF8_on(dstr); XPUSHs(dstr); if (rx->nparens) { @@ -5222,7 +5962,7 @@ PP(pp_split) dstr = NEWSV(33, 0); if (make_mortal) sv_2mortal(dstr); - if (doutf8) + if (do_utf8) (void)SvUTF8_on(dstr); XPUSHs(dstr); } @@ -5243,7 +5983,7 @@ PP(pp_split) sv_setpvn(dstr, s, l); if (make_mortal) sv_2mortal(dstr); - if (doutf8) + if (do_utf8) (void)SvUTF8_on(dstr); XPUSHs(dstr); iters++; @@ -5301,7 +6041,6 @@ PP(pp_split) void Perl_unlock_condpair(pTHX_ void *svv) { - dTHR; MAGIC *mg = mg_find((SV*)svv, 'm'); if (!mg) @@ -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. @@ -33,6 +33,13 @@ L<perlcall>. Declares a local copy of perl's stack pointer for the XSUB, available via the C<SP> macro. See C<SP>. +=for apidoc ms||djSP + +Declare Just C<SP>. This is actually identical to C<dSP>, and declares +a local copy of perl's stack pointer, available via the C<SP> macro. +See C<SP>. (Available for backward source code compatibility with the +old (Perl 5.005) thread model.) + =for apidoc Ams||dMARK Declare a stack marker variable, C<mark>, for the XSUB. See C<MARK> and C<dORIGMARK>. @@ -46,8 +53,7 @@ The original stack mark for the XSUB. See C<dORIGMARK>. =for apidoc Ams||SPAGAIN Refetch the stack pointer. Used after a callback. See L<perlcall>. -=cut -*/ +=cut */ #define SP sp #define MARK mark @@ -61,7 +67,7 @@ Refetch the stack pointer. Used after a callback. See L<perlcall>. #define POPMARK (*PL_markstack_ptr--) #define djSP register SV **sp = PL_stack_sp -#define dSP dTHR; djSP +#define dSP djSP #define dMARK register SV **mark = PL_stack_base + POPMARK #define dORIGMARK I32 origmark = mark - PL_stack_base #define SETORIGMARK origmark = mark - PL_stack_base @@ -126,6 +132,7 @@ Pops a long off the stack. #endif #define TOPs (*sp) +#define TOPm1s (*(sp-1)) #define TOPp (SvPV(TOPs, PL_na)) /* deprecated */ #define TOPpx (SvPV(TOPs, n_a)) #define TOPn (SvNV(TOPs)) @@ -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. @@ -115,7 +115,9 @@ PP(pp_regcomp) pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ if (DO_UTF8(tmpstr)) - pm->op_pmdynflags |= PMdf_UTF8; + pm->op_pmdynflags |= PMdf_DYN_UTF8; + else + pm->op_pmdynflags &= ~PMdf_DYN_UTF8; pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm); PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed inside tie/overload accessors. */ @@ -157,7 +159,7 @@ PP(pp_substcont) register char *m = cx->sb_m; char *orig = cx->sb_orig; register REGEXP *rx = cx->sb_rx; - + rxres_restore(&cx->sb_rxres, rx); if (cx->sb_iters++) { @@ -176,8 +178,8 @@ PP(pp_substcont) : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST)))) { SV *targ = cx->sb_targ; - sv_catpvn(dstr, s, cx->sb_strend - s); + sv_catpvn(dstr, s, cx->sb_strend - s); cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); (void)SvOOK_off(targ); @@ -185,13 +187,15 @@ PP(pp_substcont) SvPVX(targ) = SvPVX(dstr); SvCUR_set(targ, SvCUR(dstr)); SvLEN_set(targ, SvLEN(dstr)); + if (DO_UTF8(dstr)) + SvUTF8_on(targ); SvPVX(dstr) = 0; sv_free(dstr); TAINT_IF(cx->sb_rxtainted & 1); PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); - (void)SvPOK_only(targ); + (void)SvPOK_only_UTF8(targ); TAINT_IF(cx->sb_rxtainted); SvSETMAGIC(targ); SvTAINT(targ); @@ -209,8 +213,24 @@ PP(pp_substcont) cx->sb_strend = s + (cx->sb_strend - m); } cx->sb_m = m = rx->startp[0] + orig; - sv_catpvn(dstr, s, m-s); + if (m > s) + 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); @@ -342,6 +362,7 @@ PP(pp_formline) case FF_MORE: name = "MORE"; break; case FF_LINEMARK: name = "LINEMARK"; break; case FF_END: name = "END"; break; + case FF_0DECIMAL: name = "0DECIMAL"; break; } if (arg >= 0) PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg); @@ -524,7 +545,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++; @@ -620,6 +641,43 @@ PP(pp_formline) t += fieldsize; break; + case FF_0DECIMAL: + /* If the field is marked with ^ and the value is undefined, + blank it out. */ + arg = *fpc++; + if ((arg & 512) && !SvOK(sv)) { + arg = fieldsize; + while (arg--) + *t++ = ' '; + break; + } + gotsome = TRUE; + value = SvNV(sv); + /* Formats aren't yet marked for locales, so assume "yes". */ + { + STORE_NUMERIC_STANDARD_SET_LOCAL(); +#if defined(USE_LONG_DOUBLE) + if (arg & 256) { + sprintf(t, "%#0*.*" PERL_PRIfldbl, + (int) fieldsize, (int) arg & 255, value); +/* is this legal? I don't have long doubles */ + } else { + sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value); + } +#else + if (arg & 256) { + sprintf(t, "%#0*.*f", + (int) fieldsize, (int) arg & 255, value); + } else { + sprintf(t, "%0*.0f", + (int) fieldsize, value); + } +#endif + RESTORE_NUMERIC_STANDARD(); + } + t += fieldsize; + break; + case FF_NEWLINE: f++; while (t-- > linemark && *t == ' ') ; @@ -729,7 +787,7 @@ PP(pp_mapwhile) I32 count; I32 shift; SV** src; - SV** dst; + SV** dst; /* first, move source pointer to the next item in the source list */ ++PL_markstack_ptr[-1]; @@ -761,7 +819,7 @@ PP(pp_mapwhile) * irrelevant. --jhi */ if (shift < count) shift = count; /* Avoid shifting too often --Ben Tilly */ - + EXTEND(SP,shift); src = SP; dst = (SP += shift); @@ -771,9 +829,9 @@ PP(pp_mapwhile) *dst-- = *src--; } /* copy the new items down to the destination list */ - dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; + dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; while (items--) - *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); + *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); } LEAVE; /* exit inner scope */ @@ -1107,7 +1165,6 @@ PP(pp_flop) STATIC I32 S_dopoptolabel(pTHX_ char *label) { - dTHR; register I32 i; register PERL_CONTEXT *cx; @@ -1116,27 +1173,27 @@ S_dopoptolabel(pTHX_ char *label) switch (CxTYPE(cx)) { case CXt_SUBST: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", PL_op_name[PL_op->op_type]); break; case CXt_SUB: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", PL_op_name[PL_op->op_type]); break; case CXt_FORMAT: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", PL_op_name[PL_op->op_type]); break; case CXt_EVAL: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", PL_op_name[PL_op->op_type]); break; case CXt_NULL: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", PL_op_name[PL_op->op_type]); return -1; case CXt_LOOP: @@ -1163,7 +1220,6 @@ Perl_dowantarray(pTHX) I32 Perl_block_gimme(pTHX) { - dTHR; I32 cxix; cxix = dopoptosub(cxstack_ix); @@ -1187,14 +1243,12 @@ Perl_block_gimme(pTHX) 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--) { @@ -1215,7 +1269,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--) { @@ -1234,7 +1287,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--) { @@ -1242,27 +1294,27 @@ S_dopoptoloop(pTHX_ I32 startingblock) switch (CxTYPE(cx)) { case CXt_SUBST: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", PL_op_name[PL_op->op_type]); break; case CXt_SUB: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", PL_op_name[PL_op->op_type]); break; case CXt_FORMAT: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", PL_op_name[PL_op->op_type]); break; case CXt_EVAL: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", PL_op_name[PL_op->op_type]); break; case CXt_NULL: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", PL_op_name[PL_op->op_type]); return -1; case CXt_LOOP: @@ -1276,7 +1328,6 @@ S_dopoptoloop(pTHX_ I32 startingblock) void Perl_dounwind(pTHX_ I32 cxix) { - dTHR; register PERL_CONTEXT *cx; I32 optype; @@ -1322,7 +1373,6 @@ Perl_dounwind(pTHX_ I32 cxix) STATIC void S_free_closures(pTHX) { - dTHR; SV **svp = AvARRAY(PL_comppad_name); I32 ix; for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) { @@ -1391,8 +1441,13 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) } } } - else + else { sv_setpvn(ERRSV, message, msglen); + if (PL_hints & HINT_UTF8) + SvUTF8_on(ERRSV); + else + SvUTF8_off(ERRSV); + } } else message = SvPVx(ERRSV, msglen); @@ -1615,10 +1670,10 @@ PP(pp_caller) SV * mask ; SV * old_warnings = cx->blk_oldcop->cop_warnings ; - if (old_warnings == pWARN_NONE || + 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 @@ -1715,7 +1770,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); @@ -1723,9 +1777,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 @@ -2103,7 +2159,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) && @@ -2185,7 +2240,7 @@ PP(pp_goto) if (cxix < cxstack_ix) dounwind(cxix); TOPBLOCK(cx); - if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) + if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) DIE(aTHX_ "Can't goto subroutine from an eval-string"); mark = PL_stack_sp; if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { @@ -2253,7 +2308,7 @@ PP(pp_goto) PL_stack_sp--; /* There is no cv arg. */ /* Push a mark for the start of arglist */ - PUSHMARK(mark); + PUSHMARK(mark); (void)(*CvXSUB(cv))(aTHXo_ cv); /* Pop the current context like a decent sub should */ POPBLOCK(cx, PL_curpm); @@ -2327,14 +2382,14 @@ PP(pp_goto) #ifdef USE_THREADS if (!cx->blk_sub.hasargs) { AV* av = (AV*)PL_curpad[0]; - + items = AvFILLp(av) + 1; if (items) { /* Mark is at the end of the stack. */ EXTEND(SP, items); Copy(AvARRAY(av), SP + 1, items, SV*); SP += items; - PUTBACK ; + PUTBACK ; } } #endif /* USE_THREADS */ @@ -2384,7 +2439,7 @@ PP(pp_goto) */ SV *sv = GvSV(PL_DBsub); CV *gotocv; - + if (PERLDB_SUB_NN) { SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */ } else { @@ -2614,7 +2669,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; @@ -2707,12 +2761,12 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) #else SAVEVPTR(PL_op); #endif - PL_hints = 0; + PL_hints &= HINT_UTF8; 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); @@ -2971,17 +3025,17 @@ PP(pp_require) if (SvNIOKp(sv)) { if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */ UV rev = 0, ver = 0, sver = 0; - I32 len; + STRLEN len; U8 *s = (U8*)SvPVX(sv); U8 *end = (U8*)SvPVX(sv) + SvCUR(sv); if (s < end) { - rev = utf8_to_uv_chk(s, &len, 0); + rev = utf8_to_uv(s, end - s, &len, 0); s += len; if (s < end) { - ver = utf8_to_uv_chk(s, &len, 0); + ver = utf8_to_uv(s, end - s, &len, 0); s += len; if (s < end) - sver = utf8_to_uv_chk(s, &len, 0); + sver = utf8_to_uv(s, end - s, &len, 0); } } if (PERL_REVISION < rev @@ -3050,7 +3104,7 @@ PP(pp_require) if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':')) goto trylocal; } - else + else trylocal: { #else } @@ -3259,8 +3313,10 @@ trylocal: { PL_compiling.cop_warnings = pWARN_ALL ; else if (PL_dowarn & G_WARN_ALL_OFF) PL_compiling.cop_warnings = pWARN_NONE ; - else + else PL_compiling.cop_warnings = pWARN_STD ; + SAVESPTR(PL_compiling.cop_io); + PL_compiling.cop_io = Nullsv; if (filter_sub || filter_child_proc) { SV *datasv = filter_add(run_user_filter, Nullsv); @@ -3314,7 +3370,7 @@ PP(pp_entereval) ENTER; lex_start(sv); SAVETMPS; - + /* switch to eval mode */ if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { @@ -3346,6 +3402,13 @@ PP(pp_entereval) PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings); SAVEFREESV(PL_compiling.cop_warnings); } + SAVESPTR(PL_compiling.cop_io); + if (specialCopIO(PL_curcop->cop_io)) + PL_compiling.cop_io = PL_curcop->cop_io; + else { + PL_compiling.cop_io = newSVsv(PL_curcop->cop_io); + SAVEFREESV(PL_compiling.cop_io); + } push_return(PL_op->op_next); PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); @@ -3529,7 +3592,7 @@ S_doparseform(pTHX_ SV *sv) if (len == 0) Perl_croak(aTHX_ "Null picture in formline"); - + New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */ fpc = fops; @@ -3557,7 +3620,7 @@ S_doparseform(pTHX_ SV *sv) case ' ': case '\t': skipspaces++; continue; - + case '\n': case 0: arg = s - base; skipspaces++; @@ -3632,6 +3695,24 @@ S_doparseform(pTHX_ SV *sv) } *fpc++ = s - base; /* fieldsize for FETCH */ *fpc++ = FF_DECIMAL; + *fpc++ = arg; + } + else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */ + arg = ischop ? 512 : 0; + base = s - 1; + s++; /* skip the '0' first */ + while (*s == '#') + s++; + if (*s == '.') { + char *f; + s++; + f = s; + while (*s == '#') + s++; + arg |= 256 + (s - f); + } + *fpc++ = s - base; /* fieldsize for FETCH */ + *fpc++ = FF_0DECIMAL; *fpc++ = arg; } else { @@ -3695,7 +3776,7 @@ S_doparseform(pTHX_ SV *sv) * Research Group at University of California, Berkeley. * * See also: "Optimistic Merge Sort" (SODA '92) - * + * * The integration to Perl is by John P. Linderman <jpl@research.att.com>. * * The code can be distributed under the same terms as Perl itself. @@ -4065,7 +4146,6 @@ S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp) static I32 sortcv(pTHXo_ SV *a, SV *b) { - dTHR; I32 oldsaveix = PL_savestack_ix; I32 oldscopeix = PL_scopestack_ix; I32 result; @@ -4089,7 +4169,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; @@ -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 @@ -82,6 +78,8 @@ PP(pp_stringify) sv_setpvn(TARG,s,len); if (SvUTF8(TOPs) && !IN_BYTE) SvUTF8_on(TARG); + else + SvUTF8_off(TARG); SETTARG; RETURN; } @@ -144,99 +142,52 @@ PP(pp_concat) djSP; dATARGET; tryAMAGICbin(concat,opASSIGN); { dPOPTOPssrl; - STRLEN len; - U8 *s; - bool left_utf; - bool right_utf; + SV* rcopy = Nullsv; - if (TARG == right && SvGMAGICAL(right)) - mg_get(right); if (SvGMAGICAL(left)) mg_get(left); + if (TARG == right && SvGMAGICAL(right)) + mg_get(right); - left_utf = DO_UTF8(left); - right_utf = DO_UTF8(right); - - if (left_utf != right_utf) { - if (TARG == right && !right_utf) { - sv_utf8_upgrade(TARG); /* Now straight binary copy */ - SvUTF8_on(TARG); - } - else { - /* Set TARG to PV(left), then add right */ - U8 *l, *c, *olds = NULL; - STRLEN targlen; - s = (U8*)SvPV(right,len); - right_utf |= DO_UTF8(right); - if (TARG == right) { - /* Take a copy since we're about to overwrite TARG */ - olds = s = (U8*)savepvn((char*)s, len); - } - if (!SvOK(left) && SvTYPE(left) <= SVt_PVMG) - sv_setpv(left, ""); /* Suppress warning. */ - l = (U8*)SvPV(left, targlen); - left_utf |= DO_UTF8(left); - if (TARG != left) - sv_setpvn(TARG, (char*)l, targlen); - if (!left_utf) - sv_utf8_upgrade(TARG); - /* Extend TARG to length of right (s) */ - targlen = SvCUR(TARG) + len; - if (!right_utf) { - /* plus one for each hi-byte char if we have to upgrade */ - for (c = s; c < s + len; c++) { - if (*c & 0x80) - targlen++; - } - } - SvGROW(TARG, targlen+1); - /* And now copy, maybe upgrading right to UTF8 on the fly */ - for (c = (U8*)SvEND(TARG); len--; s++) { - if (*s & 0x80 && !right_utf) - c = uv_to_utf8(c, *s); - else - *c++ = *s; - } - SvCUR_set(TARG, targlen); - *SvEND(TARG) = '\0'; - SvUTF8_on(TARG); - SETs(TARG); - Safefree(olds); - RETURN; - } - } - - if (TARG != left) { - s = (U8*)SvPV(left,len); - if (TARG == right) { - sv_insert(TARG, 0, 0, (char*)s, len); - SETs(TARG); - RETURN; + 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, (char *)s, len); + else /* $right = $left . $right; */ + sv_catsv(TARG, rcopy); } - else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) - sv_setpv(TARG, ""); /* Suppress warning. */ - s = (U8*)SvPV(right,len); - if (SvOK(TARG)) { + else { + if (!SvOK(TARG)) /* Avoid warning when concatenating to undef. */ + sv_setpv(TARG, ""); + /* $other = $left . $right; */ + /* $left = $left . $right; */ + sv_catsv(TARG, right); + } + #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'"); - } + 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 - sv_catpvn(TARG, (char *)s, len); } - else - sv_setpvn(TARG, (char *)s, len); /* suppress warning */ - if (left_utf) - SvUTF8_on(TARG); +#endif + SETTARG; RETURN; } @@ -279,6 +230,69 @@ PP(pp_readline) PP(pp_eq) { djSP; tryAMAGICbinSET(eq,0); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + /* Unless the left argument is integer in range we are going to have to + use NV maths. Hence only attempt to coerce the right argument if + we know the left is integer. */ + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (!auvok && !buvok) { /* ## IV == IV ## */ + IV aiv = SvIVX(TOPm1s); + IV biv = SvIVX(TOPs); + + SP--; + SETs(boolSV(aiv == biv)); + RETURN; + } + if (auvok && buvok) { /* ## UV == UV ## */ + UV auv = SvUVX(TOPm1s); + UV buv = SvUVX(TOPs); + + SP--; + SETs(boolSV(auv == buv)); + RETURN; + } + { /* ## Mixed IV,UV ## */ + IV iv; + UV uv; + + /* == is commutative so swap if needed (save code) */ + if (auvok) { + /* swap. top of stack (b) is the iv */ + iv = SvIVX(TOPs); + SP--; + if (iv < 0) { + /* As (a) is a UV, it's >0, so it cannot be == */ + SETs(&PL_sv_no); + RETURN; + } + uv = SvUVX(TOPs); + } else { + iv = SvIVX(TOPm1s); + SP--; + if (iv < 0) { + /* As (b) is a UV, it's >0, so it cannot be == */ + SETs(&PL_sv_no); + RETURN; + } + uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */ + } + /* we know iv is >= 0 */ + if (uv > (UV) IV_MAX) { + SETs(&PL_sv_no); + RETURN; + } + SETs(boolSV((UV)iv == uv)); + RETURN; + } + } + } +#endif { dPOPnv; SETs(boolSV(TOPn == value)); @@ -297,7 +311,7 @@ PP(pp_preinc) ++SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } - else + else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */ sv_inc(TOPs); SvSETMAGIC(TOPs); return NORMAL; @@ -316,11 +330,125 @@ PP(pp_or) PP(pp_add) { - djSP; dATARGET; tryAMAGICbin(add,opASSIGN); + djSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN); + useleft = USE_LEFT(TOPm1s); +#ifdef PERL_PRESERVE_IVUV + /* We must see if we can perform the addition with integers if possible, + as the integer code detects overflow while the NV code doesn't. + If either argument hasn't had a numeric conversion yet attempt to get + the IV. It's important to do this now, rather than just assuming that + it's not IOK as a PV of "9223372036854775806" may not take well to NV + addition, and an SV which is NOK, NV=6.0 ought to be coerced to + integer in case the second argument is IV=9223372036854775806 + We can (now) rely on sv_2iv to do the right thing, only setting the + public IOK flag if the value in the NV (or PV) slot is truly integer. + + A side effect is that this also aggressively prefers integer maths over + fp maths for integer values. */ + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + /* Unless the left argument is integer in range we are going to have to + use NV maths. Hence only attempt to coerce the right argument if + we know the left is integer. */ + if (!useleft) { + /* left operand is undef, treat as zero. + 0 is identity. */ + if (SvUOK(TOPs)) { + dPOPuv; /* Scary macros. Lets put a sequence point (;) here */ + SETu(value); + RETURN; + } else { + dPOPiv; + SETi(value); + RETURN; + } + } + /* Left operand is defined, so is it IV? */ + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (!auvok && !buvok) { /* ## IV + IV ## */ + IV aiv = SvIVX(TOPm1s); + IV biv = SvIVX(TOPs); + IV result = aiv + biv; + + if (biv >= 0 ? (result >= aiv) : (result < aiv)) { + SP--; + SETi( result ); + RETURN; + } + if (biv >=0 && aiv >= 0) { + UV result = (UV)aiv + (UV)biv; + /* UV + UV can only get bigger... */ + if (result >= (UV) aiv) { + SP--; + SETu( result ); + RETURN; + } + } + /* Overflow, drop through to NVs (beyond next if () else ) */ + } else if (auvok && buvok) { /* ## UV + UV ## */ + UV auv = SvUVX(TOPm1s); + UV buv = SvUVX(TOPs); + UV result = auv + buv; + if (result >= auv) { + SP--; + SETu( result ); + RETURN; + } + /* Overflow, drop through to NVs (beyond next if () else ) */ + } else { /* ## Mixed IV,UV ## */ + IV aiv; + UV buv; + + /* addition is commutative so swap if needed (save code) */ + if (buvok) { + aiv = SvIVX(TOPm1s); + buv = SvUVX(TOPs); + } else { + aiv = SvIVX(TOPs); + buv = SvUVX(TOPm1s); + } + + if (aiv >= 0) { + UV result = (UV)aiv + buv; + if (result >= buv) { + SP--; + SETu( result ); + RETURN; + } + } else if (buv > (UV) IV_MAX) { + /* assuming 2s complement means that IV_MIN == -IV_MIN, + and (UV)-IV_MIN *is* the value -IV_MIN (or IV_MAX + 1) + as buv > IV_MAX, it is >= (IV_MAX + 1), and therefore + as the value we can be subtracting from it only lies in + the range (-IV_MIN to -1) it can't overflow a UV */ + SP--; + SETu( buv - (UV)-aiv ); + RETURN; + } else { + IV result = (IV) buv + aiv; + /* aiv < 0 so it must get smaller. */ + if (result < (IV) buv) { + SP--; + SETi( result ); + RETURN; + } + } + } /* end of IV+IV / UV+UV / mixed */ + } + } +#endif { - dPOPTOPnnrl_ul; - SETn( left + right ); - RETURN; + dPOPnv; + if (!useleft) { + /* left operand is undef, treat as zero. + 0.0 is identity. */ + SETn(value); + RETURN; + } + SETn( value + TOPn ); + RETURN; } } @@ -406,7 +534,6 @@ PP(pp_print) RETURN; } if (!(io = GvIO(gv))) { - dTHR; if ((GvEGV(gv)) && (mg = SvTIED_mg((SV*)GvEGV(gv),'q'))) goto had_magic; if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) @@ -416,21 +543,8 @@ PP(pp_print) } else if (!(fp = IoOFP(io))) { if (ckWARN2(WARN_CLOSED, WARN_IO)) { - if (IoIFP(io)) { - /* 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"); - } + if (IoIFP(io)) + report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); } @@ -439,13 +553,13 @@ PP(pp_print) } else { MARK++; - if (PL_ofslen) { + if (PL_ofs_sv && SvOK(PL_ofs_sv)) { while (MARK <= SP) { if (!do_print(*MARK, fp)) break; MARK++; if (MARK <= SP) { - if (PerlIO_write(fp, PL_ofs, PL_ofslen) == 0 || PerlIO_error(fp)) { + if (!do_print(PL_ofs_sv, fp)) { /* $, */ MARK--; break; } @@ -462,8 +576,8 @@ PP(pp_print) if (MARK <= SP) goto just_say_no; else { - if (PL_orslen) - if (PerlIO_write(fp, PL_ors, PL_orslen) == 0 || PerlIO_error(fp)) + if (PL_ors_sv && SvOK(PL_ors_sv)) + if (!do_print(PL_ors_sv, fp)) /* $\ */ goto just_say_no; if (IoFLAGS(io) & IOf_FLUSH) @@ -1016,11 +1130,12 @@ PP(pp_match) TARG = DEFSV; EXTEND(SP,1); } + PL_reg_sv = TARG; PUTBACK; /* EVAL blocks need stack_sp. */ 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; @@ -1076,7 +1191,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) @@ -1105,27 +1221,25 @@ play_it_again: RX_MATCH_TAINTED_on(rx); TAINT_IF(RX_MATCH_TAINTED(rx)); if (gimme == G_ARRAY) { - I32 iters, i, len; + I32 nparens, i, len; - iters = rx->nparens; - if (global && !iters) + nparens = rx->nparens; + if (global && !nparens) i = 1; else i = 0; SPAGAIN; /* EVAL blocks could move the stack. */ - EXTEND(SP, iters + i); - EXTEND_MORTAL(iters + i); - for (i = !i; i <= iters; i++) { + EXTEND(SP, nparens + i); + EXTEND_MORTAL(nparens + i); + for (i = !i; i <= nparens; i++) { PUSHs(sv_newmortal()); /*SUPPRESS 560*/ if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) { len = rx->endp[i] - rx->startp[i]; s = rx->startp[i] + truebase; sv_setpvn(*SP, s, len); - if ((pm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) { + if (DO_UTF8(TARG)) SvUTF8_on(*SP); - sv_utf8_downgrade(*SP, TRUE); - } } } if (global) { @@ -1135,7 +1249,7 @@ play_it_again: r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; goto play_it_again; } - else if (!iters) + else if (!nparens) XPUSHs(&PL_sv_yes); LEAVE_SCOPE(oldsave); RETURN; @@ -1175,7 +1289,13 @@ yup: /* Confirmed by INTUIT */ if (global) { rx->subbeg = truebase; rx->startp[0] = s - truebase; - rx->endp[0] = s - truebase + rx->minlen; + if (DO_UTF8(PL_reg_sv)) { + char *t = (char*)utf8_hop((U8*)s, rx->minlen); + rx->endp[0] = t - truebase; + } + else { + rx->endp[0] = s - truebase + rx->minlen; + } rx->sublen = strend - truebase; goto gotcha; } @@ -1257,159 +1377,15 @@ Perl_do_readline(pTHX) (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ } } - else if (type == OP_GLOB) { - SV *tmpcmd = NEWSV(55, 0); - SV *tmpglob = POPs; - ENTER; - SAVEFREESV(tmpcmd); -#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */ - /* since spawning off a process is a real performance hit */ - { -#include <descrip.h> -#include <lib$routines.h> -#include <nam.h> -#include <rmsdef.h> - char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'}; - char vmsspec[NAM$C_MAXRSS+1]; - char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp; - char tmpfnam[L_tmpnam] = "SYS$SCRATCH:"; - $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;"); - PerlIO *tmpfp; - STRLEN i; - struct dsc$descriptor_s wilddsc - = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; - struct dsc$descriptor_vs rsdsc - = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt}; - unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0; - - /* We could find out if there's an explicit dev/dir or version - by peeking into lib$find_file's internal context at - ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb - but that's unsupported, so I don't want to do it now and - have it bite someone in the future. */ - strcat(tmpfnam,PerlLIO_tmpnam(NULL)); - cp = SvPV(tmpglob,i); - for (; i; i--) { - if (cp[i] == ';') hasver = 1; - if (cp[i] == '.') { - if (sts) hasver = 1; - else sts = 1; - } - if (cp[i] == '/') { - hasdir = isunix = 1; - break; - } - if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') { - hasdir = 1; - break; - } - } - if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) { - Stat_t st; - if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode)) - ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL); - else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL); - if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer); - while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt, - &dfltdsc,NULL,NULL,NULL))&1)) { - end = rstr + (unsigned long int) *rslt; - if (!hasver) while (*end != ';') end--; - *(end++) = '\n'; *end = '\0'; - for (cp = rstr; *cp; cp++) *cp = _tolower(*cp); - if (hasdir) { - if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1); - begin = rstr; - } - else { - begin = end; - while (*(--begin) != ']' && *begin != '>') ; - ++begin; - } - ok = (PerlIO_puts(tmpfp,begin) != EOF); - } - if (cxt) (void)lib$find_file_end(&cxt); - if (ok && sts != RMS$_NMF && - sts != RMS$_DNF && sts != RMS$_FNF) ok = 0; - if (!ok) { - if (!(sts & 1)) { - SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts); - } - PerlIO_close(tmpfp); - fp = NULL; - } - else { - PerlIO_rewind(tmpfp); - IoTYPE(io) = IoTYPE_RDONLY; - IoIFP(io) = fp = tmpfp; - IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */ - } - } - } -#else /* !VMS */ -#ifdef MACOS_TRADITIONAL - sv_setpv(tmpcmd, "glob "); - sv_catsv(tmpcmd, tmpglob); - sv_catpv(tmpcmd, " |"); -#else -#ifdef DOSISH -#ifdef OS2 - sv_setpv(tmpcmd, "for a in "); - sv_catsv(tmpcmd, tmpglob); - sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |"); -#else -#ifdef DJGPP - sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */ - sv_catsv(tmpcmd, tmpglob); -#else - sv_setpv(tmpcmd, "perlglob "); - sv_catsv(tmpcmd, tmpglob); - sv_catpv(tmpcmd, " |"); -#endif /* !DJGPP */ -#endif /* !OS2 */ -#else /* !DOSISH */ -#if defined(CSH) - sv_setpvn(tmpcmd, PL_cshname, PL_cshlen); - sv_catpv(tmpcmd, " -cf 'set nonomatch; glob "); - sv_catsv(tmpcmd, tmpglob); - sv_catpv(tmpcmd, "' 2>/dev/null |"); -#else - sv_setpv(tmpcmd, "echo "); - sv_catsv(tmpcmd, tmpglob); -#if 'z' - 'a' == 25 - sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|"); -#else - sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|"); -#endif -#endif /* !CSH */ -#endif /* !DOSISH */ -#endif /* MACOS_TRADITIONAL */ - (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd), - FALSE, O_RDONLY, 0, Nullfp); - fp = IoIFP(io); -#endif /* !VMS */ - LEAVE; - } + else if (type == OP_GLOB) + fp = Perl_start_glob(aTHX_ POPs, io); } else if (type == OP_GLOB) SP--; else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */ && (IoTYPE(io) == IoTYPE_WRONLY || fp == PerlIO_stdout() || fp == PerlIO_stderr())) - { - /* 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"); - } + report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY); } if (!fp) { if (ckWARN2(WARN_GLOB, WARN_CLOSED) @@ -1446,6 +1422,13 @@ 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) \ @@ -1474,13 +1457,10 @@ 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); @@ -1556,8 +1536,11 @@ PP(pp_helem) U32 defer = PL_op->op_private & OPpLVAL_DEFER; SV *sv; U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0; + I32 preeminent; if (SvTYPE(hv) == SVt_PVHV) { + if (PL_op->op_private & OPpLVAL_INTRO) + preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0); he = hv_fetch_ent(hv, keysv, lval && !defer, hash); svp = he ? &HeVAL(he) : 0; } @@ -1590,8 +1573,14 @@ PP(pp_helem) if (PL_op->op_private & OPpLVAL_INTRO) { if (HvNAME(hv) && isGV(*svp)) save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL)); - else - save_helem(hv, keysv, svp); + else { + if (!preeminent) { + STRLEN keylen; + char *key = SvPV(keysv, keylen); + save_delete(hv, key, keylen); + } else + save_helem(hv, keysv, svp); + } } else if (PL_op->op_private & OPpDEREF) vivify_ref(*svp, PL_op->op_private & OPpDEREF); @@ -1790,6 +1779,8 @@ 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; @@ -1799,6 +1790,8 @@ PP(pp_subst) TARG = DEFSV; EXTEND(SP,1); } + PL_reg_sv = TARG; + do_utf8 = DO_UTF8(PL_reg_sv); if (SvFAKE(TARG) && SvREADONLY(TARG)) sv_force_normal(TARG); if (SvREADONLY(TARG) @@ -1818,12 +1811,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; @@ -1964,6 +1958,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); @@ -1972,6 +1968,8 @@ PP(pp_subst) rxtainted |= RX_MATCH_TAINTED(rx); dstr = NEWSV(25, len); sv_setpvn(dstr, m, s-m); + if (DO_UTF8(TARG)) + SvUTF8_on(dstr); PL_curpm = pm; if (!c) { register PERL_CONTEXT *cx; @@ -1998,7 +1996,8 @@ PP(pp_subst) sv_catpvn(dstr, c, clen); if (once) break; - } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags)); + } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, + TARG, NULL, r_flags)); sv_catpvn(dstr, s, strend - s); (void)SvOOK_off(TARG); @@ -2006,6 +2005,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); @@ -2014,6 +2014,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); @@ -2284,7 +2286,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) { @@ -2781,12 +2782,15 @@ PP(pp_aelem) { djSP; SV** svp; - IV elem = POPi; + SV* elemsv = POPs; + IV elem = SvIV(elemsv); AV* av = (AV*)POPs; U32 lval = PL_op->op_flags & OPf_MOD; U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av)); SV *sv; + if (SvROK(elemsv) && ckWARN(WARN_MISC)) + Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv)); if (elem > 0) elem -= PL_curcop->cop_arybase; if (SvTYPE(av) != SVt_PVAV) @@ -2909,7 +2913,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) !(ob=(SV*)GvIO(iogv))) { if (!packname || - ((*(U8*)packname >= 0xc0 && DO_UTF8(sv)) + ((UTF8_IS_START(*packname) && DO_UTF8(sv)) ? !isIDFIRST_utf8((U8*)packname) : !isIDFIRST(*packname) )) @@ -2988,9 +2992,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)))); @@ -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. @@ -35,11 +35,6 @@ # include <shadow.h> #endif -/* XXX If this causes problems, set i_unistd=undef in the hint file. */ -#ifdef I_UNISTD -# include <unistd.h> -#endif - #ifdef HAS_SYSCALL #ifdef __cplusplus extern "C" int syscall(unsigned long,...); @@ -54,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. @@ -142,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,...) */ @@ -317,6 +297,13 @@ PP(pp_backtick) mode = "rt"; fp = PerlProc_popen(tmps, mode); if (fp) { + char *type = NULL; + if (PL_curcop->cop_io) { + type = SvPV_nolen(PL_curcop->cop_io); + } + if (type && *type) + PerlIO_apply_layers(aTHX_ fp,mode,type); + if (gimme == G_VOID) { char tmpbuf[256]; while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0) @@ -461,7 +448,7 @@ PP(pp_die) } else { tmpsv = TOPs; - tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len); + tmps = (SvROK(tmpsv) && PL_in_eval) ? Nullch : SvPV(tmpsv, len); } if (!tmps || !len) { SV *error = ERRSV; @@ -658,8 +645,15 @@ PP(pp_fileno) RETURN; } - if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) + if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) { + /* Can't do this because people seem to do things like + defined(fileno($foo)) to check whether $foo is a valid fh. + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); + */ RETPUSHUNDEF; + } + PUSHi(PerlIO_fileno(fp)); RETURN; } @@ -697,11 +691,14 @@ PP(pp_binmode) PerlIO *fp; MAGIC *mg; SV *discp = Nullsv; + STRLEN len = 0; + char *names = NULL; if (MAXARG < 1) RETPUSHUNDEF; - if (MAXARG > 1) + if (MAXARG > 1) { discp = POPs; + } gv = (GV*)POPs; @@ -719,10 +716,18 @@ PP(pp_binmode) } EXTEND(SP, 1); - if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) - RETPUSHUNDEF; + if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) { + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); + RETPUSHUNDEF; + } - if (do_binmode(fp,IoTYPE(io),mode_from_discipline(discp))) + if (discp) { + names = SvPV(discp,len); + } + + if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp), + (discp) ? SvPV_nolen(discp) : Nullch)) RETPUSHYES; else RETPUSHUNDEF; @@ -794,9 +799,12 @@ PP(pp_tie) POPSTACK; if (sv_isobject(sv)) { sv_unmagic(varsv, how); - /* Croak if a self-tie is attempted */ - if (varsv == SvRV(sv)) - Perl_croak(aTHX_ "Self-ties are not supported"); + /* Croak if a self-tie on an aggregate is attempted. */ + if (varsv == SvRV(sv) && + (SvTYPE(sv) == SVt_PVAV || + SvTYPE(sv) == SVt_PVHV)) + Perl_croak(aTHX_ + "Self-ties of arrays and hashes are not supported"); sv_magic(varsv, sv, how, Nullch, 0); } LEAVE; @@ -1061,7 +1069,6 @@ PP(pp_sselect) void Perl_setdefout(pTHX_ GV *gv) { - dTHR; if (gv) (void)SvREFCNT_inc(gv); if (PL_defoutgv) @@ -1132,6 +1139,16 @@ PP(pp_getc) TAINT; sv_setpv(TARG, " "); *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */ + if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) { + /* Find out how many bytes the char needs */ + Size_t len = UTF8SKIP(SvPVX(TARG)); + if (len > 1) { + SvGROW(TARG,len+1); + len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1); + SvCUR_set(TARG,1+len); + } + SvUTF8_on(TARG); + } PUSHTARG; RETURN; } @@ -1144,7 +1161,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); @@ -1220,6 +1236,8 @@ PP(pp_leavewrite) DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n", (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget))); + if (!io || !ofp) + goto forget_top; if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) && PL_formtarget != PL_toptarget) { @@ -1259,13 +1277,16 @@ PP(pp_leavewrite) s++; } if (s) { - PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget)); + STRLEN save = SvCUR(PL_formtarget); + SvCUR_set(PL_formtarget, s - SvPVX(PL_formtarget)); + do_print(PL_formtarget, ofp); + SvCUR_set(PL_formtarget, save); sv_chop(PL_formtarget, s); FmLINES(PL_formtarget) -= IoLINES_LEFT(io); } } if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0) - PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed)); + do_print(PL_formfeed, ofp); IoLINES_LEFT(io) = IoPAGE_LEN(io); IoPAGE(io)++; PL_formtarget = PL_toptarget; @@ -1326,8 +1347,7 @@ PP(pp_leavewrite) if (ckWARN(WARN_IO)) Perl_warner(aTHX_ WARN_IO, "page overflow"); } - if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) || - PerlIO_error(fp)) + if (!do_print(PL_formtarget, fp)) PUSHs(&PL_sv_no); else { FmLINES(PL_formtarget) = 0; @@ -1338,6 +1358,7 @@ PP(pp_leavewrite) PUSHs(&PL_sv_yes); } } +bad_ofp: PL_formtarget = PL_bodytarget; PUTBACK; return pop_return(); @@ -1380,7 +1401,6 @@ PP(pp_prtf) sv = NEWSV(0,0); if (!(io = GvIO(gv))) { - dTHR; if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS$_IFI); @@ -1467,10 +1487,14 @@ PP(pp_sysread) IO *io; char *buffer; SSize_t length; + SSize_t count; Sock_size_t bufsize; SV *bufsv; STRLEN blen; MAGIC *mg; + int fp_utf8; + Size_t got = 0; + Size_t wanted; gv = (GV*)*++MARK; if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) && @@ -1495,10 +1519,7 @@ PP(pp_sysread) bufsv = *++MARK; if (! SvOK(bufsv)) sv_setpvn(bufsv, "", 0); - buffer = SvPV_force(bufsv, blen); length = SvIVx(*++MARK); - if (length < 0) - DIE(aTHX_ "Negative length"); SETERRNO(0,0); if (MARK < SP) offset = SvIVx(*++MARK); @@ -1507,6 +1528,18 @@ PP(pp_sysread) io = GvIO(gv); if (!io || !IoIFP(io)) goto say_undef; + if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTE) { + buffer = SvPVutf8_force(bufsv, blen); + /* UTF8 may not have been set if they are all low bytes */ + SvUTF8_on(bufsv); + } + else { + buffer = SvPV_force(bufsv, blen); + } + if (length < 0) + DIE(aTHX_ "Negative length"); + wanted = length; + #ifdef HAS_SOCKET if (PL_op->op_type == OP_RECV) { char namebuf[MAXPATHLEN]; @@ -1519,19 +1552,17 @@ 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, + count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset, (struct sockaddr *)namebuf, &bufsize); - if (length < 0) + if (count < 0) RETPUSHUNDEF; - SvCUR_set(bufsv, length); + SvCUR_set(bufsv, count); *SvEND(bufsv) = '\0'; (void)SvPOK_only(bufsv); + if (fp_utf8) + SvUTF8_on(bufsv); SvSETMAGIC(bufsv); /* This should not be marked tainted if the fp is marked clean */ if (!(IoFLAGS(io) & IOf_UNTAINT)) @@ -1545,27 +1576,38 @@ PP(pp_sysread) if (PL_op->op_type == OP_RECV) DIE(aTHX_ PL_no_sock_func, "recv"); #endif + if (DO_UTF8(bufsv)) { + /* offset adjust in characters not bytes */ + blen = sv_len_utf8(bufsv); + } if (offset < 0) { if (-offset > blen) DIE(aTHX_ "Offset outside string"); offset += blen; } + if (DO_UTF8(bufsv)) { + /* convert offset-as-chars to offset-as-bytes */ + offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer; + } + more_bytes: bufsize = SvCUR(bufsv); - buffer = SvGROW(bufsv, length+offset+1); + buffer = SvGROW(bufsv, length+offset+1); if (offset > bufsize) { /* Zero any newly allocated space */ Zero(buffer+bufsize, offset-bufsize, char); } + buffer = buffer + offset; + if (PL_op->op_type == OP_SYSREAD) { #ifdef PERL_SOCK_SYSREAD_IS_RECV if (IoTYPE(io) == IoTYPE_SOCKET) { - length = PerlSock_recv(PerlIO_fileno(IoIFP(io)), - buffer+offset, length, 0); + count = PerlSock_recv(PerlIO_fileno(IoIFP(io)), + buffer, length, 0); } else #endif { - length = PerlLIO_read(PerlIO_fileno(IoIFP(io)), - buffer+offset, length); + count = PerlLIO_read(PerlIO_fileno(IoIFP(io)), + buffer, length); } } else @@ -1577,18 +1619,18 @@ PP(pp_sysread) #else bufsize = sizeof namebuf; #endif - length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0, + count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0, (struct sockaddr *)namebuf, &bufsize); } else #endif { - length = PerlIO_read(IoIFP(io), buffer+offset, length); - /* fread() returns 0 on both error and EOF */ - if (length == 0 && PerlIO_error(IoIFP(io))) - length = -1; + count = PerlIO_read(IoIFP(io), buffer, length); + /* PerlIO_read() - like fread() returns 0 on both error and EOF */ + if (count == 0 && PerlIO_error(IoIFP(io))) + count = -1; } - if (length < 0) { + if (count < 0) { if ((IoTYPE(io) == IoTYPE_WRONLY || IoIFP(io) == PerlIO_stdout() || IoIFP(io) == PerlIO_stderr()) && ckWARN(WARN_IO)) { @@ -1608,15 +1650,43 @@ PP(pp_sysread) } goto say_undef; } - SvCUR_set(bufsv, length+offset); + SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv))); *SvEND(bufsv) = '\0'; (void)SvPOK_only(bufsv); + if (fp_utf8 && !IN_BYTE) { + /* Look at utf8 we got back and count the characters */ + char *bend = buffer + count; + while (buffer < bend) { + STRLEN skip = UTF8SKIP(buffer); + if (buffer+skip > bend) { + /* partial character - try for rest of it */ + length = skip - (bend-buffer); + offset = bend - SvPVX(bufsv); + goto more_bytes; + } + else { + got++; + buffer += skip; + } + } + /* If we have not 'got' the number of _characters_ we 'wanted' get some more + provided amount read (count) was what was requested (length) + */ + if (got < wanted && count == length) { + length = (wanted-got); + offset = bend - SvPVX(bufsv); + goto more_bytes; + } + /* return value is character count */ + count = got; + SvUTF8_on(bufsv); + } SvSETMAGIC(bufsv); /* This should not be marked tainted if the fp is marked clean */ if (!(IoFLAGS(io) & IOf_UNTAINT)) SvTAINTED_on(bufsv); SP = ORIGMARK; - PUSHi(length); + PUSHi(count); RETURN; say_undef: @@ -1647,7 +1717,6 @@ PP(pp_send) char *buffer; Size_t length; SSize_t retval; - IV offset; STRLEN blen; MAGIC *mg; @@ -1669,7 +1738,6 @@ PP(pp_send) if (!gv) goto say_undef; bufsv = *++MARK; - buffer = SvPV(bufsv, blen); #if Size_t_size > IVSIZE length = (Size_t)SvNVx(*++MARK); #else @@ -1683,8 +1751,24 @@ PP(pp_send) retval = -1; if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); + goto say_undef; } - else if (PL_op->op_type == OP_SYSWRITE) { + + if (PerlIO_isutf8(IoIFP(io))) { + buffer = SvPVutf8(bufsv, blen); + } + else { + if (DO_UTF8(bufsv)) + sv_utf8_downgrade(bufsv, FALSE); + buffer = SvPV(bufsv, blen); + } + + if (PL_op->op_type == OP_SYSWRITE) { + IV offset; + if (DO_UTF8(bufsv)) { + /* length and offset are in chars */ + blen = sv_len_utf8(bufsv); + } if (MARK < SP) { offset = SvIVx(*++MARK); if (offset < 0) { @@ -1697,17 +1781,24 @@ PP(pp_send) offset = 0; if (length > blen - offset) length = blen - offset; + if (DO_UTF8(bufsv)) { + buffer = (char*)utf8_hop((U8 *)buffer, offset); + length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer; + } + else { + buffer = buffer+offset; + } #ifdef PERL_SOCK_SYSWRITE_IS_SEND if (IoTYPE(io) == IoTYPE_SOCKET) { retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), - buffer+offset, length, 0); + buffer, length, 0); } else #endif { /* See the note at doio.c:do_print about filesize limits. --jhi */ retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)), - buffer+offset, length); + buffer, length); } } #ifdef HAS_SOCKET @@ -1715,12 +1806,13 @@ PP(pp_send) char *sockbuf; STRLEN mlen; sockbuf = SvPVx(*++MARK, mlen); + /* length is really flags */ retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length, (struct sockaddr *)sockbuf, mlen); } else + /* length is really flags */ retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length); - #else else DIE(aTHX_ PL_no_sock_func, "send"); @@ -1971,9 +2063,11 @@ PP(pp_ioctl) char *s; IV retval; GV *gv = (GV*)POPs; - IO *io = GvIOn(gv); + IO *io = gv ? GvIOn(gv) : 0; if (!io || !argsv || !IoIFP(io)) { + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */ RETPUSHUNDEF; } @@ -2085,16 +2179,17 @@ PP(pp_socket) int fd; gv = (GV*)POPs; + io = gv ? GvIOn(gv) : NULL; - if (!gv) { + if (!gv || !io) { + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); + if (IoIFP(io)) + do_close(gv, FALSE); SETERRNO(EBADF,LIB$_INVARG); RETPUSHUNDEF; } - io = GvIOn(gv); - if (IoIFP(io)) - do_close(gv, FALSE); - TAINT_PROPER("socket"); fd = PerlSock_socket(domain, type, protocol); if (fd < 0) @@ -2133,15 +2228,21 @@ PP(pp_sockpair) gv2 = (GV*)POPs; gv1 = (GV*)POPs; - if (!gv1 || !gv2) + io1 = gv1 ? GvIOn(gv1) : NULL; + io2 = gv2 ? GvIOn(gv2) : NULL; + if (!gv1 || !gv2 || !io1 || !io2) { + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) { + if (!gv1 || !io1) + report_evil_fh(gv1, io1, PL_op->op_type); + if (!gv2 || !io2) + report_evil_fh(gv1, io2, PL_op->op_type); + } + if (IoIFP(io1)) + do_close(gv1, FALSE); + if (IoIFP(io2)) + do_close(gv2, FALSE); RETPUSHUNDEF; - - io1 = GvIOn(gv1); - io2 = GvIOn(gv2); - if (IoIFP(io1)) - do_close(gv1, FALSE); - if (IoIFP(io2)) - do_close(gv2, FALSE); + } TAINT_PROPER("socketpair"); if (PerlSock_socketpair(domain, type, protocol, fd) < 0) @@ -2267,9 +2368,9 @@ PP(pp_listen) #ifdef HAS_SOCKET int backlog = POPi; GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); + register IO *io = gv ? GvIOn(gv) : NULL; - if (!io || !IoIFP(io)) + if (!gv || !io || !IoIFP(io)) goto nuts; if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0) @@ -2546,9 +2647,15 @@ PP(pp_stat) if (PL_op->op_flags & OPf_REF) { gv = cGVOP_gv; - if (PL_op->op_type == OP_LSTAT && ckWARN(WARN_IO)) - Perl_warner(aTHX_ WARN_IO, + if (PL_op->op_type == OP_LSTAT) { + if (PL_laststype != OP_LSTAT) + Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat"); + if (ckWARN(WARN_IO) && gv != PL_defgv) + Perl_warner(aTHX_ WARN_IO, "lstat() on filehandle %s", GvENAME(gv)); + /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */ + } + do_fstat: if (gv != PL_defgv) { PL_laststype = OP_STAT; @@ -2558,7 +2665,6 @@ PP(pp_stat) ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1); } if (PL_laststatval < 0) { - dTHR; if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, GvIO(gv), PL_op->op_type); max = 0; @@ -3113,7 +3219,6 @@ PP(pp_fttext) len = 512; } else { - dTHR; if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) { gv = cGVOP_gv; report_evil_fh(gv, GvIO(gv), PL_op->op_type); @@ -3138,7 +3243,7 @@ PP(pp_fttext) (void)PerlIO_close(fp); RETPUSHUNDEF; } - do_binmode(fp, '<', O_BINARY); + PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch); len = PerlIO_read(fp, tbuf, sizeof(tbuf)); (void)PerlIO_close(fp); if (len <= 0) { @@ -3173,12 +3278,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 */ @@ -58,6 +58,7 @@ START_EXTERN_C # include "pp_proto.h" PERL_CALLCONV SV* Perl_amagic_call(pTHX_ SV* left, SV* right, int method, int dir); PERL_CALLCONV bool Perl_Gv_AMupdate(pTHX_ HV* stash); +PERL_CALLCONV CV* Perl_gv_handler(pTHX_ HV* stash, I32 id); 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); @@ -303,11 +304,11 @@ PERL_CALLCONV HV* Perl_gv_stashpvn(pTHX_ const char* name, U32 namelen, I32 crea PERL_CALLCONV HV* Perl_gv_stashsv(pTHX_ SV* sv, I32 create); PERL_CALLCONV void Perl_hv_clear(pTHX_ HV* tb); PERL_CALLCONV void Perl_hv_delayfree_ent(pTHX_ HV* hv, HE* entry); -PERL_CALLCONV SV* Perl_hv_delete(pTHX_ HV* tb, const char* key, U32 klen, I32 flags); +PERL_CALLCONV SV* Perl_hv_delete(pTHX_ HV* tb, const char* key, I32 klen, I32 flags); PERL_CALLCONV SV* Perl_hv_delete_ent(pTHX_ HV* tb, SV* key, I32 flags, U32 hash); -PERL_CALLCONV bool Perl_hv_exists(pTHX_ HV* tb, const char* key, U32 klen); +PERL_CALLCONV bool Perl_hv_exists(pTHX_ HV* tb, const char* key, I32 klen); PERL_CALLCONV bool Perl_hv_exists_ent(pTHX_ HV* tb, SV* key, U32 hash); -PERL_CALLCONV SV** Perl_hv_fetch(pTHX_ HV* tb, const char* key, U32 klen, I32 lval); +PERL_CALLCONV SV** Perl_hv_fetch(pTHX_ HV* tb, const char* key, I32 klen, I32 lval); PERL_CALLCONV HE* Perl_hv_fetch_ent(pTHX_ HV* tb, SV* key, I32 lval, U32 hash); PERL_CALLCONV void Perl_hv_free_ent(pTHX_ HV* hv, HE* entry); PERL_CALLCONV I32 Perl_hv_iterinit(pTHX_ HV* tb); @@ -318,7 +319,7 @@ PERL_CALLCONV SV* Perl_hv_iternextsv(pTHX_ HV* hv, char** key, I32* retlen); PERL_CALLCONV SV* Perl_hv_iterval(pTHX_ HV* tb, HE* entry); PERL_CALLCONV void Perl_hv_ksplit(pTHX_ HV* hv, IV newmax); PERL_CALLCONV void Perl_hv_magic(pTHX_ HV* hv, GV* gv, int how); -PERL_CALLCONV SV** Perl_hv_store(pTHX_ HV* tb, const char* key, U32 klen, SV* val, U32 hash); +PERL_CALLCONV SV** Perl_hv_store(pTHX_ HV* tb, const char* key, I32 klen, SV* val, U32 hash); PERL_CALLCONV HE* Perl_hv_store_ent(pTHX_ HV* tb, SV* key, SV* val, U32 hash); PERL_CALLCONV void Perl_hv_undef(pTHX_ HV* tb); PERL_CALLCONV I32 Perl_ibcmp(pTHX_ const char* a, const char* b, I32 len); @@ -365,7 +366,7 @@ 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); @@ -504,7 +505,7 @@ PERL_CALLCONV OP* Perl_newANONHASH(pTHX_ OP* o); PERL_CALLCONV OP* Perl_newANONSUB(pTHX_ I32 floor, OP* proto, OP* block); PERL_CALLCONV OP* Perl_newASSIGNOP(pTHX_ I32 flags, OP* left, I32 optype, OP* right); PERL_CALLCONV OP* Perl_newCONDOP(pTHX_ I32 flags, OP* expr, OP* trueop, OP* falseop); -PERL_CALLCONV void Perl_newCONSTSUB(pTHX_ HV* stash, char* name, SV* sv); +PERL_CALLCONV CV* Perl_newCONSTSUB(pTHX_ HV* stash, char* name, SV* sv); PERL_CALLCONV void Perl_newFORM(pTHX_ I32 floor, OP* o, OP* block); PERL_CALLCONV OP* Perl_newFOROP(pTHX_ I32 flags, char* label, line_t forline, OP* sclr, OP* expr, OP*block, OP*cont); PERL_CALLCONV OP* Perl_newLOGOP(pTHX_ I32 optype, I32 flags, OP* left, OP* right); @@ -543,7 +544,7 @@ PERL_CALLCONV SV* Perl_newSVuv(pTHX_ UV u); PERL_CALLCONV SV* Perl_newSVnv(pTHX_ NV n); PERL_CALLCONV SV* Perl_newSVpv(pTHX_ const char* s, STRLEN len); PERL_CALLCONV SV* Perl_newSVpvn(pTHX_ const char* s, STRLEN len); -PERL_CALLCONV SV* Perl_newSVpvn_share(pTHX_ const char* s, STRLEN len, U32 hash); +PERL_CALLCONV SV* Perl_newSVpvn_share(pTHX_ const char* s, I32 len, U32 hash); PERL_CALLCONV SV* Perl_newSVpvf(pTHX_ const char* pat, ...) #ifdef CHECK_FORMAT __attribute__((format(printf,pTHX_1,pTHX_2))) @@ -572,6 +573,7 @@ PERL_CALLCONV void Perl_pad_free(pTHX_ PADOFFSET po); PERL_CALLCONV void Perl_pad_reset(pTHX); PERL_CALLCONV void Perl_pad_swipe(pTHX_ PADOFFSET po); PERL_CALLCONV void Perl_peep(pTHX_ OP* o); +PERL_CALLCONV PerlIO* Perl_start_glob(pTHX_ SV* pattern, IO *io); #if defined(PERL_OBJECT) PERL_CALLCONV void Perl_construct(pTHX); PERL_CALLCONV void Perl_destruct(pTHX); @@ -595,9 +597,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); @@ -614,6 +616,7 @@ PERL_CALLCONV void Perl_push_scope(pTHX); PERL_CALLCONV OP* Perl_ref(pTHX_ OP* o, I32 type); PERL_CALLCONV OP* Perl_refkids(pTHX_ OP* o, I32 type); PERL_CALLCONV void Perl_regdump(pTHX_ regexp* r); +PERL_CALLCONV SV* Perl_regclass_swash(pTHX_ struct regnode *n, bool doinit, SV **initsvp); PERL_CALLCONV I32 Perl_pregexec(pTHX_ regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, U32 nosave); PERL_CALLCONV void Perl_pregfree(pTHX_ struct regexp* r); PERL_CALLCONV regexp* Perl_pregcomp(pTHX_ char* exp, char* xend, PMOP* pm); @@ -669,6 +672,7 @@ 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 +681,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) @@ -781,6 +785,7 @@ PERL_CALLCONV void Perl_sv_taint(pTHX_ SV* sv); PERL_CALLCONV bool Perl_sv_tainted(pTHX_ SV* sv); PERL_CALLCONV int Perl_sv_unmagic(pTHX_ SV* sv, int type); PERL_CALLCONV void Perl_sv_unref(pTHX_ SV* sv); +PERL_CALLCONV void Perl_sv_unref_flags(pTHX_ SV* sv, U32 flags); PERL_CALLCONV void Perl_sv_untaint(pTHX_ SV* sv); PERL_CALLCONV bool Perl_sv_upgrade(pTHX_ SV* sv, U32 mt); PERL_CALLCONV void Perl_sv_usepvn(pTHX_ SV* sv, char* ptr, STRLEN len); @@ -805,12 +810,13 @@ 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_ 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 I32 Perl_utf8_distance(pTHX_ U8 *a, U8 *b); +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 U8* Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len); PERL_CALLCONV U8* Perl_bytes_to_utf8(pTHX_ U8 *s, STRLEN *len); -PERL_CALLCONV UV Perl_utf8_to_uv(pTHX_ U8 *s, I32* retlen); -PERL_CALLCONV UV Perl_utf8_to_uv_chk(pTHX_ U8 *s, I32* retlen, bool checking); +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); @@ -832,7 +838,8 @@ 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) +#ifdef USE_PURE_BISON +PERL_CALLCONV int Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp); PERL_CALLCONV int Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp); #else PERL_CALLCONV int Perl_yylex(pTHX); @@ -916,6 +923,7 @@ 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_force_normal_flags(pTHX_ SV *sv, U32 flags); 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); @@ -1098,35 +1106,34 @@ STATIC int S_dooneliner(pTHX_ char *cmd, char *filename); #endif #if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT) -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 regnode* S_regclass(pTHX); -STATIC regnode* S_regclassutf8(pTHX); +STATIC regnode* S_reg(pTHX_ struct RExC_state_t*, I32, I32 *); +STATIC regnode* S_reganode(pTHX_ struct RExC_state_t*, U8, U32); +STATIC regnode* S_regatom(pTHX_ struct RExC_state_t*, I32 *); +STATIC regnode* S_regbranch(pTHX_ struct RExC_state_t*, I32 *, I32); +STATIC void S_reguni(pTHX_ struct RExC_state_t*, UV, char *, STRLEN*); +STATIC regnode* S_regclass(pTHX_ struct RExC_state_t*); STATIC I32 S_regcurly(pTHX_ char *); -STATIC regnode* S_reg_node(pTHX_ U8); -STATIC regnode* S_regpiece(pTHX_ I32 *); -STATIC void S_reginsert(pTHX_ U8, regnode *); -STATIC void S_regoptail(pTHX_ regnode *, regnode *); -STATIC void S_regtail(pTHX_ regnode *, regnode *); +STATIC regnode* S_reg_node(pTHX_ struct RExC_state_t*, U8); +STATIC regnode* S_regpiece(pTHX_ struct RExC_state_t*, I32 *); +STATIC void S_reginsert(pTHX_ struct RExC_state_t*, U8, regnode *); +STATIC void S_regoptail(pTHX_ struct RExC_state_t*, regnode *, regnode *); +STATIC void S_regtail(pTHX_ struct RExC_state_t*, regnode *, regnode *); STATIC char* S_regwhite(pTHX_ char *, char *); -STATIC char* S_nextchar(pTHX); +STATIC char* S_nextchar(pTHX_ struct RExC_state_t*); STATIC regnode* S_dumpuntil(pTHX_ regnode *start, regnode *node, regnode *last, SV* sv, I32 l); STATIC void S_put_byte(pTHX_ SV* sv, int c); -STATIC void S_scan_commit(pTHX_ struct scan_data_t *data); -STATIC void S_cl_anything(pTHX_ struct regnode_charclass_class *cl); +STATIC void S_scan_commit(pTHX_ struct RExC_state_t*, struct scan_data_t *data); +STATIC void S_cl_anything(pTHX_ struct RExC_state_t*, struct regnode_charclass_class *cl); STATIC int S_cl_is_anything(pTHX_ struct regnode_charclass_class *cl); -STATIC void S_cl_init(pTHX_ struct regnode_charclass_class *cl); -STATIC void S_cl_init_zero(pTHX_ struct regnode_charclass_class *cl); +STATIC void S_cl_init(pTHX_ struct RExC_state_t*, struct regnode_charclass_class *cl); +STATIC void S_cl_init_zero(pTHX_ struct RExC_state_t*, struct regnode_charclass_class *cl); STATIC void S_cl_and(pTHX_ struct regnode_charclass_class *cl, struct regnode_charclass_class *and_with); -STATIC void S_cl_or(pTHX_ struct regnode_charclass_class *cl, struct regnode_charclass_class *or_with); -STATIC I32 S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, struct scan_data_t *data, U32 flags); -STATIC I32 S_add_data(pTHX_ I32 n, char *s); +STATIC void S_cl_or(pTHX_ struct RExC_state_t*, struct regnode_charclass_class *cl, struct regnode_charclass_class *or_with); +STATIC I32 S_study_chunk(pTHX_ struct RExC_state_t*, regnode **scanp, I32 *deltap, regnode *last, struct scan_data_t *data, U32 flags); +STATIC I32 S_add_data(pTHX_ struct RExC_state_t*, I32 n, char *s); STATIC void S_re_croak2(pTHX_ const char* pat1, const char* pat2, ...) __attribute__((noreturn)); -STATIC I32 S_regpposixcc(pTHX_ I32 value); -STATIC void S_checkposixcc(pTHX); +STATIC I32 S_regpposixcc(pTHX_ struct RExC_state_t*, I32 value); +STATIC void S_checkposixcc(pTHX_ struct RExC_state_t*); #endif #if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT) @@ -1134,14 +1141,15 @@ STATIC I32 S_regmatch(pTHX_ regnode *prog); STATIC I32 S_regrepeat(pTHX_ regnode *p, I32 max); STATIC I32 S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp); STATIC I32 S_regtry(pTHX_ regexp *prog, char *startpos); -STATIC bool S_reginclass(pTHX_ regnode *p, I32 c); -STATIC bool S_reginclassutf8(pTHX_ regnode *f, U8* p); +STATIC bool S_reginclass(pTHX_ regnode *n, U8 *p, bool do_utf8sv_is_utf8); STATIC CHECKPOINT S_regcppush(pTHX_ I32 parenfloor); STATIC char* S_regcppop(pTHX); STATIC char* S_regcp_set_to(pTHX_ I32 ss); STATIC void S_cache_re(pTHX_ regexp *prog); STATIC U8* S_reghop(pTHX_ U8 *pos, I32 off); +STATIC U8* S_reghop3(pTHX_ U8 *pos, I32 off, U8 *lim); STATIC U8* S_reghopmaybe(pTHX_ U8 *pos, I32 off); +STATIC U8* S_reghopmaybe3(pTHX_ U8 *pos, I32 off, U8 *lim); STATIC char* S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *startpos, I32 norun); #endif @@ -1201,6 +1209,10 @@ STATIC void S_sv_del_backref(pTHX_ SV *sv); # if defined(DEBUGGING) STATIC void S_del_sv(pTHX_ SV *p); # endif +# if !defined(NV_PRESERVES_UV) +STATIC int S_sv_2inuv_non_preserve(pTHX_ SV *sv, I32 numtype); +STATIC int S_sv_2iuv_non_preserve(pTHX_ SV *sv, I32 numtype); +# endif #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) @@ -1256,6 +1268,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); @@ -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. @@ -111,6 +111,46 @@ #define STATIC static #endif +typedef struct RExC_state_t { + U16 flags16; /* are we folding, multilining? */ + char *precomp; /* uncompiled string. */ + regexp *rx; + char *end; /* End of input for compile */ + char *parse; /* Input-scan pointer. */ + I32 whilem_seen; /* number of WHILEM in this expr */ + regnode *emit; /* Code-emit pointer; ®dummy = don't = compiling */ + I32 naughty; /* How bad is this pattern? */ + I32 sawback; /* Did we see \1, ...? */ + U32 seen; + I32 size; /* Code size. */ + I32 npar; /* () count. */ + I32 extralen; + I32 seen_zerolen; + I32 seen_evals; + I32 utf8; +#if ADD_TO_REGEXEC + char *starttry; /* -Dr: where regtry was called. */ +#define RExC_starttry (pRExC_state->starttry) +#endif +} RExC_state_t; + +#define RExC_flags16 (pRExC_state->flags16) +#define RExC_precomp (pRExC_state->precomp) +#define RExC_rx (pRExC_state->rx) +#define RExC_end (pRExC_state->end) +#define RExC_parse (pRExC_state->parse) +#define RExC_whilem_seen (pRExC_state->whilem_seen) +#define RExC_emit (pRExC_state->emit) +#define RExC_naughty (pRExC_state->naughty) +#define RExC_sawback (pRExC_state->sawback) +#define RExC_seen (pRExC_state->seen) +#define RExC_size (pRExC_state->size) +#define RExC_npar (pRExC_state->npar) +#define RExC_extralen (pRExC_state->extralen) +#define RExC_seen_zerolen (pRExC_state->seen_zerolen) +#define RExC_seen_evals (pRExC_state->seen_evals) +#define RExC_utf8 (pRExC_state->utf8) + #define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?') #define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \ ((*s) == '{' && regcurly(s))) @@ -151,6 +191,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 +200,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,14 +229,13 @@ 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) -#define LOC (PL_regflags & PMf_LOCALE) -#define FOLD (PL_regflags & PMf_FOLD) +#define UTF RExC_utf8 +#define LOC (RExC_flags16 & PMf_LOCALE) +#define FOLD (RExC_flags16 & PMf_FOLD) -#define OOB_CHAR8 1234 -#define OOB_UTF8 123456 +#define OOB_UNICODE 12345678 #define OOB_NAMEDCLASS -1 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv)) @@ -223,10 +263,10 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, #define FAIL(msg) \ STMT_START { \ char *ellipses = ""; \ - unsigned len = strlen(PL_regprecomp); \ + unsigned len = strlen(RExC_precomp); \ \ if (!SIZE_ONLY) \ - SAVEDESTRUCTOR_X(clear_re,(void*)PL_regcomp_rx); \ + SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \ \ if (len > RegexLengthToShowInErrorMessages) { \ /* chop 10 shorter than the max, to ensure meaning of "..." */ \ @@ -234,7 +274,7 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ellipses = "..."; \ } \ Perl_croak(aTHX_ "%s in regex m/%.*s%s/", \ - msg, (int)len, PL_regprecomp, ellipses); \ + msg, (int)len, RExC_precomp, ellipses); \ } STMT_END /* @@ -245,10 +285,10 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, #define FAIL2(pat,msg) \ STMT_START { \ char *ellipses = ""; \ - unsigned len = strlen(PL_regprecomp); \ + unsigned len = strlen(RExC_precomp); \ \ if (!SIZE_ONLY) \ - SAVEDESTRUCTOR_X(clear_re,(void*)PL_regcomp_rx); \ + SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \ \ if (len > RegexLengthToShowInErrorMessages) { \ /* chop 10 shorter than the max, to ensure meaning of "..." */ \ @@ -256,7 +296,7 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ellipses = "..."; \ } \ S_re_croak2(aTHX_ pat, " in regex m/%.*s%s/", \ - msg, (int)len, PL_regprecomp, ellipses); \ + msg, (int)len, RExC_precomp, ellipses); \ } STMT_END @@ -265,10 +305,10 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, */ #define Simple_vFAIL(m) \ STMT_START { \ - unsigned offset = strlen(PL_regprecomp)-(PL_regxend-PL_regcomp_parse); \ + unsigned offset = strlen(RExC_precomp)-(RExC_end-RExC_parse); \ \ Perl_croak(aTHX_ "%s" REPORT_LOCATION, \ - m, (int)offset, PL_regprecomp, PL_regprecomp + offset); \ + m, (int)offset, RExC_precomp, RExC_precomp + offset); \ } STMT_END /* @@ -277,7 +317,7 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, #define vFAIL(m) \ STMT_START { \ if (!SIZE_ONLY) \ - SAVEDESTRUCTOR_X(clear_re,(void*)PL_regcomp_rx); \ + SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \ Simple_vFAIL(m); \ } STMT_END @@ -286,10 +326,10 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, */ #define Simple_vFAIL2(m,a1) \ STMT_START { \ - unsigned offset = strlen(PL_regprecomp)-(PL_regxend-PL_regcomp_parse); \ + unsigned offset = strlen(RExC_precomp)-(RExC_end-RExC_parse); \ \ S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, \ - (int)offset, PL_regprecomp, PL_regprecomp + offset); \ + (int)offset, RExC_precomp, RExC_precomp + offset); \ } STMT_END /* @@ -298,7 +338,7 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, #define vFAIL2(m,a1) \ STMT_START { \ if (!SIZE_ONLY) \ - SAVEDESTRUCTOR_X(clear_re,(void*)PL_regcomp_rx); \ + SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \ Simple_vFAIL2(m, a1); \ } STMT_END @@ -308,10 +348,10 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, */ #define Simple_vFAIL3(m, a1, a2) \ STMT_START { \ - unsigned offset = strlen(PL_regprecomp)-(PL_regxend-PL_regcomp_parse); \ + unsigned offset = strlen(RExC_precomp)-(RExC_end-RExC_parse); \ \ S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, \ - (int)offset, PL_regprecomp, PL_regprecomp + offset); \ + (int)offset, RExC_precomp, RExC_precomp + offset); \ } STMT_END /* @@ -320,7 +360,7 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, #define vFAIL3(m,a1,a2) \ STMT_START { \ if (!SIZE_ONLY) \ - SAVEDESTRUCTOR_X(clear_re,(void*)PL_regcomp_rx); \ + SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \ Simple_vFAIL3(m, a1, a2); \ } STMT_END @@ -329,10 +369,10 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, */ #define Simple_vFAIL4(m, a1, a2, a3) \ STMT_START { \ - unsigned offset = strlen(PL_regprecomp)-(PL_regxend-PL_regcomp_parse); \ + unsigned offset = strlen(RExC_precomp)-(RExC_end-RExC_parse); \ \ S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,\ - (int)offset, PL_regprecomp, PL_regprecomp + offset); \ + (int)offset, RExC_precomp, RExC_precomp + offset); \ } STMT_END /* @@ -340,46 +380,45 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, */ #define Simple_vFAIL5(m, a1, a2, a3, a4) \ STMT_START { \ - unsigned offset = strlen(PL_regprecomp)-(PL_regxend-PL_regcomp_parse); \ + unsigned offset = strlen(RExC_precomp)-(RExC_end-RExC_parse); \ S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3, a4,\ - (int)offset, PL_regprecomp, PL_regprecomp + offset); \ + (int)offset, RExC_precomp, RExC_precomp + offset); \ } STMT_END #define vWARN(loc,m) \ STMT_START { \ - unsigned offset = strlen(PL_regprecomp)-(PL_regxend-(loc)); \ + unsigned offset = strlen(RExC_precomp)-(RExC_end-(loc)); \ Perl_warner(aTHX_ WARN_REGEXP, "%s" REPORT_LOCATION,\ - m, (int)offset, PL_regprecomp, PL_regprecomp + offset); \ + m, (int)offset, RExC_precomp, RExC_precomp + offset); \ } STMT_END \ #define vWARN2(loc, m, a1) \ STMT_START { \ - unsigned offset = strlen(PL_regprecomp)-(PL_regxend-(loc)); \ + unsigned offset = strlen(RExC_precomp)-(RExC_end-(loc)); \ Perl_warner(aTHX_ WARN_REGEXP, m REPORT_LOCATION,\ a1, \ - (int)offset, PL_regprecomp, PL_regprecomp + offset); \ + (int)offset, RExC_precomp, RExC_precomp + offset); \ } STMT_END #define vWARN3(loc, m, a1, a2) \ STMT_START { \ - unsigned offset = strlen(PL_regprecomp) - (PL_regxend - (loc)); \ + unsigned offset = strlen(RExC_precomp) - (RExC_end - (loc)); \ Perl_warner(aTHX_ WARN_REGEXP, m REPORT_LOCATION, \ a1, a2, \ - (int)offset, PL_regprecomp, PL_regprecomp + offset); \ + (int)offset, RExC_precomp, RExC_precomp + offset); \ } STMT_END #define vWARN4(loc, m, a1, a2, a3) \ STMT_START { \ - unsigned offset = strlen(PL_regprecomp)-(PL_regxend-(loc)); \ + unsigned offset = strlen(RExC_precomp)-(RExC_end-(loc)); \ Perl_warner(aTHX_ WARN_REGEXP, m REPORT_LOCATION,\ a1, a2, a3, \ - (int)offset, PL_regprecomp, PL_regprecomp + offset); \ + (int)offset, RExC_precomp, RExC_precomp + offset); \ } STMT_END - /* Allow for side effects in s */ #define REGC(c,s) STMT_START { if (!SIZE_ONLY) *(s) = (c); else (s);} STMT_END @@ -390,9 +429,8 @@ static void clear_re(pTHXo_ void *r); floating substrings if needed. */ STATIC void -S_scan_commit(pTHX_ scan_data_t *data) +S_scan_commit(pTHX_ RExC_state_t *pRExC_state, scan_data_t *data) { - dTHR; STRLEN l = CHR_SVLEN(data->last_found); STRLEN old_l = CHR_SVLEN(*data->longest); @@ -425,14 +463,14 @@ S_scan_commit(pTHX_ scan_data_t *data) /* Can match anything (initialization) */ STATIC void -S_cl_anything(pTHX_ struct regnode_charclass_class *cl) +S_cl_anything(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl) { int value; ANYOF_CLASS_ZERO(cl); for (value = 0; value < 256; ++value) ANYOF_BITMAP_SET(cl, value); - cl->flags = ANYOF_EOS; + cl->flags = ANYOF_EOS|ANYOF_UNICODE_ALL; if (LOC) cl->flags |= ANYOF_LOCALE; } @@ -446,6 +484,8 @@ S_cl_is_anything(pTHX_ struct regnode_charclass_class *cl) for (value = 0; value <= ANYOF_MAX; value += 2) if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1)) return 1; + if (!(cl->flags & ANYOF_UNICODE_ALL)) + return 0; for (value = 0; value < 256; ++value) if (!ANYOF_BITMAP_TEST(cl, value)) return 0; @@ -454,19 +494,19 @@ S_cl_is_anything(pTHX_ struct regnode_charclass_class *cl) /* Can match anything (initialization) */ STATIC void -S_cl_init(pTHX_ struct regnode_charclass_class *cl) +S_cl_init(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl) { Zero(cl, 1, struct regnode_charclass_class); cl->type = ANYOF; - cl_anything(cl); + cl_anything(pRExC_state, cl); } STATIC void -S_cl_init_zero(pTHX_ struct regnode_charclass_class *cl) +S_cl_init_zero(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl) { Zero(cl, 1, struct regnode_charclass_class); cl->type = ANYOF; - cl_anything(cl); + cl_anything(pRExC_state, cl); if (LOC) cl->flags |= ANYOF_LOCALE; } @@ -493,12 +533,22 @@ S_cl_and(pTHX_ struct regnode_charclass_class *cl, } /* XXXX: logic is complicated otherwise, leave it along for a moment. */ if (!(and_with->flags & ANYOF_EOS)) cl->flags &= ~ANYOF_EOS; + + if (cl->flags & ANYOF_UNICODE_ALL && and_with->flags & ANYOF_UNICODE) { + cl->flags &= ~ANYOF_UNICODE_ALL; + cl->flags |= ANYOF_UNICODE; + ARG_SET(cl, ARG(and_with)); + } + if (!(and_with->flags & ANYOF_UNICODE_ALL)) + cl->flags &= ~ANYOF_UNICODE_ALL; + if (!(and_with->flags & (ANYOF_UNICODE|ANYOF_UNICODE_ALL))) + cl->flags &= ~ANYOF_UNICODE; } /* 'OR' a given class with another one. Can create false positives */ /* We assume that cl is not inverted */ STATIC void -S_cl_or(pTHX_ struct regnode_charclass_class *cl, struct regnode_charclass_class *or_with) +S_cl_or(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, struct regnode_charclass_class *or_with) { if (or_with->flags & ANYOF_INVERT) { /* We do not use @@ -519,7 +569,7 @@ S_cl_or(pTHX_ struct regnode_charclass_class *cl, struct regnode_charclass_class cl->bitmap[i] |= ~or_with->bitmap[i]; } /* XXXX: logic is complicated otherwise */ else { - cl_anything(cl); + cl_anything(pRExC_state, cl); } } else { /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */ @@ -538,11 +588,21 @@ S_cl_or(pTHX_ struct regnode_charclass_class *cl, struct regnode_charclass_class } } else { /* XXXX: logic is complicated, leave it along for a moment. */ - cl_anything(cl); + cl_anything(pRExC_state, cl); } } if (or_with->flags & ANYOF_EOS) cl->flags |= ANYOF_EOS; + + if (cl->flags & ANYOF_UNICODE && or_with->flags & ANYOF_UNICODE && + ARG(cl) != ARG(or_with)) { + cl->flags |= ANYOF_UNICODE_ALL; + cl->flags &= ~ANYOF_UNICODE; + } + if (or_with->flags & ANYOF_UNICODE_ALL) { + cl->flags |= ANYOF_UNICODE_ALL; + cl->flags &= ~ANYOF_UNICODE; + } } /* REx optimizer. Converts nodes into quickier variants "in place". @@ -552,12 +612,11 @@ S_cl_or(pTHX_ struct regnode_charclass_class *cl, struct regnode_charclass_class to the position after last scanned or to NULL. */ STATIC I32 -S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 flags) +S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 flags) /* scanp: Start here (read-write). */ /* deltap: Write maxlen-minlen here. */ /* last: Stop before this one. */ { - dTHR; I32 min = 0, pars = 0, code; regnode *scan = *scanp, *next; I32 delta = 0; @@ -661,29 +720,35 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da struct regnode_charclass_class accum; if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */ - scan_commit(data); /* Cannot merge strings after this. */ + scan_commit(pRExC_state, data); /* Cannot merge strings after this. */ if (flags & SCF_DO_STCLASS) - cl_init_zero(&accum); + cl_init_zero(pRExC_state, &accum); while (OP(scan) == code) { - I32 deltanext, minnext, f = 0; + I32 deltanext, minnext, f = 0, fake; 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) scan = NEXTOPER(scan); if (flags & SCF_DO_STCLASS) { - cl_init(&this_class); + cl_init(pRExC_state, &this_class); 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); + minnext = study_chunk(pRExC_state, &scan, &deltanext, + next, &data_fake, f); if (min1 > minnext) min1 = minnext; if (max1 < minnext + deltanext) @@ -698,7 +763,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da if (data) data->whilem_c = data_fake.whilem_c; if (flags & SCF_DO_STCLASS) - cl_or(&accum, &this_class); + cl_or(pRExC_state, &accum, &this_class); if (code == SUSPEND) break; } @@ -713,7 +778,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da min += min1; delta += max1 - min1; if (flags & SCF_DO_STCLASS_OR) { - cl_or(data->start_class, &accum); + cl_or(pRExC_state, data->start_class, &accum); if (min1) { cl_and(data->start_class, &and_with); flags &= ~SCF_DO_STCLASS; @@ -745,15 +810,11 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da } else if (OP(scan) == EXACT) { I32 l = STR_LEN(scan); + UV uc = *((U8*)STRING(scan)); if (UTF) { - unsigned char *s = (unsigned char *)STRING(scan); - unsigned char *e = s + l; - I32 newl = 0; - while (s < e) { - newl++; - s += UTF8SKIP(s); - } - l = newl; + U8 *s = (U8*)STRING(scan); + l = utf8_length(s, s + l); + uc = utf8_to_uv_simple(s, NULL); } min += l; if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */ @@ -773,21 +834,22 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da /* Check whether it is compatible with what we know already! */ int compat = 1; - if (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE)) - && !ANYOF_BITMAP_TEST(data->start_class, *STRING(scan)) + if (uc >= 0x100 || + !(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE)) + && !ANYOF_BITMAP_TEST(data->start_class, uc) && (!(data->start_class->flags & ANYOF_FOLD) - || !ANYOF_BITMAP_TEST(data->start_class, - PL_fold[*(U8*)STRING(scan)]))) + || !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc]))) compat = 0; ANYOF_CLASS_ZERO(data->start_class); ANYOF_BITMAP_ZERO(data->start_class); if (compat) - ANYOF_BITMAP_SET(data->start_class, *STRING(scan)); + ANYOF_BITMAP_SET(data->start_class, uc); data->start_class->flags &= ~ANYOF_EOS; } else if (flags & SCF_DO_STCLASS_OR) { /* false positive possible if the class is case-folded */ - ANYOF_BITMAP_SET(data->start_class, *STRING(scan)); + if (uc < 0x100) + ANYOF_BITMAP_SET(data->start_class, uc); data->start_class->flags &= ~ANYOF_EOS; cl_and(data->start_class, &and_with); } @@ -795,19 +857,15 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da } else if (PL_regkind[(U8)OP(scan)] == EXACT) { /* But OP != EXACT! */ I32 l = STR_LEN(scan); + UV uc = *((U8*)STRING(scan)); /* Search for fixed substrings supports EXACT only. */ if (flags & SCF_DO_SUBSTR) - scan_commit(data); + scan_commit(pRExC_state, data); if (UTF) { - unsigned char *s = (unsigned char *)STRING(scan); - unsigned char *e = s + l; - I32 newl = 0; - while (s < e) { - newl++; - s += UTF8SKIP(s); - } - l = newl; + U8 *s = (U8 *)STRING(scan); + l = utf8_length(s, s + l); + uc = utf8_to_uv_simple(s, NULL); } min += l; if (data && (flags & SCF_DO_SUBSTR)) @@ -816,15 +874,15 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da /* Check whether it is compatible with what we know already! */ int compat = 1; - if (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE)) - && !ANYOF_BITMAP_TEST(data->start_class, *STRING(scan)) - && !ANYOF_BITMAP_TEST(data->start_class, - PL_fold[*(U8*)STRING(scan)])) + if (uc >= 0x100 || + !(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE)) + && !ANYOF_BITMAP_TEST(data->start_class, uc) + && !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])) compat = 0; ANYOF_CLASS_ZERO(data->start_class); ANYOF_BITMAP_ZERO(data->start_class); if (compat) { - ANYOF_BITMAP_SET(data->start_class, *STRING(scan)); + ANYOF_BITMAP_SET(data->start_class, uc); data->start_class->flags &= ~ANYOF_EOS; data->start_class->flags |= ANYOF_FOLD; if (OP(scan) == EXACTFL) @@ -835,7 +893,8 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da if (data->start_class->flags & ANYOF_FOLD) { /* false positive possible if the class is case-folded. Assume that the locale settings are the same... */ - ANYOF_BITMAP_SET(data->start_class, *STRING(scan)); + if (uc < 0x100) + ANYOF_BITMAP_SET(data->start_class, uc); data->start_class->flags &= ~ANYOF_EOS; } cl_and(data->start_class, &and_with); @@ -843,8 +902,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; @@ -879,7 +938,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da is_inf = is_inf_internal = 1; scan = regnext(scan); if (flags & SCF_DO_SUBSTR) { - scan_commit(data); /* Cannot extend fixed substrings */ + scan_commit(pRExC_state, data); /* Cannot extend fixed substrings */ data->longest = &(data->longest_float); } goto optimize_curly_tail; @@ -887,10 +946,15 @@ 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) { - if (mincount == 0) scan_commit(data); /* Cannot extend fixed substrings */ + if (mincount == 0) scan_commit(pRExC_state,data); /* Cannot extend fixed substrings */ pos_before = data->pos_min; } if (data) { @@ -900,15 +964,23 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da data->flags |= SF_IS_INF; } if (flags & SCF_DO_STCLASS) { - cl_init(&this_class); + cl_init(pRExC_state, &this_class); oclass = data->start_class; data->start_class = &this_class; 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, + minnext = study_chunk(pRExC_state, &scan, &deltanext, last, data, mincount == 0 ? (f & ~SCF_DO_SUBSTR) : f); @@ -916,7 +988,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da data->start_class = oclass; if (mincount == 0 || minnext == 0) { if (flags & SCF_DO_STCLASS_OR) { - cl_or(data->start_class, &this_class); + cl_or(pRExC_state, data->start_class, &this_class); } else if (flags & SCF_DO_STCLASS_AND) { /* Switch to OR mode: cache the old value of @@ -931,7 +1003,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da } } else { /* Non-zero len */ if (flags & SCF_DO_STCLASS_OR) { - cl_or(data->start_class, &this_class); + cl_or(pRExC_state, data->start_class, &this_class); cl_and(data->start_class, &and_with); } else if (flags & SCF_DO_STCLASS_AND) @@ -944,7 +1016,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da && !(data->flags & (SF_HAS_PAR|SF_IN_PAR)) && maxcount <= REG_INFTY/3) /* Complement check for big count */ { - vWARN(PL_regcomp_parse, + vWARN(RExC_parse, "Quantifier unexpected on zero-length expression"); } @@ -1036,20 +1108,27 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da } #endif /* Optimize again: */ - study_chunk(&nxt1, &deltanext, nxt, NULL, 0); + study_chunk(pRExC_state, &nxt1, &deltanext, nxt, + NULL, 0); } 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); if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */ nxt += ARG(nxt); PREVOPER(nxt)->flags = data->whilem_c - | (PL_reg_whilem_seen << 4); /* On WHILEM */ + | (RExC_whilem_seen << 4); /* On WHILEM */ } if (data && fl & (SF_HAS_PAR|SF_IN_PAR)) pars++; @@ -1097,7 +1176,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da if (mincount != maxcount) { /* Cannot extend fixed substrings found inside the group. */ - scan_commit(data); + scan_commit(pRExC_state,data); if (mincount && last_str) { sv_setsv(data->last_found, last_str); data->last_end = data->pos_min; @@ -1123,21 +1202,21 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da continue; default: /* REF and CLUMP only? */ if (flags & SCF_DO_SUBSTR) { - scan_commit(data); /* Cannot expect anything... */ + scan_commit(pRExC_state,data); /* Cannot expect anything... */ data->longest = &(data->longest_float); } is_inf = is_inf_internal = 1; if (flags & SCF_DO_STCLASS_OR) - cl_anything(data->start_class); + cl_anything(pRExC_state, data->start_class); flags &= ~SCF_DO_STCLASS; break; } } - else if (strchr((char*)PL_simple,OP(scan)) || PL_regkind[(U8)OP(scan)] == ANYUTF8) { + else if (strchr((char*)PL_simple,OP(scan))) { int value; if (flags & SCF_DO_SUBSTR) { - scan_commit(data); + scan_commit(pRExC_state,data); data->pos_min++; } min++; @@ -1147,25 +1226,12 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da /* Some of the logic below assumes that switching locale on will only add false positives. */ switch (PL_regkind[(U8)OP(scan)]) { - case ANYUTF8: case SANY: - case SANYUTF8: - case ALNUMUTF8: - case ANYOFUTF8: - case ALNUMLUTF8: - case NALNUMUTF8: - case NALNUMLUTF8: - case SPACEUTF8: - case NSPACEUTF8: - case SPACELUTF8: - case NSPACELUTF8: - case DIGITUTF8: - case NDIGITUTF8: default: do_default: /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */ if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ - cl_anything(data->start_class); + cl_anything(pRExC_state, data->start_class); break; case REG_ANY: if (OP(scan) == SANY) @@ -1173,7 +1239,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */ value = (ANYOF_BITMAP_TEST(data->start_class,'\n') || (data->start_class->flags & ANYOF_CLASS)); - cl_anything(data->start_class); + cl_anything(pRExC_state, data->start_class); } if (flags & SCF_DO_STCLASS_AND || !value) ANYOF_BITMAP_CLEAR(data->start_class,'\n'); @@ -1183,7 +1249,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da cl_and(data->start_class, (struct regnode_charclass_class*)scan); else - cl_or(data->start_class, + cl_or(pRExC_state, data->start_class, (struct regnode_charclass_class*)scan); break; case ALNUM: @@ -1356,23 +1422,29 @@ 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); + cl_init(pRExC_state, &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); + minnext = study_chunk(pRExC_state, &nscan, &deltanext, last, &data_fake, f); if (scan->flags) { if (deltanext) { vFAIL("Variable length lookbehind not implemented"); @@ -1388,7 +1460,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); @@ -1399,11 +1471,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) @@ -1411,12 +1487,12 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da } else if (OP(scan) == LOGICAL && scan->flags == 2) { /* Embedded follows */ if (flags & SCF_DO_SUBSTR) { - scan_commit(data); + scan_commit(pRExC_state,data); data->longest = &(data->longest_float); } is_inf = is_inf_internal = 1; if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ - cl_anything(data->start_class); + cl_anything(pRExC_state, data->start_class); flags &= ~SCF_DO_STCLASS; } /* Else: zero-length, ignore. */ @@ -1444,30 +1520,28 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da } STATIC I32 -S_add_data(pTHX_ I32 n, char *s) +S_add_data(pTHX_ RExC_state_t *pRExC_state, 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), + if (RExC_rx->data) { + Renewc(RExC_rx->data, + sizeof(*RExC_rx->data) + sizeof(void*) * (RExC_rx->data->count + n - 1), char, struct reg_data); - Renew(PL_regcomp_rx->data->what, PL_regcomp_rx->data->count + n, U8); - PL_regcomp_rx->data->count += n; + Renew(RExC_rx->data->what, RExC_rx->data->count + n, U8); + RExC_rx->data->count += n; } else { - Newc(1207, PL_regcomp_rx->data, sizeof(*PL_regcomp_rx->data) + sizeof(void*) * (n - 1), + Newc(1207, RExC_rx->data, sizeof(*RExC_rx->data) + sizeof(void*) * (n - 1), char, struct reg_data); - New(1208, PL_regcomp_rx->data->what, n, U8); - PL_regcomp_rx->data->count = n; + New(1208, RExC_rx->data->what, n, U8); + RExC_rx->data->count = n; } - Copy(s, PL_regcomp_rx->data->what + PL_regcomp_rx->data->count - n, n, U8); - return PL_regcomp_rx->data->count - n; + Copy(s, RExC_rx->data->what + RExC_rx->data->count - n, n, U8); + return RExC_rx->data->count - n; } void Perl_reginitcolors(pTHX) { - dTHR; int i = 0; char *s = PerlEnv_getenv("PERL_RE_COLORS"); @@ -1508,7 +1582,6 @@ Perl_reginitcolors(pTHX) regexp * Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) { - dTHR; register regexp *r; regnode *scan; regnode *first; @@ -1517,100 +1590,102 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) I32 sawplus = 0; I32 sawopen = 0; scan_data_t data; + RExC_state_t RExC_state; + RExC_state_t *pRExC_state = &RExC_state; if (exp == NULL) FAIL("NULL regexp argument"); - if (pm->op_pmdynflags & PMdf_UTF8) { - PL_reg_flags |= RF_utf8; - } + /* XXXX This looks very suspicious... */ + if (pm->op_pmdynflags & PMdf_CMP_UTF8) + RExC_utf8 = 1; else - PL_reg_flags = 0; + RExC_utf8 = 0; - PL_regprecomp = savepvn(exp, xend - exp); + RExC_precomp = savepvn(exp, xend - 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], - (int)(xend - exp), PL_regprecomp, PL_colors[1])); - PL_regflags = pm->op_pmflags; - PL_regsawback = 0; + (int)(xend - exp), RExC_precomp, PL_colors[1])); + RExC_flags16 = pm->op_pmflags; + RExC_sawback = 0; - PL_regseen = 0; - PL_seen_zerolen = *exp == '^' ? -1 : 0; - PL_seen_evals = 0; - PL_extralen = 0; + RExC_seen = 0; + RExC_seen_zerolen = *exp == '^' ? -1 : 0; + RExC_seen_evals = 0; + RExC_extralen = 0; /* First pass: determine size, legality. */ - PL_regcomp_parse = exp; - PL_regxend = xend; - PL_regnaughty = 0; - PL_regnpar = 1; - PL_regsize = 0L; - PL_regcode = &PL_regdummy; - PL_reg_whilem_seen = 0; + RExC_parse = exp; + RExC_end = xend; + RExC_naughty = 0; + RExC_npar = 1; + RExC_size = 0L; + RExC_emit = &PL_regdummy; + RExC_whilem_seen = 0; #if 0 /* REGC() is (currently) a NOP at the first pass. * Clever compilers notice this and complain. --jhi */ - REGC((U8)REG_MAGIC, (char*)PL_regcode); + REGC((U8)REG_MAGIC, (char*)RExC_emit); #endif - if (reg(0, &flags) == NULL) { - Safefree(PL_regprecomp); - PL_regprecomp = Nullch; + if (reg(pRExC_state, 0, &flags) == NULL) { + Safefree(RExC_precomp); + RExC_precomp = Nullch; return(NULL); } - DEBUG_r(PerlIO_printf(Perl_debug_log, "size %"IVdf" ", (IV)PL_regsize)); + DEBUG_r(PerlIO_printf(Perl_debug_log, "size %"IVdf" ", (IV)RExC_size)); /* Small enough for pointer-storage convention? If extralen==0, this means that we will not need long jumps. */ - if (PL_regsize >= 0x10000L && PL_extralen) - PL_regsize += PL_extralen; + if (RExC_size >= 0x10000L && RExC_extralen) + RExC_size += RExC_extralen; else - PL_extralen = 0; - if (PL_reg_whilem_seen > 15) - PL_reg_whilem_seen = 15; + RExC_extralen = 0; + if (RExC_whilem_seen > 15) + RExC_whilem_seen = 15; /* Allocate space and initialize. */ - Newc(1001, r, sizeof(regexp) + (unsigned)PL_regsize * sizeof(regnode), + Newc(1001, r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode), char, regexp); if (r == NULL) 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); + Zero(r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode), char); #endif r->refcnt = 1; r->prelen = xend - exp; - r->precomp = PL_regprecomp; + r->precomp = RExC_precomp; r->subbeg = NULL; r->reganch = pm->op_pmflags & PMf_COMPILETIME; - r->nparens = PL_regnpar - 1; /* set early to validate backrefs */ + r->nparens = RExC_npar - 1; /* set early to validate backrefs */ r->substrs = 0; /* Useful during FAIL. */ r->startp = 0; /* Useful during FAIL. */ r->endp = 0; /* Useful during FAIL. */ - PL_regcomp_rx = r; + RExC_rx = r; /* Second pass: emit code. */ - PL_regcomp_parse = exp; - PL_regxend = xend; - PL_regnaughty = 0; - PL_regnpar = 1; - PL_regcode = r->program; + RExC_parse = exp; + RExC_end = xend; + RExC_naughty = 0; + RExC_npar = 1; + RExC_emit = r->program; /* Store the count of eval-groups for security checks: */ - PL_regcode->next_off = ((PL_seen_evals > U16_MAX) ? U16_MAX : PL_seen_evals); - REGC((U8)REG_MAGIC, (char*) PL_regcode++); + RExC_emit->next_off = ((RExC_seen_evals > U16_MAX) ? U16_MAX : RExC_seen_evals); + REGC((U8)REG_MAGIC, (char*) RExC_emit++); r->data = 0; - if (reg(0, &flags) == NULL) + if (reg(pRExC_state, 0, &flags) == NULL) return(NULL); /* Dig out information for optimizations. */ r->reganch = pm->op_pmflags & PMf_COMPILETIME; /* Again? */ - pm->op_pmflags = PL_regflags; + pm->op_pmflags = RExC_flags16; if (UTF) r->reganch |= ROPT_UTF8; r->regstclass = NULL; - if (PL_regnaughty >= 10) /* Probably an expensive pattern. */ + if (RExC_naughty >= 10) /* Probably an expensive pattern. */ r->reganch |= ROPT_NAUGHTY; scan = r->program + 1; /* First BRANCH. */ @@ -1625,6 +1700,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. */ @@ -1645,9 +1721,9 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) /* Starting-point info. */ again: if (PL_regkind[(U8)OP(first)] == EXACT) { - if (OP(first) == EXACT); /* Empty, get anchored substr later. */ - else if ((OP(first) == EXACTF || OP(first) == EXACTFL) - && !UTF) + if (OP(first) == EXACT) + ; /* Empty, get anchored substr later. */ + else if ((OP(first) == EXACTF || OP(first) == EXACTFL)) r->regstclass = first; } else if (strchr((char*)PL_simple,OP(first))) @@ -1676,7 +1752,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) /* turn .* into ^.* with an implied $*=1 */ int type = OP(NEXTOPER(first)); - if (type == REG_ANY || type == ANYUTF8) + if (type == REG_ANY) type = ROPT_ANCH_MBOL; else type = ROPT_ANCH_SBOL; @@ -1685,8 +1761,8 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) first = NEXTOPER(first); goto again; } - if (sawplus && (!sawopen || !PL_regsawback) - && !(PL_regseen & REG_SEEN_EVAL)) /* May examine pos and $& */ + if (sawplus && (!sawopen || !RExC_sawback) + && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */ /* x+ must match at the 1st pos of run of x's */ r->reganch |= ROPT_SKIP; @@ -1712,27 +1788,28 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) data.longest = &(data.longest_fixed); first = scan; if (!r->regstclass) { - cl_init(&ch_class); + cl_init(pRExC_state, &ch_class); data.start_class = &ch_class; 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); - if ( PL_regnpar == 1 && data.longest == &(data.longest_fixed) + minlen = study_chunk(pRExC_state, &first, &fake, scan + RExC_size, /* Up to end */ + &data, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag); + if ( RExC_npar == 1 && data.longest == &(data.longest_fixed) && data.last_start_min == 0 && data.last_end > 0 - && !PL_seen_zerolen - && (!(PL_regseen & REG_SEEN_GPOS) || (r->reganch & ROPT_ANCH_GPOS))) + && !RExC_seen_zerolen + && (!(RExC_seen & REG_SEEN_GPOS) || (r->reganch & ROPT_ANCH_GPOS))) r->reganch |= ROPT_CHECK_ALL; - scan_commit(&data); + scan_commit(pRExC_state, &data); SvREFCNT_dec(data.last_found); longest_float_length = CHR_SVLEN(data.longest_float); if (longest_float_length || (data.flags & SF_FL_BEFORE_EOL && (!(data.flags & SF_FL_BEFORE_MEOL) - || (PL_regflags & PMf_MULTILINE)))) { + || (RExC_flags16 & PMf_MULTILINE)))) { int t; if (SvCUR(data.longest_fixed) /* ok to leave SvCUR */ @@ -1745,7 +1822,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) r->float_max_offset = data.offset_float_max; t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */ && (!(data.flags & SF_FL_BEFORE_MEOL) - || (PL_regflags & PMf_MULTILINE))); + || (RExC_flags16 & PMf_MULTILINE))); fbm_compile(r->float_substr, t ? FBMcf_TAIL : 0); } else { @@ -1759,14 +1836,14 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) if (longest_fixed_length || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */ && (!(data.flags & SF_FIX_BEFORE_MEOL) - || (PL_regflags & PMf_MULTILINE)))) { + || (RExC_flags16 & PMf_MULTILINE)))) { int t; r->anchored_substr = data.longest_fixed; r->anchored_offset = data.offset_fixed; t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */ && (!(data.flags & SF_FIX_BEFORE_MEOL) - || (PL_regflags & PMf_MULTILINE))); + || (RExC_flags16 & PMf_MULTILINE))); fbm_compile(r->anchored_substr, t ? FBMcf_TAIL : 0); } else { @@ -1775,22 +1852,22 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) longest_fixed_length = 0; } if (r->regstclass - && (OP(r->regstclass) == REG_ANY || OP(r->regstclass) == ANYUTF8 - || OP(r->regstclass) == SANYUTF8 || OP(r->regstclass) == SANY)) + && (OP(r->regstclass) == REG_ANY || OP(r->regstclass) == SANY)) r->regstclass = NULL; if ((!r->anchored_substr || r->anchored_offset) && stclass_flag && !(data.start_class->flags & ANYOF_EOS) && !cl_is_anything(data.start_class)) { SV *sv; - I32 n = add_data(1, "f"); + I32 n = add_data(pRExC_state, 1, "f"); - New(1006, PL_regcomp_rx->data->data[n], 1, + New(1006, RExC_rx->data->data[n], 1, struct regnode_charclass_class); StructCopy(data.start_class, - (struct regnode_charclass_class*)PL_regcomp_rx->data->data[n], + (struct regnode_charclass_class*)RExC_rx->data->data[n], struct regnode_charclass_class); - r->regstclass = (regnode*)PL_regcomp_rx->data->data[n]; + r->regstclass = (regnode*)RExC_rx->data->data[n]; r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */ + PL_regdata = r->data; /* for regprop() */ DEBUG_r((sv = sv_newmortal(), regprop(sv, (regnode*)data.start_class), PerlIO_printf(Perl_debug_log, "synthetic stclass `%s'.\n", @@ -1821,24 +1898,26 @@ 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); + cl_init(pRExC_state, &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(pRExC_state, &scan, &fake, scan + RExC_size, &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)) { SV *sv; - I32 n = add_data(1, "f"); + I32 n = add_data(pRExC_state, 1, "f"); - New(1006, PL_regcomp_rx->data->data[n], 1, + New(1006, RExC_rx->data->data[n], 1, struct regnode_charclass_class); StructCopy(data.start_class, - (struct regnode_charclass_class*)PL_regcomp_rx->data->data[n], + (struct regnode_charclass_class*)RExC_rx->data->data[n], struct regnode_charclass_class); - r->regstclass = (regnode*)PL_regcomp_rx->data->data[n]; + r->regstclass = (regnode*)RExC_rx->data->data[n]; r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */ DEBUG_r((sv = sv_newmortal(), regprop(sv, (regnode*)data.start_class), @@ -1848,14 +1927,15 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) } r->minlen = minlen; - if (PL_regseen & REG_SEEN_GPOS) + if (RExC_seen & REG_SEEN_GPOS) r->reganch |= ROPT_GPOS_SEEN; - if (PL_regseen & REG_SEEN_LOOKBEHIND) + if (RExC_seen & REG_SEEN_LOOKBEHIND) r->reganch |= ROPT_LOOKBEHIND_SEEN; - if (PL_regseen & REG_SEEN_EVAL) + if (RExC_seen & REG_SEEN_EVAL) r->reganch |= ROPT_EVAL_SEEN; - Newz(1002, r->startp, PL_regnpar, I32); - Newz(1002, r->endp, PL_regnpar, I32); + Newz(1002, r->startp, RExC_npar, I32); + Newz(1002, r->endp, RExC_npar, I32); + PL_regdata = r->data; /* for regprop() */ DEBUG_r(regdump(r)); return(r); } @@ -1870,43 +1950,42 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) * follows makes it hard to avoid. */ STATIC regnode * -S_reg(pTHX_ I32 paren, I32 *flagp) +S_reg(pTHX_ RExC_state_t *pRExC_state, 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; + I32 flags, oregflags = RExC_flags16, have_branch = 0, open = 0; + char *oregcomp_parse = RExC_parse; char c; *flagp = 0; /* Tentatively. */ /* Make an OPEN node, if parenthesized. */ if (paren) { - if (*PL_regcomp_parse == '?') { + if (*RExC_parse == '?') { U16 posflags = 0, negflags = 0; U16 *flagsp = &posflags; int logical = 0; - char *seqstart = PL_regcomp_parse; + char *seqstart = RExC_parse; - PL_regcomp_parse++; - paren = *PL_regcomp_parse++; + RExC_parse++; + paren = *RExC_parse++; ret = NULL; /* For look-ahead/behind. */ switch (paren) { case '<': - PL_regseen |= REG_SEEN_LOOKBEHIND; - if (*PL_regcomp_parse == '!') + RExC_seen |= REG_SEEN_LOOKBEHIND; + if (*RExC_parse == '!') paren = ','; - if (*PL_regcomp_parse != '=' && *PL_regcomp_parse != '!') + if (*RExC_parse != '=' && *RExC_parse != '!') goto unknown; - PL_regcomp_parse++; + RExC_parse++; case '=': case '!': - PL_seen_zerolen++; + RExC_seen_zerolen++; case ':': case '>': break; @@ -1915,51 +1994,50 @@ S_reg(pTHX_ I32 paren, I32 *flagp) vFAIL2("Sequence (?%c...) not implemented", (int)paren); break; case '#': - while (*PL_regcomp_parse && *PL_regcomp_parse != ')') - PL_regcomp_parse++; - if (*PL_regcomp_parse != ')') + while (*RExC_parse && *RExC_parse != ')') + RExC_parse++; + if (*RExC_parse != ')') FAIL("Sequence (?#... not terminated"); - nextchar(); + nextchar(pRExC_state); *flagp = TRYAGAIN; return NULL; case 'p': if (SIZE_ONLY) - vWARN(PL_regcomp_parse, "(?p{}) is deprecated - use (??{})"); + vWARN(RExC_parse, "(?p{}) is deprecated - use (??{})"); /* FALL THROUGH*/ case '?': logical = 1; - paren = *PL_regcomp_parse++; + paren = *RExC_parse++; /* FALL THROUGH */ case '{': { - dTHR; I32 count = 1, n = 0; char c; - char *s = PL_regcomp_parse; + char *s = RExC_parse; SV *sv; OP_4tree *sop, *rop; - PL_seen_zerolen++; - PL_regseen |= REG_SEEN_EVAL; - while (count && (c = *PL_regcomp_parse)) { - if (c == '\\' && PL_regcomp_parse[1]) - PL_regcomp_parse++; + RExC_seen_zerolen++; + RExC_seen |= REG_SEEN_EVAL; + while (count && (c = *RExC_parse)) { + if (c == '\\' && RExC_parse[1]) + RExC_parse++; else if (c == '{') count++; else if (c == '}') count--; - PL_regcomp_parse++; + RExC_parse++; } - if (*PL_regcomp_parse != ')') + if (*RExC_parse != ')') { - PL_regcomp_parse = s; + RExC_parse = s; vFAIL("Sequence (?{...}) not terminated or not {}-balanced"); } if (!SIZE_ONLY) { AV *av; - if (PL_regcomp_parse - 1 - s) - sv = newSVpvn(s, PL_regcomp_parse - 1 - s); + if (RExC_parse - 1 - s) + sv = newSVpvn(s, RExC_parse - 1 - s); else sv = newSVpvn("", 0); @@ -1968,14 +2046,14 @@ S_reg(pTHX_ I32 paren, I32 *flagp) rop = sv_compile_2op(sv, &sop, "re", &av); LEAVE; - n = add_data(3, "nop"); - PL_regcomp_rx->data->data[n] = (void*)rop; - PL_regcomp_rx->data->data[n+1] = (void*)sop; - PL_regcomp_rx->data->data[n+2] = (void*)av; + n = add_data(pRExC_state, 3, "nop"); + RExC_rx->data->data[n] = (void*)rop; + RExC_rx->data->data[n+1] = (void*)sop; + RExC_rx->data->data[n+2] = (void*)av; SvREFCNT_dec(sv); } else { /* First pass */ - if (PL_reginterp_cnt < ++PL_seen_evals + if (PL_reginterp_cnt < ++RExC_seen_evals && PL_curcop != &PL_compiling) /* No compiled RE interpolated, has runtime components ===> unsafe. */ @@ -1984,113 +2062,113 @@ S_reg(pTHX_ I32 paren, I32 *flagp) FAIL("Eval-group in insecure regular expression"); } - nextchar(); + nextchar(pRExC_state); if (logical) { - ret = reg_node(LOGICAL); + ret = reg_node(pRExC_state, LOGICAL); if (!SIZE_ONLY) ret->flags = 2; - regtail(ret, reganode(EVAL, n)); + regtail(pRExC_state, ret, reganode(pRExC_state, EVAL, n)); return ret; } - return reganode(EVAL, n); + return reganode(pRExC_state, EVAL, n); } case '(': { - if (PL_regcomp_parse[0] == '?') { - if (PL_regcomp_parse[1] == '=' || PL_regcomp_parse[1] == '!' - || PL_regcomp_parse[1] == '<' - || PL_regcomp_parse[1] == '{') { /* Lookahead or eval. */ + if (RExC_parse[0] == '?') { + if (RExC_parse[1] == '=' || RExC_parse[1] == '!' + || RExC_parse[1] == '<' + || RExC_parse[1] == '{') { /* Lookahead or eval. */ I32 flag; - ret = reg_node(LOGICAL); + ret = reg_node(pRExC_state, LOGICAL); if (!SIZE_ONLY) ret->flags = 1; - regtail(ret, reg(1, &flag)); + regtail(pRExC_state, ret, reg(pRExC_state, 1, &flag)); goto insert_if; } } - else if (PL_regcomp_parse[0] >= '1' && PL_regcomp_parse[0] <= '9' ) { - parno = atoi(PL_regcomp_parse++); + else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) { + parno = atoi(RExC_parse++); - while (isDIGIT(*PL_regcomp_parse)) - PL_regcomp_parse++; - ret = reganode(GROUPP, parno); - if ((c = *nextchar()) != ')') + while (isDIGIT(*RExC_parse)) + RExC_parse++; + ret = reganode(pRExC_state, GROUPP, parno); + if ((c = *nextchar(pRExC_state)) != ')') vFAIL("Switch condition not recognized"); insert_if: - regtail(ret, reganode(IFTHEN, 0)); - br = regbranch(&flags, 1); + regtail(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0)); + br = regbranch(pRExC_state, &flags, 1); if (br == NULL) - br = reganode(LONGJMP, 0); + br = reganode(pRExC_state, LONGJMP, 0); else - regtail(br, reganode(LONGJMP, 0)); - c = *nextchar(); + regtail(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0)); + c = *nextchar(pRExC_state); if (flags&HASWIDTH) *flagp |= HASWIDTH; if (c == '|') { - lastbr = reganode(IFTHEN, 0); /* Fake one for optimizer. */ - regbranch(&flags, 1); - regtail(ret, lastbr); + lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */ + regbranch(pRExC_state, &flags, 1); + regtail(pRExC_state, ret, lastbr); if (flags&HASWIDTH) *flagp |= HASWIDTH; - c = *nextchar(); + c = *nextchar(pRExC_state); } else lastbr = NULL; if (c != ')') vFAIL("Switch (?(condition)... contains too many branches"); - ender = reg_node(TAIL); - regtail(br, ender); + ender = reg_node(pRExC_state, TAIL); + regtail(pRExC_state, br, ender); if (lastbr) { - regtail(lastbr, ender); - regtail(NEXTOPER(NEXTOPER(lastbr)), ender); + regtail(pRExC_state, lastbr, ender); + regtail(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); } else - regtail(ret, ender); + regtail(pRExC_state, ret, ender); return ret; } else { - vFAIL2("Unknown switch condition (?(%.2s", PL_regcomp_parse); + vFAIL2("Unknown switch condition (?(%.2s", RExC_parse); } } case 0: - PL_regcomp_parse--; /* for vFAIL to print correctly */ + RExC_parse--; /* for vFAIL to print correctly */ vFAIL("Sequence (? incomplete"); break; default: - --PL_regcomp_parse; + --RExC_parse; parse_flags: - while (*PL_regcomp_parse && strchr("iogcmsx", *PL_regcomp_parse)) { - if (*PL_regcomp_parse != 'o') - pmflag(flagsp, *PL_regcomp_parse); - ++PL_regcomp_parse; + while (*RExC_parse && strchr("iogcmsx", *RExC_parse)) { + if (*RExC_parse != 'o') + pmflag(flagsp, *RExC_parse); + ++RExC_parse; } - if (*PL_regcomp_parse == '-') { + if (*RExC_parse == '-') { flagsp = &negflags; - ++PL_regcomp_parse; + ++RExC_parse; goto parse_flags; } - PL_regflags |= posflags; - PL_regflags &= ~negflags; - if (*PL_regcomp_parse == ':') { - PL_regcomp_parse++; + RExC_flags16 |= posflags; + RExC_flags16 &= ~negflags; + if (*RExC_parse == ':') { + RExC_parse++; paren = ':'; break; } unknown: - if (*PL_regcomp_parse != ')') { - PL_regcomp_parse++; - vFAIL3("Sequence (%.*s...) not recognized", PL_regcomp_parse-seqstart, seqstart); + if (*RExC_parse != ')') { + RExC_parse++; + vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart); } - nextchar(); + nextchar(pRExC_state); *flagp = TRYAGAIN; return NULL; } } else { - parno = PL_regnpar; - PL_regnpar++; - ret = reganode(OPEN, parno); + parno = RExC_npar; + RExC_npar++; + ret = reganode(pRExC_state, OPEN, parno); open = 1; } } @@ -2098,24 +2176,24 @@ S_reg(pTHX_ I32 paren, I32 *flagp) ret = NULL; /* Pick up the branches, linking them together. */ - br = regbranch(&flags, 1); + br = regbranch(pRExC_state, &flags, 1); if (br == NULL) return(NULL); - if (*PL_regcomp_parse == '|') { - if (!SIZE_ONLY && PL_extralen) { - reginsert(BRANCHJ, br); + if (*RExC_parse == '|') { + if (!SIZE_ONLY && RExC_extralen) { + reginsert(pRExC_state, BRANCHJ, br); } else - reginsert(BRANCH, br); + reginsert(pRExC_state, BRANCH, br); have_branch = 1; if (SIZE_ONLY) - PL_extralen += 1; /* For BRANCHJ-BRANCH. */ + RExC_extralen += 1; /* For BRANCHJ-BRANCH. */ } else if (paren == ':') { *flagp |= flags&SIMPLE; } if (open) { /* Starts with OPEN. */ - regtail(ret, br); /* OPEN -> first. */ + regtail(pRExC_state, ret, br); /* OPEN -> first. */ } else if (paren != '?') /* Not Conditional */ ret = br; @@ -2123,18 +2201,18 @@ S_reg(pTHX_ I32 paren, I32 *flagp) *flagp |= HASWIDTH; *flagp |= flags&SPSTART; lastbr = br; - while (*PL_regcomp_parse == '|') { - if (!SIZE_ONLY && PL_extralen) { - ender = reganode(LONGJMP,0); - regtail(NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */ + while (*RExC_parse == '|') { + if (!SIZE_ONLY && RExC_extralen) { + ender = reganode(pRExC_state, LONGJMP,0); + regtail(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */ } if (SIZE_ONLY) - PL_extralen += 2; /* Account for LONGJMP. */ - nextchar(); - br = regbranch(&flags, 0); + RExC_extralen += 2; /* Account for LONGJMP. */ + nextchar(pRExC_state); + br = regbranch(pRExC_state, &flags, 0); if (br == NULL) return(NULL); - regtail(lastbr, br); /* BRANCH -> BRANCH. */ + regtail(pRExC_state, lastbr, br); /* BRANCH -> BRANCH. */ lastbr = br; if (flags&HASWIDTH) *flagp |= HASWIDTH; @@ -2145,10 +2223,10 @@ S_reg(pTHX_ I32 paren, I32 *flagp) /* Make a closing node, and hook it on the end. */ switch (paren) { case ':': - ender = reg_node(TAIL); + ender = reg_node(pRExC_state, TAIL); break; case 1: - ender = reganode(CLOSE, parno); + ender = reganode(pRExC_state, CLOSE, parno); break; case '<': case ',': @@ -2157,18 +2235,18 @@ S_reg(pTHX_ I32 paren, I32 *flagp) *flagp &= ~HASWIDTH; /* FALL THROUGH */ case '>': - ender = reg_node(SUCCEED); + ender = reg_node(pRExC_state, SUCCEED); break; case 0: - ender = reg_node(END); + ender = reg_node(pRExC_state, END); break; } - regtail(lastbr, ender); + regtail(pRExC_state, lastbr, ender); if (have_branch) { /* Hook the tails of the branches to the closing node. */ for (br = ret; br != NULL; br = regnext(br)) { - regoptail(br, ender); + regoptail(pRExC_state, br, ender); } } } @@ -2183,23 +2261,23 @@ S_reg(pTHX_ I32 paren, I32 *flagp) if (paren == '>') node = SUSPEND, flag = 0; - reginsert(node,ret); + reginsert(pRExC_state, node,ret); ret->flags = flag; - regtail(ret, reg_node(TAIL)); + regtail(pRExC_state, ret, reg_node(pRExC_state, TAIL)); } } /* Check for proper termination. */ if (paren) { - PL_regflags = oregflags; - if (PL_regcomp_parse >= PL_regxend || *nextchar() != ')') { - PL_regcomp_parse = oregcomp_parse; + RExC_flags16 = oregflags; + if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') { + RExC_parse = oregcomp_parse; vFAIL("Unmatched ("); } } - else if (!paren && PL_regcomp_parse < PL_regxend) { - if (*PL_regcomp_parse == ')') { - PL_regcomp_parse++; + else if (!paren && RExC_parse < RExC_end) { + if (*RExC_parse == ')') { + RExC_parse++; vFAIL("Unmatched )"); } else @@ -2216,9 +2294,8 @@ S_reg(pTHX_ I32 paren, I32 *flagp) * Implements the concatenation operator. */ STATIC regnode * -S_regbranch(pTHX_ I32 *flagp, I32 first) +S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first) { - dTHR; register regnode *ret; register regnode *chain = NULL; register regnode *latest; @@ -2227,22 +2304,22 @@ S_regbranch(pTHX_ I32 *flagp, I32 first) if (first) ret = NULL; else { - if (!SIZE_ONLY && PL_extralen) - ret = reganode(BRANCHJ,0); + if (!SIZE_ONLY && RExC_extralen) + ret = reganode(pRExC_state, BRANCHJ,0); else - ret = reg_node(BRANCH); + ret = reg_node(pRExC_state, BRANCH); } if (!first && SIZE_ONLY) - PL_extralen += 1; /* BRANCHJ */ + RExC_extralen += 1; /* BRANCHJ */ *flagp = WORST; /* Tentatively. */ - PL_regcomp_parse--; - nextchar(); - while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != '|' && *PL_regcomp_parse != ')') { + RExC_parse--; + nextchar(pRExC_state); + while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') { flags &= ~TRYAGAIN; - latest = regpiece(&flags); + latest = regpiece(pRExC_state, &flags); if (latest == NULL) { if (flags & TRYAGAIN) continue; @@ -2254,14 +2331,14 @@ S_regbranch(pTHX_ I32 *flagp, I32 first) if (chain == NULL) /* First piece. */ *flagp |= flags&SPSTART; else { - PL_regnaughty++; - regtail(chain, latest); + RExC_naughty++; + regtail(pRExC_state, chain, latest); } chain = latest; c++; } if (chain == NULL) { /* Loop ran zero times. */ - chain = reg_node(NOTHING); + chain = reg_node(pRExC_state, NOTHING); if (ret == NULL) ret = chain; } @@ -2282,29 +2359,28 @@ S_regbranch(pTHX_ I32 *flagp, I32 first) * endmarker role is not redundant. */ STATIC regnode * -S_regpiece(pTHX_ I32 *flagp) +S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp) { - dTHR; register regnode *ret; register char op; register char *next; I32 flags; - char *origparse = PL_regcomp_parse; + char *origparse = RExC_parse; char *maxpos; I32 min; I32 max = REG_INFTY; - ret = regatom(&flags); + ret = regatom(pRExC_state, &flags); if (ret == NULL) { if (flags & TRYAGAIN) *flagp |= TRYAGAIN; return(NULL); } - op = *PL_regcomp_parse; + op = *RExC_parse; - if (op == '{' && regcurly(PL_regcomp_parse)) { - next = PL_regcomp_parse + 1; + if (op == '{' && regcurly(RExC_parse)) { + next = RExC_parse + 1; maxpos = Nullch; while (isDIGIT(*next) || *next == ',') { if (*next == ',') { @@ -2318,42 +2394,42 @@ S_regpiece(pTHX_ I32 *flagp) if (*next == '}') { /* got one */ if (!maxpos) maxpos = next; - PL_regcomp_parse++; - min = atoi(PL_regcomp_parse); + RExC_parse++; + min = atoi(RExC_parse); if (*maxpos == ',') maxpos++; else - maxpos = PL_regcomp_parse; + maxpos = RExC_parse; max = atoi(maxpos); if (!max && *maxpos != '0') max = REG_INFTY; /* meaning "infinity" */ else if (max >= REG_INFTY) vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1); - PL_regcomp_parse = next; - nextchar(); + RExC_parse = next; + nextchar(pRExC_state); do_curly: if ((flags&SIMPLE)) { - PL_regnaughty += 2 + PL_regnaughty / 2; - reginsert(CURLY, ret); + RExC_naughty += 2 + RExC_naughty / 2; + reginsert(pRExC_state, CURLY, ret); } else { - regnode *w = reg_node(WHILEM); + regnode *w = reg_node(pRExC_state, WHILEM); w->flags = 0; - regtail(ret, w); - if (!SIZE_ONLY && PL_extralen) { - reginsert(LONGJMP,ret); - reginsert(NOTHING,ret); + regtail(pRExC_state, ret, w); + if (!SIZE_ONLY && RExC_extralen) { + reginsert(pRExC_state, LONGJMP,ret); + reginsert(pRExC_state, NOTHING,ret); NEXT_OFF(ret) = 3; /* Go over LONGJMP. */ } - reginsert(CURLYX,ret); - if (!SIZE_ONLY && PL_extralen) + reginsert(pRExC_state, CURLYX,ret); + if (!SIZE_ONLY && RExC_extralen) NEXT_OFF(ret) = 3; /* Go over NOTHING to LONGJMP. */ - regtail(ret, reg_node(NOTHING)); + regtail(pRExC_state, ret, reg_node(pRExC_state, NOTHING)); if (SIZE_ONLY) - PL_reg_whilem_seen++, PL_extralen += 3; - PL_regnaughty += 4 + PL_regnaughty; /* compound interest */ + RExC_whilem_seen++, RExC_extralen += 3; + RExC_naughty += 4 + RExC_naughty; /* compound interest */ } ret->flags = 0; @@ -2393,23 +2469,23 @@ S_regpiece(pTHX_ I32 *flagp) vFAIL("Regexp *+ operand could be empty"); #endif - nextchar(); + nextchar(pRExC_state); *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH); if (op == '*' && (flags&SIMPLE)) { - reginsert(STAR, ret); + reginsert(pRExC_state, STAR, ret); ret->flags = 0; - PL_regnaughty += 4; + RExC_naughty += 4; } else if (op == '*') { min = 0; goto do_curly; } else if (op == '+' && (flags&SIMPLE)) { - reginsert(PLUS, ret); + reginsert(pRExC_state, PLUS, ret); ret->flags = 0; - PL_regnaughty += 3; + RExC_naughty += 3; } else if (op == '+') { min = 1; @@ -2421,19 +2497,19 @@ S_regpiece(pTHX_ I32 *flagp) } nest_check: if (ckWARN(WARN_REGEXP) && !SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3) { - vWARN3(PL_regcomp_parse, + vWARN3(RExC_parse, "%.*s matches null string many times", - PL_regcomp_parse - origparse, + RExC_parse - origparse, origparse); } - if (*PL_regcomp_parse == '?') { - nextchar(); - reginsert(MINMOD, ret); - regtail(ret, ret + NODE_STEP_REGNODE); + if (*RExC_parse == '?') { + nextchar(pRExC_state); + reginsert(pRExC_state, MINMOD, ret); + regtail(pRExC_state, ret, ret + NODE_STEP_REGNODE); } - if (ISMULT2(PL_regcomp_parse)) { - PL_regcomp_parse++; + if (ISMULT2(RExC_parse)) { + RExC_parse++; vFAIL("Nested quantifiers"); } @@ -2450,73 +2526,63 @@ S_regpiece(pTHX_ I32 *flagp) * * [Yes, it is worth fixing, some scripts can run twice the speed.] */ STATIC regnode * -S_regatom(pTHX_ I32 *flagp) +S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp) { - dTHR; register regnode *ret = 0; I32 flags; *flagp = WORST; /* Tentatively. */ tryagain: - switch (*PL_regcomp_parse) { + switch (*RExC_parse) { case '^': - PL_seen_zerolen++; - nextchar(); - if (PL_regflags & PMf_MULTILINE) - ret = reg_node(MBOL); - else if (PL_regflags & PMf_SINGLELINE) - ret = reg_node(SBOL); + RExC_seen_zerolen++; + nextchar(pRExC_state); + if (RExC_flags16 & PMf_MULTILINE) + ret = reg_node(pRExC_state, MBOL); + else if (RExC_flags16 & PMf_SINGLELINE) + ret = reg_node(pRExC_state, SBOL); else - ret = reg_node(BOL); + ret = reg_node(pRExC_state, BOL); break; case '$': - nextchar(); - if (*PL_regcomp_parse) - PL_seen_zerolen++; - if (PL_regflags & PMf_MULTILINE) - ret = reg_node(MEOL); - else if (PL_regflags & PMf_SINGLELINE) - ret = reg_node(SEOL); + nextchar(pRExC_state); + if (*RExC_parse) + RExC_seen_zerolen++; + if (RExC_flags16 & PMf_MULTILINE) + ret = reg_node(pRExC_state, MEOL); + else if (RExC_flags16 & PMf_SINGLELINE) + ret = reg_node(pRExC_state, SEOL); else - ret = reg_node(EOL); + ret = reg_node(pRExC_state, EOL); break; case '.': - nextchar(); - if (UTF) { - if (PL_regflags & PMf_SINGLELINE) - ret = reg_node(SANYUTF8); - else - ret = reg_node(ANYUTF8); - *flagp |= HASWIDTH; - } - else { - if (PL_regflags & PMf_SINGLELINE) - ret = reg_node(SANY); - else - ret = reg_node(REG_ANY); - *flagp |= HASWIDTH|SIMPLE; - } - PL_regnaughty++; + nextchar(pRExC_state); + if (RExC_flags16 & PMf_SINGLELINE) + ret = reg_node(pRExC_state, SANY); + else + ret = reg_node(pRExC_state, REG_ANY); + *flagp |= HASWIDTH|SIMPLE; + RExC_naughty++; break; case '[': { - char *oregcomp_parse = ++PL_regcomp_parse; - ret = (UTF ? regclassutf8() : regclass()); - if (*PL_regcomp_parse != ']') { - PL_regcomp_parse = oregcomp_parse; + char *oregcomp_parse = ++RExC_parse; + ret = regclass(pRExC_state); + if (*RExC_parse != ']') { + RExC_parse = oregcomp_parse; vFAIL("Unmatched ["); } - nextchar(); + nextchar(pRExC_state); *flagp |= HASWIDTH|SIMPLE; break; } case '(': - nextchar(); - ret = reg(1, &flags); + nextchar(pRExC_state); + ret = reg(pRExC_state, 1, &flags); if (ret == NULL) { if (flags & TRYAGAIN) { - if (PL_regcomp_parse == PL_regxend) { + if (RExC_parse == RExC_end) { /* Make parent create an empty node if needed. */ *flagp |= TRYAGAIN; return(NULL); @@ -2537,155 +2603,137 @@ tryagain: /* Supposed to be caught earlier. */ break; case '{': - if (!regcurly(PL_regcomp_parse)) { - PL_regcomp_parse++; + if (!regcurly(RExC_parse)) { + RExC_parse++; goto defchar; } /* FALL THROUGH */ case '?': case '+': case '*': - PL_regcomp_parse++; + RExC_parse++; vFAIL("Quantifier follows nothing"); break; case '\\': - switch (*++PL_regcomp_parse) { + switch (*++RExC_parse) { case 'A': - PL_seen_zerolen++; - ret = reg_node(SBOL); + RExC_seen_zerolen++; + ret = reg_node(pRExC_state, SBOL); *flagp |= SIMPLE; - nextchar(); + nextchar(pRExC_state); break; case 'G': - ret = reg_node(GPOS); - PL_regseen |= REG_SEEN_GPOS; + ret = reg_node(pRExC_state, GPOS); + RExC_seen |= REG_SEEN_GPOS; *flagp |= SIMPLE; - nextchar(); + nextchar(pRExC_state); break; case 'Z': - ret = reg_node(SEOL); + ret = reg_node(pRExC_state, SEOL); *flagp |= SIMPLE; - nextchar(); + nextchar(pRExC_state); break; case 'z': - ret = reg_node(EOS); + ret = reg_node(pRExC_state, EOS); *flagp |= SIMPLE; - PL_seen_zerolen++; /* Do not optimize RE away */ - nextchar(); + RExC_seen_zerolen++; /* Do not optimize RE away */ + nextchar(pRExC_state); break; case 'C': - ret = reg_node(SANY); + ret = reg_node(pRExC_state, SANY); *flagp |= HASWIDTH|SIMPLE; - nextchar(); + nextchar(pRExC_state); break; case 'X': - ret = reg_node(CLUMP); + ret = reg_node(pRExC_state, CLUMP); *flagp |= HASWIDTH; - nextchar(); + nextchar(pRExC_state); if (UTF && !PL_utf8_mark) is_utf8_mark((U8*)"~"); /* preload table */ break; case 'w': - ret = reg_node( - UTF - ? (LOC ? ALNUMLUTF8 : ALNUMUTF8) - : (LOC ? ALNUML : ALNUM)); + ret = reg_node(pRExC_state, LOC ? ALNUML : ALNUM); *flagp |= HASWIDTH|SIMPLE; - nextchar(); + nextchar(pRExC_state); if (UTF && !PL_utf8_alnum) is_utf8_alnum((U8*)"a"); /* preload table */ break; case 'W': - ret = reg_node( - UTF - ? (LOC ? NALNUMLUTF8 : NALNUMUTF8) - : (LOC ? NALNUML : NALNUM)); + ret = reg_node(pRExC_state, LOC ? NALNUML : NALNUM); *flagp |= HASWIDTH|SIMPLE; - nextchar(); + nextchar(pRExC_state); if (UTF && !PL_utf8_alnum) is_utf8_alnum((U8*)"a"); /* preload table */ break; case 'b': - PL_seen_zerolen++; - PL_regseen |= REG_SEEN_LOOKBEHIND; - ret = reg_node( - UTF - ? (LOC ? BOUNDLUTF8 : BOUNDUTF8) - : (LOC ? BOUNDL : BOUND)); + RExC_seen_zerolen++; + RExC_seen |= REG_SEEN_LOOKBEHIND; + ret = reg_node(pRExC_state, LOC ? BOUNDL : BOUND); *flagp |= SIMPLE; - nextchar(); + nextchar(pRExC_state); if (UTF && !PL_utf8_alnum) is_utf8_alnum((U8*)"a"); /* preload table */ break; case 'B': - PL_seen_zerolen++; - PL_regseen |= REG_SEEN_LOOKBEHIND; - ret = reg_node( - UTF - ? (LOC ? NBOUNDLUTF8 : NBOUNDUTF8) - : (LOC ? NBOUNDL : NBOUND)); + RExC_seen_zerolen++; + RExC_seen |= REG_SEEN_LOOKBEHIND; + ret = reg_node(pRExC_state, LOC ? NBOUNDL : NBOUND); *flagp |= SIMPLE; - nextchar(); + nextchar(pRExC_state); if (UTF && !PL_utf8_alnum) is_utf8_alnum((U8*)"a"); /* preload table */ break; case 's': - ret = reg_node( - UTF - ? (LOC ? SPACELUTF8 : SPACEUTF8) - : (LOC ? SPACEL : SPACE)); + ret = reg_node(pRExC_state, LOC ? SPACEL : SPACE); *flagp |= HASWIDTH|SIMPLE; - nextchar(); + nextchar(pRExC_state); if (UTF && !PL_utf8_space) is_utf8_space((U8*)" "); /* preload table */ break; case 'S': - ret = reg_node( - UTF - ? (LOC ? NSPACELUTF8 : NSPACEUTF8) - : (LOC ? NSPACEL : NSPACE)); + ret = reg_node(pRExC_state, LOC ? NSPACEL : NSPACE); *flagp |= HASWIDTH|SIMPLE; - nextchar(); + nextchar(pRExC_state); if (UTF && !PL_utf8_space) is_utf8_space((U8*)" "); /* preload table */ break; case 'd': - ret = reg_node(UTF ? DIGITUTF8 : DIGIT); + ret = reg_node(pRExC_state, DIGIT); *flagp |= HASWIDTH|SIMPLE; - nextchar(); + nextchar(pRExC_state); if (UTF && !PL_utf8_digit) is_utf8_digit((U8*)"1"); /* preload table */ break; case 'D': - ret = reg_node(UTF ? NDIGITUTF8 : NDIGIT); + ret = reg_node(pRExC_state, NDIGIT); *flagp |= HASWIDTH|SIMPLE; - nextchar(); + nextchar(pRExC_state); if (UTF && !PL_utf8_digit) is_utf8_digit((U8*)"1"); /* preload table */ break; case 'p': case 'P': { /* a lovely hack--pretend we saw [\pX] instead */ - char* oldregxend = PL_regxend; + char* oldregxend = RExC_end; - if (PL_regcomp_parse[1] == '{') { - PL_regxend = strchr(PL_regcomp_parse, '}'); - if (!PL_regxend) { - PL_regcomp_parse += 2; - PL_regxend = oldregxend; + if (RExC_parse[1] == '{') { + RExC_end = strchr(RExC_parse, '}'); + if (!RExC_end) { + RExC_parse += 2; + RExC_end = oldregxend; vFAIL("Missing right brace on \\p{}"); } - PL_regxend++; + RExC_end++; } else - PL_regxend = PL_regcomp_parse + 2; - PL_regcomp_parse--; + RExC_end = RExC_parse + 2; + RExC_parse--; - ret = regclassutf8(); + ret = regclass(pRExC_state); - PL_regxend = oldregxend; - PL_regcomp_parse--; - nextchar(); + RExC_end = oldregxend; + RExC_parse--; + nextchar(pRExC_state); *flagp |= HASWIDTH|SIMPLE; } break; @@ -2702,28 +2750,28 @@ tryagain: case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': { - I32 num = atoi(PL_regcomp_parse); + I32 num = atoi(RExC_parse); - if (num > 9 && num >= PL_regnpar) + if (num > 9 && num >= RExC_npar) goto defchar; else { - while (isDIGIT(*PL_regcomp_parse)) - PL_regcomp_parse++; + while (isDIGIT(*RExC_parse)) + RExC_parse++; - if (!SIZE_ONLY && num > PL_regcomp_rx->nparens) + if (!SIZE_ONLY && num > RExC_rx->nparens) vFAIL("Reference to nonexistent group"); - PL_regsawback = 1; - ret = reganode(FOLD + RExC_sawback = 1; + ret = reganode(pRExC_state, FOLD ? (LOC ? REFFL : REFF) : REF, num); *flagp |= HASWIDTH; - PL_regcomp_parse--; - nextchar(); + RExC_parse--; + nextchar(pRExC_state); } } break; case '\0': - if (PL_regcomp_parse >= PL_regxend) + if (RExC_parse >= RExC_end) FAIL("Trailing \\"); /* FALL THROUGH */ default: @@ -2734,35 +2782,35 @@ tryagain: break; case '#': - if (PL_regflags & PMf_EXTENDED) { - while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != '\n') PL_regcomp_parse++; - if (PL_regcomp_parse < PL_regxend) + if (RExC_flags16 & PMf_EXTENDED) { + while (RExC_parse < RExC_end && *RExC_parse != '\n') RExC_parse++; + if (RExC_parse < RExC_end) goto 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++; + RExC_parse++; defchar: - ret = reg_node(FOLD + ret = reg_node(pRExC_state, FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT); s = STRING(ret); - for (len = 0, p = PL_regcomp_parse - 1; - len < 127 && p < PL_regxend; + for (len = 0, p = RExC_parse - 1; + len < 127 && p < RExC_end; len++) { oldp = p; - if (PL_regflags & PMf_EXTENDED) - p = regwhite(p, PL_regxend); + if (RExC_flags16 & PMf_EXTENDED) + p = regwhite(p, RExC_end); switch (*p) { case '^': case '$': @@ -2827,10 +2875,10 @@ tryagain: char* e = strchr(p, '}'); if (!e) { - PL_regcomp_parse = p + 1; + RExC_parse = p + 1; vFAIL("Missing right brace on \\x{}"); } - else if (UTF) { + else { numlen = 1; /* allow underscores */ ender = (UV)scan_hex(p + 1, e - p - 1, &numlen); /* numlen is generous */ @@ -2840,12 +2888,6 @@ tryagain: } p = e + 1; } - else - { - PL_regcomp_parse = e + 1; - vFAIL("Can't use \\x{} without 'use utf8' declaration"); - } - } else { numlen = 0; /* disallow underscores */ @@ -2861,7 +2903,7 @@ tryagain: case '0': case '1': case '2': case '3':case '4': case '5': case '6': case '7': case '8':case '9': if (*p == '0' || - (isDIGIT(p[1]) && atoi(p) >= PL_regnpar) ) { + (isDIGIT(p[1]) && atoi(p) >= RExC_npar) ) { numlen = 0; /* disallow underscores */ ender = (UV)scan_oct(p, 3, &numlen); p += numlen; @@ -2872,7 +2914,7 @@ tryagain: } break; case '\0': - if (p >= PL_regxend) + if (p >= RExC_end) FAIL("Trailing \\"); /* FALL THROUGH */ default: @@ -2883,16 +2925,17 @@ tryagain: break; default: normal_default: - if ((*p & 0xc0) == 0xc0 && UTF) { - ender = utf8_to_uv_chk((U8*)p, &numlen, 0); + if (UTF8_IS_START(*p) && UTF) { + ender = utf8_to_uv((U8*)p, RExC_end - p, + &numlen, 0); p += numlen; } else ender = *p++; break; } - if (PL_regflags & PMf_EXTENDED) - p = regwhite(p, PL_regxend); + if (RExC_flags16 & PMf_EXTENDED) + p = regwhite(p, RExC_end); if (UTF && FOLD) { if (LOC) ender = toLOWER_LC_uni(ender); @@ -2902,8 +2945,10 @@ 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); + reguni(pRExC_state, ender, s, &numlen); s += numlen; len += numlen; } @@ -2913,8 +2958,10 @@ 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); + reguni(pRExC_state, ender, s, &numlen); s += numlen; len += numlen - 1; } @@ -2922,10 +2969,14 @@ tryagain: REGC(ender, s++); } loopdone: - PL_regcomp_parse = p - 1; - nextchar(); - if (len < 0) - vFAIL("Internal disaster"); + RExC_parse = p - 1; + nextchar(pRExC_state); + { + /* 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) @@ -2933,9 +2984,9 @@ tryagain: if (!SIZE_ONLY) STR_LEN(ret) = len; if (SIZE_ONLY) - PL_regsize += STR_SZ(len); + RExC_size += STR_SZ(len); else - PL_regcode += STR_SZ(len); + RExC_emit += STR_SZ(len); } break; } @@ -2966,30 +3017,29 @@ S_regwhite(pTHX_ char *p, char *e) Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed, but trigger warnings because they are currently unimplemented. */ STATIC I32 -S_regpposixcc(pTHX_ I32 value) +S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value) { - dTHR; char *posixcc = 0; I32 namedclass = OOB_NAMEDCLASS; - if (value == '[' && PL_regcomp_parse + 1 < PL_regxend && + if (value == '[' && RExC_parse + 1 < RExC_end && /* I smell either [: or [= or [. -- POSIX has been here, right? */ - (*PL_regcomp_parse == ':' || - *PL_regcomp_parse == '=' || - *PL_regcomp_parse == '.')) { - char c = *PL_regcomp_parse; - char* s = PL_regcomp_parse++; + (*RExC_parse == ':' || + *RExC_parse == '=' || + *RExC_parse == '.')) { + char c = *RExC_parse; + char* s = RExC_parse++; - while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != c) - PL_regcomp_parse++; - if (PL_regcomp_parse == PL_regxend) + while (RExC_parse < RExC_end && *RExC_parse != c) + RExC_parse++; + if (RExC_parse == RExC_end) /* Grandfather lone [:, [=, [. */ - PL_regcomp_parse = s; + RExC_parse = s; else { - char* t = PL_regcomp_parse++; /* skip over the c */ + char* t = RExC_parse++; /* skip over the c */ - if (*PL_regcomp_parse == ']') { - PL_regcomp_parse++; /* skip over the ending ] */ + if (*RExC_parse == ']') { + RExC_parse++; /* skip over the ending ] */ posixcc = s + 1; if (*s == ':') { I32 complement = *posixcc == '^' ? *posixcc++ : 0; @@ -3075,16 +3125,16 @@ S_regpposixcc(pTHX_ I32 value) } else if (!SIZE_ONLY) { /* [[=foo=]] and [[.foo.]] are still future. */ - /* adjust PL_regcomp_parse so the warning shows after + /* adjust RExC_parse so the warning shows after the class closes */ - while (*PL_regcomp_parse && *PL_regcomp_parse != ']') - PL_regcomp_parse++; + while (*RExC_parse && *RExC_parse != ']') + RExC_parse++; Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c); } } else { /* Maternal grandfather: * "[:" ending in ":" but not in ":]" */ - PL_regcomp_parse = s; + RExC_parse = s; } } } @@ -3093,13 +3143,13 @@ S_regpposixcc(pTHX_ I32 value) } STATIC void -S_checkposixcc(pTHX) +S_checkposixcc(pTHX_ RExC_state_t *pRExC_state) { if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && - (*PL_regcomp_parse == ':' || - *PL_regcomp_parse == '=' || - *PL_regcomp_parse == '.')) { - char *s = PL_regcomp_parse; + (*RExC_parse == ':' || + *RExC_parse == '=' || + *RExC_parse == '.')) { + char *s = RExC_parse; char c = *s++; while(*s && isALNUM(*s)) @@ -3110,9 +3160,9 @@ S_checkposixcc(pTHX) /* [[=foo=]] and [[.foo.]] are still future. */ if (c == '=' || c == '.') { - /* adjust PL_regcomp_parse so the error shows after + /* adjust RExC_parse so the error shows after the class closes */ - while (*PL_regcomp_parse && *PL_regcomp_parse++ != ']') + while (*RExC_parse && *RExC_parse++ != ']') ; Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c); } @@ -3121,61 +3171,113 @@ S_checkposixcc(pTHX) } STATIC regnode * -S_regclass(pTHX) +S_regclass(pTHX_ RExC_state_t *pRExC_state) { - dTHR; - register U32 value; - register I32 lastvalue = OOB_CHAR8; - register I32 range = 0; + register UV value; + register IV lastvalue = OOB_UNICODE; + register IV range = 0; register regnode *ret; - I32 numlen; - I32 namedclass; + STRLEN numlen; + IV namedclass; char *rangebegin; bool need_class = 0; + SV *listsv; + register char *e; + UV n; + bool dont_optimize_invert = FALSE; + + ret = reganode(pRExC_state, ANYOF, 0); + + if (!SIZE_ONLY) + ANYOF_FLAGS(ret) = 0; + + if (*RExC_parse == '^') { /* Complement of range. */ + RExC_naughty++; + RExC_parse++; + if (!SIZE_ONLY) + ANYOF_FLAGS(ret) |= ANYOF_INVERT; + } - ret = reg_node(ANYOF); if (SIZE_ONLY) - PL_regsize += ANYOF_SKIP; + RExC_size += ANYOF_SKIP; else { - ret->flags = 0; - ANYOF_BITMAP_ZERO(ret); - PL_regcode += ANYOF_SKIP; + RExC_emit += ANYOF_SKIP; if (FOLD) ANYOF_FLAGS(ret) |= ANYOF_FOLD; if (LOC) ANYOF_FLAGS(ret) |= ANYOF_LOCALE; - } - if (*PL_regcomp_parse == '^') { /* Complement of range. */ - PL_regnaughty++; - PL_regcomp_parse++; - if (!SIZE_ONLY) - ANYOF_FLAGS(ret) |= ANYOF_INVERT; + ANYOF_BITMAP_ZERO(ret); + listsv = newSVpvn("# comment\n", 10); } if (!SIZE_ONLY && ckWARN(WARN_REGEXP)) - checkposixcc(); + checkposixcc(pRExC_state); + + if (*RExC_parse == ']' || *RExC_parse == '-') + goto charclassloop; /* allow 1st char to be ] or - */ + + while (RExC_parse < RExC_end && *RExC_parse != ']') { + + charclassloop: + + namedclass = OOB_NAMEDCLASS; /* initialize as illegal */ - if (*PL_regcomp_parse == ']' || *PL_regcomp_parse == '-') - goto skipcond; /* allow 1st char to be ] or - */ - while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != ']') { - skipcond: - namedclass = OOB_NAMEDCLASS; if (!range) - rangebegin = PL_regcomp_parse; - value = UCHARAT(PL_regcomp_parse++); + rangebegin = RExC_parse; + if (UTF) { + value = utf8_to_uv((U8*)RExC_parse, + RExC_end - RExC_parse, + &numlen, 0); + RExC_parse += numlen; + } + else + value = UCHARAT(RExC_parse++); if (value == '[') - namedclass = regpposixcc(value); + namedclass = regpposixcc(pRExC_state, value); else if (value == '\\') { - value = UCHARAT(PL_regcomp_parse++); + if (UTF) { + value = utf8_to_uv((U8*)RExC_parse, + RExC_end - RExC_parse, + &numlen, 0); + RExC_parse += numlen; + } + else + value = UCHARAT(RExC_parse++); /* Some compilers cannot handle switching on 64-bit integer - * values, therefore the 'value' cannot be an UV. --jhi */ - switch (value) { + * values, therefore value cannot be an UV. Yes, this will + * be a problem later if we want switch on Unicode. + * A similar issue a little bit later when switching on + * namedclass. --jhi */ + switch ((I32)value) { case 'w': namedclass = ANYOF_ALNUM; break; case 'W': namedclass = ANYOF_NALNUM; break; case 's': namedclass = ANYOF_SPACE; break; case 'S': namedclass = ANYOF_NSPACE; break; case 'd': namedclass = ANYOF_DIGIT; break; case 'D': namedclass = ANYOF_NDIGIT; break; + case 'p': + case 'P': + if (*RExC_parse == '{') { + e = strchr(RExC_parse++, '}'); + if (!e) + vFAIL("Missing right brace on \\p{}"); + n = e - RExC_parse; + } + else { + e = RExC_parse; + n = 1; + } + if (!SIZE_ONLY) { + if (value == 'p') + Perl_sv_catpvf(aTHX_ listsv, + "+utf8::%.*s\n", (int)n, RExC_parse); + else + Perl_sv_catpvf(aTHX_ listsv, + "!utf8::%.*s\n", (int)n, RExC_parse); + } + RExC_parse = e + 1; + ANYOF_FLAGS(ret) |= ANYOF_UNICODE; + continue; case 'n': value = '\n'; break; case 'r': value = '\r'; break; case 't': value = '\t'; break; @@ -3189,46 +3291,78 @@ 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; + if (*RExC_parse == '{') { + e = strchr(RExC_parse++, '}'); + if (!e) + vFAIL("Missing right brace on \\x{}"); + numlen = 1; /* allow underscores */ + value = (UV)scan_hex(RExC_parse, + e - RExC_parse, + &numlen); + RExC_parse = e + 1; + } + else { + numlen = 0; /* disallow underscores */ + value = (UV)scan_hex(RExC_parse, 2, &numlen); + RExC_parse += numlen; + } break; case 'c': - value = UCHARAT(PL_regcomp_parse++); + value = UCHARAT(RExC_parse++); value = toCTRL(value); 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; + value = (UV)scan_oct(--RExC_parse, 3, &numlen); + RExC_parse += numlen; break; default: if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(value)) - - vWARN2(PL_regcomp_parse, "Unrecognized escape \\%c in character class passed through", (int)value); + vWARN2(RExC_parse, + "Unrecognized escape \\%c in character class passed through", + (int)value); break; } - } - if (namedclass > OOB_NAMEDCLASS) { - if (!need_class && !SIZE_ONLY) + } /* end of \blah */ + + if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */ + + if (!SIZE_ONLY && !need_class) ANYOF_CLASS_ZERO(ret); + need_class = 1; - if (range) { /* a-\d, a-[:digit:] */ + + /* a bad range like a-\d, a-[:digit:] ? */ + if (range) { if (!SIZE_ONLY) { if (ckWARN(WARN_REGEXP)) - vWARN4(PL_regcomp_parse, + vWARN4(RExC_parse, "False [] range \"%*.*s\"", - PL_regcomp_parse - rangebegin, - PL_regcomp_parse - rangebegin, + RExC_parse - rangebegin, + RExC_parse - rangebegin, rangebegin); - ANYOF_BITMAP_SET(ret, lastvalue); - ANYOF_BITMAP_SET(ret, '-'); + if (lastvalue < 256) { + ANYOF_BITMAP_SET(ret, lastvalue); + ANYOF_BITMAP_SET(ret, '-'); + } + else { + ANYOF_FLAGS(ret) |= ANYOF_UNICODE; + Perl_sv_catpvf(aTHX_ listsv, + /* 0x002D is Unicode for '-' */ + "%04"UVxf"\n002D\n", (UV)lastvalue); + } } - range = 0; /* this is not a true range */ + + range = 0; /* this was not a true range */ } + if (!SIZE_ONLY) { - switch (namedclass) { + /* Possible truncation here but in some 64-bit environments + * the compiler gets heartburn about switch on 64-bit values. + * A similar issue a little earlier when switching on value. + * --jhi */ + switch ((I32)namedclass) { case ANYOF_ALNUM: if (LOC) ANYOF_CLASS_SET(ret, ANYOF_ALNUM); @@ -3237,6 +3371,8 @@ S_regclass(pTHX) if (isALNUM(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsWord\n"); break; case ANYOF_NALNUM: if (LOC) @@ -3246,42 +3382,19 @@ S_regclass(pTHX) if (!isALNUM(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsWord\n"); break; - case ANYOF_SPACE: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_SPACE); - else { - for (value = 0; value < 256; value++) - if (isSPACE(value)) - ANYOF_BITMAP_SET(ret, value); - } - break; - case ANYOF_NSPACE: + case ANYOF_ALNUMC: if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_NSPACE); + ANYOF_CLASS_SET(ret, ANYOF_ALNUMC); else { for (value = 0; value < 256; value++) - if (!isSPACE(value)) + if (isALNUMC(value)) ANYOF_BITMAP_SET(ret, value); } - break; - case ANYOF_DIGIT: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_DIGIT); - else { - for (value = '0'; value <= '9'; value++) - ANYOF_BITMAP_SET(ret, value); - } - break; - case ANYOF_NDIGIT: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_NDIGIT); - else { - for (value = 0; value < '0'; value++) - ANYOF_BITMAP_SET(ret, value); - for (value = '9' + 1; value < 256; value++) - ANYOF_BITMAP_SET(ret, value); - } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlnum\n"); break; case ANYOF_NALNUMC: if (LOC) @@ -3291,15 +3404,8 @@ S_regclass(pTHX) if (!isALNUMC(value)) ANYOF_BITMAP_SET(ret, value); } - break; - case ANYOF_ALNUMC: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_ALNUMC); - else { - for (value = 0; value < 256; value++) - if (isALNUMC(value)) - ANYOF_BITMAP_SET(ret, value); - } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlnum\n"); break; case ANYOF_ALPHA: if (LOC) @@ -3309,6 +3415,8 @@ S_regclass(pTHX) if (isALPHA(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlpha\n"); break; case ANYOF_NALPHA: if (LOC) @@ -3318,6 +3426,8 @@ S_regclass(pTHX) if (!isALPHA(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlpha\n"); break; case ANYOF_ASCII: if (LOC) @@ -3332,6 +3442,8 @@ S_regclass(pTHX) ANYOF_BITMAP_SET(ret, value); #endif /* EBCDIC */ } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsASCII\n"); break; case ANYOF_NASCII: if (LOC) @@ -3346,6 +3458,8 @@ S_regclass(pTHX) ANYOF_BITMAP_SET(ret, value); #endif /* EBCDIC */ } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsASCII\n"); break; case ANYOF_BLANK: if (LOC) @@ -3355,6 +3469,8 @@ S_regclass(pTHX) if (isBLANK(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsBlank\n"); break; case ANYOF_NBLANK: if (LOC) @@ -3364,6 +3480,8 @@ S_regclass(pTHX) if (!isBLANK(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsBlank\n"); break; case ANYOF_CNTRL: if (LOC) @@ -3373,7 +3491,8 @@ S_regclass(pTHX) if (isCNTRL(value)) ANYOF_BITMAP_SET(ret, value); } - lastvalue = OOB_CHAR8; + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsCntrl\n"); break; case ANYOF_NCNTRL: if (LOC) @@ -3383,6 +3502,32 @@ S_regclass(pTHX) if (!isCNTRL(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsCntrl\n"); + break; + case ANYOF_DIGIT: + if (LOC) + ANYOF_CLASS_SET(ret, ANYOF_DIGIT); + else { + /* consecutive digits assumed */ + for (value = '0'; value <= '9'; value++) + ANYOF_BITMAP_SET(ret, value); + } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsDigit\n"); + break; + case ANYOF_NDIGIT: + if (LOC) + ANYOF_CLASS_SET(ret, ANYOF_NDIGIT); + else { + /* consecutive digits assumed */ + for (value = 0; value < '0'; value++) + ANYOF_BITMAP_SET(ret, value); + for (value = '9' + 1; value < 256; value++) + ANYOF_BITMAP_SET(ret, value); + } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsDigit\n"); break; case ANYOF_GRAPH: if (LOC) @@ -3392,6 +3537,8 @@ S_regclass(pTHX) if (isGRAPH(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsGraph\n"); break; case ANYOF_NGRAPH: if (LOC) @@ -3401,6 +3548,8 @@ S_regclass(pTHX) if (!isGRAPH(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsGraph\n"); break; case ANYOF_LOWER: if (LOC) @@ -3410,6 +3559,8 @@ S_regclass(pTHX) if (isLOWER(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsLower\n"); break; case ANYOF_NLOWER: if (LOC) @@ -3419,6 +3570,8 @@ S_regclass(pTHX) if (!isLOWER(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsLower\n"); break; case ANYOF_PRINT: if (LOC) @@ -3428,6 +3581,8 @@ S_regclass(pTHX) if (isPRINT(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPrint\n"); break; case ANYOF_NPRINT: if (LOC) @@ -3437,6 +3592,8 @@ S_regclass(pTHX) if (!isPRINT(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPrint\n"); break; case ANYOF_PSXSPC: if (LOC) @@ -3446,6 +3603,8 @@ S_regclass(pTHX) if (isPSXSPC(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpace\n"); break; case ANYOF_NPSXSPC: if (LOC) @@ -3455,6 +3614,8 @@ S_regclass(pTHX) if (!isPSXSPC(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpace\n"); break; case ANYOF_PUNCT: if (LOC) @@ -3464,6 +3625,8 @@ S_regclass(pTHX) if (isPUNCT(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPunct\n"); break; case ANYOF_NPUNCT: if (LOC) @@ -3473,6 +3636,30 @@ S_regclass(pTHX) if (!isPUNCT(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPunct\n"); + break; + case ANYOF_SPACE: + if (LOC) + ANYOF_CLASS_SET(ret, ANYOF_SPACE); + else { + for (value = 0; value < 256; value++) + if (isSPACE(value)) + ANYOF_BITMAP_SET(ret, value); + } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpacePerl\n"); + break; + case ANYOF_NSPACE: + if (LOC) + ANYOF_CLASS_SET(ret, ANYOF_NSPACE); + else { + for (value = 0; value < 256; value++) + if (!isSPACE(value)) + ANYOF_BITMAP_SET(ret, value); + } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpacePerl\n"); break; case ANYOF_UPPER: if (LOC) @@ -3482,6 +3669,8 @@ S_regclass(pTHX) if (isUPPER(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsUpper\n"); break; case ANYOF_NUPPER: if (LOC) @@ -3491,6 +3680,8 @@ S_regclass(pTHX) if (!isUPPER(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsUpper\n"); break; case ANYOF_XDIGIT: if (LOC) @@ -3500,6 +3691,8 @@ S_regclass(pTHX) if (isXDIGIT(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsXDigit\n"); break; case ANYOF_NXDIGIT: if (LOC) @@ -3509,6 +3702,8 @@ S_regclass(pTHX) if (!isXDIGIT(value)) ANYOF_BITMAP_SET(ret, value); } + dont_optimize_invert = TRUE; + Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsXDigit\n"); break; default: vFAIL("Invalid [::] class"); @@ -3518,364 +3713,144 @@ S_regclass(pTHX) ANYOF_FLAGS(ret) |= ANYOF_CLASS; continue; } - } + } /* end of namedclass \blah */ + if (range) { if (lastvalue > value) /* b-a */ { Simple_vFAIL4("Invalid [] range \"%*.*s\"", - PL_regcomp_parse - rangebegin, - PL_regcomp_parse - rangebegin, + RExC_parse - rangebegin, + RExC_parse - rangebegin, rangebegin); } - range = 0; + range = 0; /* not a true range */ } else { - lastvalue = value; - if (*PL_regcomp_parse == '-' && PL_regcomp_parse+1 < PL_regxend && - PL_regcomp_parse[1] != ']') { - PL_regcomp_parse++; - if (namedclass > OOB_NAMEDCLASS) { /* \w-, [:word:]- */ + lastvalue = value; /* save the beginning of the range */ + if (*RExC_parse == '-' && RExC_parse+1 < RExC_end && + RExC_parse[1] != ']') { + RExC_parse++; + + /* a bad range like \w-, [:word:]- ? */ + if (namedclass > OOB_NAMEDCLASS) { if (ckWARN(WARN_REGEXP)) - vWARN4(PL_regcomp_parse, + vWARN4(RExC_parse, "False [] range \"%*.*s\"", - PL_regcomp_parse - rangebegin, - PL_regcomp_parse - rangebegin, + RExC_parse - rangebegin, + RExC_parse - rangebegin, rangebegin); if (!SIZE_ONLY) ANYOF_BITMAP_SET(ret, '-'); } else - range = 1; - continue; /* do it next time */ + range = 1; /* yeah, it's a range! */ + continue; /* but do it the next time */ } } + /* now is the next time */ if (!SIZE_ONLY) { + if (lastvalue < 256 && value < 256) { #ifndef ASCIIish /* EBCDIC, for example. */ - if ((isLOWER(lastvalue) && isLOWER(value)) || - (isUPPER(lastvalue) && isUPPER(value))) - { - I32 i; - if (isLOWER(lastvalue)) { - for (i = lastvalue; i <= value; i++) - if (isLOWER(i)) - ANYOF_BITMAP_SET(ret, i); - } else { - for (i = lastvalue; i <= value; i++) - if (isUPPER(i)) - ANYOF_BITMAP_SET(ret, i); + if ((isLOWER(lastvalue) && isLOWER(value)) || + (isUPPER(lastvalue) && isUPPER(value))) + { + IV i; + if (isLOWER(lastvalue)) { + for (i = lastvalue; i <= value; i++) + if (isLOWER(i)) + ANYOF_BITMAP_SET(ret, i); + } else { + for (i = lastvalue; i <= value; i++) + if (isUPPER(i)) + ANYOF_BITMAP_SET(ret, i); + } } - } - else + else #endif - for ( ; lastvalue <= value; lastvalue++) - ANYOF_BITMAP_SET(ret, lastvalue); + for ( ; lastvalue <= value; lastvalue++) + ANYOF_BITMAP_SET(ret, lastvalue); + } else { + ANYOF_FLAGS(ret) |= ANYOF_UNICODE; + if (lastvalue < value) + Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n", + (UV)lastvalue, (UV)value); + else + Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", + (UV)value); + } } - range = 0; + + range = 0; /* this range (if it was one) is done now */ } + if (need_class) { if (SIZE_ONLY) - PL_regsize += ANYOF_CLASS_ADD_SKIP; + RExC_size += ANYOF_CLASS_ADD_SKIP; else - PL_regcode += ANYOF_CLASS_ADD_SKIP; + RExC_emit += ANYOF_CLASS_ADD_SKIP; } + /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */ if (!SIZE_ONLY && - (ANYOF_FLAGS(ret) & (ANYOF_FLAGS_ALL ^ ANYOF_INVERT)) == ANYOF_FOLD) { + (ANYOF_FLAGS(ret) & + /* If the only flag is folding (plus possibly inversion). */ + (ANYOF_FLAGS_ALL ^ ANYOF_INVERT) == ANYOF_FOLD)) { for (value = 0; value < 256; ++value) { if (ANYOF_BITMAP_TEST(ret, value)) { - I32 cf = PL_fold[value]; - ANYOF_BITMAP_SET(ret, cf); + IV fold = PL_fold[value]; + + if (fold != value) + ANYOF_BITMAP_SET(ret, fold); } } ANYOF_FLAGS(ret) &= ~ANYOF_FOLD; } + /* optimize inverted simple patterns (e.g. [^a-z]) */ - if (!SIZE_ONLY && (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) { + if (!SIZE_ONLY && !dont_optimize_invert && + /* If the only flag is inversion. */ + (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) { for (value = 0; value < ANYOF_BITMAP_SIZE; ++value) ANYOF_BITMAP(ret)[value] ^= ANYOF_FLAGS_ALL; - ANYOF_FLAGS(ret) = 0; - } - return ret; -} - -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; - I32 n; - SV *listsv; - U8 flags = 0; - I32 namedclass; - char *rangebegin; - - if (*PL_regcomp_parse == '^') { /* Complement of range. */ - PL_regnaughty++; - PL_regcomp_parse++; - if (!SIZE_ONLY) - flags |= ANYOF_INVERT; - } - if (!SIZE_ONLY) { - if (FOLD) - flags |= ANYOF_FOLD; - if (LOC) - flags |= ANYOF_LOCALE; - listsv = newSVpvn("# comment\n",10); - } - - if (!SIZE_ONLY && ckWARN(WARN_REGEXP)) - checkposixcc(); - - if (*PL_regcomp_parse == ']' || *PL_regcomp_parse == '-') - goto skipcond; /* allow 1st char to be ] or - */ - - while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != ']') { - skipcond: - namedclass = OOB_NAMEDCLASS; - if (!range) - rangebegin = PL_regcomp_parse; - value = utf8_to_uv_chk((U8*)PL_regcomp_parse, &numlen, 0); - PL_regcomp_parse += numlen; - if (value == '[') - namedclass = regpposixcc(value); - else if (value == '\\') { - value = (U32)utf8_to_uv_chk((U8*)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 - * be a problem later if we want switch on Unicode. --jhi */ - switch (value) { - case 'w': namedclass = ANYOF_ALNUM; break; - case 'W': namedclass = ANYOF_NALNUM; break; - case 's': namedclass = ANYOF_SPACE; break; - case 'S': namedclass = ANYOF_NSPACE; break; - case 'd': namedclass = ANYOF_DIGIT; break; - case 'D': namedclass = ANYOF_NDIGIT; break; - case 'p': - case 'P': - if (*PL_regcomp_parse == '{') { - e = strchr(PL_regcomp_parse++, '}'); - if (!e) - vFAIL("Missing right brace on \\p{}"); - n = e - PL_regcomp_parse; - } - else { - e = PL_regcomp_parse; - n = 1; - } - if (!SIZE_ONLY) { - if (value == 'p') - Perl_sv_catpvf(aTHX_ listsv, - "+utf8::%.*s\n", (int)n, PL_regcomp_parse); - else - Perl_sv_catpvf(aTHX_ listsv, - "!utf8::%.*s\n", (int)n, PL_regcomp_parse); - } - PL_regcomp_parse = e + 1; - lastvalue = OOB_UTF8; - continue; - case 'n': value = '\n'; break; - case 'r': value = '\r'; break; - case 't': value = '\t'; break; - case 'f': value = '\f'; break; - case 'b': value = '\b'; break; -#ifdef ASCIIish - case 'e': value = '\033'; break; - case 'a': value = '\007'; break; -#else - case 'e': value = '\047'; break; - case 'a': value = '\057'; break; -#endif - case 'x': - if (*PL_regcomp_parse == '{') { - e = strchr(PL_regcomp_parse++, '}'); - 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; - } - break; - case 'c': - value = UCHARAT(PL_regcomp_parse++); - value = toCTRL(value); - 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)) - vWARN2(PL_regcomp_parse, - "Unrecognized escape \\%c in character class passed through", - (int)value); - break; - } - } - if (namedclass > OOB_NAMEDCLASS) { - if (range) { /* a-\d, a-[:digit:] */ - if (!SIZE_ONLY) { - if (ckWARN(WARN_REGEXP)) - 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); - } - range = 0; - } - if (!SIZE_ONLY) { - switch (namedclass) { - case ANYOF_ALNUM: - Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsWord\n"); break; - case ANYOF_NALNUM: - Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsWord\n"); break; - case ANYOF_ALNUMC: - Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlnum\n"); break; - case ANYOF_NALNUMC: - Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlnum\n"); break; - case ANYOF_ALPHA: - Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlpha\n"); break; - case ANYOF_NALPHA: - Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlpha\n"); break; - case ANYOF_ASCII: - Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsASCII\n"); break; - case ANYOF_NASCII: - Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsASCII\n"); break; - case ANYOF_CNTRL: - Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsCntrl\n"); break; - case ANYOF_NCNTRL: - Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsCntrl\n"); break; - case ANYOF_GRAPH: - Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsGraph\n"); break; - case ANYOF_NGRAPH: - Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsGraph\n"); break; - case ANYOF_DIGIT: - Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsDigit\n"); break; - case ANYOF_NDIGIT: - Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsDigit\n"); break; - case ANYOF_LOWER: - Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsLower\n"); break; - case ANYOF_NLOWER: - Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsLower\n"); break; - case ANYOF_PRINT: - Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPrint\n"); break; - case ANYOF_NPRINT: - Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPrint\n"); break; - case ANYOF_PUNCT: - Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPunct\n"); break; - case ANYOF_NPUNCT: - Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPunct\n"); break; - case ANYOF_SPACE: - case ANYOF_PSXSPC: - case ANYOF_BLANK: - Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpace\n"); break; - case ANYOF_NSPACE: - case ANYOF_NPSXSPC: - case ANYOF_NBLANK: - Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpace\n"); break; - case ANYOF_UPPER: - Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsUpper\n"); break; - case ANYOF_NUPPER: - Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsUpper\n"); break; - case ANYOF_XDIGIT: - Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsXDigit\n"); break; - case ANYOF_NXDIGIT: - Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsXDigit\n"); break; - } - continue; - } - } - if (range) { - if (lastvalue > value) { /* b-a */ - Simple_vFAIL4("invalid [] range \"%*.*s\"", - PL_regcomp_parse - rangebegin, - PL_regcomp_parse - rangebegin, - rangebegin); - } - range = 0; - } - else { - lastvalue = value; - if (*PL_regcomp_parse == '-' && PL_regcomp_parse+1 < PL_regxend && - PL_regcomp_parse[1] != ']') { - PL_regcomp_parse++; - if (namedclass > OOB_NAMEDCLASS) { /* \w-, [:word:]- */ - if (ckWARN(WARN_REGEXP)) - 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 '-' */ - "002D\n"); - } else - range = 1; - continue; /* do it next time */ - } - } - /* now is the next time */ - if (!SIZE_ONLY) - Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n", - (UV)lastvalue, (UV)value); - range = 0; + ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL; } - ret = reganode(ANYOFUTF8, 0); + if (!SIZE_ONLY) { + AV *av = newAV(); + SV *rv; - if (!SIZE_ONLY) { - SV *rv = swash_init("utf8", "", listsv, 1, 0); - SvREFCNT_dec(listsv); - n = add_data(1,"s"); - PL_regcomp_rx->data->data[n] = (void*)rv; - ARG1_SET(ret, flags); - ARG2_SET(ret, n); + av_store(av, 0, listsv); + av_store(av, 1, NULL); + rv = newRV_noinc((SV*)av); + n = add_data(pRExC_state, 1, "s"); + RExC_rx->data->data[n] = (void*)rv; + ARG_SET(ret, n); } return ret; } STATIC char* -S_nextchar(pTHX) +S_nextchar(pTHX_ RExC_state_t *pRExC_state) { - dTHR; - char* retval = PL_regcomp_parse++; + char* retval = RExC_parse++; for (;;) { - if (*PL_regcomp_parse == '(' && PL_regcomp_parse[1] == '?' && - PL_regcomp_parse[2] == '#') { - while (*PL_regcomp_parse && *PL_regcomp_parse != ')') - PL_regcomp_parse++; - PL_regcomp_parse++; + if (*RExC_parse == '(' && RExC_parse[1] == '?' && + RExC_parse[2] == '#') { + while (*RExC_parse && *RExC_parse != ')') + RExC_parse++; + RExC_parse++; continue; } - if (PL_regflags & PMf_EXTENDED) { - if (isSPACE(*PL_regcomp_parse)) { - PL_regcomp_parse++; + if (RExC_flags16 & PMf_EXTENDED) { + if (isSPACE(*RExC_parse)) { + RExC_parse++; continue; } - else if (*PL_regcomp_parse == '#') { - while (*PL_regcomp_parse && *PL_regcomp_parse != '\n') - PL_regcomp_parse++; - PL_regcomp_parse++; + else if (*RExC_parse == '#') { + while (*RExC_parse && *RExC_parse != '\n') + RExC_parse++; + RExC_parse++; continue; } } @@ -3887,23 +3862,22 @@ S_nextchar(pTHX) - reg_node - emit a node */ STATIC regnode * /* Location. */ -S_reg_node(pTHX_ U8 op) +S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op) { - dTHR; register regnode *ret; register regnode *ptr; - ret = PL_regcode; + ret = RExC_emit; if (SIZE_ONLY) { - SIZE_ALIGN(PL_regsize); - PL_regsize += 1; + SIZE_ALIGN(RExC_size); + RExC_size += 1; return(ret); } NODE_ALIGN_FILL(ret); ptr = ret; FILL_ADVANCE_NODE(ptr, op); - PL_regcode = ptr; + RExC_emit = ptr; return(ret); } @@ -3912,23 +3886,22 @@ S_reg_node(pTHX_ U8 op) - reganode - emit a node with an argument */ STATIC regnode * /* Location. */ -S_reganode(pTHX_ U8 op, U32 arg) +S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg) { - dTHR; register regnode *ret; register regnode *ptr; - ret = PL_regcode; + ret = RExC_emit; if (SIZE_ONLY) { - SIZE_ALIGN(PL_regsize); - PL_regsize += 2; + SIZE_ALIGN(RExC_size); + RExC_size += 2; return(ret); } NODE_ALIGN_FILL(ret); ptr = ret; FILL_ADVANCE_NODE_ARG(ptr, op, arg); - PL_regcode = ptr; + RExC_emit = ptr; return(ret); } @@ -3937,16 +3910,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_ RExC_state_t *pRExC_state, 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); } /* @@ -3955,9 +3921,8 @@ S_reguni(pTHX_ UV uv, char* s, I32* lenp) * Means relocating the operand. */ STATIC void -S_reginsert(pTHX_ U8 op, regnode *opnd) +S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd) { - dTHR; register regnode *src; register regnode *dst; register regnode *place; @@ -3966,13 +3931,13 @@ S_reginsert(pTHX_ U8 op, regnode *opnd) /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */ if (SIZE_ONLY) { - PL_regsize += NODE_STEP_REGNODE + offset; + RExC_size += NODE_STEP_REGNODE + offset; return; } - src = PL_regcode; - PL_regcode += NODE_STEP_REGNODE + offset; - dst = PL_regcode; + src = RExC_emit; + RExC_emit += NODE_STEP_REGNODE + offset; + dst = RExC_emit; while (src > opnd) StructCopy(--src, --dst, regnode); @@ -3986,9 +3951,8 @@ S_reginsert(pTHX_ U8 op, regnode *opnd) - regtail - set the next-pointer at the end of a node chain of p to val. */ STATIC void -S_regtail(pTHX_ regnode *p, regnode *val) +S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, regnode *val) { - dTHR; register regnode *scan; register regnode *temp; @@ -4016,17 +3980,16 @@ S_regtail(pTHX_ regnode *p, regnode *val) - regoptail - regtail on operand of first argument; nop if operandless */ STATIC void -S_regoptail(pTHX_ regnode *p, regnode *val) +S_regoptail(pTHX_ RExC_state_t *pRExC_state, regnode *p, regnode *val) { - dTHR; /* "Operandless" and "op != BRANCH" are synonymous in practice. */ if (p == NULL || SIZE_ONLY) return; if (PL_regkind[(U8)OP(p)] == BRANCH) { - regtail(NEXTOPER(p), val); + regtail(pRExC_state, NEXTOPER(p), val); } else if ( PL_regkind[(U8)OP(p)] == BRANCHJ) { - regtail(NEXTOPER(NEXTOPER(p)), val); + regtail(pRExC_state, NEXTOPER(NEXTOPER(p)), val); } else return; @@ -4132,7 +4095,6 @@ void Perl_regdump(pTHX_ regexp *r) { #ifdef DEBUGGING - dTHR; SV *sv = sv_newmortal(); (void)dumpuntil(r->program, r->program + 1, NULL, sv, 0); @@ -4199,7 +4161,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 || !isPRINT(c)) Perl_sv_catpvf(aTHX_ sv, "\\%o", c); else if (c == '-' || c == ']' || c == '\\' || c == '^') Perl_sv_catpvf(aTHX_ sv, "\\%c", c); @@ -4214,12 +4176,13 @@ 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"); + /* It would be nice to FAIL() here, but this may be called from + regexec.c, and it would be hard to supply pRExC_state. */ + Perl_croak(aTHX_ "Corrupted regexp opcode"); sv_catpv(sv, (char*)reg_name[OP(o)]); /* Take off const! */ k = PL_regkind[(U8)OP(o)]; @@ -4228,7 +4191,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)); } @@ -4240,8 +4203,9 @@ 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 - ANYOF_ #xdefines in regcomp.h */ + U8 flags = ANYOF_FLAGS(o); + const char * const anyofs[] = { /* Should be syncronized with + * ANYOF_ #xdefines in regcomp.h */ "\\w", "\\W", "\\s", @@ -4274,12 +4238,12 @@ Perl_regprop(pTHX_ SV *sv, regnode *o) "[:^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)) { @@ -4297,10 +4261,79 @@ Perl_regprop(pTHX_ SV *sv, regnode *o) rangestart = -1; } } + if (o->flags & ANYOF_CLASS) - for (i = 0; i < sizeof(out)/sizeof(char*); i++) + for (i = 0; i < sizeof(anyofs)/sizeof(char*); i++) if (ANYOF_CLASS_TEST(o,i)) - sv_catpv(sv, out[i]); + sv_catpv(sv, anyofs[i]); + + if (flags & ANYOF_UNICODE) + sv_catpv(sv, "{unicode}"); + else if (flags & ANYOF_UNICODE_ALL) + sv_catpv(sv, "{all-unicode}"); + + { + SV *lv; + SV *sw = regclass_swash(o, FALSE, &lv); + + if (lv) { + if (sw) { + 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, "..."); /* et cetera */ + } + + { + char *s = savepv(SvPVX(lv)); + char *origs = s; + + 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); + } + + Safefree(origs); + } + } + } + Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]); } else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH)) @@ -4330,7 +4363,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)) @@ -4391,7 +4423,7 @@ Perl_pregfree(pTHX_ struct regexp *r) case 'n': break; default: - FAIL2("panic: regfree data code '%c'", r->data->what[n]); + Perl_croak(aTHX_ "panic: regfree data code '%c'", r->data->what[n]); } } Safefree(r->data->what); @@ -4411,7 +4443,6 @@ Perl_pregfree(pTHX_ struct regexp *r) regnode * Perl_regnext(pTHX_ register regnode *p) { - dTHR; register I32 offset; if (p == &PL_regdummy) @@ -4463,12 +4494,22 @@ S_re_croak2(pTHX_ const char* pat1,const char* pat2,...) void Perl_save_re_context(pTHX) { - dTHR; +#if 0 + SAVEPPTR(RExC_precomp); /* uncompiled string. */ + SAVEI32(RExC_npar); /* () count. */ + SAVEI32(RExC_size); /* Code size. */ + SAVEI16(RExC_flags16); /* are we folding, multilining? */ + SAVEVPTR(RExC_rx); /* from regcomp.c */ + SAVEI32(RExC_seen); /* from regcomp.c */ + SAVEI32(RExC_sawback); /* Did we see \1, ...? */ + SAVEI32(RExC_naughty); /* How bad is this pattern? */ + SAVEVPTR(RExC_emit); /* Code-emit pointer; ®dummy = don't */ + SAVEPPTR(RExC_end); /* End of input for compile */ + SAVEPPTR(RExC_parse); /* Input-scan pointer. */ +#endif + + SAVEI32(PL_reg_flags); /* from regexec.c */ SAVEPPTR(PL_bostr); - SAVEPPTR(PL_regprecomp); /* uncompiled string. */ - SAVEI32(PL_regnpar); /* () count. */ - SAVEI32(PL_regsize); /* Code size. */ - SAVEI16(PL_regflags); /* are we folding, multilining? */ SAVEPPTR(PL_reginput); /* String-input pointer. */ SAVEPPTR(PL_regbol); /* Beginning of input, for ^ check. */ SAVEPPTR(PL_regeol); /* End of input, for $ check. */ @@ -4483,20 +4524,12 @@ Perl_save_re_context(pTHX) SAVEI32(PL_reg_start_tmpl); /* from regexec.c */ PL_reg_start_tmpl = 0; SAVEVPTR(PL_regdata); - SAVEI32(PL_reg_flags); /* from regexec.c */ SAVEI32(PL_reg_eval_set); /* from regexec.c */ SAVEI32(PL_regnarrate); /* from regexec.c */ SAVEVPTR(PL_regprogram); /* from regexec.c */ SAVEINT(PL_regindent); /* from regexec.c */ SAVEVPTR(PL_regcc); /* from regexec.c */ SAVEVPTR(PL_curcop); - SAVEVPTR(PL_regcomp_rx); /* from regcomp.c */ - SAVEI32(PL_regseen); /* from regcomp.c */ - SAVEI32(PL_regsawback); /* Did we see \1, ...? */ - SAVEI32(PL_regnaughty); /* How bad is this pattern? */ - SAVEVPTR(PL_regcode); /* Code-emit pointer; ®dummy = don't */ - SAVEPPTR(PL_regxend); /* End of input for compile */ - SAVEPPTR(PL_regcomp_parse); /* Input-scan pointer. */ SAVEVPTR(PL_reg_call_cc); /* from regexec.c */ SAVEVPTR(PL_reg_re); /* from regexec.c */ SAVEPPTR(PL_reg_ganch); /* from regexec.c */ @@ -4505,6 +4538,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 @@ -4521,4 +4555,3 @@ clear_re(pTHXo_ void *r) { ReREFCNT_dec((regexp *)r); } - @@ -88,12 +88,13 @@ struct regnode_2 { }; #define ANYOF_BITMAP_SIZE 32 /* 256 b/(8 b/B) */ -#define ANYOF_CLASSBITMAP_SIZE 4 +#define ANYOF_CLASSBITMAP_SIZE 4 /* up to 32 (8*4) named classes */ struct regnode_charclass { U8 flags; U8 type; U16 next_off; + U32 arg1; char bitmap[ANYOF_BITMAP_SIZE]; }; @@ -101,6 +102,7 @@ struct regnode_charclass_class { U8 flags; U8 type; U16 next_off; + U32 arg1; char bitmap[ANYOF_BITMAP_SIZE]; char classflags[ANYOF_CLASSBITMAP_SIZE]; }; @@ -176,17 +178,26 @@ struct regnode_charclass_class { #define REG_MAGIC 0234 -#define SIZE_ONLY (PL_regcode == &PL_regdummy) +#define SIZE_ONLY (RExC_emit == &PL_regdummy) /* Flags for node->flags of ANYOF */ -#define ANYOF_CLASS 0x08 -#define ANYOF_INVERT 0x04 -#define ANYOF_FOLD 0x02 -#define ANYOF_LOCALE 0x01 +#define ANYOF_CLASS 0x08 +#define ANYOF_INVERT 0x04 +#define ANYOF_FOLD 0x02 +#define ANYOF_LOCALE 0x01 /* Used for regstclass only */ -#define ANYOF_EOS 0x10 /* Can match an empty string too */ +#define ANYOF_EOS 0x10 /* Can match an empty string too */ + +/* There is a character or a range past 0xff */ +#define ANYOF_UNICODE 0x20 +#define ANYOF_UNICODE_ALL 0x40 /* Can match any char past 0xff */ + +/* Are there any runtime flags on in this node? */ +#define ANYOF_RUNTIME(s) (ANYOF_FLAGS(s) & 0x0f) + +#define ANYOF_FLAGS_ALL 0xff /* Character classes for node->classflags of ANYOF */ /* Should be synchronized with a table in regprop() */ @@ -220,7 +231,7 @@ struct regnode_charclass_class { #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_BLANK 28 /* GNU extension: space and tab: non-vertical space */ #define ANYOF_NBLANK 29 #define ANYOF_MAX 32 @@ -238,7 +249,6 @@ struct regnode_charclass_class { #define ANYOF_CLASS_SIZE (sizeof(struct regnode_charclass_class)) #define ANYOF_FLAGS(p) ((p)->flags) -#define ANYOF_FLAGS_ALL 0xff #define ANYOF_BIT(c) (1 << ((c) & 7)) @@ -300,12 +310,14 @@ EXTCONST U8 PL_varies[] = { EXTCONST U8 PL_simple[]; #else EXTCONST U8 PL_simple[] = { - REG_ANY, ANYUTF8, SANY, SANYUTF8, ANYOF, ANYOFUTF8, - ALNUM, ALNUMUTF8, ALNUML, ALNUMLUTF8, - NALNUM, NALNUMUTF8, NALNUML, NALNUMLUTF8, - SPACE, SPACEUTF8, SPACEL, SPACELUTF8, - NSPACE, NSPACEUTF8, NSPACEL, NSPACELUTF8, - DIGIT, DIGITUTF8, NDIGIT, NDIGITUTF8, 0 + REG_ANY, SANY, + ANYOF, + ALNUM, ALNUML, + NALNUM, NALNUML, + SPACE, SPACEL, + NSPACE, NSPACEL, + DIGIT, NDIGIT, + 0 }; #endif diff --git a/regcomp.sym b/regcomp.sym index bb5f8f8482..59284f4b21 100644 --- a/regcomp.sym +++ b/regcomp.sym @@ -16,46 +16,27 @@ EOL EOL, no Match "" at end of line. MEOL EOL, no Same, assuming multiline. SEOL EOL, no Same, assuming singleline. BOUND BOUND, no Match "" at any word boundary -BOUNDUTF8 BOUND, no Match "" at any word boundary BOUNDL BOUND, no Match "" at any word boundary -BOUNDLUTF8 BOUND, no Match "" at any word boundary NBOUND NBOUND, no Match "" at any word non-boundary -NBOUNDUTF8 NBOUND, no Match "" at any word non-boundary NBOUNDL NBOUND, no Match "" at any word non-boundary -NBOUNDLUTF8 NBOUND, no Match "" at any word non-boundary GPOS GPOS, no Matches where last m//g left off. # [Special] alternatives REG_ANY REG_ANY, no Match any one character (except newline). -ANYUTF8 REG_ANY, no Match any one Unicode character (except newline). SANY REG_ANY, no Match any one character. -SANYUTF8 REG_ANY, no Match any one Unicode character. ANYOF ANYOF, sv Match character in (or not in) this class. -ANYOFUTF8 ANYOF, sv 1 Match character in (or not in) this class. ALNUM ALNUM, no Match any alphanumeric character -ALNUMUTF8 ALNUM, no Match any alphanumeric character in utf8 ALNUML ALNUM, no Match any alphanumeric char in locale -ALNUMLUTF8 ALNUM, no Match any alphanumeric char in locale+utf8 NALNUM NALNUM, no Match any non-alphanumeric character -NALNUMUTF8 NALNUM, no Match any non-alphanumeric character in utf8 NALNUML NALNUM, no Match any non-alphanumeric char in locale -NALNUMLUTF8 NALNUM, no Match any non-alphanumeric char in locale+utf8 SPACE SPACE, no Match any whitespace character -SPACEUTF8 SPACE, no Match any whitespace character in utf8 SPACEL SPACE, no Match any whitespace char in locale -SPACELUTF8 SPACE, no Match any whitespace char in locale+utf8 NSPACE NSPACE, no Match any non-whitespace character -NSPACEUTF8 NSPACE, no Match any non-whitespace character in utf8 NSPACEL NSPACE, no Match any non-whitespace char in locale -NSPACELUTF8 NSPACE, no Match any non-whitespace char in locale+utf8 DIGIT DIGIT, no Match any numeric character -DIGITUTF8 DIGIT, no Match any numeric character in utf8 DIGITL DIGIT, no Match any numeric character in locale -DIGITLUTF8 DIGIT, no Match any numeric character in locale+utf8 NDIGIT NDIGIT, no Match any non-numeric character -NDIGITUTF8 NDIGIT, no Match any non-numeric character in utf8 NDIGITL NDIGIT, no Match any non-numeric character in locale -NDIGITLUTF8 NDIGIT, no Match any non-numeric character in locale+utf8 CLUMP CLUMP, no Match any combining character sequence # BRANCH The set of branches constituting a single choice are hooked @@ -39,6 +39,7 @@ /* *These* symbols are masked to allow static link. */ # define Perl_pregexec my_pregexec # define Perl_reginitcolors my_reginitcolors +# define Perl_regclass_swash my_regclass_swash # define PERL_NO_GET_CONTEXT #endif @@ -66,7 +67,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. @@ -105,26 +106,29 @@ * Forwards. */ -#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)) - #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv)) -#define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b) +#define CHR_DIST(a,b) (DO_UTF8(PL_reg_sv) ? utf8_distance(a,b) : a - b) #define reghop_c(pos,off) ((char*)reghop((U8*)pos, off)) #define reghopmaybe_c(pos,off) ((char*)reghopmaybe((U8*)pos, off)) -#define HOP(pos,off) (UTF ? reghop((U8*)pos, off) : (U8*)(pos + off)) -#define HOPMAYBE(pos,off) (UTF ? reghopmaybe((U8*)pos, off) : (U8*)(pos + off)) +#define HOP(pos,off) (DO_UTF8(PL_reg_sv) ? reghop((U8*)pos, off) : (U8*)(pos + off)) +#define HOPMAYBE(pos,off) (DO_UTF8(PL_reg_sv) ? reghopmaybe((U8*)pos, off) : (U8*)(pos + off)) #define HOPc(pos,off) ((char*)HOP(pos,off)) #define HOPMAYBEc(pos,off) ((char*)HOPMAYBE(pos,off)) +#define reghop3_c(pos,off,lim) ((char*)reghop3((U8*)pos, off, (U8*)lim)) +#define reghopmaybe3_c(pos,off,lim) ((char*)reghopmaybe3((U8*)pos, off, (U8*)lim)) +#define HOP3(pos,off,lim) (DO_UTF8(PL_reg_sv) ? reghop3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off)) +#define HOPMAYBE3(pos,off,lim) (DO_UTF8(PL_reg_sv) ? reghopmaybe3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off)) +#define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim)) +#define HOPMAYBE3c(pos,off,lim) ((char*)HOPMAYBE3(pos,off,lim)) + 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; int p; @@ -145,19 +149,18 @@ S_regcppush(pTHX_ I32 parenfloor) } /* 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; U32 paren = 0; char *input; @@ -190,18 +193,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 +233,7 @@ 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) { \ @@ -260,7 +274,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; @@ -325,6 +338,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; @@ -347,10 +361,15 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, (strend - strpos > 60 ? "..." : "")) ); - if (prog->minlen > strend - strpos) { + if (prog->reganch & ROPT_UTF8) + PL_reg_flags |= RF_utf8; + + if (prog->minlen > CHR_DIST((U8*)strend, (U8*)strpos)) { DEBUG_r(PerlIO_printf(Perl_debug_log, "String too short...\n")); goto fail; } + strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos; + PL_regeol = strend; check = prog->check_substr; if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */ ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE) @@ -361,7 +380,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, if ( !(prog->reganch & ROPT_ANCH_GPOS) /* Checked by the caller */ /* SvCUR is not set on references: SvRV and SvPVX overlap */ && sv && !SvROK(sv) - && (strpos + SvCUR(sv) != strend)) { + && (strpos != strbeg)) { DEBUG_r(PerlIO_printf(Perl_debug_log, "Not at start...\n")); goto fail; } @@ -369,8 +388,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, /* Substring at constant offset from beg-of-str... */ I32 slen; - PL_regeol = strend; /* Used in HOP() */ - s = HOPc(strpos, prog->check_offset_min); + s = HOP3c(strpos, prog->check_offset_min, strend); if (SvTAIL(check)) { slen = SvCUR(check); /* >= 1 */ @@ -404,7 +422,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, if (!ml_anch) { I32 end = prog->check_offset_max + CHR_SVLEN(check) - (SvTAIL(check) != 0); - I32 eshift = strend - s - end; + I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end; if (end_shift < eshift) end_shift = eshift; @@ -428,7 +446,6 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, /* 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; @@ -444,8 +461,8 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, *data->scream_olds = s; } else - s = fbm_instr((unsigned char*)s + start_shift, - (unsigned char*)strend - end_shift, + s = fbm_instr(HOP3(s, start_shift, strend), + HOP3(strend, -end_shift, strbeg), check, PL_multiline ? FBMrf_MULTILINE : 0); /* Update the count-of-usability, remove useless subpatterns, @@ -484,34 +501,33 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, if (check == prog->float_substr) { do_other_anchored: { - char *last = s - start_shift, *last1, *last2; + char *last = HOP3c(s, -start_shift, strbeg), *last1, *last2; char *s1 = s; - tmp = PL_bostr; t = s - prog->check_offset_max; if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */ && (!(prog->reganch & ROPT_UTF8) - || (PL_bostr = strpos, /* Used in regcopmaybe() */ - (t = reghopmaybe_c(s, -(prog->check_offset_max))) + || ((t = reghopmaybe3_c(s, -(prog->check_offset_max), strpos)) && t > strpos))) /* EMPTY */; else t = strpos; - t += prog->anchored_offset; + t = HOP3c(t, prog->anchored_offset, strend); if (t < other_last) /* These positions already checked */ t = other_last; - PL_bostr = tmp; - last2 = last1 = strend - prog->minlen; + last2 = last1 = HOP3c(strend, -prog->minlen, strbeg); if (last < last1) last1 = last; /* XXXX It is not documented what units *_offsets are in. Assume bytes. */ /* On end-of-str: see comment below. */ s = fbm_instr((unsigned char*)t, - (unsigned char*)last1 + prog->anchored_offset - + SvCUR(prog->anchored_substr) - - (SvTAIL(prog->anchored_substr)!=0), - prog->anchored_substr, PL_multiline ? FBMrf_MULTILINE : 0); - DEBUG_r(PerlIO_printf(Perl_debug_log, "%s anchored substr `%s%.*s%s'%s", + HOP3(HOP3(last1, prog->anchored_offset, strend) + + SvCUR(prog->anchored_substr), + -(SvTAIL(prog->anchored_substr)!=0), strbeg), + prog->anchored_substr, + PL_multiline ? FBMrf_MULTILINE : 0); + DEBUG_r(PerlIO_printf(Perl_debug_log, + "%s anchored substr `%s%.*s%s'%s", (s ? "Found" : "Contradicts"), PL_colors[0], (int)(SvCUR(prog->anchored_substr) @@ -526,17 +542,16 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, } DEBUG_r(PerlIO_printf(Perl_debug_log, ", trying floating at offset %ld...\n", - (long)(s1 + 1 - i_strpos))); - PL_regeol = strend; /* Used in HOP() */ - other_last = last1 + prog->anchored_offset + 1; - s = HOPc(last, 1); + (long)(HOP3c(s1, 1, strend) - i_strpos))); + other_last = HOP3c(last1, prog->anchored_offset+1, strend); + s = HOP3c(last, 1, strend); goto restart; } else { DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n", (long)(s - i_strpos))); - t = s - prog->anchored_offset; - other_last = s + 1; + t = HOP3c(s, -prog->anchored_offset, strbeg); + other_last = HOP3c(s, 1, strend); s = s1; if (t == strpos) goto try_at_start; @@ -548,11 +563,12 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, char *last, *last1; char *s1 = s; - t = s - start_shift; - last1 = last = strend - prog->minlen + prog->float_min_offset; - if (last - t > prog->float_max_offset) - last = t + prog->float_max_offset; - s = t + prog->float_min_offset; + t = HOP3c(s, -start_shift, strbeg); + last1 = last = + HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg); + if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset) + last = HOP3c(t, prog->float_max_offset, strend); + s = HOP3c(t, prog->float_min_offset, strend); if (s < other_last) s = other_last; /* XXXX It is not documented what units *_offsets are in. Assume bytes. */ @@ -580,8 +596,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, ", trying anchored starting at offset %ld...\n", (long)(s1 + 1 - i_strpos))); other_last = last + 1; - PL_regeol = strend; /* Used in HOP() */ - s = HOPc(t, 1); + s = HOP3c(t, 1, strend); goto restart; } else { @@ -597,13 +612,10 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, } t = s - prog->check_offset_max; - tmp = PL_bostr; if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */ && (!(prog->reganch & ROPT_UTF8) - || (PL_bostr = strpos, /* Used in regcopmaybe() */ - ((t = reghopmaybe_c(s, -(prog->check_offset_max))) - && t > strpos)))) { - PL_bostr = tmp; + || ((t = reghopmaybe3_c(s, -prog->check_offset_max, strpos)) + && t > strpos))) { /* Fixed substring is found far enough so that the match cannot start at strpos. */ try_at_offset: @@ -661,7 +673,6 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, ++BmUSEFUL(prog->check_substr); /* hooray/5 */ } else { - PL_bostr = tmp; /* 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, @@ -670,7 +681,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, /* Even in this situation we may use MBOL flag if strpos is offset wrt the start of the string. */ if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */ - && (strpos + SvCUR(sv) != strend) && strpos[-1] != '\n' + && (strpos != strbeg) && strpos[-1] != '\n' /* May be due to an implicit anchor of m{.*foo} */ && !(prog->reganch & ROPT_IMPLICIT)) { @@ -714,18 +725,21 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, regstclass does not come from lookahead... */ /* If regstclass takes bytelength more than 1: If charlength==1, OK. This leaves EXACTF only, which is dealt with in find_byclass(). */ + U8* str = (U8*)STRING(prog->regstclass); int cl_l = (PL_regkind[(U8)OP(prog->regstclass)] == EXACT - ? STR_LEN(prog->regstclass) + ? CHR_DIST(str+STR_LEN(prog->regstclass), str) : 1); char *endpos = (prog->anchored_substr || ml_anch) - ? 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; + ? HOP3c(s, (prog->minlen ? cl_l : 0), strend) + : (prog->float_substr + ? HOP3c(HOP3c(check_at, -start_shift, strbeg), + cl_l, strend) + : strend); + char *startpos = strbeg; t = s; if (prog->reganch & ROPT_UTF8) { - PL_regdata = prog->data; /* Used by REGINCLASS UTF logic */ + PL_regdata = prog->data; PL_bostr = startpos; } s = find_byclass(prog, prog->regstclass, s, endpos, startpos, 1); @@ -747,8 +761,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, if (prog->anchored_substr == check) { DEBUG_r( what = "anchored" ); hop_and_restart: - PL_regeol = strend; /* Used in HOP() */ - s = HOPc(t, 1); + s = HOP3c(t, 1, strend); if (s + start_shift + end_shift > strend) { /* XXXX Should be taken into account earlier? */ DEBUG_r( PerlIO_printf(Perl_debug_log, @@ -827,25 +840,13 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta unsigned int c2; char *e; register I32 tmp = 1; /* Scratch variable? */ + register bool do_utf8 = DO_UTF8(PL_reg_sv); /* We know what class it must start with. */ switch (OP(c)) { - case ANYOFUTF8: - while (s < strend) { - if (REGINCLASSUTF8(c, (U8*)s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; - else - tmp = doevery; - } - else - tmp = 1; - s += UTF8SKIP(s); - } - break; case ANYOF: while (s < strend) { - if (REGINCLASS(c, *(U8*)s)) { + if (reginclass(c, (U8*)s, do_utf8)) { if (tmp && (norun || regtry(prog, s))) goto got_it; else @@ -853,14 +854,20 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta } else tmp = 1; - s++; + s += do_utf8 ? UTF8SKIP(s) : 1; } break; case EXACTF: m = STRING(c); ln = STR_LEN(c); - c1 = *(U8*)m; - c2 = PL_fold[c1]; + if (UTF) { + c1 = to_utf8_lower((U8*)m); + c2 = to_utf8_upper((U8*)m); + } + else { + c1 = *(U8*)m; + c2 = PL_fold[c1]; + } goto do_exactf; case EXACTFL: m = STRING(c); @@ -872,62 +879,85 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta if (norun && e < s) e = s; /* Due to minlen logic of intuit() */ - /* Here it is NOT UTF! */ - if (c1 == c2) { - while (s <= e) { - if ( *(U8*)s == c1 - && (ln == 1 || !(OP(c) == EXACTF - ? ibcmp(s, m, ln) - : ibcmp_locale(s, m, ln))) - && (norun || regtry(prog, s)) ) - goto got_it; - s++; - } - } else { - while (s <= e) { - if ( (*(U8*)s == c1 || *(U8*)s == c2) - && (ln == 1 || !(OP(c) == EXACTF - ? ibcmp(s, m, ln) - : ibcmp_locale(s, m, ln))) - && (norun || regtry(prog, s)) ) - goto got_it; - s++; - } + + if (do_utf8) { + STRLEN len; + if (c1 == c2) + while (s <= e) { + if ( utf8_to_uv_simple((U8*)s, &len) == c1 + && regtry(prog, s) ) + goto got_it; + s += len; + } + else + while (s <= e) { + UV c = utf8_to_uv_simple((U8*)s, &len); + if ( (c == c1 || c == c2) && regtry(prog, s) ) + goto got_it; + s += len; + } + } + else { + if (c1 == c2) + while (s <= e) { + if ( *(U8*)s == c1 + && (ln == 1 || !(OP(c) == EXACTF + ? ibcmp(s, m, ln) + : ibcmp_locale(s, m, ln))) + && (norun || regtry(prog, s)) ) + goto got_it; + s++; + } + else + while (s <= e) { + if ( (*(U8*)s == c1 || *(U8*)s == c2) + && (ln == 1 || !(OP(c) == EXACTF + ? ibcmp(s, m, ln) + : ibcmp_locale(s, m, ln))) + && (norun || regtry(prog, s)) ) + goto got_it; + s++; + } } break; case BOUNDL: PL_reg_flags |= RF_tainted; /* FALL THROUGH */ case BOUND: - tmp = (s != startpos) ? UCHARAT(s - 1) : '\n'; - tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0); - while (s < strend) { - if (tmp == !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) { - tmp = !tmp; - if ((norun || regtry(prog, s))) - goto got_it; + if (do_utf8) { + if (s == startpos) + tmp = '\n'; + else { + U8 *r = reghop3((U8*)s, -1, (U8*)startpos); + + tmp = (I32)utf8_to_uv(r, s - (char*)r, 0, 0); + } + tmp = ((OP(c) == BOUND ? + isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0); + while (s < strend) { + if (tmp == !(OP(c) == BOUND ? + swash_fetch(PL_utf8_alnum, (U8*)s) : + isALNUM_LC_utf8((U8*)s))) + { + tmp = !tmp; + if ((norun || regtry(prog, s))) + goto got_it; + } + s += UTF8SKIP(s); } - s++; } - if ((!prog->minlen && tmp) && (norun || regtry(prog, s))) - goto got_it; - break; - case BOUNDLUTF8: - PL_reg_flags |= RF_tainted; - /* FALL THROUGH */ - case BOUNDUTF8: - tmp = (I32)(s != startpos) ? utf8_to_uv_chk(reghop((U8*)s, -1), 0, 0) : '\n'; - 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) : - isALNUM_LC_utf8((U8*)s))) - { - tmp = !tmp; - if ((norun || regtry(prog, s))) - goto got_it; + else { + tmp = (s != startpos) ? UCHARAT(s - 1) : '\n'; + tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0); + while (s < strend) { + if (tmp == + !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) { + tmp = !tmp; + if ((norun || regtry(prog, s))) + goto got_it; + } + s++; } - s += UTF8SKIP(s); } if ((!prog->minlen && tmp) && (norun || regtry(prog, s))) goto got_it; @@ -936,358 +966,382 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta PL_reg_flags |= RF_tainted; /* FALL THROUGH */ case NBOUND: - tmp = (s != startpos) ? UCHARAT(s - 1) : '\n'; - tmp = ((OP(c) == NBOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0); - while (s < strend) { - if (tmp == !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s))) - tmp = !tmp; - else if ((norun || regtry(prog, s))) - goto got_it; - s++; + if (do_utf8) { + if (s == startpos) + tmp = '\n'; + else { + U8 *r = reghop3((U8*)s, -1, (U8*)startpos); + + tmp = (I32)utf8_to_uv(r, s - (char*)r, 0, 0); + } + tmp = ((OP(c) == NBOUND ? + isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0); + while (s < strend) { + if (tmp == !(OP(c) == NBOUND ? + swash_fetch(PL_utf8_alnum, (U8*)s) : + isALNUM_LC_utf8((U8*)s))) + tmp = !tmp; + else if ((norun || regtry(prog, s))) + goto got_it; + s += UTF8SKIP(s); + } } - if ((!prog->minlen && !tmp) && (norun || regtry(prog, s))) - goto got_it; - break; - case NBOUNDLUTF8: - PL_reg_flags |= RF_tainted; - /* FALL THROUGH */ - case NBOUNDUTF8: - tmp = (I32)(s != startpos) ? utf8_to_uv_chk(reghop((U8*)s, -1), 0, 0) : '\n'; - 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) : - isALNUM_LC_utf8((U8*)s))) - tmp = !tmp; - else if ((norun || regtry(prog, s))) - goto got_it; - s += UTF8SKIP(s); + else { + tmp = (s != startpos) ? UCHARAT(s - 1) : '\n'; + tmp = ((OP(c) == NBOUND ? + isALNUM(tmp) : isALNUM_LC(tmp)) != 0); + while (s < strend) { + if (tmp == + !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s))) + tmp = !tmp; + else if ((norun || regtry(prog, s))) + goto got_it; + s++; + } } if ((!prog->minlen && !tmp) && (norun || regtry(prog, s))) goto got_it; break; case ALNUM: - while (s < strend) { - if (isALNUM(*s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + if (do_utf8) { + while (s < strend) { + if (swash_fetch(PL_utf8_alnum, (U8*)s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s += UTF8SKIP(s); } - else - tmp = 1; - s++; } - break; - case ALNUMUTF8: - while (s < strend) { - if (swash_fetch(PL_utf8_alnum, (U8*)s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + else { + while (s < strend) { + if (isALNUM(*s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s++; } - else - tmp = 1; - s += UTF8SKIP(s); } break; case ALNUML: PL_reg_flags |= RF_tainted; - while (s < strend) { - if (isALNUM_LC(*s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + if (do_utf8) { + while (s < strend) { + if (isALNUM_LC_utf8((U8*)s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s += UTF8SKIP(s); } - else - tmp = 1; - s++; } - break; - case ALNUMLUTF8: - PL_reg_flags |= RF_tainted; - while (s < strend) { - if (isALNUM_LC_utf8((U8*)s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + else { + while (s < strend) { + if (isALNUM_LC(*s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s++; } - else - tmp = 1; - s += UTF8SKIP(s); } break; case NALNUM: - while (s < strend) { - if (!isALNUM(*s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + if (do_utf8) { + while (s < strend) { + if (!swash_fetch(PL_utf8_alnum, (U8*)s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s += UTF8SKIP(s); } - else - tmp = 1; - s++; } - break; - case NALNUMUTF8: - while (s < strend) { - if (!swash_fetch(PL_utf8_alnum, (U8*)s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + else { + while (s < strend) { + if (!isALNUM(*s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s++; } - else - tmp = 1; - s += UTF8SKIP(s); } break; case NALNUML: PL_reg_flags |= RF_tainted; - while (s < strend) { - if (!isALNUM_LC(*s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + if (do_utf8) { + while (s < strend) { + if (!isALNUM_LC_utf8((U8*)s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s += UTF8SKIP(s); } - else - tmp = 1; - s++; } - break; - case NALNUMLUTF8: - PL_reg_flags |= RF_tainted; - while (s < strend) { - if (!isALNUM_LC_utf8((U8*)s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + else { + while (s < strend) { + if (!isALNUM_LC(*s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s++; } - else - tmp = 1; - s += UTF8SKIP(s); } break; case SPACE: - while (s < strend) { - if (isSPACE(*s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + if (do_utf8) { + while (s < strend) { + if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s += UTF8SKIP(s); } - else - tmp = 1; - s++; } - break; - case SPACEUTF8: - while (s < strend) { - if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + else { + while (s < strend) { + if (isSPACE(*s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s++; } - else - tmp = 1; - s += UTF8SKIP(s); } break; case SPACEL: PL_reg_flags |= RF_tainted; - while (s < strend) { - if (isSPACE_LC(*s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + if (do_utf8) { + while (s < strend) { + if (*s == ' ' || isSPACE_LC_utf8((U8*)s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s += UTF8SKIP(s); } - else - tmp = 1; - s++; } - break; - case SPACELUTF8: - PL_reg_flags |= RF_tainted; - while (s < strend) { - if (*s == ' ' || isSPACE_LC_utf8((U8*)s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + else { + while (s < strend) { + if (isSPACE_LC(*s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s++; } - else - tmp = 1; - s += UTF8SKIP(s); } break; case NSPACE: - while (s < strend) { - if (!isSPACE(*s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + if (do_utf8) { + while (s < strend) { + if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s))) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s += UTF8SKIP(s); } - else - tmp = 1; - s++; } - break; - case NSPACEUTF8: - while (s < strend) { - if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s))) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + else { + while (s < strend) { + if (!isSPACE(*s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s++; } - else - tmp = 1; - s += UTF8SKIP(s); } break; case NSPACEL: PL_reg_flags |= RF_tainted; - while (s < strend) { - if (!isSPACE_LC(*s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + if (do_utf8) { + while (s < strend) { + if (!(*s == ' ' || isSPACE_LC_utf8((U8*)s))) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s += UTF8SKIP(s); } - else - tmp = 1; - s++; } - break; - case NSPACELUTF8: - PL_reg_flags |= RF_tainted; - while (s < strend) { - if (!(*s == ' ' || isSPACE_LC_utf8((U8*)s))) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + else { + while (s < strend) { + if (!isSPACE_LC(*s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s++; } - else - tmp = 1; - s += UTF8SKIP(s); } break; case DIGIT: - while (s < strend) { - if (isDIGIT(*s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + if (do_utf8) { + while (s < strend) { + if (swash_fetch(PL_utf8_digit,(U8*)s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s += UTF8SKIP(s); } - else - tmp = 1; - s++; } - break; - case DIGITUTF8: - while (s < strend) { - if (swash_fetch(PL_utf8_digit,(U8*)s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + else { + while (s < strend) { + if (isDIGIT(*s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s++; } - else - tmp = 1; - s += UTF8SKIP(s); } break; case DIGITL: PL_reg_flags |= RF_tainted; - while (s < strend) { - if (isDIGIT_LC(*s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + if (do_utf8) { + while (s < strend) { + if (isDIGIT_LC_utf8((U8*)s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s += UTF8SKIP(s); } - else - tmp = 1; - s++; } - break; - case DIGITLUTF8: - PL_reg_flags |= RF_tainted; - while (s < strend) { - if (isDIGIT_LC_utf8((U8*)s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + else { + while (s < strend) { + if (isDIGIT_LC(*s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s++; } - else - tmp = 1; - s += UTF8SKIP(s); } break; case NDIGIT: - while (s < strend) { - if (!isDIGIT(*s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + if (do_utf8) { + while (s < strend) { + if (!swash_fetch(PL_utf8_digit,(U8*)s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s += UTF8SKIP(s); } - else - tmp = 1; - s++; } - break; - case NDIGITUTF8: - while (s < strend) { - if (!swash_fetch(PL_utf8_digit,(U8*)s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + else { + while (s < strend) { + if (!isDIGIT(*s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s++; } - else - tmp = 1; - s += UTF8SKIP(s); } break; case NDIGITL: PL_reg_flags |= RF_tainted; - while (s < strend) { - if (!isDIGIT_LC(*s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + if (do_utf8) { + while (s < strend) { + if (!isDIGIT_LC_utf8((U8*)s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s += UTF8SKIP(s); } - else - tmp = 1; - s++; } - break; - case NDIGITLUTF8: - PL_reg_flags |= RF_tainted; - while (s < strend) { - if (!isDIGIT_LC_utf8((U8*)s)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; + else { + while (s < strend) { + if (!isDIGIT_LC(*s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } else - tmp = doevery; + tmp = 1; + s++; } - else - tmp = 1; - s += UTF8SKIP(s); } break; default: @@ -1311,7 +1365,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; @@ -1323,6 +1376,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * I32 scream_pos = -1; /* Internal iterator of scream. */ char *scream_olds; SV* oreplsv = GvSV(PL_replgv); + bool do_utf8 = DO_UTF8(sv); PL_regcc = 0; @@ -1338,12 +1392,22 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * } minlen = prog->minlen; - if (strend - startpos < minlen) goto phooey; + if (do_utf8) { + if (utf8_distance((U8*)strend, (U8*)startpos) < minlen) goto phooey; + } + else { + if (strend - startpos < minlen) goto phooey; + } if (startpos == strbeg) /* is ^ valid at stringarg? */ PL_regprev = '\n'; else { - PL_regprev = (U32)stringarg[-1]; + if (prog->reganch & ROPT_UTF8 && do_utf8) { + U8 *s = reghop3((U8*)stringarg, -1, (U8*)strbeg); + PL_regprev = utf8_to_uv(s, (U8*)stringarg - s, NULL, 0); + } + else + PL_regprev = (U32)stringarg[-1]; if (!PL_multiline && PL_regprev == '\n') PL_regprev = '\0'; /* force ^ to NOT match */ } @@ -1431,7 +1495,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * if (minlen) dontbother = minlen - 1; - end = HOPc(strend, -dontbother) - 1; + end = HOP3c(strend, -dontbother, strbeg) - 1; /* for multiline we only have to try after newlines */ if (prog->check_substr) { if (s == startpos) @@ -1477,7 +1541,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * int did_match = 0; #endif - if (UTF) { + if (do_utf8) { while (s < strend) { if (*s == ch) { DEBUG_r( did_match = 1 ); @@ -1506,18 +1570,19 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * "Did not find anchored character...\n")); } /*SUPPRESS 560*/ - else if (prog->anchored_substr != Nullsv - || (prog->float_substr != Nullsv - && prog->float_max_offset < strend - s)) { + else if (do_utf8 == (UTF!=0) && + (prog->anchored_substr != Nullsv + || (prog->float_substr != Nullsv + && prog->float_max_offset < strend - s))) { SV *must = prog->anchored_substr ? prog->anchored_substr : prog->float_substr; I32 back_max = prog->anchored_substr ? prog->anchored_offset : prog->float_max_offset; I32 back_min = prog->anchored_substr ? prog->anchored_offset : prog->float_min_offset; - char *last = HOPc(strend, /* Cannot start after this */ + char *last = HOP3c(strend, /* Cannot start after this */ -(I32)(CHR_SVLEN(must) - - (SvTAIL(must) != 0) + back_min)); + - (SvTAIL(must) != 0) + back_min), strbeg); char *last1; /* Last position checked before */ #ifdef DEBUGGING int did_match = 0; @@ -1535,9 +1600,9 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * strend = HOPc(strend, -dontbother); while ( (s <= last) && ((flags & REXEC_SCREAM) - ? (s = screaminstr(sv, must, HOPc(s, back_min) - strbeg, + ? (s = screaminstr(sv, must, HOP3c(s, back_min, strend) - strbeg, end_shift, &scream_pos, 0)) - : (s = fbm_instr((unsigned char*)HOP(s, back_min), + : (s = fbm_instr((unsigned char*)HOP3(s, back_min, strend), (unsigned char*)strend, must, PL_multiline ? FBMrf_MULTILINE : 0))) ) { DEBUG_r( did_match = 1 ); @@ -1551,7 +1616,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * last1 = HOPc(s, -back_min); s = t; } - if (UTF) { + if (do_utf8) { while (s <= last1) { if (regtry(prog, s)) goto got_it; @@ -1580,6 +1645,11 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * if (minlen && PL_regkind[(U8)OP(prog->regstclass)] != EXACT) /* don't bother with what can't match */ strend = HOPc(strend, -(minlen - 1)); + DEBUG_r({ + SV *prop = sv_newmortal(); + regprop(prop, c); + PerlIO_printf(Perl_debug_log, "Matching stclass `%s' against `%s'\n", SvPVX(prop), s); + }); if (find_byclass(prog, c, s, strend, startpos, 0)) goto got_it; DEBUG_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass...\n")); @@ -1593,7 +1663,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * last = screaminstr(sv, prog->float_substr, s - strbeg, end_shift, &scream_pos, 1); /* last one */ if (!last) - last = scream_olds; /* Only one occurence. */ + last = scream_olds; /* Only one occurrence. */ } else { STRLEN len; @@ -1627,7 +1697,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * dontbother = minlen - 1; strend -= dontbother; /* this one's always in bytes! */ /* We don't know much -- general case. */ - if (UTF) { + if (do_utf8) { for (;;) { if (regtry(prog, s)) goto got_it; @@ -1695,12 +1765,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; @@ -1772,24 +1844,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 * @@ -1807,7 +1922,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. */ @@ -1819,6 +1933,10 @@ 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; + register bool do_utf8 = DO_UTF8(PL_reg_sv); + #ifdef DEBUGGING PL_regindent++; #endif @@ -1828,7 +1946,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 @@ -1850,20 +1968,25 @@ S_regmatch(pTHX_ regnode *prog) SV *prop = sv_newmortal(); int docolor = *PL_colors[0]; int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */ - int l = (PL_regeol - locinput > taill ? taill : PL_regeol - locinput); + int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput); /* The part of the string before starttry has one color (pref0_len chars), between starttry and current position another one (pref_len - pref0_len chars), after the current position the third one. We assume that pref0_len <= pref_len, otherwise we decrease pref0_len. */ - int pref_len = (locinput - PL_bostr > (5 + taill) - l - ? (5 + taill) - l : locinput - PL_bostr); - int pref0_len = pref_len - (locinput - PL_reg_starttry); + int pref_len = (locinput - PL_bostr) > (5 + taill) - l + ? (5 + taill) - l : locinput - PL_bostr; + int pref0_len; + while (UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len))) + pref_len++; + pref0_len = pref_len - (locinput - PL_reg_starttry); if (l + pref_len < (5 + taill) && l < PL_regeol - locinput) l = ( PL_regeol - locinput > (5 + taill) - pref_len ? (5 + taill) - pref_len : PL_regeol - locinput); + while (UTF8_IS_CONTINUATION(*(U8*)(locinput + l))) + l--; if (pref0_len < 0) pref0_len = 0; if (pref0_len > pref_len) @@ -1936,8 +2059,8 @@ S_regmatch(pTHX_ regnode *prog) if (PL_regeol != locinput) sayNO; break; - case SANYUTF8: - if (nextchr & 0x80) { + case SANY: + if (do_utf8) { locinput += PL_utf8skip[nextchr]; if (locinput > PL_regeol) sayNO; @@ -1948,31 +2071,47 @@ S_regmatch(pTHX_ regnode *prog) sayNO; nextchr = UCHARAT(++locinput); break; - case SANY: - if (!nextchr && locinput >= PL_regeol) + case REG_ANY: + if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n') sayNO; - nextchr = UCHARAT(++locinput); - break; - case ANYUTF8: - if (nextchr & 0x80) { + if (do_utf8) { locinput += PL_utf8skip[nextchr]; if (locinput > PL_regeol) sayNO; nextchr = UCHARAT(locinput); - break; } - if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n') - sayNO; - nextchr = UCHARAT(++locinput); - break; - case REG_ANY: - if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n') - sayNO; - nextchr = UCHARAT(++locinput); + else + nextchr = UCHARAT(++locinput); break; case EXACT: s = STRING(scan); ln = STR_LEN(scan); + if (do_utf8 != (UTF!=0)) { + char *l = locinput; + char *e = s + ln; + STRLEN len; + if (do_utf8) + while (s < e) { + if (l >= PL_regeol) + sayNO; + if (*((U8*)s) != utf8_to_uv_simple((U8*)l, &len)) + sayNO; + s++; + l += len; + } + else + while (s < e) { + if (l >= PL_regeol) + sayNO; + if (*((U8*)l) != utf8_to_uv_simple((U8*)s, &len)) + sayNO; + s += len; + l++; + } + locinput = l; + nextchr = UCHARAT(locinput); + break; + } /* Inline the first character, for speed. */ if (UCHARAT(s) != nextchr) sayNO; @@ -1990,20 +2129,19 @@ S_regmatch(pTHX_ regnode *prog) s = STRING(scan); ln = STR_LEN(scan); - if (UTF) { + if (do_utf8) { char *l = locinput; - char *e = s + ln; + char *e; + e = s + ln; c1 = OP(scan) == EXACTF; while (s < e) { - if (l >= PL_regeol) - sayNO; - if (utf8_to_uv_chk((U8*)s, 0, 0) != (c1 ? - toLOWER_utf8((U8*)l) : - toLOWER_LC_utf8((U8*)l))) - { + if (l >= PL_regeol) { sayNO; } - s += UTF8SKIP(s); + if ((UTF ? utf8_to_uv((U8*)s, e - s, 0, 0) : *((U8*)s)) != + (c1 ? toLOWER_utf8((U8*)l) : toLOWER_LC_utf8((U8*)l))) + sayNO; + s += UTF ? UTF8SKIP(s) : 1; l += UTF8SKIP(l); } locinput = l; @@ -2025,22 +2163,24 @@ S_regmatch(pTHX_ regnode *prog) locinput += ln; nextchr = UCHARAT(locinput); break; - case ANYOFUTF8: - if (!REGINCLASSUTF8(scan, (U8*)locinput)) - sayNO; - if (locinput >= PL_regeol) - sayNO; - locinput += PL_utf8skip[nextchr]; - nextchr = UCHARAT(locinput); - break; case ANYOF: - if (nextchr < 0) + if (do_utf8) { + if (!reginclass(scan, (U8*)locinput, do_utf8)) + sayNO; + if (locinput >= PL_regeol) + sayNO; + locinput += PL_utf8skip[nextchr]; nextchr = UCHARAT(locinput); - if (!REGINCLASS(scan, nextchr)) - sayNO; - if (!nextchr && locinput >= PL_regeol) - sayNO; - nextchr = UCHARAT(++locinput); + } + else { + if (nextchr < 0) + nextchr = UCHARAT(locinput); + if (!reginclass(scan, (U8*)locinput, do_utf8)) + sayNO; + if (!nextchr && locinput >= PL_regeol) + sayNO; + nextchr = UCHARAT(++locinput); + } break; case ALNUML: PL_reg_flags |= RF_tainted; @@ -2048,19 +2188,8 @@ S_regmatch(pTHX_ regnode *prog) case ALNUM: if (!nextchr) sayNO; - if (!(OP(scan) == ALNUM - ? isALNUM(nextchr) : isALNUM_LC(nextchr))) - sayNO; - nextchr = UCHARAT(++locinput); - break; - case ALNUMLUTF8: - PL_reg_flags |= RF_tainted; - /* FALL THROUGH */ - case ALNUMUTF8: - if (!nextchr) - sayNO; - if (nextchr & 0x80) { - if (!(OP(scan) == ALNUMUTF8 + if (do_utf8) { + if (!(OP(scan) == ALNUM ? swash_fetch(PL_utf8_alnum, (U8*)locinput) : isALNUM_LC_utf8((U8*)locinput))) { @@ -2070,7 +2199,7 @@ S_regmatch(pTHX_ regnode *prog) nextchr = UCHARAT(locinput); break; } - if (!(OP(scan) == ALNUMUTF8 + if (!(OP(scan) == ALNUM ? isALNUM(nextchr) : isALNUM_LC(nextchr))) sayNO; nextchr = UCHARAT(++locinput); @@ -2081,19 +2210,8 @@ S_regmatch(pTHX_ regnode *prog) case NALNUM: if (!nextchr && locinput >= PL_regeol) sayNO; - if (OP(scan) == NALNUM - ? isALNUM(nextchr) : isALNUM_LC(nextchr)) - sayNO; - nextchr = UCHARAT(++locinput); - break; - case NALNUMLUTF8: - PL_reg_flags |= RF_tainted; - /* FALL THROUGH */ - case NALNUMUTF8: - if (!nextchr && locinput >= PL_regeol) - sayNO; - if (nextchr & 0x80) { - if (OP(scan) == NALNUMUTF8 + if (do_utf8) { + if (OP(scan) == NALNUM ? swash_fetch(PL_utf8_alnum, (U8*)locinput) : isALNUM_LC_utf8((U8*)locinput)) { @@ -2103,7 +2221,7 @@ S_regmatch(pTHX_ regnode *prog) nextchr = UCHARAT(locinput); break; } - if (OP(scan) == NALNUMUTF8 + if (OP(scan) == NALNUM ? isALNUM(nextchr) : isALNUM_LC(nextchr)) sayNO; nextchr = UCHARAT(++locinput); @@ -2115,37 +2233,38 @@ S_regmatch(pTHX_ regnode *prog) case BOUND: case NBOUND: /* was last char in word? */ - ln = (locinput != PL_regbol) ? UCHARAT(locinput - 1) : PL_regprev; - if (OP(scan) == BOUND || OP(scan) == NBOUND) { - ln = isALNUM(ln); - n = isALNUM(nextchr); - } - else { - ln = isALNUM_LC(ln); - n = isALNUM_LC(nextchr); - } - if (((!ln) == (!n)) == (OP(scan) == BOUND || OP(scan) == BOUNDL)) - sayNO; - break; - case BOUNDLUTF8: - case NBOUNDLUTF8: - PL_reg_flags |= RF_tainted; - /* FALL THROUGH */ - case BOUNDUTF8: - case NBOUNDUTF8: - /* was last char in word? */ - ln = (locinput != PL_regbol) - ? utf8_to_uv_chk(reghop((U8*)locinput, -1), 0, 0) : PL_regprev; - if (OP(scan) == BOUNDUTF8 || OP(scan) == NBOUNDUTF8) { - ln = isALNUM_uni(ln); - n = swash_fetch(PL_utf8_alnum, (U8*)locinput); + if (do_utf8) { + 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) == BOUND || OP(scan) == NBOUND) { + ln = isALNUM_uni(ln); + n = swash_fetch(PL_utf8_alnum, (U8*)locinput); + } + else { + ln = isALNUM_LC_uni(ln); + n = isALNUM_LC_utf8((U8*)locinput); + } } else { - ln = isALNUM_LC_uni(ln); - n = isALNUM_LC_utf8((U8*)locinput); + ln = (locinput != PL_regbol) ? + UCHARAT(locinput - 1) : PL_regprev; + if (OP(scan) == BOUND || OP(scan) == NBOUND) { + ln = isALNUM(ln); + n = isALNUM(nextchr); + } + else { + ln = isALNUM_LC(ln); + n = isALNUM_LC(nextchr); + } } - if (((!ln) == (!n)) == (OP(scan) == BOUNDUTF8 || OP(scan) == BOUNDLUTF8)) - sayNO; + if (((!ln) == (!n)) == (OP(scan) == BOUND || + OP(scan) == BOUNDL)) + sayNO; break; case SPACEL: PL_reg_flags |= RF_tainted; @@ -2153,32 +2272,29 @@ S_regmatch(pTHX_ regnode *prog) case SPACE: if (!nextchr) sayNO; - if (!(OP(scan) == SPACE - ? isSPACE(nextchr) : isSPACE_LC(nextchr))) - sayNO; - nextchr = UCHARAT(++locinput); - break; - case SPACELUTF8: - PL_reg_flags |= RF_tainted; - /* FALL THROUGH */ - case SPACEUTF8: - if (!nextchr) - sayNO; - if (nextchr & 0x80) { - if (!(OP(scan) == SPACEUTF8 - ? swash_fetch(PL_utf8_space, (U8*)locinput) - : isSPACE_LC_utf8((U8*)locinput))) - { - sayNO; + if (do_utf8) { + if (UTF8_IS_CONTINUED(nextchr)) { + if (!(OP(scan) == SPACE + ? swash_fetch(PL_utf8_space, (U8*)locinput) + : isSPACE_LC_utf8((U8*)locinput))) + { + sayNO; + } + locinput += PL_utf8skip[nextchr]; + nextchr = UCHARAT(locinput); + break; } - locinput += PL_utf8skip[nextchr]; - nextchr = UCHARAT(locinput); - break; + if (!(OP(scan) == SPACE + ? isSPACE(nextchr) : isSPACE_LC(nextchr))) + sayNO; + nextchr = UCHARAT(++locinput); + } + else { + if (!(OP(scan) == SPACE + ? isSPACE(nextchr) : isSPACE_LC(nextchr))) + sayNO; + nextchr = UCHARAT(++locinput); } - if (!(OP(scan) == SPACEUTF8 - ? isSPACE(nextchr) : isSPACE_LC(nextchr))) - sayNO; - nextchr = UCHARAT(++locinput); break; case NSPACEL: PL_reg_flags |= RF_tainted; @@ -2186,19 +2302,8 @@ S_regmatch(pTHX_ regnode *prog) case NSPACE: if (!nextchr && locinput >= PL_regeol) sayNO; - if (OP(scan) == NSPACE - ? isSPACE(nextchr) : isSPACE_LC(nextchr)) - sayNO; - nextchr = UCHARAT(++locinput); - break; - case NSPACELUTF8: - PL_reg_flags |= RF_tainted; - /* FALL THROUGH */ - case NSPACEUTF8: - if (!nextchr && locinput >= PL_regeol) - sayNO; - if (nextchr & 0x80) { - if (OP(scan) == NSPACEUTF8 + if (do_utf8) { + if (OP(scan) == NSPACE ? swash_fetch(PL_utf8_space, (U8*)locinput) : isSPACE_LC_utf8((U8*)locinput)) { @@ -2208,7 +2313,7 @@ S_regmatch(pTHX_ regnode *prog) nextchr = UCHARAT(locinput); break; } - if (OP(scan) == NSPACEUTF8 + if (OP(scan) == NSPACE ? isSPACE(nextchr) : isSPACE_LC(nextchr)) sayNO; nextchr = UCHARAT(++locinput); @@ -2219,19 +2324,8 @@ S_regmatch(pTHX_ regnode *prog) case DIGIT: if (!nextchr) sayNO; - if (!(OP(scan) == DIGIT - ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))) - sayNO; - nextchr = UCHARAT(++locinput); - break; - case DIGITLUTF8: - PL_reg_flags |= RF_tainted; - /* FALL THROUGH */ - case DIGITUTF8: - if (!nextchr) - sayNO; - if (nextchr & 0x80) { - if (!(OP(scan) == DIGITUTF8 + if (do_utf8) { + if (!(OP(scan) == DIGIT ? swash_fetch(PL_utf8_digit, (U8*)locinput) : isDIGIT_LC_utf8((U8*)locinput))) { @@ -2241,7 +2335,7 @@ S_regmatch(pTHX_ regnode *prog) nextchr = UCHARAT(locinput); break; } - if (!(OP(scan) == DIGITUTF8 + if (!(OP(scan) == DIGIT ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))) sayNO; nextchr = UCHARAT(++locinput); @@ -2252,19 +2346,8 @@ S_regmatch(pTHX_ regnode *prog) case NDIGIT: if (!nextchr && locinput >= PL_regeol) sayNO; - if (OP(scan) == NDIGIT - ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)) - sayNO; - nextchr = UCHARAT(++locinput); - break; - case NDIGITLUTF8: - PL_reg_flags |= RF_tainted; - /* FALL THROUGH */ - case NDIGITUTF8: - if (!nextchr && locinput >= PL_regeol) - sayNO; - if (nextchr & 0x80) { - if (OP(scan) == NDIGITUTF8 + if (do_utf8) { + if (OP(scan) == NDIGIT ? swash_fetch(PL_utf8_digit, (U8*)locinput) : isDIGIT_LC_utf8((U8*)locinput)) { @@ -2274,7 +2357,7 @@ S_regmatch(pTHX_ regnode *prog) nextchr = UCHARAT(locinput); break; } - if (OP(scan) == NDIGITUTF8 + if (OP(scan) == NDIGIT ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)) sayNO; nextchr = UCHARAT(++locinput); @@ -2303,7 +2386,7 @@ S_regmatch(pTHX_ regnode *prog) break; s = PL_bostr + ln; - if (UTF && OP(scan) != REF) { /* REF can do byte comparison */ + if (do_utf8 && OP(scan) != REF) { /* REF can do byte comparison */ char *l = locinput; char *e = PL_bostr + PL_regendp[n]; /* @@ -2408,7 +2491,6 @@ S_regmatch(pTHX_ regnode *prog) I32 onpar = PL_regnpar; pm.op_pmflags = 0; - pm.op_pmdynflags = (UTF||DO_UTF8(ret) ? PMdf_UTF8 : 0); re = CALLREGCOMP(aTHX_ t, t + len, &pm); if (!(SvFLAGS(ret) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY))) @@ -2433,7 +2515,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; @@ -2463,7 +2545,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; @@ -2590,12 +2672,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); @@ -2718,12 +2806,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; @@ -2750,12 +2838,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; @@ -2768,12 +2856,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( @@ -2819,30 +2907,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; @@ -2892,7 +2980,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. */ @@ -2911,7 +2999,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; @@ -2951,7 +3039,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 || @@ -2973,7 +3061,7 @@ S_regmatch(pTHX_ regnode *prog) } if (regmatch(next)) sayYES; - REGCP_UNWIND; + REGCP_UNWIND(lastcp); } /* Couldn't or didn't -- back up. */ n--; @@ -3017,13 +3105,23 @@ S_regmatch(pTHX_ regnode *prog) * when we know what character comes next. */ if (PL_regkind[(U8)OP(next)] == EXACT) { - c1 = (U8)*STRING(next); - if (OP(next) == EXACTF) - c2 = PL_fold[c1]; - else if (OP(next) == EXACTFL) - c2 = PL_fold_locale[c1]; - else - c2 = c1; + U8 *s = (U8*)STRING(next); + if (!UTF) { + c2 = c1 = *s; + if (OP(next) == EXACTF) + c2 = PL_fold[c1]; + else if (OP(next) == EXACTFL) + c2 = PL_fold_locale[c1]; + } + else { /* UTF */ + if (OP(next) == EXACTF) { + c1 = to_utf8_lower(s); + c2 = to_utf8_upper(s); + } + else { + c2 = c1 = utf8_to_uv_simple(s, NULL); + } + } } else c1 = c2 = -1000; @@ -3034,50 +3132,95 @@ 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 *e; /* Should not check after this */ char *old = locinput; - if (e >= PL_regeol || (n == REG_INFTY)) + if (n == REG_INFTY) { e = PL_regeol - 1; + if (do_utf8) + while (UTF8_IS_CONTINUATION(*(U8*)e)) + e--; + } + else if (do_utf8) { + int m = n - ln; + for (e = locinput; + m >0 && e + UTF8SKIP(e) <= PL_regeol; m--) + e += UTF8SKIP(e); + } + else { + e = locinput + n - ln; + if (e >= PL_regeol) + e = PL_regeol - 1; + } while (1) { + int count; /* Find place 'next' could work */ - if (c1 == c2) { - while (locinput <= e && *locinput != c1) - locinput++; - } else { - while (locinput <= e - && *locinput != c1 - && *locinput != c2) - locinput++; + if (!do_utf8) { + if (c1 == c2) { + while (locinput <= e && *locinput != c1) + locinput++; + } else { + while (locinput <= e + && *locinput != c1 + && *locinput != c2) + locinput++; + } + count = locinput - old; + } + else { + STRLEN len; + if (c1 == c2) { + for (count = 0; + locinput <= e && + utf8_to_uv_simple((U8*)locinput, &len) != c1; + count++) + locinput += len; + + } else { + for (count = 0; locinput <= e; count++) { + UV c = utf8_to_uv_simple((U8*)locinput, &len); + if (c == c1 || c == c2) + break; + locinput += len; + } + } } if (locinput > e) sayNO; /* PL_reginput == old now */ if (locinput != old) { ln = 1; /* Did some */ - if (regrepeat(scan, locinput - old) < - locinput - old) + if (regrepeat(scan, count) < count) sayNO; } /* PL_reginput == locinput now */ TRYPAREN(paren, ln, locinput); PL_reginput = locinput; /* Could be reset... */ - REGCP_UNWIND; + REGCP_UNWIND(lastcp); /* Couldn't or didn't -- move forward. */ - old = locinput++; + old = locinput; + if (do_utf8) + locinput += UTF8SKIP(locinput); + else + locinput++; } } else while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */ + UV c; + if (c1 != -1000) { + if (do_utf8) + c = utf8_to_uv_simple((U8*)PL_reginput, NULL); + else + c = UCHARAT(PL_reginput); + } /* If it could work, try it. */ - if (c1 == -1000 || - UCHARAT(PL_reginput) == c1 || - UCHARAT(PL_reginput) == c2) + if (c1 == -1000 || c == c1 || c == c2) { TRYPAREN(paren, n, PL_reginput); - REGCP_UNWIND; + REGCP_UNWIND(lastcp); } /* Couldn't or didn't -- move forward. */ PL_reginput = locinput; @@ -3102,16 +3245,21 @@ S_regmatch(pTHX_ regnode *prog) if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS) ln--; } - REGCP_SET; + REGCP_SET(lastcp); if (paren) { + UV c; while (n >= ln) { + if (c1 != -1000) { + if (do_utf8) + c = utf8_to_uv_simple((U8*)PL_reginput, NULL); + else + c = UCHARAT(PL_reginput); + } /* If it could work, try it. */ - if (c1 == -1000 || - UCHARAT(PL_reginput) == c1 || - UCHARAT(PL_reginput) == c2) + if (c1 == -1000 || c == c1 || c == c2) { TRYPAREN(paren, n, PL_reginput); - REGCP_UNWIND; + REGCP_UNWIND(lastcp); } /* Couldn't or didn't -- back up. */ n--; @@ -3119,14 +3267,19 @@ S_regmatch(pTHX_ regnode *prog) } } else { + UV c; while (n >= ln) { + if (c1 != -1000) { + if (do_utf8) + c = utf8_to_uv_simple((U8*)PL_reginput, NULL); + else + c = UCHARAT(PL_reginput); + } /* If it could work, try it. */ - if (c1 == -1000 || - UCHARAT(PL_reginput) == c1 || - UCHARAT(PL_reginput) == c2) + if (c1 == -1000 || c == c1 || c == c2) { TRYPAREN(paren, n, PL_reginput); - REGCP_UNWIND; + REGCP_UNWIND(lastcp); } /* Couldn't or didn't -- back up. */ n--; @@ -3144,7 +3297,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 @@ -3157,7 +3310,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; @@ -3264,6 +3417,7 @@ S_regmatch(pTHX_ regnode *prog) PTR2UV(scan), OP(scan)); Perl_croak(aTHX_ "regexp memory corruption"); } + reenter: scan = next; } @@ -3289,6 +3443,11 @@ yes: #ifdef DEBUGGING PL_regindent--; #endif + +#if 0 /* Breaks $^R */ + if (unwind) + regcpblow(firstcp); +#endif return 1; no: @@ -3300,6 +3459,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 @@ -3317,35 +3525,37 @@ do_no: STATIC I32 S_regrepeat(pTHX_ regnode *p, I32 max) { - dTHR; register char *scan; register I32 c; register char *loceol = PL_regeol; register I32 hardcount = 0; + register bool do_utf8 = DO_UTF8(PL_reg_sv); scan = PL_reginput; if (max != REG_INFTY && max < loceol - scan) loceol = scan + max; switch (OP(p)) { case REG_ANY: - while (scan < loceol && *scan != '\n') - scan++; - break; - case SANY: - scan = loceol; - break; - case ANYUTF8: - loceol = PL_regeol; - while (scan < loceol && *scan != '\n') { - scan += UTF8SKIP(scan); - hardcount++; + if (do_utf8) { + loceol = PL_regeol; + while (scan < loceol && hardcount < max && *scan != '\n') { + scan += UTF8SKIP(scan); + hardcount++; + } + } else { + while (scan < loceol && *scan != '\n') + scan++; } break; - case SANYUTF8: - loceol = PL_regeol; - while (scan < loceol) { - scan += UTF8SKIP(scan); - hardcount++; + case SANY: + if (do_utf8) { + loceol = PL_regeol; + while (hardcount < max && scan < loceol) { + scan += UTF8SKIP(scan); + hardcount++; + } + } else { + scan = loceol; } break; case EXACT: /* length of string is 1 */ @@ -3366,135 +3576,151 @@ S_regrepeat(pTHX_ regnode *p, I32 max) (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c])) scan++; break; - case ANYOFUTF8: - loceol = PL_regeol; - while (scan < loceol && REGINCLASSUTF8(p, (U8*)scan)) { - scan += UTF8SKIP(scan); - hardcount++; - } - break; case ANYOF: - while (scan < loceol && REGINCLASS(p, *scan)) - scan++; + if (do_utf8) { + loceol = PL_regeol; + while (hardcount < max && scan < loceol && + reginclass(p, (U8*)scan, do_utf8)) { + scan += UTF8SKIP(scan); + hardcount++; + } + } else { + while (scan < loceol && reginclass(p, (U8*)scan, do_utf8)) + scan++; + } break; case ALNUM: - while (scan < loceol && isALNUM(*scan)) - scan++; - break; - case ALNUMUTF8: - loceol = PL_regeol; - while (scan < loceol && swash_fetch(PL_utf8_alnum, (U8*)scan)) { - scan += UTF8SKIP(scan); - hardcount++; + if (do_utf8) { + loceol = PL_regeol; + while (hardcount < max && scan < loceol && + swash_fetch(PL_utf8_alnum, (U8*)scan)) { + scan += UTF8SKIP(scan); + hardcount++; + } + } else { + while (scan < loceol && isALNUM(*scan)) + scan++; } break; case ALNUML: PL_reg_flags |= RF_tainted; - while (scan < loceol && isALNUM_LC(*scan)) - scan++; - break; - case ALNUMLUTF8: - PL_reg_flags |= RF_tainted; - loceol = PL_regeol; - while (scan < loceol && isALNUM_LC_utf8((U8*)scan)) { - scan += UTF8SKIP(scan); - hardcount++; + if (do_utf8) { + loceol = PL_regeol; + while (hardcount < max && scan < loceol && + isALNUM_LC_utf8((U8*)scan)) { + scan += UTF8SKIP(scan); + hardcount++; + } + } else { + while (scan < loceol && isALNUM_LC(*scan)) + scan++; } break; - break; case NALNUM: - while (scan < loceol && !isALNUM(*scan)) - scan++; - break; - case NALNUMUTF8: - loceol = PL_regeol; - while (scan < loceol && !swash_fetch(PL_utf8_alnum, (U8*)scan)) { - scan += UTF8SKIP(scan); - hardcount++; + if (do_utf8) { + loceol = PL_regeol; + while (hardcount < max && scan < loceol && + !swash_fetch(PL_utf8_alnum, (U8*)scan)) { + scan += UTF8SKIP(scan); + hardcount++; + } + } else { + while (scan < loceol && !isALNUM(*scan)) + scan++; } break; case NALNUML: PL_reg_flags |= RF_tainted; - while (scan < loceol && !isALNUM_LC(*scan)) - scan++; - break; - case NALNUMLUTF8: - PL_reg_flags |= RF_tainted; - loceol = PL_regeol; - while (scan < loceol && !isALNUM_LC_utf8((U8*)scan)) { - scan += UTF8SKIP(scan); - hardcount++; + if (do_utf8) { + loceol = PL_regeol; + while (hardcount < max && scan < loceol && + !isALNUM_LC_utf8((U8*)scan)) { + scan += UTF8SKIP(scan); + hardcount++; + } + } else { + while (scan < loceol && !isALNUM_LC(*scan)) + scan++; } break; case SPACE: - while (scan < loceol && isSPACE(*scan)) - scan++; - break; - case SPACEUTF8: - loceol = PL_regeol; - while (scan < loceol && (*scan == ' ' || swash_fetch(PL_utf8_space,(U8*)scan))) { - scan += UTF8SKIP(scan); - hardcount++; + if (do_utf8) { + loceol = PL_regeol; + while (hardcount < max && scan < loceol && + (*scan == ' ' || swash_fetch(PL_utf8_space,(U8*)scan))) { + scan += UTF8SKIP(scan); + hardcount++; + } + } else { + while (scan < loceol && isSPACE(*scan)) + scan++; } break; case SPACEL: PL_reg_flags |= RF_tainted; - while (scan < loceol && isSPACE_LC(*scan)) - scan++; - break; - case SPACELUTF8: - PL_reg_flags |= RF_tainted; - loceol = PL_regeol; - while (scan < loceol && (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) { - scan += UTF8SKIP(scan); - hardcount++; + if (do_utf8) { + loceol = PL_regeol; + while (hardcount < max && scan < loceol && + (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) { + scan += UTF8SKIP(scan); + hardcount++; + } + } else { + while (scan < loceol && isSPACE_LC(*scan)) + scan++; } break; case NSPACE: - while (scan < loceol && !isSPACE(*scan)) - scan++; - break; - case NSPACEUTF8: - loceol = PL_regeol; - while (scan < loceol && !(*scan == ' ' || swash_fetch(PL_utf8_space,(U8*)scan))) { - scan += UTF8SKIP(scan); - hardcount++; + if (do_utf8) { + loceol = PL_regeol; + while (hardcount < max && scan < loceol && + !(*scan == ' ' || swash_fetch(PL_utf8_space,(U8*)scan))) { + scan += UTF8SKIP(scan); + hardcount++; + } + } else { + while (scan < loceol && !isSPACE(*scan)) + scan++; + break; } - break; case NSPACEL: PL_reg_flags |= RF_tainted; - while (scan < loceol && !isSPACE_LC(*scan)) - scan++; - break; - case NSPACELUTF8: - PL_reg_flags |= RF_tainted; - loceol = PL_regeol; - while (scan < loceol && !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) { - scan += UTF8SKIP(scan); - hardcount++; + if (do_utf8) { + loceol = PL_regeol; + while (hardcount < max && scan < loceol && + !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) { + scan += UTF8SKIP(scan); + hardcount++; + } + } else { + while (scan < loceol && !isSPACE_LC(*scan)) + scan++; } break; case DIGIT: - while (scan < loceol && isDIGIT(*scan)) - scan++; - break; - case DIGITUTF8: - loceol = PL_regeol; - while (scan < loceol && swash_fetch(PL_utf8_digit,(U8*)scan)) { - scan += UTF8SKIP(scan); - hardcount++; + if (do_utf8) { + loceol = PL_regeol; + while (hardcount < max && scan < loceol && + swash_fetch(PL_utf8_digit,(U8*)scan)) { + scan += UTF8SKIP(scan); + hardcount++; + } + } else { + while (scan < loceol && isDIGIT(*scan)) + scan++; } break; - break; case NDIGIT: - while (scan < loceol && !isDIGIT(*scan)) - scan++; - break; - case NDIGITUTF8: - loceol = PL_regeol; - while (scan < loceol && !swash_fetch(PL_utf8_digit,(U8*)scan)) { - scan += UTF8SKIP(scan); - hardcount++; + if (do_utf8) { + loceol = PL_regeol; + while (hardcount < max && scan < loceol && + !swash_fetch(PL_utf8_digit,(U8*)scan)) { + scan += UTF8SKIP(scan); + hardcount++; + } + } else { + while (scan < loceol && !isDIGIT(*scan)) + scan++; } break; default: /* Called on something of 0 width. */ @@ -3529,7 +3755,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; @@ -3540,7 +3765,7 @@ S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp) return 0; start = PL_reginput; - if (UTF) { + if (DO_UTF8(PL_reg_sv)) { while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) { if (!count++) { l = 0; @@ -3574,96 +3799,141 @@ S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp) } /* - - reginclass - determine if a character falls into a character class - */ +- regclass_swash - prepare the utf8 swash +*/ -STATIC bool -S_reginclass(pTHX_ register regnode *p, register I32 c) +SV * +Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** initsvp) { - dTHR; - char flags = ANYOF_FLAGS(p); - bool match = FALSE; + SV *sw = NULL; + SV *si = NULL; - c &= 0xFF; - if (ANYOF_BITMAP_TEST(p, c)) - match = TRUE; - else if (flags & ANYOF_FOLD) { - I32 cf; - if (flags & ANYOF_LOCALE) { - PL_reg_flags |= RF_tainted; - cf = PL_fold_locale[c]; - } - else - cf = PL_fold[c]; - if (ANYOF_BITMAP_TEST(p, cf)) - match = TRUE; - } + if (PL_regdata && PL_regdata->count) { + U32 n = ARG(node); - if (!match && (flags & ANYOF_CLASS)) { - PL_reg_flags |= RF_tainted; - if ( - (ANYOF_CLASS_TEST(p, ANYOF_ALNUM) && isALNUM_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_NALNUM) && !isALNUM_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_SPACE) && isSPACE_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_NSPACE) && !isSPACE_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_DIGIT) && isDIGIT_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_NDIGIT) && !isDIGIT_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_ALNUMC) && isALNUMC_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_NALNUMC) && !isALNUMC_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_ALPHA) && isALPHA_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_NALPHA) && !isALPHA_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_ASCII) && isASCII(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_NASCII) && !isASCII(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_CNTRL) && isCNTRL_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_NCNTRL) && !isCNTRL_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_GRAPH) && isGRAPH_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_NGRAPH) && !isGRAPH_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_LOWER) && isLOWER_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_NLOWER) && !isLOWER_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_PRINT) && isPRINT_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_NPRINT) && !isPRINT_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_PUNCT) && isPUNCT_LC(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_NPUNCT) && !isPUNCT_LC(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_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; + if (PL_regdata->what[n] == 's') { + SV *rv = (SV*)PL_regdata->data[n]; + AV *av = (AV*)SvRV((SV*)rv); + SV **a; + + si = *av_fetch(av, 0, FALSE); + a = av_fetch(av, 1, FALSE); + + if (a) + sw = *a; + else if (si && doinit) { + sw = swash_init("utf8", "", si, 1, 0); + (void)av_store(av, 1, sw); + } } } + + if (initsvp) + *initsvp = si; - return (flags & ANYOF_INVERT) ? !match : match; + return sw; } +/* + - reginclass - determine if a character falls into a character class + */ + STATIC bool -S_reginclassutf8(pTHX_ regnode *f, U8 *p) -{ - dTHR; - char flags = ARG1(f); +S_reginclass(pTHX_ register regnode *n, register U8* p, register bool do_utf8) +{ + char flags = ANYOF_FLAGS(n); bool match = FALSE; - SV *sv = (SV*)PL_regdata->data[ARG2(f)]; + UV c; + STRLEN len; - if (swash_fetch(sv, p)) - match = TRUE; - else if (flags & ANYOF_FOLD) { - U8 tmpbuf[UTF8_MAXLEN]; - if (flags & ANYOF_LOCALE) { - PL_reg_flags |= RF_tainted; - uv_to_utf8(tmpbuf, toLOWER_LC_utf8(p)); + if (do_utf8) + c = utf8_to_uv_simple(p, &len); + else + c = *p; + + if (do_utf8 || (flags & ANYOF_UNICODE)) { + if (do_utf8 && !ANYOF_RUNTIME(n)) { + if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c)) + match = TRUE; } - else - uv_to_utf8(tmpbuf, toLOWER_utf8(p)); - if (swash_fetch(sv, tmpbuf)) + if (do_utf8 && flags & ANYOF_UNICODE_ALL && c >= 256) match = TRUE; + if (!match) { + SV *sw = regclass_swash(n, TRUE, 0); + + if (sw) { + if (swash_fetch(sw, p)) + match = TRUE; + else if (flags & ANYOF_FOLD) { + 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(sw, tmpbuf)) + match = TRUE; + } + } + } } + if (!match && c < 256) { + if (ANYOF_BITMAP_TEST(n, c)) + match = TRUE; + else if (flags & ANYOF_FOLD) { + I32 f; - /* UTF8 combined with ANYOF_CLASS is ill-defined. */ + if (flags & ANYOF_LOCALE) { + PL_reg_flags |= RF_tainted; + f = PL_fold_locale[c]; + } + else + f = PL_fold[c]; + if (f != c && ANYOF_BITMAP_TEST(n, f)) + match = TRUE; + } + + if (!match && (flags & ANYOF_CLASS)) { + PL_reg_flags |= RF_tainted; + if ( + (ANYOF_CLASS_TEST(n, ANYOF_ALNUM) && isALNUM_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_NALNUM) && !isALNUM_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_SPACE) && isSPACE_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_NSPACE) && !isSPACE_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_DIGIT) && isDIGIT_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT) && !isDIGIT_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC) && isALNUMC_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_ALPHA) && isALPHA_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_NALPHA) && !isALPHA_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_ASCII) && isASCII(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_NASCII) && !isASCII(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_CNTRL) && isCNTRL_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL) && !isCNTRL_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_GRAPH) && isGRAPH_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH) && !isGRAPH_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_LOWER) && isLOWER_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_NLOWER) && !isLOWER_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_PRINT) && isPRINT_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_NPRINT) && !isPRINT_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_PUNCT) && isPUNCT_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT) && !isPUNCT_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_UPPER) && isUPPER_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_NUPPER) && !isUPPER_LC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT) && isXDIGIT(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC) && isPSXSPC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_BLANK) && isBLANK(c)) || + (ANYOF_CLASS_TEST(n, ANYOF_NBLANK) && !isBLANK(c)) + ) /* How's that for a conditional? */ + { + match = TRUE; + } + } + } return (flags & ANYOF_INVERT) ? !match : match; } @@ -3671,19 +3941,27 @@ S_reginclassutf8(pTHX_ regnode *f, U8 *p) STATIC U8 * S_reghop(pTHX_ U8 *s, I32 off) { - dTHR; + return S_reghop3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)); +} + +STATIC U8 * +S_reghop3(pTHX_ U8 *s, I32 off, U8* lim) +{ if (off >= 0) { - while (off-- && s < (U8*)PL_regeol) + while (off-- && s < lim) { + /* XXX could check well-formedness here */ s += UTF8SKIP(s); + } } else { while (off++) { - if (s > (U8*)PL_bostr) { + if (s > lim) { s--; - if (*s & 0x80) { - while (s > (U8*)PL_bostr && (*s & 0xc0) == 0x80) + if (UTF8_IS_CONTINUED(*s)) { + while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s)) s--; - } /* XXX could check well-formedness here */ + } + /* XXX could check well-formedness here */ } } } @@ -3691,23 +3969,31 @@ S_reghop(pTHX_ U8 *s, I32 off) } STATIC U8 * -S_reghopmaybe(pTHX_ U8* s, I32 off) +S_reghopmaybe(pTHX_ U8 *s, I32 off) +{ + return S_reghopmaybe3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)); +} + +STATIC U8 * +S_reghopmaybe3(pTHX_ U8* s, I32 off, U8* lim) { - dTHR; if (off >= 0) { - while (off-- && s < (U8*)PL_regeol) + while (off-- && s < lim) { + /* XXX could check well-formedness here */ s += UTF8SKIP(s); + } if (off >= 0) return 0; } else { while (off++) { - if (s > (U8*)PL_bostr) { + if (s > lim) { s--; - if (*s & 0x80) { - while (s > (U8*)PL_bostr && (*s & 0xc0) == 0x80) + if (UTF8_IS_CONTINUED(*s)) { + while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s)) s--; - } /* XXX could check well-formedness here */ + } + /* XXX could check well-formedness here */ } else break; @@ -3725,7 +4011,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; @@ -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/regnodes.h b/regnodes.h index 89c78e6bac..00dc0ecaec 100644 --- a/regnodes.h +++ b/regnodes.h @@ -13,76 +13,57 @@ #define MEOL 7 /* 0x7 Same, assuming multiline. */ #define SEOL 8 /* 0x8 Same, assuming singleline. */ #define BOUND 9 /* 0x9 Match "" at any word boundary */ -#define BOUNDUTF8 10 /* 0xa Match "" at any word boundary */ -#define BOUNDL 11 /* 0xb Match "" at any word boundary */ -#define BOUNDLUTF8 12 /* 0xc Match "" at any word boundary */ -#define NBOUND 13 /* 0xd Match "" at any word non-boundary */ -#define NBOUNDUTF8 14 /* 0xe Match "" at any word non-boundary */ -#define NBOUNDL 15 /* 0xf Match "" at any word non-boundary */ -#define NBOUNDLUTF8 16 /* 0x10 Match "" at any word non-boundary */ -#define GPOS 17 /* 0x11 Matches where last m//g left off. */ -#define REG_ANY 18 /* 0x12 Match any one character (except newline). */ -#define ANYUTF8 19 /* 0x13 Match any one Unicode character (except newline). */ -#define SANY 20 /* 0x14 Match any one character. */ -#define SANYUTF8 21 /* 0x15 Match any one Unicode character. */ -#define ANYOF 22 /* 0x16 Match character in (or not in) this class. */ -#define ANYOFUTF8 23 /* 0x17 Match character in (or not in) this class. */ -#define ALNUM 24 /* 0x18 Match any alphanumeric character */ -#define ALNUMUTF8 25 /* 0x19 Match any alphanumeric character in utf8 */ -#define ALNUML 26 /* 0x1a Match any alphanumeric char in locale */ -#define ALNUMLUTF8 27 /* 0x1b Match any alphanumeric char in locale+utf8 */ -#define NALNUM 28 /* 0x1c Match any non-alphanumeric character */ -#define NALNUMUTF8 29 /* 0x1d Match any non-alphanumeric character in utf8 */ -#define NALNUML 30 /* 0x1e Match any non-alphanumeric char in locale */ -#define NALNUMLUTF8 31 /* 0x1f Match any non-alphanumeric char in locale+utf8 */ -#define SPACE 32 /* 0x20 Match any whitespace character */ -#define SPACEUTF8 33 /* 0x21 Match any whitespace character in utf8 */ -#define SPACEL 34 /* 0x22 Match any whitespace char in locale */ -#define SPACELUTF8 35 /* 0x23 Match any whitespace char in locale+utf8 */ -#define NSPACE 36 /* 0x24 Match any non-whitespace character */ -#define NSPACEUTF8 37 /* 0x25 Match any non-whitespace character in utf8 */ -#define NSPACEL 38 /* 0x26 Match any non-whitespace char in locale */ -#define NSPACELUTF8 39 /* 0x27 Match any non-whitespace char in locale+utf8 */ -#define DIGIT 40 /* 0x28 Match any numeric character */ -#define DIGITUTF8 41 /* 0x29 Match any numeric character in utf8 */ -#define DIGITL 42 /* 0x2a Match any numeric character in locale */ -#define DIGITLUTF8 43 /* 0x2b Match any numeric character in locale+utf8 */ -#define NDIGIT 44 /* 0x2c Match any non-numeric character */ -#define NDIGITUTF8 45 /* 0x2d Match any non-numeric character in utf8 */ -#define NDIGITL 46 /* 0x2e Match any non-numeric character in locale */ -#define NDIGITLUTF8 47 /* 0x2f Match any non-numeric character in locale+utf8 */ -#define CLUMP 48 /* 0x30 Match any combining character sequence */ -#define BRANCH 49 /* 0x31 Match this alternative, or the next... */ -#define BACK 50 /* 0x32 Match "", "next" ptr points backward. */ -#define EXACT 51 /* 0x33 Match this string (preceded by length). */ -#define EXACTF 52 /* 0x34 Match this string, folded (prec. by length). */ -#define EXACTFL 53 /* 0x35 Match this string, folded in locale (w/len). */ -#define NOTHING 54 /* 0x36 Match empty string. */ -#define TAIL 55 /* 0x37 Match empty string. Can jump here from outside. */ -#define STAR 56 /* 0x38 Match this (simple) thing 0 or more times. */ -#define PLUS 57 /* 0x39 Match this (simple) thing 1 or more times. */ -#define CURLY 58 /* 0x3a Match this simple thing {n,m} times. */ -#define CURLYN 59 /* 0x3b Match next-after-this simple thing */ -#define CURLYM 60 /* 0x3c Match this medium-complex thing {n,m} times. */ -#define CURLYX 61 /* 0x3d Match this complex thing {n,m} times. */ -#define WHILEM 62 /* 0x3e Do curly processing and see if rest matches. */ -#define OPEN 63 /* 0x3f Mark this point in input as start of #n. */ -#define CLOSE 64 /* 0x40 Analogous to OPEN. */ -#define REF 65 /* 0x41 Match some already matched string */ -#define REFF 66 /* 0x42 Match already matched string, folded */ -#define REFFL 67 /* 0x43 Match already matched string, folded in loc. */ -#define IFMATCH 68 /* 0x44 Succeeds if the following matches. */ -#define UNLESSM 69 /* 0x45 Fails if the following matches. */ -#define SUSPEND 70 /* 0x46 "Independent" sub-RE. */ -#define IFTHEN 71 /* 0x47 Switch, should be preceeded by switcher . */ -#define GROUPP 72 /* 0x48 Whether the group matched. */ -#define LONGJMP 73 /* 0x49 Jump far away. */ -#define BRANCHJ 74 /* 0x4a BRANCH with long offset. */ -#define EVAL 75 /* 0x4b Execute some Perl code. */ -#define MINMOD 76 /* 0x4c Next operator is not greedy. */ -#define LOGICAL 77 /* 0x4d Next opcode should set the flag only. */ -#define RENUM 78 /* 0x4e Group with independently numbered parens. */ -#define OPTIMIZED 79 /* 0x4f Placeholder for dump. */ +#define BOUNDL 10 /* 0xa Match "" at any word boundary */ +#define NBOUND 11 /* 0xb Match "" at any word non-boundary */ +#define NBOUNDL 12 /* 0xc Match "" at any word non-boundary */ +#define GPOS 13 /* 0xd Matches where last m//g left off. */ +#define REG_ANY 14 /* 0xe Match any one character (except newline). */ +#define SANY 15 /* 0xf Match any one character. */ +#define ANYOF 16 /* 0x10 Match character in (or not in) this class. */ +#define ALNUM 17 /* 0x11 Match any alphanumeric character */ +#define ALNUML 18 /* 0x12 Match any alphanumeric char in locale */ +#define NALNUM 19 /* 0x13 Match any non-alphanumeric character */ +#define NALNUML 20 /* 0x14 Match any non-alphanumeric char in locale */ +#define SPACE 21 /* 0x15 Match any whitespace character */ +#define SPACEL 22 /* 0x16 Match any whitespace char in locale */ +#define NSPACE 23 /* 0x17 Match any non-whitespace character */ +#define NSPACEL 24 /* 0x18 Match any non-whitespace char in locale */ +#define DIGIT 25 /* 0x19 Match any numeric character */ +#define DIGITL 26 /* 0x1a Match any numeric character in locale */ +#define NDIGIT 27 /* 0x1b Match any non-numeric character */ +#define NDIGITL 28 /* 0x1c Match any non-numeric character in locale */ +#define CLUMP 29 /* 0x1d Match any combining character sequence */ +#define BRANCH 30 /* 0x1e Match this alternative, or the next... */ +#define BACK 31 /* 0x1f Match "", "next" ptr points backward. */ +#define EXACT 32 /* 0x20 Match this string (preceded by length). */ +#define EXACTF 33 /* 0x21 Match this string, folded (prec. by length). */ +#define EXACTFL 34 /* 0x22 Match this string, folded in locale (w/len). */ +#define NOTHING 35 /* 0x23 Match empty string. */ +#define TAIL 36 /* 0x24 Match empty string. Can jump here from outside. */ +#define STAR 37 /* 0x25 Match this (simple) thing 0 or more times. */ +#define PLUS 38 /* 0x26 Match this (simple) thing 1 or more times. */ +#define CURLY 39 /* 0x27 Match this simple thing {n,m} times. */ +#define CURLYN 40 /* 0x28 Match next-after-this simple thing */ +#define CURLYM 41 /* 0x29 Match this medium-complex thing {n,m} times. */ +#define CURLYX 42 /* 0x2a Match this complex thing {n,m} times. */ +#define WHILEM 43 /* 0x2b Do curly processing and see if rest matches. */ +#define OPEN 44 /* 0x2c Mark this point in input as start of #n. */ +#define CLOSE 45 /* 0x2d Analogous to OPEN. */ +#define REF 46 /* 0x2e Match some already matched string */ +#define REFF 47 /* 0x2f Match already matched string, folded */ +#define REFFL 48 /* 0x30 Match already matched string, folded in loc. */ +#define IFMATCH 49 /* 0x31 Succeeds if the following matches. */ +#define UNLESSM 50 /* 0x32 Fails if the following matches. */ +#define SUSPEND 51 /* 0x33 "Independent" sub-RE. */ +#define IFTHEN 52 /* 0x34 Switch, should be preceeded by switcher . */ +#define GROUPP 53 /* 0x35 Whether the group matched. */ +#define LONGJMP 54 /* 0x36 Jump far away. */ +#define BRANCHJ 55 /* 0x37 BRANCH with long offset. */ +#define EVAL 56 /* 0x38 Execute some Perl code. */ +#define MINMOD 57 /* 0x39 Next operator is not greedy. */ +#define LOGICAL 58 /* 0x3a Next opcode should set the flag only. */ +#define RENUM 59 /* 0x3b Group with independently numbered parens. */ +#define OPTIMIZED 60 /* 0x3c Placeholder for dump. */ #ifndef DOINIT EXTCONST U8 PL_regkind[]; @@ -98,44 +79,25 @@ EXTCONST U8 PL_regkind[] = { EOL, /* MEOL */ EOL, /* SEOL */ BOUND, /* BOUND */ - BOUND, /* BOUNDUTF8 */ BOUND, /* BOUNDL */ - BOUND, /* BOUNDLUTF8 */ NBOUND, /* NBOUND */ - NBOUND, /* NBOUNDUTF8 */ NBOUND, /* NBOUNDL */ - NBOUND, /* NBOUNDLUTF8 */ GPOS, /* GPOS */ REG_ANY, /* REG_ANY */ - REG_ANY, /* ANYUTF8 */ REG_ANY, /* SANY */ - REG_ANY, /* SANYUTF8 */ ANYOF, /* ANYOF */ - ANYOF, /* ANYOFUTF8 */ ALNUM, /* ALNUM */ - ALNUM, /* ALNUMUTF8 */ ALNUM, /* ALNUML */ - ALNUM, /* ALNUMLUTF8 */ NALNUM, /* NALNUM */ - NALNUM, /* NALNUMUTF8 */ NALNUM, /* NALNUML */ - NALNUM, /* NALNUMLUTF8 */ SPACE, /* SPACE */ - SPACE, /* SPACEUTF8 */ SPACE, /* SPACEL */ - SPACE, /* SPACELUTF8 */ NSPACE, /* NSPACE */ - NSPACE, /* NSPACEUTF8 */ NSPACE, /* NSPACEL */ - NSPACE, /* NSPACELUTF8 */ DIGIT, /* DIGIT */ - DIGIT, /* DIGITUTF8 */ DIGIT, /* DIGITL */ - DIGIT, /* DIGITLUTF8 */ NDIGIT, /* NDIGIT */ - NDIGIT, /* NDIGITUTF8 */ NDIGIT, /* NDIGITL */ - NDIGIT, /* NDIGITLUTF8 */ CLUMP, /* CLUMP */ BRANCH, /* BRANCH */ BACK, /* BACK */ @@ -184,44 +146,25 @@ static const U8 regarglen[] = { 0, /* MEOL */ 0, /* SEOL */ 0, /* BOUND */ - 0, /* BOUNDUTF8 */ 0, /* BOUNDL */ - 0, /* BOUNDLUTF8 */ 0, /* NBOUND */ - 0, /* NBOUNDUTF8 */ 0, /* NBOUNDL */ - 0, /* NBOUNDLUTF8 */ 0, /* GPOS */ 0, /* REG_ANY */ - 0, /* ANYUTF8 */ 0, /* SANY */ - 0, /* SANYUTF8 */ 0, /* ANYOF */ - EXTRA_SIZE(struct regnode_1), /* ANYOFUTF8 */ 0, /* ALNUM */ - 0, /* ALNUMUTF8 */ 0, /* ALNUML */ - 0, /* ALNUMLUTF8 */ 0, /* NALNUM */ - 0, /* NALNUMUTF8 */ 0, /* NALNUML */ - 0, /* NALNUMLUTF8 */ 0, /* SPACE */ - 0, /* SPACEUTF8 */ 0, /* SPACEL */ - 0, /* SPACELUTF8 */ 0, /* NSPACE */ - 0, /* NSPACEUTF8 */ 0, /* NSPACEL */ - 0, /* NSPACELUTF8 */ 0, /* DIGIT */ - 0, /* DIGITUTF8 */ 0, /* DIGITL */ - 0, /* DIGITLUTF8 */ 0, /* NDIGIT */ - 0, /* NDIGITUTF8 */ 0, /* NDIGITL */ - 0, /* NDIGITLUTF8 */ 0, /* CLUMP */ 0, /* BRANCH */ 0, /* BACK */ @@ -267,44 +210,25 @@ static const char reg_off_by_arg[] = { 0, /* MEOL */ 0, /* SEOL */ 0, /* BOUND */ - 0, /* BOUNDUTF8 */ 0, /* BOUNDL */ - 0, /* BOUNDLUTF8 */ 0, /* NBOUND */ - 0, /* NBOUNDUTF8 */ 0, /* NBOUNDL */ - 0, /* NBOUNDLUTF8 */ 0, /* GPOS */ 0, /* REG_ANY */ - 0, /* ANYUTF8 */ 0, /* SANY */ - 0, /* SANYUTF8 */ 0, /* ANYOF */ - 0, /* ANYOFUTF8 */ 0, /* ALNUM */ - 0, /* ALNUMUTF8 */ 0, /* ALNUML */ - 0, /* ALNUMLUTF8 */ 0, /* NALNUM */ - 0, /* NALNUMUTF8 */ 0, /* NALNUML */ - 0, /* NALNUMLUTF8 */ 0, /* SPACE */ - 0, /* SPACEUTF8 */ 0, /* SPACEL */ - 0, /* SPACELUTF8 */ 0, /* NSPACE */ - 0, /* NSPACEUTF8 */ 0, /* NSPACEL */ - 0, /* NSPACELUTF8 */ 0, /* DIGIT */ - 0, /* DIGITUTF8 */ 0, /* DIGITL */ - 0, /* DIGITLUTF8 */ 0, /* NDIGIT */ - 0, /* NDIGITUTF8 */ 0, /* NDIGITL */ - 0, /* NDIGITLUTF8 */ 0, /* CLUMP */ 0, /* BRANCH */ 0, /* BACK */ @@ -351,79 +275,60 @@ static const char * const reg_name[] = { "MEOL", /* 0x7 */ "SEOL", /* 0x8 */ "BOUND", /* 0x9 */ - "BOUNDUTF8", /* 0xa */ - "BOUNDL", /* 0xb */ - "BOUNDLUTF8", /* 0xc */ - "NBOUND", /* 0xd */ - "NBOUNDUTF8", /* 0xe */ - "NBOUNDL", /* 0xf */ - "NBOUNDLUTF8", /* 0x10 */ - "GPOS", /* 0x11 */ - "REG_ANY", /* 0x12 */ - "ANYUTF8", /* 0x13 */ - "SANY", /* 0x14 */ - "SANYUTF8", /* 0x15 */ - "ANYOF", /* 0x16 */ - "ANYOFUTF8", /* 0x17 */ - "ALNUM", /* 0x18 */ - "ALNUMUTF8", /* 0x19 */ - "ALNUML", /* 0x1a */ - "ALNUMLUTF8", /* 0x1b */ - "NALNUM", /* 0x1c */ - "NALNUMUTF8", /* 0x1d */ - "NALNUML", /* 0x1e */ - "NALNUMLUTF8", /* 0x1f */ - "SPACE", /* 0x20 */ - "SPACEUTF8", /* 0x21 */ - "SPACEL", /* 0x22 */ - "SPACELUTF8", /* 0x23 */ - "NSPACE", /* 0x24 */ - "NSPACEUTF8", /* 0x25 */ - "NSPACEL", /* 0x26 */ - "NSPACELUTF8", /* 0x27 */ - "DIGIT", /* 0x28 */ - "DIGITUTF8", /* 0x29 */ - "DIGITL", /* 0x2a */ - "DIGITLUTF8", /* 0x2b */ - "NDIGIT", /* 0x2c */ - "NDIGITUTF8", /* 0x2d */ - "NDIGITL", /* 0x2e */ - "NDIGITLUTF8", /* 0x2f */ - "CLUMP", /* 0x30 */ - "BRANCH", /* 0x31 */ - "BACK", /* 0x32 */ - "EXACT", /* 0x33 */ - "EXACTF", /* 0x34 */ - "EXACTFL", /* 0x35 */ - "NOTHING", /* 0x36 */ - "TAIL", /* 0x37 */ - "STAR", /* 0x38 */ - "PLUS", /* 0x39 */ - "CURLY", /* 0x3a */ - "CURLYN", /* 0x3b */ - "CURLYM", /* 0x3c */ - "CURLYX", /* 0x3d */ - "WHILEM", /* 0x3e */ - "OPEN", /* 0x3f */ - "CLOSE", /* 0x40 */ - "REF", /* 0x41 */ - "REFF", /* 0x42 */ - "REFFL", /* 0x43 */ - "IFMATCH", /* 0x44 */ - "UNLESSM", /* 0x45 */ - "SUSPEND", /* 0x46 */ - "IFTHEN", /* 0x47 */ - "GROUPP", /* 0x48 */ - "LONGJMP", /* 0x49 */ - "BRANCHJ", /* 0x4a */ - "EVAL", /* 0x4b */ - "MINMOD", /* 0x4c */ - "LOGICAL", /* 0x4d */ - "RENUM", /* 0x4e */ - "OPTIMIZED", /* 0x4f */ + "BOUNDL", /* 0xa */ + "NBOUND", /* 0xb */ + "NBOUNDL", /* 0xc */ + "GPOS", /* 0xd */ + "REG_ANY", /* 0xe */ + "SANY", /* 0xf */ + "ANYOF", /* 0x10 */ + "ALNUM", /* 0x11 */ + "ALNUML", /* 0x12 */ + "NALNUM", /* 0x13 */ + "NALNUML", /* 0x14 */ + "SPACE", /* 0x15 */ + "SPACEL", /* 0x16 */ + "NSPACE", /* 0x17 */ + "NSPACEL", /* 0x18 */ + "DIGIT", /* 0x19 */ + "DIGITL", /* 0x1a */ + "NDIGIT", /* 0x1b */ + "NDIGITL", /* 0x1c */ + "CLUMP", /* 0x1d */ + "BRANCH", /* 0x1e */ + "BACK", /* 0x1f */ + "EXACT", /* 0x20 */ + "EXACTF", /* 0x21 */ + "EXACTFL", /* 0x22 */ + "NOTHING", /* 0x23 */ + "TAIL", /* 0x24 */ + "STAR", /* 0x25 */ + "PLUS", /* 0x26 */ + "CURLY", /* 0x27 */ + "CURLYN", /* 0x28 */ + "CURLYM", /* 0x29 */ + "CURLYX", /* 0x2a */ + "WHILEM", /* 0x2b */ + "OPEN", /* 0x2c */ + "CLOSE", /* 0x2d */ + "REF", /* 0x2e */ + "REFF", /* 0x2f */ + "REFFL", /* 0x30 */ + "IFMATCH", /* 0x31 */ + "UNLESSM", /* 0x32 */ + "SUSPEND", /* 0x33 */ + "IFTHEN", /* 0x34 */ + "GROUPP", /* 0x35 */ + "LONGJMP", /* 0x36 */ + "BRANCHJ", /* 0x37 */ + "EVAL", /* 0x38 */ + "MINMOD", /* 0x39 */ + "LOGICAL", /* 0x3a */ + "RENUM", /* 0x3b */ + "OPTIMIZED", /* 0x3c */ }; -static const int reg_num = 80; +static const int reg_num = 61; #endif /* DEBUGGING */ #endif /* REG_COMP_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"); @@ -96,7 +93,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", @@ -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; @@ -229,7 +217,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 +228,6 @@ Perl_save_scalar(pTHX_ GV *gv) SV* Perl_save_svref(pTHX_ SV **sptr) { - dTHR; SSCHECK(3); SSPUSHPTR(sptr); SSPUSHPTR(SvREFCNT_inc(*sptr)); @@ -254,7 +240,6 @@ Perl_save_svref(pTHX_ SV **sptr) void Perl_save_generic_svref(pTHX_ SV **sptr) { - dTHR; SSCHECK(3); SSPUSHPTR(sptr); SSPUSHPTR(SvREFCNT_inc(*sptr)); @@ -267,7 +252,6 @@ Perl_save_generic_svref(pTHX_ SV **sptr) void Perl_save_generic_pvref(pTHX_ char **str) { - dTHR; SSCHECK(3); SSPUSHPTR(str); SSPUSHPTR(*str); @@ -277,7 +261,6 @@ Perl_save_generic_pvref(pTHX_ char **str) 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 */ @@ -302,6 +285,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 { @@ -313,7 +297,6 @@ Perl_save_gp(pTHX_ GV *gv, I32 empty) AV * Perl_save_ary(pTHX_ GV *gv) { - dTHR; AV *oav = GvAVn(gv); AV *av; @@ -341,7 +324,6 @@ Perl_save_ary(pTHX_ GV *gv) HV * Perl_save_hash(pTHX_ GV *gv) { - dTHR; HV *ohv, *hv; SSCHECK(3); @@ -366,7 +348,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); @@ -379,7 +360,6 @@ Perl_save_item(pTHX_ register SV *item) void Perl_save_int(pTHX_ int *intp) { - dTHR; SSCHECK(3); SSPUSHINT(*intp); SSPUSHPTR(intp); @@ -389,7 +369,6 @@ Perl_save_int(pTHX_ int *intp) void Perl_save_long(pTHX_ long int *longp) { - dTHR; SSCHECK(3); SSPUSHLONG(*longp); SSPUSHPTR(longp); @@ -399,7 +378,6 @@ Perl_save_long(pTHX_ long int *longp) void Perl_save_I32(pTHX_ I32 *intp) { - dTHR; SSCHECK(3); SSPUSHINT(*intp); SSPUSHPTR(intp); @@ -409,7 +387,6 @@ Perl_save_I32(pTHX_ I32 *intp) void Perl_save_I16(pTHX_ I16 *intp) { - dTHR; SSCHECK(3); SSPUSHINT(*intp); SSPUSHPTR(intp); @@ -419,7 +396,6 @@ Perl_save_I16(pTHX_ I16 *intp) void Perl_save_I8(pTHX_ I8 *bytep) { - dTHR; SSCHECK(3); SSPUSHINT(*bytep); SSPUSHPTR(bytep); @@ -429,7 +405,6 @@ Perl_save_I8(pTHX_ I8 *bytep) void Perl_save_iv(pTHX_ IV *ivp) { - dTHR; SSCHECK(3); SSPUSHIV(*ivp); SSPUSHPTR(ivp); @@ -442,7 +417,6 @@ Perl_save_iv(pTHX_ IV *ivp) void Perl_save_pptr(pTHX_ char **pptr) { - dTHR; SSCHECK(3); SSPUSHPTR(*pptr); SSPUSHPTR(pptr); @@ -452,7 +426,6 @@ Perl_save_pptr(pTHX_ char **pptr) void Perl_save_vptr(pTHX_ void *ptr) { - dTHR; SSCHECK(3); SSPUSHPTR(*(char**)ptr); SSPUSHPTR(ptr); @@ -462,18 +435,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))); @@ -488,7 +469,6 @@ Perl_save_threadsv(pTHX_ PADOFFSET i) void Perl_save_nogv(pTHX_ GV *gv) { - dTHR; SSCHECK(2); SSPUSHPTR(gv); SSPUSHINT(SAVEt_NSTAB); @@ -497,7 +477,6 @@ Perl_save_nogv(pTHX_ GV *gv) void Perl_save_hptr(pTHX_ HV **hptr) { - dTHR; SSCHECK(3); SSPUSHPTR(*hptr); SSPUSHPTR(hptr); @@ -507,7 +486,6 @@ Perl_save_hptr(pTHX_ HV **hptr) void Perl_save_aptr(pTHX_ AV **aptr) { - dTHR; SSCHECK(3); SSPUSHPTR(*aptr); SSPUSHPTR(aptr); @@ -517,7 +495,6 @@ Perl_save_aptr(pTHX_ AV **aptr) void Perl_save_freesv(pTHX_ SV *sv) { - dTHR; SSCHECK(2); SSPUSHPTR(sv); SSPUSHINT(SAVEt_FREESV); @@ -526,7 +503,6 @@ Perl_save_freesv(pTHX_ SV *sv) void Perl_save_freeop(pTHX_ OP *o) { - dTHR; SSCHECK(2); SSPUSHPTR(o); SSPUSHINT(SAVEt_FREEOP); @@ -535,7 +511,6 @@ Perl_save_freeop(pTHX_ OP *o) void Perl_save_freepv(pTHX_ char *pv) { - dTHR; SSCHECK(2); SSPUSHPTR(pv); SSPUSHINT(SAVEt_FREEPV); @@ -544,7 +519,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); @@ -553,7 +527,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); @@ -564,7 +537,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; @@ -581,7 +553,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); @@ -591,7 +562,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); @@ -601,7 +571,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); @@ -613,7 +582,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)); @@ -625,7 +593,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); @@ -634,7 +601,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)); @@ -652,7 +618,6 @@ 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; @@ -844,7 +809,7 @@ Perl_leave_scope(pTHX_ I32 base) /* Can clear pad variable in place? */ if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) { if (SvTHINKFIRST(sv)) - sv_force_normal(sv); + sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF); if (SvMAGICAL(sv)) mg_free(sv); @@ -887,7 +852,6 @@ Perl_leave_scope(pTHX_ I32 base) ptr = SSPOPPTR; (void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD); SvREFCNT_dec(hv); - Safefree(ptr); break; case SAVEt_DESTRUCTOR: ptr = SSPOPPTR; @@ -960,6 +924,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"); } @@ -970,7 +942,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); @@ -33,6 +33,7 @@ #define SAVEt_I8 32 #define SAVEt_COMPPAD 33 #define SAVEt_GENERIC_PVREF 34 +#define SAVEt_PADSV 35 #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)) @@ -101,6 +102,7 @@ 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 SAVEFREEOP(o) save_freeop(SOFT_CAST(OP*)(o)) #define SAVEFREEPV(p) save_freepv(SOFT_CAST(char*)(p)) @@ -173,11 +175,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 @@ -286,7 +291,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 { \ @@ -311,7 +316,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 { \ @@ -319,7 +324,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 { \ @@ -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. @@ -1285,11 +1285,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; @@ -1323,6 +1320,18 @@ See C<sv_setuv_mg>. void Perl_sv_setuv(pTHX_ register SV *sv, UV u) { + /* With these two if statements: + u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865 + + without + u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865 + + If you wish to remove them, please benchmark to see what the effect is + */ + if (u <= (UV)IV_MAX) { + sv_setiv(sv, (IV)u); + return; + } sv_setiv(sv, 0); SvIsUV_on(sv); SvUVX(sv) = u; @@ -1339,7 +1348,21 @@ Like C<sv_setuv>, but also handles 'set' magic. void Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) { - sv_setuv(sv,u); + /* With these two if statements: + u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865 + + without + u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865 + + If you wish to remove them, please benchmark to see what the effect is + */ + if (u <= (UV)IV_MAX) { + sv_setiv(sv, (IV)u); + } else { + sv_setiv(sv, 0); + SvIsUV_on(sv); + sv_setuv(sv,u); + } SvSETMAGIC(sv); } @@ -1373,11 +1396,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 */ @@ -1402,7 +1422,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; @@ -1456,16 +1475,225 @@ S_not_a_number(pTHX_ SV *sv) "Argument \"%s\" isn't numeric", tmpbuf); } -/* the number can be converted to integer with atol() or atoll() */ -#define IS_NUMBER_TO_INT_BY_ATOL 0x01 -#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 */ +/* the number can be converted to integer with atol() or atoll() although */ +#define IS_NUMBER_TO_INT_BY_ATOL 0x01 /* integer (may have decimals) */ +#define IS_NUMBER_TO_INT_BY_STRTOL 0x02 /* it may exceed IV_MAX */ +#define IS_NUMBER_TO_INT_BY_ATOF 0x04 /* seen something like 123e4 */ +#define IS_NUMBER_LONGER_THAN_IV_MAX 0x08 /* more digits than IV_MAX */ +#define IS_NUMBER_AS_LONG_AS_IV_MAX 0x10 /* may(be not) larger than IV_MAX */ +#define IS_NUMBER_NOT_INT 0x20 /* seen a decimal point or e */ +#define IS_NUMBER_NEG 0x40 /* seen a leading - */ +#define IS_NUMBER_INFINITY 0x80 /* /^\s*-?Infinity\s*$/i */ /* Actually, ISO C leaves conversion of UV to IV undefined, but until proven guilty, assume that things are not that bad... */ +/* As 64 bit platforms often have an NV that doesn't preserve all bits of + an IV (an assumption perl has been based on to date) it becomes necessary + to remove the assumption that the NV always carries enough precision to + recreate the IV whenever needed, and that the NV is the canonical form. + Instead, IV/UV and NV need to be given equal rights. So as to not lose + precision as an side effect of conversion (which would lead to insanity + and the dragon(s) in t/op/numconvert.t getting very angry) the intent is + 1) to distinguish between IV/UV/NV slots that have cached a valid + conversion where precision was lost and IV/UV/NV slots that have a + valid conversion which has lost no precision + 2) to ensure that if a numeric conversion to one form is request that + would lose precision, the precise conversion (or differently + imprecise conversion) is also performed and cached, to prevent + requests for different numeric formats on the same SV causing + lossy conversion chains. (lossless conversion chains are perfectly + acceptable (still)) + + + flags are used: + SvIOKp is true if the IV slot contains a valid value + SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true) + SvNOKp is true if the NV slot contains a valid value + SvNOK is true only if the NV value is accurate + + so + while converting from PV to NV check to see if converting that NV to an + IV(or UV) would lose accuracy over a direct conversion from PV to + IV(or UV). If it would, cache both conversions, return NV, but mark + SV as IOK NOKp (ie not NOK). + + while converting from PV to IV check to see if converting that IV to an + NV would lose accuracy over a direct conversion from PV to NV. If it + would, cache both conversions, flag similarly. + + Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite + correctly because if IV & NV were set NV *always* overruled. + Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning + changes - now IV and NV together means that the two are interchangeable + SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX; + + The benefit of this is operations such as pp_add know that if SvIOK is + true for both left and right operands, then integer addition can be + used instead of floating point. (for cases where the result won't + overflow) Before, floating point was always used, which could lead to + loss of precision compared with integer addition. + + * making IV and NV equal status should make maths accurate on 64 bit + platforms + * may speed up maths somewhat if pp_add and friends start to use + integers when possible instead of fp. (hopefully the overhead in + looking for SvIOK and checking for overflow will not outweigh the + fp to integer speedup) + * will slow down integer operations (callers of SvIV) on "inaccurate" + values, as the change from SvIOK to SvIOKp will cause a call into + sv_2iv each time rather than a macro access direct to the IV slot + * should speed up number->string conversion on integers as IV is + favoured when IV and NV equally accurate + + #################################################################### + You had better be using SvIOK_notUV if you want an IV for arithmetic + SvIOK is true if (IV or UV), so you might be getting (IV)SvUV + SvUOK is true iff UV. + #################################################################### + + Your mileage will vary depending your CPUs relative fp to integer + performance ratio. +*/ + +#ifndef NV_PRESERVES_UV +#define IS_NUMBER_UNDERFLOW_IV 1 +#define IS_NUMBER_UNDERFLOW_UV 2 +#define IS_NUMBER_IV_AND_UV 2 +#define IS_NUMBER_OVERFLOW_IV 4 +#define IS_NUMBER_OVERFLOW_UV 5 +/* Hopefully your optimiser will consider inlining these two functions. */ +STATIC int +S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) { + NV nv = SvNVX(sv); /* Code simpler and had compiler problems if */ + UV nv_as_uv = U_V(nv); /* these are not in simple variables. */ + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, numtype)); + if (nv_as_uv <= (UV)IV_MAX) { + (void)SvIOKp_on(sv); + (void)SvNOKp_on(sv); + /* Within suitable range to fit in an IV, atol won't overflow */ + /* XXX quite sure? Is that your final answer? not really, I'm + trusting that nv_as_uv to round down if NV is (IV_MAX + 1) */ + SvIVX(sv) = (IV)Atol(SvPVX(sv)); + if (numtype & IS_NUMBER_NOT_INT) { + /* I believe that even if the original PV had decimals, they + are lost beyond the limit of the FP precision. + However, neither is canonical, so both only get p flags. + NWC, 2000/11/25 */ + /* Both already have p flags, so do nothing */ + } else if (SvIVX(sv) == I_V(nv)) { + SvNOK_on(sv); + SvIOK_on(sv); + } else { + SvIOK_on(sv); + /* It had no "." so it must be integer. assert (get in here from + sv_2iv and sv_2uv only for ndef HAS_STRTOL and + IS_NUMBER_AS_LONG_AS_IV_MAX) or my logic is faulty and all + conversion routines need audit. */ + } + return nv < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV; + } + /* between IV_MAX and NV(UV_MAX). Could be slightly> UV_MAX */ + (void)SvIOKp_on(sv); + (void)SvNOKp_on(sv); +#ifdef HAS_STRTOUL + { + int save_errno = errno; + errno = 0; + SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10); + if (errno == 0) { + if (numtype & IS_NUMBER_NOT_INT) { + /* UV and NV both imprecise. */ + SvIsUV_on(sv); + } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) { + SvNOK_on(sv); + SvIOK_on(sv); + SvIsUV_on(sv); + } else { + SvIOK_on(sv); + SvIsUV_on(sv); + } + errno = save_errno; + return IS_NUMBER_OVERFLOW_IV; + } + errno = save_errno; + SvNOK_on(sv); + /* Must have just overflowed UV, but not enough that an NV could spot + this.. */ + return IS_NUMBER_OVERFLOW_UV; + } +#else + /* We've just lost integer precision, nothing we could do. */ + SvUVX(sv) = nv_as_uv; + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, numtype)); + /* UV and NV slots equally valid only if we have casting symmetry. */ + if (numtype & IS_NUMBER_NOT_INT) { + SvIsUV_on(sv); + } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) { + /* UV_MAX can cast up to NV (UV_MAX+1), that NV casts down to UV_MAX + UV_MAX ought to be 0xFF...FFF which won't preserve (We only + get to this point if NVs don't preserve UVs) */ + SvNOK_on(sv); + SvIOK_on(sv); + SvIsUV_on(sv); + } else { + /* As above, I believe UV at least as good as NV */ + SvIsUV_on(sv); + } +#endif /* HAS_STRTOUL */ + return IS_NUMBER_OVERFLOW_IV; +} + +/* For sv_2nv these three cases are "SvNOK and don't bother casting" */ +STATIC int +S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype) +{ + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), numtype)); + if (SvNVX(sv) < (NV)IV_MIN) { + (void)SvIOKp_on(sv); + (void)SvNOK_on(sv); + SvIVX(sv) = IV_MIN; + return IS_NUMBER_UNDERFLOW_IV; + } + if (SvNVX(sv) > (NV)UV_MAX) { + (void)SvIOKp_on(sv); + (void)SvNOK_on(sv); + SvIsUV_on(sv); + SvUVX(sv) = UV_MAX; + return IS_NUMBER_OVERFLOW_UV; + } + if (!(numtype & (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) { + (void)SvIOKp_on(sv); + (void)SvNOK_on(sv); + /* Can't use strtol etc to convert this string */ + if (SvNVX(sv) <= (UV)IV_MAX) { + SvIVX(sv) = I_V(SvNVX(sv)); + if ((NV)(SvIVX(sv)) == SvNVX(sv)) { + SvIOK_on(sv); /* Integer is precise. NOK, IOK */ + } else { + /* Integer is imprecise. NOK, IOKp */ + } + return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV; + } + SvIsUV_on(sv); + SvUVX(sv) = U_V(SvNVX(sv)); + if ((NV)(SvUVX(sv)) == SvNVX(sv)) { + if (SvUVX(sv) == UV_MAX) { + /* As we know that NVs don't preserve UVs, UV_MAX cannot + possibly be preserved by NV. Hence, it must be overflow. + NOK, IOKp */ + return IS_NUMBER_OVERFLOW_UV; + } + SvIOK_on(sv); /* Integer is precise. NOK, UOK */ + } else { + /* Integer is imprecise. NOK, IOKp */ + } + return IS_NUMBER_OVERFLOW_IV; + } + return S_sv_2inuv_non_preserve(aTHX_ sv, numtype); +} +#endif /* NV_PRESERVES_UV*/ + IV Perl_sv_2iv(pTHX_ register SV *sv) { @@ -1482,7 +1710,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(); } @@ -1497,8 +1724,10 @@ Perl_sv_2iv(pTHX_ register SV *sv) return SvIV(tmpstr); return PTR2IV(SvRV(sv)); } + if (SvREADONLY(sv) && SvFAKE(sv)) { + sv_force_normal(sv); + } if (SvREADONLY(sv) && !SvOK(sv)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED)) report_uninit(); return 0; @@ -1513,19 +1742,71 @@ Perl_sv_2iv(pTHX_ register SV *sv) } } if (SvNOKp(sv)) { - /* We can cache the IV/UV value even if it not good enough - * to reconstruct NV, since the conversion to PV will prefer - * NV over IV/UV. - */ + /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv + * without also getting a cached IV/UV from it at the same time + * (ie PV->NV conversion should detect loss of accuracy and cache + * IV or UV at same time to avoid this. NWC */ if (SvTYPE(sv) == SVt_NV) sv_upgrade(sv, SVt_PVNV); - (void)SvIOK_on(sv); - if (SvNVX(sv) < (NV)IV_MAX + 0.5) + (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ + /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost + certainly cast into the IV range at IV_MAX, whereas the correct + answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary + cases go to UV */ + if (SvNVX(sv) < (NV)IV_MAX + 0.5) { SvIVX(sv) = I_V(SvNVX(sv)); + if (SvNVX(sv) == (NV) SvIVX(sv) +#ifndef NV_PRESERVES_UV + && (((UV)1 << NV_PRESERVES_UV_BITS) > + (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) + /* Don't flag it as "accurately an integer" if the number + came from a (by definition imprecise) NV operation, and + we're outside the range of NV integer precision */ +#endif + ) { + SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%"UVxf" iv(%g => %"IVdf") (precise)\n", + PTR2UV(sv), + SvNVX(sv), + SvIVX(sv))); + + } else { + /* IV not precise. No need to convert from PV, as NV + conversion would already have cached IV if it detected + that PV->IV would be better than PV->NV->IV + flags already correct - don't set public IOK. */ + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n", + PTR2UV(sv), + SvNVX(sv), + SvIVX(sv))); + } + /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, + but the cast (NV)IV_MIN rounds to a the value less (more + negative) than IV_MIN which happens to be equal to SvNVX ?? + Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and + NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and + (NV)UVX == NVX are both true, but the values differ. :-( + Hopefully for 2s complement IV_MIN is something like + 0x8000000000000000 which will be exact. NWC */ + } else { SvUVX(sv) = U_V(SvNVX(sv)); + if ( + (SvNVX(sv) == (NV) SvUVX(sv)) +#ifndef NV_PRESERVES_UV + /* Make sure it's not 0xFFFFFFFFFFFFFFFF */ + /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ + && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) + /* Don't flag it as "accurately an integer" if the number + came from a (by definition imprecise) NV operation, and + we're outside the range of NV integer precision */ +#endif + ) + SvIOK_on(sv); SvIsUV_on(sv); ret_iv_max: DEBUG_c(PerlIO_printf(Perl_debug_log, @@ -1545,47 +1826,117 @@ Perl_sv_2iv(pTHX_ register SV *sv) This means that if we cache such an IV, we need to cache the NV as well. Moreover, we trade speed for space, and do not - cache the NV if not needed. + cache the NV if we are sure it's not needed. */ - if (numtype & IS_NUMBER_NOT_IV) { - /* May be not an integer. Need to cache NV if we cache IV - * - otherwise future conversion to NV will be wrong. */ - NV d; - - d = Atof(SvPVX(sv)); - if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); - SvNVX(sv) = d; - (void)SvNOK_on(sv); + if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) { + /* 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); (void)SvIOK_on(sv); + SvIVX(sv) = Atol(SvPVX(sv)); + } else { +#ifdef HAS_STRTOL + IV i; + int save_errno = errno; + /* Is it an integer that we could convert with strtol? + So try it, and if it doesn't set errno then it's pukka. + This should be faster than going atof and then thinking. */ + if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT)) + == IS_NUMBER_TO_INT_BY_STRTOL) + /* && is a sequence point. Without it not sure if I'm trying + to do too much between sequence points and hence going + undefined */ + && ((errno = 0), 1) /* , 1 so always true */ + && ((i = Strtol(SvPVX(sv), Null(char**), 10)), 1) + && (errno == 0)) { + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv, SVt_PVIV); + (void)SvIOK_on(sv); + SvIVX(sv) = i; + errno = save_errno; + } else +#endif + { + NV d; +#ifdef HAS_STRTOL + /* Hopefully trace flow will optimise this away where possible + */ + errno = save_errno; +#endif + /* It wasn't an integer, or it overflowed, or we don't have + strtol. Do things the slow way - check if it's a UV etc. */ + d = Atof(SvPVX(sv)); + + if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); + SvNVX(sv) = d; + + if (! numtype && ckWARN(WARN_NUMERIC)) + not_a_number(sv); + #if defined(USE_LONG_DOUBLE) - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", - PTR2UV(sv), SvNVX(sv))); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv))); #else - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n", - PTR2UV(sv), SvNVX(sv))); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n", + PTR2UV(sv), SvNVX(sv))); #endif - if (SvNVX(sv) < (NV)IV_MAX + 0.5) - SvIVX(sv) = I_V(SvNVX(sv)); - else { - SvUVX(sv) = U_V(SvNVX(sv)); - SvIsUV_on(sv); - goto ret_iv_max; + + +#ifdef NV_PRESERVES_UV + (void)SvIOKp_on(sv); + (void)SvNOK_on(sv); + if (SvNVX(sv) < (NV)IV_MAX + 0.5) { + SvIVX(sv) = I_V(SvNVX(sv)); + if ((NV)(SvIVX(sv)) == SvNVX(sv)) { + SvIOK_on(sv); + } else { + /* Integer is imprecise. NOK, IOKp */ + } + /* UV will not work better than IV */ + } else { + if (SvNVX(sv) > (NV)UV_MAX) { + SvIsUV_on(sv); + /* Integer is inaccurate. NOK, IOKp, is UV */ + SvUVX(sv) = UV_MAX; + SvIsUV_on(sv); + } else { + SvUVX(sv) = U_V(SvNVX(sv)); + /* 0xFFFFFFFFFFFFFFFF not an issue in here */ + if ((NV)(SvUVX(sv)) == SvNVX(sv)) { + SvIOK_on(sv); + SvIsUV_on(sv); + } else { + /* Integer is imprecise. NOK, IOKp, is UV */ + SvIsUV_on(sv); + } + } + goto ret_iv_max; + } +#else /* NV_PRESERVES_UV */ + if (((UV)1 << NV_PRESERVES_UV_BITS) > + U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { + /* Small enough to preserve all bits. */ + (void)SvIOKp_on(sv); + SvNOK_on(sv); + SvIVX(sv) = I_V(SvNVX(sv)); + if ((NV)(SvIVX(sv)) == SvNVX(sv)) + SvIOK_on(sv); + /* Assumption: first non-preserved integer is < IV_MAX, + this NV is in the preserved range, therefore: */ + if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) + < (UV)IV_MAX)) { + Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); + } + } else if (sv_2iuv_non_preserve (sv, numtype) + >= IS_NUMBER_OVERFLOW_IV) + goto ret_iv_max; +#endif /* NV_PRESERVES_UV */ } } - 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); - (void)SvIOK_on(sv); - SvIVX(sv) = Atol(SvPVX(sv)); - if (! numtype && ckWARN(WARN_NUMERIC)) - not_a_number(sv); - } - } - else { - dTHR; + } else { if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) report_uninit(); if (SvTYPE(sv) < SVt_IV) @@ -1613,7 +1964,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(); } @@ -1628,8 +1978,10 @@ Perl_sv_2uv(pTHX_ register SV *sv) return SvUV(tmpstr); return PTR2UV(SvRV(sv)); } + if (SvREADONLY(sv) && SvFAKE(sv)) { + sv_force_normal(sv); + } if (SvREADONLY(sv) && !SvOK(sv)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED)) report_uninit(); return 0; @@ -1644,26 +1996,74 @@ Perl_sv_2uv(pTHX_ register SV *sv) } } if (SvNOKp(sv)) { - /* We can cache the IV/UV value even if it not good enough - * to reconstruct NV, since the conversion to PV will prefer - * NV over IV/UV. - */ + /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv + * without also getting a cached IV/UV from it at the same time + * (ie PV->NV conversion should detect loss of accuracy and cache + * IV or UV at same time to avoid this. */ + /* IV-over-UV optimisation - choose to cache IV if possible */ + if (SvTYPE(sv) == SVt_NV) sv_upgrade(sv, SVt_PVNV); - (void)SvIOK_on(sv); - if (SvNVX(sv) >= -0.5) { - SvIsUV_on(sv); - SvUVX(sv) = U_V(SvNVX(sv)); - } - else { + + (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ + if (SvNVX(sv) < (NV)IV_MAX + 0.5) { SvIVX(sv) = I_V(SvNVX(sv)); - ret_zero: + if (SvNVX(sv) == (NV) SvIVX(sv) +#ifndef NV_PRESERVES_UV + && (((UV)1 << NV_PRESERVES_UV_BITS) > + (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) + /* Don't flag it as "accurately an integer" if the number + came from a (by definition imprecise) NV operation, and + we're outside the range of NV integer precision */ +#endif + ) { + SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%"UVxf" uv(%g => %"IVdf") (precise)\n", + PTR2UV(sv), + SvNVX(sv), + SvIVX(sv))); + + } else { + /* IV not precise. No need to convert from PV, as NV + conversion would already have cached IV if it detected + that PV->IV would be better than PV->NV->IV + flags already correct - don't set public IOK. */ + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n", + PTR2UV(sv), + SvNVX(sv), + SvIVX(sv))); + } + /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, + but the cast (NV)IV_MIN rounds to a the value less (more + negative) than IV_MIN which happens to be equal to SvNVX ?? + Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and + NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and + (NV)UVX == NVX are both true, but the values differ. :-( + Hopefully for 2s complement IV_MIN is something like + 0x8000000000000000 which will be exact. NWC */ + } + else { + SvUVX(sv) = U_V(SvNVX(sv)); + if ( + (SvNVX(sv) == (NV) SvUVX(sv)) +#ifndef NV_PRESERVES_UV + /* Make sure it's not 0xFFFFFFFFFFFFFFFF */ + /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ + && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) + /* Don't flag it as "accurately an integer" if the number + came from a (by definition imprecise) NV operation, and + we're outside the range of NV integer precision */ +#endif + ) + SvIOK_on(sv); + SvIsUV_on(sv); DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n", + "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n", PTR2UV(sv), - SvIVX(sv), - (IV)(UV)SvIVX(sv))); - return (UV)SvIVX(sv); + SvUVX(sv), + SvUVX(sv))); } } else if (SvPOKp(sv) && SvLEN(sv)) { @@ -1677,73 +2077,141 @@ Perl_sv_2uv(pTHX_ register SV *sv) NV as well. Moreover, we trade speed for space, and do not cache the NV if not needed. */ - if (numtype & IS_NUMBER_NOT_IV) { - /* May be not an integer. Need to cache NV if we cache IV - * - otherwise future conversion to NV will be wrong. */ - NV d; - d = Atof(SvPVX(sv)); - - if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); - SvNVX(sv) = d; - (void)SvNOK_on(sv); - (void)SvIOK_on(sv); -#if defined(USE_LONG_DOUBLE) - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", - PTR2UV(sv), SvNVX(sv))); -#else - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" 2nv(%g)\n", - PTR2UV(sv), SvNVX(sv))); -#endif - if (SvNVX(sv) < -0.5) { - SvIVX(sv) = I_V(SvNVX(sv)); - goto ret_zero; - } else { - SvUVX(sv) = U_V(SvNVX(sv)); - SvIsUV_on(sv); - } - } - else if (numtype & IS_NUMBER_NEG) { + if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) { /* 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) = (IV)Atol(SvPVX(sv)); - } - else if (numtype) { /* Non-negative */ - /* The NV may be reconstructed from UV - safe to cache UV, - which may be calculated by strtoul()/atol. */ - if (SvTYPE(sv) == SVt_PV) + which may be calculated by atol(). */ + if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); (void)SvIOK_on(sv); - (void)SvIsUV_on(sv); + SvIVX(sv) = Atol(SvPVX(sv)); + } else { +#ifdef HAS_STRTOUL + UV u; + char *num_begin = SvPVX(sv); + int save_errno = errno; + + /* seems that strtoul taking numbers that start with - is + implementation dependant, and can't be relied upon. */ + if (numtype & IS_NUMBER_NEG) { + /* Not totally defensive. assumine that looks_like_num + didn't lie about a - sign */ + while (isSPACE(*num_begin)) + num_begin++; + if (*num_begin == '-') + num_begin++; + } + + /* Is it an integer that we could convert with strtoul? + So try it, and if it doesn't set errno then it's pukka. + This should be faster than going atof and then thinking. */ + if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT)) + == IS_NUMBER_TO_INT_BY_STRTOL) + && ((errno = 0), 1) /* always true */ + && ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */ + && (errno == 0) + /* If known to be negative, check it didn't undeflow IV + XXX possibly we should put more negative values as NVs + direct rather than go via atof below */ + && ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) { + errno = save_errno; + + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv, SVt_PVIV); + (void)SvIOK_on(sv); + + /* If it's negative must use IV. + IV-over-UV optimisation */ + if (numtype & IS_NUMBER_NEG) { + SvIVX(sv) = -(IV)u; + } else if (u <= (UV) IV_MAX) { + SvIVX(sv) = (IV)u; + } else { + /* it didn't overflow, and it was positive. */ + SvUVX(sv) = u; + SvIsUV_on(sv); + } + } else +#endif + { + NV d; #ifdef HAS_STRTOUL - SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10); -#else /* no atou(), but we know the number fits into IV... */ - /* The only problem may be if it is negative... */ - SvUVX(sv) = (UV)Atol(SvPVX(sv)); + /* Hopefully trace flow will optimise this away where possible + */ + errno = save_errno; #endif - } - else { /* Not a number. Cache 0. */ - dTHR; + /* It wasn't an integer, or it overflowed, or we don't have + strtol. Do things the slow way - check if it's a IV etc. */ + d = Atof(SvPVX(sv)); - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv, SVt_PVIV); - (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); + if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); + SvNVX(sv) = d; + + if (! numtype && ckWARN(WARN_NUMERIC)) + not_a_number(sv); + +#if defined(USE_LONG_DOUBLE) + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv))); +#else + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n", + PTR2UV(sv), SvNVX(sv))); +#endif + +#ifdef NV_PRESERVES_UV + (void)SvIOKp_on(sv); + (void)SvNOK_on(sv); + if (SvNVX(sv) < (NV)IV_MAX + 0.5) { + SvIVX(sv) = I_V(SvNVX(sv)); + if ((NV)(SvIVX(sv)) == SvNVX(sv)) { + SvIOK_on(sv); + } else { + /* Integer is imprecise. NOK, IOKp */ + } + /* UV will not work better than IV */ + } else { + if (SvNVX(sv) > (NV)UV_MAX) { + SvIsUV_on(sv); + /* Integer is inaccurate. NOK, IOKp, is UV */ + SvUVX(sv) = UV_MAX; + SvIsUV_on(sv); + } else { + SvUVX(sv) = U_V(SvNVX(sv)); + /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs + NV preservse UV so can do correct comparison. */ + if ((NV)(SvUVX(sv)) == SvNVX(sv)) { + SvIOK_on(sv); + SvIsUV_on(sv); + } else { + /* Integer is imprecise. NOK, IOKp, is UV */ + SvIsUV_on(sv); + } + } + } +#else /* NV_PRESERVES_UV */ + if (((UV)1 << NV_PRESERVES_UV_BITS) > + U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { + /* Small enough to preserve all bits. */ + (void)SvIOKp_on(sv); + SvNOK_on(sv); + SvIVX(sv) = I_V(SvNVX(sv)); + if ((NV)(SvIVX(sv)) == SvNVX(sv)) + SvIOK_on(sv); + /* Assumption: first non-preserved integer is < IV_MAX, + this NV is in the preserved range, therefore: */ + if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) + < (UV)IV_MAX)) { + Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); + } + } else + sv_2iuv_non_preserve (sv, numtype); +#endif /* NV_PRESERVES_UV */ + } } } else { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) report_uninit(); } @@ -1768,7 +2236,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)); @@ -1781,7 +2248,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(); } @@ -1796,8 +2262,10 @@ Perl_sv_2nv(pTHX_ register SV *sv) return SvNV(tmpstr); return PTR2NV(SvRV(sv)); } + if (SvREADONLY(sv) && SvFAKE(sv)) { + sv_force_normal(sv); + } if (SvREADONLY(sv) && !SvOK(sv)) { - dTHR; if (ckWARN(WARN_UNINITIALIZED)) report_uninit(); return 0.0; @@ -1831,23 +2299,63 @@ Perl_sv_2nv(pTHX_ register SV *sv) (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv))) { SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv); +#ifdef NV_PRESERVES_UV + SvNOK_on(sv); +#else + /* Only set the public NV OK flag if this NV preserves the IV */ + /* Check it's not 0xFFFFFFFFFFFFFFFF */ + if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) + : (SvIVX(sv) == I_V(SvNVX(sv)))) + SvNOK_on(sv); + else + SvNOKp_on(sv); +#endif } 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)); +#ifdef NV_PRESERVES_UV + SvNOK_on(sv); +#else + /* Only set the public NV OK flag if this NV preserves the value in + the PV at least as well as an IV/UV would. + Not sure how to do this 100% reliably. */ + /* if that shift count is out of range then Configure's test is + wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS == + UV_BITS */ + if (((UV)1 << NV_PRESERVES_UV_BITS) > + U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) + SvNOK_on(sv); /* Definitely small enough to preserve all bits */ + else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) { + /* Definitely too large/small to fit in an integer, so no loss + of precision going to integer in the future via NV */ + SvNOK_on(sv); + } else { + /* Is it something we can run through strtol etc (ie no + trailing exponent part)? */ + int numtype = looks_like_number(sv); + /* XXX probably should cache this if called above */ + + if (!(numtype & + (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) { + /* Can't use strtol etc to convert this string, so don't try */ + SvNOK_on(sv); + } else + sv_2inuv_non_preserve (sv, numtype); + } +#endif /* NV_PRESERVES_UV */ } else { - dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) report_uninit(); if (SvTYPE(sv) < SVt_NV) /* Typically the caller expects that sv_any is not NULL now. */ + /* XXX Ilya implies that this is a bug in callers that assume this + and ideally should be fixed. */ sv_upgrade(sv, SVt_NV); return 0.0; } - SvNOK_on(sv); #if defined(USE_LONG_DOUBLE) DEBUG_c({ STORE_NUMERIC_LOCAL_SET_STANDARD(); @@ -1875,7 +2383,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); } @@ -1893,7 +2400,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); } @@ -1902,23 +2408,32 @@ S_asUV(pTHX_ SV *sv) /* * Returns a combination of (advisory only - can get false negatives) - * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV, - * IS_NUMBER_NEG + * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF + * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX + * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY * 0 if does not look like number. * - * In fact possible values are 0 and - * 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 + * (atol and strtol stop when they hit a decimal point. strtol will return + * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should + * do this, and vendors have had 11 years to get it right. + * However, will try to make it still work with only atol + * + * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX + * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX + * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX + * IS_NUMBER_LONGER_THAN_IV_MAX lots of digits, don't bother with atol + * IS_NUMBER_AS_LONG_AS_IV_MAX atol might hit LONG_MAX, might not. + * IS_NUMBER_NOT_INT saw "." or "e" + * IS_NUMBER_NEG * IS_NUMBER_INFINITY - * with a possible addition of IS_NUMBER_NEG. */ /* =for apidoc looks_like_number Test if an the content of an SV looks like a number (or is a -number). +number). C<Inf> and C<Infinity> are treated as numbers (so will not +issue a non-numeric warning), even if your atof() doesn't grok them. =cut */ @@ -1956,9 +2471,10 @@ Perl_looks_like_number(pTHX_ SV *sv) nbegin = s; /* - * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted - * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need - * (int)atof(). + * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to + * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if + * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you + * will need (int)atof(). */ /* next must be digit or the radix separator or beginning of infinity */ @@ -1967,10 +2483,34 @@ Perl_looks_like_number(pTHX_ SV *sv) s++; } while (isDIGIT(*s)); - if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */ - numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV; - else + /* Aaargh. long long really is irritating. + In the gospel according to ANSI 1989, it is an axiom that "long" + is the longest integer type, and that if you don't know how long + something is you can cast it to long, and nothing will be lost + (except possibly speed of execution if long is slower than the + type is was). + Now, one can't be sure if the old rules apply, or long long + (or some other newfangled thing) is actually longer than the + (formerly) longest thing. + */ + /* This lot will work for 64 bit *as long as* either + either long is 64 bit + or we can find both strtol/strtoq and strtoul/strtouq + If not, we really should refuse to let the user use 64 bit IVs + By "64 bit" I really mean IVs that don't get preserved by NVs + It also should work for 128 bit IVs. Can any lend me a machine to + test this? + */ + if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */ + numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX; + else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long)) + ? sizeof(long) : sizeof (IV))*8-1)) numtype |= IS_NUMBER_TO_INT_BY_ATOL; + else + /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal + digit less (IV_MAX= 9223372036854775807, + UV_MAX= 18446744073709551615) so be cautious */ + numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX; if (*s == '.' #ifdef USE_LOCALE_NUMERIC @@ -1978,7 +2518,7 @@ Perl_looks_like_number(pTHX_ SV *sv) #endif ) { s++; - numtype |= IS_NUMBER_NOT_IV; + numtype |= IS_NUMBER_NOT_INT; while (isDIGIT(*s)) /* optional digits after the radix */ s++; } @@ -1989,7 +2529,7 @@ Perl_looks_like_number(pTHX_ SV *sv) #endif ) { s++; - numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV; + numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT; /* no digits before the radix means we need digits after it */ if (isDIGIT(*s)) { do { @@ -2007,6 +2547,7 @@ Perl_looks_like_number(pTHX_ SV *sv) s++; if (*s != 'I' && *s != 'i') return 0; s++; if (*s != 'T' && *s != 't') return 0; s++; if (*s != 'Y' && *s != 'y') return 0; + s++; } sawinf = 1; } @@ -2014,12 +2555,13 @@ Perl_looks_like_number(pTHX_ SV *sv) return 0; if (sawinf) - numtype = IS_NUMBER_INFINITY; + numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */ + | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; 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; + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT; s++; if (*s == '+' || *s == '-') s++; @@ -2108,7 +2650,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(); } @@ -2135,7 +2676,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) { @@ -2206,18 +2746,39 @@ 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; return ""; } } - if (SvNOKp(sv)) { /* See note in sv_2uv() */ - /* XXXX 64-bit? IV may have better precision... */ - /* I tried changing this to be 64-bit-aware and - * the t/op/numconvert.t became very, very, angry. - * --jhi Sep 1999 */ + if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) { + /* I'm assuming that if both IV and NV are equally valid then + converting the IV is going to be more efficient */ + U32 isIOK = SvIOK(sv); + U32 isUIOK = SvIsUV(sv); + char buf[TYPE_CHARS(UV)]; + char *ebuf, *ptr; + + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv, SVt_PVIV); + if (isUIOK) + ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf); + else + ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf); + SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */ + Move(ptr,SvPVX(sv),ebuf - ptr,char); + SvCUR_set(sv, ebuf - ptr); + s = SvEND(sv); + *s = '\0'; + if (isIOK) + SvIOK_on(sv); + else + SvIOKp_on(sv); + if (isUIOK) + SvIsUV_on(sv); + } + else if (SvNOKp(sv)) { if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); /* The +20 is pure guesswork. Configure test needed. --jhi */ @@ -2243,38 +2804,10 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) *--s = '\0'; #endif } - else if (SvIOKp(sv)) { - U32 isIOK = SvIOK(sv); - U32 isUIOK = SvIsUV(sv); - char buf[TYPE_CHARS(UV)]; - char *ebuf, *ptr; - - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv, SVt_PVIV); - if (isUIOK) - ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf); - else - ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf); - SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */ - Move(ptr,SvPVX(sv),ebuf - ptr,char); - SvCUR_set(sv, ebuf - ptr); - s = SvEND(sv); - *s = '\0'; - if (isIOK) - SvIOK_on(sv); - else - SvIOKp_on(sv); - if (isUIOK) - SvIsUV_on(sv); - 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. */ @@ -2352,7 +2885,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 */ @@ -2365,7 +2898,6 @@ 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_)) && (SvRV(tmpsv) != SvRV(sv))) @@ -2405,26 +2937,37 @@ Convert the PV of an SV to its UTF8-encoded form. void Perl_sv_utf8_upgrade(pTHX_ register SV *sv) { - char *s, *t; - bool hibit; + 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 in SVs * to signal if there are any hibit chars in the PV. + * Given that there isn't make loop fast as possible */ - for (s = t = SvPVX(sv), hibit = FALSE; t < SvEND(sv) && !hibit; t++) - if (*t & 0x80) - hibit = TRUE; + s = SvPVX(sv); + e = SvEND(sv); + t = s; + while (t < e) { + if ((hibit = UTF8_IS_CONTINUED(*t++))) + break; + } if (hibit) { - STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */ + STRLEN len; + 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); - Safefree(s); /* No longer using what was there before. */ } } @@ -2443,22 +2986,26 @@ bool Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) { if (SvPOK(sv) && SvUTF8(sv)) { - char *c = SvPVX(sv); - STRLEN len = SvCUR(sv) + 1; /* include trailing NUL */ - if (!utf8_to_bytes((U8*)c, &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 (SvCUR(sv)) { + char *c = SvPVX(sv); + STRLEN len = SvCUR(sv); + + if (!utf8_to_bytes((U8*)c, &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"); + } } + SvCUR(sv) = len; } - SvCUR(sv) = len - 1; SvUTF8_off(sv); } + return TRUE; } @@ -2483,6 +3030,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; @@ -2493,9 +3041,9 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv) c = SvPVX(sv); if (!is_utf8_string((U8*)c, SvCUR(sv)+1)) return FALSE; - - while (c < SvEND(sv)) { - if (*c++ & 0x80) { + e = SvEND(sv); + while (c < e) { + if (UTF8_IS_CONTINUED(*c++)) { SvUTF8_on(sv); break; } @@ -2524,7 +3072,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; @@ -2567,7 +3114,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; @@ -2587,7 +3135,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; @@ -2656,7 +3205,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))) { @@ -2745,12 +3295,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) if (!GvCVGEN((GV*)dstr) && (CvROOT(cv) || CvXSUB(cv))) { - SV *const_sv = cv_const_sv(cv); - bool const_changed = TRUE; - if(const_sv) - const_changed = sv_cmp(const_sv, - op_const_sv(CvSTART((CV*)sref), - (CV*)sref)); + SV *const_sv; /* ahem, death to those who redefine * active sort subs */ if (PL_curstackinfo->si_type == PERLSI_SORT && @@ -2758,11 +3303,20 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", GvENAME((GV*)dstr)); - if ((const_changed && const_sv) || ckWARN(WARN_REDEFINE)) - Perl_warner(aTHX_ WARN_REDEFINE, const_sv ? - "Constant subroutine %s redefined" - : "Subroutine %s redefined", - GvENAME((GV*)dstr)); + /* Redefining a sub - warning is mandatory if + it was a const and its value changed. */ + if (ckWARN(WARN_REDEFINE) + || (CvCONST(cv) + && (!CvCONST((CV*)sref) + || sv_cmp(cv_const_sv(cv), + cv_const_sv((CV*)sref))))) + { + Perl_warner(aTHX_ WARN_REDEFINE, + CvCONST(cv) + ? "Constant subroutine %s redefined" + : "Subroutine %s redefined", + GvENAME((GV*)dstr)); + } } cv_ckproto(cv, (GV*)dstr, SvPOK(sref) ? SvPVX(sref) : Nullch); @@ -2809,7 +3363,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)) { @@ -2848,7 +3403,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) if (SvTEMP(sstr) && /* slated for free anyway? */ SvREFCNT(sstr) == 1 && /* and no other references to it? */ !(sflags & SVf_OOK) && /* and not involved in OOK hack? */ - SvLEN(sstr)) /* and really is a string */ + SvLEN(sstr) && /* and really is a string */ + !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */ { if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */ if (SvOOK(dstr)) { @@ -2918,7 +3474,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) else (void)SvOK_off(dstr); } - SvTAINT(dstr); + if (SvTAINTED(sstr)) + SvTAINT(dstr); } /* @@ -2949,8 +3506,11 @@ 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. */ + { + /* len is STRLEN which is unsigned, need to copy to signed */ + IV iv = len; + assert(iv >= 0); + } SV_CHECK_THINKFIRST(sv); if (!ptr) { (void)SvOK_off(sv); @@ -2963,7 +3523,7 @@ Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN Move(ptr,dptr,len,char); dptr[len] = '\0'; SvCUR_set(sv, len); - (void)SvPOK_only(sv); /* validate pointer */ + (void)SvPOK_only_UTF8(sv); /* validate pointer */ SvTAINT(sv); } @@ -3007,7 +3567,7 @@ Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr) SvGROW(sv, len + 1); Move(ptr,SvPVX(sv),len+1,char); SvCUR_set(sv, len); - (void)SvPOK_only(sv); /* validate pointer */ + (void)SvPOK_only_UTF8(sv); /* validate pointer */ SvTAINT(sv); } @@ -3057,7 +3617,7 @@ Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len) SvCUR_set(sv, len); SvLEN_set(sv, len+1); *SvEND(sv) = '\0'; - (void)SvPOK_only(sv); /* validate pointer */ + (void)SvPOK_only_UTF8(sv); /* validate pointer */ SvTAINT(sv); } @@ -3077,10 +3637,9 @@ Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len } void -Perl_sv_force_normal(pTHX_ register SV *sv) +Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) { if (SvREADONLY(sv)) { - dTHR; if (SvFAKE(sv)) { char *pvx = SvPVX(sv); STRLEN len = SvCUR(sv); @@ -3090,17 +3649,23 @@ Perl_sv_force_normal(pTHX_ register SV *sv) *SvEND(sv) = '\0'; SvFAKE_off(sv); SvREADONLY_off(sv); - unsharepvn(pvx,len,hash); + unsharepvn(pvx,SvUTF8(sv)?-len:len,hash); } else if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); } if (SvROK(sv)) - sv_unref(sv); + sv_unref_flags(sv, flags); else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) sv_unglob(sv); } +void +Perl_sv_force_normal(pTHX_ register SV *sv) +{ + sv_force_normal_flags(sv, 0); +} + /* =for apidoc sv_chop @@ -3189,27 +3754,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) +Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv) { - char *s; - STRLEN len; - if (!sstr) + char *spv; + STRLEN slen; + if (!ssv) return; - if ((s = SvPV(sstr, len))) { - if (DO_UTF8(sstr)) { - sv_utf8_upgrade(dstr); - sv_catpvn(dstr,s,len); - SvUTF8_on(dstr); + if ((spv = SvPV(ssv, slen))) { + bool dutf8 = DO_UTF8(dsv); + bool sutf8 = DO_UTF8(ssv); + + if (dutf8 == sutf8) + sv_catpvn(dsv,spv,slen); + else { + if (dutf8) { + /* Not modifying source SV, so taking a temporary copy. */ + SV* csv = sv_2mortal(newSVsv(ssv)); + char *cpv; + STRLEN clen; + + sv_utf8_upgrade(csv); + cpv = SvPV(csv,clen); + sv_catpvn(dsv,cpv,clen); + } + else { + sv_utf8_upgrade(dsv); + sv_catpvn(dsv,spv,slen); + SvUTF8_on(dsv); /* If dsv has no wide characters. */ + } } - else - sv_catpvn(dstr,s,len); } } @@ -3222,10 +3802,10 @@ Like C<sv_catsv>, but also handles 'set' magic. */ void -Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr) +Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv) { - sv_catsv(dstr,sstr); - SvSETMAGIC(dstr); + sv_catsv(dsv,ssv); + SvSETMAGIC(dsv); } /* @@ -3301,7 +3881,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); } @@ -3322,7 +3901,6 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam if (!obj || obj == sv || how == '#' || how == 'r') mg->mg_obj = obj; else { - dTHR; mg->mg_obj = SvREFCNT_inc(obj); mg->mg_flags |= MGf_REFCOUNTED; } @@ -3511,7 +4089,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; @@ -3664,7 +4241,6 @@ Make the first argument a copy of the second, then delete the original. 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)) @@ -3705,10 +4281,9 @@ Perl_sv_clear(pTHX_ register SV *sv) assert(SvREFCNT(sv) == 0); if (SvOBJECT(sv)) { - dTHR; if (PL_defstash) { /* Still have a symbol table? */ djSP; - GV* destructor; + CV* destructor; SV tmpref; Zero(&tmpref, 1, SV); @@ -3717,9 +4292,9 @@ Perl_sv_clear(pTHX_ register SV *sv) SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */ SvREFCNT(&tmpref) = 1; - do { + do { stash = SvSTASH(sv); - destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); + destructor = StashHANDLER(stash,DESTROY); if (destructor) { ENTER; PUSHSTACKi(PERLSI_DESTROY); @@ -3728,8 +4303,7 @@ Perl_sv_clear(pTHX_ register SV *sv) PUSHMARK(SP); PUSHs(&tmpref); PUTBACK; - call_sv((SV*)GvCV(destructor), - G_DISCARD|G_EVAL|G_KEEPERR); + call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR); SvREFCNT(sv)--; POPSTACK; SPAGAIN; @@ -3815,7 +4389,7 @@ Perl_sv_clear(pTHX_ register SV *sv) else if (SvPVX(sv) && SvLEN(sv)) Safefree(SvPVX(sv)); else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) { - unsharepvn(SvPVX(sv),SvCUR(sv),SvUVX(sv)); + unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv)); SvFAKE_off(sv); } break; @@ -3905,7 +4479,6 @@ Free the memory used by an SV. void Perl_sv_free(pTHX_ SV *sv) { - dTHR; int refcount_is_zero; if (!sv) @@ -3982,26 +4555,18 @@ UTF8 bytes as a single character. 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 @@ -4047,18 +4612,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; @@ -4100,13 +4665,30 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) /* do not utf8ize the comparands as a side-effect */ if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) { + if (PL_hints & HINT_UTF8_DISTINCT) + return FALSE; + if (SvUTF8(sv1)) { - pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2); - pv2tmp = TRUE; + (void)utf8_to_bytes((U8*)(pv1 = savepvn(pv1, cur1)), &cur1); + { + IV scur1 = cur1; + if (scur1 < 0) { + Safefree(pv1); + return 0; + } + } + pv1tmp = TRUE; } else { - pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1); - pv1tmp = TRUE; + (void)utf8_to_bytes((U8*)(pv2 = savepvn(pv2, cur2)), &cur2); + { + IV scur2 = cur2; + if (scur2 < 0) { + Safefree(pv2); + return 0; + } + } + pv2tmp = TRUE; } } @@ -4156,6 +4738,9 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) /* do not utf8ize the comparands as a side-effect */ if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) { + if (PL_hints & HINT_UTF8_DISTINCT) + return SvUTF8(sv1) ? 1 : -1; + if (SvUTF8(sv1)) { pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2); pv2tmp = TRUE; @@ -4312,7 +4897,6 @@ appending to the currently-stored string. char * Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) { - dTHR; char *rsptr; STRLEN rslen; register STDCHAR rslast; @@ -4348,14 +4932,31 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) #endif SvCUR_set(sv, bytesread); buffer[bytesread] = '\0'; + if (PerlIO_isutf8(fp)) + SvUTF8_on(sv); + else + SvUTF8_off(sv); return(SvCUR(sv) ? SvPVX(sv) : Nullch); } else if (RsPARA(PL_rs)) { rsptr = "\n\n"; rslen = 2; } - else - rsptr = SvPV(PL_rs, rslen); + else { + /* Get $/ i.e. PL_rs into same encoding as stream wants */ + if (PerlIO_isutf8(fp)) { + rsptr = SvPVutf8(PL_rs, rslen); + } + else { + 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 */ @@ -4574,6 +5175,11 @@ screamer2: } } + if (PerlIO_isutf8(fp)) + SvUTF8_on(sv); + else + SvUTF8_off(sv); + return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; } @@ -4598,7 +5204,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); } @@ -4612,12 +5217,15 @@ Perl_sv_inc(pTHX_ register SV *sv) } } flags = SvFLAGS(sv); - if (flags & SVp_NOK) { - (void)SvNOK_only(sv); - SvNVX(sv) += 1.0; - return; - } - if (flags & SVp_IOK) { + if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) { + /* It's (privately or publicly) a float, but not tested as an + integer, so test it to see. */ + (void) SvIV(sv); + flags = SvFLAGS(sv); + } + if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { + /* It's publicly an integer, or privately an integer-not-float */ + oops_its_int: if (SvIsUV(sv)) { if (SvUVX(sv) == UV_MAX) sv_setnv(sv, (NV)UV_MAX + 1.0); @@ -4626,7 +5234,7 @@ Perl_sv_inc(pTHX_ register SV *sv) ++SvUVX(sv); } else { if (SvIVX(sv) == IV_MAX) - sv_setnv(sv, (NV)IV_MAX + 1.0); + sv_setuv(sv, (UV)IV_MAX + 1); else { (void)SvIOK_only(sv); ++SvIVX(sv); @@ -4634,18 +5242,59 @@ Perl_sv_inc(pTHX_ register SV *sv) } return; } - if (!(flags & SVp_POK) || !*SvPVX(sv)) { - if ((flags & SVTYPEMASK) < SVt_PVNV) - sv_upgrade(sv, SVt_NV); - SvNVX(sv) = 1.0; + if (flags & SVp_NOK) { (void)SvNOK_only(sv); + SvNVX(sv) += 1.0; + return; + } + + if (!(flags & SVp_POK) || !*SvPVX(sv)) { + if ((flags & SVTYPEMASK) < SVt_PVIV) + sv_upgrade(sv, SVt_IV); + (void)SvIOK_only(sv); + SvIVX(sv) = 1; return; } d = SvPVX(sv); while (isALPHA(*d)) d++; while (isDIGIT(*d)) d++; if (*d) { - sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */ +#ifdef PERL_PRESERVE_IVUV + /* Got to punt this an an integer if needs be, but we don't issue + warnings. Probably ought to make the sv_iv_please() that does + the conversion if possible, and silently. */ + I32 numtype = looks_like_number(sv); + if (numtype && !(numtype & IS_NUMBER_INFINITY)) { + /* Need to try really hard to see if it's an integer. + 9.22337203685478e+18 is an integer. + but "9.22337203685478e+18" + 0 is UV=9223372036854779904 + so $a="9.22337203685478e+18"; $a+0; $a++ + needs to be the same as $a="9.22337203685478e+18"; $a++ + or we go insane. */ + + (void) sv_2iv(sv); + if (SvIOK(sv)) + goto oops_its_int; + + /* sv_2iv *should* have made this an NV */ + if (flags & SVp_NOK) { + (void)SvNOK_only(sv); + SvNVX(sv) += 1.0; + return; + } + /* I don't think we can get here. Maybe I should assert this + And if we do get here I suspect that sv_setnv will croak. NWC + Fall through. */ +#if defined(USE_LONG_DOUBLE) + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", + SvPVX(sv), SvIVX(sv), SvNVX(sv))); +#else + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n", + SvPVX(sv), SvIVX(sv), SvNVX(sv))); +#endif + } +#endif /* PERL_PRESERVE_IVUV */ + sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); return; } d--; @@ -4706,7 +5355,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); } @@ -4719,13 +5367,12 @@ Perl_sv_dec(pTHX_ register SV *sv) sv_setiv(sv, i); } } + /* Unlike sv_inc we don't have to worry about string-never-numbers + and keeping them magic. But we mustn't warn on punting */ flags = SvFLAGS(sv); - if (flags & SVp_NOK) { - SvNVX(sv) -= 1.0; - (void)SvNOK_only(sv); - return; - } - if (flags & SVp_IOK) { + if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { + /* It's publicly an integer, or privately an integer-not-float */ + oops_its_int: if (SvIsUV(sv)) { if (SvUVX(sv) == 0) { (void)SvIOK_only(sv); @@ -4745,6 +5392,11 @@ Perl_sv_dec(pTHX_ register SV *sv) } return; } + if (flags & SVp_NOK) { + SvNVX(sv) -= 1.0; + (void)SvNOK_only(sv); + return; + } if (!(flags & SVp_POK)) { if ((flags & SVTYPEMASK) < SVt_PVNV) sv_upgrade(sv, SVt_NV); @@ -4752,6 +5404,40 @@ Perl_sv_dec(pTHX_ register SV *sv) (void)SvNOK_only(sv); return; } +#ifdef PERL_PRESERVE_IVUV + { + I32 numtype = looks_like_number(sv); + if (numtype && !(numtype & IS_NUMBER_INFINITY)) { + /* Need to try really hard to see if it's an integer. + 9.22337203685478e+18 is an integer. + but "9.22337203685478e+18" + 0 is UV=9223372036854779904 + so $a="9.22337203685478e+18"; $a+0; $a-- + needs to be the same as $a="9.22337203685478e+18"; $a-- + or we go insane. */ + + (void) sv_2iv(sv); + if (SvIOK(sv)) + goto oops_its_int; + + /* sv_2iv *should* have made this an NV */ + if (flags & SVp_NOK) { + (void)SvNOK_only(sv); + SvNVX(sv) -= 1.0; + return; + } + /* I don't think we can get here. Maybe I should assert this + And if we do get here I suspect that sv_setnv will croak. NWC + Fall through. */ +#if defined(USE_LONG_DOUBLE) + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", + SvPVX(sv), SvIVX(sv), SvNVX(sv))); +#else + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n", + SvPVX(sv), SvIVX(sv), SvNVX(sv))); +#endif + } + } +#endif /* PERL_PRESERVE_IVUV */ sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */ } @@ -4772,7 +5458,6 @@ as mortal. SV * Perl_sv_mortalcopy(pTHX_ SV *oldstr) { - dTHR; register SV *sv; new_SV(sv); @@ -4794,7 +5479,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); @@ -4818,7 +5502,6 @@ ends. SV * Perl_sv_2mortal(pTHX_ register SV *sv) { - dTHR; if (!sv) return sv; if (SvREADONLY(sv) && SvIMMORTAL(sv)) @@ -4885,20 +5568,27 @@ will avoid string compare. */ SV * -Perl_newSVpvn_share(pTHX_ const char *src, STRLEN len, U32 hash) +Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) { register SV *sv; + bool is_utf8 = FALSE; + if (len < 0) { + len = -len; + is_utf8 = TRUE; + } if (!hash) PERL_HASH(hash, src, len); new_SV(sv); sv_upgrade(sv, SVt_PVIV); - SvPVX(sv) = sharepvn(src, len, hash); + SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash); SvCUR(sv) = len; SvUVX(sv) = hash; SvLEN(sv) = 0; SvREADONLY_on(sv); SvFAKE_on(sv); SvPOK_on(sv); + if (is_utf8) + SvUTF8_on(sv); return sv; } @@ -5014,7 +5704,6 @@ SV is B<not> incremented. SV * Perl_newRV_noinc(pTHX_ SV *tmpRef) { - dTHR; register SV *sv; new_SV(sv); @@ -5045,7 +5734,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) @@ -5128,7 +5816,7 @@ Perl_sv_reset(pTHX_ register char *s, HV *stash) } if (GvHV(gv) && !HvNAME(GvHV(gv))) { hv_clear(GvHV(gv)); -#if !defined( VMS) && !defined(EPOC) /* VMS has no environ array */ +#ifdef USE_ENVIRON_ARRAY if (gv == PL_envgv) environ[0] = Nullch; #endif @@ -5200,7 +5888,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); @@ -5256,7 +5943,6 @@ Returns true if the SV has a true value by Perl's rules. I32 Perl_sv_true(pTHX_ register SV *sv) { - dTHR; if (!sv) return 0; if (SvPOK(sv)) { @@ -5352,7 +6038,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]); } @@ -5532,7 +6217,6 @@ reference count is 1. SV* Perl_newSVrv(pTHX_ SV *rv, const char *classname) { - dTHR; SV *sv; new_SV(sv); @@ -5672,7 +6356,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"); @@ -5728,17 +6411,21 @@ S_sv_unglob(pTHX_ SV *sv) } /* -=for apidoc sv_unref +=for apidoc sv_unref_flags Unsets the RV status of the SV, and decrements the reference count of whatever was being referenced by the RV. This can almost be thought of -as a reversal of C<newSVrv>. See C<SvROK_off>. +as a reversal of C<newSVrv>. The C<cflags> argument can contain +C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented +(otherwise the decrementing is conditional on the reference count being +different from one or the reference being a readonly SV). +See C<SvROK_off>. =cut */ void -Perl_sv_unref(pTHX_ SV *sv) +Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags) { SV* rv = SvRV(sv); @@ -5750,12 +6437,29 @@ Perl_sv_unref(pTHX_ SV *sv) } SvRV(sv) = 0; SvROK_off(sv); - if (SvREFCNT(rv) != 1 || SvREADONLY(rv)) + if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */ SvREFCNT_dec(rv); - else + else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */ sv_2mortal(rv); /* Schedule for freeing later */ } +/* +=for apidoc sv_unref + +Unsets the RV status of the SV, and decrements the reference count of +whatever was being referenced by the RV. This can almost be thought of +as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag> +being zero. See C<SvROK_off>. + +=cut +*/ + +void +Perl_sv_unref(pTHX_ SV *sv) +{ + sv_unref_flags(sv, 0); +} + void Perl_sv_taint(pTHX_ SV *sv) { @@ -5995,7 +6699,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; @@ -6050,9 +6753,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV bool has_precis = FALSE; STRLEN precis = 0; bool is_utf = FALSE; - + char esignbuf[4]; - U8 utf8buf[UTF8_MAXLEN]; + U8 utf8buf[UTF8_MAXLEN+1]; STRLEN esignlen = 0; char *eptr = Nullch; @@ -6078,6 +6781,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV STRLEN gap; char *dotstr = "."; STRLEN dotstrlen = 1; + I32 epix = 0; /* explicit parameter index */ + I32 ewix = 0; /* explicit width index */ + bool asterisk = FALSE; for (q = p; q < patend && *q != '%'; ++q) ; if (q > p) { @@ -6138,6 +6844,15 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* WIDTH */ + scanwidth: + + if (*q == '*') { + if (asterisk) + goto unknown; + asterisk = TRUE; + q++; + } + switch (*q) { case '1': case '2': case '3': case '4': case '5': case '6': @@ -6145,17 +6860,30 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV width = 0; while (isDIGIT(*q)) width = width * 10 + (*q++ - '0'); - break; + if (*q == '$') { + if (asterisk && ewix == 0) { + ewix = width; + width = 0; + q++; + goto scanwidth; + } else if (epix == 0) { + epix = width; + width = 0; + q++; + goto scanwidth; + } else + goto unknown; + } + } - case '*': + if (asterisk) { if (args) i = va_arg(*args, int); else - i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; + i = (ewix ? ewix <= svmax : svix < svmax) ? + SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0; left |= (i < 0); width = (i < 0) ? -i : i; - q++; - break; } /* PRECISION */ @@ -6166,7 +6894,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (args) i = va_arg(*args, int); else - i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; + i = (ewix ? ewix <= svmax : svix < svmax) + ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0; precis = (i < 0) ? 0 : i; q++; } @@ -6184,8 +6913,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV vecstr = (U8*)SvPVx(vecsv,veclen); utf = DO_UTF8(vecsv); } - else if (svix < svmax) { - vecsv = svargs[svix++]; + else if (epix ? epix <= svmax : svix < svmax) { + vecsv = svargs[epix ? epix-1 : svix++]; vecstr = (U8*)SvPVx(vecsv,veclen); utf = DO_UTF8(vecsv); } @@ -6239,7 +6968,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (args) uv = va_arg(*args, int); else - uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; + uv = (epix ? epix <= svmax : svix < svmax) ? + SvIVx(svargs[epix ? epix-1 : svix++]) : 0; if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) { eptr = (char*)utf8buf; elen = uv_to_utf8((U8*)eptr, uv) - utf8buf; @@ -6268,8 +6998,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV elen = sizeof nullstr - 1; } } - else if (svix < svmax) { - argsv = svargs[svix++]; + else if (epix ? epix <= svmax : svix < svmax) { + argsv = svargs[epix ? epix-1 : svix++]; eptr = SvPVx(argsv, elen); if (DO_UTF8(argsv)) { if (has_precis && precis < elen) { @@ -6312,7 +7042,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (args) uv = PTR2UV(va_arg(*args, void*)); else - uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0; + uv = (epix ? epix <= svmax : svix < svmax) ? + PTR2UV(svargs[epix ? epix-1 : svix++]) : 0; base = 16; goto integer; @@ -6326,13 +7057,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_chk(vecstr, &ulen, 0); + iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0); else { iv = *vecstr; ulen = 1; @@ -6352,7 +7083,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } else { - iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; + iv = (epix ? epix <= svmax : svix < svmax) ? + SvIVx(svargs[epix ? epix-1 : svix++]) : 0; switch (intsize) { case 'h': iv = (short)iv; break; default: break; @@ -6407,14 +7139,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_chk(vecstr, &ulen, 0); + uv = utf8_to_uv(vecstr, veclen, &ulen, 0); else { uv = *vecstr; ulen = 1; @@ -6434,7 +7166,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } else { - uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0; + uv = (epix ? epix <= svmax : svix < svmax) ? + SvUVx(svargs[epix ? epix-1 : svix++]) : 0; switch (intsize) { case 'h': uv = (unsigned short)uv; break; default: break; @@ -6526,7 +7259,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (args) nv = va_arg(*args, NV); else - nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0; + nv = (epix ? epix <= svmax : svix < svmax) ? + SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0; need = 0; if (c != 'e' && c != 'E') { @@ -6581,15 +7315,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV *--eptr = '#'; *--eptr = '%'; - { - STORE_NUMERIC_STANDARD_SET_LOCAL(); -#ifdef USE_LOCALE_NUMERIC - if (!was_standard && maybe_tainted) - *maybe_tainted = TRUE; -#endif - (void)sprintf(PL_efloatbuf, eptr, nv); - RESTORE_NUMERIC_STANDARD(); - } + /* 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); @@ -6611,8 +7340,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV #endif } } - else if (svix < svmax) - sv_setuv_mg(svargs[svix++], (UV)i); + else if (epix ? epix <= svmax : svix < svmax) + sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i); continue; /* not "break" */ /* UNKNOWN */ @@ -6748,7 +7477,7 @@ Perl_fp_dup(pTHX_ PerlIO *fp, char type) return ret; /* create anew and remember what it is */ - ret = PerlIO_fdupopen(fp); + ret = PerlIO_fdupopen(aTHX_ fp); ptr_table_store(PL_ptr_table, fp, ret); return ret; } @@ -7624,6 +8353,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"); } @@ -7797,6 +8534,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); if (!specialWARN(PL_compiling.cop_warnings)) PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings); + if (!specialCopIO(PL_compiling.cop_io)) + PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io); PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl); /* pseudo environmental stuff */ @@ -7922,8 +8661,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_laststype = proto_perl->Ilaststype; PL_mess_sv = Nullsv; - PL_orslen = proto_perl->Iorslen; - PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen); + PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv); PL_ofmt = SAVEPV(proto_perl->Iofmt); /* interpreter atexit processing */ @@ -8206,8 +8944,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_nrs = sv_dup_inc(proto_perl->Tnrs); PL_rs = sv_dup_inc(proto_perl->Trs); PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv); - PL_ofslen = proto_perl->Tofslen; - PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen); + PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv); PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv); PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */ PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget); @@ -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. @@ -448,6 +448,9 @@ 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|SvUOK|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. @@ -562,6 +565,7 @@ Set the length of the string which is in the SV. See C<SvCUR>. #define SvIOK_UV(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) \ == (SVf_IOK|SVf_IVisUV)) +#define SvUOK(sv) SvIOK_UV(sv) #define SvIOK_notUV(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) \ == SVf_IOK) @@ -714,6 +718,12 @@ and disables all other OK bits. #define SvMAGIC(sv) ((XPVMG*) SvANY(sv))->xmg_magic #define SvSTASH(sv) ((XPVMG*) SvANY(sv))->xmg_stash +/* Ask a scalar nicely to try to become an IV, if possible. + Not guaranteed to stay returning void */ +/* Macro won't actually call sv_2iv if already IOK */ +#define SvIV_please(sv) \ + STMT_START {if (!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv))) \ + (void) SvIV(sv); } STMT_END #define SvIV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVIV*) SvANY(sv))->xiv_iv = val); } STMT_END @@ -801,7 +811,6 @@ Taints an SV if tainting is enabled #define SvTAINT(sv) \ STMT_START { \ if (PL_tainting) { \ - dTHR; \ if (PL_tainted) \ SvTAINTED_on(sv); \ } \ @@ -1097,3 +1106,4 @@ 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 SV_IMMEDIATE_UNREF 1 @@ -1,4 +1,4 @@ -This is the perl test library. To run all the tests, just type 'TEST'. +This is the perl test library. To run all the tests, just type './TEST'. To add new tests, just look at the current tests and do likewise. @@ -14,3 +14,8 @@ will fail, you may want to use Test::Harness thusly: This method pinpoints failed tests automatically. If you come up with new tests, please send them to perlbug@perl.org. + +Tests in the base/ directory ought to be runnable with plain miniperl. +That is, they should not require Config.pm nor should they require any +extensions to have been built. TEST will abort if any tests in the +base/ directory fail. @@ -114,6 +114,9 @@ EOT $next = $1, $ok = 0, last if /^not ok ([0-9]*)/; if (/^ok (\d+)(\s*#.*)?$/ && $1 == $next) { $next = $next + 1; + } + elsif (/^Bail out!\s*(.*)/i) { # magic words + die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n"); } else { $ok = 0; @@ -127,6 +127,9 @@ EOT $next = $1, $ok = 0, last if /^not ok ([0-9]*)/; if (/^ok (\d+)(\s*#.*)?$/ && $1 == $next) { $next = $next + 1; + } + elsif (/^Bail out!\s*(.*)/i) { # magic words + die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n"); } else { $ok = 0; diff --git a/t/base/commonsense.t b/t/base/commonsense.t new file mode 100644 index 0000000000..6e313073d2 --- /dev/null +++ b/t/base/commonsense.t @@ -0,0 +1,25 @@ +#!./perl + +chdir 't' if -d 't'; +@INC = '../lib'; +require Config; import Config; +if (($Config{'extensions'} !~ /\b(DB|[A-Z]DBM)_File\b/) ){ + print "Bail out! Perl configured without DB_File or [A-Z]DBM_File\n"; + exit 0; +} +if (($Config{'extensions'} !~ /\bFcntl\b/) ){ + print "Bail out! Perl configured without Fcntl module\n"; + exit 0; +} +if (($Config{'extensions'} !~ /\bIO\b/) ){ + print "Bail out! Perl configured without IO module\n"; + exit 0; +} +# hey, DOS users do not need this kind of common sense ;-) +if ($^O ne 'dos' && ($Config{'extensions'} !~ /\bFile\/Glob\b/) ){ + print "Bail out! Perl configured without File::Glob module\n"; + exit 0; +} + +print "1..1\nok 1\n"; + diff --git a/t/base/term.t b/t/base/term.t index e96313dec5..49df11fa31 100755 --- a/t/base/term.t +++ b/t/base/term.t @@ -4,19 +4,16 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; } -use Config; - print "1..7\n"; # check "" interpretation $x = "\n"; # 10 is ASCII/Iso Latin, 21 is EBCDIC. -if ($x eq chr(10) || - ($Config{ebcdic} eq 'define' && $x eq chr(21))) {print "ok 1\n";} +if ($x eq chr(10)) { print "ok 1\n";} +elsif ($x eq chr(21)) { print "ok 1 # EBCDIC\n"; } else {print "not ok 1\n";} # check `` processing diff --git a/t/comp/proto.t b/t/comp/proto.t index f9731ee489..874ab44058 100755 --- a/t/comp/proto.t +++ b/t/comp/proto.t @@ -9,6 +9,9 @@ # we should test as many as we can. # +# XXX known to leak scalars +$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; + BEGIN { chdir 't' if -d 't'; @INC = '../lib'; @@ -16,7 +19,7 @@ BEGIN { use strict; -print "1..110\n"; +print "1..124\n"; my $i = 1; @@ -340,6 +343,7 @@ sub sub_array (&@) { @array = (qw(O K)," ", $i++); sub_array { lc shift } @array; +sub_array { lc shift } ('O', 'K', ' ', $i++); print "\n"; ## @@ -485,3 +489,17 @@ 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; + print "# eval[$eval]\nnot " unless $@ && $@ =~ /syntax error/; + print "ok ", $i++, "\n"; +} + +# Not $$;$;$ +print "not " unless prototype "CORE::substr" eq '$$;$$'; +print "ok ", $i++, "\n"; diff --git a/t/comp/redef.t b/t/comp/redef.t index 07e978bb86..328b44d3c8 100755 --- a/t/comp/redef.t +++ b/t/comp/redef.t @@ -11,7 +11,7 @@ sub ok ($$) { print $_[1] ? "ok " : "not ok ", $_[0], "\n"; } -print "1..18\n"; +print "1..20\n"; my $NEWPROTO = 'Prototype mismatch:'; @@ -72,9 +72,15 @@ sub sub9 ($) { 2 } ok 16, $warn =~ s/$NEWPROTO sub main::sub9 \(\$\Q@) vs ($)\E[^\n]+\n//s; ok 17, $warn =~ s/Subroutine sub9 redefined[^\n]+\n//s; -ok 18, $_ eq ''; +BEGIN { + local $^W = 0; + eval qq(sub sub10 () {1} sub sub10 {1}); +} -# If we got any errors that we were not expecting, then print them -print $_ if length $_; +ok 18, $warn =~ s/$NEWPROTO \Qsub main::sub10 () vs none\E[^\n]+\n//s; +ok 19, $warn =~ s/Constant subroutine sub10 redefined[^\n]+\n//s; +ok 20, $warn eq ''; +# If we got any errors that we were not expecting, then print them +print $warn if length $warn; diff --git a/t/comp/require.t b/t/comp/require.t index eaea3ad5f6..e634532275 100755 --- a/t/comp/require.t +++ b/t/comp/require.t @@ -21,6 +21,7 @@ sub write_file { my $f = shift; open(REQ,">$f") or die "Can't write '$f': $!"; binmode REQ; + use bytes; print REQ @_; close REQ; } @@ -132,7 +133,7 @@ $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; + return @_ == 3 && $_[2] ? pack("$_[0]", 0xFEFF) . $utf16 : $utf16; } $i++; do_require(bytes_to_utf16('n', qq(print "ok $i\\n"; 1;\n), 1)); # BE diff --git a/t/io/dup.t b/t/io/dup.t index af13d4d8f7..9b656ec8b3 100755 --- a/t/io/dup.t +++ b/t/io/dup.t @@ -2,7 +2,7 @@ # $RCSfile: dup.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:27 $ -print "1..6\n"; +print "1..8\n"; print "ok 1\n"; @@ -17,14 +17,10 @@ select(STDOUT); $| = 1; print STDOUT "ok 2\n"; print STDERR "ok 3\n"; -if ($^O eq 'MSWin32') { print `echo ok 4`; print `echo ok 5 1>&2`; # does this work? -} -else { - system 'echo ok 4'; - system 'echo ok 5 1>&2'; -} + system 'echo ok 6'; + system 'echo ok 7 1>&2'; close(STDOUT); close(STDERR); @@ -36,5 +32,5 @@ if ($^O eq 'MSWin32') { print `type Io.dup` } else { system 'cat Io.dup' } unlink 'Io.dup'; -print STDOUT "ok 6\n"; +print STDOUT "ok 8\n"; @@ -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/t/io/open.t b/t/io/open.t index 01902812e2..0e2d57cd75 100755 --- a/t/io/open.t +++ b/t/io/open.t @@ -9,6 +9,7 @@ BEGIN { $| = 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) { + 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) { + 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/t/io/pipe.t b/t/io/pipe.t index 96935e3f88..500832595e 100755 --- a/t/io/pipe.t +++ b/t/io/pipe.t @@ -11,7 +11,7 @@ BEGIN { } $| = 1; -print "1..15\n"; +print "1..16\n"; # External program 'tr' assumed. open(PIPE, "|-") || (exec 'tr', 'YX', 'ko'); @@ -99,12 +99,23 @@ else { local $SIG{PIPE} = 'IGNORE'; open NIL, '|true' or die "open failed: $!"; sleep 5; - print NIL 'foo' or die "print failed: $!"; - if (close NIL) { - print "not ok 9\n"; + if (print NIL 'foo') { + # If print was allowed we had better get an error on close + if (close NIL) { + print "not ok 9\n"; + } + else { + print "ok 9\n"; + } } else { - print "ok 9\n"; + # If print failed, the close should be clean + if (close NIL) { + print "ok 9\n"; + } + else { + print "not ok 9\n"; + } } } @@ -174,3 +185,20 @@ if ($? != 42) { } print "ok 15\n"; $? = 0; + +# check that child is reaped if the piped program can't be executed +{ + open NIL, '/no_such_process |'; + close NIL; + + my $child = 0; + eval { + local $SIG{ALRM} = sub { die; }; + alarm 2; + $child = wait; + alarm 0; + }; + + print "not " if $child != -1; + print "ok 16\n"; +} diff --git a/t/io/tell.t b/t/io/tell.t index b89aefb230..560836d5e0 100755 --- a/t/io/tell.t +++ b/t/io/tell.t @@ -2,7 +2,7 @@ # $RCSfile: tell.t,v $$Revision$$Date$ -print "1..21\n"; +print "1..23\n"; $TST = 'tst'; @@ -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/t/io/utf8.t b/t/io/utf8.t new file mode 100755 index 0000000000..04554e7797 --- /dev/null +++ b/t/io/utf8.t @@ -0,0 +1,163 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + unless ($Config{'useperlio'}) { + print "1..0 # Skip: not perlio\n"; + exit 0; + } +} + +$| = 1; +print "1..25\n"; + +open(F,"+>:utf8",'a'); +print F chr(0x100).'£'; +print '#'.tell(F)."\n"; +print "not " unless tell(F) == 4; +print "ok 1\n"; +print F "\n"; +print '#'.tell(F)."\n"; +print "not " unless tell(F) >= 5; +print "ok 2\n"; +seek(F,0,0); +print "not " unless getc(F) eq chr(0x100); +print "ok 3\n"; +print "not " unless getc(F) eq "£"; +print "ok 4\n"; +print "not " unless getc(F) eq "\n"; +print "ok 5\n"; +seek(F,0,0); +binmode(F,":bytes"); +print "not " unless getc(F) eq chr(0xc4); +print "ok 6\n"; +print "not " unless getc(F) eq chr(0x80); +print "ok 7\n"; +print "not " unless getc(F) eq chr(0xc2); +print "ok 8\n"; +print "not " unless getc(F) eq chr(0xa3); +print "ok 9\n"; +print "not " unless getc(F) eq "\n"; +print "ok 10\n"; +seek(F,0,0); +binmode(F,":utf8"); +print "not " unless scalar(<F>) eq "\x{100}£\n"; +print "ok 11\n"; +seek(F,0,0); +$buf = chr(0x200); +$count = read(F,$buf,2,1); +print "not " unless $count == 2; +print "ok 12\n"; +print "not " unless $buf eq "\x{200}\x{100}£"; +print "ok 13\n"; +close(F); + +{ +$a = chr(300); # This *is* UTF-encoded +$b = chr(130); # This is not. + +open F, ">:utf8", 'a' or die $!; +print F $a,"\n"; +close F; + +open F, "<:utf8", 'a' or die $!; +$x = <F>; +chomp($x); +print "not " unless $x eq chr(300); +print "ok 14\n"; + +open F, "a" or die $!; # Not UTF +$x = <F>; +chomp($x); +print "not " unless $x eq chr(196).chr(172); +print "ok 15\n"; +close F; + +open F, ">:utf8", 'a' or die $!; +binmode(F); # we write a "\n" and then tell() - avoid CRLF issues. +print F $a; +my $y; +{ my $x = tell(F); + { use bytes; $y = length($a);} + print "not " unless $x == $y; + print "ok 16\n"; +} + +{ # Check byte length of $b +use bytes; my $y = length($b); +print "not " unless $y == 1; +print "ok 17\n"; +} + +print F $b,"\n"; # This upgrades $b! + +{ # Check byte length of $b +use bytes; my $y = length($b); +print "not " unless $y == 2; +print "ok 18\n"; +} + +{ my $x = tell(F); + { use bytes; $y += 3;} + print "not " unless $x == $y; + print "ok 19\n"; +} + +close F; + +open F, "a" or die $!; # Not UTF +$x = <F>; +chomp($x); +print "not " unless $x eq v196.172.194.130; +print "ok 20\n"; + +open F, "<:utf8", "a" or die $!; +$x = <F>; +chomp($x); +close F; +print "not " unless $x eq chr(300).chr(130); +print "ok 21\n"; + +# Now let's make it suffer. +open F, ">", "a" or die $!; +eval { print F $a; }; +print "not " unless $@ and $@ =~ /Wide character in print/i; +print "ok 22\n"; +} + +# Hm. Time to get more evil. +open F, ">:utf8", "a" or die $!; +print F $a; +binmode(F, ":bytes"); +print F chr(130)."\n"; +close F; + +open F, "<", "a" or die $!; +$x = <F>; chomp $x; +print "not " unless $x eq v196.172.130; +print "ok 23\n"; + +# Right. +open F, ">:utf8", "a" or die $!; +print F $a; +close F; +open F, ">>", "a" or die $!; +print F chr(130)."\n"; +close F; + +open F, "<", "a" or die $!; +$x = <F>; chomp $x; +print "not " unless $x eq v196.172.130; +print "ok 24\n"; + +# Now we have a deformed file. +open F, "<:utf8", "a" or die $!; +$x = <F>; chomp $x; +{ local $SIG{__WARN__} = sub { print "ok 25\n"; }; +eval { sprintf "%vd\n", $x; } +} + +unlink('a'); + diff --git a/t/lib/attrs.t b/t/lib/attrs.t index 440122c2b4..18a02aba84 100644 --- a/t/lib/attrs.t +++ b/t/lib/attrs.t @@ -11,9 +11,12 @@ BEGIN { } } +use warnings; +no warnings qw(deprecated); # else attrs cries. + sub NTESTS () ; -my $test, $ntests; +my ($test, $ntests); BEGIN {$ntests=0} $test=0; my $failed = 0; @@ -119,7 +122,7 @@ BEGIN {++$ntests} { my $w = "" ; - local $SIG{__WARN__} = sub {$w = @_[0]} ; + local $SIG{__WARN__} = sub {$w = shift} ; eval 'sub w1 ($) { use warnings "deprecated"; use attrs "locked"; $_[0]++ }'; (print "not "), $failed=1 if $@; print "ok ",++$test,"\n"; @@ -10,7 +10,7 @@ use warnings; use strict; use Config; -print "1..13\n"; +print "1..17\n"; my $test = 1; @@ -53,6 +53,20 @@ print "not " if $deparse->coderef2text(sub{$test = sub : method locked { 1 }}) ok; } +print "not " if (eval "sub ".$deparse->coderef2text(sub () { 42 }))->() != 42; +ok; + +use constant 'c', 'stuff'; +print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff'; +ok; + +# XXX ToDo - constsub that returns a reference +#use constant cr => ['hello']; +#my $string = "sub " . $deparse->coderef2text(\&cr); +#my $val = (eval $string)->(); +#print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello'; +#ok; + my $a; my $Is_VMS = $^O eq 'VMS'; $a = `$^X "-I../lib" "-MO=Deparse" -anle 1 2>&1`; @@ -62,26 +76,21 @@ $b = <<'EOF'; LINE: while (defined($_ = <ARGV>)) { chomp $_; @F = split(/\s+/, $_, 0); - '???' -} -continue { - '???' + '???'; } EOF print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b; ok; -#6 $a = `$^X "-I../lib" "-MO=Debug" -e 1 2>&1`; print "not " unless $a =~ /\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s; ok; -#7 $a = `$^X "-I../lib" "-MO=Terse" -e 1 2>&1`; print "not " unless $a =~ -/\bLISTOP\b.*leave.*\bOP\b.*enter.*\bCOP\b.*nextstate.*\bOP\b.*null/s; +/\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s; ok; $a = `$^X "-I../lib" "-MO=Terse" -ane "s/foo/bar/" 2>&1`; @@ -114,12 +123,13 @@ ok; chomp($a = `$^X "-I../lib" "-MB::Stash" "-Mwarnings" -e1`); $a = join ',', sort split /,/, $a; +$a =~ s/-u(perlio|open)(?:::\w+)?,//g if defined $Config{'useperlio'} and $Config{'useperlio'} eq 'define'; $a =~ s/-uWin32,// if $^O eq 'MSWin32'; $a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2'; $a =~ s/-uCwd,// if $^O eq 'cygwin'; if ($Config{static_ext} eq ' ') { $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,' - . '-umain,-uwarnings'; + . '-umain,-ustrict,-uwarnings'; print "# [$a] vs [$b]\nnot " if $a ne $b; ok; } else { @@ -133,3 +143,14 @@ if ($is_thread) { print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s; } ok; + +# Bug 20001204.07 +{ +my $foo = $deparse->coderef2text(sub { { 234; }}); +# Constants don't get optimised here. +print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm; +ok; +$foo = $deparse->coderef2text(sub { { 234; } continue { 123; } }); +print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm; +ok; +} diff --git a/t/lib/bigfltpm.t b/t/lib/bigfltpm.t index 20816940c4..b335d13016 100755 --- a/t/lib/bigfltpm.t +++ b/t/lib/bigfltpm.t @@ -449,10 +449,10 @@ $Math::BigFloat::div_scale = 20 $Math::BigFloat::div_scale = 40 &fsqrt +0:0 --1:/^(?i:0|\?|NaNQ?)$ --2:/^(?i:0|\?|NaNQ?)$ --16:/^(?i:0|\?|NaNQ?)$ --123.456:/^(?i:0|\?|NaNQ?)$ +-1:/^(?i:0|\?|-?N\.?aNQ?)$ +-2:/^(?i:0|\?|-?N\.?aNQ?)$ +-16:/^(?i:0|\?|-?N\.?aNQ?)$ +-123.456:/^(?i:0|\?|-?N\.?aNQ?)$ +1:1. +1.44:1.2 +2:1.41421356237309504880168872420969807857 diff --git a/t/lib/cgi-function.t b/t/lib/cgi-function.t index 653c4e55e6..3b9722e3bd 100755 --- a/t/lib/cgi-function.t +++ b/t/lib/cgi-function.t @@ -36,6 +36,11 @@ my $CRLF = "\015\012"; 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'; diff --git a/t/lib/cgi-html.t b/t/lib/cgi-html.t index 50c840816b..3d3da10b25 100755 --- a/t/lib/cgi-html.t +++ b/t/lib/cgi-html.t @@ -82,7 +82,12 @@ 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/t/lib/class-struct.t b/t/lib/class-struct.t new file mode 100644 index 0000000000..26505bacfc --- /dev/null +++ b/t/lib/class-struct.t @@ -0,0 +1,66 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..8\n"; + +package aClass; + +sub new { bless {}, shift } + +sub meth { 42 } + +package MyObj; + +use Class::Struct; +use Class::Struct 'struct'; # test out both forms + +use Class::Struct SomeClass => { SomeElem => '$' }; + +struct( s => '$', a => '@', h => '%', c => 'aClass' ); + +my $obj = MyObj->new; + +$obj->s('foo'); + +print "not " unless $obj->s() eq 'foo'; +print "ok 1\n"; + +my $arf = $obj->a; + +print "not " unless ref $arf eq 'ARRAY'; +print "ok 2\n"; + +$obj->a(2, 'secundus'); + +print "not " unless $obj->a(2) eq 'secundus'; +print "ok 3\n"; + +my $hrf = $obj->h; + +print "not " unless ref $hrf eq 'HASH'; +print "ok 4\n"; + +$obj->h('x', 10); + +print "not " unless $obj->h('x') == 10; +print "ok 5\n"; + +my $orf = $obj->c; + +print "not " unless ref $orf eq 'aClass'; +print "ok 6\n"; + +print "not " unless $obj->c->meth() == 42; +print "ok 7\n"; + +my $obk = SomeClass->new(); + +$obk->SomeElem(123); + +print "not " unless $obk->SomeElem() == 123; +print "ok 8\n"; + diff --git a/t/lib/db-btree.t b/t/lib/db-btree.t index 75c661bbee..1822823563 100755 --- a/t/lib/db-btree.t +++ b/t/lib/db-btree.t @@ -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/t/lib/db-hash.t b/t/lib/db-hash.t index b7018742e4..effc60b7dd 100755 --- a/t/lib/db-hash.t +++ b/t/lib/db-hash.t @@ -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/t/lib/db-recno.t b/t/lib/db-recno.t index 18fb45b114..8b5a88cc6d 100755 --- a/t/lib/db-recno.t +++ b/t/lib/db-recno.t @@ -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/t/lib/dprof.t b/t/lib/dprof.t index 10c9b0fa16..be711f1330 100755 --- a/t/lib/dprof.t +++ b/t/lib/dprof.t @@ -11,7 +11,8 @@ BEGIN { } END { - unlink 'tmon.out', 'err'; + while(-e 'tmon.out' && unlink 'tmon.out') {} + while(-e 'err' && unlink 'err') {} } use Benchmark qw( timediff timestr ); @@ -22,7 +23,7 @@ getopts('vI:p:'); # -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 ); @@ -46,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 ); @@ -56,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; } @@ -72,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/t/lib/dprof/V.pm b/t/lib/dprof/V.pm index 7e34da5d47..cbdeca4eda 100644 --- a/t/lib/dprof/V.pm +++ b/t/lib/dprof/V.pm @@ -13,6 +13,7 @@ $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?" } @@ -21,7 +22,7 @@ if( ! -f $dpp ){ die "Where's dprofpp?" } 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/t/lib/encode.t b/t/lib/encode.t index 568efd31f5..280c2d0ed5 100644 --- a/t/lib/encode.t +++ b/t/lib/encode.t @@ -12,7 +12,11 @@ use Encode qw(from_to); use charnames qw(greek); my @encodings = grep(/iso8859/,Encode::encodings()); my $n = 2; -plan test => 13+$n*@encodings; +my @character_set = ('0'..'9', 'A'..'Z', 'a'..'z'); +my @source = qw(ascii iso8859-1 cp1250); +my @destiny = qw(cp1047 cp37 posix-bc); +my @ebcdic_sets = qw(cp1047 cp37 posix-bc); +plan test => 21+$n*@encodings + 2*@source*@destiny*@character_set + 2*@ebcdic_sets*256; my $str = join('',map(chr($_),0x20..0x7E)); my $cpy = $str; ok(length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong"); @@ -27,7 +31,7 @@ ok(length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong"); my $sym = Encode->getEncoding('symbol'); my $uni = $sym->toUnicode('a'); -ok("\N{alpha}",substr($uni,0,1),"alpha does not map so symbol 'a'"); +ok("\N{alpha}",substr($uni,0,1),"alpha does not map to symbol 'a'"); $str = $sym->fromUnicode("\N{Beta}"); ok("B",substr($str,0,1),"Symbol 'B' does not map to Beta"); @@ -41,3 +45,58 @@ foreach my $enc (qw(symbol dingbats ascii),@encodings) ok($cpy,$str,"$enc mangled translating to Unicode and back"); } +# On ASCII based machines see if we can map several codepoints from +# three distinct ASCII sets to three distinct EBCDIC coded character sets. +# On EBCDIC machines see if we can map from three EBCDIC sets to three +# distinct ASCII sets. + +my @expectation = (240..249, 193..201,209..217,226..233, 129..137,145..153,162..169); +if (ord('A') != 65) { + my @temp = @destiny; + @destiny = @source; + @source = @temp; + undef(@temp); + @expectation = (48..57, 65..90, 97..122); +} + +foreach my $to (@destiny) + { + foreach my $from (@source) + { + my @expected = @expectation; + foreach my $chr (@character_set) + { + my $native_chr = $chr; + my $cpy = $chr; + my $rc = from_to($cpy,$from,$to); + ok(1,$rc,"Could not translate from $from to $to"); + ok(ord($cpy),shift(@expected),"mangled translating $native_chr from $from to $to"); + } + } + } + +# On either ASCII or EBCDIC machines ensure we can take the full one +# byte repetoire to EBCDIC sets and back. + +my $enc_as = 'iso8859-1'; +foreach my $enc_eb (@ebcdic_sets) + { + foreach my $ord (0..255) + { + $str = chr($ord); + my $rc = from_to($str,$enc_as,$enc_eb); + $rc += from_to($str,$enc_eb,$enc_as); + ok($rc,2,"return code for $ord $enc_eb -> $enc_as -> $enc_eb was not obtained"); + ok($ord,ord($str),"$enc_as mangled translating $ord to $enc_eb and back"); + } + } + +for $i (256,128,129,256) + { + my $c = chr($i); + my $s = "$c\n".sprintf("%02X",$i); + ok(Encode::valid_utf8($s),1,"concat of $i botched"); + Encode::utf8_upgrade($s); + ok(Encode::valid_utf8($s),1,"concat of $i botched"); + } + diff --git a/t/lib/filter-util.pl b/t/lib/filter-util.pl new file mode 100644 index 0000000000..9b29c5ef52 --- /dev/null +++ b/t/lib/filter-util.pl @@ -0,0 +1,48 @@ +sub readFile +{ + my ($filename) = @_ ; + my ($string) = '' ; + + open (F, "<$filename") + or die "Cannot open $filename: $!\n" ; + while (<F>) + { $string .= $_ } + close F ; + $string ; +} + +sub writeFile +{ + my($filename, @strings) = @_ ; + open (F, ">$filename") + or die "Cannot open $filename: $!\n" ; + binmode(F) if $filename =~ /bin$/i; + foreach (@strings) + { print F } + close F ; +} + +sub ok +{ + my($number, $result, $note) = @_ ; + + $note = "" if ! defined $note ; + if ($note) { + $note = "# $note" if $note !~ /^\s*#/ ; + $note =~ s/^\s*/ / ; + } + + print "not " if !$result ; + print "ok ${number}${note}\n"; +} + +$Inc = '' ; +foreach (@INC) + { $Inc .= "\"-I$_\" " } + +$Perl = '' ; +$Perl = ($ENV{'FULLPERL'} or $^X or 'perl') ; + +$Perl = "$Perl -w" ; + +1; diff --git a/t/lib/filter-util.t b/t/lib/filter-util.t new file mode 100644 index 0000000000..80c8f56a24 --- /dev/null +++ b/t/lib/filter-util.t @@ -0,0 +1,791 @@ +BEGIN { + chdir('t') if -d 't'; + @INC = '.'; + push @INC, '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ m{\bFilter/Util/Call\b}) { + print "1..0 # Skip: Filter::Util::Call was not built\n"; + exit 0; + } + require 'lib/filter-util.pl'; +} + +print "1..28\n" ; + +$Perl = "$Perl -w" ; + +use Cwd ; +$here = getcwd ; + +use vars qw($Inc $Perl); + +$filename = "call.tst" ; +$filenamebin = "call.bin" ; +$module = "MyTest" ; +$module2 = "MyTest2" ; +$module3 = "MyTest3" ; +$module4 = "MyTest4" ; +$module5 = "MyTest5" ; +$nested = "nested" ; +$block = "block" ; + +# Test error cases +################## + +# no filter function in module +############################### + +writeFile("${module}.pm", <<EOM) ; +package ${module} ; + +use Filter::Util::Call ; + +sub import { filter_add(bless []) } + +1 ; +EOM + +$a = `$Perl "-I." $Inc -e "use ${module} ;" 2>&1` ; +ok(1, (($? >>8) != 0 or ($^O eq 'MSWin32' && $? != 0))) ; +ok(2, $a =~ /^Can't locate object method "filter" via package "MyTest"/) ; + +# no reference parameter in filter_add +###################################### + +writeFile("${module}.pm", <<EOM) ; +package ${module} ; + +use Filter::Util::Call ; + +sub import { filter_add() } + +1 ; +EOM + +$a = `$Perl "-I." $Inc -e "use ${module} ;" 2>&1` ; +ok(3, (($? >>8) != 0 or ($^O eq 'MSWin32' && $? != 0))) ; +#ok(4, $a =~ /^usage: filter_add\(ref\) at ${module}.pm/) ; +ok(4, $a =~ /^Not enough arguments for Filter::Util::Call::filter_add/) ; + + + + +# non-error cases +################# + + +# a simple filter, using a closure +################# + +writeFile("${module}.pm", <<EOM, <<'EOM') ; +package ${module} ; + +EOM +use Filter::Util::Call ; +sub import { + filter_add( + sub { + + my ($status) ; + + if (($status = filter_read()) > 0) { + s/ABC/DEF/g + } + $status ; + } ) ; +} + +1 ; +EOM + +writeFile($filename, <<EOM, <<'EOM') ; + +use $module ; +EOM + +use Cwd ; +$here = getcwd ; +print "I am $here\n" ; +print "some letters ABC\n" ; +$y = "ABCDEF" ; +print <<EOF ; +Alphabetti Spagetti ($y) +EOF + +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(5, ($? >>8) == 0) ; +ok(6, $a eq <<EOM) ; +I am $here +some letters DEF +Alphabetti Spagetti (DEFDEF) +EOM + +# a simple filter, not using a closure +################# + +writeFile("${module}.pm", <<EOM, <<'EOM') ; +package ${module} ; + +EOM +use Filter::Util::Call ; +sub import { filter_add(bless []) } + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + if (($status = filter_read()) > 0) { + s/ABC/DEF/g + } + $status ; +} + + +1 ; +EOM + +writeFile($filename, <<EOM, <<'EOM') ; + +use $module ; +EOM + +use Cwd ; +$here = getcwd ; +print "I am $here\n" ; +print "some letters ABC\n" ; +$y = "ABCDEF" ; +print <<EOF ; +Alphabetti Spagetti ($y) +EOF + +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(7, ($? >>8) == 0) ; +ok(8, $a eq <<EOM) ; +I am $here +some letters DEF +Alphabetti Spagetti (DEFDEF) +EOM + + +# nested filters +################ + + +writeFile("${module2}.pm", <<EOM, <<'EOM') ; +package ${module2} ; +use Filter::Util::Call ; + +EOM +sub import { filter_add(bless []) } + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + if (($status = filter_read()) > 0) { + s/XYZ/PQR/g + } + $status ; +} + +1 ; +EOM + +writeFile("${module3}.pm", <<EOM, <<'EOM') ; +package ${module3} ; +use Filter::Util::Call ; + +EOM +sub import { filter_add( + + sub + { + my ($status) ; + + if (($status = filter_read()) > 0) { + s/Fred/Joe/g + } + $status ; + } ) ; +} + +1 ; +EOM + +writeFile("${module4}.pm", <<EOM) ; +package ${module4} ; + +use $module5 ; + +print "I'm feeling used!\n" ; +print "Fred Joe ABC DEF PQR XYZ\n" ; +print "See you Today\n" ; +1; +EOM + +writeFile("${module5}.pm", <<EOM, <<'EOM') ; +package ${module5} ; +use Filter::Util::Call ; + +EOM +sub import { filter_add(bless []) } + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + if (($status = filter_read()) > 0) { + s/Today/Tomorrow/g + } + $status ; +} + +1 ; +EOM + +writeFile($filename, <<EOM, <<'EOM') ; + +# two filters for this file +use $module ; +use $module2 ; +require "$nested" ; +use $module4 ; +EOM + +print "some letters ABCXYZ\n" ; +$y = "ABCDEFXYZ" ; +print <<EOF ; +Fred likes Alphabetti Spagetti ($y) +EOF + +EOM + +writeFile($nested, <<EOM, <<'EOM') ; +use $module3 ; +EOM + +print "This is another file XYZ\n" ; +print <<EOF ; +Where is Fred? +EOF + +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(9, ($? >>8) == 0) ; +ok(10, $a eq <<EOM) ; +I'm feeling used! +Fred Joe ABC DEF PQR XYZ +See you Tomorrow +This is another file XYZ +Where is Joe? +some letters DEFPQR +Fred likes Alphabetti Spagetti (DEFDEFPQR) +EOM + +# using the module context (with a closure) +########################################### + + +writeFile("${module2}.pm", <<EOM, <<'EOM') ; +package ${module2} ; +use Filter::Util::Call ; + +EOM +sub import +{ + my ($type) = shift ; + my (@strings) = @_ ; + + + filter_add ( + + sub + { + my ($status) ; + my ($pattern) ; + + if (($status = filter_read()) > 0) { + foreach $pattern (@strings) + { s/$pattern/PQR/g } + } + + $status ; + } + ) + +} +1 ; +EOM + + +writeFile($filename, <<EOM, <<'EOM') ; + +use $module2 qw( XYZ KLM) ; +use $module2 qw( ABC NMO) ; +EOM + +print "some letters ABCXYZ KLM NMO\n" ; +$y = "ABCDEFXYZKLMNMO" ; +print <<EOF ; +Alphabetti Spagetti ($y) +EOF + +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(11, ($? >>8) == 0) ; +ok(12, $a eq <<EOM) ; +some letters PQRPQR PQR PQR +Alphabetti Spagetti (PQRDEFPQRPQRPQR) +EOM + + + +# using the module context (without a closure) +############################################## + + +writeFile("${module2}.pm", <<EOM, <<'EOM') ; +package ${module2} ; +use Filter::Util::Call ; + +EOM +sub import +{ + my ($type) = shift ; + my (@strings) = @_ ; + + + filter_add (bless [@strings]) +} + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + my ($pattern) ; + + if (($status = filter_read()) > 0) { + foreach $pattern (@$self) + { s/$pattern/PQR/g } + } + + $status ; +} + +1 ; +EOM + + +writeFile($filename, <<EOM, <<'EOM') ; + +use $module2 qw( XYZ KLM) ; +use $module2 qw( ABC NMO) ; +EOM + +print "some letters ABCXYZ KLM NMO\n" ; +$y = "ABCDEFXYZKLMNMO" ; +print <<EOF ; +Alphabetti Spagetti ($y) +EOF + +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(13, ($? >>8) == 0) ; +ok(14, $a eq <<EOM) ; +some letters PQRPQR PQR PQR +Alphabetti Spagetti (PQRDEFPQRPQRPQR) +EOM + +# multi line test +################# + + +writeFile("${module2}.pm", <<EOM, <<'EOM') ; +package ${module2} ; +use Filter::Util::Call ; + +EOM +sub import +{ + my ($type) = shift ; + my (@strings) = @_ ; + + + filter_add(bless []) +} + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + # read first line + if (($status = filter_read()) > 0) { + chop ; + s/\r$//; + # and now the second line (it will append) + $status = filter_read() ; + } + + $status ; +} + +1 ; +EOM + + +writeFile($filename, <<EOM, <<'EOM') ; + +use $module2 ; +EOM +print "don't cut me +in half\n" ; +print +<<EOF ; +appen +ded +EO +F + +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(15, ($? >>8) == 0) ; +ok(16, $a eq <<EOM) ; +don't cut me in half +appended +EOM + +# Block test +############# + +writeFile("${block}.pm", <<EOM, <<'EOM') ; +package ${block} ; +use Filter::Util::Call ; + +EOM +sub import +{ + my ($type) = shift ; + my (@strings) = @_ ; + + + filter_add (bless [@strings] ) +} + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + my ($pattern) ; + + filter_read(20) ; +} + +1 ; +EOM + +$string = <<'EOM' ; +print "hello mum\n" ; +$x = 'me ' x 3 ; +print "Who wants it?\n$x\n" ; +EOM + + +writeFile($filename, <<EOM, $string ) ; +use $block ; +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(17, ($? >>8) == 0) ; +ok(18, $a eq <<EOM) ; +hello mum +Who wants it? +me me me +EOM + +# use in the filter +#################### + +writeFile("${block}.pm", <<EOM, <<'EOM') ; +package ${block} ; +use Filter::Util::Call ; + +EOM +use Cwd ; + +sub import +{ + my ($type) = shift ; + my (@strings) = @_ ; + + + filter_add(bless [@strings] ) +} + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + my ($here) = quotemeta getcwd ; + + if (($status = filter_read()) > 0) { + s/DIR/$here/g + } + $status ; +} + +1 ; +EOM + +writeFile($filename, <<EOM, <<'EOM') ; +use $block ; +EOM +print "We are in DIR\n" ; +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(19, ($? >>8) == 0) ; +ok(20, $a eq <<EOM) ; +We are in $here +EOM + + +# filter_del +############# + +writeFile("${block}.pm", <<EOM, <<'EOM') ; +package ${block} ; +use Filter::Util::Call ; + +EOM + +sub import +{ + my ($type) = shift ; + my ($count) = @_ ; + + + filter_add(bless \$count ) +} + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + s/HERE/THERE/g + if ($status = filter_read()) > 0 ; + + -- $$self ; + filter_del() if $$self <= 0 ; + + $status ; +} + +1 ; +EOM + +writeFile($filename, <<EOM, <<'EOM') ; +use $block (3) ; +EOM +print " +HERE I am +I am HERE +HERE today gone tomorrow\n" ; +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(21, ($? >>8) == 0) ; +ok(22, $a eq <<EOM) ; + +THERE I am +I am THERE +HERE today gone tomorrow +EOM + + +# filter_read_exact +#################### + +writeFile("${block}.pm", <<EOM, <<'EOM') ; +package ${block} ; +use Filter::Util::Call ; + +EOM + +sub import +{ + my ($type) = shift ; + + filter_add(bless [] ) +} + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + if (($status = filter_read_exact(9)) > 0) { + s/HERE/THERE/g + } + + $status ; +} + +1 ; +EOM + +writeFile($filenamebin, <<EOM, <<'EOM') ; +use $block ; +EOM +print " +HERE I am +I'm HERE +HERE today gone tomorrow\n" ; +EOM + +$a = `$Perl "-I." $Inc $filenamebin 2>&1` ; +ok(23, ($? >>8) == 0) ; +ok(24, $a eq <<EOM) ; + +HERE I am +I'm THERE +THERE today gone tomorrow +EOM + +{ + +# Check __DATA__ +#################### + +writeFile("${block}.pm", <<EOM, <<'EOM') ; +package ${block} ; +use Filter::Util::Call ; + +EOM + +sub import +{ + my ($type) = shift ; + + filter_add(bless [] ) +} + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + if (($status = filter_read()) > 0) { + s/HERE/THERE/g + } + + $status ; +} + +1 ; +EOM + +writeFile($filename, <<EOM, <<'EOM') ; +use $block ; +EOM +print "HERE HERE\n"; +@a = <DATA>; +print @a; +__DATA__ +HERE I am +I'm HERE +HERE today gone tomorrow +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(25, ($? >>8) == 0) ; +ok(26, $a eq <<EOM) ; +THERE THERE +HERE I am +I'm HERE +HERE today gone tomorrow +EOM + +} + +{ + +# Check __END__ +#################### + +writeFile("${block}.pm", <<EOM, <<'EOM') ; +package ${block} ; +use Filter::Util::Call ; + +EOM + +sub import +{ + my ($type) = shift ; + + filter_add(bless [] ) +} + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + if (($status = filter_read()) > 0) { + s/HERE/THERE/g + } + + $status ; +} + +1 ; +EOM + +writeFile($filename, <<EOM, <<'EOM') ; +use $block ; +EOM +print "HERE HERE\n"; +@a = <DATA>; +print @a; +__END__ +HERE I am +I'm HERE +HERE today gone tomorrow +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(27, ($? >>8) == 0) ; +ok(28, $a eq <<EOM) ; +THERE THERE +HERE I am +I'm HERE +HERE today gone tomorrow +EOM + +} + +END { + 1 while unlink $filename ; + 1 while unlink $filenamebin ; + 1 while unlink "${module}.pm" ; + 1 while unlink "${module2}.pm" ; + 1 while unlink "${module3}.pm" ; + 1 while unlink "${module4}.pm" ; + 1 while unlink "${module5}.pm" ; + 1 while unlink $nested ; + 1 while unlink "${block}.pm" ; +} + + diff --git a/t/lib/ftmp-mktemp.t b/t/lib/ftmp-mktemp.t index 9503ea7585..2209baa025 100755 --- a/t/lib/ftmp-mktemp.t +++ b/t/lib/ftmp-mktemp.t @@ -15,6 +15,7 @@ use strict; use File::Spec; use File::Path; use File::Temp qw/ :mktemp unlink0 /; +use FileHandle; ok(1); diff --git a/t/lib/ftmp-posix.t b/t/lib/ftmp-posix.t index 2e455861e9..bc3845c22b 100755 --- a/t/lib/ftmp-posix.t +++ b/t/lib/ftmp-posix.t @@ -11,6 +11,8 @@ BEGIN { use strict; use File::Temp qw/ :POSIX unlink0 /; +use FileHandle; + ok(1); # TMPNAM - scalar diff --git a/t/lib/ftmp-tempfile.t b/t/lib/ftmp-tempfile.t index 48a52b3c92..ed59765a75 100755 --- a/t/lib/ftmp-tempfile.t +++ b/t/lib/ftmp-tempfile.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require Test; import Test; - plan(tests => 16); + plan(tests => 20); } use strict; @@ -51,6 +51,10 @@ my ($fh, $tempfile) = tempfile( ); ok( (-f $tempfile) ); +# Should still be around after closing +ok( close( $fh ) ); +ok( (-f $tempfile) ); +# Check again at exit push(@files, $tempfile); # TEMPDIR test @@ -113,5 +117,29 @@ ok( -f $tempfile ); ok( close( $fh ) ); push( @still_there, $tempfile); # check at END +# Would like to create a temp file and just retrieve the handle +# but the test is problematic since: +# - We dont know the filename so we cant check that it is tidied +# correctly +# - The unlink0 required on unix for tempfile creation will fail +# on NFS +# Try to do what we can. +# Tempfile croaks on error so we need an eval +$fh = eval { tempfile( 'ftmpXXXXX', DIR => File::Spec->tmpdir ) }; + +if ($fh) { + + # print something to it to make sure something is there + ok( print $fh "Test\n" ); + + # Close it - can not check it is gone since we dont know the name + ok( close($fh) ); + +} else { + skip "Skip Failed probably due to NFS", 1; + skip "Skip Failed probably due to NFS", 1; +} + # Now END block will execute to test the removal of directories +print "# End of tests. Execute END blocks\n"; diff --git a/t/lib/gdbm.t b/t/lib/gdbm.t index 54f59946b7..af83fdda81 100755 --- a/t/lib/gdbm.t +++ b/t/lib/gdbm.t @@ -13,7 +13,7 @@ BEGIN { use GDBM_File; -print "1..66\n"; +print "1..68\n"; unlink <Op.dbmx*>; @@ -178,6 +178,7 @@ EOM close FILE ; BEGIN { push @INC, '.'; } + unlink <dbhash.tmp*> ; eval 'use SubDB ; '; main::ok(13, $@ eq "") ; @@ -392,3 +393,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/t/lib/io_sock.t b/t/lib/io_sock.t index 5a8e16c313..38292a7a59 100755 --- a/t/lib/io_sock.t +++ b/t/lib/io_sock.t @@ -30,7 +30,7 @@ BEGIN { } $| = 1; -print "1..14\n"; +print "1..20\n"; use IO::Socket; @@ -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,10 +150,14 @@ 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"); + } else { + print "not ok 11\n"; } $sock = undef; sleep(1); @@ -166,7 +169,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 +185,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 @@ -195,3 +203,131 @@ print "ok 13\n"; $server->blocking(0); print "not " if $server->blocking; print "ok 14\n"; + +### TEST 15 +### Set up some data to be transfered between the server and +### the client. We'll use own source code ... +# +local @data; +if( !open( SRC, "< $0")) { + print "not ok 15 - $!"; +} else { + @data = <SRC>; + close( SRC); +} +print "ok 15\n"; + +### TEST 16 +### Start the server +# +my $listen = IO::Socket::INET->new( Listen => 2, Proto => 'tcp', Timeout => 15) || + print "not "; +print "ok 16\n"; +die if( !defined( $listen)); +my $serverport = $listen->sockport; + +my $server_pid = fork(); +if( $server_pid) { + + ### TEST 17 Client/Server establishment + # + print "ok 17\n"; + + ### TEST 18 + ### Get data from the server using a single stream + # + $sock = IO::Socket::INET->new("localhost:$serverport") + || IO::Socket::INET->new("127.0.0.1:$serverport"); + + if ($sock) { + $sock->print("send\n"); + + my @array = (); + while( <$sock>) { + push( @array, $_); + } + + $sock->print("done\n"); + $sock->close; + + print "not " if( @array != @data); + } else { + print "not "; + } + print "ok 18\n"; + + ### TEST 19 + ### Get data from the server using a stream, which is + ### interrupted by eof calls. + ### On perl-5.7.0@7673 this failed in a SOCKS environment, because eof + ### did an getc followed by an ungetc in order to check for the streams + ### end. getc(3) got replaced by the SOCKS funktion, which ended up in + ### a recv(2) call on the socket, while ungetc(3) put back a character + ### to an IO buffer, which never again was read. + # + $sock = IO::Socket::INET->new("localhost:$serverport") + || IO::Socket::INET->new("127.0.0.1:$serverport"); + + if ($sock) { + $sock->print("send\n"); + + my @array = (); + while( !eof( $sock ) ){ + while( <$sock>) { + push( @array, $_); + last; + } + } + + $sock->print("done\n"); + $sock->close; + + print "not " if( @array != @data); + } else { + print "not "; + } + print "ok 19\n"; + + ### TEST 20 + ### Stop the server + # + $sock = IO::Socket::INET->new("localhost:$serverport") + || IO::Socket::INET->new("127.0.0.1:$serverport"); + + if ($sock) { + $sock->print("done\n"); + $sock->close; + + print "not " if( 1 != kill 0, $server_pid); + } else { + print "not "; + } + print "ok 20\n"; + +} elsif( defined( $server_pid)) { + + ### Child + # + SERVER_LOOP: while (1) { + last SERVER_LOOP unless $sock = $listen->accept; + while (<$sock>) { + last SERVER_LOOP if /^quit/; + last if /^done/; + if( /^send/) { + print $sock @data; + last; + } + print; + } + $sock = undef; + } + $listen->close; + +} else { + + ### Fork failed + # + print "not ok 17\n"; + die; +} + diff --git a/t/lib/io_tell.t b/t/lib/io_tell.t index 3aa4b031e1..65c63bdfc9 100755 --- a/t/lib/io_tell.t +++ b/t/lib/io_tell.t @@ -27,7 +27,7 @@ print "1..13\n"; use IO::File; $tst = IO::File->new("$tell_file","r") || die("Can't open $tell_file"); -binmode $tst if ($^O eq 'MSWin32' or $^O eq 'dos'); +binmode $tst; # its a nop unless it matters. Was only if ($^O eq 'MSWin32' or $^O eq 'dos'); if ($tst->eof) { print "not ok 1\n"; } else { print "ok 1\n"; } $firstline = <$tst>; diff --git a/t/lib/io_udp.t b/t/lib/io_udp.t index 9df62cfbaf..d63a5dcf7b 100755 --- a/t/lib/io_udp.t +++ b/t/lib/io_udp.t @@ -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/t/lib/io_xs.t b/t/lib/io_xs.t index 9305c31986..2449fc45c1 100755 --- a/t/lib/io_xs.t +++ b/t/lib/io_xs.t @@ -40,3 +40,4 @@ print scalar <$x>; $! = 0; $x->setpos(undef); print $! ? "ok 4 # $!\n" : "not ok 4\n"; + diff --git a/t/lib/ndbm.t b/t/lib/ndbm.t index 4937a8ce31..a8344444c8 100755 --- a/t/lib/ndbm.t +++ b/t/lib/ndbm.t @@ -16,7 +16,7 @@ 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*>; @@ -391,3 +391,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/t/lib/net-hostent.t b/t/lib/net-hostent.t new file mode 100644 index 0000000000..abc5b9292f --- /dev/null +++ b/t/lib/net-hostent.t @@ -0,0 +1,72 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bSocket\b/ && + !(($^O eq 'VMS') && $Config{d_socket})) { + print "1..0 # Test uses Socket, Socket not built\n"; + exit 0; + } +} + +BEGIN { $| = 1; print "1..7\n"; } + +END {print "not ok 1\n" unless $loaded;} + +use Net::hostent; + +$loaded = 1; +print "ok 1\n"; + +# test basic resolution of localhost <-> 127.0.0.1 +use Socket; + +my $h = gethost('localhost'); +print +(defined $h ? '' : 'not ') . "ok 2\n"; +my $i = gethostbyaddr(inet_aton("127.0.0.1")); +print +(!defined $i ? 'not ' : '') . "ok 3\n"; + +print "not " if inet_ntoa($h->addr) ne "127.0.0.1"; +print "ok 4\n"; + +print "not " if inet_ntoa($i->addr) ne "127.0.0.1"; +print "ok 5\n"; + +# need to skip the name comparisons on Win32 because windows will +# return the name of the machine instead of "localhost" when resolving +# 127.0.0.1 or even "localhost" + +# VMS returns "LOCALHOST" under tcp/ip services V4.1 ECO 2, possibly others +# OS/390 returns localhost.YADDA.YADDA + +if ($^O eq 'MSWin32' or $^O eq 'cygwin') { + print "ok $_ # skipped on win32\n" for (6,7); +} else { + my $in_alias; + unless ($h->name =~ /^localhost(?:\..+)?$/i) { + foreach (@{$h->aliases}) { + if (/^localhost(?:\..+)?$/i) { + $in_alias = 1; + last; + } + } + print "not " unless $in_alias; + } # Else we found it as the hostname + print "ok 6 # ",$h->name, " ", join (",", @{$h->aliases}), "\n"; + + if ($in_alias) { + # If we found it in the aliases before, expect to find it there again. + foreach (@{$h->aliases}) { + if (/^localhost(?:\..+)?$/i) { + undef $in_alias; # This time, clear the flag if we see "localhost" + last; + } + } + print "not " if $in_alias; + } else { + print "not " unless $i->name =~ /^localhost(?:\..+)?$/i; + } + print "ok 7 # ",$h->name, " ", join (",", @{$h->aliases}), "\n"; +} diff --git a/t/lib/odbm.t b/t/lib/odbm.t index ccd3e60319..f2c1bb6d32 100755 --- a/t/lib/odbm.t +++ b/t/lib/odbm.t @@ -16,7 +16,7 @@ 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*>; @@ -394,6 +394,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/t/lib/peek.t b/t/lib/peek.t index a90574f744..288d3bdf6d 100644 --- a/t/lib/peek.t +++ b/t/lib/peek.t @@ -88,10 +88,10 @@ do_test( 5, do_test( 6, $c + $d, -'SV = NV\\($ADDR\\) at $ADDR +'SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(PADTMP,NOK,pNOK\\) - NV = 456'); + FLAGS = \\(PADTMP,IOK,pIOK\\) + IV = 456'); ($d = "789") += 0.1; @@ -110,8 +110,8 @@ do_test( 8, 0xabcd, 'SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(.*IOK,READONLY,pIOK,IsUV\\) - UV = 43981'); + FLAGS = \\(.*IOK,READONLY,pIOK\\) + IV = 43981'); do_test( 9, undef, @@ -154,12 +154,10 @@ do_test(11, FLAGS = \\(IOK,pIOK\\) IV = 123 Elt No. 1 - SV = PVNV\\($ADDR\\) at $ADDR + SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(IOK,NOK,pIOK,pNOK\\) - IV = 456 - NV = 456 - PV = 0'); + FLAGS = \\(IOK,pIOK\\) + IV = 456'); do_test(12, {$b=>$c}, @@ -180,12 +178,10 @@ do_test(12, RITER = -1 EITER = 0x0 Elt "123" HASH = $ADDR - SV = PVNV\\($ADDR\\) at $ADDR + SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(IOK,NOK,pIOK,pNOK\\) - IV = 456 - NV = 456 - PV = 0'); + FLAGS = \\(IOK,pIOK\\) + IV = 456'); do_test(13, sub(){@_}, diff --git a/t/lib/sdbm.t b/t/lib/sdbm.t index b6a1a69de0..d60447e960 100755 --- a/t/lib/sdbm.t +++ b/t/lib/sdbm.t @@ -15,7 +15,7 @@ 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.*>; @@ -396,3 +396,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/t/lib/st-lock.t b/t/lib/st-lock.t index 28fe66490e..77d73bbb79 100644 --- a/t/lib/st-lock.t +++ b/t/lib/st-lock.t @@ -1,10 +1,19 @@ #!./perl -# $Id: lock.t,v 1.0.1.1 2000/09/28 21:44:06 ram Exp $ +# $Id: lock.t,v 1.0.1.4 2001/01/03 09:41:00 ram Exp $ # # @COPYRIGHT@ # # $Log: lock.t,v $ +# Revision 1.0.1.4 2001/01/03 09:41:00 ram +# patch7: use new CAN_FLOCK routine to determine whether to run tests +# +# Revision 1.0.1.3 2000/10/26 17:11:27 ram +# patch5: just check $^O, there's no need for the whole Config +# +# Revision 1.0.1.2 2000/10/23 18:03:07 ram +# patch4: protected calls to flock() for dos platform +# # Revision 1.0.1.1 2000/09/28 21:44:06 ram # patch2: created. # @@ -19,10 +28,7 @@ sub BEGIN { print "1..0 # Skip: Storable was not built\n"; exit 0; } - if (!$Config{'d_flock'} && !$Config{'d_fcntl'} && !$Config{'d_lockf'}) { - print "1..0 # Skip: no flock or flock emulation on this platform\n"; - exit 0; - } + require 'lib/st-dump.pl'; } @@ -30,6 +36,11 @@ sub ok; use Storable qw(lock_store lock_retrieve); +unless (&Storable::CAN_FLOCK) { + print "1..0 # Skip: fcntl/flock emulation broken on this platform\n"; + exit 0; +} + print "1..5\n"; @a = ('first', undef, 3, -4, -3.14159, 456, 4.5); diff --git a/t/lib/st-recurse.t b/t/lib/st-recurse.t index dcf6d1a029..b42974748e 100644 --- a/t/lib/st-recurse.t +++ b/t/lib/st-recurse.t @@ -1,6 +1,6 @@ #!./perl -# $Id: recurse.t,v 1.0.1.1 2000/09/17 16:48:05 ram Exp $ +# $Id: recurse.t,v 1.0.1.2 2000/11/05 17:22:05 ram Exp ram $ # # Copyright (c) 1995-2000, Raphael Manfredi # @@ -8,6 +8,10 @@ # in the README file that comes with the distribution. # # $Log: recurse.t,v $ +# Revision 1.0.1.2 2000/11/05 17:22:05 ram +# patch6: stress hook a little more with refs to lexicals +# +# $Log: recurse.t,v $ # Revision 1.0.1.1 2000/09/17 16:48:05 ram # patch1: added test case for store hook bug # @@ -97,15 +101,19 @@ sub make { sub STORABLE_freeze { my $self = shift; - my $t = dclone($self->{sync}); - return ("", [$t, $self->{ext}], $self, $self->{ext}); + my %copy = %$self; + my $r = \%copy; + my $t = dclone($r->{sync}); + return ("", [$t, $self->{ext}], $r, $self, $r->{ext}); } sub STORABLE_thaw { my $self = shift; - my ($cloning, $undef, $a, $obj, $ext) = @_; + my ($cloning, $undef, $a, $r, $obj, $ext) = @_; die "STORABLE_thaw #1" unless $obj eq $self; die "STORABLE_thaw #2" unless ref $a eq 'ARRAY'; + die "STORABLE_thaw #3" unless ref $r eq 'HASH'; + die "STORABLE_thaw #4" unless $a->[1] == $r->{ext}; $self->{ok} = $self; ($self->{sync}, $self->{ext}) = @$a; } diff --git a/t/lib/syslfs.t b/t/lib/syslfs.t index 96625f2c88..2bdb69d7e0 100644 --- a/t/lib/syslfs.t +++ b/t/lib/syslfs.t @@ -14,6 +14,11 @@ BEGIN { 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 # Skip: 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 # Skip: 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(); } @@ -120,9 +132,8 @@ sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET); unless (! $r && defined $sysseek && $sysseek == 5_000_000_000) { $sysseek = 'undef' unless defined $sysseek; - print "1..0 # Skip: seeking past 2GB failed: ", - $r ? 'signal '.($r & 0x7f) : "$! (sysseek returned $sysseek)", "\n"; - explain(); + explain("seeking past 2GB failed: ", + $r ? 'signal '.($r & 0x7f) : "$! (sysseek returned $sysseek)"); bye(); } @@ -135,11 +146,12 @@ my $close = close BIG; print "# close failed: $!\n" unless $close; unless($syswrite && $close) { if ($! =~/too large/i) { - print "1..0 # Skip: writing past 2GB failed: process limits?\n"; + explain("writing past 2GB failed: process limits?"); } elsif ($! =~ /quota/i) { - print "1..0 # Skip: filesystem quota limits?\n"; + explain("filesystem quota limits?"); + } else { + explain("error: $!"); } - explain(); bye(); } @@ -148,8 +160,7 @@ unless($syswrite && $close) { print "# @s\n"; unless ($s[7] == 5_000_000_003) { - print "1..0 # Skip: not configured to use large files?\n"; - explain(); + explain("kernel/fs not configured to use large files?"); bye(); } @@ -158,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"; @@ -176,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; @@ -209,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; @@ -220,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/t/lib/syslog.t b/t/lib/syslog.t index 7ad4204ee0..04adb6bed9 100755 --- a/t/lib/syslog.t +++ b/t/lib/syslog.t @@ -8,21 +8,56 @@ BEGIN { print "1..0 # Skip: Sys::Syslog was not built\n"; exit 0; } + + require Socket; + + # This code inspired by Sys::Syslog::connect(): + require Sys::Hostname; + my ($host_uniq) = Sys::Hostname::hostname(); + my ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; + + if (! defined Socket::inet_aton($host)) { + print "1..0 # Skip: Can't lookup $host\n"; + exit 0; + } } use Sys::Syslog qw(:DEFAULT setlogsock); +# Test this to 1 if your syslog accepts udp connections. +# Most don't (or at least shouldn't) +my $Test_Syslog_INET = 0; + print "1..6\n"; if (Sys::Syslog::_PATH_LOG()) { - print defined(eval { setlogsock('unix') }) ? "ok 1\n" : "not ok 1\n"; - print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 2\n" : "not ok 2\n"; - print defined(eval { syslog('info', 'test') }) ? "ok 3\n" : "not ok 3\n"; + if (-e Sys::Syslog::_PATH_LOG()) { + print defined(eval { setlogsock('unix') }) ? "ok 1\n" : "not ok 1\n"; + print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 2\n" : "not ok 2\n"; + print defined(eval { syslog('info', 'test') }) ? "ok 3\n" : "not ok 3\n"; + } + else { + for (1..3) { + print + "ok $_ # skipping, file ", + Sys::Syslog::_PATH_LOG(), + " does not exist\n"; + } + } } else { for (1..3) { print "ok $_ # skipping, _PATH_LOG unavailable\n" } } -print defined(eval { setlogsock('inet') }) ? "ok 4\n" : "not ok 4\n"; -print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 5\n" : "not ok 5\n"; -print defined(eval { syslog('info', 'test') }) ? "ok 6\n" : "not ok 6\n"; +if( $Test_Syslog_INET ) { + print defined(eval { setlogsock('inet') }) ? "ok 4\n" + : "not ok 4\n"; + print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 5\n" + : "not ok 5\n"; + print defined(eval { syslog('info', 'test') }) ? "ok 6\n" + : "not ok 6\n"; +} +else { + print "ok $_ # skipped(assuming syslog doesn't accept inet connections)\n" + foreach (4..6); +} diff --git a/t/lib/thr5005.t b/t/lib/thr5005.t index 680e1af3e7..bc6aed7182 100755 --- a/t/lib/thr5005.t +++ b/t/lib/thr5005.t @@ -13,7 +13,7 @@ BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } $| = 1; -print "1..22\n"; +print "1..74\n"; use Thread 'yield'; print "ok 1\n"; @@ -129,3 +129,79 @@ $thr1->join; $thr2->join; $thr3->join; print "ok 22\n"; + +{ + my $THRf_STATE_MASK = 7; + my $THRf_R_JOINABLE = 0; + my $THRf_R_JOINED = 1; + my $THRf_R_DETACHED = 2; + my $THRf_ZOMBIE = 3; + my $THRf_DEAD = 4; + my $THRf_DID_DIE = 8; + sub _test { + my($test, $t, $state, $die) = @_; + my $flags = $t->flags; + if (($flags & $THRf_STATE_MASK) == $state + && !($flags & $THRf_DID_DIE) == !$die) { + print "ok $test\n"; + } else { + print <<BAD; +not ok $test\t# got flags $flags not @{[ $state + ($die ? $THRf_DID_DIE : 0) ]} +BAD + } + } + + my @t; + push @t, ( + Thread->new(sub { sleep 4; die "thread die\n" }), + Thread->new(sub { die "thread die\n" }), + Thread->new(sub { sleep 4; 1 }), + Thread->new(sub { 1 }), + ) for 1, 2; + $_->detach for @t[grep $_ & 4, 0..$#t]; + + sleep 1; + my $test = 23; + for (0..7) { + my $t = $t[$_]; + my $flags = ($_ & 1) + ? ($_ & 4) ? $THRf_DEAD : $THRf_ZOMBIE + : ($_ & 4) ? $THRf_R_DETACHED : $THRf_R_JOINABLE; + _test($test++, $t, $flags, (($_ & 3) != 1) ? 0 : $THRf_DID_DIE); + printf "%sok %s\n", !$t->done == !($_ & 1) ? "" : "not ", $test++; + } +# $test = 39; + for (grep $_ & 1, 0..$#t) { + next if $_ & 4; # can't join detached threads + $t[$_]->eval; + my $die = ($_ & 2) ? "" : "thread die\n"; + printf "%sok %s\n", $@ eq $die ? "" : "not ", $test++; + } +# $test = 41; + for (0..7) { + my $t = $t[$_]; + my $flags = ($_ & 1) + ? ($_ & 4) ? $THRf_DEAD : $THRf_DEAD + : ($_ & 4) ? $THRf_R_DETACHED : $THRf_R_JOINABLE; + _test($test++, $t, $flags, (($_ & 3) != 1) ? 0 : $THRf_DID_DIE); + printf "%sok %s\n", !$t->done == !($_ & 1) ? "" : "not ", $test++; + } +# $test = 57; + for (grep !($_ & 1), 0..$#t) { + next if $_ & 4; # can't join detached threads + $t[$_]->eval; + my $die = ($_ & 2) ? "" : "thread die\n"; + printf "%sok %s\n", $@ eq $die ? "" : "not ", $test++; + } + sleep 1; # make sure even the detached threads are done sleeping +# $test = 59; + for (0..7) { + my $t = $t[$_]; + my $flags = ($_ & 1) + ? ($_ & 4) ? $THRf_DEAD : $THRf_DEAD + : ($_ & 4) ? $THRf_DEAD : $THRf_DEAD; + _test($test++, $t, $flags, ($_ & 2) ? 0 : $THRf_DID_DIE); + printf "%sok %s\n", $t->done ? "" : "not ", $test++; + } +# $test = 75; +} diff --git a/t/lib/tie-refhash.t b/t/lib/tie-refhash.t new file mode 100644 index 0000000000..d80b2e10fc --- /dev/null +++ b/t/lib/tie-refhash.t @@ -0,0 +1,305 @@ +#!/usr/bin/perl -w +# +# Basic test suite for Tie::RefHash and Tie::RefHash::Nestable. +# +# The testing is in two parts: first, run lots of tests on both a tied +# hash and an ordinary un-tied hash, and check they give the same +# answer. Then there are tests for those cases where the tied hashes +# should behave differently to normal hashes, that is, when using +# references as keys. +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '.'; + push @INC, '../lib'; +} + +use strict; +use Tie::RefHash; +use Data::Dumper; +my $numtests = 34; +my $currtest = 1; +print "1..$numtests\n"; + +my $ref = []; my $ref1 = []; + +# Test standard hash functionality, by performing the same operations +# on a tied hash and on a normal hash, and checking that the results +# are the same. This does of course assume that Perl hashes are not +# buggy :-) +# +my @tests = standard_hash_tests(); + +my @ordinary_results = runtests(\@tests, undef); +foreach my $class ('Tie::RefHash', 'Tie::RefHash::Nestable') { + my @tied_results = runtests(\@tests, $class); + my $all_ok = 1; + + die if @ordinary_results != @tied_results; + foreach my $i (0 .. $#ordinary_results) { + my ($or, $ow, $oe) = @{$ordinary_results[$i]}; + my ($tr, $tw, $te) = @{$tied_results[$i]}; + + my $ok = 1; + local $^W = 0; + $ok = 0 if (defined($or) != defined($tr)) or ($or ne $tr); + $ok = 0 if (defined($ow) != defined($tw)) or ($ow ne $tw); + $ok = 0 if (defined($oe) != defined($te)) or ($oe ne $te); + + if (not $ok) { + print STDERR + "failed for $class: $tests[$i]\n", + "ordinary hash gave:\n", + defined $or ? "\tresult: $or\n" : "\tundef result\n", + defined $ow ? "\twarning: $ow\n" : "\tno warning\n", + defined $oe ? "\texception: $oe\n" : "\tno exception\n", + "tied $class hash gave:\n", + defined $tr ? "\tresult: $tr\n" : "\tundef result\n", + defined $tw ? "\twarning: $tw\n" : "\tno warning\n", + defined $te ? "\texception: $te\n" : "\tno exception\n", + "\n"; + $all_ok = 0; + } + } + test($all_ok); +} + +# Now test Tie::RefHash's special powers +my (%h, $h); +$h = eval { tie %h, 'Tie::RefHash' }; +warn $@ if $@; +test(not $@); +test(ref($h) eq 'Tie::RefHash'); +test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash/); +$h{$ref} = 'cholet'; +test($h{$ref} eq 'cholet'); +test(exists $h{$ref}); +test((keys %h) == 1); +test(ref((keys %h)[0]) eq 'ARRAY'); +test((keys %h)[0] eq $ref); +test((values %h) == 1); +test((values %h)[0] eq 'cholet'); +my $count = 0; +while (my ($k, $v) = each %h) { + if ($count++ == 0) { + test(ref($k) eq 'ARRAY'); + test($k eq $ref); + } +} +test($count == 1); +delete $h{$ref}; +test(not defined $h{$ref}); +test(not exists($h{$ref})); +test((keys %h) == 0); +test((values %h) == 0); +undef $h; +untie %h; + +# And now Tie::RefHash::Nestable's differences from Tie::RefHash. +$h = eval { tie %h, 'Tie::RefHash::Nestable' }; +warn $@ if $@; +test(not $@); +test(ref($h) eq 'Tie::RefHash::Nestable'); +test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash::Nestable/); +$h{$ref}->{$ref1} = 'bungo'; +test($h{$ref}->{$ref1} eq 'bungo'); + +# Test that the nested hash is also tied (for current implementation) +test(defined(tied(%{$h{$ref}})) + and tied(%{$h{$ref}}) =~ /^Tie::RefHash::Nestable=/ ); + +test((keys %h) == 1); +test((keys %h)[0] eq $ref); +test((keys %{$h{$ref}}) == 1); +test((keys %{$h{$ref}})[0] eq $ref1); + + +die "expected to run $numtests tests, but ran ", $currtest - 1 + if $currtest - 1 != $numtests; + +@tests = (); +undef $ref; +undef $ref1; + +exit(); + + +# Print 'ok X' if true, 'not ok X' if false +# Uses global $currtest. +# +sub test { + my $t = shift; + print 'not ' if not $t; + print 'ok ', $currtest++, "\n"; +} + + +# Wrapper for Data::Dumper to 'dump' a scalar as an EXPR string. +sub dumped { + my $s = shift; + my $d = Dumper($s); + $d =~ s/^\$VAR1 =\s*//; + $d =~ s/;$//; + chomp $d; + return $d; +} + +# Crudely dump a hash into a canonical string representation (because +# hash keys can appear in any order, Data::Dumper may give different +# strings for the same hash). +# +sub dumph { + my $h = shift; + my $r = ''; + foreach (sort keys %$h) { + $r = dumped($_) . ' => ' . dumped($h->{$_}) . "\n"; + } + return $r; +} + +# Run the tests and give results. +# +# Parameters: reference to list of tests to run +# name of class to use for tied hash, or undef if not tied +# +# Returns: list of [R, W, E] tuples, one for each test. +# R is the return value from running the test, W any warnings it gave, +# and E any exception raised with 'die'. E and W will be tidied up a +# little to remove irrelevant details like line numbers :-) +# +# Will also run a few of its own 'ok N' tests. +# +sub runtests { + my ($tests, $class) = @_; + my @r; + + my (%h, $h); + if (defined $class) { + $h = eval { tie %h, $class }; + warn $@ if $@; + test(not $@); + test(ref($h) eq $class); + test(defined(tied(%h)) and tied(%h) =~ /^\Q$class\E/); + } + + foreach (@$tests) { + my ($result, $warning, $exception); + local $SIG{__WARN__} = sub { $warning .= $_[0] }; + $result = scalar(eval $_); + if ($@) + { + die "$@:$_" unless defined $class; + $exception = $@; + } + + foreach ($warning, $exception) { + next if not defined; + s/ at .+ line \d+\.$//mg; + s/ at .+ line \d+, at .*//mg; + s/ at .+ line \d+, near .*//mg; + } + + my (@warnings, %seen); + foreach (split /\n/, $warning) { + push @warnings, $_ unless $seen{$_}++; + } + $warning = join("\n", @warnings); + + push @r, [ $result, $warning, $exception ]; + } + + return @r; +} + + +# Things that should work just the same for an ordinary hash and a +# Tie::RefHash. +# +# Each test is a code string to be eval'd, it should do something with +# %h and give a scalar return value. The global $ref and $ref1 may +# also be used. +# +# One thing we don't test is that the ordering from 'keys', 'values' +# and 'each' is the same. You can't reasonably expect that. +# +sub standard_hash_tests { + my @r; + + # Library of standard tests on keys, values and each + my $STD_TESTS = <<'END' + join $;, sort keys %h; + join $;, sort values %h; + { my ($v, %tmp); $tmp{$v}++ while (defined($v = each %h)); dumph(\%tmp) } + { my ($k, $v, %tmp); $tmp{"$k$;$v"}++ while (($k, $v) = each %h); dumph(\%tmp) } +END + ; + + # Tests on the existence of the element 'foo' + my $FOO_TESTS = <<'END' + defined $h{foo}; + exists $h{foo}; + $h{foo}; +END + ; + + # Test storing and deleting 'foo' + push @r, split /\n/, <<"END" + $STD_TESTS; + $FOO_TESTS; + \$h{foo} = undef; + $STD_TESTS; + $FOO_TESTS; + \$h{foo} = 'hello'; + $STD_TESTS; + $FOO_TESTS; + delete \$h{foo}; + $STD_TESTS; + $FOO_TESTS; +END + ; + + # Test storing and removing under ordinary keys + my @things = ('boink', 0, 1, '', undef); + foreach my $key (map { dumped($_) } @things) { + foreach my $value ((map { dumped($_) } @things), '$ref') { + push @r, split /\n/, <<"END" + \$h{$key} = $value; + $STD_TESTS; + defined \$h{$key}; + exists \$h{$key}; + \$h{$key}; + delete \$h{$key}; + $STD_TESTS; + defined \$h{$key}; + exists \$h{$key}; + \$h{$key}; +END + ; + } + } + + # Test hash slices + my @slicetests; + @slicetests = split /\n/, <<'END' + @h{'b'} = (); + @h{'c'} = ('d'); + @h{'e'} = ('f', 'g'); + @h{'h', 'i'} = (); + @h{'j', 'k'} = ('l'); + @h{'m', 'n'} = ('o', 'p'); + @h{'q', 'r'} = ('s', 't', 'u'); +END + ; + my @aaa = @slicetests; + foreach (@slicetests) { + push @r, $_; + push @r, split(/\n/, $STD_TESTS); + } + + # Test CLEAR + push @r, '%h = ();', split(/\n/, $STD_TESTS); + + return @r; +} + diff --git a/t/lib/tie-splice.t b/t/lib/tie-splice.t new file mode 100644 index 0000000000..d7ea6cc1dc --- /dev/null +++ b/t/lib/tie-splice.t @@ -0,0 +1,17 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '.'; + push @INC, '../lib'; +} + +# bug id 20001020.002 +# -dlc 20001021 + +use Tie::Array; +tie @a,Tie::StdArray; +undef *Tie::StdArray::SPLICE; +require "op/splice.t" + +# Pre-fix, this failed tests 6-9 diff --git a/t/lib/tie-substrhash.t b/t/lib/tie-substrhash.t new file mode 100644 index 0000000000..8256db7b58 --- /dev/null +++ b/t/lib/tie-substrhash.t @@ -0,0 +1,111 @@ +#!/usr/bin/perl -w +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '.'; + push @INC, '../lib'; +} + +print "1..20\n"; + +use strict; + +require Tie::SubstrHash; + +my %a; + +tie %a, 'Tie::SubstrHash', 3, 3, 3; + +$a{abc} = 123; +$a{bcd} = 234; + +print "not " unless $a{abc} == 123; +print "ok 1\n"; + +print "not " unless keys %a == 2; +print "ok 2\n"; + +delete $a{abc}; + +print "not " unless $a{bcd} == 234; +print "ok 3\n"; + +print "not " unless (values %a)[0] == 234; +print "ok 4\n"; + +eval { $a{abcd} = 123 }; +print "not " unless $@ =~ /Key "abcd" is not 3 characters long/; +print "ok 5\n"; + +eval { $a{abc} = 1234 }; +print "not " unless $@ =~ /Value "1234" is not 3 characters long/; +print "ok 6\n"; + +eval { $a = $a{abcd}; $a++ }; +print "not " unless $@ =~ /Key "abcd" is not 3 characters long/; +print "ok 7\n"; + +@a{qw(abc cde)} = qw(123 345); + +print "not " unless $a{cde} == 345; +print "ok 8\n"; + +eval { $a{def} = 456 }; +print "not " unless $@ =~ /Table is full \(3 elements\)/; +print "ok 9\n"; + +%a = (); + +print "not " unless keys %a == 0; +print "ok 10\n"; + +# Tests 11..16 by Linc Madison. + +my $hashsize = 119; # arbitrary values from my data +my %test; +tie %test, "Tie::SubstrHash", 13, 86, $hashsize; + +for (my $i = 1; $i <= $hashsize; $i++) { + my $key1 = $i + 100_000; # fix to uniform 6-digit numbers + my $key2 = "abcdefg$key1"; + $test{$key2} = ("abcdefgh" x 10) . "$key1"; +} + +for (my $i = 1; $i <= $hashsize; $i++) { + my $key1 = $i + 100_000; + my $key2 = "abcdefg$key1"; + unless ($test{$key2}) { + print "not "; + last; + } +} +print "ok 11\n"; + +print "not " unless Tie::SubstrHash::findgteprime(1) == 2; +print "ok 12\n"; + +print "not " unless Tie::SubstrHash::findgteprime(2) == 2; +print "ok 13\n"; + +print "not " unless Tie::SubstrHash::findgteprime(5.5) == 7; +print "ok 14\n"; + +print "not " unless Tie::SubstrHash::findgteprime(13) == 13; +print "ok 15\n"; + +print "not " unless Tie::SubstrHash::findgteprime(13.000001) == 17; +print "ok 16\n"; + +print "not " unless Tie::SubstrHash::findgteprime(114) == 127; +print "ok 17\n"; + +print "not " unless Tie::SubstrHash::findgteprime(1000) == 1009; +print "ok 18\n"; + +print "not " unless Tie::SubstrHash::findgteprime(1024) == 1031; +print "ok 19\n"; + +print "not " unless Tie::SubstrHash::findgteprime(10000) == 10007; +print "ok 20\n"; + diff --git a/t/op/64bitint.t b/t/op/64bitint.t index 88fbc55c67..c34d188c37 100644 --- a/t/op/64bitint.t +++ b/t/op/64bitint.t @@ -16,7 +16,7 @@ BEGIN { # 32+ bit integers don't cause noise no warnings qw(overflow portable); -print "1..55\n"; +print "1..58\n"; my $q = 12345678901; my $r = 23456789012; @@ -294,4 +294,36 @@ $q = 18446744073709551615; print "# $q ne\n# 18446744073709551615\nnot " unless "$q" eq "18446744073709551615"; print "ok 55\n"; +# Test that sv_2nv then sv_2iv is the same as sv_2iv direct +# fails if whatever Atol is defined as can't actually cope with >32 bits. +my $num = 4294967297; +my $string = "4294967297"; +{ + use integer; + $num += 0; + $string += 0; +} +if ($num eq $string) { + print "ok 56\n"; +} else { + print "not ok 56 # \"$num\" ne \"$string\"\n"; +} + +# Test that sv_2nv then sv_2uv is the same as sv_2uv direct +$num = 4294967297; +$string = "4294967297"; +$num &= 0; +$string &= 0; +if ($num eq $string) { + print "ok 57\n"; +} else { + print "not ok 57 # \"$num\" ne \"$string\"\n"; +} + +$q = "18446744073709551616e0"; +$q += 0; +print "# \"18446744073709551616e0\" += 0 gives $q\nnot " if "$q" eq "18446744073709551615"; +print "ok 58\n"; + + # eof diff --git a/t/op/array.t b/t/op/array.t index 7cc84e3217..d48b5fbfa0 100755 --- a/t/op/array.t +++ b/t/op/array.t @@ -1,6 +1,6 @@ #!./perl -print "1..70\n"; +print "1..71\n"; # # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them @@ -229,3 +229,8 @@ print "ok 69\n"; print "not " unless unshift(@ary,12) == 5; print "ok 70\n"; + +sub foo { "a" } +@foo=(foo())[0,0]; +$foo[1] eq "a" or print "not "; +print "ok 71\n"; diff --git a/t/op/assignwarn.t b/t/op/assignwarn.t index 2d05b82289..aff433c464 100755 --- a/t/op/assignwarn.t +++ b/t/op/assignwarn.t @@ -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/t/op/attrs.t b/t/op/attrs.t index 2702004881..f9212e4c26 100644 --- a/t/op/attrs.t +++ b/t/op/attrs.t @@ -142,6 +142,10 @@ eval 'my A $x : plugh plover;'; mytest qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; BEGIN {++$ntests} +eval 'package Cat; my Cat @socks;'; +mytest qr/^Can't declare class for non-scalar \@socks in "my"/; +BEGIN {++$ntests} + sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } sub X::foo { 1 } *Y::bar = \&X::foo; diff --git a/t/op/bop.t b/t/op/bop.t index fd080e6be8..622d1698fe 100755 --- a/t/op/bop.t +++ b/t/op/bop.t @@ -9,7 +9,7 @@ BEGIN { @INC = '../lib'; } -print "1..38\n"; +print "1..42\n"; # numerics print ((0xdead & 0xbeef) == 0x9ead ? "ok 1\n" : "not ok 1\n"); @@ -107,7 +107,7 @@ for (0x100...0xFFF) { if $a ne chr(~$_) or length($a) != 1 or ~$a ne chr($_); } if (@not36) { - print "# test 36 failed: @not36\n"; + print "# test 36 failed\n"; print "not "; } print "ok 36\n"; @@ -120,14 +120,46 @@ for my $i (0xEEE...0xF00) { 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); + ~$a ne chr($i).chr($j); } } if (@not37) { - print "# test 37 failed: @not37\n"; + 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"; diff --git a/t/op/chop.t b/t/op/chop.t index 6723ca3f1b..65d0669841 100755 --- a/t/op/chop.t +++ b/t/op/chop.t @@ -1,6 +1,6 @@ #!./perl -print "1..30\n"; +print "1..33\n"; # optimized @@ -89,3 +89,17 @@ $_ = "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"; diff --git a/t/op/cmp.t b/t/op/cmp.t index 4a7e68d448..ffd34c62dd 100755 --- a/t/op/cmp.t +++ b/t/op/cmp.t @@ -1,35 +1,185 @@ #!./perl -@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1); +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +# 2s complement assumption. Won't break test, just makes the internals of +# the SVs less interesting if were not on 2s complement system. +my $uv_max = ~0; +my $uv_maxm1 = ~0 ^ 1; +my $uv_big = $uv_max; +$uv_big = ($uv_big - 20000) | 1; +my ($iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big, $iv_small); +$iv_max = $uv_max; # Do copy, *then* divide +$iv_max /= 2; +$iv_min = $iv_max; +{ + use integer; + $iv0 = 2 - 2; + $iv1 = 3 - 2; + $ivm1 = 2 - 3; + $iv_max -= 1; + $iv_min += 0; + $iv_big = $iv_max - 3; + $iv_small = $iv_min + 2; +} +my $uv_bigi = $iv_big; +$uv_bigi |= 0x0; + +# Seems one needs to perform the maths on 'Inf' to get the NV correctly primed. +@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1, 3.14, 1e37, 0.632120558, -.5, + 'Inf'+1, '-Inf'-1, 0x0, 0x1, 0x5, 0xFFFFFFFF, $uv_max, $uv_maxm1, + $uv_big, $uv_bigi, $iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big, + $iv_small); -$expect = ($#FOO+2) * ($#FOO+1); +$expect = 6 * ($#FOO+2) * ($#FOO+1); print "1..$expect\n"; my $ok = 0; for my $i (0..$#FOO) { for my $j ($i..$#FOO) { $ok++; - my $cmp = $FOO[$i] <=> $FOO[$j]; - if (!defined($cmp) || - $cmp == -1 && $FOO[$i] < $FOO[$j] || - $cmp == 0 && $FOO[$i] == $FOO[$j] || - $cmp == 1 && $FOO[$i] > $FOO[$j]) + # Comparison routines may convert these internally, which would change + # what is used to determine the comparison on later runs. Hence copy + my ($i1, $i2, $i3, $i4, $i5, $i6, $i7, $i8, $i9, $i10, + $i11, $i12, $i13, $i14, $i15) = + ($FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], + $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], + $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i]); + my ($j1, $j2, $j3, $j4, $j5, $j6, $j7, $j8, $j9, $j10, + $j11, $j12, $j13, $j14, $j15) = + ($FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], + $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], + $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j]); + my $cmp = $i1 <=> $j1; + if (!defined($cmp) ? !($i2 < $j2) + : ($cmp == -1 && $i2 < $j2 || + $cmp == 0 && !($i2 < $j2) || + $cmp == 1 && !($i2 < $j2))) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, < disagrees\n"; + } + $ok++; + if (!defined($cmp) ? !($i4 == $j4) + : ($cmp == -1 && !($i4 == $j4) || + $cmp == 0 && $i4 == $j4 || + $cmp == 1 && !($i4 == $j4))) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, == disagrees\n"; + } + $ok++; + if (!defined($cmp) ? !($i5 > $j5) + : ($cmp == -1 && !($i5 > $j5) || + $cmp == 0 && !($i5 > $j5) || + $cmp == 1 && ($i5 > $j5))) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, > disagrees\n"; + } + $ok++; + if (!defined($cmp) ? !($i6 >= $j6) + : ($cmp == -1 && !($i6 >= $j6) || + $cmp == 0 && $i6 >= $j6 || + $cmp == 1 && $i6 >= $j6)) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, >= disagrees\n"; + } + $ok++; + # OK, so the docs are wrong it seems. NaN != NaN + if (!defined($cmp) ? ($i7 != $j7) + : ($cmp == -1 && $i7 != $j7 || + $cmp == 0 && !($i7 != $j7) || + $cmp == 1 && $i7 != $j7)) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, != disagrees\n"; + } + $ok++; + if (!defined($cmp) ? !($i8 <= $j8) + : ($cmp == -1 && $i8 <= $j8 || + $cmp == 0 && $i8 <= $j8 || + $cmp == 1 && !($i8 <= $j8))) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, <= disagrees\n"; + } + $ok++; + $cmp = $i9 cmp $j9; + if ($cmp == -1 && $i10 lt $j10 || + $cmp == 0 && !($i10 lt $j10) || + $cmp == 1 && !($i10 lt $j10)) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, lt disagrees\n"; + } + $ok++; + if ($cmp == -1 && !($i11 eq $j11) || + $cmp == 0 && ($i11 eq $j11) || + $cmp == 1 && !($i11 eq $j11)) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, eq disagrees\n"; + } + $ok++; + if ($cmp == -1 && !($i12 gt $j12) || + $cmp == 0 && !($i12 gt $j12) || + $cmp == 1 && ($i12 gt $j12)) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, gt disagrees\n"; + } + $ok++; + if ($cmp == -1 && $i13 le $j13 || + $cmp == 0 && ($i13 le $j13) || + $cmp == 1 && !($i13 le $j13)) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, le disagrees\n"; + } + $ok++; + if ($cmp == -1 && ($i14 ne $j14) || + $cmp == 0 && !($i14 ne $j14) || + $cmp == 1 && ($i14 ne $j14)) { print "ok $ok\n"; } else { - print "not ok $ok ($FOO[$i] <=> $FOO[$j]) gives: '$cmp'\n"; + print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, ne disagrees\n"; } $ok++; - $cmp = $FOO[$i] cmp $FOO[$j]; - if ($cmp == -1 && $FOO[$i] lt $FOO[$j] || - $cmp == 0 && $FOO[$i] eq $FOO[$j] || - $cmp == 1 && $FOO[$i] gt $FOO[$j]) + if ($cmp == -1 && !($i15 ge $j15) || + $cmp == 0 && ($i15 ge $j15) || + $cmp == 1 && ($i15 ge $j15)) { print "ok $ok\n"; } else { - print "not ok $ok ($FOO[$i] cmp $FOO[$j]) gives '$cmp'\n"; + print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, ge disagrees\n"; } } } diff --git a/t/op/concat.t b/t/op/concat.t new file mode 100644 index 0000000000..76074e0f28 --- /dev/null +++ b/t/op/concat.t @@ -0,0 +1,100 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..11\n"; + +($a, $b, $c) = qw(foo bar); + +print "not " unless "$a" eq "foo"; +print "ok 1\n"; + +print "not " unless "$a$b" eq "foobar"; +print "ok 2\n"; + +print "not " unless "$c$a$c" eq "foo"; +print "ok 3\n"; + +# Okay, so that wasn't very challenging. Let's go Unicode. + +my $test = 4; + +{ + # bug id 20000819.004 + + $_ = $dx = "\x{10f2}"; + s/($dx)/$dx$1/; + { + use bytes; + print "not " unless $_ eq "$dx$dx"; + print "ok $test\n"; + $test++; + } + + $_ = $dx = "\x{10f2}"; + s/($dx)/$1$dx/; + { + use bytes; + print "not " unless $_ eq "$dx$dx"; + print "ok $test\n"; + $test++; + } + + $dx = "\x{10f2}"; + $_ = "\x{10f2}\x{10f2}"; + s/($dx)($dx)/$1$2/; + { + use bytes; + print "not " unless $_ eq "$dx$dx"; + print "ok $test\n"; + $test++; + } +} + +{ + # bug id 20000901.092 + # test that undef left and right of utf8 results in a valid string + + my $a; + $a .= "\x{1ff}"; + print "not " unless $a eq "\x{1ff}"; + print "ok $test\n"; + $test++; +} + +{ + # ID 20001020.006 + + "x" =~ /(.)/; # unset $2 + + # Without the fix this 5.7.0 would croak: + # Modification of a read-only value attempted at ... + "$2\x{1234}"; + + print "ok $test\n"; + $test++; + + # For symmetry with the above. + "\x{1234}$2"; + + print "ok $test\n"; + $test++; + + *pi = \undef; + # This bug existed earlier than the $2 bug, but is fixed with the same + # patch. Without the fix this 5.7.0 would also croak: + # Modification of a read-only value attempted at ... + "$pi\x{1234}"; + + print "ok $test\n"; + $test++; + + # For symmetry with the above. + "\x{1234}$pi"; + + print "ok $test\n"; + $test++; +} diff --git a/t/op/each.t b/t/op/each.t index 879c0d0fd3..35792ab9c3 100755 --- a/t/op/each.t +++ b/t/op/each.t @@ -1,6 +1,6 @@ #!./perl -print "1..19\n"; +print "1..24\n"; $h{'abc'} = 'ABC'; $h{'def'} = 'DEF'; @@ -131,3 +131,28 @@ if ($i == 5) { print "ok 16\n" } else { print "not ok\n" } print "ok 19\n"; } +# Check for Unicode hash keys. +%u = ("\x{12}", "f", "\x{123}", "fo", "\x{1234}", "foo"); +$u{"\x{12345}"} = "bar"; +@u{"\x{123456}"} = "zap"; + +foreach (keys %u) { + unless (length() == 1) { + print "not "; + last; + } +} +print "ok 20\n"; + +$a = "\xe3\x81\x82"; $A = "\x{3042}"; +%b = ( $a => "non-utf8"); +%u = ( $A => "utf8"); + +print "not " if exists $b{$A}; +print "ok 21\n"; +print "not " if exists $u{$a}; +print "ok 22\n"; +print "#$b{$_}\n" for keys %b; # Used to core dump before change #8056. +print "ok 23\n"; +print "#$u{$_}\n" for keys %u; # Used to core dump before change #8056. +print "ok 24\n"; diff --git a/t/op/fork.t b/t/op/fork.t index 93cf673228..fbcd0987fe 100755 --- a/t/op/fork.t +++ b/t/op/fork.t @@ -8,7 +8,9 @@ BEGIN { require Config; import Config; unless ($Config{'d_fork'} or ($^O eq 'MSWin32' and $Config{useithreads} - and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/)) + and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/ +# and !defined $Config{'useperlio'} + )) { print "1..0 # Skip: no fork\n"; exit 0; @@ -184,6 +186,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"; diff --git a/t/op/goto_xs.t b/t/op/goto_xs.t index cf2cafd467..dc8e7d77aa 100755 --- a/t/op/goto_xs.t +++ b/t/op/goto_xs.t @@ -35,7 +35,7 @@ $VALID = 'LOCK_SH'; ### First, we check whether Fcntl::constant returns sane answers. # Fcntl::constant("LOCK_SH",0) should always succeed. -$value = Fcntl::constant($VALID,0); +$value = Fcntl::constant($VALID); print((!defined $value) ? "not ok 1\n# Sanity check broke, remaining tests will fail.\n" : "ok 1\n"); @@ -45,20 +45,20 @@ print((!defined $value) # test "goto &function_constant" sub goto_const { goto &Fcntl::constant; } -$ret = goto_const($VALID,0); +$ret = goto_const($VALID); print(($ret == $value) ? "ok 2\n" : "not ok 2\n# ($ret != $value)\n"); # test "goto &$function_package_and_name" $FNAME1 = 'Fcntl::constant'; sub goto_name1 { goto &$FNAME1; } -$ret = goto_name1($VALID,0); +$ret = goto_name1($VALID); print(($ret == $value) ? "ok 3\n" : "not ok 3\n# ($ret != $value)\n"); # test "goto &$function_package_and_name" again, with dirtier stack -$ret = goto_name1($VALID,0); +$ret = goto_name1($VALID); print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n"); -$ret = goto_name1($VALID,0); +$ret = goto_name1($VALID); print(($ret == $value) ? "ok 5\n" : "not ok 5\n# ($ret != $value)\n"); # test "goto &$function_name" from local package @@ -67,14 +67,14 @@ $FNAME2 = 'constant'; sub goto_name2 { goto &$FNAME2; } package main; -$ret = Fcntl::goto_name2($VALID,0); +$ret = Fcntl::goto_name2($VALID); print(($ret == $value) ? "ok 6\n" : "not ok 6\n# ($ret != $value)\n"); # test "goto &$function_ref" $FREF = \&Fcntl::constant; sub goto_ref { goto &$FREF; } -$ret = goto_ref($VALID,0); +$ret = goto_ref($VALID); print(($ret == $value) ? "ok 7\n" : "not ok 7\n# ($ret != $value)\n"); ### tests where the args are not on stack but in GvAV(defgv) (ie, @_) @@ -82,17 +82,17 @@ print(($ret == $value) ? "ok 7\n" : "not ok 7\n# ($ret != $value)\n"); # test "goto &function_constant" from a sub called without arglist sub call_goto_const { &goto_const; } -$ret = call_goto_const($VALID,0); +$ret = call_goto_const($VALID); print(($ret == $value) ? "ok 8\n" : "not ok 8\n# ($ret != $value)\n"); # test "goto &$function_package_and_name" from a sub called without arglist sub call_goto_name1 { &goto_name1; } -$ret = call_goto_name1($VALID,0); +$ret = call_goto_name1($VALID); print(($ret == $value) ? "ok 9\n" : "not ok 9\n# ($ret != $value)\n"); # test "goto &$function_ref" from a sub called without arglist sub call_goto_ref { &goto_ref; } -$ret = call_goto_ref($VALID,0); +$ret = call_goto_ref($VALID); print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n"); diff --git a/t/op/join.t b/t/op/join.t index b50878e735..0f849fda9c 100755 --- a/t/op/join.t +++ b/t/op/join.t @@ -1,6 +1,6 @@ #!./perl -print "1..10\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";} @@ -44,3 +44,24 @@ if ($f eq 'baeak') {print "ok 6\n";} else {print "# '$f'\nnot ok 6\n";} 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/t/op/length.t b/t/op/length.t new file mode 100644 index 0000000000..ceb005ecc4 --- /dev/null +++ b/t/op/length.t @@ -0,0 +1,85 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..13\n"; + +print "not " unless length("") == 0; +print "ok 1\n"; + +print "not " unless length("abc") == 3; +print "ok 2\n"; + +$_ = "foobar"; +print "not " unless length() == 6; +print "ok 3\n"; + +# Okay, so that wasn't very challenging. Let's go Unicode. + +{ + my $a = "\x{41}"; + + print "not " unless length($a) == 1; + print "ok 4\n"; + $test++; + + use bytes; + print "not " unless $a eq "\x41" && length($a) == 1; + print "ok 5\n"; + $test++; +} + +{ + my $a = "\x{80}"; + + print "not " unless length($a) == 1; + print "ok 6\n"; + $test++; + + use bytes; + print "not " unless $a eq "\xc2\x80" && length($a) == 2; + print "ok 7\n"; + $test++; +} + +{ + my $a = "\x{100}"; + + print "not " unless length($a) == 1; + print "ok 8\n"; + $test++; + + use bytes; + print "not " unless $a eq "\xc4\x80" && length($a) == 2; + print "ok 9\n"; + $test++; +} + +{ + my $a = "\x{100}\x{80}"; + + print "not " unless length($a) == 2; + print "ok 10\n"; + $test++; + + use bytes; + print "not " unless $a eq "\xc4\x80\xc2\x80" && length($a) == 4; + print "ok 11\n"; + $test++; +} + +{ + my $a = "\x{80}\x{100}"; + + print "not " unless length($a) == 2; + print "ok 12\n"; + $test++; + + use bytes; + print "not " unless $a eq "\xc2\x80\xc4\x80" && length($a) == 4; + print "ok 13\n"; + $test++; +} diff --git a/t/op/lfs.t b/t/op/lfs.t index feee8cc9b3..0a1c399840 100644 --- a/t/op/lfs.t +++ b/t/op/lfs.t @@ -13,6 +13,11 @@ BEGIN { } } +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 # Skip: 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 # Skip: 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(); } @@ -125,8 +137,7 @@ open(BIG, ">big") or do { warn "open failed: $!\n"; bye }; binmode BIG; if ($r or not seek(BIG, 5_000_000_000, $SEEK_SET)) { my $err = $r ? 'signal '.($r & 0x7f) : $!; - print "1..0 # Skip: seeking past 2GB failed: $err\n"; - explain(); + explain("seeking past 2GB failed: $err"); bye(); } @@ -138,11 +149,12 @@ my $close = close BIG; print "# close failed: $!\n" unless $close; unless ($print && $close) { if ($! =~/too large/i) { - print "1..0 # Skip: writing past 2GB failed: process limits?\n"; + explain("writing past 2GB failed: process limits?"); } elsif ($! =~ /quota/i) { - print "1..0 # Skip: filesystem quota limits?\n"; + explain("filesystem quota limits?"); + } else { + explain("error: $!"); } - explain(); bye(); } @@ -151,8 +163,7 @@ unless ($print && $close) { print "# @s\n"; unless ($s[7] == 5_000_000_003) { - print "1..0 # Skip: not configured to use large files?\n"; - explain(); + explain("kernel/fs not configured to use large files?"); bye(); } @@ -161,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"; @@ -183,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; @@ -213,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"; @@ -224,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/t/op/local.t b/t/op/local.t index b478e01993..781afa5b35 100755 --- a/t/op/local.t +++ b/t/op/local.t @@ -1,6 +1,6 @@ #!./perl -print "1..69\n"; +print "1..71\n"; # XXX known to leak scalars $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; @@ -235,3 +235,14 @@ while (/(o.+?),/gc) { untie $_; } +{ + # BUG 20001205.22 + my %x; + $x{a} = 1; + { local $x{b} = 1; } + print "not " if exists $x{b}; + print "ok 70\n"; + { local @x{c,d,e}; } + print "not " if exists $x{c}; + print "ok 71\n"; +} diff --git a/t/op/method.t b/t/op/method.t index be4df75fe2..1f5cbb64dc 100755 --- a/t/op/method.t +++ b/t/op/method.t @@ -9,7 +9,7 @@ BEGIN { @INC = '../lib'; } -print "1..53\n"; +print "1..54\n"; @A::ISA = 'B'; @B::ISA = 'C'; @@ -185,3 +185,8 @@ test(do { eval 'E->foo()'; test(do { eval '$e = bless {}, "E"; $e->foo()'; $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1); +# This is actually testing parsing of indirect objects and undefined subs +# print foo("bar") where foo does not exist is not an indirect object. +# print foo "bar" where foo does not exist is an indirect object. +eval { sub AUTOLOAD { "ok ", shift, "\n"; } }; +print nonsuch(++$cnt); diff --git a/t/op/misc.t b/t/op/misc.t index f4424946a9..805a32bc9a 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -562,3 +562,58 @@ 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". +use Config; +my $have_setlocale = $Config{d_setlocale} eq 'define'; +eval { + require POSIX; +}; +$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 +######## +die qr(x) +EXPECT +(?-xism:x) at - line 1. +######## +# 20001210.003 mjd@plover.com +format REMITOUT_TOP = +FOO +. + +format REMITOUT = +BAR +. + +# This loop causes a segv in 5.6.0 +for $lineno (1..61) { + write REMITOUT; +} + +print "It's OK!"; +EXPECT +It's OK! diff --git a/t/op/numconvert.t b/t/op/numconvert.t index f3c9867a91..3db280bbfd 100755 --- a/t/op/numconvert.t +++ b/t/op/numconvert.t @@ -85,8 +85,15 @@ my @list = (1, $yet_smaller_than_iv, $smaller_than_iv, $max_iv, $max_iv + 1, unshift @list, (reverse map -$_, @list), 0; # 15 elts @list = map "$_", @list; # Normalize -# print "@list\n"; +print "# @list\n"; +# need to special case ++ for max_uv, as ++ "magic" on a string gives +# another string, whereas ++ magic on a string used as a number gives +# a number. Not a problem when NV preserves UV, but if it doesn't then +# stringification of the latter gives something in e notation. + +my $max_uv_pp = "$max_uv"; $max_uv_pp++; +my $max_uv_p1 = "$max_uv"; $max_uv_p1+=0; $max_uv_p1++; my @opnames = split //, "-+UINPuinp"; @@ -178,9 +185,18 @@ for my $num_chain (1..$max_chain) { } push @ans, $inpt; } - $nok++, - print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n" - if $ans[0] ne $ans[1]; + if ($ans[0] ne $ans[1]) { + print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n"; + # XXX ought to check that "+" was in the list of opnames + if ((($ans[0] eq $max_uv_pp) and ($ans[1] eq $max_uv_p1)) + or (($ans[1] eq $max_uv_pp) and ($ans[0] eq $max_uv_p1))) { + # string ++ versus numeric ++. Tolerate this little + # bit of insanity + print "# ok, as string ++ of max_uv is \"$max_uv_pp\", numeric is $max_uv_p1\n" + } else { + $nok++, + } + } } print "not " if $nok; print "ok $test\n"; diff --git a/t/op/ord.t b/t/op/ord.t index 22ff3af4ed..f664078d00 100755 --- a/t/op/ord.t +++ b/t/op/ord.t @@ -1,11 +1,11 @@ #!./perl -print "1..5\n"; +print "1..8\n"; # compile time evaluation -# 65 ASCII -# 193 EBCDIC +# 'A' 65 ASCII +# 'A' 193 EBCDIC if (ord('A') == 65 || ord('A') == 193) {print "ok 1\n";} else {print "not ok 1\n";} print "not " unless ord(chr(500)) == 500; @@ -18,6 +18,17 @@ if (ord($x) == 65 || ord($x) == 193) {print "ok 3\n";} else {print "not ok 3\n"; if (chr 65 eq 'A' || chr 193 eq 'A') {print "ok 4\n";} else {print "not ok 4\n";} +print "not " unless ord(chr(500)) == 500; +print "ok 5\n"; + $x = 500; print "not " unless ord(chr($x)) == $x; -print "ok 5\n"; +print "ok 6\n"; + +print "not " unless ord("\x{1234}") == 0x1234; +print "ok 7\n"; + +$x = "\x{1234}"; +print "not " unless ord($x) == 0x1234; +print "ok 8\n"; + diff --git a/t/op/pat.t b/t/op/pat.t index f0090865a1..17df867fd9 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -4,7 +4,7 @@ # 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..223\n"; +print "1..231\n"; BEGIN { chdir 't' if -d 't'; @@ -496,7 +496,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 +504,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 +545,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 +570,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; @@ -1064,7 +1097,8 @@ my %space = ( spc => " ", cr => "\r", lf => "\n", ff => "\f", -# The vertical tabulator seems miraculously be 12 both in ASCII and EBCDIC. +# There's no \v but the vertical tabulator seems miraculously +# be 11 both in ASCII and EBCDIC. vt => chr(11), false => "space" ); @@ -1073,14 +1107,25 @@ 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\n"; +print "ok $test # @space0\n"; $test++; print "not " unless "@space1" eq "cr ff lf spc tab vt"; -print "ok $test\n"; +print "ok $test # @space1\n"; $test++; print "not " unless "@space2" eq "spc tab"; -print "ok $test\n"; +print "ok $test # @space2\n"; $test++; +# bugid 20001021.005 - this caused a SEGV +print "not " unless undef =~ /^([^\/]*)(.*)$/; +print "ok $test\n"; +$test++; + +# bugid 20000731.001 + +print "not " unless "A \x{263a} B z C" =~ /A . B (??{ "z" }) C/; +print "ok $test\n"; +$test++; + diff --git a/t/op/pos.t b/t/op/pos.t index 46811b7bbc..f3bc23c84a 100755 --- a/t/op/pos.t +++ b/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/t/op/re_tests b/t/op/re_tests index c2753e592e..52666daea5 100644 --- a/t/op/re_tests +++ b/t/op/re_tests @@ -46,8 +46,8 @@ a[b-d] aac y $& ac a[-b] a- y $& a- a[b-] a- y $& a- 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/ at (eval 96) line 1, <TESTS> line 49. -a[ - c - Unmatched [ before HERE mark in regex m/a[ << HERE / at (eval 97) line 1, <TESTS> line 50. +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 - Quantifier follows nothing before HERE mark in regex m/* << HERE a/ at (eval 192) line 1, <TESTS> line 98. -(*)b - c - Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/ at (eval 193) line 1, <TESTS> line 99. +*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 - Unmatched ) before HERE mark in regex m/abc) << HERE / at (eval 205) line 1, <TESTS> line 106. -(abc - c - Unmatched ( before HERE mark in regex m/( << HERE abc/ at (eval 206) line 1, <TESTS> line 107. +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 - Nested quantifiers before HERE mark in regex m/a** << HERE / at (eval 215) line 1, <TESTS> line 112. +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 ) before HERE mark in regex m/) << HERE (/ at (eval 230) line 1, <TESTS> line 120. +)( - c - Unmatched ) before HERE mark in regex m/) << HERE (/ [^ab]* cde y $& cde abc n - - a* y $& @@ -219,8 +219,8 @@ a[-]?c ac y $& ac 'a[-b]'i A- y $& A- 'a[b-]'i A- y $& A- '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/ at (eval 431) line 1, <TESTS> line 222. -'a['i - c - Unmatched [ before HERE mark in regex m/a[ << HERE / at (eval 432) line 1, <TESTS> line 223. +'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 - Quantifier follows nothing before HERE mark in regex m/* << HERE a/ at (eval 455) line 1, <TESTS> line 235. -'(*)b'i - c - Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/ at (eval 456) line 1, <TESTS> line 236. +'*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 - Unmatched ) before HERE mark in regex m/abc) << HERE / at (eval 468) line 1, <TESTS> line 243. -'(abc'i - c - Unmatched ( before HERE mark in regex m/( << HERE abc/ at (eval 469) line 1, <TESTS> line 244. +'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 - Nested quantifiers before HERE mark in regex m/a** << HERE / at (eval 478) line 1, <TESTS> line 249. +'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 ) before HERE mark in regex m/) << HERE (/ at (eval 499) line 1, <TESTS> line 260. +')('i - c - Unmatched ) before HERE mark in regex m/) << HERE (/ '[^ab]*'i CDE y $& CDE 'abc'i n - - 'a*'i y $& @@ -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 - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE )b/ at (eval 780) line 1, <TESTS> line 400. -a(?{{})b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE {})b/ at (eval 781) line 1, <TESTS> line 401. +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/ at (eval 783) line 1, <TESTS> line 403. +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,7 +441,7 @@ x(~~)*(?:(?:F)?)? x~~ y - - ^(\(+)?blah(?(1)(\)))$ blah y ($2) () ^(\(+)?blah(?(1)(\)))$ blah) n - - ^(\(+)?blah(?(1)(\)))$ (blah n - - -(?(1?)a|b) a c - Switch condition not recognized before HERE mark in regex m/(?(1? << HERE )a|b)/ at (eval 868) line 1, <TESTS> line 444. +(?(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 @@ -473,7 +473,7 @@ $(?<=^(a)) a y $1 a ([[:]+) a:[b]: y $1 :[ ([[=]+) a=[b]= y $1 =[ ([[.]+) a.[b]. y $1 .[ -[a[:xyz: - c - Unmatched [ before HERE mark in regex m/[ << HERE a[:xyz:/ at (eval 950) line 1, <TESTS> line 476. +[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 - POSIX class [:xyz:] unknown before HERE mark in regex m/([a[:xyz:] << HERE b]+)/ @@ -775,3 +775,9 @@ tt+$ xxxtt y - - '^.{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 diff --git a/t/op/ref.t b/t/op/ref.t index a2baab8e3b..8ae90424eb 100755 --- a/t/op/ref.t +++ b/t/op/ref.t @@ -1,6 +1,6 @@ #!./perl -print "1..56\n"; +print "1..61\n"; # Test glob operations. @@ -279,14 +279,34 @@ print $$_,"\n"; print ${\$_} for @a; } +# This test is the reason for postponed destruction in sv_unref +$a = [1,2,3]; +$a = $a->[1]; +print "not " unless $a == 2; +print "ok 54\n"; + +sub x::DESTROY {print "ok ", 54 + shift->[0], "\n"} +{ my $a1 = bless [4],"x"; + my $a2 = bless [3],"x"; + { my $a3 = bless [2],"x"; + my $a4 = bless [1],"x"; + 567; + } +} + + # test global destruction +my $test = 59; +my $test1 = $test + 1; +my $test2 = $test + 2; + package FINALE; { - $ref3 = bless ["ok 56\n"]; # package destruction - my $ref2 = bless ["ok 55\n"]; # lexical destruction - local $ref1 = bless ["ok 54\n"]; # dynamic destruction + $ref3 = bless ["ok $test2\n"]; # package destruction + my $ref2 = bless ["ok $test1\n"]; # lexical destruction + local $ref1 = bless ["ok $test\n"]; # dynamic destruction 1; # flush any temp values on stack } diff --git a/t/op/regexp.t b/t/op/regexp.t index 23ae576c75..7fbfc97342 100755 --- a/t/op/regexp.t +++ b/t/op/regexp.t @@ -26,6 +26,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 @@ -56,7 +59,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 +73,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 +85,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/t/op/regmesg.t b/t/op/regmesg.t index f209239841..50a020bc4d 100644 --- a/t/op/regmesg.t +++ b/t/op/regmesg.t @@ -65,14 +65,12 @@ my @death = '/(x)\2/' => 'Reference to nonexistent group before {#} mark in regex m/(x)\2{#}/', - 'my $m = chr(92); $m =~ $m', => 'Trailing \ in regex m/\/', + 'my $m = "\\\"; $m =~ $m', => 'Trailing \ in regex m/\/', '/\x{1/' => 'Missing right brace on \x{} before {#} mark in regex m/\x{{#}1/', 'use utf8; /[\x{X]/' => 'Missing right brace on \x{} before {#} mark in regex m/[\x{{#}X]/', - '/\x{x}/' => 'Can\'t use \x{} without \'use utf8\' declaration before {#} mark in regex m/\x{x}{#}/', - '/[[:barf:]]/' => 'POSIX class [:barf:] unknown before {#} mark in regex m/[[:barf:]{#}]/', '/[[=barf=]]/' => 'POSIX syntax [= =] is reserved for future extensions before {#} mark in regex m/[[=barf=]{#}]/', @@ -101,15 +99,24 @@ my @death = my $total = (@death + @warning)/2; +# utf8 is a noop on EBCDIC platforms, it is not fatal +my $Is_EBCDIC = (ord('A') == 193); +if ($Is_EBCDIC) { + my @utf8_death = grep(/utf8/, @death); + $total = $total - $#utf8_death; +} + print "1..$total\n"; my $count = 0; while (@death) { - $count++; my $regex = shift @death; my $result = shift @death; + # skip the utf8 test on EBCDIC since they do not die + next if ($Is_EBCDIC && $regex =~ /utf8/); + $count++; $_ = "x"; eval $regex; diff --git a/t/op/reverse.t b/t/op/reverse.t new file mode 100644 index 0000000000..bb7b9b77fe --- /dev/null +++ b/t/op/reverse.t @@ -0,0 +1,33 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..4\n"; + +print "not " unless reverse("abc") eq "cba"; +print "ok 1\n"; + +$_ = "foobar"; +print "not " unless reverse() eq "raboof"; +print "ok 2\n"; + +{ + my @a = ("foo", "bar"); + my @b = reverse @a; + + print "not " unless $b[0] eq $a[1] && $b[1] eq $a[0]; + print "ok 3\n"; +} + +{ + # Unicode. + + my $a = "\x{263A}\x{263A}x\x{263A}y\x{263A}"; + my $b = scalar reverse($a); + my $c = scalar reverse($b); + print "not " unless $a eq $c; + print "ok 4\n"; +} diff --git a/t/op/sort.t b/t/op/sort.t index 9095871a29..c1dfb63ccb 100755 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -5,7 +5,7 @@ BEGIN { @INC = '../lib'; } use warnings; -print "1..57\n"; +print "1..58\n"; # XXX known to leak scalars { @@ -321,3 +321,10 @@ sub cxt_six { sort test_if_scalar 1,2 } print "# x = '@b'\n"; print !$def ? "ok 57\n" : "not ok 57\n"; } + +# Bug 19991001.003 +{ + sub routine { "one", "two" }; + @a = sort(routine(1)); + print "@a" eq "one two" ? "ok 58\n" : "not ok 58\n"; +} diff --git a/t/op/split.t b/t/op/split.t index 45df76a2bc..90c38e0770 100755 --- a/t/op/split.t +++ b/t/op/split.t @@ -1,6 +1,6 @@ #!./perl -print "1..28\n"; +print "1..30\n"; $FS = ':'; @@ -122,3 +122,13 @@ print "ok 27\n"; 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"; + +# unicode splittage +@ary = map {ord} split //, v1.20.300.4000.50000.4000.300.20.1; +print "not " unless "@ary" eq "1 20 300 4000 50000 4000 300 20 1"; +print "ok 30\n"; diff --git a/t/op/sprintf.t b/t/op/sprintf.t index 2f6cd276ad..4e80999bc3 100755 --- a/t/op/sprintf.t +++ b/t/op/sprintf.t @@ -229,8 +229,8 @@ __END__ >%.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< ->%.0f< >-0.6< >-1< >Known to fail with sfio< +>%.0f< >0.6< >1< >Known to fail with sfio and nonstop-ux< +>%.0f< >-0.6< >-1< >Known to fail with sfio and nonstop-ux< >%.0f< >1< >1< >%#.0f< >1< >1.< >%g< >12345.6789< >12345.7< @@ -308,3 +308,16 @@ __END__ >%0*x< >[-10, ,2**32-1]< >ffffffff < >%y< >''< >%y INVALID< >%z< >''< >%z INVALID< +>%2$d %1$d< >[12, 34]< >34 12< +>%*2$d< >[12, 3]< > 12< +>%2$d %d< >[12, 34]< >34 12< +>%2$d %d %d< >[12, 34]< >34 12 34< +>%3$d %d %d< >[12, 34, 56]< >56 12 34< +>%2$*3$d %d< >[12, 34, 3]< > 34 12< +>%*3$2$d %d< >[12, 34, 3]< > 34 12< +>%2$d< >12< >0< +>%0$d< >12< >%0$d INVALID< +>%1$$d< >12< >%1$$d INVALID< +>%1$1$d< >12< >%1$1$d INVALID< +>%*2$*2$d< >[12, 3]< >%*2$*2$d INVALID< +>%*2*2$d< >[12, 3]< >%*2*2$d INVALID< diff --git a/t/op/taint.t b/t/op/taint.t index 7cc4447a0b..1e3d3964c2 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -99,7 +99,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 @@ -681,3 +681,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/t/op/tie.t b/t/op/tie.t index afcc4a1635..4413ed2100 100755 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -162,19 +162,28 @@ $C = $B = tied %H ; untie %H; EXPECT ######## - -# verify no leak when underlying object is selfsame tied variable -my ($a, $b); +# Forbidden aggregate self-ties +my ($a, $b) = (0, 0); sub Self::TIEHASH { bless $_[1], $_[0] } -sub Self::DESTROY { $b = $_[0] + 0; } +sub Self::DESTROY { $b = $_[0] + 1; } +{ + my %c = 42; + tie %c, 'Self', \%c; +} +EXPECT +Self-ties of arrays and hashes are not supported +######## +# Allowed scalar self-ties +my ($a, $b) = (0, 0); +sub Self::TIESCALAR { bless $_[1], $_[0] } +sub Self::DESTROY { $b = $_[0] + 1; } { - my %b5; - $a = \%b5 + 0; - tie %b5, 'Self', \%b5; + my $c = 42; + $a = $c + 0; + tie $c, 'Self', \$c; } -die unless $a == $b; +die unless $a == 0 && $b == 43; EXPECT -Self-ties are not supported ######## # Interaction of tie and vec diff --git a/t/op/utf8decode.t b/t/op/utf8decode.t new file mode 100644 index 0000000000..4d05a6b8d3 --- /dev/null +++ b/t/op/utf8decode.t @@ -0,0 +1,183 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +no utf8; + +print "1..78\n"; + +my $test = 1; + +# This table is based on Markus Kuhn's UTF-8 Decode Stress Tester, +# http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt, +# version dated 2000-09-02. + +# We use the \x notation instead of raw binary bytes for \x00-\x1f\x7f-\xff +# because e.g. many patch programs have issues with binary data. + +my @MK = split(/\n/, <<__EOMK__); +1 Correct UTF-8 +1.1.1 y "\xce\xba\xe1\xbd\xb9\xcf\x83\xce\xbc\xce\xb5" - 11 ce:ba:e1:bd:b9:cf:83:ce:bc:ce:b5 5 +2 Boundary conditions +2.1 First possible sequence of certain length +2.1.1 y "\x00" 0 1 00 1 +2.1.2 y "\xc2\x80" 80 2 c2:80 1 +2.1.3 y "\xe0\xa0\x80" 800 3 e0:a0:80 1 +2.1.4 y "\xf0\x90\x80\x80" 10000 4 f0:90:80:80 1 +2.1.5 y "\xf8\x88\x80\x80\x80" 200000 5 f8:88:80:80:80 1 +2.1.6 y "\xfc\x84\x80\x80\x80\x80" 4000000 6 fc:84:80:80:80:80 1 +2.2 Last possible sequence of certain length +2.2.1 y "\x7f" 7f 1 7f 1 +2.2.2 y "\xdf\xbf" 7ff 2 df:bf 1 +# The ffff is illegal unless UTF8_ALLOW_FFFF +2.2.3 n "\xef\xbf\xbf" ffff 3 ef:bf:bf 1 character 0xffff +2.2.4 y "\xf7\xbf\xbf\xbf" 1fffff 4 f7:bf:bf:bf 1 +2.2.5 y "\xfb\xbf\xbf\xbf\xbf" 3ffffff 5 fb:bf:bf:bf:bf 1 +2.2.6 y "\xfd\xbf\xbf\xbf\xbf\xbf" 7fffffff 6 fd:bf:bf:bf:bf:bf 1 +2.3 Other boundary conditions +2.3.1 y "\xed\x9f\xbf" d7ff 3 ed:9f:bf 1 +2.3.2 y "\xee\x80\x80" e000 3 ee:80:80 1 +2.3.3 y "\xef\xbf\xbd" fffd 3 ef:bf:bd 1 +2.3.4 y "\xf4\x8f\xbf\xbf" 10ffff 4 f4:8f:bf:bf 1 +2.3.5 y "\xf4\x90\x80\x80" 110000 4 f4:90:80:80 1 +3 Malformed sequences +3.1 Unexpected continuation bytes +3.1.1 n "\x80" - 1 80 - unexpected continuation byte 0x80 +3.1.2 n "\xbf" - 1 bf - unexpected continuation byte 0xbf +3.1.3 n "\x80\xbf" - 2 80:bf - unexpected continuation byte 0x80 +3.1.4 n "\x80\xbf\x80" - 3 80:bf:80 - unexpected continuation byte 0x80 +3.1.5 n "\x80\xbf\x80\xbf" - 4 80:bf:80:bf - unexpected continuation byte 0x80 +3.1.6 n "\x80\xbf\x80\xbf\x80" - 5 80:bf:80:bf:80 - unexpected continuation byte 0x80 +3.1.7 n "\x80\xbf\x80\xbf\x80\xbf" - 6 80:bf:80:bf:80:bf - unexpected continuation byte 0x80 +3.1.8 n "\x80\xbf\x80\xbf\x80\xbf\x80" - 7 80:bf:80:bf:80:bf:80 - unexpected continuation byte 0x80 +3.1.9 n "\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf" - 64 80:81:82:83:84:85:86:87:88:89:8a:8b:8c:8d:8e:8f:90:91:92:93:94:95:96:97:98:99:9a:9b:9c:9d:9e:9f:a0:a1:a2:a3:a4:a5:a6:a7:a8:a9:aa:ab:ac:ad:ae:af:b0:b1:b2:b3:b4:b5:b6:b7:b8:b9:ba:bb:bc:bd:be:bf - unexpected continuation byte 0x80 +3.2 Lonely start characters +3.2.1 n "\xc0 \xc1 \xc2 \xc3 \xc4 \xc5 \xc6 \xc7 \xc8 \xc9 \xca \xcb \xcc \xcd \xce \xcf \xd0 \xd1 \xd2 \xd3 \xd4 \xd5 \xd6 \xd7 \xd8 \xd9 \xda \xdb \xdc \xdd \xde \xdf " - 64 c0:20:c1:20:c2:20:c3:20:c4:20:c5:20:c6:20:c7:20:c8:20:c9:20:ca:20:cb:20:cc:20:cd:20:ce:20:cf:20:d0:20:d1:20:d2:20:d3:20:d4:20:d5:20:d6:20:d7:20:d8:20:d9:20:da:20:db:20:dc:20:dd:20:de:20:df:20 - unexpected non-continuation byte 0x20 after start byte 0xc0 +3.2.2 n "\xe0 \xe1 \xe2 \xe3 \xe4 \xe5 \xe6 \xe7 \xe8 \xe9 \xea \xeb \xec \xed \xee \xef " - 32 e0:20:e1:20:e2:20:e3:20:e4:20:e5:20:e6:20:e7:20:e8:20:e9:20:ea:20:eb:20:ec:20:ed:20:ee:20:ef:20 - unexpected non-continuation byte 0x20 after start byte 0xe0 +3.2.3 n "\xf0 \xf1 \xf2 \xf3 \xf4 \xf5 \xf6 \xf7 " - 16 f0:20:f1:20:f2:20:f3:20:f4:20:f5:20:f6:20:f7:20 - unexpected non-continuation byte 0x20 after start byte 0xf0 +3.2.4 n "\xf8 \xf9 \xfa \xfb " - 8 f8:20:f9:20:fa:20:fb:20 - unexpected non-continuation byte 0x20 after start byte 0xf8 +3.2.5 n "\xfc \xfd " - 4 fc:20:fd:20 - unexpected non-continuation byte 0x20 after start byte 0xfc +3.3 Sequences with last continuation byte missing +3.3.1 n "\xc0" - 1 c0 - 1 byte, need 2 +3.3.2 n "\xe0\x80" - 2 e0:80 - 2 bytes, need 3 +3.3.3 n "\xf0\x80\x80" - 3 f0:80:80 - 3 bytes, need 4 +3.3.4 n "\xf8\x80\x80\x80" - 4 f8:80:80:80 - 4 bytes, need 5 +3.3.5 n "\xfc\x80\x80\x80\x80" - 5 fc:80:80:80:80 - 5 bytes, need 6 +3.3.6 n "\xdf" - 1 df - 1 byte, need 2 +3.3.7 n "\xef\xbf" - 2 ef:bf - 2 bytes, need 3 +3.3.8 n "\xf7\xbf\xbf" - 3 f7:bf:bf - 3 bytes, need 4 +3.3.9 n "\xfb\xbf\xbf\xbf" - 4 fb:bf:bf:bf - 4 bytes, need 5 +3.3.10 n "\xfd\xbf\xbf\xbf\xbf" - 5 fd:bf:bf:bf:bf - 5 bytes, need 6 +3.4 Concatenation of incomplete sequences +3.4.1 n "\xc0\xe0\x80\xf0\x80\x80\xf8\x80\x80\x80\xfc\x80\x80\x80\x80\xdf\xef\xbf\xf7\xbf\xbf\xfb\xbf\xbf\xbf\xfd\xbf\xbf\xbf\xbf" - 30 c0:e0:80:f0:80:80:f8:80:80:80:fc:80:80:80:80:df:ef:bf:f7:bf:bf:fb:bf:bf:bf:fd:bf:bf:bf:bf - unexpected non-continuation byte 0xe0 after start byte 0xc0 +3.5 Impossible bytes +3.5.1 n "\xfe" - 1 fe - byte 0xfe +3.5.2 n "\xff" - 1 ff - byte 0xff +3.5.3 n "\xfe\xfe\xff\xff" - 4 fe:fe:ff:ff - byte 0xfe +4 Overlong sequences +4.1 Examples of an overlong ASCII character +4.1.1 n "\xc0\xaf" - 2 c0:af - 2 bytes, need 1 +4.1.2 n "\xe0\x80\xaf" - 3 e0:80:af - 3 bytes, need 1 +4.1.3 n "\xf0\x80\x80\xaf" - 4 f0:80:80:af - 4 bytes, need 1 +4.1.4 n "\xf8\x80\x80\x80\xaf" - 5 f8:80:80:80:af - 5 bytes, need 1 +4.1.5 n "\xfc\x80\x80\x80\x80\xaf" - 6 fc:80:80:80:80:af - 6 bytes, need 1 +4.2 Maximum overlong sequences +4.2.1 n "\xc1\xbf" - 2 c1:bf - 2 bytes, need 1 +4.2.2 n "\xe0\x9f\xbf" - 3 e0:9f:bf - 3 bytes, need 2 +4.2.3 n "\xf0\x8f\xbf\xbf" - 4 f0:8f:bf:bf - 4 bytes, need 3 +4.2.4 n "\xf8\x87\xbf\xbf\xbf" - 5 f8:87:bf:bf:bf - 5 bytes, need 4 +4.2.5 n "\xfc\x83\xbf\xbf\xbf\xbf" - 6 fc:83:bf:bf:bf:bf - 6 bytes, need 5 +4.3 Overlong representation of the NUL character +4.3.1 n "\xc0\x80" - 2 c0:80 - 2 bytes, need 1 +4.3.2 n "\xe0\x80\x80" - 3 e0:80:80 - 3 bytes, need 1 +4.3.3 n "\xf0\x80\x80\x80" - 4 f0:80:80:80 - 4 bytes, need 1 +4.3.4 n "\xf8\x80\x80\x80\x80" - 5 f8:80:80:80:80 - 5 bytes, need 1 +4.3.5 n "\xfc\x80\x80\x80\x80\x80" - 6 fc:80:80:80:80:80 - 6 bytes, need 1 +5 Illegal code positions +5.1 Single UTF-16 surrogates +5.1.1 n "\xed\xa0\x80" - 3 ed:a0:80 - UTF-16 surrogate 0xd800 +5.1.2 n "\xed\xad\xbf" - 3 ed:ad:bf - UTF-16 surrogate 0xdb7f +5.1.3 n "\xed\xae\x80" - 3 ed:ae:80 - UTF-16 surrogate 0xdb80 +5.1.4 n "\xed\xaf\xbf" - 3 ed:af:bf - UTF-16 surrogate 0xdbff +5.1.5 n "\xed\xb0\x80" - 3 ed:b0:80 - UTF-16 surrogate 0xdc00 +5.1.6 n "\xed\xbe\x80" - 3 ed:be:80 - UTF-16 surrogate 0xdf80 +5.1.7 n "\xed\xbf\xbf" - 3 ed:bf:bf - UTF-16 surrogate 0xdfff +5.2 Paired UTF-16 surrogates +5.2.1 n "\xed\xa0\x80\xed\xb0\x80" - 6 ed:a0:80:ed:b0:80 - UTF-16 surrogate 0xd800 +5.2.2 n "\xed\xa0\x80\xed\xbf\xbf" - 6 ed:a0:80:ed:bf:bf - UTF-16 surrogate 0xd800 +5.2.3 n "\xed\xad\xbf\xed\xb0\x80" - 6 ed:ad:bf:ed:b0:80 - UTF-16 surrogate 0xdb7f +5.2.4 n "\xed\xad\xbf\xed\xbf\xbf" - 6 ed:ad:bf:ed:bf:bf - UTF-16 surrogate 0xdb7f +5.2.5 n "\xed\xae\x80\xed\xb0\x80" - 6 ed:ae:80:ed:b0:80 - UTF-16 surrogate 0xdb80 +5.2.6 n "\xed\xae\x80\xed\xbf\xbf" - 6 ed:ae:80:ed:bf:bf - UTF-16 surrogate 0xdb80 +5.2.7 n "\xed\xaf\xbf\xed\xb0\x80" - 6 ed:af:bf:ed:b0:80 - UTF-16 surrogate 0xdbff +5.2.8 n "\xed\xaf\xbf\xed\xbf\xbf" - 6 ed:af:bf:ed:bf:bf - UTF-16 surrogate 0xdbff +5.3 Other illegal code positions +5.3.1 n "\xef\xbf\xbe" - 3 ef:bf:be - byte order mark 0xfffe +# The ffff is illegal unless UTF8_ALLOW_FFFF +5.3.2 n "\xef\xbf\xbf" - 3 ef:bf:bf - character 0xffff +__EOMK__ + +# 104..181 +{ + my $WARNCNT; + my $id; + + local $SIG{__WARN__} = + sub { + print "# $id: @_"; + $WARNCNT++; + $WARNMSG = "@_"; + }; + + sub moan { + print "$id: @_"; + } + + sub test_unpack_U { + $WARNCNT = 0; + $WARNMSG = ""; + unpack('U*', $_[0]); + } + + for (@MK) { + if (/^(?:\d+(?:\.\d+)?)\s/ || /^#/) { + # print "# $_\n"; + } elsif (/^(\d+\.\d+\.\d+[bu]?)\s+([yn])\s+"(.+)"\s+([0-9a-f]{1,8}|-)\s+(\d+)\s+([0-9a-f]{2}(?::[0-9a-f]{2})*)(?:\s+((?:\d+|-)(?:\s+(.+))?))?$/) { + $id = $1; + my ($okay, $bytes, $Unicode, $byteslen, $hex, $charslen, $error) = + ($2, $3, $4, $5, $6, $7, $8); + my @hex = split(/:/, $hex); + unless (@hex == $byteslen) { + my $nhex = @hex; + moan "amount of hex ($nhex) not equal to byteslen ($byteslen)\n"; + } + { + use bytes; + my $bytesbyteslen = length($bytes); + unless ($bytesbyteslen == $byteslen) { + moan "bytes length() ($bytesbyteslen) not equal to $byteslen\n"; + } + } + if ($okay eq 'y') { + test_unpack_U($bytes); + if ($WARNCNT) { + moan "unpack('U*') false negative\n"; + print "not "; + } + } elsif ($okay eq 'n') { + test_unpack_U($bytes); + if ($WARNCNT == 0 || ($error ne '' && $WARNMSG !~ /$error/)) { + moan "unpack('U*') false positive\n"; + print "not "; + } + } + print "ok $test\n"; + $test++; + } else { + moan "unknown format\n"; + } + } +} diff --git a/t/op/ver.t b/t/op/ver.t index 08beced092..edfebd20ff 100755 --- a/t/op/ver.t +++ b/t/op/ver.t @@ -5,7 +5,7 @@ BEGIN { @INC = '../lib'; } -print "1..23\n"; +print "1..28\n"; my $test = 1; @@ -155,3 +155,27 @@ print "ok $test\n"; ++$test; 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/t/op/write.t b/t/op/write.t index 5b01eb78b7..fc155a88c7 100755 --- a/t/op/write.t +++ b/t/op/write.t @@ -1,6 +1,6 @@ #!./perl -print "1..9\n"; +print "1..11\n"; my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat'; @@ -43,7 +43,7 @@ of huma... now is the time for all good men to come to\n"; if (`$CAT Op_write.tmp` eq $right) - { print "ok 1\n"; unlink 'Op_write.tmp'; } + { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; } else { print "not ok 1\n"; } @@ -85,7 +85,7 @@ necessary now is the time for all good men to come to\n"; if (`$CAT Op_write.tmp` eq $right) - { print "ok 2\n"; unlink 'Op_write.tmp'; } + { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; } else { print "not ok 2\n"; } @@ -129,7 +129,7 @@ necessary now is the time for all good men to come to\n"; if (`$CAT Op_write.tmp` eq $right) - { print "ok 3\n"; unlink 'Op_write.tmp'; } + { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; } else { print "not ok 3\n"; } @@ -184,7 +184,7 @@ $right = "fit\n"; if (`$CAT Op_write.tmp` eq $right) - { print "ok 6\n"; unlink 'Op_write.tmp'; } + { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; } else { print "not ok 6\n"; } @@ -213,8 +213,53 @@ write (OUT4); close OUT4; if (`$CAT Op_write.tmp` eq "1\n") { print "ok 9\n"; - unlink "Op_write.tmp"; + 1 while unlink "Op_write.tmp"; } else { print "not ok 9\n"; } + +eval <<'EOFORMAT'; +format OUT10 = +@####.## @0###.## +$test1, $test1 +. +EOFORMAT + +open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp"; + +$test1 = 12.95; +write(OUT10); +close OUT10; + +$right = " 12.95 00012.95\n"; +if (`$CAT Op_write.tmp` eq $right) + { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; } +else + { print "not ok 10\n"; } + +eval <<'EOFORMAT'; +format OUT11 = +@0###.## +$test1 +@ 0# +$test1 +@0 # +$test1 +. +EOFORMAT + +open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp"; + +$test1 = 12.95; +write(OUT11); +close OUT11; + +$right = +"00012.95 +1 0# +10 #\n"; +if (`$CAT Op_write.tmp` eq $right) + { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; } +else + { print "not ok 11\n"; } diff --git a/t/pragma/constant.t b/t/pragma/constant.t index 450b4d02cf..f932976f60 100755 --- a/t/pragma/constant.t +++ b/t/pragma/constant.t @@ -14,7 +14,7 @@ END { print @warnings } ######################### We start with some black magic to print on failure. -BEGIN { $| = 1; print "1..73\n"; } +BEGIN { $| = 1; print "1..82\n"; } END {print "not ok 1\n" unless $loaded;} use constant 1.01; $loaded = 1; @@ -229,3 +229,23 @@ test 71, (shift @warnings) =~ /^Constant name 'ENV' is forced into package main: test 72, (shift @warnings) =~ /^Constant name 'INC' is forced into package main:: at/; test 73, (shift @warnings) =~ /^Constant name 'SIG' is forced into package main:: at/; @warnings = (); + + +use constant { + THREE => 3, + FAMILY => [ qw( John Jane Sally ) ], + AGES => { John => 33, Jane => 28, Sally => 3 }, + RFAM => [ [ qw( John Jane Sally ) ] ], + SPIT => sub { shift }, + PHFAM => [ { John => 1, Jane => 2, Sally => 3 }, 33, 28, 3 ], +}; + +test 74, @{+FAMILY} == THREE; +test 75, @{+FAMILY} == @{RFAM->[0]}; +test 76, FAMILY->[2] eq RFAM->[0]->[2]; +test 77, AGES->{FAMILY->[1]} == 28; +test 78, PHFAM->{John} == AGES->{John}; +test 79, PHFAM->[3] == AGES->{FAMILY->[2]}; +test 80, @{+PHFAM} == SPIT->(THREE+1); +test 81, THREE**3 eq SPIT->(@{+FAMILY}**3); +test 82, AGES->{FAMILY->[THREE-1]} == PHFAM->[THREE]; diff --git a/t/pragma/locale.t b/t/pragma/locale.t index c8a0df8724..61528b35c3 100755 --- a/t/pragma/locale.t +++ b/t/pragma/locale.t @@ -34,7 +34,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 +244,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 +273,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 +286,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 +330,7 @@ sub decode_encodings { } } else { push @enc, $_; + push @enc, "$_.UTF-8"; } } if ($^O eq 'os390') { @@ -347,32 +352,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 +414,8 @@ foreach my $locale (split(/\n/, $locales)) { setlocale(LC_ALL, "C"); +sub utf8locale { $_[0] =~ /utf-?8/i } + @Locale = sort @Locale; debug "# Locales = @Locale\n"; @@ -470,7 +506,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+)$/; @@ -623,6 +662,9 @@ foreach $Locale (@Locale) { } 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; @@ -646,7 +688,13 @@ foreach $Locale (@Locale) { } 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,15 +709,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"; @@ -685,7 +734,7 @@ foreach (99..116) { my $didwarn = 0; -foreach (99..116) { +foreach (99..$last) { if ($Problem{$_}) { my @f = sort keys %{ $Problem{$_} }; my $f = join(" ", @f); @@ -710,17 +759,18 @@ EOW } } -# Tell which locales were 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..116) { + foreach my $t (102..$last) { $p++ if $Problem{$t}{$l}; } push @s, $l if $p == 0; + push @F, $l unless $p == 0; } if (@s) { @@ -732,7 +782,19 @@ if ($didwarn) { "#\t", $s, "\n#\n", "# tested okay.\n#\n", } else { - warn "# None of your locales was fully okay.\n"; + warn "# None of your locales were fully okay.\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"; } } diff --git a/t/pragma/overload.t b/t/pragma/overload.t index c7105dc9ca..bf24c07ec9 100755 --- a/t/pragma/overload.t +++ b/t/pragma/overload.t @@ -133,6 +133,7 @@ test ( $a eq "087"); # 29 test ( $b eq "88"); # 30 test (ref $a eq "Oscalar"); # 31 +undef $b; # Destroying updates tables too... eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ]; diff --git a/t/pragma/sub_lval.t b/t/pragma/sub_lval.t index 3ab8766892..a54075dd64 100755 --- a/t/pragma/sub_lval.t +++ b/t/pragma/sub_lval.t @@ -1,4 +1,4 @@ -print "1..46\n"; +print "1..49\n"; BEGIN { chdir 't' if -d 't'; @@ -334,8 +334,8 @@ 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 +sub lv1tmpr : lvalue { yyy } # is it read-only? $_ = undef; eval <<'EOE' or $_ = $@; @@ -427,3 +427,25 @@ $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"; + diff --git a/t/pragma/utf8.t b/t/pragma/utf8.t index c3538c0cb5..8e4d296f5d 100755 --- a/t/pragma/utf8.t +++ b/t/pragma/utf8.t @@ -10,7 +10,7 @@ BEGIN { } } -print "1..99\n"; +print "1..105\n"; my $test = 1; @@ -42,6 +42,7 @@ sub nok_bytes { { use utf8; + $_ = ">\x{263A}<"; s/([\x{80}-\x{10ffff}])/"&#".ord($1).";"/eg; ok $_, '>☺<'; @@ -104,215 +105,193 @@ sub nok_bytes { ok $1, '123alpha'; $test++; # 12 } -{ - use utf8; - - $_ = "\x{263A}>\x{263A}\x{263A}"; - ok length, 4; - $test++; # 13 - - ok length((m/>(.)/)[0]), 1; - $test++; # 14 - - ok length($&), 2; - $test++; # 15 +{ + # no use utf8 needed + $_ = "\x{263A}\x{263A}x\x{263A}y\x{263A}"; + + ok length($_), 6; # 13 + $test++; - ok length($'), 1; - $test++; # 16 + ($a) = m/x(.)/; - ok length($`), 1; - $test++; # 17 + ok length($a), 1; # 14 + $test++; - ok length($1), 1; - $test++; # 18 + ok length($`), 2; # 15 + $test++; + ok length($&), 2; # 16 + $test++; + ok length($'), 2; # 17 + $test++; - ok length($tmp=$&), 2; - $test++; # 19 + ok length($1), 1; # 18 + $test++; - ok length($tmp=$'), 1; - $test++; # 20 + ok length($b=$`), 2; # 19 + $test++; - ok length($tmp=$`), 1; - $test++; # 21 + ok length($b=$&), 2; # 20 + $test++; - ok length($tmp=$1), 1; - $test++; # 22 + ok length($b=$'), 2; # 21 + $test++; - { - use bytes; + ok length($b=$1), 1; # 22 + $test++; - my $tmp = $&; - ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272); - $test++; # 23 + ok $a, "\x{263A}"; # 23 + $test++; - $tmp = $'; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 24 + ok $`, "\x{263A}\x{263A}"; # 24 + $test++; - $tmp = $`; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 25 + ok $&, "x\x{263A}"; # 25 + $test++; - $tmp = $1; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 26 - } + ok $', "y\x{263A}"; # 26 + $test++; - ok_bytes $&, pack("C*", ord(">"), 0342, 0230, 0272); - $test++; # 27 + ok $1, "\x{263A}"; # 27 + $test++; - ok_bytes $', pack("C*", 0342, 0230, 0272); - $test++; # 28 + ok_bytes $a, "\342\230\272"; # 28 + $test++; - ok_bytes $`, pack("C*", 0342, 0230, 0272); - $test++; # 29 + ok_bytes $1, "\342\230\272"; # 29 + $test++; - ok_bytes $1, pack("C*", 0342, 0230, 0272); - $test++; # 30 + ok_bytes $&, "x\342\230\272"; # 30 + $test++; { - use bytes; - no utf8; - - ok length, 10; - $test++; # 31 - - ok length((m/>(.)/)[0]), 1; - $test++; # 32 - - ok length($&), 2; - $test++; # 33 + use utf8; # required + $_ = chr(0x263A) . chr(0x263A) . 'x' . chr(0x263A) . 'y' . chr(0x263A); + } - ok length($'), 5; - $test++; # 34 + ok length($_), 6; # 31 + $test++; - ok length($`), 3; - $test++; # 35 + ($a) = m/x(.)/; - ok length($1), 1; - $test++; # 36 + ok length($a), 1; # 32 + $test++; - ok $&, pack("C*", ord(">"), 0342); - $test++; # 37 + ok length($`), 2; # 33 + $test++; - ok $', pack("C*", 0230, 0272, 0342, 0230, 0272); - $test++; # 38 + ok length($&), 2; # 34 + $test++; - ok $`, pack("C*", 0342, 0230, 0272); - $test++; # 39 + ok length($'), 2; # 35 + $test++; - ok $1, pack("C*", 0342); - $test++; # 40 + ok length($1), 1; # 36 + $test++; - } + ok length($b=$`), 2; # 37 + $test++; + ok length($b=$&), 2; # 38 + $test++; - { - no utf8; - $_="\342\230\272>\342\230\272\342\230\272"; - } + ok length($b=$'), 2; # 39 + $test++; - ok length, 10; - $test++; # 41 + ok length($b=$1), 1; # 40 + $test++; - ok length((m/>(.)/)[0]), 1; - $test++; # 42 + ok $a, "\x{263A}"; # 41 + $test++; - ok length($&), 2; - $test++; # 43 + ok $`, "\x{263A}\x{263A}"; # 42 + $test++; - ok length($'), 1; - $test++; # 44 + ok $&, "x\x{263A}"; # 43 + $test++; - ok length($`), 1; - $test++; # 45 + ok $', "y\x{263A}"; # 44 + $test++; - ok length($1), 1; - $test++; # 46 + ok $1, "\x{263A}"; # 45 + $test++; - ok length($tmp=$&), 2; - $test++; # 47 + ok_bytes $a, "\342\230\272"; # 46 + $test++; - ok length($tmp=$'), 1; - $test++; # 48 + ok_bytes $1, "\342\230\272"; # 47 + $test++; - ok length($tmp=$`), 1; - $test++; # 49 + ok_bytes $&, "x\342\230\272"; # 48 + $test++; - ok length($tmp=$1), 1; - $test++; # 50 + $_ = "\342\230\272\342\230\272x\342\230\272y\342\230\272"; - { - use bytes; + ok length($_), 14; # 49 + $test++; - my $tmp = $&; - ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272); - $test++; # 51 + ($a) = m/x(.)/; - $tmp = $'; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 52 + ok length($a), 1; # 50 + $test++; - $tmp = $`; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 53 + ok length($`), 6; # 51 + $test++; - $tmp = $1; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 54 - } - { - use bytes; - no utf8; + ok length($&), 2; # 52 + $test++; - ok length, 10; - $test++; # 55 + ok length($'), 6; # 53 + $test++; - ok length((m/>(.)/)[0]), 1; - $test++; # 56 + ok length($1), 1; # 54 + $test++; - ok length($&), 2; - $test++; # 57 + ok length($b=$`), 6; # 55 + $test++; - ok length($'), 5; - $test++; # 58 + ok length($b=$&), 2; # 56 + $test++; - ok length($`), 3; - $test++; # 59 + ok length($b=$'), 6; # 57 + $test++; - ok length($1), 1; - $test++; # 60 + ok length($b=$1), 1; # 58 + $test++; - ok $&, pack("C*", ord(">"), 0342); - $test++; # 61 + ok $a, "\342"; # 59 + $test++; - ok $', pack("C*", 0230, 0272, 0342, 0230, 0272); - $test++; # 62 + ok $`, "\342\230\272\342\230\272"; # 60 + $test++; - ok $`, pack("C*", 0342, 0230, 0272); - $test++; # 63 + ok $&, "x\342"; # 61 + $test++; - ok $1, pack("C*", 0342); - $test++; # 64 + ok $', "\230\272y\342\230\272"; # 62 + $test++; - } + ok $1, "\342"; # 63 + $test++; +} +{ + use utf8; ok "\x{ab}" =~ /^\x{ab}$/, 1; - $test++; # 65 + $test++; # 64 } { use utf8; ok_bytes chr(0xe2), pack("C*", 0xc3, 0xa2); - $test++; # 66 + $test++; # 65 } { use utf8; my @a = map ord, split(//, join("", map chr, (1234, 123, 2345))); ok "@a", "1234 123 2345"; - $test++; # 67 + $test++; # 66 } { @@ -320,17 +299,22 @@ sub nok_bytes { my $x = chr(123); my @a = map ord, split(/$x/, join("", map chr, (1234, 123, 2345))); ok "@a", "1234 2345"; - $test++; # 68 + $test++; # 67 } { # bug id 20001009.001 - my($a,$b); - { use bytes; $a = "\xc3\xa4"; } - { use utf8; $b = "\xe4"; } - { use bytes; ok_bytes $a, $b; $test++; } # 69 - { use utf8; nok $a, $b; $test++; } # 70 + 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++; # 68 + + { use utf8; print "not " if $a eq $b; } + print "ok $test\n"; $test++; # 69 } { @@ -340,7 +324,7 @@ sub nok_bytes { for (@x) { s/(\d+)\s*([\w\-]+)/$1 . uc $2/e; my($latin) = /^(.+)(?:\s+\d)/; - print $latin eq "stra\337e" ? "ok $test\n" : + print $latin eq "stra\337e" ? "ok $test\n" : # 70, 71 "#latin[$latin]\nnot ok $test\n"; $test++; $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a @@ -350,64 +334,6 @@ sub nok_bytes { } { - # bug id 20000819.004 - - $_ = $dx = "\x{10f2}"; - s/($dx)/$dx$1/; - { - use bytes; - print "not " unless $_ eq "$dx$dx"; - print "ok $test\n"; - $test++; - } - - $_ = $dx = "\x{10f2}"; - s/($dx)/$1$dx/; - { - use bytes; - print "not " unless $_ eq "$dx$dx"; - print "ok $test\n"; - $test++; - } - - $dx = "\x{10f2}"; - $_ = "\x{10f2}\x{10f2}"; - s/($dx)($dx)/$1$2/; - { - use bytes; - print "not " unless $_ eq "$dx$dx"; - print "ok $test\n"; - $test++; - } -} - -{ - # bug id 20000323.056 - - use utf8; - - 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++; -} - -{ # bug id 20000427.003 use utf8; @@ -423,18 +349,7 @@ sub nok_bytes { } print "not " unless $r eq " U+B36C U+5A8C U+FF5B U+5079 U+505B"; - print "ok $test\n"; - $test++; -} - -{ - # bug id 20000901.092 - # test that undef left and right of utf8 results in a valid string - - my $a; - $a .= "\x{1ff}"; - print "not " unless $a eq "\x{1ff}"; - print "ok $test\n"; + print "ok $test\n"; # 72 $test++; } @@ -449,27 +364,27 @@ sub nok_bytes { print "not " unless $a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a; print "ok $test\n"; - $test++; + $test++; # 73 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++; + $test++; # 74 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++; + $test++; # 75 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++; + $test++; # 76 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++; + $test++; # 77 } { @@ -479,14 +394,14 @@ sub nok_bytes { my $smiley = "\x{263a}"; - for my $s ("\x{263a}", # 1 - $smiley, # 2 + for my $s ("\x{263a}", # 78 + $smiley, # 79 - "" . $smiley, # 3 - "" . "\x{263a}", # 4 + "" . $smiley, # 80 + "" . "\x{263a}", # 81 - $smiley . "", # 5 - "\x{263a}" . "", # 6 + $smiley . "", # 82 + "\x{263a}" . "", # 83 ) { my $length_chars = length($s); my $length_bytes; @@ -502,14 +417,14 @@ sub nok_bytes { $test++; } - for my $s ("\x{263a}" . "\x{263a}", # 7 - $smiley . $smiley, # 8 + for my $s ("\x{263a}" . "\x{263a}", # 84 + $smiley . $smiley, # 85 - "\x{263a}\x{263a}", # 9 - "$smiley$smiley", # 10 + "\x{263a}\x{263a}", # 86 + "$smiley$smiley", # 87 - "\x{263a}" x 2, # 11 - $smiley x 2, # 12 + "\x{263a}" x 2, # 88 + $smiley x 2, # 89 ) { my $length_chars = length($s); my $length_bytes; @@ -525,3 +440,117 @@ sub nok_bytes { $test++; } } + +{ + use utf8; + + print "not " unless "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\xd4"; + print "ok $test\n"; + $test++; # 90 + + print "not " unless "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}"; + print "ok $test\n"; + $test++; # 91 + + print "not " unless "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}"; + print "ok $test\n"; + $test++; # 92 + + print "not " unless "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\xd4"; + print "ok $test\n"; + $test++; # 93 + + print "not " unless "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4"; + print "ok $test\n"; + $test++; # 94 + + print "not " unless "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}"; + print "ok $test\n"; + $test++; # 95 + + print "not " unless "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}"; + print "ok $test\n"; + $test++; # 96 + + print "not " unless "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4"; + print "ok $test\n"; + $test++; # 97 +} + +{ + # the first half of 20001028.003 + + my $X = chr(1448); + my ($Y) = $X =~ /(.*)/; + print "not " unless length $Y == 1; + print "ok $test\n"; + $test++; # 98 +} + +{ + # 20001108.001 + + use utf8; + my $X = "Szab\x{f3},Bal\x{e1}zs"; + my $Y = $X; + $Y =~ s/(B)/$1/ for 0..3; + print "not " unless $Y eq $X; + print "ok $test\n"; + $test++; # 99 +} + +{ + # 20001114.001 + + use utf8; + use charnames ':full'; + my $text = "\N{LATIN CAPITAL LETTER A WITH DIAERESIS}"; + print "not " unless ord($text) == 0xc4; + print "ok $test\n"; + $test++; # 100 +} + +{ + # 20001205.014 + + use utf8; + + my $a = "ABC\x{263A}"; + + my @b = split( //, $a ); + + print "not " unless @b == 4; + print "ok $test\n"; + $test++; # 101 + + print "not " unless length($b[3]) == 1; + print "ok $test\n"; + $test++; # 102 + + $a =~ s/^A/Z/; + print "not " unless length($a) == 4; + print "ok $test\n"; + $test++; # 103 +} + +{ + # the second half of 20001028.003 + + use utf8; + $X =~ s/^/chr(1488)/e; + print "not " unless length $X == 1; + print "ok $test\n"; + $test++; # 104 +} + +{ + # 20000517.001 + + my $x = "\x{100}A"; + + $x =~ s/A/B/; + + print "not " unless $x eq "\x{100}B" && length($x) == 2; + print "ok $test\n"; + $test++; # 105 +} diff --git a/t/pragma/warn/pp_hot b/t/pragma/warn/pp_hot index 426820550c..5dd03801e1 100644 --- a/t/pragma/warn/pp_hot +++ b/t/pragma/warn/pp_hot @@ -47,6 +47,9 @@ Possible Y2K bug: about to append an integer to '19' [pp_concat] $x = "19$yy\n"; + Use of reference "%s" as array index [pp_aelem] + $x[\1] + __END__ # pp_hot.c [pp_print] use warnings 'unopened' ; @@ -151,6 +154,7 @@ open (FH, ">./xcv") ; my $a = <FH> ; no warnings 'io' ; $a = <FH> ; +close (FH) ; unlink $file ; EXPECT Filehandle FH opened only for output at - line 5. @@ -227,3 +231,17 @@ $x = "19" . $yy . "\n"; EXPECT Possible Y2K bug: about to append an integer to '19' at - line 12. Possible Y2K bug: about to append an integer to '19' at - line 13. +######## +# pp_hot.c [pp_aelem] +{ +use warnings 'misc'; +print $x[\1]; +} +{ +no warnings 'misc'; +print $x[\1]; +} + +EXPECT +OPTION regex +Use of reference ".*" as array index at - line 4. diff --git a/t/pragma/warn/pp_sys b/t/pragma/warn/pp_sys index 2843c70ed3..e30637b0d4 100644 --- a/t/pragma/warn/pp_sys +++ b/t/pragma/warn/pp_sys @@ -3,6 +3,15 @@ untie attempted while %d inner references still exist [pp_untie] sub TIESCALAR { bless [] } ; tie $a, 'main'; untie $a ; + fileno() on unopened filehandle abc [pp_fileno] + $a = "abc"; fileno($a) + + binmode() on unopened filehandle abc [pp_binmode] + $a = "abc"; fileno($a) + + printf() on unopened filehandle abc [pp_prtf] + $a = "abc"; printf $a "fred" + Filehandle %s opened only for input [pp_leavewrite] format STDIN = . @@ -74,7 +83,7 @@ flock STDIN, 8; flock $a, 8; - lstat() on filehandle %s [pp_stat] + The stat preceding lstat() wasn't an lstat %s [pp_stat] lstat(STDIN); warn(warn_nl, "stat"); [pp_stat] @@ -203,7 +212,9 @@ syswrite() on closed filehandle STDIN at - line 6. # 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 @@ -225,11 +236,11 @@ flock STDIN, 8; flock FOO, 8; flock $a, 8; EXPECT -flock() on closed filehandle STDIN at - line 14. 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 17. -flock() on unopened filehandle at - line 18. +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' ; @@ -352,7 +363,7 @@ lstat(STDIN) ; no warnings 'io' ; lstat(STDIN) ; EXPECT -lstat() on filehandle STDIN at - line 13. +The stat preceding lstat() wasn't an lstat at - line 13. ######## # pp_sys.c [pp_fttext] use warnings qw(unopened closed) ; @@ -398,3 +409,11 @@ close F ; unlink $file ; EXPECT Filehandle F opened only for output at - line 12. +######## +# pp_sys.c [pp_binmode] +use warnings 'unopened' ; +binmode(BLARG); +$a = "BLERG";binmode($a); +EXPECT +binmode() on unopened filehandle BLARG at - line 3. +binmode() on unopened filehandle at - line 4. diff --git a/t/pragma/warn/utf8 b/t/pragma/warn/utf8 index 6a2fe5446c..9a7dbafdee 100644 --- a/t/pragma/warn/utf8 +++ b/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/t/pragma/warnings.t b/t/pragma/warnings.t index 367449797d..872e6e1417 100644 --- a/t/pragma/warnings.t +++ b/t/pragma/warnings.t @@ -25,28 +25,37 @@ if (@ARGV) else { @w_files = sort glob("pragma/warn/*") } -foreach (@w_files) { +my $files = 0; +foreach my $file (@w_files) { next if /(~|\.orig|,v)$/; - open F, "<$_" or die "Cannot open $_: $!\n" ; + open F, "<$file" or die "Cannot open $file: $!\n" ; + my $line = 0; while (<F>) { + $line++; last if /^__END__/ ; } { local $/ = undef; - @prgs = (@prgs, split "\n########\n", <F>) ; + $files++; + @prgs = (@prgs, $file, split "\n########\n", <F>) ; } close F ; } undef $/; -print "1..", scalar @prgs, "\n"; +print "1..", scalar(@prgs)-$files, "\n"; for (@prgs){ + unless (/\n/) + { + print "# From $_\n"; + next; + } my $switch = ""; my @temps = () ; if (s/^\s*-\w+//){ @@ -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); } @@ -84,8 +84,7 @@ PERLVAR(Tcurpm, PMOP *) /* what to do \ interps in REs from */ PERLVAR(Tnrs, SV *) PERLVAR(Trs, SV *) /* input record separator $/ */ PERLVAR(Tlast_in_gv, GV *) /* GV used in last <FH> */ -PERLVAR(Tofs, char *) /* output field separator $, */ -PERLVAR(Tofslen, STRLEN) +PERLVAR(Tofs_sv, SV *) /* output field separator $, */ PERLVAR(Tdefoutgv, GV *) /* default FH for output */ PERLVARI(Tchopset, char *, " \n-") /* $: */ PERLVAR(Tformtarget, SV *) @@ -236,5 +235,5 @@ PERLVAR(i, struct thread_intern) #endif PERLVAR(trailing_nul, char) /* For the sake of thrsv and oursv */ - +PERLVAR(thr_done, bool) /* True when the thread has finished */ #endif /* USE_THREADS */ @@ -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. */ @@ -39,7 +39,7 @@ static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen); /*#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))) @@ -69,26 +69,24 @@ static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen); #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" @@ -123,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. */ @@ -276,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); } @@ -339,7 +336,6 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) void Perl_lex_start(pTHX_ SV *line) { - dTHR; char *s; STRLEN len; @@ -435,7 +431,6 @@ Perl_lex_end(pTHX) STATIC void S_incline(pTHX_ char *s) { - dTHR; char *t; char *n; char *e; @@ -451,7 +446,7 @@ S_incline(pTHX_ char *s) return; if (*s == ' ' || *s == '\t') s++; - else + else return; while (SPACE_OR_TAB(*s)) s++; if (!isDIGIT(*s)) @@ -497,7 +492,6 @@ 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 && SPACE_OR_TAB(*s)) s++; @@ -616,7 +610,6 @@ S_check_uni(pTHX) { char *s; char *t; - dTHR; if (PL_oldoldbufptr != PL_last_uni) return; @@ -628,8 +621,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; } @@ -682,7 +675,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; @@ -709,7 +701,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; @@ -742,7 +734,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) || @@ -784,7 +776,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. @@ -809,10 +800,10 @@ Perl_str_to_version(pTHX_ SV *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_chk((U8*)start, &skip, 0); + n = utf8_to_uv((U8*)start, len, &skip, 0); else { n = *(U8*)start; skip = 1; @@ -824,7 +815,7 @@ Perl_str_to_version(pTHX_ SV *sv) return retval; } -/* +/* * S_force_version * Forces the next token to be a version number. */ @@ -844,7 +835,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)) { @@ -857,7 +848,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); } @@ -965,7 +956,7 @@ S_sublex_start(pTHX) SvUTF8_on(nsv); SvREFCNT_dec(sv); sv = nsv; - } + } yylval.opval = (OP*)newSVOP(op_type, 0, sv); PL_lex_stuff = Nullsv; return THING; @@ -997,7 +988,6 @@ S_sublex_start(pTHX) STATIC I32 S_sublex_push(pTHX) { - dTHR; ENTER; PL_lex_state = PL_sublex_info.super_state; @@ -1171,7 +1161,7 @@ S_sublex_done(pTHX) } (end switch) } (end if backslash) } (end while character to read) - + */ STATIC char * @@ -1183,14 +1173,13 @@ S_scan_const(pTHX_ char *start) register char *d = SvPVX(sv); /* destination for copies */ bool dorange = FALSE; /* are we in a translit range? */ bool didrange = FALSE; /* did we just finish a 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; @@ -1244,11 +1233,11 @@ S_scan_const(pTHX_ char *start) dorange = FALSE; didrange = TRUE; continue; - } + } /* range begins (ignore - as first or last char) */ else if (*s == '-' && s+1 < send && s != start) { - if (didrange) { + if (didrange) { Perl_croak(aTHX_ "Ambiguous range in transliteration operator"); } if (utf) { @@ -1283,9 +1272,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++; } @@ -1322,27 +1311,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_chk((U8*)s, &len, 0); - 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 */ @@ -1356,7 +1328,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 = '$'; @@ -1381,9 +1352,8 @@ S_scan_const(pTHX_ char *start) /* FALL THROUGH */ default: { - dTHR; if (ckWARN(WARN_MISC) && isALNUM(*s)) - Perl_warner(aTHX_ WARN_MISC, + Perl_warner(aTHX_ WARN_MISC, "Unrecognized escape \\%c passed through", *s); /* default action is to copy the quoted character */ @@ -1394,9 +1364,11 @@ S_scan_const(pTHX_ char *start) /* \132 indicates an octal constant */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': - len = 0; /* disallow underscores */ - 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 */ @@ -1408,46 +1380,68 @@ S_scan_const(pTHX_ char *start) yyerror("Missing right brace on \\x{}"); e = s; } - len = 1; /* allow underscores */ - 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 { - len = 0; /* disallow underscores */ - 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); + U8 tmpbuf[UTF8_MAXLEN+1]; + U8 *tmpend; + + 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)) { + tmpend = uv_to_utf8(tmpbuf, (U8)*src--); + dst -= tmpend - tmpbuf; + Copy((char *)tmpbuf, dst+1, + tmpend - tmpbuf, char); } else { *dst-- = *src--; @@ -1456,9 +1450,9 @@ S_scan_const(pTHX_ char *start) } } - if (thisutf || uv > 255) { + if (to_be_utf8 || (has_utf8 && uv > 127) || uv > 255) { d = (char*)uv_to_utf8((U8*)d, uv); - has_utf = TRUE; + has_utf8 = TRUE; } else { *d++ = (char)uv; @@ -1477,17 +1471,17 @@ 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{...}" ); 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); @@ -1496,7 +1490,7 @@ S_scan_const(pTHX_ char *start) /* 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); @@ -1521,11 +1515,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; @@ -1566,6 +1562,29 @@ S_scan_const(pTHX_ char *start) continue; } /* end if (backslash) */ + /* (now in tr/// code again) */ + + 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; + continue; + } + *d++ = *s++; } /* while loop to process each character */ @@ -1573,7 +1592,7 @@ S_scan_const(pTHX_ char *start) *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 */ @@ -1585,9 +1604,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" @@ -1858,7 +1877,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). * @@ -1894,7 +1913,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 @@ -1921,8 +1940,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; @@ -1935,7 +1954,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) ; @@ -2057,28 +2076,42 @@ S_find_in_my_stash(pTHX_ char *pkgname, I32 len) if we already built the token before, use it. */ +#ifdef USE_PURE_BISON +#ifdef __SC__ +#pragma segment Perl_yylex_r +#endif +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 -#ifdef USE_PURE_BISON -Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp) -#else Perl_yylex(pTHX) -#endif { - 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) { @@ -2086,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. @@ -2110,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 @@ -2223,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. @@ -2254,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... */ @@ -2304,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; @@ -2400,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); } ) @@ -2420,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) @@ -2485,8 +2532,32 @@ Perl_yylex(pTHX) goto retry; } do { - bool bof; - bof = PL_rsfp && (PerlIO_tell(PL_rsfp) == 0); /* *Before* read! */ + bof = PL_rsfp ? TRUE : FALSE; + if (bof) { +#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) == 0; +#else + bof = PerlIO_tell(PL_rsfp) == 0; +#endif + } s = filter_gets(PL_linestr, PL_rsfp, 0); if (s == Nullch) { fake_eof: @@ -2526,7 +2597,7 @@ Perl_yylex(pTHX) PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_doextract = FALSE; } - } + } incline(s); } while (PL_doextract); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s; @@ -2651,7 +2722,7 @@ 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 @@ -2699,7 +2770,7 @@ 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: @@ -2735,6 +2806,8 @@ Perl_yylex(pTHX) goto retry; case '-': if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) { + I32 ftst = 0; + s++; PL_bufptr = s; tmp = *s++; @@ -2744,42 +2817,64 @@ Perl_yylex(pTHX) 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; } + if (ftst) { + PL_last_lop_op = ftst; + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw file test %c\n", ftst); + } ) + FTST(ftst); + } + else { + /* Assume it was a minus followed by a one-letter named + * subroutine call (or a -bareword), then. */ + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### %c looked like a file test but was not\n", ftst); + } ) + s -= 2; + } } tmp = *s++; if (*s == tmp) { @@ -3040,6 +3135,9 @@ Perl_yylex(pTHX) 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('-'); } @@ -3477,8 +3575,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(); @@ -3522,13 +3620,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 in '%s'\n", s); + } ) if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; @@ -3545,6 +3649,9 @@ Perl_yylex(pTHX) case '"': s = scan_str(s,FALSE,FALSE); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw string in '%s'\n", s); + } ) if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; @@ -3558,7 +3665,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; } @@ -3567,6 +3674,9 @@ Perl_yylex(pTHX) case '`': s = scan_str(s,FALSE,FALSE); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw backtick string in '%s'\n", s); + } ) if (PL_expect == XOPERATOR) no_op("Backticks",s); if (!s) @@ -3592,7 +3702,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;> */ @@ -3603,7 +3713,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); } } @@ -3682,6 +3792,8 @@ Perl_yylex(pTHX) 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); } @@ -3766,7 +3878,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; @@ -3823,10 +3935,10 @@ Perl_yylex(pTHX) /* If not a declared subroutine, it's an indirect object. */ /* (But it's an indir obj regardless for sort.) */ - if ((PL_last_lop_op == OP_SORT || - (!immediate_paren && (!gv || !GvCVu(gv)))) && + if ( !immediate_paren && (PL_last_lop_op == OP_SORT || + ((!gv || !GvCVu(gv)) && (PL_last_lop_op != OP_MAPSTART && - PL_last_lop_op != OP_GREPSTART)) + PL_last_lop_op != OP_GREPSTART)))) { PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR; goto bareword; @@ -3841,6 +3953,8 @@ Perl_yylex(pTHX) 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); } @@ -4012,6 +4126,10 @@ Perl_yylex(pTHX) } } #endif +#ifdef PERLIO_LAYERS + if (UTF && !IN_BYTE) + PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8"); +#endif PL_rsfp = Nullfp; } goto fake_eof; @@ -4162,7 +4280,7 @@ Perl_yylex(pTHX) case KEY_exists: UNI(OP_EXISTS); - + case KEY_exit: UNI(OP_EXIT); @@ -4366,7 +4484,7 @@ Perl_yylex(pTHX) case KEY_last: s = force_word(s,WORD,TRUE,FALSE,FALSE); LOOPX(OP_LAST); - + case KEY_lc: UNI(OP_LC); @@ -4511,7 +4629,7 @@ Perl_yylex(pTHX) case KEY_pos: UNI(OP_POS); - + case KEY_pack: LOP(OP_PACK,XTERM); @@ -4542,6 +4660,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; @@ -4562,8 +4681,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, tokeq(newSVpvn(b, d-b)))); + newSVOP(OP_CONST, 0, tokeq(sv))); } } if (words) { @@ -4673,7 +4795,7 @@ Perl_yylex(pTHX) case KEY_chomp: UNI(OP_CHOMP); - + case KEY_scalar: UNI(OP_SCALAR); @@ -4962,7 +5084,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"); } @@ -5017,7 +5139,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); } @@ -5163,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; @@ -5307,7 +5429,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; @@ -5389,11 +5511,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; @@ -5500,7 +5622,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; @@ -5529,7 +5651,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; @@ -5609,7 +5731,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; } @@ -5655,7 +5777,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++) { @@ -5710,18 +5831,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; @@ -5741,11 +5871,11 @@ 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, 3); if (pv) @@ -5755,9 +5885,9 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, PUSHs(typesv); 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; @@ -5770,12 +5900,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; @@ -5786,7 +5916,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) { @@ -5806,9 +5936,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); @@ -5858,9 +5988,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); @@ -5913,7 +6043,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); @@ -5929,7 +6059,6 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des *d = '\0'; 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, @@ -5940,8 +6069,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)) @@ -5961,7 +6090,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))) { @@ -6150,7 +6278,9 @@ S_scan_trans(pTHX_ char *start) squash = OPpTRANS_SQUASH; s++; } - o->op_private = del|squash|complement; + 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; @@ -6160,7 +6290,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; @@ -6345,6 +6474,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; @@ -6495,7 +6626,7 @@ 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 @@ -6512,14 +6643,13 @@ S_scan_inputsymbol(pTHX_ char *start) 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)) @@ -6530,8 +6660,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); @@ -6577,8 +6707,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; } } @@ -6606,8 +6736,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; } } @@ -6662,12 +6792,12 @@ 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); } - + /* 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++; @@ -6681,7 +6811,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 @@ -6710,9 +6840,9 @@ 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 */ @@ -6728,7 +6858,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': @@ -6743,7 +6873,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; @@ -6831,7 +6960,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)) @@ -6863,7 +6991,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", @@ -6872,7 +6999,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", @@ -6898,11 +7024,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; @@ -6918,7 +7043,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"); } @@ -7027,7 +7151,7 @@ Perl_scan_num(pTHX_ char *start) 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. + 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) @@ -7038,7 +7162,7 @@ Perl_scan_num(pTHX_ char *start) 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 */ { @@ -7055,7 +7179,7 @@ Perl_scan_num(pTHX_ char *start) #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; @@ -7070,7 +7194,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' */ @@ -7115,7 +7239,8 @@ vstring: SvREADONLY_on(sv); if (utf8) { SvUTF8_on(sv); - sv_utf8_downgrade(sv, TRUE); + if (!UTF||IN_BYTE) + sv_utf8_downgrade(sv, TRUE); } } } @@ -7125,9 +7250,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; } @@ -7135,7 +7260,6 @@ vstring: STATIC char * S_scan_formline(pTHX_ register char *s) { - dTHR; register char *eol; register char *t; SV *stuff = newSVpvn("",0); @@ -7226,7 +7350,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; @@ -7282,7 +7405,6 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) int Perl_yywarn(pTHX_ char *s) { - dTHR; PL_in_eval |= EVAL_WARNONLY; yyerror(s); PL_in_eval &= ~EVAL_WARNONLY; @@ -7292,7 +7414,6 @@ Perl_yywarn(pTHX_ char *s) int Perl_yyerror(pTHX_ char *s) { - dTHR; char *where = NULL; char *context = NULL; int contlen = -1; @@ -7376,8 +7497,8 @@ S_swallow_bom(pTHX_ U8 *s) STRLEN slen; slen = SvCUR(PL_linestr); switch (*s) { - case 0xFF: - if (s[1] == 0xFE) { + 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"); @@ -7479,7 +7600,7 @@ utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen) 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); } @@ -581,12 +581,6 @@ */ /*#define HAS_STRTOL / **/ -/* HAS_STRTOUL: - * This symbol, if defined, indicates that the strtoul routine is - * available to provide conversion of strings to unsigned long. - */ -/*#define HAS_STRTOUL / **/ - /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. @@ -957,12 +951,6 @@ */ #define SH_PATH "" /**/ -/* 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 char /**/ - /* CROSSCOMPILE: * This symbol, if defined, signifies that we our * build process is a cross-compilation. @@ -1065,8 +1053,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 "/usr/local/lib/perl5/5.6/unknown" / **/ -/*#define ARCHLIB_EXP "/usr/local/lib/perl5/5.6/unknown" / **/ +/*#define ARCHLIB "/usr/local/lib/perl5/5.7/unknown" / **/ +/*#define ARCHLIB_EXP "/usr/local/lib/perl5/5.7/unknown" / **/ /* ARCHNAME: * This symbol holds a string representing the architecture name. @@ -1204,6 +1192,12 @@ #define CPPRUN "" #define CPPLAST "" +/* HAS__FWALK: + * This symbol, if defined, indicates that the _fwalk system call is + * available to apply a function to all the file handles. + */ +/*#define HAS__FWALK / **/ + /* HAS_ACCESS: * This manifest constant lets the C program know that the access() * system call is available to check for accessibility using real UID/GID. @@ -1301,6 +1295,13 @@ */ /*#define HAS_ENDSERVENT / **/ +/* FCNTL_CAN_LOCK: + * This symbol, if defined, indicates that fcntl() can be used + * for file locking. Normally on Unix systems this is defined. + * It may be undefined on VMS. + */ +/*#define FCNTL_CAN_LOCK / **/ + /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in <sys/types.h> @@ -1343,6 +1344,13 @@ */ /*#define HAS_FSTATFS / **/ +/* HAS_FSYNC: + * This symbol, if defined, indicates that the fsync routine is + * available to write a file's modified data and attributes to + * permanent storage. + */ +/*#define HAS_FSYNC / **/ + /* HAS_FTELLO: * This symbol, if defined, indicates that the ftello routine is * available to ftell beyond 32 bits (useful for ILP32 hosts). @@ -1483,12 +1491,30 @@ */ /*#define HAS_GETNET_PROTOS / **/ +/* HAS_GETPAGESIZE: + * This symbol, if defined, indicates that the getpagesize system call + * is available to get system page size, which is the granularity of + * many memory management calls. + */ +/*#define HAS_GETPAGESIZE / **/ + /* HAS_GETPROTOENT: * This symbol, if defined, indicates that the getprotoent() routine is * available to look up protocols in some data base or another. */ /*#define HAS_GETPROTOENT / **/ +/* HAS_GETPGRP: + * This symbol, if defined, indicates that the getpgrp routine is + * available to get the current process group. + */ +/* USE_BSD_GETPGRP: + * This symbol, if defined, indicates that getpgrp needs one + * arguments whereas USG one needs none. + */ +/*#define HAS_GETPGRP / **/ +/*#define USE_BSD_GETPGRP / **/ + /* HAS_GETPROTOBYNAME: * This symbol, if defined, indicates that the getprotobyname() * routine is available to look up protocols by their name. @@ -1798,6 +1824,15 @@ */ /*#define HAS_SANE_MEMCMP / **/ +/* HAS_SBRK_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the sbrk() function. Otherwise, it is up + * to the program to supply one. Good guesses are + * extern void* sbrk _((int)); + * extern void* sbrk _((size_t)); + */ +/*#define HAS_SBRK_PROTO / **/ + /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. @@ -1835,6 +1870,18 @@ */ /*#define HAS_SETPROTOENT / **/ +/* HAS_SETPGRP: + * This symbol, if defined, indicates that the setpgrp routine is + * available to set the current process group. + */ +/* USE_BSD_SETPGRP: + * This symbol, if defined, indicates that setpgrp needs two + * arguments whereas USG one needs none. See also HAS_SETPGID + * for a POSIX interface. + */ +/*#define HAS_SETPGRP / **/ +/*#define USE_BSD_SETPGRP / **/ + /* HAS_SETPROCTITLE: * This symbol, if defined, indicates that the setproctitle routine is * available to set process title. @@ -2024,12 +2071,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)->_IO_read_ptr) /*#define STDIO_PTR_LVALUE / **/ #define FILE_cnt(fp) ((fp)->_IO_read_end - (fp)->_IO_read_ptr) /*#define STDIO_CNT_LVALUE / **/ +/*#define STDIO_PTR_LVAL_SETS_CNT / **/ +/*#define STDIO_PTR_LVAL_NOCHANGE_CNT / **/ #endif /* USE_STDIO_BASE: @@ -2089,6 +2147,18 @@ */ /*#define HAS_STRTOLL / **/ +/* HAS_STRTOQ: + * This symbol, if defined, indicates that the strtoq routine is + * available to convert strings to long longs (quads). + */ +/*#define HAS_STRTOQ / **/ + +/* HAS_STRTOUL: + * This symbol, if defined, indicates that the strtoul routine is + * available to provide conversion of strings to unsigned long. + */ +/*#define HAS_STRTOUL / **/ + /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. @@ -2579,6 +2649,17 @@ #define RD_NODATA -1 #undef EOF_NONBLOCK +/* NEED_VA_COPY: + * This symbol, if defined, indicates that the system stores + * the variable argument list datatype, va_list, in a format + * that cannot be copied by simple assignment, so that some + * other means must be used when copying is required. + * As such systems vary in their provision (or non-provision) + * of copying mechanisms, handy.h defines a platform- + * independent macro, Perl_va_copy(src, dst), to do the job. + */ +/*#define NEED_VA_COPY / **/ + /* Netdb_host_t: * This symbol holds the type used for the 1st argument * to gethostbyaddr(). @@ -2711,7 +2792,7 @@ #endif #define NVSIZE 8 /**/ #undef NV_PRESERVES_UV -#define NV_PRESERVES_UV_BITS +#define NV_PRESERVES_UV_BITS 0 /* IVdf: * This symbol defines the format string used for printing a Perl IV @@ -2766,8 +2847,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 "/usr/local/lib/perl5/5.6" /**/ -#define PRIVLIB_EXP "/usr/local/lib/perl5/5.6" /**/ +#define PRIVLIB "/usr/local/lib/perl5/5.7" /**/ +#define PRIVLIB_EXP "/usr/local/lib/perl5/5.7" /**/ /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor @@ -2928,6 +3009,12 @@ */ #define STARTPERL "" /**/ +/* STDCHAR: + * This symbol is defined to be the type of char used in stdio.h. + * It has the values "unsigned char" or "char". + */ +#define STDCHAR char /**/ + /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array * holding the stdio streams. @@ -3146,27 +3233,4 @@ #define PERL_XS_APIVERSION "5.005" #define PERL_PM_APIVERSION "5.005" -/* HAS_GETPGRP: - * This symbol, if defined, indicates that the getpgrp routine is - * available to get the current process group. - */ -/* USE_BSD_GETPGRP: - * This symbol, if defined, indicates that getpgrp needs one - * arguments whereas USG one needs none. - */ -/*#define HAS_GETPGRP / **/ -/*#define USE_BSD_GETPGRP / **/ - -/* HAS_SETPGRP: - * This symbol, if defined, indicates that the setpgrp routine is - * available to set the current process group. - */ -/* USE_BSD_SETPGRP: - * This symbol, if defined, indicates that setpgrp needs two - * arguments whereas USG one needs none. See also HAS_SETPGID - * for a POSIX interface. - */ -/*#define HAS_SETPGRP / **/ -/*#define USE_BSD_SETPGRP / **/ - #endif diff --git a/uconfig.sh b/uconfig.sh index faf618a955..f6d64aef62 100755 --- a/uconfig.sh +++ b/uconfig.sh @@ -4,8 +4,8 @@ _o='.o' afs='false' alignbytes='4' apiversion='5.005' -archlib='/usr/local/lib/perl5/5.6/unknown' -archlibexp='/usr/local/lib/perl5/5.6/unknown' +archlib='/usr/local/lib/perl5/5.7/unknown' +archlibexp='/usr/local/lib/perl5/5.7/unknown' archname='unknown' bin='/usr/local/bin' bincompat5005='define' @@ -16,7 +16,6 @@ clocktype='clock_t' cpp_stuff='42' crosscompile='undef' d_Gconvert='sprintf((b),"%.*g",(n),(x))' -d_SCNfldbl='undef' d_PRIEUldbl='undef' d_PRIFUldbl='undef' d_PRIGUldbl='undef' @@ -29,6 +28,8 @@ d_PRIi64='undef' d_PRIo64='undef' d_PRIu64='undef' d_PRIx64='undef' +d_SCNfldbl='undef' +d__fwalk='undef' d_access='undef' d_accessx='undef' d_alarm='undef' @@ -70,12 +71,12 @@ d_endnent='undef' d_endpent='undef' d_endpwent='undef' d_endsent='undef' -d_endspent='undef' d_eofnblk='undef' d_eunice='undef' d_fchmod='undef' d_fchown='undef' d_fcntl='undef' +d_fcntl_can_lock='undef' d_fd_macros='undef' d_fd_set='undef' d_fds_bits='undef' @@ -85,14 +86,18 @@ d_flock='undef' d_fork='define' d_fpathconf='undef' d_fpos64_t='undef' +d_frexpl='undef' d_fs_data_s='undef' d_fseeko='undef' d_fsetpos='undef' d_fstatfs='undef' d_fstatvfs='undef' +d_fsync='undef' d_ftello='undef' d_ftime='undef' d_getcwd='undef' +d_getespwnam='undef' +d_getfsstat='undef' d_getgrent='undef' d_getgrps='undef' d_gethbyaddr='undef' @@ -107,6 +112,7 @@ d_getnbyaddr='undef' d_getnbyname='undef' d_getnent='undef' d_getnetprotos='undef' +d_getpagsz='undef' d_getpbyname='undef' d_getpbynumber='undef' d_getpent='undef' @@ -116,6 +122,7 @@ d_getpgrp='undef' d_getppid='undef' d_getprior='undef' d_getprotoprotos='undef' +d_getprpwnam='undef' d_getpwent='undef' d_getsbyname='undef' d_getsbyport='undef' @@ -131,8 +138,10 @@ d_htonl='undef' d_iconv='undef' d_index='undef' d_inetaton='undef' -d_int64t='undef' +d_int64_t='undef' d_isascii='undef' +d_isnan='undef' +d_isnanl='undef' d_killpg='undef' d_lchown='undef' d_ldbl_dig='undef' @@ -141,7 +150,9 @@ d_locconv='undef' d_lockf='undef' d_longdbl='undef' d_longlong='undef' +d_lseekproto='undef' d_lstat='undef' +d_madvise='undef' d_mblen='undef' d_mbstowcs='undef' d_mbtowc='undef' @@ -156,6 +167,8 @@ d_mkfifo='undef' d_mkstemp='undef' d_mkstemps='undef' d_mktime='undef' +d_mmap='undef' +d_modfl='undef' d_mprotect='undef' d_msg='undef' d_msg_ctrunc='undef' @@ -172,6 +185,7 @@ d_munmap='undef' d_mymalloc='undef' d_nice='undef' d_nv_preserves_uv='undef' +d_nv_preserves_uv_bits='0' d_off64_t='undef' d_old_pthread_create_joinable='undef' d_oldpthreads='undef' @@ -179,6 +193,7 @@ d_oldsock='undef' d_open3='undef' d_pathconf='undef' d_pause='undef' +d_perl_otherlibdirs='undef' d_phostname='undef' d_pipe='undef' d_poll='undef' @@ -192,6 +207,7 @@ d_pwexpire='undef' d_pwgecos='undef' d_pwpasswd='undef' d_pwquota='undef' +d_qgcvt='undef' d_quad='undef' d_readdir='undef' d_readlink='undef' @@ -201,6 +217,7 @@ d_rmdir='undef' d_safebcpy='undef' d_safemcpy='undef' d_sanemcmp='undef' +d_sbrkproto='undef' d_sched_yield='undef' d_scm_rights='undef' d_seekdir='undef' @@ -234,7 +251,6 @@ d_setrgid='undef' d_setruid='undef' d_setsent='undef' d_setsid='undef' -d_setspent='undef' d_setvbuf='undef' d_sfio='undef' d_shm='undef' @@ -246,6 +262,7 @@ d_shmget='undef' d_sigaction='undef' d_sigsetjmp='undef' d_socket='undef' +d_socklen_t='undef' d_sockpair='undef' d_socks5_init='undef' d_sqrtl='undef' @@ -255,6 +272,8 @@ d_statfs_s='undef' d_statvfs='undef' d_stdio_cnt_lval='undef' d_stdio_ptr_lval='undef' +d_stdio_ptr_lval_nochange_cnt='undef' +d_stdio_ptr_lval_sets_cnt='undef' d_stdio_stream_array='undef' d_stdiobase='undef' d_stdstdio='undef' @@ -267,6 +286,7 @@ d_strtod='undef' d_strtol='undef' d_strtold='undef' d_strtoll='undef' +d_strtoq='undef' d_strtoul='undef' d_strtoull='undef' d_strtouq='undef' @@ -290,6 +310,7 @@ d_umask='undef' d_uname='undef' d_union_semun='undef' d_ustat='undef' +d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' d_vfork='undef' @@ -344,6 +365,7 @@ i_float='undef' i_gdbm='undef' i_grp='undef' i_iconv='undef' +i_ieeefp='undef' i_inttypes='undef' i_libutil='undef' i_limits='undef' @@ -359,6 +381,7 @@ i_neterrno='undef' i_netinettcp='undef' i_niin='undef' i_poll='undef' +i_prot='undef' i_pthread='undef' i_pwd='undef' i_rpcsvcdbm='undef' @@ -370,6 +393,7 @@ i_stdarg='define' i_stddef='undef' i_stdlib='undef' i_string='define' +i_sunmath='undef' i_sysaccess='undef' i_sysdir='undef' i_sysfile='undef' @@ -377,6 +401,8 @@ i_sysfilio='undef' i_sysin='undef' i_sysioctl='undef' i_syslog='undef' +i_sysmman='undef' +i_sysmode='undef' i_sysmount='undef' i_sysndir='undef' i_sysparam='undef' @@ -393,6 +419,7 @@ i_systimes='undef' i_systypes='undef' i_sysuio='undef' i_sysun='undef' +i_sysutsname='undef' i_sysvfs='undef' i_syswait='undef' i_termio='undef' @@ -406,6 +433,7 @@ i_varargs='undef' i_varhdr='stdarg.h' i_vfork='undef' ignore_versioned_solibs='y' +inc_version_list_init='NULL' installstyle='lib/perl5' installusrbinperl='undef' intsize='4' @@ -426,6 +454,7 @@ modetype=int multiarch='undef' myarchname='unknown' myuname='unknown' +need_va_copy='undef' netdb_hlen_type='int' netdb_host_type='const char *' netdb_name_type='const char *' @@ -444,8 +473,8 @@ osname='unknown' phostname='hostname' pidtype=int pm_apiversion='5.005' -privlib='/usr/local/lib/perl5/5.6' -privlibexp='/usr/local/lib/perl5/5.6' +privlib='/usr/local/lib/perl5/5.7' +privlibexp='/usr/local/lib/perl5/5.7' prototype='undef' ptrsize=1 quadkind='4' @@ -466,6 +495,7 @@ sPRIi64='"Li"' sPRIo64='"Lo"' sPRIu64='"Lu"' sPRIx64='"Lx"' +sSCNfldbl='"llf"' sched_yield='sched_yield()' scriptdir='/usr/local/bin' scriptdirexp='/usr/local/bin' @@ -478,9 +508,9 @@ sig_count='64' sig_name_init='0' sig_num_init='0' signal_t=int -sizetype=int sizesize=1 -sSCNfldbl='"llf"' +sizetype=int +socksizetype='int' ssizetype=int stdchar=char stdio_base='((fp)->_IO_read_base)' @@ -505,12 +535,12 @@ uidsize='4' uidtype=int uquadtype='uint64_t' use5005threads='undef' -use64bits='undef' +use64bitall='undef' +use64bitint='undef' usedl='undef' useithreads='undef' uselargefiles='undef' uselongdouble='undef' -uselonglong='undef' usemorebits='undef' usemultiplicity='undef' usemymalloc='n' @@ -532,28 +562,3 @@ uvxformat='"lx"' versiononly='undef' voidflags=1 xs_apiversion='5.005' -d_getfsstat='undef' -d_int64_t='undef' -d_lseekproto='undef' -d_madvise='undef' -d_mmap='undef' -use64bitint='undef' -use64bitall='undef' -d_vendorarch='undef' -d_vendorarch='undef' -i_ieeefp='undef' -i_sunmath='undef' -i_sysmode='undef' -i_sysutsname='undef' -d_frexpl='undef' -d_modfl='undef' -d_getespwnam='undef' -d_getprpwnam='undef' -d_isnan='undef' -d_isnanl='undef' -i_prot='undef' -d_perl_otherlibdirs='undef' -inc_version_list_init='NULL' -socksizetype='int' - - diff --git a/universal.c b/universal.c index 0899b1a601..12d31e58b1 100644 --- a/universal.c +++ b/universal.c @@ -74,7 +74,6 @@ 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", @@ -129,11 +129,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 @@ -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. @@ -27,21 +27,24 @@ /* Unicode support */ U8 * -Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) +Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) /* the d must be UTF8_MAXLEN+1 deep */ { if (uv < 0x80) { *d++ = uv; + *d = 0; return d; } if (uv < 0x800) { *d++ = (( uv >> 6) | 0xc0); *d++ = (( uv & 0x3f) | 0x80); + *d = 0; return d; } if (uv < 0x10000) { *d++ = (( uv >> 12) | 0xe0); *d++ = (((uv >> 6) & 0x3f) | 0x80); *d++ = (( uv & 0x3f) | 0x80); + *d = 0; return d; } if (uv < 0x200000) { @@ -49,6 +52,7 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) *d++ = (((uv >> 12) & 0x3f) | 0x80); *d++ = (((uv >> 6) & 0x3f) | 0x80); *d++ = (( uv & 0x3f) | 0x80); + *d = 0; return d; } if (uv < 0x4000000) { @@ -57,6 +61,7 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) *d++ = (((uv >> 12) & 0x3f) | 0x80); *d++ = (((uv >> 6) & 0x3f) | 0x80); *d++ = (( uv & 0x3f) | 0x80); + *d = 0; return d; } if (uv < 0x80000000) { @@ -66,10 +71,11 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) *d++ = (((uv >> 12) & 0x3f) | 0x80); *d++ = (((uv >> 6) & 0x3f) | 0x80); *d++ = (( uv & 0x3f) | 0x80); + *d = 0; return d; } #ifdef HAS_QUAD - if (uv < 0x1000000000LL) + if (uv < UTF8_QUAD_MAX) #endif { *d++ = 0xfe; /* Can't match U+FEFF! */ @@ -79,6 +85,7 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) *d++ = (((uv >> 12) & 0x3f) | 0x80); *d++ = (((uv >> 6) & 0x3f) | 0x80); *d++ = (( uv & 0x3f) | 0x80); + *d = 0; return d; } #ifdef HAS_QUAD @@ -96,6 +103,7 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) *d++ = (((uv >> 12) & 0x3f) | 0x80); *d++ = (((uv >> 6) & 0x3f) | 0x80); *d++ = (( uv & 0x3f) | 0x80); + *d = 0; return d; } #endif @@ -104,27 +112,41 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) /* 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 +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; 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; } @@ -140,138 +162,356 @@ string, false otherwise. bool Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len) { - U8* x=s; - U8* send=s+len; - int c; + 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 (!c || x > send) - return 0; } - return 1; + if (x != send) + return FALSE; + + return TRUE; } /* -=for apidoc Am|U8* s|utf8_to_uv_chk|I32 *retlen|I32 checking +=for apidoc Am|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; C<retlen> will be set to the -length, in bytes, of that character, and the pointer C<s> will be -advanced to the end of the character. +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<checking>: if this is true, it is -assumed that the caller will raise a warning, and this function will -set C<retlen> to C<-1> and return. If C<checking> is not true, an optional UTF8 -warning is produced. +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. -=cut -*/ +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_chk(pTHX_ U8* s, I32* retlen, bool checking) -{ - UV uv = *s; - int len; - if (!(uv & 0x80)) { - if (retlen) - *retlen = 1; - return *s; +Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags) +{ + 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 (checking && retlen) { - *retlen = -1; - return 0; - } - 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 (checking && retlen) { - *retlen = -1; - return 0; - } - - 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; } /* -=for apidoc Am|U8* s|utf8_to_uv|I32 *retlen +=for apidoc Am|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, and the pointer C<s> will be -advanced to the end of the character. +length, in bytes, of that character. -If C<s> does not point to a well-formed UTF8 character, an optional UTF8 -warning is produced. +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(pTHX_ U8* s, I32* retlen) +Perl_utf8_to_uv_simple(pTHX_ U8* s, STRLEN* retlen) { - return Perl_utf8_to_uv_chk(aTHX_ s, retlen, 0); + return Perl_utf8_to_uv(aTHX_ s, UTF8_MAXLEN, retlen, 0); } -/* utf8_distance(a,b) returns the number of UTF8 characters between - the pointers a and b */ +/* +=for apidoc Am|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 Am|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 */ -I32 +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 Am|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); @@ -279,10 +519,8 @@ 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; @@ -302,32 +540,27 @@ Returns zero on failure, setting C<len> to -1. U8 * Perl_utf8_to_bytes(pTHX_ U8* s, STRLEN *len) { - dTHR; U8 *send; U8 *d; - U8 *save; - - send = s + *len; - d = save = s; + U8 *save = s; /* ensure valid UTF8 and chars < 256 before updating string */ - while (s < send) { - U8 c = *s++; + for (send = s + *len; s < send; ) { + U8 c = *s++; + if (c >= 0x80 && - ( (s >= send) || ((*s++ & 0xc0) != 0x80) || ((c & 0xfe) != 0xc2))) { - *len = -1; - return 0; - } + ((s >= send) || + ((*s++ & 0xc0) != 0x80) || ((c & 0xfe) != 0xc2))) { + *len = -1; + return 0; + } } - s = save; + + d = s = save; while (s < send) { - if (*s < 0x80) - *d++ = *s++; - else { - I32 ulen; - *d++ = (U8)utf8_to_uv(s, &ulen); - s += ulen; - } + STRLEN ulen; + *d++ = (U8)utf8_to_uv_simple(s, &ulen); + s += ulen; } *d = '\0'; *len = d - save; @@ -347,7 +580,6 @@ reflect the new length. U8* Perl_bytes_to_utf8(pTHX_ U8* s, STRLEN *len) { - dTHR; U8 *send; U8 *d; U8 *dst; @@ -400,7 +632,6 @@ Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen) continue; } if (uv >= 0xd800 && uv < 0xdbff) { /* surrogates */ - dTHR; UV low = *p++; if (low < 0xdc00 || low >= 0xdfff) Perl_croak(aTHX_ "Malformed UTF-16 surrogate"); @@ -445,7 +676,7 @@ Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen) 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); } @@ -453,7 +684,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); } @@ -461,7 +692,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); } @@ -469,7 +700,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); } @@ -477,7 +708,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); } @@ -485,7 +716,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); } @@ -493,7 +724,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); } @@ -501,7 +732,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); } @@ -509,7 +740,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); } @@ -517,7 +748,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); } @@ -525,7 +756,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); } @@ -533,7 +764,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); } @@ -541,7 +772,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); } @@ -549,7 +780,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); } @@ -557,7 +788,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); } @@ -565,7 +796,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); } @@ -573,7 +804,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); } @@ -751,7 +982,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); } @@ -853,7 +1084,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_chk(p,0,0); + return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0); } UV @@ -864,7 +1095,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_chk(p,0,0); + return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0); } UV @@ -875,7 +1106,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_chk(p,0,0); + return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0); } /* a "swash" is a swatch hash */ @@ -884,7 +1115,7 @@ SV* Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none) { SV* retval; - char tmpbuf[256]; + SV* tokenbufsv = sv_2mortal(NEWSV(0,0)); dSP; if (!gv_stashpv(pkg, 0)) { /* demand load utf8 */ @@ -906,8 +1137,9 @@ 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--); else @@ -915,7 +1147,10 @@ Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none) 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) @@ -965,7 +1200,7 @@ Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr) PUSHMARK(SP); EXTEND(SP,3); PUSHs((SV*)sv); - PUSHs(sv_2mortal(newSViv(utf8_to_uv_chk(ptr, 0, 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)) @@ -992,7 +1227,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; @@ -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,64 @@ 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) + +#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_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 UTF8LEN(uv) ( (uv) < 0x80 ? 1 : \ +#define UNISKIP(uv) ( (uv) < 0x80 ? 1 : \ (uv) < 0x800 ? 2 : \ (uv) < 0x10000 ? 3 : \ (uv) < 0x200000 ? 4 : \ (uv) < 0x4000000 ? 5 : \ (uv) < 0x80000000 ? 6 : \ - (uv) < 0x1000000000LL ? 7 : 13 ) + (uv) < UTF8_QUAD_MAX ? 7 : 13 ) #else /* No, I'm not even going to *TRY* putting #ifdef inside a #define */ -#define UTF8LEN(uv) ( (uv) < 0x80 ? 1 : \ +#define UNISKIP(uv) ( (uv) < 0x80 ? 1 : \ (uv) < 0x800 ? 2 : \ (uv) < 0x10000 ? 3 : \ (uv) < 0x200000 ? 4 : \ @@ -53,6 +94,7 @@ END_EXTERN_C (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 @@ -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. @@ -26,11 +26,6 @@ #endif #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 @@ -115,7 +110,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) Malloc_t PerlMem_realloc(); #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ -#ifdef HAS_64K_LIMIT +#ifdef HAS_64K_LIMIT if (size > 0xffff) { PerlIO_printf(Perl_error_log, "Reallocation too large: %lx\n", size) FLUSH; @@ -135,7 +130,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) #endif ptr = (Malloc_t)PerlMem_realloc(where,size); PERL_ALLOC_CHECK(ptr); - + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); @@ -245,12 +240,12 @@ Perl_safexrealloc(Malloc_t wh, MEM_SIZE size) if (!wh) return safexmalloc(0,size); - + { MEM_SIZE old = sizeof_chunk(where - ALIGN); int t = typeof_chunk(where - ALIGN); register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN); - + xycount[t][SIZE_TO_Y(old)]--; xycount[t][SIZE_TO_Y(size)]++; xcount[t] += size - old; @@ -265,7 +260,7 @@ Perl_safexfree(Malloc_t wh) I32 x; char *where = (char*)wh; MEM_SIZE size; - + if (!where) return; where -= ALIGN; @@ -297,7 +292,7 @@ S_xstat(pTHX_ int flag) for (j = 0; j < MAXYCOUNT; j++) { subtot[j] = 0; } - + PerlIO_printf(Perl_debug_log, " Id subtot 4 8 12 16 20 24 28 32 36 40 48 56 64 72 80 80+\n", total); for (i = 0; i < MAXXCOUNT; i++) { total += xcount[i]; @@ -306,21 +301,21 @@ S_xstat(pTHX_ int flag) } if (flag == 0 ? xcount[i] /* Have something */ - : (flag == 2 + : (flag == 2 ? xcount[i] != lastxcount[i] /* Changed */ : xcount[i] > lastxcount[i])) { /* Growed */ - PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100, + PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100, flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]); lastxcount[i] = xcount[i]; for (j = 0; j < MAXYCOUNT; j++) { - if ( flag == 0 + if ( flag == 0 ? xycount[i][j] /* Have something */ - : (flag == 2 + : (flag == 2 ? xycount[i][j] != lastxycount[i][j] /* Changed */ : xycount[i][j] > lastxycount[i][j])) { /* Growed */ - PerlIO_printf(Perl_debug_log,"%3ld ", - flag == 2 - ? xycount[i][j] - lastxycount[i][j] + PerlIO_printf(Perl_debug_log,"%3ld ", + flag == 2 + ? xycount[i][j] - lastxycount[i][j] : xycount[i][j]); lastxycount[i][j] = xycount[i][j]; } else { @@ -466,7 +461,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 @@ -485,10 +480,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 @@ -497,17 +536,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")); { @@ -551,7 +590,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 @@ -559,15 +598,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(); @@ -585,6 +624,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 */ @@ -714,18 +754,18 @@ Perl_init_i18nl10n(pTHX_ int printwarn) if (setlocale_failure) { char *p; - bool locwarn = (printwarn > 1 || + bool locwarn = (printwarn > 1 || (printwarn && (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p)))); if (locwarn) { #ifdef LC_ALL - + PerlIO_printf(Perl_error_log, "perl: warning: Setting locale failed.\n"); #else /* !LC_ALL */ - + PerlIO_printf(Perl_error_log, "perl: warning: Setting locale failed for the categories:\n\t"); #ifdef USE_LOCALE_CTYPE @@ -1025,9 +1065,9 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit register I32 multiline = flags & FBMrf_MULTILINE; if (bigend - big < littlelen) { - if ( SvTAIL(littlestr) + if ( SvTAIL(littlestr) && (bigend - big == littlelen - 1) - && (littlelen == 1 + && (littlelen == 1 || (*big == *little && memEQ((char *)big, (char *)little, littlelen - 1)))) return (char*)big; @@ -1119,7 +1159,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ s = bigend - littlelen; - if (s >= big && bigend[-1] == '\n' && *s == *little + if (s >= big && bigend[-1] == '\n' && *s == *little /* Automatically of length > 2 */ && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) { @@ -1148,7 +1188,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } return b; } - + { /* Do actual FBM. */ register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET; register unsigned char *oldlittle; @@ -1208,7 +1248,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit of ends of some substring of bigstr. If `last' we want the last occurence. old_posp is the way of communication between consequent calls if - the next call needs to find the . + the next call needs to find the . The initial *old_posp should be -1. Note that we take into account SvTAIL, so one can get extra @@ -1222,7 +1262,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; @@ -1237,7 +1276,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) { cant_find: - if ( BmRARE(littlestr) == '\n' + if ( BmRARE(littlestr) == '\n' && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) { little = (unsigned char *)(SvPVX(littlestr)); littleend = little + SvCUR(littlestr); @@ -1300,7 +1339,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift found = 1; } } while ( pos += PL_screamnext[pos] ); - if (last && found) + if (last && found) return (char *)(big+(*old_posp)); #endif /* POINTERRIGOR */ check_tail: @@ -1392,7 +1431,6 @@ Perl_savepvn(pTHX_ const char *sv, register I32 len) STATIC SV * S_mess_alloc(pTHX) { - dTHR; SV *sv; XPVMG *any; @@ -1478,7 +1516,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)); @@ -1487,7 +1524,7 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n'); Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf, PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv), - line_mode ? "line" : "chunk", + line_mode ? "line" : "chunk", (IV)IoLINES(GvIOp(PL_last_in_gv))); } #ifdef USE_THREADS @@ -1502,7 +1539,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; @@ -1603,7 +1639,6 @@ Perl_die(pTHX_ const char* pat, ...) void Perl_vcroak(pTHX_ const char* pat, va_list *args) { - dTHR; char *message; HV *stash; GV *gv; @@ -1736,7 +1771,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); @@ -1768,7 +1802,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) PerlIO_write(serr, message, msglen); #ifdef LEAKTEST - DEBUG_L(*message == '!' + DEBUG_L(*message == '!' ? (xstat(message[1]=='!' ? (message[2]=='!' ? 2 : 1) : 0) @@ -1834,7 +1868,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; @@ -1860,13 +1893,13 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; SV *msg; - + ENTER; save_re_context(); msg = newSVpvn(message, msglen); SvREADONLY_on(msg); SAVEFREESV(msg); - + PUSHSTACKi(PERLSI_DIEHOOK); PUSHMARK(sp); XPUSHs(msg); @@ -1891,7 +1924,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); @@ -1901,13 +1933,13 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; SV *msg; - + ENTER; save_re_context(); msg = newSVpvn(message, msglen); SvREADONLY_on(msg); SAVEFREESV(msg); - + PUSHSTACKi(PERLSI_WARNHOOK); PUSHMARK(sp); XPUSHs(msg); @@ -1922,7 +1954,7 @@ 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(*message == '!' + DEBUG_L(*message == '!' ? (xstat(message[1]=='!' ? (message[2]=='!' ? 2 : 1) : 0) @@ -1936,7 +1968,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) #ifdef USE_ENVIRON_ARRAY /* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */ -#if !defined(WIN32) && !defined(__CYGWIN__) +#if !defined(WIN32) void Perl_my_setenv(pTHX_ char *nam, char *val) { @@ -1978,50 +2010,19 @@ 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) @@ -2082,7 +2083,6 @@ Perl_my_setenv(pTHX_ char *nam,char *val) } #endif /* WIN32 */ -#endif I32 Perl_setenv_getix(pTHX_ char *nam) @@ -2358,7 +2358,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) if (doexec) { return my_syspopen(aTHX_ cmd,mode); } -#endif +#endif This = (*mode == 'w'); that = !This; if (doexec && PL_tainting) { @@ -2455,8 +2455,12 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) PerlLIO_close(pp[0]); did_pipes = 0; if (n) { /* Error */ + int pid2, status; if (n != sizeof(int)) Perl_croak(aTHX_ "panic: kid popen errno read"); + do { + pid2 = wait4pid(pid, &status, 0); + } while (pid2 == -1 && errno == EINTR); errno = errkid; /* Propagate errno from kid */ return Nullfp; } @@ -2471,10 +2475,12 @@ FILE *popen(); PerlIO * Perl_my_popen(pTHX_ char *cmd, char *mode) { - /* Needs work for PerlIO ! */ - /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */ PERL_FLUSHALL_FOR_CHILD; - return popen(PerlIO_exportFILE(cmd, 0), mode); + /* Call system's popen() to get a FILE *, then import it. + used 0 for 2nd parameter to PerlIO_importFILE; + apparently not used + */ + return PerlIO_importFILE(popen(cmd, mode), 0); } #endif @@ -2664,7 +2670,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) if (pid == -1) { /* Opened by popen. */ return my_syspclose(ptr); } -#endif +#endif if ((close_failed = (PerlIO_close(ptr) == EOF))) { saved_errno = errno; #ifdef VMS @@ -2783,7 +2789,7 @@ my_syspclose(PerlIO *ptr) #else I32 Perl_my_pclose(pTHX_ PerlIO *ptr) -#endif +#endif { /* Needs work for PerlIO ! */ FILE *f = PerlIO_findFILE(ptr); @@ -2847,7 +2853,7 @@ Perl_cast_ulong(pTHX_ NV f) /* Code modified to prefer proper named type ranges, I32, IV, or UV, instead of LONG_(MIN/MAX). -- Kenneth Albanowski <kjahds@kjahds.com> -*/ +*/ #ifndef MY_UV_MAX # define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1) @@ -2933,7 +2939,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; @@ -2955,7 +2961,6 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) continue; } else { - dTHR; if (ckWARN(WARN_DIGIT)) Perl_warner(aTHX_ WARN_DIGIT, "Illegal binary digit '%c' ignored", *s); @@ -2966,7 +2971,6 @@ 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)) @@ -2993,8 +2997,7 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) #if UVSIZE > 4 || (!overflowed && ruv > 0xffffffff ) #endif - ) { - dTHR; + ) { if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ WARN_PORTABLE, "Binary number > 0b11111111111111111111111111111111 non-portable"); @@ -3004,7 +3007,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; @@ -3024,7 +3027,6 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) * 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); @@ -3036,7 +3038,6 @@ 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)) @@ -3064,7 +3065,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"); @@ -3074,15 +3074,25 @@ 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; register UV ruv = 0; - register bool seenx = FALSE; register bool overflowed = FALSE; char *hexdigit; + if (len > 2) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len > 3 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + for (; len-- && *s; s++) { hexdigit = strchr((char *) PL_hexdigit, *s); if (!hexdigit) { @@ -3092,13 +3102,7 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) --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); @@ -3109,7 +3113,6 @@ 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)) @@ -3136,8 +3139,7 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) #if UVSIZE > 4 || (!overflowed && ruv > 0xffffffff ) #endif - ) { - dTHR; + ) { if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ WARN_PORTABLE, "Hexadecimal number > 0xffffffff non-portable"); @@ -3149,7 +3151,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]; @@ -3357,7 +3358,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f } #ifndef DOSISH if (!xfound && !seen_dot && !xfailed && - (PerlLIO_stat(scriptname,&PL_statbuf) < 0 + (PerlLIO_stat(scriptname,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))) #endif seen_dot = 1; /* Disable message. */ @@ -3437,7 +3438,7 @@ Perl_cond_signal(pTHX_ perl_cond *cp) { perl_os_thread t; perl_cond cond = *cp; - + if (!cond) return; t = cond->thread; @@ -3457,7 +3458,7 @@ Perl_cond_broadcast(pTHX_ perl_cond *cp) { perl_os_thread t; perl_cond cond, cond_next; - + for (cond = *cp; cond; cond = cond_next) { t = cond->thread; /* Insert t in the runnable queue just ahead of us */ @@ -3480,7 +3481,7 @@ Perl_cond_wait(pTHX_ perl_cond *cp) if (thr->i.next_run == thr) Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread"); - + New(666, cond, 1, struct perl_wait_queue); cond->thread = thr; cond->next = *cp; @@ -3496,7 +3497,7 @@ MAGIC * Perl_condpair_magic(pTHX_ SV *sv) { MAGIC *mg; - + SvUPGRADE(sv, SVt_PVMG); mg = mg_find(sv, 'm'); if (!mg) { @@ -3605,6 +3606,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) thr->specific = newAV(); thr->errsv = newSVpvn("", 0); thr->flags = THRf_R_JOINABLE; + thr->thr_done = 0; MUTEX_INIT(&thr->mutex); JMPENV_BOOTSTRAP; @@ -3645,8 +3647,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) PL_nrs = newSVsv(t->Tnrs); PL_rs = SvREFCNT_inc(PL_nrs); PL_last_in_gv = Nullgv; - PL_ofslen = t->Tofslen; - PL_ofs = savepvn(t->Tofs, PL_ofslen); + PL_ofs_sv = SvREFCNT_inc(PL_ofs_sv); PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv); PL_chopset = t->Tchopset; PL_bodytarget = newSVsv(t->Tbodytarget); @@ -3667,7 +3668,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) "new_struct_thread: copied threadsv %"IVdf" %p->%p\n", (IV)i, t, thr)); } - } + } thr->threadsvp = AvARRAY(thr->threadsv); MUTEX_LOCK(&PL_threads_mutex); @@ -3692,10 +3693,10 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) #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. + * So it is in perl for (say) POSIX to use. * Needed for SunOS with Sun's 'acc' for example. */ -NV +NV Perl_huge(void) { # if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) @@ -3862,30 +3863,36 @@ Perl_get_vtbl(pTHX_ int vtbl_id) 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(&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++) @@ -3895,9 +3902,10 @@ Perl_my_fflush_all(pTHX) PerlIO_flush(&STDIO_STREAM_ARRAY[i]); return 0; } -# endif +# endif SETERRNO(EBADF,RMS$_IFI); return EOF; +# endif #endif } @@ -3953,7 +3961,15 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) name = SvPVX(sv); } - if (name && *name) { + if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) { + if (name && *name) + Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for %sput", + name, + (op == OP_phoney_INPUT_ONLY ? "in" : "out")); + else + Perl_warner(aTHX_ WARN_IO, "Filehandle opened only for %sput", + (op == OP_phoney_INPUT_ONLY ? "in" : "out")); + } else 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)) @@ -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. diff --git a/utils/h2xs.PL b/utils/h2xs.PL index 44b9ac888f..88ac482b55 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -41,7 +41,7 @@ h2xs - convert .h C header files to Perl extensions =head1 SYNOPSIS -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<-ACOPXacdfkmx>] [B<-F> addflags] [B<-M> fmask] [B<-n> module_name] [B<-o> tmask] [B<-p> prefix] [B<-s> subs] [B<-v> version] [B<-b> compat_version] [headerfile ... [extra_libraries]] B<h2xs> B<-h> @@ -403,7 +403,7 @@ 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 = $]; @@ -524,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; @@ -542,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"; } @@ -550,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])(.*)/) { @@ -603,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'; @@ -1023,7 +1043,7 @@ my $pod = <<"END" unless $opt_P; $exp_doc$meth_doc$revhist #=head1 AUTHOR # -#$author, $email +#$author, E<lt>${email}E<gt> # #=head1 SEE ALSO # @@ -1697,6 +1717,9 @@ 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; @@ -1725,32 +1748,75 @@ 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/utils/perlbug.PL b/utils/perlbug.PL index 6c92254d81..c4289f8d3a 100644 --- a/utils/perlbug.PL +++ b/utils/perlbug.PL @@ -91,7 +91,7 @@ BEGIN { $::HaveUtil = ($@ eq ""); }; -my $Version = "1.32"; +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. @@ -128,6 +128,7 @@ my $Version = "1.32"; # 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 @@ -153,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); @@ -215,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. @@ -574,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", @@ -724,10 +731,11 @@ EOF chop $action; if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve - print "\n\nName of file to save message in [perlbug.rep]: "; + my $file_save = $outfile || "perlbug.rep"; + print "\n\nName of file to save message in [$file_save]: "; my $file = scalar <>; chop $file; - $file = "perlbug.rep" if $file eq ""; + $file = $file_save if $file eq ""; unless (open(FILE, ">$file")) { print "\nError opening $file: $!\n\n"; @@ -769,7 +777,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 @@ -837,7 +845,7 @@ 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"; @@ -867,7 +875,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. @@ -889,9 +897,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. @@ -939,10 +947,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 @@ -1087,6 +1095,13 @@ version of perl comes out and your bug is still present. 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> Body of the report. If not included on the command line, or diff --git a/utils/perlcc.PL b/utils/perlcc.PL index 0c4b726d35..a9501305c8 100644 --- a/utils/perlcc.PL +++ b/utils/perlcc.PL @@ -308,10 +308,10 @@ sub cc_harness { my ($cfile,$stash)=@_; use ExtUtils::Embed (); my $command = ExtUtils::Embed::ccopts." -o $Output $cfile "; - $command .= join " -I", split /\s+/, opt(I); - $command .= join " -L", split /\s+/, opt(L); + $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); + $command .= " ".ExtUtils::Embed::ldopts("-std", \@mods); vprint 3, "running cc $command"; system("cc $command"); } diff --git a/utils/perldoc.PL b/utils/perldoc.PL index e1dd783e86..313be205dd 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -409,7 +409,11 @@ sub page { } else { foreach my $pager (@pagers) { + if ($Is_VMS) { + last if system("$pager $tmp") == 0; # quoting prevents logical expansion + } else { last if system("$pager \"$tmp\"") == 0; + } } } } diff --git a/vmesa/vmesa.c b/vmesa/vmesa.c index 0e4ad86682..8bc733b5b7 100644 --- a/vmesa/vmesa.c +++ b/vmesa/vmesa.c @@ -121,7 +121,6 @@ do_aspawn(SV* really, SV **mark, SV **sp) status = FAIL; if (sp > mark) { - dTHR; New(401,PL_Argv, sp - mark + 1, char*); a = PL_Argv; while (++mark <= sp) @@ -286,7 +285,6 @@ do_spawn(char *cmd, int execf) (const char **) environ); if (pid < 0) { - dTHR; status = FAIL; if (ckWARN(WARN_EXEC)) warner(WARN_EXEC,"Can't exec \"%s\": %s", diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index c34be75e0a..35f66762ef 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -1211,6 +1211,11 @@ cleanlis : - If F$Search("*.CPP").nes."" Then Delete/NoConfirm/Log *.CPP;* - If F$Search("*.Map").nes."" Then Delete/NoConfirm/Log *.Map;* +cleantest : + - If F$Search("[.t]Perl.").nes."" Then Delete/NoConfirm/Log [.t]Perl.;* + - If F$Search("[.t]VMSPIPE.COM").nes."" Then Delete/NoConfirm/Log [.t]VMSPIPE.COM;* + - If F$Search("[.t]Echo.exe").nes."" Then Delete/NoConfirm/Log [.t]Echo.exe;* + tidy : cleanlis - If F$Search("[...]*.Opt;-1").nes."" Then Purge/NoConfirm/Log [...]*.Opt - If F$Search("[...]*$(O);-1").nes."" Then Purge/NoConfirm/Log [...]*$(O) @@ -1247,7 +1252,7 @@ tidy : cleanlis - If F$Search("[.x2p]*.com;-1").nes."" Then Purge/NoConfirm/Log [.x2p]*.com - If F$Search("[.lib.pod]*.com;-1").nes."" Then Purge/NoConfirm/Log [.lib.pod]*.com -clean : tidy +clean : tidy cleantest - @make_ext "$(dynamic_ext)" "$(MINIPERL_EXE)" "$(MMS)" clean - If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt - If F$Search("[...]*$(O);*") .nes."" Then Delete/NoConfirm/Log [...]*$(O);* diff --git a/vms/ext/DCLsym/Makefile.PL b/vms/ext/DCLsym/Makefile.PL index 84ab2be2b5..28e2fa3758 100644 --- a/vms/ext/DCLsym/Makefile.PL +++ b/vms/ext/DCLsym/Makefile.PL @@ -1,4 +1,4 @@ use ExtUtils::MakeMaker; WriteMakefile( 'VERSION_FROM' => 'DCLsym.pm', - 'MAN3PODS' => ' '); + 'MAN3PODS' => {}); diff --git a/vms/ext/Stdio/Makefile.PL b/vms/ext/Stdio/Makefile.PL index f5599f8a96..4e17a48082 100644 --- a/vms/ext/Stdio/Makefile.PL +++ b/vms/ext/Stdio/Makefile.PL @@ -1,5 +1,5 @@ use ExtUtils::MakeMaker; WriteMakefile( 'VERSION_FROM' => 'Stdio.pm', - 'MAN3PODS' => ' ', # pods will be built later + 'MAN3PODS' => {}, # pods will be built later ); diff --git a/vms/ext/Stdio/Stdio.pm b/vms/ext/Stdio/Stdio.pm index b51f2c9f15..446b0785e1 100644 --- a/vms/ext/Stdio/Stdio.pm +++ b/vms/ext/Stdio/Stdio.pm @@ -134,7 +134,7 @@ This package C<ISA> IO::File, so that you can call IO::File methods on the handles returned by C<vmsopen> and C<vmssysopen>. The IO::File package is not initialized, however, until you actually call a method that VMS::Stdio doesn't provide. This -is doen to save startup time for users who don't wish to use +is done to save startup time for users who don't wish to use the IO::File methods. B<Note:> In order to conform to naming conventions for Perl @@ -201,7 +201,7 @@ true value if successful, and C<undef> if it fails. This function sets the default device and directory for the process. It is identical to the built-in chdir() operator, except that the change persists after Perl exits. It returns a true value on success, and -C<undef> if it encounters and error. +C<undef> if it encounters an error. =item sync diff --git a/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs index 22d9a7262c..d82b17dbfa 100644 --- a/vms/ext/Stdio/Stdio.xs +++ b/vms/ext/Stdio/Stdio.xs @@ -87,7 +87,6 @@ newFH(FILE *fp, char type) { HV *stash; IO *io; - dTHR; /* Find stash for VMS::Stdio. We don't do this once at boot * to allow for possibility of threaded Perl with per-thread * symbol tables. This code (through io = ...) is really diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl index 68bb6e8e60..48499d4a49 100644 --- a/vms/gen_shrfls.pl +++ b/vms/gen_shrfls.pl @@ -68,16 +68,21 @@ if ($docc) { elsif (-f '[-]perl.h') { $dir = '[-]'; } else { die "$0: Can't find perl.h\n"; } - # Go see if debugging is enabled in config.h - $config = $dir . "config.h"; + $use_threads = $use_mymalloc = $case_about_case = $debugging_enabled = 0; + $hide_mymalloc = $isgcc = 0; + + # Go see what is enabled in config.sh + $config = $dir . "config.sh"; open CONFIG, "< $config"; while(<CONFIG>) { - $debugging_enabled++ if /define\s+DEBUGGING/; - $use_mymalloc++ if /define\s+MYMALLOC/; - $hide_mymalloc++ if /define\s+EMBEDMYMALLOC/; - $use_threads++ if /define\s+USE_THREADS/; - $care_about_case++ if /define\s+VMS_WE_ARE_CASE_SENSITIVE/; + $use_threads++ if /usethreads='define'/; + $use_mymalloc++ if /usemymalloc='Y'/; + $care_about_case++ if /d_vms_case_sensitive_symbols='define'/; + $debugging_enabled++ if /usedebugging_perl='Y'/; + $hide_mymalloc++ if /embedmymalloc='Y'/; + $isgcc++ if /gccversion='[^']/; } + close CONFIG; # put quotes back onto defines - they were removed by DCL on the way in if (($prefix,$defines,$suffix) = @@ -92,8 +97,7 @@ if ($docc) { # check for gcc - if present, we'll need to use MACRO hack to # define global symbols for shared variables - $isgcc = `$cc_cmd _nla0:/Version` =~ /GNU/ - or 0; # make debug output nice + print "\$isgcc: $isgcc\n" if $debug; print "\$debugging_enabled: $debugging_enabled\n" if $debug; @@ -168,7 +172,7 @@ if ($docc) { else { open(CPP,"$cpp_file") or die "$0: Can't read preprocessed file $cpp_file: $!\n"; } -%checkh = map { $_,1 } qw( thread bytecode byterun proto ); +%checkh = map { $_,1 } qw( thread bytecode byterun proto perlio ); $ckfunc = 0; LINE: while (<CPP>) { while (/^#.*vmsish\.h/i .. /^#.*perl\.h/i) { diff --git a/vms/genconfig.pl b/vms/genconfig.pl index e500e760a2..ef1d5ad4a5 100644 --- a/vms/genconfig.pl +++ b/vms/genconfig.pl @@ -229,6 +229,8 @@ foreach (@ARGV) { d_wcstombs d_wctomb d_mblen d_mktime d_strcoll d_strxfrm ]) { print OUT "$_='$rtlhas'\n"; } + print OUT "d_stdio_ptr_lval_sets_cnt='undef'\n"; + print OUT "d_stdio_ptr_lval_nochange_cnt='undef'\n"; foreach (qw[ d_gettimeod d_uname d_truncate d_wait4 d_index d_pathconf d_fpathconf d_sysconf d_sigsetjmp ]) { print OUT "$_='$rtlnew'\n"; diff --git a/vms/perlvms.pod b/vms/perlvms.pod index 17e83e5c1b..f43cbb0e46 100644 --- a/vms/perlvms.pod +++ b/vms/perlvms.pod @@ -788,6 +788,14 @@ by saying (You can't just say C<$ENV{$key} = $ENV{$key}>, since the Perl optimizer is smart enough to elide the expression.) +Don't try to clear C<%ENV> by saying C<%ENV = ();>, it will throw +a fatal error. This is equivalent to doing the following from DCL: + + DELETE/LOGICAL * + +You can imagine how bad things would be if, for example, the SYS$MANAGER +or SYS$SYSTEM logicals were deleted. + At present, the first time you iterate over %ENV using C<keys>, or C<values>, you will incur a time penalty as all logical names are read, in order to fully populate %ENV. diff --git a/vms/perly_c.vms b/vms/perly_c.vms index 0676ebd249..640780af83 100644 --- a/vms/perly_c.vms +++ b/vms/perly_c.vms @@ -1749,7 +1749,7 @@ case 35: break; case 37: #line 269 "perly.y" -{ (void)scan_num("1"); yyval.opval = yylval.opval; } +{ (void)scan_num("1", &yylval); yyval.opval = yylval.opval; } break; case 39: #line 274 "perly.y" diff --git a/vms/test.com b/vms/test.com index 7b4ebce510..a0569a6bde 100644 --- a/vms/test.com +++ b/vms/test.com @@ -43,7 +43,11 @@ $! $! Pick up a copy of perl to use for the tests $ If F$Search("Perl.").nes."" Then Delete/Log/NoConfirm Perl.;* $ Copy/Log/NoConfirm [-]'ndbg'Perl'exe' []Perl. -$ +$! +$! Pick up a copy of vmspipe.com to use for the tests +$ If F$Search("VMSPIPE.COM").nes."" then Delete/Log/Noconfirm VMSPIPE.COM;* +$ Copy/Log/NoConfirm [-]VMSPIPE.COM [] +$! $! Make the environment look a little friendlier to tests which assume Unix $ cat == "Type" $ Macro/NoDebug/NoList/Object=Echo.Obj Sys$Input @@ -86,6 +90,7 @@ $ Macro/NoDebug/NoList/Object=Echo.Obj Sys$Input movl #1,r0 ret .end echo +$ If F$Search("Echo.Exe").nes."" Then Delete/Log/NoConfirm Echo.Exe;* $ Link/NoMap/NoTrace/Exe=Echo.Exe Echo.Obj; $ Delete/Log/NoConfirm Echo.Obj;* $ echo == "$" + F$Parse("Echo.Exe") @@ -114,7 +119,7 @@ use Config; @libexcl=('db-btree.t','db-hash.t','db-recno.t', 'gdbm.t','io_dup.t', 'io_pipe.t', 'io_poll.t', 'io_sel.t', 'io_sock.t', 'io_unix.t', - 'ndbm.t','odbm.t','open2.t','open3.t', 'ph.t', 'posix.t', 'dprof.t'); + 'ndbm.t','odbm.t','open2.t','open3.t', 'ph.t', 'posix.t'); # Note: POSIX is not part of basic build, but can be built # separately if you're using DECC @@ -238,7 +243,7 @@ if ($bad == 0) { } } ($user,$sys,$cuser,$csys) = times; -print sprintf("u=%g s=%g cu=%g cs=%g files=%d tests=%d\n", +print sprintf("u=%g s=%g cu=%g cs=%g scripts=%d tests=%d\n", $user,$sys,$cuser,$csys,$files,$totmax); $$END-OF-TEST$$ $ wrapup: @@ -250,7 +255,6 @@ $ Else $ Deassign 'dbg'PerlShr $ EndIf $ Show Process/Accounting -$ If F$Search("Echo.Exe").nes."" Then Delete/Log/NoConfirm Echo.Exe;* $ Set Default &olddef $ Set Message 'oldmsg' $ Exit @@ -98,6 +98,9 @@ struct itmlst_3 { #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d) #define getredirection(a,b) mp_getredirection(aTHX_ a,b) +/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */ +#define PERL_LNM_MAX_ALLOWED_INDEX 127 + static char *__mystrtolower(char *str) { if (str) for (; *str; ++str) *str= tolower(*str); @@ -152,7 +155,7 @@ Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx, } #endif - if (!lnm || !eqv || idx > LNM$_MAX_INDEX) { + if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) { set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0; } for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) { @@ -596,7 +599,7 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) if ((cp1 = strchr(environ[i],'=')) && !strncmp(environ[i],lnm,cp1 - environ[i])) { #ifdef HAS_SETENV - return setenv(lnm,eqv,1) ? vaxc$errno : 0; + return setenv(lnm,"",1) ? vaxc$errno : 0; } } ivenv = 1; retsts = SS$_NOLOGNAM; @@ -730,6 +733,30 @@ Perl_my_setenv(pTHX_ char *lnm,char *eqv) } /*}}}*/ +/*{{{static void vmssetuserlnm(char *name, char *eqv); +/* vmssetuserlnm + * sets a user-mode logical in the process logical name table + * used for redirection of sys$error + */ +void +Perl_vmssetuserlnm(char *name, char *eqv) +{ + $DESCRIPTOR(d_tab, "LNM$PROCESS"); + struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0}; + unsigned long int iss, attr = 0; + unsigned char acmode = PSL$C_USER; + struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0}, + {0, 0, 0, 0}}; + d_name.dsc$a_pointer = name; + d_name.dsc$w_length = strlen(name); + + lnmlst[0].buflen = strlen(eqv); + lnmlst[0].bufadr = eqv; + + iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst); + if (!(iss&1)) lib$signal(iss); +} +/*}}}*/ /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/ @@ -1843,17 +1870,19 @@ vmspipe_tempfile(void) fprintf(fp,"$ perl_del = \"delete\"\n"); fprintf(fp,"$ pif = \"if\"\n"); fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n"); - fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define sys$input 'perl_popen_in'\n"); - fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define sys$error 'perl_popen_err'\n"); + fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user sys$input 'perl_popen_in'\n"); + fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user sys$error 'perl_popen_err'\n"); + fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n"); fprintf(fp,"$ cmd = perl_popen_cmd\n"); fprintf(fp,"$! --- get rid of global symbols\n"); fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n"); fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n"); + fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n"); fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n"); fprintf(fp,"$ perl_on\n"); fprintf(fp,"$ 'cmd\n"); fprintf(fp,"$ perl_status = $STATUS\n"); - fprintf(fp,"$ perl_del 'perl_cfile'\n"); + fprintf(fp,"$ perl_del 'perl_cfile'\n"); fprintf(fp,"$ perl_exit 'perl_status'\n"); fsync(fileno(fp)); @@ -1892,12 +1921,12 @@ safe_popen(char *cmd, char *mode) pInfo info; struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, symbol}; - struct dsc$descriptor_s d_out = {0, DSC$K_DTYPE_T, - DSC$K_CLASS_S, out}; struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD"); $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN"); + $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT"); $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR"); /* once-per-program initialization... @@ -1958,9 +1987,9 @@ safe_popen(char *cmd, char *mode) info->in_done = TRUE; info->out_done = TRUE; info->err_done = TRUE; + in[0] = out[0] = err[0] = '\0'; if (*mode == 'r') { /* piping from subroutine */ - in[0] = '\0'; info->out = pipe_infromchild_setup(mbx,out); if (info->out) { @@ -1979,13 +2008,13 @@ safe_popen(char *cmd, char *mode) if (!done) _ckvmssts(sys$clref(pipe_ef)); _ckvmssts(sys$setast(1)); if (!done) _ckvmssts(sys$waitfr(pipe_ef)); - } + } if (info->out->buf) Safefree(info->out->buf); Safefree(info->out); Safefree(info); return Nullfp; - } + } info->err = pipe_mbxtofd_setup(fileno(stderr), err); if (info->err) { @@ -1995,7 +2024,6 @@ safe_popen(char *cmd, char *mode) } } else { /* piping to subroutine , mode=w*/ - int melded; info->in = pipe_tochild_setup(in,mbx); info->fp = PerlIO_open(mbx, mode); @@ -2023,21 +2051,9 @@ safe_popen(char *cmd, char *mode) if (info->in->buf) Safefree(info->in->buf); Safefree(info->in); Safefree(info); - return Nullfp; + return Nullfp; } - /* if SYS$ERROR == SYS$OUTPUT, use only one mbx */ - - melded = FALSE; - fgetname(stderr, err); - if (strncmp(err,"SYS$ERROR:",10) == 0) { - fgetname(stdout, out); - if (strncmp(out,"SYS$OUTPUT:",11) == 0) { - if (popen_translate("SYS$OUTPUT",out) == popen_translate("SYS$ERROR",err)) { - melded = TRUE; - } - } - } info->out = pipe_mbxtofd_setup(fileno(stdout), out); if (info->out) { @@ -2045,18 +2061,14 @@ safe_popen(char *cmd, char *mode) info->out_done = FALSE; info->out->info = info; } - if (!melded) { - info->err = pipe_mbxtofd_setup(fileno(stderr), err); - if (info->err) { - info->err->pipe_done = &info->err_done; - info->err_done = FALSE; - info->err->info = info; - } - } else { - err[0] = '\0'; - } + + info->err = pipe_mbxtofd_setup(fileno(stderr), err); + if (info->err) { + info->err->pipe_done = &info->err_done; + info->err_done = FALSE; + info->err->info = info; + } } - d_out.dsc$w_length = strlen(out); /* lib$spawn sets SYS$OUTPUT so can meld*/ symbol[MAX_DCL_SYMBOL] = '\0'; @@ -2068,6 +2080,9 @@ safe_popen(char *cmd, char *mode) d_symbol.dsc$w_length = strlen(symbol); _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table)); + strncpy(symbol, out, MAX_DCL_SYMBOL); + d_symbol.dsc$w_length = strlen(symbol); + _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table)); p = VMScmd.dsc$a_pointer; while (*p && *p != '\n') p++; @@ -2084,7 +2099,7 @@ safe_popen(char *cmd, char *mode) info->next=open_pipes; /* prepend to list */ open_pipes=info; _ckvmssts(sys$setast(1)); - _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &d_out, &flags, + _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags, 0, &info->pid, &info->completion, 0, popen_completion_ast,info,0,0,0)); @@ -2098,7 +2113,7 @@ safe_popen(char *cmd, char *mode) _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table)); _ckvmssts(lib$delete_symbol(&d_sym_in, &table)); _ckvmssts(lib$delete_symbol(&d_sym_err, &table)); - + _ckvmssts(lib$delete_symbol(&d_sym_out, &table)); vms_execfree(aTHX); PL_forkprocess = info->pid; @@ -3572,9 +3587,12 @@ mp_getredirection(pTHX_ int *ac, char ***av) PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out); exit(vaxc$errno); } + if (out != NULL) Perl_vmssetuserlnm("SYS$OUTPUT",out); + if (err != NULL) { if (strcmp(err,"&1") == 0) { dup2(fileno(stdout), fileno(Perl_debug_log)); + Perl_vmssetuserlnm("SYS$ERROR","SYS$OUTPUT"); } else { FILE *tmperr; if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2"))) @@ -3587,6 +3605,7 @@ mp_getredirection(pTHX_ int *ac, char ***av) { exit(vaxc$errno); } + Perl_vmssetuserlnm("SYS$ERROR",err); } } #ifdef ARGPROC_DEBUG diff --git a/vms/vmsish.h b/vms/vmsish.h index 8d2a628894..17c5a00ed3 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -709,6 +709,7 @@ int Perl_rmscopy (pTHX_ char *, char *, int); #endif char * my_getenv_len (const char *, unsigned long *, bool); int vmssetenv (char *, char *, struct dsc$descriptor_s **); +void Perl_vmssetuserlnm(char *name, char *eqv); char * my_crypt (const char *, const char *); Pid_t my_waitpid (Pid_t, int *, int); char * my_gconvert (double, int, int, char *); diff --git a/vms/vmspipe.com b/vms/vmspipe.com index bbb4461c72..652783eec5 100644 --- a/vms/vmspipe.com +++ b/vms/vmspipe.com @@ -6,12 +6,14 @@ $ perl_exit = "exit" $ perl_del = "delete" $ pif = "if" $! --- define i/o redirection (sys$output set by lib$spawn) -$ pif perl_popen_in .nes. "" then perl_define sys$input 'perl_popen_in' -$ pif perl_popen_err .nes. "" then perl_define sys$error 'perl_popen_err' +$ pif perl_popen_in .nes. "" then perl_define/user sys$input 'perl_popen_in' +$ pif perl_popen_err .nes. "" then perl_define/user sys$error 'perl_popen_err' +$ pif perl_popen_out .nes. "" then perl_define sys$output 'perl_popen_out' $ cmd = perl_popen_cmd $! --- get rid of global symbols $ perl_del/symbol/global perl_popen_in $ perl_del/symbol/global perl_popen_err +$ perl_del/symbol/global perl_popen_out $ perl_del/symbol/global perl_popen_cmd $ perl_on $ 'cmd diff --git a/vos/Changes b/vos/Changes index 9af03d1c5f..ba0856ac94 100644 --- a/vos/Changes +++ b/vos/Changes @@ -1,6 +1,32 @@ This file documents the changes made to port Perl to the Stratus VOS operating system. +For 5.7: + Updated "build.cm" to build perl using either the alpha or GA + version of POSIX. + Updated "Changes". + Updated "compile_perl.cm" to use either the alpha or GA + version of POSIX. + Split "config.def" into config.alpha.def and config.ga.def; + one for each version. Use the configure_perl.cm macro + to select the appropriate version. + Split "config.h" into config.alpha.h and config.ga.h. Use the + configure_perl.cm macro to select the appropriate version. + Updated "config.pl". It now diagnoses undefined (missing) and + unused substitution variables. When a new version of + Perl comes out, run "configure_perl.cm", add any missing + definitions to config.*.def, and remove any unused + definitions. + Removed "config_h.SH_orig". It is no longer needed. + Added "configure_perl.cm". It is used to configure perl so that + it can be built with either version of VOS POSIX.1 support. + Added "install_perl.cm" to install Perl into the appropriate + system directories. + Updated "perl.bind" to work with either the alpha or GA + version of POSIX. + Updated "vosish.h" to just use the standard "unixish.h" since + there are no changes needed at this time. + After 5.005_63: Supplied "config.pl" perl script that takes "config_h.SH_orig" and "config.def" as input and produces "config.h.new". diff --git a/vos/build.cm b/vos/build.cm index 8719d050c4..f749538231 100644 --- a/vos/build.cm +++ b/vos/build.cm @@ -2,6 +2,8 @@ cpu option(-processor)name,allow(mc68020,i80860,pa7100,pa8000),=mc68020 recompile switch(-recompile),=1 rebind switch(-rebind),=1 + tgt_mod option(-target_module)module_name,='(current_module)' + version option(-version)name,allow(alpha,ga),=ga &end_parameters &echo command_lines & @@ -11,14 +13,22 @@ & necessary, to assign the correct pathname of the directory that & contains VOS POSIX.1 support. & -&set_string POSIX >vos_ftp_site>pub>vos>alpha>posix +&if &version& = alpha +&then &set_string POSIX >vos_ftp_site>pub>vos>alpha>posix +&else &set_string POSIX >system>posix_object_library & & See if the site has VOS POSIX.1 support loaded. If not, quit now. & &if ^ (exists &POSIX& -directory) &then &do &display_line build: VOS POSIX.1 support not found. &POSIX& - &return + &return 1 + &end +& +&if &cpu& = mc68020 & &version& = ga | &cpu& = i80860 & &version& = ga +&then &do + &display_line build: "-version ga" is incompatible with "-processor mc68020 or i80860" + &return 1 &end & & Set up the appropriate directory suffix for each architecture. @@ -43,7 +53,11 @@ &if &recompile& = 0 &then &goto CHECK_REBIND & -!set_library_paths include << < &POSIX&>incl &+ +&if &version& = alpha +&then !set_library_paths include << < &POSIX&>incl &+ + (master_disk)>system>include_library +&else !set_library_paths include << < &+ + (master_disk)>system>stcp>include_library &+ (master_disk)>system>include_library & &if (exists *.obj -link) @@ -52,7 +66,12 @@ & Suppress several harmless compiler warning and advice messages. & Use -list -show_include all -show_macros both_ways when debugging. & -&set_string cflags '-u -O4 -D_POSIX_C_SOURCE=199309L -DPERL_CORE' +&set_string cflags '-u -O4 -D_POSIX_C_SOURCE=199506L -DPERL_CORE' +& +& The following is a work-around for stcp-1437,8,9 +& +&if &version& = ga +&then &set_string cflags &cflags& -D_BSD_SOURCE & !cc <<av.c -suppress_diag 2006 2064 2065 &cpu& &cflags& &if (command_status) ^= 0 &then &return @@ -76,15 +95,26 @@ & &if (command_status) ^= 0 &then &return !cc <<mg.c -suppress_diag 2006 2064 2065 &cpu& &cflags& &if (command_status) ^= 0 &then &return -!cc <<miniperlmain.c -suppress_diag 2006 &cpu& &cflags& +!cc <<miniperlmain.c -suppress_diag 2006 2065 &cpu& &cflags& &if (command_status) ^= 0 &then &return !cc <<op.c -suppress_diag 2006 2064 2065 &cpu& &cflags& &if (command_status) ^= 0 &then &return +& +& We are essentially building miniperl for now. Until we +& get a POSIX shell on VOS we won't add any of the extensions. +& +& !link <<op.c opmini.c -delete +& &if (command_status) ^= 0 &then &return +& !cc opmini.c -suppress_diag 2006 2064 2065 &cpu& &cflags& -DPERL_EXTERNAL_GLOB +& &if (command_status) ^= 0 &then &return +& !unlink opmini.c +& &if (command_status) ^= 0 &then &return +& !cc <<perl.c -suppress_diag 2006 2053 2065 &cpu& &cflags& &+ - -DARCHLIB="/system/ported/perl/lib/5.005&obj2&" &+ - -DARCHLIB_EXP="/system/ported/perl/lib/5.005&obj2&" &+ - -DSITEARCH="/system/ported/perl/lib/site/5.005&obj2&" &+ - -DSITEARCH_EXP="/system/ported/perl/lib/site/5.005&obj2&" + -DARCHLIB="/system/ported/perl/lib/5.7&obj2&" &+ + -DARCHLIB_EXP="/system/ported/perl/lib/5.7&obj2&" &+ + -DSITEARCH="/system/ported/perl/lib/site/5.7&obj2&" &+ + -DSITEARCH_EXP="/system/ported/perl/lib/site/5.7&obj2&" &if (command_status) ^= 0 &then &return !cc <<perlapi.c &cpu& &cflags& &if (command_status) ^= 0 &then &return @@ -126,8 +156,11 @@ &if (command_status) ^= 0 &then &return !cc <<xsutils.c &cpu& &cflags& &if (command_status) ^= 0 &then &return +&if &version& = alpha +&then &do !cc <vos_dummies.c &cpu& -O4 &if (command_status) ^= 0 &then &return +&end & & If requested, bind the executable program module. & @@ -139,6 +172,10 @@ &then &set_string tcp_objlib (master_disk)>system>tcp_os>object_library&obj2& &else &set_string tcp_objlib (master_disk)>system>tcp_os>object_library & +&if (exists -directory (master_disk)>system>stcp>object_library&obj2&) +&then &set_string stcp_objlib (master_disk)>system>stcp>object_library&obj2& +&else &set_string stcp_objlib (master_disk)>system>stcp>object_library +& &if (exists -directory (master_disk)>system>object_library&obj2&) &then &set_string objlib (master_disk)>system>object_library&obj2& &else &set_string objlib (master_disk)>system>object_library @@ -147,11 +184,28 @@ &then &set_string c_objlib (master_disk)>system>c_object_library&obj2& &else &set_string c_objlib (master_disk)>system>c_object_library & -!set_library_paths object . &+ - &POSIX&>c>runtime>obj&obj& &+ +&if (exists -directory (master_disk)>system>posix_object_library&obj2&) +&then &set_string posix_objlib (master_disk)>system>posix_object_library&obj2& +&else &set_string posix_objlib (master_disk)>system>posix_object_library +& +&if &version& = alpha +&then !set_library_paths object . &tcp_objlib& &+ &POSIX&>c>sysv_runtime>obj&obj& &+ - &tcp_objlib& &objlib& &c_objlib& -!bind -control <perl.bind &cpu& -map + &POSIX&>c>runtime>obj&obj& &+ + &c_objlib& &objlib& +&else !set_library_paths object . &stcp_objlib& &+ + &stcp_objlib&>common &+ + &stcp_objlib&>net &+ + &stcp_objlib&>sbsd &+ + &stcp_objlib&>socket &+ + &posix_objlib&>bsd &+ + &posix_objlib& &+ + &c_objlib& &objlib& +&if &version& = alpha +&then !bind -control <perl.bind vos_dummies &+ + &tcp_objlib&>tcp_runtime &tcp_objlib&>tcp_gethost &+ + &cpu& -target_module &tgt_mod& -map +&else !bind -control <perl.bind &cpu& -target_module &tgt_mod& -map &if (command_status) ^= 0 &then &return !delete_file *.obj -no_ask -brief !unlink *.obj -no_ask -brief diff --git a/vos/compile_perl.cm b/vos/compile_perl.cm index 86a8d6a182..f8ecf3ba22 100644 --- a/vos/compile_perl.cm +++ b/vos/compile_perl.cm @@ -3,12 +3,15 @@ & build macro in that subdirectory to create the perl & executable program module file. & Written 99-02-03 by Paul Green (Paul_Green@stratus.com) +& Modified 00-10-24 by Paul Green & &begin_parameters - cpu option(-processor)name,allow(mc68020,i80860,pa7100,pa8000),=mc68020 + cpu option(-processor)name,allow(mc68020,i80860,pa7100,pa8000),=pa7100 recompile switch(-recompile),=1 rebind switch(-rebind),=1 module option(-module)module_name,='(current_module)' + tgt_mod option(-target_module)module_name,='(current_module)' + version option(-version)name,allow(alpha,ga),=ga &end_parameters &echo command_lines & @@ -35,6 +38,9 @@ &if ^ (exists obj&obj&>build.out) &then !create_file obj&obj&>build.out ; set_implicit_locking obj&obj&>build.out & +!configure_perl -version &version& +& !change_current_dir obj&obj& -!start_process (string <build -processor &cpu& &recompile& &rebind&) -module &module& +!start_process (string <build -processor &cpu& &recompile& &rebind& &+ + -target_module &tgt_mod& -version &version&) -module &module& !change_current_dir < diff --git a/vos/config.def b/vos/config.alpha.def index 4edc806b9c..7a2093731a 100644 --- a/vos/config.def +++ b/vos/config.alpha.def @@ -8,13 +8,15 @@ $binexp='/system/ported/command_library' $byteorder='4321' $castflags='0' $cf_by='Paul_Green@stratus.com' -$cf_time='2000-02-03 19:13 UCT' +$cf_time='2000-10-23 18:48 UCT' +$CONFIG_SH='config.sh' $cpp_stuff='42' $cpplast='-' $cppminus='-' $cpprun='cc -E -' $cppstdin='cc -E' $crosscompile='undef' +$d__fwalk='undef' $d_access='undef' $d_accessx='undef' $d_alarm='define' @@ -57,6 +59,7 @@ $d_eofnblk='define' $d_fchmod='define' $d_fchown='undef' $d_fcntl='define' +$d_fcntl_can_lock='define' $d_fd_set='undef' $d_fgetpos='define' $d_flexfnam='define' @@ -70,6 +73,7 @@ $d_fseeko='undef' $d_fsetpos='define' $d_fstatfs='undef' $d_fstatvfs='undef' +$d_fsync='undef' $d_ftello='undef' $d_Gconvert='sprintf((b),"%.*g",(n),(x))' $d_getcwd='define' @@ -89,6 +93,7 @@ $d_getnbyaddr='define' $d_getnbyname='define' $d_getnent='define' $d_getnetprotos='define' +$d_getpagsz='undef' $d_getpbyname='define' $d_getpbynumber='define' $d_getpent='define' @@ -115,7 +120,7 @@ $d_index='undef' $d_inetaton='undef' $d_int64_t='undef' $d_isascii='define' -$d_isnan='define' +$d_isnan='undef' $d_isnanl='undef' $d_killpg='undef' $d_lchown='undef' @@ -170,9 +175,6 @@ $d_poll='define' $d_PRIeldbl='define' $d_PRIfldbl='define' $d_PRIgldbl='define' -$d_PRIEUldbl='define' -$d_PRIFUldbl='define' -$d_PRIGUldbl='define' $d_pthread_yield='undef' $d_pwage='undef' $d_pwchange='undef' @@ -182,7 +184,6 @@ $d_pwexpire='undef' $d_pwgecos='undef' $d_pwpasswd='undef' $d_pwquota='undef' -$d_qgcvt='undef' $d_quad='undef' $d_readdir='define' $d_readlink='define' @@ -192,8 +193,10 @@ $d_rmdir='define' $d_safebcpy='undef' $d_safemcpy='undef' $d_sanemcmp='define' +$d_sbrkproto='undef' $d_sched_yield='undef' $d_scm_rights='undef' +$d_SCNfldbl='define' $d_seekdir='undef' $d_select='define' $d_sem='undef' @@ -228,7 +231,6 @@ $d_shm='undef' $d_shmatprototype='define' $d_sigaction='undef' $d_sigsetjmp='undef' -$d_sitearch='undef' $d_socket='define' $d_sockpair='undef' $d_socks5_init='undef' @@ -238,6 +240,8 @@ $d_statfs_f_flags='undef' $d_statfs_s='undef' $d_stdio_cnt_lval='define' $d_stdio_ptr_lval='define' +$d_stdio_ptr_lval_sets_cnt='undef' +$d_stdio_ptr_lval_nochange_cnt='undef' $d_stdio_stream_array='define' $d_stdiobase='define' $d_stdstdio='define' @@ -250,6 +254,7 @@ $d_strtod='define' $d_strtol='define' $d_strtold='undef' $d_strtoll='undef' +$d_strtoq='undef' $d_strtoul='define' $d_strtoull='undef' $d_strtouq='undef' @@ -314,7 +319,7 @@ $i_dirent='define' $i_dlfcn='undef' $i_fcntl='define' $i_float='define' -$i_grp='undef' +$i_grp='define' $i_iconv='undef' $i_ieeefp='undef' $i_inttypes='undef' @@ -333,7 +338,7 @@ $i_niin='define' $i_poll='undef' $i_prot='undef' $i_pthread='undef' -$i_pwd='undef' +$i_pwd='define' $i_rpcsvcdbm='undef' $i_sfio='undef' $i_sgtty='undef' @@ -390,9 +395,11 @@ $longsize='4' $lseeksize='4' $lseektype='off_t' $malloctype='void *' +$mmaptype='void *' $modetype='mode_t' $multiarch='undef' $myuname='VOS' +$need_va_copy='undef' $netdb_hlen_type='int' $netdb_host_type='char *' $netdb_name_type='char *' @@ -430,15 +437,17 @@ $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, $signal_t='void' $sitearch='' $sitearchexp='' -$sitelib='/system/ported/perl/lib/site/5.005' -$sitelibexp='/system/ported/perl/lib/site/5.005' +$sitelib='/system/ported/perl/lib/site/5.7' +$sitelibexp='/system/ported/perl/lib/site/5.7' $sitelib_stem='/system/ported/perl/lib/site' $sizesize='4' $sizetype='size_t' $socksizetype='int' +$sPRIeldbl='"Le"' $sPRIfldbl='"Lf"' $sPRIgldbl='"Lg"' -$src='%es#lang/vos_ftp_site/pub/vos/alpha/perl' +$src='/vos_ftp_site/pub/vos/posix/(alpha|ga)/perl' +$sSCNfldbl='"Lf"' $ssizetype='ssize_t' $startperl='!perl.pm' $stdchar='unsigned char' @@ -460,6 +469,7 @@ $uidformat='"d"' $uidsize='4' $uidsign='-1' $uidtype='uid_t' +$undef='$undef' $uquadtype='_error_' $use5005threads='undef' $use64bitall='undef' @@ -472,7 +482,6 @@ $usemorebits='undef' $usemultiplicity='undef' $useperlio='undef' $usesocks='undef' -$usethreads='undef' $uvoformat='"o"' $uvsize='4' $uvtype='unsigned int' @@ -482,6 +491,5 @@ $vendorarch='' $vendorarchexp='' $vendorlib_stem='' $vendorlibexp='' -$versiononly='undef' $voidflags='15' $xs_apiversion='5.00563' diff --git a/vos/config.h b/vos/config.alpha.h index 985e6ea5bc..aaeb129cba 100644 --- a/vos/config.h +++ b/vos/config.alpha.h @@ -1,19 +1,19 @@ /* * This file was produced by running the config_h.SH script, which - * gets its values from $CONFIG_SH, which is generally produced by + * gets its values from config.sh, which is generally produced by * running Configure. * * Feel free to modify any of this as the need arises. Note, however, * that running config_h.SH again will wipe out any changes you've made. - * For a more permanent change edit $CONFIG_SH and rerun config_h.SH. + * For a more permanent change edit config.sh and rerun config_h.SH. * * \$Id: Config_h.U,v 3.0.1.5 1997/02/28 14:57:43 ram Exp $ */ /* * Package name : perl5 - * Source directory : %es#lang/vos_ftp_site/pub/vos/alpha/perl - * Configuration time: 2000-02-03 19:13 UCT + * Source directory : /vos_ftp_site/pub/vos/posix/(alpha|ga)/perl + * Configuration time: 2000-10-23 18:48 UCT * Configured by : Paul_Green@stratus.com * Target system : VOS */ @@ -165,6 +165,19 @@ */ #define HAS_FCNTL /**/ +/* 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_FGETPOS: * This symbol, if defined, indicates that the fgetpos routine is * available to get the file position indicator, similar to ftell(). @@ -213,6 +226,13 @@ */ #define HAS_GETLOGIN /**/ +/* 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_GETPGID: * This symbol, if defined, indicates to the C program that * the getpgid(pid) function is available to get the @@ -1343,6 +1363,13 @@ */ /*#define HAS_FSTATFS /**/ +/* HAS_FSYNC: + * This symbol, if defined, indicates that the fsync routine is + * available to write a file's modified data and attributes to + * permanent storage. + */ +/*#define HAS_FSYNC /**/ + /* HAS_FTELLO: * This symbol, if defined, indicates that the ftello routine is * available to ftell beyond 32 bits (useful for ILP32 hosts). @@ -1614,7 +1641,7 @@ * This symbol, if defined, indicates that the isnan routine is * available to check whether a double is a NaN. */ -#define HAS_ISNAN /**/ +/*#define HAS_ISNAN /**/ /* HAS_ISNANL: * This symbol, if defined, indicates that the isnanl routine is @@ -1714,7 +1741,7 @@ * Usually set to 'void *' or 'cadd_t'. */ /*#define HAS_MMAP /**/ -#define Mmap_t $mmaptype /**/ +#define Mmap_t void * /**/ /* HAS_MODFL: * This symbol, if defined, indicates that the modfl routine is @@ -1798,6 +1825,15 @@ */ #define HAS_SANE_MEMCMP /**/ +/* HAS_SBRK_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the sbrk() function. Otherwise, it is up + * to the program to supply one. Good guesses are + * extern void* sbrk _((int)); + * extern void* sbrk _((size_t)); + */ +/*#define HAS_SBRK_PROTO / **/ + /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. @@ -2024,12 +2060,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: @@ -2089,6 +2136,18 @@ */ /*#define HAS_STRTOLL /**/ +/* HAS_STRTOQ: + * This symbol, if defined, indicates that the strtouq routine is + * available to convert strings to long longs (quads). + */ +/*#define HAS_STRTOQ /**/ + +/* HAS_STRTOQ: + * This symbol, if defined, indicates that the strtouq routine is + * available to convert strings to long longs (quads). + */ +/*#define HAS_STRTOQ /**/ + /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. @@ -2276,7 +2335,7 @@ * This symbol, if defined, indicates to the C program that struct group * in <grp.h> contains gr_passwd. */ -/*#define I_GRP /**/ +#define I_GRP /**/ /*#define GRPASSWD /**/ /* I_ICONV: @@ -2381,7 +2440,7 @@ * This symbol, if defined, indicates to the C program that struct passwd * contains pw_passwd. */ -/*#define I_PWD /**/ +#define I_PWD /**/ /*#define PWQUOTA /**/ /*#define PWAGE /**/ /*#define PWCHANGE /**/ @@ -2511,8 +2570,8 @@ */ #define PERL_PRIfldbl "Lf" /**/ #define PERL_PRIgldbl "Lg" /**/ -#define PERL_PRIeldbl $sPRIeldbl /**/ -# PERL_SCNfldbl $sSCNfldbl /**/ +#define PERL_PRIeldbl "Le" /**/ +#define PERL_SCNfldbl "Lf" /**/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. @@ -2865,8 +2924,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 "" /**/ -#define SITEARCH_EXP "" /**/ +/*#define SITEARCH "" /**/ +/*#define SITEARCH_EXP "" /**/ /* SITELIB: * This symbol contains the name of the private library for this package. @@ -2888,8 +2947,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 "/system/ported/perl/lib/site/5.005" /**/ -#define SITELIB_EXP "/system/ported/perl/lib/site/5.005" /**/ +#define SITELIB "/system/ported/perl/lib/site/5.7" /**/ +#define SITELIB_EXP "/system/ported/perl/lib/site/5.7" /**/ #define SITELIB_STEM "/system/ported/perl/lib/site" /**/ /* Size_t_size: @@ -3133,7 +3192,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 /system/ported/perl/lib/site/5.005 for older directories across major versions + * search in /system/ported/perl/lib/site/5.7 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 @@ -3169,4 +3228,15 @@ /*#define HAS_SETPGRP /**/ /*#define USE_BSD_SETPGRP /**/ +/* NEED_VA_COPY: + * This symbol, if defined, indicates that the system stores + * the variable argument list datatype, va_list, in a format + * that cannot be copied by simple assignment, so that some + * other means must be used when copying is required. + * As such systems vary in their provision (or non-provision) + * of copying mechanisms, handy.h defines a platform- + * independent macro, Perl_va_copy(src, dst), to do the job. + */ +/*#define NEED_VA_COPY / **/ + #endif diff --git a/vos/config.ga.def b/vos/config.ga.def new file mode 100644 index 0000000000..46cbc202da --- /dev/null +++ b/vos/config.ga.def @@ -0,0 +1,495 @@ +$alignbytes='8' +$aphostname='' +$archlib='' +$archlibexp='' +$archname='vos' +$bin='/system/ported/command_library' +$binexp='/system/ported/command_library' +$byteorder='4321' +$castflags='0' +$cf_by='Paul_Green@stratus.com' +$cf_time='2000-10-24 15:35 UCT' +$CONFIG_SH='config.sh' +$cpp_stuff='42' +$cpplast='-' +$cppminus='-' +$cpprun='cc -E -' +$cppstdin='cc -E' +$crosscompile='undef' +$d__fwalk='undef' +$d_access='define' +$d_accessx='undef' +$d_alarm='define' +$d_archlib='undef' +$d_atolf='undef' +$d_atoll='undef' +$d_attribut='undef' +$d_bcmp='undef' +$d_bcopy='undef' +$d_bincompat5005='undef' +$d_bsdgetpgrp='undef' +$d_bsdsetpgrp='undef' +$d_bzero='undef' +$d_casti32='undef' +$d_castneg='define' +$d_charvspr='undef' +$d_chown='define' +$d_chroot='undef' +$d_chsize='undef' +$d_const='define' +$d_crypt='undef' +$d_csh='define' +$d_cuserid='undef' +$d_dbl_dig='define' +$d_difftime='define' +$d_dirnamlen='undef' +$d_dlerror='undef' +$d_dlsymun='undef' +$d_dosuid='undef' +$d_drand48proto='undef' +$d_dup2='define' +$d_eaccess='undef' +$d_endgrent='undef' +$d_endhent='define' +$d_endnent='define' +$d_endpent='define' +$d_endpwent='undef' +$d_endsent='define' +$d_eofnblk='define' +$d_fchmod='define' +$d_fchown='undef' +$d_fcntl='define' +$d_fcntl_can_lock='define' +$d_fd_set='undef' +$d_fgetpos='define' +$d_flexfnam='define' +$d_flock='undef' +$d_fork='define' +$d_fpathconf='define' +$d_fpos64_t='undef' +$d_frexpl='undef' +$d_fs_data_s='undef' +$d_fseeko='undef' +$d_fsetpos='define' +$d_fstatfs='undef' +$d_fstatvfs='undef' +$d_fsync='undef' +$d_ftello='undef' +$d_Gconvert='sprintf((b),"%.*g",(n),(x))' +$d_getcwd='define' +$d_getespwnam='undef' +$d_getfsstat='undef' +$d_getgrent='undef' +$d_getgrps='undef' +$d_gethbyaddr='define' +$d_gethbyname='define' +$d_gethent='define' +$d_gethname='define' +$d_gethostprotos='define' +$d_getlogin='define' +$d_getmnt='undef' +$d_getmntent='undef' +$d_getnbyaddr='define' +$d_getnbyname='define' +$d_getnent='define' +$d_getnetprotos='define' +$d_getpagsz='undef' +$d_getpbyname='define' +$d_getpbynumber='define' +$d_getpent='define' +$d_getpgid='undef' +$d_getpgrp2='undef' +$d_getpgrp='define' +$d_getppid='define' +$d_getprior='undef' +$d_getprotoprotos='define' +$d_getprpwnam='undef' +$d_getpwent='undef' +$d_getsbyname='define' +$d_getsbyport='define' +$d_getsent='define' +$d_getservprotos='define' +$d_getspnam='undef' +$d_gettimeod='undef' +$d_gnulibc='undef' +$d_grpasswd='undef' +$d_hasmntopt='undef' +$d_htonl='define' +$d_iconv='undef' +$d_index='undef' +$d_inetaton='undef' +$d_int64_t='undef' +$d_isascii='define' +$d_isnan='undef' +$d_isnanl='undef' +$d_killpg='undef' +$d_lchown='undef' +$d_ldbl_dig='define' +$d_link='undef' +$d_locconv='define' +$d_lockf='define' +$d_longdbl='define' +$d_longlong='undef' +$d_lseekproto='define' +$d_lstat='define' +$d_madvise='undef' +$d_mblen='define' +$d_mbstowcs='define' +$d_mbtowc='define' +$d_memchr='define' +$d_memcmp='define' +$d_memcpy='define' +$d_memmove='define' +$d_memset='define' +$d_mkdir='define' +$d_mkdtemp='undef' +$d_mkstemp='undef' +$d_mkstemps='undef' +$d_mkfifo='define' +$d_mktime='define' +$d_mmap='define' +$d_modfl='undef' +$d_mprotect='undef' +$d_msg='undef' +$d_msg_ctrunc='undef' +$d_msg_dontroute='undef' +$d_msg_oob='undef' +$d_msg_peek='undef' +$d_msg_proxy='undef' +$d_msync='undef' +$d_munmap='define' +$d_mymalloc='undef' +$d_nice='undef' +$d_nv_preserves_uv='define' +$d_nv_preserves_uv_bits='32' +$d_off64_t='undef' +$d_old_pthread_create_joinable='undef' +$d_oldpthreads='undef' +$d_open3='define' +$d_pathconf='define' +$d_perl_otherlibdirs='undef' +$d_pause='define' +$d_phostname='undef' +$d_pipe='define' +$d_poll='define' +$d_PRIeldbl='define' +$d_PRIfldbl='define' +$d_PRIgldbl='define' +$d_pthread_yield='undef' +$d_pwage='undef' +$d_pwchange='undef' +$d_pwclass='undef' +$d_pwcomment='undef' +$d_pwexpire='undef' +$d_pwgecos='undef' +$d_pwpasswd='undef' +$d_pwquota='undef' +$d_quad='undef' +$d_readdir='define' +$d_readlink='define' +$d_rename='define' +$d_rewinddir='define' +$d_rmdir='define' +$d_safebcpy='undef' +$d_safemcpy='undef' +$d_sanemcmp='define' +$d_sbrkproto='undef' +$d_sched_yield='undef' +$d_scm_rights='undef' +$d_SCNfldbl='define' +$d_seekdir='undef' +$d_select='define' +$d_sem='undef' +$d_semctl_semid_ds='undef' +$d_semctl_semun='undef' +$d_setegid='define' +$d_seteuid='define' +$d_setgrent='undef' +$d_setgrps='undef' +$d_sethent='define' +$d_setlinebuf='define' +$d_setlocale='define' +$d_setnent='define' +$d_setpent='define' +$d_setpgid='define' +$d_setpgrp2='undef' +$d_setpgrp='undef' +$d_setprior='undef' +$d_setproctitle='undef' +$d_setpwent='undef' +$d_setregid='undef' +$d_setresgid='undef' +$d_setresuid='undef' +$d_setreuid='undef' +$d_setrgid='undef' +$d_setruid='undef' +$d_setsent='define' +$d_setsid='define' +$d_setvbuf='define' +$d_sfio='undef' +$d_shm='undef' +$d_shmatprototype='define' +$d_sigaction='define' +$d_sigsetjmp='define' +$d_socket='define' +$d_sockpair='undef' +$d_socks5_init='undef' +$d_sqrtl='undef' +$d_statblks='undef' +$d_statfs_f_flags='undef' +$d_statfs_s='undef' +$d_stdio_cnt_lval='define' +$d_stdio_ptr_lval='define' +$d_stdio_ptr_lval_sets_cnt='undef' +$d_stdio_ptr_lval_nochange_cnt='undef' +$d_stdio_stream_array='define' +$d_stdiobase='define' +$d_stdstdio='define' +$d_strchr='define' +$d_strcoll='define' +$d_strctcpy='define' +$d_strerrm='strerror(e)' +$d_strerror='define' +$d_strtod='define' +$d_strtol='define' +$d_strtold='undef' +$d_strtoll='undef' +$d_strtoq='undef' +$d_strtoul='define' +$d_strtoull='undef' +$d_strtouq='undef' +$d_strxfrm='define' +$d_suidsafe='define' +$d_symlink='define' +$d_syscall='undef' +$d_sysconf='define' +$d_syserrlst='define' +$d_system='define' +$d_tcgetpgrp='define' +$d_tcsetpgrp='define' +$d_telldir='undef' +$d_telldirproto='undef' +$d_times='define' +$d_truncate='undef' +$d_tzname='define' +$d_umask='define' +$d_uname='define' +$d_union_semun='undef' +$d_ustat='undef' +$d_vendorarch='define' +$d_vendorlib='define' +$d_vfork='undef' +$d_void_closedir='undef' +$d_volatile='define' +$d_vprintf='define' +$d_wait4='define' +$d_waitpid='define' +$d_wcstombs='define' +$d_wctomb='define' +$db_hashtype='int' +$db_prefixtype='int' +$defvoidused='15' +$direntrytype='struct dirent' +$doublesize='8' +$drand01='rand()/(RAND_MAX+1)' +$eagain='EAGAIN' +$ebcdic='undef' +$fflushall='undef' +$fflushNULL='define' +$fpostype='fpos_t' +$freetype='void' +$full_csh='/system/ported/command_library/bash.pm' +$full_sed='/system/ported/command_library/sed.pm' +$gidformat='"d"' +$gidsize='4' +$gidsign='-1' +$gidtype='gid_t' +$groupstype='gid_t' +$i16size='2' +$i16type='short' +$i32size='4' +$i32type='int' +$i64size='_error_' +$i64type='_error_' +$i8size='1' +$i8type='char' +$i_arpainet='define' +$i_dbm='undef' +$i_dirent='define' +$i_dlfcn='undef' +$i_fcntl='define' +$i_float='define' +$i_grp='define' +$i_iconv='undef' +$i_ieeefp='undef' +$i_inttypes='undef' +$i_libutil='undef' +$i_limits='define' +$i_locale='define' +$i_machcthr='undef' +$i_math='define' +$i_memory='undef' +$i_mntent='undef' +$i_ndbm='undef' +$i_netdb='define' +$i_neterrno='undef' +$i_netinettcp='define' +$i_niin='define' +$i_poll='undef' +$i_prot='undef' +$i_pthread='undef' +$i_pwd='define' +$i_rpcsvcdbm='undef' +$i_sfio='undef' +$i_sgtty='undef' +$i_shadow='undef' +$i_socks='undef' +$i_stdarg='define' +$i_stddef='define' +$i_stdlib='define' +$i_string='define' +$i_sunmath='undef' +$i_sysaccess='undef' +$i_sysdir='undef' +$i_sysfile='undef' +$i_sysioctl='define' +$i_syslog='undef' +$i_sysmode='undef' +$i_sysmount='undef' +$i_sysndir='undef' +$i_sysparam='undef' +$i_sysresrc='undef' +$i_syssecrt='undef' +$i_sysselct='define' +$i_sysstat='define' +$i_sysstatfs='undef' +$i_sysstatvfs='undef' +$i_systime='define' +$i_systimek='undef' +$i_systimes='define' +$i_systypes='define' +$i_sysuio='undef' +$i_sysun='undef' +$i_sysutsname='define' +$i_sysvfs='undef' +$i_syswait='define' +$i_termio='undef' +$i_termios='define' +$i_time='undef' +$i_unistd='define' +$i_ustat='undef' +$i_utime='define' +$i_values='define' +$i_varargs='undef' +$i_vfork='undef' +$Id='$Id' +$inc_version_list_init='0' +$installusrbinperl='undef' +$intsize='4' +$ivdformat='"d"' +$ivsize='4' +$ivtype='int' +$longdblsize='8' +$longlongsize='_error_' +$longsize='4' +$lseeksize='4' +$lseektype='off_t' +$malloctype='void *' +$mmaptype='void *' +$modetype='mode_t' +$multiarch='undef' +$myuname='VOS' +$need_va_copy='undef' +$netdb_hlen_type='int' +$netdb_host_type='char *' +$netdb_name_type='char *' +$netdb_net_type='long' +$nveformat='"e"' +$nvfformat='"f"' +$nvgformat='"g"' +$nvsize='8' +$nvtype='double' +$o_nonblock='O_NONBLOCK' +$old_pthread_create_joinable='' +$osname='VOS' +$otherlibdirs='' +$package='perl5' +$pidtype='pid_t' +$pm_apiversion='5.005' +$privlib='/system/ported/perl/lib/5.7' +$privlibexp='/system/ported/perl/lib/5.7' +$prototype='define' +$ptrsize='4' +$quadkind='_error_' +$quadtype='_error_' +$randbits='15' +$randseedtype='unsigned int' +$rd_nodata='-1' +$sched_yield='' +$seedfunc='srand' +$selectminbits='1' +$selecttype='fd_set *' +$sh='/system/ported/command_library/bash.pm' +$shmattype='void *' +$shortsize='2' +$sig_name_init='"ZERO","ABRT","FPE","ILL","INT","SEGV","TERM","USR1","USR2","IO","HUP","URG","ALRM","CHLD","CONT","KILL","STOP","PIPE","QUIT","BUS","TRAP","TSTP","TTIN","TTOU","RT1","RT2","RT3","RT4","RT5","RT6","RT7","RT8",0' +$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,0' +$signal_t='void' +$sitearch='' +$sitearchexp='' +$sitelib='/system/ported/perl/lib/site/5.7' +$sitelibexp='/system/ported/perl/lib/site/5.7' +$sitelib_stem='/system/ported/perl/lib/site' +$sizesize='4' +$sizetype='size_t' +$socksizetype='int' +$sPRIeldbl='"Le"' +$sPRIfldbl='"Lf"' +$sPRIgldbl='"Lg"' +$src='/vos_ftp_site/pub/vos/posix/(alpha|ga)/perl' +$sSCNfldbl='"Lf"' +$ssizetype='ssize_t' +$startperl='!perl.pm' +$stdchar='unsigned char' +$stdio_base='((fp)->_base)' +$stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)' +$stdio_cnt='((fp)->_cnt)' +$stdio_ptr='((fp)->_ptr)' +$stdio_stream_array='_iob' +$timetype='time_t' +$u16size='2' +$u16type='unsigned short' +$u32size='4' +$u32type='unsigned int' +$u64size='_error_' +$u64type='_error_' +$u8size='1' +$u8type='unsigned char' +$uidformat='"d"' +$uidsize='4' +$uidsign='-1' +$uidtype='uid_t' +$undef='$undef' +$uquadtype='_error_' +$use5005threads='undef' +$use64bitall='undef' +$use64bitint='undef' +$usedl='undef' +$useithreads='undef' +$uselargefiles='undef' +$uselongdouble='define' +$usemorebits='undef' +$usemultiplicity='undef' +$useperlio='undef' +$usesocks='undef' +$uvoformat='"o"' +$uvsize='4' +$uvtype='unsigned int' +$uvuformat='"u"' +$uvxformat='"x"' +$vendorarch='' +$vendorarchexp='' +$vendorlib_stem='' +$vendorlibexp='' +$voidflags='15' +$xs_apiversion='5.00563' diff --git a/vos/config_h.SH_orig b/vos/config.ga.h index a209e6d29f..d235ba11ce 100755..100644 --- a/vos/config_h.SH_orig +++ b/vos/config.ga.h @@ -1,45 +1,21 @@ -case "$CONFIG_SH" in -'') CONFIG_SH=config.sh ;; -esac -case "$CONFIG_H" in -'') CONFIG_H=config.h ;; -esac -case $CONFIG in -'') - if test -f $CONFIG_SH; then TOP=.; - elif test -f ../$CONFIG_SH; then TOP=..; - elif test -f ../../$CONFIG_SH; then TOP=../..; - elif test -f ../../../$CONFIG_SH; then TOP=../../..; - elif test -f ../../../../$CONFIG_SH; then TOP=../../../..; - else - echo "Can't find $CONFIG_SH."; exit 1 - fi - . $TOP/$CONFIG_SH - ;; -esac -case "$0" in -*/*) cd `expr X$0 : 'X\(.*\)/'` ;; -esac -echo "Extracting $CONFIG_H (with variable substitutions)" -sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un-def!#undef!' /* * This file was produced by running the config_h.SH script, which - * gets its values from $CONFIG_SH, which is generally produced by + * gets its values from config.sh, which is generally produced by * running Configure. * * Feel free to modify any of this as the need arises. Note, however, * that running config_h.SH again will wipe out any changes you've made. - * For a more permanent change edit $CONFIG_SH and rerun config_h.SH. + * For a more permanent change edit config.sh and rerun config_h.SH. * * \$Id: Config_h.U,v 3.0.1.5 1997/02/28 14:57:43 ram Exp $ */ /* - * Package name : $package - * Source directory : $src - * Configuration time: $cf_time - * Configured by : $cf_by - * Target system : $myuname + * Package name : perl5 + * Source directory : /vos_ftp_site/pub/vos/posix/(alpha|ga)/perl + * Configuration time: 2000-10-24 15:35 UCT + * Configured by : Paul_Green@stratus.com + * Target system : VOS */ #ifndef _config_h_ @@ -48,19 +24,19 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un /* LOC_SED: * This symbol holds the complete pathname to the sed program. */ -#define LOC_SED "$full_sed" /**/ +#define LOC_SED "/system/ported/command_library/sed.pm" /**/ /* HAS_ALARM: * This symbol, if defined, indicates that the alarm routine is * available. */ -#$d_alarm HAS_ALARM /**/ +#define HAS_ALARM /**/ /* HASATTRIBUTE: * This symbol indicates the C compiler can check for function attributes, * such as printf formats. This is normally only supported by GNU cc. */ -#$d_attribut HASATTRIBUTE /**/ +/*#define HASATTRIBUTE /**/ #ifndef HASATTRIBUTE #define __attribute__(_arg_) #endif @@ -69,37 +45,37 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol is defined if the bcmp() routine is available to * compare blocks of memory. */ -#$d_bcmp HAS_BCMP /**/ +/*#define HAS_BCMP /**/ /* HAS_BCOPY: * This symbol is defined if the bcopy() routine is available to * copy blocks of memory. */ -#$d_bcopy HAS_BCOPY /**/ +/*#define HAS_BCOPY /**/ /* HAS_BZERO: * This symbol is defined if the bzero() routine is available to * set a memory block to 0. */ -#$d_bzero HAS_BZERO /**/ +/*#define HAS_BZERO /**/ /* HAS_CHOWN: * This symbol, if defined, indicates that the chown routine is * available. */ -#$d_chown HAS_CHOWN /**/ +#define HAS_CHOWN /**/ /* HAS_CHROOT: * This symbol, if defined, indicates that the chroot routine is * available. */ -#$d_chroot HAS_CHROOT /**/ +/*#define HAS_CHROOT /**/ /* HAS_CHSIZE: * This symbol, if defined, indicates that the chsize routine is available * to truncate files. You might need a -lx to get this routine. */ -#$d_chsize HAS_CHSIZE /**/ +/*#define HAS_CHSIZE /**/ /* HASCONST: * This symbol, if defined, indicates that this C compiler knows about @@ -107,7 +83,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * within your programs. The mere use of the "const" keyword will * trigger the necessary tests. */ -#$d_const HASCONST /**/ +#define HASCONST /**/ #ifndef HASCONST #define const #endif @@ -116,13 +92,13 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol, if defined, indicates that the crypt routine is available * to encrypt passwords and the like. */ -#$d_crypt HAS_CRYPT /**/ +/*#define HAS_CRYPT /**/ /* HAS_CUSERID: * This symbol, if defined, indicates that the cuserid routine is * available to get character login names. */ -#$d_cuserid HAS_CUSERID /**/ +/*#define HAS_CUSERID /**/ /* HAS_DBL_DIG: * This symbol, if defined, indicates that this system's <float.h> @@ -130,20 +106,20 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * of significant digits in a double precision number. If this * symbol is not defined, a guess of 15 is usually pretty good. */ -#$d_dbl_dig HAS_DBL_DIG /* */ +#define HAS_DBL_DIG /* */ /* HAS_DIFFTIME: * This symbol, if defined, indicates that the difftime routine is * available. */ -#$d_difftime HAS_DIFFTIME /**/ +#define HAS_DIFFTIME /**/ /* HAS_DLERROR: * This symbol, if defined, indicates that the dlerror routine is * available to return a string describing the last error that * occurred from a call to dlopen(), dlclose() or dlsym(). */ -#$d_dlerror HAS_DLERROR /**/ +/*#define HAS_DLERROR /**/ /* SETUID_SCRIPTS_ARE_SECURE_NOW: * This symbol, if defined, indicates that the bug that prevents @@ -162,56 +138,69 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * subprocesses to which it must pass the filename rather than the * file descriptor of the script to be executed. */ -#$d_suidsafe SETUID_SCRIPTS_ARE_SECURE_NOW /**/ -#$d_dosuid DOSUID /**/ +#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/ +/*#define DOSUID /**/ /* HAS_DUP2: * This symbol, if defined, indicates that the dup2 routine is * available to duplicate file descriptors. */ -#$d_dup2 HAS_DUP2 /**/ +#define HAS_DUP2 /**/ /* HAS_FCHMOD: * This symbol, if defined, indicates that the fchmod routine is available * to change mode of opened files. If unavailable, use chmod(). */ -#$d_fchmod HAS_FCHMOD /**/ +#define HAS_FCHMOD /**/ /* HAS_FCHOWN: * This symbol, if defined, indicates that the fchown routine is available * to change ownership of opened files. If unavailable, use chown(). */ -#$d_fchown HAS_FCHOWN /**/ +/*#define HAS_FCHOWN /**/ /* HAS_FCNTL: * This symbol, if defined, indicates to the C program that * the fcntl() function exists. */ -#$d_fcntl HAS_FCNTL /**/ +#define HAS_FCNTL /**/ + +/* 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_FGETPOS: * This symbol, if defined, indicates that the fgetpos routine is * available to get the file position indicator, similar to ftell(). */ -#$d_fgetpos HAS_FGETPOS /**/ +#define HAS_FGETPOS /**/ /* HAS_FLOCK: * This symbol, if defined, indicates that the flock routine is * available to do file locking. */ -#$d_flock HAS_FLOCK /**/ +/*#define HAS_FLOCK /**/ /* HAS_FORK: * This symbol, if defined, indicates that the fork routine is * available. */ -#$d_fork HAS_FORK /**/ +#define HAS_FORK /**/ /* HAS_FSETPOS: * This symbol, if defined, indicates that the fsetpos routine is * available to set the file position indicator, similar to fseek(). */ -#$d_fsetpos HAS_FSETPOS /**/ +#define HAS_FSETPOS /**/ /* HAS_GETTIMEOFDAY: * This symbol, if defined, indicates that the gettimeofday() system @@ -219,7 +208,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * <sys/resource.h> needs to be included (see I_SYS_RESOURCE). * The type "Timeval" should be used to refer to "struct timeval". */ -#$d_gettimeod HAS_GETTIMEOFDAY /**/ +/*#define HAS_GETTIMEOFDAY /**/ #ifdef HAS_GETTIMEOFDAY #define Timeval struct timeval /* Structure used by gettimeofday() */ #endif @@ -229,106 +218,113 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * available to get the list of process groups. If unavailable, multiple * groups are probably not supported. */ -#$d_getgrps HAS_GETGROUPS /**/ +/*#define HAS_GETGROUPS /**/ /* HAS_GETLOGIN: * This symbol, if defined, indicates that the getlogin routine is * available to get the login name. */ -#$d_getlogin HAS_GETLOGIN /**/ +#define HAS_GETLOGIN /**/ + +/* 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_GETPGID: * This symbol, if defined, indicates to the C program that * the getpgid(pid) function is available to get the * process group id. */ -#$d_getpgid HAS_GETPGID /**/ +/*#define HAS_GETPGID /**/ /* HAS_GETPGRP2: * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) * routine is available to get the current process group. */ -#$d_getpgrp2 HAS_GETPGRP2 /**/ +/*#define HAS_GETPGRP2 /**/ /* HAS_GETPPID: * This symbol, if defined, indicates that the getppid routine is * available to get the parent process ID. */ -#$d_getppid HAS_GETPPID /**/ +#define HAS_GETPPID /**/ /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is * available to get a process's priority. */ -#$d_getprior HAS_GETPRIORITY /**/ +/*#define HAS_GETPRIORITY /**/ /* HAS_INET_ATON: * This symbol, if defined, indicates to the C program that the * inet_aton() function is available to parse IP address "dotted-quad" * strings. */ -#$d_inetaton HAS_INET_ATON /**/ +/*#define HAS_INET_ATON /**/ /* HAS_KILLPG: * This symbol, if defined, indicates that the killpg routine is available * to kill process groups. If unavailable, you probably should use kill * with a negative process number. */ -#$d_killpg HAS_KILLPG /**/ +/*#define HAS_KILLPG /**/ /* HAS_LINK: * This symbol, if defined, indicates that the link routine is * available to create hard links. */ -#$d_link HAS_LINK /**/ +/*#define HAS_LINK /**/ /* HAS_LOCALECONV: * This symbol, if defined, indicates that the localeconv routine is * available for numeric and monetary formatting conventions. */ -#$d_locconv HAS_LOCALECONV /**/ +#define HAS_LOCALECONV /**/ /* HAS_LOCKF: * This symbol, if defined, indicates that the lockf routine is * available to do file locking. */ -#$d_lockf HAS_LOCKF /**/ +#define HAS_LOCKF /**/ /* HAS_LSTAT: * This symbol, if defined, indicates that the lstat routine is * available to do file stats on symbolic links. */ -#$d_lstat HAS_LSTAT /**/ +#define HAS_LSTAT /**/ /* HAS_MBLEN: * This symbol, if defined, indicates that the mblen routine is available * to find the number of bytes in a multibye character. */ -#$d_mblen HAS_MBLEN /**/ +#define HAS_MBLEN /**/ /* HAS_MBSTOWCS: * This symbol, if defined, indicates that the mbstowcs routine is * available to covert a multibyte string into a wide character string. */ -#$d_mbstowcs HAS_MBSTOWCS /**/ +#define HAS_MBSTOWCS /**/ /* HAS_MBTOWC: * This symbol, if defined, indicates that the mbtowc routine is available * to covert a multibyte to a wide character. */ -#$d_mbtowc HAS_MBTOWC /**/ +#define HAS_MBTOWC /**/ /* HAS_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * to compare blocks of memory. */ -#$d_memcmp HAS_MEMCMP /**/ +#define HAS_MEMCMP /**/ /* HAS_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy blocks of memory. */ -#$d_memcpy HAS_MEMCPY /**/ +#define HAS_MEMCPY /**/ /* HAS_MEMMOVE: * This symbol, if defined, indicates that the memmove routine is available @@ -336,20 +332,20 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your * own version. */ -#$d_memmove HAS_MEMMOVE /**/ +#define HAS_MEMMOVE /**/ /* HAS_MEMSET: * This symbol, if defined, indicates that the memset routine is available * to set blocks of memory. */ -#$d_memset HAS_MEMSET /**/ +#define HAS_MEMSET /**/ /* HAS_MKDIR: * This symbol, if defined, indicates that the mkdir routine is available * to create directories. Otherwise you should fork off a new process to * exec /bin/mkdir. */ -#$d_mkdir HAS_MKDIR /**/ +#define HAS_MKDIR /**/ /* HAS_MKFIFO: * This symbol, if defined, indicates that the mkfifo routine is @@ -357,31 +353,31 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * do it for you. However, if mkfifo is there, mknod might require * super-user privileges which mkfifo will not. */ -#$d_mkfifo HAS_MKFIFO /**/ +#define HAS_MKFIFO /**/ /* HAS_MKTIME: * This symbol, if defined, indicates that the mktime routine is * available. */ -#$d_mktime HAS_MKTIME /**/ +#define HAS_MKTIME /**/ /* HAS_MSYNC: * This symbol, if defined, indicates that the msync system call is * available to synchronize a mapped file. */ -#$d_msync HAS_MSYNC /**/ +/*#define HAS_MSYNC /**/ /* HAS_MUNMAP: * This symbol, if defined, indicates that the munmap system call is * available to unmap a region, usually mapped by mmap(). */ -#$d_munmap HAS_MUNMAP /**/ +#define HAS_MUNMAP /**/ /* HAS_NICE: * This symbol, if defined, indicates that the nice routine is * available. */ -#$d_nice HAS_NICE /**/ +/*#define HAS_NICE /**/ /* HAS_PATHCONF: * This symbol, if defined, indicates that pathconf() is available @@ -393,122 +389,122 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * to determine file-system related limits and options associated * with a given open file descriptor. */ -#$d_pathconf HAS_PATHCONF /**/ -#$d_fpathconf HAS_FPATHCONF /**/ +#define HAS_PATHCONF /**/ +#define HAS_FPATHCONF /**/ /* HAS_PAUSE: * This symbol, if defined, indicates that the pause routine is * available to suspend a process until a signal is received. */ -#$d_pause HAS_PAUSE /**/ +#define HAS_PAUSE /**/ /* HAS_PIPE: * This symbol, if defined, indicates that the pipe routine is * available to create an inter-process channel. */ -#$d_pipe HAS_PIPE /**/ +#define HAS_PIPE /**/ /* HAS_POLL: * This symbol, if defined, indicates that the poll routine is * available to poll active file descriptors. You may safely * include <poll.h> when this symbol is defined. */ -#$d_poll HAS_POLL /**/ +#define HAS_POLL /**/ /* HAS_READDIR: * This symbol, if defined, indicates that the readdir routine is * available to read directory entries. You may have to include * <dirent.h>. See I_DIRENT. */ -#$d_readdir HAS_READDIR /**/ +#define HAS_READDIR /**/ /* HAS_SEEKDIR: * This symbol, if defined, indicates that the seekdir routine is * available. You may have to include <dirent.h>. See I_DIRENT. */ -#$d_seekdir HAS_SEEKDIR /**/ +/*#define HAS_SEEKDIR /**/ /* HAS_TELLDIR: * This symbol, if defined, indicates that the telldir routine is * available. You may have to include <dirent.h>. See I_DIRENT. */ -#$d_telldir HAS_TELLDIR /**/ +/*#define HAS_TELLDIR /**/ /* HAS_REWINDDIR: * This symbol, if defined, indicates that the rewinddir routine is * available. You may have to include <dirent.h>. See I_DIRENT. */ -#$d_rewinddir HAS_REWINDDIR /**/ +#define HAS_REWINDDIR /**/ /* HAS_READLINK: * This symbol, if defined, indicates that the readlink routine is * available to read the value of a symbolic link. */ -#$d_readlink HAS_READLINK /**/ +#define HAS_READLINK /**/ /* HAS_RENAME: * This symbol, if defined, indicates that the rename routine is available * to rename files. Otherwise you should do the unlink(), link(), unlink() * trick. */ -#$d_rename HAS_RENAME /**/ +#define HAS_RENAME /**/ /* HAS_RMDIR: * This symbol, if defined, indicates that the rmdir routine is * available to remove directories. Otherwise you should fork off a * new process to exec /bin/rmdir. */ -#$d_rmdir HAS_RMDIR /**/ +#define HAS_RMDIR /**/ /* HAS_SELECT: * This symbol, if defined, indicates that the select routine is * available to select active file descriptors. If the timeout field * is used, <sys/time.h> may need to be included. */ -#$d_select HAS_SELECT /**/ +#define HAS_SELECT /**/ /* HAS_SETEGID: * This symbol, if defined, indicates that the setegid routine is available * to change the effective gid of the current program. */ -#$d_setegid HAS_SETEGID /**/ +#define HAS_SETEGID /**/ /* HAS_SETEUID: * This symbol, if defined, indicates that the seteuid routine is available * to change the effective uid of the current program. */ -#$d_seteuid HAS_SETEUID /**/ +#define HAS_SETEUID /**/ /* HAS_SETLINEBUF: * This symbol, if defined, indicates that the setlinebuf routine is * available to change stderr or stdout from block-buffered or unbuffered * to a line-buffered mode. */ -#$d_setlinebuf HAS_SETLINEBUF /**/ +#define HAS_SETLINEBUF /**/ /* HAS_SETLOCALE: * This symbol, if defined, indicates that the setlocale routine is * available to handle locale-specific ctype implementations. */ -#$d_setlocale HAS_SETLOCALE /**/ +#define HAS_SETLOCALE /**/ /* HAS_SETPGID: * This symbol, if defined, indicates that the setpgid(pid, gpid) * routine is available to set process group ID. */ -#$d_setpgid HAS_SETPGID /**/ +#define HAS_SETPGID /**/ /* HAS_SETPGRP2: * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) * routine is available to set the current process group. */ -#$d_setpgrp2 HAS_SETPGRP2 /**/ +/*#define HAS_SETPGRP2 /**/ /* HAS_SETPRIORITY: * This symbol, if defined, indicates that the setpriority routine is * available to set a process's priority. */ -#$d_setprior HAS_SETPRIORITY /**/ +/*#define HAS_SETPRIORITY /**/ /* HAS_SETREGID: * This symbol, if defined, indicates that the setregid routine is @@ -520,8 +516,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * available to change the real, effective and saved gid of the current * process. */ -#$d_setregid HAS_SETREGID /**/ -#$d_setresgid HAS_SETRESGID /**/ +/*#define HAS_SETREGID /**/ +/*#define HAS_SETRESGID /**/ /* HAS_SETREUID: * This symbol, if defined, indicates that the setreuid routine is @@ -533,26 +529,26 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * available to change the real, effective and saved uid of the current * process. */ -#$d_setreuid HAS_SETREUID /**/ -#$d_setresuid HAS_SETRESUID /**/ +/*#define HAS_SETREUID /**/ +/*#define HAS_SETRESUID /**/ /* HAS_SETRGID: * This symbol, if defined, indicates that the setrgid routine is available * to change the real gid of the current program. */ -#$d_setrgid HAS_SETRGID /**/ +/*#define HAS_SETRGID /**/ /* HAS_SETRUID: * This symbol, if defined, indicates that the setruid routine is available * to change the real uid of the current program. */ -#$d_setruid HAS_SETRUID /**/ +/*#define HAS_SETRUID /**/ /* HAS_SETSID: * This symbol, if defined, indicates that the setsid routine is * available to set the process group ID. */ -#$d_setsid HAS_SETSID /**/ +#define HAS_SETSID /**/ /* Shmat_t: * This symbol holds the return type of the shmat() system call. @@ -565,8 +561,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * but not always right so it should be emitted by the program only * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. */ -#define Shmat_t $shmattype /**/ -#$d_shmatprototype HAS_SHMAT_PROTOTYPE /**/ +#define Shmat_t void * /**/ +#define HAS_SHMAT_PROTOTYPE /**/ /* HAS_STRCHR: * This symbol is defined to indicate that the strchr()/strrchr() @@ -577,105 +573,117 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol is defined to indicate that the index()/rindex() * functions are available for string searching. */ -#$d_strchr HAS_STRCHR /**/ -#$d_index HAS_INDEX /**/ +#define HAS_STRCHR /**/ +/*#define HAS_INDEX /**/ /* HAS_STRCOLL: * This symbol, if defined, indicates that the strcoll routine is * available to compare strings using collating information. */ -#$d_strcoll HAS_STRCOLL /**/ +#define HAS_STRCOLL /**/ /* USE_STRUCT_COPY: * This symbol, if defined, indicates that this C compiler knows how * to copy structures. If undefined, you'll need to use a block copy * routine of some sort instead. */ -#$d_strctcpy USE_STRUCT_COPY /**/ +#define USE_STRUCT_COPY /**/ /* HAS_STRTOD: * This symbol, if defined, indicates that the strtod routine is * available to provide better numeric string conversion than atof(). */ -#$d_strtod HAS_STRTOD /**/ +#define HAS_STRTOD /**/ /* HAS_STRTOL: * This symbol, if defined, indicates that the strtol routine is available * to provide better numeric string conversion than atoi() and friends. */ -#$d_strtol HAS_STRTOL /**/ +#define HAS_STRTOL /**/ + +/* HAS_STRTOQ: + * This symbol, if defined, indicates that the strtouq routine is + * available to convert strings to long longs (quads). + */ +/*#define HAS_STRTOQ /**/ + +/* HAS_STRTOQ: + * This symbol, if defined, indicates that the strtouq routine is + * available to convert strings to long longs (quads). + */ +/*#define HAS_STRTOQ /**/ /* HAS_STRTOUL: * This symbol, if defined, indicates that the strtoul routine is * available to provide conversion of strings to unsigned long. */ -#$d_strtoul HAS_STRTOUL /**/ +#define HAS_STRTOUL /**/ /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. */ -#$d_strxfrm HAS_STRXFRM /**/ +#define HAS_STRXFRM /**/ /* HAS_SYMLINK: * This symbol, if defined, indicates that the symlink routine is available * to create symbolic links. */ -#$d_symlink HAS_SYMLINK /**/ +#define HAS_SYMLINK /**/ /* HAS_SYSCALL: * This symbol, if defined, indicates that the syscall routine is * available to call arbitrary system calls. If undefined, that's tough. */ -#$d_syscall HAS_SYSCALL /**/ +/*#define HAS_SYSCALL /**/ /* HAS_SYSCONF: * This symbol, if defined, indicates that sysconf() is available * to determine system related limits and options. */ -#$d_sysconf HAS_SYSCONF /**/ +#define HAS_SYSCONF /**/ /* HAS_SYSTEM: * This symbol, if defined, indicates that the system routine is * available to issue a shell command. */ -#$d_system HAS_SYSTEM /**/ +#define HAS_SYSTEM /**/ /* HAS_TCGETPGRP: * This symbol, if defined, indicates that the tcgetpgrp routine is * available to get foreground process group ID. */ -#$d_tcgetpgrp HAS_TCGETPGRP /**/ +#define HAS_TCGETPGRP /**/ /* HAS_TCSETPGRP: * This symbol, if defined, indicates that the tcsetpgrp routine is * available to set foreground process group ID. */ -#$d_tcsetpgrp HAS_TCSETPGRP /**/ +#define HAS_TCSETPGRP /**/ /* HAS_TRUNCATE: * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ -#$d_truncate HAS_TRUNCATE /**/ +/*#define HAS_TRUNCATE /**/ /* HAS_TZNAME: * This symbol, if defined, indicates that the tzname[] array is * available to access timezone names. */ -#$d_tzname HAS_TZNAME /**/ +#define HAS_TZNAME /**/ /* HAS_UMASK: * This symbol, if defined, indicates that the umask routine is * available to set and get the value of the file creation mask. */ -#$d_umask HAS_UMASK /**/ +#define HAS_UMASK /**/ /* HASVOLATILE: * This symbol, if defined, indicates that this C compiler knows about * the volatile declaration. */ -#$d_volatile HASVOLATILE /**/ +#define HASVOLATILE /**/ #ifndef HASVOLATILE #define volatile #endif @@ -683,31 +691,31 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un /* HAS_WAIT4: * This symbol, if defined, indicates that wait4() exists. */ -#$d_wait4 HAS_WAIT4 /**/ +#define HAS_WAIT4 /**/ /* HAS_WAITPID: * This symbol, if defined, indicates that the waitpid routine is * available to wait for child process. */ -#$d_waitpid HAS_WAITPID /**/ +#define HAS_WAITPID /**/ /* HAS_WCSTOMBS: * This symbol, if defined, indicates that the wcstombs routine is * available to convert wide character strings to multibyte strings. */ -#$d_wcstombs HAS_WCSTOMBS /**/ +#define HAS_WCSTOMBS /**/ /* HAS_WCTOMB: * This symbol, if defined, indicates that the wctomb routine is available * to covert a wide character to a multibyte. */ -#$d_wctomb HAS_WCTOMB /**/ +#define HAS_WCTOMB /**/ /* I_ARPA_INET: * This symbol, if defined, indicates to the C program that it should * include <arpa/inet.h> to get inet_addr and friends declarations. */ -#$i_arpainet I_ARPA_INET /**/ +#define I_ARPA_INET /**/ /* I_DBM: * This symbol, if defined, indicates that <dbm.h> exists and should @@ -717,8 +725,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol, if defined, indicates that <rpcsvc/dbm.h> exists and * should be included. */ -#$i_dbm I_DBM /**/ -#$i_rpcsvcdbm I_RPCSVC_DBM /**/ +/*#define I_DBM /**/ +/*#define I_RPCSVC_DBM /**/ /* I_DIRENT: * This symbol, if defined, indicates to the C program that it should @@ -736,166 +744,166 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * whether dirent is available or not. You should use this pseudo type to * portably declare your directory entries. */ -#$i_dirent I_DIRENT /**/ -#$d_dirnamlen DIRNAMLEN /**/ -#define Direntry_t $direntrytype +#define I_DIRENT /**/ +/*#define DIRNAMLEN /**/ +#define Direntry_t struct dirent /* I_DLFCN: * This symbol, if defined, indicates that <dlfcn.h> exists and should * be included. */ -#$i_dlfcn I_DLFCN /**/ +/*#define I_DLFCN /**/ /* I_FCNTL: * This manifest constant tells the C program to include <fcntl.h>. */ -#$i_fcntl I_FCNTL /**/ +#define I_FCNTL /**/ /* I_FLOAT: * This symbol, if defined, indicates to the C program that it should * include <float.h> to get definition of symbols like DBL_MAX or * DBL_MIN, i.e. machine dependent floating point values. */ -#$i_float I_FLOAT /**/ +#define I_FLOAT /**/ /* I_LIMITS: * This symbol, if defined, indicates to the C program that it should * include <limits.h> to get definition of symbols like WORD_BIT or * LONG_MAX, i.e. machine dependant limitations. */ -#$i_limits I_LIMITS /**/ +#define I_LIMITS /**/ /* I_LOCALE: * This symbol, if defined, indicates to the C program that it should * include <locale.h>. */ -#$i_locale I_LOCALE /**/ +#define I_LOCALE /**/ /* I_MATH: * This symbol, if defined, indicates to the C program that it should * include <math.h>. */ -#$i_math I_MATH /**/ +#define I_MATH /**/ /* I_MEMORY: * This symbol, if defined, indicates to the C program that it should * include <memory.h>. */ -#$i_memory I_MEMORY /**/ +/*#define I_MEMORY /**/ /* I_NDBM: * This symbol, if defined, indicates that <ndbm.h> exists and should * be included. */ -#$i_ndbm I_NDBM /**/ +/*#define I_NDBM /**/ /* I_NET_ERRNO: * This symbol, if defined, indicates that <net/errno.h> exists and * should be included. */ -#$i_neterrno I_NET_ERRNO /**/ +/*#define I_NET_ERRNO /**/ /* I_NETINET_IN: * This symbol, if defined, indicates to the C program that it should * include <netinet/in.h>. Otherwise, you may try <sys/in.h>. */ -#$i_niin I_NETINET_IN /**/ +#define I_NETINET_IN /**/ /* I_SFIO: * This symbol, if defined, indicates to the C program that it should * include <sfio.h>. */ -#$i_sfio I_SFIO /**/ +/*#define I_SFIO /**/ /* I_STDDEF: * This symbol, if defined, indicates that <stddef.h> exists and should * be included. */ -#$i_stddef I_STDDEF /**/ +#define I_STDDEF /**/ /* I_STDLIB: * This symbol, if defined, indicates that <stdlib.h> exists and should * be included. */ -#$i_stdlib I_STDLIB /**/ +#define I_STDLIB /**/ /* I_STRING: * This symbol, if defined, indicates to the C program that it should * include <string.h> (USG systems) instead of <strings.h> (BSD systems). */ -#$i_string I_STRING /**/ +#define I_STRING /**/ /* I_SYS_DIR: * This symbol, if defined, indicates to the C program that it should * include <sys/dir.h>. */ -#$i_sysdir I_SYS_DIR /**/ +/*#define I_SYS_DIR /**/ /* I_SYS_FILE: * This symbol, if defined, indicates to the C program that it should * include <sys/file.h> to get definition of R_OK and friends. */ -#$i_sysfile I_SYS_FILE /**/ +/*#define I_SYS_FILE /**/ /* I_SYS_IOCTL: * This symbol, if defined, indicates that <sys/ioctl.h> exists and should * be included. Otherwise, include <sgtty.h> or <termio.h>. */ -#$i_sysioctl I_SYS_IOCTL /**/ +#define I_SYS_IOCTL /**/ /* I_SYS_NDIR: * This symbol, if defined, indicates to the C program that it should * include <sys/ndir.h>. */ -#$i_sysndir I_SYS_NDIR /**/ +/*#define I_SYS_NDIR /**/ /* I_SYS_PARAM: * This symbol, if defined, indicates to the C program that it should * include <sys/param.h>. */ -#$i_sysparam I_SYS_PARAM /**/ +/*#define I_SYS_PARAM /**/ /* I_SYS_RESOURCE: * This symbol, if defined, indicates to the C program that it should * include <sys/resource.h>. */ -#$i_sysresrc I_SYS_RESOURCE /**/ +/*#define I_SYS_RESOURCE /**/ /* I_SYS_SELECT: * This symbol, if defined, indicates to the C program that it should * include <sys/select.h> in order to get definition of struct timeval. */ -#$i_sysselct I_SYS_SELECT /**/ +#define I_SYS_SELECT /**/ /* I_SYS_STAT: * This symbol, if defined, indicates to the C program that it should * include <sys/stat.h>. */ -#$i_sysstat I_SYS_STAT /**/ +#define I_SYS_STAT /**/ /* I_SYS_TIMES: * This symbol, if defined, indicates to the C program that it should * include <sys/times.h>. */ -#$i_systimes I_SYS_TIMES /**/ +#define I_SYS_TIMES /**/ /* I_SYS_TYPES: * This symbol, if defined, indicates to the C program that it should * include <sys/types.h>. */ -#$i_systypes I_SYS_TYPES /**/ +#define I_SYS_TYPES /**/ /* I_SYS_UN: * This symbol, if defined, indicates to the C program that it should * include <sys/un.h> to get UNIX domain socket definitions. */ -#$i_sysun I_SYS_UN /**/ +/*#define I_SYS_UN /**/ /* I_SYS_WAIT: * This symbol, if defined, indicates to the C program that it should * include <sys/wait.h>. */ -#$i_syswait I_SYS_WAIT /**/ +#define I_SYS_WAIT /**/ /* I_TERMIO: * This symbol, if defined, indicates that the program should include @@ -913,21 +921,21 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * <sgtty.h> rather than <termio.h>. There are also differences in * the ioctl() calls that depend on the value of this symbol. */ -#$i_termio I_TERMIO /**/ -#$i_termios I_TERMIOS /**/ -#$i_sgtty I_SGTTY /**/ +/*#define I_TERMIO /**/ +#define I_TERMIOS /**/ +/*#define I_SGTTY /**/ /* I_UNISTD: * This symbol, if defined, indicates to the C program that it should * include <unistd.h>. */ -#$i_unistd I_UNISTD /**/ +#define I_UNISTD /**/ /* I_UTIME: * This symbol, if defined, indicates to the C program that it should * include <utime.h>. */ -#$i_utime I_UTIME /**/ +#define I_UTIME /**/ /* I_VALUES: * This symbol, if defined, indicates to the C program that it should @@ -935,7 +943,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * MAXLONG, i.e. machine dependant limitations. Probably, you * should use <limits.h> instead, if it is available. */ -#$i_values I_VALUES /**/ +#define I_VALUES /**/ /* I_STDARG: * This symbol, if defined, indicates that <stdarg.h> exists and should @@ -945,14 +953,14 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol, if defined, indicates to the C program that it should * include <varargs.h>. */ -#$i_stdarg I_STDARG /**/ -#$i_varargs I_VARARGS /**/ +#define I_STDARG /**/ +/*#define I_VARARGS /**/ /* I_VFORK: * This symbol, if defined, indicates to the C program that it should * include vfork.h. */ -#$i_vfork I_VFORK /**/ +/*#define I_VFORK /**/ /* CAN_PROTOTYPE: * If defined, this macro indicates that the C compiler can handle @@ -965,7 +973,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * * int main _((int argc, char *argv[])); */ -#$prototype CAN_PROTOTYPE /**/ +#define CAN_PROTOTYPE /**/ #ifdef CAN_PROTOTYPE #define _(args) args #else @@ -979,19 +987,19 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ -#define SH_PATH "$sh" /**/ +#define SH_PATH "/system/ported/command_library/bash.pm" /**/ /* 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 /**/ +#define STDCHAR unsigned char /**/ /* CROSSCOMPILE: * This symbol, if defined, signifies that we our * build process is a cross-compilation. */ -#$crosscompile CROSSCOMPILE /**/ +/*#define CROSSCOMPILE /**/ /* INTSIZE: * This symbol contains the value of sizeof(int) so that the C @@ -1005,9 +1013,9 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol contains the value of sizeof(short) so that the C * preprocessor can make decisions based on it. */ -#define INTSIZE $intsize /**/ -#define LONGSIZE $longsize /**/ -#define SHORTSIZE $shortsize /**/ +#define INTSIZE 4 /**/ +#define LONGSIZE 4 /**/ +#define SHORTSIZE 2 /**/ /* MULTIARCH: * This symbol, if defined, signifies that the build @@ -1016,18 +1024,18 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * example with the NeXT "fat" binaries that contain executables * for several CPUs. */ -#$multiarch MULTIARCH /**/ +/*#define MULTIARCH /**/ /* HAS_QUAD: * This symbol, if defined, tells that there's a 64-bit integer type, * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, or QUAD_IS_INT64_T. */ -#$d_quad HAS_QUAD /**/ +/*#define HAS_QUAD /**/ #ifdef HAS_QUAD -# define Quad_t $quadtype /**/ -# define Uquad_t $uquadtype /**/ -# define QUADKIND $quadkind /**/ +# define Quad_t _error_ /**/ +# define Uquad_t _error_ /**/ +# define QUADKIND _error_ /**/ # define QUAD_IS_INT 1 # define QUAD_IS_LONG 2 # define QUAD_IS_LONG_LONG 3 @@ -1038,32 +1046,32 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol, if defined, indicates that the accessx routine is * available to do extended access checks. */ -#$d_accessx HAS_ACCESSX /**/ +/*#define HAS_ACCESSX /**/ /* HAS_EACCESS: * This symbol, if defined, indicates that the eaccess routine is * available to do extended access checks. */ -#$d_eaccess HAS_EACCESS /**/ +/*#define HAS_EACCESS /**/ /* I_SYS_ACCESS: * This symbol, if defined, indicates to the C program that it should * include <sys/access.h>. */ -#$i_sysaccess I_SYS_ACCESS /**/ +/*#define I_SYS_ACCESS /**/ /* I_SYS_SECURITY: * This symbol, if defined, indicates to the C program that it should * include <sys/security.h>. */ -#$i_syssecrt I_SYS_SECURITY /**/ +/*#define I_SYS_SECURITY /**/ /* OSNAME: * This symbol contains the name of the operating system, as determined * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ -#define OSNAME "$osname" /**/ +#define OSNAME "VOS" /**/ /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a @@ -1073,13 +1081,13 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #if defined(CROSSCOMPILE) || defined(MULTIARCH) # define MEM_ALIGNBYTES 8 #else -#define MEM_ALIGNBYTES $alignbytes +#define MEM_ALIGNBYTES 8 #endif /* ARCHLIB: * This variable, if defined, holds the name of the directory in * which the user wants to put architecture-dependent public - * library files for $package. It is most often a local directory + * library files for perl5. It is most often a local directory * such as /usr/local/lib. Programs using this variable must be * prepared to deal with filename expansion. If ARCHLIB is the * same as PRIVLIB, it is not defined, since presumably the @@ -1089,8 +1097,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * 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. */ -#$d_archlib ARCHLIB "$archlib" /**/ -#$d_archlib ARCHLIB_EXP "$archlibexp" /**/ +/*#define ARCHLIB "" /**/ +/*#define ARCHLIB_EXP "" /**/ /* ARCHNAME: * This symbol holds a string representing the architecture name. @@ -1098,19 +1106,19 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * where library files may be held under a private library, for * instance. */ -#define ARCHNAME "$archname" /**/ +#define ARCHNAME "vos" /**/ /* HAS_ATOLF: * This symbol, if defined, indicates that the atolf routine is * available to convert strings into long doubles. */ -#$d_atolf HAS_ATOLF /**/ +/*#define HAS_ATOLF /**/ /* HAS_ATOLL: * This symbol, if defined, indicates that the atoll routine is * available to convert strings into long longs. */ -#$d_atoll HAS_ATOLL /**/ +/*#define HAS_ATOLL /**/ /* BIN: * This symbol holds the path of the bin directory where the package will @@ -1120,8 +1128,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ -#define BIN "$bin" /**/ -#define BIN_EXP "$binexp" /**/ +#define BIN "/system/ported/command_library" /**/ +#define BIN_EXP "/system/ported/command_library" /**/ /* PERL_BINCOMPAT_5005: * This symbol, if defined, indicates that this version of Perl should be @@ -1129,7 +1137,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * that use features like threads and multiplicity it is always $undef * for those versions. */ -#$d_bincompat5005 PERL_BINCOMPAT_5005 /**/ +/*#define PERL_BINCOMPAT_5005 /**/ /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, @@ -1171,7 +1179,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un # define BYTEORDER 0x4321 # endif #else -#define BYTEORDER 0x$byteorder /* large digits for MSB */ +#define BYTEORDER 0x4321 /* large digits for MSB */ #endif /* NeXT */ /* CAT2: @@ -1180,12 +1188,12 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un /* STRINGIFY: * This macro surrounds its token with double quotes. */ -#if $cpp_stuff == 1 +#if 42 == 1 #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 +#if 42 == 42 #define PeRl_CaTiFy(a, b) a ## b #define PeRl_StGiFy(a) #a /* the additional level of indirection enables these macros to be @@ -1194,7 +1202,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #define StGiFy(a) PeRl_StGiFy(a) #define STRINGIFY(a) PeRl_StGiFy(a) #endif -#if $cpp_stuff != 1 && $cpp_stuff != 42 +#if 42 != 1 && 42 != 42 # include "Bletch: How does this C preprocessor catenate tokens?" #endif @@ -1223,23 +1231,23 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol is intended to be used along with CPPRUN in the same manner * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "". */ -#define CPPSTDIN "$cppstdin" -#define CPPMINUS "$cppminus" -#define CPPRUN "$cpprun" -#define CPPLAST "$cpplast" +#define CPPSTDIN "cc -E" +#define CPPMINUS "-" +#define CPPRUN "cc -E -" +#define CPPLAST "-" /* HAS_ACCESS: * This manifest constant lets the C program know that the access() * system call is available to check for accessibility using real UID/GID. * (always present on UNIX.) */ -#$d_access HAS_ACCESS /**/ +#define HAS_ACCESS /**/ /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. */ -#$d_casti32 CASTI32 /**/ +/*#define CASTI32 /**/ /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative @@ -1253,14 +1261,14 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * 2 = couldn't cast >= 0x80000000 * 4 = couldn't cast in argument expression list */ -#$d_castneg CASTNEGFLOAT /**/ -#define CASTFLAGS $castflags /**/ +#define CASTNEGFLOAT /**/ +#define CASTFLAGS 0 /**/ /* VOID_CLOSEDIR: * This symbol, if defined, indicates that the closedir() routine * does not return a value. */ -#$d_void_closedir VOID_CLOSEDIR /**/ +/*#define VOID_CLOSEDIR /**/ /* HAS_CSH: * This symbol, if defined, indicates that the C-shell exists. @@ -1268,9 +1276,9 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un /* CSH: * This symbol, if defined, contains the full pathname of csh. */ -#$d_csh HAS_CSH /**/ +#define HAS_CSH /**/ #ifdef HAS_CSH -#define CSH "$full_csh" /**/ +#define CSH "/system/ported/command_library/bash.pm" /**/ #endif /* DLSYM_NEEDS_UNDERSCORE: @@ -1279,7 +1287,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * makes sense if you *have* dlsym, which we will presume is the * case if you're using dl_dlopen.xs. */ -#$d_dlsymun DLSYM_NEEDS_UNDERSCORE /**/ +/*#define DLSYM_NEEDS_UNDERSCORE /**/ /* HAS_DRAND48_PROTO: * This symbol, if defined, indicates that the system provides @@ -1287,91 +1295,98 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * to the program to supply one. A good guess is * extern double drand48 _((void)); */ -#$d_drand48proto HAS_DRAND48_PROTO /**/ +/*#define HAS_DRAND48_PROTO /**/ /* HAS_ENDGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the group database. */ -#$d_endgrent HAS_ENDGRENT /**/ +/*#define HAS_ENDGRENT /**/ /* HAS_ENDHOSTENT: * This symbol, if defined, indicates that the endhostent() routine is * available to close whatever was being used for host queries. */ -#$d_endhent HAS_ENDHOSTENT /**/ +#define HAS_ENDHOSTENT /**/ /* HAS_ENDNETENT: * This symbol, if defined, indicates that the endnetent() routine is * available to close whatever was being used for network queries. */ -#$d_endnent HAS_ENDNETENT /**/ +#define HAS_ENDNETENT /**/ /* HAS_ENDPROTOENT: * This symbol, if defined, indicates that the endprotoent() routine is * available to close whatever was being used for protocol queries. */ -#$d_endpent HAS_ENDPROTOENT /**/ +#define HAS_ENDPROTOENT /**/ /* HAS_ENDPWENT: * This symbol, if defined, indicates that the getgrent routine is * available for finalizing sequential access of the passwd database. */ -#$d_endpwent HAS_ENDPWENT /**/ +/*#define HAS_ENDPWENT /**/ /* HAS_ENDSERVENT: * This symbol, if defined, indicates that the endservent() routine is * available to close whatever was being used for service queries. */ -#$d_endsent HAS_ENDSERVENT /**/ +#define HAS_ENDSERVENT /**/ /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in <sys/types.h> */ -#$d_fd_set HAS_FD_SET /**/ +/*#define HAS_FD_SET /**/ /* FLEXFILENAMES: * This symbol, if defined, indicates that the system supports filenames * longer than 14 characters. */ -#$d_flexfnam FLEXFILENAMES /**/ +#define FLEXFILENAMES /**/ /* HAS_FPOS64_T: * This symbol will be defined if the C compiler supports fpos64_t. */ -#$d_fpos64_t HAS_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. */ -#$d_frexpl HAS_FREXPL /**/ +/*#define HAS_FREXPL /**/ /* HAS_STRUCT_FS_DATA: * This symbol, if defined, indicates that the struct fs_data * to do statfs() is supported. */ -#$d_fs_data_s HAS_STRUCT_FS_DATA /**/ +/*#define HAS_STRUCT_FS_DATA /**/ /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ -#$d_fseeko HAS_FSEEKO /**/ +/*#define HAS_FSEEKO /**/ /* HAS_FSTATFS: * This symbol, if defined, indicates that the fstatfs routine is * available to stat filesystems by file descriptors. */ -#$d_fstatfs HAS_FSTATFS /**/ +/*#define HAS_FSTATFS /**/ + +/* HAS_FSYNC: + * This symbol, if defined, indicates that the fsync routine is + * available to write a file's modified data and attributes to + * permanent storage. + */ +/*#define HAS_FSYNC /**/ /* HAS_FTELLO: * This symbol, if defined, indicates that the ftello routine is * available to ftell beyond 32 bits (useful for ILP32 hosts). */ -#$d_ftello HAS_FTELLO /**/ +/*#define HAS_FTELLO /**/ /* Gconvert: * This preprocessor macro is defined to convert a floating point @@ -1388,49 +1403,49 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * d_Gconvert='sprintf((b),"%.*g",(n),(x))' * The last two assume trailing zeros should not be kept. */ -#define Gconvert(x,n,t,b) $d_Gconvert +#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x)) /* HAS_GETCWD: * This symbol, if defined, indicates that the getcwd routine is * available to get the current working directory. */ -#$d_getcwd HAS_GETCWD /**/ +#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. */ -#$d_getespwnam HAS_GETESPWNAM /**/ +/*#define HAS_GETESPWNAM /**/ /* HAS_GETFSSTAT: * This symbol, if defined, indicates that the getfsstat routine is * available to stat filesystems in bulk. */ -#$d_getfsstat HAS_GETFSSTAT /**/ +/*#define HAS_GETFSSTAT /**/ /* HAS_GETGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for sequential access of the group database. */ -#$d_getgrent HAS_GETGRENT /**/ +/*#define HAS_GETGRENT /**/ /* HAS_GETHOSTBYADDR: * This symbol, if defined, indicates that the gethostbyaddr() routine is * available to look up hosts by their IP addresses. */ -#$d_gethbyaddr HAS_GETHOSTBYADDR /**/ +#define HAS_GETHOSTBYADDR /**/ /* HAS_GETHOSTBYNAME: * This symbol, if defined, indicates that the gethostbyname() routine is * available to look up host names in some data base or other. */ -#$d_gethbyname HAS_GETHOSTBYNAME /**/ +#define HAS_GETHOSTBYNAME /**/ /* HAS_GETHOSTENT: * This symbol, if defined, indicates that the gethostent() routine is * available to look up host names in some data base or another. */ -#$d_gethent HAS_GETHOSTENT /**/ +#define HAS_GETHOSTENT /**/ /* HAS_GETHOSTNAME: * This symbol, if defined, indicates that the C program may use the @@ -1454,11 +1469,11 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * contents of PHOSTNAME as a command to feed to the popen() routine * to derive the host name. */ -#$d_gethname HAS_GETHOSTNAME /**/ -#$d_uname HAS_UNAME /**/ -#$d_phostname HAS_PHOSTNAME /**/ +#define HAS_GETHOSTNAME /**/ +#define HAS_UNAME /**/ +/*#define HAS_PHOSTNAME /**/ #ifdef HAS_PHOSTNAME -#define PHOSTNAME "$aphostname" /* How to get the host name */ +#define PHOSTNAME "" /* How to get the host name */ #endif /* HAS_GETHOST_PROTOS: @@ -1467,37 +1482,37 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * gethostbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ -#$d_gethostprotos HAS_GETHOST_PROTOS /**/ +#define HAS_GETHOST_PROTOS /**/ /* HAS_GETMNT: * This symbol, if defined, indicates that the getmnt routine is * available to get filesystem mount info by filename. */ -#$d_getmnt HAS_GETMNT /**/ +/*#define HAS_GETMNT /**/ /* HAS_GETMNTENT: * This symbol, if defined, indicates that the getmntent routine is * available to iterate through mounted file systems to get their info. */ -#$d_getmntent HAS_GETMNTENT /**/ +/*#define HAS_GETMNTENT /**/ /* HAS_GETNETBYADDR: * This symbol, if defined, indicates that the getnetbyaddr() routine is * available to look up networks by their IP addresses. */ -#$d_getnbyaddr HAS_GETNETBYADDR /**/ +#define HAS_GETNETBYADDR /**/ /* HAS_GETNETBYNAME: * This symbol, if defined, indicates that the getnetbyname() routine is * available to look up networks by their names. */ -#$d_getnbyname HAS_GETNETBYNAME /**/ +#define HAS_GETNETBYNAME /**/ /* HAS_GETNETENT: * This symbol, if defined, indicates that the getnetent() routine is * available to look up network names in some data base or another. */ -#$d_getnent HAS_GETNETENT /**/ +#define HAS_GETNETENT /**/ /* HAS_GETNET_PROTOS: * This symbol, if defined, indicates that <netdb.h> includes @@ -1505,13 +1520,13 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * getnetbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ -#$d_getnetprotos HAS_GETNET_PROTOS /**/ +#define HAS_GETNET_PROTOS /**/ /* HAS_GETPROTOENT: * This symbol, if defined, indicates that the getprotoent() routine is * available to look up protocols in some data base or another. */ -#$d_getpent HAS_GETPROTOENT /**/ +#define HAS_GETPROTOENT /**/ /* HAS_GETPROTOBYNAME: * This symbol, if defined, indicates that the getprotobyname() @@ -1521,8 +1536,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol, if defined, indicates that the getprotobynumber() * routine is available to look up protocols by their number. */ -#$d_getpbyname HAS_GETPROTOBYNAME /**/ -#$d_getpbynumber HAS_GETPROTOBYNUMBER /**/ +#define HAS_GETPROTOBYNAME /**/ +#define HAS_GETPROTOBYNUMBER /**/ /* HAS_GETPROTO_PROTOS: * This symbol, if defined, indicates that <netdb.h> includes @@ -1530,26 +1545,26 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * getprotobyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ -#$d_getprotoprotos HAS_GETPROTO_PROTOS /**/ +#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. */ -#$d_getprpwnam HAS_GETPRPWNAM /**/ +/*#define HAS_GETPRPWNAM /**/ /* HAS_GETPWENT: * This symbol, if defined, indicates that the getpwent routine is * available for sequential access of the passwd database. * If this is not available, the older getpw() function may be available. */ -#$d_getpwent HAS_GETPWENT /**/ +/*#define HAS_GETPWENT /**/ /* HAS_GETSERVENT: * This symbol, if defined, indicates that the getservent() routine is * available to look up network services in some data base or another. */ -#$d_getsent HAS_GETSERVENT /**/ +#define HAS_GETSERVENT /**/ /* HAS_GETSERV_PROTOS: * This symbol, if defined, indicates that <netdb.h> includes @@ -1557,13 +1572,13 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * getservbyaddr(). Otherwise, it is up to the program to guess * them. See netdbtype.U for probing for various Netdb_xxx_t types. */ -#$d_getservprotos HAS_GETSERV_PROTOS /**/ +#define HAS_GETSERV_PROTOS /**/ /* HAS_GETSPNAM: * This symbol, if defined, indicates that the getspnam system call is * available to retrieve SysV shadow password entries by name. */ -#$d_getspnam HAS_GETSPNAM /**/ +/*#define HAS_GETSPNAM /**/ /* HAS_GETSERVBYNAME: * This symbol, if defined, indicates that the getservbyname() @@ -1573,14 +1588,14 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol, if defined, indicates that the getservbyport() * routine is available to look up services by their port. */ -#$d_getsbyname HAS_GETSERVBYNAME /**/ -#$d_getsbyport HAS_GETSERVBYPORT /**/ +#define HAS_GETSERVBYNAME /**/ +#define HAS_GETSERVBYPORT /**/ /* HAS_GNULIBC: * This symbol, if defined, indicates to the C program that * the GNU C library is being used. */ -#$d_gnulibc HAS_GNULIBC /**/ +/*#define HAS_GNULIBC /**/ #if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE) # define _GNU_SOURCE #endif @@ -1588,7 +1603,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol, if defined, indicates that the hasmntopt routine is * available to query the mount options of file systems. */ -#$d_hasmntopt HAS_HASMNTOPT /**/ +/*#define HAS_HASMNTOPT /**/ /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and @@ -1610,48 +1625,48 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * friends htonl() htons() ntohl()) are available to do network * order byte swapping. */ -#$d_htonl HAS_HTONL /**/ -#$d_htonl HAS_HTONS /**/ -#$d_htonl HAS_NTOHL /**/ -#$d_htonl HAS_NTOHS /**/ +#define HAS_HTONL /**/ +#define HAS_HTONS /**/ +#define HAS_NTOHL /**/ +#define HAS_NTOHS /**/ /* HAS_ICONV: * This symbol, if defined, indicates that the iconv routine is * available to do character set conversions. */ -#$d_iconv HAS_ICONV /**/ +/*#define HAS_ICONV /**/ /* HAS_INT64_T: * This symbol will defined if the C compiler supports int64_t. * Usually the <inttypes.h> needs to be included, but sometimes * <sys/types.h> is enough. */ -#$d_int64_t HAS_INT64_T /**/ +/*#define HAS_INT64_T /**/ /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. */ -#$d_isascii HAS_ISASCII /**/ +#define 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 /**/ +/*#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. */ -#$d_isnanl HAS_ISNANL /**/ +/*#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). */ -#$d_lchown HAS_LCHOWN /**/ +/*#define HAS_LCHOWN /**/ /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's <float.h> @@ -1659,7 +1674,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * of significant digits in a long double precision number. Unlike * for DBL_DIG, there's no good guess for LDBL_DIG if it is undefined. */ -#$d_ldbl_dig HAS_LDBL_DIG /* */ +#define HAS_LDBL_DIG /* */ /* HAS_LONG_DOUBLE: * This symbol will be defined if the C compiler supports long @@ -1670,9 +1685,9 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * C preprocessor can make decisions based on it. It is only * defined if the system supports long doubles. */ -#$d_longdbl HAS_LONG_DOUBLE /**/ +#define HAS_LONG_DOUBLE /**/ #ifdef HAS_LONG_DOUBLE -#define LONG_DOUBLESIZE $longdblsize /**/ +#define LONG_DOUBLESIZE 8 /**/ #endif /* HAS_LONG_LONG: @@ -1683,9 +1698,9 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * C preprocessor can make decisions based on it. It is only * defined if the system supports long long. */ -#$d_longlong HAS_LONG_LONG /**/ +/*#define HAS_LONG_LONG /**/ #ifdef HAS_LONG_LONG -#define LONGLONGSIZE $longlongsize /**/ +#define LONGLONGSIZE _error_ /**/ #endif /* HAS_LSEEK_PROTO: @@ -1694,39 +1709,39 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * to the program to supply one. A good guess is * extern off_t lseek(int, off_t, int); */ -#$d_lseekproto HAS_LSEEK_PROTO /**/ +#define HAS_LSEEK_PROTO /**/ /* HAS_MADVISE: * This symbol, if defined, indicates that the madvise system call is * available to map a file into memory. */ -#$d_madvise HAS_MADVISE /**/ +/*#define HAS_MADVISE /**/ /* HAS_MEMCHR: * This symbol, if defined, indicates that the memchr routine is available * to locate characters within a C string. */ -#$d_memchr HAS_MEMCHR /**/ +#define HAS_MEMCHR /**/ /* HAS_MKDTEMP: * This symbol, if defined, indicates that the mkdtemp routine is * available to exclusively create a uniquely named temporary directory. */ -#$d_mkdtemp HAS_MKDTEMP /**/ +/*#define HAS_MKDTEMP /**/ /* HAS_MKSTEMP: * This symbol, if defined, indicates that the mkstemp routine is * available to exclusively create and open a uniquely named * temporary file. */ -#$d_mkstemp HAS_MKSTEMP /**/ +/*#define HAS_MKSTEMP /**/ /* HAS_MKSTEMPS: * This symbol, if defined, indicates that the mkstemps routine is * available to excluslvely create and open a uniquely named * (with a suffix) temporary file. */ -#$d_mkstemps HAS_MKSTEMPS /**/ +/*#define HAS_MKSTEMPS /**/ /* HAS_MMAP: * This symbol, if defined, indicates that the mmap system call is @@ -1737,38 +1752,38 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * (and simultaneously the type of the first argument). * Usually set to 'void *' or 'cadd_t'. */ -#$d_mmap HAS_MMAP /**/ -#define Mmap_t $mmaptype /**/ +#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. */ -#$d_modfl HAS_MODFL /**/ +/*#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. */ -#$d_mprotect HAS_MPROTECT /**/ +/*#define HAS_MPROTECT /**/ /* HAS_MSG: * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). */ -#$d_msg HAS_MSG /**/ +/*#define HAS_MSG /**/ /* HAS_OFF64_T: * This symbol will be defined if the C compiler supports off64_t. */ -#$d_off64_t HAS_OFF64_T /**/ +/*#define HAS_OFF64_T /**/ /* HAS_OPEN3: * This manifest constant lets the C program know that the three * argument form of open(2) is available. */ -#$d_open3 HAS_OPEN3 /**/ +#define HAS_OPEN3 /**/ /* OLD_PTHREAD_CREATE_JOINABLE: * This symbol, if defined, indicates how to create pthread @@ -1778,7 +1793,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * If defined, known values are PTHREAD_CREATE_UNDETACHED * and __UNDETACHED. */ -#$d_old_pthread_create_joinable OLD_PTHREAD_CREATE_JOINABLE $old_pthread_create_joinable /**/ +/*#define OLD_PTHREAD_CREATE_JOINABLE /**/ /* HAS_PTHREAD_YIELD: * This symbol, if defined, indicates that the pthread_yield @@ -1795,9 +1810,9 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * routine is available to yield the execution of the current * thread. sched_yield is preferable to pthread_yield. */ -#$d_pthread_yield HAS_PTHREAD_YIELD /**/ -#define SCHED_YIELD $sched_yield /**/ -#$d_sched_yield HAS_SCHED_YIELD /**/ +/*#define HAS_PTHREAD_YIELD /**/ +#define SCHED_YIELD /**/ +/*#define HAS_SCHED_YIELD /**/ /* HAS_SAFE_BCOPY: * This symbol, if defined, indicates that the bcopy routine is available @@ -1805,7 +1820,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * probably use memmove() or memcpy(). If neither is defined, roll your * own version. */ -#$d_safebcpy HAS_SAFE_BCOPY /**/ +/*#define HAS_SAFE_BCOPY /**/ /* HAS_SAFE_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available @@ -1813,94 +1828,103 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * probably use memmove() or memcpy(). If neither is defined, roll your * own version. */ -#$d_safemcpy HAS_SAFE_MEMCPY /**/ +/*#define HAS_SAFE_MEMCPY /**/ /* HAS_SANE_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * and can be used to compare relative magnitudes of chars with their high * bits set. If it is not defined, roll your own version. */ -#$d_sanemcmp HAS_SANE_MEMCMP /**/ +#define HAS_SANE_MEMCMP /**/ + +/* HAS_SBRK_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the sbrk() function. Otherwise, it is up + * to the program to supply one. Good guesses are + * extern void* sbrk _((int)); + * extern void* sbrk _((size_t)); + */ +/*#define HAS_SBRK_PROTO / **/ /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. */ -#$d_sem HAS_SEM /**/ +/*#define HAS_SEM /**/ /* HAS_SETGRENT: * This symbol, if defined, indicates that the setgrent routine is * available for initializing sequential access of the group database. */ -#$d_setgrent HAS_SETGRENT /**/ +/*#define HAS_SETGRENT /**/ /* HAS_SETGROUPS: * This symbol, if defined, indicates that the setgroups() routine is * available to set the list of process groups. If unavailable, multiple * groups are probably not supported. */ -#$d_setgrps HAS_SETGROUPS /**/ +/*#define HAS_SETGROUPS /**/ /* HAS_SETHOSTENT: * This symbol, if defined, indicates that the sethostent() routine is * available. */ -#$d_sethent HAS_SETHOSTENT /**/ +#define HAS_SETHOSTENT /**/ /* HAS_SETNETENT: * This symbol, if defined, indicates that the setnetent() routine is * available. */ -#$d_setnent HAS_SETNETENT /**/ +#define HAS_SETNETENT /**/ /* HAS_SETPROTOENT: * This symbol, if defined, indicates that the setprotoent() routine is * available. */ -#$d_setpent HAS_SETPROTOENT /**/ +#define HAS_SETPROTOENT /**/ /* HAS_SETPROCTITLE: * This symbol, if defined, indicates that the setproctitle routine is * available to set process title. */ -#$d_setproctitle HAS_SETPROCTITLE /**/ +/*#define HAS_SETPROCTITLE /**/ /* HAS_SETPWENT: * This symbol, if defined, indicates that the setpwent routine is * available for initializing sequential access of the passwd database. */ -#$d_setpwent HAS_SETPWENT /**/ +/*#define HAS_SETPWENT /**/ /* HAS_SETSERVENT: * This symbol, if defined, indicates that the setservent() routine is * available. */ -#$d_setsent HAS_SETSERVENT /**/ +#define HAS_SETSERVENT /**/ /* HAS_SETVBUF: * This symbol, if defined, indicates that the setvbuf routine is * available to change buffering on an open stdio stream. * to a line-buffered mode. */ -#$d_setvbuf HAS_SETVBUF /**/ +#define HAS_SETVBUF /**/ /* USE_SFIO: * This symbol, if defined, indicates that sfio should * be used. */ -#$d_sfio USE_SFIO /**/ +/*#define USE_SFIO /**/ /* HAS_SHM: * This symbol, if defined, indicates that the entire shm*(2) library is * supported. */ -#$d_shm HAS_SHM /**/ +/*#define HAS_SHM /**/ /* HAS_SIGACTION: * This symbol, if defined, indicates that Vr4's sigaction() routine * is available. */ -#$d_sigaction HAS_SIGACTION /**/ +#define HAS_SIGACTION /**/ /* HAS_SIGSETJMP: * This variable indicates to the C program that the sigsetjmp() @@ -1922,7 +1946,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * traditional longjmp() if siglongjmp isn't available. * See HAS_SIGSETJMP. */ -#$d_sigsetjmp HAS_SIGSETJMP /**/ +#define HAS_SIGSETJMP /**/ #ifdef HAS_SIGSETJMP #define Sigjmp_buf sigjmp_buf #define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask)) @@ -1971,33 +1995,33 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * Checking just with #ifdef might not be enough because this symbol * has been known to be an enum. */ -#$d_socket HAS_SOCKET /**/ -#$d_sockpair HAS_SOCKETPAIR /**/ -#$d_msg_ctrunc HAS_MSG_CTRUNC /**/ -#$d_msg_dontroute HAS_MSG_DONTROUTE /**/ -#$d_msg_oob HAS_MSG_OOB /**/ -#$d_msg_peek HAS_MSG_PEEK /**/ -#$d_msg_proxy HAS_MSG_PROXY /**/ -#$d_scm_rights HAS_SCM_RIGHTS /**/ +#define HAS_SOCKET /**/ +/*#define HAS_SOCKETPAIR /**/ +/*#define HAS_MSG_CTRUNC /**/ +/*#define HAS_MSG_DONTROUTE /**/ +/*#define HAS_MSG_OOB /**/ +/*#define HAS_MSG_PEEK /**/ +/*#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. */ -#$d_socks5_init HAS_SOCKS5_INIT /**/ +/*#define HAS_SOCKS5_INIT /**/ /* HAS_SQRTL: * This symbol, if defined, indicates that the sqrtl routine is * available to do long double square roots. */ -#$d_sqrtl HAS_SQRTL /**/ +/*#define HAS_SQRTL /**/ /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. */ #ifndef USE_STAT_BLOCKS -#$d_statblks USE_STAT_BLOCKS /**/ +/*#define USE_STAT_BLOCKS /**/ #endif /* HAS_STRUCT_STATFS_F_FLAGS: @@ -2009,19 +2033,19 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * have statfs() and struct statfs, they have ustat() and getmnt() * with struct ustat and struct fs_data. */ -#$d_statfs_f_flags HAS_STRUCT_STATFS_F_FLAGS /**/ +/*#define HAS_STRUCT_STATFS_F_FLAGS /**/ /* HAS_STRUCT_STATFS: * This symbol, if defined, indicates that the struct statfs * to do statfs() is supported. */ -#$d_statfs_s HAS_STRUCT_STATFS /**/ +/*#define HAS_STRUCT_STATFS /**/ /* HAS_FSTATVFS: * This symbol, if defined, indicates that the fstatvfs routine is * available to stat filesystems by file descriptors. */ -#$d_fstatvfs HAS_FSTATVFS /**/ +/*#define HAS_FSTATVFS /**/ /* USE_STDIO_PTR: * This symbol is defined if the _ptr and _cnt fields (or similar) @@ -2048,12 +2072,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. */ -#$d_stdstdio USE_STDIO_PTR /**/ +/* 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) $stdio_ptr -#$d_stdio_ptr_lval STDIO_PTR_LVALUE /**/ -#define FILE_cnt(fp) $stdio_cnt -#$d_stdio_cnt_lval STDIO_CNT_LVALUE /**/ +#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: @@ -2076,10 +2111,10 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * structure pointed to its argument. This macro will always be defined * if USE_STDIO_BASE is defined. */ -#$d_stdiobase USE_STDIO_BASE /**/ +#define USE_STDIO_BASE /**/ #ifdef USE_STDIO_BASE -#define FILE_base(fp) $stdio_base -#define FILE_bufsiz(fp) $stdio_bufsiz +#define FILE_base(fp) ((fp)->_base) +#define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base) #endif /* HAS_STRERROR: @@ -2097,33 +2132,33 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * not available to translate error numbers to strings but sys_errlist[] * array is there. */ -#$d_strerror HAS_STRERROR /**/ -#$d_syserrlst HAS_SYS_ERRLIST /**/ -#define Strerror(e) $d_strerrm +#define HAS_STRERROR /**/ +#define HAS_SYS_ERRLIST /**/ +#define Strerror(e) strerror(e) /* HAS_STRTOLD: * This symbol, if defined, indicates that the strtold routine is * available to convert strings to long doubles. */ -#$d_strtold HAS_STRTOLD /**/ +/*#define HAS_STRTOLD /**/ /* HAS_STRTOLL: * This symbol, if defined, indicates that the strtoll routine is * available to convert strings to long longs. */ -#$d_strtoll HAS_STRTOLL /**/ +/*#define HAS_STRTOLL /**/ /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. */ -#$d_strtoull HAS_STRTOULL /**/ +/*#define HAS_STRTOULL /**/ /* HAS_STRTOUQ: * This symbol, if defined, indicates that the strtouq routine is * available to convert strings to unsigned long longs (quads). */ -#$d_strtouq HAS_STRTOUQ /**/ +/*#define HAS_STRTOUQ /**/ /* HAS_TELLDIR_PROTO: * This symbol, if defined, indicates that the system provides @@ -2131,21 +2166,21 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * to the program to supply one. A good guess is * extern long telldir _((DIR*)); */ -#$d_telldirproto HAS_TELLDIR_PROTO /**/ +/*#define HAS_TELLDIR_PROTO /**/ /* Time_t: * This symbol holds the type returned by time(). It can be long, * or time_t on BSD sites (in which case <sys/types.h> should be * included). */ -#define Time_t $timetype /* Time type */ +#define Time_t time_t /* Time type */ /* HAS_TIMES: * This symbol, if defined, indicates that the times() routine exists. * Note that this became obsolete on some systems (SUNOS), which now * use getrusage(). It may be necessary to include <sys/times.h>. */ -#$d_times HAS_TIMES /**/ +#define HAS_TIMES /**/ /* HAS_UNION_SEMUN: * This symbol, if defined, indicates that the union semun is @@ -2165,20 +2200,20 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol, if defined, indicates that struct semid_ds * is * used for semctl IPC_STAT. */ -#$d_union_semun HAS_UNION_SEMUN /**/ -#$d_semctl_semun USE_SEMCTL_SEMUN /**/ -#$d_semctl_semid_ds USE_SEMCTL_SEMID_DS /**/ +/*#define HAS_UNION_SEMUN /**/ +/*#define USE_SEMCTL_SEMUN /**/ +/*#define USE_SEMCTL_SEMID_DS /**/ /* HAS_USTAT: * This symbol, if defined, indicates that the ustat system call is * available to query file system statistics by dev_t. */ -#$d_ustat HAS_USTAT /**/ +/*#define HAS_USTAT /**/ /* HAS_VFORK: * This symbol, if defined, indicates that vfork() exists. */ -#$d_vfork HAS_VFORK /**/ +/*#define HAS_VFORK /**/ /* Signal_t: * This symbol's value is either "void" or "int", corresponding to the @@ -2186,7 +2221,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * a signal handler using "Signal_t (*handler)()", and define the * handler using "Signal_t handler(sig)". */ -#define Signal_t $signal_t /* Signal handler's return type */ +#define Signal_t void /* Signal handler's return type */ /* HAS_VPRINTF: * This symbol, if defined, indicates that the vprintf routine is available @@ -2199,26 +2234,26 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * is up to the package author to declare vsprintf correctly based on the * symbol. */ -#$d_vprintf HAS_VPRINTF /**/ -#$d_charvspr USE_CHAR_VSPRINTF /**/ +#define HAS_VPRINTF /**/ +/*#define USE_CHAR_VSPRINTF /**/ /* USE_DYNAMIC_LOADING: * This symbol, if defined, indicates that dynamic loading of * some sort is available. */ -#$usedl USE_DYNAMIC_LOADING /**/ +/*#define USE_DYNAMIC_LOADING /**/ /* DOUBLESIZE: * This symbol contains the size of a double, so that the C preprocessor * can make decisions based on it. */ -#define DOUBLESIZE $doublesize /**/ +#define DOUBLESIZE 8 /**/ /* EBCDIC: * This symbol, if defined, indicates that this system uses * EBCDIC encoding. */ -#$ebcdic EBCDIC /**/ +/*#define EBCDIC /**/ /* FFLUSH_NULL: * This symbol, if defined, tells that fflush(NULL) does flush @@ -2231,31 +2266,31 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * Note that if fflushNULL is defined, fflushall will not * even be probed for and will be left undefined. */ -#$fflushNULL FFLUSH_NULL /**/ -#$fflushall FFLUSH_ALL /**/ +#define FFLUSH_NULL /**/ +/*#define FFLUSH_ALL /**/ /* Fpos_t: * This symbol holds the type used to declare file positions in libc. * It can be fpos_t, long, uint, etc... It may be necessary to include * <sys/types.h> to get any typedef'ed information. */ -#define Fpos_t $fpostype /* File position type */ +#define Fpos_t fpos_t /* File position type */ /* Gid_t_f: * This symbol defines the format string used for printing a Gid_t. */ -#define Gid_t_f $gidformat /**/ +#define Gid_t_f "d" /**/ /* Gid_t_sign: * This symbol holds the signedess of a Gid_t. * 1 for unsigned, -1 for signed. */ -#define Gid_t_sign $gidsign /* GID sign */ +#define Gid_t_sign -1 /* GID sign */ /* Gid_t_size: * This symbol holds the size of a Gid_t in bytes. */ -#define Gid_t_size $gidsize /* GID size */ +#define Gid_t_size 4 /* GID size */ /* Gid_t: * This symbol holds the return type of getgid() and the type of @@ -2264,7 +2299,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * gid_t, etc... It may be necessary to include <sys/types.h> to get * any typedef'ed information. */ -#define Gid_t $gidtype /* Type for getgid(), etc... */ +#define Gid_t gid_t /* Type for getgid(), etc... */ /* Groups_t: * This symbol holds the type used for the second argument to @@ -2276,7 +2311,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * getgroups() or setgroups().. */ #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) -#define Groups_t $groupstype /* Type for 2nd arg to [sg]etgroups() */ +#define Groups_t gid_t /* Type for 2nd arg to [sg]etgroups() */ #endif /* DB_Prefix_t: @@ -2289,8 +2324,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * in the <db.h> header file. In older versions of DB, it was * int, while in newer ones it is size_t. */ -#define DB_Hash_t $db_hashtype /**/ -#define DB_Prefix_t $db_prefixtype /**/ +#define DB_Hash_t int /**/ +#define DB_Prefix_t int /**/ /* I_GRP: * This symbol, if defined, indicates to the C program that it should @@ -2300,74 +2335,74 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol, if defined, indicates to the C program that struct group * in <grp.h> contains gr_passwd. */ -#$i_grp I_GRP /**/ -#$d_grpasswd GRPASSWD /**/ +#define I_GRP /**/ +/*#define GRPASSWD /**/ /* I_ICONV: * This symbol, if defined, indicates that <iconv.h> exists and * should be included. */ -#$i_iconv I_ICONV /**/ +/*#define I_ICONV /**/ /* I_IEEEFP: * This symbol, if defined, indicates that <ieeefp.h> exists and * should be included. */ -#$i_ieeefp I_IEEEFP /**/ +/*#define I_IEEEFP /**/ /* I_INTTYPES: * This symbol, if defined, indicates to the C program that it should * include <inttypes.h>. */ -#$i_inttypes I_INTTYPES /**/ +/*#define I_INTTYPES /**/ /* I_LIBUTIL: * This symbol, if defined, indicates that <libutil.h> exists and * should be included. */ -#$i_libutil I_LIBUTIL /**/ +/*#define I_LIBUTIL /**/ /* I_MACH_CTHREADS: * This symbol, if defined, indicates to the C program that it should * include <mach/cthreads.h>. */ -#$i_machcthr I_MACH_CTHREADS /**/ +/*#define I_MACH_CTHREADS /**/ /* I_MNTENT: * This symbol, if defined, indicates that <mntent.h> exists and * should be included. */ -#$i_mntent I_MNTENT /**/ +/*#define I_MNTENT /**/ /* I_NETDB: * This symbol, if defined, indicates that <netdb.h> exists and * should be included. */ -#$i_netdb I_NETDB /**/ +#define I_NETDB /**/ /* I_NETINET_TCP: * This symbol, if defined, indicates to the C program that it should * include <netinet/tcp.h>. */ -#$i_netinettcp I_NETINET_TCP /**/ +#define I_NETINET_TCP /**/ /* I_POLL: * This symbol, if defined, indicates that <poll.h> exists and * should be included. */ -#$i_poll I_POLL /**/ +/*#define I_POLL /**/ /* I_PROT: * This symbol, if defined, indicates that <prot.h> exists and * should be included. */ -#$i_prot I_PROT /**/ +/*#define I_PROT /**/ /* I_PTHREAD: * This symbol, if defined, indicates to the C program that it should * include <pthread.h>. */ -#$i_pthread I_PTHREAD /**/ +/*#define I_PTHREAD /**/ /* I_PWD: * This symbol, if defined, indicates to the C program that it should @@ -2405,80 +2440,80 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol, if defined, indicates to the C program that struct passwd * contains pw_passwd. */ -#$i_pwd I_PWD /**/ -#$d_pwquota PWQUOTA /**/ -#$d_pwage PWAGE /**/ -#$d_pwchange PWCHANGE /**/ -#$d_pwclass PWCLASS /**/ -#$d_pwexpire PWEXPIRE /**/ -#$d_pwcomment PWCOMMENT /**/ -#$d_pwgecos PWGECOS /**/ -#$d_pwpasswd PWPASSWD /**/ +#define I_PWD /**/ +/*#define PWQUOTA /**/ +/*#define PWAGE /**/ +/*#define PWCHANGE /**/ +/*#define PWCLASS /**/ +/*#define PWEXPIRE /**/ +/*#define PWCOMMENT /**/ +/*#define PWGECOS /**/ +/*#define PWPASSWD /**/ /* I_SHADOW: * This symbol, if defined, indicates that <shadow.h> exists and * should be included. */ -#$i_shadow I_SHADOW /**/ +/*#define I_SHADOW /**/ /* I_SOCKS: * This symbol, if defined, indicates that <socks.h> exists and * should be included. */ -#$i_socks I_SOCKS /**/ +/*#define I_SOCKS /**/ /* I_SUNMATH: * This symbol, if defined, indicates that <sunmath.h> exists and * should be included. */ -#$i_sunmath I_SUNMATH /**/ +/*#define I_SUNMATH /**/ /* I_SYSLOG: * This symbol, if defined, indicates that <syslog.h> exists and * should be included. */ -#$i_syslog I_SYSLOG /**/ +/*#define I_SYSLOG /**/ /* I_SYSMODE: * This symbol, if defined, indicates that <sys/mode.h> exists and * should be included. */ -#$i_sysmode I_SYSMODE /**/ +/*#define I_SYSMODE /**/ /* I_SYS_MOUNT: * This symbol, if defined, indicates that <sys/mount.h> exists and * should be included. */ -#$i_sysmount I_SYS_MOUNT /**/ +/*#define I_SYS_MOUNT /**/ /* I_SYS_STATFS: * This symbol, if defined, indicates that <sys/statfs.h> exists. */ -#$i_sysstatfs I_SYS_STATFS /**/ +/*#define I_SYS_STATFS /**/ /* I_SYS_STATVFS: * This symbol, if defined, indicates that <sys/statvfs.h> exists and * should be included. */ -#$i_sysstatvfs I_SYS_STATVFS /**/ +/*#define I_SYS_STATVFS /**/ /* I_SYSUIO: * This symbol, if defined, indicates that <sys/uio.h> exists and * should be included. */ -#$i_sysuio I_SYSUIO /**/ +/*#define I_SYSUIO /**/ /* I_SYSUTSNAME: * This symbol, if defined, indicates that <sys/utsname.h> exists and * should be included. */ -#$i_sysutsname I_SYSUTSNAME /**/ +#define I_SYSUTSNAME /**/ /* I_SYS_VFS: * This symbol, if defined, indicates that <sys/vfs.h> exists and * should be included. */ -#$i_sysvfs I_SYS_VFS /**/ +/*#define I_SYS_VFS /**/ /* I_TIME: * This symbol, if defined, indicates to the C program that it should @@ -2492,15 +2527,15 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol, if defined, indicates to the C program that it should * include <sys/time.h> with KERNEL defined. */ -#$i_time I_TIME /**/ -#$i_systime I_SYS_TIME /**/ -#$i_systimek I_SYS_TIME_KERNEL /**/ +/*#define I_TIME /**/ +#define I_SYS_TIME /**/ +/*#define I_SYS_TIME_KERNEL /**/ /* I_USTAT: * This symbol, if defined, indicates that <ustat.h> exists and * should be included. */ -#$i_ustat I_USTAT /**/ +/*#define I_USTAT /**/ /* PERL_INC_VERSION_LIST: * This variable specifies the list of subdirectories in over @@ -2509,13 +2544,13 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * for a C initialization string. See the inc_version_list entry * in Porting/Glossary for more details. */ -#define PERL_INC_VERSION_LIST $inc_version_list_init /**/ +#define PERL_INC_VERSION_LIST 0 /**/ /* INSTALL_USR_BIN_PERL: * This symbol, if defined, indicates that Perl is to be installed * also as /usr/bin/perl. */ -#$installusrbinperl INSTALL_USR_BIN_PERL /**/ +/*#define INSTALL_USR_BIN_PERL /**/ /* PERL_PRIfldbl: * This symbol, if defined, contains the string used by stdio to @@ -2533,10 +2568,10 @@ 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 'f') for input. */ -#$d_PRIfldbl PERL_PRIfldbl $sPRIfldbl /**/ -#$d_PRIgldbl PERL_PRIgldbl $sPRIgldbl /**/ -#$d_PRIeldbl PERL_PRIeldbl $sPRIeldbl /**/ -#$d_SCNfldbl PERL_SCNfldbl $sSCNfldbl /**/ +#define PERL_PRIfldbl "Lf" /**/ +#define PERL_PRIgldbl "Lg" /**/ +#define PERL_PRIeldbl "Le" /**/ +#define PERL_SCNfldbl "Lf" /**/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. @@ -2549,9 +2584,9 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un /* Off_t_size: * This symbol holds the number of bytes used by the Off_t. */ -#define Off_t $lseektype /* <offset> type */ -#define LSEEKSIZE $lseeksize /* <offset> size */ -#define Off_t_size $lseeksize /* <offset> size */ +#define Off_t off_t /* <offset> type */ +#define LSEEKSIZE 4 /* <offset> size */ +#define Off_t_size 4 /* <offset> size */ /* Free_t: * This variable contains the return type of free(). It is usually @@ -2560,13 +2595,13 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un /* Malloc_t: * This symbol is the type of pointer returned by malloc and realloc. */ -#define Malloc_t $malloctype /**/ -#define Free_t $freetype /**/ +#define Malloc_t void * /**/ +#define Free_t void /**/ /* MYMALLOC: * This symbol, if defined, indicates that we're using our own malloc. */ -#$d_mymalloc MYMALLOC /**/ +/*#define MYMALLOC /**/ /* Mode_t: * This symbol holds the type used to declare file modes @@ -2574,7 +2609,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * int or unsigned short. It may be necessary to include <sys/types.h> * to get any typedef'ed information. */ -#define Mode_t $modetype /* file mode parameter for system calls */ +#define Mode_t mode_t /* file mode parameter for system calls */ /* VAL_O_NONBLOCK: * This symbol is to be used during open() or fcntl(F_SETFL) to turn on @@ -2598,10 +2633,10 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * a non-blocking file descriptor will return 0 on EOF, and not the value * held in RD_NODATA (-1 usually, in that case!). */ -#define VAL_O_NONBLOCK $o_nonblock -#define VAL_EAGAIN $eagain -#define RD_NODATA $rd_nodata -#$d_eofnblk EOF_NONBLOCK +#define VAL_O_NONBLOCK O_NONBLOCK +#define VAL_EAGAIN EAGAIN +#define RD_NODATA -1 +#define EOF_NONBLOCK /* Netdb_host_t: * This symbol holds the type used for the 1st argument @@ -2619,10 +2654,10 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol holds the type used for the 1st argument to * getnetbyaddr(). */ -#define Netdb_host_t $netdb_host_type /**/ -#define Netdb_hlen_t $netdb_hlen_type /**/ -#define Netdb_name_t $netdb_name_type /**/ -#define Netdb_net_t $netdb_net_type /**/ +#define Netdb_host_t char * /**/ +#define Netdb_hlen_t int /**/ +#define Netdb_name_t char * /**/ +#define Netdb_net_t long /**/ /* PERL_OTHERLIBDIRS: * This variable contains a colon-separated set of paths for the perl @@ -2632,7 +2667,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * and architecture-specific directories. See PERL_INC_VERSION_LIST * for more details. */ -#$d_perl_otherlibdirs PERL_OTHERLIBDIRS "$otherlibdirs" /**/ +/*#define PERL_OTHERLIBDIRS "" /**/ /* IVTYPE: * This symbol defines the C type used for Perl's IV. @@ -2708,34 +2743,34 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * 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 /**/ -#define I8TYPE $i8type /**/ -#define U8TYPE $u8type /**/ -#define I16TYPE $i16type /**/ -#define U16TYPE $u16type /**/ -#define I32TYPE $i32type /**/ -#define U32TYPE $u32type /**/ +#define IVTYPE int /**/ +#define UVTYPE unsigned int /**/ +#define I8TYPE char /**/ +#define U8TYPE unsigned char /**/ +#define I16TYPE short /**/ +#define U16TYPE unsigned short /**/ +#define I32TYPE int /**/ +#define U32TYPE unsigned int /**/ #ifdef HAS_QUAD -#define I64TYPE $i64type /**/ -#define U64TYPE $u64type /**/ +#define I64TYPE _error_ /**/ +#define U64TYPE _error_ /**/ #endif -#define NVTYPE $nvtype /**/ -#define IVSIZE $ivsize /**/ -#define UVSIZE $uvsize /**/ -#define I8SIZE $i8size /**/ -#define U8SIZE $u8size /**/ -#define I16SIZE $i16size /**/ -#define U16SIZE $u16size /**/ -#define I32SIZE $i32size /**/ -#define U32SIZE $u32size /**/ +#define NVTYPE double /**/ +#define IVSIZE 4 /**/ +#define UVSIZE 4 /**/ +#define I8SIZE 1 /**/ +#define U8SIZE 1 /**/ +#define I16SIZE 2 /**/ +#define U16SIZE 2 /**/ +#define I32SIZE 4 /**/ +#define U32SIZE 4 /**/ #ifdef HAS_QUAD -#define I64SIZE $i64size /**/ -#define U64SIZE $u64size /**/ +#define I64SIZE _error_ /**/ +#define U64SIZE _error_ /**/ #endif -#define NVSIZE $nvsize /**/ -#$d_nv_preserves_uv NV_PRESERVES_UV -#define NV_PRESERVES_UV_BITS $d_nv_preserves_uv_bits +#define NVSIZE 8 /**/ +#define NV_PRESERVES_UV +#define NV_PRESERVES_UV_BITS 32 /* IVdf: * This symbol defines the format string used for printing a Perl IV @@ -2765,20 +2800,20 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * 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 /**/ +#define IVdf "d" /**/ +#define UVuf "u" /**/ +#define UVof "o" /**/ +#define UVxf "x" /**/ +#define NVef "e" /**/ +#define NVff "f" /**/ +#define NVgf "g" /**/ /* Pid_t: * This symbol holds the type used to declare process ids in the kernel. * It can be int, uint, pid_t, etc... It may be necessary to include * <sys/types.h> to get any typedef'ed information. */ -#define Pid_t $pidtype /* PID type */ +#define Pid_t pid_t /* PID type */ /* PRIVLIB: * This symbol contains the name of the private library for this package. @@ -2790,8 +2825,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * 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 "$privlib" /**/ -#define PRIVLIB_EXP "$privlibexp" /**/ +#define PRIVLIB "/system/ported/perl/lib/5.7" /**/ +#define PRIVLIB_EXP "/system/ported/perl/lib/5.7" /**/ /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor @@ -2799,7 +2834,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * the compiler supports (void *); otherwise it will be * sizeof(char *). */ -#define PTRSIZE $ptrsize /**/ +#define PTRSIZE 4 /**/ /* Drand01: * This macro is to be used to generate uniformly distributed @@ -2821,10 +2856,10 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * function used to generate normalized random numbers. * Values include 15, 16, 31, and 48. */ -#define Drand01() $drand01 /**/ -#define Rand_seed_t $randseedtype /**/ -#define seedDrand01(x) $seedfunc((Rand_seed_t)x) /**/ -#define RANDBITS $randbits /**/ +#define Drand01() rand()/(RAND_MAX+1) /**/ +#define Rand_seed_t unsigned int /**/ +#define seedDrand01(x) srand((Rand_seed_t)x) /**/ +#define RANDBITS 15 /**/ /* SELECT_MIN_BITS: * This symbol holds the minimum number of bits operated by select. @@ -2833,7 +2868,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * is either n or 32*ceil(n/32), especially many little-endians do * the latter. This is only useful if you have select(), naturally. */ -#define SELECT_MIN_BITS $selectminbits /**/ +#define SELECT_MIN_BITS 1 /**/ /* Select_fd_set_t: * This symbol holds the type used for the 2nd, 3rd, and 4th @@ -2841,7 +2876,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * is defined, and 'int *' otherwise. This is only useful if you * have select(), of course. */ -#define Select_fd_set_t $selecttype /**/ +#define Select_fd_set_t fd_set * /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of @@ -2871,8 +2906,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * The last element is 0, corresponding to the 0 at the end of * the sig_name list. */ -#define SIG_NAME $sig_name_init /**/ -#define SIG_NUM $sig_num_init /**/ +#define SIG_NAME "ZERO","ABRT","FPE","ILL","INT","SEGV","TERM","USR1","USR2","IO","HUP","URG","ALRM","CHLD","CONT","KILL","STOP","PIPE","QUIT","BUS","TRAP","TSTP","TTIN","TTOU","RT1","RT2","RT3","RT4","RT5","RT6","RT7","RT8",0 /**/ +#define 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,0 /**/ /* SITEARCH: * This symbol contains the name of the private library for this package. @@ -2889,8 +2924,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * 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 "$sitearch" /**/ -#define SITEARCH_EXP "$sitearchexp" /**/ +/*#define SITEARCH "" /**/ +/*#define SITEARCH_EXP "" /**/ /* SITELIB: * This symbol contains the name of the private library for this package. @@ -2912,14 +2947,14 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * 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 "$sitelib" /**/ -#define SITELIB_EXP "$sitelibexp" /**/ -#define SITELIB_STEM "$sitelib_stem" /**/ +#define SITELIB "/system/ported/perl/lib/site/5.7" /**/ +#define SITELIB_EXP "/system/ported/perl/lib/site/5.7" /**/ +#define SITELIB_STEM "/system/ported/perl/lib/site" /**/ /* Size_t_size: * This symbol holds the size of a Size_t in bytes. */ -#define Size_t_size $sizesize /* */ +#define Size_t_size 4 /* */ /* Size_t: * This symbol holds the type used to declare length parameters @@ -2927,13 +2962,13 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * unsigned long, int, etc. It may be necessary to include * <sys/types.h> to get any typedef'ed information. */ -#define Size_t $sizetype /* length paramater for string functions */ +#define Size_t size_t /* length paramater for string functions */ /* Sock_size_t: * This symbol holds the type used for the size argument of * various socket calls (just the base type, not the pointer-to). */ -#define Sock_size_t $socksizetype /**/ +#define Sock_size_t int /**/ /* SSize_t: * This symbol holds the type used by functions that return @@ -2943,14 +2978,14 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * to get any typedef'ed information. * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). */ -#define SSize_t $ssizetype /* signed count of bytes */ +#define SSize_t ssize_t /* signed count of bytes */ /* STARTPERL: * This variable contains the string to put in front of a perl * script to make sure (one hopes) that it runs with perl and not * some shell. */ -#define STARTPERL "$startperl" /**/ +#define STARTPERL "!perl.pm" /**/ /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array @@ -2960,31 +2995,31 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol tells the name of the array holding the stdio streams. * Usual values include _iob, __iob, and __sF. */ -#$d_stdio_stream_array HAS_STDIO_STREAM_ARRAY /**/ -#define STDIO_STREAM_ARRAY $stdio_stream_array +#define HAS_STDIO_STREAM_ARRAY /**/ +#define STDIO_STREAM_ARRAY _iob /* Uid_t_f: * This symbol defines the format string used for printing a Uid_t. */ -#define Uid_t_f $uidformat /**/ +#define Uid_t_f "d" /**/ /* Uid_t_sign: * This symbol holds the signedess of a Uid_t. * 1 for unsigned, -1 for signed. */ -#define Uid_t_sign $uidsign /* UID sign */ +#define Uid_t_sign -1 /* UID sign */ /* Uid_t_size: * This symbol holds the size of a Uid_t in bytes. */ -#define Uid_t_size $uidsize /* UID size */ +#define Uid_t_size 4 /* UID size */ /* Uid_t: * This symbol holds the type used to declare user ids in the kernel. * It can be int, ushort, uid_t, etc... It may be necessary to include * <sys/types.h> to get any typedef'ed information. */ -#define Uid_t $uidtype /* UID type */ +#define Uid_t uid_t /* UID type */ /* USE_64_BIT_INT: * This symbol, if defined, indicates that 64-bit integers should @@ -3005,11 +3040,11 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * you may need at least to reboot your OS to 64-bit mode. */ #ifndef USE_64_BIT_INT -#$use64bitint USE_64_BIT_INT /**/ +/*#define USE_64_BIT_INT /**/ #endif #ifndef USE_64_BIT_ALL -#$use64bitall USE_64_BIT_ALL /**/ +/*#define USE_64_BIT_ALL /**/ #endif /* USE_LARGE_FILES: @@ -3017,7 +3052,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * should be used when available. */ #ifndef USE_LARGE_FILES -#$uselargefiles USE_LARGE_FILES /**/ +/*#define USE_LARGE_FILES /**/ #endif /* USE_LONG_DOUBLE: @@ -3025,7 +3060,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * be used when available. */ #ifndef USE_LONG_DOUBLE -#$uselongdouble USE_LONG_DOUBLE /**/ +#define USE_LONG_DOUBLE /**/ #endif /* USE_MORE_BITS: @@ -3033,7 +3068,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * long doubles should be used when available. */ #ifndef USE_MORE_BITS -#$usemorebits USE_MORE_BITS /**/ +/*#define USE_MORE_BITS /**/ #endif /* MULTIPLICITY: @@ -3041,7 +3076,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * be built to use multiplicity. */ #ifndef MULTIPLICITY -#$usemultiplicity MULTIPLICITY /**/ +/*#define MULTIPLICITY /**/ #endif /* USE_PERLIO: @@ -3050,7 +3085,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * used in a fully backward compatible manner. */ #ifndef USE_PERLIO -#$useperlio USE_PERLIO /**/ +/*#define USE_PERLIO /**/ #endif /* USE_SOCKS: @@ -3058,7 +3093,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * be built to use socks. */ #ifndef USE_SOCKS -#$usesocks USE_SOCKS /**/ +/*#define USE_SOCKS /**/ #endif /* USE_ITHREADS: @@ -3073,12 +3108,12 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ -#$use5005threads USE_5005THREADS /**/ -#$useithreads USE_ITHREADS /**/ +/*#define USE_5005THREADS /**/ +/*#define USE_ITHREADS /**/ #if defined(USE_5005THREADS) && !defined(USE_ITHREADS) #define USE_THREADS /* until src is revised*/ #endif -#$d_oldpthreads OLD_PTHREADS_API /**/ +/*#define OLD_PTHREADS_API /**/ /* PERL_VENDORARCH: * If defined, this symbol contains the name of a private library. @@ -3095,8 +3130,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#$d_vendorarch PERL_VENDORARCH "$vendorarch" /**/ -#$d_vendorarch PERL_VENDORARCH_EXP "$vendorarchexp" /**/ +#define PERL_VENDORARCH "" /**/ +#define PERL_VENDORARCH_EXP "" /**/ /* PERL_VENDORLIB_EXP: * This symbol contains the ~name expanded version of VENDORLIB, to be used @@ -3107,8 +3142,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * 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. */ -#$d_vendorlib PERL_VENDORLIB_EXP "$vendorlibexp" /**/ -#$d_vendorlib PERL_VENDORLIB_STEM "$vendorlib_stem" /**/ +#define PERL_VENDORLIB_EXP "" /**/ +#define PERL_VENDORLIB_STEM "" /**/ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this @@ -3127,9 +3162,9 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * level of void support necessary is not present, defines void to int. */ #ifndef VOIDUSED -#define VOIDUSED $defvoidused +#define VOIDUSED 15 #endif -#define VOIDFLAGS $voidflags +#define VOIDFLAGS 15 #if (VOIDFLAGS & VOIDUSED) != VOIDUSED #define void int /* is void to be avoided? */ #define M_VOID /* Xenix strikes again */ @@ -3138,7 +3173,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un /* 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 $sitearch for older + * lib/lib.pm will automatically search in 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. @@ -3157,7 +3192,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * 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 $sitelib for older directories across major versions + * search in /system/ported/perl/lib/site/5.7 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 @@ -3167,8 +3202,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * (presumably) be similar. * See the INSTALL file for how this works. */ -#define PERL_XS_APIVERSION "$xs_apiversion" -#define PERL_PM_APIVERSION "$pm_apiversion" +#define PERL_XS_APIVERSION "5.00563" +#define PERL_PM_APIVERSION "5.005" /* HAS_GETPGRP: * This symbol, if defined, indicates that the getpgrp routine is @@ -3178,8 +3213,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol, if defined, indicates that getpgrp needs one * arguments whereas USG one needs none. */ -#$d_getpgrp HAS_GETPGRP /**/ -#$d_bsdgetpgrp USE_BSD_GETPGRP /**/ +#define HAS_GETPGRP /**/ +/*#define USE_BSD_GETPGRP /**/ /* HAS_SETPGRP: * This symbol, if defined, indicates that the setpgrp routine is @@ -3190,8 +3225,18 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * arguments whereas USG one needs none. See also HAS_SETPGID * for a POSIX interface. */ -#$d_setpgrp HAS_SETPGRP /**/ -#$d_bsdsetpgrp USE_BSD_SETPGRP /**/ +/*#define HAS_SETPGRP /**/ +/*#define USE_BSD_SETPGRP /**/ + +/* NEED_VA_COPY: + * This symbol, if defined, indicates that the system stores + * the variable argument list datatype, va_list, in a format + * that cannot be copied by simple assignment, so that some + * other means must be used when copying is required. + * As such systems vary in their provision (or non-provision) + * of copying mechanisms, handy.h defines a platform- + * independent macro, Perl_va_copy(src, dst), to do the job. + */ +/*#define NEED_VA_COPY / **/ #endif -!GROK!THIS! diff --git a/vos/config.pl b/vos/config.pl index c6014ade9a..c865ba158b 100644 --- a/vos/config.pl +++ b/vos/config.pl @@ -3,6 +3,7 @@ # # Written January 24, 2000 by Jarkko Hietaniemi [jhi@iki.fi] # Modified February 2, 2000 by Paul Green [Paul_Green@stratus.com] +# Modified October 23, 2000 by Paul Green [Paul_Green@stratus.com] # # Read in the definitions file @@ -13,6 +14,7 @@ if (open(CONFIG_DEF, "config.def")) { if (/^([^=]+)='(.*)'$/) { my ($var, $val) = ($1, $2); $define{$var} = $val; + $used{$var} = 0; } else { warn "config.def: $.: illegal line: $_"; } @@ -27,8 +29,9 @@ close (CONFIG_DEF); # Open the template input file. # -unless (open(CONFIG_SH, "config_h.SH_orig")) { - die "$0: Cannot open config_h.SH_orig: $!"; +$lineno = 0; +unless (open(CONFIG_SH, "../config_h.SH")) { + die "$0: Cannot open ../config_h.SH: $!"; } # @@ -44,6 +47,7 @@ unless (open(CONFIG_H, ">config.h.new")) { # while (<CONFIG_SH>) { + $lineno = $lineno + 1; last if /^sed <<!GROK!THIS!/; } @@ -53,20 +57,34 @@ while (<CONFIG_SH>) { # while (<CONFIG_SH>) { + $lineno = $lineno + 1; last if /^!GROK!THIS!/; # +# The definition of SITEARCH and SITEARCH_EXP has to be commented-out. +# The easiest way to do this is to special-case it here. +# + if (/^#define SITEARCH*/) { + s@(^.*$)@/*$1@; + } +# # The case of #$d_foo at the BOL has to be handled carefully. # If $d_foo is "undef", then we must first comment out the entire line. # - if (/^#\$\w+/) { - s@^#(\$\w+)@("$define{$1}" eq "undef")?"/*#define":"#$define{$1}"@e; + if (/^#(\$\w+)/) { + if (exists $define{$1}) { + $used{$1}=1; + s@^#(\$\w+)@("$define{$1}" eq "undef") ? + "/*#define":"#$define{$1}"@e; + } } # # There could be multiple $variables on this line. # Find and replace all of them. # if (/(\$\w+)/) { - s/(\$\w+)/(exists $define{$1}) ? $define{$1} : $1/ge; + s/(\$\w+)/(exists $define{$1}) ? + (($used{$1}=1),$define{$1}) : + ((print "Undefined keyword $1 on line $lineno\n"),$1)/ge; print CONFIG_H; } # @@ -82,3 +100,10 @@ unless (close (CONFIG_H)) { } close (CONFIG_SH); + +while (($key,$value) = each %used) { + if ($value == 0) { + print "Unused keyword definition: $key\n"; + } +} + diff --git a/vos/configure_perl.cm b/vos/configure_perl.cm new file mode 100644 index 0000000000..49611f9a66 --- /dev/null +++ b/vos/configure_perl.cm @@ -0,0 +1,24 @@ +& This command macro configures perl to build with +& either the alpha or generally-available version of +& VOS POSIX.1 support. +& Written 00-10-24 by Paul Green (Paul_Green@stratus.com) +& +&begin_parameters + version option(-version)name,allow(alpha,ga),=ga +&end_parameters +&echo command_lines +& +&if (file_info config.&version&.def date_modified) > (file_info config.&version&.h date_modified) +&then &do +!copy_file config.&version&.def config.def -delete +& +& NOTE: We must invoke Perl 5 not Perl 4. If necessary, edit the +& next line to say "perl5 config.pl". +& +!perl config.pl +!rename config.h.new config.&version&.h -delete +!delete_file config.def +&end +& +&if (file_info config.&version&.h date_modified) ^= (file_info config.h date_modified) +&then !copy_file config.&version&.h config.h -delete -keep_dates diff --git a/vos/install_perl.cm b/vos/install_perl.cm new file mode 100644 index 0000000000..95fe064ea6 --- /dev/null +++ b/vos/install_perl.cm @@ -0,0 +1,69 @@ +& Macro to install the perl components into the right directories +& Written 00-10-24 by Paul Green (Paul_Green@stratus.com) +& +&begin_parameters + cpu option(-processor)name,allow(mc68020,i80860,pa7100,pa8000),=mc68020 +&end_parameters priv +&echo command_lines +& +&if &cpu& = mc68020 +&then &set_string obj '' +&if &cpu& = i80860 +&then &set_string obj .860 +&if &cpu& = pa7100 +&then &set_string obj .7100 +&if &cpu& = pa8000 +&then &set_string obj .8000 +& +&set_string MDS (master_disk)>system +& +&if ^ (exists -directory &MDS&>ported) +&then !create_dir &MDS&>ported +& +&if ^ (exists -directory &MDS&>ported>command_library) +&then !create_dir &MDS&>ported>command_library +& +&if ^ (exists -directory &MDS&>ported>perl) +&then !create_dir &MDS&>ported>perl +& +&if ^ (exists -directory &MDS&>ported>perl>lib) +&then !create_dir &MDS&>ported>perl>lib +& +&if ^ (exists -directory &MDS&>ported>perl>lib>5.7) +&then !create_dir &MDS&>ported>perl>lib>5.7 +& +&if ^ (exists -directory &MDS&>ported>perl>lib>5.7.68k) +&then !create_dir &MDS&>ported>perl>lib>5.7.68k +& +&if ^ (exists -directory &MDS&>ported>perl>lib>5.7.860) +&then !create_dir &MDS&>ported>perl>lib>5.7.860 +& +&if ^ (exists -directory &MDS&>ported>perl>lib>5.7.7100) +&then !create_dir &MDS&>ported>perl>lib>5.7.7100 +& +&if ^ (exists -directory &MDS&>ported>perl>lib>5.7.8000) +&then !create_dir &MDS&>ported>perl>lib>5.7.8000 +& +&if ^ (exists -directory &MDS&>ported>perl>lib>site) +&then !create_dir &MDS&>ported>perl>lib>site +& +&if ^ (exists -directory &MDS&>ported>perl>lib>site>5.7) +&then !create_dir &MDS&>ported>perl>lib>site>5.7 +& +&if ^ (exists -directory &MDS&>ported>perl>lib>site>5.7.68k) +&then !create_dir &MDS&>ported>perl>lib>site>5.7.68k +& +&if ^ (exists -directory &MDS&>ported>perl>lib>site>5.7.860) +&then !create_dir &MDS&>ported>perl>lib>site>5.7.860 +& +&if ^ (exists -directory &MDS&>ported>perl>lib>site>5.7.7100) +&then !create_dir &MDS&>ported>perl>lib>site>5.7.7100 +& +&if ^ (exists -directory &MDS&>ported>perl>lib>site>5.7.8000) +&then !create_dir &MDS&>ported>perl>lib>site>5.7.8000 +& +!copy_dir <lib &MDS&>ported>perl>lib>5.7 -delete +& +!copy_file obj&obj&>perl.pm &MDS&>ported>command_library>perl.pm.new -delete +!rename &MDS&>ported>command_library>perl.pm *.(date).(time) -delete +!rename &MDS&>ported>command_library>perl.pm.new perl.pm -delete diff --git a/vos/perl.bind b/vos/perl.bind index 714ce3d680..1e77e5a6de 100644 --- a/vos/perl.bind +++ b/vos/perl.bind @@ -31,9 +31,6 @@ modules: miniperlmain, universal, utf8, util, - xsutils, - vos_dummies, - tcp_runtime, - tcp_gethost; + xsutils; end; diff --git a/vos/vosish.h b/vos/vosish.h index 5a6b0796f8..d600065698 100644 --- a/vos/vosish.h +++ b/vos/vosish.h @@ -1,140 +1 @@ -/* - * The following symbols are defined if your operating system supports - * functions by that name. All Unixes I know of support them, thus they - * are not checked by the configuration script, but are directly defined - * here. - */ - -/* HAS_IOCTL: - * This symbol, if defined, indicates that the ioctl() routine is - * available to set I/O characteristics - */ -#define HAS_IOCTL / **/ - -/* HAS_UTIME: - * This symbol, if defined, indicates that the routine utime() is - * available to update the access and modification times of files. - */ -#define HAS_UTIME / **/ - -/* HAS_GROUP - * This symbol, if defined, indicates that the getgrnam() and - * getgrgid() routines are available to get group entries. - * The getgrent() has a separate definition, HAS_GETGRENT. - */ -/*#define HAS_GROUP / **/ - -/* HAS_PASSWD - * This symbol, if defined, indicates that the getpwnam() and - * getpwuid() routines are available to get password entries. - * The getpwent() has a separate definition, HAS_GETPWENT. - */ -/*#define HAS_PASSWD / **/ - -#define HAS_KILL -#define HAS_WAIT - -/* USEMYBINMODE - * This symbol, if defined, indicates that the program should - * use the routine my_binmode(FILE *fp, char iotype, int mode) to insure - * that a file is in "binary" mode -- that is, that no translation - * of bytes occurs on read or write operations. - */ -#undef USEMYBINMODE - -/* Stat_t: - * This symbol holds the type used to declare buffers for information - * returned by stat(). It's usually just struct stat. It may be necessary - * to include <sys/stat.h> and <sys/types.h> to get any typedef'ed - * information. - */ -#define Stat_t struct stat - -/* USE_STAT_RDEV: - * This symbol is defined if this system has a stat structure declaring - * st_rdev - */ -/*#define USE_STAT_RDEV / **/ - -/* ACME_MESS: - * This symbol, if defined, indicates that error messages should be - * should be generated in a format that allows the use of the Acme - * GUI/editor's autofind feature. - */ -#undef ACME_MESS /**/ - -/* UNLINK_ALL_VERSIONS: - * This symbol, if defined, indicates that the program should arrange - * to remove all versions of a file if unlink() is called. This is - * probably only relevant for VMS. - */ -/* #define UNLINK_ALL_VERSIONS / **/ - -/* VMS: - * This symbol, if defined, indicates that the program is running under - * VMS. It is currently automatically set by cpps running under VMS, - * and is included here for completeness only. - */ -/* #define VMS / **/ - -/* ALTERNATE_SHEBANG: - * This symbol, if defined, contains a "magic" string which may be used - * as the first line of a Perl program designed to be executed directly - * by name, instead of the standard Unix #!. If ALTERNATE_SHEBANG - * begins with a character other then #, then Perl will only treat - * it as a command line if if finds the string "perl" in the first - * word; otherwise it's treated as the first line of code in the script. - * (IOW, Perl won't hand off to another interpreter via an alternate - * shebang sequence that might be legal Perl code.) - */ -/* #define ALTERNATE_SHEBANG "#!" / **/ - -#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) || defined(__NetBSD__) -# include <signal.h> -#endif - -#ifndef SIGABRT -# define SIGABRT SIGILL -#endif -#ifndef SIGILL -# define SIGILL 6 /* blech */ -#endif -#define ABORT() kill(PerlProc_getpid(),SIGABRT); - -/* - * fwrite1() should be a routine with the same calling sequence as fwrite(), - * but which outputs all of the bytes requested as a single stream (unlike - * fwrite() itself, which on some systems outputs several distinct records - * if the number_of_items parameter is >1). - */ -#define fwrite1 fwrite - -#define Stat(fname,bufptr) stat((fname),(bufptr)) -#define Fstat(fd,bufptr) fstat((fd),(bufptr)) -#define Fflush(fp) fflush(fp) -#define Mkdir(path,mode) mkdir((path),(mode)) - -/* these should be set in a hint file, not here */ -#ifndef PERL_SYS_INIT -#ifdef PERL_SCO5 -# define PERL_SYS_INIT(c,v) fpsetmask(0); MALLOC_INIT -#else -# 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 -# endif -#endif -#endif - -#ifndef PERL_SYS_TERM -#define PERL_SYS_TERM() MALLOC_TERM -#endif - -#define BIT_BUCKET "/dev/null" - -#define dXSUB_SYS +#include "unixish.h" diff --git a/warnings.pl b/warnings.pl index 0c2d2ec458..3a5037d40d 100644 --- a/warnings.pl +++ b/warnings.pl @@ -1,5 +1,8 @@ #!/usr/bin/perl + +$VERSION = '1.00'; + BEGIN { push @INC, './lib'; } @@ -104,7 +107,7 @@ sub mkRange for ($i = 1 ; $i < @a; ++ $i) { - $out[$i] = ".." + $out[$i] = ".." if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ; } @@ -130,9 +133,9 @@ sub printTree print $prefix . "|\n" ; print $prefix . "+- $k" ; if (ref $v) - { + { print " " . "-" x ($max - length $k ) . "+\n" ; - printTree ($v, $prefix . "|" , $max + $indent - 1) + printTree ($v, $prefix . "|" , $max + $indent - 1) } else { print "\n" } @@ -289,9 +292,9 @@ foreach $k (sort keys %list) { my $v = $list{$k} ; my @list = sort { $a <=> $b } @$v ; - print PM tab(4, " '$k'"), '=> "', - # mkHex($warn_size, @list), - mkHex($warn_size, map $_ * 2 , @list), + print PM tab(4, " '$k'"), '=> "', + # mkHex($warn_size, @list), + mkHex($warn_size, map $_ * 2 , @list), '", # [', mkRange(@list), "]\n" ; } @@ -303,9 +306,9 @@ foreach $k (sort keys %list) { my $v = $list{$k} ; my @list = sort { $a <=> $b } @$v ; - print PM tab(4, " '$k'"), '=> "', - # mkHex($warn_size, @list), - mkHex($warn_size, map $_ * 2 + 1 , @list), + print PM tab(4, " '$k'"), '=> "', + # mkHex($warn_size, @list), + mkHex($warn_size, map $_ * 2 + 1 , @list), '", # [', mkRange(@list), "]\n" ; } @@ -327,6 +330,8 @@ __END__ package warnings; +our $VERSION = '1.00'; + =head1 NAME warnings - Perl pragma to control optional warnings @@ -361,7 +366,7 @@ warnings - Perl pragma to control optional warnings If no import list is supplied, all possible warnings are either enabled or disabled. -A number of functions are provided to assist module authors. +A number of functions are provided to assist module authors. =over 4 @@ -465,7 +470,7 @@ sub bits { $mask |= $DeadBits{$word} if $fatal ; } else - { croak("unknown warnings category '$word'")} + { croak("unknown warnings category '$word'")} } return $mask ; @@ -511,13 +516,13 @@ sub __chk unless defined $offset; } else { - $category = (caller(1))[0] ; + $category = (caller(1))[0] ; $offset = $Offsets{$category}; croak("package '$category' not registered for warnings") unless defined $offset ; } - my $this_pkg = (caller(1))[0] ; + my $this_pkg = (caller(1))[0] ; my $i = 2 ; my $pkg ; @@ -531,11 +536,11 @@ sub __chk for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) { last if $pkg ne $this_pkg ; } - $i = 2 + $i = 2 if !$pkg || $pkg eq $this_pkg ; } - my $callers_bitmask = (caller($i))[9] ; + my $callers_bitmask = (caller($i))[9] ; return ($callers_bitmask, $offset, $i) ; } @@ -560,7 +565,7 @@ sub warn my $message = pop ; my ($callers_bitmask, $offset, $i) = __chk(@_) ; local $Carp::CarpLevel = $i ; - croak($message) + croak($message) if vec($callers_bitmask, $offset+1, 1) || vec($callers_bitmask, $Offsets{'all'}+1, 1) ; carp($message) ; @@ -575,12 +580,12 @@ sub warnif my ($callers_bitmask, $offset, $i) = __chk(@_) ; local $Carp::CarpLevel = $i ; - return + return unless defined $callers_bitmask && (vec($callers_bitmask, $offset, 1) || vec($callers_bitmask, $Offsets{'all'}, 1)) ; - croak($message) + croak($message) if vec($callers_bitmask, $offset+1, 1) || vec($callers_bitmask, $Offsets{'all'}+1, 1) ; diff --git a/win32/Makefile b/win32/Makefile index af119909e8..fe1b1b1690 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -1,8 +1,10 @@ # # Makefile to build perl on Windows NT using Microsoft NMAKE. +# Supported compilers: +# Visual C++ 5.x (possibly other versions) # # This is set up to build a perl.exe that runs off a shared library -# (perl56.dll). Also makes individual DLLs for the XS extensions. +# (perl57.dll). Also makes individual DLLs for the XS extensions. # ## @@ -29,7 +31,7 @@ INST_TOP = $(INST_DRV)\perl # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # -INST_VER = \5.6.0 +INST_VER = \5.7.0 # # Comment this out if you DON'T want your perl installation to have @@ -63,6 +65,12 @@ INST_ARCH = \$(ARCHNAME) #USE_IMP_SYS = define # +# uncomment to enable the experimental PerlIO I/O subsystem. +# This is currently incompatible with USE_MULTI, USE_ITHREADS, +# and USE_IMP_SYS +#USE_PERLIO = define + +# # WARNING! This option is deprecated and will eventually go away (enable # USE_ITHREADS instead). # @@ -70,7 +78,7 @@ INST_ARCH = \$(ARCHNAME) # USE_ITHREADS, and is only here for people who may have come to rely # on the experimental Thread support that was in 5.005. # -#USE_5005THREADS= define +#USE_5005THREADS = define # # WARNING! This option is deprecated and will eventually go away (enable @@ -273,10 +281,18 @@ ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-thread !IF "$(USE_MULTI)" == "define" ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-multi !ELSE +!IF "$(USE_PERLIO)" == "define" +ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-perlio +!ELSE ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE) !ENDIF !ENDIF !ENDIF +!ENDIF + +!IF "$(USE_PERLIO)" == "define" +BUILDOPT = $(BUILDOPT) -DUSE_PERLIO +!ENDIF !IF "$(USE_ITHREADS)" == "define" ARCHNAME = $(ARCHNAME)-thread @@ -287,7 +303,7 @@ ARCHNAME = $(ARCHNAME)-thread # VC 6.0 can load the socket dll on demand. Makes the test suite # run in about 10% less time. -DELAYLOAD = -DELAYLOAD:wsock32.dll -DELAYLOAD:shell32.dll delayimp.lib +DELAYLOAD = -DELAYLOAD:wsock32.dll -DELAYLOAD:shell32.dll delayimp.lib # VC 6.0 seems capable of compiling perl correctly with optimizations # enabled. Anything earlier fails tests. @@ -327,7 +343,7 @@ RSC = rc # INCLUDES = -I$(COREDIR) -I.\include -I. -I.. -#PCHFLAGS = -Fpc:\temp\vcmoduls.pch -YX +#PCHFLAGS = -Fpc:\temp\vcmoduls.pch -YX DEFINES = -DWIN32 -D_CONSOLE -DNO_STRICT $(CRYPT_FLAG) LOCDEFS = -DPERLDLL -DPERL_CORE SUBSYS = console @@ -395,7 +411,7 @@ o = .obj # # Rules -# +# .SUFFIXES : .c $(o) .dll .lib .exe .rc .res @@ -407,15 +423,19 @@ o = .obj $(o).dll: $(LINK32) -dll -subsystem:windows -implib:$(*B).lib -def:$(*B).def \ - -out:$@ $(LINK_FLAGS) $(LIBFILES) $< $(LIBPERL) + -out:$@ $(LINK_FLAGS) $(LIBFILES) $< $(LIBPERL) .rc.res: $(RSC) -i.. $< # # various targets -PERLIMPLIB = ..\perl56.lib -PERLDLL = ..\perl56.dll + +# makedef.pl must be updated if this changes, and this should normally +# only change when there is an incompatible revision of the public API. +# XXX so why did we change it from perl56 to perl57? +PERLIMPLIB = ..\perl57.lib +PERLDLL = ..\perl57.dll MINIPERL = ..\miniperl.exe MINIDIR = .\mini @@ -465,6 +485,8 @@ RCOPY = xcopy /f /r /i /e /d NOOP = @echo NULL = +DEL = bin\mdelete.bat + # # filenames given to xsubpp must have forward slashes (since it puts # full pathnames in #line strings) @@ -514,7 +536,7 @@ EXTRACORE_SRC = $(EXTRACORE_SRC) ..\perlio.c WIN32_SRC = \ .\win32.c \ .\win32sck.c \ - .\win32thread.c + .\win32thread.c !IF "$(CRYPT_SRC)" != "" WIN32_SRC = $(WIN32_SRC) .\$(CRYPT_SRC) @@ -594,7 +616,7 @@ SETARGV_OBJ = setargv$(o) DYNAMIC_EXT = Socket IO Fcntl Opcode SDBM_File POSIX attrs Thread B re \ Data/Dumper Devel/Peek ByteLoader Devel/DProf File/Glob \ - Sys/Hostname Storable + Sys/Hostname Storable Filter/Util/Call Encode STATIC_EXT = DynaLoader NONXS_EXT = Errno @@ -617,6 +639,8 @@ DPROF = $(EXTDIR)\Devel\DProf\DProf GLOB = $(EXTDIR)\File\Glob\Glob HOSTNAME = $(EXTDIR)\Sys\Hostname\Hostname STORABLE = $(EXTDIR)\Storable\Storable +FILTER = $(EXTDIR)\Filter\Util\Call\Call +ENCODE = $(EXTDIR)\Encode\Encode SOCKET_DLL = $(AUTODIR)\Socket\Socket.dll FCNTL_DLL = $(AUTODIR)\Fcntl\Fcntl.dll @@ -635,6 +659,8 @@ DPROF_DLL = $(AUTODIR)\Devel\DProf\DProf.dll GLOB_DLL = $(AUTODIR)\File\Glob\Glob.dll HOSTNAME_DLL = $(AUTODIR)\Sys\Hostname\Hostname.dll STORABLE_DLL = $(AUTODIR)\Storable\Storable.dll +FILTER_DLL = $(AUTODIR)\Filter\Util\Call\Call.dll +ENCODE_DLL = $(AUTODIR)\Encode\Encode.dll ERRNO_PM = $(LIBDIR)\Errno.pm @@ -655,7 +681,9 @@ EXTENSION_C = \ $(DPROF).c \ $(GLOB).c \ $(HOSTNAME).c \ - $(STORABLE).c + $(STORABLE).c \ + $(FILTER).c \ + $(ENCODE).c EXTENSION_DLL = \ $(SOCKET_DLL) \ @@ -674,7 +702,9 @@ EXTENSION_DLL = \ $(DPROF_DLL) \ $(GLOB_DLL) \ $(HOSTNAME_DLL) \ - $(STORABLE_DLL) + $(STORABLE_DLL) \ + $(FILTER_DLL) \ + $(ENCODE_DLL) EXTENSION_PM = \ $(ERRNO_PM) @@ -691,8 +721,9 @@ CFG_VARS = \ "INST_ARCH=$(INST_ARCH)" \ "archname=$(ARCHNAME)" \ "cc=$(CC)" \ - "ccflags=$(OPTIMIZE:"=\") $(DEFINES) $(BUILDOPT)" \ - "cf_email=$(EMAIL)" \ + "ld=$(LINK32)" \ + "ccflags=-nologo -Gf -W3 $(OPTIMIZE:"=\") $(DEFINES) $(BUILDOPT)" \ + "cf_email=$(EMAIL)" \ "d_crypt=$(D_CRYPT)" \ "d_mymalloc=$(PERL_MALLOC)" \ "libs=$(LIBFILES)" \ @@ -724,7 +755,7 @@ $(DYNALOADER)$(o) : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c $(GLOBEXE) : perlglob$(o) $(LINK32) $(LINK_FLAGS) $(LIBFILES) -out:$@ -subsystem:$(SUBSYS) \ - perlglob$(o) setargv$(o) + perlglob$(o) setargv$(o) perlglob$(o) : perlglob.c @@ -740,7 +771,7 @@ config.w32 : $(CFGSH_TMPL) # this target is for when changes to the main config.sh happen # edit config.{b,v,g}c and make this target once for each supported -# compiler (e.g. `dmake CCTYPE=BORLAND regen_config_h`) +# compiler (e.g. `nmake CCTYPE=BORLAND regen_config_h`) regen_config_h: perl config_sh.PL $(CFG_VARS) $(CFGSH_TMPL) > ..\config.sh cd .. @@ -753,14 +784,16 @@ regen_config_h: rename config.h $(CFGH_TMPL) $(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl - cd .. && miniperl configpm + cd .. + miniperl configpm + cd win32 if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL) $(XCOPY) ..\*.h $(COREDIR)\*.* $(XCOPY) *.h $(COREDIR)\*.* $(XCOPY) ..\ext\re\re.pm $(LIBDIR)\*.* $(RCOPY) include $(COREDIR)\*.* - $(MINIPERL) -I..\lib config_h.PL "INST_VER=$(INST_VER)" \ - || $(MAKE) /$(MAKEFLAGS) $(CONFIGPM) + -$(MINIPERL) -I..\lib config_h.PL "INST_VER=$(INST_VER)" + if errorlevel 1 $(MAKE) /$(MAKEFLAGS) $(CONFIGPM) $(MINIPERL) : $(MINIDIR) $(MINI_OBJ) $(LINK32) -subsystem:console -out:$@ @<< @@ -803,7 +836,9 @@ $(PERLDLL): perldll.def $(PERLDLL_OBJ) $(PERLDLL_RES) $(XCOPY) $(PERLIMPLIB) $(COREDIR) $(MINIMOD) : $(MINIPERL) ..\minimod.pl - cd .. && miniperl minimod.pl > lib\ExtUtils\Miniperl.pm + cd .. + miniperl minimod.pl > lib\ExtUtils\Miniperl.pm + cd win32 ..\x2p\a2p$(o) : ..\x2p\a2p.c $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\a2p.c @@ -827,7 +862,7 @@ $(X2P) : $(MINIPERL) $(X2P_OBJ) $(LINK_FLAGS) $(LIBFILES) $(X2P_OBJ) << -perlmain.c : runperl.c +perlmain.c : runperl.c copy runperl.c perlmain.c perlmain$(o) : perlmain.c @@ -838,7 +873,7 @@ $(PERLEXE): $(PERLDLL) $(CONFIGPM) $(PERLEXE_OBJ) $(PERLEXE_RES) $(LIBFILES) $(PERLEXE_OBJ) $(SETARGV_OBJ) $(PERLIMPLIB) $(PERLEXE_RES) copy $(PERLEXE) $(WPERLEXE) $(MINIPERL) -I..\lib bin\exetype.pl $(WPERLEXE) WINDOWS - copy splittree.pl .. + copy splittree.pl .. $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR) $(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM) @@ -952,12 +987,30 @@ $(BYTELOADER_DLL): $(PERLEXE) $(BYTELOADER).xs $(MAKE) cd ..\..\win32 +$(ENCODE_DLL): $(PERLEXE) $(ENCODE).xs + cd $(EXTDIR)\$(*B) + ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl + $(MAKE) + cd ..\..\win32 + $(STORABLE_DLL): $(PERLEXE) $(STORABLE).xs cd $(EXTDIR)\$(*B) ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl $(MAKE) cd ..\..\win32 +$(FILTER_DLL): $(PERLEXE) $(FILTER).xs + cd $(EXTDIR)\Filter\Util\Call + ..\..\..\..\miniperl -I..\..\..\..\lib Makefile.PL INSTALLDIRS=perl + $(MAKE) + cd ..\..\..\..\win32 + +$(ENCODE_DLL): $(PERLEXE) $(ENCODE).xs + cd $(EXTDIR)\$(*B) + ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl + $(MAKE) + cd ..\..\win32 + $(ERRNO_PM): $(PERLEXE) $(ERRNO)_pm.PL cd $(EXTDIR)\$(*B) ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl @@ -1004,10 +1057,17 @@ distclean: clean -del /f $(LIBDIR)\Devel\Peek.pm $(LIBDIR)\Devel\DProf.pm -del /f $(LIBDIR)\File\Glob.pm -del /f $(LIBDIR)\Storable.pm - -if exist $(LIBDIR)\IO rmdir /s /q $(LIBDIR)\IO || rmdir /s $(LIBDIR)\IO - -if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread || rmdir /s $(LIBDIR)\Thread - -if exist $(LIBDIR)\B rmdir /s /q $(LIBDIR)\B || rmdir /s $(LIBDIR)\B - -if exist $(LIBDIR)\Data rmdir /s /q $(LIBDIR)\Data || rmdir /s $(LIBDIR)\Data + -del /f $(LIBDIR)\Filter\Util\Call\Call.pm + -if exist $(LIBDIR)\IO rmdir /s /q $(LIBDIR)\IO + -rmdir /s $(LIBDIR)\IO + -if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread + -rmdir /s $(LIBDIR)\Thread + -if exist $(LIBDIR)\B rmdir /s /q $(LIBDIR)\B + -rmdir /s $(LIBDIR)\B + -if exist $(LIBDIR)\Data rmdir /s /q $(LIBDIR)\Data + -rmdir /s $(LIBDIR)\Data + -if exist $(LIBDIR)\Filter\Util\Call rmdir /s /q $(LIBDIR)\Filter\Util\Call + -if exist $(LIBDIR)\Filter\Util rmdir /s /q $(LIBDIR)\Filter\Util -del /f $(PODDIR)\*.html -del /f $(PODDIR)\*.bat cd ..\utils @@ -1024,8 +1084,10 @@ distclean: clean cd $(EXTDIR) -del /s *.lib *.def *.map *.pdb *.bs Makefile *$(o) pm_to_blib cd ..\win32 - -if exist $(AUTODIR) rmdir /s /q $(AUTODIR) || rmdir /s $(AUTODIR) - -if exist $(COREDIR) rmdir /s /q $(COREDIR) || rmdir /s $(COREDIR) + -if exist $(AUTODIR) rmdir /s /q $(AUTODIR) + -rmdir /s $(AUTODIR) + -if exist $(COREDIR) rmdir /s /q $(COREDIR) + -rmdir /s $(COREDIR) install : all installbare installhtml @@ -1039,7 +1101,7 @@ installhtml : doc $(RCOPY) html\*.* $(INST_HTML)\*.* inst_lib : $(CONFIGPM) - copy splittree.pl .. + copy splittree.pl .. $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR) $(RCOPY) ..\lib $(INST_LIB)\*.* @@ -1081,28 +1143,29 @@ test-wide-notty : test-prep $(PERLEXE) -I..\lib harness cd ..\win32 -clean : - -@erase miniperlmain$(o) - -@erase $(MINIPERL) - -@erase perlglob$(o) - -@erase perlmain$(o) - -@erase config.w32 - -@erase /f config.h - -@erase $(GLOBEXE) - -@erase $(PERLEXE) - -@erase $(WPERLEXE) - -@erase $(PERLDLL) - -@erase $(CORE_OBJ) - -if exist $(MINIDIR) rmdir /s /q $(MINIDIR) || rmdir /s $(MINIDIR) - -@erase $(WIN32_OBJ) - -@erase $(DLL_OBJ) - -@erase $(X2P_OBJ) - -@erase ..\*$(o) ..\*.lib ..\*.exp *$(o) *.lib *.exp *.res - -@erase ..\t\*.exe ..\t\*.dll ..\t\*.bat - -@erase ..\x2p\*.exe ..\x2p\*.bat - -@erase *.ilk - -@erase *.pdb - +clean : + -@$(DEL) miniperlmain$(o) + -@$(DEL) $(MINIPERL) + -@$(DEL) perlglob$(o) + -@$(DEL) perlmain$(o) + -@$(DEL) config.w32 + -@$(DEL) /f config.h + -@$(DEL) $(GLOBEXE) + -@$(DEL) $(PERLEXE) + -@$(DEL) $(WPERLEXE) + -@$(DEL) $(PERLDLL) + -@$(DEL) $(CORE_OBJ) + -if exist $(MINIDIR) rmdir /s /q $(MINIDIR) + -rmdir /s $(MINIDIR) + -@$(DEL) $(WIN32_OBJ) + -@$(DEL) $(DLL_OBJ) + -@$(DEL) $(X2P_OBJ) + -@$(DEL) ..\*$(o) ..\*.lib ..\*.exp *$(o) *.lib *.exp *.res + -@$(DEL) ..\t\*.exe ..\t\*.dll ..\t\*.bat + -@$(DEL) ..\x2p\*.exe ..\x2p\*.bat + -@$(DEL) *.ilk + -@$(DEL) *.pdb + # 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. # Please *don't* use this unless all tests pass. @@ -1112,9 +1175,9 @@ ok: utils okfile: utils $(PERLEXE) -I..\lib ..\utils\perlbug -ok -s "(UNINSTALLED)" -F perl.ok - + nok: utils $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)" - + nokfile: utils $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)" -F perl.nok diff --git a/win32/bin/mdelete.bat b/win32/bin/mdelete.bat new file mode 100644 index 0000000000..0e7e8bda0a --- /dev/null +++ b/win32/bin/mdelete.bat @@ -0,0 +1,30 @@ +@echo off +rem ! This is a batch file to delete all the files on its +rem ! command line, to work around command.com's del command's +rem ! braindeadness +rem ! +rem ! -- BKS, 11-11-2000 + +:nextfile +set file=%1 +shift +if "%file%"=="" goto end +del %file% +goto nextfile +:end + +@echo off
+rem ! This is a batch file to delete all the files on its
+rem ! command line, to work around command.com's del command's
+rem ! braindeadness
+rem !
+rem ! -- BKS, 11-11-2000
+
+:nextfile
+set file=%1
+shift
+if "%file%"=="" goto end
+del %file%
+goto nextfile
+:end
+
diff --git a/win32/bin/search.pl b/win32/bin/search.pl index ad74001be5..5c3d65e06e 100644 --- a/win32/bin/search.pl +++ b/win32/bin/search.pl @@ -621,7 +621,7 @@ sub read_rc local($line_num, $ln, $tag) = 0; local($use_default, @default) = 0; - { package magic; $ = 0; } ## turn off warnings for when we run EXPR's + { package magic; $^W= 0; } ## turn off warnings for when we run EXPR's unless (open(RC, "$file")) { $use_default=1; diff --git a/win32/config.bc b/win32/config.bc index 097d4290ab..4e246fa0f6 100644 --- a/win32/config.bc +++ b/win32/config.bc @@ -40,7 +40,7 @@ byteorder='1234' c='' castflags='0' cat='type' -cc='bcc32' +cc='~CC~' cccdlflags=' ' ccdlflags='-tWD' ccflags='-DWIN32' @@ -70,6 +70,7 @@ cppsymbols='' crosscompile='undef' cryptlib='' csh='undef' +d__fwalk='undef' d_Gconvert='gcvt((x),(n),(b))' d_PRIEUldbl='undef' d_PRIFUldbl='undef' @@ -129,6 +130,7 @@ d_eunice='undef' d_fchmod='undef' d_fchown='undef' d_fcntl='undef' +d_fcntl_can_lock='undef' d_fd_macros='define' d_fd_set='define' d_fds_bits='define' @@ -144,6 +146,7 @@ d_fseeko='undef' d_fsetpos='define' d_fstatfs='undef' d_fstatvfs='undef' +d_fsync='undef' d_ftello='undef' d_ftime='define' d_getcwd='undef' @@ -163,6 +166,7 @@ d_getnbyaddr='undef' d_getnbyname='undef' d_getnent='undef' d_getnetprotos='undef' +d_getpagsz='undef' d_getpbyname='define' d_getpbynumber='define' d_getpent='undef' @@ -266,6 +270,7 @@ d_rmdir='define' d_safebcpy='undef' d_safemcpy='undef' d_sanemcmp='define' +d_sbrkproto='undef' d_sched_yield='undef' d_scm_rights='undef' d_seekdir='define' @@ -319,6 +324,8 @@ d_statfs_s='undef' d_statvfs='undef' d_stdio_cnt_lval='define' d_stdio_ptr_lval='define' +d_stdio_ptr_lval_sets_cnt='undef' +d_stdio_ptr_lval_nochange_cnt='undef' d_stdio_stream_array='undef' d_stdiobase='define' d_stdstdio='define' @@ -331,6 +338,7 @@ d_strtod='define' d_strtol='define' d_strtold='undef' d_strtoll='undef' +d_strtoq='undef' d_strtoul='define' d_strtoull='undef' d_strtouq='undef' @@ -522,12 +530,13 @@ installvendorarch='' installvendorbin='' installvendorlib='' intsize='4' +issymlink='' ivdformat='"ld"' ivsize='4' ivtype='long' known_extensions='~static_ext~ ~dynamic_ext~ ~nonxs_ext~' ksh='' -ld='tlink32' +ld='~LINK32~' lddlflags='-Tpd ~LINK_FLAGS~' ldflags='~LINK_FLAGS~' ldlibpthname='' @@ -597,6 +606,7 @@ mydomain='' myhostname='' myuname='' n='-n' +need_va_copy='undef' netdb_hlen_type='int' netdb_host_type='char *' netdb_name_type='char *' diff --git a/win32/config.gc b/win32/config.gc index 9251b24f3d..31c6b432b0 100644 --- a/win32/config.gc +++ b/win32/config.gc @@ -40,7 +40,7 @@ byteorder='1234' c='' castflags='0' cat='type' -cc='gcc' +cc='~CC~' cccdlflags=' ' ccdlflags=' ' ccflags='-MD -DWIN32' @@ -70,6 +70,7 @@ cppsymbols='' crosscompile='undef' cryptlib='' csh='undef' +d__fwalk='undef' d_Gconvert='sprintf((b),"%.*g",(n),(x))' d_PRIEUldbl='undef' d_PRIFUldbl='undef' @@ -129,6 +130,7 @@ d_eunice='undef' d_fchmod='undef' d_fchown='undef' d_fcntl='undef' +d_fcntl_can_lock='undef' d_fd_macros='define' d_fd_set='define' d_fds_bits='define' @@ -144,6 +146,7 @@ d_fseeko='undef' d_fsetpos='define' d_fstatfs='undef' d_fstatvfs='undef' +d_fsync='undef' d_ftello='undef' d_ftime='define' d_getcwd='undef' @@ -163,6 +166,7 @@ d_getnbyaddr='undef' d_getnbyname='undef' d_getnent='undef' d_getnetprotos='undef' +d_getpagsz='undef' d_getpbyname='define' d_getpbynumber='define' d_getpent='undef' @@ -266,6 +270,7 @@ d_rmdir='define' d_safebcpy='undef' d_safemcpy='undef' d_sanemcmp='define' +d_sbrkproto='undef' d_sched_yield='undef' d_scm_rights='undef' d_seekdir='define' @@ -319,6 +324,8 @@ d_statfs_s='undef' d_statvfs='undef' d_stdio_cnt_lval='define' d_stdio_ptr_lval='define' +d_stdio_ptr_lval_sets_cnt='undef' +d_stdio_ptr_lval_nochange_cnt='define' d_stdio_stream_array='undef' d_stdiobase='define' d_stdstdio='define' @@ -331,6 +338,7 @@ d_strtod='define' d_strtol='define' d_strtold='undef' d_strtoll='undef' +d_strtoq='undef' d_strtoul='define' d_strtoull='undef' d_strtouq='undef' @@ -522,6 +530,7 @@ installvendorarch='' installvendorbin='' installvendorlib='' intsize='4' +issymlink='' ivdformat='"ld"' ivsize='4' ivtype='long' @@ -597,6 +606,7 @@ mydomain='' myhostname='' myuname='' n='-n' +need_va_copy='undef' netdb_hlen_type='int' netdb_host_type='char *' netdb_name_type='char *' @@ -759,7 +769,7 @@ usemultiplicity='undef' usemymalloc='n' usenm='false' useopcode='true' -useperlio='undef' +useperlio='define' useposix='true' usesfio='false' useshrplib='yes' diff --git a/win32/config.vc b/win32/config.vc index 61558e5612..c526018307 100644 --- a/win32/config.vc +++ b/win32/config.vc @@ -1,4 +1,4 @@ -## Configured by: ~cf_email~ +# Configured by: ~cf_email~ ## Target system: WIN32 Author='' CONFIGDOTSH='true' @@ -40,7 +40,7 @@ byteorder='1234' c='' castflags='0' cat='type' -cc='cl' +cc='~CC~' cccdlflags=' ' ccdlflags=' ' ccflags='-MD -DWIN32' @@ -70,6 +70,7 @@ cppsymbols='' crosscompile='undef' cryptlib='' csh='undef' +d__fwalk='undef' d_Gconvert='sprintf((b),"%.*g",(n),(x))' d_PRIEUldbl='undef' d_PRIFUldbl='undef' @@ -129,6 +130,7 @@ d_eunice='undef' d_fchmod='undef' d_fchown='undef' d_fcntl='undef' +d_fcntl_can_lock='undef' d_fd_macros='define' d_fd_set='define' d_fds_bits='define' @@ -144,6 +146,7 @@ d_fseeko='undef' d_fsetpos='define' d_fstatfs='undef' d_fstatvfs='undef' +d_fsync='undef' d_ftello='undef' d_ftime='define' d_getcwd='undef' @@ -163,6 +166,7 @@ d_getnbyaddr='undef' d_getnbyname='undef' d_getnent='undef' d_getnetprotos='undef' +d_getpagsz='undef' d_getpbyname='define' d_getpbynumber='define' d_getpent='undef' @@ -266,6 +270,7 @@ d_rmdir='define' d_safebcpy='undef' d_safemcpy='undef' d_sanemcmp='define' +d_sbrkproto='undef' d_sched_yield='undef' d_scm_rights='undef' d_seekdir='define' @@ -319,6 +324,8 @@ d_statfs_s='undef' d_statvfs='undef' d_stdio_cnt_lval='define' d_stdio_ptr_lval='define' +d_stdio_ptr_lval_sets_cnt='undef' +d_stdio_ptr_lval_nochange_cnt='define' d_stdio_stream_array='undef' d_stdiobase='define' d_stdstdio='define' @@ -331,6 +338,7 @@ d_strtod='define' d_strtol='define' d_strtold='undef' d_strtoll='undef' +d_strtoq='undef' d_strtoul='define' d_strtoull='undef' d_strtouq='undef' @@ -522,12 +530,13 @@ installvendorarch='' installvendorbin='' installvendorlib='' intsize='4' +issymlink='' ivdformat='"ld"' ivsize='4' ivtype='long' known_extensions='~static_ext~ ~dynamic_ext~ ~nonxs_ext~' ksh='' -ld='link' +ld='~LINK32~' lddlflags='-dll ~LINK_FLAGS~' ldflags='~LINK_FLAGS~' ldlibpthname='' @@ -597,6 +606,7 @@ mydomain='' myhostname='' myuname='' n='-n' +need_va_copy='undef' netdb_hlen_type='int' netdb_host_type='char *' netdb_name_type='char *' @@ -759,7 +769,7 @@ usemultiplicity='undef' usemymalloc='n' usenm='false' useopcode='true' -useperlio='undef' +useperlio='define' useposix='true' usesfio='false' useshrplib='yes' diff --git a/win32/config_H.bc b/win32/config_H.bc index d71db9876c..2af3c6f796 100644 --- a/win32/config_H.bc +++ b/win32/config_H.bc @@ -1,11 +1,11 @@ /* * This file was produced by running the config_h.SH script, which - * gets its values from config.sh, which is generally produced by + * gets its values from undef, which is generally produced by * running Configure. * * Feel free to modify any of this as the need arises. Note, however, * that running config_h.SH again will wipe out any changes you've made. - * For a more permanent change edit config.sh and rerun config_h.SH. + * For a more permanent change edit undef and rerun config_h.SH. * * $Id: Config_h.U,v 3.0.1.5 1997/02/28 14:57:43 ram Exp $ */ @@ -13,8 +13,8 @@ /* * Package name : perl5 * Source directory : - * Configuration time: Tue Mar 21 01:26:35 2000 - * Configured by : gsar + * Configuration time: Wed Dec 6 18:24:42 2000 + * Configured by : nick * Target system : */ @@ -183,13 +183,6 @@ */ /*#define HAS_FORK /**/ -/* 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_FSETPOS: * This symbol, if defined, indicates that the fsetpos routine is * available to set the file position indicator, similar to fseek(). @@ -227,17 +220,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. @@ -492,18 +474,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. @@ -987,12 +957,6 @@ */ #define SH_PATH "cmd /x /c" /**/ -/* 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. @@ -1095,7 +1059,7 @@ * 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 "c:\\perl\\5.6.0\\lib\\MSWin32-x86" /**/ +#define ARCHLIB "c:\\perl\\5.7.0\\lib\\MSWin32-x86-multi-thread" /**/ /*#define ARCHLIB_EXP "" /**/ /* ARCHNAME: @@ -1104,7 +1068,7 @@ * where library files may be held under a private library, for * instance. */ -#define ARCHNAME "MSWin32-x86" /**/ +#define ARCHNAME "MSWin32-x86-multi-thread" /**/ /* HAS_ATOLF: * This symbol, if defined, indicates that the atolf routine is @@ -1126,8 +1090,8 @@ * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ -#define BIN "c:\\perl\\5.6.0\\bin\\MSWin32-x86" /**/ -#define BIN_EXP "c:\\perl\\5.6.0\\bin\\MSWin32-x86" /**/ +#define BIN "c:\\perl\\5.7.0\\bin\\MSWin32-x86-multi-thread" /**/ +#define BIN_EXP "c:\\perl\\5.7.0\\bin\\MSWin32-x86-multi-thread" /**/ /* PERL_BINCOMPAT_5005: * This symbol, if defined, indicates that this version of Perl should be @@ -1187,21 +1151,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: @@ -1337,11 +1301,24 @@ */ #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. @@ -1389,6 +1366,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. @@ -1494,6 +1477,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. @@ -1519,6 +1509,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. @@ -1546,24 +1542,6 @@ */ /*#define HAS_GETSPNAM /**/ -/* 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_GETPRPWNAM: - * This symbol, if defined, indicates that the getprpwnam system call is - * available to retrieve protected (shadow) password entries by name. - */ -/*#define HAS_GETPRPWNAM /**/ - -/* I_PROT: - * This symbol, if defined, indicates that <prot.h> exists and - * should be included. - */ -/*#define I_PROT /**/ - /* HAS_GETSERVBYNAME: * This symbol, if defined, indicates that the getservbyname() * routine is available to look up services by their name. @@ -1645,6 +1623,13 @@ */ /*#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 @@ -1732,12 +1717,6 @@ /*#define HAS_MMAP /**/ #define Mmap_t void * /**/ -/* HAS_MPROTECT: - * This symbol, if defined, indicates that the mprotect system call is - * available to modify the access protection of a memory mapped file. - */ -/*#define HAS_MPROTECT /**/ - /* 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 @@ -1745,6 +1724,12 @@ */ /*#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. + */ +/*#define HAS_MPROTECT /**/ + /* HAS_MSG: * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). @@ -1851,6 +1836,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. @@ -1966,6 +1957,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. @@ -2028,12 +2025,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)->curp) #define STDIO_PTR_LVALUE /**/ #define FILE_cnt(fp) ((fp)->level) #define STDIO_CNT_LVALUE /**/ +/*#define STDIO_PTR_LVAL_SETS_CNT /**/ +/*#define STDIO_PTR_LVAL_NOCHANGE_CNT /**/ #endif /* USE_STDIO_BASE: @@ -2301,6 +2309,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>. @@ -2331,6 +2345,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>. @@ -2493,8 +2513,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 undef /**/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. @@ -2582,6 +2612,16 @@ #define Netdb_name_t char * /**/ #define Netdb_net_t long /**/ +/* 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. */ @@ -2645,9 +2685,12 @@ /* 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 UVTYPE. + * 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 @@ -2678,6 +2721,7 @@ #define I64SIZE 8 /**/ #define U64SIZE 8 /**/ #endif +#define NVSIZE 8 /**/ #define NV_PRESERVES_UV #define NV_PRESERVES_UV_BITS 32 @@ -2695,7 +2739,7 @@ */ /* 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 @@ -2734,8 +2778,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 "c:\\perl\\5.6.0\\lib" /**/ -#define PRIVLIB_EXP (win32_get_privlib("5.6.0")) /**/ +#define PRIVLIB "c:\\perl\\5.7.0\\lib" /**/ +#define PRIVLIB_EXP (win32_get_privlib("5.7.0")) /**/ /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor @@ -2833,7 +2877,7 @@ * 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 "c:\\perl\\site\\5.6.0\\lib\\MSWin32-x86" /**/ +#define SITEARCH "c:\\perl\\site\\5.7.0\\lib\\MSWin32-x86-multi-thread" /**/ /*#define SITEARCH_EXP "" /**/ /* SITELIB: @@ -2856,8 +2900,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 "c:\\perl\\site\\5.6.0\\lib" /**/ -#define SITELIB_EXP (win32_get_sitelib("5.6.0")) /**/ +#define SITELIB "c:\\perl\\site\\5.7.0\\lib" /**/ +#define SITELIB_EXP (win32_get_sitelib("5.7.0")) /**/ #define SITELIB_STEM "" /**/ /* Size_t_size: @@ -2985,7 +3029,7 @@ * be built to use multiplicity. */ #ifndef MULTIPLICITY -/*#define MULTIPLICITY /**/ +#define MULTIPLICITY /**/ #endif /* USE_PERLIO: @@ -3018,7 +3062,7 @@ * be built to use the old draft POSIX threads API. */ /*#define USE_5005THREADS /**/ -/*#define USE_ITHREADS /**/ +#define USE_ITHREADS /**/ #if defined(USE_5005THREADS) && !defined(USE_ITHREADS) #define USE_THREADS /* until src is revised*/ #endif @@ -3082,7 +3126,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 c:\\perl\\site\\5.6.0\\lib\\MSWin32-x86 for older + * lib/lib.pm will automatically search in c:\\perl\\site\\5.7.0\\lib\\MSWin32-x86-multi-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. @@ -3101,7 +3145,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 c:\\perl\\site\\5.6.0\\lib for older directories across major versions + * search in c:\\perl\\site\\5.7.0\\lib 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 @@ -3114,17 +3158,73 @@ #define PERL_XS_APIVERSION "5.6.0" #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 /**/ + +/* NEED_VA_COPY: + * This symbol, if defined, indicates that the system stores + * the variable argument list datatype, va_list, in a format + * that cannot be copied by simple assignment, so that some + * other means must be used when copying is required. + * As such systems vary in their provision (or non-provision) + * of copying mechanisms, handy.h defines a platform- + * independent macro, Perl_va_copy(src, dst), to do the job. + */ +/*#define NEED_VA_COPY /**/ #endif diff --git a/win32/config_H.gc b/win32/config_H.gc index f943aad908..d26492fca9 100644 --- a/win32/config_H.gc +++ b/win32/config_H.gc @@ -1,11 +1,11 @@ /* * This file was produced by running the config_h.SH script, which - * gets its values from config.sh, which is generally produced by + * gets its values from undef, which is generally produced by * running Configure. * * Feel free to modify any of this as the need arises. Note, however, * that running config_h.SH again will wipe out any changes you've made. - * For a more permanent change edit config.sh and rerun config_h.SH. + * For a more permanent change edit undef and rerun config_h.SH. * * $Id: Config_h.U,v 3.0.1.5 1997/02/28 14:57:43 ram Exp $ */ @@ -13,8 +13,8 @@ /* * Package name : perl5 * Source directory : - * Configuration time: Tue Mar 21 01:26:44 2000 - * Configured by : gsar + * Configuration time: Wed Dec 6 18:22:28 2000 + * Configured by : nick * Target system : */ @@ -183,13 +183,6 @@ */ /*#define HAS_FORK /**/ -/* 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_FSETPOS: * This symbol, if defined, indicates that the fsetpos routine is * available to set the file position indicator, similar to fseek(). @@ -227,17 +220,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. @@ -492,18 +474,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. @@ -987,12 +957,6 @@ */ #define SH_PATH "cmd /x /c" /**/ -/* 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 char /**/ - /* CROSSCOMPILE: * This symbol, if defined, signifies that we our * build process is a cross-compilation. @@ -1095,7 +1059,7 @@ * 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 "c:\\perl\\5.6.0\\lib\\MSWin32-x86" /**/ +#define ARCHLIB "c:\\perl\\5.7.0\\lib\\MSWin32-x86-multi-thread" /**/ /*#define ARCHLIB_EXP "" /**/ /* ARCHNAME: @@ -1104,7 +1068,7 @@ * where library files may be held under a private library, for * instance. */ -#define ARCHNAME "MSWin32-x86" /**/ +#define ARCHNAME "MSWin32-x86-multi-thread" /**/ /* HAS_ATOLF: * This symbol, if defined, indicates that the atolf routine is @@ -1126,8 +1090,8 @@ * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ -#define BIN "c:\\perl\\5.6.0\\bin\\MSWin32-x86" /**/ -#define BIN_EXP "c:\\perl\\5.6.0\\bin\\MSWin32-x86" /**/ +#define BIN "c:\\perl\\5.7.0\\bin\\MSWin32-x86-multi-thread" /**/ +#define BIN_EXP "c:\\perl\\5.7.0\\bin\\MSWin32-x86-multi-thread" /**/ /* PERL_BINCOMPAT_5005: * This symbol, if defined, indicates that this version of Perl should be @@ -1187,21 +1151,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: @@ -1337,11 +1301,24 @@ */ #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. @@ -1389,6 +1366,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. @@ -1494,6 +1477,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. @@ -1519,6 +1509,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. @@ -1546,24 +1542,6 @@ */ /*#define HAS_GETSPNAM /**/ -/* 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_GETPRPWNAM: - * This symbol, if defined, indicates that the getprpwnam system call is - * available to retrieve protected (shadow) password entries by name. - */ -/*#define HAS_GETPRPWNAM /**/ - -/* I_PROT: - * This symbol, if defined, indicates that <prot.h> exists and - * should be included. - */ -/*#define I_PROT /**/ - /* HAS_GETSERVBYNAME: * This symbol, if defined, indicates that the getservbyname() * routine is available to look up services by their name. @@ -1645,6 +1623,13 @@ */ /*#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 @@ -1732,12 +1717,6 @@ /*#define HAS_MMAP /**/ #define Mmap_t void * /**/ -/* HAS_MPROTECT: - * This symbol, if defined, indicates that the mprotect system call is - * available to modify the access protection of a memory mapped file. - */ -/*#define HAS_MPROTECT /**/ - /* 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 @@ -1745,6 +1724,12 @@ */ /*#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. + */ +/*#define HAS_MPROTECT /**/ + /* HAS_MSG: * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). @@ -1851,6 +1836,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. @@ -1966,6 +1957,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. @@ -2028,12 +2025,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: @@ -2301,6 +2309,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>. @@ -2331,6 +2345,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>. @@ -2493,8 +2513,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 undef /**/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. @@ -2582,6 +2612,16 @@ #define Netdb_name_t char * /**/ #define Netdb_net_t long /**/ +/* 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. */ @@ -2645,9 +2685,12 @@ /* 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 UVTYPE. + * 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 @@ -2678,6 +2721,7 @@ #define I64SIZE 8 /**/ #define U64SIZE 8 /**/ #endif +#define NVSIZE 8 /**/ #define NV_PRESERVES_UV #define NV_PRESERVES_UV_BITS 32 @@ -2695,7 +2739,7 @@ */ /* 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 @@ -2734,8 +2778,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 "c:\\perl\\5.6.0\\lib" /**/ -#define PRIVLIB_EXP (win32_get_privlib("5.6.0")) /**/ +#define PRIVLIB "c:\\perl\\5.7.0\\lib" /**/ +#define PRIVLIB_EXP (win32_get_privlib("5.7.0")) /**/ /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor @@ -2833,7 +2877,7 @@ * 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 "c:\\perl\\site\\5.6.0\\lib\\MSWin32-x86" /**/ +#define SITEARCH "c:\\perl\\site\\5.7.0\\lib\\MSWin32-x86-multi-thread" /**/ /*#define SITEARCH_EXP "" /**/ /* SITELIB: @@ -2856,8 +2900,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 "c:\\perl\\site\\5.6.0\\lib" /**/ -#define SITELIB_EXP (win32_get_sitelib("5.6.0")) /**/ +#define SITELIB "c:\\perl\\site\\5.7.0\\lib" /**/ +#define SITELIB_EXP (win32_get_sitelib("5.7.0")) /**/ #define SITELIB_STEM "" /**/ /* Size_t_size: @@ -2985,7 +3029,7 @@ * be built to use multiplicity. */ #ifndef MULTIPLICITY -/*#define MULTIPLICITY /**/ +#define MULTIPLICITY /**/ #endif /* USE_PERLIO: @@ -2994,7 +3038,7 @@ * used in a fully backward compatible manner. */ #ifndef USE_PERLIO -/*#define USE_PERLIO /**/ +#define USE_PERLIO /**/ #endif /* USE_SOCKS: @@ -3018,7 +3062,7 @@ * be built to use the old draft POSIX threads API. */ /*#define USE_5005THREADS /**/ -/*#define USE_ITHREADS /**/ +#define USE_ITHREADS /**/ #if defined(USE_5005THREADS) && !defined(USE_ITHREADS) #define USE_THREADS /* until src is revised*/ #endif @@ -3082,7 +3126,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 c:\\perl\\site\\5.6.0\\lib\\MSWin32-x86 for older + * lib/lib.pm will automatically search in c:\\perl\\site\\5.7.0\\lib\\MSWin32-x86-multi-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. @@ -3101,7 +3145,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 c:\\perl\\site\\5.6.0\\lib for older directories across major versions + * search in c:\\perl\\site\\5.7.0\\lib 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 @@ -3114,17 +3158,73 @@ #define PERL_XS_APIVERSION "5.6.0" #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 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 /**/ + +/* NEED_VA_COPY: + * This symbol, if defined, indicates that the system stores + * the variable argument list datatype, va_list, in a format + * that cannot be copied by simple assignment, so that some + * other means must be used when copying is required. + * As such systems vary in their provision (or non-provision) + * of copying mechanisms, handy.h defines a platform- + * independent macro, Perl_va_copy(src, dst), to do the job. + */ +/*#define NEED_VA_COPY /**/ #endif diff --git a/win32/config_H.vc b/win32/config_H.vc index 6b8d234f5e..0aa5f385d6 100644 --- a/win32/config_H.vc +++ b/win32/config_H.vc @@ -1,11 +1,11 @@ /* * This file was produced by running the config_h.SH script, which - * gets its values from config.sh, which is generally produced by + * gets its values from undef, which is generally produced by * running Configure. * * Feel free to modify any of this as the need arises. Note, however, * that running config_h.SH again will wipe out any changes you've made. - * For a more permanent change edit config.sh and rerun config_h.SH. + * For a more permanent change edit undef and rerun config_h.SH. * * $Id: Config_h.U,v 3.0.1.5 1997/02/28 14:57:43 ram Exp $ */ @@ -13,8 +13,8 @@ /* * Package name : perl5 * Source directory : - * Configuration time: Tue Mar 21 01:26:24 2000 - * Configured by : gsar + * Configuration time: Wed Dec 6 14:45:43 2000 + * Configured by : nick * Target system : */ @@ -183,13 +183,6 @@ */ /*#define HAS_FORK /**/ -/* 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_FSETPOS: * This symbol, if defined, indicates that the fsetpos routine is * available to set the file position indicator, similar to fseek(). @@ -227,17 +220,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. @@ -492,18 +474,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. @@ -987,12 +957,6 @@ */ #define SH_PATH "cmd /x /c" /**/ -/* 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 char /**/ - /* CROSSCOMPILE: * This symbol, if defined, signifies that we our * build process is a cross-compilation. @@ -1095,7 +1059,7 @@ * 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 "c:\\perl\\5.6.0\\lib\\MSWin32-x86" /**/ +#define ARCHLIB "c:\\perl\\5.7.0\\lib\\MSWin32-x86-multi-thread" /**/ /*#define ARCHLIB_EXP "" /**/ /* ARCHNAME: @@ -1104,7 +1068,7 @@ * where library files may be held under a private library, for * instance. */ -#define ARCHNAME "MSWin32-x86" /**/ +#define ARCHNAME "MSWin32-x86-multi-thread" /**/ /* HAS_ATOLF: * This symbol, if defined, indicates that the atolf routine is @@ -1126,8 +1090,8 @@ * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ -#define BIN "c:\\perl\\5.6.0\\bin\\MSWin32-x86" /**/ -#define BIN_EXP "c:\\perl\\5.6.0\\bin\\MSWin32-x86" /**/ +#define BIN "c:\\perl\\5.7.0\\bin\\MSWin32-x86-multi-thread" /**/ +#define BIN_EXP "c:\\perl\\5.7.0\\bin\\MSWin32-x86-multi-thread" /**/ /* PERL_BINCOMPAT_5005: * This symbol, if defined, indicates that this version of Perl should be @@ -1187,21 +1151,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: @@ -1337,11 +1301,24 @@ */ #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. @@ -1389,6 +1366,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. @@ -1494,6 +1477,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. @@ -1519,6 +1509,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. @@ -1546,24 +1542,6 @@ */ /*#define HAS_GETSPNAM /**/ -/* 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_GETPRPWNAM: - * This symbol, if defined, indicates that the getprpwnam system call is - * available to retrieve protected (shadow) password entries by name. - */ -/*#define HAS_GETPRPWNAM /**/ - -/* I_PROT: - * This symbol, if defined, indicates that <prot.h> exists and - * should be included. - */ -/*#define I_PROT /**/ - /* HAS_GETSERVBYNAME: * This symbol, if defined, indicates that the getservbyname() * routine is available to look up services by their name. @@ -1645,6 +1623,13 @@ */ /*#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 @@ -1732,12 +1717,6 @@ /*#define HAS_MMAP /**/ #define Mmap_t void * /**/ -/* HAS_MPROTECT: - * This symbol, if defined, indicates that the mprotect system call is - * available to modify the access protection of a memory mapped file. - */ -/*#define HAS_MPROTECT /**/ - /* 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 @@ -1745,6 +1724,12 @@ */ /*#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. + */ +/*#define HAS_MPROTECT /**/ + /* HAS_MSG: * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). @@ -1851,6 +1836,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. @@ -1966,6 +1957,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. @@ -2028,12 +2025,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: @@ -2301,6 +2309,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>. @@ -2331,6 +2345,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>. @@ -2493,8 +2513,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 undef /**/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. @@ -2582,6 +2612,16 @@ #define Netdb_name_t char * /**/ #define Netdb_net_t long /**/ +/* 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. */ @@ -2645,9 +2685,12 @@ /* 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 UVTYPE. + * 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 @@ -2678,6 +2721,7 @@ #define I64SIZE 8 /**/ #define U64SIZE 8 /**/ #endif +#define NVSIZE 8 /**/ #define NV_PRESERVES_UV #define NV_PRESERVES_UV_BITS 32 @@ -2695,7 +2739,7 @@ */ /* 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 @@ -2734,8 +2778,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 "c:\\perl\\5.6.0\\lib" /**/ -#define PRIVLIB_EXP (win32_get_privlib("5.6.0")) /**/ +#define PRIVLIB "c:\\perl\\5.7.0\\lib" /**/ +#define PRIVLIB_EXP (win32_get_privlib("5.7.0")) /**/ /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor @@ -2833,7 +2877,7 @@ * 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 "c:\\perl\\site\\5.6.0\\lib\\MSWin32-x86" /**/ +#define SITEARCH "c:\\perl\\site\\5.7.0\\lib\\MSWin32-x86-multi-thread" /**/ /*#define SITEARCH_EXP "" /**/ /* SITELIB: @@ -2856,8 +2900,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 "c:\\perl\\site\\5.6.0\\lib" /**/ -#define SITELIB_EXP (win32_get_sitelib("5.6.0")) /**/ +#define SITELIB "c:\\perl\\site\\5.7.0\\lib" /**/ +#define SITELIB_EXP (win32_get_sitelib("5.7.0")) /**/ #define SITELIB_STEM "" /**/ /* Size_t_size: @@ -2985,7 +3029,7 @@ * be built to use multiplicity. */ #ifndef MULTIPLICITY -/*#define MULTIPLICITY /**/ +#define MULTIPLICITY /**/ #endif /* USE_PERLIO: @@ -2994,7 +3038,7 @@ * used in a fully backward compatible manner. */ #ifndef USE_PERLIO -/*#define USE_PERLIO /**/ +#define USE_PERLIO /**/ #endif /* USE_SOCKS: @@ -3018,7 +3062,7 @@ * be built to use the old draft POSIX threads API. */ /*#define USE_5005THREADS /**/ -/*#define USE_ITHREADS /**/ +#define USE_ITHREADS /**/ #if defined(USE_5005THREADS) && !defined(USE_ITHREADS) #define USE_THREADS /* until src is revised*/ #endif @@ -3082,7 +3126,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 c:\\perl\\site\\5.6.0\\lib\\MSWin32-x86 for older + * lib/lib.pm will automatically search in c:\\perl\\site\\5.7.0\\lib\\MSWin32-x86-multi-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. @@ -3101,7 +3145,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 c:\\perl\\site\\5.6.0\\lib for older directories across major versions + * search in c:\\perl\\site\\5.7.0\\lib 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 @@ -3114,17 +3158,73 @@ #define PERL_XS_APIVERSION "5.6.0" #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 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 /**/ + +/* NEED_VA_COPY: + * This symbol, if defined, indicates that the system stores + * the variable argument list datatype, va_list, in a format + * that cannot be copied by simple assignment, so that some + * other means must be used when copying is required. + * As such systems vary in their provision (or non-provision) + * of copying mechanisms, handy.h defines a platform- + * independent macro, Perl_va_copy(src, dst), to do the job. + */ +/*#define NEED_VA_COPY /**/ #endif diff --git a/win32/config_h.PL b/win32/config_h.PL index 91f35a4753..a0ee22d305 100644 --- a/win32/config_h.PL +++ b/win32/config_h.PL @@ -45,7 +45,7 @@ eval $str; die "$str:$@" if $@; open(H,">$file.new") || die "Cannot open $file.new:$!"; -binmode H; # no CRs (which cause a spurious rebuild) +#binmode H; # no CRs (which cause a spurious rebuild) while (<SH>) { last if /^$term$/o; diff --git a/win32/distclean.bat b/win32/distclean.bat new file mode 100755 index 0000000000..e202eab5d9 --- /dev/null +++ b/win32/distclean.bat @@ -0,0 +1,30 @@ +@perl -w -Sx %0 %* +@goto end_of_perl +#!perl -w +BEGIN { push(@INC,'lib') } +use strict; +use File::Find; +use ExtUtils::Manifest qw(maniread); +my $files = maniread(); +my @dead; +find(sub { +return if -d $_; +my $name = $File::Find::name; +$name =~ s#^\./##; + unless (exists $files->{$name}) + { + print "new $name\n"; + push(@dead,$name); + } +},'.'); + +foreach my $file (@dead) + { + chmod(0666,$file) unless -w $file; + unlink($file) || warn "Cannot delete $file:$!"; + } + +__END__ +:end_of_perl +del perl.exe +del perl*.dll
\ No newline at end of file diff --git a/win32/include/sys/socket.h b/win32/include/sys/socket.h index 194de9581f..e83fd2bd94 100644 --- a/win32/include/sys/socket.h +++ b/win32/include/sys/socket.h @@ -10,49 +10,14 @@ extern "C" { #endif -#ifndef _WINDOWS_ -#ifdef __GNUC__ #define WIN32_LEAN_AND_MEAN #ifdef __GNUC__ -#define Win32_Winsock +# define Win32_Winsock #endif #include <windows.h> -#else -#define _WINDOWS_ - -#define FAR -#define PASCAL __stdcall -#define WINAPI __stdcall - -#undef WORD -typedef int BOOL; -typedef unsigned short WORD; -typedef void* HANDLE; -typedef void* HWND; -typedef int (FAR WINAPI *FARPROC)(); - -typedef unsigned long DWORD; -typedef void *PVOID; - -#define IN -#define OUT - -typedef struct _OVERLAPPED { - DWORD Internal; - DWORD InternalHigh; - DWORD Offset; - DWORD OffsetHigh; - HANDLE hEvent; -} OVERLAPPED, *LPOVERLAPPED; - -#endif -#endif //_WINDOWS_ -// #ifndef __GNUC__ #include <winsock.h> -// #endif #define ENOTSOCK WSAENOTSOCK -#undef HOST_NOT_FOUND #ifdef USE_SOCKETS_AS_HANDLES diff --git a/win32/makefile.mk b/win32/makefile.mk index 86a2bf4bfa..974deb3483 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -6,7 +6,7 @@ # Mingw32 with gcc-2.95.2 or better **experimental** # # This is set up to build a perl.exe that runs off a shared library -# (perl56.dll). Also makes individual DLLs for the XS extensions. +# (perl57.dll). Also makes individual DLLs for the XS extensions. # ## @@ -33,7 +33,7 @@ INST_TOP *= $(INST_DRV)\perl # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # -INST_VER *= \5.6.0 +INST_VER *= \5.7.0 # # Comment this out if you DON'T want your perl installation to have @@ -50,21 +50,21 @@ INST_ARCH *= \$(ARCHNAME) # uncomment to enable multiple interpreters. This is need for fork() # emulation. # -#USE_MULTI *= define +USE_MULTI *= define # # Beginnings of interpreter cloning/threads; still very incomplete. # This should be enabled to get the fork() emulation. This needs # USE_MULTI as well. # -#USE_ITHREADS *= define +USE_ITHREADS *= define # # uncomment to enable the implicit "host" layer for all system calls # made by perl. This needs USE_MULTI above. This is also needed to # get fork(). # -#USE_IMP_SYS *= define +USE_IMP_SYS *= define # # WARNING! This option is deprecated and will eventually go away (enable @@ -89,17 +89,17 @@ INST_ARCH *= \$(ARCHNAME) # # uncomment exactly one of the following -# +# # Visual C++ 2.x #CCTYPE *= MSVC20 # Visual C++ > 2.x and < 6.x #CCTYPE *= MSVC # Visual C++ >= 6.x -#CCTYPE *= MSVC60 +CCTYPE *= MSVC60 # Borland 5.02 or later #CCTYPE *= BORLAND # mingw32+gcc-2.95.2 or better -CCTYPE *= GCC +#CCTYPE *= GCC # # uncomment this if you are compiling under Windows 95/98 and command.com @@ -111,7 +111,7 @@ CCTYPE *= GCC # If not enabled, we automatically try to use maximum optimization # with all compilers that are known to have a working optimizer. # -#CFG *= Debug +CFG *= Debug # # uncomment to enable use of PerlCRT.DLL when using the Visual C compiler. @@ -165,7 +165,7 @@ CCTYPE *= GCC # #CCHOME *= c:\bc5 #CCHOME *= $(MSVCDIR) -CCHOME *= c:\gcc-2.95.2-msvcrt +CCHOME *= c:\gcc-2.95.2 CCINCDIR *= $(CCHOME)\include CCLIBDIR *= $(CCHOME)\lib @@ -290,12 +290,15 @@ ARCHNAME !:= $(ARCHNAME)-thread # VC 6.0 can load the socket dll on demand. Makes the test suite # run in about 10% less time. -DELAYLOAD *= -DELAYLOAD:wsock32.dll -DELAYLOAD:shell32.dll delayimp.lib +DELAYLOAD *= -DELAYLOAD:wsock32.dll -DELAYLOAD:shell32.dll delayimp.lib +.IF "$(CFG)" == "Debug" +.ELSE # VC 6.0 seems capable of compiling perl correctly with optimizations # enabled. Anything earlier fails tests. CFG *= Optimize .ENDIF +.ENDIF ARCHDIR = ..\lib\$(ARCHNAME) COREDIR = ..\lib\CORE @@ -332,7 +335,7 @@ RSC = rc # Options # INCLUDES = -I$(COREDIR) -I.\include -I. -I.. -I"$(CCINCDIR)" -#PCHFLAGS = -H -Hc -H=c:\temp\bcmoduls.pch +#PCHFLAGS = -H -Hc -H=c:\temp\bcmoduls.pch DEFINES = -DWIN32 $(CRYPT_FLAG) LOCDEFS = -DPERLDLL -DPERL_CORE SUBSYS = console @@ -346,7 +349,7 @@ OPTIMIZE = -v -D_RTLDLL -DDEBUGGING LINK_DBG = -v .ELSE OPTIMIZE = -O2 -D_RTLDLL -LINK_DBG = +LINK_DBG = .ENDIF CFLAGS = -w -g0 -tWM -tWD $(INCLUDES) $(DEFINES) $(LOCDEFS) \ @@ -354,7 +357,7 @@ CFLAGS = -w -g0 -tWM -tWD $(INCLUDES) $(DEFINES) $(LOCDEFS) \ LINK_FLAGS = $(LINK_DBG) -L"$(INST_COREDIR)" -L"$(CCLIBDIR)" OBJOUT_FLAG = -o EXEOUT_FLAG = -e -LIBOUT_FLAG = +LIBOUT_FLAG = .ELIF "$(CCTYPE)" == "GCC" @@ -364,6 +367,7 @@ LIB32 = ar rc IMPLIB = dlltool RSC = rc +i = .i o = .o a = .a @@ -371,7 +375,7 @@ a = .a # Options # -INCLUDES = -I$(COREDIR) -I.\include -I. -I.. +INCLUDES = -I.\include -I. -I.. -I$(COREDIR) DEFINES = -DWIN32 $(CRYPT_FLAG) LOCDEFS = -DPERLDLL -DPERL_CORE SUBSYS = console @@ -387,18 +391,18 @@ LIBFILES = $(CRYPT_LIB) $(LIBC) \ -lwinmm -lversion -lodbc32 .IF "$(CFG)" == "Debug" -OPTIMIZE = -g -DDEBUGGING +OPTIMIZE = -g -O2 -DDEBUGGING LINK_DBG = -g .ELSE OPTIMIZE = -g -O2 -LINK_DBG = +LINK_DBG = -g .ENDIF CFLAGS = $(INCLUDES) $(DEFINES) $(LOCDEFS) $(OPTIMIZE) LINK_FLAGS = $(LINK_DBG) -L"$(INST_COREDIR)" -L"$(CCLIBDIR)" OBJOUT_FLAG = -o EXEOUT_FLAG = -o -LIBOUT_FLAG = +LIBOUT_FLAG = # NOTE: we assume that GCC uses MSVCRT.DLL BUILDOPT += -fno-strict-aliasing -DPERL_MSVCRT_READFIX @@ -415,7 +419,7 @@ RSC = rc # INCLUDES = -I$(COREDIR) -I.\include -I. -I.. -#PCHFLAGS = -Fpc:\temp\vcmoduls.pch -YX +#PCHFLAGS = -Fpc:\temp\vcmoduls.pch -YX DEFINES = -DWIN32 -D_CONSOLE -DNO_STRICT $(CRYPT_FLAG) LOCDEFS = -DPERLDLL -DPERL_CORE SUBSYS = console @@ -433,10 +437,14 @@ PERLDLL_RES = .IF "$(CFG)" == "Debug" .IF "$(CCTYPE)" == "MSVC20" OPTIMIZE = -Od -MD -Z7 -DDEBUGGING +LINK_DBG = -debug -pdb:none .ELSE -OPTIMIZE = -Od -MD -Zi -DDEBUGGING +# -Zi requires .pdb file(s) +#OPTIMIZE = -Od -MD -Zi -DDEBUGGING +#LINK_DBG = -debug +OPTIMIZE = -O1 -MD -Z7 -DDEBUGGING +LINK_DBG = -debug -debugtype:both -pdb:none .ENDIF -LINK_DBG = -debug -pdb:none .ELSE .IF "$(CFG)" == "Optimize" # -O1 yields smaller code, which turns out to be faster than -O2 @@ -496,13 +504,16 @@ LKPOST = ) # # Rules -# +# -.SUFFIXES : .c $(o) .dll $(a) .exe .rc .res +.SUFFIXES : .c .i $(o) .dll $(a) .exe .rc .res .c$(o): $(CC) -c $(null,$(<:d) $(NULL) -I$(<:d)) $(CFLAGS_O) $(OBJOUT_FLAG)$@ $< +.c.i: + $(CC) -c $(null,$(<:d) $(NULL) -I$(<:d)) $(CFLAGS_O) -E $< >$@ + .y.c: $(NOOP) @@ -515,7 +526,7 @@ $(o).dll: $(IMPLIB) --input-def $(*B).def --output-lib $(*B).a $@ .ELSE $(LINK32) -dll -subsystem:windows -implib:$(*B).lib -def:$(*B).def \ - -out:$@ $(BLINK_FLAGS) $(LIBFILES) $< $(LIBPERL) + -out:$@ $(BLINK_FLAGS) $(LIBFILES) $< $(LIBPERL) .ENDIF .rc.res: @@ -532,6 +543,13 @@ CONFIGPM = ..\lib\Config.pm MINIMOD = ..\lib\ExtUtils\Miniperl.pm X2P = ..\x2p\a2p.exe +# Nominate a target which causes extensions to be re-built +# This used to be $(PERLEXE), but at worst it is the .dll that they depend +# on and really only the interface - i.e. the .def file used to export symbols +# from the .dll +PERLDEP = perldll.def + + PL2BAT = bin\pl2bat.pl GLOBBAT = bin\perlglob.bat @@ -570,7 +588,7 @@ CFGH_TMPL = config_H.bc CFGSH_TMPL = config.gc CFGH_TMPL = config_H.gc -PERLIMPLIB = ..\libperl56$(a) +PERLIMPLIB = ..\libperl57$(a) .ELSE @@ -579,8 +597,11 @@ CFGH_TMPL = config_H.vc .ENDIF -PERLIMPLIB *= ..\perl56$(a) -PERLDLL = ..\perl56.dll +# makedef.pl must be updated if this changes, and this should normally +# only change when there is an incompatible revision of the public API. +# XXX so why did we change it from perl56 to perl57? +PERLIMPLIB *= ..\perl57$(a) +PERLDLL = ..\perl57.dll XCOPY = xcopy /f /r /i /d RCOPY = xcopy /f /r /i /e /d @@ -635,7 +656,7 @@ EXTRACORE_SRC += ..\perlio.c WIN32_SRC = \ .\win32.c \ .\win32sck.c \ - .\win32thread.c + .\win32thread.c .IF "$(CRYPT_SRC)" != "" WIN32_SRC += .\$(CRYPT_SRC) @@ -712,7 +733,7 @@ SETARGV_OBJ = setargv$(o) DYNAMIC_EXT = Socket IO Fcntl Opcode SDBM_File POSIX attrs Thread B re \ Data/Dumper Devel/Peek ByteLoader Devel/DProf File/Glob \ - Sys/Hostname Storable + Sys/Hostname Storable Filter/Util/Call Encode STATIC_EXT = DynaLoader NONXS_EXT = Errno @@ -735,6 +756,8 @@ DPROF = $(EXTDIR)\Devel\DProf\DProf GLOB = $(EXTDIR)\File\Glob\Glob HOSTNAME = $(EXTDIR)\Sys\Hostname\Hostname STORABLE = $(EXTDIR)\Storable\Storable +FILTER = $(EXTDIR)\Filter\Util\Call\Call +ENCODE = $(EXTDIR)\Encode\Encode SOCKET_DLL = $(AUTODIR)\Socket\Socket.dll FCNTL_DLL = $(AUTODIR)\Fcntl\Fcntl.dll @@ -753,6 +776,8 @@ DPROF_DLL = $(AUTODIR)\Devel\DProf\DProf.dll GLOB_DLL = $(AUTODIR)\File\Glob\Glob.dll HOSTNAME_DLL = $(AUTODIR)\Sys\Hostname\Hostname.dll STORABLE_DLL = $(AUTODIR)\Storable\Storable.dll +FILTER_DLL = $(AUTODIR)\Filter\Util\Call\Call.dll +ENCODE_DLL = $(AUTODIR)\Encode\Encode.dll ERRNO_PM = $(LIBDIR)\Errno.pm @@ -773,7 +798,9 @@ EXTENSION_C = \ $(DPROF).c \ $(GLOB).c \ $(HOSTNAME).c \ - $(STORABLE).c + $(STORABLE).c \ + $(FILTER).c \ + $(ENCODE).c EXTENSION_DLL = \ $(SOCKET_DLL) \ @@ -792,7 +819,9 @@ EXTENSION_DLL = \ $(DPROF_DLL) \ $(GLOB_DLL) \ $(HOSTNAME_DLL) \ - $(STORABLE_DLL) + $(STORABLE_DLL) \ + $(FILTER_DLL) \ + $(ENCODE_DLL) EXTENSION_PM = \ $(ERRNO_PM) @@ -813,6 +842,7 @@ CFG_VARS = \ INST_ARCH=$(INST_ARCH) ~ \ archname=$(ARCHNAME) ~ \ cc=$(CC) ~ \ + ld=$(LINK32) ~ \ ccflags=$(OPTIMIZE) $(DEFINES) $(BUILDOPT) ~ \ cf_email=$(EMAIL) ~ \ d_crypt=$(D_CRYPT) ~ \ @@ -845,7 +875,7 @@ RIGHTMAKE = __switch_makefiles NOOP = @rem .ELSE MK2 = __not_needed -RIGHTMAKE = __not_needed +RIGHTMAKE = .ENDIF # @@ -901,7 +931,7 @@ __no_such_target: #--------------------- END Win95 SPECIFIC --------------------- # a blank target for when builds don't need to do certain things -# this target added for Win95 port but used to keep the WinNT port able to +# this target added for Win95 port but used to keep the WinNT port able to # use this file __not_needed: $(NOOP) @@ -915,7 +945,7 @@ $(GLOBEXE) : perlglob$(o) $(LINK32) $(BLINK_FLAGS) -mconsole -o $@ perlglob$(o) $(LIBFILES) .ELSE $(LINK32) $(BLINK_FLAGS) $(LIBFILES) -out:$@ -subsystem:$(SUBSYS) \ - perlglob$(o) setargv$(o) + perlglob$(o) setargv$(o) .ENDIF perlglob$(o) : perlglob.c @@ -960,7 +990,7 @@ $(MINIPERL) : $(MINIDIR) $(MINI_OBJ) $(CRTIPMLIBS) @$(mktmp c0x32$(o) $(MINI_OBJ:s,\,\\),$(@:s,\,\\),,$(LIBFILES),) .ELIF "$(CCTYPE)" == "GCC" $(LINK32) -v -mconsole -o $@ $(BLINK_FLAGS) \ - $(mktmp $(LKPRE) $(MINI_OBJ:s,\,\\) $(LIBFILES) $(LKPOST)) + $(mktmp $(LKPRE) $(MINI_OBJ:s,\,\\) $(LIBFILES) $(LKPOST)) .ELSE $(LINK32) -subsystem:console -out:$@ \ @$(mktmp $(BLINK_FLAGS) $(LIBFILES) $(MINI_OBJ:s,\,\\)) @@ -1058,7 +1088,7 @@ $(X2P) : $(MINIPERL) $(X2P_OBJ) @$(mktmp $(BLINK_FLAGS) $(LIBFILES) $(X2P_OBJ:s,\,\\)) .ENDIF -perlmain.c : runperl.c +perlmain.c : runperl.c copy runperl.c perlmain.c perlmain$(o) : perlmain.c @@ -1079,7 +1109,7 @@ $(PERLEXE): $(PERLDLL) $(CONFIGPM) $(PERLEXE_OBJ) $(PERLEXE_RES) .ENDIF copy $(PERLEXE) $(WPERLEXE) $(MINIPERL) -I..\lib bin\exetype.pl $(WPERLEXE) WINDOWS - copy splittree.pl .. + copy splittree.pl .. $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR) $(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM) @@ -1094,92 +1124,102 @@ $(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM) $(EXTDIR)\DynaLoader\dl_win32.xs: dl_win32.xs copy dl_win32.xs $(EXTDIR)\DynaLoader\dl_win32.xs -$(DUMPER_DLL): $(PERLEXE) $(DUMPER).xs +$(DUMPER_DLL): $(PERLDEP) $(DUMPER).xs cd $(EXTDIR)\Data\$(*B) && \ ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\Data\$(*B) && $(MAKE) -$(DPROF_DLL): $(PERLEXE) $(DPROF).xs +$(DPROF_DLL): $(PERLDEP) $(DPROF).xs cd $(EXTDIR)\Devel\$(*B) && \ ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\Devel\$(*B) && $(MAKE) -$(GLOB_DLL): $(PERLEXE) $(GLOB).xs +$(GLOB_DLL): $(PERLDEP) $(GLOB).xs cd $(EXTDIR)\File\$(*B) && \ ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\File\$(*B) && $(MAKE) -$(PEEK_DLL): $(PERLEXE) $(PEEK).xs +$(PEEK_DLL): $(PERLDEP) $(PEEK).xs cd $(EXTDIR)\Devel\$(*B) && \ ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\Devel\$(*B) && $(MAKE) -$(RE_DLL): $(PERLEXE) $(RE).xs +$(RE_DLL): $(PERLDEP) $(RE).xs cd $(EXTDIR)\$(*B) && \ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\$(*B) && $(MAKE) -$(B_DLL): $(PERLEXE) $(B).xs +$(B_DLL): $(PERLDEP) $(B).xs cd $(EXTDIR)\$(*B) && \ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\$(*B) && $(MAKE) -$(THREAD_DLL): $(PERLEXE) $(THREAD).xs +$(THREAD_DLL): $(PERLDEP) $(THREAD).xs cd $(EXTDIR)\$(*B) && \ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\$(*B) && $(MAKE) -$(ATTRS_DLL): $(PERLEXE) $(ATTRS).xs +$(ATTRS_DLL): $(PERLDEP) $(ATTRS).xs cd $(EXTDIR)\$(*B) && \ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\$(*B) && $(MAKE) -$(POSIX_DLL): $(PERLEXE) $(POSIX).xs +$(POSIX_DLL): $(PERLDEP) $(POSIX).xs cd $(EXTDIR)\$(*B) && \ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\$(*B) && $(MAKE) -$(IO_DLL): $(PERLEXE) $(IO).xs +$(IO_DLL): $(PERLDEP) $(IO).xs cd $(EXTDIR)\$(*B) && \ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\$(*B) && $(MAKE) -$(SDBM_FILE_DLL) : $(PERLEXE) $(SDBM_FILE).xs +$(SDBM_FILE_DLL) : $(PERLDEP) $(SDBM_FILE).xs cd $(EXTDIR)\$(*B) && \ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\$(*B) && $(MAKE) -$(FCNTL_DLL): $(PERLEXE) $(FCNTL).xs +$(FCNTL_DLL): $(PERLDEP) $(FCNTL).xs cd $(EXTDIR)\$(*B) && \ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\$(*B) && $(MAKE) -$(OPCODE_DLL): $(PERLEXE) $(OPCODE).xs +$(OPCODE_DLL): $(PERLDEP) $(OPCODE).xs cd $(EXTDIR)\$(*B) && \ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\$(*B) && $(MAKE) -$(SOCKET_DLL): $(PERLEXE) $(SOCKET).xs +$(SOCKET_DLL): $(PERLDEP) $(SOCKET).xs cd $(EXTDIR)\$(*B) && \ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\$(*B) && $(MAKE) -$(HOSTNAME_DLL): $(PERLEXE) $(HOSTNAME).xs +$(HOSTNAME_DLL): $(PERLDEP) $(HOSTNAME).xs cd $(EXTDIR)\Sys\$(*B) && \ ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\Sys\$(*B) && $(MAKE) -$(BYTELOADER_DLL): $(PERLEXE) $(BYTELOADER).xs +$(BYTELOADER_DLL): $(PERLDEP) $(BYTELOADER).xs cd $(EXTDIR)\$(*B) && \ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\$(*B) && $(MAKE) -$(STORABLE_DLL): $(PERLEXE) $(STORABLE).xs +$(ENCODE_DLL): $(PERLDEP) $(ENCODE).xs cd $(EXTDIR)\$(*B) && \ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\$(*B) && $(MAKE) -$(ERRNO_PM): $(PERLEXE) $(ERRNO)_pm.PL +$(STORABLE_DLL): $(PERLDEP) $(STORABLE).xs + cd $(EXTDIR)\$(*B) && \ + ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl + cd $(EXTDIR)\$(*B) && $(MAKE) + +$(FILTER_DLL): $(PERLDEP) $(FILTER).xs + cd $(EXTDIR)\Filter\Util\Call && \ + ..\..\..\..\miniperl -I..\..\..\..\lib Makefile.PL INSTALLDIRS=perl + cd $(EXTDIR)\Filter\Util\Call && $(MAKE) + +$(ERRNO_PM): $(PERLDEP) $(ERRNO)_pm.PL cd $(EXTDIR)\$(*B) && \ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\$(*B) && $(MAKE) @@ -1220,10 +1260,13 @@ distclean: clean -del /f $(LIBDIR)\Devel\Peek.pm $(LIBDIR)\Devel\DProf.pm -del /f $(LIBDIR)\File\Glob.pm -del /f $(LIBDIR)\Storable.pm + -del /f $(LIBDIR)\Filter\Util\Call\Call.pm -if exist $(LIBDIR)\IO rmdir /s /q $(LIBDIR)\IO || rmdir /s $(LIBDIR)\IO -if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread || rmdir /s $(LIBDIR)\Thread -if exist $(LIBDIR)\B rmdir /s /q $(LIBDIR)\B || rmdir /s $(LIBDIR)\B -if exist $(LIBDIR)\Data rmdir /s /q $(LIBDIR)\Data || rmdir /s $(LIBDIR)\Data + -if exist $(LIBDIR)\Filter\Util\Call rmdir /s /q $(LIBDIR)\Filter\Util\Call || rmdir /s $(LIBDIR)\Filter + -if exist $(LIBDIR)\Filter\Util rmdir /s /q $(LIBDIR)\Filter\Util || rmdir /s $(LIBDIR)\Filter -del /f $(PODDIR)\*.html -del /f $(PODDIR)\*.bat -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph h2xs perldoc \ @@ -1249,7 +1292,7 @@ installhtml : doc $(RCOPY) html\*.* $(INST_HTML)\*.* inst_lib : $(CONFIGPM) - copy splittree.pl .. + copy splittree.pl .. $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR) $(RCOPY) ..\lib $(INST_LIB)\*.* @@ -1290,7 +1333,7 @@ test-wide-notty : test-prep set HARNESS_PERL_SWITCHES=-C && \ cd ..\t && $(PERLEXE) -I..\lib harness -clean : +clean : -@erase miniperlmain$(o) -@erase $(MINIPERL) -@erase perlglob$(o) @@ -1321,9 +1364,9 @@ ok: utils okfile: utils $(PERLEXE) -I..\lib ..\utils\perlbug -ok -s "(UNINSTALLED)" -F perl.ok - + nok: utils $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)" - + nokfile: utils $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)" -F perl.nok diff --git a/win32/perlhost.h b/win32/perlhost.h index 78074955b4..a260d0895d 100644 --- a/win32/perlhost.h +++ b/win32/perlhost.h @@ -35,6 +35,7 @@ extern int g_do_aspawn(void *vreally, void **vmark, void **vsp); class CPerlHost { public: + /* Constructors */ CPerlHost(void); CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, @@ -197,8 +198,13 @@ protected: DWORD m_dwEnvCount; LPSTR* m_lppEnvList; + static long num_hosts; +public: + inline int LastHost(void) { return num_hosts == 1L; }; }; +long CPerlHost::num_hosts = 0L; + #define STRUCT2PTR(x, y) (CPerlHost*)(((LPBYTE)x)-offsetof(CPerlHost, y)) @@ -522,65 +528,65 @@ struct IPerlEnv perlEnv = #define IPERL2HOST(x) IPerlStdIO2Host(x) /* PerlStdIO */ -PerlIO* +FILE* PerlStdIOStdin(struct IPerlStdIO* piPerl) { - return (PerlIO*)win32_stdin(); + return win32_stdin(); } -PerlIO* +FILE* PerlStdIOStdout(struct IPerlStdIO* piPerl) { - return (PerlIO*)win32_stdout(); + return win32_stdout(); } -PerlIO* +FILE* PerlStdIOStderr(struct IPerlStdIO* piPerl) { - return (PerlIO*)win32_stderr(); + return win32_stderr(); } -PerlIO* +FILE* PerlStdIOOpen(struct IPerlStdIO* piPerl, const char *path, const char *mode) { - return (PerlIO*)win32_fopen(path, mode); + return win32_fopen(path, mode); } int -PerlStdIOClose(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOClose(struct IPerlStdIO* piPerl, FILE* pf) { - return win32_fclose(((FILE*)pf)); + return win32_fclose((pf)); } int -PerlStdIOEof(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOEof(struct IPerlStdIO* piPerl, FILE* pf) { - return win32_feof((FILE*)pf); + return win32_feof(pf); } int -PerlStdIOError(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOError(struct IPerlStdIO* piPerl, FILE* pf) { - return win32_ferror((FILE*)pf); + return win32_ferror(pf); } void -PerlStdIOClearerr(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOClearerr(struct IPerlStdIO* piPerl, FILE* pf) { - win32_clearerr((FILE*)pf); + win32_clearerr(pf); } int -PerlStdIOGetc(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOGetc(struct IPerlStdIO* piPerl, FILE* pf) { - return win32_getc((FILE*)pf); + return win32_getc(pf); } char* -PerlStdIOGetBase(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOGetBase(struct IPerlStdIO* piPerl, FILE* pf) { #ifdef FILE_base - FILE *f = (FILE*)pf; + FILE *f = pf; return FILE_base(f); #else return Nullch; @@ -588,10 +594,10 @@ PerlStdIOGetBase(struct IPerlStdIO* piPerl, PerlIO* pf) } int -PerlStdIOGetBufsiz(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOGetBufsiz(struct IPerlStdIO* piPerl, FILE* pf) { #ifdef FILE_bufsiz - FILE *f = (FILE*)pf; + FILE *f = pf; return FILE_bufsiz(f); #else return (-1); @@ -599,10 +605,10 @@ PerlStdIOGetBufsiz(struct IPerlStdIO* piPerl, PerlIO* pf) } int -PerlStdIOGetCnt(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOGetCnt(struct IPerlStdIO* piPerl, FILE* pf) { #ifdef USE_STDIO_PTR - FILE *f = (FILE*)pf; + FILE *f = pf; return FILE_cnt(f); #else return (-1); @@ -610,10 +616,10 @@ PerlStdIOGetCnt(struct IPerlStdIO* piPerl, PerlIO* pf) } char* -PerlStdIOGetPtr(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOGetPtr(struct IPerlStdIO* piPerl, FILE* pf) { #ifdef USE_STDIO_PTR - FILE *f = (FILE*)pf; + FILE *f = pf; return FILE_ptr(f); #else return Nullch; @@ -621,150 +627,149 @@ PerlStdIOGetPtr(struct IPerlStdIO* piPerl, PerlIO* pf) } char* -PerlStdIOGets(struct IPerlStdIO* piPerl, PerlIO* pf, char* s, int n) +PerlStdIOGets(struct IPerlStdIO* piPerl, FILE* pf, char* s, int n) { - return win32_fgets(s, n, (FILE*)pf); + return win32_fgets(s, n, pf); } int -PerlStdIOPutc(struct IPerlStdIO* piPerl, PerlIO* pf, int c) +PerlStdIOPutc(struct IPerlStdIO* piPerl, FILE* pf, int c) { - return win32_fputc(c, (FILE*)pf); + return win32_fputc(c, pf); } int -PerlStdIOPuts(struct IPerlStdIO* piPerl, PerlIO* pf, const char *s) +PerlStdIOPuts(struct IPerlStdIO* piPerl, FILE* pf, const char *s) { - return win32_fputs(s, (FILE*)pf); + return win32_fputs(s, pf); } int -PerlStdIOFlush(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOFlush(struct IPerlStdIO* piPerl, FILE* pf) { - return win32_fflush((FILE*)pf); + return win32_fflush(pf); } int -PerlStdIOUngetc(struct IPerlStdIO* piPerl, PerlIO* pf,int c) +PerlStdIOUngetc(struct IPerlStdIO* piPerl,int c, FILE* pf) { - return win32_ungetc(c, (FILE*)pf); + return win32_ungetc(c, pf); } int -PerlStdIOFileno(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOFileno(struct IPerlStdIO* piPerl, FILE* pf) { - return win32_fileno((FILE*)pf); + return win32_fileno(pf); } -PerlIO* +FILE* PerlStdIOFdopen(struct IPerlStdIO* piPerl, int fd, const char *mode) { - return (PerlIO*)win32_fdopen(fd, mode); + return win32_fdopen(fd, mode); } -PerlIO* -PerlStdIOReopen(struct IPerlStdIO* piPerl, const char*path, const char*mode, PerlIO* pf) +FILE* +PerlStdIOReopen(struct IPerlStdIO* piPerl, const char*path, const char*mode, FILE* pf) { - return (PerlIO*)win32_freopen(path, mode, (FILE*)pf); + return win32_freopen(path, mode, (FILE*)pf); } SSize_t -PerlStdIORead(struct IPerlStdIO* piPerl, PerlIO* pf, void *buffer, Size_t size) +PerlStdIORead(struct IPerlStdIO* piPerl, void *buffer, Size_t size, Size_t count, FILE* pf) { - return win32_fread(buffer, 1, size, (FILE*)pf); + return win32_fread(buffer, size, count, pf); } SSize_t -PerlStdIOWrite(struct IPerlStdIO* piPerl, PerlIO* pf, const void *buffer, Size_t size) +PerlStdIOWrite(struct IPerlStdIO* piPerl, const void *buffer, Size_t size, Size_t count, FILE* pf) { - return win32_fwrite(buffer, 1, size, (FILE*)pf); + return win32_fwrite(buffer, size, count, pf); } void -PerlStdIOSetBuf(struct IPerlStdIO* piPerl, PerlIO* pf, char* buffer) +PerlStdIOSetBuf(struct IPerlStdIO* piPerl, FILE* pf, char* buffer) { - win32_setbuf((FILE*)pf, buffer); + win32_setbuf(pf, buffer); } int -PerlStdIOSetVBuf(struct IPerlStdIO* piPerl, PerlIO* pf, char* buffer, int type, Size_t size) +PerlStdIOSetVBuf(struct IPerlStdIO* piPerl, FILE* pf, char* buffer, int type, Size_t size) { - return win32_setvbuf((FILE*)pf, buffer, type, size); + return win32_setvbuf(pf, buffer, type, size); } void -PerlStdIOSetCnt(struct IPerlStdIO* piPerl, PerlIO* pf, int n) +PerlStdIOSetCnt(struct IPerlStdIO* piPerl, FILE* pf, int n) { #ifdef STDIO_CNT_LVALUE - FILE *f = (FILE*)pf; + FILE *f = pf; FILE_cnt(f) = n; #endif } void -PerlStdIOSetPtrCnt(struct IPerlStdIO* piPerl, PerlIO* pf, char * ptr, int n) +PerlStdIOSetPtr(struct IPerlStdIO* piPerl, FILE* pf, char * ptr) { #ifdef STDIO_PTR_LVALUE - FILE *f = (FILE*)pf; + FILE *f = pf; FILE_ptr(f) = ptr; - FILE_cnt(f) = n; #endif } void -PerlStdIOSetlinebuf(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOSetlinebuf(struct IPerlStdIO* piPerl, FILE* pf) { - win32_setvbuf((FILE*)pf, NULL, _IOLBF, 0); + win32_setvbuf(pf, NULL, _IOLBF, 0); } int -PerlStdIOPrintf(struct IPerlStdIO* piPerl, PerlIO* pf, const char *format,...) +PerlStdIOPrintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format,...) { va_list(arglist); va_start(arglist, format); - return win32_vfprintf((FILE*)pf, format, arglist); + return win32_vfprintf(pf, format, arglist); } int -PerlStdIOVprintf(struct IPerlStdIO* piPerl, PerlIO* pf, const char *format, va_list arglist) +PerlStdIOVprintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format, va_list arglist) { - return win32_vfprintf((FILE*)pf, format, arglist); + return win32_vfprintf(pf, format, arglist); } long -PerlStdIOTell(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOTell(struct IPerlStdIO* piPerl, FILE* pf) { - return win32_ftell((FILE*)pf); + return win32_ftell(pf); } int -PerlStdIOSeek(struct IPerlStdIO* piPerl, PerlIO* pf, off_t offset, int origin) +PerlStdIOSeek(struct IPerlStdIO* piPerl, FILE* pf, off_t offset, int origin) { - return win32_fseek((FILE*)pf, offset, origin); + return win32_fseek(pf, offset, origin); } void -PerlStdIORewind(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIORewind(struct IPerlStdIO* piPerl, FILE* pf) { - win32_rewind((FILE*)pf); + win32_rewind(pf); } -PerlIO* +FILE* PerlStdIOTmpfile(struct IPerlStdIO* piPerl) { - return (PerlIO*)win32_tmpfile(); + return win32_tmpfile(); } int -PerlStdIOGetpos(struct IPerlStdIO* piPerl, PerlIO* pf, Fpos_t *p) +PerlStdIOGetpos(struct IPerlStdIO* piPerl, FILE* pf, Fpos_t *p) { - return win32_fgetpos((FILE*)pf, p); + return win32_fgetpos(pf, p); } int -PerlStdIOSetpos(struct IPerlStdIO* piPerl, PerlIO* pf, const Fpos_t *p) +PerlStdIOSetpos(struct IPerlStdIO* piPerl, FILE* pf, const Fpos_t *p) { - return win32_fsetpos((FILE*)pf, p); + return win32_fsetpos(pf, p); } void PerlStdIOInit(struct IPerlStdIO* piPerl) @@ -789,39 +794,39 @@ PerlStdIOGetOSfhandle(struct IPerlStdIO* piPerl, int filenum) return win32_get_osfhandle(filenum); } -PerlIO* -PerlStdIOFdupopen(struct IPerlStdIO* piPerl, PerlIO* pf) +FILE* +PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf) { - PerlIO* pfdup; + FILE* pfdup; fpos_t pos; char mode[3]; - int fileno = win32_dup(win32_fileno((FILE*)pf)); + int fileno = win32_dup(win32_fileno(pf)); /* open the file in the same mode */ #ifdef __BORLANDC__ - if(((FILE*)pf)->flags & _F_READ) { + if((pf)->flags & _F_READ) { mode[0] = 'r'; mode[1] = 0; } - else if(((FILE*)pf)->flags & _F_WRIT) { + else if((pf)->flags & _F_WRIT) { mode[0] = 'a'; mode[1] = 0; } - else if(((FILE*)pf)->flags & _F_RDWR) { + else if((pf)->flags & _F_RDWR) { mode[0] = 'r'; mode[1] = '+'; mode[2] = 0; } #else - if(((FILE*)pf)->_flag & _IOREAD) { + if((pf)->_flag & _IOREAD) { mode[0] = 'r'; mode[1] = 0; } - else if(((FILE*)pf)->_flag & _IOWRT) { + else if((pf)->_flag & _IOWRT) { mode[0] = 'a'; mode[1] = 0; } - else if(((FILE*)pf)->_flag & _IORW) { + else if((pf)->_flag & _IORW) { mode[0] = 'r'; mode[1] = '+'; mode[2] = 0; @@ -832,11 +837,11 @@ PerlStdIOFdupopen(struct IPerlStdIO* piPerl, PerlIO* pf) * file descriptor so binmode files will be handled * correctly */ - pfdup = (PerlIO*)win32_fdopen(fileno, mode); + pfdup = win32_fdopen(fileno, mode); /* move the file pointer to the same position */ - if (!fgetpos((FILE*)pf, &pos)) { - fsetpos((FILE*)pfdup, &pos); + if (!fgetpos(pf, &pos)) { + fsetpos(pfdup, &pos); } return pfdup; } @@ -869,7 +874,7 @@ struct IPerlStdIO perlStdIO = PerlStdIOSetBuf, PerlStdIOSetVBuf, PerlStdIOSetCnt, - PerlStdIOSetPtrCnt, + PerlStdIOSetPtr, PerlStdIOSetlinebuf, PerlStdIOPrintf, PerlStdIOVprintf, @@ -1586,13 +1591,13 @@ PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode) { dTHXo; PERL_FLUSHALL_FOR_CHILD; - return (PerlIO*)win32_popen(command, mode); + return win32_popen(command, mode); } int PerlProcPclose(struct IPerlProc* piPerl, PerlIO *stream) { - return win32_pclose((FILE*)stream); + return win32_pclose(stream); } int @@ -1845,6 +1850,14 @@ PerlProcASpawn(struct IPerlProc* piPerl, void *vreally, void **vmark, void **vsp return do_aspawn(vreally, vmark, vsp); } +int +PerlProcLastHost(struct IPerlProc* piPerl) +{ + dTHXo; + CPerlHost *h = (CPerlHost*)w32_internal_host; + return h->LastHost(); +} + struct IPerlProc perlProc = { PerlProcAbort, @@ -1880,6 +1893,7 @@ struct IPerlProc perlProc = PerlProcSpawn, PerlProcSpawnvp, PerlProcASpawn, + PerlProcLastHost }; @@ -1889,6 +1903,8 @@ struct IPerlProc perlProc = CPerlHost::CPerlHost(void) { + /* Construct a host from scratch */ + InterlockedIncrement(&num_hosts); m_pvDir = new VDir(); m_pVMem = new VMem(); m_pVMemShared = new VMem(); @@ -1937,6 +1953,7 @@ CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, struct IPerlDir** ppDir, struct IPerlSock** ppSock, struct IPerlProc** ppProc) { + InterlockedIncrement(&num_hosts); m_pvDir = new VDir(0); m_pVMem = new VMem(); m_pVMemShared = new VMem(); @@ -1971,6 +1988,8 @@ CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, CPerlHost::CPerlHost(CPerlHost& host) { + /* Construct a host from another host */ + InterlockedIncrement(&num_hosts); m_pVMem = new VMem(); m_pVMemShared = host.GetMemShared(); m_pVMemParse = host.GetMemParse(); @@ -2011,6 +2030,7 @@ CPerlHost::CPerlHost(CPerlHost& host) CPerlHost::~CPerlHost(void) { // Reset(); + InterlockedDecrement(&num_hosts); delete m_pvDir; m_pVMemParse->Release(); m_pVMemShared->Release(); diff --git a/win32/perllib.c b/win32/perllib.c index e2b245d84f..87b79c031d 100644 --- a/win32/perllib.c +++ b/win32/perllib.c @@ -1,8 +1,7 @@ /* * "The Road goes ever on and on, down from the door where it began." */ - - +#define PERLIO_NOT_STDIO 0 #include "EXTERN.h" #include "perl.h" @@ -371,6 +370,12 @@ DllMain(HANDLE hModule, /* DLL module handle */ * process termination or call to FreeLibrary. */ case DLL_PROCESS_DETACH: + /* As long as we use TerminateProcess()/TerminateThread() etc. for mimicing kill() + anything here had better be harmless if: + A. Not called at all. + B. Called after memory allocation for Heap has been forcibly removed by OS. + PerlIO_cleanup() was done here but fails (B). + */ EndSockets(); #if defined(USE_THREADS) || defined(USE_ITHREADS) if (PL_curinterp) diff --git a/win32/vdir.h b/win32/vdir.h index 37cb4a580e..af769f1549 100644 --- a/win32/vdir.h +++ b/win32/vdir.h @@ -393,7 +393,7 @@ char *VDir::MapPathA(const char *pInName) /* has drive letter */ if (IsPathSep(pInName[2])) { /* absolute with drive letter */ - strcpy(szLocalBufferA, pInName); + DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA); } else { /* relative path with drive letter */ @@ -409,15 +409,14 @@ char *VDir::MapPathA(const char *pInName) /* no drive letter */ if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) { /* UNC name */ - strcpy(szLocalBufferA, pInName); + DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA); } else { strcpy(szBuffer, GetDefaultDirA()); if (IsPathSep(pInName[0])) { /* absolute path */ - szLocalBufferA[0] = szBuffer[0]; - szLocalBufferA[1] = szBuffer[1]; - strcpy(&szLocalBufferA[2], pInName); + strcpy(&szBuffer[2], pInName); + DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA); } else { /* relative path */ @@ -620,7 +619,7 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName) /* has drive letter */ if (IsPathSep(pInName[2])) { /* absolute with drive letter */ - wcscpy(szLocalBufferW, pInName); + DoGetFullPathNameW((WCHAR*)pInName, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW); } else { /* relative path with drive letter */ @@ -636,15 +635,14 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName) /* no drive letter */ if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) { /* UNC name */ - wcscpy(szLocalBufferW, pInName); + DoGetFullPathNameW((WCHAR*)pInName, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW); } else { wcscpy(szBuffer, GetDefaultDirW()); if (IsPathSep(pInName[0])) { /* absolute path */ - szLocalBufferW[0] = szBuffer[0]; - szLocalBufferW[1] = szBuffer[1]; - wcscpy(&szLocalBufferW[2], pInName); + wcscpy(&szBuffer[2], pInName); + DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW); } else { /* relative path */ diff --git a/win32/win32.c b/win32/win32.c index 2b31878a52..ba445a488b 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -581,7 +581,6 @@ do_aspawn(void *vreally, void **vmark, void **vsp) } else { if (status < 0) { - dTHR; if (ckWARN(WARN_EXEC)) Perl_warner(aTHX_ WARN_EXEC, "Can't spawn \"%s\": %s", argv[0], strerror(errno)); status = 255 * 256; @@ -674,7 +673,6 @@ do_spawn2(char *cmd, int exectype) } else { if (status < 0) { - dTHR; if (ckWARN(WARN_EXEC)) Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s", (exectype == EXECF_EXEC ? "exec" : "spawn"), @@ -977,6 +975,31 @@ chown(const char *path, uid_t owner, gid_t group) return 0; } +/* + * XXX this needs strengthening (for PerlIO) + * -- BKS, 11-11-200 +*/ +int mkstemp(const char *path) +{ + dTHX; + char buf[MAX_PATH+1]; + int i = 0, fd = -1; + +retry: + if (i++ > 10) { /* give up */ + errno = ENOENT; + return -1; + } + if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) { + errno = ENOENT; + return -1; + } + fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600); + if (fd == -1) + goto retry; + return fd; +} + static long find_pid(int pid) { @@ -1850,7 +1873,6 @@ win32_crypt(const char *txt, const char *salt) { dTHXo; #ifdef HAVE_DES_FCRYPT - dTHR; return des_fcrypt(txt, salt, w32_crypt_buffer); #else Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); @@ -2106,7 +2128,6 @@ win32_str_os_error(void *sv, DWORD dwErr) } } - DllExport int win32_fprintf(FILE *fp, const char *format, ...) { @@ -2329,7 +2350,7 @@ win32_fstat(int fd,struct stat *sbufptr) } return rc; #else - return fstat(fd,sbufptr); + return my_fstat(fd,sbufptr); #endif } @@ -2341,9 +2362,11 @@ win32_pipe(int *pfd, unsigned int size, int mode) /* * a popen() clone that respects PERL5SHELL + * + * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000 */ -DllExport FILE* +DllExport PerlIO* win32_popen(const char *command, const char *mode) { #ifdef USE_RTL_POPEN @@ -2417,7 +2440,7 @@ win32_popen(const char *command, const char *mode) } /* we have an fd, return a file stream */ - return (win32_fdopen(p[parent], (char *)mode)); + return (PerlIO_fdopen(p[parent], (char *)mode)); cleanup: /* we don't need to check for errors here */ @@ -2437,7 +2460,7 @@ cleanup: */ DllExport int -win32_pclose(FILE *pf) +win32_pclose(PerlIO *pf) { #ifdef USE_RTL_POPEN return _pclose(pf); @@ -2447,7 +2470,7 @@ win32_pclose(FILE *pf) SV *sv; LOCK_FDPID_MUTEX; - sv = *av_fetch(w32_fdpid, win32_fileno(pf), TRUE); + sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE); if (SvIOK(sv)) childpid = SvIVX(sv); @@ -2459,7 +2482,11 @@ win32_pclose(FILE *pf) return -1; } - win32_fclose(pf); +#ifdef USE_PERLIO + PerlIO_close(pf); +#else + fclose(pf); +#endif SvIVX(sv) = 0; UNLOCK_FDPID_MUTEX; @@ -2721,10 +2748,13 @@ win32_open(const char *path, int flag, ...) return open(PerlDir_mapA(path), flag, pmode); } +/* close() that understands socket */ +extern int my_close(int); /* in win32sck.c */ + DllExport int win32_close(int fd) { - return close(fd); + return my_close(fd); } DllExport int @@ -3838,6 +3868,8 @@ XS(w32_Spawn) { dXSARGS; char *cmd, *args; + void *env; + char *dir; PROCESS_INFORMATION stProcInfo; STARTUPINFO stStartInfo; BOOL bSuccess = FALSE; @@ -3848,6 +3880,9 @@ XS(w32_Spawn) cmd = SvPV_nolen(ST(0)); args = SvPV_nolen(ST(1)); + env = PerlEnv_get_childenv(); + dir = PerlEnv_get_childdir(); + memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */ stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */ stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */ @@ -3860,8 +3895,8 @@ XS(w32_Spawn) NULL, /* Default thread security */ FALSE, /* Must be TRUE to use std handles */ NORMAL_PRIORITY_CLASS, /* No special scheduling */ - NULL, /* Inherit our environment block */ - NULL, /* Inherit our currrent directory */ + env, /* Inherit our environment block */ + dir, /* Inherit our currrent directory */ &stStartInfo, /* -> Startup info */ &stProcInfo)) /* <- Process info (if OK) */ { @@ -3872,6 +3907,8 @@ XS(w32_Spawn) CloseHandle(stProcInfo.hThread);/* library source code does this. */ bSuccess = TRUE; } + PerlEnv_free_childenv(env); + PerlEnv_free_childdir(dir); XSRETURN_IV(bSuccess); } diff --git a/win32/win32.h b/win32/win32.h index d9ffbfe1a1..1040ef1c1a 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -302,6 +302,7 @@ extern int kill(int pid, int sig); extern void *sbrk(int need); extern char * getlogin(void); extern int chown(const char *p, uid_t o, gid_t g); +extern int mkstemp(const char *path); #undef Stat #define Stat win32_stat @@ -343,6 +344,7 @@ DllExport void win32_get_child_IO(child_IO_table* ptr); extern FILE * my_fdopen(int, char *); #endif extern int my_fclose(FILE *); +extern int my_fstat(int fd, struct stat *sbufptr); extern int do_aspawn(void *really, void **mark, void **sp); extern int do_spawn(char *cmd); extern int do_spawn_nowait(char *cmd); @@ -543,11 +545,17 @@ EXTERN_C _CRTIMP ioinfo* __pioinfo[]; #endif #endif +#define PERLIO_NOT_STDIO 0 + +#include "perlio.h" + /* * This provides a layer of functions and macros to ensure extensions will * get to use the same RTL functions as the core. */ #include "win32iop.h" +#define EXEC_ARGV_CAST(x) ((const char *const *) x) + #endif /* _INC_WIN32_PERL5 */ diff --git a/win32/win32iop.h b/win32/win32iop.h index d7c2ac4f74..5629babe83 100644 --- a/win32/win32iop.h +++ b/win32/win32iop.h @@ -72,8 +72,8 @@ DllExport void win32_abort(void); DllExport int win32_fstat(int fd,struct stat *sbufptr); DllExport int win32_stat(const char *name,struct stat *sbufptr); DllExport int win32_pipe( int *phandles, unsigned int psize, int textmode ); -DllExport FILE* win32_popen( const char *command, const char *mode ); -DllExport int win32_pclose( FILE *pf); +DllExport PerlIO* win32_popen( const char *command, const char *mode ); +DllExport int win32_pclose( PerlIO *pf); DllExport int win32_rename( const char *oname, const char *newname); DllExport int win32_setmode( int fd, int mode); DllExport long win32_lseek( int fd, long offset, int origin); diff --git a/win32/win32sck.c b/win32/win32sck.c index 3b81d8bcae..d169db6d9e 100644 --- a/win32/win32sck.c +++ b/win32/win32sck.c @@ -11,6 +11,7 @@ #define WIN32IO_IS_STDIO #define WIN32SCK_IS_STDSCK #define WIN32_LEAN_AND_MEAN +#define PERLIO_NOT_STDIO 0 #ifdef __GNUC__ #define Win32_Winsock #endif @@ -418,6 +419,41 @@ win32_socket(int af, int type, int protocol) return s; } +/* + * close RTL fd while respecting sockets + * added as temporary measure until PerlIO has real + * Win32 native layer + * -- BKS, 11-11-2000 +*/ + +int my_close(int fd) +{ + int osf; + if (!wsock_started) /* No WinSock? */ + return(close(fd)); /* Then not a socket. */ + osf = TO_SOCKET(fd);/* Get it now before it's gone! */ + if (osf != -1) { + int err; + err = closesocket(osf); + if (err == 0) { +#if defined(USE_FIXED_OSFHANDLE) || defined(PERL_MSVCRT_READFIX) + _set_osfhnd(fd, INVALID_HANDLE_VALUE); +#endif + (void)close(fd); /* handle already closed, ignore error */ + return 0; + } + else if (err == SOCKET_ERROR) { + err = WSAGetLastError(); + if (err != WSAENOTSOCK) { + (void)close(fd); + errno = err; + return EOF; + } + } + } + return close(fd); +} + #undef fclose int my_fclose (FILE *pf) @@ -425,14 +461,14 @@ my_fclose (FILE *pf) int osf; if (!wsock_started) /* No WinSock? */ return(fclose(pf)); /* Then not a socket. */ - osf = TO_SOCKET(fileno(pf));/* Get it now before it's gone! */ + osf = TO_SOCKET(win32_fileno(pf));/* Get it now before it's gone! */ if (osf != -1) { int err; win32_fflush(pf); err = closesocket(osf); if (err == 0) { #if defined(USE_FIXED_OSFHANDLE) || defined(PERL_MSVCRT_READFIX) - _set_osfhnd(fileno(pf), INVALID_HANDLE_VALUE); + _set_osfhnd(win32_fileno(pf), INVALID_HANDLE_VALUE); #endif (void)fclose(pf); /* handle already closed, ignore error */ return 0; @@ -449,6 +485,41 @@ my_fclose (FILE *pf) return fclose(pf); } +#undef fstat +int +my_fstat(int fd, struct stat *sbufptr) +{ + /* This fixes a bug in fstat() on Windows 9x. fstat() uses the + * GetFileType() win32 syscall, which will fail on Windows 9x. + * So if we recognize a socket on Windows 9x, we return the + * same results as on Windows NT/2000. + * XXX this should be extended further to set S_IFSOCK on + * sbufptr->st_mode. + */ + int osf; + if (!wsock_started || IsWinNT()) + return fstat(fd, sbufptr); + + osf = TO_SOCKET(fd); + if (osf != -1) { + char sockbuf[256]; + int optlen = sizeof(sockbuf); + int retval; + + retval = getsockopt((SOCKET)osf, SOL_SOCKET, SO_TYPE, sockbuf, &optlen); + if (retval != SOCKET_ERROR || WSAGetLastError() != WSAENOTSOCK) { + sbufptr->st_mode = _S_IFIFO; + sbufptr->st_rdev = sbufptr->st_dev = (dev_t)fd; + sbufptr->st_nlink = 1; + sbufptr->st_uid = sbufptr->st_gid = sbufptr->st_ino = 0; + sbufptr->st_atime = sbufptr->st_mtime = sbufptr->st_ctime = 0; + sbufptr->st_size = (off_t)0; + return 0; + } + } + return fstat(fd, sbufptr); +} + struct hostent * win32_gethostbyaddr(const char *addr, int len, int type) { diff --git a/win32/win32thread.h b/win32/win32thread.h index a52118b48e..1f8840c0c0 100644 --- a/win32/win32thread.h +++ b/win32/win32thread.h @@ -170,7 +170,7 @@ END_EXTERN_C #define ALLOC_THREAD_KEY \ STMT_START { \ if ((PL_thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES) { \ - fprintf(stderr,"panic: TlsAlloc"); \ + PerlIO_printf(PerlIO_stderr(),"panic: TlsAlloc"); \ exit(1); \ } \ } STMT_END diff --git a/x2p/EXTERN.h b/x2p/EXTERN.h index cd1a4112ae..80fffb46e4 100644 --- a/x2p/EXTERN.h +++ b/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/x2p/INTERN.h b/x2p/INTERN.h index ac1d57ab05..2303ea3ac1 100644 --- a/x2p/INTERN.h +++ b/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. @@ -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. @@ -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. @@ -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/x2p/find2perl.PL b/x2p/find2perl.PL index 25d0135528..4d74d06e1b 100644 --- a/x2p/find2perl.PL +++ b/x2p/find2perl.PL @@ -37,6 +37,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 +58,7 @@ my @roots = (); while ($ARGV[0] =~ /^[^-!(]/) { push(@roots, shift); } -@roots = ('.') unless @roots; +@roots = (curdir()) unless @roots; for (@roots) { $_ = "e($_) } my $roots = join(', ', @roots); @@ -674,6 +675,7 @@ sub n { sub quote { my $string = shift; + $string =~ s/\\/\\\\/g; $string =~ s/'/\\'/g; "'$string'"; } diff --git a/x2p/hash.c b/x2p/hash.c index 77b9ad8fd1..a266403efe 100644 --- a/x2p/hash.c +++ b/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/x2p/hash.h b/x2p/hash.h index 377bfd2db0..7b2b668492 100644 --- a/x2p/hash.h +++ b/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/x2p/proto.h b/x2p/proto.h index 85d749616a..e57b4fc30e 100644 --- a/x2p/proto.h +++ b/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. @@ -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. @@ -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/x2p/util.c b/x2p/util.c index d43a1eb723..ab24808d73 100644 --- a/x2p/util.c +++ b/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/x2p/util.h b/x2p/util.h index 34138c7da1..c5ebcec7df 100644 --- a/x2p/util.h +++ b/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/x2p/walk.c b/x2p/walk.c index 3344688117..59ac8a9f3d 100644 --- a/x2p/walk.c +++ b/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. |