-# 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>
[ 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
# $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
[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
cpprun=''
cppstdin=''
crosscompile=''
+d__fwalk=''
d_access=''
d_accessx=''
d_alarm=''
d_fchmod=''
d_fchown=''
d_fcntl=''
+d_fcntl_can_lock=''
d_fd_macros=''
d_fd_set=''
d_fds_bits=''
d_fseeko=''
d_fsetpos=''
d_fstatfs=''
+d_fsync=''
d_ftello=''
d_ftime=''
d_gettimeod=''
d_getnbyname=''
d_getnent=''
d_getnetprotos=''
+d_getpagsz=''
d_getpent=''
d_getpgid=''
d_getpgrp2=''
d_safebcpy=''
d_safemcpy=''
d_sanemcmp=''
+d_sbrkproto=''
d_select=''
d_sem=''
d_semctl=''
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=''
d_strtol=''
d_strtold=''
d_strtoll=''
+d_strtoq=''
d_strtoul=''
d_strtoull=''
d_strtouq=''
intsize=''
longsize=''
shortsize=''
+issymlink=''
libc=''
ldlibpthname=''
libperl=''
eagain=''
o_nonblock=''
rd_nodata=''
+need_va_copy=''
netdb_hlen_type=''
netdb_host_type=''
netdb_name_type=''
*/*) src=`echo $0 | sed -e 's%/[^/][^/]*$%%'`
case "$src" in
/*) ;;
+ .) ;;
*) src=`cd ../$src && pwd` ;;
esac
;;
*)
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
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
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"
esac
;;
next*) osname=next ;;
- NonStop-UX) osname=nonstopux ;;
+ nonstop-ux) osname=nonstopux ;;
POSIX-BC | posix-bc ) osname=posix-bc
osvers="$3"
;;
;;
esac
test "$override" && . ./optdef.sh
-myuname="$newmyuname"
: Restore computed paths
for file in $loclist $trylist; do
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..."
case "$fn" in
*\(*)
- expr $fn : '.*(\(.*\)).*' | tr ',' $trnl >getfile.ok
+ expr $fn : '.*(\(.*\)).*' | $tr ',' $trnl >getfile.ok
fn=`echo $fn | sed 's/(.*)//'`
;;
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
set usesocks
eval $setvar
+case "$usesocks" in
+$define|true|[yY]*) useperlio="$define";;
+esac
+
: Looking for optional libraries
echo " "
echo "Checking for optional libraries..." >&4
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 ;;
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
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:
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
. ./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
'')
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
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
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=''
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
;;
esac
+: see if _fwalk exists
+set fwalk d__fwalk
+eval $inlibc
+
: Initialize h_fcntl
h_fcntl=false
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
eval $inlibc
+: see if fsync exists
+set fsync d_fsync
+eval $inlibc
+
: see if ftello exists
set ftello d_ftello
eval $inlibc
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
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
;;
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 " "
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
: 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)'
'') 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
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
;;
esac
-: see if strtoul exists
-set strtoul d_strtoul
+: see if strtoq exists
+set strtoq d_strtoq
eval $inlibc
-: see if strtoull exists
-set strtoull d_strtoull
+: see if strtoul exists
+set strtoul d_strtoul
eval $inlibc
-case "$d_longlong-$d_strtoull" in
-"$define-$define")
+case "$d_strtoul" in
+"$define")
$cat <<EOM
-Checking whether your strtoull() works okay...
+Checking whether your strtoul() works okay...
EOM
$cat >try.c <<'EOCP'
#include <errno.h>
-#ifdef __hpux
-#define strtoull __strtoull
-#endif
#include <stdio.h>
-extern unsigned long long int strtoull(char *s, char **, int);
+extern unsigned long int strtoul(char *s, char **, int);
+static int bad = 0;
+void check(char *s, unsigned long eul, int een) {
+ unsigned long gul;
+ errno = 0;
+ gul = strtoul(s, 0, 10);
+ if (!((gul == eul) && (errno == een)))
+ bad++;
+}
+int main() {
+ check(" 1", 1L, 0);
+ check(" 0", 0L, 0);
+EOCP
+ case "$longsize" in
+ 8)
+ $cat >>try.c <<'EOCP'
+ check("18446744073709551615", 18446744073709551615UL, 0);
+ check("18446744073709551616", 18446744073709551615UL, ERANGE);
+#if 0 /* strtoul() for /^-/ strings is undefined. */
+ check("-1", 18446744073709551615UL, 0);
+ check("-18446744073709551614", 2, 0);
+ check("-18446744073709551615", 1, 0);
+ check("-18446744073709551616", 18446744073709551615UL, ERANGE);
+ check("-18446744073709551617", 18446744073709551615UL, ERANGE);
+#endif
+EOCP
+ ;;
+ 4)
+ $cat >>try.c <<'EOCP'
+ check("4294967295", 4294967295UL, 0);
+ check("4294967296", 4294967295UL, ERANGE);
+#if 0 /* strtoul() for /^-/ strings is undefined. */
+ check("-1", 4294967295UL, 0);
+ check("-4294967294", 2, 0);
+ check("-4294967295", 1, 0);
+ check("-4294967296", 4294967295UL, ERANGE);
+ check("-4294967297", 4294967295UL, ERANGE);
+#endif
+EOCP
+ ;;
+ *)
+: Should we write these tests to be more portable by sprintf-ing
+: ~0 and then manipulating that char string as input for strtol?
+ ;;
+ esac
+ $cat >>try.c <<'EOCP'
+ if (!bad)
+ printf("ok\n");
+ return 0;
+}
+EOCP
+ set try
+ if eval $compile; then
+ case "`./try`" in
+ ok) echo "Your strtoul() seems to be working okay." ;;
+ *) cat <<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
+
+case "$d_longlong-$d_strtoull" in
+"$define-$define")
+ $cat <<EOM
+Checking whether your strtoull() works okay...
+EOM
+ $cat >try.c <<'EOCP'
+#include <errno.h>
+#ifdef __hpux
+#define strtoull __strtoull
+#endif
+#include <stdio.h>
+extern unsigned long long int strtoull(char *s, char **, int);
static int bad = 0;
int check(char *s, long long eull, int een) {
long long gull;
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");
}
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
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
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
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")
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"
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
: 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 " "
./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
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
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'
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'
d_fsetpos='$d_fsetpos'
d_fstatfs='$d_fstatfs'
d_fstatvfs='$d_fstatvfs'
+d_fsync='$d_fsync'
d_ftello='$d_ftello'
d_ftime='$d_ftime'
d_getcwd='$d_getcwd'
d_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'
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'
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'
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'
installvendorbin='$installvendorbin'
installvendorlib='$installvendorlib'
intsize='$intsize'
+issymlink='$issymlink'
ivdformat='$ivdformat'
ivsize='$ivsize'
ivtype='$ivtype'
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'
: 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
/* 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.
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
=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.
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
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,
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:
/* 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.
+++ /dev/null
-# 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
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
Porting/patching.pod How to report changes made to Perl
Porting/patchls Flexible patch file listing utility
Porting/pumpkin.pod Guidelines and hints for Perl maintainers
+Porting/repository.pod How to use the Perl repository
README The Instructions
README.Y2K Notes about Year 2000 concerns
README.aix Notes about AIX port
README.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
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
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
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
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
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
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
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
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)
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
lib/File/Find.pm Routines to do a find
lib/File/Path.pm Do things like `mkdir -p' and `rm -r'
lib/File/Spec.pm portable operations on file names
+lib/File/Spec/Epoc.pm portable operations on EPOC file names
lib/File/Spec/Functions.pm Function interface to File::Spec object methods
lib/File/Spec/Mac.pm portable operations on Mac file names
lib/File/Spec/OS2.pm portable operations on OS2 file names
lib/File/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)
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
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
lib/unicode/Is/BidiRLO.pl Unicode character database
lib/unicode/Is/BidiS.pl Unicode character database
lib/unicode/Is/BidiWS.pl Unicode character database
+lib/unicode/Is/Blank.pl Unicode character database
lib/unicode/Is/C.pl Unicode character database
lib/unicode/Is/Cc.pl Unicode character database
lib/unicode/Is/Cf.pl Unicode character database
lib/unicode/Is/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
lib/unicode/Is/Sm.pl Unicode character database
lib/unicode/Is/So.pl Unicode character database
lib/unicode/Is/Space.pl Unicode character database
+lib/unicode/Is/SpacePerl.pl Unicode character database
lib/unicode/Is/SylA.pl Unicode character database
lib/unicode/Is/SylAA.pl Unicode character database
lib/unicode/Is/SylAAI.pl Unicode character database
lib/unicode/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
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
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
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
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
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
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
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
t/lib/textwrap.t See if Text::Wrap::wrap works
t/lib/thr5005.t Test 5.005-style threading (skipped if no use5005threads)
t/lib/tie-push.t Test for Tie::Array
+t/lib/tie-refhash.t Test for Tie::RefHash and Tie::RefHash::Nestable
+t/lib/tie-splice.t Test for Tie::Array::SPLICE
t/lib/tie-stdarray.t Test for Tie::StdArray
t/lib/tie-stdhandle.t Test for Tie::StdHandle
t/lib/tie-stdpush.t Test for Tie::StdArray
+t/lib/tie-substrhash.t Test for Tie::SubstrHash
t/lib/timelocal.t See if Time::Local works
t/lib/trig.t See if Math::Trig works
t/op/64bitint.t See if 64 bit integers work
t/op/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
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
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
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
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
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
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
mallocsrc = $mallocsrc
mallocobj = $mallocobj
LNS = $lns
+CPS = $cp -f
RMS = rm -f
ranlib = $ranlib
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
!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
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
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
# 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 \
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
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
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
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
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.
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
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.
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
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
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.
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
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.
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.
# 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
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=''
d_PRIu64='define'
d_PRIx64='define'
d_SCNfldbl='define'
+d__fwalk='undef'
d_access='define'
d_accessx='undef'
d_alarm='define'
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'
d_fsetpos='define'
d_fstatfs='define'
d_fstatvfs='define'
+d_fsync='define'
d_ftello='undef'
d_ftime='undef'
d_getcwd='define'
d_getnbyname='define'
d_getnent='define'
d_getnetprotos='define'
+d_getpagsz='define'
d_getpbyname='define'
d_getpbynumber='define'
d_getpent='define'
d_safebcpy='define'
d_safemcpy='undef'
d_sanemcmp='define'
+d_sbrkproto='define'
d_sched_yield='define'
d_scm_rights='define'
d_seekdir='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'
d_strtol='define'
d_strtold='undef'
d_strtoll='undef'
+d_strtoq='undef'
d_strtoul='define'
d_strtoull='undef'
d_strtouq='undef'
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'
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=''
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'
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 *'
/*
* 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
*/
*/
#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.
*/
#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.
#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.
*/
#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>
*/
#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).
*/
#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.
*/
#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.
*/
#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.
* 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:
*/
/*#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.
#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().
*/
#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.
#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
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);
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}) {
}
}
}
- 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
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;
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.
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,
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
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
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:
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
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
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.
=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
=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
--- /dev/null
+=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
+
+
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
=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.
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.
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
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
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
... ?
=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
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
=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>).
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
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.)
=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:
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
=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
make install
-=head1 AUTHOR
+=head1 AUTHORS
Norbert Pueschel, pueschel@imsdd.meb.uni-bonn.de
+Jan-Erik Karlsson, trg@privat.utfors.se
=head1 SEE ALSO
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
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
=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
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
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>,
=head1 HISTORY
-Last updated: 15 August 2000
+Last updated: 9 November 2000
=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
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
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.
tests, don't forget to use
set LFN=y
- set FNCASE=y
+ set FNCASE=y
before unpacking the archive.
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!)
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
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
-=====================================================================
-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/
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.
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
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
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
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
=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
-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
+
- Threads
AUTHOR
SEE ALSO
-
+
=head1 DESCRIPTION
=head2 Target
=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
=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 *
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.
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.
Most notable problems:
-=over
+=over 4
=item C<COND_WAIT>
+
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.
=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
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
=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.
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).
make
make test
-if everything looks ok then:
+if everything looks ok (see the next section for test/IVP diagnosis) then:
make install
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
+
--- /dev/null
+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 $
-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
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
=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.
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"
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
=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.
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
=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
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
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>.
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%
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:
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
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
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
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
=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
=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
Win9x support was added in 5.6 (Benjamin Stuhl).
-Last updated: 22 March 2000
+Last updated: 22 November 2000
=cut
/* 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.
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)
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;
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;
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
register I32 i;
register SV **ary;
MAGIC* mg;
+ I32 slide;
if (!av || num <= 0)
return;
}
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);
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);
}
}
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
/* 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.
void
byterun(pTHXo_ register struct byteloader_state *bstate)
{
- dTHR;
register int insn;
U32 ix;
SV *specialsv_list[6];
*/
#$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.
*/
#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.
#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.
*/
#$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>
*/
#$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).
*/
#$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.
*/
#$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.
*/
#$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.
* 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:
*/
#$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.
#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().
*/
#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.
#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!
$ 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
$ 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
$ 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"
$ 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."
$!
$ 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
$ 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
$ 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
$ 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
$ 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
$ WC "cpprun='" + cpprun + "'"
$ WC "cppstdin='" + cppstdin + "'"
$ WC "crosscompile='undef'"
+$ WC "d__fwalk='undef'"
$ WC "d_Gconvert='my_gconvert(x,n,t,b)'"
$ WC "d_PRId64='" + d_PRId64 + "'"
$ WC "d_PRIEldbl='" + d_PRIEUldbl + "'"
$ WC "d_fchmod='undef'"
$ WC "d_fchown='undef'"
$ WC "d_fcntl='" + d_fcntl + "'"
+$ WC "d_fcntl_can_lock='" + d_fcntl_can_lock + "'"
$ WC "d_fd_set='" + d_fd_set + "'"
$ WC "d_fgetpos='define'"
$ WC "d_flexfnam='define'"
$ WC "d_fsetpos='define'"
$ WC "d_fstatfs='undef'"
$ WC "d_fstatvfs='undef'"
+$ WC "d_fsync='undef'"
$ WC "d_ftello='undef'"
$ WC "d_getcwd='undef'"
$ WC "d_getespwnam='undef'"
$ WC "d_getnbyname='" + d_getnbyname + "'"
$ WC "d_getnent='" + d_getnent + "'"
$ WC "d_getnetprotos='" + d_getnetprotos + "'"
+$ WC "d_getpagsz='undef'"
$ WC "d_getpbyname='" + d_getpbyname + "'"
$ WC "d_getpbynumber='" + d_getpbynumber + "'"
$ WC "d_getpent='" + d_getpent + "'"
$ WC "d_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'"
$ WC "d_statfsflags='undef'"
$ WC "d_stdio_cnt_lval='" + d_stdio_cnt_lval + "'"
$ WC "d_stdio_ptr_lval='" + d_stdio_ptr_lval + "'"
+$ WC "d_stdio_ptr_lval_sets_cnt='" + d_stdio_ptr_lval_sets_cnt + "'"
+$ WC "d_stdio_ptr_lval_nochange_cnt='" + d_stdio_ptr_lval_nochange_cnt + "'"
$ WC "d_stdio_stream_array='undef'"
$ WC "d_stdiobase='" + d_stdiobase + "'"
$ WC "d_stdstdio='" + d_stdstdio + "'"
$ WC "d_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 + "'"
$ WC "dynamic_ext='" + extensions + "'"
$ WC "eagain=' '"
$ WC "ebcdic='undef'"
+$ WC "embedmymalloc='" + mymalloc + "'"
$ WC "eunicefix=':'"
$ WC "exe_ext='" + exe_ext + "'"
$ WC "extensions='" + extensions + "'"
$ 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 + "'"
$ 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)'"
$ WC "use5005threads='" + use5005threads + "'"
$ WC "use64bitall='" + use64bitall + "'"
$ WC "use64bitint='" + use64bitint + "'"
+$ WC "usedebugging_perl='" + use_debugging_perl + "'"
$ WC "usedl='" + usedl + "'"
$ WC "useithreads='" + useithreads + "'"
$ WC "uselargefiles='" + uselargefiles + "'"
$ WC "usemorebits='" + usemorebits + "'"
$ WC "usemultiplicity='" + usemultiplicity + "'"
$ WC "usemymalloc='" + usemymalloc + "'"
-$ WC "useperlio='undef'"
+$ WC "useperlio='" + useperlio + "'"
$ WC "useposix='false'"
$ WC "usesocks='undef'"
$ WC "usethreads='" + usethreads + "'"
/* 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.
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*)
/* 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.
#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)
#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)
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);
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);
/* 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.
Perl_vdeb(pTHX_ const char *pat, va_list *args)
{
#ifdef DEBUGGING
- dTHR;
char* file = CopFILE(PL_curcop);
#ifdef USE_THREADS
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),
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;
ln='cp'
-pager='less'
+pager='${DJDIR}/bin/less.exe'
# fix extension names under DOS
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")
int
do_aspawn (pTHX_ SV *really,SV **mark,SV **sp)
{
- dTHR;
int rc;
char **a,*tmps,**argv;
STRLEN n_a;
/* 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.
#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)
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;
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)
}
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
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;
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");
/* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */
mode[0] = IoTYPE(io) = IoTYPE_APPEND;
type++;
- tlen--;
}
else
mode[0] = 'w';
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 == '=') {
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;
}
}
}
else if (*type == IoTYPE_RDONLY) {
- if (num_svs && tlen != 1)
- goto unknown_desr;
/*SUPPRESS 530*/
for (type++; isSPACE(*type); type++) ;
mode[0] = 'r';
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;
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 {
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;
#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)) {
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);
}
#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;
}
PL_filemode = 0;
while (av_len(GvAV(gv)) >= 0) {
- dTHR;
STRLEN oldlen;
sv = av_shift(GvAV(gv));
SAVEFREESV(sv);
#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);
return IoIFP(GvIOp(gv));
}
else {
- dTHR;
if (ckWARN_d(WARN_INPLACE)) {
int eno = errno;
if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0
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);
bool
Perl_do_eof(pTHX_ GV *gv)
{
- dTHR;
register IO *io;
int ch;
|| 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);
(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);
#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;
}
#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;
}
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;
}
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
}
}
}
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)
}
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)) {
}
/* 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
STRLEN n_a;
if (sp > mark) {
- dTHR;
New(401,PL_Argv, sp - mark + 1, char*);
a = PL_Argv;
while (++mark <= 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;
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));
I32
Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
{
- dTHR;
register I32 val;
register I32 val2;
register I32 tot = 0;
}
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.
I32
Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
{
- dTHR;
key_t key;
I32 n, flags;
I32
Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
{
- dTHR;
SV *astr;
char *a;
I32 id, n, cmd, infosize, getinfo;
Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
{
#ifdef HAS_MSG
- dTHR;
SV *mstr;
char *mbuf;
I32 id, msize, flags;
Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
{
#ifdef HAS_MSG
- dTHR;
SV *mstr;
char *mbuf;
long mtype;
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) {
Perl_do_semop(pTHX_ SV **mark, SV **sp)
{
#ifdef HAS_SEM
- dTHR;
SV *opstr;
char *opbuf;
I32 id;
Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
{
#ifdef HAS_SHM
- dTHR;
SV *mstr;
char *mbuf, *shm;
I32 id, mpos, msize;
#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;
+}
/* 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.
#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++;
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 */
}
}
*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;
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;
}
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;
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;
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;
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;
}
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;
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) {
matches++;
s += UTF8SKIP(s);
}
+ if (hibit)
+ Safefree(start);
return matches;
}
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;
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;
}
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;
}
}
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++;
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) {
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;
I32
Perl_do_trans(pTHX_ SV *sv)
{
- dTHR;
STRLEN len;
I32 hasutf = (PL_op->op_private &
(OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
}
if (items-- > 0) {
- char *s;
-
sv_setpv(sv, "");
if (*mark)
sv_catsv(sv, *mark);
}
else
sv_setpv(sv,"");
- len = delimlen;
- if (len) {
+ if (delimlen) {
for (; items > 0; items--,mark++) {
- sv_catpvn(sv,delim,len);
+ sv_catsv(sv,del);
sv_catsv(sv,*mark);
}
}
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 */
}
#ifdef UV_IS_QUAD
else if (size == 64) {
- dTHR;
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
"Bit vector size > 32 non-portable");
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");
}
#ifdef UV_IS_QUAD
else if (size == 64) {
- dTHR;
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
"Bit vector size > 32 non-portable");
{
STRLEN len;
char *s;
- dTHR;
if (SvTYPE(sv) == SVt_PVAV) {
register I32 i;
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);
I32
Perl_do_chomp(pTHX_ register SV *sv)
{
- dTHR;
register I32 count;
STRLEN len;
char *s;
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;
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)))
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;
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;
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;
/* 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.
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);
}
void
Perl_dump_all(pTHX)
{
- dTHR;
PerlIO_setlinebuf(Perl_debug_log);
if (PL_main_root)
op_dump(PL_main_root);
void
Perl_dump_packsubs(pTHX_ HV *stash)
{
- dTHR;
I32 i;
HE *entry;
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);
}
}
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)
}
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 ||
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;
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;
found-bad found)))
(not not-found)))
-\ 6
;;; Getting help
(defvar cperl-have-help-regexp
;;(concat "\\("
# 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`"
}' 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
#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
#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
#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
#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
#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
#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
#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
#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
#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)
# 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
#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
#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)
#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)
#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)
#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)
#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)
#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)
#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)
#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)
# 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)
# 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)
#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)
#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
#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
#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
#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
#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
#define utf16_to_utf8 Perl_utf16_to_utf8
#define Perl_utf16_to_utf8_reversed CPerlObj::Perl_utf16_to_utf8_reversed
#define utf16_to_utf8_reversed Perl_utf16_to_utf8_reversed
+#define Perl_utf8_length CPerlObj::Perl_utf8_length
+#define utf8_length Perl_utf8_length
#define Perl_utf8_distance CPerlObj::Perl_utf8_distance
#define utf8_distance Perl_utf8_distance
#define Perl_utf8_hop CPerlObj::Perl_utf8_hop
#define utf8_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
#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
#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
#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
#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
#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
#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
#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)
# 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
#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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
#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)
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
# 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)
#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
#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)
#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)
#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)
#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)
#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)
#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
#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)
#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
crosscompile='define'
cryptlib=''
csh='csh'
+d__fwalk='undef'
d_Gconvert='epoc_gcvt((x),(n),(b))'
d_PRIEUldbl='undef'
d_PRIFUldbl='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'
d_fsetpos='define'
d_fstatfs='define'
d_fstatvfs='undef'
+d_fsync='undef'
d_ftello='undef'
d_ftime='undef'
d_getespwnam='undef'
d_getnbyname='undef'
d_getnent='undef'
d_getnetprotos='define'
+d_getpagsz='undef'
d_getpbyname='define'
d_getpbynumber='define'
d_getpent='undef'
d_safebcpy='undef'
d_safemcpy='undef'
d_sanemcmp='define'
+d_sbrkproto='undef'
d_sched_yield='undef'
d_scm_rights='undef'
d_seekdir='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'
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'
myhostname='dragon'
myuname=''
n='-n'
+need_va_copy='undef'
netdb_hlen_type='int'
netdb_host_type='const char *'
netdb_name_type='const char *'
d_SCNfldbl='undef'
d_perl_otherlibdirs='undef'
nvsize='16'
+issymlink=''
+
+
int
do_spawn (pTHX_ SV *really,SV **mark,SV **sp)
{
- dTHR;
int rc;
char **a,*cmd,**ptr, *cmdline, **argv, *p2;
STRLEN n_a;
/* 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( '.'));
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';
*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 {
=item CvFLAGS
+=item const_sv
+
=back
=head2 B::HV METHODS
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
print <<"EOT";
static int $init_name()
{
- dTHR;
dTARG;
djSP;
EOT
# 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);
if ($sym =~ /::$/)
{
$sym = $prefix . $sym;
- if ($sym ne "main::" && &$recurse($sym))
+ if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym))
{
walkpackages(\%glob, $recurse, $sym);
}
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:
# - 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
# - 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?)
# - 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>?
$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;
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);
# 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";
}
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.
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";
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);
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;
$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 {
=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
=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
=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.
=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
);
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);
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);
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;
void
byterun(pTHXo_ register struct byteloader_state *bstate)
{
- dTHR;
register int insn;
U32 ix;
SV *specialsv_list[6];
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.
+
+
# 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
require 5.003 ;
+use warnings;
use strict;
use Carp;
require Tie::Hash;
package DB_File::RECNOINFO ;
+use warnings;
use strict ;
@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ;
package DB_File::BTREEINFO ;
+use warnings;
use strict ;
@DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ;
package DB_File ;
+use warnings;
use strict;
use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO
$db_version $use_XSLoader
use Carp;
-$VERSION = "1.73" ;
+$VERSION = "1.75" ;
#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
$DB_BTREE = new DB_File::BTREEINFO ;
sub CLEAR
{
my $self = shift;
- my $key = "" ;
+ my $key = 0 ;
my $value = "" ;
my $status = $self->seq($key, $value, R_FIRST());
my @keys;
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 ) ;
BTREE uses. Instead of using the normal lexical ordering, a case
insensitive compare function will be used.
+ use warnings ;
use strict ;
use DB_File ;
want to manipulate a BTREE database with duplicate keys. Consider this
code:
+ use warnings ;
use strict ;
use DB_File ;
Here is the script above rewritten using the C<seq> API method.
+ use warnings ;
use strict ;
use DB_File ;
So assuming the database created above, we can use C<get_dup> like
this:
+ use warnings ;
use strict ;
use DB_File ;
Assuming the database from the previous example:
+ use warnings ;
use strict ;
use DB_File ;
Again assuming the existence of the C<tree> database
+ use warnings ;
use strict ;
use DB_File ;
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 ;
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 ;
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 ;
sure you have already guessed, this is a problem that DBM Filters can
fix very easily.
+ use warnings ;
use strict ;
use DB_File ;
Here is a DBM Filter that does it:
+ use warnings ;
use strict ;
use DB_File ;
my %hash ;
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 ;
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) ;
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
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.
*/
# include <db.h>
#endif
+#ifdef CAN_PROTOTYPE
+extern void __getBerkeleyDBInfo(void);
+#endif
+
#ifndef pTHX
# define pTHX
# define pTHX_
# 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
#else /* db version 1.x */
+#define BERKELEY_DB_1
#define BERKELEY_DB_1_OR_2
typedef union INFO {
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
const DBT * key1 ;
const DBT * key2 ;
#endif
+
+#endif
+
{
#ifdef dTHX
dTHX;
}
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
const DBT * key1 ;
const DBT * key2 ;
#endif
+
+#endif
{
#ifdef dTHX
dTHX;
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
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)) ; */
# 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.
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 => {
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",
}
},
) ;
{ 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}
# 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
#
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
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.
+
*/
#include <db.h>
void
+#ifdef CAN_PROTOTYPE
+__getBerkeleyDBInfo(void)
+#else
__getBerkeleyDBInfo()
+#endif
{
#ifdef dTHX
dTHX;
#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 */
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;
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;
void
fill_mstats(SV *sv, int level)
{
+ dTHX;
int nbuckets;
struct mstats_buffer buf;
void
_mstats_to_hv(HV *hv, struct mstats_buffer *b, int level)
{
+ dTHX;
SV **svp;
int type;
-
use Config;
sub to_string {
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;
#
# 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
# 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;
# (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) &&
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);
# (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; }
* 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
# 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
}
/* 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);
off_utf8
utf_to_utf
encodings
+ utf8_decode
+ utf8_encode
+ utf8_upgrade
+ utf8_downgrade
);
bootstrap Encode ();
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
{
last unless $type eq '#';
}
$class .= ('::'.(($type eq 'E') ? 'Escape' : 'Table'));
+ #warn "Loading $file";
return $class->read($fh,$name,$type);
}
else
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;
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' }
$uni .= chr($code);
}
$_[1] = $str if $chk;
+ Encode::utf8_upgrade($uni);
return $uni;
}
return $str;
}
+
package Encode::Escape;
use Carp;
#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"); \
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
{
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)))
OUTPUT:
RETVAL
+BOOT:
+{
+#ifdef USE_PERLIO
+ PerlIO_define_layer(&PerlIO_encode);
+#endif
+#include "iso8859.def"
+#include "EBCDIC.def"
+#include "Symbols.def"
+}
--- /dev/null
+=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 $
0040004100420043004400450046004700480049004A004B004C004D004E004F
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
-0070007100720073007400750076007700780079007A007B007C007D007E0000
+0070007100720073007400750076007700780079007A007B007C007D007E007F
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
--- /dev/null
+# 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
--- /dev/null
+# 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
--- /dev/null
+# 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
--- /dev/null
+# 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
--- /dev/null
+# 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
--- /dev/null
+# 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
--- /dev/null
+# 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
--- /dev/null
+# 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
--- /dev/null
+# 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
--- /dev/null
+# 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
--- /dev/null
+# 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
--- /dev/null
+# 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
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',
},
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;
+}
--- /dev/null
+#!../../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";
+}
+
--- /dev/null
+/*
+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;
+}
+
+
--- /dev/null
+#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
use Config;
use strict;
-use vars qw($VERSION);
-
-$VERSION = "1.111";
+our $VERSION = "1.111";
my %err = ();
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
} 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";
#
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;
sub AUTOLOAD {
(my $constname = $AUTOLOAD) =~ s/.*:://;
- my $val = constant($constname, 0);
+ my $val = constant($constname);
if ($! != 0) {
if ($! =~ /Invalid/ || $!{EINVAL}) {
$AutoLoader::AUTOLOAD = $AUTOLOAD;
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
#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
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
#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
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
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
#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
MODULE = Fcntl PACKAGE = Fcntl
-double
-constant(name,arg)
+IV
+constant(name)
char * name
- int arg
--- /dev/null
+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
+
--- /dev/null
+/*
+ * 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");
+
+
--- /dev/null
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'Filter::Util::Call',
+ VERSION_FROM => 'Call.pm',
+ MAN3PODS => {}, # Pods will be built by installman.
+);
GDBM_WRITER
);
-$VERSION = "1.03";
+$VERSION = "1.04";
sub AUTOLOAD {
my($constname);
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);
$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);
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
}
}
#else
- /* Standard POSIX */
+ /* Standard POSIX */
RETVAL = RETVAL & O_NONBLOCK ? 0 : 1;
if ((block == 0) && !(mode & O_NONBLOCK)) {
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;
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;
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;
MODULE = IO PACKAGE = IO::Poll
-void
+void
_poll(timeout,...)
int timeout;
PPCODE:
=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
=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 ] )
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:
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
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>,
sub _fileno
{
my($self, $f) = @_;
+ return unless defined $f;
$f = $f->[0] if ref($f) eq 'ARRAY';
($f =~ /^\d+$/) ? $f : fileno($f);
}
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
use XSLoader ();
our @ISA = qw(Tie::Hash);
-our $VERSION = "1.03";
+our $VERSION = "1.04";
XSLoader::load 'NDBM_File', $VERSION;
#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 {
$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
use XSLoader ();
our @ISA = qw(Tie::Hash);
-our $VERSION = "1.02";
+our $VERSION = "1.03";
XSLoader::load 'ODBM_File', $VERSION;
#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
$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
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
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;
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',
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()";
}
=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
=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
$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
SysRet
pause()
+SysRet
+setgid(gid)
+ Gid_t gid
+
+SysRet
+setuid(uid)
+ Uid_t uid
+
SysRetLong
sysconf(name)
int name
char *
ttyname(fd)
int fd
+
--- /dev/null
+# 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'];
+}
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
use ExtUtils::MakeMaker;
+use Config;
# The existence of the ./sdbm/Makefile.PL file causes MakeMaker
# to automatically include Makefile code for the targets
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
use XSLoader ();
our @ISA = qw(Tie::Hash);
-our $VERSION = "1.02" ;
+our $VERSION = "1.03" ;
XSLoader::load 'SDBM_File', $VERSION;
{
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;
* 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)
$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
+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:
-# $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
#
# 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.
#
'MAN3PODS' => {},
'VERSION_FROM' => 'Storable.pm',
'dist' => { SUFFIX => 'gz', COMPRESS => 'gzip -f' },
- 'clean' => {'FILES' => '*%'},
);
-;# $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
;#
;# 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.
;#
use AutoLoader;
use vars qw($forgive_me $VERSION);
-$VERSION = '1.003';
+$VERSION = '1.007';
*AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr...
#
require Carp;
Carp::croak(@_);
}
+ sub logcarp {
+ require Carp;
+ Carp::carp(@_);
+ }
};
}
}
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__
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;
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
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
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.
*/
/*
- * $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
*
* 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.
*
#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)) { \
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 */
#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)
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])
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 */
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 */
*/
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 */
}
/*
/*
* 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;
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;
clean_retrieve_context(cxt);
else
clean_store_context(cxt);
+
+ ASSERT(!cxt->s_dirty, ("context is clean"));
}
/*
}
/*
+ * 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.
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.
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)));
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.
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);
$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 {
($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: $!";
$result = $t->join;
$result = $t->eval;
$t->detach;
+ $flags = $t->flags;
+
+ if ($t->done) {
+ $t->join;
+ }
if($t->equal($another_thread)) {
# ...
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
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
*/
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)));
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);
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)));
#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:
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' },
);
--- /dev/null
+# 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)';
+}
+
static void
deinstall(pTHX)
{
- dTHR;
PL_regexecp = Perl_regexec_flags;
PL_regcompp = Perl_pregcomp;
PL_regint_start = Perl_re_intuit_start;
static void
install(pTHX)
{
- dTHR;
PL_colorset = 0; /* Allow reinspection of ENV. */
PL_regexecp = &my_regexec;
PL_regcompp = &my_regcomp;
--- /dev/null
+/*
+ * 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_
+
+++ /dev/null
-#!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";
/* 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.
#define FF_NEWLINE 13
#define FF_BLANK 14
#define FF_MORE 15
+#define FF_0DECIMAL 16
Perl_set_context
Perl_amagic_call
Perl_Gv_AMupdate
+Perl_gv_handler
Perl_apply_attrs_string
Perl_avhv_delete_ent
Perl_avhv_exists_ent
Perl_pop_scope
Perl_push_scope
Perl_regdump
+Perl_regclass_swash
Perl_pregexec
Perl_pregfree
Perl_pregcomp
Perl_save_pptr
Perl_save_vptr
Perl_save_re_context
+Perl_save_padsv
Perl_save_sptr
Perl_save_svref
Perl_save_threadsv
Perl_sv_tainted
Perl_sv_unmagic
Perl_sv_unref
+Perl_sv_unref_flags
Perl_sv_untaint
Perl_sv_upgrade
Perl_sv_usepvn
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
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
/* 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.
GV *
Perl_gv_fetchfile(pTHX_ const char *name)
{
- dTHR;
char smallbuf[256];
char *tmpbuf;
STRLEN tmplen;
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;
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));
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));
GV *
Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
{
- dTHR;
register const char *nend;
const char *nsplit = 0;
GV* gv;
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;
return Nullgv;
cv = GvCV(gv);
- if (!CvROOT(cv))
+ if (!(CvROOT(cv) || CvXSUB(cv)))
return Nullgv;
/*
"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
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;
case ',':
case '\\':
case '/':
- case '|':
case '\001': /* $^A */
case '\003': /* $^C */
case '\004': /* $^D */
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;
IO *
Perl_newIO(pTHX)
{
- dTHR;
IO *io;
GV *iogv;
void
Perl_gv_check(pTHX_ HV *stash)
{
- dTHR;
register HE *entry;
register I32 i;
register GV *gv;
void
Perl_gp_free(pTHX_ GV *gv)
{
- dTHR;
GP* gp;
if (!gv || !(gp = GvGP(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++) {
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. */
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: */
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;
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 ":
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",
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;
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"))
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 */
/* 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.
/* 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.
*/
+#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;
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. */
#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 */
#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
+
*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."
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.
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'
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.
*** 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.
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'
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 / /'`
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 ;;
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
# 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
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 / /' \
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
lddlflags='-shared'
ldflags=''
;;
- '')
+ *)
cc="cc -Xa -Olimit 4096"
malloctype="void *"
;;
;;
*) # from 2.8 onwards
ld=${cc:-cc}
- lddlflags="-shared $lddlflags"
+ lddlflags="-shared -fPIC $lddlflags"
;;
esac
;;
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'
# 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.
;;
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.
#
# 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.
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
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.
# 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
:
# 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*)
# 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
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";
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);
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]*)
# 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
;;
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
*"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`"
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
;;
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.)
-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'
# 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
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'
/* 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.
{
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)
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;
}
*/
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;
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 */
#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;
}
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);
}
key = SvPV(keysv, klen);
+ is_utf8 = (SvUTF8(keysv)!=0);
if (!hash)
PERL_HASH(hash, key, klen);
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 */
*/
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;
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);
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;
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);
}
key = SvPV(keysv, klen);
+ is_utf8 = (SvUTF8(keysv) != 0);
if (!hash)
PERL_HASH(hash, key, klen);
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;
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;
*/
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;
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;
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--;
register HE *entry;
register HE **oentry;
SV *sv;
+ bool is_utf8;
if (!hv)
return Nullsv;
return Nullsv;
key = SvPV(keysv, klen);
+ is_utf8 = (SvUTF8(keysv) != 0);
if (!hash)
PERL_HASH(hash, key, klen);
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--;
*/
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'));
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? */
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);
#endif
key = SvPV(keysv, klen);
+ is_utf8 = (SvUTF8(keysv) != 0);
if (!hash)
PERL_HASH(hash, key, 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? */
/* 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;
{
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)));
}
/*
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))) {
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);
}
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
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:
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;
/* 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.
#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) ? \
#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)
-#!./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;
=cut
+my $usage;
+
$usage =<<END_OF_USAGE;
Usage: $0 --help --podpath=<name>:...:<name> --podroot=<name>
--htmldir=<name> --htmlroot=<name> --norecurse --recurse
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.
# 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
# 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
# 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
open(H, "<$file.html") ||
die "$0: error opening $file.html for input: $!\n";
$/ = "";
- @data = ();
+ my @data = ();
while (<H>) {
last if /NAME=/;
$_ =~ s{HREF="#(.*)">}{
# 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);
}
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.
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)?$,;
# 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+(.*)/;
}
# 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) ||
}
# 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);
}
# 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);
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};
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};
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",
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
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;
}
# 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;
}
$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};
-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;
=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>.
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 */
/*
=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
*
*/
-
/*
- 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);
#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
{
LPSetBuf pSetBuf;
LPSetVBuf pSetVBuf;
LPSetCnt pSetCnt;
- LPSetPtrCnt pSetPtrCnt;
+ LPSetPtr pSetPtr;
LPSetlinebuf pSetlinebuf;
LPPrintf pPrintf;
LPVprintf pVprintf;
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
#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))
/* 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 */
const char*const*);
typedef int (*LPProcASpawn)(struct IPerlProc*, void*, void**, void**);
#endif
+typedef int (*LPProcLastHost)(struct IPerlProc*);
struct IPerlProc
{
LPProcSpawnvp pSpawnvp;
LPProcASpawn pASpawn;
#endif
+ LPProcLastHost pLastHost;
};
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 */
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);
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;
$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';
}
# 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
@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
=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
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
if the former is unavailable.
=item B<script_name()>
+
Return the script name as a partial URL, for self-refering
scripts.
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);
use CGI;
+
+our $VERSION = '1.00';
+
1;
__END__
use CGI;
+
+our $VERSION = '1.00';
+
1;
__END__
# -*- 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 ();
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);
$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';
# 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" :
)
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 = $_;
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;
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) {
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;
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);
@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 {
}
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;
&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();}
#-> 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 ||= "";
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: $!");
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(
$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");
+ }
+ }
+ }
+ }
}
}
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);
}
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/) {
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
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);
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::|) {
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
) {
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;
}
);
}
} 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)) {
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";
sub myprint {
my($self,$what) = @_;
+
$self->print_ornamented($what, 'bold blue on_yellow');
}
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, }.
# 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};
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;
$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;
$src_switch = " -source";
} elsif ($f eq "ncftp"){
$src_switch = " -c";
+ } elsif ($f eq "wget"){
+ $src_switch = " -O -";
}
my($chdir) = "";
my($stdout_redir) = " > $asl_ungz";
}, $class;
}
+# CPAN::FTP::hasdefault;
sub hasdefault { shift->{'hasdefault'} }
sub netrc { shift->{'netrc'} }
sub protected { shift->{'protected'} }
}
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);
@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 = ();
}
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
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";
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;
# 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} ||= {};
# 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;
}
#-> sub CPAN::InfoObj::author ;
sub author {
my($self) = @_;
- $CPAN::META->instance(CPAN::Author,$self->cpan_userid)->fullname;
+ $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
}
#-> sub CPAN::InfoObj::dump ;
}
#-> sub 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;
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;
#-> 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 ;
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) = @_;
"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(
$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 ) {
$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{
WriteMakefile(NAME => q[$cf]);
});
- $fh->close;
+ $fh->close;
}
- }
}
+
return $self;
}
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
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});
$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 =
$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);
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) {
#-> 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) {
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": $!});
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 ;
#-> 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) = @_;
# 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} }
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;
}
$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/) {
}
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;
# 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) {
} 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.
-});
}
}
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;
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
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
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
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","/./")){
=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
('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)
=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
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
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
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
=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
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
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:
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
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
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
package CPAN::Mirrored::By;
sub new {
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
} 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
$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?
#
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.
};
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;
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.
$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
}
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
};
}
}
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));
$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;
package Carp;
+our $VERSION = '1.00';
+
=head1 NAME
carp - warn of errors (from perspective of caller)
$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);
+# 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;
+
@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);
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:
$class = (caller())[0];
@decls = @_;
}
+
_usage_error() if @decls % 2 == 1;
# Ensure we are not, and will not be, a subclass.
# 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;
# 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>.
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.
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
See Example 3 below for an example of initialization.
-
=head1 EXAMPLES
=over
$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
as an anonymous hash of initializers, which is passed on to the nested
struct's constructor.
-
use Class::Struct;
struct Breed =>
=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.
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.
Class name to struct() made optional.
Diagnostic checks added.
-
Originally C<Class::Template> by Dean Roehrich.
# Template.pm --- struct/member template builder
use Carp;
-our $VERSION = '2.03';
+our $VERSION = '2.04';
use base qw/ Exporter /;
our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
}
}
+# set a reasonable (and very safe) default for fastgetcwd, in case it
+# isn't redefined later (20001212 rspier)
+*fastgetcwd = \&cwd;
# By Brandon S. Allbery
#
}
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;
*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;
package DirHandle;
+our $VERSION = '1.00';
+
=head1 NAME
DirHandle - supply object methods for directory handles
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
package English;
+our $VERSION = '1.00';
+
require Exporter;
@ISA = (Exporter);
package Env;
+our $VERSION = '1.00';
+
=head1 NAME
Env - perl module that imports environment variables as scalars or arrays
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
-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
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;
}
}
if ($spec =~ s/^://){
if ($spec eq 'DEFAULT'){
- @names = @exports;
+ @names = @$exports;
}
elsif ($tagdata = $tagsref->{$spec}) {
@names = @$tagdata;
}
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 {
}
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
@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++;
}
}
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) {
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) = @_;
}
}
+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);
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);
}
}
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
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';
}
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.
$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'};
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;
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++;
."No library found for -l$thislib\n"
unless $found_lib>0;
}
- return ('','','','') unless $found;
- ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path));
+ return ('','','','', ($give_libs ? \@libs : ())) unless $found;
+ ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path), ($give_libs ? \@libs : ()));
}
sub _win32_ext {
require Text::ParseWords;
- my($self, $potential_libs, $verbose) = @_;
+ my($self, $potential_libs, $verbose, $give_libs) = @_;
# If user did not supply a list, we punt.
# (caller should probably use the list in $Config{libs})
- return ("", "", "", "") unless $potential_libs;
+ return ("", "", "", "", ($give_libs ? [] : ())) unless $potential_libs;
my $cc = $Config{cc};
my $VC = 1 if $cc =~ /^cl/i;
my $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
$found++;
$found_lib++;
push(@extralibs, $fullname);
+ push @libs, $fullname unless $libs_seen{$fullname}++;
last;
}
}
- 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)
$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'};
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);
# 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',
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;
}
}
$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;
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:
--- /dev/null
+# 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$
+\#$
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';
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}};
}
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';
', "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";
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
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';
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
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";
# 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
$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, '
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")
&&
$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
}
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}";
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) $@
};
}
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};
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
cd ..
]
EOT
- }
- else {
+ } elsif ($Config{'make'} =~ /nmake/i) {
+ # nmake-specific
+ return <<EOT;
+subdirs ::
+ cd $subdir
+ \$(MAKE) all \$(PASTHRU)
+ cd ..
+EOT
+ }
+ } else {
return <<EOT;
subdirs ::
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
sub ExtUtils::MM_VMS::ext;
sub ExtUtils::MM_VMS::nicetext;
-#use SelfLoader;
+our $AUTOLOAD;
sub AUTOLOAD {
my $code;
if (defined fileno(DATA)) {
# 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
# 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);
$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}}) {
';
- for $tmp (qw/
+ for my $tmp (qw/
INST_MAN1DIR INSTALLMAN1DIR MAN1EXT INST_MAN3DIR INSTALLMAN3DIR MAN3EXT
/) {
next unless defined $self->{$tmp};
# 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;
}
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
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, "
=cut
+our %olbs;
+
sub makeaperl {
my($self, %attribs) = @_;
my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) =
$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 {
push @optlibs, @$extra;
$target = "Perl$Config{'exe_ext'}" unless $target;
+ my $shrtarget;
($shrtarget,$targdir) = fileparse($target);
$shrtarget =~ s/^([^.]*)/$1Shr/;
$shrtarget = $targdir . $shrtarget;
package ExtUtils::MM_Win32;
+our $VERSION = '1.00';
+
=head1 NAME
ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker
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';
($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)
<<
# 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:
# "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;
#
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
dir_target libscan makeaperl needs_linking perm_rw perm_rwx
subdir_x test_via_harness test_via_script
-
];
push @MM_Sections, qw[
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:
=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.
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
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
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
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
=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
=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
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
=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
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
( $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:
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
{ANY_TARGET => ANY_DEPENDECY, ...}
+(ANY_TARGET must not be given a double-colon rule by MakeMaker.)
+
=item dist
{TARFLAGS => 'cvfF', COMPRESS => 'gzip', SUFFIX => '.gz',
=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
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');
$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}) {
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 /^#/;
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);
}
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>,
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>.
=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
}
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) }
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
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
$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
while (items--) {
DO_ARRAY_ELEM;
}
+T_STDIO
+ $var = PerlIO_findFILE(IoIFP(sv_2io($arg)))
T_IN
$var = IoIFP(sv_2io($arg))
T_INOUT
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");
# Global Constants
-$XSUBPP_version = "1.9507";
+$XSUBPP_version = "1.9508";
my ($Is_VMS, $SymSet);
if ($^O eq 'VMS') {
$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
$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";
} 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$/;
}
}
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*$/;
# initialize info arrays
undef(%args_match);
undef(%var_types);
- undef(%var_addr);
undef(%defaults);
undef($class);
undef($static);
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) ;
$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) {
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;
$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 {
} 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;
}
}
last;
}
}
- if ($out_vars{$args[$i]}) {
+ if ($only_outlist{$args[$i]}) {
push @args_num, undef;
} else {
push @args_num, ++$num_args;
# print function header
print Q<<"EOF";
+#XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
#XS(XS_${Full_func_name})
#[[
# dXSARGS;
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";
$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") ;
EOF
print Q<<"EOF";
+#XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
#XS(boot_$Module_cname)
EOF
$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/;
}
package File::CheckTree;
+
+our $VERSION = '4.1';
+
require 5.000;
require Exporter;
=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);
$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;
$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;
}
#!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;
$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 '..';
# 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.");
}
}
my %entries;
sub glob {
- my $pat = shift;
- my $cxix = shift;
+ my($pat,$cxix) = @_;
my @pat;
# glob without args defaults to $_
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};
}
}
-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__
package File::Find;
+use strict;
use 5.005_64;
+our $VERSION = '1.00';
require Exporter;
require Cwd;
=cut
-@ISA = qw(Exporter);
-@EXPORT = qw(find finddepth);
+our @ISA = qw(Exporter);
+our @EXPORT = qw(find finddepth);
use strict;
$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
# 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) = @_;
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";
--- /dev/null
+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;
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';
package File::Spec::Unix;
use strict;
-use vars qw($VERSION);
+our($VERSION);
$VERSION = '1.2';
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
# Version number
-$VERSION = '0.10';
+$VERSION = '0.11';
# This is a list of characters that can be used in random filenames
# 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 ();
}
# 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 ();
}
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()
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);
# 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
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
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
use 5.005_64;
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+our $VERSION = '1.00';
+
BEGIN {
use Exporter ();
@EXPORT = qw(stat lstat);
package FileCache;
+our $VERSION = '1.00';
+
=head1 NAME
FileCache - keep more files open than the system permits
--- /dev/null
+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)
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
################ 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.
my %atts = @_;
# Register the callers package.
- my $self = { caller => (caller)[0] };
+ my $self = { caller_pkg => (caller)[0] };
bless ($self, $class);
# 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.
################ 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 {
if ( ! defined $o ) {
# empty -> '-' option
- $opctl{$linko = $o = ''} = $c;
+ $linko = $o = '';
+ $opctl{''} = $c;
+ $bopctl{''} = $c if $bundling;
}
else {
# Handle alias names
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;
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 ",
=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
package I18N::Collate;
+use strict;
+our $VERSION = '1.00';
+
=head1 NAME
I18N::Collate - compare 8-bit scalar data according to the current locale
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];
1;
__END__
+=pod
+
=head1 NAME
Math::Complex - complex numbers and associated mathematical functions
);
$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
}
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;
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
use strict;
use 5.005_64;
+our $VERSION = '1.00';
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
BEGIN {
use Exporter ();
use strict;
use 5.005_64;
+our $VERSION = '1.00';
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
BEGIN {
use Exporter ();
use strict;
use 5.005_64;
+our $VERSION = '1.00';
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
BEGIN {
use Exporter ();
use strict;
use 5.005_64;
+our $VERSION = '1.00';
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
BEGIN {
use Exporter ();
=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>"
'cut' => 1,
'head1' => 1,
'head2' => 1,
+ 'head3' => 1,
+ 'head4' => 1,
'over' => 1,
'back' => 1,
'item' => 1,
#: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',
'Namespace' => 'Keywords altering or affecting scoping of identifiers',
);
-@Type_Order = qw{
+our @Type_Order = qw{
String
Regexp
Math
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;
}
}
use Cwd;
use File::Spec::Unix;
use Getopt::Long;
-use Pod::Functions;
use locale; # make \w work right in non-ASCII lands
# 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>
#
# 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;
############################################################################
$_;
}
-# 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] }
$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;
}
$$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;
}
$$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 {
$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}++;
# 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)};
# 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
=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</!.+>
# 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>
#
# 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;
############################################################################
$$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) {
}
}
+# 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;
# 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>
#
@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;
############################################################################
--- /dev/null
+# 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
# 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>
#
@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;
############################################################################
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
=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;
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;
}
}
$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;
}
package SelectSaver;
+our $VERSION = '1.00';
+
=head1 NAME
SelectSaver - save and restore selected file handle
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
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
=cut
+our($complete, $kill, $erase1, $erase2);
CONFIG: {
$complete = "\004";
$kill = "\025";
}
sub Complete {
- my($prompt, @cmp_list, $cmp, $test, $l, @match);
+ my($prompt, @cmp_lst, $cmp, $test, $l, @match);
my ($return, $r) = ("", 0);
$return = "";
=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;
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";
}
}
- $consoleOUT = $console;
+ my $consoleOUT = $console;
$console = "&STDIN" unless defined $console;
if (!defined $consoleOUT) {
$consoleOUT = defined fileno(STDERR) ? "&STDERR" : "&STDOUT";
#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];
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){
# 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) {
# 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;
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 {
=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
+# -*- 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;
$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 = ();
$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++;
$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";
$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'
}
}
my $t_total = timediff(new Benchmark, $t_start);
-
+
if ($^O eq 'VMS') {
if (defined $old5lib) {
$ENV{PERL5LIB} = $old5lib;
ok
END
-will generate
+will generate
FAILED tests 1, 3, 6
Failed 3/6 tests, 50.00% okay
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.
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
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
=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)
$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 {
package Tie::Hash;
+our $VERSION = '1.00';
+
=head1 NAME
Tie::Hash, Tie::StdHash - base class definitions for tied hashes
package Tie::RefHash;
+our $VERSION = '1.21';
+
=head1 NAME
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;
print ref($_), "\n";
}
+ tie %h, 'Tie::RefHash::Nestable';
+ $h{$a}->{$b} = 1;
+ for (keys %h, keys %{$h{$a}}) {
+ print ref($_), "\n";
+ }
=head1 AUTHOR
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 {
%{$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;
package Tie::Scalar;
+our $VERSION = '1.00';
+
=head1 NAME
Tie::Scalar, Tie::StdScalar - base class definitions for tied scalars
package Tie::SubstrHash;
+our $VERSION = '1.00';
+
=head1 NAME
Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing
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;
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];
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;
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);
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;
}
}
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) = @_;
$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
}
sub timegm_nocheck {
- local $options{no_range_check} = 1;
+ local $Options{no_range_check} = 1;
&timegm;
}
$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;
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 }
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.
use strict;
use 5.005_64;
+our $VERSION = '1.00';
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
BEGIN {
use Exporter ();
package User::pwent;
use 5.006;
+our $VERSION = '1.00';
use strict;
use warnings;
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
package bytes;
+our $VERSION = '1.00';
+
$bytes::hint_bits = 0x00000008;
sub import {
package charnames;
+
+our $VERSION = '1.00';
+
use bytes (); # for $bytes::hint_bits
use warnings();
$charnames::hint_bits = 0x20000;
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;
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
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;
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
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
use 5.005_64;
use Carp;
-our $VERSION = v1.0;
+our $VERSION = 1.0;
our $DEBUG;
our $VERBOSE;
our $PRETTY;
package filetest;
+our $VERSION = '1.00';
+
=head1 NAME
filetest - Perl pragma to control the filetest permission operators
# 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.
#
package integer;
+our $VERSION = '1.00';
+
=head1 NAME
integer - Perl pragma to compute arithmetic in integer instead of double
package less;
+our $VERSION = '0.01';
+
=head1 NAME
less - perl pragma to request less of something from the compiler
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: $!";
# 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!';
}
# 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
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.
package locale;
+our $VERSION = '1.00';
+
=head1 NAME
locale - Perl pragma to use and avoid POSIX locales for built-in operations
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;
package overload;
+our $VERSION = '1.00';
+
$overload::hint_bits = 0x20000;
sub nil {}
# 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
$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";
}
--- /dev/null
+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
+
+
$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
package subs;
+our $VERSION = '1.00';
+
=head1 NAME
subs - Perl pragma to predeclare sub names
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
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
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
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
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
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
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
1fe0 1fec
1ff2 1ff4
1ff6 1ffc
-207f
+2070
+2074 2079
+207f 2089
+20d0 20e3
2102
2107
210a 2113
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
f900 fa2d
fb00 fb06
fb13 fb17
-fb1d
-fb1f fb28
+fb1d fb28
fb2a fb36
fb38 fb3c
fb3e
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
00f8 021f
0222 0233
0250 02ad
+02b0 02b8
+02bb 02c1
+02d0 02d1
+02e0 02e4
+02ee
+0300 034e
+0360 0362
+037a
0386
0388 038a
038c
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
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
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
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
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
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
1ff2 1ff4
1ff6 1ffc
207f
+20d0 20e3
2102
2107
210a 2113
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
f900 fa2d
fb00 fb06
fb13 fb17
-fb1d
-fb1f fb28
+fb1d fb28
fb2a fb36
fb38 fb3c
fb3e
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
--- /dev/null
+# !!!!!!! 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
--- /dev/null
+# !!!!!!! 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
# Any changes made here will be lost!
return <<'END';
0021 007e
-00a0 021f
+00a1 021f
0222 0233
0250 02ad
02b0 02ee
1361 137c
13a0 13f4
1401 1676
-1680 169c
+1681 169c
16a0 16f0
1780 17dc
17e0 17e9
1fdd 1fef
1ff2 1ff4
1ff6 1ffe
-2000 2008
-200b
-2010 2029
-202f 2046
+2010 2027
+2030 2046
2048 204d
2070
2074 208e
2e9b 2ef3
2f00 2fd5
2ff0 2ffb
-3000 303a
+3001 303a
303e 303f
3041 3094
3099 309e
a4c2 a4c4
a4c6
ac00 d7a3
+e000 f8ff
f900 fa2d
fb00 fb06
fb13 fb17
ffe0 ffe6
ffe8 ffee
fffc fffd
+f0000 ffffd
+100000 10fffd
END
1ff2 1ff4
1ff6 1ffe
2000 200b
-2010 2029
+2010 2027
202f 2046
2048 204d
2070
a4c2 a4c4
a4c6
ac00 d7a3
+e000 f8ff
f900 fa2d
fb00 fb06
fb13 fb17
ffe0 ffe6
ffe8 ffee
fffc fffd
+f0000 ffffd
+100000 10fffd
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
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
ff1a ff1b
ff1f ff20
ff3b ff3d
-ff3f
-ff5b
-ff5d
+ff3f
+ff5b
+ff5d
ff61 ff65
END
# 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
--- /dev/null
+# !!!!!!! 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
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
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
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
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
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
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
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
1fe0 1fec
1ff2 1ff4
1ff6 1ffc
-207f
+2070
+2074 2079
+207f 2089
+20d0 20e3
2102
2107
210a 2113
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
f900 fa2d
fb00 fb06
fb13 fb17
-fb1d
-fb1f fb28
+fb1d fb28
fb2a fb36
fb38 fb3c
fb3e
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
--- /dev/null
+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
@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'],
['IsDCfont', '$decomp =~ /^<font>/', ''],
['IsDCnoBreak', '$decomp =~ /^<noBreak>/', ''],
['IsDCinitial', '$decomp =~ /^<initial>/', ''],
- ['IsDCinital', '$decomp =~ /^<medial>/', ''],
+ ['IsDCmedial', '$decomp =~ /^<medial>/', ''],
['IsDCfinal', '$decomp =~ /^<final>/', ''],
['IsDCisolated', '$decomp =~ /^<isolated>/', ''],
['IsDCcircle', '$decomp =~ /^<circle>/', ''],
-################################################################################\r
-#\r
-# V: as "u" in "but" (often represented with schwa or small uppercase lambda)\r
-# U: as "oo" in "fool"\r
-# I: as "ea" in "meat"\r
-# A: as "a" in "father"\r
-# E: as "a" in "hate"\r
-# C: the consonant form having no vowel element\r
-# O: as "o" in "note"\r
-#\r
-# Vowel identifiers are assumed short, doubled identifiers are considered long\r
-# (following Cushitic rules). Dipthong syllables are identified with "W" as\r
-# per Ethiopic and Canadian syllabary character names.\r
-# \r
-#\r
-# WV WVV WU WUU WI WII WA WAA WAI WAAI WE WEE WC WO WOO\r
-#\r
-# V VV U UU I II A AA AI AAI E EE C O OO\r
-# \r
-################################################################################\r
-\r
-#\r
-# Ethiopic\r
-#\r
-1200; HA; V\r
-1201; HU; U\r
-1202; HI; I\r
-1203; HAA; A\r
-1204; HEE; E\r
-1205; HE; C\r
-1206; HO; O\r
-1208; LA; V\r
-1209; LU; U\r
-120A; LI; I\r
-120B; LAA; A\r
-120C; LEE; E\r
-120D; LE; C\r
-120E; LO; O\r
-120F; LWA; WA\r
-1210; HHA; V\r
-1211; HHU; U\r
-1212; HHI; I\r
-1213; HHAA; A\r
-1214; HHEE; E\r
-1215; HHE; C\r
-1216; HHO; O\r
-1217; HHWA; WA\r
-1218; MA; V\r
-1219; MU; U\r
-121A; MI; I\r
-121B; MAA; A\r
-121C; MEE; E\r
-121D; ME; C\r
-121E; MO; O\r
-121F; MWA; WA\r
-1220; SZA; V\r
-1221; SZU; U\r
-1222; SZI; I\r
-1223; SZAA; A\r
-1224; SZEE; E\r
-1225; SZE; C\r
-1226; SZO; O\r
-1227; SZWA; WA\r
-1228; RA; V\r
-1229; RU; U\r
-122A; RI; I\r
-122B; RAA; A\r
-122C; REE; E\r
-122D; RE; C\r
-122E; RO; O\r
-122F; RWA; WA\r
-1230; SA; V\r
-1231; SU; U\r
-1232; SI; I\r
-1233; SAA; A\r
-1234; SEE; E\r
-1235; SE; C\r
-1236; SO; O\r
-1237; SWA; WA\r
-1238; SHA; V\r
-1239; SHU; U\r
-123A; SHI; I\r
-123B; SHAA; A\r
-123C; SHEE; E\r
-123D; SHE; C\r
-123E; SHO; O\r
-123F; SHWA; WA\r
-1240; QA; V\r
-1241; QU; U\r
-1242; QI; I\r
-1243; QAA; A\r
-1244; QEE; E\r
-1245; QE; C\r
-1246; QO; O\r
-1248; QWA; WV\r
-124A; QWI; WI\r
-124B; QWAA; WA\r
-124C; QWEE; WE\r
-124D; QWE; WC\r
-1250; QHA; V\r
-1251; QHU; U\r
-1252; QHI; I\r
-1253; QHAA; A\r
-1254; QHEE; E\r
-1255; QHE; C\r
-1256; QHO; O\r
-1258; QHWA; WV\r
-125A; QHWI; WI\r
-125B; QHWAA; WA\r
-125C; QHWEE; WE\r
-125D; QHWE; WC\r
-1260; BA; V\r
-1261; BU; U\r
-1262; BI; I\r
-1263; BAA; A\r
-1264; BEE; E\r
-1265; BE; C\r
-1266; BO; O\r
-1267; BWA; WA\r
-1268; VA; V\r
-1269; VU; U\r
-126A; VI; I\r
-126B; VAA; A\r
-126C; VEE; E\r
-126D; VE; C\r
-126E; VO; O\r
-126F; VWA; WA\r
-1270; TA; V\r
-1271; TU; U\r
-1272; TI; I\r
-1273; TAA; A\r
-1274; TEE; E\r
-1275; TE; C\r
-1276; TO; O\r
-1277; TWA; WA\r
-1278; CA; V\r
-1279; CU; U\r
-127A; CI; I\r
-127B; CAA; A\r
-127C; CEE; E\r
-127D; CE; C\r
-127E; CO; O\r
-127F; CWA; WA\r
-1280; XA; V\r
-1281; XU; U\r
-1282; XI; I\r
-1283; XAA; A\r
-1284; XEE; E\r
-1285; XE; C\r
-1286; XO; O\r
-1288; XWA; WV\r
-128A; XWI; WI\r
-128B; XWAA; WA\r
-128C; XWEE; WE\r
-128D; XWE; WC\r
-1290; NA; V\r
-1291; NU; U\r
-1292; NI; I\r
-1293; NAA; A\r
-1294; NEE; E\r
-1295; NE; C\r
-1296; NO; O\r
-1297; NWA; WA\r
-1298; NYA; V\r
-1299; NYU; U\r
-129A; NYI; I\r
-129B; NYAA; A\r
-129C; NYEE; E\r
-129D; NYE; C\r
-129E; NYO; O\r
-129F; NYWA; WA\r
-12A0; GLOTTAL A; V\r
-12A1; GLOTTAL U; U\r
-12A2; GLOTTAL I; I\r
-12A3; GLOTTAL AA; A\r
-12A4; GLOTTAL EE; E\r
-12A5; GLOTTAL E; C\r
-12A6; GLOTTAL O; O\r
-12A7; GLOTTAL WA; WA\r
-12A8; KA; V\r
-12A9; KU; U\r
-12AA; KI; I\r
-12AB; KAA; A\r
-12AC; KEE; E\r
-12AD; KE; C\r
-12AE; KO; O\r
-12B0; KWA; WV\r
-12B2; KWI; WI\r
-12B3; KWAA; WA\r
-12B4; KWEE; WE\r
-12B5; KWE; WC\r
-12B8; KXA; V\r
-12B9; KXU; U\r
-12BA; KXI; I\r
-12BB; KXAA; A\r
-12BC; KXEE; E\r
-12BD; KXE; C\r
-12BE; KXO; O\r
-12C0; KXWA; WV\r
-12C2; KXWI; WI\r
-12C3; KXWAA; WA\r
-12C4; KXWEE; WE\r
-12C5; KXWE; WC\r
-12C8; WA; V\r
-12C9; WU; U\r
-12CA; WI; I\r
-12CB; WAA; A\r
-12CC; WEE; E\r
-12CD; WE; C\r
-12CE; WO; O\r
-12D0; PHARYNGEAL A; V\r
-12D1; PHARYNGEAL U; U\r
-12D2; PHARYNGEAL I; I\r
-12D3; PHARYNGEAL AA; A\r
-12D4; PHARYNGEAL EE; E\r
-12D5; PHARYNGEAL E; C\r
-12D6; PHARYNGEAL O; O\r
-12D8; ZA; V\r
-12D9; ZU; U\r
-12DA; ZI; I\r
-12DB; ZAA; A\r
-12DC; ZEE; E\r
-12DD; ZE; C\r
-12DE; ZO; O\r
-12DF; ZWA; WA\r
-12E0; ZHA; V\r
-12E1; ZHU; U\r
-12E2; ZHI; I\r
-12E3; ZHAA; A\r
-12E4; ZHEE; E\r
-12E5; ZHE; C\r
-12E6; ZHO; O\r
-12E7; ZHWA; WA\r
-12E8; YA; V\r
-12E9; YU; U\r
-12EA; YI; I\r
-12EB; YAA; A\r
-12EC; YEE; E\r
-12ED; YE; C\r
-12EE; YO; O\r
-12F0; DA; V\r
-12F1; DU; U\r
-12F2; DI; I\r
-12F3; DAA; A\r
-12F4; DEE; E\r
-12F5; DE; C\r
-12F6; DO; O\r
-12F7; DWA; WA\r
-12F8; DDA; V\r
-12F9; DDU; U\r
-12FA; DDI; I\r
-12FB; DDAA; A\r
-12FC; DDEE; E\r
-12FD; DDE; C\r
-12FE; DDO; O\r
-12FF; DDWA; WA\r
-1300; JA; V\r
-1301; JU; U\r
-1302; JI; I\r
-1303; JAA; A\r
-1304; JEE; E\r
-1305; JE; C\r
-1306; JO; O\r
-1307; JWA; WA\r
-1308; GA; V\r
-1309; GU; U\r
-130A; GI; I\r
-130B; GAA; A\r
-130C; GEE; E\r
-130D; GE; C\r
-130E; GO; O\r
-1310; GWA; WV\r
-1312; GWI; WI\r
-1313; GWAA; WA\r
-1314; GWEE; WE\r
-1315; GWE; WC\r
-1318; GGA; V\r
-1319; GGU; U\r
-131A; GGI; I\r
-131B; GGAA; A\r
-131C; GGEE; E\r
-131D; GGE; C\r
-131E; GGO; O\r
-1320; THA; V\r
-1321; THU; U\r
-1322; THI; I\r
-1323; THAA; A\r
-1324; THEE; E\r
-1325; THE; C\r
-1326; THO; O\r
-1327; THWA; WA\r
-1328; CHA; V\r
-1329; CHU; U\r
-132A; CHI; I\r
-132B; CHAA; A\r
-132C; CHEE; E\r
-132D; CHE; C\r
-132E; CHO; O\r
-132F; CHWA; WA\r
-1330; PHA; V\r
-1331; PHU; U\r
-1332; PHI; I\r
-1333; PHAA; A\r
-1334; PHEE; E\r
-1335; PHE; C\r
-1336; PHO; O\r
-1337; PHWA; WA\r
-1338; TSA; V\r
-1339; TSU; U\r
-133A; TSI; I\r
-133B; TSAA; A\r
-133C; TSEE; E\r
-133D; TSE; C\r
-133E; TSO; O\r
-133F; TSWA; WA\r
-1340; TZA; V\r
-1341; TZU; U\r
-1342; TZI; I\r
-1343; TZAA; A\r
-1344; TZEE; E\r
-1345; TZE; C\r
-1346; TZO; O\r
-1348; FA; V\r
-1349; FU; U\r
-134A; FI; I\r
-134B; FAA; A\r
-134C; FEE; E\r
-134D; FE; C\r
-134E; FO; O\r
-134F; FWA; WA\r
-1350; PA; V\r
-1351; PU; U\r
-1352; PI; I\r
-1353; PAA; A\r
-1354; PEE; E\r
-1355; PE; C\r
-1356; PO; O\r
-1357; PWA; WA\r
-#\r
-# Cherokee\r
-#\r
-13A0; A; A\r
-13A1; E; E\r
-13A2; I; I\r
-13A3; O; O\r
-13A4; U; U\r
-13A5; V; V\r
-13A6; GA; A \r
-13A7; KA; A \r
-13A8; GE; E\r
-13A9; GI; I\r
-13AA; GO; O\r
-13AB; GU; U\r
-13AC; GV; V\r
-13AD; HA; A\r
-13AE; HE; E\r
-13AF; HI; I\r
-13B0; HO; O\r
-13B1; HU; U\r
-13B2; HV; V\r
-13B3; LA; A\r
-13B4; LE; E\r
-13B5; LI; I\r
-13B6; LO; O\r
-13B7; LU; U\r
-13B8; LV; V\r
-13B9; MA; A\r
-13BA; ME; E\r
-13BB; MI; I\r
-13BC; MO; O\r
-13BD; MU; U\r
-13BE; NA; A\r
-13BF; HNA; A\r
-13C0; NAH; C\r
-13C1; NE; E\r
-13C2; NI; I\r
-13C3; NO; O\r
-13C4; NU; U\r
-13C5; NV; V\r
-13C6; QUA; A\r
-13C7; QUE; E\r
-13C8; QUI; I\r
-13C9; QUO; O\r
-13CA; QUU; U\r
-13CB; QUV; V\r
-13CC; SA; A\r
-13CD; S; C\r
-13CE; SE; E\r
-13CF; SI; I\r
-13D0; SO; O\r
-13D1; SU; U\r
-13D2; SV; V\r
-13D3; DA; A\r
-13D4; TA; A\r
-13D5; DE; E\r
-13D6; TE; E\r
-13D7; DI; I\r
-13D8; TI; I\r
-13D9; DO; O\r
-13DA; DU; U\r
-13DB; DV; V\r
-13DC; DLA; A\r
-13DD; TLA; A\r
-13DE; TLE; E\r
-13DF; TLI; I\r
-13E0; TLO; O\r
-13E1; TLU; U\r
-13E2; TLV; V\r
-13E3; TSA; A\r
-13E4; TSE; E\r
-13E5; TSI; I\r
-13E6; TSO; O\r
-13E7; TSU; U\r
-13E8; TSV; V\r
-13E9; WA; A\r
-13EA; WE; E\r
-13EB; WI; I\r
-13EC; WO; O\r
-13ED; WU; U\r
-13EE; WV; V\r
-13EF; YA; A\r
-13F0; YE; E\r
-13F1; YI; I\r
-13F2; YO; O\r
-13F3; YU; U\r
-13F4; YV; V\r
-#\r
-# 1400 Unified Canadian Aboriginal Syllabics 167F\r
-#\r
-1401; E; E\r
-1402; AAI; AAI\r
-1403; I; I\r
-1404; II; II\r
-1405; O; O\r
-1406; OO; OO\r
-1407; Y-CREE OO; OO\r
-1408; CARRIER EE; EE\r
-1409; CARRIER I; I\r
-140A; A; A\r
-140B; AA; AA\r
-140C; WE; WE\r
-140D; WEST-CREE WE; WE\r
-140E; WI; WI\r
-140F; WEST-CREE WI; WI\r
-1410; WII; WII\r
-1411; WEST-CREE WII; WII\r
-1412; WO; WO\r
-1413; WEST-CREE WO; WO\r
-1414; WOO; WOO\r
-1415; WEST-CREE WOO; WOO\r
-1416; NASKAPI WOO; WOO\r
-1417; WA; WA\r
-1418; WEST-CREE WA; WA\r
-1419; WAA; WAA\r
-141A; WEST-CREE WAA; WAA\r
-141B; NASKAPI WAA; WAA\r
-141C; AI; AI\r
-141D; Y-CREE W; C\r
-142B; EN; C\r
-142C; IN; C\r
-142D; ON; C\r
-142E; AN; C\r
-142F; PE; E\r
-1430; PAAI; AAI\r
-1431; PI; I\r
-1432; PII; II\r
-1433; PO; O\r
-1434; POO; OO\r
-1435; Y-CREE POO; OO\r
-1436; CARRIER HEE; EE\r
-1437; CARRIER HI; I\r
-1438; PA; A\r
-1439; PAA; AA\r
-143A; PWE; WE\r
-143B; WEST-CREE PWE; WE\r
-143C; PWI; WI\r
-143D; WEST-CREE PWI; WI\r
-143E; PWII; WII\r
-143F; WEST-CREE PWII; WII\r
-1440; PWO; WO\r
-1441; WEST-CREE PWO; WO\r
-1442; PWOO; WOO\r
-1443; WEST-CREE PWOO; WOO\r
-1444; PWA; WA\r
-1445; WEST-CREE PWA; WA\r
-1446; PWAA; WAA\r
-1447; WEST-CREE PWAA; WAA\r
-1448; Y-CREE PWAA; WAA\r
-1449; P; C\r
-144A; WEST-CREE P; C\r
-144B; CARRIER H; C\r
-144C; TE; E\r
-144D; TAAI; AAI\r
-144E; TI; I\r
-144F; TII; II\r
-1450; TO; O\r
-1451; TOO; OO\r
-1452; Y-CREE TOO; OO\r
-1453; CARRIER DEE; EE\r
-1454; CARRIER DI; I\r
-1455; TA; A\r
-1456; TAA; AA\r
-1457; TWE; WE\r
-1458; WEST-CREE TWE; WE\r
-1459; TWI; WI\r
-145A; WEST-CREE TWI; WI\r
-145B; TWII; WII\r
-145C; WEST-CREE TWII; WII\r
-145D; TWO; WO\r
-145E; WEST-CREE TWO; WO\r
-145F; TWOO; WOO\r
-1460; WEST-CREE TWOO; WOO\r
-1461; TWA; WA\r
-1462; WEST-CREE TWA; WA\r
-1463; TWAA; WAA\r
-1464; WEST-CREE TWAA; WAA\r
-1465; NASKAPI TWAA; WAA\r
-1466; T; C \r
-1467; TTE; E \r
-1468; TTI; I\r
-1469; TTO; O\r
-146A; TTA; A\r
-146B; KE; E\r
-146C; KAAI; AAI\r
-146D; KI; I\r
-146E; KII; II\r
-146F; KO; O\r
-1470; KOO; OO\r
-1471; Y-CREE KOO; OO\r
-1472; KA; A\r
-1473; KAA; AA\r
-1474; KWE; WE\r
-1475; WEST-CREE KWE; WE\r
-1476; KWI; WI\r
-1477; WEST-CREE KWI; WI\r
-1478; KWII; WII\r
-1479; WEST-CREE KWII; WII\r
-147A; KWO; WO\r
-147B; WEST-CREE KWO; WO\r
-147C; KWOO; WOO\r
-147D; WEST-CREE KWOO; WOO\r
-147E; KWA; WA\r
-147F; WEST-CREE KWA; WA\r
-1480; KWAA; WAA\r
-1481; WEST-CREE KWAA; WAA\r
-1482; NASKAPI KWAA; WAA\r
-1483; K; C\r
-1484; KW; WC\r
-1485; SOUTH-SLAVEY KEH; C\r
-1486; SOUTH-SLAVEY KIH; C\r
-1487; SOUTH-SLAVEY KOH; C\r
-1488; SOUTH-SLAVEY KAH; C\r
-1489; CE; E\r
-148A; CAAI; AAI\r
-148B; CI; I\r
-148C; CII; II\r
-148D; CO; O\r
-148E; COO; OO\r
-148F; Y-CREE COO; OO\r
-1490; CA; A\r
-1491; CAA; AA\r
-1492; CWE; WE\r
-1493; WEST-CREE CWE; WE\r
-1494; CWI; WI\r
-1495; WEST-CREE CWI; WI\r
-1496; CWII; WII\r
-1497; WEST-CREE CWII; WII\r
-1498; CWO; WO\r
-1499; WEST-CREE CWO; WO\r
-149A; CWOO; WOO\r
-149B; WEST-CREE CWOO; WOO\r
-149C; CWA; WA\r
-149D; WEST-CREE CWA; WA\r
-149E; CWAA; WAA\r
-149F; WEST-CREE CWAA; WAA\r
-14A0; NASKAPI CWAA; WAA\r
-14A1; C; C\r
-14A2; SAYISI TH; \r
-14A3; ME; E\r
-14A4; MAAI; AAI\r
-14A5; MI; I\r
-14A6; MII; II\r
-14A7; MO; O\r
-14A8; MOO; OO\r
-14A9; Y-CREE MOO; OO\r
-14AA; MA; A\r
-14AB; MAA; AA\r
-14AC; MWE; WE\r
-14AD; WEST-CREE MWE; WE\r
-14AE; MWI; WI\r
-14AF; WEST-CREE MWI; WI\r
-14B0; MWII; WII\r
-14B1; WEST-CREE MWII; WII\r
-14B2; MWO; WO\r
-14B3; WEST-CREE MWO; WO\r
-14B4; MWOO; WOO\r
-14B5; WEST-CREE MWOO; WOO\r
-14B6; MWA; WA\r
-14B7; WEST-CREE MWA; WA\r
-14B8; MWAA; WAA\r
-14B9; WEST-CREE MWAA; WAA\r
-14BA; NASKAPI MWAA; WAA\r
-14BB; M; C\r
-14BC; WEST-CREE M; C\r
-14BD; MH; C\r
-14BE; ATHAPASCAN M; C\r
-14BF; SAYISI M; C\r
-14C0; NE; E\r
-14C1; NAAI; AAI\r
-14C2; NI; I\r
-14C3; NII; II\r
-14C4; NO; O\r
-14C5; NOO; OO\r
-14C6; Y-CREE NOO; OO\r
-14C7; NA; A\r
-14C8; NAA; AA\r
-14C9; NWE; WE\r
-14CA; WEST-CREE NWE; WE\r
-14CB; NWA; WA\r
-14CC; WEST-CREE NWA; WA\r
-14CD; NWAA; WAA\r
-14CE; WEST-CREE NWAA; WAA\r
-14CF; NASKAPI NWAA; WAA\r
-14D0; N; C\r
-14D1; CARRIER NG; C\r
-14D2; NH; C\r
-14D3; LE; E\r
-14D4; LAAI; AAI\r
-14D5; LI; I\r
-14D6; LII; II\r
-14D7; LO; O\r
-14D8; LOO; OO\r
-14D9; Y-CREE LOO; OO\r
-14DA; LA; A\r
-14DB; LAA; AA\r
-14DC; LWE; WE\r
-14DD; WEST-CREE LWE; WE\r
-14DE; LWI; WI\r
-14DF; WEST-CREE LWI; WI\r
-14E0; LWII; WII\r
-14E1; WEST-CREE LWII; WII\r
-14E2; LWO; WO\r
-14E3; WEST-CREE LWO; WO\r
-14E4; LWOO; WOO\r
-14E5; WEST-CREE LWOO; WOO\r
-14E6; LWA; WA\r
-14E7; WEST-CREE LWA; WA\r
-14E8; LWAA; WAA\r
-14E9; WEST-CREE LWAA; WAA\r
-14EA; L; C\r
-14EB; WEST-CREE L; C\r
-14EC; MEDIAL L; C\r
-14ED; SE; E\r
-14EE; SAAI; AAI\r
-14EF; SI; I\r
-14F0; SII; II\r
-14F1; SO; O\r
-14F2; SOO; OO\r
-14F3; Y-CREE SOO; OO\r
-14F4; SA; A\r
-14F5; SAA; AA\r
-14F6; SWE; WE\r
-14F7; WEST-CREE SWE; WE\r
-14F8; SWI; WI\r
-14F9; WEST-CREE SWI; WI\r
-14FA; SWII; WII\r
-14FB; WEST-CREE SWII; WII\r
-14FC; SWO; WO\r
-14FD; WEST-CREE SWO; WO\r
-14FE; SWOO; WOO\r
-14FF; WEST-CREE SWOO; WOO\r
-1500; SWA; WA\r
-1501; WEST-CREE SWA; WA\r
-1502; SWAA; WAA\r
-1503; WEST-CREE SWAA; WAA\r
-1504; NASKAPI SWAA; WAA\r
-1505; S; C\r
-1506; ATHAPASCAN S; C\r
-1507; SW; WC\r
-1508; BLACKFOOT S; C\r
-1509; MOOSE-CREE SK;C \r
-150A; NASKAPI SKW; C\r
-150B; NASKAPI S-W; C\r
-150C; NASKAPI SPWA; WA\r
-150D; NASKAPI STWA; WA\r
-150E; NASKAPI SKWA; WA\r
-150F; NASKAPI SCWA; WA\r
-1510; SHE; E\r
-1511; SHI; I\r
-1512; SHII; II\r
-1513; SHO; O\r
-1514; SHOO; OO\r
-1515; SHA; A\r
-1516; SHAA; AA\r
-1517; SHWE; WE\r
-1518; WEST-CREE SHWE; WE\r
-1519; SHWI; WI\r
-151A; WEST-CREE SHWI; WI\r
-151B; SHWII; WII\r
-151C; WEST-CREE SHWII; WII\r
-151D; SHWO; WO\r
-151E; WEST-CREE SHWO; WO\r
-151F; SHWOO; WOO\r
-1520; WEST-CREE SHWOO; WOO\r
-1521; SHWA; WA\r
-1522; WEST-CREE SHWA; WA\r
-1523; SHWAA; WAA\r
-1524; WEST-CREE SHWAA; WAA\r
-1525; SH; C\r
-1526; YE; E\r
-1527; YAAI; AAI\r
-1528; YI; I\r
-1529; YII; II\r
-152A; YO; O\r
-152B; YOO; OO\r
-152C; Y-CREE YOO; OO\r
-152D; YA; A\r
-152E; YAA; AA\r
-152F; YWE; WE\r
-1530; WEST-CREE YWE; WE\r
-1531; YWI; WI\r
-1532; WEST-CREE YWI; WI\r
-1533; YWII; WII\r
-1534; WEST-CREE YWII; WII\r
-1535; YWO; WO\r
-1536; WEST-CREE YWO; WO\r
-1537; YWOO; WOO\r
-1538; WEST-CREE YWOO; WOO\r
-1539; YWA; WA\r
-153A; WEST-CREE YWA; WA\r
-153B; YWAA; WAA\r
-153C; WEST-CREE YWAA; WAA\r
-153D; NASKAPI YWAA; WAA\r
-153E; Y; C\r
-153F; BIBLE-CREE Y; C\r
-1540; WEST-CREE Y; C\r
-1541; SAYISI YI; I\r
-1542; RE; E\r
-1543; R-CREE RE; E\r
-1544; WEST-CREE LE; E\r
-1545; RAAI; AAI\r
-1546; RI; I\r
-1547; RII; II\r
-1548; RO; O\r
-1549; ROO; OO\r
-154A; WEST-CREE LO; O\r
-154B; RA; A\r
-154C; RAA; AA\r
-154D; WEST-CREE LA; A\r
-154E; RWAA; WAA\r
-154F; WEST-CREE RWAA; WAA\r
-1550; R; C\r
-1551; WEST-CREE R; C\r
-1552; MEDIAL R; C\r
-1553; FE; E\r
-1554; FAAI; AAI\r
-1555; FI; I\r
-1556; FII; II\r
-1557; FO; O\r
-1558; FOO; OO\r
-1559; FA; A\r
-155A; FAA; AA\r
-155B; FWAA; WAA\r
-155C; WEST-CREE FWAA; WAA\r
-155D; F; C\r
-155E; THE; E\r
-155F; N-CREE THE; E\r
-1560; THI; I\r
-1561; N-CREE THI; I\r
-1562; THII; II\r
-1563; N-CREE THII; II\r
-1564; THO; O\r
-1565; THOO; OO\r
-1566; THA; A\r
-1567; THAA; AA\r
-1568; THWAA; WAA\r
-1569; WEST-CREE THWAA; WAA\r
-156A; TH; C\r
-156B; TTHE; E\r
-156C; TTHI; I\r
-156D; TTHO; O\r
-156E; TTHA; A\r
-156F; TTH; C\r
-1570; TYE; E\r
-1571; TYI; I\r
-1572; TYO; O\r
-1573; TYA; A\r
-1574; NUNAVIK HE; E\r
-1575; NUNAVIK HI; I\r
-1576; NUNAVIK HII; II\r
-1577; NUNAVIK HO; O\r
-1578; NUNAVIK HOO; OO\r
-1579; NUNAVIK HA; A\r
-157A; NUNAVIK HAA; AA\r
-157B; NUNAVIK H; C\r
-157C; NUNAVUT H; C\r
-157D; HK; C\r
-157E; QAAI; AAI\r
-157F; QI; I\r
-1580; QII; II\r
-1581; QO; O\r
-1582; QOO; OO\r
-1583; QA; A\r
-1584; QAA; AA\r
-1585; Q; C\r
-1586; TLHE; E\r
-1587; TLHI; I\r
-1588; TLHO; O\r
-1589; TLHA; A\r
-158A; WEST-CREE RE; E\r
-158B; WEST-CREE RI; I\r
-158C; WEST-CREE RO; O\r
-158D; WEST-CREE RA; A\r
-158E; NGAAI; AAI\r
-158F; NGI; I\r
-1590; NGII; II\r
-1591; NGO; O\r
-1592; NGOO; OO\r
-1593; NGA; A\r
-1594; NGAA; AA\r
-1595; NG; C\r
-1596; NNG; C\r
-1597; SAYISI SHE; E\r
-1598; SAYISI SHI; I\r
-1599; SAYISI SHO; O\r
-159A; SAYISI SHA; A\r
-159B; WOODS-CREE THE; E\r
-159C; WOODS-CREE THI; I\r
-159D; WOODS-CREE THO; O\r
-159E; WOODS-CREE THA; A\r
-159F; WOODS-CREE TH; C\r
-15A0; LHI; I\r
-15A1; LHII; II\r
-15A2; LHO; O\r
-15A3; LHOO; OO\r
-15A4; LHA; A\r
-15A5; LHAA; AA\r
-15A6; LH; C\r
-15A7; TH-CREE THE; E\r
-15A8; TH-CREE THI; I\r
-15A9; TH-CREE THII; II\r
-15AA; TH-CREE THO; O\r
-15AB; TH-CREE THOO; OO\r
-15AC; TH-CREE THA; A\r
-15AD; TH-CREE THAA; AA\r
-15AE; TH-CREE TH; C\r
-15AF; AIVILIK B; C\r
-15B0; BLACKFOOT E; E\r
-15B1; BLACKFOOT I; I\r
-15B2; BLACKFOOT O; O\r
-15B3; BLACKFOOT A; A\r
-15B4; BLACKFOOT WE; E\r
-15B5; BLACKFOOT WI; I\r
-15B6; BLACKFOOT WO; O\r
-15B7; BLACKFOOT WA; A\r
-15B8; BLACKFOOT NE; E\r
-15B9; BLACKFOOT NI; I\r
-15BA; BLACKFOOT NO; O\r
-15BB; BLACKFOOT NA; A\r
-15BC; BLACKFOOT KE; E\r
-15BD; BLACKFOOT KI; I\r
-15BE; BLACKFOOT KO; O\r
-15BF; BLACKFOOT KA; A\r
-15C0; SAYISI HE; E\r
-15C1; SAYISI HI; I\r
-15C2; SAYISI HO; O\r
-15C3; SAYISI HA; A\r
-15C4; CARRIER GHU; U\r
-15C5; CARRIER GHO; O\r
-15C6; CARRIER GHE; E\r
-15C7; CARRIER GHEE; EE\r
-15C8; CARRIER GHI; I\r
-15C9; CARRIER GHA; A\r
-15CA; CARRIER RU; U\r
-15CB; CARRIER RO; O\r
-15CC; CARRIER RE; E\r
-15CD; CARRIER REE; EE\r
-15CE; CARRIER RI; I\r
-15CF; CARRIER RA; A\r
-15D0; CARRIER WU; U\r
-15D1; CARRIER WO; O\r
-15D2; CARRIER WE; E\r
-15D3; CARRIER WEE; EE\r
-15D4; CARRIER WI; I\r
-15D5; CARRIER WA; A\r
-15D6; CARRIER HWU; WU\r
-15D7; CARRIER HWO; WO\r
-15D8; CARRIER HWE; WE\r
-15D9; CARRIER HWEE; WEE\r
-15DA; CARRIER HWI; WI\r
-15DB; CARRIER HWA; WA\r
-15DC; CARRIER THU; U\r
-15DD; CARRIER THO; O\r
-15DE; CARRIER THE; E\r
-15DF; CARRIER THEE; EE\r
-15E0; CARRIER THI; I\r
-15E1; CARRIER THA; A\r
-15E2; CARRIER TTU; U\r
-15E3; CARRIER TTO; O\r
-15E4; CARRIER TTE; E\r
-15E5; CARRIER TTEE; EE\r
-15E6; CARRIER TTI; I\r
-15E7; CARRIER TTA; A\r
-15E8; CARRIER PU; U\r
-15E9; CARRIER PO; O\r
-15EA; CARRIER PE; E\r
-15EB; CARRIER PEE; EE\r
-15EC; CARRIER PI; I\r
-15ED; CARRIER PA; A\r
-15EE; CARRIER P; \r
-15EF; CARRIER GU; U\r
-15F0; CARRIER GO; O\r
-15F1; CARRIER GE; E\r
-15F2; CARRIER GEE; EE\r
-15F3; CARRIER GI; I\r
-15F4; CARRIER GA; A\r
-15F5; CARRIER KHU; U\r
-15F6; CARRIER KHO; O\r
-15F7; CARRIER KHE; E\r
-15F8; CARRIER KHEE; EE\r
-15F9; CARRIER KHI; I\r
-15FA; CARRIER KHA; A\r
-15FB; CARRIER KKU; U\r
-15FC; CARRIER KKO; O\r
-15FD; CARRIER KKE; E\r
-15FE; CARRIER KKEE; EE\r
-15FF; CARRIER KKI; I\r
-1600; CARRIER KKA; A\r
-1601; CARRIER KK; \r
-1602; CARRIER NU; U\r
-1603; CARRIER NO; O\r
-1604; CARRIER NE; E\r
-1605; CARRIER NEE; EE\r
-1606; CARRIER NI; I\r
-1607; CARRIER NA; A\r
-1608; CARRIER MU; U\r
-1609; CARRIER MO; O\r
-160A; CARRIER ME; E\r
-160B; CARRIER MEE; EE\r
-160C; CARRIER MI; I\r
-160D; CARRIER MA; A\r
-160E; CARRIER YU; U\r
-160F; CARRIER YO; O\r
-1610; CARRIER YE; E\r
-1611; CARRIER YEE; EE\r
-1612; CARRIER YI; I\r
-1613; CARRIER YA; A\r
-1614; CARRIER JU; U\r
-1615; SAYISI JU; U\r
-1616; CARRIER JO; O\r
-1617; CARRIER JE; E\r
-1618; CARRIER JEE; EE\r
-1619; CARRIER JI; I\r
-161A; SAYISI JI; I\r
-161B; CARRIER JA; A\r
-161C; CARRIER JJU; U\r
-161D; CARRIER JJO; O\r
-161E; CARRIER JJE; E\r
-161F; CARRIER JJEE; EE\r
-1620; CARRIER JJI; I\r
-1621; CARRIER JJA; A\r
-1622; CARRIER LU; U\r
-1623; CARRIER LO; O\r
-1624; CARRIER LE; E\r
-1625; CARRIER LEE; EE\r
-1626; CARRIER LI; I\r
-1627; CARRIER LA; A\r
-1628; CARRIER DLU; U\r
-1629; CARRIER DLO; O\r
-162A; CARRIER DLE; E\r
-162B; CARRIER DLEE; EE\r
-162C; CARRIER DLI; I\r
-162D; CARRIER DLA; A\r
-162E; CARRIER LHU; U\r
-162F; CARRIER LHO; O\r
-1630; CARRIER LHE; E\r
-1631; CARRIER LHEE; EE\r
-1632; CARRIER LHI; I\r
-1633; CARRIER LHA; A\r
-1634; CARRIER TLHU; U\r
-1635; CARRIER TLHO; O\r
-1636; CARRIER TLHE; E\r
-1637; CARRIER TLHEE; EE\r
-1638; CARRIER TLHI; I\r
-1639; CARRIER TLHA; A\r
-163A; CARRIER TLU; U\r
-163B; CARRIER TLO; O\r
-163C; CARRIER TLE; E\r
-163D; CARRIER TLEE; EE\r
-163E; CARRIER TLI; I\r
-163F; CARRIER TLA; A\r
-1640; CARRIER ZU; U\r
-1641; CARRIER ZO; O\r
-1642; CARRIER ZE; E\r
-1643; CARRIER ZEE; EE\r
-1644; CARRIER ZI; I\r
-1645; CARRIER ZA; A\r
-1646; CARRIER Z; \r
-1647; CARRIER INITIAL Z; \r
-1648; CARRIER DZU; U\r
-1649; CARRIER DZO; O\r
-164A; CARRIER DZE; E\r
-164B; CARRIER DZEE; EE\r
-164C; CARRIER DZI; I\r
-164D; CARRIER DZA; A\r
-164E; CARRIER SU; U\r
-164F; CARRIER SO; O\r
-1650; CARRIER SE; E\r
-1651; CARRIER SEE; EE\r
-1652; CARRIER SI; I\r
-1653; CARRIER SA; A\r
-1654; CARRIER SHU; U\r
-1655; CARRIER SHO; O\r
-1656; CARRIER SHE; E\r
-1657; CARRIER SHEE; EE\r
-1658; CARRIER SHI; I\r
-1659; CARRIER SHA; A\r
-165A; CARRIER SH; \r
-165B; CARRIER TSU; U\r
-165C; CARRIER TSO; O\r
-165D; CARRIER TSE; E\r
-165E; CARRIER TSEE; EE\r
-165F; CARRIER TSI; I\r
-1660; CARRIER TSA; A\r
-1661; CARRIER CHU; U\r
-1662; CARRIER CHO; O\r
-1663; CARRIER CHE; E\r
-1664; CARRIER CHEE; EE\r
-1665; CARRIER CHI; I\r
-1666; CARRIER CHA; A\r
-1667; CARRIER TTSU; U\r
-1668; CARRIER TTSO; O\r
-1669; CARRIER TTSE; E\r
-166A; CARRIER TTSEE; EE\r
-166B; CARRIER TTSI; I\r
-166C; CARRIER TTSA; A\r
-166F; QAI; AI\r
-1670; NGAI; AI\r
-1671; NNGI; I\r
-1672; NNGII; II\r
-1673; NNGO; O\r
-1674; NNGOO; OO\r
-1675; NNGA; A\r
-1676; NNGAA; AA\r
-#\r
-# Katakana\r
-#\r
-30A1; SMALL A; A\r
-30A2; A; A\r
-30A3; SMALL I; I\r
-30A4; I; I\r
-30A5; SMALL U; U\r
-30A6; U; U\r
-30A7; SMALL E; E\r
-30A8; E; E\r
-30A9; SMALL O; O\r
-30AA; O; O\r
-30AB; KA; A\r
-30AC; GA; A\r
-30AD; KI; I\r
-30AE; GI; I\r
-30AF; KU; U\r
-30B0; GU; U\r
-30B1; KE; E\r
-30B2; GE; E\r
-30B3; KO; O\r
-30B4; GO; O\r
-30B5; SA; A\r
-30B6; ZA; A\r
-30B7; SI; I\r
-30B8; ZI; I\r
-30B9; SU; U\r
-30BA; ZU; U\r
-30BB; SE; E\r
-30BC; ZE; E\r
-30BD; SO; O\r
-30BE; ZO; O\r
-30BF; TA; A\r
-30C0; DA; A\r
-30C1; TI; I\r
-30C2; DI; I\r
-30C3; SMALL TU; U\r
-30C4; TU; U\r
-30C5; DU; U\r
-30C6; TE; E\r
-30C7; DE; E\r
-30C8; TO; O\r
-30C9; DO; O\r
-30CA; NA; A\r
-30CB; NI; I\r
-30CC; NU; U\r
-30CD; NE; E\r
-30CE; NO; O\r
-30CF; HA; A\r
-30D0; BA; A\r
-30D1; PA; A\r
-30D2; HI; I\r
-30D3; BI; I\r
-30D4; PI; I\r
-30D5; HU; U\r
-30D6; BU; U\r
-30D7; PU; U\r
-30D8; HE; E\r
-30D9; BE; E\r
-30DA; PE; E\r
-30DB; HO; O\r
-30DC; BO; O\r
-30DD; PO; O\r
-30DE; MA; A\r
-30DF; MI; I\r
-30E0; MU; U\r
-30E1; ME; E\r
-30E2; MO; O\r
-30E3; SMALL YA; A\r
-30E4; YA; A\r
-30E5; SMALL YU; U\r
-30E6; YU; U\r
-30E7; SMALL YO; O\r
-30E8; YO; O\r
-30E9; RA; A\r
-30EA; RI; I\r
-30EB; RU; U\r
-30EC; RE; E\r
-30ED; RO; O\r
-30EE; SMALL WA; A\r
-30EF; WA; A\r
-30F0; WI; I\r
-30F1; WE; E\r
-30F2; WO; O\r
-30F3; N; C\r
-30F4; VU; U\r
-30F5; SMALL KA; A\r
-30F6; SMALL KE; E\r
-30F7; VA; A\r
-30F8; VI; I\r
-30F9; VE; E\r
-30FA; VO; O\r
-32D0; CIRCLED KATAKANA A; A\r
-32D1; CIRCLED KATAKANA I; I\r
-32D2; CIRCLED KATAKANA U; U\r
-32D3; CIRCLED KATAKANA E; E\r
-32D4; CIRCLED KATAKANA O; O\r
-32D5; CIRCLED KATAKANA KA; A\r
-32D6; CIRCLED KATAKANA KI; I\r
-32D7; CIRCLED KATAKANA KU; U\r
-32D8; CIRCLED KATAKANA KE; E\r
-32D9; CIRCLED KATAKANA KO; O\r
-32DA; CIRCLED KATAKANA SA; A\r
-32DB; CIRCLED KATAKANA SI; I\r
-32DC; CIRCLED KATAKANA SU; U\r
-32DD; CIRCLED KATAKANA SE; E\r
-32DE; CIRCLED KATAKANA SO; O\r
-32DF; CIRCLED KATAKANA TA; A\r
-32E0; CIRCLED KATAKANA TI; I\r
-32E1; CIRCLED KATAKANA TU; U\r
-32E2; CIRCLED KATAKANA TE; E\r
-32E3; CIRCLED KATAKANA TO; O\r
-32E4; CIRCLED KATAKANA NA; A\r
-32E5; CIRCLED KATAKANA NI; I\r
-32E6; CIRCLED KATAKANA NU; U\r
-32E7; CIRCLED KATAKANA NE; E\r
-32E8; CIRCLED KATAKANA NO; O\r
-32E9; CIRCLED KATAKANA HA; A\r
-32EA; CIRCLED KATAKANA HI; I\r
-32EB; CIRCLED KATAKANA HU; U\r
-32EC; CIRCLED KATAKANA HE; E\r
-32ED; CIRCLED KATAKANA HO; O\r
-32EE; CIRCLED KATAKANA MA; A\r
-32EF; CIRCLED KATAKANA MI; I\r
-32F0; CIRCLED KATAKANA MU; U\r
-32F1; CIRCLED KATAKANA ME; E\r
-32F2; CIRCLED KATAKANA MO; O\r
-32F3; CIRCLED KATAKANA YA; A\r
-32F4; CIRCLED KATAKANA YU; U\r
-32F5; CIRCLED KATAKANA YO; O\r
-32F6; CIRCLED KATAKANA RA; A\r
-32F7; CIRCLED KATAKANA RI; I\r
-32F8; CIRCLED KATAKANA RU; U\r
-32F9; CIRCLED KATAKANA RE; E\r
-32FA; CIRCLED KATAKANA RO; O\r
-32FB; CIRCLED KATAKANA WA; A\r
-32FC; CIRCLED KATAKANA WI; I\r
-32FD; CIRCLED KATAKANA WE; E\r
-32FE; CIRCLED KATAKANA WO; O\r
-#\r
-# Katakana\r
-#\r
-FF66; HALFWIDTH WO; O\r
-FF67; HALFWIDTH SMALL A; A\r
-FF68; HALFWIDTH SMALL I; I\r
-FF69; HALFWIDTH SMALL U; U\r
-FF6A; HALFWIDTH SMALL E; E\r
-FF6B; HALFWIDTH SMALL O; O\r
-FF6C; HALFWIDTH SMALL YA; A\r
-FF6D; HALFWIDTH SMALL YU; U\r
-FF6E; HALFWIDTH SMALL YO; O\r
-FF6F; HALFWIDTH SMALL TU; U\r
-FF71; HALFWIDTH A; A\r
-FF72; HALFWIDTH I; I\r
-FF73; HALFWIDTH U; U\r
-FF74; HALFWIDTH E; E\r
-FF75; HALFWIDTH O; O\r
-FF76; HALFWIDTH KA; A\r
-FF77; HALFWIDTH KI; I\r
-FF78; HALFWIDTH KU; U\r
-FF79; HALFWIDTH KE; E\r
-FF7A; HALFWIDTH KO; O\r
-FF7B; HALFWIDTH SA; A\r
-FF7C; HALFWIDTH SI; I\r
-FF7D; HALFWIDTH SU; U\r
-FF7E; HALFWIDTH SE; E\r
-FF7F; HALFWIDTH SO; O\r
-FF80; HALFWIDTH TA; A\r
-FF81; HALFWIDTH TI; I\r
-FF82; HALFWIDTH TU; U\r
-FF83; HALFWIDTH TE; E\r
-FF84; HALFWIDTH TO; O\r
-FF85; HALFWIDTH NA; A\r
-FF86; HALFWIDTH NI; I\r
-FF87; HALFWIDTH NU; U\r
-FF88; HALFWIDTH NE; E\r
-FF89; HALFWIDTH NO; O\r
-FF8A; HALFWIDTH HA; A\r
-FF8B; HALFWIDTH HI; I\r
-FF8C; HALFWIDTH HU; U\r
-FF8D; HALFWIDTH HE; E\r
-FF8E; HALFWIDTH HO; O\r
-FF8F; HALFWIDTH MA; A\r
-FF90; HALFWIDTH MI; I\r
-FF91; HALFWIDTH MU; U\r
-FF92; HALFWIDTH ME; E\r
-FF93; HALFWIDTH MO; O\r
-FF94; HALFWIDTH YA; A\r
-FF95; HALFWIDTH YU; U\r
-FF96; HALFWIDTH YO; O\r
-FF97; HALFWIDTH RA; A\r
-FF98; HALFWIDTH RI; I\r
-FF99; HALFWIDTH RU; U\r
-FF9A; HALFWIDTH RE; E\r
-FF9B; HALFWIDTH RO; O\r
-FF9C; HALFWIDTH WA; A\r
-FF9D; HALFWIDTH N; C\r
-#\r
-# Hiragana\r
-#\r
-3041; SMALL A; A\r
-3042; A; A\r
-3043; SMALL I; I\r
-3044; I; I\r
-3045; SMALL U; U\r
-3046; U; U\r
-3047; SMALL E; E\r
-3048; E; E\r
-3049; SMALL O; O\r
-304A; O; O\r
-304B; KA; A\r
-304C; GA; A\r
-304D; KI; I\r
-304E; GI; I\r
-304F; KU; U\r
-3050; GU; U\r
-3051; KE; E\r
-3052; GE; E\r
-3053; KO; O\r
-3054; GO; O\r
-3055; SA; A\r
-3056; ZA; A\r
-3057; SI; I\r
-3058; ZI; I\r
-3059; SU; U\r
-305A; ZU; U\r
-305B; SE; E\r
-305C; ZE; E\r
-305D; SO; O\r
-305E; ZO; O\r
-305F; TA; A\r
-3060; DA; A\r
-3061; TI; I\r
-3062; DI; I\r
-3063; SMALL TU; U\r
-3064; TU; U\r
-3065; DU; U\r
-3066; TE; E\r
-3067; DE; E\r
-3068; TO; O\r
-3069; DO; O\r
-306A; NA; A\r
-306B; NI; I\r
-306C; NU; U\r
-306D; NE; E\r
-306E; NO; O\r
-306F; HA; A\r
-3070; BA; A\r
-3071; PA; A\r
-3072; HI; I\r
-3073; BI; I\r
-3074; PI; I\r
-3075; HU; U\r
-3076; BU; U\r
-3077; PU; U\r
-3078; HE; E\r
-3079; BE; E\r
-307A; PE; E\r
-307B; HO; O\r
-307C; BO; O\r
-307D; PO; O\r
-307E; MA; A\r
-307F; MI; I\r
-3080; MU; U\r
-3081; ME; E\r
-3082; MO; O\r
-3083; SMALL YA; A\r
-3084; YA; A\r
-3085; SMALL YU; U\r
-3086; YU; U\r
-3087; SMALL YO; O\r
-3088; YO; O\r
-3089; RA; A\r
-308A; RI; I\r
-308B; RU; U\r
-308C; RE; E\r
-308D; RO; O\r
-308E; SMALL WA; A\r
-308F; WA; A\r
-3090; WI; I\r
-3091; WE; E\r
-3092; WO; O\r
-3093; N; N\r
-3094; VU; U\r
+################################################################################
+#
+# 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
$utf8::hint_bits = 0x00800000;
+our $VERSION = '1.00';
+
sub import {
$^H |= $utf8::hint_bits;
$enc{caller()} = $_[1] if $_[1];
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
require Carp if $] < 5.00450;
use warnings::register;
+require strict;
sub import {
my $callpack = caller;
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"} =
package warnings;
+our $VERSION = '1.00';
+
=head1 NAME
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
$mask |= $DeadBits{$word} if $fatal ;
}
else
- { croak("unknown warnings category '$word'")}
+ { croak("unknown warnings category '$word'")}
}
return $mask ;
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 ;
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) ;
}
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) ;
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) ;
package warnings::register ;
+our $VERSION = '1.00';
+
=pod
=head1 NAME
}
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!^!..\\!;
}
}
}
if ($PLATFORM eq 'os2') {
$CONFIG_ARGS = $1 if /^(?:config_args)='(.+)'$/;
- $ARCHNAME = $1 if /^(?:archname)='(.+)'$/;
+ $ARCHNAME = $1 if /^(?:archname)='(.+)'$/;
}
}
close(CFG);
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);
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}) {
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'
unless ($define{'DEBUGGING'}) {
skip_symbols [qw(
- Perl_deb
Perl_deb_growlevel
Perl_debop
Perl_debprofdump
if ($PLATFORM eq 'win32') {
foreach my $symbol (qw(
+ setuid
+ setgid
boot_DynaLoader
Perl_init_os_extras
Perl_thread_create
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
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
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);
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
# 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)
# 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
# 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
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
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
# 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) {
}
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
{
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);
}
}
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;
/* 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.
#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
STATIC void
S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
{
- dTHR;
MGS* mgs;
assert(SvMAGICAL(sv));
int
Perl_mg_get(pTHX_ SV *sv)
{
- dTHR;
I32 mgs_ix;
MAGIC* mg;
MAGIC** mgp;
int
Perl_mg_set(pTHX_ SV *sv)
{
- dTHR;
I32 mgs_ix;
MAGIC* mg;
MAGIC* nextmg;
{
MAGIC* mg;
I32 len;
-
+
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
MGVTBL* vtbl = mg->mg_virtual;
if (vtbl && vtbl->svt_len) {
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;
U32
Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
register REGEXP *rx;
if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
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;
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);
}
}
int
Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
Perl_croak(aTHX_ PL_no_modify);
/* NOT REACHED */
return 0;
U32
Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
register I32 paren;
register I32 i;
register REGEXP *rx;
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 &&
{
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;
}
}
return 0;
- case ',':
- return (STRLEN)PL_ofslen;
- case '\\':
- return (STRLEN)PL_orslen;
}
magic_get(sv,mg);
if (!SvPOK(sv) && SvNIOK(sv)) {
int
Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
register I32 paren;
register char *s;
register I32 i;
#ifdef MACOS_TRADITIONAL
{
char msg[256];
-
+
sv_setnv(sv,(double)gMacPerl_OSErr);
sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
}
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)
}
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"))
* 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 &&
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);
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);
#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;
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;
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 */
int
Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
register char *s;
I32 i;
SV** svp;
hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
}
return 0;
-}
+}
/* caller is responsible for stack switching/cleanup */
STATIC int
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)));
U32
Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
-{
+{
dSP;
U32 retval = 0;
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;
int
Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
return 0;
}
int
Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
return 0;
}
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);
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) {
{
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;
int
Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
if (PL_localizing) {
if (PL_localizing == 1)
mg->mg_len <<= 1;
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);
void
Perl_vivify_defelem(pTHX_ SV *sv)
{
- dTHR; /* just for SvREFCNT_inc and SvREFCNT_dec*/
MAGIC *mg;
SV *value = Nullsv;
int
Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
register char *s;
I32 i;
STRLEN len;
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);
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) ;
}
}
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)
if (PL_origargv[i] == s + 1
#ifdef OS2
|| PL_origargv[i] == s + 2
-#endif
+#endif
)
{
++s;
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 */
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));)
#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)
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++;
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);
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;
static void
restore_magic(pTHXo_ void *p)
{
- dTHR;
MGS* mgs = SSPTR(PTR2IV(p), MGS*);
SV* sv = mgs->mgs_sv;
static void
unwind_handler_stack(pTHXo_ void *p)
{
- dTHR;
U32 flags = *(U32*)p;
if (flags & 1)
/* 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.
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 );
-/* 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
#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
#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
#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
#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
#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
#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
#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
#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)
#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
#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
/* 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.
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])) {
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;
PADOFFSET
Perl_pad_findmy(pTHX_ char *name)
{
- dTHR;
I32 off;
I32 pendoff = 0;
SV *sv;
void
Perl_pad_leavemy(pTHX_ I32 fill)
{
- dTHR;
I32 off;
SV **svp = AvARRAY(PL_comppad_name);
SV *sv;
PADOFFSET
Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
{
- dTHR;
SV *sv;
I32 retval;
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",
void
Perl_pad_free(pTHX_ PADOFFSET po)
{
- dTHR;
if (!PL_curpad)
return;
if (AvARRAY(PL_comppad) != PL_curpad)
void
Perl_pad_swipe(pTHX_ PADOFFSET po)
{
- dTHR;
if (AvARRAY(PL_comppad) != PL_curpad)
Perl_croak(aTHX_ "panic: pad_swipe curpad");
if (!po)
Perl_pad_reset(pTHX)
{
#ifdef USE_BROKEN_PAD_RESET
- dTHR;
register I32 po;
if (AvARRAY(PL_comppad) != PL_curpad)
PADOFFSET
Perl_find_threadsv(pTHX_ const char *name)
{
- dTHR;
char *p;
PADOFFSET key;
SV **svp;
#endif
if (! specialWARN(cop->cop_warnings))
SvREFCNT_dec(cop->cop_warnings);
+ if (! specialCopIO(cop->cop_io))
+ SvREFCNT_dec(cop->cop_io);
}
STATIC void
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);
|| (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;
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))
}
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;
}
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);
OP *
Perl_mod(pTHX_ OP *o, I32 type)
{
- dTHR;
OP *kid;
STRLEN n_a;
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) {
OP *
Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
{
- dTHR;
OP *o;
if (ckWARN(WARN_MISC) &&
int
Perl_block_start(pTHX_ int full)
{
- dTHR;
int retval = PL_savestack_ix;
SAVEI32(PL_comppad_name_floor);
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);
void
Perl_newPROG(pTHX_ OP *o)
{
- dTHR;
if (PL_in_eval) {
if (PL_eval_root)
return;
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",
OP *
Perl_fold_constants(pTHX_ register OP *o)
{
- dTHR;
register OP *curop;
I32 type = o->op_type;
SV *sv;
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);
}
OP *
Perl_gen_constant_list(pTHX_ register OP *o)
{
- dTHR;
register OP *curop;
I32 oldtmps_floor = PL_tmps_floor;
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)) {
SV* transv = 0;
U8* tend = t + tlen;
U8* rend = r + rlen;
- I32 ulen;
+ STRLEN ulen;
U32 tfirst = 1;
U32 tlast = 0;
I32 tdiff;
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;
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) {
}
}
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;
}
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
/* 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
OP *
Perl_newPMOP(pTHX_ I32 type, I32 flags)
{
- dTHR;
PMOP *pmop;
NewOp(1101, pmop, 1, PMOP);
OP *
Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
{
- dTHR;
PMOP *pm;
LOGOP *rcop;
I32 repl_has_vars = 0;
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))
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));
void
Perl_package(pTHX_ OP *o)
{
- dTHR;
SV *sv;
save_hptr(&PL_curstash);
}
if (list_assignment(left)) {
- dTHR;
OP *curop;
PL_modcount = 0;
OP *
Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
{
- dTHR;
U32 seq = intro_my();
register COP *cop;
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)
STATIC OP *
S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
{
- dTHR;
LOGOP *logop;
OP *o;
OP *first = *firstp;
OP *
Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
{
- dTHR;
LOGOP *logop;
OP *start;
OP *o;
OP *
Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
{
- dTHR;
LOGOP *range;
OP *flip;
OP *flop;
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 &&
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;
if (cont) {
next = LINKLIST(cont);
- loopflags |= OPpLOOP_CONTINUE;
}
if (expr) {
OP *unstack = newOP(OP_UNSTACK, 0);
OP*
Perl_newLOOPEX(pTHX_ I32 type, OP *label)
{
- dTHR;
OP *o;
STRLEN n_a;
void
Perl_cv_undef(pTHX_ CV *cv)
{
- dTHR;
#ifdef USE_THREADS
if (CvMUTEXP(cv)) {
MUTEX_DESTROY(CvMUTEXP(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))) {
STATIC CV *
S_cv_clone2(pTHX_ CV *proto, CV *outside)
{
- dTHR;
AV* av;
I32 ix;
AV* protopadlist = CvPADLIST(proto);
#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;
}
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;
}
}
+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 *
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)
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
CV *
Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
- dTHR;
STRLEN n_a;
char *name;
char *aname;
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)) {
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,
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);
/* 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;
}
}
}
- 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);
PL_curpad[ix] = Nullsv;
}
}
+ assert(!CvCONST(cv));
+ if (ps && !*ps && op_const_sv(block, cv))
+ CvCONST_on(cv);
}
else {
AV *av = newAV(); /* Will be @_ */
=cut
*/
-void
+CV *
Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
{
- dTHR;
+ CV* cv;
ENTER;
#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;
}
/*
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;
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);
void
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
- dTHR;
register CV *cv;
char *name;
GV *gv;
OP *
Perl_oopsHV(pTHX_ OP *o)
{
- dTHR;
-
switch (o->op_type) {
case OP_PADSV:
case OP_PADAV:
OP *
Perl_ck_rvconst(pTHX_ register OP *o)
{
- dTHR;
SVOP *kid = (SVOP*)cUNOPo->op_first;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
#else
kid->op_sv = SvREFCNT_inc(gv);
#endif
+ kid->op_private = 0;
kid->op_ppaddr = PL_ppaddr[OP_GV];
}
}
OP *
Perl_ck_ftst(pTHX_ OP *o)
{
- dTHR;
I32 type = o->op_type;
if (o->op_flags & OPf_REF) {
OP *
Perl_ck_fun(pTHX_ OP *o)
{
- dTHR;
register OP *kid;
OP **tokid;
OP *sibl;
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:
STATIC void
S_simplify_sort(pTHX_ OP *o)
{
- dTHR;
register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
OP *k;
int reversed;
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;
void
Perl_peep(pTHX_ register OP *o)
{
- dTHR;
register OP* oldop = 0;
STRLEN n_a;
OP *last_composite = Nullop;
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);
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;
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;
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;
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;
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",
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\" "
}
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);
+}
/* 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.
/* 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. */
#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 */
#!/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";
}
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.
} opcode;
#define MAXO 351
+#define OP_phoney_INPUT_ONLY -1
+#define OP_phoney_OUTPUT_ONLY -2
#define OP_IS_SOCKET(op) \
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'
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'
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'
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,
);
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,
);
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,
#include <process.h>
#include <fcntl.h>
+#define PERLIO_NOT_STDIO 0
+
#include "EXTERN.h"
#include "perl.h"
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() */
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;
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);
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 (?)
} 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));
int
do_spawn3(pTHX_ char *cmd, int execf, int flag)
{
- dTHR;
register char **a;
register char *s;
char flags[10];
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;
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;
}
bool
os2exec(pTHX_ char *cmd)
{
- dTHR;
return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
}
((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); }
char *
os2_execname(pTHX)
{
- dTHR;
char buf[300], *p;
if (_execname(buf, sizeof buf) != 0)
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
#if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT)
static char *local_patches[] = {
NULL
- ,"DEVEL7368"
+ ,"DEVEL8341"
,NULL
};
/* 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.
#ifdef MULTIPLICITY
init_interp();
- PL_perl_destruct_level = 1;
+ PL_perl_destruct_level = 1;
#else
if (PL_perl_destruct_level > 0)
init_interp();
void
perl_destruct(pTHXx)
{
- dTHR;
int destruct_level; /* 0=none, 1=full, 2=full with checks */
I32 last_sv_count;
HV *hv;
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
if (destruct_level == 0){
DEBUG_P(debprofdump());
-
+
/* The exit() function will do everything that needs doing. */
return;
}
/* 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;
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;
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);
#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
int
perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
{
- dTHR;
I32 oldscope;
int ret;
dJMPENV;
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
STATIC void *
S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
{
- dTHR;
int argc = PL_origargc;
char **argv = PL_origargv;
char *scriptname = NULL;
#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");
# else
SOCKSinit(argv[0]);
# endif
-#endif
+#endif
init_predump_symbols();
/* init_postdump_symbols not currently designed to be called */
int
perl_run(pTHXx)
{
- dTHR;
I32 oldscope;
int ret = 0;
dJMPENV;
STATIC void *
S_run_body(pTHX_ I32 oldscope)
{
- dTHR;
-
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
PL_sawampersand ? "Enabling" : "Omitting"));
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);
}
#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);
I32
Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
-
+
/* See G_* flags in cop.h */
/* null terminated arg list */
{
{
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;
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 */
I32
Perl_eval_sv(pTHX_ SV *sv, I32 flags)
-
+
/* See G_* flags in cop.h */
{
dSP;
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);
#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++)
}
PL_debug |= 0x80000000;
#else
- dTHR;
if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ WARN_DEBUGGING,
"Recompile perl with -DDEBUGGING to use -D switch\n");
return s;
}
case 'h':
- usage(PL_origargv[0]);
+ usage(PL_origargv[0]);
PerlProc_exit(0);
case 'i':
if (PL_inplace)
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':
#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");
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;
STATIC void
S_init_main_stash(pTHX)
{
- dTHR;
GV *gv;
/* Note that strtab is a rather special HV. Assumptions are made
#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);
STATIC void
S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
{
- dTHR;
-
*fdscript = -1;
if (PL_e_script) {
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) && \
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;
}
*/
#ifdef DOSUID
- dTHR;
char *s, *s2;
if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
#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)
||
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)
/* Pater peccavi, file does not have #! */
PerlIO_rewind(PL_rsfp);
-
+
break;
}
#else
void
Perl_init_debugger(pTHX)
{
- dTHR;
HV *ostash = PL_curstash;
PL_curstash = PL_debstash;
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;
}
STATIC void
S_nuke_stacks(pTHX)
{
- dTHR;
while (PL_curstackinfo->si_next)
PL_curstackinfo = PL_curstackinfo->si_next;
while (PL_curstackinfo) {
STATIC void
S_init_predump_symbols(pTHX)
{
- dTHR;
GV *tmpgv;
IO *io;
STATIC void
S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
{
- dTHR;
char *s;
SV *sv;
GV* tmpgv;
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
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)
#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);
#endif
#ifndef PERLLIB_MANGLE
# define PERLLIB_MANGLE(s,n) (s)
-#endif
+#endif
STATIC void
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);
thr->tid = 0;
thr->next = thr;
thr->prev = thr;
+ thr->thr_done = 0;
MUTEX_UNLOCK(&PL_threads_mutex);
#ifdef HAVE_THREAD_INTERN
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);
void
Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
{
- dTHR;
SV *atsv;
line_t oldline = CopLINE(PL_curcop);
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) {
if (errno & 255)
STATUS_POSIX_SET(errno);
else {
- exitstatus = STATUS_POSIX >> 8;
+ exitstatus = STATUS_POSIX >> 8;
if (exitstatus & 255)
STATUS_POSIX_SET(exitstatus);
else
STATIC void
S_my_exit_jump(pTHX)
{
- dTHR;
register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
/* 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.
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
#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
# 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
#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
#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.
#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
UV *bucket_available_size;
UV nbuckets;
};
+struct RExC_state_t;
typedef MEM_SIZE STRLEN;
# else
# if defined(MACOS_TRADITIONAL)
# include "macos/macish.h"
+# ifndef NO_ENVIRON_ARRAY
+# define NO_ENVIRON_ARRAY
+# endif
# else
# include "unixish.h"
# endif
# else
# define DEBUG_S(a)
# endif
+#define DEBUG_T(a) if (PL_debug & (1<<17)) a
#else
#define DEB(a)
#define DEBUG(a)
#define DEBUG_X(a)
#define DEBUG_D(a)
#define DEBUG_S(a)
+#define DEBUG_T(a)
#endif
#define YYMAXDEPTH 300
# 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);
#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))
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*);
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];
#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
#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) && \
#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();
# 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)
# 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"
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)
#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);
}
#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);
}
#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);
}
#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);
}
}
#undef Perl_is_utf8_char
-int
+STRLEN
Perl_is_utf8_char(pTHXo_ U8 *p)
{
return ((CPerlObj*)pPerl)->Perl_is_utf8_char(p);
}
#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
#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);
}
#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);
}
((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)
((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)
#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);
}
((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)
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);
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
{
return ((CPerlObj*)pPerl)->Perl_whichsig(sig);
}
-#if defined(USE_PURE_BISON)
+#ifdef USE_PURE_BISON
#else
#endif
#if defined(MYMALLOC)
((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)
#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
#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
#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
*
*/
-
#define VOIDUSED 1
#ifdef PERL_MICRO
# include "uconfig.h"
# 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
*/
}
#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
*/
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"
-#undef PerlIO_stderr
-PerlIO *
-PerlIO_stderr(void)
+/* 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,...)
{
- return (PerlIO *) stderr;
+ dTHX;
+ static int dbg = 0;
+ va_list ap;
+ va_start(ap,fmt);
+ if (!dbg)
+ {
+ char *s = PerlEnv_getenv("PERLIO_DEBUG");
+ if (s && *s)
+ dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
+ else
+ dbg = -1;
+ }
+ if (dbg > 0)
+ {
+ dTHX;
+ SV *sv = newSVpvn("",0);
+ char *s;
+ STRLEN len;
+ s = CopFILE(PL_curcop);
+ if (!s)
+ s = "(none)";
+ Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
+ Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
+
+ s = SvPV(sv,len);
+ PerlLIO_write(dbg,s,len);
+ SvREFCNT_dec(sv);
+ }
+ va_end(ap);
}
-#undef PerlIO_stdin
+/*--------------------------------------------------------------------------------------*/
+
+/* Inner level routines */
+
+/* Table of pointers to the PerlIO structs (malloc'ed) */
+PerlIO *_perlio = NULL;
+#define PERLIO_TABLE_SIZE 64
+
PerlIO *
-PerlIO_stdin(void)
+PerlIO_allocate(pTHX)
{
- return (PerlIO *) stdin;
+ /* Find a free slot in the table, allocating new table as necessary */
+ PerlIO **last;
+ PerlIO *f;
+ last = &_perlio;
+ while ((f = *last))
+ {
+ int i;
+ last = (PerlIO **)(f);
+ for (i=1; i < PERLIO_TABLE_SIZE; i++)
+ {
+ if (!*++f)
+ {
+ return f;
+ }
+ }
+ }
+ f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
+ if (!f)
+ {
+ return NULL;
+ }
+ *last = f;
+ return f+1;
}
-#undef PerlIO_stdout
-PerlIO *
-PerlIO_stdout(void)
+void
+PerlIO_cleantable(pTHX_ PerlIO **tablep)
+{
+ PerlIO *table = *tablep;
+ if (table)
+ {
+ int i;
+ PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
+ for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
+ {
+ PerlIO *f = table+i;
+ if (*f)
+ {
+ PerlIO_close(f);
+ }
+ }
+ PerlMemShared_free(table);
+ *tablep = NULL;
+ }
+}
+
+HV *PerlIO_layer_hv;
+AV *PerlIO_layer_av;
+
+void
+PerlIO_cleanup()
{
- return (PerlIO *) stdout;
+ dTHX;
+ PerlIO_cleantable(aTHX_ &_perlio);
}
-#undef PerlIO_fast_gets
-int
-PerlIO_fast_gets(PerlIO *f)
+void
+PerlIO_pop(PerlIO *f)
{
-#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
- return 1;
-#else
+ dTHX;
+ PerlIOl *l = *f;
+ if (l)
+ {
+ PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
+ (*l->tab->Popped)(f);
+ *f = l->next;
+ PerlMemShared_free(l);
+ }
+}
+
+/*--------------------------------------------------------------------------------------*/
+/* XS Interface for perl code */
+
+XS(XS_perlio_import)
+{
+ dXSARGS;
+ GV *gv = CvGV(cv);
+ char *s = GvNAME(gv);
+ STRLEN l = GvNAMELEN(gv);
+ PerlIO_debug("%.*s\n",(int) l,s);
+ XSRETURN_EMPTY;
+}
+
+XS(XS_perlio_unimport)
+{
+ dXSARGS;
+ GV *gv = CvGV(cv);
+ char *s = GvNAME(gv);
+ STRLEN l = GvNAMELEN(gv);
+ PerlIO_debug("%.*s\n",(int) l,s);
+ XSRETURN_EMPTY;
+}
+
+SV *
+PerlIO_find_layer(const char *name, STRLEN len)
+{
+ dTHX;
+ SV **svp;
+ SV *sv;
+ if ((SSize_t) len <= 0)
+ len = strlen(name);
+ svp = hv_fetch(PerlIO_layer_hv,name,len,0);
+ if (svp && (sv = *svp) && SvROK(sv))
+ return *svp;
+ return NULL;
+}
+
+
+static int
+perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
+{
+ if (SvROK(sv))
+ {
+ IO *io = GvIOn((GV *)SvRV(sv));
+ PerlIO *ifp = IoIFP(io);
+ PerlIO *ofp = IoOFP(io);
+ AV *av = (AV *) mg->mg_obj;
+ Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
+ }
return 0;
-#endif
}
-#undef PerlIO_has_cntptr
-int
-PerlIO_has_cntptr(PerlIO *f)
+static int
+perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
{
-#if defined(USE_STDIO_PTR)
- return 1;
-#else
+ if (SvROK(sv))
+ {
+ IO *io = GvIOn((GV *)SvRV(sv));
+ PerlIO *ifp = IoIFP(io);
+ PerlIO *ofp = IoOFP(io);
+ AV *av = (AV *) mg->mg_obj;
+ Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
+ }
return 0;
-#endif
}
-#undef PerlIO_canset_cnt
-int
-PerlIO_canset_cnt(PerlIO *f)
+static int
+perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
{
-#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
- return 1;
-#else
+ Perl_warn(aTHX_ "clear %"SVf,sv);
return 0;
-#endif
}
-#undef PerlIO_set_cnt
+static int
+perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
+{
+ Perl_warn(aTHX_ "free %"SVf,sv);
+ return 0;
+}
+
+MGVTBL perlio_vtab = {
+ perlio_mg_get,
+ perlio_mg_set,
+ NULL, /* len */
+ NULL,
+ perlio_mg_free
+};
+
+XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
+{
+ dXSARGS;
+ SV *sv = SvRV(ST(1));
+ AV *av = newAV();
+ MAGIC *mg;
+ int count = 0;
+ int i;
+ sv_magic(sv, (SV *)av, '~', NULL, 0);
+ SvRMAGICAL_off(sv);
+ mg = mg_find(sv,'~');
+ mg->mg_virtual = &perlio_vtab;
+ mg_magical(sv);
+ Perl_warn(aTHX_ "attrib %"SVf,sv);
+ for (i=2; i < items; i++)
+ {
+ STRLEN len;
+ const char *name = SvPV(ST(i),len);
+ SV *layer = PerlIO_find_layer(name,len);
+ if (layer)
+ {
+ av_push(av,SvREFCNT_inc(layer));
+ }
+ else
+ {
+ ST(count) = ST(i);
+ count++;
+ }
+ }
+ SvREFCNT_dec(av);
+ XSRETURN(count);
+}
+
void
-PerlIO_set_cnt(PerlIO *f, int cnt)
+PerlIO_define_layer(PerlIO_funcs *tab)
{
dTHX;
- if (cnt < -1 && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d\n",cnt);
-#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
- FILE_cnt(f) = cnt;
-#else
- Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system");
+ HV *stash = gv_stashpv("perlio::Layer", TRUE);
+ SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
+ hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
+}
+
+PerlIO_funcs *
+PerlIO_default_layer(I32 n)
+{
+ dTHX;
+ SV **svp;
+ SV *layer;
+ PerlIO_funcs *tab = &PerlIO_stdio;
+ int len;
+ if (!PerlIO_layer_hv)
+ {
+ const char *s = PerlEnv_getenv("PERLIO");
+ newXS("perlio::import",XS_perlio_import,__FILE__);
+ newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
+#if 0
+ newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
+#endif
+ PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
+ PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
+ PerlIO_define_layer(&PerlIO_unix);
+ PerlIO_define_layer(&PerlIO_perlio);
+ PerlIO_define_layer(&PerlIO_stdio);
+ PerlIO_define_layer(&PerlIO_crlf);
+#ifdef HAS_MMAP
+ PerlIO_define_layer(&PerlIO_mmap);
#endif
+ av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
+ if (s)
+ {
+ while (*s)
+ {
+ while (*s && isSPACE((unsigned char)*s))
+ s++;
+ if (*s)
+ {
+ const char *e = s;
+ SV *layer;
+ while (*e && !isSPACE((unsigned char)*e))
+ e++;
+ if (*s == ':')
+ s++;
+ layer = PerlIO_find_layer(s,e-s);
+ if (layer)
+ {
+ PerlIO_debug("Pushing %.*s\n",(e-s),s);
+ av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
+ }
+ else
+ Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
+ s = e;
+ }
+ }
+ }
+ }
+ len = av_len(PerlIO_layer_av);
+ if (len < 1)
+ {
+ if (O_BINARY != O_TEXT)
+ {
+ av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_crlf.name,0)));
+ }
+ else
+ {
+ if (PerlIO_stdio.Set_ptrcnt)
+ {
+ av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
+ }
+ else
+ {
+ av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
+ }
+ }
+ len = av_len(PerlIO_layer_av);
+ }
+ if (n < 0)
+ n += len+1;
+ svp = av_fetch(PerlIO_layer_av,n,0);
+ if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
+ {
+ tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
+ }
+ /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
+ return tab;
+}
+
+#define PerlIO_default_top() PerlIO_default_layer(-1)
+#define PerlIO_default_btm() PerlIO_default_layer(0)
+
+void
+PerlIO_stdstreams()
+{
+ if (!_perlio)
+ {
+ dTHX;
+ PerlIO_allocate(aTHX);
+ PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
+ PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
+ PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
+ }
+}
+
+PerlIO *
+PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len)
+{
+ dTHX;
+ PerlIOl *l = NULL;
+ l = PerlMemShared_calloc(tab->size,sizeof(char));
+ if (l)
+ {
+ Zero(l,tab->size,char);
+ l->next = *f;
+ l->tab = tab;
+ *f = l;
+ PerlIO_debug("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)");
+ if ((*l->tab->Pushed)(f,mode,arg,len) != 0)
+ {
+ PerlIO_pop(f);
+ return NULL;
+ }
+ }
+ return f;
+}
+
+int
+PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
+{
+ if (names)
+ {
+ const char *s = names;
+ while (*s)
+ {
+ while (isSPACE(*s))
+ s++;
+ if (*s == ':')
+ s++;
+ if (*s)
+ {
+ const char *e = s;
+ const char *as = Nullch;
+ const char *ae = Nullch;
+ int count = 0;
+ while (*e && *e != ':' && !isSPACE(*e))
+ {
+ if (*e == '(')
+ {
+ if (!as)
+ as = e;
+ count++;
+ }
+ else if (*e == ')')
+ {
+ if (as && --count == 0)
+ ae = e;
+ }
+ e++;
+ }
+ if (e > s)
+ {
+ if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
+ {
+ /* Pop back to bottom layer */
+ if (PerlIONext(f))
+ {
+ PerlIO_flush(f);
+ while (PerlIONext(f))
+ {
+ PerlIO_pop(f);
+ }
+ }
+ }
+ else if ((e - s) == 4 && strncmp(s,"utf8",4) == 0)
+ {
+ PerlIOBase(f)->flags |= PERLIO_F_UTF8;
+ }
+ else if ((e - s) == 5 && strncmp(s,"bytes",5) == 0)
+ {
+ PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
+ }
+ else
+ {
+ STRLEN len = ((as) ? as : e)-s;
+ SV *layer = PerlIO_find_layer(s,len);
+ if (layer)
+ {
+ PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
+ if (tab)
+ {
+ len = (as) ? (ae-(as++)-1) : 0;
+ if (!PerlIO_push(f,tab,mode,as,len))
+ return -1;
+ }
+ }
+ else
+ Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)len,s);
+ }
+ }
+ s = e;
+ }
+ }
+ }
+ return 0;
+}
+
+
+
+/*--------------------------------------------------------------------------------------*/
+/* Given the abstraction above the public API functions */
+
+int
+PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
+{
+ PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
+ f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
+ if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
+ {
+ PerlIO *top = f;
+ PerlIOl *l;
+ while (l = *top)
+ {
+ if (PerlIOBase(top)->tab == &PerlIO_crlf)
+ {
+ PerlIO_flush(top);
+ PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
+ break;
+ }
+ top = PerlIONext(top);
+ }
+ }
+ return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
+}
+
+#undef PerlIO__close
+int
+PerlIO__close(PerlIO *f)
+{
+ return (*PerlIOBase(f)->tab->Close)(f);
+}
+
+#undef PerlIO_fdupopen
+PerlIO *
+PerlIO_fdupopen(pTHX_ PerlIO *f)
+{
+ char buf[8];
+ int fd = PerlLIO_dup(PerlIO_fileno(f));
+ PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
+ if (new)
+ {
+ Off_t posn = PerlIO_tell(f);
+ PerlIO_seek(new,posn,SEEK_SET);
+ }
+ return new;
+}
+
+#undef PerlIO_close
+int
+PerlIO_close(PerlIO *f)
+{
+ int code = (*PerlIOBase(f)->tab->Close)(f);
+ while (*f)
+ {
+ PerlIO_pop(f);
+ }
+ return code;
+}
+
+#undef PerlIO_fileno
+int
+PerlIO_fileno(PerlIO *f)
+{
+ return (*PerlIOBase(f)->tab->Fileno)(f);
+}
+
+
+
+#undef PerlIO_fdopen
+PerlIO *
+PerlIO_fdopen(int fd, const char *mode)
+{
+ PerlIO_funcs *tab = PerlIO_default_top();
+ if (!_perlio)
+ PerlIO_stdstreams();
+ return (*tab->Fdopen)(tab,fd,mode);
+}
+
+#undef PerlIO_open
+PerlIO *
+PerlIO_open(const char *path, const char *mode)
+{
+ PerlIO_funcs *tab = PerlIO_default_top();
+ if (!_perlio)
+ PerlIO_stdstreams();
+ return (*tab->Open)(tab,path,mode);
+}
+
+#undef PerlIO_reopen
+PerlIO *
+PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
+{
+ if (f)
+ {
+ PerlIO_flush(f);
+ if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
+ {
+ if ((*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0) == 0)
+ return f;
+ }
+ return NULL;
+ }
+ else
+ return PerlIO_open(path,mode);
+}
+
+#undef PerlIO_read
+SSize_t
+PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
+{
+ return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
+}
+
+#undef PerlIO_unread
+SSize_t
+PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
+{
+ return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
+}
+
+#undef PerlIO_write
+SSize_t
+PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
+{
+ return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
}
-#undef PerlIO_set_ptrcnt
-void
-PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
+#undef PerlIO_seek
+int
+PerlIO_seek(PerlIO *f, Off_t offset, int whence)
+{
+ return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
+}
+
+#undef PerlIO_tell
+Off_t
+PerlIO_tell(PerlIO *f)
+{
+ return (*PerlIOBase(f)->tab->Tell)(f);
+}
+
+#undef PerlIO_flush
+int
+PerlIO_flush(PerlIO *f)
+{
+ if (f)
+ {
+ return (*PerlIOBase(f)->tab->Flush)(f);
+ }
+ else
+ {
+ PerlIO **table = &_perlio;
+ int code = 0;
+ while ((f = *table))
+ {
+ int i;
+ table = (PerlIO **)(f++);
+ for (i=1; i < PERLIO_TABLE_SIZE; i++)
+ {
+ if (*f && PerlIO_flush(f) != 0)
+ code = -1;
+ f++;
+ }
+ }
+ return code;
+ }
+}
+
+#undef PerlIO_fill
+int
+PerlIO_fill(PerlIO *f)
+{
+ return (*PerlIOBase(f)->tab->Fill)(f);
+}
+
+#undef PerlIO_isutf8
+int
+PerlIO_isutf8(PerlIO *f)
+{
+ return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
+}
+
+#undef PerlIO_eof
+int
+PerlIO_eof(PerlIO *f)
+{
+ return (*PerlIOBase(f)->tab->Eof)(f);
+}
+
+#undef PerlIO_error
+int
+PerlIO_error(PerlIO *f)
+{
+ return (*PerlIOBase(f)->tab->Error)(f);
+}
+
+#undef PerlIO_clearerr
+void
+PerlIO_clearerr(PerlIO *f)
+{
+ if (f && *f)
+ (*PerlIOBase(f)->tab->Clearerr)(f);
+}
+
+#undef PerlIO_setlinebuf
+void
+PerlIO_setlinebuf(PerlIO *f)
+{
+ (*PerlIOBase(f)->tab->Setlinebuf)(f);
+}
+
+#undef PerlIO_has_base
+int
+PerlIO_has_base(PerlIO *f)
+{
+ if (f && *f)
+ {
+ return (PerlIOBase(f)->tab->Get_base != NULL);
+ }
+ return 0;
+}
+
+#undef PerlIO_fast_gets
+int
+PerlIO_fast_gets(PerlIO *f)
+{
+ if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
+ {
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
+ return (tab->Set_ptrcnt != NULL);
+ }
+ return 0;
+}
+
+#undef PerlIO_has_cntptr
+int
+PerlIO_has_cntptr(PerlIO *f)
+{
+ if (f && *f)
+ {
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
+ return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
+ }
+ return 0;
+}
+
+#undef PerlIO_canset_cnt
+int
+PerlIO_canset_cnt(PerlIO *f)
+{
+ if (f && *f)
+ {
+ PerlIOl *l = PerlIOBase(f);
+ return (l->tab->Set_ptrcnt != NULL);
+ }
+ return 0;
+}
+
+#undef PerlIO_get_base
+STDCHAR *
+PerlIO_get_base(PerlIO *f)
+{
+ return (*PerlIOBase(f)->tab->Get_base)(f);
+}
+
+#undef PerlIO_get_bufsiz
+int
+PerlIO_get_bufsiz(PerlIO *f)
+{
+ return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
+}
+
+#undef PerlIO_get_ptr
+STDCHAR *
+PerlIO_get_ptr(PerlIO *f)
+{
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
+ if (tab->Get_ptr == NULL)
+ return NULL;
+ return (*tab->Get_ptr)(f);
+}
+
+#undef PerlIO_get_cnt
+int
+PerlIO_get_cnt(PerlIO *f)
+{
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
+ if (tab->Get_cnt == NULL)
+ return 0;
+ return (*tab->Get_cnt)(f);
+}
+
+#undef PerlIO_set_cnt
+void
+PerlIO_set_cnt(PerlIO *f,int cnt)
+{
+ (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
+}
+
+#undef PerlIO_set_ptrcnt
+void
+PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
+{
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
+ if (tab->Set_ptrcnt == NULL)
+ {
+ dTHX;
+ Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
+ }
+ (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
+}
+
+/*--------------------------------------------------------------------------------------*/
+/* "Methods" of the "base class" */
+
+IV
+PerlIOBase_fileno(PerlIO *f)
+{
+ return PerlIO_fileno(PerlIONext(f));
+}
+
+char *
+PerlIO_modestr(PerlIO *f,char *buf)
+{
+ char *s = buf;
+ IV flags = PerlIOBase(f)->flags;
+ if (flags & PERLIO_F_APPEND)
+ {
+ *s++ = 'a';
+ if (flags & PERLIO_F_CANREAD)
+ {
+ *s++ = '+';
+ }
+ }
+ else if (flags & PERLIO_F_CANREAD)
+ {
+ *s++ = 'r';
+ if (flags & PERLIO_F_CANWRITE)
+ *s++ = '+';
+ }
+ else if (flags & PERLIO_F_CANWRITE)
+ {
+ *s++ = 'w';
+ if (flags & PERLIO_F_CANREAD)
+ {
+ *s++ = '+';
+ }
+ }
+#if O_TEXT != O_BINARY
+ if (!(flags & PERLIO_F_CRLF))
+ *s++ = 'b';
+#endif
+ *s = '\0';
+ return buf;
+}
+
+IV
+PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
+{
+ PerlIOl *l = PerlIOBase(f);
+ const char *omode = mode;
+ char temp[8];
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
+ l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
+ PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
+ if (tab->Set_ptrcnt != NULL)
+ l->flags |= PERLIO_F_FASTGETS;
+ if (mode)
+ {
+ switch (*mode++)
+ {
+ case 'r':
+ l->flags |= PERLIO_F_CANREAD;
+ break;
+ case 'a':
+ l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
+ break;
+ case 'w':
+ l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
+ break;
+ default:
+ errno = EINVAL;
+ return -1;
+ }
+ while (*mode)
+ {
+ switch (*mode++)
+ {
+ case '+':
+ l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
+ break;
+ case 'b':
+ l->flags &= ~PERLIO_F_CRLF;
+ break;
+ case 't':
+ l->flags |= PERLIO_F_CRLF;
+ break;
+ default:
+ errno = EINVAL;
+ return -1;
+ }
+ }
+ }
+ else
+ {
+ if (l->next)
+ {
+ l->flags |= l->next->flags &
+ (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
+ }
+ }
+#if 0
+ PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
+ f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
+ l->flags,PerlIO_modestr(f,temp));
+#endif
+ return 0;
+}
+
+IV
+PerlIOBase_popped(PerlIO *f)
+{
+ return 0;
+}
+
+SSize_t
+PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
+{
+ Off_t old = PerlIO_tell(f);
+ SSize_t done;
+ PerlIO_push(f,&PerlIO_pending,"r",Nullch,0);
+ done = PerlIOBuf_unread(f,vbuf,count);
+ PerlIOSelf(f,PerlIOBuf)->posn = old - done;
+ return done;
+}
+
+IV
+PerlIOBase_noop_ok(PerlIO *f)
+{
+ return 0;
+}
+
+IV
+PerlIOBase_noop_fail(PerlIO *f)
+{
+ return -1;
+}
+
+IV
+PerlIOBase_close(PerlIO *f)
+{
+ IV code = 0;
+ PerlIO *n = PerlIONext(f);
+ if (PerlIO_flush(f) != 0)
+ code = -1;
+ if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
+ code = -1;
+ PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
+ return code;
+}
+
+IV
+PerlIOBase_eof(PerlIO *f)
+{
+ if (f && *f)
+ {
+ return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
+ }
+ return 1;
+}
+
+IV
+PerlIOBase_error(PerlIO *f)
+{
+ if (f && *f)
+ {
+ return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
+ }
+ return 1;
+}
+
+void
+PerlIOBase_clearerr(PerlIO *f)
+{
+ if (f && *f)
+ {
+ PerlIO *n = PerlIONext(f);
+ PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
+ if (n)
+ PerlIO_clearerr(n);
+ }
+}
+
+void
+PerlIOBase_setlinebuf(PerlIO *f)
+{
+
+}
+
+/*--------------------------------------------------------------------------------------*/
+/* Bottom-most level for UNIX-like case */
+
+typedef struct
+{
+ struct _PerlIO base; /* The generic part */
+ int fd; /* UNIX like file descriptor */
+ int oflags; /* open/fcntl flags */
+} PerlIOUnix;
+
+int
+PerlIOUnix_oflags(const char *mode)
+{
+ int oflags = -1;
+ switch(*mode)
+ {
+ case 'r':
+ oflags = O_RDONLY;
+ if (*++mode == '+')
+ {
+ oflags = O_RDWR;
+ mode++;
+ }
+ break;
+
+ case 'w':
+ oflags = O_CREAT|O_TRUNC;
+ if (*++mode == '+')
+ {
+ oflags |= O_RDWR;
+ mode++;
+ }
+ else
+ oflags |= O_WRONLY;
+ break;
+
+ case 'a':
+ oflags = O_CREAT|O_APPEND;
+ if (*++mode == '+')
+ {
+ oflags |= O_RDWR;
+ mode++;
+ }
+ else
+ oflags |= O_WRONLY;
+ break;
+ }
+ if (*mode == 'b')
+ {
+ oflags |= O_BINARY;
+ oflags &= ~O_TEXT;
+ mode++;
+ }
+ else if (*mode == 't')
+ {
+ oflags |= O_TEXT;
+ oflags &= ~O_BINARY;
+ mode++;
+ }
+ /* Always open in binary mode */
+ oflags |= O_BINARY;
+ if (*mode || oflags == -1)
+ {
+ errno = EINVAL;
+ oflags = -1;
+ }
+ return oflags;
+}
+
+IV
+PerlIOUnix_fileno(PerlIO *f)
+{
+ return PerlIOSelf(f,PerlIOUnix)->fd;
+}
+
+PerlIO *
+PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
+{
+ dTHX;
+ PerlIO *f = NULL;
+ if (*mode == 'I')
+ mode++;
+ if (fd >= 0)
+ {
+ int oflags = PerlIOUnix_oflags(mode);
+ if (oflags != -1)
+ {
+ PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
+ s->fd = fd;
+ s->oflags = oflags;
+ PerlIOBase(f)->flags |= PERLIO_F_OPEN;
+ }
+ }
+ return f;
+}
+
+PerlIO *
+PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
+{
+ dTHX;
+ PerlIO *f = NULL;
+ int oflags = PerlIOUnix_oflags(mode);
+ if (oflags != -1)
+ {
+ int fd = PerlLIO_open3(path,oflags,0666);
+ if (fd >= 0)
+ {
+ PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
+ s->fd = fd;
+ s->oflags = oflags;
+ PerlIOBase(f)->flags |= PERLIO_F_OPEN;
+ }
+ }
+ return f;
+}
+
+int
+PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
+{
+ PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
+ int oflags = PerlIOUnix_oflags(mode);
+ if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
+ (*PerlIOBase(f)->tab->Close)(f);
+ if (oflags != -1)
+ {
+ dTHX;
+ int fd = PerlLIO_open3(path,oflags,0666);
+ if (fd >= 0)
+ {
+ s->fd = fd;
+ s->oflags = oflags;
+ PerlIOBase(f)->flags |= PERLIO_F_OPEN;
+ return 0;
+ }
+ }
+ return -1;
+}
+
+SSize_t
+PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
+{
+ dTHX;
+ int fd = PerlIOSelf(f,PerlIOUnix)->fd;
+ if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
+ return 0;
+ while (1)
+ {
+ SSize_t len = PerlLIO_read(fd,vbuf,count);
+ if (len >= 0 || errno != EINTR)
+ {
+ if (len < 0)
+ PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ else if (len == 0 && count != 0)
+ PerlIOBase(f)->flags |= PERLIO_F_EOF;
+ return len;
+ }
+ }
+}
+
+SSize_t
+PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
+{
+ dTHX;
+ int fd = PerlIOSelf(f,PerlIOUnix)->fd;
+ while (1)
+ {
+ SSize_t len = PerlLIO_write(fd,vbuf,count);
+ if (len >= 0 || errno != EINTR)
+ {
+ if (len < 0)
+ PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ return len;
+ }
+ }
+}
+
+IV
+PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
+{
+ dTHX;
+ Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
+ PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
+ return (new == (Off_t) -1) ? -1 : 0;
+}
+
+Off_t
+PerlIOUnix_tell(PerlIO *f)
+{
+ dTHX;
+ Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
+ return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
+}
+
+IV
+PerlIOUnix_close(PerlIO *f)
+{
+ dTHX;
+ int fd = PerlIOSelf(f,PerlIOUnix)->fd;
+ int code = 0;
+ while (PerlLIO_close(fd) != 0)
+ {
+ if (errno != EINTR)
+ {
+ code = -1;
+ break;
+ }
+ }
+ if (code == 0)
+ {
+ PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
+ }
+ return code;
+}
+
+PerlIO_funcs PerlIO_unix = {
+ "unix",
+ sizeof(PerlIOUnix),
+ PERLIO_K_RAW,
+ PerlIOUnix_fileno,
+ PerlIOUnix_fdopen,
+ PerlIOUnix_open,
+ PerlIOUnix_reopen,
+ PerlIOBase_pushed,
+ PerlIOBase_noop_ok,
+ PerlIOUnix_read,
+ PerlIOBase_unread,
+ PerlIOUnix_write,
+ PerlIOUnix_seek,
+ PerlIOUnix_tell,
+ PerlIOUnix_close,
+ PerlIOBase_noop_ok, /* flush */
+ PerlIOBase_noop_fail, /* fill */
+ PerlIOBase_eof,
+ PerlIOBase_error,
+ PerlIOBase_clearerr,
+ PerlIOBase_setlinebuf,
+ NULL, /* get_base */
+ NULL, /* get_bufsiz */
+ NULL, /* get_ptr */
+ NULL, /* get_cnt */
+ NULL, /* set_ptrcnt */
+};
+
+/*--------------------------------------------------------------------------------------*/
+/* stdio as a layer */
+
+typedef struct
+{
+ struct _PerlIO base;
+ FILE * stdio; /* The stream */
+} PerlIOStdio;
+
+IV
+PerlIOStdio_fileno(PerlIO *f)
+{
+ dTHX;
+ return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
+}
+
+char *
+PerlIOStdio_mode(const char *mode,char *tmode)
+{
+ char *ret = tmode;
+ while (*mode)
+ {
+ *tmode++ = *mode++;
+ }
+ if (O_BINARY != O_TEXT)
+ {
+ *tmode++ = 'b';
+ }
+ *tmode = '\0';
+ return ret;
+}
+
+PerlIO *
+PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
+{
+ dTHX;
+ PerlIO *f = NULL;
+ int init = 0;
+ char tmode[8];
+ if (*mode == 'I')
+ {
+ init = 1;
+ mode++;
+ }
+ if (fd >= 0)
+ {
+ FILE *stdio = NULL;
+ if (init)
+ {
+ switch(fd)
+ {
+ case 0:
+ stdio = PerlSIO_stdin;
+ break;
+ case 1:
+ stdio = PerlSIO_stdout;
+ break;
+ case 2:
+ stdio = PerlSIO_stderr;
+ break;
+ }
+ }
+ else
+ {
+ stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
+ }
+ if (stdio)
+ {
+ PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio);
+ s->stdio = stdio;
+ }
+ }
+ return f;
+}
+
+#undef PerlIO_importFILE
+PerlIO *
+PerlIO_importFILE(FILE *stdio, int fl)
+{
+ dTHX;
+ PerlIO *f = NULL;
+ if (stdio)
+ {
+ PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
+ s->stdio = stdio;
+ }
+ return f;
+}
+
+PerlIO *
+PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
+{
+ dTHX;
+ PerlIO *f = NULL;
+ FILE *stdio = PerlSIO_fopen(path,mode);
+ if (stdio)
+ {
+ char tmode[8];
+ PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
+ (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0),
+ PerlIOStdio);
+ s->stdio = stdio;
+ }
+ return f;
+}
+
+int
+PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
+{
+ dTHX;
+ PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
+ char tmode[8];
+ FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
+ if (!s->stdio)
+ return -1;
+ s->stdio = stdio;
+ return 0;
+}
+
+SSize_t
+PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
+{
+ dTHX;
+ FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
+ SSize_t got = 0;
+ if (count == 1)
+ {
+ STDCHAR *buf = (STDCHAR *) vbuf;
+ /* Perl is expecting PerlIO_getc() to fill the buffer
+ * Linux's stdio does not do that for fread()
+ */
+ int ch = PerlSIO_fgetc(s);
+ if (ch != EOF)
+ {
+ *buf = ch;
+ got = 1;
+ }
+ }
+ else
+ got = PerlSIO_fread(vbuf,1,count,s);
+ return got;
+}
+
+SSize_t
+PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
+{
+ dTHX;
+ FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
+ STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
+ SSize_t unread = 0;
+ while (count > 0)
+ {
+ int ch = *buf-- & 0xff;
+ if (PerlSIO_ungetc(ch,s) != ch)
+ break;
+ unread++;
+ count--;
+ }
+ return unread;
+}
+
+SSize_t
+PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
+{
+ dTHX;
+ return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
+}
+
+IV
+PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
+{
+ dTHX;
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ return PerlSIO_fseek(stdio,offset,whence);
+}
+
+Off_t
+PerlIOStdio_tell(PerlIO *f)
+{
+ dTHX;
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ return PerlSIO_ftell(stdio);
+}
+
+IV
+PerlIOStdio_close(PerlIO *f)
+{
+ dTHX;
+#ifdef HAS_SOCKET
+ int optval, optlen = sizeof(int);
+#endif
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ return(
+#ifdef HAS_SOCKET
+ (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
+ PerlSIO_fclose(stdio) :
+ close(PerlIO_fileno(f))
+#else
+ PerlSIO_fclose(stdio)
+#endif
+ );
+
+}
+
+IV
+PerlIOStdio_flush(PerlIO *f)
+{
+ dTHX;
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
+ {
+ return PerlSIO_fflush(stdio);
+ }
+ else
+ {
+#if 0
+ /* FIXME: This discards ungetc() and pre-read stuff which is
+ not right if this is just a "sync" from a layer above
+ Suspect right design is to do _this_ but not have layer above
+ flush this layer read-to-read
+ */
+ /* Not writeable - sync by attempting a seek */
+ int err = errno;
+ if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
+ errno = err;
+#endif
+ }
+ return 0;
+}
+
+IV
+PerlIOStdio_fill(PerlIO *f)
+{
+ dTHX;
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ int c;
+ /* fflush()ing read-only streams can cause trouble on some stdio-s */
+ if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
+ {
+ if (PerlSIO_fflush(stdio) != 0)
+ return EOF;
+ }
+ c = PerlSIO_fgetc(stdio);
+ if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
+ return EOF;
+ return 0;
+}
+
+IV
+PerlIOStdio_eof(PerlIO *f)
+{
+ dTHX;
+ return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
+}
+
+IV
+PerlIOStdio_error(PerlIO *f)
+{
+ dTHX;
+ return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
+}
+
+void
+PerlIOStdio_clearerr(PerlIO *f)
+{
+ dTHX;
+ PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
+}
+
+void
+PerlIOStdio_setlinebuf(PerlIO *f)
+{
+ dTHX;
+#ifdef HAS_SETLINEBUF
+ PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
+#else
+ PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
+#endif
+}
+
+#ifdef FILE_base
+STDCHAR *
+PerlIOStdio_get_base(PerlIO *f)
+{
+ dTHX;
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ return PerlSIO_get_base(stdio);
+}
+
+Size_t
+PerlIOStdio_get_bufsiz(PerlIO *f)
+{
+ dTHX;
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ return PerlSIO_get_bufsiz(stdio);
+}
+#endif
+
+#ifdef USE_STDIO_PTR
+STDCHAR *
+PerlIOStdio_get_ptr(PerlIO *f)
+{
+ dTHX;
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ return PerlSIO_get_ptr(stdio);
+}
+
+SSize_t
+PerlIOStdio_get_cnt(PerlIO *f)
+{
+ dTHX;
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ return PerlSIO_get_cnt(stdio);
+}
+
+void
+PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
+{
+ dTHX;
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ if (ptr != NULL)
+ {
+#ifdef STDIO_PTR_LVALUE
+ PerlSIO_set_ptr(stdio,ptr);
+#ifdef STDIO_PTR_LVAL_SETS_CNT
+ if (PerlSIO_get_cnt(stdio) != (cnt))
+ {
+ dTHX;
+ assert(PerlSIO_get_cnt(stdio) == (cnt));
+ }
+#endif
+#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
+ /* Setting ptr _does_ change cnt - we are done */
+ return;
+#endif
+#else /* STDIO_PTR_LVALUE */
+ PerlProc_abort();
+#endif /* STDIO_PTR_LVALUE */
+ }
+/* Now (or only) set cnt */
+#ifdef STDIO_CNT_LVALUE
+ PerlSIO_set_cnt(stdio,cnt);
+#else /* STDIO_CNT_LVALUE */
+#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
+ PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
+#else /* STDIO_PTR_LVAL_SETS_CNT */
+ PerlProc_abort();
+#endif /* STDIO_PTR_LVAL_SETS_CNT */
+#endif /* STDIO_CNT_LVALUE */
+}
+
+#endif
+
+PerlIO_funcs PerlIO_stdio = {
+ "stdio",
+ sizeof(PerlIOStdio),
+ PERLIO_K_BUFFERED,
+ PerlIOStdio_fileno,
+ PerlIOStdio_fdopen,
+ PerlIOStdio_open,
+ PerlIOStdio_reopen,
+ PerlIOBase_pushed,
+ PerlIOBase_noop_ok,
+ PerlIOStdio_read,
+ PerlIOStdio_unread,
+ PerlIOStdio_write,
+ PerlIOStdio_seek,
+ PerlIOStdio_tell,
+ PerlIOStdio_close,
+ PerlIOStdio_flush,
+ PerlIOStdio_fill,
+ PerlIOStdio_eof,
+ PerlIOStdio_error,
+ PerlIOStdio_clearerr,
+ PerlIOStdio_setlinebuf,
+#ifdef FILE_base
+ PerlIOStdio_get_base,
+ PerlIOStdio_get_bufsiz,
+#else
+ NULL,
+ NULL,
+#endif
+#ifdef USE_STDIO_PTR
+ PerlIOStdio_get_ptr,
+ PerlIOStdio_get_cnt,
+#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
+ PerlIOStdio_set_ptrcnt
+#else /* STDIO_PTR_LVALUE */
+ NULL
+#endif /* STDIO_PTR_LVALUE */
+#else /* USE_STDIO_PTR */
+ NULL,
+ NULL,
+ NULL
+#endif /* USE_STDIO_PTR */
+};
+
+#undef PerlIO_exportFILE
+FILE *
+PerlIO_exportFILE(PerlIO *f, int fl)
+{
+ FILE *stdio;
+ PerlIO_flush(f);
+ stdio = fdopen(PerlIO_fileno(f),"r+");
+ if (stdio)
+ {
+ PerlIOStdio *s = PerlIOSelf(PerlIO_push(f,&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
+ s->stdio = stdio;
+ }
+ return stdio;
+}
+
+#undef PerlIO_findFILE
+FILE *
+PerlIO_findFILE(PerlIO *f)
+{
+ PerlIOl *l = *f;
+ while (l)
+ {
+ if (l->tab == &PerlIO_stdio)
+ {
+ PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
+ return s->stdio;
+ }
+ l = *PerlIONext(&l);
+ }
+ return PerlIO_exportFILE(f,0);
+}
+
+#undef PerlIO_releaseFILE
+void
+PerlIO_releaseFILE(PerlIO *p, FILE *f)
+{
+}
+
+/*--------------------------------------------------------------------------------------*/
+/* perlio buffer layer */
+
+IV
+PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ b->posn = PerlIO_tell(PerlIONext(f));
+ return PerlIOBase_pushed(f,mode,arg,len);
+}
+
+PerlIO *
+PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
+{
+ dTHX;
+ PerlIO_funcs *tab = PerlIO_default_btm();
+ int init = 0;
+ PerlIO *f;
+ if (*mode == 'I')
+ {
+ init = 1;
+ mode++;
+ }
+#if O_BINARY != O_TEXT
+ /* do something about failing setmode()? --jhi */
+ PerlLIO_setmode(fd, O_BINARY);
+#endif
+ f = (*tab->Fdopen)(tab,fd,mode);
+ if (f)
+ {
+ PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf);
+ if (init && fd == 2)
+ {
+ /* Initial stderr is unbuffered */
+ PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
+ }
+#if 0
+ PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
+ self->name,f,fd,mode,PerlIOBase(f)->flags);
+#endif
+ }
+ return f;
+}
+
+PerlIO *
+PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
+{
+ PerlIO_funcs *tab = PerlIO_default_btm();
+ PerlIO *f = (*tab->Open)(tab,path,mode);
+ if (f)
+ {
+ PerlIO_push(f,self,mode,Nullch,0);
+ }
+ return f;
+}
+
+int
+PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
+{
+ PerlIO *next = PerlIONext(f);
+ int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
+ if (code = 0)
+ code = (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0);
+ return code;
+}
+
+/* This "flush" is akin to sfio's sync in that it handles files in either
+ read or write state
+*/
+IV
+PerlIOBuf_flush(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ int code = 0;
+ if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
+ {
+ /* write() the buffer */
+ STDCHAR *buf = b->buf;
+ STDCHAR *p = buf;
+ int count;
+ PerlIO *n = PerlIONext(f);
+ while (p < b->ptr)
+ {
+ count = PerlIO_write(n,p,b->ptr - p);
+ if (count > 0)
+ {
+ p += count;
+ }
+ else if (count < 0 || PerlIO_error(n))
+ {
+ PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ code = -1;
+ break;
+ }
+ }
+ b->posn += (p - buf);
+ }
+ else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
+ {
+ STDCHAR *buf = PerlIO_get_base(f);
+ /* Note position change */
+ b->posn += (b->ptr - buf);
+ if (b->ptr < b->end)
+ {
+ /* We did not consume all of it */
+ if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
+ {
+ b->posn = PerlIO_tell(PerlIONext(f));
+ }
+ }
+ }
+ b->ptr = b->end = b->buf;
+ PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
+ /* FIXME: Is this right for read case ? */
+ if (PerlIO_flush(PerlIONext(f)) != 0)
+ code = -1;
+ return code;
+}
+
+IV
+PerlIOBuf_fill(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ PerlIO *n = PerlIONext(f);
+ SSize_t avail;
+ /* FIXME: doing the down-stream flush is a bad idea if it causes
+ pre-read data in stdio buffer to be discarded
+ but this is too simplistic - as it skips _our_ hosekeeping
+ and breaks tell tests.
+ if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
+ {
+ }
+ */
+ if (PerlIO_flush(f) != 0)
+ return -1;
+
+ if (!b->buf)
+ PerlIO_get_base(f); /* allocate via vtable */
+
+ b->ptr = b->end = b->buf;
+ if (PerlIO_fast_gets(n))
+ {
+ /* Layer below is also buffered
+ * We do _NOT_ want to call its ->Read() because that will loop
+ * till it gets what we asked for which may hang on a pipe etc.
+ * Instead take anything it has to hand, or ask it to fill _once_.
+ */
+ avail = PerlIO_get_cnt(n);
+ if (avail <= 0)
+ {
+ avail = PerlIO_fill(n);
+ if (avail == 0)
+ avail = PerlIO_get_cnt(n);
+ else
+ {
+ if (!PerlIO_error(n) && PerlIO_eof(n))
+ avail = 0;
+ }
+ }
+ if (avail > 0)
+ {
+ STDCHAR *ptr = PerlIO_get_ptr(n);
+ SSize_t cnt = avail;
+ if (avail > b->bufsiz)
+ avail = b->bufsiz;
+ Copy(ptr,b->buf,avail,STDCHAR);
+ PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
+ }
+ }
+ else
+ {
+ avail = PerlIO_read(n,b->ptr,b->bufsiz);
+ }
+ if (avail <= 0)
+ {
+ if (avail == 0)
+ PerlIOBase(f)->flags |= PERLIO_F_EOF;
+ else
+ PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ return -1;
+ }
+ b->end = b->buf+avail;
+ PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
+ return 0;
+}
+
+SSize_t
+PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ STDCHAR *buf = (STDCHAR *) vbuf;
+ if (f)
+ {
+ if (!b->ptr)
+ PerlIO_get_base(f);
+ if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
+ return 0;
+ while (count > 0)
+ {
+ SSize_t avail = PerlIO_get_cnt(f);
+ SSize_t take = (count < avail) ? count : avail;
+ if (take > 0)
+ {
+ STDCHAR *ptr = PerlIO_get_ptr(f);
+ Copy(ptr,buf,take,STDCHAR);
+ PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
+ count -= take;
+ buf += take;
+ }
+ if (count > 0 && avail <= 0)
+ {
+ if (PerlIO_fill(f) != 0)
+ break;
+ }
+ }
+ return (buf - (STDCHAR *) vbuf);
+ }
+ return 0;
+}
+
+SSize_t
+PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
+{
+ const STDCHAR *buf = (const STDCHAR *) vbuf+count;
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ SSize_t unread = 0;
+ SSize_t avail;
+ if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
+ PerlIO_flush(f);
+ if (!b->buf)
+ PerlIO_get_base(f);
+ if (b->buf)
+ {
+ if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
+ {
+ avail = (b->ptr - b->buf);
+ }
+ else
+ {
+ avail = b->bufsiz;
+ b->end = b->buf + avail;
+ b->ptr = b->end;
+ PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
+ b->posn -= b->bufsiz;
+ }
+ if (avail > (SSize_t) count)
+ avail = count;
+ if (avail > 0)
+ {
+ b->ptr -= avail;
+ buf -= avail;
+ if (buf != b->ptr)
+ {
+ Copy(buf,b->ptr,avail,STDCHAR);
+ }
+ count -= avail;
+ unread += avail;
+ PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
+ }
+ }
+ return unread;
+}
+
+SSize_t
+PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ const STDCHAR *buf = (const STDCHAR *) vbuf;
+ Size_t written = 0;
+ if (!b->buf)
+ PerlIO_get_base(f);
+ if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
+ return 0;
+ while (count > 0)
+ {
+ SSize_t avail = b->bufsiz - (b->ptr - b->buf);
+ if ((SSize_t) count < avail)
+ avail = count;
+ PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
+ if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
+ {
+ while (avail > 0)
+ {
+ int ch = *buf++;
+ *(b->ptr)++ = ch;
+ count--;
+ avail--;
+ written++;
+ if (ch == '\n')
+ {
+ PerlIO_flush(f);
+ break;
+ }
+ }
+ }
+ else
+ {
+ if (avail)
+ {
+ Copy(buf,b->ptr,avail,STDCHAR);
+ count -= avail;
+ buf += avail;
+ written += avail;
+ b->ptr += avail;
+ }
+ }
+ if (b->ptr >= (b->buf + b->bufsiz))
+ PerlIO_flush(f);
+ }
+ if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
+ PerlIO_flush(f);
+ return written;
+}
+
+IV
+PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
+{
+ IV code;
+ if ((code = PerlIO_flush(f)) == 0)
+ {
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
+ code = PerlIO_seek(PerlIONext(f),offset,whence);
+ if (code == 0)
+ {
+ b->posn = PerlIO_tell(PerlIONext(f));
+ }
+ }
+ return code;
+}
+
+Off_t
+PerlIOBuf_tell(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ Off_t posn = b->posn;
+ if (b->buf)
+ posn += (b->ptr - b->buf);
+ return posn;
+}
+
+IV
+PerlIOBuf_close(PerlIO *f)
+{
+ dTHX;
+ IV code = PerlIOBase_close(f);
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ if (b->buf && b->buf != (STDCHAR *) &b->oneword)
+ {
+ PerlMemShared_free(b->buf);
+ }
+ b->buf = NULL;
+ b->ptr = b->end = b->buf;
+ PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
+ return code;
+}
+
+void
+PerlIOBuf_setlinebuf(PerlIO *f)
+{
+ if (f)
+ {
+ PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
+ }
+}
+
+STDCHAR *
+PerlIOBuf_get_ptr(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ if (!b->buf)
+ PerlIO_get_base(f);
+ return b->ptr;
+}
+
+SSize_t
+PerlIOBuf_get_cnt(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ if (!b->buf)
+ PerlIO_get_base(f);
+ if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
+ return (b->end - b->ptr);
+ return 0;
+}
+
+STDCHAR *
+PerlIOBuf_get_base(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ if (!b->buf)
+ {
+ dTHX;
+ if (!b->bufsiz)
+ b->bufsiz = 4096;
+ b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
+ if (!b->buf)
+ {
+ b->buf = (STDCHAR *)&b->oneword;
+ b->bufsiz = sizeof(b->oneword);
+ }
+ b->ptr = b->buf;
+ b->end = b->ptr;
+ }
+ return b->buf;
+}
+
+Size_t
+PerlIOBuf_bufsiz(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ if (!b->buf)
+ PerlIO_get_base(f);
+ return (b->end - b->buf);
+}
+
+void
+PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ if (!b->buf)
+ PerlIO_get_base(f);
+ b->ptr = ptr;
+ if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
+ {
+ dTHX;
+ assert(PerlIO_get_cnt(f) == cnt);
+ assert(b->ptr >= b->buf);
+ }
+ PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
+}
+
+PerlIO_funcs PerlIO_perlio = {
+ "perlio",
+ sizeof(PerlIOBuf),
+ PERLIO_K_BUFFERED,
+ PerlIOBase_fileno,
+ PerlIOBuf_fdopen,
+ PerlIOBuf_open,
+ PerlIOBuf_reopen,
+ PerlIOBuf_pushed,
+ PerlIOBase_noop_ok,
+ PerlIOBuf_read,
+ PerlIOBuf_unread,
+ PerlIOBuf_write,
+ PerlIOBuf_seek,
+ PerlIOBuf_tell,
+ PerlIOBuf_close,
+ PerlIOBuf_flush,
+ PerlIOBuf_fill,
+ PerlIOBase_eof,
+ PerlIOBase_error,
+ PerlIOBase_clearerr,
+ PerlIOBuf_setlinebuf,
+ PerlIOBuf_get_base,
+ PerlIOBuf_bufsiz,
+ PerlIOBuf_get_ptr,
+ PerlIOBuf_get_cnt,
+ PerlIOBuf_set_ptrcnt,
+};
+
+/*--------------------------------------------------------------------------------------*/
+/* Temp layer to hold unread chars when cannot do it any other way */
+
+IV
+PerlIOPending_fill(PerlIO *f)
+{
+ /* Should never happen */
+ PerlIO_flush(f);
+ return 0;
+}
+
+IV
+PerlIOPending_close(PerlIO *f)
+{
+ /* A tad tricky - flush pops us, then we close new top */
+ PerlIO_flush(f);
+ return PerlIO_close(f);
+}
+
+IV
+PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
+{
+ /* A tad tricky - flush pops us, then we seek new top */
+ PerlIO_flush(f);
+ return PerlIO_seek(f,offset,whence);
+}
+
+
+IV
+PerlIOPending_flush(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ if (b->buf && b->buf != (STDCHAR *) &b->oneword)
+ {
+ dTHX;
+ PerlMemShared_free(b->buf);
+ b->buf = NULL;
+ }
+ PerlIO_pop(f);
+ return 0;
+}
+
+void
+PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
+{
+ if (cnt <= 0)
+ {
+ PerlIO_flush(f);
+ }
+ else
+ {
+ PerlIOBuf_set_ptrcnt(f,ptr,cnt);
+ }
+}
+
+IV
+PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len)
+{
+ IV code = PerlIOBase_pushed(f,mode,arg,len);
+ PerlIOl *l = PerlIOBase(f);
+ /* Our PerlIO_fast_gets must match what we are pushed on,
+ or sv_gets() etc. get muddled when it changes mid-string
+ when we auto-pop.
+ */
+ l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
+ (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
+ return code;
+}
+
+SSize_t
+PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
+{
+ SSize_t avail = PerlIO_get_cnt(f);
+ SSize_t got = 0;
+ if (count < avail)
+ avail = count;
+ if (avail > 0)
+ got = PerlIOBuf_read(f,vbuf,avail);
+ if (got < count)
+ got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
+ return got;
+}
+
+
+PerlIO_funcs PerlIO_pending = {
+ "pending",
+ sizeof(PerlIOBuf),
+ PERLIO_K_BUFFERED,
+ PerlIOBase_fileno,
+ NULL,
+ NULL,
+ NULL,
+ PerlIOPending_pushed,
+ PerlIOBase_noop_ok,
+ PerlIOPending_read,
+ PerlIOBuf_unread,
+ PerlIOBuf_write,
+ PerlIOPending_seek,
+ PerlIOBuf_tell,
+ PerlIOPending_close,
+ PerlIOPending_flush,
+ PerlIOPending_fill,
+ PerlIOBase_eof,
+ PerlIOBase_error,
+ PerlIOBase_clearerr,
+ PerlIOBuf_setlinebuf,
+ PerlIOBuf_get_base,
+ PerlIOBuf_bufsiz,
+ PerlIOBuf_get_ptr,
+ PerlIOBuf_get_cnt,
+ PerlIOPending_set_ptrcnt,
+};
+
+
+
+/*--------------------------------------------------------------------------------------*/
+/* crlf - translation
+ On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
+ to hand back a line at a time and keeping a record of which nl we "lied" about.
+ On write translate "\n" to CR,LF
+ */
+
+typedef struct
+{
+ PerlIOBuf base; /* PerlIOBuf stuff */
+ STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
+} PerlIOCrlf;
+
+IV
+PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
+{
+ IV code;
+ PerlIOBase(f)->flags |= PERLIO_F_CRLF;
+ code = PerlIOBuf_pushed(f,mode,arg,len);
+#if 0
+ PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
+ f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
+ PerlIOBase(f)->flags);
+#endif
+ return code;
+}
+
+
+SSize_t
+PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
+{
+ PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
+ if (c->nl)
+ {
+ *(c->nl) = 0xd;
+ c->nl = NULL;
+ }
+ if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
+ return PerlIOBuf_unread(f,vbuf,count);
+ else
+ {
+ const STDCHAR *buf = (const STDCHAR *) vbuf+count;
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ SSize_t unread = 0;
+ if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
+ PerlIO_flush(f);
+ if (!b->buf)
+ PerlIO_get_base(f);
+ if (b->buf)
+ {
+ if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
+ {
+ b->end = b->ptr = b->buf + b->bufsiz;
+ PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
+ b->posn -= b->bufsiz;
+ }
+ while (count > 0 && b->ptr > b->buf)
+ {
+ int ch = *--buf;
+ if (ch == '\n')
+ {
+ if (b->ptr - 2 >= b->buf)
+ {
+ *--(b->ptr) = 0xa;
+ *--(b->ptr) = 0xd;
+ unread++;
+ count--;
+ }
+ else
+ {
+ buf++;
+ break;
+ }
+ }
+ else
+ {
+ *--(b->ptr) = ch;
+ unread++;
+ count--;
+ }
+ }
+ }
+ return unread;
+ }
+}
+
+SSize_t
+PerlIOCrlf_get_cnt(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ if (!b->buf)
+ PerlIO_get_base(f);
+ if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
+ {
+ PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
+ if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
+ {
+ STDCHAR *nl = b->ptr;
+ scan:
+ while (nl < b->end && *nl != 0xd)
+ nl++;
+ if (nl < b->end && *nl == 0xd)
+ {
+ test:
+ if (nl+1 < b->end)
+ {
+ if (nl[1] == 0xa)
+ {
+ *nl = '\n';
+ c->nl = nl;
+ }
+ else
+ {
+ /* Not CR,LF but just CR */
+ nl++;
+ goto scan;
+ }
+ }
+ else
+ {
+ /* Blast - found CR as last char in buffer */
+ if (b->ptr < nl)
+ {
+ /* They may not care, defer work as long as possible */
+ return (nl - b->ptr);
+ }
+ else
+ {
+ int code;
+ dTHX;
+ b->ptr++; /* say we have read it as far as flush() is concerned */
+ b->buf++; /* Leave space an front of buffer */
+ b->bufsiz--; /* Buffer is thus smaller */
+ code = PerlIO_fill(f); /* Fetch some more */
+ b->bufsiz++; /* Restore size for next time */
+ b->buf--; /* Point at space */
+ b->ptr = nl = b->buf; /* Which is what we hand off */
+ b->posn--; /* Buffer starts here */
+ *nl = 0xd; /* Fill in the CR */
+ if (code == 0)
+ goto test; /* fill() call worked */
+ /* CR at EOF - just fall through */
+ }
+ }
+ }
+ }
+ return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
+ }
+ return 0;
+}
+
+void
+PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
+ IV flags = PerlIOBase(f)->flags;
+ if (!b->buf)
+ PerlIO_get_base(f);
+ if (!ptr)
+ {
+ if (c->nl)
+ ptr = c->nl+1;
+ else
+ {
+ ptr = b->end;
+ if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
+ ptr--;
+ }
+ ptr -= cnt;
+ }
+ else
+ {
+ /* Test code - delete when it works ... */
+ STDCHAR *chk;
+ if (c->nl)
+ chk = c->nl+1;
+ else
+ {
+ chk = b->end;
+ if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
+ chk--;
+ }
+ chk -= cnt;
+
+ if (ptr != chk)
+ {
+ dTHX;
+ Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
+ ptr, chk, flags, c->nl, b->end, cnt);
+ }
+ }
+ if (c->nl)
+ {
+ if (ptr > c->nl)
+ {
+ /* They have taken what we lied about */
+ *(c->nl) = 0xd;
+ c->nl = NULL;
+ ptr++;
+ }
+ }
+ b->ptr = ptr;
+ PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
+}
+
+SSize_t
+PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
+{
+ if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
+ return PerlIOBuf_write(f,vbuf,count);
+ else
+ {
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ const STDCHAR *buf = (const STDCHAR *) vbuf;
+ const STDCHAR *ebuf = buf+count;
+ if (!b->buf)
+ PerlIO_get_base(f);
+ if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
+ return 0;
+ while (buf < ebuf)
+ {
+ STDCHAR *eptr = b->buf+b->bufsiz;
+ PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
+ while (buf < ebuf && b->ptr < eptr)
+ {
+ if (*buf == '\n')
+ {
+ if ((b->ptr + 2) > eptr)
+ {
+ /* Not room for both */
+ PerlIO_flush(f);
+ break;
+ }
+ else
+ {
+ *(b->ptr)++ = 0xd; /* CR */
+ *(b->ptr)++ = 0xa; /* LF */
+ buf++;
+ if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
+ {
+ PerlIO_flush(f);
+ break;
+ }
+ }
+ }
+ else
+ {
+ int ch = *buf++;
+ *(b->ptr)++ = ch;
+ }
+ if (b->ptr >= eptr)
+ {
+ PerlIO_flush(f);
+ break;
+ }
+ }
+ }
+ if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
+ PerlIO_flush(f);
+ return (buf - (STDCHAR *) vbuf);
+ }
+}
+
+IV
+PerlIOCrlf_flush(PerlIO *f)
+{
+ PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
+ if (c->nl)
+ {
+ *(c->nl) = 0xd;
+ c->nl = NULL;
+ }
+ return PerlIOBuf_flush(f);
+}
+
+PerlIO_funcs PerlIO_crlf = {
+ "crlf",
+ sizeof(PerlIOCrlf),
+ PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
+ PerlIOBase_fileno,
+ PerlIOBuf_fdopen,
+ PerlIOBuf_open,
+ PerlIOBuf_reopen,
+ PerlIOCrlf_pushed,
+ PerlIOBase_noop_ok, /* popped */
+ PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
+ PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
+ PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
+ PerlIOBuf_seek,
+ PerlIOBuf_tell,
+ PerlIOBuf_close,
+ PerlIOCrlf_flush,
+ PerlIOBuf_fill,
+ PerlIOBase_eof,
+ PerlIOBase_error,
+ PerlIOBase_clearerr,
+ PerlIOBuf_setlinebuf,
+ PerlIOBuf_get_base,
+ PerlIOBuf_bufsiz,
+ PerlIOBuf_get_ptr,
+ PerlIOCrlf_get_cnt,
+ PerlIOCrlf_set_ptrcnt,
+};
+
+#ifdef HAS_MMAP
+/*--------------------------------------------------------------------------------------*/
+/* mmap as "buffer" layer */
+
+typedef struct
+{
+ PerlIOBuf base; /* PerlIOBuf stuff */
+ Mmap_t mptr; /* Mapped address */
+ Size_t len; /* mapped length */
+ STDCHAR *bbuf; /* malloced buffer if map fails */
+} PerlIOMmap;
+
+static size_t page_size = 0;
+
+IV
+PerlIOMmap_map(PerlIO *f)
{
dTHX;
-#ifdef FILE_bufsiz
- STDCHAR *e = FILE_base(f) + FILE_bufsiz(f);
- int ec = e - ptr;
- if (ptr > e + 1 && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "Setting ptr %p > end+1 %p\n", ptr, e + 1);
- if (cnt != ec && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d, ptr implies %d\n",cnt,ec);
-#endif
-#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE)
- FILE_ptr(f) = ptr;
+ PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
+ PerlIOBuf *b = &m->base;
+ IV flags = PerlIOBase(f)->flags;
+ IV code = 0;
+ if (m->len)
+ abort();
+ if (flags & PERLIO_F_CANREAD)
+ {
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ int fd = PerlIO_fileno(f);
+ struct stat st;
+ code = fstat(fd,&st);
+ if (code == 0 && S_ISREG(st.st_mode))
+ {
+ SSize_t len = st.st_size - b->posn;
+ if (len > 0)
+ {
+ Off_t posn;
+ if (!page_size) {
+#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
+ {
+ SETERRNO(0,SS$_NORMAL);
+# ifdef _SC_PAGESIZE
+ page_size = sysconf(_SC_PAGESIZE);
+# else
+ page_size = sysconf(_SC_PAGE_SIZE);
+# endif
+ if ((long)page_size < 0) {
+ if (errno) {
+ SV *error = ERRSV;
+ char *msg;
+ STRLEN n_a;
+ (void)SvUPGRADE(error, SVt_PV);
+ msg = SvPVx(error, n_a);
+ Perl_croak(aTHX_ "panic: sysconf: %s", msg);
+ }
+ else
+ Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
+ }
+ }
#else
- Perl_croak(aTHX_ "Cannot set 'ptr' of FILE * on this system");
+# ifdef HAS_GETPAGESIZE
+ page_size = getpagesize();
+# else
+# if defined(I_SYS_PARAM) && defined(PAGESIZE)
+ page_size = PAGESIZE; /* compiletime, bad */
+# endif
+# endif
#endif
-#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
- FILE_cnt(f) = cnt;
-#else
- Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system");
+ if ((IV)page_size <= 0)
+ Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
+ }
+ if (b->posn < 0)
+ {
+ /* This is a hack - should never happen - open should have set it ! */
+ b->posn = PerlIO_tell(PerlIONext(f));
+ }
+ posn = (b->posn / page_size) * page_size;
+ len = st.st_size - posn;
+ m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
+ if (m->mptr && m->mptr != (Mmap_t) -1)
+ {
+#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
+ madvise(m->mptr, len, MADV_SEQUENTIAL);
+#endif
+#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
+ madvise(m->mptr, len, MADV_WILLNEED);
#endif
+ PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
+ b->end = ((STDCHAR *)m->mptr) + len;
+ b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
+ b->ptr = b->buf;
+ m->len = len;
+ }
+ else
+ {
+ b->buf = NULL;
+ }
+ }
+ else
+ {
+ PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
+ b->buf = NULL;
+ b->ptr = b->end = b->ptr;
+ code = -1;
+ }
+ }
+ }
+ return code;
}
-#undef PerlIO_get_cnt
-int
-PerlIO_get_cnt(PerlIO *f)
+IV
+PerlIOMmap_unmap(PerlIO *f)
{
-#ifdef FILE_cnt
- return FILE_cnt(f);
-#else
- dTHX;
- Perl_croak(aTHX_ "Cannot get 'cnt' of FILE * on this system");
- return -1;
-#endif
+ PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
+ PerlIOBuf *b = &m->base;
+ IV code = 0;
+ if (m->len)
+ {
+ if (b->buf)
+ {
+ code = munmap(m->mptr, m->len);
+ b->buf = NULL;
+ m->len = 0;
+ m->mptr = NULL;
+ if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
+ code = -1;
+ }
+ b->ptr = b->end = b->buf;
+ PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
+ }
+ return code;
}
-#undef PerlIO_get_bufsiz
-int
-PerlIO_get_bufsiz(PerlIO *f)
+STDCHAR *
+PerlIOMmap_get_base(PerlIO *f)
{
-#ifdef FILE_bufsiz
- return FILE_bufsiz(f);
-#else
- dTHX;
- Perl_croak(aTHX_ "Cannot get 'bufsiz' of FILE * on this system");
- return -1;
-#endif
+ PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
+ PerlIOBuf *b = &m->base;
+ if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
+ {
+ /* Already have a readbuffer in progress */
+ return b->buf;
+ }
+ if (b->buf)
+ {
+ /* We have a write buffer or flushed PerlIOBuf read buffer */
+ m->bbuf = b->buf; /* save it in case we need it again */
+ b->buf = NULL; /* Clear to trigger below */
+ }
+ if (!b->buf)
+ {
+ PerlIOMmap_map(f); /* Try and map it */
+ if (!b->buf)
+ {
+ /* Map did not work - recover PerlIOBuf buffer if we have one */
+ b->buf = m->bbuf;
+ }
+ }
+ b->ptr = b->end = b->buf;
+ if (b->buf)
+ return b->buf;
+ return PerlIOBuf_get_base(f);
}
-#undef PerlIO_get_ptr
-STDCHAR *
-PerlIO_get_ptr(PerlIO *f)
+SSize_t
+PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
{
-#ifdef FILE_ptr
- return FILE_ptr(f);
-#else
- dTHX;
- Perl_croak(aTHX_ "Cannot get 'ptr' of FILE * on this system");
- return NULL;
-#endif
+ PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
+ PerlIOBuf *b = &m->base;
+ if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
+ PerlIO_flush(f);
+ if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
+ {
+ b->ptr -= count;
+ PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
+ return count;
+ }
+ if (m->len)
+ {
+ /* Loose the unwritable mapped buffer */
+ PerlIO_flush(f);
+ /* If flush took the "buffer" see if we have one from before */
+ if (!b->buf && m->bbuf)
+ b->buf = m->bbuf;
+ if (!b->buf)
+ {
+ PerlIOBuf_get_base(f);
+ m->bbuf = b->buf;
+ }
+ }
+return PerlIOBuf_unread(f,vbuf,count);
}
-#undef PerlIO_get_base
-STDCHAR *
-PerlIO_get_base(PerlIO *f)
+SSize_t
+PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
{
-#ifdef FILE_base
- return FILE_base(f);
-#else
- dTHX;
- Perl_croak(aTHX_ "Cannot get 'base' of FILE * on this system");
- return NULL;
-#endif
+ PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
+ PerlIOBuf *b = &m->base;
+ if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
+ {
+ /* No, or wrong sort of, buffer */
+ if (m->len)
+ {
+ if (PerlIOMmap_unmap(f) != 0)
+ return 0;
+ }
+ /* If unmap took the "buffer" see if we have one from before */
+ if (!b->buf && m->bbuf)
+ b->buf = m->bbuf;
+ if (!b->buf)
+ {
+ PerlIOBuf_get_base(f);
+ m->bbuf = b->buf;
+ }
+ }
+ return PerlIOBuf_write(f,vbuf,count);
}
-#undef PerlIO_has_base
-int
-PerlIO_has_base(PerlIO *f)
+IV
+PerlIOMmap_flush(PerlIO *f)
{
-#ifdef FILE_base
- return 1;
-#else
- return 0;
-#endif
+ PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
+ PerlIOBuf *b = &m->base;
+ IV code = PerlIOBuf_flush(f);
+ /* Now we are "synced" at PerlIOBuf level */
+ if (b->buf)
+ {
+ if (m->len)
+ {
+ /* Unmap the buffer */
+ if (PerlIOMmap_unmap(f) != 0)
+ code = -1;
+ }
+ else
+ {
+ /* We seem to have a PerlIOBuf buffer which was not mapped
+ * remember it in case we need one later
+ */
+ m->bbuf = b->buf;
+ }
+ }
+ return code;
}
-#undef PerlIO_puts
-int
-PerlIO_puts(PerlIO *f, const char *s)
+IV
+PerlIOMmap_fill(PerlIO *f)
{
- return fputs(s,f);
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ IV code = PerlIO_flush(f);
+ if (code == 0 && !b->buf)
+ {
+ code = PerlIOMmap_map(f);
+ }
+ if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
+ {
+ code = PerlIOBuf_fill(f);
+ }
+ return code;
}
-#undef PerlIO_open
-PerlIO *
-PerlIO_open(const char *path, const char *mode)
+IV
+PerlIOMmap_close(PerlIO *f)
{
- return fopen(path,mode);
+ PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
+ PerlIOBuf *b = &m->base;
+ IV code = PerlIO_flush(f);
+ if (m->bbuf)
+ {
+ b->buf = m->bbuf;
+ m->bbuf = NULL;
+ b->ptr = b->end = b->buf;
+ }
+ if (PerlIOBuf_close(f) != 0)
+ code = -1;
+ return code;
}
-#undef PerlIO_fdopen
-PerlIO *
-PerlIO_fdopen(int fd, const char *mode)
+
+PerlIO_funcs PerlIO_mmap = {
+ "mmap",
+ sizeof(PerlIOMmap),
+ PERLIO_K_BUFFERED,
+ PerlIOBase_fileno,
+ PerlIOBuf_fdopen,
+ PerlIOBuf_open,
+ PerlIOBuf_reopen,
+ PerlIOBuf_pushed,
+ PerlIOBase_noop_ok,
+ PerlIOBuf_read,
+ PerlIOMmap_unread,
+ PerlIOMmap_write,
+ PerlIOBuf_seek,
+ PerlIOBuf_tell,
+ PerlIOBuf_close,
+ PerlIOMmap_flush,
+ PerlIOMmap_fill,
+ PerlIOBase_eof,
+ PerlIOBase_error,
+ PerlIOBase_clearerr,
+ PerlIOBuf_setlinebuf,
+ PerlIOMmap_get_base,
+ PerlIOBuf_bufsiz,
+ PerlIOBuf_get_ptr,
+ PerlIOBuf_get_cnt,
+ PerlIOBuf_set_ptrcnt,
+};
+
+#endif /* HAS_MMAP */
+
+void
+PerlIO_init(void)
{
- return fdopen(fd,mode);
+ if (!_perlio)
+ {
+#ifndef WIN32
+ atexit(&PerlIO_cleanup);
+#endif
+ }
}
-#undef PerlIO_reopen
-PerlIO *
-PerlIO_reopen(const char *name, const char *mode, PerlIO *f)
+#undef PerlIO_stdin
+PerlIO *
+PerlIO_stdin(void)
{
- return freopen(name,mode,f);
+ if (!_perlio)
+ PerlIO_stdstreams();
+ return &_perlio[1];
}
-#undef PerlIO_close
-int
-PerlIO_close(PerlIO *f)
+#undef PerlIO_stdout
+PerlIO *
+PerlIO_stdout(void)
{
- return fclose(f);
+ if (!_perlio)
+ PerlIO_stdstreams();
+ return &_perlio[2];
}
-#undef PerlIO_eof
-int
-PerlIO_eof(PerlIO *f)
+#undef PerlIO_stderr
+PerlIO *
+PerlIO_stderr(void)
{
- return feof(f);
+ if (!_perlio)
+ PerlIO_stdstreams();
+ return &_perlio[3];
}
+/*--------------------------------------------------------------------------------------*/
+
#undef PerlIO_getname
char *
PerlIO_getname(PerlIO *f, char *buf)
{
-#ifdef VMS
- return fgetname(f,buf);
-#else
dTHX;
Perl_croak(aTHX_ "Don't know how to get file name");
return NULL;
-#endif
-}
-
-#undef PerlIO_getc
-int
-PerlIO_getc(PerlIO *f)
-{
- return fgetc(f);
-}
-
-#undef PerlIO_error
-int
-PerlIO_error(PerlIO *f)
-{
- return ferror(f);
}
-#undef PerlIO_clearerr
-void
-PerlIO_clearerr(PerlIO *f)
-{
- clearerr(f);
-}
-#undef PerlIO_flush
-int
-PerlIO_flush(PerlIO *f)
-{
- return Fflush(f);
-}
+/*--------------------------------------------------------------------------------------*/
+/* Functions which can be called on any kind of PerlIO implemented
+ in terms of above
+*/
-#undef PerlIO_fileno
-int
-PerlIO_fileno(PerlIO *f)
+#undef PerlIO_getc
+int
+PerlIO_getc(PerlIO *f)
{
- return fileno(f);
+ STDCHAR buf[1];
+ SSize_t count = PerlIO_read(f,buf,1);
+ if (count == 1)
+ {
+ return (unsigned char) buf[0];
+ }
+ return EOF;
}
-#undef PerlIO_setlinebuf
-void
-PerlIO_setlinebuf(PerlIO *f)
+#undef PerlIO_ungetc
+int
+PerlIO_ungetc(PerlIO *f, int ch)
{
-#ifdef HAS_SETLINEBUF
- setlinebuf(f);
-#else
-# ifdef __BORLANDC__ /* Borland doesn't like NULL size for _IOLBF */
- setvbuf(f, Nullch, _IOLBF, BUFSIZ);
-# else
- setvbuf(f, Nullch, _IOLBF, 0);
-# endif
-#endif
+ if (ch != EOF)
+ {
+ STDCHAR buf = ch;
+ if (PerlIO_unread(f,&buf,1) == 1)
+ return ch;
+ }
+ return EOF;
}
#undef PerlIO_putc
-int
+int
PerlIO_putc(PerlIO *f, int ch)
{
- return putc(ch,f);
-}
-
-#undef PerlIO_ungetc
-int
-PerlIO_ungetc(PerlIO *f, int ch)
-{
- return ungetc(ch,f);
+ STDCHAR buf = ch;
+ return PerlIO_write(f,&buf,1);
}
-#undef PerlIO_read
-SSize_t
-PerlIO_read(PerlIO *f, void *buf, Size_t count)
+#undef PerlIO_puts
+int
+PerlIO_puts(PerlIO *f, const char *s)
{
- return fread(buf,1,count,f);
+ STRLEN len = strlen(s);
+ return PerlIO_write(f,s,len);
}
-#undef PerlIO_write
-SSize_t
-PerlIO_write(PerlIO *f, const void *buf, Size_t count)
+#undef PerlIO_rewind
+void
+PerlIO_rewind(PerlIO *f)
{
- return fwrite1(buf,1,count,f);
+ PerlIO_seek(f,(Off_t)0,SEEK_SET);
+ PerlIO_clearerr(f);
}
#undef PerlIO_vprintf
-int
-PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
-{
- return vfprintf(f,fmt,ap);
-}
-
-#undef PerlIO_tell
-Off_t
-PerlIO_tell(PerlIO *f)
-{
-#if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64)
- return ftello(f);
-#else
- return ftell(f);
-#endif
-}
-
-#undef PerlIO_seek
int
-PerlIO_seek(PerlIO *f, Off_t offset, int whence)
+PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
{
-#if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64)
- return fseeko(f,offset,whence);
+ dTHX;
+ SV *sv = newSVpvn("",0);
+ char *s;
+ STRLEN len;
+#ifdef NEED_VA_COPY
+ va_list apc;
+ Perl_va_copy(ap, apc);
+ sv_vcatpvf(sv, fmt, &apc);
#else
- return fseek(f,offset,whence);
+ sv_vcatpvf(sv, fmt, &ap);
#endif
-}
-
-#undef PerlIO_rewind
-void
-PerlIO_rewind(PerlIO *f)
-{
- rewind(f);
+ s = SvPV(sv,len);
+ return PerlIO_write(f,s,len);
}
#undef PerlIO_printf
-int
+int
PerlIO_printf(PerlIO *f,const char *fmt,...)
{
va_list ap;
int result;
va_start(ap,fmt);
- result = vfprintf(f,fmt,ap);
+ result = PerlIO_vprintf(f,fmt,ap);
va_end(ap);
return result;
}
#undef PerlIO_stdoutf
-int
+int
PerlIO_stdoutf(const char *fmt,...)
{
va_list ap;
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)
#endif
#ifndef PerlIO_vsprintf
-int
+int
PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
{
int val = vsprintf(s, fmt, 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);
}
}
#endif
#ifndef PerlIO_sprintf
-int
+int
PerlIO_sprintf(char *s, int n, const char *fmt,...)
{
va_list ap;
}
#endif
-#endif /* !PERL_IMPLICIT_SYS */
-#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 */
--- /dev/null
+#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 */
-/*
- * 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)
(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)
#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);
/* 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 */
#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 */
/* 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*));
#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)
#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)
/* 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)
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"
/* 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.
;
texpr : /* NULL means true */
- { (void)scan_num("1"); $$ = yylval.opval; }
+ { (void)scan_num("1", &yylval); $$ = yylval.opval; }
| expr
;
--libpods=perlfunc:perlguts:perlvar:perlrun:perlop
PERL = ../miniperl
+PERLILIB = $(PERL) -I../lib
REALPERL = ../perl
all: $(CONVERTERS) man
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)
tex: pod2latex $(TEX)
toc: buildtoc
- $(PERL) -I../lib buildtoc
+ $(PERLILIB) buildtoc
.SUFFIXES: .pm .pod
perlamiga
perlcygwin
perldos
+ perlepoc
perlhpux
perlmachten
+ perlmpeix
perlos2
perlos390
perlposix-bc
+ perlsolaris
perlvms
+ perlvos
perlwin32
);
perlamiga
perlcygwin
perldos
+ perlepoc
perlhpux
perlmachten
+ perlmpeix
perlos2
perlos390
perlposix-bc
+ perlsolaris
perlvms
+ perlvos
perlwin32
);
for (@ARCHPODS) { s/$/.pod/ }
Here should be listed all the extra programs' documentation, but they
don't all have manual pages yet:
- =over
+ =over 4
=item a2p
}
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;
}
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/\.$//;
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,
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>.
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
The new restrictions when tainting include:
-=over
+=over 4
=item No glob() or <*>
=head2 New and changed syntax
-=over
+=over 4
=item $coderef->(PARAMS)
=head2 New and changed builtin constants
-=over
+=over 4
=item __PACKAGE__
=head2 New and changed builtin variables
-=over
+=over 4
=item $^E
=head2 New and changed builtin functions
-=over
+=over 4
=item delete on slices
The C<UNIVERSAL> package automatically contains the following methods that
are inherited by all other classes:
-=over
+=over 4
=item isa(CLASS)
See L<perltie> for other kinds of tie()s.
-=over
+=over 4
=item TIEHANDLE classname, LIST
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
Six new pragmatic modules exist:
-=over
+=over 4
=item use autouse MODULE => qw(sub1 sub2 sub3)
There have been quite a few changes made to DB_File. Here are a few of
the highlights:
-=over
+=over 4
=item *
=head2 pod2html
-=over
+=over 4
=item Sends converted HTML to standard output
=head2 xsubpp
-=over
+=over 4
=item C<void> XSUBs now default to returning nothing
=head1 C Language API Changes
-=over
+=over 4
=item C<gv_fetchmethod> and C<perl_call_sv>
Many of the base and library pods were updated. These
new pods are included in section 1:
-=over
+=over 4
=item L<perldelta>
(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
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>
=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
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.
=head2 New Modules
-=over
+=over 4
=item B
=head2 Changes in existing modules
-=over
+=over 4
=item Benchmark
=head1 New Diagnostics
-=over
+=over 4
=item Ambiguous call resolved as CORE::%s(), qualify as such or use &
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.
=head1 Obsolete Diagnostics
-=over
+=over 4
=item Can't mktemp()
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
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
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
=head2 Compatible C Source API Changes
-=over
+=over 4
=item C<PATCHLEVEL> is now C<PERL_VERSION>
=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
=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
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
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
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
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
=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)
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
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
=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>.
=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
=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
=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)
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
=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.
=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
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 *
The fields of interest which may appear in the last line are
-=over
+=over 4
=item C<anchored> I<STRING> C<at> I<POS>
Here is some explanation of that format:
-=over
+=over 4
=item C<buckets SMALLEST(APPROX)..GREATEST(APPROX)>
Here are explanations for other I<Id>s above:
-=over
+=over 4
=item C<717>
If warn() string starts with
-=over
+=over 4
=item C<!!!>
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:
DB<4> c 29
main::f2c(temp:29): return $c;
-
+
And have a look at the return value:
DB<5> p $c
floating `'$ at 4..2147483647 (checking floating) stclass `EXACTF <pe>'
anchored(BOL) minlen 4
Omitting $` $& $' support.
-
+
EXECUTING...
Freeing REx: `^pe(a)*rl$'
> 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
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]]
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 < ?
(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.
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
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
=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
=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?
(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
(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
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
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
=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()
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
(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
(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.
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
=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
{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
=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
(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
=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/
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
(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
=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
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
(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
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
=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
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' .
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.
=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
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
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.
=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
=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
=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.
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
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
=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
=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
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"?
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
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
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.
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
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?
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
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
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:
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,
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
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
Recommended books on (or mostly on) Perl follow.
-=over
+=over 4
=item References
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
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
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
=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.*
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
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
=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
=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:
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?
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
=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.
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.
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?
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
=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
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
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
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.
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?
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
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
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
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
=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,...]?
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,
# 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>""
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]
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
=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.
=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
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.)
$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
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.''
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.
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;
substr($a, 0, 3) = "Tom";
Although those with a pattern matching kind of thought process will
-likely prefer:
+likely prefer
$a =~ s/^.../Tom/;
=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:
$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
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+//;
=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
=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?
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 {
@@@ }
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;
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.
=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).
=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;
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
}
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?
}
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
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 = ();
}
@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] }
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.
$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.
} 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 {
=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.
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
=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);
# 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;
# *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.
}
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
$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;
}
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.
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
$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.
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);
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:
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.
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).
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 {
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
=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
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?
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
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
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:
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?
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?
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.
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
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`;
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
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;
# 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?
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?
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;
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.
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?
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
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?
$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.
=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
=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
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?
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:
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?
=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
=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
}
}
-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?
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
* 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".
=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>.
}
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?
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.
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 );
=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:
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;
}
}
}
-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);
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()));
=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.
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?
=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.
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:
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>.
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):
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
$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
$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
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
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.
+
=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.
$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();
(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
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
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.
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;
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.
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
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).
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?
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).
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
=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()?
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
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:
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
`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
=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:
=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.
=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?
=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?
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.
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.
use lib '/u/mydir/perl';
-This is almost the same as:
+This is almost the same as
BEGIN {
unshift(@INC, '/u/mydir/perl');
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
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:
=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.
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?
=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
=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>;
=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:
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
=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")'
=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.
perlfilter - Source Filters
-
=head1 DESCRIPTION
This article is about a little-known feature of Perl called
arranged by category. Some functions appear in more
than one place.
-=over
+=over 4
=item Functions for SCALARs or strings
-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.
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
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
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:
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;
=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
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
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>;
=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
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
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);
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
=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.
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.
Inside such a I<pseudo-block> the following service is available:
-=over
+=over 4
=item C<SAVEINT(int i)>
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)>
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
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
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
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
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.
Some of the functionality of the debugging code can be achieved using XS
modules.
-
+
-Dr => use re 'debug'
-Dx => use O 'Debug'
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.
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:
=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
-=pod
-
=head1 NAME
perlhist - the Perl history records
=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.
=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
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,
BEGIN { $ENV{PATH} = '/usr/ucb:/bin' }
use Socket;
use Carp;
- $EOL = "\015\012";
+ my $EOL = "\015\012";
sub spawn; # forward declaration
sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }
my $port = shift || 2345;
my $proto = getprotobyname('tcp');
- ($port) = $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,
use Carp;
BEGIN { $ENV{PATH} = '/usr/ucb:/bin' }
+ sub spawn; # forward declaration
sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }
my $NAME = '/tmp/catsock';
};
}
+ 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
Here are what those parameters to the C<new> constructor mean:
-=over
+=over 4
=item C<Proto>
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
bless [], $class ;
}
-
+
1 ;
The code below makes use of both modules, but it only enables warnings from
=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>.
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
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
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
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
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
=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.
=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.
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
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()):
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.
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
Package for overloading perl operations
+=item perlio
+
+Configure C level IO
+
=item re
Alter regular expression behaviour
Control optional warnings
+=item warnings::register
+
+Warnings import function
+
=back
=head2 Standard Modules
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
Warn of errors (from perspective of caller)
-=item Carp::Heavy
-
-Carp guts
-
=item Class::Struct
Declare struct-like datatypes as Perl classes
Provides screen dump of Perl data.
+=item Encode
+
+Character encodings
+
=item English
Use nice English (or awk) names for ugly punctuation variables
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
Supply object methods for filehandles
+=item Filter::Simple
+
+Simplified source filtering
+
=item FindBin
Locate directory of original perl script
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
Load the C socket.h defines and structure manipulators
+=item Storable
+
+Persistency for perl data structures
+
=item Symbol
Manipulate Perl symbols and their names
=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
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.
=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:
These conversions are governed by the following general rules:
-=over
+=over 4
=item *
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>
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.
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.
=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
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
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///>
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
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
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
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
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");
=head1 heading
=head2 heading
+ =head3 heading
+ =head4 heading
=item text
=over N
=back
=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
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.
=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 *
=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
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
precompiled binary and source code form from http://www.novell.com/
as well as from CPAN.
-=item
+=item *
Plan 9, F<README.plan9>
=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
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
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",
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>
=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.
=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
=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
=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
=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
=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
=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
=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
=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.
=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
=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
=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
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
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
=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>
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
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.
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
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
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
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:
use strict;
$Nice::DEBUG = 0 unless defined $Nice::DEBUG;
-=over
+=over 4
=item TIESCALAR classname, LIST
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
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
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
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.)
=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
Here are the methods for the DotFiles tied hash.
-=over
+=over 4
=item TIEHASH classname, LIST
package Shout;
-=over
+=over 4
=item TIEHANDLE classname, LIST
UNTIE by Nick Ing-Simmons <F<nick@ing-simmons.net>>
+Tying Arrays by Casey Tweten <F<crt@kiski.net>>
=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
=head2 perlfaq - frequently asked questions about Perl ($Date: 1999/05/23
20:38:02 $)
-=over
+=over 4
=item DESCRIPTION
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
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
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?,
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
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
=item Author and Copyright Information
-=over
+=over 4
=item Bundled Distributions
=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
=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
=head2 perlbook - Perl book information
-=over
+=over 4
=item DESCRIPTION
=head2 perlsyn - Perl syntax
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item Declarations
=head2 perldata - Perl data types
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item Variable names
=head2 perlop - Perl operators and precedence
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item Terms and List Operators (Leftward)
=head2 perlsub - Perl subroutines
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item Private Variables via my()
=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
=head2 perlfunc - Perl builtin functions
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item Perl Functions by Category
=head2 perlreftut - Mark's very short tutorial about references
-=over
+=over 4
=item DESCRIPTION
=item Syntax
-=over
+=over 4
=item Making References
=item Credits
-=over
+=over 4
=item Distribution Conditions
=head2 perldsc - Perl Data Structures Cookbook
-=over
+=over 4
=item DESCRIPTION
=item ARRAYS OF ARRAYS
-=over
+=over 4
=item Declaration of a ARRAY OF ARRAYS
=item HASHES OF ARRAYS
-=over
+=over 4
=item Declaration of a HASH OF ARRAYS
=item ARRAYS OF HASHES
-=over
+=over 4
=item Declaration of a ARRAY OF HASHES
=item HASHES OF HASHES
-=over
+=over 4
=item Declaration of a HASH OF HASHES
=item MORE ELABORATE RECORDS
-=over
+=over 4
=item Declaration of MORE ELABORATE RECORDS
=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
=item AUTHOR AND COPYRIGHT
-=over
+=over 4
=item Acknowledgments
=head2 perlpod - plain old documentation
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item Verbatim Paragraph
=head2 perlstyle - Perl style guide
-=over
+=over 4
=item DESCRIPTION
=head2 perltrap - Perl traps for the unwary
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item Awk Traps
=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
=head2 perldiag - various Perl diagnostics
-=over
+=over 4
=item DESCRIPTION
=head2 perllexwarn - Perl Lexical Warnings
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item Default Warnings and Optional Warnings
=head2 perldebtut - Perl debugging tutorial
-=over
+=over 4
=item DESCRIPTION
=head2 perldebug - Perl debugging
-=over
+=over 4
=item DESCRIPTION
=item The Perl Debugger
-=over
+=over 4
=item Debugger Commands
=head2 perlvar - Perl predefined variables
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item Predefined Names
=head2 perllol - Manipulating Arrays of Arrays in Perl
-=over
+=over 4
=item DESCRIPTION
=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
=item Open E<agrave> la C
-=over
+=over 4
=item Permissions E<agrave> la mode
=item Obscure Open Tricks
-=over
+=over 4
=item Re-Opening Files (dups)
=item Other I/O Issues
-=over
+=over 4
=item Opening Non-File Files
=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
=item AUTHOR AND COPYRIGHT
-=over
+=over 4
=item Acknowledgments
=head2 perlre - Perl regular expressions
-=over
+=over 4
=item DESCRIPTION
i, m, s, x
-=over
+=over 4
=item Regular Expressions
=head2 perlref - Perl references and nested data structures
-=over
+=over 4
=item NOTE
=item DESCRIPTION
-=over
+=over 4
=item Making References
=head2 perlform - Perl formats
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item Format Variables
=item NOTES
-=over
+=over 4
=item Footers
=head2 perlboot - Beginner's Object-Oriented Tutorial
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item If we could talk to the animals...
=head2 perltoot - Tom's object-oriented tutorial for perl
-=over
+=over 4
=item DESCRIPTION
=item Creating a Class
-=over
+=over 4
=item Object Representation
=item Class Data
-=over
+=over 4
=item Accessing Class Data
=item Inheritance
-=over
+=over 4
=item Overridden Methods
=item Alternate Object Representations
-=over
+=over 4
=item Arrays as Objects
=item AUTOLOAD: Proxy Methods
-=over
+=over 4
=item Autoloaded Data Methods
=item Metaclassical Tools
-=over
+=over 4
=item Class::Struct
=item Data Members as Variables
+=back
+
=item NOTES
+=over 4
+
=item Object Terminology
=back
=item COPYRIGHT
-=over
+=over 4
=item Acknowledgments
=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
=item Class Data as Lexical Variables
-=over
+=over 4
=item Privacy and Responsibility
=head2 perlobj - Perl objects
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item An Object is Simply a Reference
=head2 perlbot - Bag'o Object Tricks (the BOT)
-=over
+=over 4
=item DESCRIPTION
=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
=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
=head2 perlipc - Perl interprocess communication (signals, fifos, pipes,
safe subprocesses, sockets, and semaphores)
-=over
+=over 4
=item DESCRIPTION
=item Named Pipes
-=over
+=over 4
=item WARNING
=item Using open() for IPC
-=over
+=over 4
=item Filehandles
=item Sockets: Client/Server Communication
-=over
+=over 4
=item Internet Line Terminators
=item TCP Clients with IO::Socket
-=over
+=over 4
=item A Simple Client
=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
=head2 perlnumber - semantics of numbers and numeric operations in Perl
-=over
+=over 4
=item SYNOPSIS
=head2 perlthrtut - tutorial on threads in Perl
-=over
+=over 4
=item DESCRIPTION
=item Threaded Program Models
-=over
+=over 4
=item Boss/Worker
=item Thread Basics
-=over
+=over 4
=item Basic Thread Support
=item Threads And Data
-=over
+=over 4
=item Shared And Unshared Data
=item Threads And Code
-=over
+=over 4
=item Semaphores: Synchronizing Data Access
=item General Thread Utility Routines
-=over
+=over 4
=item What Thread Am I In?
=item Bibliography
-=over
+=over 4
=item Introductory Texts
=head2 perlport - Writing portable Perl
-=over
+=over 4
=item DESCRIPTION
=item ISSUES
-=over
+=over 4
=item Newlines
=item PLATFORMS
-=over
+=over 4
=item Unix
=item FUNCTION IMPLEMENTATIONS
-=over
+=over 4
=item Alphabetical Listing of Perl Functions
=head2 perllocale - Perl locale handling (internationalization and
localization)
-=over
+=over 4
=item DESCRIPTION
=item USING LOCALES
-=over
+=over 4
=item The use locale pragma
=item LOCALE CATEGORIES
-=over
+=over 4
=item Category LC_COLLATE: Collation
=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,
=item NOTES
-=over
+=over 4
=item Backward compatibility
=item BUGS
-=over
+=over 4
=item Broken systems
=head2 perlunicode - Unicode support in Perl
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item Important Caveat
=head2 perlebcdic - Considerations for running Perl on EBCDIC platforms
-=over
+=over 4
=item DESCRIPTION
=item COMMON CHARACTER CODE SETS
-=over
+=over 4
=item ASCII
=item CONVERSIONS
-=over
+=over 4
=item tr///
=item SORTING
-=over
+=over 4
=item Ignore ASCII vs. EBCDIC sort differences.
=item TRANFORMATION FORMATS
-=over
+=over 4
=item URL decoding and encoding
=item OS ISSUES
-=over
+=over 4
=item OS/400
=head2 perlsec - Perl security
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item Laundering and Detecting Tainted Data
=head2 perlmod - Perl modules (packages and symbol tables)
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item Packages
=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
=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
=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
=head2 perlmodinstall - Installing CPAN Modules
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item PREAMBLE
=head2 perlnewmod - preparing a new module for distribution
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item Warning
=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?
=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
=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?
=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)?
=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?
=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)?
=item Data: Dates
-=over
+=over 4
=item How do I find the week-of-the-year/day-of-the-year?
=item Data: Strings
-=over
+=over 4
=item How do I validate input?
=item Data: Arrays
-=over
+=over 4
=item What is the difference between a list and an array?
=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?
=item Data: Hashes (Associative Arrays)
-=over
+=over 4
=item How do I process an entire hash?
=item Data: Misc
-=over
+=over 4
=item How do I handle binary data correctly?
=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?
=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?
=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?
=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?
=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?
=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?
=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?
=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?
=head2 perlcompile - Introduction to the Perl Compiler-Translator
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item Layout
=item Using The Back Ends
-=over
+=over 4
=item The Cross Referencing Back End
=head2 perlembed - how to embed perl in your C program
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item PREAMBLE
=back
-=item Embedding Perl under Windows
+=item Embedding Perl under Win32
=item MORAL
=head2 perldebguts - Guts of Perl debugging
-=over
+=over 4
=item DESCRIPTION
=item Debugger Internals
-=over
+=over 4
=item Writing Your Own Debugger
=item Debugging regular expressions
-=over
+=over 4
=item Compile-time output
=item Debugging Perl memory usage
-=over
+=over 4
=item Using C<$ENV{PERL_DEBUG_MSTATS}>
=head2 perlxstut, perlXStut - Tutorial for writing XSUBs
-=over
+=over 4
=item DESCRIPTION
=item SPECIAL NOTES
-=over
+=over 4
=item make
=item TUTORIAL
-=over
+=over 4
=item EXAMPLE 1
=item Author
-=over
+=over 4
=item Last Changed
=head2 perlxs - XS language reference manual
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item Introduction
=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
=item The & Unary Operator
-=item Inserting Comments and C Preprocessor Directives
+=item Inserting POD, Comments and C Preprocessor Directives
=item Using XS With C++
=head2 perlguts - Introduction to the Perl API
-=over
+=over 4
=item DESCRIPTION
=item Variables
-=over
+=over 4
=item Datatypes
=item Subroutines
-=over
+=over 4
=item XSUBs and the Argument Stack
=item Compiled code
-=over
+=over 4
=item Code tree
=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
A, p, d, s, n, r, f, m, o, j, x
-=over
+=over 4
=item Formatted Printing of IVs, UVs, and NVs
=item Unicode Support
-=over
+=over 4
=item What B<is> Unicode, anyway?
=head2 perlcall - Perl calling conventions from C
-=over
+=over 4
=item DESCRIPTION
=item FLAG VALUES
-=over
+=over 4
=item G_VOID
=item EXAMPLES
-=over
+=over 4
=item No Parameters, Nothing returned
=head2 perlutil - utilities packaged with the Perl distribution
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item DOCUMENTATION
=head2 perlfilter - Source Filters
-=over
+=over 4
=item DESCRIPTION
=head2 perldbmfilter - Perl DBM Filters
-=over
+=over 4
=item SYNOPSIS
B<filter_store_key>, B<filter_store_value>, B<filter_fetch_key>,
B<filter_fetch_value>
-=over
+=over 4
=item The Filter
=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,
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,
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
=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
=head2 perlapio - perl's IO abstraction interface.
-=over
+=over 4
=item SYNOPSIS
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
=head2 perltodo - Perl TO-DO List
-=over
+=over 4
=item DESCRIPTION
=item Infrastructure
-=over
+=over 4
=item Mailing list archives
=item Configure
-=over
+=over 4
=item Install HTML
=item Perl Language
-=over
-
-=item our ($var)
+=over 4
=item 64-bit Perl
=item Perl Internals
-=over
+=over 4
=item magic_setisa
=item Documentation
-=over
+=over 4
=item A clear division into tutorial and reference
=item Modules
-=over
+=over 4
=item Update the POSIX extension to conform with the POSIX 1003.1 Edition 2
=item Update semibroken auxiliary tools; h2ph, a2p, etc.
-=item POD Converters
-
=item pod2html
=item Podchecker
=item Tom's Wishes
-=over
+=over 4
=item Webperl
=item Win32 Stuff
-=over
+=over 4
=item Rename new headers to be consistent with the rest
=item Possible pragmas
-=over
+=over 4
=item 'less'
=item Optimizations
-=over
+=over 4
=item constant function cache
=item To Do Or Not To Do
-=over
+=over 4
=item Making my() work on "package" variables
=item Threading
-=over
+=over 4
=item Modules
=item Compiler
-=over
+=over 4
=item Optimization
=item Recently Finished Tasks
-=over
+=over 4
=item Figure a way out of $^(capital letter)
=head2 perlhack - How to hack at the Perl internals
-=over
+=over 4
=item DESCRIPTION
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
=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
=item EXTERNAL TOOLS FOR DEBUGGING PERL
-=over
+=over 4
=item Rational Software's Purify
=head2 perlhist - the Perl history records
-=over
+=over 4
=item DESCRIPTION
=item THE KEEPERS OF THE PUMPKIN
-=over
+=over 4
=item PUMPKIN?
=item THE RECORDS
-=over
+=over 4
=item SELECTED RELEASE SIZES
=head2 perldelta - what's new for perl v5.7.0
-=over
+=over 4
=item DESCRIPTION
=item Modules and Pragmata
-=over
+=over 4
=item New Modules
=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
=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
=item Known Problems
-=over
+=over 4
=item Unicode Support Still Far From Perfect
=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
=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
=item Modules and Pragmata
-=over
+=over 4
=item Modules
=item Utility Changes
-=over
+=over 4
=item dprofpp
=item Performance enhancements
-=over
+=over 4
=item Simple sort() using { $a <=> $b } and the like are optimized
=item Installation and Configuration Improvements
-=over
+=over 4
=item -Dusethreads means something different
=item Platform specific changes
-=over
+=over 4
=item Supported platforms
=item Significant bug fixes
-=over
+=over 4
=item <HANDLE> on empty files
=item Incompatible Changes
-=over
+=over 4
=item Perl Source Incompatibilities
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
=item Known Problems
-=over
+=over 4
=item Thread test failures
=head2 perl5005delta, perldelta - what's new for perl5.005
-=over
+=over 4
=item DESCRIPTION
=item Incompatible Changes
-=over
+=over 4
=item WARNING: This version is not binary compatible with Perl 5.004.
=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
=item Core Changes
-=over
+=over 4
=item Threads
=item Supported Platforms
-=over
+=over 4
=item New Platforms
=item Modules and Pragmata
-=over
+=over 4
=item New Modules
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
=head2 perl5004delta, perldelta - what's new for perl5.004
-=over
+=over 4
=item DESCRIPTION
=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
=item Support for More Operating Systems
-=over
+=over 4
=item Win32
=item Modules
-=over
+=over 4
=item Required Updates
=item Utility Changes
-=over
+=over 4
=item pod2html
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
=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
=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
=item Accessing documentation
-=over
+=over 4
=item Manpages
=item BUILD
-=over
+=over 4
=item Prerequisites
=item Making
+sh Configure -Dprefix=/ade -Dloclibpth=/ade/lib
+
=item Testing
=item Installing the built perl
=back
-=item AUTHOR
+=item AUTHORS
=item SEE ALSO
=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)
=item CONFIGURE
-=over
+=over 4
=item Strip Binaries
=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
=item TEST
-=over
+=over 4
=item File Permissions
=head2 perldos - Perl under DOS, W31, W95.
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item Prerequisites
=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
=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
=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
=back
-=over
-
=item Frequently asked questions
-=over
+=over 4
=item I cannot run external programs
=item INSTALLATION
-=over
+=over 4
=item Automatic binary installation
=item Accessing documentation
-=over
+=over 4
=item OS/2 F<.INF> file
=item BUILD
-=over
+=over 4
=item Prerequisites
=item Build FAQ
-=over
+=over 4
=item Some C</> became C<\> in pdksh.
=item Specific (mis)features of OS/2 port
-=over
+=over 4
=item C<setpriority>, C<getpriority>
=item Perl flavors
-=over
+=over 4
=item F<perl.exe>
=item ENVIRONMENT
-=over
+=over 4
=item C<PERLLIB_PREFIX>
=item Evolution
-=over
+=over 4
=item Priorities
=back
-=over
+=over 4
=item AUTHOR
=head2 perlos390, README.os390 - building and installing Perl for OS/390.
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item Unpacking
=item Build, test, install
+=item build anomalies
+
+=item testing anomalies
+
=item Usage Hints
-=item Extensions
+=item Modules and Extensions
=back
=item SEE ALSO
-=over
+=over 4
=item Mailing list
=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
=item SEE ALSO
-=over
+=over 4
=item Mailing list
=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
=item Organization of Perl Images
-=over
+=over 4
=item Core Images
=item File specifications
-=over
+=over 4
=item Syntax
=item Command line
-=over
+=over 4
=item I/O redirection and backgrounding
=item Standard modules with VMS-specific differences
-=over
+=over 4
=item SDBM_File
=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
=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
=head2 attrs - set/get attributes of a subroutine (deprecated)
-=over
+=over 4
=item SYNOPSIS
=head2 re - Perl pragma to alter regular expression behaviour
-=over
+=over 4
=item SYNOPSIS
=head2 attributes - get/set subroutine or variable attributes
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item Built-in Attributes
=item EXPORTS
-=over
+=over 4
=item Default exports
=head2 attrs - set/get attributes of a subroutine (deprecated)
-=over
+=over 4
=item SYNOPSIS
=head2 autouse - postpone load of modules until a function is used
-=over
+=over 4
=item SYNOPSIS
=head2 base - Establish IS-A relationship with base class at compile time
-=over
+=over 4
=item SYNOPSIS
=head2 blib - Use MakeMaker's uninstalled version of a package
-=over
+=over 4
=item SYNOPSIS
=head2 bytes - Perl pragma to force byte semantics rather than character
semantics
-=over
+=over 4
=item SYNOPSIS
=head2 charnames - define character names for C<\N{named}> string literal
escape.
-=over
+=over 4
=item SYNOPSIS
=head2 constant - Perl pragma to declare constants
-=over
+=over 4
=item SYNOPSIS
=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
=head2 fields - compile-time class fields
-=over
+=over 4
=item SYNOPSIS
=head2 filetest - Perl pragma to control the filetest permission operators
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item subpragma access
=head2 integer - Perl pragma to compute arithmetic in integer instead of
double
-=over
+=over 4
=item SYNOPSIS
=head2 less - perl pragma to request less of something from the compiler
-=over
+=over 4
=item SYNOPSIS
=head2 lib - manipulate @INC at compile time
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item Adding directories to @INC
=head2 locale - Perl pragma to use and avoid POSIX locales for built-in
operations
-=over
+=over 4
=item SYNOPSIS
=head2 open - perl pragma to set default disciplines for input and output
-=over
+=over 4
=item SYNOPSIS
=head2 ops - Perl pragma to restrict unsafe operations when compiling
-=over
+=over 4
=item SYNOPSIS
=head2 overload - Package for overloading perl operations
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item Declaration of overloaded functions
=item SPECIAL SYMBOLS FOR C<use overload>
-=over
+=over 4
=item Last Resort
=item Cookbook
-=over
+=over 4
=item Two-face scalars
=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
=head2 sigtrap - Perl pragma to enable simple signal handling
-=over
+=over 4
=item SYNOPSIS
=item OPTIONS
-=over
+=over 4
=item SIGNAL HANDLERS
=head2 strict - Perl pragma to restrict unsafe constructs
-=over
+=over 4
=item SYNOPSIS
=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
=head2 vars - Perl pragma to predeclare global variable names (obsolete)
-=over
+=over 4
=item SYNOPSIS
=head2 warnings - Perl pragma to control optional warnings
-=over
+=over 4
=item SYNOPSIS
=head2 AnyDBM_File - provide framework for multiple DBMs
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item DBM Comparisons
=head2 AutoLoader - load subroutines only on demand
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item Subroutine Stubs
=head2 AutoSplit - split a package for autoloading
-=over
+=over 4
=item SYNOPSIS
$keep, $check, $modtime
-=over
+=over 4
=item Multiple packages
=head2 B - The Perl Compiler
-=over
+=over 4
=item SYNOPSIS
=item OVERVIEW OF CLASSES
-=over
+=over 4
=item SV-RELATED CLASSES
=item B::CV METHODS
STASH, START, ROOT, GV, FILE, DEPTH, PADLIST, OUTSIDE, XSUB, XSUBANY,
-CvFLAGS
+CvFLAGS, const_sv
=item B::HV METHODS
=head2 B::Asmdata - Autogenerated data about Perl ops, used to generate
bytecode
-=over
+=over 4
=item SYNOPSIS
=head2 B::Assembler - Assemble Perl bytecode
-=over
+=over 4
=item SYNOPSIS
=head2 B::Bblock - Walk basic blocks
-=over
+=over 4
=item SYNOPSIS
=head2 B::Bytecode - Perl compiler's bytecode backend
-=over
+=over 4
=item SYNOPSIS
=head2 B::C - Perl compiler's C backend
-=over
+=over 4
=item SYNOPSIS
=head2 B::CC - Perl compiler's optimized C translation backend
-=over
+=over 4
=item SYNOPSIS
=item DIFFERENCES
-=over
+=over 4
=item Loops
=head2 B::Debug - Walk Perl syntax tree, printing debug info about ops
-=over
+=over 4
=item SYNOPSIS
=head2 B::Deparse - Perl compiler backend to produce perl code
-=over
+=over 4
=item SYNOPSIS
=item USING B::Deparse AS A MODULE
-=over
+=over 4
=item Synopsis
=head2 B::Disassembler - Disassemble Perl bytecode
-=over
+=over 4
=item SYNOPSIS
=head2 B::Lint - Perl lint
-=over
+=over 4
=item SYNOPSIS
=head2 B::O, O - Generic interface to Perl Compiler backends
-=over
+=over 4
=item SYNOPSIS
=head2 B::Showlex - Show lexical variables used in functions or files
-=over
+=over 4
=item SYNOPSIS
=head2 B::Stackobj - Helper module for CC backend
-=over
+=over 4
=item SYNOPSIS
=head2 B::Terse - Walk Perl syntax tree, printing terse info about ops
-=over
+=over 4
=item SYNOPSIS
=head2 B::Xref - Generates cross reference reports for Perl programs
-=over
+=over 4
=item SYNOPSIS
=head2 Bblock, B::Bblock - Walk basic blocks
-=over
+=over 4
=item SYNOPSIS
=head2 Benchmark - benchmark running times of Perl code
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item Methods
=head2 ByteLoader - load byte compiled perl code
-=over
+=over 4
=item SYNOPSIS
=head2 Bytecode, B::Bytecode - Perl compiler's bytecode backend
-=over
+=over 4
=item SYNOPSIS
=head2 CGI - Simple Common Gateway Interface Class
-=over
+=over 4
=item SYNOPSIS
=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
=item GENERATING DYNAMIC DOCUMENTS
-=over
+=over 4
=item CREATING A STANDARD HTTP HEADER:
=item CREATING STANDARD HTML ELEMENTS:
-=over
+=over 4
=item PROVIDING ARGUMENTS TO HTML SHORTCUTS
=item CREATING FILL-OUT FORMS:
-=over
+=over 4
=item CREATING AN ISINDEX TAG
=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
=item DEBUGGING
-=over
+=over 4
=item DUMPING OUT ALL THE NAME/VALUE PAIRS
=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
=head2 CGI::Apache - Backward compatibility module for CGI.pm
-=over
+=over 4
=item SYNOPSIS
=head2 CGI::Carp, B<CGI::Carp> - CGI routines for writing to the HTTPD (or
other) error log
-=over
+=over 4
=item SYNOPSIS
=item MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW
-=over
+=over 4
=item Changing the default message
=head2 CGI::Cookie - Interface to Netscape Cookies
-=over
+=over 4
=item SYNOPSIS
B<1. expiration date>, B<2. domain>, B<3. path>, B<4. secure flag>
-=over
+=over 4
=item Creating New Cookies
=head2 CGI::Fast - CGI Interface for Fast CGI
-=over
+=over 4
=item SYNOPSIS
=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
=head2 CGI::Push - Simple Interface to Server Push
-=over
+=over 4
=item SYNOPSIS
-next_page, -last_page, -type, -delay, -cookie, -target, -expires
-=over
+=over 4
=item Heterogeneous Pages
=head2 CGI::Switch - Backward compatibility module for defunct CGI::Switch
-=over
+=over 4
=item SYNOPSIS
=head2 CPAN - query, download and build perl modules from CPAN sites
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item Interactive Mode
=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
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
=item WORKING WITH CPAN.pm BEHIND FIREWALLS
-=over
+=over 4
=item Three basic types of firewalls
=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
=head2 CPAN::FirstTime - Utility for CPAN::Config file Initialization
-=over
+=over 4
=item SYNOPSIS
=head2 CPANox, CPAN::Nox - Wrapper around CPAN.pm without using any XS
module
-=over
+=over 4
=item SYNOPSIS
=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
=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
=head2 Config - access Perl configuration information
-=over
+=over 4
=item SYNOPSIS
=item GLOSSARY
-=over
+=over 4
=item _
=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>,
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
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
=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
=head2 Cwd, getcwd - get pathname of current working directory
-=over
+=over 4
=item SYNOPSIS
subject to
change)
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item Global Variables
=head2 DB_File - Perl5 access to Berkeley DB version 1.x
-=over
+=over 4
=item SYNOPSIS
B<DB_HASH>, B<DB_BTREE>, B<DB_RECNO>
-=over
+=over 4
=item Using DB_File with Berkeley DB version 2 or 3
=item DB_HASH
-=over
+=over 4
=item A Simple Example
=item DB_BTREE
-=over
+=over 4
=item Changing the BTREE sort order
=item DB_RECNO
-=over
+=over 4
=item The 'bval' Option
B<filter_store_key>, B<filter_store_value>, B<filter_fetch_key>,
B<filter_fetch_value>
-=over
+=over 4
=item The Filter
=item HINTS AND TIPS
-=over
+=over 4
=item Locking: The Trouble with fd
=item COMMON QUESTIONS
-=over
+=over 4
=item Why is there Perl source in my database?
=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
=head2 Devel::DProf - a Perl code profiler
-=over
+=over 4
=item SYNOPSIS
=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
=item EXAMPLES
-=over
+=over 4
=item A simple scalar string
=head2 Devel::SelfStubber - generate stubs for a SelfLoading module
-=over
+=over 4
=item SYNOPSIS
=head2 DirHandle - supply object methods for directory handles
-=over
+=over 4
=item SYNOPSIS
=head2 Dumpvalue - provides screen dump of Perl data.
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item Creation
=head2 DynaLoader - Dynamically load C libraries into Perl code
-=over
+=over 4
=item SYNOPSIS
=head2 DynaLoader::XSLoader, XSLoader - Dynamically load C libraries into
Perl code
-=over
+=over 4
=item SYNOPSIS
=head2 Encode - character encodings
-=over
+=over 4
=item TERMINOLOGY
=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
=head2 Env - perl module that imports environment variables as scalars or
arrays
-=over
+=over 4
=item SYNOPSIS
=head2 Errno - System errno constants
-=over
+=over 4
=item SYNOPSIS
=head2 Exporter - Implements default import method for modules
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item How to Export
=head2 Exporter::Heavy - Exporter guts
-=over
+=over 4
=item SYNOPIS
=head2 ExtUtils::Command - utilities to replace common UNIX commands in
Makefiles etc.
-=over
+=over 4
=item SYNOPSIS
test_f file
-=over
+=over 4
=item BUGS
=head2 ExtUtils::Embed - Utilities for embedding Perl in C/C++ applications
-=over
+=over 4
=item SYNOPSIS
=head2 ExtUtils::Install - install files from here to there
-=over
+=over 4
=item SYNOPSIS
=head2 ExtUtils::Installed - Inventory management of installed modules
-=over
+=over 4
=item SYNOPSIS
=head2 ExtUtils::Liblist - determine libraries to use and how to use them
-=over
+=over 4
=item SYNOPSIS
For static extensions, For dynamic extensions, For dynamic extensions
-=over
+=over 4
=item EXTRALIBS
=item PORTABILITY
-=over
+=over 4
=item VMS implementation
=head2 ExtUtils::MM_Cygwin - methods to override UN*X behaviour in
ExtUtils::MakeMaker
-=over
+=over 4
=item SYNOPSIS
=head2 ExtUtils::MM_OS2 - methods to override UN*X behaviour in
ExtUtils::MakeMaker
-=over
+=over 4
=item SYNOPSIS
=head2 ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker
-=over
+=over 4
=item SYNOPSIS
=item METHODS
-=over
+=over 4
=item Preloaded methods
updir
-=over
+=over 4
=item SelfLoaded methods
find_perl
-=over
+=over 4
=item Methods to actually produce chunks of text for the Makefile
export_list
-=over
+=over 4
=item SEE ALSO
=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
rootdir (override)
-=over
+=over 4
=item SelfLoaded methods
=head2 ExtUtils::MM_Win32 - methods to override UN*X behaviour in
ExtUtils::MakeMaker
-=over
+=over 4
=item SYNOPSIS
=head2 ExtUtils::MakeMaker - create an extension Makefile
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item How To Write A Makefile.PL
=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
=head2 ExtUtils::Manifest - utilities to write and check a MANIFEST file
-=over
+=over 4
=item SYNOPSIS
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
=head2 ExtUtils::Miniperl, writemain - write the C code for perlmain.c
-=over
+=over 4
=item SYNOPSIS
=head2 ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader
-=over
+=over 4
=item SYNOPSIS
=head2 ExtUtils::Mksymlists - write linker options files for dynamic
extension
-=over
+=over 4
=item SYNOPSIS
=head2 ExtUtils::Packlist - manage .packlist files
-=over
+=over 4
=item SYNOPSIS
=head2 ExtUtils::testlib - add blib/* directories to @INC
-=over
+=over 4
=item SYNOPSIS
=head2 Fatal - replace functions with equivalents which succeed or die
-=over
+=over 4
=item SYNOPSIS
=head2 Fcntl - load the C Fcntl.h defines
-=over
+=over 4
=item SYNOPSIS
=head2 File::Basename, fileparse - split a pathname into pieces
-=over
+=over 4
=item SYNOPSIS
=head2 File::CheckTree, validate - run many filetest checks on a tree
-=over
+=over 4
=item SYNOPSIS
=head2 File::Compare - Compare files or filehandles
-=over
+=over 4
=item SYNOPSIS
=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)
=head2 File::DosGlob - DOS like globbing and then some
-=over
+=over 4
=item SYNOPSIS
=head2 File::Find, find - traverse a file tree
-=over
+=over 4
=item SYNOPSIS
=head2 File::Glob - Perl extension for BSD glob routine
-=over
+=over 4
=item SYNOPSIS
=head2 File::Path - create or remove directory trees
-=over
+=over 4
=item SYNOPSIS
=head2 File::Spec - portably perform operations on file names
-=over
+=over 4
=item SYNOPSIS
=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
=head2 File::Spec::Mac - File::Spec for MacOS
-=over
+=over 4
=item SYNOPSIS
rel2abs
-=over
+=over 4
=item SEE ALSO
=head2 File::Spec::OS2 - methods for OS/2 file specs
-=over
+=over 4
=item SYNOPSIS
=head2 File::Spec::Unix - methods used by File::Spec
-=over
+=over 4
=item SYNOPSIS
rel2abs
-=over
+=over 4
=item SEE ALSO
=head2 File::Spec::VMS - methods for VMS file specs
-=over
+=over 4
=item SYNOPSIS
fixpath
-=over
+=over 4
=item Methods always loaded
rel2abs (override)
-=over
+=over 4
=item SEE ALSO
=head2 File::Spec::Win32 - methods for Win32 file specs
-=over
+=over 4
=item SYNOPSIS
catpath
-=over
+=over 4
=item SEE ALSO
=head2 File::Temp - return name and handle of a temporary file safely
-=over
+=over 4
=item PORTABILITY
=back
-=over
+=over 4
=item FUNCTIONS
B<tempdir>
-=over
+=over 4
=item MKTEMP FUNCTIONS
B<mktemp>
-=over
+=over 4
=item POSIX FUNCTIONS
B<tmpfile>
-=over
+=over 4
=item ADDITIONAL FUNCTIONS
=back
-=over
+=over 4
=item UTILITY FUNCTIONS
=back
-=over
+=over 4
=item PACKAGE VARIABLES
TopSystemUID
-=over
+=over 4
=item WARNING
+=over 4
+
+=item Temporary files and NFS
+
+=back
+
=item HISTORY
=item SEE ALSO
=head2 File::stat - by-name interface to Perl's built-in stat() functions
-=over
+=over 4
=item SYNOPSIS
=head2 FileCache - keep more files open than the system permits
-=over
+=over 4
=item SYNOPSIS
=head2 FileHandle - supply object methods for filehandles
-=over
+=over 4
=item SYNOPSIS
=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
=head2 GDBM_File - Perl5 access to the gdbm library.
-=over
+=over 4
=item SYNOPSIS
=head2 Getopt::Long - Extended processing of command line options
-=over
+=over 4
=item SYNOPSIS
=item Getting Started with Getopt::Long
-=over
+=over 4
=item Simple options
=item Advanced Possibilities
-=over
+=over 4
=item Object oriented interface
=item Legacy
-=over
+=over 4
=item Default destinations
=item Trouble Shooting
-=over
+=over 4
=item Warning: Ignoring '!' modifier for short option
=head2 Getopt::Std, getopt - Process single-character switches with switch
clustering
-=over
+=over 4
=item SYNOPSIS
=head2 I18N::Collate - compare 8-bit scalar data according to the current
locale
-=over
+=over 4
=item SYNOPSIS
=head2 IO - load various IO modules
-=over
+=over 4
=item SYNOPSIS
=head2 IO::Dir - supply object methods for directory handles
-=over
+=over 4
=item SYNOPSIS
=head2 IO::File - supply object methods for filehandles
-=over
+=over 4
=item SYNOPSIS
=head2 IO::Handle - supply object methods for I/O handles
-=over
+=over 4
=item SYNOPSIS
=head2 IO::Pipe - supply object methods for pipes
-=over
+=over 4
=item SYNOPSIS
=head2 IO::Poll - Object interface to system poll call
-=over
+=over 4
=item SYNOPSIS
=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
=head2 IO::Select - OO interface to the select system call
-=over
+=over 4
=item SYNOPSIS
=head2 IO::Socket - Object interface to socket communications
-=over
+=over 4
=item SYNOPSIS
=head2 IO::Socket::INET - Object interface for AF_INET domain sockets
-=over
+=over 4
=item SYNOPSIS
new ( [ARGS] )
-=over
+=over 4
=item METHODS
=head2 IO::Socket::UNIX - Object interface for AF_UNIX domain sockets
-=over
+=over 4
=item SYNOPSIS
=head2 IO::lib::IO::Dir, IO::Dir - supply object methods for directory
handles
-=over
+=over 4
=item SYNOPSIS
=head2 IO::lib::IO::File, IO::File - supply object methods for filehandles
-=over
+=over 4
=item SYNOPSIS
=head2 IO::lib::IO::Handle, IO::Handle - supply object methods for I/O
handles
-=over
+=over 4
=item SYNOPSIS
=head2 IO::lib::IO::Pipe, IO::Pipe - supply object methods for pipes
-=over
+=over 4
=item SYNOPSIS
=head2 IO::lib::IO::Poll, IO::Poll - Object interface to system poll call
-=over
+=over 4
=item SYNOPSIS
=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
=head2 IO::lib::IO::Select, IO::Select - OO interface to the select system
call
-=over
+=over 4
=item SYNOPSIS
=head2 IO::lib::IO::Socket, IO::Socket - Object interface to socket
communications
-=over
+=over 4
=item SYNOPSIS
=head2 IO::lib::IO::Socket::INET, IO::Socket::INET - Object interface for
AF_INET domain sockets
-=over
+=over 4
=item SYNOPSIS
new ( [ARGS] )
-=over
+=over 4
=item METHODS
=head2 IO::lib::IO::Socket::UNIX, IO::Socket::UNIX - Object interface for
AF_UNIX domain sockets
-=over
+=over 4
=item SYNOPSIS
=head2 IPC::Msg - SysV Msg IPC object class
-=over
+=over 4
=item SYNOPSIS
=head2 IPC::Open2, open2 - open a process for both reading and writing
-=over
+=over 4
=item SYNOPSIS
=head2 IPC::Open3, open3 - open a process for reading, writing, and error
handling
-=over
+=over 4
=item SYNOPSIS
=head2 IPC::Semaphore - SysV Semaphore IPC object class
-=over
+=over 4
=item SYNOPSIS
=head2 IPC::SysV - SysV IPC constants
-=over
+=over 4
=item SYNOPSIS
=head2 IPC::SysV::Msg, IPC::Msg - SysV Msg IPC object class
-=over
+=over 4
=item SYNOPSIS
=head2 IPC::SysV::Semaphore, IPC::Semaphore - SysV Semaphore IPC object
class
-=over
+=over 4
=item SYNOPSIS
=head2 Math::BigFloat - Arbitrary length float math package
-=over
+=over 4
=item SYNOPSIS
=head2 Math::BigInt - Arbitrary size integer math package
-=over
+=over 4
=item SYNOPSIS
=head2 Math::Complex - complex numbers and associated mathematical
functions
-=over
+=over 4
=item SYNOPSIS
=item STRINGIFICATION
-=over
+=over 4
=item CHANGED IN PERL 5.6
=head2 Math::Trig - trigonometric functions
-=over
+=over 4
=item SYNOPSIS
B<tan>
-=over
+=over 4
=item ERRORS DUE TO DIVISION BY ZERO
=item RADIAL COORDINATE CONVERSIONS
-=over
+=over 4
=item COORDINATE SYSTEMS
=head2 NDBM_File - Tied access to ndbm files
-=over
+=over 4
=item SYNOPSIS
=item DIAGNOSTICS
-=over
+=over 4
=item C<ndbm store returned -1, errno 22, key "..." at ...>
=head2 Net::Ping - check a remote host for reachability
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item Functions
=head2 Net::hostent - by-name interface to Perl's built-in gethost*()
functions
-=over
+=over 4
=item SYNOPSIS
=head2 Net::netent - by-name interface to Perl's built-in getnet*()
functions
-=over
+=over 4
=item SYNOPSIS
=head2 Net::protoent - by-name interface to Perl's built-in getproto*()
functions
-=over
+=over 4
=item SYNOPSIS
=head2 Net::servent - by-name interface to Perl's built-in getserv*()
functions
-=over
+=over 4
=item SYNOPSIS
=head2 O - Generic interface to Perl Compiler backends
-=over
+=over 4
=item SYNOPSIS
=head2 ODBM_File - Tied access to odbm files
-=over
+=over 4
=item SYNOPSIS
=item DIAGNOSTICS
-=over
+=over 4
=item C<odbm store returned -1, errno 22, key "..." at ...>
=head2 Opcode - Disable named opcodes when compiling perl code
-=over
+=over 4
=item SYNOPSIS
=back
-=over
+=over 4
=item Predefined Opcode Tags
=head2 Opcode::Safe, Safe - Compile and execute code in restricted
compartments
-=over
+=over 4
=item SYNOPSIS
=item WARNING
-=over
+=over 4
=item RECENT CHANGES
=head2 Opcode::ops, ops - Perl pragma to restrict unsafe operations when
compiling
-=over
+=over 4
=item SYNOPSIS
=head2 POSIX - Perl interface to IEEE Std 1003.1
-=over
+=over 4
=item SYNOPSIS
=item CLASSES
-=over
+=over 4
=item POSIX::SigAction
=head2 Pod::Checker, podchecker() - check pod documents for syntax errors
-=over
+=over 4
=item SYNOPSIS
=item OPTIONS/ARGUMENTS
-=over
+=over 4
=item podchecker()
=item DIAGNOSTICS
-=over
+=over 4
=item Errors
C<$checker-E<gt>hyperlink()>
-=over
+=over 4
=item AUTHOR
=head2 Pod::Find - find POD documents in directory trees
-=over
+=over 4
=item SYNOPSIS
=back
-=over
+=over 4
=item C<pod_find( { %opts } , @directories )>
=back
-=over
+=over 4
=item C<simplify_name( $str )>
=back
-=over
+=over 4
=item C<pod_where( { %opts }, $pod )>
=back
-=over
+=over 4
=item C<contains_pod( $file , $verbose )>
=back
-=over
+=over 4
=item AUTHOR
=head2 Pod::Html - module to convert pod files to HTML
-=over
+=over 4
=item SYNOPSIS
=head2 Pod::InputObjects - objects representing POD input paragraphs,
commands, etc.
-=over
+=over 4
=item SYNOPSIS
=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
=head2 Pod::LaTeX - Convert Pod data to formatted Latex
-=over
+=over 4
=item SYNOPSIS
=back
-=over
+=over 4
=item OBJECT METHODS
=back
-=over
+=over 4
=item Data Accessors
B<Lists>
-=over
+=over 4
=item Subclassed methods
B<interior_sequence>
-=over
+=over 4
=item List Methods
B<add_item>
-=over
+=over 4
=item Methods for headings
=back
-=over
+=over 4
=item Internal methods
B<_clean_latex_commands>
-=over
+=over 4
=item NOTES
=head2 Pod::Man - Convert POD data to formatted *roff input
-=over
+=over 4
=item SYNOPSIS
=head2 Pod::ParseUtils - helpers for POD parsing and conversion
-=over
+=over 4
=item SYNOPSIS
=back
-=over
+=over 4
=item Pod::List
$list-E<gt>tag()
-=over
+=over 4
=item Pod::Hyperlink
$link-E<gt>link()
-=over
+=over 4
=item Pod::Cache
$cache-E<gt>find_page($name)
-=over
+=over 4
=item Pod::Cache::Item
$cacheitem-E<gt>idx()
-=over
+=over 4
=item AUTHOR
=head2 Pod::Parser - base class for creating POD filters and translators
-=over
+=over 4
=item SYNOPSIS
=back
-=over
+=over 4
=item RECOMMENDED SUBROUTINE/METHOD OVERRIDES
=back
-=over
+=over 4
=item B<command()>
=back
-=over
+=over 4
=item B<verbatim()>
=back
-=over
+=over 4
=item B<textblock()>
=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()>
=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
=head2 Pod::Plainer - Perl extension for converting Pod to old style Pod.
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item EXPORT
=head2 Pod::Select, podselect() - extract selected sections of POD from
input
-=over
+=over 4
=item SYNOPSIS
=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()>
=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
=head2 Pod::Text - Convert POD data to formatted ASCII text
-=over
+=over 4
=item SYNOPSIS
=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
=head2 Pod::Text::Termcap, Pod::Text::Color - Convert POD data to ASCII
text with format escapes
-=over
+=over 4
=item SYNOPSIS
=head2 Pod::Usage, pod2usage() - print a usage message from embedded pod
documentation
-=over
+=over 4
=item SYNOPSIS
=item EXAMPLES
-=over
+=over 4
=item Recommended Use
=head2 SDBM_File - Tied access to sdbm files
-=over
+=over 4
=item SYNOPSIS
=item DIAGNOSTICS
-=over
+=over 4
=item C<sdbm store returned -1, errno 22, key "..." at ...>
=head2 Safe - Compile and execute code in restricted compartments
-=over
+=over 4
=item SYNOPSIS
=item WARNING
-=over
+=over 4
=item RECENT CHANGES
=head2 Search::Dict, look - search for key in dictionary file
-=over
+=over 4
=item SYNOPSIS
=head2 SelectSaver - save and restore selected file handle
-=over
+=over 4
=item SYNOPSIS
=head2 SelfLoader - load functions only on demand
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item The __DATA__ token
=head2 Shell - run shell commands transparently within perl
-=over
+=over 4
=item SYNOPSIS
=item DESCRIPTION
-=over
+=over 4
=item OBJECT ORIENTED SYNTAX
=head2 Socket, sockaddr_in, sockaddr_un, inet_aton, inet_ntoa - load the C
socket.h defines and structure manipulators
-=over
+=over 4
=item SYNOPSIS
=head2 Storable - persistency for perl data structures
-=over
+=over 4
=item SYNOPSIS
=item WIZARDS ONLY
-=over
+=over 4
=item Hooks
=head2 Symbol - manipulate Perl symbols and their names
-=over
+=over 4
=item SYNOPSIS
=head2 Sys::Hostname - Try every conceivable way to get hostname
-=over
+=over 4
=item SYNOPSIS
=head2 Syslog, Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl
interface to the UNIX syslog(3) calls
-=over
+=over 4
=item SYNOPSIS
=head2 Syslog::Syslog, Sys::Syslog, openlog, closelog, setlogmask, syslog -
Perl interface to the UNIX syslog(3) calls
-=over
+=over 4
=item SYNOPSIS
=head2 Term::ANSIColor - Color screen output using ANSI escape sequences
-=over
+=over 4
=item SYNOPSIS
=head2 Term::Cap - Perl termcap interface
-=over
+=over 4
=item SYNOPSIS
=head2 Term::Complete - Perl word completion module
-=over
+=over 4
=item SYNOPSIS
=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
=head2 Test - provides a simple framework for writing test scripts
-=over
+=over 4
=item SYNOPSIS
=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
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
=head2 Text::Abbrev, abbrev - create an abbreviation table from a list
-=over
+=over 4
=item SYNOPSIS
=head2 Text::ParseWords - parse text into an array of tokens or array of
arrays
-=over
+=over 4
=item SYNOPSIS
=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
=head2 Text::Soundex - Implementation of the Soundex Algorithm as Described
by Knuth
-=over
+=over 4
=item SYNOPSIS
=head2 Text::Tabs -- expand and unexpand tabs per the unix expand(1) and
unexpand(1)
-=over
+=over 4
=item SYNOPSIS
=head2 Text::Wrap - line wrapping to form simple paragraphs
-=over
+=over 4
=item SYNOPSIS
=head2 Thread - manipulate threads in Perl (EXPERIMENTAL, subject to
change)
-=over
+=over 4
=item SYNOPSIS
=item METHODS
-join, eval, detach, equal, tid
+join, eval, detach, equal, tid, flags, done
=item LIMITATIONS
=head2 Thread::Queue - thread-safe queues
-=over
+=over 4
=item SYNOPSIS
=head2 Thread::Semaphore - thread-safe semaphores
-=over
+=over 4
=item SYNOPSIS
=head2 Thread::Signal - Start a thread which runs signal handlers reliably
-=over
+=over 4
=item SYNOPSIS
=head2 Thread::Specific - thread-specific keys
-=over
+=over 4
=item SYNOPSIS
=head2 Tie::Array - base class for tied arrays
-=over
+=over 4
=item SYNOPSIS
=head2 Tie::Handle, Tie::StdHandle - base class definitions for tied
handles
-=over
+=over 4
=item SYNOPSIS
=head2 Tie::Hash, Tie::StdHash - base class definitions for tied hashes
-=over
+=over 4
=item SYNOPSIS
=head2 Tie::RefHash - use references as hash keys
-=over
+=over 4
=item SYNOPSIS
=head2 Tie::Scalar, Tie::StdScalar - base class definitions for tied
scalars
-=over
+=over 4
=item SYNOPSIS
=head2 Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing
-=over
+=over 4
=item SYNOPSIS
=head2 Time::Local - efficiently compute time from local and GMT time
-=over
+=over 4
=item SYNOPSIS
=head2 Time::gmtime - by-name interface to Perl's built-in gmtime()
function
-=over
+=over 4
=item SYNOPSIS
=head2 Time::localtime - by-name interface to Perl's built-in localtime()
function
-=over
+=over 4
=item SYNOPSIS
=head2 Time::tm - internal object used by Time::gmtime and Time::localtime
-=over
+=over 4
=item SYNOPSIS
=head2 UNIVERSAL - base class for ALL classes (blessed references)
-=over
+=over 4
=item SYNOPSIS
=head2 User::grent - by-name interface to Perl's built-in getgr*()
functions
-=over
+=over 4
=item SYNOPSIS
=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
=head2 Win32 - Interfaces to some Win32 API Functions
-=over
+=over 4
=item DESCRIPTION
-=over
+=over 4
=item Alphabetical Listing of Win32 Functions
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),
=head2 XSLoader - Dynamically load C libraries into Perl code
-=over
+=over 4
=item SYNOPSIS
Here should be listed all the extra programs' documentation, but they
don't all have manual pages yet:
-=over
+=over 4
=item a2p
=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
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
It would be nice to combine Alias with
something like Class::Struct or Class::MethodMaker.
-=head2 NOTES
+=head1 NOTES
=head2 Object Terminology
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.
Here are a few examples where class attributes might come in handy:
-=over
+=over 4
=item *
The following areas need further work.
-=over
+=over 4
=item Input and Output Disciplines
=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
=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
$< = $>; # 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().
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.)
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.)
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.
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
=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.
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)
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)
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
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
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
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>
#
$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
[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>
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
$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.
} 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);
=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>
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
/* 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.
/* 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
PP(pp_rv2gv)
{
- djSP; dTOPss;
+ djSP; dTOPss;
if (SvROK(sv)) {
wasref:
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;
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);
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;
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)
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++] = '\\';
}
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);
}
char *elem;
djSP;
STRLEN n_a;
-
+
sv = POPs;
elem = SvPV(sv, n_a);
gv = (GV*)POPs;
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 );
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;
}
}
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));
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));
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));
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));
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));
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;
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;
}
SETi(-SvIVX(sv));
RETURN;
}
+#ifdef PERL_PRESERVE_IVUV
+ else {
+ SETu((UV)IV_MIN);
+ RETURN;
+ }
+#endif
}
if (SvNIOKp(sv))
SETn(-SvNV(sv));
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
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;
PP(pp_i_modulo)
{
- djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
{
dPOPTOPiirl;
if (!right)
{
djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
{
- dPOPTOPiirl;
+ dPOPTOPiirl_ul;
SETi( left + right );
RETURN;
}
{
djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
{
- dPOPTOPiirl;
+ dPOPTOPiirl_ul;
SETi( left - right );
RETURN;
}
#define SEED_C3 269
#define SEED_C5 26107
- dTHR;
#ifndef PERL_NO_DEV_RANDOM
int fd;
#endif
{
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;
{
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);
}
}
{
djSP; dTARGET;
char *tmps;
- I32 argtype;
+ STRLEN argtype;
STRLEN n_a;
tmps = POPpx;
{
djSP; dTARGET;
NV value;
- I32 argtype;
+ STRLEN argtype;
char *tmps;
STRLEN n_a;
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;
}
(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);
XPUSHs(TARG);
RETURN;
}
+ else {
+ SvUTF8_off(TARG);
+ }
SvGROW(TARG,2);
SvCUR_set(TARG, 1);
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);
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;
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;
if (DO_UTF8(sv)) {
dTARGET;
- I32 ulen;
+ STRLEN ulen;
register U8 *d;
U8 *send;
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;
}
}
if (DO_UTF8(sv)) {
dTARGET;
- I32 ulen;
+ STRLEN ulen;
register U8 *d;
U8 *send;
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;
}
}
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;
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;
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;
}
ix = SvIVx(*lelem);
if (ix < 0)
ix += max;
- else
+ else
ix -= arybase;
if (ix < 0 || ix >= max)
*lelem = &PL_sv_undef;
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;
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
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;
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);
if (checksum) {
#if LONGSIZE != SIZE32
if (natint) {
- long along;
while (len-- > 0) {
COPYNN(s, &along, sizeof(long));
s += sizeof(long);
#endif
{
while (len-- > 0) {
+#if LONGSIZE > SIZE32 && INTSIZE == SIZE32
+ I32 along;
+#endif
COPY32(s, &along);
#if LONGSIZE > SIZE32
if (along > 2147483647)
EXTEND_MORTAL(len);
#if LONGSIZE != SIZE32
if (natint) {
- long along;
while (len-- > 0) {
COPYNN(s, &along, sizeof(long));
s += sizeof(long);
#endif
{
while (len-- > 0) {
+#if LONGSIZE > SIZE32 && INTSIZE == SIZE32
+ I32 along;
+#endif
COPY32(s, &along);
#if LONGSIZE > SIZE32
if (along > 2147483647)
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);
*/
if (PL_uudmap['M'] == 0) {
int i;
-
+
for (i = 0; i < sizeof(PL_uuemap); i += 1)
PL_uudmap[(U8)PL_uuemap[i]] = i;
/*
patcopy++;
continue;
}
- if (datumtype == 'U' && pat == patcopy+1)
+ if (datumtype == 'U' && pat == patcopy+1)
SvUTF8_on(cat);
if (datumtype == '#') {
while (pat < patend && *pat != '\n')
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));
}
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;
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) &&
sv_setpvn(dstr, s, m-s);
if (make_mortal)
sv_2mortal(dstr);
- if (doutf8)
+ if (do_utf8)
(void)SvUTF8_on(dstr);
XPUSHs(dstr);
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;
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) {
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 {
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,
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) {
dstr = NEWSV(33, 0);
if (make_mortal)
sv_2mortal(dstr);
- if (doutf8)
+ if (do_utf8)
(void)SvUTF8_on(dstr);
XPUSHs(dstr);
}
sv_setpvn(dstr, s, l);
if (make_mortal)
sv_2mortal(dstr);
- if (doutf8)
+ if (do_utf8)
(void)SvUTF8_on(dstr);
XPUSHs(dstr);
iters++;
void
Perl_unlock_condpair(pTHX_ void *svv)
{
- dTHR;
MAGIC *mg = mg_find((SV*)svv, 'm');
if (!mg)
/* 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.
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>.
=for apidoc Ams||SPAGAIN
Refetch the stack pointer. Used after a callback. See L<perlcall>.
-=cut
-*/
+=cut */
#define SP sp
#define MARK mark
#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
#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))
/* 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.
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. */
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++) {
: (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);
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);
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);
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);
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++;
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 == ' ') ;
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];
* irrelevant. --jhi */
if (shift < count)
shift = count; /* Avoid shifting too often --Ben Tilly */
-
+
EXTEND(SP,shift);
src = SP;
dst = (SP += shift);
*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 */
STATIC I32
S_dopoptolabel(pTHX_ char *label)
{
- dTHR;
register I32 i;
register PERL_CONTEXT *cx;
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:
I32
Perl_block_gimme(pTHX)
{
- dTHR;
I32 cxix;
cxix = dopoptosub(cxstack_ix);
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--) {
STATIC I32
S_dopoptoeval(pTHX_ I32 startingblock)
{
- dTHR;
I32 i;
register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
STATIC I32
S_dopoptoloop(pTHX_ I32 startingblock)
{
- dTHR;
I32 i;
register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
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:
void
Perl_dounwind(pTHX_ I32 cxix)
{
- dTHR;
register PERL_CONTEXT *cx;
I32 optype;
STATIC void
S_free_closures(pTHX)
{
- dTHR;
SV **svp = AvARRAY(PL_comppad_name);
I32 ix;
for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
}
}
}
- else
+ else {
sv_setpvn(ERRSV, message, msglen);
+ if (PL_hints & HINT_UTF8)
+ SvUTF8_on(ERRSV);
+ else
+ SvUTF8_off(ERRSV);
+ }
}
else
message = SvPVx(ERRSV, msglen);
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
#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);
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
}
*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) &&
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) {
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);
#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 */
*/
SV *sv = GvSV(PL_DBsub);
CV *gotocv;
-
+
if (PERLDB_SUB_NN) {
SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
} else {
STATIC OP *
S_docatch(pTHX_ OP *o)
{
- dTHR;
int ret;
OP *oldop = PL_op;
volatile PERL_SI *cursi = PL_curstackinfo;
#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);
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
if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
goto trylocal;
}
- else
+ else
trylocal: {
#else
}
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);
ENTER;
lex_start(sv);
SAVETMPS;
-
+
/* switch to eval mode */
if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
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);
if (len == 0)
Perl_croak(aTHX_ "Null picture in formline");
-
+
New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
fpc = fops;
case ' ': case '\t':
skipspaces++;
continue;
-
+
case '\n': case 0:
arg = s - base;
skipspaces++;
}
*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 {
* 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.
static I32
sortcv(pTHXo_ SV *a, SV *b)
{
- dTHR;
I32 oldsaveix = PL_savestack_ix;
I32 oldscopeix = PL_scopestack_ix;
I32 result;
static I32
sortcv_stacked(pTHXo_ SV *a, SV *b)
{
- dTHR;
I32 oldsaveix = PL_savestack_ix;
I32 oldscopeix = PL_scopestack_ix;
I32 result;
/* 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.
#define PERL_IN_PP_HOT_C
#include "perl.h"
-#ifdef I_UNISTD
-#include <unistd.h>
-#endif
-
/* Hot code. */
#ifdef USE_THREADS
sv_setpvn(TARG,s,len);
if (SvUTF8(TOPs) && !IN_BYTE)
SvUTF8_on(TARG);
+ else
+ SvUTF8_off(TARG);
SETTARG;
RETURN;
}
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;
}
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));
++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;
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;
}
}
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))
}
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);
}
}
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;
}
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)
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;
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)
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) {
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;
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;
}
(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)
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) \
(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);
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;
}
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);
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;
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)
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;
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);
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;
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);
SvPVX(TARG) = SvPVX(dstr);
SvCUR_set(TARG, SvCUR(dstr));
SvLEN_set(TARG, SvLEN(dstr));
+ isutf8 = DO_UTF8(dstr);
SvPVX(dstr) = 0;
sv_free(dstr);
PUSHs(sv_2mortal(newSViv((I32)iters)));
(void)SvPOK_only(TARG);
+ if (isutf8)
+ SvUTF8_on(TARG);
TAINT_IF(rxtainted);
SvSETMAGIC(TARG);
SvTAINT(TARG);
STATIC CV *
S_get_db_sub(pTHX_ SV **svp, CV *cv)
{
- dTHR;
SV *dbsv = GvSV(PL_DBsub);
if (!PERLDB_SUB_NN) {
{
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)
!(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)
))
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))));
/* 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.
# 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,...);
# 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.
# 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,...) */
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)
}
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;
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;
}
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;
}
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;
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;
void
Perl_setdefout(pTHX_ GV *gv)
{
- dTHR;
if (gv)
(void)SvREFCNT_inc(gv);
if (PL_defoutgv)
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;
}
STATIC OP *
S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
{
- dTHR;
register PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
AV* padlist = CvPADLIST(cv);
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)
{
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;
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;
PUSHs(&PL_sv_yes);
}
}
+bad_ofp:
PL_formtarget = PL_bodytarget;
PUTBACK;
return pop_return();
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);
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) &&
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);
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];
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))
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
#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))
{
}
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:
char *buffer;
Size_t length;
SSize_t retval;
- IV offset;
STRLEN blen;
MAGIC *mg;
if (!gv)
goto say_undef;
bufsv = *++MARK;
- buffer = SvPV(bufsv, blen);
#if Size_t_size > IVSIZE
length = (Size_t)SvNVx(*++MARK);
#else
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) {
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
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");
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;
}
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)
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)
#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)
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;
? 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;
len = 512;
}
else {
- dTHR;
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
gv = cGVOP_gv;
report_evil_fh(gv, GvIO(gv), PL_op->op_type);
(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) {
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 */
# 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);
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);
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);
PERL_CALLCONV U32 Perl_to_uni_upper_lc(pTHX_ U32 c);
PERL_CALLCONV U32 Perl_to_uni_title_lc(pTHX_ U32 c);
PERL_CALLCONV U32 Perl_to_uni_lower_lc(pTHX_ U32 c);
-PERL_CALLCONV int Perl_is_utf8_char(pTHX_ U8 *p);
+PERL_CALLCONV STRLEN Perl_is_utf8_char(pTHX_ U8 *p);
PERL_CALLCONV bool Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len);
PERL_CALLCONV bool Perl_is_utf8_alnum(pTHX_ U8 *p);
PERL_CALLCONV bool Perl_is_utf8_alnumc(pTHX_ U8 *p);
PERL_CALLCONV 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);
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)))
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);
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);
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);
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);
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)
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);
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);
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);
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);
#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)
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
# 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)
#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);
*
**** 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.
#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)))
I32 offset_float_max;
I32 flags;
I32 whilem_c;
+ I32 *last_closep;
struct regnode_charclass_class *start_class;
} 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
#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))
#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 "..." */ \
ellipses = "..."; \
} \
Perl_croak(aTHX_ "%s in regex m/%.*s%s/", \
- msg, (int)len, PL_regprecomp, ellipses); \
+ msg, (int)len, RExC_precomp, ellipses); \
} STMT_END
/*
#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 "..." */ \
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
*/
#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
/*
#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
*/
#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
/*
#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
*/
#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
/*
#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
*/
#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
/*
*/
#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
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);
/* 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;
}
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;
/* 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;
}
} /* 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
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)) */
}
}
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".
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;
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)
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;
}
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;
}
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. */
/* 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);
}
}
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))
/* 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)
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);
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;
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;
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) {
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);
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
}
} 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)
&& !(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");
}
}
#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++;
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;
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++;
/* 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)
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');
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:
&& (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");
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);
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)
}
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. */
}
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");
regexp *
Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
{
- dTHR;
register regexp *r;
regnode *scan;
regnode *first;
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. */
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. */
/* 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)))
/* 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;
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;
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 */
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 {
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 {
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",
/* 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),
}
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);
}
* 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;
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);
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. */
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;
}
}
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;
*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;
/* 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 ',':
*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);
}
}
}
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
* 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;
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;
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;
}
* 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 == ',') {
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;
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;
}
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");
}
*
* [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);
/* 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;
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:
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 '$':
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 */
}
p = e + 1;
}
- else
- {
- PL_regcomp_parse = e + 1;
- vFAIL("Can't use \\x{} without 'use utf8' declaration");
- }
-
}
else {
numlen = 0; /* disallow underscores */
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;
}
break;
case '\0':
- if (p >= PL_regxend)
+ if (p >= RExC_end)
FAIL("Trailing \\");
/* FALL THROUGH */
default:
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);
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;
}
}
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;
}
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)
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;
}
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;
} 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;
}
}
}
}
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))
/* [[=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);
}
}
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;
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);
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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");
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;
}
}
- 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);
}
- 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);
}
- 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);
}
/*
* 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;
/* (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);
- 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;
- 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;
Perl_regdump(pTHX_ regexp *r)
{
#ifdef DEBUGGING
- dTHR;
SV *sv = sv_newmortal();
(void)dumpuntil(r->program, r->program + 1, NULL, sv, 0);
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);
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)];
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));
}
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",
"[:^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)) {
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))
void
Perl_pregfree(pTHX_ struct regexp *r)
{
- dTHR;
DEBUG_r(if (!PL_colorset) reginitcolors());
if (!r || (--r->refcnt > 0))
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);
regnode *
Perl_regnext(pTHX_ register regnode *p)
{
- dTHR;
register I32 offset;
if (p == &PL_regdummy)
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. */
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 */
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
{
ReREFCNT_dec((regexp *)r);
}
-
};
#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];
};
U8 flags;
U8 type;
U16 next_off;
+ U32 arg1;
char bitmap[ANYOF_BITMAP_SIZE];
char classflags[ANYOF_CLASSBITMAP_SIZE];
};
#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() */
#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
#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))
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
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
/* *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
*
**** 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.
* 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;
}
/* 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;
(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;
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) { \
STATIC void
S_cache_re(pTHX_ regexp *prog)
{
- dTHR;
PL_regprecomp = prog->precomp; /* Needed for FAIL. */
#ifdef DEBUGGING
PL_regprogram = prog->program;
register I32 end_shift;
register char *s;
register SV *check;
+ char *strbeg;
char *t;
I32 ml_anch;
char *tmp;
(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)
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;
}
/* 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 */
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;
/* 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;
*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,
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)
}
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;
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. */
", 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 {
}
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:
++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,
/* 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))
{
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);
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,
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
}
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);
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;
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:
/* data: May be used for some additional optimizations. */
/* nosave: For optimizations. */
{
- dTHR;
register char *s;
register regnode *c;
register char *startpos = stringarg;
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;
}
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 */
}
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)
int did_match = 0;
#endif
- if (UTF) {
+ if (do_utf8) {
while (s < strend) {
if (*s == ch) {
DEBUG_r( did_match = 1 );
"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;
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 );
last1 = HOPc(s, -back_min);
s = t;
}
- if (UTF) {
+ if (do_utf8) {
while (s <= last1) {
if (regtry(prog, s))
goto got_it;
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"));
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;
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;
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;
/* 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
*
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. */
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
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
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)
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;
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;
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;
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;
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)))
{
nextchr = UCHARAT(locinput);
break;
}
- if (!(OP(scan) == ALNUMUTF8
+ if (!(OP(scan) == ALNUM
? isALNUM(nextchr) : isALNUM_LC(nextchr)))
sayNO;
nextchr = UCHARAT(++locinput);
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))
{
nextchr = UCHARAT(locinput);
break;
}
- if (OP(scan) == NALNUMUTF8
+ if (OP(scan) == NALNUM
? isALNUM(nextchr) : isALNUM_LC(nextchr))
sayNO;
nextchr = UCHARAT(++locinput);
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;
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;
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))
{
nextchr = UCHARAT(locinput);
break;
}
- if (OP(scan) == NSPACEUTF8
+ if (OP(scan) == NSPACE
? isSPACE(nextchr) : isSPACE_LC(nextchr))
sayNO;
nextchr = UCHARAT(++locinput);
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)))
{
nextchr = UCHARAT(locinput);
break;
}
- if (!(OP(scan) == DIGITUTF8
+ if (!(OP(scan) == DIGIT
? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
sayNO;
nextchr = UCHARAT(++locinput);
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))
{
nextchr = UCHARAT(locinput);
break;
}
- if (OP(scan) == NDIGITUTF8
+ if (OP(scan) == NDIGIT
? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
sayNO;
nextchr = UCHARAT(++locinput);
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];
/*
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)))
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;
sayYES;
}
ReREFCNT_dec(re);
- REGCP_UNWIND;
+ REGCP_UNWIND(lastcp);
regcppop();
PL_reg_call_cc = state.prev;
PL_regcc = state.cc;
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);
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;
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;
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(
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;
}
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. */
}
if (regmatch(next))
sayYES;
- REGCP_UNWIND;
+ REGCP_UNWIND(lastcp);
}
/* Couldn't or didn't -- move forward. */
PL_reginput = locinput;
else
c1 = c2 = -1000;
}
- REGCP_SET;
+ REGCP_SET(lastcp);
while (n >= ln) {
/* If it could work, try it. */
if (c1 == -1000 ||
}
if (regmatch(next))
sayYES;
- REGCP_UNWIND;
+ REGCP_UNWIND(lastcp);
}
/* Couldn't or didn't -- back up. */
n--;
* 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;
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;
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--;
}
}
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--;
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
regcpblow(cp);
sayYES;
}
- REGCP_UNWIND;
+ REGCP_UNWIND(lastcp);
regcppop();
PL_reg_call_cc = cur_call_cc;
PL_regcc = cctmp;
PTR2UV(scan), OP(scan));
Perl_croak(aTHX_ "regexp memory corruption");
}
+ reenter:
scan = next;
}
#ifdef DEBUGGING
PL_regindent--;
#endif
+
+#if 0 /* Breaks $^R */
+ if (unwind)
+ regcpblow(firstcp);
+#endif
return 1;
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
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 */
(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. */
STATIC I32
S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp)
{
- dTHR;
register char *scan;
register char *start;
register char *loceol = PL_regeol;
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;
}
/*
- - 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;
}
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 */
}
}
}
}
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;
static void
restore_pos(pTHXo_ void *arg)
{
- dTHR;
if (PL_reg_eval_set) {
if (PL_reg_oldsaved) {
PL_reg_re->subbeg = PL_reg_oldsaved;
struct reg_substr_data;
+struct reg_data;
+
typedef struct regexp {
I32 *startp;
I32 *endp;
#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[];
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 */
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 */
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 */
"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 */
/* 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.
int
Perl_runops_standard(pTHX)
{
- dTHR;
-
while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX))) {
PERL_ASYNC_CHECK();
}
Perl_runops_debug(pTHX)
{
#ifdef DEBUGGING
- dTHR;
if (!PL_op) {
if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ WARN_DEBUGGING, "NULL OP IN RUN");
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",
/* 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.
Perl_vdefault_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt,
protect_body_t body, va_list *args)
{
- dTHR;
int ex;
void *ret;
SV**
Perl_stack_grow(pTHX_ SV **sp, SV **p, int n)
{
- dTHR;
#if defined(DEBUGGING) && !defined(USE_THREADS)
static int growing = 0;
if (growing++)
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;
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*);
OP *
Perl_pop_return(pTHX)
{
- dTHR;
if (PL_retstack_ix > 0)
return PL_retstack[--PL_retstack_ix];
else
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);
void
Perl_pop_scope(pTHX)
{
- dTHR;
I32 oldsave = PL_scopestack[--PL_scopestack_ix];
LEAVE_SCOPE(oldsave);
}
void
Perl_markstack_grow(pTHX)
{
- dTHR;
I32 oldmax = PL_markstack_max - PL_markstack;
I32 newmax = GROW(oldmax);
void
Perl_savestack_grow(pTHX)
{
- dTHR;
PL_savestack_max = GROW(PL_savestack_max) + 4;
Renew(PL_savestack, PL_savestack_max, ANY);
}
void
Perl_tmps_grow(pTHX_ I32 n)
{
- dTHR;
#ifndef STRESS_REALLOC
if (n < 128)
n = (PL_tmps_max < 512) ? 128 : 512;
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 */
STATIC SV *
S_save_scalar_at(pTHX_ SV **sptr)
{
- dTHR;
register SV *sv;
SV *osv = *sptr;
SV *
Perl_save_scalar(pTHX_ GV *gv)
{
- dTHR;
SV **sptr = &GvSV(gv);
SSCHECK(3);
SSPUSHPTR(SvREFCNT_inc(gv));
SV*
Perl_save_svref(pTHX_ SV **sptr)
{
- dTHR;
SSCHECK(3);
SSPUSHPTR(sptr);
SSPUSHPTR(SvREFCNT_inc(*sptr));
void
Perl_save_generic_svref(pTHX_ SV **sptr)
{
- dTHR;
SSCHECK(3);
SSPUSHPTR(sptr);
SSPUSHPTR(SvREFCNT_inc(*sptr));
void
Perl_save_generic_pvref(pTHX_ char **str)
{
- dTHR;
SSCHECK(3);
SSPUSHPTR(str);
SSPUSHPTR(*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 */
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 {
AV *
Perl_save_ary(pTHX_ GV *gv)
{
- dTHR;
AV *oav = GvAVn(gv);
AV *av;
HV *
Perl_save_hash(pTHX_ GV *gv)
{
- dTHR;
HV *ohv, *hv;
SSCHECK(3);
void
Perl_save_item(pTHX_ register SV *item)
{
- dTHR;
register SV *sv = NEWSV(0,0);
sv_setsv(sv,item);
void
Perl_save_int(pTHX_ int *intp)
{
- dTHR;
SSCHECK(3);
SSPUSHINT(*intp);
SSPUSHPTR(intp);
void
Perl_save_long(pTHX_ long int *longp)
{
- dTHR;
SSCHECK(3);
SSPUSHLONG(*longp);
SSPUSHPTR(longp);
void
Perl_save_I32(pTHX_ I32 *intp)
{
- dTHR;
SSCHECK(3);
SSPUSHINT(*intp);
SSPUSHPTR(intp);
void
Perl_save_I16(pTHX_ I16 *intp)
{
- dTHR;
SSCHECK(3);
SSPUSHINT(*intp);
SSPUSHPTR(intp);
void
Perl_save_I8(pTHX_ I8 *bytep)
{
- dTHR;
SSCHECK(3);
SSPUSHINT(*bytep);
SSPUSHPTR(bytep);
void
Perl_save_iv(pTHX_ IV *ivp)
{
- dTHR;
SSCHECK(3);
SSPUSHIV(*ivp);
SSPUSHPTR(ivp);
void
Perl_save_pptr(pTHX_ char **pptr)
{
- dTHR;
SSCHECK(3);
SSPUSHPTR(*pptr);
SSPUSHPTR(pptr);
void
Perl_save_vptr(pTHX_ void *ptr)
{
- dTHR;
SSCHECK(3);
SSPUSHPTR(*(char**)ptr);
SSPUSHPTR(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)));
void
Perl_save_nogv(pTHX_ GV *gv)
{
- dTHR;
SSCHECK(2);
SSPUSHPTR(gv);
SSPUSHINT(SAVEt_NSTAB);
void
Perl_save_hptr(pTHX_ HV **hptr)
{
- dTHR;
SSCHECK(3);
SSPUSHPTR(*hptr);
SSPUSHPTR(hptr);
void
Perl_save_aptr(pTHX_ AV **aptr)
{
- dTHR;
SSCHECK(3);
SSPUSHPTR(*aptr);
SSPUSHPTR(aptr);
void
Perl_save_freesv(pTHX_ SV *sv)
{
- dTHR;
SSCHECK(2);
SSPUSHPTR(sv);
SSPUSHINT(SAVEt_FREESV);
void
Perl_save_freeop(pTHX_ OP *o)
{
- dTHR;
SSCHECK(2);
SSPUSHPTR(o);
SSPUSHINT(SAVEt_FREEOP);
void
Perl_save_freepv(pTHX_ char *pv)
{
- dTHR;
SSCHECK(2);
SSPUSHPTR(pv);
SSPUSHINT(SAVEt_FREEPV);
void
Perl_save_clearsv(pTHX_ SV **svp)
{
- dTHR;
SSCHECK(2);
SSPUSHLONG((long)(svp-PL_curpad));
SSPUSHINT(SAVEt_CLEARSV);
void
Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
{
- dTHR;
SSCHECK(4);
SSPUSHINT(klen);
SSPUSHPTR(key);
void
Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg)
{
- dTHR;
register SV *sv;
register I32 i;
void
Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
{
- dTHR;
SSCHECK(3);
SSPUSHDPTR(f);
SSPUSHPTR(p);
void
Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
{
- dTHR;
SSCHECK(3);
SSPUSHDXPTR(f);
SSPUSHPTR(p);
void
Perl_save_aelem(pTHX_ AV *av, I32 idx, SV **sptr)
{
- dTHR;
SSCHECK(4);
SSPUSHPTR(SvREFCNT_inc(av));
SSPUSHINT(idx);
void
Perl_save_helem(pTHX_ HV *hv, SV *key, SV **sptr)
{
- dTHR;
SSCHECK(4);
SSPUSHPTR(SvREFCNT_inc(hv));
SSPUSHPTR(SvREFCNT_inc(key));
void
Perl_save_op(pTHX)
{
- dTHR;
SSCHECK(2);
SSPUSHPTR(PL_op);
SSPUSHINT(SAVEt_OP);
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));
void
Perl_leave_scope(pTHX_ I32 base)
{
- dTHR;
register SV *sv;
register SV *value;
register GV *gv;
/* 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);
ptr = SSPOPPTR;
(void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD);
SvREFCNT_dec(hv);
- Safefree(ptr);
break;
case SAVEt_DESTRUCTOR:
ptr = SSPOPPTR;
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");
}
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);
#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))
#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))
* 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
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 { \
(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 { \
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 { \
/* 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.
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;
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;
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);
}
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 */
STATIC void
S_not_a_number(pTHX_ SV *sv)
{
- dTHR;
char tmpbuf[64];
char *d = tmpbuf;
char *s;
"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)
{
return asIV(sv);
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
report_uninit();
}
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;
}
}
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,
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)
return asUV(sv);
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
report_uninit();
}
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;
}
}
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)) {
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();
}
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));
}
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
report_uninit();
}
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;
(!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();
if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
return Atol(SvPVX(sv));
if (!numtype) {
- dTHR;
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
return Strtoul(SvPVX(sv), Null(char**), 10);
#endif
if (!numtype) {
- dTHR;
if (ckWARN(WARN_NUMERIC))
not_a_number(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
*/
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 */
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
#endif
) {
s++;
- numtype |= IS_NUMBER_NOT_IV;
+ numtype |= IS_NUMBER_NOT_INT;
while (isDIGIT(*s)) /* optional digits after the radix */
s++;
}
#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 {
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;
}
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++;
}
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
report_uninit();
}
== (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) {
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 */
*--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. */
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 */
if (!SvOK(sv))
return 0;
if (SvROK(sv)) {
- dTHR;
SV* tmpsv;
if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
(SvRV(tmpsv) != SvRV(sv)))
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. */
}
}
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;
}
{
if (SvPOK(sv)) {
char *c;
+ char *e;
bool has_utf = FALSE;
if (!sv_utf8_downgrade(sv, TRUE))
return FALSE;
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;
}
void
Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
{
- dTHR;
register U32 sflags;
register int dtype;
register int stype;
SvIVX(dstr) = SvIVX(sstr);
if (SvIsUV(sstr))
SvIsUV_on(dstr);
- SvTAINT(dstr);
+ if (SvTAINTED(sstr))
+ SvTAINT(dstr);
return;
}
goto undef_sstr;
}
SvNVX(dstr) = SvNVX(sstr);
(void)SvNOK_only(dstr);
- SvTAINT(dstr);
+ if (SvTAINTED(sstr))
+ SvTAINT(dstr);
return;
}
goto undef_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)))
{
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 &&
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);
SvREFCNT_dec(dref);
if (intro)
SAVEFREESV(sref);
- SvTAINT(dstr);
+ if (SvTAINTED(sstr))
+ SvTAINT(dstr);
return;
}
if (SvPVX(dstr)) {
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)) {
else
(void)SvOK_off(dstr);
}
- SvTAINT(dstr);
+ if (SvTAINTED(sstr))
+ SvTAINT(dstr);
}
/*
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);
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);
}
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);
}
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);
}
}
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);
*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
/*
=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);
}
}
*/
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);
}
/*
MAGIC* mg;
if (SvREADONLY(sv)) {
- dTHR;
if (PL_curcop != &PL_compiling && !strchr("gBf", how))
Perl_croak(aTHX_ PL_no_modify);
}
if (!obj || obj == sv || how == '#' || how == 'r')
mg->mg_obj = obj;
else {
- dTHR;
mg->mg_obj = SvREFCNT_inc(obj);
mg->mg_flags |= MGf_REFCOUNTED;
}
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;
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))
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);
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);
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;
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;
void
Perl_sv_free(pTHX_ SV *sv)
{
- dTHR;
int refcount_is_zero;
if (!sv)
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
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;
/* 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;
}
}
/* 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;
char *
Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
{
- dTHR;
char *rsptr;
STRLEN rslen;
register STDCHAR rslast;
#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 */
}
}
+ if (PerlIO_isutf8(fp))
+ SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
+
return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
}
mg_get(sv);
if (SvTHINKFIRST(sv)) {
if (SvREADONLY(sv)) {
- dTHR;
if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
}
}
}
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);
++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);
}
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--;
mg_get(sv);
if (SvTHINKFIRST(sv)) {
if (SvREADONLY(sv)) {
- dTHR;
if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
}
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);
}
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);
(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 */
}
SV *
Perl_sv_mortalcopy(pTHX_ SV *oldstr)
{
- dTHR;
register SV *sv;
new_SV(sv);
SV *
Perl_sv_newmortal(pTHX)
{
- dTHR;
register SV *sv;
new_SV(sv);
SV *
Perl_sv_2mortal(pTHX_ register SV *sv)
{
- dTHR;
if (!sv)
return sv;
if (SvREADONLY(sv) && SvIMMORTAL(sv))
*/
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;
}
SV *
Perl_newRV_noinc(pTHX_ SV *tmpRef)
{
- dTHR;
register SV *sv;
new_SV(sv);
SV *
Perl_newSVsv(pTHX_ register SV *old)
{
- dTHR;
register SV *sv;
if (!old)
}
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
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvROK(sv)) {
- dTHR;
SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
tryAMAGICunDEREF(to_cv);
I32
Perl_sv_true(pTHX_ register SV *sv)
{
- dTHR;
if (!sv)
return 0;
if (SvPOK(sv)) {
}
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]);
}
SV*
Perl_newSVrv(pTHX_ SV *rv, const char *classname)
{
- dTHR;
SV *sv;
new_SV(sv);
SV*
Perl_sv_bless(pTHX_ SV *sv, HV *stash)
{
- dTHR;
SV *tmpRef;
if (!SvROK(sv))
Perl_croak(aTHX_ "Can't bless non-reference value");
}
/*
-=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);
}
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)
{
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;
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;
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) {
/* 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':
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 */
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++;
}
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);
}
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;
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) {
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;
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;
}
}
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;
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;
}
}
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;
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') {
*--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);
#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 */
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;
}
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");
}
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 */
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 */
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);
/* 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.
=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.
#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)
#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
#define SvTAINT(sv) \
STMT_START { \
if (PL_tainting) { \
- dTHR; \
if (PL_tainted) \
SvTAINTED_on(sv); \
} \
#define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv))
#define Sv_Grow sv_grow
+#define SV_IMMEDIATE_UNREF 1
-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.
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.
$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;
$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;
--- /dev/null
+#!./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";
+
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
# 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';
use strict;
-print "1..110\n";
+print "1..124\n";
my $i = 1;
@array = (qw(O K)," ", $i++);
sub_array { lc shift } @array;
+sub_array { lc shift } ('O', 'K', ' ', $i++);
print "\n";
##
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";
print $_[1] ? "ok " : "not ok ", $_[0], "\n";
}
-print "1..18\n";
+print "1..20\n";
my $NEWPROTO = 'Prototype mismatch:';
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;
my $f = shift;
open(REQ,">$f") or die "Can't write '$f': $!";
binmode REQ;
+ use bytes;
print REQ @_;
close REQ;
}
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
# $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";
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);
else { system 'cat Io.dup' }
unlink 'Io.dup';
-print STDOUT "ok 6\n";
+print STDOUT "ok 8\n";
{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";}
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";
$| = 1;
use warnings;
$Is_VMS = $^O eq 'VMS';
+$Is_Dos = $^O eq 'dos';
print "1..66\n";
{
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;
}
}
$| = 1;
-print "1..15\n";
+print "1..16\n";
# External program 'tr' assumed.
open(PIPE, "|-") || (exec 'tr', 'YX', 'ko');
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";
+ }
}
}
}
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";
+}
# $RCSfile: tell.t,v $$Revision$$Date$
-print "1..21\n";
+print "1..23\n";
$TST = 'tst';
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.
+
--- /dev/null
+#!./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');
+
}
}
+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;
{
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";
use strict;
use Config;
-print "1..13\n";
+print "1..17\n";
my $test = 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`;
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`;
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 {
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;
+}
$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
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';
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>');
--- /dev/null
+#!./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";
+
}
}
+use warnings;
+use strict;
use DB_File;
use Fcntl;
-print "1..155\n";
+print "1..157\n";
sub ok
{
}
-$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;
# 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++;
}
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) ;
$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);
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
# 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
$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'}) ;
$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)
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
# 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' ;
# 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 ;
}
package Another ;
+ use warnings ;
use strict ;
open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
package SubDB ;
+ use warnings ;
use strict ;
use vars qw( @ISA @EXPORT) ;
{
# DBM Filter tests
+ use warnings ;
use strict ;
my (%h, $db) ;
my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
{
# DBM Filter with a closure
+ use warnings ;
use strict ;
my (%h, $db) ;
{
# DBM Filter recursion detection
+ use warnings ;
use strict ;
my (%h, $db) ;
unlink $Dfile;
# BTREE example 1
###
+ use warnings FATAL => qw(all) ;
use strict ;
use DB_File ;
# BTREE example 2
###
+ use warnings FATAL => qw(all) ;
use strict ;
use DB_File ;
# BTREE example 3
###
+ use warnings FATAL => qw(all) ;
use strict ;
use DB_File ;
# BTREE example 4
###
+ use warnings FATAL => qw(all) ;
use strict ;
use DB_File ;
# BTREE example 5
###
+ use warnings FATAL => qw(all) ;
use strict ;
use DB_File ;
# BTREE example 6
###
+ use warnings FATAL => qw(all) ;
use strict ;
use DB_File ;
# BTREE example 7
###
+ use warnings FATAL => qw(all) ;
use strict ;
use DB_File ;
use Fcntl ;
# 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 ;
}
}
+use strict;
+use warnings;
use DB_File;
use Fcntl;
-print "1..109\n";
+print "1..111\n";
sub ok
{
}
my $Dfile = "dbhash.tmp";
+my $null_keys_allowed = ($DB_File::db_ver < 2.004010
+ || $DB_File::db_ver >= 3.1 );
+
unlink $Dfile;
umask(0);
# 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++;
}
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) ;
$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 );
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) );
# 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
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
package Another ;
+ use warnings ;
use strict ;
open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
package SubDB ;
+ use warnings ;
use strict ;
use vars qw( @ISA @EXPORT) ;
{
# DBM Filter tests
+ use warnings ;
use strict ;
my (%h, $db) ;
my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
{
# DBM Filter with a closure
+ use warnings ;
use strict ;
my (%h, $db) ;
{
# DBM Filter recursion detection
+ use warnings ;
use strict ;
my (%h, $db) ;
unlink $Dfile;
{
my $redirect = new Redirect $file ;
+ use warnings FATAL => qw(all);
use strict ;
use DB_File ;
use vars qw( %h $k $v ) ;
}
+{
+ # 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 ;
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
EOM
}
-print "1..126\n";
+print "1..128\n";
my $Dfile = "recno.tmp";
unlink $Dfile ;
package Another ;
+ use warnings ;
use strict ;
open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
package SubDB ;
+ use warnings ;
use strict ;
use vars qw( @ISA @EXPORT) ;
{
# DBM Filter tests
+ use warnings ;
use strict ;
my (@h, $db) ;
my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
{
# DBM Filter with a closure
+ use warnings ;
use strict ;
my (@h, $db) ;
{
# DBM Filter recursion detection
+ use warnings ;
use strict ;
my (@h, $db) ;
unlink $Dfile;
{
my $redirect = new Redirect $file ;
+ use warnings FATAL => qw(all);
use strict ;
use DB_File ;
{
my $redirect = new Redirect $save_output ;
+ use warnings FATAL => qw(all);
use strict ;
use vars qw(@h $H $file $i) ;
use DB_File ;
}
+{
+ # 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 ;
}
END {
- unlink 'tmon.out', 'err';
+ while(-e 'tmon.out' && unlink 'tmon.out') {}
+ while(-e 'err' && unlink 'err') {}
}
use Benchmark qw( timediff timestr );
# -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 );
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 );
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;
}
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;
$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?" }
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;
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");
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");
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");
+ }
+
--- /dev/null
+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;
--- /dev/null
+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" ;
+}
+
+
use File::Spec;
use File::Path;
use File::Temp qw/ :mktemp unlink0 /;
+use FileHandle;
ok(1);
use strict;
use File::Temp qw/ :POSIX unlink0 /;
+use FileHandle;
+
ok(1);
# TMPNAM - scalar
chdir 't' if -d 't';
@INC = '../lib';
require Test; import Test;
- plan(tests => 16);
+ plan(tests => 20);
}
use strict;
);
ok( (-f $tempfile) );
+# Should still be around after closing
+ok( close( $fh ) );
+ok( (-f $tempfile) );
+# Check again at exit
push(@files, $tempfile);
# TEMPDIR test
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";
use GDBM_File;
-print "1..66\n";
+print "1..68\n";
unlink <Op.dbmx*>;
close FILE ;
BEGIN { push @INC, '.'; }
+ unlink <dbhash.tmp*> ;
eval 'use SubDB ; ';
main::ok(13, $@ eq "") ;
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*>;
+}
}
$| = 1;
-print "1..14\n";
+print "1..20\n";
use IO::Socket;
} 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);
$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";
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);
# 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') {
} 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
$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;
+}
+
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>;
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";
$! = 0;
$x->setpos(undef);
print $! ? "ok 4 # $!\n" : "not ok 4\n";
+
#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*>;
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)) ;
+}
--- /dev/null
+#!./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";
+}
#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*>;
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;
#
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;
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,
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},
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(){@_},
#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.*>;
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*>;
+}
#!./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.
#
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';
}
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);
#!./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
#
# 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
#
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;
}
require Fcntl; import Fcntl qw(/^O_/ /^SEEK_/);
}
+use strict;
+
+our @s;
+our $fail;
+
sub zap {
close(BIG);
unlink("big");
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();
}
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();
}
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();
}
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();
}
$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";
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;
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;
fail unless $zero eq "\0\0\0";
print "ok 17\n";
-explain if $fail;
+explain() if $fail;
bye(); # does the necessary cleanup
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);
+}
$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";
$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;
+}
--- /dev/null
+#!/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;
+}
+
--- /dev/null
+#!./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
--- /dev/null
+#!/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";
+
# 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;
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
#!./perl
-print "1..70\n";
+print "1..71\n";
#
# @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
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";
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; }
{ 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;
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;
@INC = '../lib';
}
-print "1..38\n";
+print "1..42\n";
# numerics
print ((0xdead & 0xbeef) == 0x9ead ? "ok 1\n" : "not ok 1\n");
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";
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";
#!./perl
-print "1..30\n";
+print "1..33\n";
# optimized
$/ = \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";
#!./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";
}
}
}
--- /dev/null
+#!./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++;
+}
#!./perl
-print "1..19\n";
+print "1..24\n";
$h{'abc'} = 'ABC';
$h{'def'} = 'DEF';
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";
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;
[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";
### 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");
# 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
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, @_)
# 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");
#!./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";}
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";
+}
+
--- /dev/null
+#!./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++;
+}
}
}
+use strict;
+
+our @s;
+our $fail;
+
sub zap {
close(BIG);
unlink("big");
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();
}
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();
}
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();
}
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();
}
$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";
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;
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";
fail unless $zero eq "\0\0\0";
print "ok 17\n";
-explain if $fail;
+explain() if $fail;
bye(); # does the necessary cleanup
#!./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;
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";
+}
@INC = '../lib';
}
-print "1..53\n";
+print "1..54\n";
@A::ISA = 'B';
@B::ISA = 'C';
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);
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!
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";
}
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";
#!./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;
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";
+
# 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';
$_ = '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++;
}
$_ = 'a';
foreach $ans ('', 'a', '') {
/^|a|$/g;
- print "not " unless $& eq $ans;
+ print "# \$& ='$&'\n# \$ans='$ans'\nnot " unless $& eq $ans;
print "ok $test\n";
$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 "
}
{
+ 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;
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" );
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++;
+
#!./perl
-print "1..3\n";
+print "1..4\n";
$x='banana';
$x=~/.a/g;
$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";
+
+
+
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
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
(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 $&
'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
'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
'(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 $&
'(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 {
^(\(+)?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
([[:]+) 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]+)/
'^.{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
#!./perl
-print "1..56\n";
+print "1..61\n";
# Test glob operations.
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
}
# 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
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);
$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;
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;
'/(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=]{#}]/',
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;
--- /dev/null
+#!./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";
+}
@INC = '../lib';
}
use warnings;
-print "1..57\n";
+print "1..58\n";
# XXX known to leak scalars
{
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";
+}
#!./perl
-print "1..28\n";
+print "1..30\n";
$FS = ':';
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";
>%.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<
>%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<
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
}
}
+{
+ # 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;
+}
+
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
--- /dev/null
+#!./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";
+ }
+ }
+}
@INC = '../lib';
}
-print "1..23\n";
+print "1..28\n";
my $test = 1;
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++;
+}
#!./perl
-print "1..9\n";
+print "1..11\n";
my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat';
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"; }
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"; }
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"; }
"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"; }
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"; }
######################### 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;
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];
# 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);
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
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
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//;
}
}
} else {
push @enc, $_;
+ push @enc, "$_.UTF-8";
}
}
if ($^O eq 'os390') {
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");
+ }
}
}
}
setlocale(LC_ALL, "C");
+sub utf8locale { $_[0] =~ /utf-?8/i }
+
@Locale = sort @Locale;
debug "# Locales = @Locale\n";
# Test \w.
- {
+ if (utf8locale($Locale)) {
+ # Until the polymorphic regexen arrive.
+ debug "# skipping UTF-8 locale '$Locale'\n";
+ } else {
my $word = join('', @Neoalpha);
$word =~ /^(\w+)$/;
}
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;
}
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 = ();
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";
my $didwarn = 0;
-foreach (99..116) {
+foreach (99..$last) {
if ($Problem{$_}) {
my @f = sort keys %{ $Problem{$_} };
my $f = join(" ", @f);
}
}
-# 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) {
"#\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";
}
}
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] } ) ];
-print "1..46\n";
+print "1..49\n";
BEGIN {
chdir 't' if -d 't';
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 $_ = $@;
$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";
+
}
}
-print "1..99\n";
+print "1..105\n";
my $test = 1;
{
use utf8;
+
$_ = ">\x{263A}<";
s/([\x{80}-\x{10ffff}])/"&#".ord($1).";"/eg;
ok $_, '>☺<';
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
}
{
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
}
{
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
}
{
- # 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;
}
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++;
}
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
}
{
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;
$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;
$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
+}
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' ;
my $a = <FH> ;
no warnings 'io' ;
$a = <FH> ;
+close (FH) ;
unlink $file ;
EXPECT
Filehandle FH opened only for output at - line 5.
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.
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 =
.
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]
# 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
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' ;
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) ;
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.
__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" ;
{
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.
########
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+//){
void
Perl_taint_proper(pTHX_ const char *f, const char *s)
{
- dTHR; /* just for taint */
char *ug;
#ifdef HAS_SETEUID
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}");
}
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}");
}
/* 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);
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);
}
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 *)
#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 */
/* 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.
/*
* 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.
*/
/*#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)))
#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"
* 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.
*/
void
Perl_deprecate(pTHX_ char *s)
{
- dTHR;
if (ckWARN(WARN_DEPRECATED))
Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
}
void
Perl_lex_start(pTHX_ SV *line)
{
- dTHR;
char *s;
STRLEN len;
STATIC void
S_incline(pTHX_ char *s)
{
- dTHR;
char *t;
char *n;
char *e;
return;
if (*s == ' ' || *s == '\t')
s++;
- else
+ else
return;
while (SPACE_OR_TAB(*s)) s++;
if (!isDIGIT(*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++;
{
char *s;
char *t;
- dTHR;
if (PL_oldoldbufptr != PL_last_uni)
return;
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;
}
STATIC I32
S_lop(pTHX_ I32 f, int x, char *s)
{
- dTHR;
yylval.ival = f;
CLINE;
PL_expect = x;
* handles the token correctly.
*/
-STATIC void
+STATIC void
S_force_next(pTHX_ I32 type)
{
PL_nexttype[PL_nexttoke] = type;
{
register char *s;
STRLEN len;
-
+
start = skipspace(start);
s = start;
if (isIDFIRST_lazy_if(s,UTF) ||
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.
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;
return retval;
}
-/*
+/*
* S_force_version
* Forces the next token to be a version number.
*/
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)) {
/* 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);
}
SvUTF8_on(nsv);
SvREFCNT_dec(sv);
sv = nsv;
- }
+ }
yylval.opval = (OP*)newSVOP(op_type, 0, sv);
PL_lex_stuff = Nullsv;
return THING;
STATIC I32
S_sublex_push(pTHX)
{
- dTHR;
ENTER;
PL_lex_state = PL_sublex_info.super_state;
} (end switch)
} (end if backslash)
} (end while character to read)
-
+
*/
STATIC char *
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;
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) {
while (count && (c = *regparse)) {
if (c == '\\' && regparse[1])
regparse++;
- else if (c == '{')
+ else if (c == '{')
count++;
- else if (c == '}')
+ else if (c == '}')
count--;
regparse++;
}
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 */
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 = '$';
/* 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 */
/* \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 */
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--;
}
}
- 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;
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);
/* 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);
*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;
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 */
*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 */
/* 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"
/* 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).
*
av_store(PL_rsfp_filters, 0, datasv) ;
return(datasv);
}
-
+
/* Delete most recently added instance of this filter function. */
void
/* 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;
/* 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) ;
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) {
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.
}
}
- /*
+ /*
build the ops for accesses to a my() variable.
Deny my($a) or my($b) in a sort block, *if* $a or $b is
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.
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... */
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;
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);
} )
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)
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:
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;
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
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:
goto retry;
case '-':
if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
+ I32 ftst = 0;
+
s++;
PL_bufptr = s;
tmp = *s++;
if (strnEQ(s,"=>",2)) {
s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ "### Saw unary minus before =>, forcing word '%s'\n", s);
+ } )
OPERATOR('-'); /* unary minus */
}
PL_last_uni = PL_oldbufptr;
- PL_last_lop_op = OP_FTEREAD; /* good enough */
switch (tmp) {
- case 'r': FTST(OP_FTEREAD);
- case 'w': FTST(OP_FTEWRITE);
- case 'x': FTST(OP_FTEEXEC);
- case 'o': FTST(OP_FTEOWNED);
- case 'R': FTST(OP_FTRREAD);
- case 'W': FTST(OP_FTRWRITE);
- case 'X': FTST(OP_FTREXEC);
- case 'O': FTST(OP_FTROWNED);
- case 'e': FTST(OP_FTIS);
- case 'z': FTST(OP_FTZERO);
- case 's': FTST(OP_FTSIZE);
- case 'f': FTST(OP_FTFILE);
- case 'd': FTST(OP_FTDIR);
- case 'l': FTST(OP_FTLINK);
- case 'p': FTST(OP_FTPIPE);
- case 'S': FTST(OP_FTSOCK);
- case 'u': FTST(OP_FTSUID);
- case 'g': FTST(OP_FTSGID);
- case 'k': FTST(OP_FTSVTX);
- case 'b': FTST(OP_FTBLK);
- case 'c': FTST(OP_FTCHR);
- case 't': FTST(OP_FTTTY);
- case 'T': FTST(OP_FTTEXT);
- case 'B': FTST(OP_FTBINARY);
- case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
- case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
- case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
+ case 'r': ftst = OP_FTEREAD; break;
+ case 'w': ftst = OP_FTEWRITE; break;
+ case 'x': ftst = OP_FTEEXEC; break;
+ case 'o': ftst = OP_FTEOWNED; break;
+ case 'R': ftst = OP_FTRREAD; break;
+ case 'W': ftst = OP_FTRWRITE; break;
+ case 'X': ftst = OP_FTREXEC; break;
+ case 'O': ftst = OP_FTROWNED; break;
+ case 'e': ftst = OP_FTIS; break;
+ case 'z': ftst = OP_FTZERO; break;
+ case 's': ftst = OP_FTSIZE; break;
+ case 'f': ftst = OP_FTFILE; break;
+ case 'd': ftst = OP_FTDIR; break;
+ case 'l': ftst = OP_FTLINK; break;
+ case 'p': ftst = OP_FTPIPE; break;
+ case 'S': ftst = OP_FTSOCK; break;
+ case 'u': ftst = OP_FTSUID; break;
+ case 'g': ftst = OP_FTSGID; break;
+ case 'k': ftst = OP_FTSVTX; break;
+ case 'b': ftst = OP_FTBLK; break;
+ case 'c': ftst = OP_FTCHR; break;
+ case 't': ftst = OP_FTTTY; break;
+ case 'T': ftst = OP_FTTEXT; break;
+ case 'B': ftst = OP_FTBINARY; break;
+ case 'M': case 'A': case 'C':
+ gv_fetchpv("\024",TRUE, SVt_PV);
+ switch (tmp) {
+ case 'M': ftst = OP_FTMTIME; break;
+ case 'A': ftst = OP_FTATIME; break;
+ case 'C': ftst = OP_FTCTIME; break;
+ default: break;
+ }
+ break;
default:
- Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
break;
}
+ 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) {
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('-');
}
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();
/* 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;
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;
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;
}
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)
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;> */
gv = gv_fetchpv(s, FALSE, SVt_PVCV);
*start = c;
if (!gv) {
- s = scan_num(s);
+ s = scan_num(s, &yylval);
TERM(THING);
}
}
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);
}
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;
/* 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;
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);
}
}
}
#endif
+#ifdef PERLIO_LAYERS
+ if (UTF && !IN_BYTE)
+ PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
+#endif
PL_rsfp = Nullfp;
}
goto fake_eof;
case KEY_exists:
UNI(OP_EXISTS);
-
+
case KEY_exit:
UNI(OP_EXIT);
case KEY_last:
s = force_word(s,WORD,TRUE,FALSE,FALSE);
LOOPX(OP_LAST);
-
+
case KEY_lc:
UNI(OP_LC);
case KEY_pos:
UNI(OP_POS);
-
+
case KEY_pack:
LOP(OP_PACK,XTERM);
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;
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) {
case KEY_chomp:
UNI(OP_CHOMP);
-
+
case KEY_scalar:
UNI(OP_SCALAR);
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");
}
{
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);
}
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;
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;
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;
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;
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;
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;
}
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++) {
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;
typesv = sv_2mortal(newSVpv(type, 0));
else
typesv = &PL_sv_undef;
-
+
PUSHSTACKi(PERLSI_OVERLOAD);
ENTER ;
SAVETMPS;
-
+
PUSHMARK(SP) ;
EXTEND(sp, 3);
if (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;
res = POPs;
(void)SvREFCNT_inc(res);
}
-
+
PUTBACK ;
FREETMPS ;
LEAVE ;
POPSTACK;
-
+
if (!SvOK(res)) {
why1 = "Call to &{$^H{";
why2 = key;
return res;
}
-
+
STATIC char *
S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
{
*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);
*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);
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);
*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,
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))
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)))
{
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;
STATIC char *
S_scan_heredoc(pTHX_ register char *s)
{
- dTHR;
SV *herewas;
I32 op_type = OP_SCALAR;
I32 len;
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;
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
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))
/* 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);
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;
}
}
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;
}
}
/* 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++;
/* 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
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 */
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':
we in octal/hex/binary?" indicator to disallow hex characters
when in octal mode.
*/
- dTHR;
NV n = 0.0;
UV u = 0;
I32 shift;
if ((x >> shift) != u
&& !(PL_hints & HINT_NEW_BINARY)) {
- dTHR;
overflowed = TRUE;
n = (NV) u;
if (ckWARN_d(WARN_OVERFLOW))
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",
}
else {
#if UVSIZE > 4
- dTHR;
if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
Perl_warner(aTHX_ WARN_PORTABLE,
"%s number > %s non-portable",
/* 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;
/* final misplaced underbar check */
if (lastub && s - lastub != 3) {
- dTHR;
if (ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
}
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)
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
*/
{
#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;
pos++;
if (!isALPHA(*pos)) {
UV rev;
- U8 tmpbuf[UTF8_MAXLEN];
+ U8 tmpbuf[UTF8_MAXLEN+1];
U8 *tmpend;
bool utf8 = FALSE;
s++; /* get past 'v' */
SvREADONLY_on(sv);
if (utf8) {
SvUTF8_on(sv);
- sv_utf8_downgrade(sv, TRUE);
+ if (!UTF||IN_BYTE)
+ sv_utf8_downgrade(sv, TRUE);
}
}
}
/* 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;
}
STATIC char *
S_scan_formline(pTHX_ register char *s)
{
- dTHR;
register char *eol;
register char *t;
SV *stuff = newSVpvn("",0);
I32
Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
{
- dTHR;
I32 oldsavestack_ix = PL_savestack_ix;
CV* outsidecv = PL_compcv;
AV* comppadlist;
int
Perl_yywarn(pTHX_ char *s)
{
- dTHR;
PL_in_eval |= EVAL_WARNONLY;
yyerror(s);
PL_in_eval &= ~EVAL_WARNONLY;
int
Perl_yyerror(pTHX_ char *s)
{
- dTHR;
char *where = NULL;
char *context = NULL;
int contlen = -1;
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");
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);
}
*/
/*#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.
*/
#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.
* 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.
#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.
*/
/*#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>
*/
/*#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).
*/
/*#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.
*/
/*#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.
*/
/*#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.
* 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:
*/
/*#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.
#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().
#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
* 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
*/
#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.
#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
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'
cpp_stuff='42'
crosscompile='undef'
d_Gconvert='sprintf((b),"%.*g",(n),(x))'
-d_SCNfldbl='undef'
d_PRIEUldbl='undef'
d_PRIFUldbl='undef'
d_PRIGUldbl='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'
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'
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'
d_getnbyname='undef'
d_getnent='undef'
d_getnetprotos='undef'
+d_getpagsz='undef'
d_getpbyname='undef'
d_getpbynumber='undef'
d_getpent='undef'
d_getppid='undef'
d_getprior='undef'
d_getprotoprotos='undef'
+d_getprpwnam='undef'
d_getpwent='undef'
d_getsbyname='undef'
d_getsbyport='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'
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'
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'
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'
d_open3='undef'
d_pathconf='undef'
d_pause='undef'
+d_perl_otherlibdirs='undef'
d_phostname='undef'
d_pipe='undef'
d_poll='undef'
d_pwgecos='undef'
d_pwpasswd='undef'
d_pwquota='undef'
+d_qgcvt='undef'
d_quad='undef'
d_readdir='undef'
d_readlink='undef'
d_safebcpy='undef'
d_safemcpy='undef'
d_sanemcmp='undef'
+d_sbrkproto='undef'
d_sched_yield='undef'
d_scm_rights='undef'
d_seekdir='undef'
d_setruid='undef'
d_setsent='undef'
d_setsid='undef'
-d_setspent='undef'
d_setvbuf='undef'
d_sfio='undef'
d_shm='undef'
d_sigaction='undef'
d_sigsetjmp='undef'
d_socket='undef'
+d_socklen_t='undef'
d_sockpair='undef'
d_socks5_init='undef'
d_sqrtl='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'
d_strtol='undef'
d_strtold='undef'
d_strtoll='undef'
+d_strtoq='undef'
d_strtoul='undef'
d_strtoull='undef'
d_strtouq='undef'
d_uname='undef'
d_union_semun='undef'
d_ustat='undef'
+d_vendorarch='undef'
d_vendorbin='undef'
d_vendorlib='undef'
d_vfork='undef'
i_gdbm='undef'
i_grp='undef'
i_iconv='undef'
+i_ieeefp='undef'
i_inttypes='undef'
i_libutil='undef'
i_limits='undef'
i_netinettcp='undef'
i_niin='undef'
i_poll='undef'
+i_prot='undef'
i_pthread='undef'
i_pwd='undef'
i_rpcsvcdbm='undef'
i_stddef='undef'
i_stdlib='undef'
i_string='define'
+i_sunmath='undef'
i_sysaccess='undef'
i_sysdir='undef'
i_sysfile='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'
i_systypes='undef'
i_sysuio='undef'
i_sysun='undef'
+i_sysutsname='undef'
i_sysvfs='undef'
i_syswait='undef'
i_termio='undef'
i_varhdr='stdarg.h'
i_vfork='undef'
ignore_versioned_solibs='y'
+inc_version_list_init='NULL'
installstyle='lib/perl5'
installusrbinperl='undef'
intsize='4'
multiarch='undef'
myarchname='unknown'
myuname='unknown'
+need_va_copy='undef'
netdb_hlen_type='int'
netdb_host_type='const char *'
netdb_name_type='const char *'
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'
sPRIo64='"Lo"'
sPRIu64='"Lu"'
sPRIx64='"Lx"'
+sSCNfldbl='"llf"'
sched_yield='sched_yield()'
scriptdir='/usr/local/bin'
scriptdirexp='/usr/local/bin'
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)'
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'
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'
-
-
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",
# 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
/* 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.
/* 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) {
*d++ = (((uv >> 12) & 0x3f) | 0x80);
*d++ = (((uv >> 6) & 0x3f) | 0x80);
*d++ = (( uv & 0x3f) | 0x80);
+ *d = 0;
return d;
}
if (uv < 0x4000000) {
*d++ = (((uv >> 12) & 0x3f) | 0x80);
*d++ = (((uv >> 6) & 0x3f) | 0x80);
*d++ = (( uv & 0x3f) | 0x80);
+ *d = 0;
return d;
}
if (uv < 0x80000000) {
*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! */
*d++ = (((uv >> 12) & 0x3f) | 0x80);
*d++ = (((uv >> 6) & 0x3f) | 0x80);
*d++ = (( uv & 0x3f) | 0x80);
+ *d = 0;
return d;
}
#ifdef HAS_QUAD
*d++ = (((uv >> 12) & 0x3f) | 0x80);
*d++ = (((uv >> 6) & 0x3f) | 0x80);
*d++ = (( uv & 0x3f) | 0x80);
+ *d = 0;
return d;
}
#endif
/* Tests if some arbitrary number of bytes begins in a valid UTF-8 character.
* The actual number of bytes in the UTF-8 character will be returned if it
* is valid, otherwise 0. */
-int
+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;
}
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);
else {
while (off++) {
s--;
- if (*s & 0x80) {
- while ((*s & 0xc0) == 0x80)
- s--;
- }
+ while (UTF8_IS_CONTINUATION(*s))
+ s--;
}
}
return s;
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;
U8*
Perl_bytes_to_utf8(pTHX_ U8* s, STRLEN *len)
{
- dTHR;
U8 *send;
U8 *d;
U8 *dst;
continue;
}
if (uv >= 0xd800 && uv < 0xdbff) { /* surrogates */
- dTHR;
UV low = *p++;
if (low < 0xdc00 || low >= 0xdfff)
Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
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);
}
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);
}
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);
}
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);
}
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);
}
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);
}
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);
}
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);
}
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);
}
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);
}
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);
}
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);
}
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);
}
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);
}
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);
}
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);
}
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);
}
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);
}
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
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
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 */
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 */
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
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)
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))
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;
/* 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.
#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 : \
(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
/* 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.
#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
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;
#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));
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;
I32 x;
char *where = (char*)wh;
MEM_SIZE size;
-
+
if (!where)
return;
where -= ALIGN;
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];
}
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 {
* 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
}
/*
+ * 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
++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"));
{
* 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
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();
setlocale(LC_NUMERIC, "C");
PL_numeric_standard = TRUE;
PL_numeric_local = FALSE;
+ set_numeric_radix();
}
#endif /* USE_LOCALE_NUMERIC */
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
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;
}
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))
{
}
return b;
}
-
+
{ /* Do actual FBM. */
register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
register unsigned char *oldlittle;
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
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;
? (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);
found = 1;
}
} while ( pos += PL_screamnext[pos] );
- if (last && found)
+ if (last && found)
return (char *)(big+(*old_posp));
#endif /* POINTERRIGOR */
check_tail:
STATIC SV *
S_mess_alloc(pTHX)
{
- dTHR;
SV *sv;
XPVMG *any;
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));
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
OP *
Perl_vdie(pTHX_ const char* pat, va_list *args)
{
- dTHR;
char *message;
int was_in_eval = PL_in_eval;
HV *stash;
void
Perl_vcroak(pTHX_ const char* pat, va_list *args)
{
- dTHR;
char *message;
HV *stash;
GV *gv;
if (PL_warnhook) {
/* sv_2cv might call Perl_warn() */
- dTHR;
SV *oldwarnhook = PL_warnhook;
ENTER;
SAVESPTR(PL_warnhook);
PerlIO_write(serr, message, msglen);
#ifdef LEAKTEST
- DEBUG_L(*message == '!'
+ DEBUG_L(*message == '!'
? (xstat(message[1]=='!'
? (message[2]=='!' ? 2 : 1)
: 0)
void
Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
{
- dTHR;
char *message;
HV *stash;
GV *gv;
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);
else {
if (PL_warnhook) {
/* sv_2cv might call Perl_warn() */
- dTHR;
SV *oldwarnhook = PL_warnhook;
ENTER;
SAVESPTR(PL_warnhook);
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);
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)
#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)
{
(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)
}
#endif /* WIN32 */
-#endif
I32
Perl_setenv_getix(pTHX_ char *nam)
if (doexec) {
return my_syspopen(aTHX_ cmd,mode);
}
-#endif
+#endif
This = (*mode == 'w');
that = !This;
if (doexec && PL_tainting) {
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;
}
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
if (pid == -1) { /* Opened by popen. */
return my_syspclose(ptr);
}
-#endif
+#endif
if ((close_failed = (PerlIO_close(ptr) == EOF))) {
saved_errno = errno;
#ifdef VMS
#else
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
-#endif
+#endif
{
/* Needs work for PerlIO ! */
FILE *f = PerlIO_findFILE(ptr);
/* 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)
#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;
continue;
}
else {
- dTHR;
if (ckWARN(WARN_DIGIT))
Perl_warner(aTHX_ WARN_DIGIT,
"Illegal binary digit '%c' ignored", *s);
register UV xuv = ruv << 1;
if ((xuv >> 1) != ruv) {
- dTHR;
overflowed = TRUE;
rnv = (NV) ruv;
if (ckWARN_d(WARN_OVERFLOW))
#if UVSIZE > 4
|| (!overflowed && ruv > 0xffffffff )
#endif
- ) {
- dTHR;
+ ) {
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
"Binary number > 0b11111111111111111111111111111111 non-portable");
}
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;
* 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);
register UV xuv = ruv << 3;
if ((xuv >> 3) != ruv) {
- dTHR;
overflowed = TRUE;
rnv = (NV) ruv;
if (ckWARN_d(WARN_OVERFLOW))
|| (!overflowed && ruv > 0xffffffff )
#endif
) {
- dTHR;
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
"Octal number > 037777777777 non-portable");
}
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) {
--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);
register UV xuv = ruv << 4;
if ((xuv >> 4) != ruv) {
- dTHR;
overflowed = TRUE;
rnv = (NV) ruv;
if (ckWARN_d(WARN_OVERFLOW))
#if UVSIZE > 4
|| (!overflowed && ruv > 0xffffffff )
#endif
- ) {
- dTHR;
+ ) {
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
"Hexadecimal number > 0xffffffff non-portable");
char*
Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
{
- dTHR;
char *xfound = Nullch;
char *xfailed = Nullch;
char tmpbuf[MAXPATHLEN];
}
#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. */
{
perl_os_thread t;
perl_cond cond = *cp;
-
+
if (!cond)
return;
t = cond->thread;
{
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 */
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;
Perl_condpair_magic(pTHX_ SV *sv)
{
MAGIC *mg;
-
+
SvUPGRADE(sv, SVt_PVMG);
mg = mg_find(sv, 'm');
if (!mg) {
thr->specific = newAV();
thr->errsv = newSVpvn("", 0);
thr->flags = THRf_R_JOINABLE;
+ thr->thr_done = 0;
MUTEX_INIT(&thr->mutex);
JMPENV_BOOTSTRAP;
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);
"new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
(IV)i, t, thr));
}
- }
+ }
thr->threadsvp = AvARRAY(thr->threadsv);
MUTEX_LOCK(&PL_threads_mutex);
#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)
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++)
PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
return 0;
}
-# endif
+# endif
SETERRNO(EBADF,RMS$_IFI);
return EOF;
+# endif
#endif
}
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))
/* 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.
=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>
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 = $];
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;
}
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";
}
$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])(.*)/) {
}
-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';
$exp_doc$meth_doc$revhist
#=head1 AUTHOR
#
-#$author, $email
+#$author, E<lt>${email}E<gt>
#
#=head1 SEE ALSO
#
'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;
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";
$::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.
# 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
EOF
die "\n";
}
-if (!-t STDOUT && !$outfile) { Dump(*STDOUT); exit; }
Query();
Edit() unless $usefile || ($ok and not $::opt_n);
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.
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",
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";
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
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";
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.
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.
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
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
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");
}
}
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;
+ }
}
}
}
status = FAIL;
if (sp > mark)
{
- dTHR;
New(401,PL_Argv, sp - mark + 1, char*);
a = PL_Argv;
while (++mark <= sp)
(const char **) environ);
if (pid < 0)
{
- dTHR;
status = FAIL;
if (ckWARN(WARN_EXEC))
warner(WARN_EXEC,"Can't exec \"%s\": %s",
- 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)
- 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);*
use ExtUtils::MakeMaker;
WriteMakefile( 'VERSION_FROM' => 'DCLsym.pm',
- 'MAN3PODS' => ' ');
+ 'MAN3PODS' => {});
use ExtUtils::MakeMaker;
WriteMakefile( 'VERSION_FROM' => 'Stdio.pm',
- 'MAN3PODS' => ' ', # pods will be built later
+ 'MAN3PODS' => {}, # pods will be built later
);
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
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
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
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) =
# 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;
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) {
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";
(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.
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"
$! 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
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")
@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
}
}
($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:
$ 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
#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);
}
#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++) {
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;
}
/*}}}*/
+/*{{{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)*/
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));
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...
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) {
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) {
}
} else { /* piping to subroutine , mode=w*/
- int melded;
info->in = pipe_tochild_setup(in,mbx);
info->fp = PerlIO_open(mbx, 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) {
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';
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++;
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));
_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;
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")))
{
exit(vaxc$errno);
}
+ Perl_vmssetuserlnm("SYS$ERROR",err);
}
}
#ifdef ARGPROC_DEBUG
#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 *);
$ 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
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".
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
&
& 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.
&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)
& 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
& &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
&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.
&
&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
&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
& 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
&
&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 <
$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'
$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_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_getnbyname='define'
$d_getnent='define'
$d_getnetprotos='define'
+$d_getpagsz='undef'
$d_getpbyname='define'
$d_getpbynumber='define'
$d_getpent='define'
$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'
$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'
$d_pwgecos='undef'
$d_pwpasswd='undef'
$d_pwquota='undef'
-$d_qgcvt='undef'
$d_quad='undef'
$d_readdir='define'
$d_readlink='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_shmatprototype='define'
$d_sigaction='undef'
$d_sigsetjmp='undef'
-$d_sitearch='undef'
$d_socket='define'
$d_sockpair='undef'
$d_socks5_init='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_strtol='define'
$d_strtold='undef'
$d_strtoll='undef'
+$d_strtoq='undef'
$d_strtoul='define'
$d_strtoull='undef'
$d_strtouq='undef'
$i_dlfcn='undef'
$i_fcntl='define'
$i_float='define'
-$i_grp='undef'
+$i_grp='define'
$i_iconv='undef'
$i_ieeefp='undef'
$i_inttypes='undef'
$i_poll='undef'
$i_prot='undef'
$i_pthread='undef'
-$i_pwd='undef'
+$i_pwd='define'
$i_rpcsvcdbm='undef'
$i_sfio='undef'
$i_sgtty='undef'
$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 *'
$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'
$uidsize='4'
$uidsign='-1'
$uidtype='uid_t'
+$undef='$undef'
$uquadtype='_error_'
$use5005threads='undef'
$use64bitall='undef'
$usemultiplicity='undef'
$useperlio='undef'
$usesocks='undef'
-$usethreads='undef'
$uvoformat='"o"'
$uvsize='4'
$uvtype='unsigned int'
$vendorarchexp=''
$vendorlib_stem=''
$vendorlibexp=''
-$versiononly='undef'
$voidflags='15'
$xs_apiversion='5.00563'
/*
* 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
*/
*/
#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().
*/
#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
*/
/*#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).
* 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
* 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
*/
#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.
* 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:
*/
/*#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.
* 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:
* 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 /**/
*/
#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.
* 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.
* 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:
* 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
/*#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
$byteorder='4321'
$castflags='0'
$cf_by='Paul_Green@stratus.com'
-$cf_time='2000-02-03 19:13 UCT'
+$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_access='undef'
+$d__fwalk='undef'
+$d_access='define'
$d_accessx='undef'
$d_alarm='define'
$d_archlib='undef'
$d_casti32='undef'
$d_castneg='define'
$d_charvspr='undef'
-$d_chown='undef'
+$d_chown='define'
$d_chroot='undef'
$d_chsize='undef'
$d_const='define'
$d_crypt='undef'
-$d_csh='undef'
+$d_csh='define'
$d_cuserid='undef'
$d_dbl_dig='define'
$d_difftime='define'
$d_dlsymun='undef'
$d_dosuid='undef'
$d_drand48proto='undef'
-$d_dup2='undef'
+$d_dup2='define'
$d_eaccess='undef'
$d_endgrent='undef'
$d_endhent='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='undef'
+$d_fork='define'
$d_fpathconf='define'
$d_fpos64_t='undef'
$d_frexpl='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_getnbyname='define'
$d_getnent='define'
$d_getnetprotos='define'
+$d_getpagsz='undef'
$d_getpbyname='define'
$d_getpbynumber='define'
$d_getpent='define'
$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'
$d_mkstemps='undef'
$d_mkfifo='define'
$d_mktime='define'
-$d_mmap='undef'
+$d_mmap='define'
$d_modfl='undef'
$d_mprotect='undef'
$d_msg='undef'
$d_msg_peek='undef'
$d_msg_proxy='undef'
$d_msync='undef'
-$d_munmap='undef'
+$d_munmap='define'
$d_mymalloc='undef'
$d_nice='undef'
$d_nv_preserves_uv='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'
$d_pwgecos='undef'
$d_pwpasswd='undef'
$d_pwquota='undef'
-$d_qgcvt='undef'
$d_quad='undef'
$d_readdir='define'
$d_readlink='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='undef'
-$d_seteuid='undef'
+$d_setegid='define'
+$d_seteuid='define'
$d_setgrent='undef'
$d_setgrps='undef'
$d_sethent='define'
-$d_setlinebuf='undef'
+$d_setlinebuf='define'
$d_setlocale='define'
$d_setnent='define'
$d_setpent='define'
-$d_setpgid='undef'
+$d_setpgid='define'
$d_setpgrp2='undef'
$d_setpgrp='undef'
$d_setprior='undef'
$d_setrgid='undef'
$d_setruid='undef'
$d_setsent='define'
-$d_setsid='undef'
+$d_setsid='define'
$d_setvbuf='define'
$d_sfio='undef'
$d_shm='undef'
$d_shmatprototype='define'
-$d_sigaction='undef'
-$d_sigsetjmp='undef'
-$d_sitearch='undef'
+$d_sigaction='define'
+$d_sigsetjmp='define'
$d_socket='define'
$d_sockpair='undef'
$d_socks5_init='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_strtol='define'
$d_strtold='undef'
$d_strtoll='undef'
+$d_strtoq='undef'
$d_strtoul='define'
$d_strtoull='undef'
$d_strtouq='undef'
$d_sysconf='define'
$d_syserrlst='define'
$d_system='define'
-$d_tcgetpgrp='undef'
-$d_tcsetpgrp='undef'
+$d_tcgetpgrp='define'
+$d_tcsetpgrp='define'
$d_telldir='undef'
$d_telldirproto='undef'
$d_times='define'
$d_void_closedir='undef'
$d_volatile='define'
$d_vprintf='define'
-$d_wait4='undef'
+$d_wait4='define'
$d_waitpid='define'
$d_wcstombs='define'
$d_wctomb='define'
$fflushNULL='define'
$fpostype='fpos_t'
$freetype='void'
-$full_csh=''
+$full_csh='/system/ported/command_library/bash.pm'
$full_sed='/system/ported/command_library/sed.pm'
$gidformat='"d"'
$gidsize='4'
$i_dlfcn='undef'
$i_fcntl='define'
$i_float='define'
-$i_grp='undef'
+$i_grp='define'
$i_iconv='undef'
$i_ieeefp='undef'
$i_inttypes='undef'
$i_ndbm='undef'
$i_netdb='define'
$i_neterrno='undef'
-$i_netinettcp='undef'
+$i_netinettcp='define'
$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'
$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 *'
$seedfunc='srand'
$selectminbits='1'
$selecttype='fd_set *'
-$sh='/bin/sh'
+$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","KILL","PIPE","QUIT","CHLD","CONT","STOP","TSTP","TTIN","TTOU","BUS","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,0'
+$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.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'
$uidsize='4'
$uidsign='-1'
$uidtype='uid_t'
+$undef='$undef'
$uquadtype='_error_'
$use5005threads='undef'
$use64bitall='undef'
$usemultiplicity='undef'
$useperlio='undef'
$usesocks='undef'
-$usethreads='undef'
$uvoformat='"o"'
$uvsize='4'
$uvtype='unsigned int'
$vendorarchexp=''
$vendorlib_stem=''
$vendorlibexp=''
-$versiononly='undef'
$voidflags='15'
$xs_apiversion='5.00563'
-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_
/* 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
* 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
* 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
* 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>
* 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
* 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
* <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
* 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
* 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
* 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
* 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
* 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
* 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.
* 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()
* 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
/* 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
* 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
* 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
* <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
* 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
* 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
*
* int main _((int argc, char *argv[]));
*/
-#$prototype CAN_PROTOTYPE /**/
+#define CAN_PROTOTYPE /**/
#ifdef CAN_PROTOTYPE
#define _(args) args
#else
* /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
* 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
* 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
* 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
#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
* 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.
* 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
* 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
* 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,
# define BYTEORDER 0x4321
# endif
#else
-#define BYTEORDER 0x$byteorder /* large digits for MSB */
+#define BYTEORDER 0x4321 /* large digits for MSB */
#endif /* NeXT */
/* CAT2:
/* 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
#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
* 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
* 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.
/* 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:
* 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
* 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
* 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
* 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:
* 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
* 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()
* 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
* 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
* 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()
* 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
* 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
* 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>
* 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
* 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:
* 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:
* 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
* (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
* 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
* 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
* 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
* 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()
* 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))
* 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:
* 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)
* 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:
* 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:
* 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
* 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
* 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
* 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
* 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
* 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
* 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
* 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:
* 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
* 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
* 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
* 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
* 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
* 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.
/* 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
/* 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
* 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
* 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
* 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
* 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.
* 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
* 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.
* 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
* 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
* 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.
* 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
* 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
* 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.
* 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.
* 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
* 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
* 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
* 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
* 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:
* should be used when available.
*/
#ifndef USE_LARGE_FILES
-#$uselargefiles USE_LARGE_FILES /**/
+/*#define USE_LARGE_FILES /**/
#endif
/* USE_LONG_DOUBLE:
* be used when available.
*/
#ifndef USE_LONG_DOUBLE
-#$uselongdouble USE_LONG_DOUBLE /**/
+#define USE_LONG_DOUBLE /**/
#endif
/* USE_MORE_BITS:
* long doubles should be used when available.
*/
#ifndef USE_MORE_BITS
-#$usemorebits USE_MORE_BITS /**/
+/*#define USE_MORE_BITS /**/
#endif
/* MULTIPLICITY:
* be built to use multiplicity.
*/
#ifndef MULTIPLICITY
-#$usemultiplicity MULTIPLICITY /**/
+/*#define MULTIPLICITY /**/
#endif
/* USE_PERLIO:
* used in a fully backward compatible manner.
*/
#ifndef USE_PERLIO
-#$useperlio USE_PERLIO /**/
+/*#define USE_PERLIO /**/
#endif
/* USE_SOCKS:
* be built to use socks.
*/
#ifndef USE_SOCKS
-#$usesocks USE_SOCKS /**/
+/*#define USE_SOCKS /**/
#endif
/* USE_ITHREADS:
* 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.
* 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
* 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
* 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 */
/* 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.
* 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
* (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
* 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
* 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!
#
# 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
if (/^([^=]+)='(.*)'$/) {
my ($var, $val) = ($1, $2);
$define{$var} = $val;
+ $used{$var} = 0;
} else {
warn "config.def: $.: illegal line: $_";
}
# 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: $!";
}
#
#
while (<CONFIG_SH>) {
+ $lineno = $lineno + 1;
last if /^sed <<!GROK!THIS!/;
}
#
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;
}
#
}
close (CONFIG_SH);
+
+while (($key,$value) = each %used) {
+ if ($value == 0) {
+ print "Unused keyword definition: $key\n";
+ }
+}
+
--- /dev/null
+& 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
--- /dev/null
+& 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
universal,
utf8,
util,
- xsutils,
- vos_dummies,
- tcp_runtime,
- tcp_gethost;
+ xsutils;
end;
-/*
- * 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"
#!/usr/bin/perl
+
+$VERSION = '1.00';
+
BEGIN {
push @INC, './lib';
}
for ($i = 1 ; $i < @a; ++ $i) {
- $out[$i] = ".."
+ $out[$i] = ".."
if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
}
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" }
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" ;
}
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" ;
}
package warnings;
+our $VERSION = '1.00';
+
=head1 NAME
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
$mask |= $DeadBits{$word} if $fatal ;
}
else
- { croak("unknown warnings category '$word'")}
+ { croak("unknown warnings category '$word'")}
}
return $mask ;
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 ;
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) ;
}
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) ;
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) ;
#
# 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.
#
##
# 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
#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).
#
# 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
!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
# 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.
#
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
#
# Rules
-#
+#
.SUFFIXES : .c $(o) .dll .lib .exe .rc .res
$(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
NOOP = @echo
NULL =
+DEL = bin\mdelete.bat
+
#
# filenames given to xsubpp must have forward slashes (since it puts
# full pathnames in #line strings)
WIN32_SRC = \
.\win32.c \
.\win32sck.c \
- .\win32thread.c
+ .\win32thread.c
!IF "$(CRYPT_SRC)" != ""
WIN32_SRC = $(WIN32_SRC) .\$(CRYPT_SRC)
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
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
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
$(DPROF).c \
$(GLOB).c \
$(HOSTNAME).c \
- $(STORABLE).c
+ $(STORABLE).c \
+ $(FILTER).c \
+ $(ENCODE).c
EXTENSION_DLL = \
$(SOCKET_DLL) \
$(DPROF_DLL) \
$(GLOB_DLL) \
$(HOSTNAME_DLL) \
- $(STORABLE_DLL)
+ $(STORABLE_DLL) \
+ $(FILTER_DLL) \
+ $(ENCODE_DLL)
EXTENSION_PM = \
$(ERRNO_PM)
"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)" \
$(GLOBEXE) : perlglob$(o)
$(LINK32) $(LINK_FLAGS) $(LIBFILES) -out:$@ -subsystem:$(SUBSYS) \
- perlglob$(o) setargv$(o)
+ perlglob$(o) setargv$(o)
perlglob$(o) : perlglob.c
# 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 ..
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:$@ @<<
$(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
$(LINK_FLAGS) $(LIBFILES) $(X2P_OBJ)
<<
-perlmain.c : runperl.c
+perlmain.c : runperl.c
copy runperl.c perlmain.c
perlmain$(o) : perlmain.c
$(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)
$(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
-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
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
$(RCOPY) html\*.* $(INST_HTML)\*.*
inst_lib : $(CONFIGPM)
- copy splittree.pl ..
+ copy splittree.pl ..
$(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR)
$(RCOPY) ..\lib $(INST_LIB)\*.*
$(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.
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
--- /dev/null
+@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\r
+rem ! This is a batch file to delete all the files on its\r
+rem ! command line, to work around command.com's del command's\r
+rem ! braindeadness\r
+rem !\r
+rem ! -- BKS, 11-11-2000\r
+\r
+:nextfile\r
+set file=%1\r
+shift\r
+if "%file%"=="" goto end\r
+del %file%\r
+goto nextfile\r
+:end\r
+\r
local($line_num, $ln, $tag) = 0;
local($use_default, @default) = 0;
- { package magic; $\17 = 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;
c=''
castflags='0'
cat='type'
-cc='bcc32'
+cc='~CC~'
cccdlflags=' '
ccdlflags='-tWD'
ccflags='-DWIN32'
crosscompile='undef'
cryptlib=''
csh='undef'
+d__fwalk='undef'
d_Gconvert='gcvt((x),(n),(b))'
d_PRIEUldbl='undef'
d_PRIFUldbl='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'
d_fsetpos='define'
d_fstatfs='undef'
d_fstatvfs='undef'
+d_fsync='undef'
d_ftello='undef'
d_ftime='define'
d_getcwd='undef'
d_getnbyname='undef'
d_getnent='undef'
d_getnetprotos='undef'
+d_getpagsz='undef'
d_getpbyname='define'
d_getpbynumber='define'
d_getpent='undef'
d_safebcpy='undef'
d_safemcpy='undef'
d_sanemcmp='define'
+d_sbrkproto='undef'
d_sched_yield='undef'
d_scm_rights='undef'
d_seekdir='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='define'
d_stdstdio='define'
d_strtol='define'
d_strtold='undef'
d_strtoll='undef'
+d_strtoq='undef'
d_strtoul='define'
d_strtoull='undef'
d_strtouq='undef'
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=''
myhostname=''
myuname=''
n='-n'
+need_va_copy='undef'
netdb_hlen_type='int'
netdb_host_type='char *'
netdb_name_type='char *'
c=''
castflags='0'
cat='type'
-cc='gcc'
+cc='~CC~'
cccdlflags=' '
ccdlflags=' '
ccflags='-MD -DWIN32'
crosscompile='undef'
cryptlib=''
csh='undef'
+d__fwalk='undef'
d_Gconvert='sprintf((b),"%.*g",(n),(x))'
d_PRIEUldbl='undef'
d_PRIFUldbl='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'
d_fsetpos='define'
d_fstatfs='undef'
d_fstatvfs='undef'
+d_fsync='undef'
d_ftello='undef'
d_ftime='define'
d_getcwd='undef'
d_getnbyname='undef'
d_getnent='undef'
d_getnetprotos='undef'
+d_getpagsz='undef'
d_getpbyname='define'
d_getpbynumber='define'
d_getpent='undef'
d_safebcpy='undef'
d_safemcpy='undef'
d_sanemcmp='define'
+d_sbrkproto='undef'
d_sched_yield='undef'
d_scm_rights='undef'
d_seekdir='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='define'
d_stdio_stream_array='undef'
d_stdiobase='define'
d_stdstdio='define'
d_strtol='define'
d_strtold='undef'
d_strtoll='undef'
+d_strtoq='undef'
d_strtoul='define'
d_strtoull='undef'
d_strtouq='undef'
installvendorbin=''
installvendorlib=''
intsize='4'
+issymlink=''
ivdformat='"ld"'
ivsize='4'
ivtype='long'
myhostname=''
myuname=''
n='-n'
+need_va_copy='undef'
netdb_hlen_type='int'
netdb_host_type='char *'
netdb_name_type='char *'
usemymalloc='n'
usenm='false'
useopcode='true'
-useperlio='undef'
+useperlio='define'
useposix='true'
usesfio='false'
useshrplib='yes'
-## Configured by: ~cf_email~
+# Configured by: ~cf_email~
## Target system: WIN32
Author=''
CONFIGDOTSH='true'
c=''
castflags='0'
cat='type'
-cc='cl'
+cc='~CC~'
cccdlflags=' '
ccdlflags=' '
ccflags='-MD -DWIN32'
crosscompile='undef'
cryptlib=''
csh='undef'
+d__fwalk='undef'
d_Gconvert='sprintf((b),"%.*g",(n),(x))'
d_PRIEUldbl='undef'
d_PRIFUldbl='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'
d_fsetpos='define'
d_fstatfs='undef'
d_fstatvfs='undef'
+d_fsync='undef'
d_ftello='undef'
d_ftime='define'
d_getcwd='undef'
d_getnbyname='undef'
d_getnent='undef'
d_getnetprotos='undef'
+d_getpagsz='undef'
d_getpbyname='define'
d_getpbynumber='define'
d_getpent='undef'
d_safebcpy='undef'
d_safemcpy='undef'
d_sanemcmp='define'
+d_sbrkproto='undef'
d_sched_yield='undef'
d_scm_rights='undef'
d_seekdir='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='define'
d_stdio_stream_array='undef'
d_stdiobase='define'
d_stdstdio='define'
d_strtol='define'
d_strtold='undef'
d_strtoll='undef'
+d_strtoq='undef'
d_strtoul='define'
d_strtoull='undef'
d_strtouq='undef'
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=''
myhostname=''
myuname=''
n='-n'
+need_va_copy='undef'
netdb_hlen_type='int'
netdb_host_type='char *'
netdb_name_type='char *'
usemymalloc='n'
usenm='false'
useopcode='true'
-useperlio='undef'
+useperlio='define'
useposix='true'
usesfio='false'
useshrplib='yes'
/*
* 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 $
*/
/*
* 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 :
*/
*/
/*#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().
*/
/*#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.
*/
/*#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.
*/
#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.
* 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:
* 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
* 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
* 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:
*/
#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.
*/
/*#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.
*/
/*#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_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.
*/
/*#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.
*/
/*#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
/*#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
*/
/*#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).
*/
/*#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.
/*#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.
* 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:
*/
/*#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>.
*/
/*#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>.
* 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.
#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.
*/
/* 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
#define I64SIZE 8 /**/
#define U64SIZE 8 /**/
#endif
+#define NVSIZE 8 /**/
#define NV_PRESERVES_UV
#define NV_PRESERVES_UV_BITS 32
*/
/* 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
* 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
* 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:
* 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:
* be built to use multiplicity.
*/
#ifndef MULTIPLICITY
-/*#define MULTIPLICITY /**/
+#define MULTIPLICITY /**/
#endif
/* USE_PERLIO:
* 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
/* 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.
* 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
#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
/*
* 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 $
*/
/*
* 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 :
*/
*/
/*#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().
*/
/*#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.
*/
/*#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.
*/
#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.
* 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:
* 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
* 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
* 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:
*/
#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.
*/
/*#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.
*/
/*#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_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.
*/
/*#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.
*/
/*#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
/*#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
*/
/*#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).
*/
/*#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.
/*#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.
* 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:
*/
/*#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>.
*/
/*#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>.
* 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.
#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.
*/
/* 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
#define I64SIZE 8 /**/
#define U64SIZE 8 /**/
#endif
+#define NVSIZE 8 /**/
#define NV_PRESERVES_UV
#define NV_PRESERVES_UV_BITS 32
*/
/* 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
* 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
* 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:
* 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:
* be built to use multiplicity.
*/
#ifndef MULTIPLICITY
-/*#define MULTIPLICITY /**/
+#define MULTIPLICITY /**/
#endif
/* USE_PERLIO:
* used in a fully backward compatible manner.
*/
#ifndef USE_PERLIO
-/*#define USE_PERLIO /**/
+#define USE_PERLIO /**/
#endif
/* USE_SOCKS:
* 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
/* 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.
* 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
#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
/*
* 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 $
*/
/*
* 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 :
*/
*/
/*#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().
*/
/*#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.
*/
/*#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.
*/
#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.
* 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:
* 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
* 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
* 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:
*/
#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.
*/
/*#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.
*/
/*#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_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.
*/
/*#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.
*/
/*#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
/*#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
*/
/*#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).
*/
/*#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.
/*#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.
* 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:
*/
/*#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>.
*/
/*#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>.
* 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.
#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.
*/
/* 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
#define I64SIZE 8 /**/
#define U64SIZE 8 /**/
#endif
+#define NVSIZE 8 /**/
#define NV_PRESERVES_UV
#define NV_PRESERVES_UV_BITS 32
*/
/* 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
* 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
* 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:
* 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:
* be built to use multiplicity.
*/
#ifndef MULTIPLICITY
-/*#define MULTIPLICITY /**/
+#define MULTIPLICITY /**/
#endif
/* USE_PERLIO:
* used in a fully backward compatible manner.
*/
#ifndef USE_PERLIO
-/*#define USE_PERLIO /**/
+#define USE_PERLIO /**/
#endif
/* USE_SOCKS:
* 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
/* 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.
* 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
#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
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;
--- /dev/null
+@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
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
# 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.
#
##
# 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
# 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
#
# 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
# 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.
#
#CCHOME *= c:\bc5
#CCHOME *= $(MSVCDIR)
-CCHOME *= c:\gcc-2.95.2-msvcrt
+CCHOME *= c:\gcc-2.95.2
CCINCDIR *= $(CCHOME)\include
CCLIBDIR *= $(CCHOME)\lib
# 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
# 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
LINK_DBG = -v
.ELSE
OPTIMIZE = -O2 -D_RTLDLL
-LINK_DBG =
+LINK_DBG =
.ENDIF
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"
IMPLIB = dlltool
RSC = rc
+i = .i
o = .o
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
-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
#
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
.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
#
# 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)
$(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:
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
CFGSH_TMPL = config.gc
CFGH_TMPL = config_H.gc
-PERLIMPLIB = ..\libperl56$(a)
+PERLIMPLIB = ..\libperl57$(a)
.ELSE
.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
WIN32_SRC = \
.\win32.c \
.\win32sck.c \
- .\win32thread.c
+ .\win32thread.c
.IF "$(CRYPT_SRC)" != ""
WIN32_SRC += .\$(CRYPT_SRC)
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
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
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
$(DPROF).c \
$(GLOB).c \
$(HOSTNAME).c \
- $(STORABLE).c
+ $(STORABLE).c \
+ $(FILTER).c \
+ $(ENCODE).c
EXTENSION_DLL = \
$(SOCKET_DLL) \
$(DPROF_DLL) \
$(GLOB_DLL) \
$(HOSTNAME_DLL) \
- $(STORABLE_DLL)
+ $(STORABLE_DLL) \
+ $(FILTER_DLL) \
+ $(ENCODE_DLL)
EXTENSION_PM = \
$(ERRNO_PM)
INST_ARCH=$(INST_ARCH) ~ \
archname=$(ARCHNAME) ~ \
cc=$(CC) ~ \
+ ld=$(LINK32) ~ \
ccflags=$(OPTIMIZE) $(DEFINES) $(BUILDOPT) ~ \
cf_email=$(EMAIL) ~ \
d_crypt=$(D_CRYPT) ~ \
NOOP = @rem
.ELSE
MK2 = __not_needed
-RIGHTMAKE = __not_needed
+RIGHTMAKE =
.ENDIF
#
#--------------------- 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)
$(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
@$(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,\,\\))
@$(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
.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)
$(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)
-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 \
$(RCOPY) html\*.* $(INST_HTML)\*.*
inst_lib : $(CONFIGPM)
- copy splittree.pl ..
+ copy splittree.pl ..
$(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR)
$(RCOPY) ..\lib $(INST_LIB)\*.*
set HARNESS_PERL_SWITCHES=-C && \
cd ..\t && $(PERLEXE) -I..\lib harness
-clean :
+clean :
-@erase miniperlmain$(o)
-@erase $(MINIPERL)
-@erase perlglob$(o)
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
class CPerlHost
{
public:
+ /* Constructors */
CPerlHost(void);
CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
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))
#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;
}
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);
}
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);
}
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;
}
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)
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;
* 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;
}
PerlStdIOSetBuf,
PerlStdIOSetVBuf,
PerlStdIOSetCnt,
- PerlStdIOSetPtrCnt,
+ PerlStdIOSetPtr,
PerlStdIOSetlinebuf,
PerlStdIOPrintf,
PerlStdIOVprintf,
{
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
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,
PerlProcSpawn,
PerlProcSpawnvp,
PerlProcASpawn,
+ PerlProcLastHost
};
CPerlHost::CPerlHost(void)
{
+ /* Construct a host from scratch */
+ InterlockedIncrement(&num_hosts);
m_pvDir = new VDir();
m_pVMem = new VMem();
m_pVMemShared = new VMem();
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();
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();
CPerlHost::~CPerlHost(void)
{
// Reset();
+ InterlockedDecrement(&num_hosts);
delete m_pvDir;
m_pVMemParse->Release();
m_pVMemShared->Release();
/*
* "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"
* 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)
/* 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 */
/* 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 */
/* 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 */
/* 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 */
}
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;
}
else {
if (status < 0) {
- dTHR;
if (ckWARN(WARN_EXEC))
Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
(exectype == EXECF_EXEC ? "exec" : "spawn"),
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)
{
{
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.");
}
}
-
DllExport int
win32_fprintf(FILE *fp, const char *format, ...)
{
}
return rc;
#else
- return fstat(fd,sbufptr);
+ return my_fstat(fd,sbufptr);
#endif
}
/*
* 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
}
/* 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 */
*/
DllExport int
-win32_pclose(FILE *pf)
+win32_pclose(PerlIO *pf)
{
#ifdef USE_RTL_POPEN
return _pclose(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);
return -1;
}
- win32_fclose(pf);
+#ifdef USE_PERLIO
+ PerlIO_close(pf);
+#else
+ fclose(pf);
+#endif
SvIVX(sv) = 0;
UNLOCK_FDPID_MUTEX;
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
{
dXSARGS;
char *cmd, *args;
+ void *env;
+ char *dir;
PROCESS_INFORMATION stProcInfo;
STARTUPINFO stStartInfo;
BOOL bSuccess = FALSE;
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 */
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) */
{
CloseHandle(stProcInfo.hThread);/* library source code does this. */
bSuccess = TRUE;
}
+ PerlEnv_free_childenv(env);
+ PerlEnv_free_childdir(dir);
XSRETURN_IV(bSuccess);
}
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
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);
#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 */
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);
#define WIN32IO_IS_STDIO
#define WIN32SCK_IS_STDSCK
#define WIN32_LEAN_AND_MEAN
+#define PERLIO_NOT_STDIO 0
#ifdef __GNUC__
#define Win32_Winsock
#endif
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)
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;
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)
{
#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
/* $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.
/* $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.
#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.
/* $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.
%{
/* $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.
print OUT <<'!NO!SUBS!';
use strict;
use vars qw/$statdone/;
+use File::Spec::Functions 'curdir';
my $startperl = "#! $perlpath -w";
#
while ($ARGV[0] =~ /^[^-!(]/) {
push(@roots, shift);
}
-@roots = ('.') unless @roots;
+@roots = (curdir()) unless @roots;
for (@roots) { $_ = "e($_) }
my $roots = join(', ', @roots);
sub quote {
my $string = shift;
+ $string =~ s/\\/\\\\/g;
$string =~ s/'/\\'/g;
"'$string'";
}
/* $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.
/* $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.
/* 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.
/* $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.
/* $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.
/* $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.
/* $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.
/* $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.
projects / p5sagit/p5-mst-13.2.git / commitdiff