From 0461d253df33e5f57be9816f42946f63a61854d1 Mon Sep 17 00:00:00 2001 From: markm Date: Sat, 16 Mar 2002 22:35:55 +0000 Subject: Punt to attic files not in 5.6.1 OR not needed by FreeBSD. --- contrib/perl5/MAINTAIN | 879 --- contrib/perl5/README.posix-bc | 131 - contrib/perl5/Todo-5.005 | 61 - contrib/perl5/XSlock.h | 38 - contrib/perl5/bytecode.h | 161 - contrib/perl5/byterun.c | 867 --- contrib/perl5/byterun.h | 184 - contrib/perl5/ebcdic.c | 41 - contrib/perl5/eg/cgi/dna.small.gif.uu | 63 - contrib/perl5/eg/cgi/wilogo.gif.uu | 13 - contrib/perl5/ext/B/byteperl.c | 110 - contrib/perl5/ext/DynaLoader/dl_cygwin32.xs | 153 - contrib/perl5/hints/cygwin32.sh | 50 - contrib/perl5/interp.sym | 211 - contrib/perl5/lib/CGI.pm | 6481 ---------------- contrib/perl5/lib/CGI/Apache.pm | 23 - contrib/perl5/lib/CGI/Carp.pm | 373 - contrib/perl5/lib/CGI/Cookie.pm | 418 - contrib/perl5/lib/CGI/Fast.pm | 174 - contrib/perl5/lib/CGI/Pretty.pm | 236 - contrib/perl5/lib/CGI/Push.pm | 307 - contrib/perl5/lib/CGI/Switch.pm | 24 - contrib/perl5/lib/Sys/Hostname.pm | 127 - contrib/perl5/lib/Sys/Syslog.pm | 276 - contrib/perl5/lib/unicode/Is/DCinital.pl | 59 - contrib/perl5/lib/unicode/Props.txt | 3640 --------- contrib/perl5/lib/unicode/UCD300.html | 345 - contrib/perl5/lib/unicode/Unicode.300 | 10617 -------------------------- contrib/perl5/lib/unicode/Unicode3.html | 1988 ----- contrib/perl5/myconfig | 43 - contrib/perl5/objpp.h | 1473 ---- contrib/perl5/perl_exp.SH | 132 - contrib/perl5/pod/Makefile | 364 - contrib/perl5/pod/Win32.pod | 284 - contrib/perl5/pod/buildtoc | 258 - contrib/perl5/t/lib/thread.t | 73 - contrib/perl5/t/op/nothread.t | 35 - contrib/perl5/t/pragma/warn-1global | 159 - contrib/perl5/t/pragma/warning.t | 113 - contrib/perl5/thread.sym | 1 - contrib/perl5/utils/perlbc.PL | 80 - 41 files changed, 31065 deletions(-) delete mode 100644 contrib/perl5/MAINTAIN delete mode 100644 contrib/perl5/README.posix-bc delete mode 100644 contrib/perl5/Todo-5.005 delete mode 100644 contrib/perl5/XSlock.h delete mode 100644 contrib/perl5/bytecode.h delete mode 100644 contrib/perl5/byterun.c delete mode 100644 contrib/perl5/byterun.h delete mode 100644 contrib/perl5/ebcdic.c delete mode 100644 contrib/perl5/eg/cgi/dna.small.gif.uu delete mode 100644 contrib/perl5/eg/cgi/wilogo.gif.uu delete mode 100644 contrib/perl5/ext/B/byteperl.c delete mode 100644 contrib/perl5/ext/DynaLoader/dl_cygwin32.xs delete mode 100644 contrib/perl5/hints/cygwin32.sh delete mode 100644 contrib/perl5/interp.sym delete mode 100644 contrib/perl5/lib/CGI.pm delete mode 100644 contrib/perl5/lib/CGI/Apache.pm delete mode 100644 contrib/perl5/lib/CGI/Carp.pm delete mode 100644 contrib/perl5/lib/CGI/Cookie.pm delete mode 100644 contrib/perl5/lib/CGI/Fast.pm delete mode 100644 contrib/perl5/lib/CGI/Pretty.pm delete mode 100644 contrib/perl5/lib/CGI/Push.pm delete mode 100644 contrib/perl5/lib/CGI/Switch.pm delete mode 100644 contrib/perl5/lib/Sys/Hostname.pm delete mode 100644 contrib/perl5/lib/Sys/Syslog.pm delete mode 100644 contrib/perl5/lib/unicode/Is/DCinital.pl delete mode 100644 contrib/perl5/lib/unicode/Props.txt delete mode 100644 contrib/perl5/lib/unicode/UCD300.html delete mode 100644 contrib/perl5/lib/unicode/Unicode.300 delete mode 100644 contrib/perl5/lib/unicode/Unicode3.html delete mode 100755 contrib/perl5/myconfig delete mode 100644 contrib/perl5/objpp.h delete mode 100755 contrib/perl5/perl_exp.SH delete mode 100644 contrib/perl5/pod/Makefile delete mode 100644 contrib/perl5/pod/Win32.pod delete mode 100644 contrib/perl5/pod/buildtoc delete mode 100755 contrib/perl5/t/lib/thread.t delete mode 100755 contrib/perl5/t/op/nothread.t delete mode 100644 contrib/perl5/t/pragma/warn-1global delete mode 100755 contrib/perl5/t/pragma/warning.t delete mode 100644 contrib/perl5/thread.sym delete mode 100644 contrib/perl5/utils/perlbc.PL diff --git a/contrib/perl5/MAINTAIN b/contrib/perl5/MAINTAIN deleted file mode 100644 index 37ef489..0000000 --- a/contrib/perl5/MAINTAIN +++ /dev/null @@ -1,879 +0,0 @@ -# In addition to actual maintainers this file also lists "interested parties". -# -# The maintainer aliases come from AUTHORS. They may be defined in -# a layered way: 'doc' expands to tchrist which expands to Tom Christiansen. -# -# A file that is in MANIFEST need not be here at all. -# In any case, if nobody else is listed as maintainer, -# PUMPKING (from AUTHORS) should be it. -# -# Filenames can contain * which means qr(.*) on the filenames found -# using File::Find (it's _not_ filename glob). -# -# Maintainership definitions are of course cumulative: if A maintains -# X/* and B maintains X/Y/Z, if X/Y/Z is changed, both A and B should -# be notified. -# -# The filename(glob) and the maintainer(s) are separated by one or more tabs. - -Artistic -Changes -Changes5.000 -Changes5.001 -Changes5.002 -Changes5.003 -Changes5.004 -Changes5.005 -Configure cfg -Copying -EXTERN.h -INSTALL -INTERN.h -MANIFEST -Makefile.SH -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.mpeix mpeix -README.os2 os2 -README.os390 mvs -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 -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 cygwinx -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 lynxos -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 mvs -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/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/Parser.pm bradapp -lib/Pod/PlainText.pm bradapp -lib/Pod/Select.pm bradapp -lib/Pod/Text.pm tchrist -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/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 stok -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/perldiag.pod -pod/perldsc.pod tchrist -pod/perlembed.pod doug,jon -pod/perlfaq* gnat -pod/perlform.pod -pod/perlfunc.pod -pod/perlguts.pod -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 -pod/perlobj.pod -pod/perlop.pod -pod/perlpod.pod lwall -pod/perlport.pod pudge -pod/perlre.pod regex -pod/perlref.pod -pod/perlreftut.pod mjd -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/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/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/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 -universal.c -unixish.h -utf* lwall -utils/Makefile -utils/c2ph.PL tchrist -utils/h2ph.PL kstar -utils/h2xs.PL -utils/perlbug.PL -utils/perlcc.PL -utils/perldoc.PL -utils/pl2pm.PL -utils/splain.PL doc -vmesa/* vmesa -vms/* vms -vos/* vos -warning.h lexwarn -warning.pl lexwarn -win32/* -writemain.SH -x2p/EXTERN.h -x2p/INTERN.h -x2p/Makefile.SH -x2p/a2p.c -x2p/a2p.h -x2p/a2p.pod -x2p/a2p.y -x2p/a2py.c -x2p/cflags.SH -x2p/find2perl.PL -x2p/hash.c -x2p/hash.h -x2p/proto.h -x2p/s2p.PL -x2p/str.c -x2p/str.h -x2p/util.c -x2p/util.h -x2p/walk.c diff --git a/contrib/perl5/README.posix-bc b/contrib/perl5/README.posix-bc deleted file mode 100644 index 34bcad7..0000000 --- a/contrib/perl5/README.posix-bc +++ /dev/null @@ -1,131 +0,0 @@ -This is a first ported perl for the POSIX subsystem in BS2000 VERSION -'V121', OSD V3.1, POSIX Shell V03.1A55. It may work on other -versions, but that's the one we've tested it on. - -You may need the following GNU programs in order to install perl: - -gzip: - -We used version 1.2.4, which could be installed out of the box with -one failure during 'make check'. - -bison: - -The yacc coming with BS2000 POSIX didn't work for us. So we had to -use bison. We had to make a few changes to perl in order to use the -pure (reentrant) parser of bison. We used version 1.25, but we had to -add a few changes due to EBCDIC. - - -UNPACKING: -========== - -To extract an ASCII tar archive on BS2000 POSIX you need an ASCII -filesystem (we used the mountpoint /usr/local/ascii for this). Now -you extract the archive in the ASCII filesystem without I/O-conversion: - -cd /usr/local/ascii -export IO_CONVERSION=NO -gunzip < /usr/local/src/perl.tar.gz | pax -r - -You may ignore the error message for the first element of the archive -(this doesn't look like a tar archive / skipping to next file...), -it's only the directory which will be made anyway. - -After extracting the archive you copy the whole directory tree to your -EBCDIC filesystem. This time you use I/O-conversion: - -cd /usr/local/src -IO_CONVERSION=YES -cp -r /usr/local/ascii/perl5.005_02 ./ - - -COMPILING: -========== - -There is a "hints" file for posix-bc that specifies the correct values -for most things. The major problem is (of course) the EBCDIC character -set. - -Configure did everything except the perl parser. - -Because of our problems with the native yacc we used GNU bison to -generate a pure (=reentrant) parser for perly.y. So our yacc is -really the following script: - ------8<-----/usr/local/bin/yacc-----8<----- -#! /usr/bin/sh - -# Bison as a reentrant yacc: - -# save parameters: -params="" -while [[ $# -gt 1 ]]; do - params="$params $1" - shift -done - -# add flag %pure_parser: - -tmpfile=/tmp/bison.$$.y -echo %pure_parser > $tmpfile -cat $1 >> $tmpfile - -# call bison: - -echo "/usr/local/bin/bison --yacc $params $1\t\t\t(Pure Parser)" -/usr/local/bin/bison --yacc $params $tmpfile - -# cleanup: - -rm -f $tmpfile ------8<----------8<----- - -We still use the normal yacc for a2p.y though!!! We made a softlink -called byacc to distinguish between the two versions: - -ln -s /usr/bin/yacc /usr/local/bin/byacc - -We build perl using both GNU make and the native make. - - -TESTING: -======== - -We still got a few errors during 'make test'. Most of them are the -result of using bison. Bison prints 'parser error' instead of 'syntax -error', so we may ignore them. One error in the test op/regexp (and -op/regexp_noamp) seems a bit critical, the result was an 'Out of -memory' (core dump with op/regexp_noamp). The following list shows -our errors, your results may differ: - -op/misc.............FAILED tests 45-46 -op/pack.............FAILED tests 58-60 -op/regexp...........FAILED tests 405-492 (core dump) -op/regexp_noamp.....FAILED tests 405-492 (core dump) -pragma/overload.....FAILED tests 152-153, 170-171 -pragma/subs.........FAILED tests 1-2 -pragma/warning......FAILED tests 121, 127, 130, 142 -lib/cgi-html........dubious, FAILED tests 1-17 (ALL) -lib/complex.........FAILED tests 264, 484 -lib/dumper..........FAILED tests MANY -Failed 7/190 test scripts, 96.32% okay. 234/6549 subtests failed, 96.43% okay. - - -INSTALLING: -=========== - -We have no nroff on BS2000 POSIX (yet), so we ignored any errors while -installing the documentation. - - -USING PERL: -=========== - -BS2000 POSIX doesn't support the shebang notation -('#!/usr/local/bin/perl'), so you have to use the following lines -instead: - -: # use perl - eval 'exec /usr/local/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; diff --git a/contrib/perl5/Todo-5.005 b/contrib/perl5/Todo-5.005 deleted file mode 100644 index 7f2dbc9..0000000 --- a/contrib/perl5/Todo-5.005 +++ /dev/null @@ -1,61 +0,0 @@ -Multi-threading - $AUTOLOAD. Hmm. - consistent semantics for exit/die in threads - SvREFCNT_dec(curstack) in threadstart() in Thread.xs - better support for externally created threads - Thread::Pool - spot-check globals like statcache and global GVs for thread-safety - -Compiler - auto-produce executable - typed lexicals should affect B::CC::load_pad - workarounds to help Win32 - END blocks need saving in compiled output - _AUTOLOAD prodding - fix comppadlist (names in comppad_name can have fake SvCUR - from where newASSIGNOP steals the field) - -Namespace cleanup - CPP-space: restrict what we export from headers - stop malloc()/free() pollution unless asked - header-space: move into CORE/perl/ - API-space: begin list of things that constitute public api - -MULTIPLICITY support - complete work on safe recursive interpreters, Cnew()> - revisit extra implicit arg that provides curthread/curinterp context - -Reliable Signals - alternate runops() for signal despatch - figure out how to die() in delayed sighandler - add tests for Thread::Signal - -Win32 stuff - get PERL_OBJECT building under gcc - get PERL_OBJECT building on non-win32 - automate generation of 'protected' prototypes for CPerlObj - rename new headers to be consistent with the rest - sort out the spawnvp() mess - work out DLL versioning - style-check - -Miscellaneous - rename and alter ISA.pm - magic_setisa should be made to update %FIELDS [???] - add new modules (Archive::Tar, Compress::Zlib, CPAN::FTP?) - fix pod2html to generate relative URLs - automate testing with large parts of CPAN - -Ongoing - keep filenames 8.3 friendly, where feasible - upgrade to newer versions of all independently maintained modules - comprehensive perldelta.pod - -Documentation - describe new age patterns - update perl{guts,call,embed,xs} with additions, changes to API - document Win32 choices - spot-check all new modules for completeness - better docs for pack()/unpack() - reorg tutorials vs. reference sections - diff --git a/contrib/perl5/XSlock.h b/contrib/perl5/XSlock.h deleted file mode 100644 index 0b2c829..0000000 --- a/contrib/perl5/XSlock.h +++ /dev/null @@ -1,38 +0,0 @@ -#ifndef __XSlock_h__ -#define __XSlock_h__ - -class XSLockManager -{ -public: - XSLockManager() { InitializeCriticalSection(&cs); }; - ~XSLockManager() { DeleteCriticalSection(&cs); }; - void Enter(void) { EnterCriticalSection(&cs); }; - void Leave(void) { LeaveCriticalSection(&cs); }; -protected: - CRITICAL_SECTION cs; -}; - -XSLockManager g_XSLock; -CPerlObj* pPerl; - -class XSLock -{ -public: - XSLock(CPerlObj *p) { - g_XSLock.Enter(); - ::pPerl = p; - }; - ~XSLock() { g_XSLock.Leave(); }; -}; - -/* PERL_CAPI does its own locking in xs_handler() */ -#if defined(PERL_OBJECT) && !defined(PERL_CAPI) -#undef dXSARGS -#define dXSARGS \ - XSLock localLock(pPerl); \ - dSP; dMARK; \ - I32 ax = mark - PL_stack_base + 1; \ - I32 items = sp - mark -#endif /* PERL_OBJECT && !PERL_CAPI */ - -#endif diff --git a/contrib/perl5/bytecode.h b/contrib/perl5/bytecode.h deleted file mode 100644 index 7f0ab13..0000000 --- a/contrib/perl5/bytecode.h +++ /dev/null @@ -1,161 +0,0 @@ -typedef char *pvcontents; -typedef char *strconst; -typedef U32 PV; -typedef char *op_tr_array; -typedef int comment_t; -typedef SV *svindex; -typedef OP *opindex; -typedef IV IV64; - -#ifdef INDIRECT_BGET_MACROS -#define BGET_FREAD(argp, len, nelem) \ - bs.fread((char*)(argp),(len),(nelem),bs.data) -#define BGET_FGETC() bs.fgetc(bs.data) -#else -#define BGET_FREAD(argp, len, nelem) PerlIO_read(fp, (argp), (len)*(nelem)) -#define BGET_FGETC() PerlIO_getc(fp) -#endif /* INDIRECT_BGET_MACROS */ - -#define BGET_U32(arg) \ - BGET_FREAD(&arg, sizeof(U32), 1); arg = PerlSock_ntohl((U32)arg) -#define BGET_I32(arg) \ - BGET_FREAD(&arg, sizeof(I32), 1); arg = (I32)PerlSock_ntohl((U32)arg) -#define BGET_U16(arg) \ - BGET_FREAD(&arg, sizeof(U16), 1); arg = PerlSock_ntohs((U16)arg) -#define BGET_U8(arg) arg = BGET_FGETC() - -#if INDIRECT_BGET_MACROS -#define BGET_PV(arg) STMT_START { \ - BGET_U32(arg); \ - if (arg) \ - bs.freadpv(arg, bs.data); \ - else { \ - PL_bytecode_pv.xpv_pv = 0; \ - PL_bytecode_pv.xpv_len = 0; \ - PL_bytecode_pv.xpv_cur = 0; \ - } \ - } STMT_END -#else -#define BGET_PV(arg) STMT_START { \ - BGET_U32(arg); \ - if (arg) { \ - New(666, PL_bytecode_pv.xpv_pv, arg, char); \ - PerlIO_read(fp, PL_bytecode_pv.xpv_pv, arg); \ - PL_bytecode_pv.xpv_len = arg; \ - PL_bytecode_pv.xpv_cur = arg - 1; \ - } else { \ - PL_bytecode_pv.xpv_pv = 0; \ - PL_bytecode_pv.xpv_len = 0; \ - PL_bytecode_pv.xpv_cur = 0; \ - } \ - } STMT_END -#endif /* INDIRECT_BGET_MACROS */ - -#define BGET_comment_t(arg) \ - do { arg = BGET_FGETC(); } while (arg != '\n' && arg != EOF) - -/* - * In the following, sizeof(IV)*4 is just a way of encoding 32 on 64-bit-IV - * machines such that 32-bit machine compilers don't whine about the shift - * count being too high even though the code is never reached there. - */ -#define BGET_IV64(arg) STMT_START { \ - U32 hi, lo; \ - BGET_U32(hi); \ - BGET_U32(lo); \ - if (sizeof(IV) == 8) \ - arg = ((IV)hi << (sizeof(IV)*4) | lo); \ - else if (((I32)hi == -1 && (I32)lo < 0) \ - || ((I32)hi == 0 && (I32)lo >= 0)) { \ - arg = (I32)lo; \ - } \ - else { \ - PL_bytecode_iv_overflows++; \ - arg = 0; \ - } \ - } STMT_END - -#define BGET_op_tr_array(arg) do { \ - unsigned short *ary; \ - int i; \ - New(666, ary, 256, unsigned short); \ - BGET_FREAD(ary, 256, 2); \ - for (i = 0; i < 256; i++) \ - ary[i] = PerlSock_ntohs(ary[i]); \ - arg = (char *) ary; \ - } while (0) - -#define BGET_pvcontents(arg) arg = PL_bytecode_pv.xpv_pv -#define BGET_strconst(arg) STMT_START { \ - for (arg = PL_tokenbuf; (*arg = BGET_FGETC()); arg++) /* nothing */; \ - arg = PL_tokenbuf; \ - } STMT_END - -#define BGET_double(arg) STMT_START { \ - char *str; \ - BGET_strconst(str); \ - arg = atof(str); \ - } STMT_END - -#define BGET_objindex(arg, type) STMT_START { \ - U32 ix; \ - BGET_U32(ix); \ - arg = (type)PL_bytecode_obj_list[ix]; \ - } STMT_END -#define BGET_svindex(arg) BGET_objindex(arg, svindex) -#define BGET_opindex(arg) BGET_objindex(arg, opindex) - -#define BSET_ldspecsv(sv, arg) sv = PL_specialsv_list[arg] - -#define BSET_sv_refcnt_add(svrefcnt, arg) svrefcnt += arg -#define BSET_gp_refcnt_add(gprefcnt, arg) gprefcnt += arg -#define BSET_gp_share(sv, arg) STMT_START { \ - gp_free((GV*)sv); \ - GvGP(sv) = GvGP(arg); \ - } STMT_END - -#define BSET_gv_fetchpv(sv, arg) sv = (SV*)gv_fetchpv(arg, TRUE, SVt_PV) -#define BSET_gv_stashpv(sv, arg) sv = (SV*)gv_stashpv(arg, TRUE) -#define BSET_sv_magic(sv, arg) sv_magic(sv, Nullsv, arg, 0, 0) -#define BSET_mg_pv(mg, arg) mg->mg_ptr = arg; mg->mg_len = PL_bytecode_pv.xpv_cur -#define BSET_sv_upgrade(sv, arg) (void)SvUPGRADE(sv, arg) -#define BSET_xpv(sv) do { \ - SvPV_set(sv, PL_bytecode_pv.xpv_pv); \ - SvCUR_set(sv, PL_bytecode_pv.xpv_cur); \ - SvLEN_set(sv, PL_bytecode_pv.xpv_len); \ - } while (0) -#define BSET_av_extend(sv, arg) av_extend((AV*)sv, arg) - -#define BSET_av_push(sv, arg) av_push((AV*)sv, arg) -#define BSET_hv_store(sv, arg) \ - hv_store((HV*)sv, PL_bytecode_pv.xpv_pv, PL_bytecode_pv.xpv_cur, arg, 0) -#define BSET_pv_free(pv) Safefree(pv.xpv_pv) -#define BSET_pregcomp(o, arg) \ - ((PMOP*)o)->op_pmregexp = arg ? \ - CALLREGCOMP(arg, arg + PL_bytecode_pv.xpv_cur, ((PMOP*)o)) : 0 -#define BSET_newsv(sv, arg) sv = NEWSV(666,0); SvUPGRADE(sv, arg) -#define BSET_newop(o, arg) o = (OP*)safemalloc(optype_size[arg]) -#define BSET_newopn(o, arg) STMT_START { \ - OP *oldop = o; \ - BSET_newop(o, arg); \ - oldop->op_next = o; \ - } STMT_END - -#define BSET_ret(foo) return - -/* - * Kludge special-case workaround for OP_MAPSTART - * which needs the ppaddr for OP_GREPSTART. Blech. - */ -#define BSET_op_type(o, arg) STMT_START { \ - o->op_type = arg; \ - if (arg == OP_MAPSTART) \ - arg = OP_GREPSTART; \ - o->op_ppaddr = ppaddr[arg]; \ - } STMT_END -#define BSET_op_ppaddr(o, arg) croak("op_ppaddr not yet implemented") -#define BSET_curpad(pad, arg) pad = AvARRAY(arg) - -#define BSET_OBJ_STORE(obj, ix) \ - (I32)ix > PL_bytecode_obj_list_fill ? \ - bset_obj_store(obj, (I32)ix) : (PL_bytecode_obj_list[ix] = obj) diff --git a/contrib/perl5/byterun.c b/contrib/perl5/byterun.c deleted file mode 100644 index 34beaf4..0000000 --- a/contrib/perl5/byterun.c +++ /dev/null @@ -1,867 +0,0 @@ -/* - * Copyright (c) 1996-1998 Malcolm Beattie - * - * 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 autogenerated from bytecode.pl. Changes made here will be lost. - */ - -#include "EXTERN.h" -#include "perl.h" - -void * -bset_obj_store(void *obj, I32 ix) -{ - if (ix > PL_bytecode_obj_list_fill) { - if (PL_bytecode_obj_list_fill == -1) - New(666, PL_bytecode_obj_list, ix + 1, void*); - else - Renew(PL_bytecode_obj_list, ix + 1, void*); - PL_bytecode_obj_list_fill = ix; - } - PL_bytecode_obj_list[ix] = obj; - return obj; -} - -#ifdef INDIRECT_BGET_MACROS -void byterun(struct bytestream bs) -#else -void byterun(PerlIO *fp) -#endif /* INDIRECT_BGET_MACROS */ -{ - dTHR; - int insn; - while ((insn = BGET_FGETC()) != EOF) { - switch (insn) { - case INSN_COMMENT: /* 35 */ - { - comment_t arg; - BGET_comment_t(arg); - arg = arg; - break; - } - case INSN_NOP: /* 10 */ - { - break; - } - case INSN_RET: /* 0 */ - { - BSET_ret(none); - break; - } - case INSN_LDSV: /* 1 */ - { - svindex arg; - BGET_svindex(arg); - PL_bytecode_sv = arg; - break; - } - case INSN_LDOP: /* 2 */ - { - opindex arg; - BGET_opindex(arg); - PL_op = arg; - break; - } - case INSN_STSV: /* 3 */ - { - U32 arg; - BGET_U32(arg); - BSET_OBJ_STORE(PL_bytecode_sv, arg); - break; - } - case INSN_STOP: /* 4 */ - { - U32 arg; - BGET_U32(arg); - BSET_OBJ_STORE(PL_op, arg); - break; - } - case INSN_LDSPECSV: /* 5 */ - { - U8 arg; - BGET_U8(arg); - BSET_ldspecsv(PL_bytecode_sv, arg); - break; - } - case INSN_NEWSV: /* 6 */ - { - U8 arg; - BGET_U8(arg); - BSET_newsv(PL_bytecode_sv, arg); - break; - } - case INSN_NEWOP: /* 7 */ - { - U8 arg; - BGET_U8(arg); - BSET_newop(PL_op, arg); - break; - } - case INSN_NEWOPN: /* 8 */ - { - U8 arg; - BGET_U8(arg); - BSET_newopn(PL_op, arg); - break; - } - case INSN_NEWPV: /* 9 */ - { - PV arg; - BGET_PV(arg); - break; - } - case INSN_PV_CUR: /* 11 */ - { - STRLEN arg; - BGET_U32(arg); - PL_bytecode_pv.xpv_cur = arg; - break; - } - case INSN_PV_FREE: /* 12 */ - { - BSET_pv_free(PL_bytecode_pv); - break; - } - case INSN_SV_UPGRADE: /* 13 */ - { - char arg; - BGET_U8(arg); - BSET_sv_upgrade(PL_bytecode_sv, arg); - break; - } - case INSN_SV_REFCNT: /* 14 */ - { - U32 arg; - BGET_U32(arg); - SvREFCNT(PL_bytecode_sv) = arg; - break; - } - case INSN_SV_REFCNT_ADD: /* 15 */ - { - I32 arg; - BGET_I32(arg); - BSET_sv_refcnt_add(SvREFCNT(PL_bytecode_sv), arg); - break; - } - case INSN_SV_FLAGS: /* 16 */ - { - U32 arg; - BGET_U32(arg); - SvFLAGS(PL_bytecode_sv) = arg; - break; - } - case INSN_XRV: /* 17 */ - { - svindex arg; - BGET_svindex(arg); - SvRV(PL_bytecode_sv) = arg; - break; - } - case INSN_XPV: /* 18 */ - { - BSET_xpv(PL_bytecode_sv); - break; - } - case INSN_XIV32: /* 19 */ - { - I32 arg; - BGET_I32(arg); - SvIVX(PL_bytecode_sv) = arg; - break; - } - case INSN_XIV64: /* 20 */ - { - IV64 arg; - BGET_IV64(arg); - SvIVX(PL_bytecode_sv) = arg; - break; - } - case INSN_XNV: /* 21 */ - { - double arg; - BGET_double(arg); - SvNVX(PL_bytecode_sv) = arg; - break; - } - case INSN_XLV_TARGOFF: /* 22 */ - { - STRLEN arg; - BGET_U32(arg); - LvTARGOFF(PL_bytecode_sv) = arg; - break; - } - case INSN_XLV_TARGLEN: /* 23 */ - { - STRLEN arg; - BGET_U32(arg); - LvTARGLEN(PL_bytecode_sv) = arg; - break; - } - case INSN_XLV_TARG: /* 24 */ - { - svindex arg; - BGET_svindex(arg); - LvTARG(PL_bytecode_sv) = arg; - break; - } - case INSN_XLV_TYPE: /* 25 */ - { - char arg; - BGET_U8(arg); - LvTYPE(PL_bytecode_sv) = arg; - break; - } - case INSN_XBM_USEFUL: /* 26 */ - { - I32 arg; - BGET_I32(arg); - BmUSEFUL(PL_bytecode_sv) = arg; - break; - } - case INSN_XBM_PREVIOUS: /* 27 */ - { - U16 arg; - BGET_U16(arg); - BmPREVIOUS(PL_bytecode_sv) = arg; - break; - } - case INSN_XBM_RARE: /* 28 */ - { - U8 arg; - BGET_U8(arg); - BmRARE(PL_bytecode_sv) = arg; - break; - } - case INSN_XFM_LINES: /* 29 */ - { - I32 arg; - BGET_I32(arg); - FmLINES(PL_bytecode_sv) = arg; - break; - } - case INSN_XIO_LINES: /* 30 */ - { - long arg; - BGET_I32(arg); - IoLINES(PL_bytecode_sv) = arg; - break; - } - case INSN_XIO_PAGE: /* 31 */ - { - long arg; - BGET_I32(arg); - IoPAGE(PL_bytecode_sv) = arg; - break; - } - case INSN_XIO_PAGE_LEN: /* 32 */ - { - long arg; - BGET_I32(arg); - IoPAGE_LEN(PL_bytecode_sv) = arg; - break; - } - case INSN_XIO_LINES_LEFT: /* 33 */ - { - long arg; - BGET_I32(arg); - IoLINES_LEFT(PL_bytecode_sv) = arg; - break; - } - case INSN_XIO_TOP_NAME: /* 34 */ - { - pvcontents arg; - BGET_pvcontents(arg); - IoTOP_NAME(PL_bytecode_sv) = arg; - break; - } - case INSN_XIO_TOP_GV: /* 36 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&IoTOP_GV(PL_bytecode_sv) = arg; - break; - } - case INSN_XIO_FMT_NAME: /* 37 */ - { - pvcontents arg; - BGET_pvcontents(arg); - IoFMT_NAME(PL_bytecode_sv) = arg; - break; - } - case INSN_XIO_FMT_GV: /* 38 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&IoFMT_GV(PL_bytecode_sv) = arg; - break; - } - case INSN_XIO_BOTTOM_NAME: /* 39 */ - { - pvcontents arg; - BGET_pvcontents(arg); - IoBOTTOM_NAME(PL_bytecode_sv) = arg; - break; - } - case INSN_XIO_BOTTOM_GV: /* 40 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&IoBOTTOM_GV(PL_bytecode_sv) = arg; - break; - } - case INSN_XIO_SUBPROCESS: /* 41 */ - { - short arg; - BGET_U16(arg); - IoSUBPROCESS(PL_bytecode_sv) = arg; - break; - } - case INSN_XIO_TYPE: /* 42 */ - { - char arg; - BGET_U8(arg); - IoTYPE(PL_bytecode_sv) = arg; - break; - } - case INSN_XIO_FLAGS: /* 43 */ - { - char arg; - BGET_U8(arg); - IoFLAGS(PL_bytecode_sv) = arg; - break; - } - case INSN_XCV_STASH: /* 44 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&CvSTASH(PL_bytecode_sv) = arg; - break; - } - case INSN_XCV_START: /* 45 */ - { - opindex arg; - BGET_opindex(arg); - CvSTART(PL_bytecode_sv) = arg; - break; - } - case INSN_XCV_ROOT: /* 46 */ - { - opindex arg; - BGET_opindex(arg); - CvROOT(PL_bytecode_sv) = arg; - break; - } - case INSN_XCV_GV: /* 47 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&CvGV(PL_bytecode_sv) = arg; - break; - } - case INSN_XCV_FILEGV: /* 48 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&CvFILEGV(PL_bytecode_sv) = arg; - break; - } - case INSN_XCV_DEPTH: /* 49 */ - { - long arg; - BGET_I32(arg); - CvDEPTH(PL_bytecode_sv) = arg; - break; - } - case INSN_XCV_PADLIST: /* 50 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&CvPADLIST(PL_bytecode_sv) = arg; - break; - } - case INSN_XCV_OUTSIDE: /* 51 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&CvOUTSIDE(PL_bytecode_sv) = arg; - break; - } - case INSN_XCV_FLAGS: /* 52 */ - { - U8 arg; - BGET_U8(arg); - CvFLAGS(PL_bytecode_sv) = arg; - break; - } - case INSN_AV_EXTEND: /* 53 */ - { - SSize_t arg; - BGET_I32(arg); - BSET_av_extend(PL_bytecode_sv, arg); - break; - } - case INSN_AV_PUSH: /* 54 */ - { - svindex arg; - BGET_svindex(arg); - BSET_av_push(PL_bytecode_sv, arg); - break; - } - case INSN_XAV_FILL: /* 55 */ - { - SSize_t arg; - BGET_I32(arg); - AvFILLp(PL_bytecode_sv) = arg; - break; - } - case INSN_XAV_MAX: /* 56 */ - { - SSize_t arg; - BGET_I32(arg); - AvMAX(PL_bytecode_sv) = arg; - break; - } - case INSN_XAV_FLAGS: /* 57 */ - { - U8 arg; - BGET_U8(arg); - AvFLAGS(PL_bytecode_sv) = arg; - break; - } - case INSN_XHV_RITER: /* 58 */ - { - I32 arg; - BGET_I32(arg); - HvRITER(PL_bytecode_sv) = arg; - break; - } - case INSN_XHV_NAME: /* 59 */ - { - pvcontents arg; - BGET_pvcontents(arg); - HvNAME(PL_bytecode_sv) = arg; - break; - } - case INSN_HV_STORE: /* 60 */ - { - svindex arg; - BGET_svindex(arg); - BSET_hv_store(PL_bytecode_sv, arg); - break; - } - case INSN_SV_MAGIC: /* 61 */ - { - char arg; - BGET_U8(arg); - BSET_sv_magic(PL_bytecode_sv, arg); - break; - } - case INSN_MG_OBJ: /* 62 */ - { - svindex arg; - BGET_svindex(arg); - SvMAGIC(PL_bytecode_sv)->mg_obj = arg; - break; - } - case INSN_MG_PRIVATE: /* 63 */ - { - U16 arg; - BGET_U16(arg); - SvMAGIC(PL_bytecode_sv)->mg_private = arg; - break; - } - case INSN_MG_FLAGS: /* 64 */ - { - U8 arg; - BGET_U8(arg); - SvMAGIC(PL_bytecode_sv)->mg_flags = arg; - break; - } - case INSN_MG_PV: /* 65 */ - { - pvcontents arg; - BGET_pvcontents(arg); - BSET_mg_pv(SvMAGIC(PL_bytecode_sv), arg); - break; - } - case INSN_XMG_STASH: /* 66 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&SvSTASH(PL_bytecode_sv) = arg; - break; - } - case INSN_GV_FETCHPV: /* 67 */ - { - strconst arg; - BGET_strconst(arg); - BSET_gv_fetchpv(PL_bytecode_sv, arg); - break; - } - case INSN_GV_STASHPV: /* 68 */ - { - strconst arg; - BGET_strconst(arg); - BSET_gv_stashpv(PL_bytecode_sv, arg); - break; - } - case INSN_GP_SV: /* 69 */ - { - svindex arg; - BGET_svindex(arg); - GvSV(PL_bytecode_sv) = arg; - break; - } - case INSN_GP_REFCNT: /* 70 */ - { - U32 arg; - BGET_U32(arg); - GvREFCNT(PL_bytecode_sv) = arg; - break; - } - case INSN_GP_REFCNT_ADD: /* 71 */ - { - I32 arg; - BGET_I32(arg); - BSET_gp_refcnt_add(GvREFCNT(PL_bytecode_sv), arg); - break; - } - case INSN_GP_AV: /* 72 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&GvAV(PL_bytecode_sv) = arg; - break; - } - case INSN_GP_HV: /* 73 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&GvHV(PL_bytecode_sv) = arg; - break; - } - case INSN_GP_CV: /* 74 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&GvCV(PL_bytecode_sv) = arg; - break; - } - case INSN_GP_FILEGV: /* 75 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&GvFILEGV(PL_bytecode_sv) = arg; - break; - } - case INSN_GP_IO: /* 76 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&GvIOp(PL_bytecode_sv) = arg; - break; - } - case INSN_GP_FORM: /* 77 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&GvFORM(PL_bytecode_sv) = arg; - break; - } - case INSN_GP_CVGEN: /* 78 */ - { - U32 arg; - BGET_U32(arg); - GvCVGEN(PL_bytecode_sv) = arg; - break; - } - case INSN_GP_LINE: /* 79 */ - { - line_t arg; - BGET_U16(arg); - GvLINE(PL_bytecode_sv) = arg; - break; - } - case INSN_GP_SHARE: /* 80 */ - { - svindex arg; - BGET_svindex(arg); - BSET_gp_share(PL_bytecode_sv, arg); - break; - } - case INSN_XGV_FLAGS: /* 81 */ - { - U8 arg; - BGET_U8(arg); - GvFLAGS(PL_bytecode_sv) = arg; - break; - } - case INSN_OP_NEXT: /* 82 */ - { - opindex arg; - BGET_opindex(arg); - PL_op->op_next = arg; - break; - } - case INSN_OP_SIBLING: /* 83 */ - { - opindex arg; - BGET_opindex(arg); - PL_op->op_sibling = arg; - break; - } - case INSN_OP_PPADDR: /* 84 */ - { - strconst arg; - BGET_strconst(arg); - BSET_op_ppaddr(PL_op->op_ppaddr, arg); - break; - } - case INSN_OP_TARG: /* 85 */ - { - PADOFFSET arg; - BGET_U32(arg); - PL_op->op_targ = arg; - break; - } - case INSN_OP_TYPE: /* 86 */ - { - OPCODE arg; - BGET_U16(arg); - BSET_op_type(PL_op, arg); - break; - } - case INSN_OP_SEQ: /* 87 */ - { - U16 arg; - BGET_U16(arg); - PL_op->op_seq = arg; - break; - } - case INSN_OP_FLAGS: /* 88 */ - { - U8 arg; - BGET_U8(arg); - PL_op->op_flags = arg; - break; - } - case INSN_OP_PRIVATE: /* 89 */ - { - U8 arg; - BGET_U8(arg); - PL_op->op_private = arg; - break; - } - case INSN_OP_FIRST: /* 90 */ - { - opindex arg; - BGET_opindex(arg); - cUNOP->op_first = arg; - break; - } - case INSN_OP_LAST: /* 91 */ - { - opindex arg; - BGET_opindex(arg); - cBINOP->op_last = arg; - break; - } - case INSN_OP_OTHER: /* 92 */ - { - opindex arg; - BGET_opindex(arg); - cLOGOP->op_other = arg; - break; - } - case INSN_OP_TRUE: /* 93 */ - { - opindex arg; - BGET_opindex(arg); - cCONDOP->op_true = arg; - break; - } - case INSN_OP_FALSE: /* 94 */ - { - opindex arg; - BGET_opindex(arg); - cCONDOP->op_false = arg; - break; - } - case INSN_OP_CHILDREN: /* 95 */ - { - U32 arg; - BGET_U32(arg); - cLISTOP->op_children = arg; - break; - } - case INSN_OP_PMREPLROOT: /* 96 */ - { - opindex arg; - BGET_opindex(arg); - cPMOP->op_pmreplroot = arg; - break; - } - case INSN_OP_PMREPLROOTGV: /* 97 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&cPMOP->op_pmreplroot = arg; - break; - } - case INSN_OP_PMREPLSTART: /* 98 */ - { - opindex arg; - BGET_opindex(arg); - cPMOP->op_pmreplstart = arg; - break; - } - case INSN_OP_PMNEXT: /* 99 */ - { - opindex arg; - BGET_opindex(arg); - *(OP**)&cPMOP->op_pmnext = arg; - break; - } - case INSN_PREGCOMP: /* 100 */ - { - pvcontents arg; - BGET_pvcontents(arg); - BSET_pregcomp(PL_op, arg); - break; - } - case INSN_OP_PMFLAGS: /* 101 */ - { - U16 arg; - BGET_U16(arg); - cPMOP->op_pmflags = arg; - break; - } - case INSN_OP_PMPERMFLAGS: /* 102 */ - { - U16 arg; - BGET_U16(arg); - cPMOP->op_pmpermflags = arg; - break; - } - case INSN_OP_SV: /* 103 */ - { - svindex arg; - BGET_svindex(arg); - cSVOP->op_sv = arg; - break; - } - case INSN_OP_GV: /* 104 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&cGVOP->op_gv = arg; - break; - } - case INSN_OP_PV: /* 105 */ - { - pvcontents arg; - BGET_pvcontents(arg); - cPVOP->op_pv = arg; - break; - } - case INSN_OP_PV_TR: /* 106 */ - { - op_tr_array arg; - BGET_op_tr_array(arg); - cPVOP->op_pv = arg; - break; - } - case INSN_OP_REDOOP: /* 107 */ - { - opindex arg; - BGET_opindex(arg); - cLOOP->op_redoop = arg; - break; - } - case INSN_OP_NEXTOP: /* 108 */ - { - opindex arg; - BGET_opindex(arg); - cLOOP->op_nextop = arg; - break; - } - case INSN_OP_LASTOP: /* 109 */ - { - opindex arg; - BGET_opindex(arg); - cLOOP->op_lastop = arg; - break; - } - case INSN_COP_LABEL: /* 110 */ - { - pvcontents arg; - BGET_pvcontents(arg); - cCOP->cop_label = arg; - break; - } - case INSN_COP_STASH: /* 111 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&cCOP->cop_stash = arg; - break; - } - case INSN_COP_FILEGV: /* 112 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&cCOP->cop_filegv = arg; - break; - } - case INSN_COP_SEQ: /* 113 */ - { - U32 arg; - BGET_U32(arg); - cCOP->cop_seq = arg; - break; - } - case INSN_COP_ARYBASE: /* 114 */ - { - I32 arg; - BGET_I32(arg); - cCOP->cop_arybase = arg; - break; - } - case INSN_COP_LINE: /* 115 */ - { - line_t arg; - BGET_U16(arg); - cCOP->cop_line = arg; - break; - } - case INSN_MAIN_START: /* 116 */ - { - opindex arg; - BGET_opindex(arg); - PL_main_start = arg; - break; - } - case INSN_MAIN_ROOT: /* 117 */ - { - opindex arg; - BGET_opindex(arg); - PL_main_root = arg; - break; - } - case INSN_CURPAD: /* 118 */ - { - svindex arg; - BGET_svindex(arg); - BSET_curpad(PL_curpad, arg); - break; - } - default: - croak("Illegal bytecode instruction %d\n", insn); - /* NOTREACHED */ - } - } -} diff --git a/contrib/perl5/byterun.h b/contrib/perl5/byterun.h deleted file mode 100644 index bd54c76..0000000 --- a/contrib/perl5/byterun.h +++ /dev/null @@ -1,184 +0,0 @@ -/* - * Copyright (c) 1996-1998 Malcolm Beattie - * - * 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 autogenerated from bytecode.pl. Changes made here will be lost. - */ -#ifdef INDIRECT_BGET_MACROS -struct bytestream { - void *data; - int (*fgetc)(void *); - int (*fread)(char *, size_t, size_t, void*); - void (*freadpv)(U32, void*); -}; -#endif /* INDIRECT_BGET_MACROS */ - -void *bset_obj_store _((void *, I32)); - -enum { - INSN_RET, /* 0 */ - INSN_LDSV, /* 1 */ - INSN_LDOP, /* 2 */ - INSN_STSV, /* 3 */ - INSN_STOP, /* 4 */ - INSN_LDSPECSV, /* 5 */ - INSN_NEWSV, /* 6 */ - INSN_NEWOP, /* 7 */ - INSN_NEWOPN, /* 8 */ - INSN_NEWPV, /* 9 */ - INSN_NOP, /* 10 */ - INSN_PV_CUR, /* 11 */ - INSN_PV_FREE, /* 12 */ - INSN_SV_UPGRADE, /* 13 */ - INSN_SV_REFCNT, /* 14 */ - INSN_SV_REFCNT_ADD, /* 15 */ - INSN_SV_FLAGS, /* 16 */ - INSN_XRV, /* 17 */ - INSN_XPV, /* 18 */ - INSN_XIV32, /* 19 */ - INSN_XIV64, /* 20 */ - INSN_XNV, /* 21 */ - INSN_XLV_TARGOFF, /* 22 */ - INSN_XLV_TARGLEN, /* 23 */ - INSN_XLV_TARG, /* 24 */ - INSN_XLV_TYPE, /* 25 */ - INSN_XBM_USEFUL, /* 26 */ - INSN_XBM_PREVIOUS, /* 27 */ - INSN_XBM_RARE, /* 28 */ - INSN_XFM_LINES, /* 29 */ - INSN_XIO_LINES, /* 30 */ - INSN_XIO_PAGE, /* 31 */ - INSN_XIO_PAGE_LEN, /* 32 */ - INSN_XIO_LINES_LEFT, /* 33 */ - INSN_XIO_TOP_NAME, /* 34 */ - INSN_COMMENT, /* 35 */ - INSN_XIO_TOP_GV, /* 36 */ - INSN_XIO_FMT_NAME, /* 37 */ - INSN_XIO_FMT_GV, /* 38 */ - INSN_XIO_BOTTOM_NAME, /* 39 */ - INSN_XIO_BOTTOM_GV, /* 40 */ - INSN_XIO_SUBPROCESS, /* 41 */ - INSN_XIO_TYPE, /* 42 */ - INSN_XIO_FLAGS, /* 43 */ - INSN_XCV_STASH, /* 44 */ - INSN_XCV_START, /* 45 */ - INSN_XCV_ROOT, /* 46 */ - INSN_XCV_GV, /* 47 */ - INSN_XCV_FILEGV, /* 48 */ - INSN_XCV_DEPTH, /* 49 */ - INSN_XCV_PADLIST, /* 50 */ - INSN_XCV_OUTSIDE, /* 51 */ - INSN_XCV_FLAGS, /* 52 */ - INSN_AV_EXTEND, /* 53 */ - INSN_AV_PUSH, /* 54 */ - INSN_XAV_FILL, /* 55 */ - INSN_XAV_MAX, /* 56 */ - INSN_XAV_FLAGS, /* 57 */ - INSN_XHV_RITER, /* 58 */ - INSN_XHV_NAME, /* 59 */ - INSN_HV_STORE, /* 60 */ - INSN_SV_MAGIC, /* 61 */ - INSN_MG_OBJ, /* 62 */ - INSN_MG_PRIVATE, /* 63 */ - INSN_MG_FLAGS, /* 64 */ - INSN_MG_PV, /* 65 */ - INSN_XMG_STASH, /* 66 */ - INSN_GV_FETCHPV, /* 67 */ - INSN_GV_STASHPV, /* 68 */ - INSN_GP_SV, /* 69 */ - INSN_GP_REFCNT, /* 70 */ - INSN_GP_REFCNT_ADD, /* 71 */ - INSN_GP_AV, /* 72 */ - INSN_GP_HV, /* 73 */ - INSN_GP_CV, /* 74 */ - INSN_GP_FILEGV, /* 75 */ - INSN_GP_IO, /* 76 */ - INSN_GP_FORM, /* 77 */ - INSN_GP_CVGEN, /* 78 */ - INSN_GP_LINE, /* 79 */ - INSN_GP_SHARE, /* 80 */ - INSN_XGV_FLAGS, /* 81 */ - INSN_OP_NEXT, /* 82 */ - INSN_OP_SIBLING, /* 83 */ - INSN_OP_PPADDR, /* 84 */ - INSN_OP_TARG, /* 85 */ - INSN_OP_TYPE, /* 86 */ - INSN_OP_SEQ, /* 87 */ - INSN_OP_FLAGS, /* 88 */ - INSN_OP_PRIVATE, /* 89 */ - INSN_OP_FIRST, /* 90 */ - INSN_OP_LAST, /* 91 */ - INSN_OP_OTHER, /* 92 */ - INSN_OP_TRUE, /* 93 */ - INSN_OP_FALSE, /* 94 */ - INSN_OP_CHILDREN, /* 95 */ - INSN_OP_PMREPLROOT, /* 96 */ - INSN_OP_PMREPLROOTGV, /* 97 */ - INSN_OP_PMREPLSTART, /* 98 */ - INSN_OP_PMNEXT, /* 99 */ - INSN_PREGCOMP, /* 100 */ - INSN_OP_PMFLAGS, /* 101 */ - INSN_OP_PMPERMFLAGS, /* 102 */ - INSN_OP_SV, /* 103 */ - INSN_OP_GV, /* 104 */ - INSN_OP_PV, /* 105 */ - INSN_OP_PV_TR, /* 106 */ - INSN_OP_REDOOP, /* 107 */ - INSN_OP_NEXTOP, /* 108 */ - INSN_OP_LASTOP, /* 109 */ - INSN_COP_LABEL, /* 110 */ - INSN_COP_STASH, /* 111 */ - INSN_COP_FILEGV, /* 112 */ - INSN_COP_SEQ, /* 113 */ - INSN_COP_ARYBASE, /* 114 */ - INSN_COP_LINE, /* 115 */ - INSN_MAIN_START, /* 116 */ - INSN_MAIN_ROOT, /* 117 */ - INSN_CURPAD, /* 118 */ - MAX_INSN = 118 -}; - -enum { - OPt_OP, /* 0 */ - OPt_UNOP, /* 1 */ - OPt_BINOP, /* 2 */ - OPt_LOGOP, /* 3 */ - OPt_CONDOP, /* 4 */ - OPt_LISTOP, /* 5 */ - OPt_PMOP, /* 6 */ - OPt_SVOP, /* 7 */ - OPt_GVOP, /* 8 */ - OPt_PVOP, /* 9 */ - OPt_LOOP, /* 10 */ - OPt_COP /* 11 */ -}; - -EXT int optype_size[] -#ifdef DOINIT -= { - sizeof(OP), - sizeof(UNOP), - sizeof(BINOP), - sizeof(LOGOP), - sizeof(CONDOP), - sizeof(LISTOP), - sizeof(PMOP), - sizeof(SVOP), - sizeof(GVOP), - sizeof(PVOP), - sizeof(LOOP), - sizeof(COP) -} -#endif /* DOINIT */ -; - -#define INIT_SPECIALSV_LIST STMT_START { \ - PL_specialsv_list[0] = Nullsv; \ - PL_specialsv_list[1] = &PL_sv_undef; \ - PL_specialsv_list[2] = &PL_sv_yes; \ - PL_specialsv_list[3] = &PL_sv_no; \ - } STMT_END diff --git a/contrib/perl5/ebcdic.c b/contrib/perl5/ebcdic.c deleted file mode 100644 index d86d50b..0000000 --- a/contrib/perl5/ebcdic.c +++ /dev/null @@ -1,41 +0,0 @@ -#include "EXTERN.h" -#define PERL_IN_EBCDIC_C -#include "perl.h" - -/* in ASCII order, not that it matters */ -static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"; - -int -ebcdic_control(int ch) -{ - if (ch > 'a') { - char *ctlp; - - if (islower(ch)) - ch = toupper(ch); - - if ((ctlp = strchr(controllablechars, ch)) == 0) { - Perl_die(aTHX_ "unrecognised control character '%c'\n", ch); - } - - if (ctlp == controllablechars) - return('\177'); /* DEL */ - else - return((unsigned char)(ctlp - controllablechars - 1)); - } else { /* Want uncontrol */ - if (ch == '\177' || ch == -1) - return('?'); - else if (ch == '\157') - return('\177'); - else if (ch == '\174') - return('\000'); - else if (ch == '^') /* '\137' in 1047, '\260' in 819 */ - return('\036'); - else if (ch == '\155') - return('\037'); - else if (0 < ch && ch < (sizeof(controllablechars) - 1)) - return(controllablechars[ch+1]); - else - Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF); - } -} diff --git a/contrib/perl5/eg/cgi/dna.small.gif.uu b/contrib/perl5/eg/cgi/dna.small.gif.uu deleted file mode 100644 index d3ce24c..0000000 --- a/contrib/perl5/eg/cgi/dna.small.gif.uu +++ /dev/null @@ -1,63 +0,0 @@ -begin 444 dna.small.gif -M1TE&.#=A)0`J`.<``+9%&Y@_&A$_5`Y#3$=2"=#59M((H88,GP\/]X^&+$R -M$"(79"DF33(93"$86=%;&"T4/=Y"&\\A$Q4Z4!`62*T4-Q4B9+X1*BH96SP? -M1<0D/3(F<-TM$!`=5:H.(!<64C$W?#8J3*`S(S<@3=8V%K$](QT.6Q`43AL4 -M1:$D,;<0,\X9&,8])\@=$A(U244S5U,D6Q=/#YH> -M08$I1B,09S$35R(:4C0?<19$75!()-;4702M`=;56)A`25,0K%"X< -M83`N>K`H'HDS*1`40,M&%!<@7M,_$AE+#%0>0S0/:4PJ9I,F-6DG420Y<"@09R,0 -M-V$R/R4M<:\H0!(H410Z:AT27&4Q9"L@;=1%(MA-$M5+#RL4+M8Z&AT<7[<: -M(-QA&2,36R$++B(84!0:5ALO:K$A.]X?&!$84V@;/SX<6Q`;2$(B2QD21W4J -M1=TW&@```````````````"P`````)0`J```(_@!]:(N'18\W%15T$1N'C)V? -M0_HH,<$G9YBX!C6<3;+T@AZ-)K@\O*"!KP^$>"KVA`L3*8P3)^5ZA)@B:AH+ -M9];F7.$Q+!`!0=*.%",&P7J"9XB82L5,48F5K,:" -M'94FU='6;!*R3T->E"%&95DR"`/6P,I0PDF)0SG8($$RJN0R`FI(H7$A2]VD -M*^^L_6(T3U*V%XH"_AB:HDS8H$AO5@R:P,8.I%^.:*AC(>Z!'":6RC`1L@W- -M%1Q/,%(.'5+1``/"*]=90`PD.F'3SR@-AG)`&_A=3'"**#[J(P<0^C0&S/#1""(ZI)'&*6,,$842N%Q!@3NK -M"R'%%4KP0D(Q?"`S!3)BVE(/$+)#-80 -M<+,`-[QH$LP+0_P!1C>=S("!,N>8XP<8H6131!B;3`#&#)"DTH(L5#P0S#W+ -MQ)*`$K1HHD4^;E!2QP%:B``&4H$,/Y2C$Y*(1%0(00A)@```77B"*$0@#3>P -MP&PU4`,^H!","P!!$')0P^H6((I5L"$'.;``';[Q!@-\PP"$0?)M$`<92!%OG8Q3#@(`U2C*)%9-!`&`K`!!EP0@80 -M2,0M;I$.:"C#"D.@P#UJ``]GT"*,K%B&*0+!@TFH8VV*0$(:_/`)?7@#'.'0 -M@R[H8``\:&`,=NC"*"B@!2TTHP5]N((TEH&`<)B"!PU`0RQ(P8MNS``9K6@% -M'W31AG%$(BZ2&((PA-&#'I"A&`F8!DD\\`H6-,.,X'B'%,+R#FX4`PS&_L!$ -M.4R0#7W<0@%O2,07$($#9@C3"%C8P!5H88\]J$,"-E!;(.X@C5T<`!65V,40 -M,'&(0C!"`1JP@"3TH`T9=&,5JRC$-]+1`U%TP@@[^,$>Z$&*0%1A%XFK`BFD -MX0L6Y"(#A_A$#[JPC@%\@1@02`(SJ#&&.`A@'\&$!AALX(4Y="`/TA"",UA! -M@%W<8!*\$`$@C%""+G1A"9AP!"<>9@ME*)$0F\C!$I8`B3\TP@%'@$(QH$`" -M)8@#'(B0ACB`P`,@%&,'9"##)S`1!&)\`0)^&,,^+$`("QC"#D\X!":HX0!< -ML(`&-O!%,&H@BS#F0AI'`!LO^"`,/OS!%KJ0_H0HEA`E27Q#%T%X0"%"@`1E -M2,`!:F!%+Q#A!G)40A!HP`4OFK`#-13#`?I(QCW38(Q/9&``%0#!);01BE>$ -M@!TZNL81$G`!-]2!&&5@A1N&T0Q<,$$$%*!``BR1A5$PPPH<74$%]*`#$.RA -M`(VP@#`X$(`7``(%T=@`.5Q`C@:0`P[)D$4'$H`."MB#"908Q=X@,01B9$(7 -MG'A%`#8!"QSL@PUAL,0==M"")CQCP4)0QQUDP806H&,!T]A!`EH@AC2P`P,^ -MT`,*NN%-&&T!&L@X!!Y^<(4.D(,%E>A`,T20C#IXL`6-:,`5F+"#!W"@'%OH -MA`IJ$5(#;`(;AV/'FA103(EV+(,>GHB&&ZJ`!D'P!57`X1F9D`4<0!]FB(F*(A55\BX%UEI^;OJ8N%(*Z^4G -M.OJJ>8HZ.(>;JRMD>X" -M%A1XSM]!A?T8/C0T$1XMJG\B&G+,"-&C/(VS0(842;`)M'S>_OE8F#"=2S#* -M8LHLAS'D1Y,42UGY9O,F-T:X@@JEE@D1RW>/D@8R.DZ-+*E0CQ:9JJ5JU!SQ -MR&BU2D.;E*4'ER0TNY%G2A/Y.G[=VG%81+5K_UG$21-GQW55;$8L\RW6J8-9>QM7<^A/SMZK!ESY$,+ -(KPA.EJ```#L` -end diff --git a/contrib/perl5/ext/B/byteperl.c b/contrib/perl5/ext/B/byteperl.c deleted file mode 100644 index 6b53e3b..0000000 --- a/contrib/perl5/ext/B/byteperl.c +++ /dev/null @@ -1,110 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#ifndef PATCHLEVEL -#include "patchlevel.h" -#endif - -static void xs_init _((void)); -static PerlInterpreter *my_perl; - -int -#ifndef CAN_PROTOTYPE -main(argc, argv, env) -int argc; -char **argv; -char **env; -#else /* def(CAN_PROTOTYPE) */ -main(int argc, char **argv, char **env) -#endif /* def(CAN_PROTOTYPE) */ -{ - int exitstatus; - int i; - char **fakeargv; - FILE *fp; -#ifdef INDIRECT_BGET_MACROS - struct bytestream bs; -#endif /* INDIRECT_BGET_MACROS */ - - INIT_SPECIALSV_LIST; - PERL_SYS_INIT(&argc,&argv); - -#if PATCHLEVEL > 3 || (PATCHLEVEL == 3 && SUBVERSION >= 1) - perl_init_i18nl10n(1); -#else - perl_init_i18nl14n(1); -#endif - - if (!PL_do_undump) { - my_perl = perl_alloc(); - if (!my_perl) -#ifdef VMS - exit(vaxc$errno); -#else - exit(1); -#endif - perl_construct( my_perl ); - } - -#ifdef CSH - if (!PL_cshlen) - PL_cshlen = strlen(PL_cshname); -#endif - - if (argc < 2) - fp = stdin; - else { -#ifdef WIN32 - fp = fopen(argv[1], "rb"); -#else - fp = fopen(argv[1], "r"); -#endif - if (!fp) { - perror(argv[1]); -#ifdef VMS - exit(vaxc$errno); -#else - exit(1); -#endif - } - argv++; - argc--; - } - New(666, fakeargv, argc + 4, char *); - fakeargv[0] = argv[0]; - fakeargv[1] = "-e"; - fakeargv[2] = ""; - fakeargv[3] = "--"; - for (i = 1; i < argc; i++) - fakeargv[i + 3] = argv[i]; - fakeargv[argc + 3] = 0; - - exitstatus = perl_parse(my_perl, xs_init, argc + 3, fakeargv, NULL); - if (exitstatus) - exit( exitstatus ); - - sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]); - PL_main_cv = PL_compcv; - PL_compcv = 0; - -#ifdef INDIRECT_BGET_MACROS - bs.data = fp; - bs.fgetc = (int(*) _((void*)))fgetc; - bs.fread = (int(*) _((char*,size_t,size_t,void*)))fread; - bs.freadpv = freadpv; - byterun(bs); -#else - byterun(fp); -#endif /* INDIRECT_BGET_MACROS */ - - exitstatus = perl_run( my_perl ); - - perl_destruct( my_perl ); - perl_free( my_perl ); - - exit( exitstatus ); -} - -static void -xs_init() -{ -} diff --git a/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs b/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs deleted file mode 100644 index b64ab3e..0000000 --- a/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs +++ /dev/null @@ -1,153 +0,0 @@ -/* dl_cygwin32.xs - * - * Platform: Win32 (Windows NT/Windows 95) - * Author: Wei-Yuen Tan (wyt@hip.com) - * Created: A warm day in June, 1995 - * - * Modified: - * August 23rd 1995 - rewritten after losing everything when I - * wiped off my NT partition (eek!) - */ -/* Modified from the original dl_win32.xs to work with cygwin32 - -John Cerney 3/26/97 -*/ -/* Porting notes: - -I merely took Paul's dl_dlopen.xs, took out extraneous stuff and -replaced the appropriate SunOS calls with the corresponding Win32 -calls. - -*/ - -#define WIN32_LEAN_AND_MEAN -// Defines from windows needed for this function only. Can't include full -// Cygwin32 windows headers because of problems with CONTEXT redefinition -// Removed logic to tell not dynamically load static modules. It is assumed that all -// modules are dynamically built. This should be similar to the behavoir on sunOS. -// Leaving in the logic would have required changes to the standard perlmain.c code -// -// // Includes call a dll function to initialize it's impure_ptr. -#include -void (*impure_setupptr)(struct _reent *); // pointer to the impure_setup routine - -//#include -#define LOAD_WITH_ALTERED_SEARCH_PATH (8) -typedef void *HANDLE; -typedef HANDLE HINSTANCE; -#define STDCALL __attribute__ ((stdcall)) -typedef int STDCALL (*FARPROC)(); - -HINSTANCE -STDCALL -LoadLibraryExA( - char* lpLibFileName, - HANDLE hFile, - unsigned int dwFlags - ); -unsigned int -STDCALL -GetLastError( - void - ); -FARPROC -STDCALL -GetProcAddress( - HINSTANCE hModule, - char* lpProcName - ); - -#include - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#include "dlutils.c" /* SaveError() etc */ - -static void -dl_private_init() -{ - (void)dl_generic_private_init(); -} - - -MODULE = DynaLoader PACKAGE = DynaLoader - -BOOT: - (void)dl_private_init(); - -void * -dl_load_file(filename,flags=0) - char * filename - int flags - PREINIT: - CODE: - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(),"dl_load_file(%s):\n", filename)); - - RETVAL = (void*) LoadLibraryExA(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH ) ; - - DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," libref=%x\n", RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL){ - SaveError("%d",GetLastError()) ; - } - else{ - // setup the dll's impure_ptr: - impure_setupptr = GetProcAddress(RETVAL, "impure_setup"); - if( impure_setupptr == NULL){ - printf( - "Cygwin32 dynaloader error: could not load impure_setup symbol\n"); - RETVAL = NULL; - } - else{ - // setup the DLLs impure_ptr: - (*impure_setupptr)(_impure_ptr); - sv_setiv( ST(0), (IV)RETVAL); - } - } - - - -void * -dl_find_symbol(libhandle, symbolname) - void * libhandle - char * symbolname - CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_find_symbol(handle=%x, symbol=%s)\n", - libhandle, symbolname)); - RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," symbolref = %x\n", RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError("%d",GetLastError()) ; - else - sv_setiv( ST(0), (IV)RETVAL); - - -void -dl_undef_symbols() - PPCODE: - - - -# These functions should not need changing on any platform: - -void -dl_install_xsub(perl_name, symref, filename="$Package") - char * perl_name - void * symref - char * filename - CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_install_xsub(name=%s, symref=%x)\n", - perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); - - -char * -dl_error() - CODE: - RETVAL = LastError ; - OUTPUT: - RETVAL - -# end. diff --git a/contrib/perl5/hints/cygwin32.sh b/contrib/perl5/hints/cygwin32.sh deleted file mode 100644 index 5853499..0000000 --- a/contrib/perl5/hints/cygwin32.sh +++ /dev/null @@ -1,50 +0,0 @@ -#! /bin/sh -# cygwin32.sh - hintsfile for building perl on Windows NT using the -# Cygnus Win32 Development Kit. -# See "http://www.cygnus.com/misc/gnu-win32/" to learn about the kit. -# -path_sep=\; -exe_ext='.exe' -firstmakefile='GNUmakefile' -if test -f $sh.exe; then sh=$sh.exe; fi -startsh="#!$sh" -cc='gcc2' -ld='ld2' -usrinc='/gnuwin32/H-i386-cygwin32/i386-cygwin32/include' -libpth='/gnuwin32/H-i386-cygwin32/i386-cygwin32/lib /gnuwin32/H-i386-cygwin32/lib' -libs='-lcygwin -lm -lc -lkernel32' -# dynamic lib stuff -so='dll' -#i_dlfcn='define' -dlsrc='dl_cygwin32.xs' -usedl='y' -# flag to include the perl.exe export variable translation file cw32imp.h -# when building extension libs -cccdlflags='-DCYGWIN32 -DDLLIMPORT ' -# flag that signals gcc2 to build exportable perl -ccdlflags='-buildperl ' -lddlflags='-L../.. -L/gnuwin32/H-i386-cygwin32/i386-cygwin32/lib -lperlexp -lcygwin' -d_voidsig='undef' -extensions='Fcntl IO Opcode SDBM_File' -lns='cp' -signal_t='int' -useposix='false' -rd_nodata='0' -eagain='EAGAIN' -archname='cygwin32' -# - -installbin='/usr/local/bin' -installman1dir='' -installman3dir='' -installprivlib='/usr/local/lib/perl5' -installscript='/usr/local/bin' - -installsitelib='/usr/local/lib/perl5/site_perl' -libc='/gnuwin32/H-i386-cygwin32/i386-cygwin32/lib/libc.a' - -perlpath='/usr/local/bin/perl' - -sitelib='/usr/local/lib/perl5/site_perl' -sitelibexp='/usr/local/lib/perl5/site_perl' -usrinc='/gnuwin32/H-i386-cygwin32/i386-cygwin32/include' diff --git a/contrib/perl5/interp.sym b/contrib/perl5/interp.sym deleted file mode 100644 index fbbe2a7..0000000 --- a/contrib/perl5/interp.sym +++ /dev/null @@ -1,211 +0,0 @@ -Argv -Cmd -DBcv -DBgv -DBline -DBsignal -DBsingle -DBsub -DBtrace -ampergv -archpat_auto -argvgv -argvoutgv -basetime -beginav -bodytarget -bostr -cddir -chopset -colors -colorset -compcv -compiling -comppad -comppad_name -comppad_name_fill -comppad_name_floor -copline -curcop -curcopdb -curpm -curstack -curstash -curstname -dbargs -debdelim -debname -debstash -defgv -defoutgv -defstash -delaymagic -diehook -dirty -dlevel -dlmax -doextract -doswitches -dowarn -dumplvl -e_script -endav -envgv -errgv -eval_root -eval_start -exitlist -exitlistlen -extralen -fdpid -filemode -firstgv -forkprocess -formfeed -formtarget -generation -gensym -globalstash -hintgv -in_clean_all -in_clean_objs -in_eval -incgv -initav -inplace -bytecode_iv_overflows -sys_intern -last_in_gv -last_proto -lastfd -lastgotoprobe -lastscream -lastsize -lastspbase -laststatval -laststype -leftgv -lineary -linestart -localizing -localpatches -main_cv -main_root -main_start -mainstack -maxscream -maxsysfd -mess_sv -minus_F -minus_a -minus_c -minus_l -minus_n -minus_p -modglobal -modcount -multiline -mystrk -nrs -bytecode_obj_list -bytecode_obj_list_fill -ofmt -ofs -ofslen -oldlastpm -oldname -op_mask -origargc -origargv -origfilename -ors -orslen -parsehook -patchlevel -pending_ident -perldb -perl_destruct_level -preambled -preambleav -preprocess -profiledata -bytecode_pv -reg_eval_set -reg_flags -reg_start_tmp -reg_start_tmpl -regbol -regcc -regcode -regcompp -regexecp -regdata -regdummy -regendp -regeol -regflags -regindent -reginput -reginterp_cnt -reglastparen -regnarrate -regnaughty -regnpar -regcomp_parse -regprecomp -regprev -regprogram -regsawback -regseen -regsize -regstartp -regtill -regxend -replgv -restartop -rightgv -rs -rsfp -rsfp_filters -regcomp_rx -sawampersand -sawstudy -sawvec -screamfirst -screamnext -secondgv -seen_zerolen -seen_evals -siggv -sortcop -sortcxix -sortstash -splitstr -start_env -statcache -statgv -statname -statusvalue -statusvalue_vms -stdingv -strchop -strtab -sub_generation -sublex_info -bytecode_sv -sv_count -sv_objcount -sv_root -sv_arenaroot -tainted -tainting -threadnum -thrsv -tmps_floor -tmps_ix -tmps_max -tmps_stack -top_env -toptarget -unsafe -warnhook diff --git a/contrib/perl5/lib/CGI.pm b/contrib/perl5/lib/CGI.pm deleted file mode 100644 index 3e03257..0000000 --- a/contrib/perl5/lib/CGI.pm +++ /dev/null @@ -1,6481 +0,0 @@ -package CGI; -require 5.004; - -# See the bottom of this file for the POD documentation. Search for the -# string '=head'. - -# You can run this file through either pod2man or pod2html to produce pretty -# documentation in manual or html file format (these utilities are part of the -# Perl 5 distribution). - -# Copyright 1995-1998 Lincoln D. Stein. All rights reserved. -# It may be used and modified freely, but I do request that this copyright -# notice remain attached to the file. You may modify this module as you -# wish, but if you redistribute a modified version, please attach a note -# listing the modifications you have made. - -# The most recent version and complete docs are available at: -# http://stein.cshl.org/WWW/software/CGI/ - -$CGI::revision = '$Id: CGI.pm,v 1.19 1999/08/31 17:04:37 lstein Exp $'; -$CGI::VERSION='2.56'; - -# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. -# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. -# $TempFile::TMPDIRECTORY = '/usr/tmp'; - -# >>>>> Here are some globals that you might want to adjust <<<<<< -sub initialize_globals { - # Set this to 1 to enable copious autoloader debugging messages - $AUTOLOAD_DEBUG = 0; - - # Change this to the preferred DTD to print in start_html() - # or use default_dtd('text of DTD to use'); - $DEFAULT_DTD = '-//IETF//DTD HTML//EN'; - - # Set this to 1 to enable NPH scripts - # or: - # 1) use CGI qw(-nph) - # 2) $CGI::nph(1) - # 3) print header(-nph=>1) - $NPH = 0; - - # Set this to 1 to disable debugging from the - # command line - $NO_DEBUG = 0; - - # Set this to 1 to make the temporary files created - # during file uploads safe from prying eyes - # or do... - # 1) use CGI qw(:private_tempfiles) - # 2) $CGI::private_tempfiles(1); - $PRIVATE_TEMPFILES = 0; - - # Set this to a positive value to limit the size of a POSTing - # to a certain number of bytes: - $POST_MAX = -1; - - # Change this to 1 to disable uploads entirely: - $DISABLE_UPLOADS = 0; - - # Automatically determined -- don't change - $EBCDIC = 0; - - # Change this to 1 to suppress redundant HTTP headers - $HEADERS_ONCE = 0; - - # separate the name=value pairs by semicolons rather than ampersands - $USE_PARAM_SEMICOLONS = 0; - - # Other globals that you shouldn't worry about. - undef $Q; - $BEEN_THERE = 0; - undef @QUERY_PARAM; - undef %EXPORT; - - # prevent complaints by mod_perl - 1; -} - -# ------------------ START OF THE LIBRARY ------------ - -# make mod_perlhappy -initialize_globals(); - -# FIGURE OUT THE OS WE'RE RUNNING UNDER -# Some systems support the $^O variable. If not -# available then require() the Config library -unless ($OS) { - unless ($OS = $^O) { - require Config; - $OS = $Config::Config{'osname'}; - } -} -if ($OS=~/Win/i) { - $OS = 'WINDOWS'; -} elsif ($OS=~/vms/i) { - $OS = 'VMS'; -} elsif ($OS=~/bsdos/i) { - $OS = 'UNIX'; -} elsif ($OS=~/dos/i) { - $OS = 'DOS'; -} elsif ($OS=~/^MacOS$/i) { - $OS = 'MACINTOSH'; -} elsif ($OS=~/os2/i) { - $OS = 'OS2'; -} else { - $OS = 'UNIX'; -} - -# Some OS logic. Binary mode enabled on DOS, NT and VMS -$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin)/; - -# This is the default class for the CGI object to use when all else fails. -$DefaultClass = 'CGI' unless defined $CGI::DefaultClass; - -# This is where to look for autoloaded routines. -$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass; - -# The path separator is a slash, backslash or semicolon, depending -# on the paltform. -$SL = { - UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/' - }->{$OS}; - -# This no longer seems to be necessary -# Turn on NPH scripts by default when running under IIS server! -# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; -$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; - -# Turn on special checking for Doug MacEachern's modperl -if (exists $ENV{'GATEWAY_INTERFACE'} - && - ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//)) -{ - $| = 1; - require Apache; -} -# Turn on special checking for ActiveState's PerlEx -$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/; - -# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning -# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF -# and sometimes CR). The most popular VMS web server -# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't -# use ASCII, so \015\012 means something different. I find this all -# really annoying. -$EBCDIC = "\t" ne "\011"; -if ($OS eq 'VMS') { - $CRLF = "\n"; -} elsif ($EBCDIC) { - $CRLF= "\r\n"; -} else { - $CRLF = "\015\012"; -} - -if ($EBCDIC) { -@A2E = ( - 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15, - 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31, - 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97, -240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111, -124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214, -215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109, -121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150, -151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7, - 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27, - 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255, - 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188, -144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171, -100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119, -172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89, - 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87, -140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223 - ); -} - -if ($needs_binmode) { - $CGI::DefaultClass->binmode(main::STDOUT); - $CGI::DefaultClass->binmode(main::STDIN); - $CGI::DefaultClass->binmode(main::STDERR); -} - -%EXPORT_TAGS = ( - ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em - tt u i b blockquote pre img a address cite samp dfn html head - base body Link nextid title meta kbd start_html end_html - input Select option comment/], - ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param - embed basefont style span layer ilayer font frameset frame script small big/], - ':netscape'=>[qw/blink fontsize center/], - ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group - submit reset defaults radio_group popup_menu button autoEscape - scrolling_list image_button start_form end_form startform endform - start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/], - ':cgi'=>[qw/param upload path_info path_translated url self_url script_name cookie Dump - raw_cookie request_method query_string Accept user_agent remote_host content_type - remote_addr referer server_name server_software server_port server_protocol - virtual_host remote_ident auth_type http use_named_parameters - save_parameters restore_parameters param_fetch - remote_user user_name header redirect import_names put - Delete Delete_all url_param cgi_error/], - ':ssl' => [qw/https/], - ':imagemap' => [qw/Area Map/], - ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/], - ':html' => [qw/:html2 :html3 :netscape/], - ':standard' => [qw/:html2 :html3 :form :cgi/], - ':push' => [qw/multipart_init multipart_start multipart_end/], - ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal/] - ); - -# to import symbols into caller -sub import { - my $self = shift; - -# This causes modules to clash. -# undef %EXPORT_OK; -# undef %EXPORT; - - $self->_setup_symbols(@_); - my ($callpack, $callfile, $callline) = caller; - - # To allow overriding, search through the packages - # Till we find one in which the correct subroutine is defined. - my @packages = ($self,@{"$self\:\:ISA"}); - foreach $sym (keys %EXPORT) { - my $pck; - my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass; - foreach $pck (@packages) { - if (defined(&{"$pck\:\:$sym"})) { - $def = $pck; - last; - } - } - *{"${callpack}::$sym"} = \&{"$def\:\:$sym"}; - } -} - -sub compile { - my $pack = shift; - $pack->_setup_symbols('-compile',@_); -} - -sub expand_tags { - my($tag) = @_; - return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/; - my(@r); - return ($tag) unless $EXPORT_TAGS{$tag}; - foreach (@{$EXPORT_TAGS{$tag}}) { - push(@r,&expand_tags($_)); - } - return @r; -} - -#### Method: new -# The new routine. This will check the current environment -# for an existing query string, and initialize itself, if so. -#### -sub new { - my($class,$initializer) = @_; - my $self = {}; - bless $self,ref $class || $class || $DefaultClass; - if ($MOD_PERL) { - Apache->request->register_cleanup(\&CGI::_reset_globals); - undef $NPH; - } - $self->_reset_globals if $PERLEX; - $self->init($initializer); - return $self; -} - -# We provide a DESTROY method so that the autoloader -# doesn't bother trying to find it. -sub DESTROY { } - -#### Method: param -# Returns the value(s)of a named parameter. -# If invoked in a list context, returns the -# entire list. Otherwise returns the first -# member of the list. -# If name is not provided, return a list of all -# the known parameters names available. -# If more than one argument is provided, the -# second and subsequent arguments are used to -# set the value of the parameter. -#### -sub param { - my($self,@p) = self_or_default(@_); - return $self->all_parameters unless @p; - my($name,$value,@other); - - # For compatibility between old calling style and use_named_parameters() style, - # we have to special case for a single parameter present. - if (@p > 1) { - ($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p); - my(@values); - - if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) { - @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : (); - } else { - foreach ($value,@other) { - push(@values,$_) if defined($_); - } - } - # If values is provided, then we set it. - if (@values) { - $self->add_parameter($name); - $self->{$name}=[@values]; - } - } else { - $name = $p[0]; - } - - return unless defined($name) && $self->{$name}; - return wantarray ? @{$self->{$name}} : $self->{$name}->[0]; -} - -sub self_or_default { - return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI'); - unless (defined($_[0]) && - (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case - ) { - $Q = $CGI::DefaultClass->new unless defined($Q); - unshift(@_,$Q); - } - return @_; -} - -sub self_or_CGI { - local $^W=0; # prevent a warning - if (defined($_[0]) && - (substr(ref($_[0]),0,3) eq 'CGI' - || UNIVERSAL::isa($_[0],'CGI'))) { - return @_; - } else { - return ($DefaultClass,@_); - } -} - -######################################## -# THESE METHODS ARE MORE OR LESS PRIVATE -# GO TO THE __DATA__ SECTION TO SEE MORE -# PUBLIC METHODS -######################################## - -# Initialize the query object from the environment. -# If a parameter list is found, this object will be set -# to an associative array in which parameter names are keys -# and the values are stored as lists -# If a keyword list is found, this method creates a bogus -# parameter list with the single parameter 'keywords'. - -sub init { - my($self,$initializer) = @_; - my($query_string,$meth,$content_length,$fh,@lines) = ('','','',''); - local($/) = "\n"; - - # if we get called more than once, we want to initialize - # ourselves from the original query (which may be gone - # if it was read from STDIN originally.) - if (@QUERY_PARAM && !defined($initializer)) { - foreach (@QUERY_PARAM) { - $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_}); - } - return; - } - - $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'}); - $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0; - - $fh = to_filehandle($initializer) if $initializer; - - METHOD: { - - # avoid unreasonably large postings - if (($POST_MAX > 0) && ($content_length > $POST_MAX)) { - $self->cgi_error("413 Request entity too large"); - last METHOD; - } - - # Process multipart postings, but only if the initializer is - # not defined. - if ($meth eq 'POST' - && defined($ENV{'CONTENT_TYPE'}) - && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data| - && !defined($initializer) - ) { - my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/; - $self->read_multipart($boundary,$content_length); - last METHOD; - } - - # If initializer is defined, then read parameters - # from it. - if (defined($initializer)) { - if (UNIVERSAL::isa($initializer,'CGI')) { - $query_string = $initializer->query_string; - last METHOD; - } - if (ref($initializer) && ref($initializer) eq 'HASH') { - foreach (keys %$initializer) { - $self->param('-name'=>$_,'-value'=>$initializer->{$_}); - } - last METHOD; - } - - if (defined($fh) && ($fh ne '')) { - while (<$fh>) { - chomp; - last if /^=/; - push(@lines,$_); - } - # massage back into standard format - if ("@lines" =~ /=/) { - $query_string=join("&",@lines); - } else { - $query_string=join("+",@lines); - } - last METHOD; - } - - # last chance -- treat it as a string - $initializer = $$initializer if ref($initializer) eq 'SCALAR'; - $query_string = $initializer; - - last METHOD; - } - - # If method is GET or HEAD, fetch the query from - # the environment. - if ($meth=~/^(GET|HEAD)$/) { - if ($MOD_PERL) { - $query_string = Apache->request->args; - } else { - $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; - } - last METHOD; - } - - if ($meth eq 'POST') { - $self->read_from_client(\*STDIN,\$query_string,$content_length,0) - if $content_length > 0; - # Some people want to have their cake and eat it too! - # Uncomment this line to have the contents of the query string - # APPENDED to the POST data. - # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; - last METHOD; - } - - # If $meth is not of GET, POST or HEAD, assume we're being debugged offline. - # Check the command line and then the standard input for data. - # We use the shellwords package in order to behave the way that - # UN*X programmers expect. - $query_string = read_from_cmdline() unless $NO_DEBUG; - } - - # We now have the query string in hand. We do slightly - # different things for keyword lists and parameter lists. - if (defined $query_string && $query_string) { - if ($query_string =~ /=/) { - $self->parse_params($query_string); - } else { - $self->add_parameter('keywords'); - $self->{'keywords'} = [$self->parse_keywordlist($query_string)]; - } - } - - # Special case. Erase everything if there is a field named - # .defaults. - if ($self->param('.defaults')) { - undef %{$self}; - } - - # Associative array containing our defined fieldnames - $self->{'.fieldnames'} = {}; - foreach ($self->param('.cgifields')) { - $self->{'.fieldnames'}->{$_}++; - } - - # Clear out our default submission button flag if present - $self->delete('.submit'); - $self->delete('.cgifields'); - $self->save_request unless $initializer; -} - -# FUNCTIONS TO OVERRIDE: -# Turn a string into a filehandle -sub to_filehandle { - my $thingy = shift; - return undef unless $thingy; - return $thingy if UNIVERSAL::isa($thingy,'GLOB'); - return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); - if (!ref($thingy)) { - my $caller = 1; - while (my $package = caller($caller++)) { - my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; - return $tmp if defined(fileno($tmp)); - } - } - return undef; -} - -# send output to the browser -sub put { - my($self,@p) = self_or_default(@_); - $self->print(@p); -} - -# print to standard output (for overriding in mod_perl) -sub print { - shift; - CORE::print(@_); -} - -# get/set last cgi_error -sub cgi_error { - my ($self,$err) = self_or_default(@_); - $self->{'.cgi_error'} = $err if defined $err; - return $self->{'.cgi_error'}; -} - -# unescape URL-encoded data -sub unescape { - shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $DefaultClass); - my $todecode = shift; - return undef unless defined($todecode); - $todecode =~ tr/+/ /; # pluses become spaces - if ($EBCDIC) { - $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",$A2E[hex($1)])/ge; - } else { - $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge; - } - return $todecode; -} - -# URL-encode data -sub escape { - shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $DefaultClass); - my $toencode = shift; - return undef unless defined($toencode); - $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg; - return $toencode; -} - -sub save_request { - my($self) = @_; - # We're going to play with the package globals now so that if we get called - # again, we initialize ourselves in exactly the same way. This allows - # us to have several of these objects. - @QUERY_PARAM = $self->param; # save list of parameters - foreach (@QUERY_PARAM) { - $QUERY_PARAM{$_}=$self->{$_}; - } -} - -sub parse_params { - my($self,$tosplit) = @_; - my(@pairs) = split(/[&;]/,$tosplit); - my($param,$value); - foreach (@pairs) { - ($param,$value) = split('=',$_,2); - $param = unescape($param); - $value = unescape($value); - $self->add_parameter($param); - push (@{$self->{$param}},$value); - } -} - -sub add_parameter { - my($self,$param)=@_; - push (@{$self->{'.parameters'}},$param) - unless defined($self->{$param}); -} - -sub all_parameters { - my $self = shift; - return () unless defined($self) && $self->{'.parameters'}; - return () unless @{$self->{'.parameters'}}; - return @{$self->{'.parameters'}}; -} - -# put a filehandle into binary mode (DOS) -sub binmode { - CORE::binmode($_[1]); -} - -sub _make_tag_func { - my ($self,$tagname) = @_; - my $func = qq( - sub $tagname { - shift if \$_[0] && -# (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) || - (ref(\$_[0]) && - (substr(ref(\$_[0]),0,3) eq 'CGI' || - UNIVERSAL::isa(\$_[0],'CGI'))); - - my(\$attr) = ''; - if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') { - my(\@attr) = make_attributes( '',shift() ); - \$attr = " \@attr" if \@attr; - } - ); - if ($tagname=~/start_(\w+)/i) { - $func .= qq! return "<\U$1\E\$attr>";} !; - } elsif ($tagname=~/end_(\w+)/i) { - $func .= qq! return "<\U/$1\E>"; } !; - } else { - $func .= qq# - my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U\E"); - return \$tag unless \@_; - my \@result = map { "\$tag\$_\$untag" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_"; - return "\@result"; - }#; - } -return $func; -} - -sub AUTOLOAD { - print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG; - my $func = &_compile; - goto &$func; -} - -# PRIVATE SUBROUTINE -# Smart rearrangement of parameters to allow named parameter -# calling. We do the rearangement if: -# 1. The first parameter begins with a - -# 2. The use_named_parameters() method returns true -sub rearrange { - my($self,$order,@param) = @_; - return () unless @param; - - if (ref($param[0]) eq 'HASH') { - @param = %{$param[0]}; - } else { - return @param - unless (defined($param[0]) && substr($param[0],0,1) eq '-') - || $self->use_named_parameters; - } - - # map parameters into positional indices - my ($i,%pos); - $i = 0; - foreach (@$order) { - foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; } - $i++; - } - - my (@result,%leftover); - $#result = $#$order; # preextend - while (@param) { - my $key = uc(shift(@param)); - $key =~ s/^\-//; - if (exists $pos{$key}) { - $result[$pos{$key}] = shift(@param); - } else { - $leftover{$key} = shift(@param); - } - } - - push (@result,$self->make_attributes(\%leftover)) if %leftover; - @result; -} - -sub _compile { - my($func) = $AUTOLOAD; - my($pack,$func_name); - { - local($1,$2); # this fixes an obscure variable suicide problem. - $func=~/(.+)::([^:]+)$/; - ($pack,$func_name) = ($1,$2); - $pack=~s/::SUPER$//; # fix another obscure problem - $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass - unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"}); - - my($sub) = \%{"$pack\:\:SUBS"}; - unless (%$sub) { - my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"}; - eval "package $pack; $$auto"; - die $@ if $@; - $$auto = ''; # Free the unneeded storage (but don't undef it!!!) - } - my($code) = $sub->{$func_name}; - - $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY'); - if (!$code) { - (my $base = $func_name) =~ s/^(start_|end_)//i; - if ($EXPORT{':any'} || - $EXPORT{'-any'} || - $EXPORT{$base} || - (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html'))) - && $EXPORT_OK{$base}) { - $code = $CGI::DefaultClass->_make_tag_func($func_name); - } - } - die "Undefined subroutine $AUTOLOAD\n" unless $code; - eval "package $pack; $code"; - if ($@) { - $@ =~ s/ at .*\n//; - die $@; - } - } - CORE::delete($sub->{$func_name}); #free storage - return "$pack\:\:$func_name"; -} - -sub _reset_globals { initialize_globals(); } - -sub _setup_symbols { - my $self = shift; - my $compile = 0; - foreach (@_) { - $HEADERS_ONCE++, next if /^[:-]unique_headers$/; - $NPH++, next if /^[:-]nph$/; - $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/; - $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/; - $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/; - $EXPORT{$_}++, next if /^[:-]any$/; - $compile++, next if /^[:-]compile$/; - - # This is probably extremely evil code -- to be deleted some day. - if (/^[-]autoload$/) { - my($pkg) = caller(1); - *{"${pkg}::AUTOLOAD"} = sub { - my($routine) = $AUTOLOAD; - $routine =~ s/^.*::/CGI::/; - &$routine; - }; - next; - } - - foreach (&expand_tags($_)) { - tr/a-zA-Z0-9_//cd; # don't allow weird function names - $EXPORT{$_}++; - } - } - _compile_all(keys %EXPORT) if $compile; -} - -############################################################################### -################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### -############################################################################### -$AUTOLOADED_ROUTINES = ''; # get rid of -w warning -$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; - -%SUBS = ( - -'URL_ENCODED'=> <<'END_OF_FUNC', -sub URL_ENCODED { 'application/x-www-form-urlencoded'; } -END_OF_FUNC - -'MULTIPART' => <<'END_OF_FUNC', -sub MULTIPART { 'multipart/form-data'; } -END_OF_FUNC - -'SERVER_PUSH' => <<'END_OF_FUNC', -sub SERVER_PUSH { 'multipart/x-mixed-replace; boundary="' . shift() . '"'; } -END_OF_FUNC - -'use_named_parameters' => <<'END_OF_FUNC', -#### Method: use_named_parameters -# Force CGI.pm to use named parameter-style method calls -# rather than positional parameters. The same effect -# will happen automatically if the first parameter -# begins with a -. -sub use_named_parameters { - my($self,$use_named) = self_or_default(@_); - return $self->{'.named'} unless defined ($use_named); - - # stupidity to avoid annoying warnings - return $self->{'.named'}=$use_named; -} -END_OF_FUNC - -'new_MultipartBuffer' => <<'END_OF_FUNC', -# Create a new multipart buffer -sub new_MultipartBuffer { - my($self,$boundary,$length,$filehandle) = @_; - return MultipartBuffer->new($self,$boundary,$length,$filehandle); -} -END_OF_FUNC - -'read_from_client' => <<'END_OF_FUNC', -# Read data from a file handle -sub read_from_client { - my($self, $fh, $buff, $len, $offset) = @_; - local $^W=0; # prevent a warning - return undef unless defined($fh); - return read($fh, $$buff, $len, $offset); -} -END_OF_FUNC - -'delete' => <<'END_OF_FUNC', -#### Method: delete -# Deletes the named parameter entirely. -#### -sub delete { - my($self,$name) = self_or_default(@_); - CORE::delete $self->{$name}; - CORE::delete $self->{'.fieldnames'}->{$name}; - @{$self->{'.parameters'}}=grep($_ ne $name,$self->param()); - return wantarray ? () : undef; -} -END_OF_FUNC - -#### Method: import_names -# Import all parameters into the given namespace. -# Assumes namespace 'Q' if not specified -#### -'import_names' => <<'END_OF_FUNC', -sub import_names { - my($self,$namespace,$delete) = self_or_default(@_); - $namespace = 'Q' unless defined($namespace); - die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::; - if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) { - # can anyone find an easier way to do this? - foreach (keys %{"${namespace}::"}) { - local *symbol = "${namespace}::${_}"; - undef $symbol; - undef @symbol; - undef %symbol; - } - } - my($param,@value,$var); - foreach $param ($self->param) { - # protect against silly names - ($var = $param)=~tr/a-zA-Z0-9_/_/c; - $var =~ s/^(?=\d)/_/; - local *symbol = "${namespace}::$var"; - @value = $self->param($param); - @symbol = @value; - $symbol = $value[0]; - } -} -END_OF_FUNC - -#### Method: keywords -# Keywords acts a bit differently. Calling it in a list context -# returns the list of keywords. -# Calling it in a scalar context gives you the size of the list. -#### -'keywords' => <<'END_OF_FUNC', -sub keywords { - my($self,@values) = self_or_default(@_); - # If values is provided, then we set it. - $self->{'keywords'}=[@values] if @values; - my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : (); - @result; -} -END_OF_FUNC - -# These are some tie() interfaces for compatibility -# with Steve Brenner's cgi-lib.pl routines -'Vars' => <<'END_OF_FUNC', -sub Vars { - my $q = shift; - my %in; - tie(%in,CGI,$q); - return %in if wantarray; - return \%in; -} -END_OF_FUNC - -# These are some tie() interfaces for compatibility -# with Steve Brenner's cgi-lib.pl routines -'ReadParse' => <<'END_OF_FUNC', -sub ReadParse { - local(*in); - if (@_) { - *in = $_[0]; - } else { - my $pkg = caller(); - *in=*{"${pkg}::in"}; - } - tie(%in,CGI); - return scalar(keys %in); -} -END_OF_FUNC - -'PrintHeader' => <<'END_OF_FUNC', -sub PrintHeader { - my($self) = self_or_default(@_); - return $self->header(); -} -END_OF_FUNC - -'HtmlTop' => <<'END_OF_FUNC', -sub HtmlTop { - my($self,@p) = self_or_default(@_); - return $self->start_html(@p); -} -END_OF_FUNC - -'HtmlBot' => <<'END_OF_FUNC', -sub HtmlBot { - my($self,@p) = self_or_default(@_); - return $self->end_html(@p); -} -END_OF_FUNC - -'SplitParam' => <<'END_OF_FUNC', -sub SplitParam { - my ($param) = @_; - my (@params) = split ("\0", $param); - return (wantarray ? @params : $params[0]); -} -END_OF_FUNC - -'MethGet' => <<'END_OF_FUNC', -sub MethGet { - return request_method() eq 'GET'; -} -END_OF_FUNC - -'MethPost' => <<'END_OF_FUNC', -sub MethPost { - return request_method() eq 'POST'; -} -END_OF_FUNC - -'TIEHASH' => <<'END_OF_FUNC', -sub TIEHASH { - return $_[1] if defined $_[1]; - return $Q || new shift; -} -END_OF_FUNC - -'STORE' => <<'END_OF_FUNC', -sub STORE { - $_[0]->param($_[1],split("\0",$_[2])); -} -END_OF_FUNC - -'FETCH' => <<'END_OF_FUNC', -sub FETCH { - return $_[0] if $_[1] eq 'CGI'; - return undef unless defined $_[0]->param($_[1]); - return join("\0",$_[0]->param($_[1])); -} -END_OF_FUNC - -'FIRSTKEY' => <<'END_OF_FUNC', -sub FIRSTKEY { - $_[0]->{'.iterator'}=0; - $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; -} -END_OF_FUNC - -'NEXTKEY' => <<'END_OF_FUNC', -sub NEXTKEY { - $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; -} -END_OF_FUNC - -'EXISTS' => <<'END_OF_FUNC', -sub EXISTS { - exists $_[0]->{$_[1]}; -} -END_OF_FUNC - -'DELETE' => <<'END_OF_FUNC', -sub DELETE { - $_[0]->delete($_[1]); -} -END_OF_FUNC - -'CLEAR' => <<'END_OF_FUNC', -sub CLEAR { - %{$_[0]}=(); -} -#### -END_OF_FUNC - -#### -# Append a new value to an existing query -#### -'append' => <<'EOF', -sub append { - my($self,@p) = @_; - my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p); - my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : (); - if (@values) { - $self->add_parameter($name); - push(@{$self->{$name}},@values); - } - return $self->param($name); -} -EOF - -#### Method: delete_all -# Delete all parameters -#### -'delete_all' => <<'EOF', -sub delete_all { - my($self) = self_or_default(@_); - undef %{$self}; -} -EOF - -'Delete' => <<'EOF', -sub Delete { - my($self,@p) = self_or_default(@_); - $self->delete(@p); -} -EOF - -'Delete_all' => <<'EOF', -sub Delete_all { - my($self,@p) = self_or_default(@_); - $self->delete_all(@p); -} -EOF - -#### Method: autoescape -# If you want to turn off the autoescaping features, -# call this method with undef as the argument -'autoEscape' => <<'END_OF_FUNC', -sub autoEscape { - my($self,$escape) = self_or_default(@_); - $self->{'dontescape'}=!$escape; -} -END_OF_FUNC - - -#### Method: version -# Return the current version -#### -'version' => <<'END_OF_FUNC', -sub version { - return $VERSION; -} -END_OF_FUNC - -'make_attributes' => <<'END_OF_FUNC', -sub make_attributes { - my($self,$attr) = @_; - return () unless $attr && ref($attr) && ref($attr) eq 'HASH'; - my(@att); - foreach (keys %{$attr}) { - my($key) = $_; - $key=~s/^\-//; # get rid of initial - if present - $key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes - push(@att,defined($attr->{$_}) ? qq/$key="$attr->{$_}"/ : qq/$key/); - } - return @att; -} -END_OF_FUNC - -#### Method: url_param -# Return a parameter in the QUERY_STRING, regardless of -# whether this was a POST or a GET -#### -'url_param' => <<'END_OF_FUNC', -sub url_param { - my ($self,@p) = self_or_default(@_); - my $name = shift(@p); - return undef unless exists($ENV{QUERY_STRING}); - unless (exists($self->{'.url_param'})) { - $self->{'.url_param'}={}; # empty hash - if ($ENV{QUERY_STRING} =~ /=/) { - my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING}); - my($param,$value); - foreach (@pairs) { - ($param,$value) = split('=',$_,2); - $param = unescape($param); - $value = unescape($value); - push(@{$self->{'.url_param'}->{$param}},$value); - } - } else { - $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})]; - } - } - return keys %{$self->{'.url_param'}} unless defined($name); - return () unless $self->{'.url_param'}->{$name}; - return wantarray ? @{$self->{'.url_param'}->{$name}} - : $self->{'.url_param'}->{$name}->[0]; -} -END_OF_FUNC - -#### Method: dump -# Returns a string in which all the known parameter/value -# pairs are represented as nested lists, mainly for the purposes -# of debugging. -#### -'dump' => <<'END_OF_FUNC', -sub dump { - my($self) = self_or_default(@_); - my($param,$value,@result); - return '
    ' unless $self->param; - push(@result,"
      "); - foreach $param ($self->param) { - my($name)=$self->escapeHTML($param); - push(@result,"
    • $param"); - push(@result,"
        "); - foreach $value ($self->param($param)) { - $value = $self->escapeHTML($value); - $value =~ s/\n/
        \n/g; - push(@result,"
      • $value"); - } - push(@result,"
      "); - } - push(@result,"
    \n"); - return join("\n",@result); -} -END_OF_FUNC - -#### Method as_string -# -# synonym for "dump" -#### -'as_string' => <<'END_OF_FUNC', -sub as_string { - &dump(@_); -} -END_OF_FUNC - -#### Method: save -# Write values out to a filehandle in such a way that they can -# be reinitialized by the filehandle form of the new() method -#### -'save' => <<'END_OF_FUNC', -sub save { - my($self,$filehandle) = self_or_default(@_); - $filehandle = to_filehandle($filehandle); - my($param); - local($,) = ''; # set print field separator back to a sane value - local($\) = ''; # set output line separator to a sane value - foreach $param ($self->param) { - my($escaped_param) = escape($param); - my($value); - foreach $value ($self->param($param)) { - print $filehandle "$escaped_param=",escape("$value"),"\n"; - } - } - print $filehandle "=\n"; # end of record -} -END_OF_FUNC - - -#### Method: save_parameters -# An alias for save() that is a better name for exportation. -# Only intended to be used with the function (non-OO) interface. -#### -'save_parameters' => <<'END_OF_FUNC', -sub save_parameters { - my $fh = shift; - return save(to_filehandle($fh)); -} -END_OF_FUNC - -#### Method: restore_parameters -# A way to restore CGI parameters from an initializer. -# Only intended to be used with the function (non-OO) interface. -#### -'restore_parameters' => <<'END_OF_FUNC', -sub restore_parameters { - $Q = $CGI::DefaultClass->new(@_); -} -END_OF_FUNC - -#### Method: multipart_init -# Return a Content-Type: style header for server-push -# This has to be NPH, and it is advisable to set $| = 1 -# -# Many thanks to Ed Jordan for this -# contribution -#### -'multipart_init' => <<'END_OF_FUNC', -sub multipart_init { - my($self,@p) = self_or_default(@_); - my($boundary,@other) = $self->rearrange([BOUNDARY],@p); - $boundary = $boundary || '------- =_aaaaaaaaaa0'; - $self->{'separator'} = "\n--$boundary\n"; - $type = SERVER_PUSH($boundary); - return $self->header( - -nph => 1, - -type => $type, - (map { split "=", $_, 2 } @other), - ) . $self->multipart_end; -} -END_OF_FUNC - - -#### Method: multipart_start -# Return a Content-Type: style header for server-push, start of section -# -# Many thanks to Ed Jordan for this -# contribution -#### -'multipart_start' => <<'END_OF_FUNC', -sub multipart_start { - my($self,@p) = self_or_default(@_); - my($type,@other) = $self->rearrange([TYPE],@p); - $type = $type || 'text/html'; - return $self->header( - -type => $type, - (map { split "=", $_, 2 } @other), - ); -} -END_OF_FUNC - - -#### Method: multipart_end -# Return a Content-Type: style header for server-push, end of section -# -# Many thanks to Ed Jordan for this -# contribution -#### -'multipart_end' => <<'END_OF_FUNC', -sub multipart_end { - my($self,@p) = self_or_default(@_); - return $self->{'separator'}; -} -END_OF_FUNC - - -#### Method: header -# Return a Content-Type: style header -# -#### -'header' => <<'END_OF_FUNC', -sub header { - my($self,@p) = self_or_default(@_); - my(@header); - - return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE; - - my($type,$status,$cookie,$target,$expires,$nph,@other) = - $self->rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], - STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p); - - $nph ||= $NPH; - # rearrange() was designed for the HTML portion, so we - # need to fix it up a little. - foreach (@other) { - next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/; - ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e; - } - - $type ||= 'text/html' unless defined($type); - - # Maybe future compatibility. Maybe not. - my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'; - push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph; - - push(@header,"Status: $status") if $status; - push(@header,"Window-Target: $target") if $target; - # push all the cookies -- there may be several - if ($cookie) { - my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie; - foreach (@cookie) { - my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_; - push(@header,"Set-Cookie: $cs") if $cs ne ''; - } - } - # if the user indicates an expiration time, then we need - # both an Expires and a Date header (so that the browser is - # uses OUR clock) - push(@header,"Expires: " . expires($expires,'http')) - if $expires; - push(@header,"Date: " . expires(0,'http')) if $expires || $cookie; - push(@header,"Pragma: no-cache") if $self->cache(); - push(@header,@other); - push(@header,"Content-Type: $type") if $type ne ''; - - my $header = join($CRLF,@header)."${CRLF}${CRLF}"; - if ($MOD_PERL and not $nph) { - my $r = Apache->request; - $r->send_cgi_header($header); - return ''; - } - return $header; -} -END_OF_FUNC - - -#### Method: cache -# Control whether header() will produce the no-cache -# Pragma directive. -#### -'cache' => <<'END_OF_FUNC', -sub cache { - my($self,$new_value) = self_or_default(@_); - $new_value = '' unless $new_value; - if ($new_value ne '') { - $self->{'cache'} = $new_value; - } - return $self->{'cache'}; -} -END_OF_FUNC - - -#### Method: redirect -# Return a Location: style header -# -#### -'redirect' => <<'END_OF_FUNC', -sub redirect { - my($self,@p) = self_or_default(@_); - my($url,$target,$cookie,$nph,@other) = $self->rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p); - $url = $url || $self->self_url; - my(@o); - foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); } - unshift(@o, - '-Status'=>'302 Moved', - '-Location'=>$url, - '-nph'=>$nph); - unshift(@o,'-Target'=>$target) if $target; - unshift(@o,'-Cookie'=>$cookie) if $cookie; - unshift(@o,'-Type'=>''); - return $self->header(@o); -} -END_OF_FUNC - - -#### Method: start_html -# Canned HTML header -# -# Parameters: -# $title -> (optional) The title for this HTML document (-title) -# $author -> (optional) e-mail address of the author (-author) -# $base -> (optional) if set to true, will enter the BASE address of this document -# for resolving relative references (-base) -# $xbase -> (optional) alternative base at some remote location (-xbase) -# $target -> (optional) target window to load all links into (-target) -# $script -> (option) Javascript code (-script) -# $no_script -> (option) Javascript -END - ; - my($other) = @other ? " @other" : ''; - push(@result,""); - return join("\n",@result); -} -END_OF_FUNC - -### Method: _style -# internal method for generating a CSS style section -#### -'_style' => <<'END_OF_FUNC', -sub _style { - my ($self,$style) = @_; - my (@result); - my $type = 'text/css'; - if (ref($style)) { - my($src,$code,$stype,@other) = - $self->rearrange([SRC,CODE,TYPE], - '-foo'=>'bar', # a trick to allow the '-' to be omitted - ref($style) eq 'ARRAY' ? @$style : %$style); - $type = $stype if $stype; - push(@result,qq//) if $src; - push(@result,style({'type'=>$type},"")) if $code; - } else { - push(@result,style({'type'=>$type},"")); - } - @result; -} -END_OF_FUNC - - -'_script' => <<'END_OF_FUNC', -sub _script { - my ($self,$script) = @_; - my (@result); - my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script); - foreach $script (@scripts) { - my($src,$code,$language); - if (ref($script)) { # script is a hash - ($src,$code,$language) = - $self->rearrange([SRC,CODE,LANGUAGE], - '-foo'=>'bar', # a trick to allow the '-' to be omitted - ref($script) eq 'ARRAY' ? @$script : %$script); - - } else { - ($src,$code,$language) = ('',$script,'JavaScript'); - } - my(@satts); - push(@satts,'src'=>$src) if $src; - push(@satts,'language'=>$language || 'JavaScript'); - $code = "" - if $code && $language=~/javascript/i; - $code = "" - if $code && $language=~/perl/i; - push(@result,script({@satts},$code || '')); - } - @result; -} -END_OF_FUNC - -#### Method: end_html -# End an HTML document. -# Trivial method for completeness. Just returns "" -#### -'end_html' => <<'END_OF_FUNC', -sub end_html { - return ""; -} -END_OF_FUNC - - -################################ -# METHODS USED IN BUILDING FORMS -################################ - -#### Method: isindex -# Just prints out the isindex tag. -# Parameters: -# $action -> optional URL of script to run -# Returns: -# A string containing a tag -'isindex' => <<'END_OF_FUNC', -sub isindex { - my($self,@p) = self_or_default(@_); - my($action,@other) = $self->rearrange([ACTION],@p); - $action = qq/ACTION="$action"/ if $action; - my($other) = @other ? " @other" : ''; - return ""; -} -END_OF_FUNC - - -#### Method: startform -# Start a form -# Parameters: -# $method -> optional submission method to use (GET or POST) -# $action -> optional URL of script to run -# $enctype ->encoding to use (URL_ENCODED or MULTIPART) -'startform' => <<'END_OF_FUNC', -sub startform { - my($self,@p) = self_or_default(@_); - - my($method,$action,$enctype,@other) = - $self->rearrange([METHOD,ACTION,ENCTYPE],@p); - - $method = $method || 'POST'; - $enctype = $enctype || &URL_ENCODED; - $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ? - 'ACTION="'.$self->script_name.'"' : ''; - my($other) = @other ? " @other" : ''; - $self->{'.parametersToAdd'}={}; - return qq/
    \n/; -} -END_OF_FUNC - - -#### Method: start_form -# synonym for startform -'start_form' => <<'END_OF_FUNC', -sub start_form { - &startform; -} -END_OF_FUNC - -'end_multipart_form' => <<'END_OF_FUNC', -sub end_multipart_form { - &endform; -} -END_OF_FUNC - -#### Method: start_multipart_form -# synonym for startform -'start_multipart_form' => <<'END_OF_FUNC', -sub start_multipart_form { - my($self,@p) = self_or_default(@_); - if ($self->use_named_parameters || - (defined($param[0]) && substr($param[0],0,1) eq '-')) { - my(%p) = @p; - $p{'-enctype'}=&MULTIPART; - return $self->startform(%p); - } else { - my($method,$action,@other) = - $self->rearrange([METHOD,ACTION],@p); - return $self->startform($method,$action,&MULTIPART,@other); - } -} -END_OF_FUNC - - -#### Method: endform -# End a form -'endform' => <<'END_OF_FUNC', -sub endform { - my($self,@p) = self_or_default(@_); - return wantarray ? ($self->get_fields,"
    ") : - $self->get_fields ."\n"; -} -END_OF_FUNC - - -#### Method: end_form -# synonym for endform -'end_form' => <<'END_OF_FUNC', -sub end_form { - &endform; -} -END_OF_FUNC - - -'_textfield' => <<'END_OF_FUNC', -sub _textfield { - my($self,$tag,@p) = self_or_default(@_); - my($name,$default,$size,$maxlength,$override,@other) = - $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); - - my $current = $override ? $default : - (defined($self->param($name)) ? $self->param($name) : $default); - - $current = defined($current) ? $self->escapeHTML($current) : ''; - $name = defined($name) ? $self->escapeHTML($name) : ''; - my($s) = defined($size) ? qq/ SIZE=$size/ : ''; - my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : ''; - my($other) = @other ? " @other" : ''; - # this entered at cristy's request to fix problems with file upload fields - # and WebTV -- not sure it won't break stuff - my($value) = $current ne '' ? qq(VALUE="$current") : ''; - return qq//; -} -END_OF_FUNC - -#### Method: textfield -# Parameters: -# $name -> Name of the text field -# $default -> Optional default value of the field if not -# already defined. -# $size -> Optional width of field in characaters. -# $maxlength -> Optional maximum number of characters. -# Returns: -# A string containing a field -# -'textfield' => <<'END_OF_FUNC', -sub textfield { - my($self,@p) = self_or_default(@_); - $self->_textfield('text',@p); -} -END_OF_FUNC - - -#### Method: filefield -# Parameters: -# $name -> Name of the file upload field -# $size -> Optional width of field in characaters. -# $maxlength -> Optional maximum number of characters. -# Returns: -# A string containing a field -# -'filefield' => <<'END_OF_FUNC', -sub filefield { - my($self,@p) = self_or_default(@_); - $self->_textfield('file',@p); -} -END_OF_FUNC - - -#### Method: password -# Create a "secret password" entry field -# Parameters: -# $name -> Name of the field -# $default -> Optional default value of the field if not -# already defined. -# $size -> Optional width of field in characters. -# $maxlength -> Optional maximum characters that can be entered. -# Returns: -# A string containing a field -# -'password_field' => <<'END_OF_FUNC', -sub password_field { - my ($self,@p) = self_or_default(@_); - $self->_textfield('password',@p); -} -END_OF_FUNC - -#### Method: textarea -# Parameters: -# $name -> Name of the text field -# $default -> Optional default value of the field if not -# already defined. -# $rows -> Optional number of rows in text area -# $columns -> Optional number of columns in text area -# Returns: -# A string containing a tag -# -'textarea' => <<'END_OF_FUNC', -sub textarea { - my($self,@p) = self_or_default(@_); - - my($name,$default,$rows,$cols,$override,@other) = - $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p); - - my($current)= $override ? $default : - (defined($self->param($name)) ? $self->param($name) : $default); - - $name = defined($name) ? $self->escapeHTML($name) : ''; - $current = defined($current) ? $self->escapeHTML($current) : ''; - my($r) = $rows ? " ROWS=$rows" : ''; - my($c) = $cols ? " COLS=$cols" : ''; - my($other) = @other ? " @other" : ''; - return qq{}; -} -END_OF_FUNC - - -#### Method: button -# Create a javascript button. -# Parameters: -# $name -> (optional) Name for the button. (-name) -# $value -> (optional) Value of the button when selected (and visible name) (-value) -# $onclick -> (optional) Text of the JavaScript to run when the button is -# clicked. -# Returns: -# A string containing a tag -#### -'button' => <<'END_OF_FUNC', -sub button { - my($self,@p) = self_or_default(@_); - - my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL], - [ONCLICK,SCRIPT]],@p); - - $label=$self->escapeHTML($label); - $value=$self->escapeHTML($value); - $script=$self->escapeHTML($script); - - my($name) = ''; - $name = qq/ NAME="$label"/ if $label; - $value = $value || $label; - my($val) = ''; - $val = qq/ VALUE="$value"/ if $value; - $script = qq/ ONCLICK="$script"/ if $script; - my($other) = @other ? " @other" : ''; - return qq//; -} -END_OF_FUNC - - -#### Method: submit -# Create a "submit query" button. -# Parameters: -# $name -> (optional) Name for the button. -# $value -> (optional) Value of the button when selected (also doubles as label). -# $label -> (optional) Label printed on the button(also doubles as the value). -# Returns: -# A string containing a tag -#### -'submit' => <<'END_OF_FUNC', -sub submit { - my($self,@p) = self_or_default(@_); - - my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p); - - $label=$self->escapeHTML($label); - $value=$self->escapeHTML($value); - - my($name) = ' NAME=".submit"'; - $name = qq/ NAME="$label"/ if defined($label); - $value = defined($value) ? $value : $label; - my($val) = ''; - $val = qq/ VALUE="$value"/ if defined($value); - my($other) = @other ? " @other" : ''; - return qq//; -} -END_OF_FUNC - - -#### Method: reset -# Create a "reset" button. -# Parameters: -# $name -> (optional) Name for the button. -# Returns: -# A string containing a tag -#### -'reset' => <<'END_OF_FUNC', -sub reset { - my($self,@p) = self_or_default(@_); - my($label,@other) = $self->rearrange([NAME],@p); - $label=$self->escapeHTML($label); - my($value) = defined($label) ? qq/ VALUE="$label"/ : ''; - my($other) = @other ? " @other" : ''; - return qq//; -} -END_OF_FUNC - - -#### Method: defaults -# Create a "defaults" button. -# Parameters: -# $name -> (optional) Name for the button. -# Returns: -# A string containing a tag -# -# Note: this button has a special meaning to the initialization script, -# and tells it to ERASE the current query string so that your defaults -# are used again! -#### -'defaults' => <<'END_OF_FUNC', -sub defaults { - my($self,@p) = self_or_default(@_); - - my($label,@other) = $self->rearrange([[NAME,VALUE]],@p); - - $label=$self->escapeHTML($label); - $label = $label || "Defaults"; - my($value) = qq/ VALUE="$label"/; - my($other) = @other ? " @other" : ''; - return qq//; -} -END_OF_FUNC - - -#### Method: comment -# Create an HTML -# Parameters: a string -'comment' => <<'END_OF_FUNC', -sub comment { - my($self,@p) = self_or_CGI(@_); - return ""; -} -END_OF_FUNC - -#### Method: checkbox -# Create a checkbox that is not logically linked to any others. -# The field value is "on" when the button is checked. -# Parameters: -# $name -> Name of the checkbox -# $checked -> (optional) turned on by default if true -# $value -> (optional) value of the checkbox, 'on' by default -# $label -> (optional) a user-readable label printed next to the box. -# Otherwise the checkbox name is used. -# Returns: -# A string containing a field -#### -'checkbox' => <<'END_OF_FUNC', -sub checkbox { - my($self,@p) = self_or_default(@_); - - my($name,$checked,$value,$label,$override,@other) = - $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p); - - $value = defined $value ? $value : 'on'; - - if (!$override && ($self->{'.fieldnames'}->{$name} || - defined $self->param($name))) { - $checked = grep($_ eq $value,$self->param($name)) ? ' CHECKED' : ''; - } else { - $checked = $checked ? ' CHECKED' : ''; - } - my($the_label) = defined $label ? $label : $name; - $name = $self->escapeHTML($name); - $value = $self->escapeHTML($value); - $the_label = $self->escapeHTML($the_label); - my($other) = @other ? " @other" : ''; - $self->register_parameter($name); - return qq{$the_label}; -} -END_OF_FUNC - - -#### Method: checkbox_group -# Create a list of logically-linked checkboxes. -# Parameters: -# $name -> Common name for all the check boxes -# $values -> A pointer to a regular array containing the -# values for each checkbox in the group. -# $defaults -> (optional) -# 1. If a pointer to a regular array of checkbox values, -# then this will be used to decide which -# checkboxes to turn on by default. -# 2. If a scalar, will be assumed to hold the -# value of a single checkbox in the group to turn on. -# $linebreak -> (optional) Set to true to place linebreaks -# between the buttons. -# $labels -> (optional) -# A pointer to an associative array of labels to print next to each checkbox -# in the form $label{'value'}="Long explanatory label". -# Otherwise the provided values are used as the labels. -# Returns: -# An ARRAY containing a series of fields -#### -'checkbox_group' => <<'END_OF_FUNC', -sub checkbox_group { - my($self,@p) = self_or_default(@_); - - my($name,$values,$defaults,$linebreak,$labels,$rows,$columns, - $rowheaders,$colheaders,$override,$nolabels,@other) = - $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], - LINEBREAK,LABELS,ROWS,[COLUMNS,COLS], - ROWHEADERS,COLHEADERS, - [OVERRIDE,FORCE],NOLABELS],@p); - - my($checked,$break,$result,$label); - - my(%checked) = $self->previous_or_default($name,$defaults,$override); - - $break = $linebreak ? "
    " : ''; - $name=$self->escapeHTML($name); - - # Create the elements - my(@elements,@values); - - @values = $self->_set_values_and_labels($values,\$labels,$name); - - my($other) = @other ? " @other" : ''; - foreach (@values) { - $checked = $checked{$_} ? ' CHECKED' : ''; - $label = ''; - unless (defined($nolabels) && $nolabels) { - $label = $_; - $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); - $label = $self->escapeHTML($label); - } - $_ = $self->escapeHTML($_); - push(@elements,qq/${label}${break}/); - } - $self->register_parameter($name); - return wantarray ? @elements : join(' ',@elements) - unless defined($columns) || defined($rows); - return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); -} -END_OF_FUNC - -# Escape HTML -- used internally -'escapeHTML' => <<'END_OF_FUNC', -sub escapeHTML { - my ($self,$toencode) = self_or_default(@_); - return undef unless defined($toencode); - return $toencode if ref($self) && $self->{'dontescape'}; - - $toencode=~s/&/&/g; - $toencode=~s/\"/"/g; - $toencode=~s/>/>/g; - $toencode=~s/ <<'END_OF_FUNC', -sub unescapeHTML { - my $string = ref($_[0]) ? $_[1] : $_[0]; - return undef unless defined($string); - # thanks to Randal Schwartz for the correct solution to this one - $string=~ s[&(.*?);]{ - local $_ = $1; - /^amp$/i ? "&" : - /^quot$/i ? '"' : - /^gt$/i ? ">" : - /^lt$/i ? "<" : - /^#(\d+)$/ ? chr($1) : - /^#x([0-9a-f]+)$/i ? chr(hex($1)) : - $_ - }gex; - return $string; -} -END_OF_FUNC - -# Internal procedure - don't use -'_tableize' => <<'END_OF_FUNC', -sub _tableize { - my($rows,$columns,$rowheaders,$colheaders,@elements) = @_; - my($result); - - if (defined($columns)) { - $rows = int(0.99 + @elements/$columns) unless defined($rows); - } - if (defined($rows)) { - $columns = int(0.99 + @elements/$rows) unless defined($columns); - } - - # rearrange into a pretty table - $result = ""; - my($row,$column); - unshift(@$colheaders,'') if @$colheaders && @$rowheaders; - $result .= "" if @$colheaders; - foreach (@{$colheaders}) { - $result .= ""; - } - for ($row=0;$row<$rows;$row++) { - $result .= ""; - $result .= "" if @$rowheaders; - for ($column=0;$column<$columns;$column++) { - $result .= "" - if defined($elements[$column*$rows + $row]); - } - $result .= ""; - } - $result .= "
    $_
    $rowheaders->[$row]" . $elements[$column*$rows + $row] . "
    "; - return $result; -} -END_OF_FUNC - - -#### Method: radio_group -# Create a list of logically-linked radio buttons. -# Parameters: -# $name -> Common name for all the buttons. -# $values -> A pointer to a regular array containing the -# values for each button in the group. -# $default -> (optional) Value of the button to turn on by default. Pass '-' -# to turn _nothing_ on. -# $linebreak -> (optional) Set to true to place linebreaks -# between the buttons. -# $labels -> (optional) -# A pointer to an associative array of labels to print next to each checkbox -# in the form $label{'value'}="Long explanatory label". -# Otherwise the provided values are used as the labels. -# Returns: -# An ARRAY containing a series of fields -#### -'radio_group' => <<'END_OF_FUNC', -sub radio_group { - my($self,@p) = self_or_default(@_); - - my($name,$values,$default,$linebreak,$labels, - $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) = - $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS, - ROWS,[COLUMNS,COLS], - ROWHEADERS,COLHEADERS, - [OVERRIDE,FORCE],NOLABELS],@p); - my($result,$checked); - - if (!$override && defined($self->param($name))) { - $checked = $self->param($name); - } else { - $checked = $default; - } - my(@elements,@values); - @values = $self->_set_values_and_labels($values,\$labels,$name); - - # If no check array is specified, check the first by default - $checked = $values[0] unless defined($checked) && $checked ne ''; - $name=$self->escapeHTML($name); - - my($other) = @other ? " @other" : ''; - foreach (@values) { - my($checkit) = $checked eq $_ ? ' CHECKED' : ''; - my($break) = $linebreak ? '
    ' : ''; - my($label)=''; - unless (defined($nolabels) && $nolabels) { - $label = $_; - $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); - $label = $self->escapeHTML($label); - } - $_=$self->escapeHTML($_); - push(@elements,qq/${label}${break}/); - } - $self->register_parameter($name); - return wantarray ? @elements : join(' ',@elements) - unless defined($columns) || defined($rows); - return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); -} -END_OF_FUNC - - -#### Method: popup_menu -# Create a popup menu. -# Parameters: -# $name -> Name for all the menu -# $values -> A pointer to a regular array containing the -# text of each menu item. -# $default -> (optional) Default item to display -# $labels -> (optional) -# A pointer to an associative array of labels to print next to each checkbox -# in the form $label{'value'}="Long explanatory label". -# Otherwise the provided values are used as the labels. -# Returns: -# A string containing the definition of a popup menu. -#### -'popup_menu' => <<'END_OF_FUNC', -sub popup_menu { - my($self,@p) = self_or_default(@_); - - my($name,$values,$default,$labels,$override,@other) = - $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p); - my($result,$selected); - - if (!$override && defined($self->param($name))) { - $selected = $self->param($name); - } else { - $selected = $default; - } - $name=$self->escapeHTML($name); - my($other) = @other ? " @other" : ''; - - my(@values); - @values = $self->_set_values_and_labels($values,\$labels,$name); - - $result = qq/\n"; - return $result; -} -END_OF_FUNC - - -#### Method: scrolling_list -# Create a scrolling list. -# Parameters: -# $name -> name for the list -# $values -> A pointer to a regular array containing the -# values for each option line in the list. -# $defaults -> (optional) -# 1. If a pointer to a regular array of options, -# then this will be used to decide which -# lines to turn on by default. -# 2. Otherwise holds the value of the single line to turn on. -# $size -> (optional) Size of the list. -# $multiple -> (optional) If set, allow multiple selections. -# $labels -> (optional) -# A pointer to an associative array of labels to print next to each checkbox -# in the form $label{'value'}="Long explanatory label". -# Otherwise the provided values are used as the labels. -# Returns: -# A string containing the definition of a scrolling list. -#### -'scrolling_list' => <<'END_OF_FUNC', -sub scrolling_list { - my($self,@p) = self_or_default(@_); - my($name,$values,$defaults,$size,$multiple,$labels,$override,@other) - = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], - SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p); - - my($result,@values); - @values = $self->_set_values_and_labels($values,\$labels,$name); - - $size = $size || scalar(@values); - - my(%selected) = $self->previous_or_default($name,$defaults,$override); - my($is_multiple) = $multiple ? ' MULTIPLE' : ''; - my($has_size) = $size ? " SIZE=$size" : ''; - my($other) = @other ? " @other" : ''; - - $name=$self->escapeHTML($name); - $result = qq/\n"; - $self->register_parameter($name); - return $result; -} -END_OF_FUNC - - -#### Method: hidden -# Parameters: -# $name -> Name of the hidden field -# @default -> (optional) Initial values of field (may be an array) -# or -# $default->[initial values of field] -# Returns: -# A string containing a -#### -'hidden' => <<'END_OF_FUNC', -sub hidden { - my($self,@p) = self_or_default(@_); - - # this is the one place where we departed from our standard - # calling scheme, so we have to special-case (darn) - my(@result,@value); - my($name,$default,$override,@other) = - $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p); - - my $do_override = 0; - if ( ref($p[0]) || substr($p[0],0,1) eq '-' || $self->use_named_parameters ) { - @value = ref($default) ? @{$default} : $default; - $do_override = $override; - } else { - foreach ($default,$override,@other) { - push(@value,$_) if defined($_); - } - } - - # use previous values if override is not set - my @prev = $self->param($name); - @value = @prev if !$do_override && @prev; - - $name=$self->escapeHTML($name); - foreach (@value) { - $_ = defined($_) ? $self->escapeHTML($_) : ''; - push(@result,qq//); - } - return wantarray ? @result : join('',@result); -} -END_OF_FUNC - - -#### Method: image_button -# Parameters: -# $name -> Name of the button -# $src -> URL of the image source -# $align -> Alignment style (TOP, BOTTOM or MIDDLE) -# Returns: -# A string containing a -#### -'image_button' => <<'END_OF_FUNC', -sub image_button { - my($self,@p) = self_or_default(@_); - - my($name,$src,$alignment,@other) = - $self->rearrange([NAME,SRC,ALIGN],@p); - - my($align) = $alignment ? " ALIGN=\U$alignment" : ''; - my($other) = @other ? " @other" : ''; - $name=$self->escapeHTML($name); - return qq//; -} -END_OF_FUNC - - -#### Method: self_url -# Returns a URL containing the current script and all its -# param/value pairs arranged as a query. You can use this -# to create a link that, when selected, will reinvoke the -# script with all its state information preserved. -#### -'self_url' => <<'END_OF_FUNC', -sub self_url { - my($self,@p) = self_or_default(@_); - return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p); -} -END_OF_FUNC - - -# This is provided as a synonym to self_url() for people unfortunate -# enough to have incorporated it into their programs already! -'state' => <<'END_OF_FUNC', -sub state { - &self_url; -} -END_OF_FUNC - - -#### Method: url -# Like self_url, but doesn't return the query string part of -# the URL. -#### -'url' => <<'END_OF_FUNC', -sub url { - my($self,@p) = self_or_default(@_); - my ($relative,$absolute,$full,$path_info,$query) = - $self->rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING']],@p); - my $url; - $full++ if !($relative || $absolute); - - my $path = $self->path_info; - my $script_name; - if (exists($ENV{REQUEST_URI})) { - my $index; - $script_name = $ENV{REQUEST_URI}; - # strip query string - substr($script_name,$index) = '' if ($index = index($script_name,'?')) >= 0; - # and path - substr($script_name,$index) = '' if exists($ENV{PATH_INFO}) - and ($index = rindex($script_name,$ENV{PATH_INFO})) >= 0; - } else { - $script_name = $self->script_name; - } - - if ($full) { - my $protocol = $self->protocol(); - $url = "$protocol://"; - my $vh = http('host'); - if ($vh) { - $url .= $vh; - } else { - $url .= server_name(); - my $port = $self->server_port; - $url .= ":" . $port - unless (lc($protocol) eq 'http' && $port == 80) - || (lc($protocol) eq 'https' && $port == 443); - } - $url .= $script_name; - } elsif ($relative) { - ($url) = $script_name =~ m!([^/]+)$!; - } elsif ($absolute) { - $url = $script_name; - } - $url .= $path if $path_info and defined $path; - $url .= "?" . $self->query_string if $query and $self->query_string; - return $url; -} - -END_OF_FUNC - -#### Method: cookie -# Set or read a cookie from the specified name. -# Cookie can then be passed to header(). -# Usual rules apply to the stickiness of -value. -# Parameters: -# -name -> name for this cookie (optional) -# -value -> value of this cookie (scalar, array or hash) -# -path -> paths for which this cookie is valid (optional) -# -domain -> internet domain in which this cookie is valid (optional) -# -secure -> if true, cookie only passed through secure channel (optional) -# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional) -#### -'cookie' => <<'END_OF_FUNC', -sub cookie { - my($self,@p) = self_or_default(@_); - my($name,$value,$path,$domain,$secure,$expires) = - $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p); - - require CGI::Cookie; - - # if no value is supplied, then we retrieve the - # value of the cookie, if any. For efficiency, we cache the parsed - # cookies in our state variables. - unless ( defined($value) ) { - $self->{'.cookies'} = CGI::Cookie->fetch - unless $self->{'.cookies'}; - - # If no name is supplied, then retrieve the names of all our cookies. - return () unless $self->{'.cookies'}; - return keys %{$self->{'.cookies'}} unless $name; - return () unless $self->{'.cookies'}->{$name}; - return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne ''; - } - - # If we get here, we're creating a new cookie - return undef unless $name; # this is an error - - my @param; - push(@param,'-name'=>$name); - push(@param,'-value'=>$value); - push(@param,'-domain'=>$domain) if $domain; - push(@param,'-path'=>$path) if $path; - push(@param,'-expires'=>$expires) if $expires; - push(@param,'-secure'=>$secure) if $secure; - - return CGI::Cookie->new(@param); -} -END_OF_FUNC - -# This internal routine creates an expires time exactly some number of -# hours from the current time. It incorporates modifications from -# Mark Fisher. -'expire_calc' => <<'END_OF_FUNC', -sub expire_calc { - my($time) = @_; - my(%mult) = ('s'=>1, - 'm'=>60, - 'h'=>60*60, - 'd'=>60*60*24, - 'M'=>60*60*24*30, - 'y'=>60*60*24*365); - # format for time can be in any of the forms... - # "now" -- expire immediately - # "+180s" -- in 180 seconds - # "+2m" -- in 2 minutes - # "+12h" -- in 12 hours - # "+1d" -- in 1 day - # "+3M" -- in 3 months - # "+2y" -- in 2 years - # "-3m" -- 3 minutes ago(!) - # If you don't supply one of these forms, we assume you are - # specifying the date yourself - my($offset); - if (!$time || (lc($time) eq 'now')) { - $offset = 0; - } elsif ($time=~/^\d+/) { - return $time; - } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) { - $offset = ($mult{$2} || 1)*$1; - } else { - return $time; - } - return (time+$offset); -} -END_OF_FUNC - -# This internal routine creates date strings suitable for use in -# cookies and HTTP headers. (They differ, unfortunately.) -# Thanks to Mark Fisher for this. -'expires' => <<'END_OF_FUNC', -sub expires { - my($time,$format) = @_; - $format ||= 'http'; - - my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; - my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/; - - # pass through preformatted dates for the sake of expire_calc() - $time = expire_calc($time); - return $time unless $time =~ /^\d+$/; - - # make HTTP/cookie date string from GMT'ed time - # (cookies use '-' as date separator, HTTP uses ' ') - my($sc) = ' '; - $sc = '-' if $format eq "cookie"; - my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time); - $year += 1900; - return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT", - $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec); -} -END_OF_FUNC - -'parse_keywordlist' => <<'END_OF_FUNC', -sub parse_keywordlist { - my($self,$tosplit) = @_; - $tosplit = unescape($tosplit); # unescape the keywords - $tosplit=~tr/+/ /; # pluses to spaces - my(@keywords) = split(/\s+/,$tosplit); - return @keywords; -} -END_OF_FUNC - -'param_fetch' => <<'END_OF_FUNC', -sub param_fetch { - my($self,@p) = self_or_default(@_); - my($name) = $self->rearrange([NAME],@p); - unless (exists($self->{$name})) { - $self->add_parameter($name); - $self->{$name} = []; - } - - return $self->{$name}; -} -END_OF_FUNC - -############################################### -# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT -############################################### - -#### Method: path_info -# Return the extra virtual path information provided -# after the URL (if any) -#### -'path_info' => <<'END_OF_FUNC', -sub path_info { - my ($self,$info) = self_or_default(@_); - if (defined($info)) { - $info = "/$info" if $info ne '' && substr($info,0,1) ne '/'; - $self->{'.path_info'} = $info; - } elsif (! defined($self->{'.path_info'}) ) { - $self->{'.path_info'} = defined($ENV{'PATH_INFO'}) ? - $ENV{'PATH_INFO'} : ''; - - # hack to fix broken path info in IIS - $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS; - - } - return $self->{'.path_info'}; -} -END_OF_FUNC - - -#### Method: request_method -# Returns 'POST', 'GET', 'PUT' or 'HEAD' -#### -'request_method' => <<'END_OF_FUNC', -sub request_method { - return $ENV{'REQUEST_METHOD'}; -} -END_OF_FUNC - -#### Method: content_type -# Returns the content_type string -#### -'content_type' => <<'END_OF_FUNC', -sub content_type { - return $ENV{'CONTENT_TYPE'}; -} -END_OF_FUNC - -#### Method: path_translated -# Return the physical path information provided -# by the URL (if any) -#### -'path_translated' => <<'END_OF_FUNC', -sub path_translated { - return $ENV{'PATH_TRANSLATED'}; -} -END_OF_FUNC - - -#### Method: query_string -# Synthesize a query string from our current -# parameters -#### -'query_string' => <<'END_OF_FUNC', -sub query_string { - my($self) = self_or_default(@_); - my($param,$value,@pairs); - foreach $param ($self->param) { - my($eparam) = escape($param); - foreach $value ($self->param($param)) { - $value = escape($value); - next unless defined $value; - push(@pairs,"$eparam=$value"); - } - } - return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs); -} -END_OF_FUNC - - -#### Method: accept -# Without parameters, returns an array of the -# MIME types the browser accepts. -# With a single parameter equal to a MIME -# type, will return undef if the browser won't -# accept it, 1 if the browser accepts it but -# doesn't give a preference, or a floating point -# value between 0.0 and 1.0 if the browser -# declares a quantitative score for it. -# This handles MIME type globs correctly. -#### -'Accept' => <<'END_OF_FUNC', -sub Accept { - my($self,$search) = self_or_CGI(@_); - my(%prefs,$type,$pref,$pat); - - my(@accept) = split(',',$self->http('accept')); - - foreach (@accept) { - ($pref) = /q=(\d\.\d+|\d+)/; - ($type) = m#(\S+/[^;]+)#; - next unless $type; - $prefs{$type}=$pref || 1; - } - - return keys %prefs unless $search; - - # if a search type is provided, we may need to - # perform a pattern matching operation. - # The MIME types use a glob mechanism, which - # is easily translated into a perl pattern match - - # First return the preference for directly supported - # types: - return $prefs{$search} if $prefs{$search}; - - # Didn't get it, so try pattern matching. - foreach (keys %prefs) { - next unless /\*/; # not a pattern match - ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters - $pat =~ s/\*/.*/g; # turn it into a pattern - return $prefs{$_} if $search=~/$pat/; - } -} -END_OF_FUNC - - -#### Method: user_agent -# If called with no parameters, returns the user agent. -# If called with one parameter, does a pattern match (case -# insensitive) on the user agent. -#### -'user_agent' => <<'END_OF_FUNC', -sub user_agent { - my($self,$match)=self_or_CGI(@_); - return $self->http('user_agent') unless $match; - return $self->http('user_agent') =~ /$match/i; -} -END_OF_FUNC - - -#### Method: raw_cookie -# Returns the magic cookies for the session. -# The cookies are not parsed or altered in any way, i.e. -# cookies are returned exactly as given in the HTTP -# headers. If a cookie name is given, only that cookie's -# value is returned, otherwise the entire raw cookie -# is returned. -#### -'raw_cookie' => <<'END_OF_FUNC', -sub raw_cookie { - my($self,$key) = self_or_CGI(@_); - - require CGI::Cookie; - - if (defined($key)) { - $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch - unless $self->{'.raw_cookies'}; - - return () unless $self->{'.raw_cookies'}; - return () unless $self->{'.raw_cookies'}->{$key}; - return $self->{'.raw_cookies'}->{$key}; - } - return $self->http('cookie') || $ENV{'COOKIE'} || ''; -} -END_OF_FUNC - -#### Method: virtual_host -# Return the name of the virtual_host, which -# is not always the same as the server -###### -'virtual_host' => <<'END_OF_FUNC', -sub virtual_host { - my $vh = http('host') || server_name(); - $vh =~ s/:\d+$//; # get rid of port number - return $vh; -} -END_OF_FUNC - -#### Method: remote_host -# Return the name of the remote host, or its IP -# address if unavailable. If this variable isn't -# defined, it returns "localhost" for debugging -# purposes. -#### -'remote_host' => <<'END_OF_FUNC', -sub remote_host { - return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'} - || 'localhost'; -} -END_OF_FUNC - - -#### Method: remote_addr -# Return the IP addr of the remote host. -#### -'remote_addr' => <<'END_OF_FUNC', -sub remote_addr { - return $ENV{'REMOTE_ADDR'} || '127.0.0.1'; -} -END_OF_FUNC - - -#### Method: script_name -# Return the partial URL to this script for -# self-referencing scripts. Also see -# self_url(), which returns a URL with all state information -# preserved. -#### -'script_name' => <<'END_OF_FUNC', -sub script_name { - return $ENV{'SCRIPT_NAME'} if defined($ENV{'SCRIPT_NAME'}); - # These are for debugging - return "/$0" unless $0=~/^\//; - return $0; -} -END_OF_FUNC - - -#### Method: referer -# Return the HTTP_REFERER: useful for generating -# a GO BACK button. -#### -'referer' => <<'END_OF_FUNC', -sub referer { - my($self) = self_or_CGI(@_); - return $self->http('referer'); -} -END_OF_FUNC - - -#### Method: server_name -# Return the name of the server -#### -'server_name' => <<'END_OF_FUNC', -sub server_name { - return $ENV{'SERVER_NAME'} || 'localhost'; -} -END_OF_FUNC - -#### Method: server_software -# Return the name of the server software -#### -'server_software' => <<'END_OF_FUNC', -sub server_software { - return $ENV{'SERVER_SOFTWARE'} || 'cmdline'; -} -END_OF_FUNC - -#### Method: server_port -# Return the tcp/ip port the server is running on -#### -'server_port' => <<'END_OF_FUNC', -sub server_port { - return $ENV{'SERVER_PORT'} || 80; # for debugging -} -END_OF_FUNC - -#### Method: server_protocol -# Return the protocol (usually HTTP/1.0) -#### -'server_protocol' => <<'END_OF_FUNC', -sub server_protocol { - return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging -} -END_OF_FUNC - -#### Method: http -# Return the value of an HTTP variable, or -# the list of variables if none provided -#### -'http' => <<'END_OF_FUNC', -sub http { - my ($self,$parameter) = self_or_CGI(@_); - return $ENV{$parameter} if $parameter=~/^HTTP/; - $parameter =~ tr/-/_/; - return $ENV{"HTTP_\U$parameter\E"} if $parameter; - my(@p); - foreach (keys %ENV) { - push(@p,$_) if /^HTTP/; - } - return @p; -} -END_OF_FUNC - -#### Method: https -# Return the value of HTTPS -#### -'https' => <<'END_OF_FUNC', -sub https { - local($^W)=0; - my ($self,$parameter) = self_or_CGI(@_); - return $ENV{HTTPS} unless $parameter; - return $ENV{$parameter} if $parameter=~/^HTTPS/; - $parameter =~ tr/-/_/; - return $ENV{"HTTPS_\U$parameter\E"} if $parameter; - my(@p); - foreach (keys %ENV) { - push(@p,$_) if /^HTTPS/; - } - return @p; -} -END_OF_FUNC - -#### Method: protocol -# Return the protocol (http or https currently) -#### -'protocol' => <<'END_OF_FUNC', -sub protocol { - local($^W)=0; - my $self = shift; - return 'https' if uc($self->https()) eq 'ON'; - return 'https' if $self->server_port == 443; - my $prot = $self->server_protocol; - my($protocol,$version) = split('/',$prot); - return "\L$protocol\E"; -} -END_OF_FUNC - -#### Method: remote_ident -# Return the identity of the remote user -# (but only if his host is running identd) -#### -'remote_ident' => <<'END_OF_FUNC', -sub remote_ident { - return $ENV{'REMOTE_IDENT'}; -} -END_OF_FUNC - - -#### Method: auth_type -# Return the type of use verification/authorization in use, if any. -#### -'auth_type' => <<'END_OF_FUNC', -sub auth_type { - return $ENV{'AUTH_TYPE'}; -} -END_OF_FUNC - - -#### Method: remote_user -# Return the authorization name used for user -# verification. -#### -'remote_user' => <<'END_OF_FUNC', -sub remote_user { - return $ENV{'REMOTE_USER'}; -} -END_OF_FUNC - - -#### Method: user_name -# Try to return the remote user's name by hook or by -# crook -#### -'user_name' => <<'END_OF_FUNC', -sub user_name { - my ($self) = self_or_CGI(@_); - return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'}; -} -END_OF_FUNC - -#### Method: nph -# Set or return the NPH global flag -#### -'nph' => <<'END_OF_FUNC', -sub nph { - my ($self,$param) = self_or_CGI(@_); - $CGI::NPH = $param if defined($param); - return $CGI::NPH; -} -END_OF_FUNC - -#### Method: private_tempfiles -# Set or return the private_tempfiles global flag -#### -'private_tempfiles' => <<'END_OF_FUNC', -sub private_tempfiles { - my ($self,$param) = self_or_CGI(@_); - $CGI::PRIVATE_TEMPFILES = $param if defined($param); - return $CGI::PRIVATE_TEMPFILES; -} -END_OF_FUNC - -#### Method: default_dtd -# Set or return the default_dtd global -#### -'default_dtd' => <<'END_OF_FUNC', -sub default_dtd { - my ($self,$param) = self_or_CGI(@_); - $CGI::DEFAULT_DTD = $param if defined($param); - return $CGI::DEFAULT_DTD; -} -END_OF_FUNC - -# -------------- really private subroutines ----------------- -'previous_or_default' => <<'END_OF_FUNC', -sub previous_or_default { - my($self,$name,$defaults,$override) = @_; - my(%selected); - - if (!$override && ($self->{'.fieldnames'}->{$name} || - defined($self->param($name)) ) ) { - grep($selected{$_}++,$self->param($name)); - } elsif (defined($defaults) && ref($defaults) && - (ref($defaults) eq 'ARRAY')) { - grep($selected{$_}++,@{$defaults}); - } else { - $selected{$defaults}++ if defined($defaults); - } - - return %selected; -} -END_OF_FUNC - -'register_parameter' => <<'END_OF_FUNC', -sub register_parameter { - my($self,$param) = @_; - $self->{'.parametersToAdd'}->{$param}++; -} -END_OF_FUNC - -'get_fields' => <<'END_OF_FUNC', -sub get_fields { - my($self) = @_; - return $self->CGI::hidden('-name'=>'.cgifields', - '-values'=>[keys %{$self->{'.parametersToAdd'}}], - '-override'=>1); -} -END_OF_FUNC - -'read_from_cmdline' => <<'END_OF_FUNC', -sub read_from_cmdline { - my($input,@words); - my($query_string); - if (@ARGV) { - @words = @ARGV; - } else { - require "shellwords.pl"; - print STDERR "(offline mode: enter name=value pairs on standard input)\n"; - chomp(@lines = ); # remove newlines - $input = join(" ",@lines); - @words = &shellwords($input); - } - foreach (@words) { - s/\\=/%3D/g; - s/\\&/%26/g; - } - - if ("@words"=~/=/) { - $query_string = join('&',@words); - } else { - $query_string = join('+',@words); - } - return $query_string; -} -END_OF_FUNC - -##### -# subroutine: read_multipart -# -# Read multipart data and store it into our parameters. -# An interesting feature is that if any of the parts is a file, we -# create a temporary file and open up a filehandle on it so that the -# caller can read from it if necessary. -##### -'read_multipart' => <<'END_OF_FUNC', -sub read_multipart { - my($self,$boundary,$length,$filehandle) = @_; - my($buffer) = $self->new_MultipartBuffer($boundary,$length,$filehandle); - return unless $buffer; - my(%header,$body); - my $filenumber = 0; - while (!$buffer->eof) { - %header = $buffer->readHeader; - - unless (%header) { - $self->cgi_error("400 Bad request (malformed multipart POST)"); - return; - } - - my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/; - - # Bug: Netscape doesn't escape quotation marks in file names!!! - my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\";]*)"?/; - - # add this parameter to our list - $self->add_parameter($param); - - # If no filename specified, then just read the data and assign it - # to our parameter list. - if ( !defined($filename) || $filename eq '' ) { - my($value) = $buffer->readBody; - push(@{$self->{$param}},$value); - next; - } - - my ($tmpfile,$tmp,$filehandle); - UPLOADS: { - # If we get here, then we are dealing with a potentially large - # uploaded form. Save the data to a temporary file, then open - # the file for reading. - - # skip the file if uploads disabled - if ($DISABLE_UPLOADS) { - while (defined($data = $buffer->read)) { } - last UPLOADS; - } - - # choose a relatively unpredictable tmpfile sequence number - my $seqno = unpack("%16C*",join('',localtime,values %ENV)); - for (my $cnt=10;$cnt>0;$cnt--) { - next unless $tmpfile = new TempFile($seqno); - $tmp = $tmpfile->as_string; - last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES)); - $seqno += int rand(100); - } - die "CGI open of tmpfile: $!\n" unless $filehandle; - $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; - - my ($data); - local($\) = ''; - while (defined($data = $buffer->read)) { - print $filehandle $data; - } - - # back up to beginning of file - seek($filehandle,0,0); - $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; - - # Save some information about the uploaded file where we can get - # at it later. - $self->{'.tmpfiles'}->{fileno($filehandle)}= { - name => $tmpfile, - info => {%header}, - }; - push(@{$self->{$param}},$filehandle); - } - } -} -END_OF_FUNC - -'upload' =><<'END_OF_FUNC', -sub upload { - my($self,$param_name) = self_or_default(@_); - my $param = $self->param($param_name); - return unless $param; - return unless ref($param) && fileno($param); - return $param; -} -END_OF_FUNC - -'tmpFileName' => <<'END_OF_FUNC', -sub tmpFileName { - my($self,$filename) = self_or_default(@_); - return $self->{'.tmpfiles'}->{fileno($filename)}->{name} ? - $self->{'.tmpfiles'}->{fileno($filename)}->{name}->as_string - : ''; -} -END_OF_FUNC - -'uploadInfo' => <<'END_OF_FUNC', -sub uploadInfo { - my($self,$filename) = self_or_default(@_); - return $self->{'.tmpfiles'}->{fileno($filename)}->{info}; -} -END_OF_FUNC - -# internal routine, don't use -'_set_values_and_labels' => <<'END_OF_FUNC', -sub _set_values_and_labels { - my $self = shift; - my ($v,$l,$n) = @_; - $$l = $v if ref($v) eq 'HASH' && !ref($$l); - return $self->param($n) if !defined($v); - return $v if !ref($v); - return ref($v) eq 'HASH' ? keys %$v : @$v; -} -END_OF_FUNC - -'_compile_all' => <<'END_OF_FUNC', -sub _compile_all { - foreach (@_) { - next if defined(&$_); - $AUTOLOAD = "CGI::$_"; - _compile(); - } -} -END_OF_FUNC - -); -END_OF_AUTOLOAD -; - -######################################################### -# Globals and stubs for other packages that we use. -######################################################### - -################### Fh -- lightweight filehandle ############### -package Fh; -use overload - '""' => \&asString, - 'cmp' => \&compare, - 'fallback'=>1; - -$FH='fh00000'; - -*Fh::AUTOLOAD = \&CGI::AUTOLOAD; - -$AUTOLOADED_ROUTINES = ''; # prevent -w error -$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; -%SUBS = ( -'asString' => <<'END_OF_FUNC', -sub asString { - my $self = shift; - # get rid of package name - (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//; - $i =~ s/\\(.)/$1/g; - return $i; -# BEGIN DEAD CODE -# This was an extremely clever patch that allowed "use strict refs". -# Unfortunately it relied on another bug that caused leaky file descriptors. -# The underlying bug has been fixed, so this no longer works. However -# "strict refs" still works for some reason. -# my $self = shift; -# return ${*{$self}{SCALAR}}; -# END DEAD CODE -} -END_OF_FUNC - -'compare' => <<'END_OF_FUNC', -sub compare { - my $self = shift; - my $value = shift; - return "$self" cmp $value; -} -END_OF_FUNC - -'new' => <<'END_OF_FUNC', -sub new { - my($pack,$name,$file,$delete) = @_; - require Fcntl unless defined &Fcntl::O_RDWR; - my $ref = \*{'Fh::' . ++$FH . quotemeta($name)}; - sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return; - unlink($file) if $delete; - CORE::delete $Fh::{$FH}; - return bless $ref,$pack; -} -END_OF_FUNC - -'DESTROY' => <<'END_OF_FUNC', -sub DESTROY { - my $self = shift; - close $self; -} -END_OF_FUNC - -); -END_OF_AUTOLOAD - -######################## MultipartBuffer #################### -package MultipartBuffer; - -# how many bytes to read at a time. We use -# a 4K buffer by default. -$INITIAL_FILLUNIT = 1024 * 4; -$TIMEOUT = 240*60; # 4 hour timeout for big files -$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers -$CRLF=$CGI::CRLF; - -#reuse the autoload function -*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD; - -# avoid autoloader warnings -sub DESTROY {} - -############################################################################### -################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### -############################################################################### -$AUTOLOADED_ROUTINES = ''; # prevent -w error -$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; -%SUBS = ( - -'new' => <<'END_OF_FUNC', -sub new { - my($package,$interface,$boundary,$length,$filehandle) = @_; - $FILLUNIT = $INITIAL_FILLUNIT; - my $IN; - if ($filehandle) { - my($package) = caller; - # force into caller's package if necessary - $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle"; - } - $IN = "main::STDIN" unless $IN; - - $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode; - - # If the user types garbage into the file upload field, - # then Netscape passes NOTHING to the server (not good). - # We may hang on this read in that case. So we implement - # a read timeout. If nothing is ready to read - # by then, we return. - - # Netscape seems to be a little bit unreliable - # about providing boundary strings. - if ($boundary) { - - # Under the MIME spec, the boundary consists of the - # characters "--" PLUS the Boundary string - - # BUG: IE 3.01 on the Macintosh uses just the boundary -- not - # the two extra hyphens. We do a special case here on the user-agent!!!! - $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac'); - - } else { # otherwise we find it ourselves - my($old); - ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line - $boundary = <$IN>; # BUG: This won't work correctly under mod_perl - $length -= length($boundary); - chomp($boundary); # remove the CRLF - $/ = $old; # restore old line separator - } - - my $self = {LENGTH=>$length, - BOUNDARY=>$boundary, - IN=>$IN, - INTERFACE=>$interface, - BUFFER=>'', - }; - - $FILLUNIT = length($boundary) - if length($boundary) > $FILLUNIT; - - my $retval = bless $self,ref $package || $package; - - # Read the preamble and the topmost (boundary) line plus the CRLF. - while ($self->read(0)) { } - die "Malformed multipart POST\n" if $self->eof; - - return $retval; -} -END_OF_FUNC - -'readHeader' => <<'END_OF_FUNC', -sub readHeader { - my($self) = @_; - my($end); - my($ok) = 0; - my($bad) = 0; - - if ($CGI::OS eq 'VMS') { # tssk, tssk: inconsistency alert! - local($CRLF) = "\015\012"; - } - - do { - $self->fillBuffer($FILLUNIT); - $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0; - $ok++ if $self->{BUFFER} eq ''; - $bad++ if !$ok && $self->{LENGTH} <= 0; - # this was a bad idea - # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT; - } until $ok || $bad; - return () if $bad; - - my($header) = substr($self->{BUFFER},0,$end+2); - substr($self->{BUFFER},0,$end+4) = ''; - my %return; - - - # See RFC 2045 Appendix A and RFC 822 sections 3.4.8 - # (Folding Long Header Fields), 3.4.3 (Comments) - # and 3.4.5 (Quoted-Strings). - - my $token = '[-\w!\#$%&\'*+.^_\`|{}~]'; - $header=~s/$CRLF\s+/ /og; # merge continuation lines - while ($header=~/($token+):\s+([^$CRLF]*)/mgox) { - my ($field_name,$field_value) = ($1,$2); # avoid taintedness - $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize - $return{$field_name}=$field_value; - } - return %return; -} -END_OF_FUNC - -# This reads and returns the body as a single scalar value. -'readBody' => <<'END_OF_FUNC', -sub readBody { - my($self) = @_; - my($data); - my($returnval)=''; - while (defined($data = $self->read)) { - $returnval .= $data; - } - return $returnval; -} -END_OF_FUNC - -# This will read $bytes or until the boundary is hit, whichever happens -# first. After the boundary is hit, we return undef. The next read will -# skip over the boundary and begin reading again; -'read' => <<'END_OF_FUNC', -sub read { - my($self,$bytes) = @_; - - # default number of bytes to read - $bytes = $bytes || $FILLUNIT; - - # Fill up our internal buffer in such a way that the boundary - # is never split between reads. - $self->fillBuffer($bytes); - - # Find the boundary in the buffer (it may not be there). - my $start = index($self->{BUFFER},$self->{BOUNDARY}); - # protect against malformed multipart POST operations - die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0); - - # If the boundary begins the data, then skip past it - # and return undef. The +2 here is a fiendish plot to - # remove the CR/LF pair at the end of the boundary. - if ($start == 0) { - - # clear us out completely if we've hit the last boundary. - if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) { - $self->{BUFFER}=''; - $self->{LENGTH}=0; - return undef; - } - - # just remove the boundary. - substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)=''; - return undef; - } - - my $bytesToReturn; - if ($start > 0) { # read up to the boundary - $bytesToReturn = $start > $bytes ? $bytes : $start; - } else { # read the requested number of bytes - # leave enough bytes in the buffer to allow us to read - # the boundary. Thanks to Kevin Hendrick for finding - # this one. - $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1); - } - - my $returnval=substr($self->{BUFFER},0,$bytesToReturn); - substr($self->{BUFFER},0,$bytesToReturn)=''; - - # If we hit the boundary, remove the CRLF from the end. - return ($start > 0) ? substr($returnval,0,-2) : $returnval; -} -END_OF_FUNC - - -# This fills up our internal buffer in such a way that the -# boundary is never split between reads -'fillBuffer' => <<'END_OF_FUNC', -sub fillBuffer { - my($self,$bytes) = @_; - return unless $self->{LENGTH}; - - my($boundaryLength) = length($self->{BOUNDARY}); - my($bufferLength) = length($self->{BUFFER}); - my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2; - $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead; - - # Try to read some data. We may hang here if the browser is screwed up. - my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN}, - \$self->{BUFFER}, - $bytesToRead, - $bufferLength); - $self->{BUFFER} = '' unless defined $self->{BUFFER}; - - # An apparent bug in the Apache server causes the read() - # to return zero bytes repeatedly without blocking if the - # remote user aborts during a file transfer. I don't know how - # they manage this, but the workaround is to abort if we get - # more than SPIN_LOOP_MAX consecutive zero reads. - if ($bytesRead == 0) { - die "CGI.pm: Server closed socket during multipart read (client aborted?).\n" - if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX); - } else { - $self->{ZERO_LOOP_COUNTER}=0; - } - - $self->{LENGTH} -= $bytesRead; -} -END_OF_FUNC - - -# Return true when we've finished reading -'eof' => <<'END_OF_FUNC' -sub eof { - my($self) = @_; - return 1 if (length($self->{BUFFER}) == 0) - && ($self->{LENGTH} <= 0); - undef; -} -END_OF_FUNC - -); -END_OF_AUTOLOAD - -#################################################################################### -################################## TEMPORARY FILES ################################# -#################################################################################### -package TempFile; - -$SL = $CGI::SL; -$MAC = $CGI::OS eq 'MACINTOSH'; -my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : ""; -unless ($TMPDIRECTORY) { - @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp", - "C:${SL}temp","${SL}tmp","${SL}temp", - "${vol}${SL}Temporary Items","${SL}sys\$scratch", - "${SL}WWW_ROOT"); - unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'}; - - # - # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX'; - # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this - # : can generate a 'getpwuid() not implemented' exception, even though - # : it's never called. Found under DOS/Win with the DJGPP perl port. - # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX. - unshift(@TEMP,(eval {(getpwuid($<))[7]}).'/tmp') if $CGI::OS eq 'UNIX'; - - foreach (@TEMP) { - do {$TMPDIRECTORY = $_; last} if -d $_ && -w _; - } -} - -$TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY; -$MAXTRIES = 5000; - -# cute feature, but overload implementation broke it -# %OVERLOAD = ('""'=>'as_string'); -*TempFile::AUTOLOAD = \&CGI::AUTOLOAD; - -############################################################################### -################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### -############################################################################### -$AUTOLOADED_ROUTINES = ''; # prevent -w error -$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; -%SUBS = ( - -'new' => <<'END_OF_FUNC', -sub new { - my($package,$sequence) = @_; - my $filename; - for (my $i = 0; $i < $MAXTRIES; $i++) { - last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++)); - } - # untaint the darn thing - return unless $filename =~ m!^([a-zA-Z0-9_ '":/\\]+)$!; - $filename = $1; - return bless \$filename; -} -END_OF_FUNC - -'DESTROY' => <<'END_OF_FUNC', -sub DESTROY { - my($self) = @_; - unlink $$self; # get rid of the file -} -END_OF_FUNC - -'as_string' => <<'END_OF_FUNC' -sub as_string { - my($self) = @_; - return $$self; -} -END_OF_FUNC - -); -END_OF_AUTOLOAD - -package CGI; - -# We get a whole bunch of warnings about "possibly uninitialized variables" -# when running with the -w switch. Touch them all once to get rid of the -# warnings. This is ugly and I hate it. -if ($^W) { - $CGI::CGI = ''; - $CGI::CGI=<'words', - -values=>['eenie','meenie','minie','moe'], - -defaults=>['eenie','minie']), p, - "What's your favorite color? ", - popup_menu(-name=>'color', - -values=>['red','green','blue','chartreuse']),p, - submit, - end_form, - hr; - - if (param()) { - print "Your name is",em(param('name')),p, - "The keywords are: ",em(join(", ",param('words'))),p, - "Your favorite color is ",em(param('color')), - hr; - } - -=head1 ABSTRACT - -This perl library uses perl5 objects to make it easy to create Web -fill-out forms and parse their contents. This package defines CGI -objects, entities that contain the values of the current query string -and other state variables. Using a CGI object's methods, you can -examine keywords and parameters passed to your script, and create -forms whose initial values are taken from the current query (thereby -preserving state information). The module provides shortcut functions -that produce boilerplate HTML, reducing typing and coding errors. It -also provides functionality for some of the more advanced features of -CGI scripting, including support for file uploads, cookies, cascading -style sheets, server push, and frames. - -CGI.pm also provides a simple function-oriented programming style for -those who don't need its object-oriented features. - -The current version of CGI.pm is available at - - http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html - ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ - -=head1 DESCRIPTION - -=head2 PROGRAMMING STYLE - -There are two styles of programming with CGI.pm, an object-oriented -style and a function-oriented style. In the object-oriented style you -create one or more CGI objects and then use object methods to create -the various elements of the page. Each CGI object starts out with the -list of named parameters that were passed to your CGI script by the -server. You can modify the objects, save them to a file or database -and recreate them. Because each object corresponds to the "state" of -the CGI script, and because each object's parameter list is -independent of the others, this allows you to save the state of the -script and restore it later. - -For example, using the object oriented style, here is how you create -a simple "Hello World" HTML page: - - #!/usr/local/bin/perl -w - use CGI; # load CGI routines - $q = new CGI; # create new CGI object - print $q->header, # create the HTTP header - $q->start_html('hello world'), # start the HTML - $q->h1('hello world'), # level 1 header - $q->end_html; # end the HTML - -In the function-oriented style, there is one default CGI object that -you rarely deal with directly. Instead you just call functions to -retrieve CGI parameters, create HTML tags, manage cookies, and so -on. This provides you with a cleaner programming interface, but -limits you to using one CGI object at a time. The following example -prints the same page, but uses the function-oriented interface. -The main differences are that we now need to import a set of functions -into our name space (usually the "standard" functions), and we don't -need to create the CGI object. - - #!/usr/local/bin/perl - use CGI qw/:standard/; # load standard CGI routines - print header, # create the HTTP header - start_html('hello world'), # start the HTML - h1('hello world'), # level 1 header - end_html; # end the HTML - -The examples in this document mainly use the object-oriented style. -See HOW TO IMPORT FUNCTIONS for important information on -function-oriented programming in CGI.pm - -=head2 CALLING CGI.PM ROUTINES - -Most CGI.pm routines accept several arguments, sometimes as many as 20 -optional ones! To simplify this interface, all routines use a named -argument calling style that looks like this: - - print $q->header(-type=>'image/gif',-expires=>'+3d'); - -Each argument name is preceded by a dash. Neither case nor order -matters in the argument list. -type, -Type, and -TYPE are all -acceptable. In fact, only the first argument needs to begin with a -dash. If a dash is present in the first argument, CGI.pm assumes -dashes for the subsequent ones. - -You don't have to use the hyphen at all if you don't want to. After -creating a CGI object, call the B method with -a nonzero value. This will tell CGI.pm that you intend to use named -parameters exclusively: - - $query = new CGI; - $query->use_named_parameters(1); - $field = $query->radio_group('name'=>'OS', - 'values'=>['Unix','Windows','Macintosh'], - 'default'=>'Unix'); - -Several routines are commonly called with just one argument. In the -case of these routines you can provide the single argument without an -argument name. header() happens to be one of these routines. In this -case, the single argument is the document type. - - print $q->header('text/html'); - -Other such routines are documented below. - -Sometimes named arguments expect a scalar, sometimes a reference to an -array, and sometimes a reference to a hash. Often, you can pass any -type of argument and the routine will do whatever is most appropriate. -For example, the param() routine is used to set a CGI parameter to a -single or a multi-valued value. The two cases are shown below: - - $q->param(-name=>'veggie',-value=>'tomato'); - $q->param(-name=>'veggie',-value=>'[tomato','tomahto','potato','potahto']); - -A large number of routines in CGI.pm actually aren't specifically -defined in the module, but are generated automatically as needed. -These are the "HTML shortcuts," routines that generate HTML tags for -use in dynamically-generated pages. HTML tags have both attributes -(the attribute="value" pairs within the tag itself) and contents (the -part between the opening and closing pairs.) To distinguish between -attributes and contents, CGI.pm uses the convention of passing HTML -attributes as a hash reference as the first argument, and the -contents, if any, as any subsequent arguments. It works out like -this: - - Code Generated HTML - ---- -------------- - h1()

    - h1('some','contents');

    some contents

    - h1({-align=>left});

    - h1({-align=>left},'contents');

    contents

    - -HTML tags are described in more detail later. - -Many newcomers to CGI.pm are puzzled by the difference between the -calling conventions for the HTML shortcuts, which require curly braces -around the HTML tag attributes, and the calling conventions for other -routines, which manage to generate attributes without the curly -brackets. Don't be confused. As a convenience the curly braces are -optional in all but the HTML shortcuts. If you like, you can use -curly braces when calling any routine that takes named arguments. For -example: - - print $q->header( {-type=>'image/gif',-expires=>'+3d'} ); - -If you use the B<-w> switch, you will be warned that some CGI.pm argument -names conflict with built-in Perl functions. The most frequent of -these is the -values argument, used to create multi-valued menus, -radio button clusters and the like. To get around this warning, you -have several choices: - -=over 4 - -=item 1. Use another name for the argument, if one is available. For -example, -value is an alias for -values. - -=item 2. Change the capitalization, e.g. -Values - -=item 3. Put quotes around the argument name, e.g. '-values' - -=back - -Many routines will do something useful with a named argument that it -doesn't recognize. For example, you can produce non-standard HTTP -header fields by providing them as named arguments: - - print $q->header(-type => 'text/html', - -cost => 'Three smackers', - -annoyance_level => 'high', - -complaints_to => 'bit bucket'); - -This will produce the following nonstandard HTTP header: - - HTTP/1.0 200 OK - Cost: Three smackers - Annoyance-level: high - Complaints-to: bit bucket - Content-type: text/html - -Notice the way that underscores are translated automatically into -hyphens. HTML-generating routines perform a different type of -translation. - -This feature allows you to keep up with the rapidly changing HTTP and -HTML "standards". - -=head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE): - - $query = new CGI; - -This will parse the input (from both POST and GET methods) and store -it into a perl5 object called $query. - -=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE - - $query = new CGI(INPUTFILE); - -If you provide a file handle to the new() method, it will read -parameters from the file (or STDIN, or whatever). The file can be in -any of the forms describing below under debugging (i.e. a series of -newline delimited TAG=VALUE pairs will work). Conveniently, this type -of file is created by the save() method (see below). Multiple records -can be saved and restored. - -Perl purists will be pleased to know that this syntax accepts -references to file handles, or even references to filehandle globs, -which is the "official" way to pass a filehandle: - - $query = new CGI(\*STDIN); - -You can also initialize the CGI object with a FileHandle or IO::File -object. - -If you are using the function-oriented interface and want to -initialize CGI state from a file handle, the way to do this is with -B. This will (re)initialize the -default CGI object from the indicated file handle. - - open (IN,"test.in") || die; - restore_parameters(IN); - close IN; - -You can also initialize the query object from an associative array -reference: - - $query = new CGI( {'dinosaur'=>'barney', - 'song'=>'I love you', - 'friends'=>[qw/Jessica George Nancy/]} - ); - -or from a properly formatted, URL-escaped query string: - - $query = new CGI('dinosaur=barney&color=purple'); - -or from a previously existing CGI object (currently this clones the -parameter list, but none of the other object-specific fields, such as -autoescaping): - - $old_query = new CGI; - $new_query = new CGI($old_query); - -To create an empty query, initialize it from an empty string or hash: - - $empty_query = new CGI(""); - - -or- - - $empty_query = new CGI({}); - -=head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY: - - @keywords = $query->keywords - -If the script was invoked as the result of an search, the -parsed keywords can be obtained as an array using the keywords() method. - -=head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT: - - @names = $query->param - -If the script was invoked with a parameter list -(e.g. "name1=value1&name2=value2&name3=value3"), the param() -method will return the parameter names as a list. If the -script was invoked as an script, there will be a -single parameter named 'keywords'. - -NOTE: As of version 1.5, the array of parameter names returned will -be in the same order as they were submitted by the browser. -Usually this order is the same as the order in which the -parameters are defined in the form (however, this isn't part -of the spec, and so isn't guaranteed). - -=head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER: - - @values = $query->param('foo'); - - -or- - - $value = $query->param('foo'); - -Pass the param() method a single argument to fetch the value of the -named parameter. If the parameter is multivalued (e.g. from multiple -selections in a scrolling list), you can ask to receive an array. Otherwise -the method will return a single value. - -=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER: - - $query->param('foo','an','array','of','values'); - -This sets the value for the named parameter 'foo' to an array of -values. This is one way to change the value of a field AFTER -the script has been invoked once before. (Another way is with -the -override parameter accepted by all methods that generate -form elements.) - -param() also recognizes a named parameter style of calling described -in more detail later: - - $query->param(-name=>'foo',-values=>['an','array','of','values']); - - -or- - - $query->param(-name=>'foo',-value=>'the value'); - -=head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER: - - $query->append(-name=>'foo',-values=>['yet','more','values']); - -This adds a value or list of values to the named parameter. The -values are appended to the end of the parameter if it already exists. -Otherwise the parameter is created. Note that this method only -recognizes the named argument calling syntax. - -=head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE: - - $query->import_names('R'); - -This creates a series of variables in the 'R' namespace. For example, -$R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear. -If no namespace is given, this method will assume 'Q'. -WARNING: don't import anything into 'main'; this is a major security -risk!!!! - -In older versions, this method was called B. As of version 2.20, -this name has been removed completely to avoid conflict with the built-in -Perl module B operator. - -=head2 DELETING A PARAMETER COMPLETELY: - - $query->delete('foo'); - -This completely clears a parameter. It sometimes useful for -resetting parameters that you don't want passed down between -script invocations. - -If you are using the function call interface, use "Delete()" instead -to avoid conflicts with Perl's built-in delete operator. - -=head2 DELETING ALL PARAMETERS: - - $query->delete_all(); - -This clears the CGI object completely. It might be useful to ensure -that all the defaults are taken when you create a fill-out form. - -Use Delete_all() instead if you are using the function call interface. - -=head2 DIRECT ACCESS TO THE PARAMETER LIST: - - $q->param_fetch('address')->[1] = '1313 Mockingbird Lane'; - unshift @{$q->param_fetch(-name=>'address')},'George Munster'; - -If you need access to the parameter list in a way that isn't covered -by the methods above, you can obtain a direct reference to it by -calling the B method with the name of the . This -will return an array reference to the named parameters, which you then -can manipulate in any way you like. - -You can also use a named argument style using the B<-name> argument. - -=head2 FETCHING THE PARAMETER LIST AS A HASH: - - $params = $q->Vars; - print $params->{'address'}; - @foo = split("\0",$params->{'foo'}); - %params = $q->Vars; - - use CGI ':cgi-lib'; - $params = Vars; - -Many people want to fetch the entire parameter list as a hash in which -the keys are the names of the CGI parameters, and the values are the -parameters' values. The Vars() method does this. Called in a scalar -context, it returns the parameter list as a tied hash reference. -Changing a key changes the value of the parameter in the underlying -CGI parameter list. Called in an array context, it returns the -parameter list as an ordinary hash. This allows you to read the -contents of the parameter list, but not to change it. - -When using this, the thing you must watch out for are multivalued CGI -parameters. Because a hash cannot distinguish between scalar and -array context, multivalued parameters will be returned as a packed -string, separated by the "\0" (null) character. You must split this -packed string in order to get at the individual values. This is the -convention introduced long ago by Steve Brenner in his cgi-lib.pl -module for Perl version 4. - -If you wish to use Vars() as a function, import the I<:cgi-lib> set of -function calls (also see the section on CGI-LIB compatibility). - -=head2 SAVING THE STATE OF THE SCRIPT TO A FILE: - - $query->save(FILEHANDLE) - -This will write the current state of the form to the provided -filehandle. You can read it back in by providing a filehandle -to the new() method. Note that the filehandle can be a file, a pipe, -or whatever! - -The format of the saved file is: - - NAME1=VALUE1 - NAME1=VALUE1' - NAME2=VALUE2 - NAME3=VALUE3 - = - -Both name and value are URL escaped. Multi-valued CGI parameters are -represented as repeated names. A session record is delimited by a -single = symbol. You can write out multiple records and read them -back in with several calls to B. You can do this across several -sessions by opening the file in append mode, allowing you to create -primitive guest books, or to keep a history of users' queries. Here's -a short example of creating multiple session records: - - use CGI; - - open (OUT,">>test.out") || die; - $records = 5; - foreach (0..$records) { - my $q = new CGI; - $q->param(-name=>'counter',-value=>$_); - $q->save(OUT); - } - close OUT; - - # reopen for reading - open (IN,"test.out") || die; - while (!eof(IN)) { - my $q = new CGI(IN); - print $q->param('counter'),"\n"; - } - -The file format used for save/restore is identical to that used by the -Whitehead Genome Center's data exchange format "Boulderio", and can be -manipulated and even databased using Boulderio utilities. See - - http://stein.cshl.org/boulder/ - -for further details. - -If you wish to use this method from the function-oriented (non-OO) -interface, the exported name for this method is B. - -=head2 RETRIEVING CGI ERRORS - -Errors can occur while processing user input, particularly when -processing uploaded files. When these errors occur, CGI will stop -processing and return an empty parameter list. You can test for -the existence and nature of errors using the I function. -The error messages are formatted as HTTP status codes. You can either -incorporate the error text into an HTML page, or use it as the value -of the HTTP status: - - my $error = $q->cgi_error; - if ($error) { - print $q->header(-status=>$error), - $q->start_html('Problems'), - $q->h2('Request not processed'), - $q->strong($error); - exit 0; - } - -When using the function-oriented interface (see the next section), -errors may only occur the first time you call I. Be ready -for this! - -=head2 USING THE FUNCTION-ORIENTED INTERFACE - -To use the function-oriented interface, you must specify which CGI.pm -routines or sets of routines to import into your script's namespace. -There is a small overhead associated with this importation, but it -isn't much. - - use CGI ; - -The listed methods will be imported into the current package; you can -call them directly without creating a CGI object first. This example -shows how to import the B and B -methods, and then use them directly: - - use CGI 'param','header'; - print header('text/plain'); - $zipcode = param('zipcode'); - -More frequently, you'll import common sets of functions by referring -to the groups by name. All function sets are preceded with a ":" -character as in ":html3" (for tags defined in the HTML 3 standard). - -Here is a list of the function sets you can import: - -=over 4 - -=item B<:cgi> - -Import all CGI-handling methods, such as B, B -and the like. - -=item B<:form> - -Import all fill-out form generating methods, such as B. - -=item B<:html2> - -Import all methods that generate HTML 2.0 standard elements. - -=item B<:html3> - -Import all methods that generate HTML 3.0 proposed elements (such as -, and ). - -=item B<:netscape> - -Import all methods that generate Netscape-specific HTML extensions. - -=item B<:html> - -Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' + -'netscape')... - -=item B<:standard> - -Import "standard" features, 'html2', 'html3', 'form' and 'cgi'. - -=item B<:all> - -Import all the available methods. For the full list, see the CGI.pm -code, where the variable %EXPORT_TAGS is defined. - -=back - -If you import a function name that is not part of CGI.pm, the module -will treat it as a new HTML tag and generate the appropriate -subroutine. You can then use it like any other HTML tag. This is to -provide for the rapidly-evolving HTML "standard." For example, say -Microsoft comes out with a new tag called (which causes the -user's desktop to be flooded with a rotating gradient fill until his -machine reboots). You don't need to wait for a new version of CGI.pm -to start using it immediately: - - use CGI qw/:standard :html3 gradient/; - print gradient({-start=>'red',-end=>'blue'}); - -Note that in the interests of execution speed CGI.pm does B use -the standard L syntax for specifying load symbols. This may -change in the future. - -If you import any of the state-maintaining CGI or form-generating -methods, a default CGI object will be created and initialized -automatically the first time you use any of the methods that require -one to be present. This includes B, B, -B and the like. (If you need direct access to the CGI -object, you can find it in the global variable B<$CGI::Q>). By -importing CGI.pm methods, you can create visually elegant scripts: - - use CGI qw/:standard/; - print - header, - start_html('Simple Script'), - h1('Simple Script'), - start_form, - "What's your name? ",textfield('name'),p, - "What's the combination?", - checkbox_group(-name=>'words', - -values=>['eenie','meenie','minie','moe'], - -defaults=>['eenie','moe']),p, - "What's your favorite color?", - popup_menu(-name=>'color', - -values=>['red','green','blue','chartreuse']),p, - submit, - end_form, - hr,"\n"; - - if (param) { - print - "Your name is ",em(param('name')),p, - "The keywords are: ",em(join(", ",param('words'))),p, - "Your favorite color is ",em(param('color')),".\n"; - } - print end_html; - -=head2 PRAGMAS - -In addition to the function sets, there are a number of pragmas that -you can import. Pragmas, which are always preceded by a hyphen, -change the way that CGI.pm functions in various ways. Pragmas, -function sets, and individual functions can all be imported in the -same use() line. For example, the following use statement imports the -standard set of functions and disables debugging mode (pragma --no_debug): - - use CGI qw/:standard -no_debug/; - -The current list of pragmas is as follows: - -=over 4 - -=item -any - -When you I, then any method that the query object -doesn't recognize will be interpreted as a new HTML tag. This allows -you to support the next I Netscape or Microsoft HTML -extension. This lets you go wild with new and unsupported tags: - - use CGI qw(-any); - $q=new CGI; - print $q->gradient({speed=>'fast',start=>'red',end=>'blue'}); - -Since using any causes any mistyped method name -to be interpreted as an HTML tag, use it with care or not at -all. - -=item -compile - -This causes the indicated autoloaded methods to be compiled up front, -rather than deferred to later. This is useful for scripts that run -for an extended period of time under FastCGI or mod_perl, and for -those destined to be crunched by Malcom Beattie's Perl compiler. Use -it in conjunction with the methods or method families you plan to use. - - use CGI qw(-compile :standard :html3); - -or even - - use CGI qw(-compile :all); - -Note that using the -compile pragma in this way will always have -the effect of importing the compiled functions into the current -namespace. If you want to compile without importing use the -compile() method instead (see below). - -=item -nph - -This makes CGI.pm produce a header appropriate for an NPH (no -parsed header) script. You may need to do other things as well -to tell the server that the script is NPH. See the discussion -of NPH scripts below. - -=item -newstyle_urls - -Separate the name=value pairs in CGI parameter query strings with -semicolons rather than ampersands. For example: - - ?name=fred;age=24;favorite_color=3 - -Semicolon-delimited query strings are always accepted, but will not be -emitted by self_url() and query_string() unless the -newstyle_urls -pragma is specified. - -=item -autoload - -This overrides the autoloader so that any function in your program -that is not recognized is referred to CGI.pm for possible evaluation. -This allows you to use all the CGI.pm functions without adding them to -your symbol table, which is of concern for mod_perl users who are -worried about memory consumption. I when -I<-autoload> is in effect, you cannot use "poetry mode" -(functions without the parenthesis). Use I rather -than I
    , or add something like I -to the top of your script. - -=item -no_debug - -This turns off the command-line processing features. If you want to -run a CGI.pm script from the command line to produce HTML, and you -don't want it pausing to request CGI parameters from standard input or -the command line, then use this pragma: - - use CGI qw(-no_debug :standard); - -If you'd like to process the command-line parameters but not standard -input, this should work: - - use CGI qw(-no_debug :standard); - restore_parameters(join('&',@ARGV)); - -See the section on debugging for more details. - -=item -private_tempfiles - -CGI.pm can process uploaded file. Ordinarily it spools the uploaded -file to a temporary directory, then deletes the file when done. -However, this opens the risk of eavesdropping as described in the file -upload section. Another CGI script author could peek at this data -during the upload, even if it is confidential information. On Unix -systems, the -private_tempfiles pragma will cause the temporary file -to be unlinked as soon as it is opened and before any data is written -into it, reducing, but not eliminating the risk of eavesdropping -(there is still a potential race condition). To make life harder for -the attacker, the program chooses tempfile names by calculating a 32 -bit checksum of the incoming HTTP headers. - -To ensure that the temporary file cannot be read by other CGI scripts, -use suEXEC or a CGI wrapper program to run your script. The temporary -file is created with mode 0600 (neither world nor group readable). - -The temporary directory is selected using the following algorithm: - - 1. if the current user (e.g. "nobody") has a directory named - "tmp" in its home directory, use that (Unix systems only). - - 2. if the environment variable TMPDIR exists, use the location - indicated. - - 3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp, - /tmp, /temp, ::Temporary Items, and \WWW_ROOT. - -Each of these locations is checked that it is a directory and is -writable. If not, the algorithm tries the next choice. - -=back - -=head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS - -Many of the methods generate HTML tags. As described below, tag -functions automatically generate both the opening and closing tags. -For example: - - print h1('Level 1 Header'); - -produces - -

    Level 1 Header

    - -There will be some times when you want to produce the start and end -tags yourself. In this case, you can use the form start_I -and end_I, as in: - - print start_h1,'Level 1 Header',end_h1; - -With a few exceptions (described below), start_I and -end_I functions are not generated automatically when you -I. However, you can specify the tags you want to generate -I functions for by putting an asterisk in front of their -name, or, alternatively, requesting either "start_I" or -"end_I" in the import list. - -Example: - - use CGI qw/:standard *table start_ul/; - -In this example, the following functions are generated in addition to -the standard ones: - -=over 4 - -=item 1. start_table() (generates a
    tag) - -=item 2. end_table() (generates a
    tag) - -=item 3. start_ul() (generates a
      tag) - -=item 4. end_ul() (generates a
    tag) - -=back - -=head1 GENERATING DYNAMIC DOCUMENTS - -Most of CGI.pm's functions deal with creating documents on the fly. -Generally you will produce the HTTP header first, followed by the -document itself. CGI.pm provides functions for generating HTTP -headers of various types as well as for generating HTML. For creating -GIF images, see the GD.pm module. - -Each of these functions produces a fragment of HTML or HTTP which you -can print out directly so that it displays in the browser window, -append to a string, or save to a file for later use. - -=head2 CREATING A STANDARD HTTP HEADER: - -Normally the first thing you will do in any CGI script is print out an -HTTP header. This tells the browser what type of document to expect, -and gives other optional information, such as the language, expiration -date, and whether to cache the document. The header can also be -manipulated for special purposes, such as server push and pay per view -pages. - - print $query->header; - - -or- - - print $query->header('image/gif'); - - -or- - - print $query->header('text/html','204 No response'); - - -or- - - print $query->header(-type=>'image/gif', - -nph=>1, - -status=>'402 Payment required', - -expires=>'+3d', - -cookie=>$cookie, - -Cost=>'$2.00'); - -header() returns the Content-type: header. You can provide your own -MIME type if you choose, otherwise it defaults to text/html. An -optional second parameter specifies the status code and a human-readable -message. For example, you can specify 204, "No response" to create a -script that tells the browser to do nothing at all. - -The last example shows the named argument style for passing arguments -to the CGI methods using named parameters. Recognized parameters are -B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named -parameters will be stripped of their initial hyphens and turned into -header fields, allowing you to specify any HTTP header you desire. -Internal underscores will be turned into hyphens: - - print $query->header(-Content_length=>3002); - -Most browsers will not cache the output from CGI scripts. Every time -the browser reloads the page, the script is invoked anew. You can -change this behavior with the B<-expires> parameter. When you specify -an absolute or relative expiration interval with this parameter, some -browsers and proxy servers will cache the script's output until the -indicated expiration date. The following forms are all valid for the --expires field: - - +30s 30 seconds from now - +10m ten minutes from now - +1h one hour from now - -1d yesterday (i.e. "ASAP!") - now immediately - +3M in three months - +10y in ten years time - Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date - -The B<-cookie> parameter generates a header that tells the browser to provide -a "magic cookie" during all subsequent transactions with your script. -Netscape cookies have a special format that includes interesting attributes -such as expiration time. Use the cookie() method to create and retrieve -session cookies. - -The B<-nph> parameter, if set to a true value, will issue the correct -headers to work with a NPH (no-parse-header) script. This is important -to use with certain servers, such as Microsoft Internet Explorer, which -expect all their scripts to be NPH. - -=head2 GENERATING A REDIRECTION HEADER - - print $query->redirect('http://somewhere.else/in/movie/land'); - -Sometimes you don't want to produce a document yourself, but simply -redirect the browser elsewhere, perhaps choosing a URL based on the -time of day or the identity of the user. - -The redirect() function redirects the browser to a different URL. If -you use redirection like this, you should B print out a header as -well. As of version 2.0, we produce both the unofficial Location: -header and the official URI: header. This should satisfy most servers -and browsers. - -One hint I can offer is that relative links may not work correctly -when you generate a redirection to another document on your site. -This is due to a well-intentioned optimization that some servers use. -The solution to this is to use the full URL (including the http: part) -of the document you are redirecting to. - -You can also use named arguments: - - print $query->redirect(-uri=>'http://somewhere.else/in/movie/land', - -nph=>1); - -The B<-nph> parameter, if set to a true value, will issue the correct -headers to work with a NPH (no-parse-header) script. This is important -to use with certain servers, such as Microsoft Internet Explorer, which -expect all their scripts to be NPH. - -=head2 CREATING THE HTML DOCUMENT HEADER - - print $query->start_html(-title=>'Secrets of the Pyramids', - -author=>'fred@capricorn.org', - -base=>'true', - -target=>'_blank', - -meta=>{'keywords'=>'pharaoh secret mummy', - 'copyright'=>'copyright 1996 King Tut'}, - -style=>{'src'=>'/styles/style1.css'}, - -BGCOLOR=>'blue'); - -After creating the HTTP header, most CGI scripts will start writing -out an HTML document. The start_html() routine creates the top of the -page, along with a lot of optional information that controls the -page's appearance and behavior. - -This method returns a canned HTML header and the opening tag. -All parameters are optional. In the named parameter form, recognized -parameters are -title, -author, -base, -xbase and -target (see below -for the explanation). Any additional parameters you provide, such as -the Netscape unofficial BGCOLOR attribute, are added to the -tag. Additional parameters must be proceeded by a hyphen. - -The argument B<-xbase> allows you to provide an HREF for the tag -different from the current location, as in - - -xbase=>"http://home.mcom.com/" - -All relative links will be interpreted relative to this tag. - -The argument B<-target> allows you to provide a default target frame -for all the links and fill-out forms on the page. See the Netscape -documentation on frames for details of how to manipulate this. - - -target=>"answer_window" - -All relative links will be interpreted relative to this tag. -You add arbitrary meta information to the header with the B<-meta> -argument. This argument expects a reference to an associative array -containing name/value pairs of meta information. These will be turned -into a series of header tags that look something like this: - - - - -There is no support for the HTTP-EQUIV type of tag. This is -because you can modify the HTTP header directly with the B -method. For example, if you want to send the Refresh: header, do it -in the header() method: - - print $q->header(-Refresh=>'10; URL=http://www.capricorn.com'); - -The B<-style> tag is used to incorporate cascading stylesheets into -your code. See the section on CASCADING STYLESHEETS for more information. - -You can place other arbitrary HTML elements to the section with the -B<-head> tag. For example, to place the rarely-used element in the -head section, use this: - - print start_html(-head=>Link({-rel=>'next', - -href=>'http://www.capricorn.com/s2.html'})); - -To incorporate multiple HTML elements into the section, just pass an -array reference: - - print start_html(-head=>[ - Link({-rel=>'next', - -href=>'http://www.capricorn.com/s2.html'}), - Link({-rel=>'previous', - -href=>'http://www.capricorn.com/s1.html'}) - ] - ); - -JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>, -B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used -to add Netscape JavaScript calls to your pages. B<-script> should -point to a block of text containing JavaScript function definitions. -This block will be placed within a